]>
Commit | Line | Data |
---|---|---|
cacbc350 RK |
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 | -- -- | |
4b490c1e | 9 | -- Copyright (C) 1992-2020, Free Software Foundation, Inc. -- |
cacbc350 RK |
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- -- | |
748086b7 | 13 | -- ware Foundation; either version 3, or (at your option) any later ver- -- |
cacbc350 RK |
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 -- | |
748086b7 JJ |
16 | -- or FITNESS FOR A PARTICULAR PURPOSE. -- |
17 | -- -- | |
18 | -- As a special exception under Section 7 of GPL version 3, you are granted -- | |
19 | -- additional permissions described in the GCC Runtime Library Exception, -- | |
20 | -- version 3.1, as published by the Free Software Foundation. -- | |
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/>. -- | |
cacbc350 RK |
26 | -- -- |
27 | -- GNAT was originally developed by the GNAT team at New York University. -- | |
71ff80dc | 28 | -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
cacbc350 RK |
29 | -- -- |
30 | ------------------------------------------------------------------------------ | |
31 | ||
91b1417d | 32 | with System.Soft_Links; |
fbf5a39b | 33 | |
cecaf88a | 34 | with Ada.Unchecked_Conversion; |
cacbc350 RK |
35 | |
36 | package body System.Pool_Size is | |
37 | ||
38 | package SSE renames System.Storage_Elements; | |
39 | use type SSE.Storage_Offset; | |
40 | ||
b11e8d6f RD |
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 | |
91b1417d AC |
46 | -- linked list implementation for efficiency reasons. |
47 | ||
48 | package SSL renames System.Soft_Links; | |
49 | ||
fbf5a39b AC |
50 | type Storage_Count_Access is access SSE.Storage_Count; |
51 | function To_Storage_Count_Access is | |
cecaf88a | 52 | new Ada.Unchecked_Conversion (Address, Storage_Count_Access); |
cacbc350 | 53 | |
c8307596 | 54 | SC_Size : constant := SSE.Storage_Count'Object_Size / System.Storage_Unit; |
cacbc350 RK |
55 | |
56 | package Variable_Size_Management is | |
57 | ||
b11e8d6f | 58 | -- Embedded pool that manages allocation of variable-size data |
cacbc350 | 59 | |
276e95ca | 60 | -- This pool is used as soon as the Elmt_Size of the pool object is 0 |
cacbc350 RK |
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 | |
91b1417d AC |
92 | SSL.Lock_Task.all; |
93 | ||
cacbc350 RK |
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; | |
fbf5a39b | 99 | Pool.First_Free := To_Storage_Count_Access (Address).all; |
cacbc350 RK |
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; | |
91b1417d AC |
110 | |
111 | SSL.Unlock_Task.all; | |
112 | ||
113 | exception | |
114 | when others => | |
115 | SSL.Unlock_Task.all; | |
116 | raise; | |
cacbc350 RK |
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 | |
91b1417d AC |
130 | SSL.Lock_Task.all; |
131 | ||
cacbc350 RK |
132 | if Pool.Elmt_Size = 0 then |
133 | Vsize.Deallocate (Pool, Address, Storage_Size, Alignment); | |
134 | ||
135 | else | |
fbf5a39b | 136 | To_Storage_Count_Access (Address).all := Pool.First_Free; |
cacbc350 RK |
137 | Pool.First_Free := Address - Pool.The_Pool'Address + 1; |
138 | end if; | |
91b1417d AC |
139 | |
140 | SSL.Unlock_Task.all; | |
141 | exception | |
142 | when others => | |
143 | SSL.Unlock_Task.all; | |
144 | raise; | |
cacbc350 RK |
145 | end Deallocate; |
146 | ||
147 | ---------------- | |
148 | -- Initialize -- | |
149 | ---------------- | |
150 | ||
86ec3bfb | 151 | procedure Initialize (Pool : in out Stack_Bounded_Pool) is |
a5b62485 AC |
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 | ||
cacbc350 | 158 | Align : constant SSE.Storage_Count := |
a5b62485 AC |
159 | SSE.Storage_Count'Max |
160 | (SSE.Storage_Count'Alignment, Pool.Alignment); | |
cacbc350 RK |
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 | |
a5b62485 | 171 | -- the possible alignment requirement as defined above. |
cacbc350 RK |
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 | ||
86ec3bfb | 183 | function Storage_Size |
a5b62485 | 184 | (Pool : Stack_Bounded_Pool) return SSE.Storage_Count |
cacbc350 RK |
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; | |
a5b62485 | 210 | Chunk : SSE.Storage_Count) return SSE.Storage_Count; |
cacbc350 RK |
211 | -- Fetch the field 'size' of a chunk of available storage |
212 | ||
213 | function Next | |
214 | (Pool : Stack_Bounded_Pool; | |
a5b62485 | 215 | Chunk : SSE.Storage_Count) return SSE.Storage_Count; |
cacbc350 RK |
216 | -- Fetch the field 'next' of a chunk of available storage |
217 | ||
218 | function Chunk_Of | |
219 | (Pool : Stack_Bounded_Pool; | |
a5b62485 | 220 | Addr : System.Address) return SSE.Storage_Count; |
cacbc350 RK |
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 | ||
276e95ca | 262 | -- When the chunk is bigger than what is needed, take appropriate |
cacbc350 RK |
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; | |
a5b62485 | 286 | Addr : System.Address) return SSE.Storage_Count |
cacbc350 RK |
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 | |
9d77af56 RD |
302 | pragma Warnings (Off, Pool); |
303 | ||
cacbc350 RK |
304 | Align_Size : constant SSE.Storage_Count := |
305 | ((Storage_Size + Alignment - 1) / Alignment) * | |
306 | Alignment; | |
fbf5a39b | 307 | Chunk : constant SSE.Storage_Count := Chunk_Of (Pool, Address); |
cacbc350 RK |
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; | |
a5b62485 | 342 | Chunk : SSE.Storage_Count) return SSE.Storage_Count |
cacbc350 RK |
343 | is |
344 | begin | |
fbf5a39b AC |
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); | |
cacbc350 RK |
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 | |
fbf5a39b AC |
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); | |
cacbc350 RK |
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 | |
fbf5a39b AC |
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); | |
cacbc350 RK |
391 | end Set_Size; |
392 | ||
393 | ---------- | |
394 | -- Size -- | |
395 | ---------- | |
396 | ||
397 | function Size | |
398 | (Pool : Stack_Bounded_Pool; | |
a5b62485 | 399 | Chunk : SSE.Storage_Count) return SSE.Storage_Count |
cacbc350 RK |
400 | is |
401 | begin | |
fbf5a39b AC |
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); | |
cacbc350 RK |
409 | end Size; |
410 | ||
411 | end Variable_Size_Management; | |
412 | end System.Pool_Size; |