1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME COMPONENTS --
5 -- S Y S T E M . P O O L _ S I Z E --
11 -- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
13 -- GNAT is free software; you can redistribute it and/or modify it under --
14 -- terms of the GNU General Public License as published by the Free Soft- --
15 -- ware Foundation; either version 2, or (at your option) any later ver- --
16 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
17 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
18 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
19 -- for more details. You should have received a copy of the GNU General --
20 -- Public License distributed with GNAT; see file COPYING. If not, write --
21 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
22 -- MA 02111-1307, USA. --
24 -- As a special exception, if other files instantiate generics from this --
25 -- unit, or you link this unit with other files to produce an executable, --
26 -- this unit does not by itself cause the resulting executable to be --
27 -- covered by the GNU General Public License. This exception does not --
28 -- however invalidate any other reasons why the executable file might be --
29 -- covered by the GNU Public License. --
31 -- GNAT was originally developed by the GNAT team at New York University. --
32 -- Extensive contributions were provided by Ada Core Technologies Inc. --
34 ------------------------------------------------------------------------------
36 with System
.Storage_Elements
;
37 with System
.Address_To_Access_Conversions
;
39 package body System
.Pool_Size
is
41 package SSE
renames System
.Storage_Elements
;
42 use type SSE
.Storage_Offset
;
44 package SC
is new Address_To_Access_Conversions
(SSE
.Storage_Count
);
47 := SSE
.Storage_Count
'Object_Size / System
.Storage_Unit
;
49 package Variable_Size_Management
is
51 -- Embedded pool that manages allocation of variable-size data.
53 -- This pool is used as soon as the Elmt_sizS of the pool object is 0.
55 -- Allocation is done on the first chunk long enough for the request.
56 -- Deallocation just puts the freed chunk at the beginning of the list.
58 procedure Initialize
(Pool
: in out Stack_Bounded_Pool
);
60 (Pool
: in out Stack_Bounded_Pool
;
61 Address
: out System
.Address
;
62 Storage_Size
: SSE
.Storage_Count
;
63 Alignment
: SSE
.Storage_Count
);
66 (Pool
: in out Stack_Bounded_Pool
;
67 Address
: System
.Address
;
68 Storage_Size
: SSE
.Storage_Count
;
69 Alignment
: SSE
.Storage_Count
);
70 end Variable_Size_Management
;
72 package Vsize
renames Variable_Size_Management
;
79 (Pool
: in out Stack_Bounded_Pool
;
80 Address
: out System
.Address
;
81 Storage_Size
: SSE
.Storage_Count
;
82 Alignment
: SSE
.Storage_Count
)
85 if Pool
.Elmt_Size
= 0 then
86 Vsize
.Allocate
(Pool
, Address
, Storage_Size
, Alignment
);
88 elsif Pool
.First_Free
/= 0 then
89 Address
:= Pool
.The_Pool
(Pool
.First_Free
)'Address;
90 Pool
.First_Free
:= SC
.To_Pointer
(Address
).all;
93 Pool
.First_Empty
<= (Pool
.Pool_Size
- Pool
.Aligned_Elmt_Size
+ 1)
95 Address
:= Pool
.The_Pool
(Pool
.First_Empty
)'Address;
96 Pool
.First_Empty
:= Pool
.First_Empty
+ Pool
.Aligned_Elmt_Size
;
108 (Pool
: in out Stack_Bounded_Pool
;
109 Address
: System
.Address
;
110 Storage_Size
: SSE
.Storage_Count
;
111 Alignment
: SSE
.Storage_Count
)
114 if Pool
.Elmt_Size
= 0 then
115 Vsize
.Deallocate
(Pool
, Address
, Storage_Size
, Alignment
);
118 SC
.To_Pointer
(Address
).all := Pool
.First_Free
;
119 Pool
.First_Free
:= Address
- Pool
.The_Pool
'Address + 1;
127 procedure Initialize
(Pool
: in out Stack_Bounded_Pool
) is
128 Align
: constant SSE
.Storage_Count
:=
129 SSE
.Storage_Count
'Max (SSE
.Storage_Count
'Alignment, Pool
.Alignment
);
132 if Pool
.Elmt_Size
= 0 then
133 Vsize
.Initialize
(Pool
);
136 Pool
.First_Free
:= 0;
137 Pool
.First_Empty
:= 1;
139 -- Compute the size to allocate given the size of the element and
140 -- the possible Alignment clause
142 Pool
.Aligned_Elmt_Size
:=
143 SSE
.Storage_Count
'Max (SC_Size
,
144 ((Pool
.Elmt_Size
+ Align
- 1) / Align
) * Align
);
152 function Storage_Size
153 (Pool
: Stack_Bounded_Pool
)
154 return SSE
.Storage_Count
157 return Pool
.Pool_Size
;
160 ------------------------------
161 -- Variable_Size_Management --
162 ------------------------------
164 package body Variable_Size_Management
is
166 Minimum_Size
: constant := 2 * SC_Size
;
169 (Pool
: Stack_Bounded_Pool
;
170 Chunk
, Size
: SSE
.Storage_Count
);
171 -- Update the field 'size' of a chunk of available storage
174 (Pool
: Stack_Bounded_Pool
;
175 Chunk
, Next
: SSE
.Storage_Count
);
176 -- Update the field 'next' of a chunk of available storage
179 (Pool
: Stack_Bounded_Pool
;
180 Chunk
: SSE
.Storage_Count
)
181 return SSE
.Storage_Count
;
182 -- Fetch the field 'size' of a chunk of available storage
185 (Pool
: Stack_Bounded_Pool
;
186 Chunk
: SSE
.Storage_Count
)
187 return SSE
.Storage_Count
;
188 -- Fetch the field 'next' of a chunk of available storage
191 (Pool
: Stack_Bounded_Pool
;
192 Addr
: System
.Address
)
193 return SSE
.Storage_Count
;
194 -- Give the chunk number in the pool from its Address
201 (Pool
: in out Stack_Bounded_Pool
;
202 Address
: out System
.Address
;
203 Storage_Size
: SSE
.Storage_Count
;
204 Alignment
: SSE
.Storage_Count
)
206 Chunk
: SSE
.Storage_Count
;
207 New_Chunk
: SSE
.Storage_Count
;
208 Prev_Chunk
: SSE
.Storage_Count
;
209 Our_Align
: constant SSE
.Storage_Count
:=
210 SSE
.Storage_Count
'Max (SSE
.Storage_Count
'Alignment,
212 Align_Size
: constant SSE
.Storage_Count
:=
213 SSE
.Storage_Count
'Max (
215 ((Storage_Size
+ Our_Align
- 1) / Our_Align
) *
219 -- Look for the first big enough chunk
221 Prev_Chunk
:= Pool
.First_Free
;
222 Chunk
:= Next
(Pool
, Prev_Chunk
);
224 while Chunk
/= 0 and then Size
(Pool
, Chunk
) < Align_Size
loop
226 Chunk
:= Next
(Pool
, Chunk
);
229 -- Raise storage_error if no big enough chunk available
235 -- When the chunk is bigger than what is needed, take appropraite
236 -- amount and build a new shrinked chunk with the remainder.
238 if Size
(Pool
, Chunk
) - Align_Size
> Minimum_Size
then
239 New_Chunk
:= Chunk
+ Align_Size
;
240 Set_Size
(Pool
, New_Chunk
, Size
(Pool
, Chunk
) - Align_Size
);
241 Set_Next
(Pool
, New_Chunk
, Next
(Pool
, Chunk
));
242 Set_Next
(Pool
, Prev_Chunk
, New_Chunk
);
244 -- If the chunk is the right size, just delete it from the chain
247 Set_Next
(Pool
, Prev_Chunk
, Next
(Pool
, Chunk
));
250 Address
:= Pool
.The_Pool
(Chunk
)'Address;
258 (Pool
: Stack_Bounded_Pool
;
259 Addr
: System
.Address
)
260 return SSE
.Storage_Count
263 return 1 + abs (Addr
- Pool
.The_Pool
(1)'Address);
271 (Pool
: in out Stack_Bounded_Pool
;
272 Address
: System
.Address
;
273 Storage_Size
: SSE
.Storage_Count
;
274 Alignment
: SSE
.Storage_Count
)
276 Align_Size
: constant SSE
.Storage_Count
:=
277 ((Storage_Size
+ Alignment
- 1) / Alignment
) *
279 Chunk
: SSE
.Storage_Count
:= Chunk_Of
(Pool
, Address
);
282 -- Attach the freed chunk to the chain
284 Set_Size
(Pool
, Chunk
,
285 SSE
.Storage_Count
'Max (Align_Size
, Minimum_Size
));
286 Set_Next
(Pool
, Chunk
, Next
(Pool
, Pool
.First_Free
));
287 Set_Next
(Pool
, Pool
.First_Free
, Chunk
);
295 procedure Initialize
(Pool
: in out Stack_Bounded_Pool
) is
297 Pool
.First_Free
:= 1;
299 if Pool
.Pool_Size
> Minimum_Size
then
300 Set_Next
(Pool
, Pool
.First_Free
, Pool
.First_Free
+ Minimum_Size
);
301 Set_Size
(Pool
, Pool
.First_Free
, 0);
302 Set_Size
(Pool
, Pool
.First_Free
+ Minimum_Size
,
303 Pool
.Pool_Size
- Minimum_Size
);
304 Set_Next
(Pool
, Pool
.First_Free
+ Minimum_Size
, 0);
313 (Pool
: Stack_Bounded_Pool
;
314 Chunk
: SSE
.Storage_Count
)
315 return SSE
.Storage_Count
318 return SC
.To_Pointer
(Pool
.The_Pool
(Chunk
+ SC_Size
)'Address).all;
326 (Pool
: Stack_Bounded_Pool
;
327 Chunk
, Next
: SSE
.Storage_Count
)
330 SC
.To_Pointer
(Pool
.The_Pool
(Chunk
+ SC_Size
)'Address).all := Next
;
338 (Pool
: Stack_Bounded_Pool
;
339 Chunk
, Size
: SSE
.Storage_Count
)
342 SC
.To_Pointer
(Pool
.The_Pool
(Chunk
)'Address).all := Size
;
350 (Pool
: Stack_Bounded_Pool
;
351 Chunk
: SSE
.Storage_Count
)
352 return SSE
.Storage_Count
355 return SC
.To_Pointer
(Pool
.The_Pool
(Chunk
)'Address).all;
358 end Variable_Size_Management
;
359 end System
.Pool_Size
;