GCC v8.2
[gcc.git] / gcc / ada / libgnat / 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-2018, 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;