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-2017, 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 Max_Align
: constant SS_Ptr
:= SS_Ptr
(Standard
'Maximum_Alignment);
56 Mem_Request
: constant SS_Ptr
:=
57 ((SS_Ptr
(Storage_Size
) + Max_Align
- 1) / Max_Align
) *
59 -- Round up Storage_Size to the nearest multiple of the max alignment
60 -- value for the target. This ensures efficient stack access.
62 Stack
: constant SS_Stack_Ptr
:= SSL
.Get_Sec_Stack
.all;
64 -- Case of fixed secondary stack
66 if not SP
.Sec_Stack_Dynamic
then
67 -- Check if max stack usage is increasing
69 if Stack
.Top
+ Mem_Request
> Stack
.Max
then
71 -- If so, check if the stack is exceeded, noting Stack.Top points
72 -- to the first free byte (so the value of Stack.Top on a fully
73 -- allocated stack will be Stack.Size + 1).
75 if Stack
.Top
+ Mem_Request
> Stack
.Size
+ 1 then
79 -- Record new max usage
81 Stack
.Max
:= Stack
.Top
+ Mem_Request
;
84 -- Set resulting address and update top of stack pointer
86 Addr
:= Stack
.Internal_Chunk
.Mem
(Stack
.Top
)'Address;
87 Stack
.Top
:= Stack
.Top
+ Mem_Request
;
89 -- Case of dynamic secondary stack
95 To_Be_Released_Chunk
: Chunk_Ptr
;
98 Chunk
:= Stack
.Current_Chunk
;
100 -- The Current_Chunk may not be the best one if a lot of release
101 -- operations have taken place. Go down the stack if necessary.
103 while Chunk
.First
> Stack
.Top
loop
107 -- Find out if the available memory in the current chunk is
108 -- sufficient, if not, go to the next one and eventually create
109 -- the necessary room.
111 while Chunk
.Last
- Stack
.Top
+ 1 < Mem_Request
loop
112 if Chunk
.Next
/= null then
114 -- Release unused non-first empty chunk
116 if Chunk
.Prev
/= null and then Chunk
.First
= Stack
.Top
then
117 To_Be_Released_Chunk
:= Chunk
;
119 Chunk
.Next
:= To_Be_Released_Chunk
.Next
;
120 To_Be_Released_Chunk
.Next
.Prev
:= Chunk
;
121 Free
(To_Be_Released_Chunk
);
124 -- Create new chunk of default size unless it is not sufficient
125 -- to satisfy the current request.
127 elsif Mem_Request
<= Stack
.Size
then
130 (First
=> Chunk
.Last
+ 1,
131 Last
=> Chunk
.Last
+ SS_Ptr
(Stack
.Size
));
133 Chunk
.Next
.Prev
:= Chunk
;
135 -- Otherwise create new chunk of requested size
140 (First
=> Chunk
.Last
+ 1,
141 Last
=> Chunk
.Last
+ Mem_Request
);
143 Chunk
.Next
.Prev
:= Chunk
;
147 Stack
.Top
:= Chunk
.First
;
150 -- Resulting address is the address pointed by Stack.Top
152 Addr
:= Chunk
.Mem
(Stack
.Top
)'Address;
153 Stack
.Top
:= Stack
.Top
+ Mem_Request
;
154 Stack
.Current_Chunk
:= Chunk
;
156 -- Record new max usage
158 if Stack
.Top
> Stack
.Max
then
159 Stack
.Max
:= Stack
.Top
;
170 procedure SS_Free
(Stack
: in out SS_Stack_Ptr
) is
172 new Ada
.Unchecked_Deallocation
(SS_Stack
, SS_Stack_Ptr
);
174 -- If using dynamic secondary stack, free any external chunks
176 if SP
.Sec_Stack_Dynamic
then
181 new Ada
.Unchecked_Deallocation
(Chunk_Id
, Chunk_Ptr
);
184 Chunk
:= Stack
.Current_Chunk
;
186 -- Go to top of linked list and free backwards. Do not free the
187 -- internal chunk as it is part of SS_Stack.
189 while Chunk
.Next
/= null loop
193 while Chunk
.Prev
/= null loop
200 if Stack
.Freeable
then
209 function SS_Get_Max
return Long_Long_Integer is
210 Stack
: constant SS_Stack_Ptr
:= SSL
.Get_Sec_Stack
.all;
212 -- Stack.Max points to the first untouched byte in the stack, thus the
213 -- maximum number of bytes that have been allocated on the stack is one
214 -- less the value of Stack.Max.
216 return Long_Long_Integer (Stack
.Max
- 1);
224 Stack
: constant SS_Stack_Ptr
:= SSL
.Get_Sec_Stack
.all;
226 Put_Line
("Secondary Stack information:");
228 -- Case of fixed secondary stack
230 if not SP
.Sec_Stack_Dynamic
then
231 Put_Line
(" Total size : "
232 & SS_Ptr
'Image (Stack
.Size
)
235 Put_Line
(" Current allocated space : "
236 & SS_Ptr
'Image (Stack
.Top
- 1)
239 -- Case of dynamic secondary stack
243 Nb_Chunks
: Integer := 1;
244 Chunk
: Chunk_Ptr
:= Stack
.Current_Chunk
;
247 while Chunk
.Prev
/= null loop
251 while Chunk
.Next
/= null loop
252 Nb_Chunks
:= Nb_Chunks
+ 1;
256 -- Current Chunk information
258 -- Note that First of each chunk is one more than Last of the
259 -- previous one, so Chunk.Last is the total size of all chunks; we
260 -- don't need to walk all the chunks to compute the total size.
262 Put_Line
(" Total size : "
263 & SS_Ptr
'Image (Chunk
.Last
)
266 Put_Line
(" Current allocated space : "
267 & SS_Ptr
'Image (Stack
.Top
- 1)
270 Put_Line
(" Number of Chunks : "
271 & Integer'Image (Nb_Chunks
));
273 Put_Line
(" Default size of Chunks : "
274 & SP
.Size_Type
'Image (Stack
.Size
));
284 (Stack
: in out SS_Stack_Ptr
;
285 Size
: SP
.Size_Type
:= SP
.Unspecified_Size
)
289 Stack_Size
: Size_Type
;
291 -- If Stack is not null then the stack has been allocated outside the
292 -- package (by the compiler or the user) and all that is left to do is
293 -- initialize the stack. Otherwise, SS_Init will allocate a secondary
294 -- stack from either the heap or the default-sized secondary stack pool
295 -- generated by the binder. In the later case, this pool is generated
296 -- only when the either No_Implicit_Heap_Allocations
297 -- or No_Implicit_Task_Allocations are active, and SS_Init will allocate
298 -- all requests for a secondary stack of Unspecified_Size from this
302 if Size
= Unspecified_Size
then
303 Stack_Size
:= Default_Sec_Stack_Size
;
308 if Size
= Unspecified_Size
309 and then Binder_SS_Count
> 0
310 and then Num_Of_Assigned_Stacks
< Binder_SS_Count
312 -- The default-sized secondary stack pool is passed from the
313 -- binder to this package as an Address since it is not possible
314 -- to have a pointer to an array of unconstrained objects. A
315 -- pointer to the pool is obtainable via an unchecked conversion
316 -- to a constrained array of SS_Stacks that mirrors the one used
319 -- However, Ada understandably does not allow a local pointer to
320 -- a stack in the pool to be stored in a pointer outside of this
321 -- scope. While the conversion is safe in this case, since a view
322 -- of a global object is being used, using Unchecked_Access
323 -- would prevent users from specifying the restriction
324 -- No_Unchecked_Access whenever the secondary stack is used. As
325 -- a workaround, the local stack pointer is converted to a global
326 -- pointer via System.Address.
329 type Stk_Pool_Array
is array (1 .. Binder_SS_Count
) of
330 aliased SS_Stack
(Default_SS_Size
);
331 type Stk_Pool_Access
is access Stk_Pool_Array
;
333 function To_Stack_Pool
is new
334 Ada
.Unchecked_Conversion
(Address
, Stk_Pool_Access
);
336 pragma Warnings
(Off
);
337 function To_Global_Ptr
is new
338 Ada
.Unchecked_Conversion
(Address
, SS_Stack_Ptr
);
339 pragma Warnings
(On
);
340 -- Suppress aliasing warning since the pointer we return will
341 -- be the only access to the stack.
343 Local_Stk_Address
: System
.Address
;
346 Num_Of_Assigned_Stacks
:= Num_Of_Assigned_Stacks
+ 1;
350 (Default_Sized_SS_Pool
) (Num_Of_Assigned_Stacks
)'Address;
351 Stack
:= To_Global_Ptr
(Local_Stk_Address
);
354 Stack
.Freeable
:= False;
356 Stack
:= new SS_Stack
(Stack_Size
);
357 Stack
.Freeable
:= True;
363 Stack
.Current_Chunk
:= Stack
.Internal_Chunk
'Access;
370 function SS_Mark
return Mark_Id
is
371 Stack
: constant SS_Stack_Ptr
:= SSL
.Get_Sec_Stack
.all;
373 return (Sec_Stack
=> Stack
, Sptr
=> Stack
.Top
);
380 procedure SS_Release
(M
: Mark_Id
) is
382 M
.Sec_Stack
.Top
:= M
.Sptr
;
385 end System
.Secondary_Stack
;