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-2007, 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 2, 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. 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 GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
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. --
29 -- GNAT was originally developed by the GNAT team at New York University. --
30 -- Extensive contributions were provided by Ada Core Technologies Inc. --
32 ------------------------------------------------------------------------------
34 pragma Warnings
(Off
);
38 with System
.Soft_Links
;
39 with System
.Parameters
;
40 with Ada
.Unchecked_Conversion
;
41 with Ada
.Unchecked_Deallocation
;
43 package body System
.Secondary_Stack
is
45 package SSL
renames System
.Soft_Links
;
47 use type SSE
.Storage_Offset
;
48 use type System
.Parameters
.Size_Type
;
50 SS_Ratio_Dynamic
: constant Boolean :=
51 Parameters
.Sec_Stack_Ratio
= Parameters
.Dynamic
;
52 -- There are two entirely different implementations of the secondary
53 -- stack mechanism in this unit, and this Boolean is used to select
54 -- between them (at compile time, so the generated code will contain
55 -- only the code for the desired variant). If SS_Ratio_Dynamic is
56 -- True, then the secondary stack is dynamically allocated from the
57 -- heap in a linked list of chunks. If SS_Ration_Dynamic is False,
58 -- then the secondary stack is allocated statically by grabbing a
59 -- section of the primary stack and using it for this purpose.
61 type Memory
is array (SS_Ptr
range <>) of SSE
.Storage_Element
;
62 for Memory
'Alignment use Standard
'Maximum_Alignment;
63 -- This is the type used for actual allocation of secondary stack
64 -- areas. We require maximum alignment for all such allocations.
66 ---------------------------------------------------------------
67 -- Data Structures for Dynamically Allocated Secondary Stack --
68 ---------------------------------------------------------------
70 -- The following is a diagram of the data structures used for the
71 -- case of a dynamically allocated secondary stack, where the stack
72 -- is allocated as a linked list of chunks allocated from the heap.
74 -- +------------------+
76 -- +------------------+
84 -- +------------------+
86 -- | +----------+-------+
90 -- | +-------+----------+
92 -- | +------------------+
96 -- +-----------------+ | +-------->| U |
97 -- | Current_Chunk -|--+ | | N |
98 -- +-----------------+ | | K |
99 -- | Top -|-----+ | | First (1)
100 -- +-----------------+ +------------------+
101 -- | Default_Size | | Prev |
102 -- +-----------------+ +------------------+
105 type Chunk_Id
(First
, Last
: SS_Ptr
);
106 type Chunk_Ptr
is access all Chunk_Id
;
108 type Chunk_Id
(First
, Last
: SS_Ptr
) is record
109 Prev
, Next
: Chunk_Ptr
;
110 Mem
: Memory
(First
.. Last
);
113 type Stack_Id
is record
115 Default_Size
: SSE
.Storage_Count
;
116 Current_Chunk
: Chunk_Ptr
;
119 type Stack_Ptr
is access Stack_Id
;
120 -- Pointer to record used to represent a dynamically allocated secondary
121 -- stack descriptor for a secondary stack chunk.
123 procedure Free
is new Ada
.Unchecked_Deallocation
(Chunk_Id
, Chunk_Ptr
);
124 -- Free a dynamically allocated chunk
126 function To_Stack_Ptr
is new
127 Ada
.Unchecked_Conversion
(Address
, Stack_Ptr
);
128 function To_Addr
is new
129 Ada
.Unchecked_Conversion
(Stack_Ptr
, Address
);
130 -- Convert to and from address stored in task data structures
132 --------------------------------------------------------------
133 -- Data Structures for Statically Allocated Secondary Stack --
134 --------------------------------------------------------------
136 -- For the static case, the secondary stack is a single contiguous
137 -- chunk of storage, carved out of the primary stack, and represented
138 -- by the following data strcuture
140 type Fixed_Stack_Id
is record
142 -- Index of next available location in Mem. This is initialized to
143 -- 0, and then incremented on Allocate, and Decremented on Release.
146 -- Length of usable Mem array, which is thus the index past the
147 -- last available location in Mem. Mem (Last-1) can be used. This
148 -- is used to check that the stack does not overflow.
151 -- Maximum value of Top. Initialized to 0, and then may be incremented
152 -- on Allocate, but is never Decremented. The last used location will
153 -- be Mem (Max - 1), so Max is the maximum count of used stack space.
155 Mem
: Memory
(0 .. 0);
156 -- This is the area that is actually used for the secondary stack.
157 -- Note that the upper bound is a dummy value properly defined by
158 -- the value of Last. We never actually allocate objects of type
159 -- Fixed_Stack_Id, so the bounds declared here do not matter.
162 Dummy_Fixed_Stack
: Fixed_Stack_Id
;
163 pragma Warnings
(Off
, Dummy_Fixed_Stack
);
164 -- Well it is not quite true that we never allocate an object of the
165 -- type. This dummy object is allocated for the purpose of getting the
166 -- offset of the Mem field via the 'Position attribute (such a nuisance
167 -- that we cannot apply this to a field of a type!)
169 type Fixed_Stack_Ptr
is access Fixed_Stack_Id
;
170 -- Pointer to record used to describe statically allocated sec stack
172 function To_Fixed_Stack_Ptr
is new
173 Ada
.Unchecked_Conversion
(Address
, Fixed_Stack_Ptr
);
174 -- Convert from address stored in task data structures
180 procedure SS_Allocate
182 Storage_Size
: SSE
.Storage_Count
)
184 Max_Align
: constant SS_Ptr
:= SS_Ptr
(Standard
'Maximum_Alignment);
185 Max_Size
: constant SS_Ptr
:=
186 ((SS_Ptr
(Storage_Size
) + Max_Align
- 1) / Max_Align
)
190 -- Case of fixed allocation secondary stack
192 if not SS_Ratio_Dynamic
then
194 Fixed_Stack
: constant Fixed_Stack_Ptr
:=
195 To_Fixed_Stack_Ptr
(SSL
.Get_Sec_Stack_Addr
.all);
198 -- Check if max stack usage is increasing
200 if Fixed_Stack
.Top
+ Max_Size
> Fixed_Stack
.Max
then
202 -- If so, check if max size is exceeded
204 if Fixed_Stack
.Top
+ Max_Size
> Fixed_Stack
.Last
then
208 -- Record new max usage
210 Fixed_Stack
.Max
:= Fixed_Stack
.Top
+ Max_Size
;
213 -- Set resulting address and update top of stack pointer
215 Addr
:= Fixed_Stack
.Mem
(Fixed_Stack
.Top
)'Address;
216 Fixed_Stack
.Top
:= Fixed_Stack
.Top
+ Max_Size
;
219 -- Case of dynamically allocated secondary stack
223 Stack
: constant Stack_Ptr
:=
224 To_Stack_Ptr
(SSL
.Get_Sec_Stack_Addr
.all);
227 To_Be_Released_Chunk
: Chunk_Ptr
;
230 Chunk
:= Stack
.Current_Chunk
;
232 -- The Current_Chunk may not be the good one if a lot of release
233 -- operations have taken place. So go down the stack if necessary
235 while Chunk
.First
> Stack
.Top
loop
239 -- Find out if the available memory in the current chunk is
240 -- sufficient, if not, go to the next one and eventally create
241 -- the necessary room.
243 while Chunk
.Last
- Stack
.Top
+ 1 < Max_Size
loop
244 if Chunk
.Next
/= null then
246 -- Release unused non-first empty chunk
248 if Chunk
.Prev
/= null and then Chunk
.First
= Stack
.Top
then
249 To_Be_Released_Chunk
:= Chunk
;
251 Chunk
.Next
:= To_Be_Released_Chunk
.Next
;
252 To_Be_Released_Chunk
.Next
.Prev
:= Chunk
;
253 Free
(To_Be_Released_Chunk
);
256 -- Create new chunk of default size unless it is not
257 -- sufficient to satisfy the current request.
259 elsif SSE
.Storage_Count
(Max_Size
) <= Stack
.Default_Size
then
262 (First
=> Chunk
.Last
+ 1,
263 Last
=> Chunk
.Last
+ SS_Ptr
(Stack
.Default_Size
));
265 Chunk
.Next
.Prev
:= Chunk
;
267 -- Otherwise create new chunk of requested size
272 (First
=> Chunk
.Last
+ 1,
273 Last
=> Chunk
.Last
+ Max_Size
);
275 Chunk
.Next
.Prev
:= Chunk
;
279 Stack
.Top
:= Chunk
.First
;
282 -- Resulting address is the address pointed by Stack.Top
284 Addr
:= Chunk
.Mem
(Stack
.Top
)'Address;
285 Stack
.Top
:= Stack
.Top
+ Max_Size
;
286 Stack
.Current_Chunk
:= Chunk
;
295 procedure SS_Free
(Stk
: in out Address
) is
297 -- Case of statically allocated secondary stack, nothing to free
299 if not SS_Ratio_Dynamic
then
302 -- Case of dynamically allocated secondary stack
306 Stack
: Stack_Ptr
:= To_Stack_Ptr
(Stk
);
310 new Ada
.Unchecked_Deallocation
(Stack_Id
, Stack_Ptr
);
313 Chunk
:= Stack
.Current_Chunk
;
315 while Chunk
.Prev
/= null loop
319 while Chunk
.Next
/= null loop
335 function SS_Get_Max
return Long_Long_Integer is
337 if SS_Ratio_Dynamic
then
341 Fixed_Stack
: constant Fixed_Stack_Ptr
:=
342 To_Fixed_Stack_Ptr
(SSL
.Get_Sec_Stack_Addr
.all);
344 return Long_Long_Integer (Fixed_Stack
.Max
);
355 Put_Line
("Secondary Stack information:");
357 -- Case of fixed secondary stack
359 if not SS_Ratio_Dynamic
then
361 Fixed_Stack
: constant Fixed_Stack_Ptr
:=
362 To_Fixed_Stack_Ptr
(SSL
.Get_Sec_Stack_Addr
.all);
367 & SS_Ptr
'Image (Fixed_Stack
.Last
)
371 " Current allocated space : "
372 & SS_Ptr
'Image (Fixed_Stack
.Top
- 1)
376 -- Case of dynamically allocated secondary stack
380 Stack
: constant Stack_Ptr
:=
381 To_Stack_Ptr
(SSL
.Get_Sec_Stack_Addr
.all);
382 Nb_Chunks
: Integer := 1;
383 Chunk
: Chunk_Ptr
:= Stack
.Current_Chunk
;
386 while Chunk
.Prev
/= null loop
390 while Chunk
.Next
/= null loop
391 Nb_Chunks
:= Nb_Chunks
+ 1;
395 -- Current Chunk information
399 & SS_Ptr
'Image (Chunk
.Last
)
403 " Current allocated space : "
404 & SS_Ptr
'Image (Stack
.Top
- 1)
408 " Number of Chunks : "
409 & Integer'Image (Nb_Chunks
));
412 " Default size of Chunks : "
413 & SSE
.Storage_Count
'Image (Stack
.Default_Size
));
423 (Stk
: in out Address
;
424 Size
: Natural := Default_Secondary_Stack_Size
)
427 -- Case of fixed size secondary stack
429 if not SS_Ratio_Dynamic
then
431 Fixed_Stack
: constant Fixed_Stack_Ptr
:=
432 To_Fixed_Stack_Ptr
(Stk
);
435 Fixed_Stack
.Top
:= 0;
436 Fixed_Stack
.Max
:= 0;
438 if Size
< Dummy_Fixed_Stack
.Mem
'Position then
439 Fixed_Stack
.Last
:= 0;
442 SS_Ptr
(Size
) - Dummy_Fixed_Stack
.Mem
'Position;
446 -- Case of dynamically allocated secondary stack
452 Stack
:= new Stack_Id
;
453 Stack
.Current_Chunk
:= new Chunk_Id
(1, SS_Ptr
(Size
));
455 Stack
.Default_Size
:= SSE
.Storage_Count
(Size
);
456 Stk
:= To_Addr
(Stack
);
465 function SS_Mark
return Mark_Id
is
466 Sstk
: constant System
.Address
:= SSL
.Get_Sec_Stack_Addr
.all;
468 if SS_Ratio_Dynamic
then
469 return (Sstk
=> Sstk
, Sptr
=> To_Stack_Ptr
(Sstk
).Top
);
471 return (Sstk
=> Sstk
, Sptr
=> To_Fixed_Stack_Ptr
(Sstk
).Top
);
479 procedure SS_Release
(M
: Mark_Id
) is
481 if SS_Ratio_Dynamic
then
482 To_Stack_Ptr
(M
.Sstk
).Top
:= M
.Sptr
;
484 To_Fixed_Stack_Ptr
(M
.Sstk
).Top
:= M
.Sptr
;
488 -------------------------
489 -- Package Elaboration --
490 -------------------------
492 -- Allocate a secondary stack for the main program to use
494 -- We make sure that the stack has maximum alignment. Some systems require
495 -- this (e.g. Sparc), and in any case it is a good idea for efficiency.
497 Stack
: aliased Stack_Id
;
498 for Stack
'Alignment use Standard
'Maximum_Alignment;
500 Static_Secondary_Stack_Size
: constant := 10 * 1024;
501 -- Static_Secondary_Stack_Size must be static so that Chunk is allocated
502 -- statically, and not via dynamic memory allocation.
504 Chunk
: aliased Chunk_Id
(1, Static_Secondary_Stack_Size
);
505 for Chunk
'Alignment use Standard
'Maximum_Alignment;
506 -- Default chunk used, unless gnatbind -D is specified with a value
507 -- greater than Static_Secondary_Stack_Size
511 Chunk_Address
: Address
;
512 Chunk_Access
: Chunk_Ptr
;
515 if Default_Secondary_Stack_Size
<= Static_Secondary_Stack_Size
then
517 -- Normally we allocate the secondary stack for the main program
518 -- statically, using the default secondary stack size.
520 Chunk_Access
:= Chunk
'Access;
523 -- Default_Secondary_Stack_Size was increased via gnatbind -D, so we
524 -- need to allocate a chunk dynamically.
527 new Chunk_Id
(1, SS_Ptr
(Default_Secondary_Stack_Size
));
530 if SS_Ratio_Dynamic
then
532 Stack
.Current_Chunk
:= Chunk_Access
;
533 Stack
.Default_Size
:=
534 SSE
.Storage_Offset
(Default_Secondary_Stack_Size
);
535 System
.Soft_Links
.Set_Sec_Stack_Addr_NT
(Stack
'Address);
538 Chunk_Address
:= Chunk_Access
.all'Address;
539 SS_Init
(Chunk_Address
, Default_Secondary_Stack_Size
);
540 System
.Soft_Links
.Set_Sec_Stack_Addr_NT
(Chunk_Address
);
543 end System
.Secondary_Stack
;