|
111
|
1 ------------------------------------------------------------------------------
|
|
|
2 -- --
|
|
|
3 -- GNAT COMPILER COMPONENTS --
|
|
|
4 -- --
|
|
|
5 -- S Y S T E M . S E C O N D A R Y _ S T A C K --
|
|
|
6 -- --
|
|
|
7 -- B o d y --
|
|
|
8 -- --
|
|
145
|
9 -- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
|
|
111
|
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 pragma Compiler_Unit_Warning;
|
|
|
33
|
|
|
34 with Ada.Unchecked_Conversion;
|
|
|
35 with Ada.Unchecked_Deallocation;
|
|
131
|
36
|
|
|
37 with System; use System;
|
|
|
38 with System.Parameters; use System.Parameters;
|
|
|
39 with System.Soft_Links; use System.Soft_Links;
|
|
|
40 with System.Storage_Elements; use System.Storage_Elements;
|
|
111
|
41
|
|
|
42 package body System.Secondary_Stack is
|
|
|
43
|
|
131
|
44 ------------------------------------
|
|
|
45 -- Binder Allocated Stack Support --
|
|
|
46 ------------------------------------
|
|
|
47
|
|
|
48 -- When at least one of the following restrictions
|
|
|
49 --
|
|
|
50 -- No_Implicit_Heap_Allocations
|
|
|
51 -- No_Implicit_Task_Allocations
|
|
|
52 --
|
|
|
53 -- is in effect, the binder creates a static secondary stack pool, where
|
|
|
54 -- each stack has a default size. Assignment of these stacks to tasks is
|
|
|
55 -- performed by SS_Init. The following variables are defined in this unit
|
|
|
56 -- in order to avoid depending on the binder. Their values are set by the
|
|
|
57 -- binder.
|
|
|
58
|
|
|
59 Binder_SS_Count : Natural;
|
|
|
60 pragma Export (Ada, Binder_SS_Count, "__gnat_binder_ss_count");
|
|
|
61 -- The number of secondary stacks in the pool created by the binder
|
|
|
62
|
|
|
63 Binder_Default_SS_Size : Size_Type;
|
|
|
64 pragma Export (Ada, Binder_Default_SS_Size, "__gnat_default_ss_size");
|
|
|
65 -- The default secondary stack size as specified by the binder. The value
|
|
|
66 -- is defined here rather than in init.c or System.Init because the ZFP and
|
|
|
67 -- Ravenscar-ZFP run-times lack these locations.
|
|
|
68
|
|
|
69 Binder_Default_SS_Pool : Address;
|
|
|
70 pragma Export (Ada, Binder_Default_SS_Pool, "__gnat_default_ss_pool");
|
|
|
71 -- The address of the secondary stack pool created by the binder
|
|
|
72
|
|
|
73 Binder_Default_SS_Pool_Index : Natural := 0;
|
|
|
74 -- Index into the secondary stack pool created by the binder
|
|
|
75
|
|
|
76 -----------------------
|
|
|
77 -- Local subprograms --
|
|
|
78 -----------------------
|
|
|
79
|
|
|
80 procedure Allocate_Dynamic
|
|
|
81 (Stack : SS_Stack_Ptr;
|
|
|
82 Mem_Size : Memory_Size;
|
|
|
83 Addr : out Address);
|
|
|
84 pragma Inline (Allocate_Dynamic);
|
|
|
85 -- Allocate enough space on dynamic secondary stack Stack to fit a request
|
|
|
86 -- of size Mem_Size. Addr denotes the address of the first byte of the
|
|
|
87 -- allocation.
|
|
|
88
|
|
|
89 procedure Allocate_On_Chunk
|
|
|
90 (Stack : SS_Stack_Ptr;
|
|
|
91 Prev_Chunk : SS_Chunk_Ptr;
|
|
|
92 Chunk : SS_Chunk_Ptr;
|
|
|
93 Byte : Memory_Index;
|
|
|
94 Mem_Size : Memory_Size;
|
|
|
95 Addr : out Address);
|
|
|
96 pragma Inline (Allocate_On_Chunk);
|
|
|
97 -- Allocate enough space on chunk Chunk to fit a request of size Mem_Size.
|
|
|
98 -- Stack is the owner of the allocation Chunk. Prev_Chunk is the preceding
|
|
|
99 -- chunk of Chunk. Byte indicates the first free byte within Chunk. Addr
|
|
|
100 -- denotes the address of the first byte of the allocation. This routine
|
|
|
101 -- updates the state of Stack.all to reflect the side effects of the
|
|
|
102 -- allocation.
|
|
|
103
|
|
|
104 procedure Allocate_Static
|
|
|
105 (Stack : SS_Stack_Ptr;
|
|
|
106 Mem_Size : Memory_Size;
|
|
|
107 Addr : out Address);
|
|
|
108 pragma Inline (Allocate_Static);
|
|
|
109 -- Allocate enough space on static secondary stack Stack to fit a request
|
|
|
110 -- of size Mem_Size. Addr denotes the address of the first byte of the
|
|
|
111 -- allocation.
|
|
|
112
|
|
|
113 procedure Free is new Ada.Unchecked_Deallocation (SS_Chunk, SS_Chunk_Ptr);
|
|
|
114 -- Free a dynamically allocated chunk
|
|
|
115
|
|
|
116 procedure Free is new Ada.Unchecked_Deallocation (SS_Stack, SS_Stack_Ptr);
|
|
|
117 -- Free a dynamically allocated secondary stack
|
|
|
118
|
|
|
119 function Has_Enough_Free_Memory
|
|
|
120 (Chunk : SS_Chunk_Ptr;
|
|
|
121 Byte : Memory_Index;
|
|
|
122 Mem_Size : Memory_Size) return Boolean;
|
|
|
123 pragma Inline (Has_Enough_Free_Memory);
|
|
|
124 -- Determine whether chunk Chunk has enough room to fit a memory request of
|
|
|
125 -- size Mem_Size, starting from the first free byte of the chunk denoted by
|
|
|
126 -- Byte.
|
|
|
127
|
|
|
128 function Number_Of_Chunks (Stack : SS_Stack_Ptr) return Chunk_Count;
|
|
|
129 pragma Inline (Number_Of_Chunks);
|
|
|
130 -- Count the number of static and dynamic chunks of secondary stack Stack
|
|
|
131
|
|
|
132 function Size_Up_To_And_Including (Chunk : SS_Chunk_Ptr) return Memory_Size;
|
|
|
133 pragma Inline (Size_Up_To_And_Including);
|
|
|
134 -- Calculate the size of secondary stack which houses chunk Chunk, from the
|
|
|
135 -- start of the secondary stack up to and including Chunk itself. The size
|
|
|
136 -- includes the following kinds of memory:
|
|
|
137 --
|
|
|
138 -- * Free memory in used chunks due to alignment holes
|
|
|
139 -- * Occupied memory by allocations
|
|
|
140 --
|
|
|
141 -- This is a constant time operation, regardless of the secondary stack's
|
|
|
142 -- nature.
|
|
|
143
|
|
|
144 function Top_Chunk_Id (Stack : SS_Stack_Ptr) return Chunk_Id_With_Invalid;
|
|
|
145 pragma Inline (Top_Chunk_Id);
|
|
|
146 -- Obtain the Chunk_Id of the chunk indicated by secondary stack Stack's
|
|
|
147 -- pointer.
|
|
|
148
|
|
|
149 function Used_Memory_Size (Stack : SS_Stack_Ptr) return Memory_Size;
|
|
|
150 pragma Inline (Used_Memory_Size);
|
|
|
151 -- Calculate the size of stack Stack's occupied memory usage. This includes
|
|
|
152 -- the following kinds of memory:
|
|
|
153 --
|
|
|
154 -- * Free memory in used chunks due to alignment holes
|
|
|
155 -- * Occupied memory by allocations
|
|
|
156 --
|
|
|
157 -- This is a constant time operation, regardless of the secondary stack's
|
|
|
158 -- nature.
|
|
|
159
|
|
|
160 ----------------------
|
|
|
161 -- Allocate_Dynamic --
|
|
|
162 ----------------------
|
|
|
163
|
|
|
164 procedure Allocate_Dynamic
|
|
|
165 (Stack : SS_Stack_Ptr;
|
|
|
166 Mem_Size : Memory_Size;
|
|
|
167 Addr : out Address)
|
|
|
168 is
|
|
|
169 function Allocate_New_Chunk return SS_Chunk_Ptr;
|
|
|
170 pragma Inline (Allocate_New_Chunk);
|
|
|
171 -- Create a new chunk which is big enough to fit a request of size
|
|
|
172 -- Mem_Size.
|
|
|
173
|
|
|
174 ------------------------
|
|
|
175 -- Allocate_New_Chunk --
|
|
|
176 ------------------------
|
|
|
177
|
|
|
178 function Allocate_New_Chunk return SS_Chunk_Ptr is
|
|
|
179 Chunk_Size : Memory_Size;
|
|
|
180
|
|
|
181 begin
|
|
|
182 -- The size of the new chunk must fit the memory request precisely.
|
|
|
183 -- In the case where the memory request is way too small, use the
|
|
|
184 -- default chunk size. This avoids creating multiple tiny chunks.
|
|
|
185
|
|
|
186 Chunk_Size := Mem_Size;
|
|
|
187
|
|
|
188 if Chunk_Size < Stack.Default_Chunk_Size then
|
|
|
189 Chunk_Size := Stack.Default_Chunk_Size;
|
|
|
190 end if;
|
|
|
191
|
|
|
192 return new SS_Chunk (Chunk_Size);
|
|
|
193
|
|
|
194 -- The creation of the new chunk may exhaust the heap. Raise a new
|
|
|
195 -- Storage_Error to indicate that the secondary stack is exhausted
|
|
|
196 -- as well.
|
|
|
197
|
|
|
198 exception
|
|
|
199 when Storage_Error =>
|
|
|
200 raise Storage_Error with "secondary stack exhausted";
|
|
|
201 end Allocate_New_Chunk;
|
|
|
202
|
|
|
203 -- Local variables
|
|
|
204
|
|
|
205 Next_Chunk : SS_Chunk_Ptr;
|
|
|
206
|
|
|
207 -- Start of processing for Allocate_Dynamic
|
|
|
208
|
|
|
209 begin
|
|
|
210 -- Determine whether the chunk indicated by the stack pointer is big
|
|
|
211 -- enough to fit the memory request and if it is, allocate on it.
|
|
|
212
|
|
|
213 if Has_Enough_Free_Memory
|
|
|
214 (Chunk => Stack.Top.Chunk,
|
|
|
215 Byte => Stack.Top.Byte,
|
|
|
216 Mem_Size => Mem_Size)
|
|
|
217 then
|
|
|
218 Allocate_On_Chunk
|
|
|
219 (Stack => Stack,
|
|
|
220 Prev_Chunk => null,
|
|
|
221 Chunk => Stack.Top.Chunk,
|
|
|
222 Byte => Stack.Top.Byte,
|
|
|
223 Mem_Size => Mem_Size,
|
|
|
224 Addr => Addr);
|
|
|
225
|
|
|
226 return;
|
|
|
227 end if;
|
|
|
228
|
|
|
229 -- At this point it is known that the chunk indicated by the stack
|
|
|
230 -- pointer is not big enough to fit the memory request. Examine all
|
|
|
231 -- subsequent chunks, and apply the following criteria:
|
|
|
232 --
|
|
|
233 -- * If the current chunk is too small, free it
|
|
|
234 --
|
|
|
235 -- * If the current chunk is big enough, allocate on it
|
|
|
236 --
|
|
|
237 -- This ensures that no space is wasted. The process is costly, however
|
|
|
238 -- allocation is costly in general. Paying the price here keeps routines
|
|
|
239 -- SS_Mark and SS_Release cheap.
|
|
|
240
|
|
|
241 while Stack.Top.Chunk.Next /= null loop
|
|
|
242
|
|
|
243 -- The current chunk is big enough to fit the memory request,
|
|
|
244 -- allocate on it.
|
|
|
245
|
|
|
246 if Has_Enough_Free_Memory
|
|
|
247 (Chunk => Stack.Top.Chunk.Next,
|
|
|
248 Byte => Stack.Top.Chunk.Next.Memory'First,
|
|
|
249 Mem_Size => Mem_Size)
|
|
|
250 then
|
|
|
251 Allocate_On_Chunk
|
|
|
252 (Stack => Stack,
|
|
|
253 Prev_Chunk => Stack.Top.Chunk,
|
|
|
254 Chunk => Stack.Top.Chunk.Next,
|
|
|
255 Byte => Stack.Top.Chunk.Next.Memory'First,
|
|
|
256 Mem_Size => Mem_Size,
|
|
|
257 Addr => Addr);
|
|
|
258
|
|
|
259 return;
|
|
|
260
|
|
|
261 -- Otherwise the chunk is too small, free it
|
|
|
262
|
|
|
263 else
|
|
|
264 Next_Chunk := Stack.Top.Chunk.Next.Next;
|
|
|
265
|
|
|
266 -- Unchain the chunk from the stack. This keeps the next candidate
|
|
|
267 -- chunk situated immediately after Top.Chunk.
|
|
|
268 --
|
|
|
269 -- Top.Chunk Top.Chunk.Next Top.Chunk.Next.Next
|
|
|
270 -- | | (Next_Chunk)
|
|
|
271 -- v v v
|
|
|
272 -- +-------+ +------------+ +--------------+
|
|
|
273 -- | | --> | | --> | |
|
|
|
274 -- +-------+ +------------+ +--------------+
|
|
|
275 -- to be freed
|
|
|
276
|
|
|
277 Free (Stack.Top.Chunk.Next);
|
|
|
278 Stack.Top.Chunk.Next := Next_Chunk;
|
|
|
279 end if;
|
|
|
280 end loop;
|
|
|
281
|
|
|
282 -- At this point one of the following outcomes took place:
|
|
|
283 --
|
|
|
284 -- * Top.Chunk is the last chunk in the stack
|
|
|
285 --
|
|
|
286 -- * Top.Chunk was not the last chunk originally. It was followed by
|
|
|
287 -- chunks which were too small and as a result were deleted, thus
|
|
|
288 -- making Top.Chunk the last chunk in the stack.
|
|
|
289 --
|
|
|
290 -- Either way, nothing should be hanging off the chunk indicated by the
|
|
|
291 -- stack pointer.
|
|
|
292
|
|
|
293 pragma Assert (Stack.Top.Chunk.Next = null);
|
|
111
|
294
|
|
131
|
295 -- Create a new chunk big enough to fit the memory request, and allocate
|
|
|
296 -- on it.
|
|
|
297
|
|
|
298 Stack.Top.Chunk.Next := Allocate_New_Chunk;
|
|
|
299
|
|
|
300 Allocate_On_Chunk
|
|
|
301 (Stack => Stack,
|
|
|
302 Prev_Chunk => Stack.Top.Chunk,
|
|
|
303 Chunk => Stack.Top.Chunk.Next,
|
|
|
304 Byte => Stack.Top.Chunk.Next.Memory'First,
|
|
|
305 Mem_Size => Mem_Size,
|
|
|
306 Addr => Addr);
|
|
|
307 end Allocate_Dynamic;
|
|
|
308
|
|
|
309 -----------------------
|
|
|
310 -- Allocate_On_Chunk --
|
|
|
311 -----------------------
|
|
|
312
|
|
|
313 procedure Allocate_On_Chunk
|
|
|
314 (Stack : SS_Stack_Ptr;
|
|
|
315 Prev_Chunk : SS_Chunk_Ptr;
|
|
|
316 Chunk : SS_Chunk_Ptr;
|
|
|
317 Byte : Memory_Index;
|
|
|
318 Mem_Size : Memory_Size;
|
|
|
319 Addr : out Address)
|
|
|
320 is
|
|
|
321 New_High_Water_Mark : Memory_Size;
|
|
|
322
|
|
|
323 begin
|
|
|
324 -- The allocation occurs on a reused or a brand new chunk. Such a chunk
|
|
|
325 -- must always be connected to some previous chunk.
|
|
|
326
|
|
|
327 if Prev_Chunk /= null then
|
|
|
328 pragma Assert (Prev_Chunk.Next = Chunk);
|
|
|
329
|
|
|
330 -- Update the Size_Up_To_Chunk because this value is invalidated for
|
|
|
331 -- reused and new chunks.
|
|
|
332 --
|
|
|
333 -- Prev_Chunk Chunk
|
|
|
334 -- v v
|
|
|
335 -- . . . . . . . +--------------+ +--------
|
|
|
336 -- . --> |##############| --> |
|
|
|
337 -- . . . . . . . +--------------+ +--------
|
|
|
338 -- | |
|
|
|
339 -- -------------------+------------+
|
|
|
340 -- Size_Up_To_Chunk Size
|
|
|
341 --
|
|
|
342 -- The Size_Up_To_Chunk is equal to the size of the whole stack up to
|
|
|
343 -- the previous chunk, plus the size of the previous chunk itself.
|
|
|
344
|
|
|
345 Chunk.Size_Up_To_Chunk := Size_Up_To_And_Including (Prev_Chunk);
|
|
|
346 end if;
|
|
|
347
|
|
|
348 -- The chunk must have enough room to fit the memory request. If this is
|
|
|
349 -- not the case, then a previous step picked the wrong chunk.
|
|
|
350
|
|
|
351 pragma Assert (Has_Enough_Free_Memory (Chunk, Byte, Mem_Size));
|
|
|
352
|
|
|
353 -- The first byte of the allocation is the first free byte within the
|
|
|
354 -- chunk.
|
|
|
355
|
|
|
356 Addr := Chunk.Memory (Byte)'Address;
|
|
|
357
|
|
|
358 -- The chunk becomes the chunk indicated by the stack pointer. This is
|
|
|
359 -- either the currently indicated chunk, an existing chunk, or a brand
|
|
|
360 -- new chunk.
|
|
|
361
|
|
|
362 Stack.Top.Chunk := Chunk;
|
|
|
363
|
|
|
364 -- The next free byte is immediately after the memory request
|
|
|
365 --
|
|
|
366 -- Addr Top.Byte
|
|
|
367 -- | |
|
|
|
368 -- +-----|--------|----+
|
|
|
369 -- |##############| |
|
|
|
370 -- +-------------------+
|
|
|
371
|
|
|
372 -- ??? this calculation may overflow on 32bit targets
|
|
|
373
|
|
|
374 Stack.Top.Byte := Byte + Mem_Size;
|
|
|
375
|
|
|
376 -- At this point the next free byte cannot go beyond the memory capacity
|
|
|
377 -- of the chunk indicated by the stack pointer, except when the chunk is
|
|
|
378 -- full, in which case it indicates the byte beyond the chunk. Ensure
|
|
|
379 -- that the occupied memory is at most as much as the capacity of the
|
|
|
380 -- chunk. Top.Byte - 1 denotes the last occupied byte.
|
|
|
381
|
|
|
382 pragma Assert (Stack.Top.Byte - 1 <= Stack.Top.Chunk.Size);
|
|
|
383
|
|
|
384 -- Calculate the new high water mark now that the memory request has
|
|
|
385 -- been fulfilled, and update if necessary. The new high water mark is
|
|
|
386 -- technically the size of the used memory by the whole stack.
|
|
|
387
|
|
|
388 New_High_Water_Mark := Used_Memory_Size (Stack);
|
|
|
389
|
|
|
390 if New_High_Water_Mark > Stack.High_Water_Mark then
|
|
|
391 Stack.High_Water_Mark := New_High_Water_Mark;
|
|
|
392 end if;
|
|
|
393 end Allocate_On_Chunk;
|
|
|
394
|
|
|
395 ---------------------
|
|
|
396 -- Allocate_Static --
|
|
|
397 ---------------------
|
|
|
398
|
|
|
399 procedure Allocate_Static
|
|
|
400 (Stack : SS_Stack_Ptr;
|
|
|
401 Mem_Size : Memory_Size;
|
|
|
402 Addr : out Address)
|
|
|
403 is
|
|
|
404 begin
|
|
|
405 -- Static secondary stack allocations are performed only on the static
|
|
|
406 -- chunk. There should be no dynamic chunks following the static chunk.
|
|
|
407
|
|
|
408 pragma Assert (Stack.Top.Chunk = Stack.Static_Chunk'Access);
|
|
|
409 pragma Assert (Stack.Top.Chunk.Next = null);
|
|
|
410
|
|
|
411 -- Raise Storage_Error if the static chunk does not have enough room to
|
|
|
412 -- fit the memory request. This indicates that the stack is about to be
|
|
|
413 -- depleted.
|
|
111
|
414
|
|
131
|
415 if not Has_Enough_Free_Memory
|
|
|
416 (Chunk => Stack.Top.Chunk,
|
|
|
417 Byte => Stack.Top.Byte,
|
|
|
418 Mem_Size => Mem_Size)
|
|
|
419 then
|
|
|
420 raise Storage_Error with "secondary stack exhaused";
|
|
|
421 end if;
|
|
|
422
|
|
|
423 Allocate_On_Chunk
|
|
|
424 (Stack => Stack,
|
|
|
425 Prev_Chunk => null,
|
|
|
426 Chunk => Stack.Top.Chunk,
|
|
|
427 Byte => Stack.Top.Byte,
|
|
|
428 Mem_Size => Mem_Size,
|
|
|
429 Addr => Addr);
|
|
|
430 end Allocate_Static;
|
|
|
431
|
|
|
432 --------------------
|
|
|
433 -- Get_Chunk_Info --
|
|
|
434 --------------------
|
|
|
435
|
|
|
436 function Get_Chunk_Info
|
|
|
437 (Stack : SS_Stack_Ptr;
|
|
|
438 C_Id : Chunk_Id) return Chunk_Info
|
|
|
439 is
|
|
|
440 function Find_Chunk return SS_Chunk_Ptr;
|
|
|
441 pragma Inline (Find_Chunk);
|
|
|
442 -- Find the chunk which corresponds to Id. Return null if no such chunk
|
|
|
443 -- exists.
|
|
|
444
|
|
|
445 ----------------
|
|
|
446 -- Find_Chunk --
|
|
|
447 ----------------
|
|
|
448
|
|
|
449 function Find_Chunk return SS_Chunk_Ptr is
|
|
|
450 Chunk : SS_Chunk_Ptr;
|
|
|
451 Id : Chunk_Id;
|
|
|
452
|
|
|
453 begin
|
|
|
454 Chunk := Stack.Static_Chunk'Access;
|
|
|
455 Id := 1;
|
|
|
456 while Chunk /= null loop
|
|
|
457 if Id = C_Id then
|
|
|
458 return Chunk;
|
|
|
459 end if;
|
|
|
460
|
|
|
461 Chunk := Chunk.Next;
|
|
|
462 Id := Id + 1;
|
|
|
463 end loop;
|
|
|
464
|
|
|
465 return null;
|
|
|
466 end Find_Chunk;
|
|
|
467
|
|
|
468 -- Local variables
|
|
|
469
|
|
|
470 Chunk : constant SS_Chunk_Ptr := Find_Chunk;
|
|
|
471
|
|
|
472 -- Start of processing for Get_Chunk_Info
|
|
|
473
|
|
|
474 begin
|
|
|
475 if Chunk = null then
|
|
|
476 return Invalid_Chunk;
|
|
|
477
|
|
|
478 else
|
|
|
479 return (Size => Chunk.Size,
|
|
|
480 Size_Up_To_Chunk => Chunk.Size_Up_To_Chunk);
|
|
|
481 end if;
|
|
|
482 end Get_Chunk_Info;
|
|
|
483
|
|
|
484 --------------------
|
|
|
485 -- Get_Stack_Info --
|
|
|
486 --------------------
|
|
|
487
|
|
|
488 function Get_Stack_Info (Stack : SS_Stack_Ptr) return Stack_Info is
|
|
|
489 Info : Stack_Info;
|
|
|
490
|
|
|
491 begin
|
|
|
492 Info.Default_Chunk_Size := Stack.Default_Chunk_Size;
|
|
|
493 Info.Freeable := Stack.Freeable;
|
|
|
494 Info.High_Water_Mark := Stack.High_Water_Mark;
|
|
|
495 Info.Number_Of_Chunks := Number_Of_Chunks (Stack);
|
|
|
496 Info.Top.Byte := Stack.Top.Byte;
|
|
|
497 Info.Top.Chunk := Top_Chunk_Id (Stack);
|
|
|
498
|
|
|
499 return Info;
|
|
|
500 end Get_Stack_Info;
|
|
|
501
|
|
|
502 ----------------------------
|
|
|
503 -- Has_Enough_Free_Memory --
|
|
|
504 ----------------------------
|
|
|
505
|
|
|
506 function Has_Enough_Free_Memory
|
|
|
507 (Chunk : SS_Chunk_Ptr;
|
|
|
508 Byte : Memory_Index;
|
|
|
509 Mem_Size : Memory_Size) return Boolean
|
|
|
510 is
|
|
|
511 begin
|
|
|
512 -- Byte - 1 denotes the last occupied byte. Subtracting that byte from
|
|
|
513 -- the memory capacity of the chunk yields the size of the free memory
|
|
|
514 -- within the chunk. The chunk can fit the request as long as the free
|
|
|
515 -- memory is as big as the request.
|
|
|
516
|
|
|
517 return Chunk.Size - (Byte - 1) >= Mem_Size;
|
|
|
518 end Has_Enough_Free_Memory;
|
|
|
519
|
|
|
520 ----------------------
|
|
|
521 -- Number_Of_Chunks --
|
|
|
522 ----------------------
|
|
|
523
|
|
|
524 function Number_Of_Chunks (Stack : SS_Stack_Ptr) return Chunk_Count is
|
|
|
525 Chunk : SS_Chunk_Ptr;
|
|
|
526 Count : Chunk_Count;
|
|
|
527
|
|
|
528 begin
|
|
|
529 Chunk := Stack.Static_Chunk'Access;
|
|
|
530 Count := 0;
|
|
|
531 while Chunk /= null loop
|
|
|
532 Chunk := Chunk.Next;
|
|
|
533 Count := Count + 1;
|
|
|
534 end loop;
|
|
|
535
|
|
|
536 return Count;
|
|
|
537 end Number_Of_Chunks;
|
|
|
538
|
|
|
539 ------------------------------
|
|
|
540 -- Size_Up_To_And_Including --
|
|
|
541 ------------------------------
|
|
|
542
|
|
|
543 function Size_Up_To_And_Including
|
|
|
544 (Chunk : SS_Chunk_Ptr) return Memory_Size
|
|
|
545 is
|
|
|
546 begin
|
|
|
547 return Chunk.Size_Up_To_Chunk + Chunk.Size;
|
|
|
548 end Size_Up_To_And_Including;
|
|
111
|
549
|
|
|
550 -----------------
|
|
|
551 -- SS_Allocate --
|
|
|
552 -----------------
|
|
|
553
|
|
|
554 procedure SS_Allocate
|
|
|
555 (Addr : out Address;
|
|
131
|
556 Storage_Size : Storage_Count)
|
|
111
|
557 is
|
|
131
|
558 function Round_Up (Size : Storage_Count) return Memory_Size;
|
|
|
559 pragma Inline (Round_Up);
|
|
|
560 -- Round Size up to the nearest multiple of the maximum alignment
|
|
111
|
561
|
|
131
|
562 --------------
|
|
|
563 -- Round_Up --
|
|
|
564 --------------
|
|
111
|
565
|
|
131
|
566 function Round_Up (Size : Storage_Count) return Memory_Size is
|
|
|
567 Algn_MS : constant Memory_Size := Standard'Maximum_Alignment;
|
|
|
568 Size_MS : constant Memory_Size := Memory_Size (Size);
|
|
111
|
569
|
|
131
|
570 begin
|
|
|
571 -- Detect a case where the Storage_Size is very large and may yield
|
|
|
572 -- a rounded result which is outside the range of Chunk_Memory_Size.
|
|
|
573 -- Treat this case as secondary-stack depletion.
|
|
111
|
574
|
|
131
|
575 if Memory_Size'Last - Algn_MS < Size_MS then
|
|
|
576 raise Storage_Error with "secondary stack exhaused";
|
|
111
|
577 end if;
|
|
|
578
|
|
131
|
579 return ((Size_MS + Algn_MS - 1) / Algn_MS) * Algn_MS;
|
|
|
580 end Round_Up;
|
|
111
|
581
|
|
131
|
582 -- Local variables
|
|
111
|
583
|
|
131
|
584 Stack : constant SS_Stack_Ptr := Get_Sec_Stack.all;
|
|
|
585 Mem_Size : Memory_Size;
|
|
111
|
586
|
|
131
|
587 -- Start of processing for SS_Allocate
|
|
111
|
588
|
|
131
|
589 begin
|
|
|
590 -- It should not be possible to request an allocation of negative or
|
|
|
591 -- zero size.
|
|
111
|
592
|
|
131
|
593 pragma Assert (Storage_Size > 0);
|
|
111
|
594
|
|
131
|
595 -- Round the requested size up to the nearest multiple of the maximum
|
|
|
596 -- alignment to ensure efficient access.
|
|
111
|
597
|
|
131
|
598 Mem_Size := Round_Up (Storage_Size);
|
|
111
|
599
|
|
131
|
600 if Sec_Stack_Dynamic then
|
|
|
601 Allocate_Dynamic (Stack, Mem_Size, Addr);
|
|
|
602 else
|
|
|
603 Allocate_Static (Stack, Mem_Size, Addr);
|
|
111
|
604 end if;
|
|
|
605 end SS_Allocate;
|
|
|
606
|
|
|
607 -------------
|
|
|
608 -- SS_Free --
|
|
|
609 -------------
|
|
|
610
|
|
|
611 procedure SS_Free (Stack : in out SS_Stack_Ptr) is
|
|
131
|
612 Static_Chunk : constant SS_Chunk_Ptr := Stack.Static_Chunk'Access;
|
|
|
613 Next_Chunk : SS_Chunk_Ptr;
|
|
111
|
614
|
|
131
|
615 begin
|
|
|
616 -- Free all dynamically allocated chunks. The first dynamic chunk is
|
|
|
617 -- found immediately after the static chunk of the stack.
|
|
111
|
618
|
|
131
|
619 while Static_Chunk.Next /= null loop
|
|
|
620 Next_Chunk := Static_Chunk.Next.Next;
|
|
|
621 Free (Static_Chunk.Next);
|
|
|
622 Static_Chunk.Next := Next_Chunk;
|
|
|
623 end loop;
|
|
111
|
624
|
|
131
|
625 -- At this point one of the following outcomes has taken place:
|
|
|
626 --
|
|
|
627 -- * The stack lacks any dynamic chunks
|
|
|
628 --
|
|
|
629 -- * The stack had dynamic chunks which were all freed
|
|
|
630 --
|
|
|
631 -- Either way, there should be nothing hanging off the static chunk
|
|
111
|
632
|
|
131
|
633 pragma Assert (Static_Chunk.Next = null);
|
|
|
634
|
|
|
635 -- Free the stack only when it was dynamically allocated
|
|
111
|
636
|
|
|
637 if Stack.Freeable then
|
|
|
638 Free (Stack);
|
|
|
639 end if;
|
|
|
640 end SS_Free;
|
|
|
641
|
|
|
642 ----------------
|
|
|
643 -- SS_Get_Max --
|
|
|
644 ----------------
|
|
|
645
|
|
|
646 function SS_Get_Max return Long_Long_Integer is
|
|
131
|
647 Stack : constant SS_Stack_Ptr := Get_Sec_Stack.all;
|
|
|
648
|
|
111
|
649 begin
|
|
131
|
650 return Long_Long_Integer (Stack.High_Water_Mark);
|
|
111
|
651 end SS_Get_Max;
|
|
|
652
|
|
|
653 -------------
|
|
|
654 -- SS_Info --
|
|
|
655 -------------
|
|
|
656
|
|
|
657 procedure SS_Info is
|
|
131
|
658 procedure SS_Info_Dynamic (Stack : SS_Stack_Ptr);
|
|
|
659 pragma Inline (SS_Info_Dynamic);
|
|
|
660 -- Output relevant information concerning dynamic secondary stack Stack
|
|
|
661
|
|
|
662 function Total_Memory_Size (Stack : SS_Stack_Ptr) return Memory_Size;
|
|
|
663 pragma Inline (Total_Memory_Size);
|
|
|
664 -- Calculate the size of stack Stack's total memory usage. This includes
|
|
|
665 -- the following kinds of memory:
|
|
|
666 --
|
|
|
667 -- * Free memory in used chunks due to alignment holes
|
|
|
668 -- * Free memory in the topmost chunk due to partial usage
|
|
|
669 -- * Free memory in unused chunks following the chunk indicated by the
|
|
|
670 -- stack pointer.
|
|
|
671 -- * Memory occupied by allocations
|
|
|
672 --
|
|
|
673 -- This is a linear-time operation on the number of chunks.
|
|
|
674
|
|
|
675 ---------------------
|
|
|
676 -- SS_Info_Dynamic --
|
|
|
677 ---------------------
|
|
|
678
|
|
|
679 procedure SS_Info_Dynamic (Stack : SS_Stack_Ptr) is
|
|
|
680 begin
|
|
|
681 Put_Line
|
|
|
682 (" Number of Chunks : " & Number_Of_Chunks (Stack)'Img);
|
|
|
683
|
|
|
684 Put_Line
|
|
|
685 (" Default size of Chunks : " & Stack.Default_Chunk_Size'Img);
|
|
|
686 end SS_Info_Dynamic;
|
|
|
687
|
|
|
688 -----------------------
|
|
|
689 -- Total_Memory_Size --
|
|
|
690 -----------------------
|
|
|
691
|
|
|
692 function Total_Memory_Size (Stack : SS_Stack_Ptr) return Memory_Size is
|
|
|
693 Chunk : SS_Chunk_Ptr;
|
|
|
694 Total : Memory_Size;
|
|
|
695
|
|
|
696 begin
|
|
|
697 -- The total size of the stack is equal to the size of the stack up
|
|
|
698 -- to the chunk indicated by the stack pointer, plus the size of the
|
|
|
699 -- indicated chunk, plus the size of any subsequent chunks.
|
|
|
700
|
|
|
701 Total := Size_Up_To_And_Including (Stack.Top.Chunk);
|
|
|
702
|
|
|
703 Chunk := Stack.Top.Chunk.Next;
|
|
|
704 while Chunk /= null loop
|
|
|
705 Total := Total + Chunk.Size;
|
|
|
706 Chunk := Chunk.Next;
|
|
|
707 end loop;
|
|
|
708
|
|
|
709 return Total;
|
|
|
710 end Total_Memory_Size;
|
|
|
711
|
|
|
712 -- Local variables
|
|
|
713
|
|
|
714 Stack : constant SS_Stack_Ptr := Get_Sec_Stack.all;
|
|
|
715
|
|
|
716 -- Start of processing for SS_Info
|
|
|
717
|
|
111
|
718 begin
|
|
|
719 Put_Line ("Secondary Stack information:");
|
|
|
720
|
|
131
|
721 Put_Line
|
|
|
722 (" Total size : "
|
|
|
723 & Total_Memory_Size (Stack)'Img
|
|
|
724 & " bytes");
|
|
111
|
725
|
|
131
|
726 Put_Line
|
|
|
727 (" Current allocated space : "
|
|
|
728 & Used_Memory_Size (Stack)'Img
|
|
|
729 & " bytes");
|
|
111
|
730
|
|
131
|
731 if Sec_Stack_Dynamic then
|
|
|
732 SS_Info_Dynamic (Stack);
|
|
111
|
733 end if;
|
|
|
734 end SS_Info;
|
|
|
735
|
|
|
736 -------------
|
|
|
737 -- SS_Init --
|
|
|
738 -------------
|
|
|
739
|
|
|
740 procedure SS_Init
|
|
|
741 (Stack : in out SS_Stack_Ptr;
|
|
131
|
742 Size : Size_Type := Unspecified_Size)
|
|
111
|
743 is
|
|
131
|
744 function Next_Available_Binder_Sec_Stack return SS_Stack_Ptr;
|
|
|
745 pragma Inline (Next_Available_Binder_Sec_Stack);
|
|
|
746 -- Return a pointer to the next available stack from the pool created by
|
|
|
747 -- the binder. This routine updates global Default_Sec_Stack_Pool_Index.
|
|
|
748
|
|
|
749 -------------------------------------
|
|
|
750 -- Next_Available_Binder_Sec_Stack --
|
|
|
751 -------------------------------------
|
|
|
752
|
|
|
753 function Next_Available_Binder_Sec_Stack return SS_Stack_Ptr is
|
|
|
754
|
|
|
755 -- The default-sized secondary stack pool generated by the binder
|
|
|
756 -- is passed to this unit as an Address because it is not possible
|
|
|
757 -- to define a pointer to an array of unconstrained components. The
|
|
|
758 -- pointer is instead obtained using an unchecked conversion to a
|
|
|
759 -- constrained array of secondary stacks with the same size as that
|
|
|
760 -- specified by the binder.
|
|
|
761
|
|
|
762 -- WARNING: The following data structure must be synchronized with
|
|
|
763 -- the one created in Bindgen.Gen_Output_File_Ada. The version in
|
|
|
764 -- bindgen is called Sec_Default_Sized_Stacks.
|
|
|
765
|
|
|
766 type SS_Pool is
|
|
|
767 array (1 .. Binder_SS_Count)
|
|
|
768 of aliased SS_Stack (Binder_Default_SS_Size);
|
|
|
769
|
|
|
770 type SS_Pool_Ptr is access SS_Pool;
|
|
|
771 -- A reference to the secondary stack pool
|
|
|
772
|
|
|
773 function To_SS_Pool_Ptr is
|
|
|
774 new Ada.Unchecked_Conversion (Address, SS_Pool_Ptr);
|
|
111
|
775
|
|
131
|
776 -- Use an unchecked conversion to obtain a pointer to one of the
|
|
|
777 -- secondary stacks from the pool generated by the binder. There
|
|
|
778 -- are several reasons for using the conversion:
|
|
|
779 --
|
|
|
780 -- * Accessibility checks prevent a value of a local pointer to be
|
|
|
781 -- stored outside this scope. The conversion is safe because the
|
|
|
782 -- pool is global to the whole application.
|
|
|
783 --
|
|
|
784 -- * Unchecked_Access may circumvent the accessibility checks, but
|
|
|
785 -- it is incompatible with restriction No_Unchecked_Access.
|
|
|
786 --
|
|
|
787 -- * Unrestricted_Access may circumvent the accessibility checks,
|
|
|
788 -- but it is incompatible with pure Ada constructs.
|
|
|
789 -- ??? cannot find the restriction or switch
|
|
|
790
|
|
|
791 pragma Warnings (Off);
|
|
|
792 function To_SS_Stack_Ptr is
|
|
|
793 new Ada.Unchecked_Conversion (Address, SS_Stack_Ptr);
|
|
|
794 pragma Warnings (On);
|
|
|
795
|
|
|
796 Pool : SS_Pool_Ptr;
|
|
|
797
|
|
|
798 begin
|
|
|
799 -- Obtain a typed view of the pool
|
|
|
800
|
|
|
801 Pool := To_SS_Pool_Ptr (Binder_Default_SS_Pool);
|
|
|
802
|
|
|
803 -- Advance the stack index to the next available stack
|
|
|
804
|
|
|
805 Binder_Default_SS_Pool_Index := Binder_Default_SS_Pool_Index + 1;
|
|
|
806
|
|
|
807 -- Return a pointer to the next available stack
|
|
|
808
|
|
|
809 return To_SS_Stack_Ptr (Pool (Binder_Default_SS_Pool_Index)'Address);
|
|
|
810 end Next_Available_Binder_Sec_Stack;
|
|
|
811
|
|
|
812 -- Local variables
|
|
|
813
|
|
|
814 Stack_Size : Memory_Size_With_Invalid;
|
|
|
815
|
|
|
816 -- Start of processing for SS_Init
|
|
|
817
|
|
111
|
818 begin
|
|
131
|
819 -- Allocate a new stack on the heap or use one from the pool created by
|
|
|
820 -- the binder.
|
|
111
|
821
|
|
|
822 if Stack = null then
|
|
131
|
823
|
|
|
824 -- The caller requested a pool-allocated stack. Determine the proper
|
|
|
825 -- size of the stack based on input from the binder or the runtime in
|
|
|
826 -- case the pool is exhausted.
|
|
|
827
|
|
111
|
828 if Size = Unspecified_Size then
|
|
131
|
829
|
|
|
830 -- Use the default secondary stack size as specified by the binder
|
|
|
831 -- only when it has been set. This prevents a bootstrap issue with
|
|
|
832 -- older compilers where the size is never set.
|
|
|
833
|
|
|
834 if Binder_Default_SS_Size > 0 then
|
|
|
835 Stack_Size := Binder_Default_SS_Size;
|
|
|
836
|
|
|
837 -- Otherwise use the default stack size of the particular runtime
|
|
|
838
|
|
|
839 else
|
|
|
840 Stack_Size := Runtime_Default_Sec_Stack_Size;
|
|
|
841 end if;
|
|
|
842
|
|
|
843 -- Otherwise the caller requested a heap-allocated stack. Use the
|
|
|
844 -- specified size directly.
|
|
|
845
|
|
111
|
846 else
|
|
|
847 Stack_Size := Size;
|
|
|
848 end if;
|
|
|
849
|
|
131
|
850 -- The caller requested a pool-allocated stack. Use one as long as
|
|
|
851 -- the pool created by the binder has available stacks. This stack
|
|
|
852 -- cannot be deallocated.
|
|
|
853
|
|
111
|
854 if Size = Unspecified_Size
|
|
|
855 and then Binder_SS_Count > 0
|
|
131
|
856 and then Binder_Default_SS_Pool_Index < Binder_SS_Count
|
|
111
|
857 then
|
|
131
|
858 Stack := Next_Available_Binder_Sec_Stack;
|
|
|
859 Stack.Freeable := False;
|
|
111
|
860
|
|
131
|
861 -- Otherwise the caller requested a heap-allocated stack, or the pool
|
|
|
862 -- created by the binder ran out of available stacks. This stack can
|
|
|
863 -- be deallocated.
|
|
111
|
864
|
|
131
|
865 else
|
|
|
866 -- It should not be possible to create a stack with a negative
|
|
|
867 -- default chunk size.
|
|
111
|
868
|
|
131
|
869 pragma Assert (Stack_Size in Memory_Size);
|
|
111
|
870
|
|
|
871 Stack := new SS_Stack (Stack_Size);
|
|
|
872 Stack.Freeable := True;
|
|
|
873 end if;
|
|
131
|
874
|
|
|
875 -- Otherwise the stack was already created either by the compiler or by
|
|
|
876 -- the user, and is about to be reused.
|
|
|
877
|
|
|
878 else
|
|
|
879 null;
|
|
111
|
880 end if;
|
|
|
881
|
|
131
|
882 -- The static chunk becomes the chunk indicated by the stack pointer.
|
|
|
883 -- Note that the stack may still hold dynamic chunks, which in turn may
|
|
|
884 -- be reused or freed.
|
|
|
885
|
|
|
886 Stack.Top.Chunk := Stack.Static_Chunk'Access;
|
|
|
887
|
|
|
888 -- The first free byte is the first free byte of the chunk indicated by
|
|
|
889 -- the stack pointer.
|
|
|
890
|
|
|
891 Stack.Top.Byte := Stack.Top.Chunk.Memory'First;
|
|
|
892
|
|
|
893 -- Since the chunk indicated by the stack pointer is also the first
|
|
|
894 -- chunk in the stack, there are no prior chunks, therefore the size
|
|
|
895 -- of the stack up to the chunk is zero.
|
|
|
896
|
|
|
897 Stack.Top.Chunk.Size_Up_To_Chunk := 0;
|
|
|
898
|
|
|
899 -- Reset the high water mark to account for brand new allocations
|
|
|
900
|
|
|
901 Stack.High_Water_Mark := 0;
|
|
111
|
902 end SS_Init;
|
|
|
903
|
|
|
904 -------------
|
|
|
905 -- SS_Mark --
|
|
|
906 -------------
|
|
|
907
|
|
|
908 function SS_Mark return Mark_Id is
|
|
131
|
909 Stack : constant SS_Stack_Ptr := Get_Sec_Stack.all;
|
|
|
910
|
|
111
|
911 begin
|
|
131
|
912 return (Stack => Stack, Top => Stack.Top);
|
|
111
|
913 end SS_Mark;
|
|
|
914
|
|
|
915 ----------------
|
|
|
916 -- SS_Release --
|
|
|
917 ----------------
|
|
|
918
|
|
|
919 procedure SS_Release (M : Mark_Id) is
|
|
|
920 begin
|
|
131
|
921 M.Stack.Top := M.Top;
|
|
111
|
922 end SS_Release;
|
|
|
923
|
|
131
|
924 ------------------
|
|
|
925 -- Top_Chunk_Id --
|
|
|
926 ------------------
|
|
|
927
|
|
|
928 function Top_Chunk_Id (Stack : SS_Stack_Ptr) return Chunk_Id_With_Invalid is
|
|
|
929 Chunk : SS_Chunk_Ptr;
|
|
|
930 Id : Chunk_Id;
|
|
|
931
|
|
|
932 begin
|
|
|
933 Chunk := Stack.Static_Chunk'Access;
|
|
|
934 Id := 1;
|
|
|
935 while Chunk /= null loop
|
|
|
936 if Chunk = Stack.Top.Chunk then
|
|
|
937 return Id;
|
|
|
938 end if;
|
|
|
939
|
|
|
940 Chunk := Chunk.Next;
|
|
|
941 Id := Id + 1;
|
|
|
942 end loop;
|
|
|
943
|
|
|
944 return Invalid_Chunk_Id;
|
|
|
945 end Top_Chunk_Id;
|
|
|
946
|
|
|
947 ----------------------
|
|
|
948 -- Used_Memory_Size --
|
|
|
949 ----------------------
|
|
|
950
|
|
|
951 function Used_Memory_Size (Stack : SS_Stack_Ptr) return Memory_Size is
|
|
|
952 begin
|
|
|
953 -- The size of the occupied memory is equal to the size up to the chunk
|
|
|
954 -- indicated by the stack pointer, plus the size in use by the indicated
|
|
|
955 -- chunk itself. Top.Byte - 1 is the last occupied byte.
|
|
|
956 --
|
|
|
957 -- Top.Byte
|
|
|
958 -- |
|
|
|
959 -- . . . . . . . +--------------|----+
|
|
|
960 -- . ..> |##############| |
|
|
|
961 -- . . . . . . . +-------------------+
|
|
|
962 -- | |
|
|
|
963 -- -------------------+-------------+
|
|
|
964 -- Size_Up_To_Chunk size in use
|
|
|
965
|
|
|
966 -- ??? this calculation may overflow on 32bit targets
|
|
|
967
|
|
|
968 return Stack.Top.Chunk.Size_Up_To_Chunk + Stack.Top.Byte - 1;
|
|
|
969 end Used_Memory_Size;
|
|
|
970
|
|
111
|
971 end System.Secondary_Stack;
|
