1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME COMPONENTS --
5 -- S Y S T E M . P O O L _ S I Z E --
9 -- Copyright (C) 1992-2001 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, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, 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 with System
.Storage_Elements
;
35 with System
.Address_To_Access_Conversions
;
37 package body System
.Pool_Size
is
39 package SSE
renames System
.Storage_Elements
;
40 use type SSE
.Storage_Offset
;
42 package SC
is new Address_To_Access_Conversions
(SSE
.Storage_Count
);
45 := SSE
.Storage_Count
'Object_Size / System
.Storage_Unit
;
47 package Variable_Size_Management
is
49 -- Embedded pool that manages allocation of variable-size data.
51 -- This pool is used as soon as the Elmt_sizS of the pool object is 0.
53 -- Allocation is done on the first chunk long enough for the request.
54 -- Deallocation just puts the freed chunk at the beginning of the list.
56 procedure Initialize
(Pool
: in out Stack_Bounded_Pool
);
58 (Pool
: in out Stack_Bounded_Pool
;
59 Address
: out System
.Address
;
60 Storage_Size
: SSE
.Storage_Count
;
61 Alignment
: SSE
.Storage_Count
);
64 (Pool
: in out Stack_Bounded_Pool
;
65 Address
: System
.Address
;
66 Storage_Size
: SSE
.Storage_Count
;
67 Alignment
: SSE
.Storage_Count
);
68 end Variable_Size_Management
;
70 package Vsize
renames Variable_Size_Management
;
77 (Pool
: in out Stack_Bounded_Pool
;
78 Address
: out System
.Address
;
79 Storage_Size
: SSE
.Storage_Count
;
80 Alignment
: SSE
.Storage_Count
)
83 if Pool
.Elmt_Size
= 0 then
84 Vsize
.Allocate
(Pool
, Address
, Storage_Size
, Alignment
);
86 elsif Pool
.First_Free
/= 0 then
87 Address
:= Pool
.The_Pool
(Pool
.First_Free
)'Address;
88 Pool
.First_Free
:= SC
.To_Pointer
(Address
).all;
91 Pool
.First_Empty
<= (Pool
.Pool_Size
- Pool
.Aligned_Elmt_Size
+ 1)
93 Address
:= Pool
.The_Pool
(Pool
.First_Empty
)'Address;
94 Pool
.First_Empty
:= Pool
.First_Empty
+ Pool
.Aligned_Elmt_Size
;
106 (Pool
: in out Stack_Bounded_Pool
;
107 Address
: System
.Address
;
108 Storage_Size
: SSE
.Storage_Count
;
109 Alignment
: SSE
.Storage_Count
)
112 if Pool
.Elmt_Size
= 0 then
113 Vsize
.Deallocate
(Pool
, Address
, Storage_Size
, Alignment
);
116 SC
.To_Pointer
(Address
).all := Pool
.First_Free
;
117 Pool
.First_Free
:= Address
- Pool
.The_Pool
'Address + 1;
125 procedure Initialize
(Pool
: in out Stack_Bounded_Pool
) is
126 Align
: constant SSE
.Storage_Count
:=
127 SSE
.Storage_Count
'Max (SSE
.Storage_Count
'Alignment, Pool
.Alignment
);
130 if Pool
.Elmt_Size
= 0 then
131 Vsize
.Initialize
(Pool
);
134 Pool
.First_Free
:= 0;
135 Pool
.First_Empty
:= 1;
137 -- Compute the size to allocate given the size of the element and
138 -- the possible Alignment clause
140 Pool
.Aligned_Elmt_Size
:=
141 SSE
.Storage_Count
'Max (SC_Size
,
142 ((Pool
.Elmt_Size
+ Align
- 1) / Align
) * Align
);
150 function Storage_Size
151 (Pool
: Stack_Bounded_Pool
)
152 return SSE
.Storage_Count
155 return Pool
.Pool_Size
;
158 ------------------------------
159 -- Variable_Size_Management --
160 ------------------------------
162 package body Variable_Size_Management
is
164 Minimum_Size
: constant := 2 * SC_Size
;
167 (Pool
: Stack_Bounded_Pool
;
168 Chunk
, Size
: SSE
.Storage_Count
);
169 -- Update the field 'size' of a chunk of available storage
172 (Pool
: Stack_Bounded_Pool
;
173 Chunk
, Next
: SSE
.Storage_Count
);
174 -- Update the field 'next' of a chunk of available storage
177 (Pool
: Stack_Bounded_Pool
;
178 Chunk
: SSE
.Storage_Count
)
179 return SSE
.Storage_Count
;
180 -- Fetch the field 'size' of a chunk of available storage
183 (Pool
: Stack_Bounded_Pool
;
184 Chunk
: SSE
.Storage_Count
)
185 return SSE
.Storage_Count
;
186 -- Fetch the field 'next' of a chunk of available storage
189 (Pool
: Stack_Bounded_Pool
;
190 Addr
: System
.Address
)
191 return SSE
.Storage_Count
;
192 -- Give the chunk number in the pool from its Address
199 (Pool
: in out Stack_Bounded_Pool
;
200 Address
: out System
.Address
;
201 Storage_Size
: SSE
.Storage_Count
;
202 Alignment
: SSE
.Storage_Count
)
204 Chunk
: SSE
.Storage_Count
;
205 New_Chunk
: SSE
.Storage_Count
;
206 Prev_Chunk
: SSE
.Storage_Count
;
207 Our_Align
: constant SSE
.Storage_Count
:=
208 SSE
.Storage_Count
'Max (SSE
.Storage_Count
'Alignment,
210 Align_Size
: constant SSE
.Storage_Count
:=
211 SSE
.Storage_Count
'Max (
213 ((Storage_Size
+ Our_Align
- 1) / Our_Align
) *
217 -- Look for the first big enough chunk
219 Prev_Chunk
:= Pool
.First_Free
;
220 Chunk
:= Next
(Pool
, Prev_Chunk
);
222 while Chunk
/= 0 and then Size
(Pool
, Chunk
) < Align_Size
loop
224 Chunk
:= Next
(Pool
, Chunk
);
227 -- Raise storage_error if no big enough chunk available
233 -- When the chunk is bigger than what is needed, take appropraite
234 -- amount and build a new shrinked chunk with the remainder.
236 if Size
(Pool
, Chunk
) - Align_Size
> Minimum_Size
then
237 New_Chunk
:= Chunk
+ Align_Size
;
238 Set_Size
(Pool
, New_Chunk
, Size
(Pool
, Chunk
) - Align_Size
);
239 Set_Next
(Pool
, New_Chunk
, Next
(Pool
, Chunk
));
240 Set_Next
(Pool
, Prev_Chunk
, New_Chunk
);
242 -- If the chunk is the right size, just delete it from the chain
245 Set_Next
(Pool
, Prev_Chunk
, Next
(Pool
, Chunk
));
248 Address
:= Pool
.The_Pool
(Chunk
)'Address;
256 (Pool
: Stack_Bounded_Pool
;
257 Addr
: System
.Address
)
258 return SSE
.Storage_Count
261 return 1 + abs (Addr
- Pool
.The_Pool
(1)'Address);
269 (Pool
: in out Stack_Bounded_Pool
;
270 Address
: System
.Address
;
271 Storage_Size
: SSE
.Storage_Count
;
272 Alignment
: SSE
.Storage_Count
)
274 Align_Size
: constant SSE
.Storage_Count
:=
275 ((Storage_Size
+ Alignment
- 1) / Alignment
) *
277 Chunk
: SSE
.Storage_Count
:= Chunk_Of
(Pool
, Address
);
280 -- Attach the freed chunk to the chain
282 Set_Size
(Pool
, Chunk
,
283 SSE
.Storage_Count
'Max (Align_Size
, Minimum_Size
));
284 Set_Next
(Pool
, Chunk
, Next
(Pool
, Pool
.First_Free
));
285 Set_Next
(Pool
, Pool
.First_Free
, Chunk
);
293 procedure Initialize
(Pool
: in out Stack_Bounded_Pool
) is
295 Pool
.First_Free
:= 1;
297 if Pool
.Pool_Size
> Minimum_Size
then
298 Set_Next
(Pool
, Pool
.First_Free
, Pool
.First_Free
+ Minimum_Size
);
299 Set_Size
(Pool
, Pool
.First_Free
, 0);
300 Set_Size
(Pool
, Pool
.First_Free
+ Minimum_Size
,
301 Pool
.Pool_Size
- Minimum_Size
);
302 Set_Next
(Pool
, Pool
.First_Free
+ Minimum_Size
, 0);
311 (Pool
: Stack_Bounded_Pool
;
312 Chunk
: SSE
.Storage_Count
)
313 return SSE
.Storage_Count
316 return SC
.To_Pointer
(Pool
.The_Pool
(Chunk
+ SC_Size
)'Address).all;
324 (Pool
: Stack_Bounded_Pool
;
325 Chunk
, Next
: SSE
.Storage_Count
)
328 SC
.To_Pointer
(Pool
.The_Pool
(Chunk
+ SC_Size
)'Address).all := Next
;
336 (Pool
: Stack_Bounded_Pool
;
337 Chunk
, Size
: SSE
.Storage_Count
)
340 SC
.To_Pointer
(Pool
.The_Pool
(Chunk
)'Address).all := Size
;
348 (Pool
: Stack_Bounded_Pool
;
349 Chunk
: SSE
.Storage_Count
)
350 return SSE
.Storage_Count
353 return SC
.To_Pointer
(Pool
.The_Pool
(Chunk
)'Address).all;
356 end Variable_Size_Management
;
357 end System
.Pool_Size
;