Mercurial > hg > CbC > CbC_gcc
comparison gcc/ada/libgnat/s-poosiz.adb @ 111:04ced10e8804
gcc 7
author | kono |
---|---|
date | Fri, 27 Oct 2017 22:46:09 +0900 |
parents | |
children | 84e7813d76e9 |
comparison
equal
deleted
inserted
replaced
68:561a7518be6b | 111:04ced10e8804 |
---|---|
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-2017, 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 -- 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/>. -- | |
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; |