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 --
10 -- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
12 -- GNAT is free software; you can redistribute it and/or modify it under --
13 -- terms of the GNU General Public License as published by the Free Soft- --
14 -- ware Foundation; either version 2, or (at your option) any later ver- --
15 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
16 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
17 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
18 -- for more details. You should have received a copy of the GNU General --
19 -- Public License distributed with GNAT; see file COPYING. If not, write --
20 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
21 -- MA 02111-1307, USA. --
23 -- As a special exception, if other files instantiate generics from this --
24 -- unit, or you link this unit with other files to produce an executable, --
25 -- this unit does not by itself cause the resulting executable to be --
26 -- covered by the GNU General Public License. This exception does not --
27 -- however invalidate any other reasons why the executable file might be --
28 -- covered by the GNU Public License. --
30 -- GNAT was originally developed by the GNAT team at New York University. --
31 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
33 ------------------------------------------------------------------------------
35 with System
.Soft_Links
;
36 with System
.Parameters
;
37 with Unchecked_Conversion
;
38 with Unchecked_Deallocation
;
40 package body System
.Secondary_Stack
is
42 package SSL
renames System
.Soft_Links
;
44 use type SSE
.Storage_Offset
;
45 use type System
.Parameters
.Size_Type
;
47 SS_Ratio_Dynamic
: constant Boolean :=
48 Parameters
.Sec_Stack_Ratio
= Parameters
.Dynamic
;
50 -- +------------------+
52 -- +------------------+
60 -- +------------------+
62 -- | +----------+-------+
66 -- | +-------+----------+
68 -- | +------------------+
72 -- +-----------------+ | +-------->| U |
73 -- | Current_Chunk -|--+ | | N |
74 -- +-----------------+ | | K |
75 -- | Top -|-----+ | | First (1)
76 -- +-----------------+ +------------------+
77 -- | Default_Size | | Prev |
78 -- +-----------------+ +------------------+
81 type Memory
is array (Mark_Id
range <>) of SSE
.Storage_Element
;
83 type Chunk_Id
(First
, Last
: Mark_Id
);
84 type Chunk_Ptr
is access all Chunk_Id
;
86 type Chunk_Id
(First
, Last
: Mark_Id
) is record
87 Prev
, Next
: Chunk_Ptr
;
88 Mem
: Memory
(First
.. Last
);
91 type Stack_Id
is record
93 Default_Size
: SSE
.Storage_Count
;
94 Current_Chunk
: Chunk_Ptr
;
97 type Fixed_Stack_Id
is record
100 Mem
: Memory
(1 .. Mark_Id
'Last / 2 - 1);
101 -- This should really be 1 .. Mark_Id'Last, but there is a bug in gigi
102 -- with this type, introduced Sep 2001, that causes gigi to reject this
103 -- type because its size in bytes overflows ???
106 type Stack_Ptr
is access Stack_Id
;
107 type Fixed_Stack_Ptr
is access Fixed_Stack_Id
;
109 function From_Addr
is new Unchecked_Conversion
(Address
, Stack_Ptr
);
110 function To_Addr
is new Unchecked_Conversion
(Stack_Ptr
, System
.Address
);
111 function To_Fixed
is new Unchecked_Conversion
(Stack_Ptr
, Fixed_Stack_Ptr
);
113 procedure Free
is new Unchecked_Deallocation
(Chunk_Id
, Chunk_Ptr
);
119 procedure SS_Allocate
120 (Address
: out System
.Address
;
121 Storage_Size
: SSE
.Storage_Count
)
123 Stack
: constant Stack_Ptr
:=
124 From_Addr
(SSL
.Get_Sec_Stack_Addr
.all);
125 Fixed_Stack
: Fixed_Stack_Ptr
;
127 Max_Align
: constant Mark_Id
:= Mark_Id
(Standard
'Maximum_Alignment);
128 Max_Size
: constant Mark_Id
:=
129 ((Mark_Id
(Storage_Size
) + Max_Align
- 1) / Max_Align
)
132 Count_Unreleased_Chunks
: Natural;
133 To_Be_Released_Chunk
: Chunk_Ptr
;
136 -- If the secondary stack is fixed in the primary stack, then the
137 -- handling becomes simple
139 if not SS_Ratio_Dynamic
then
140 Fixed_Stack
:= To_Fixed
(Stack
);
142 if Fixed_Stack
.Top
+ Max_Size
> Fixed_Stack
.Last
then
146 Address
:= Fixed_Stack
.Mem
(Fixed_Stack
.Top
)'Address;
147 Fixed_Stack
.Top
:= Fixed_Stack
.Top
+ Mark_Id
(Max_Size
);
151 Chunk
:= Stack
.Current_Chunk
;
153 -- The Current_Chunk may not be the good one if a lot of release
154 -- operations have taken place. So go down the stack if necessary
156 while Chunk
.First
> Stack
.Top
loop
160 -- Find out if the available memory in the current chunk is sufficient.
161 -- if not, go to the next one and eventally create the necessary room
163 Count_Unreleased_Chunks
:= 0;
165 while Chunk
.Last
- Stack
.Top
+ 1 < Max_Size
loop
166 if Chunk
.Next
/= null then
168 -- Release unused non-first empty chunk
170 if Chunk
.Prev
/= null and then Chunk
.First
= Stack
.Top
then
171 To_Be_Released_Chunk
:= Chunk
;
173 Chunk
.Next
:= To_Be_Released_Chunk
.Next
;
174 To_Be_Released_Chunk
.Next
.Prev
:= Chunk
;
175 Free
(To_Be_Released_Chunk
);
178 -- Create new chunk of the default size unless it is not sufficient
180 elsif SSE
.Storage_Count
(Max_Size
) <= Stack
.Default_Size
then
181 Chunk
.Next
:= new Chunk_Id
(
182 First
=> Chunk
.Last
+ 1,
183 Last
=> Chunk
.Last
+ Mark_Id
(Stack
.Default_Size
));
185 Chunk
.Next
.Prev
:= Chunk
;
188 Chunk
.Next
:= new Chunk_Id
(
189 First
=> Chunk
.Last
+ 1,
190 Last
=> Chunk
.Last
+ Max_Size
);
192 Chunk
.Next
.Prev
:= Chunk
;
196 Stack
.Top
:= Chunk
.First
;
199 -- Resulting address is the address pointed by Stack.Top
201 Address
:= Chunk
.Mem
(Stack
.Top
)'Address;
202 Stack
.Top
:= Stack
.Top
+ Max_Size
;
203 Stack
.Current_Chunk
:= Chunk
;
210 procedure SS_Free
(Stk
: in out System
.Address
) is
214 procedure Free
is new Unchecked_Deallocation
(Stack_Id
, Stack_Ptr
);
217 if not SS_Ratio_Dynamic
then
221 Stack
:= From_Addr
(Stk
);
222 Chunk
:= Stack
.Current_Chunk
;
224 while Chunk
.Prev
/= null loop
228 while Chunk
.Next
/= null loop
243 Stack
: constant Stack_Ptr
:=
244 From_Addr
(SSL
.Get_Sec_Stack_Addr
.all);
245 Fixed_Stack
: Fixed_Stack_Ptr
;
246 Nb_Chunks
: Integer := 1;
247 Chunk
: Chunk_Ptr
:= Stack
.Current_Chunk
;
250 Put_Line
("Secondary Stack information:");
252 if not SS_Ratio_Dynamic
then
253 Fixed_Stack
:= To_Fixed
(Stack
);
256 & Mark_Id
'Image (Fixed_Stack
.Last
)
259 " Current allocated space : "
260 & Mark_Id
'Image (Fixed_Stack
.Top
- 1)
265 while Chunk
.Prev
/= null loop
269 while Chunk
.Next
/= null loop
270 Nb_Chunks
:= Nb_Chunks
+ 1;
274 -- Current Chunk information
278 & Mark_Id
'Image (Chunk
.Last
)
281 " Current allocated space : "
282 & Mark_Id
'Image (Stack
.Top
- 1)
286 " Number of Chunks : "
287 & Integer'Image (Nb_Chunks
));
290 " Default size of Chunks : "
291 & SSE
.Storage_Count
'Image (Stack
.Default_Size
));
299 (Stk
: in out System
.Address
;
300 Size
: Natural := Default_Secondary_Stack_Size
)
303 Fixed_Stack
: Fixed_Stack_Ptr
;
306 if not SS_Ratio_Dynamic
then
307 Fixed_Stack
:= To_Fixed
(From_Addr
(Stk
));
308 Fixed_Stack
.Top
:= Fixed_Stack
.Mem
'First;
310 if Size
< 2 * Mark_Id
'Max_Size_In_Storage_Elements then
311 Fixed_Stack
.Last
:= 0;
313 Fixed_Stack
.Last
:= Mark_Id
(Size
) -
314 2 * Mark_Id
'Max_Size_In_Storage_Elements;
320 Stack
:= new Stack_Id
;
321 Stack
.Current_Chunk
:= new Chunk_Id
(1, Mark_Id
(Size
));
323 Stack
.Default_Size
:= SSE
.Storage_Count
(Size
);
325 Stk
:= To_Addr
(Stack
);
332 function SS_Mark
return Mark_Id
is
334 return From_Addr
(SSL
.Get_Sec_Stack_Addr
.all).Top
;
341 procedure SS_Release
(M
: Mark_Id
) is
343 From_Addr
(SSL
.Get_Sec_Stack_Addr
.all).Top
:= M
;
346 -------------------------
347 -- Package Elaboration --
348 -------------------------
350 -- Allocate a secondary stack for the main program to use.
351 -- We make sure that the stack has maximum alignment. Some systems require
352 -- this (e.g. Sun), and in any case it is a good idea for efficiency.
354 Stack
: aliased Stack_Id
;
355 for Stack
'Alignment use Standard
'Maximum_Alignment;
357 Chunk
: aliased Chunk_Id
(1, Default_Secondary_Stack_Size
);
358 for Chunk
'Alignment use Standard
'Maximum_Alignment;
360 Chunk_Address
: System
.Address
;
363 if SS_Ratio_Dynamic
then
365 Stack
.Current_Chunk
:= Chunk
'Access;
366 Stack
.Default_Size
:= Default_Secondary_Stack_Size
;
367 System
.Soft_Links
.Set_Sec_Stack_Addr_NT
(Stack
'Address);
370 Chunk_Address
:= Chunk
'Address;
371 SS_Init
(Chunk_Address
, Default_Secondary_Stack_Size
);
372 System
.Soft_Links
.Set_Sec_Stack_Addr_NT
(Chunk_Address
);
374 end System
.Secondary_Stack
;