1------------------------------------------------------------------------------ 2-- -- 3-- GNAT RUN-TIME COMPONENTS -- 4-- -- 5-- S Y S T E M . P O O L _ S I Z E -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2009, 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 32with System.Soft_Links; 33 34with Ada.Unchecked_Conversion; 35 36package body System.Pool_Size is 37 38 package SSE renames System.Storage_Elements; 39 use type SSE.Storage_Offset; 40 41 -- Even though these storage pools are typically only used by a single 42 -- task, if multiple tasks are declared at the same or a more nested scope 43 -- as the storage pool, there still may be concurrent access. The current 44 -- implementation of Stack_Bounded_Pool always uses a global lock for 45 -- protecting access. This should eventually be replaced by an atomic 46 -- linked list implementation for efficiency reasons. 47 48 package SSL renames System.Soft_Links; 49 50 type Storage_Count_Access is access SSE.Storage_Count; 51 function To_Storage_Count_Access is 52 new Ada.Unchecked_Conversion (Address, Storage_Count_Access); 53 54 SC_Size : constant := SSE.Storage_Count'Object_Size / System.Storage_Unit; 55 56 package Variable_Size_Management is 57 58 -- Embedded pool that manages allocation of variable-size data 59 60 -- This pool is used as soon as the Elmt_Size of the pool object is 0 61 62 -- Allocation is done on the first chunk long enough for the request. 63 -- Deallocation just puts the freed chunk at the beginning of the list. 64 65 procedure Initialize (Pool : in out Stack_Bounded_Pool); 66 procedure Allocate 67 (Pool : in out Stack_Bounded_Pool; 68 Address : out System.Address; 69 Storage_Size : SSE.Storage_Count; 70 Alignment : SSE.Storage_Count); 71 72 procedure Deallocate 73 (Pool : in out Stack_Bounded_Pool; 74 Address : System.Address; 75 Storage_Size : SSE.Storage_Count; 76 Alignment : SSE.Storage_Count); 77 end Variable_Size_Management; 78 79 package Vsize renames Variable_Size_Management; 80 81 -------------- 82 -- Allocate -- 83 -------------- 84 85 procedure Allocate 86 (Pool : in out Stack_Bounded_Pool; 87 Address : out System.Address; 88 Storage_Size : SSE.Storage_Count; 89 Alignment : SSE.Storage_Count) 90 is 91 begin 92 SSL.Lock_Task.all; 93 94 if Pool.Elmt_Size = 0 then 95 Vsize.Allocate (Pool, Address, Storage_Size, Alignment); 96 97 elsif Pool.First_Free /= 0 then 98 Address := Pool.The_Pool (Pool.First_Free)'Address; 99 Pool.First_Free := To_Storage_Count_Access (Address).all; 100 101 elsif 102 Pool.First_Empty <= (Pool.Pool_Size - Pool.Aligned_Elmt_Size + 1) 103 then 104 Address := Pool.The_Pool (Pool.First_Empty)'Address; 105 Pool.First_Empty := Pool.First_Empty + Pool.Aligned_Elmt_Size; 106 107 else 108 raise Storage_Error; 109 end if; 110 111 SSL.Unlock_Task.all; 112 113 exception 114 when others => 115 SSL.Unlock_Task.all; 116 raise; 117 end Allocate; 118 119 ---------------- 120 -- Deallocate -- 121 ---------------- 122 123 procedure Deallocate 124 (Pool : in out Stack_Bounded_Pool; 125 Address : System.Address; 126 Storage_Size : SSE.Storage_Count; 127 Alignment : SSE.Storage_Count) 128 is 129 begin 130 SSL.Lock_Task.all; 131 132 if Pool.Elmt_Size = 0 then 133 Vsize.Deallocate (Pool, Address, Storage_Size, Alignment); 134 135 else 136 To_Storage_Count_Access (Address).all := Pool.First_Free; 137 Pool.First_Free := Address - Pool.The_Pool'Address + 1; 138 end if; 139 140 SSL.Unlock_Task.all; 141 exception 142 when others => 143 SSL.Unlock_Task.all; 144 raise; 145 end Deallocate; 146 147 ---------------- 148 -- Initialize -- 149 ---------------- 150 151 procedure Initialize (Pool : in out Stack_Bounded_Pool) is 152 153 -- Define the appropriate alignment for allocations. This is the 154 -- maximum of the requested alignment, and the alignment required 155 -- for Storage_Count values. The latter test is to ensure that we 156 -- can properly reference the linked list pointers for free lists. 157 158 Align : constant SSE.Storage_Count := 159 SSE.Storage_Count'Max 160 (SSE.Storage_Count'Alignment, Pool.Alignment); 161 162 begin 163 if Pool.Elmt_Size = 0 then 164 Vsize.Initialize (Pool); 165 166 else 167 Pool.First_Free := 0; 168 Pool.First_Empty := 1; 169 170 -- Compute the size to allocate given the size of the element and 171 -- the possible alignment requirement as defined above. 172 173 Pool.Aligned_Elmt_Size := 174 SSE.Storage_Count'Max (SC_Size, 175 ((Pool.Elmt_Size + Align - 1) / Align) * Align); 176 end if; 177 end Initialize; 178 179 ------------------ 180 -- Storage_Size -- 181 ------------------ 182 183 function Storage_Size 184 (Pool : Stack_Bounded_Pool) return SSE.Storage_Count 185 is 186 begin 187 return Pool.Pool_Size; 188 end Storage_Size; 189 190 ------------------------------ 191 -- Variable_Size_Management -- 192 ------------------------------ 193 194 package body Variable_Size_Management is 195 196 Minimum_Size : constant := 2 * SC_Size; 197 198 procedure Set_Size 199 (Pool : Stack_Bounded_Pool; 200 Chunk, Size : SSE.Storage_Count); 201 -- Update the field 'size' of a chunk of available storage 202 203 procedure Set_Next 204 (Pool : Stack_Bounded_Pool; 205 Chunk, Next : SSE.Storage_Count); 206 -- Update the field 'next' of a chunk of available storage 207 208 function Size 209 (Pool : Stack_Bounded_Pool; 210 Chunk : SSE.Storage_Count) return SSE.Storage_Count; 211 -- Fetch the field 'size' of a chunk of available storage 212 213 function Next 214 (Pool : Stack_Bounded_Pool; 215 Chunk : SSE.Storage_Count) return SSE.Storage_Count; 216 -- Fetch the field 'next' of a chunk of available storage 217 218 function Chunk_Of 219 (Pool : Stack_Bounded_Pool; 220 Addr : System.Address) return SSE.Storage_Count; 221 -- Give the chunk number in the pool from its Address 222 223 -------------- 224 -- Allocate -- 225 -------------- 226 227 procedure Allocate 228 (Pool : in out Stack_Bounded_Pool; 229 Address : out System.Address; 230 Storage_Size : SSE.Storage_Count; 231 Alignment : SSE.Storage_Count) 232 is 233 Chunk : SSE.Storage_Count; 234 New_Chunk : SSE.Storage_Count; 235 Prev_Chunk : SSE.Storage_Count; 236 Our_Align : constant SSE.Storage_Count := 237 SSE.Storage_Count'Max (SSE.Storage_Count'Alignment, 238 Alignment); 239 Align_Size : constant SSE.Storage_Count := 240 SSE.Storage_Count'Max ( 241 Minimum_Size, 242 ((Storage_Size + Our_Align - 1) / Our_Align) * 243 Our_Align); 244 245 begin 246 -- Look for the first big enough chunk 247 248 Prev_Chunk := Pool.First_Free; 249 Chunk := Next (Pool, Prev_Chunk); 250 251 while Chunk /= 0 and then Size (Pool, Chunk) < Align_Size loop 252 Prev_Chunk := Chunk; 253 Chunk := Next (Pool, Chunk); 254 end loop; 255 256 -- Raise storage_error if no big enough chunk available 257 258 if Chunk = 0 then 259 raise Storage_Error; 260 end if; 261 262 -- When the chunk is bigger than what is needed, take appropriate 263 -- amount and build a new shrinked chunk with the remainder. 264 265 if Size (Pool, Chunk) - Align_Size > Minimum_Size then 266 New_Chunk := Chunk + Align_Size; 267 Set_Size (Pool, New_Chunk, Size (Pool, Chunk) - Align_Size); 268 Set_Next (Pool, New_Chunk, Next (Pool, Chunk)); 269 Set_Next (Pool, Prev_Chunk, New_Chunk); 270 271 -- If the chunk is the right size, just delete it from the chain 272 273 else 274 Set_Next (Pool, Prev_Chunk, Next (Pool, Chunk)); 275 end if; 276 277 Address := Pool.The_Pool (Chunk)'Address; 278 end Allocate; 279 280 -------------- 281 -- Chunk_Of -- 282 -------------- 283 284 function Chunk_Of 285 (Pool : Stack_Bounded_Pool; 286 Addr : System.Address) return SSE.Storage_Count 287 is 288 begin 289 return 1 + abs (Addr - Pool.The_Pool (1)'Address); 290 end Chunk_Of; 291 292 ---------------- 293 -- Deallocate -- 294 ---------------- 295 296 procedure Deallocate 297 (Pool : in out Stack_Bounded_Pool; 298 Address : System.Address; 299 Storage_Size : SSE.Storage_Count; 300 Alignment : SSE.Storage_Count) 301 is 302 pragma Warnings (Off, Pool); 303 304 Align_Size : constant SSE.Storage_Count := 305 ((Storage_Size + Alignment - 1) / Alignment) * 306 Alignment; 307 Chunk : constant SSE.Storage_Count := Chunk_Of (Pool, Address); 308 309 begin 310 -- Attach the freed chunk to the chain 311 312 Set_Size (Pool, Chunk, 313 SSE.Storage_Count'Max (Align_Size, Minimum_Size)); 314 Set_Next (Pool, Chunk, Next (Pool, Pool.First_Free)); 315 Set_Next (Pool, Pool.First_Free, Chunk); 316 317 end Deallocate; 318 319 ---------------- 320 -- Initialize -- 321 ---------------- 322 323 procedure Initialize (Pool : in out Stack_Bounded_Pool) is 324 begin 325 Pool.First_Free := 1; 326 327 if Pool.Pool_Size > Minimum_Size then 328 Set_Next (Pool, Pool.First_Free, Pool.First_Free + Minimum_Size); 329 Set_Size (Pool, Pool.First_Free, 0); 330 Set_Size (Pool, Pool.First_Free + Minimum_Size, 331 Pool.Pool_Size - Minimum_Size); 332 Set_Next (Pool, Pool.First_Free + Minimum_Size, 0); 333 end if; 334 end Initialize; 335 336 ---------- 337 -- Next -- 338 ---------- 339 340 function Next 341 (Pool : Stack_Bounded_Pool; 342 Chunk : SSE.Storage_Count) return SSE.Storage_Count 343 is 344 begin 345 pragma Warnings (Off); 346 -- Kill alignment warnings, we are careful to make sure 347 -- that the alignment is correct. 348 349 return To_Storage_Count_Access 350 (Pool.The_Pool (Chunk + SC_Size)'Address).all; 351 352 pragma Warnings (On); 353 end Next; 354 355 -------------- 356 -- Set_Next -- 357 -------------- 358 359 procedure Set_Next 360 (Pool : Stack_Bounded_Pool; 361 Chunk, Next : SSE.Storage_Count) 362 is 363 begin 364 pragma Warnings (Off); 365 -- Kill alignment warnings, we are careful to make sure 366 -- that the alignment is correct. 367 368 To_Storage_Count_Access 369 (Pool.The_Pool (Chunk + SC_Size)'Address).all := Next; 370 371 pragma Warnings (On); 372 end Set_Next; 373 374 -------------- 375 -- Set_Size -- 376 -------------- 377 378 procedure Set_Size 379 (Pool : Stack_Bounded_Pool; 380 Chunk, Size : SSE.Storage_Count) 381 is 382 begin 383 pragma Warnings (Off); 384 -- Kill alignment warnings, we are careful to make sure 385 -- that the alignment is correct. 386 387 To_Storage_Count_Access 388 (Pool.The_Pool (Chunk)'Address).all := Size; 389 390 pragma Warnings (On); 391 end Set_Size; 392 393 ---------- 394 -- Size -- 395 ---------- 396 397 function Size 398 (Pool : Stack_Bounded_Pool; 399 Chunk : SSE.Storage_Count) return SSE.Storage_Count 400 is 401 begin 402 pragma Warnings (Off); 403 -- Kill alignment warnings, we are careful to make sure 404 -- that the alignment is correct. 405 406 return To_Storage_Count_Access (Pool.The_Pool (Chunk)'Address).all; 407 408 pragma Warnings (On); 409 end Size; 410 411 end Variable_Size_Management; 412end System.Pool_Size; 413