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-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 32pragma Compiler_Unit_Warning; 33 34with Ada.Unchecked_Conversion; 35with Ada.Unchecked_Deallocation; 36with System.Soft_Links; 37 38package body System.Secondary_Stack is 39 40 package SSL renames System.Soft_Links; 41 42 use type System.Parameters.Size_Type; 43 44 procedure Free is new Ada.Unchecked_Deallocation (Chunk_Id, Chunk_Ptr); 45 -- Free a dynamically allocated chunk 46 47 ----------------- 48 -- SS_Allocate -- 49 ----------------- 50 51 procedure SS_Allocate 52 (Addr : out Address; 53 Storage_Size : SSE.Storage_Count) 54 is 55 use type System.Storage_Elements.Storage_Count; 56 57 Max_Align : constant SS_Ptr := SS_Ptr (Standard'Maximum_Alignment); 58 Mem_Request : SS_Ptr; 59 60 Stack : constant SS_Stack_Ptr := SSL.Get_Sec_Stack.all; 61 begin 62 -- Round up Storage_Size to the nearest multiple of the max alignment 63 -- value for the target. This ensures efficient stack access. First 64 -- perform a check to ensure that the rounding operation does not 65 -- overflow SS_Ptr. 66 67 if SSE.Storage_Count (SS_Ptr'Last) - Standard'Maximum_Alignment < 68 Storage_Size 69 then 70 raise Storage_Error; 71 end if; 72 73 Mem_Request := ((SS_Ptr (Storage_Size) + Max_Align - 1) / Max_Align) * 74 Max_Align; 75 76 -- Case of fixed secondary stack 77 78 if not SP.Sec_Stack_Dynamic then 79 -- Check if max stack usage is increasing 80 81 if Stack.Max - Stack.Top - Mem_Request < 0 then 82 83 -- If so, check if the stack is exceeded, noting Stack.Top points 84 -- to the first free byte (so the value of Stack.Top on a fully 85 -- allocated stack will be Stack.Size + 1). The comparison is 86 -- formed to prevent integer overflows. 87 88 if Stack.Size - Stack.Top - Mem_Request < -1 then 89 raise Storage_Error; 90 end if; 91 92 -- Record new max usage 93 94 Stack.Max := Stack.Top + Mem_Request; 95 end if; 96 97 -- Set resulting address and update top of stack pointer 98 99 Addr := Stack.Internal_Chunk.Mem (Stack.Top)'Address; 100 Stack.Top := Stack.Top + Mem_Request; 101 102 -- Case of dynamic secondary stack 103 104 else 105 declare 106 Chunk : Chunk_Ptr; 107 Chunk_Size : SS_Ptr; 108 To_Be_Released_Chunk : Chunk_Ptr; 109 110 begin 111 Chunk := Stack.Current_Chunk; 112 113 -- The Current_Chunk may not be the best one if a lot of release 114 -- operations have taken place. Go down the stack if necessary. 115 116 while Chunk.First > Stack.Top loop 117 Chunk := Chunk.Prev; 118 end loop; 119 120 -- Find out if the available memory in the current chunk is 121 -- sufficient, if not, go to the next one and eventually create 122 -- the necessary room. 123 124 while Chunk.Last - Stack.Top - Mem_Request < -1 loop 125 if Chunk.Next /= null then 126 -- Release unused non-first empty chunk 127 128 if Chunk.Prev /= null and then Chunk.First = Stack.Top then 129 To_Be_Released_Chunk := Chunk; 130 Chunk := Chunk.Prev; 131 Chunk.Next := To_Be_Released_Chunk.Next; 132 To_Be_Released_Chunk.Next.Prev := Chunk; 133 Free (To_Be_Released_Chunk); 134 end if; 135 136 -- Create a new chunk 137 138 else 139 -- The new chunk should be no smaller than the default 140 -- chunk size to minimize the amount of secondary stack 141 -- management. 142 143 if Mem_Request <= Stack.Size then 144 Chunk_Size := Stack.Size; 145 else 146 Chunk_Size := Mem_Request; 147 end if; 148 149 -- Check that the indexing limits are not exceeded 150 151 if SS_Ptr'Last - Chunk.Last - Chunk_Size < 0 then 152 raise Storage_Error; 153 end if; 154 155 Chunk.Next := 156 new Chunk_Id 157 (First => Chunk.Last + 1, 158 Last => Chunk.Last + Chunk_Size); 159 160 Chunk.Next.Prev := Chunk; 161 end if; 162 163 Chunk := Chunk.Next; 164 Stack.Top := Chunk.First; 165 end loop; 166 167 -- Resulting address is the address pointed by Stack.Top 168 169 Addr := Chunk.Mem (Stack.Top)'Address; 170 Stack.Top := Stack.Top + Mem_Request; 171 Stack.Current_Chunk := Chunk; 172 173 -- Record new max usage 174 175 if Stack.Top > Stack.Max then 176 Stack.Max := Stack.Top; 177 end if; 178 179 end; 180 end if; 181 end SS_Allocate; 182 183 ------------- 184 -- SS_Free -- 185 ------------- 186 187 procedure SS_Free (Stack : in out SS_Stack_Ptr) is 188 procedure Free is 189 new Ada.Unchecked_Deallocation (SS_Stack, SS_Stack_Ptr); 190 begin 191 -- If using dynamic secondary stack, free any external chunks 192 193 if SP.Sec_Stack_Dynamic then 194 declare 195 Chunk : Chunk_Ptr; 196 197 procedure Free is 198 new Ada.Unchecked_Deallocation (Chunk_Id, Chunk_Ptr); 199 200 begin 201 Chunk := Stack.Current_Chunk; 202 203 -- Go to top of linked list and free backwards. Do not free the 204 -- internal chunk as it is part of SS_Stack. 205 206 while Chunk.Next /= null loop 207 Chunk := Chunk.Next; 208 end loop; 209 210 while Chunk.Prev /= null loop 211 Chunk := Chunk.Prev; 212 Free (Chunk.Next); 213 end loop; 214 end; 215 end if; 216 217 if Stack.Freeable then 218 Free (Stack); 219 end if; 220 end SS_Free; 221 222 ---------------- 223 -- SS_Get_Max -- 224 ---------------- 225 226 function SS_Get_Max return Long_Long_Integer is 227 Stack : constant SS_Stack_Ptr := SSL.Get_Sec_Stack.all; 228 begin 229 -- Stack.Max points to the first untouched byte in the stack, thus the 230 -- maximum number of bytes that have been allocated on the stack is one 231 -- less the value of Stack.Max. 232 233 return Long_Long_Integer (Stack.Max - 1); 234 end SS_Get_Max; 235 236 ------------- 237 -- SS_Info -- 238 ------------- 239 240 procedure SS_Info is 241 Stack : constant SS_Stack_Ptr := SSL.Get_Sec_Stack.all; 242 begin 243 Put_Line ("Secondary Stack information:"); 244 245 -- Case of fixed secondary stack 246 247 if not SP.Sec_Stack_Dynamic then 248 Put_Line (" Total size : " 249 & SS_Ptr'Image (Stack.Size) 250 & " bytes"); 251 252 Put_Line (" Current allocated space : " 253 & SS_Ptr'Image (Stack.Top - 1) 254 & " bytes"); 255 256 -- Case of dynamic secondary stack 257 258 else 259 declare 260 Nb_Chunks : Integer := 1; 261 Chunk : Chunk_Ptr := Stack.Current_Chunk; 262 263 begin 264 while Chunk.Prev /= null loop 265 Chunk := Chunk.Prev; 266 end loop; 267 268 while Chunk.Next /= null loop 269 Nb_Chunks := Nb_Chunks + 1; 270 Chunk := Chunk.Next; 271 end loop; 272 273 -- Current Chunk information 274 275 -- Note that First of each chunk is one more than Last of the 276 -- previous one, so Chunk.Last is the total size of all chunks; we 277 -- don't need to walk all the chunks to compute the total size. 278 279 Put_Line (" Total size : " 280 & SS_Ptr'Image (Chunk.Last) 281 & " bytes"); 282 283 Put_Line (" Current allocated space : " 284 & SS_Ptr'Image (Stack.Top - 1) 285 & " bytes"); 286 287 Put_Line (" Number of Chunks : " 288 & Integer'Image (Nb_Chunks)); 289 290 Put_Line (" Default size of Chunks : " 291 & SP.Size_Type'Image (Stack.Size)); 292 end; 293 end if; 294 end SS_Info; 295 296 ------------- 297 -- SS_Init -- 298 ------------- 299 300 procedure SS_Init 301 (Stack : in out SS_Stack_Ptr; 302 Size : SP.Size_Type := SP.Unspecified_Size) 303 is 304 use Parameters; 305 306 Stack_Size : Size_Type; 307 begin 308 -- If Stack is not null then the stack has been allocated outside the 309 -- package (by the compiler or the user) and all that is left to do is 310 -- initialize the stack. Otherwise, SS_Init will allocate a secondary 311 -- stack from either the heap or the default-sized secondary stack pool 312 -- generated by the binder. In the later case, this pool is generated 313 -- only when the either No_Implicit_Heap_Allocations 314 -- or No_Implicit_Task_Allocations are active, and SS_Init will allocate 315 -- all requests for a secondary stack of Unspecified_Size from this 316 -- pool. 317 318 if Stack = null then 319 if Size = Unspecified_Size then 320 -- Cover the case when bootstraping with an old compiler that does 321 -- not set Default_SS_Size. 322 323 if Default_SS_Size > 0 then 324 Stack_Size := Default_SS_Size; 325 else 326 Stack_Size := Runtime_Default_Sec_Stack_Size; 327 end if; 328 329 else 330 Stack_Size := Size; 331 end if; 332 333 if Size = Unspecified_Size 334 and then Binder_SS_Count > 0 335 and then Num_Of_Assigned_Stacks < Binder_SS_Count 336 then 337 -- The default-sized secondary stack pool is passed from the 338 -- binder to this package as an Address since it is not possible 339 -- to have a pointer to an array of unconstrained objects. A 340 -- pointer to the pool is obtainable via an unchecked conversion 341 -- to a constrained array of SS_Stacks that mirrors the one used 342 -- by the binder. 343 344 -- However, Ada understandably does not allow a local pointer to 345 -- a stack in the pool to be stored in a pointer outside of this 346 -- scope. While the conversion is safe in this case, since a view 347 -- of a global object is being used, using Unchecked_Access 348 -- would prevent users from specifying the restriction 349 -- No_Unchecked_Access whenever the secondary stack is used. As 350 -- a workaround, the local stack pointer is converted to a global 351 -- pointer via System.Address. 352 353 declare 354 type Stk_Pool_Array is array (1 .. Binder_SS_Count) of 355 aliased SS_Stack (Default_SS_Size); 356 type Stk_Pool_Access is access Stk_Pool_Array; 357 358 function To_Stack_Pool is new 359 Ada.Unchecked_Conversion (Address, Stk_Pool_Access); 360 361 pragma Warnings (Off); 362 function To_Global_Ptr is new 363 Ada.Unchecked_Conversion (Address, SS_Stack_Ptr); 364 pragma Warnings (On); 365 -- Suppress aliasing warning since the pointer we return will 366 -- be the only access to the stack. 367 368 Local_Stk_Address : System.Address; 369 370 begin 371 Num_Of_Assigned_Stacks := Num_Of_Assigned_Stacks + 1; 372 373 Local_Stk_Address := 374 To_Stack_Pool 375 (Default_Sized_SS_Pool) (Num_Of_Assigned_Stacks)'Address; 376 Stack := To_Global_Ptr (Local_Stk_Address); 377 end; 378 379 Stack.Freeable := False; 380 else 381 Stack := new SS_Stack (Stack_Size); 382 Stack.Freeable := True; 383 end if; 384 end if; 385 386 Stack.Top := 1; 387 Stack.Max := 1; 388 Stack.Current_Chunk := Stack.Internal_Chunk'Access; 389 end SS_Init; 390 391 ------------- 392 -- SS_Mark -- 393 ------------- 394 395 function SS_Mark return Mark_Id is 396 Stack : constant SS_Stack_Ptr := SSL.Get_Sec_Stack.all; 397 begin 398 return (Sec_Stack => Stack, Sptr => Stack.Top); 399 end SS_Mark; 400 401 ---------------- 402 -- SS_Release -- 403 ---------------- 404 405 procedure SS_Release (M : Mark_Id) is 406 begin 407 M.Sec_Stack.Top := M.Sptr; 408 end SS_Release; 409 410end System.Secondary_Stack; 411