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-- -- 9-- Copyright (C) 1992-2019, 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 32pragma Compiler_Unit_Warning; 33 34with Ada.Unchecked_Conversion; 35with Ada.Unchecked_Deallocation; 36 37with System; use System; 38with System.Parameters; use System.Parameters; 39with System.Soft_Links; use System.Soft_Links; 40with System.Storage_Elements; use System.Storage_Elements; 41 42package body System.Secondary_Stack is 43 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); 294 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. 414 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; 549 550 ----------------- 551 -- SS_Allocate -- 552 ----------------- 553 554 procedure SS_Allocate 555 (Addr : out Address; 556 Storage_Size : Storage_Count) 557 is 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 561 562 -------------- 563 -- Round_Up -- 564 -------------- 565 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); 569 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. 574 575 if Memory_Size'Last - Algn_MS < Size_MS then 576 raise Storage_Error with "secondary stack exhaused"; 577 end if; 578 579 return ((Size_MS + Algn_MS - 1) / Algn_MS) * Algn_MS; 580 end Round_Up; 581 582 -- Local variables 583 584 Stack : constant SS_Stack_Ptr := Get_Sec_Stack.all; 585 Mem_Size : Memory_Size; 586 587 -- Start of processing for SS_Allocate 588 589 begin 590 -- It should not be possible to request an allocation of negative or 591 -- zero size. 592 593 pragma Assert (Storage_Size > 0); 594 595 -- Round the requested size up to the nearest multiple of the maximum 596 -- alignment to ensure efficient access. 597 598 Mem_Size := Round_Up (Storage_Size); 599 600 if Sec_Stack_Dynamic then 601 Allocate_Dynamic (Stack, Mem_Size, Addr); 602 else 603 Allocate_Static (Stack, Mem_Size, Addr); 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 612 Static_Chunk : constant SS_Chunk_Ptr := Stack.Static_Chunk'Access; 613 Next_Chunk : SS_Chunk_Ptr; 614 615 begin 616 -- Free all dynamically allocated chunks. The first dynamic chunk is 617 -- found immediately after the static chunk of the stack. 618 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; 624 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 632 633 pragma Assert (Static_Chunk.Next = null); 634 635 -- Free the stack only when it was dynamically allocated 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 647 Stack : constant SS_Stack_Ptr := Get_Sec_Stack.all; 648 649 begin 650 return Long_Long_Integer (Stack.High_Water_Mark); 651 end SS_Get_Max; 652 653 ------------- 654 -- SS_Info -- 655 ------------- 656 657 procedure SS_Info is 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 718 begin 719 Put_Line ("Secondary Stack information:"); 720 721 Put_Line 722 (" Total size : " 723 & Total_Memory_Size (Stack)'Img 724 & " bytes"); 725 726 Put_Line 727 (" Current allocated space : " 728 & Used_Memory_Size (Stack)'Img 729 & " bytes"); 730 731 if Sec_Stack_Dynamic then 732 SS_Info_Dynamic (Stack); 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; 742 Size : Size_Type := Unspecified_Size) 743 is 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); 775 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 818 begin 819 -- Allocate a new stack on the heap or use one from the pool created by 820 -- the binder. 821 822 if Stack = null then 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 828 if Size = Unspecified_Size then 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 846 else 847 Stack_Size := Size; 848 end if; 849 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 854 if Size = Unspecified_Size 855 and then Binder_SS_Count > 0 856 and then Binder_Default_SS_Pool_Index < Binder_SS_Count 857 then 858 Stack := Next_Available_Binder_Sec_Stack; 859 Stack.Freeable := False; 860 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. 864 865 else 866 -- It should not be possible to create a stack with a negative 867 -- default chunk size. 868 869 pragma Assert (Stack_Size in Memory_Size); 870 871 Stack := new SS_Stack (Stack_Size); 872 Stack.Freeable := True; 873 end if; 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; 880 end if; 881 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; 902 end SS_Init; 903 904 ------------- 905 -- SS_Mark -- 906 ------------- 907 908 function SS_Mark return Mark_Id is 909 Stack : constant SS_Stack_Ptr := Get_Sec_Stack.all; 910 911 begin 912 return (Stack => Stack, Top => Stack.Top); 913 end SS_Mark; 914 915 ---------------- 916 -- SS_Release -- 917 ---------------- 918 919 procedure SS_Release (M : Mark_Id) is 920 begin 921 M.Stack.Top := M.Top; 922 end SS_Release; 923 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 971end System.Secondary_Stack; 972