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-2013, 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 System.Soft_Links; 35with System.Parameters; 36 37with Ada.Unchecked_Conversion; 38with Ada.Unchecked_Deallocation; 39 40package body System.Secondary_Stack is 41 42 package SSL renames System.Soft_Links; 43 44 use type SSE.Storage_Offset; 45 use type System.Parameters.Size_Type; 46 47 SS_Ratio_Dynamic : constant Boolean := 48 Parameters.Sec_Stack_Percentage = Parameters.Dynamic; 49 -- There are two entirely different implementations of the secondary 50 -- stack mechanism in this unit, and this Boolean is used to select 51 -- between them (at compile time, so the generated code will contain 52 -- only the code for the desired variant). If SS_Ratio_Dynamic is 53 -- True, then the secondary stack is dynamically allocated from the 54 -- heap in a linked list of chunks. If SS_Ration_Dynamic is False, 55 -- then the secondary stack is allocated statically by grabbing a 56 -- section of the primary stack and using it for this purpose. 57 58 type Memory is array (SS_Ptr range <>) of SSE.Storage_Element; 59 for Memory'Alignment use Standard'Maximum_Alignment; 60 -- This is the type used for actual allocation of secondary stack 61 -- areas. We require maximum alignment for all such allocations. 62 63 --------------------------------------------------------------- 64 -- Data Structures for Dynamically Allocated Secondary Stack -- 65 --------------------------------------------------------------- 66 67 -- The following is a diagram of the data structures used for the 68 -- case of a dynamically allocated secondary stack, where the stack 69 -- is allocated as a linked list of chunks allocated from the heap. 70 71 -- +------------------+ 72 -- | Next | 73 -- +------------------+ 74 -- | | Last (200) 75 -- | | 76 -- | | 77 -- | | 78 -- | | 79 -- | | 80 -- | | First (101) 81 -- +------------------+ 82 -- +----------> | | | 83 -- | +----------+-------+ 84 -- | | | 85 -- | ^ V 86 -- | | | 87 -- | +-------+----------+ 88 -- | | | | 89 -- | +------------------+ 90 -- | | | Last (100) 91 -- | | C | 92 -- | | H | 93 -- +-----------------+ | +-------->| U | 94 -- | Current_Chunk -|--+ | | N | 95 -- +-----------------+ | | K | 96 -- | Top -|-----+ | | First (1) 97 -- +-----------------+ +------------------+ 98 -- | Default_Size | | Prev | 99 -- +-----------------+ +------------------+ 100 -- 101 102 type Chunk_Id (First, Last : SS_Ptr); 103 type Chunk_Ptr is access all Chunk_Id; 104 105 type Chunk_Id (First, Last : SS_Ptr) is record 106 Prev, Next : Chunk_Ptr; 107 Mem : Memory (First .. Last); 108 end record; 109 110 type Stack_Id is record 111 Top : SS_Ptr; 112 Default_Size : SSE.Storage_Count; 113 Current_Chunk : Chunk_Ptr; 114 end record; 115 116 type Stack_Ptr is access Stack_Id; 117 -- Pointer to record used to represent a dynamically allocated secondary 118 -- stack descriptor for a secondary stack chunk. 119 120 procedure Free is new Ada.Unchecked_Deallocation (Chunk_Id, Chunk_Ptr); 121 -- Free a dynamically allocated chunk 122 123 function To_Stack_Ptr is new 124 Ada.Unchecked_Conversion (Address, Stack_Ptr); 125 function To_Addr is new 126 Ada.Unchecked_Conversion (Stack_Ptr, Address); 127 -- Convert to and from address stored in task data structures 128 129 -------------------------------------------------------------- 130 -- Data Structures for Statically Allocated Secondary Stack -- 131 -------------------------------------------------------------- 132 133 -- For the static case, the secondary stack is a single contiguous 134 -- chunk of storage, carved out of the primary stack, and represented 135 -- by the following data structure 136 137 type Fixed_Stack_Id is record 138 Top : SS_Ptr; 139 -- Index of next available location in Mem. This is initialized to 140 -- 0, and then incremented on Allocate, and Decremented on Release. 141 142 Last : SS_Ptr; 143 -- Length of usable Mem array, which is thus the index past the 144 -- last available location in Mem. Mem (Last-1) can be used. This 145 -- is used to check that the stack does not overflow. 146 147 Max : SS_Ptr; 148 -- Maximum value of Top. Initialized to 0, and then may be incremented 149 -- on Allocate, but is never Decremented. The last used location will 150 -- be Mem (Max - 1), so Max is the maximum count of used stack space. 151 152 Mem : Memory (0 .. 0); 153 -- This is the area that is actually used for the secondary stack. 154 -- Note that the upper bound is a dummy value properly defined by 155 -- the value of Last. We never actually allocate objects of type 156 -- Fixed_Stack_Id, so the bounds declared here do not matter. 157 end record; 158 159 Dummy_Fixed_Stack : Fixed_Stack_Id; 160 pragma Warnings (Off, Dummy_Fixed_Stack); 161 -- Well it is not quite true that we never allocate an object of the 162 -- type. This dummy object is allocated for the purpose of getting the 163 -- offset of the Mem field via the 'Position attribute (such a nuisance 164 -- that we cannot apply this to a field of a type). 165 166 type Fixed_Stack_Ptr is access Fixed_Stack_Id; 167 -- Pointer to record used to describe statically allocated sec stack 168 169 function To_Fixed_Stack_Ptr is new 170 Ada.Unchecked_Conversion (Address, Fixed_Stack_Ptr); 171 -- Convert from address stored in task data structures 172 173 -------------- 174 -- Allocate -- 175 -------------- 176 177 procedure SS_Allocate 178 (Addr : out Address; 179 Storage_Size : SSE.Storage_Count) 180 is 181 Max_Align : constant SS_Ptr := SS_Ptr (Standard'Maximum_Alignment); 182 Max_Size : constant SS_Ptr := 183 ((SS_Ptr (Storage_Size) + Max_Align - 1) / Max_Align) 184 * Max_Align; 185 186 begin 187 -- Case of fixed allocation secondary stack 188 189 if not SS_Ratio_Dynamic then 190 declare 191 Fixed_Stack : constant Fixed_Stack_Ptr := 192 To_Fixed_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all); 193 194 begin 195 -- Check if max stack usage is increasing 196 197 if Fixed_Stack.Top + Max_Size > Fixed_Stack.Max then 198 199 -- If so, check if max size is exceeded 200 201 if Fixed_Stack.Top + Max_Size > Fixed_Stack.Last then 202 raise Storage_Error; 203 end if; 204 205 -- Record new max usage 206 207 Fixed_Stack.Max := Fixed_Stack.Top + Max_Size; 208 end if; 209 210 -- Set resulting address and update top of stack pointer 211 212 Addr := Fixed_Stack.Mem (Fixed_Stack.Top)'Address; 213 Fixed_Stack.Top := Fixed_Stack.Top + Max_Size; 214 end; 215 216 -- Case of dynamically allocated secondary stack 217 218 else 219 declare 220 Stack : constant Stack_Ptr := 221 To_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all); 222 Chunk : Chunk_Ptr; 223 224 To_Be_Released_Chunk : Chunk_Ptr; 225 226 begin 227 Chunk := Stack.Current_Chunk; 228 229 -- The Current_Chunk may not be the good one if a lot of release 230 -- operations have taken place. So go down the stack if necessary 231 232 while Chunk.First > Stack.Top loop 233 Chunk := Chunk.Prev; 234 end loop; 235 236 -- Find out if the available memory in the current chunk is 237 -- sufficient, if not, go to the next one and eventually create 238 -- the necessary room. 239 240 while Chunk.Last - Stack.Top + 1 < Max_Size loop 241 if Chunk.Next /= null then 242 243 -- Release unused non-first empty chunk 244 245 if Chunk.Prev /= null and then Chunk.First = Stack.Top then 246 To_Be_Released_Chunk := Chunk; 247 Chunk := Chunk.Prev; 248 Chunk.Next := To_Be_Released_Chunk.Next; 249 To_Be_Released_Chunk.Next.Prev := Chunk; 250 Free (To_Be_Released_Chunk); 251 end if; 252 253 -- Create new chunk of default size unless it is not 254 -- sufficient to satisfy the current request. 255 256 elsif SSE.Storage_Count (Max_Size) <= Stack.Default_Size then 257 Chunk.Next := 258 new Chunk_Id 259 (First => Chunk.Last + 1, 260 Last => Chunk.Last + SS_Ptr (Stack.Default_Size)); 261 262 Chunk.Next.Prev := Chunk; 263 264 -- Otherwise create new chunk of requested size 265 266 else 267 Chunk.Next := 268 new Chunk_Id 269 (First => Chunk.Last + 1, 270 Last => Chunk.Last + Max_Size); 271 272 Chunk.Next.Prev := Chunk; 273 end if; 274 275 Chunk := Chunk.Next; 276 Stack.Top := Chunk.First; 277 end loop; 278 279 -- Resulting address is the address pointed by Stack.Top 280 281 Addr := Chunk.Mem (Stack.Top)'Address; 282 Stack.Top := Stack.Top + Max_Size; 283 Stack.Current_Chunk := Chunk; 284 end; 285 end if; 286 end SS_Allocate; 287 288 ------------- 289 -- SS_Free -- 290 ------------- 291 292 procedure SS_Free (Stk : in out Address) is 293 begin 294 -- Case of statically allocated secondary stack, nothing to free 295 296 if not SS_Ratio_Dynamic then 297 return; 298 299 -- Case of dynamically allocated secondary stack 300 301 else 302 declare 303 Stack : Stack_Ptr := To_Stack_Ptr (Stk); 304 Chunk : Chunk_Ptr; 305 306 procedure Free is 307 new Ada.Unchecked_Deallocation (Stack_Id, Stack_Ptr); 308 309 begin 310 Chunk := Stack.Current_Chunk; 311 312 while Chunk.Prev /= null loop 313 Chunk := Chunk.Prev; 314 end loop; 315 316 while Chunk.Next /= null loop 317 Chunk := Chunk.Next; 318 Free (Chunk.Prev); 319 end loop; 320 321 Free (Chunk); 322 Free (Stack); 323 Stk := Null_Address; 324 end; 325 end if; 326 end SS_Free; 327 328 ---------------- 329 -- SS_Get_Max -- 330 ---------------- 331 332 function SS_Get_Max return Long_Long_Integer is 333 begin 334 if SS_Ratio_Dynamic then 335 return -1; 336 else 337 declare 338 Fixed_Stack : constant Fixed_Stack_Ptr := 339 To_Fixed_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all); 340 begin 341 return Long_Long_Integer (Fixed_Stack.Max); 342 end; 343 end if; 344 end SS_Get_Max; 345 346 ------------- 347 -- SS_Info -- 348 ------------- 349 350 procedure SS_Info is 351 begin 352 Put_Line ("Secondary Stack information:"); 353 354 -- Case of fixed secondary stack 355 356 if not SS_Ratio_Dynamic then 357 declare 358 Fixed_Stack : constant Fixed_Stack_Ptr := 359 To_Fixed_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all); 360 361 begin 362 Put_Line ( 363 " Total size : " 364 & SS_Ptr'Image (Fixed_Stack.Last) 365 & " bytes"); 366 367 Put_Line ( 368 " Current allocated space : " 369 & SS_Ptr'Image (Fixed_Stack.Top - 1) 370 & " bytes"); 371 end; 372 373 -- Case of dynamically allocated secondary stack 374 375 else 376 declare 377 Stack : constant Stack_Ptr := 378 To_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all); 379 Nb_Chunks : Integer := 1; 380 Chunk : Chunk_Ptr := Stack.Current_Chunk; 381 382 begin 383 while Chunk.Prev /= null loop 384 Chunk := Chunk.Prev; 385 end loop; 386 387 while Chunk.Next /= null loop 388 Nb_Chunks := Nb_Chunks + 1; 389 Chunk := Chunk.Next; 390 end loop; 391 392 -- Current Chunk information 393 394 Put_Line ( 395 " Total size : " 396 & SS_Ptr'Image (Chunk.Last) 397 & " bytes"); 398 399 Put_Line ( 400 " Current allocated space : " 401 & SS_Ptr'Image (Stack.Top - 1) 402 & " bytes"); 403 404 Put_Line ( 405 " Number of Chunks : " 406 & Integer'Image (Nb_Chunks)); 407 408 Put_Line ( 409 " Default size of Chunks : " 410 & SSE.Storage_Count'Image (Stack.Default_Size)); 411 end; 412 end if; 413 end SS_Info; 414 415 ------------- 416 -- SS_Init -- 417 ------------- 418 419 procedure SS_Init 420 (Stk : in out Address; 421 Size : Natural := Default_Secondary_Stack_Size) 422 is 423 begin 424 -- Case of fixed size secondary stack 425 426 if not SS_Ratio_Dynamic then 427 declare 428 Fixed_Stack : constant Fixed_Stack_Ptr := 429 To_Fixed_Stack_Ptr (Stk); 430 431 begin 432 Fixed_Stack.Top := 0; 433 Fixed_Stack.Max := 0; 434 435 if Size < Dummy_Fixed_Stack.Mem'Position then 436 Fixed_Stack.Last := 0; 437 else 438 Fixed_Stack.Last := 439 SS_Ptr (Size) - Dummy_Fixed_Stack.Mem'Position; 440 end if; 441 end; 442 443 -- Case of dynamically allocated secondary stack 444 445 else 446 declare 447 Stack : Stack_Ptr; 448 begin 449 Stack := new Stack_Id; 450 Stack.Current_Chunk := new Chunk_Id (1, SS_Ptr (Size)); 451 Stack.Top := 1; 452 Stack.Default_Size := SSE.Storage_Count (Size); 453 Stk := To_Addr (Stack); 454 end; 455 end if; 456 end SS_Init; 457 458 ------------- 459 -- SS_Mark -- 460 ------------- 461 462 function SS_Mark return Mark_Id is 463 Sstk : constant System.Address := SSL.Get_Sec_Stack_Addr.all; 464 begin 465 if SS_Ratio_Dynamic then 466 return (Sstk => Sstk, Sptr => To_Stack_Ptr (Sstk).Top); 467 else 468 return (Sstk => Sstk, Sptr => To_Fixed_Stack_Ptr (Sstk).Top); 469 end if; 470 end SS_Mark; 471 472 ---------------- 473 -- SS_Release -- 474 ---------------- 475 476 procedure SS_Release (M : Mark_Id) is 477 begin 478 if SS_Ratio_Dynamic then 479 To_Stack_Ptr (M.Sstk).Top := M.Sptr; 480 else 481 To_Fixed_Stack_Ptr (M.Sstk).Top := M.Sptr; 482 end if; 483 end SS_Release; 484 485 ------------------------- 486 -- Package Elaboration -- 487 ------------------------- 488 489 -- Allocate a secondary stack for the main program to use 490 491 -- We make sure that the stack has maximum alignment. Some systems require 492 -- this (e.g. Sparc), and in any case it is a good idea for efficiency. 493 494 Stack : aliased Stack_Id; 495 for Stack'Alignment use Standard'Maximum_Alignment; 496 497 Static_Secondary_Stack_Size : constant := 10 * 1024; 498 -- Static_Secondary_Stack_Size must be static so that Chunk is allocated 499 -- statically, and not via dynamic memory allocation. 500 501 Chunk : aliased Chunk_Id (1, Static_Secondary_Stack_Size); 502 for Chunk'Alignment use Standard'Maximum_Alignment; 503 -- Default chunk used, unless gnatbind -D is specified with a value 504 -- greater than Static_Secondary_Stack_Size 505 506begin 507 declare 508 Chunk_Address : Address; 509 Chunk_Access : Chunk_Ptr; 510 511 begin 512 if Default_Secondary_Stack_Size <= Static_Secondary_Stack_Size then 513 514 -- Normally we allocate the secondary stack for the main program 515 -- statically, using the default secondary stack size. 516 517 Chunk_Access := Chunk'Access; 518 519 else 520 -- Default_Secondary_Stack_Size was increased via gnatbind -D, so we 521 -- need to allocate a chunk dynamically. 522 523 Chunk_Access := 524 new Chunk_Id (1, SS_Ptr (Default_Secondary_Stack_Size)); 525 end if; 526 527 if SS_Ratio_Dynamic then 528 Stack.Top := 1; 529 Stack.Current_Chunk := Chunk_Access; 530 Stack.Default_Size := 531 SSE.Storage_Offset (Default_Secondary_Stack_Size); 532 System.Soft_Links.Set_Sec_Stack_Addr_NT (Stack'Address); 533 534 else 535 Chunk_Address := Chunk_Access.all'Address; 536 SS_Init (Chunk_Address, Default_Secondary_Stack_Size); 537 System.Soft_Links.Set_Sec_Stack_Addr_NT (Chunk_Address); 538 end if; 539 end; 540end System.Secondary_Stack; 541