File : s-poosiz.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT RUN-TIME COMPONENTS --
4 -- --
5 -- S Y S T E M . P O O L _ S I Z E --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
10 -- --
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. --
17 -- --
18 -- --
19 -- --
20 -- --
21 -- --
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/>. --
26 -- --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
29 -- --
30 ------------------------------------------------------------------------------
31
32 with System.Soft_Links;
33
34 with Ada.Unchecked_Conversion;
35
36 package body System.Pool_Size is
37
38 package SSE renames System.Storage_Elements;
39 use type SSE.Storage_Offset;
40
41 -- Even though these storage pools are typically only used by a single
42 -- task, if multiple tasks are declared at the same or a more nested scope
43 -- as the storage pool, there still may be concurrent access. The current
44 -- implementation of Stack_Bounded_Pool always uses a global lock for
45 -- protecting access. This should eventually be replaced by an atomic
46 -- linked list implementation for efficiency reasons.
47
48 package SSL renames System.Soft_Links;
49
50 type Storage_Count_Access is access SSE.Storage_Count;
51 function To_Storage_Count_Access is
52 new Ada.Unchecked_Conversion (Address, Storage_Count_Access);
53
54 SC_Size : constant := SSE.Storage_Count'Object_Size / System.Storage_Unit;
55
56 package Variable_Size_Management is
57
58 -- Embedded pool that manages allocation of variable-size data
59
60 -- This pool is used as soon as the Elmt_Size of the pool object is 0
61
62 -- Allocation is done on the first chunk long enough for the request.
63 -- Deallocation just puts the freed chunk at the beginning of the list.
64
65 procedure Initialize (Pool : in out Stack_Bounded_Pool);
66 procedure Allocate
67 (Pool : in out Stack_Bounded_Pool;
68 Address : out System.Address;
69 Storage_Size : SSE.Storage_Count;
70 Alignment : SSE.Storage_Count);
71
72 procedure Deallocate
73 (Pool : in out Stack_Bounded_Pool;
74 Address : System.Address;
75 Storage_Size : SSE.Storage_Count;
76 Alignment : SSE.Storage_Count);
77 end Variable_Size_Management;
78
79 package Vsize renames Variable_Size_Management;
80
81 --------------
82 -- Allocate --
83 --------------
84
85 procedure Allocate
86 (Pool : in out Stack_Bounded_Pool;
87 Address : out System.Address;
88 Storage_Size : SSE.Storage_Count;
89 Alignment : SSE.Storage_Count)
90 is
91 begin
92 SSL.Lock_Task.all;
93
94 if Pool.Elmt_Size = 0 then
95 Vsize.Allocate (Pool, Address, Storage_Size, Alignment);
96
97 elsif Pool.First_Free /= 0 then
98 Address := Pool.The_Pool (Pool.First_Free)'Address;
99 Pool.First_Free := To_Storage_Count_Access (Address).all;
100
101 elsif
102 Pool.First_Empty <= (Pool.Pool_Size - Pool.Aligned_Elmt_Size + 1)
103 then
104 Address := Pool.The_Pool (Pool.First_Empty)'Address;
105 Pool.First_Empty := Pool.First_Empty + Pool.Aligned_Elmt_Size;
106
107 else
108 raise Storage_Error;
109 end if;
110
111 SSL.Unlock_Task.all;
112
113 exception
114 when others =>
115 SSL.Unlock_Task.all;
116 raise;
117 end Allocate;
118
119 ----------------
120 -- Deallocate --
121 ----------------
122
123 procedure Deallocate
124 (Pool : in out Stack_Bounded_Pool;
125 Address : System.Address;
126 Storage_Size : SSE.Storage_Count;
127 Alignment : SSE.Storage_Count)
128 is
129 begin
130 SSL.Lock_Task.all;
131
132 if Pool.Elmt_Size = 0 then
133 Vsize.Deallocate (Pool, Address, Storage_Size, Alignment);
134
135 else
136 To_Storage_Count_Access (Address).all := Pool.First_Free;
137 Pool.First_Free := Address - Pool.The_Pool'Address + 1;
138 end if;
139
140 SSL.Unlock_Task.all;
141 exception
142 when others =>
143 SSL.Unlock_Task.all;
144 raise;
145 end Deallocate;
146
147 ----------------
148 -- Initialize --
149 ----------------
150
151 procedure Initialize (Pool : in out Stack_Bounded_Pool) is
152
153 -- Define the appropriate alignment for allocations. This is the
154 -- maximum of the requested alignment, and the alignment required
155 -- for Storage_Count values. The latter test is to ensure that we
156 -- can properly reference the linked list pointers for free lists.
157
158 Align : constant SSE.Storage_Count :=
159 SSE.Storage_Count'Max
160 (SSE.Storage_Count'Alignment, Pool.Alignment);
161
162 begin
163 if Pool.Elmt_Size = 0 then
164 Vsize.Initialize (Pool);
165
166 else
167 Pool.First_Free := 0;
168 Pool.First_Empty := 1;
169
170 -- Compute the size to allocate given the size of the element and
171 -- the possible alignment requirement as defined above.
172
173 Pool.Aligned_Elmt_Size :=
174 SSE.Storage_Count'Max (SC_Size,
175 ((Pool.Elmt_Size + Align - 1) / Align) * Align);
176 end if;
177 end Initialize;
178
179 ------------------
180 -- Storage_Size --
181 ------------------
182
183 function Storage_Size
184 (Pool : Stack_Bounded_Pool) return SSE.Storage_Count
185 is
186 begin
187 return Pool.Pool_Size;
188 end Storage_Size;
189
190 ------------------------------
191 -- Variable_Size_Management --
192 ------------------------------
193
194 package body Variable_Size_Management is
195
196 Minimum_Size : constant := 2 * SC_Size;
197
198 procedure Set_Size
199 (Pool : Stack_Bounded_Pool;
200 Chunk, Size : SSE.Storage_Count);
201 -- Update the field 'size' of a chunk of available storage
202
203 procedure Set_Next
204 (Pool : Stack_Bounded_Pool;
205 Chunk, Next : SSE.Storage_Count);
206 -- Update the field 'next' of a chunk of available storage
207
208 function Size
209 (Pool : Stack_Bounded_Pool;
210 Chunk : SSE.Storage_Count) return SSE.Storage_Count;
211 -- Fetch the field 'size' of a chunk of available storage
212
213 function Next
214 (Pool : Stack_Bounded_Pool;
215 Chunk : SSE.Storage_Count) return SSE.Storage_Count;
216 -- Fetch the field 'next' of a chunk of available storage
217
218 function Chunk_Of
219 (Pool : Stack_Bounded_Pool;
220 Addr : System.Address) return SSE.Storage_Count;
221 -- Give the chunk number in the pool from its Address
222
223 --------------
224 -- Allocate --
225 --------------
226
227 procedure Allocate
228 (Pool : in out Stack_Bounded_Pool;
229 Address : out System.Address;
230 Storage_Size : SSE.Storage_Count;
231 Alignment : SSE.Storage_Count)
232 is
233 Chunk : SSE.Storage_Count;
234 New_Chunk : SSE.Storage_Count;
235 Prev_Chunk : SSE.Storage_Count;
236 Our_Align : constant SSE.Storage_Count :=
237 SSE.Storage_Count'Max (SSE.Storage_Count'Alignment,
238 Alignment);
239 Align_Size : constant SSE.Storage_Count :=
240 SSE.Storage_Count'Max (
241 Minimum_Size,
242 ((Storage_Size + Our_Align - 1) / Our_Align) *
243 Our_Align);
244
245 begin
246 -- Look for the first big enough chunk
247
248 Prev_Chunk := Pool.First_Free;
249 Chunk := Next (Pool, Prev_Chunk);
250
251 while Chunk /= 0 and then Size (Pool, Chunk) < Align_Size loop
252 Prev_Chunk := Chunk;
253 Chunk := Next (Pool, Chunk);
254 end loop;
255
256 -- Raise storage_error if no big enough chunk available
257
258 if Chunk = 0 then
259 raise Storage_Error;
260 end if;
261
262 -- When the chunk is bigger than what is needed, take appropriate
263 -- amount and build a new shrinked chunk with the remainder.
264
265 if Size (Pool, Chunk) - Align_Size > Minimum_Size then
266 New_Chunk := Chunk + Align_Size;
267 Set_Size (Pool, New_Chunk, Size (Pool, Chunk) - Align_Size);
268 Set_Next (Pool, New_Chunk, Next (Pool, Chunk));
269 Set_Next (Pool, Prev_Chunk, New_Chunk);
270
271 -- If the chunk is the right size, just delete it from the chain
272
273 else
274 Set_Next (Pool, Prev_Chunk, Next (Pool, Chunk));
275 end if;
276
277 Address := Pool.The_Pool (Chunk)'Address;
278 end Allocate;
279
280 --------------
281 -- Chunk_Of --
282 --------------
283
284 function Chunk_Of
285 (Pool : Stack_Bounded_Pool;
286 Addr : System.Address) return SSE.Storage_Count
287 is
288 begin
289 return 1 + abs (Addr - Pool.The_Pool (1)'Address);
290 end Chunk_Of;
291
292 ----------------
293 -- Deallocate --
294 ----------------
295
296 procedure Deallocate
297 (Pool : in out Stack_Bounded_Pool;
298 Address : System.Address;
299 Storage_Size : SSE.Storage_Count;
300 Alignment : SSE.Storage_Count)
301 is
302 pragma Warnings (Off, Pool);
303
304 Align_Size : constant SSE.Storage_Count :=
305 ((Storage_Size + Alignment - 1) / Alignment) *
306 Alignment;
307 Chunk : constant SSE.Storage_Count := Chunk_Of (Pool, Address);
308
309 begin
310 -- Attach the freed chunk to the chain
311
312 Set_Size (Pool, Chunk,
313 SSE.Storage_Count'Max (Align_Size, Minimum_Size));
314 Set_Next (Pool, Chunk, Next (Pool, Pool.First_Free));
315 Set_Next (Pool, Pool.First_Free, Chunk);
316
317 end Deallocate;
318
319 ----------------
320 -- Initialize --
321 ----------------
322
323 procedure Initialize (Pool : in out Stack_Bounded_Pool) is
324 begin
325 Pool.First_Free := 1;
326
327 if Pool.Pool_Size > Minimum_Size then
328 Set_Next (Pool, Pool.First_Free, Pool.First_Free + Minimum_Size);
329 Set_Size (Pool, Pool.First_Free, 0);
330 Set_Size (Pool, Pool.First_Free + Minimum_Size,
331 Pool.Pool_Size - Minimum_Size);
332 Set_Next (Pool, Pool.First_Free + Minimum_Size, 0);
333 end if;
334 end Initialize;
335
336 ----------
337 -- Next --
338 ----------
339
340 function Next
341 (Pool : Stack_Bounded_Pool;
342 Chunk : SSE.Storage_Count) return SSE.Storage_Count
343 is
344 begin
345 pragma Warnings (Off);
346 -- Kill alignment warnings, we are careful to make sure
347 -- that the alignment is correct.
348
349 return To_Storage_Count_Access
350 (Pool.The_Pool (Chunk + SC_Size)'Address).all;
351
352 pragma Warnings (On);
353 end Next;
354
355 --------------
356 -- Set_Next --
357 --------------
358
359 procedure Set_Next
360 (Pool : Stack_Bounded_Pool;
361 Chunk, Next : SSE.Storage_Count)
362 is
363 begin
364 pragma Warnings (Off);
365 -- Kill alignment warnings, we are careful to make sure
366 -- that the alignment is correct.
367
368 To_Storage_Count_Access
369 (Pool.The_Pool (Chunk + SC_Size)'Address).all := Next;
370
371 pragma Warnings (On);
372 end Set_Next;
373
374 --------------
375 -- Set_Size --
376 --------------
377
378 procedure Set_Size
379 (Pool : Stack_Bounded_Pool;
380 Chunk, Size : SSE.Storage_Count)
381 is
382 begin
383 pragma Warnings (Off);
384 -- Kill alignment warnings, we are careful to make sure
385 -- that the alignment is correct.
386
387 To_Storage_Count_Access
388 (Pool.The_Pool (Chunk)'Address).all := Size;
389
390 pragma Warnings (On);
391 end Set_Size;
392
393 ----------
394 -- Size --
395 ----------
396
397 function Size
398 (Pool : Stack_Bounded_Pool;
399 Chunk : SSE.Storage_Count) return SSE.Storage_Count
400 is
401 begin
402 pragma Warnings (Off);
403 -- Kill alignment warnings, we are careful to make sure
404 -- that the alignment is correct.
405
406 return To_Storage_Count_Access (Pool.The_Pool (Chunk)'Address).all;
407
408 pragma Warnings (On);
409 end Size;
410
411 end Variable_Size_Management;
412 end System.Pool_Size;