1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- T A B L E -- 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 32with Debug; use Debug; 33with Opt; use Opt; 34with Output; use Output; 35with System; use System; 36with Tree_IO; use Tree_IO; 37 38with System.Memory; use System.Memory; 39 40with Unchecked_Conversion; 41 42pragma Elaborate_All (Output); 43 44package body Table is 45 package body Table is 46 47 Min : constant Int := Int (Table_Low_Bound); 48 -- Subscript of the minimum entry in the currently allocated table 49 50 Length : Int := 0; 51 -- Number of entries in currently allocated table. The value of zero 52 -- ensures that we initially allocate the table. 53 54 ----------------------- 55 -- Local Subprograms -- 56 ----------------------- 57 58 procedure Reallocate; 59 -- Reallocate the existing table according to the current value stored 60 -- in Max. Works correctly to do an initial allocation if the table 61 -- is currently null. 62 63 function Tree_Get_Table_Address return Address; 64 -- Return Null_Address if the table length is zero, 65 -- Table (First)'Address if not. 66 67 pragma Warnings (Off); 68 -- Turn off warnings. The following unchecked conversions are only used 69 -- internally in this package, and cannot never result in any instances 70 -- of improperly aliased pointers for the client of the package. 71 72 function To_Address is new Unchecked_Conversion (Table_Ptr, Address); 73 function To_Pointer is new Unchecked_Conversion (Address, Table_Ptr); 74 75 pragma Warnings (On); 76 77 ------------ 78 -- Append -- 79 ------------ 80 81 procedure Append (New_Val : Table_Component_Type) is 82 begin 83 Set_Item (Table_Index_Type (Last_Val + 1), New_Val); 84 end Append; 85 86 ---------------- 87 -- Append_All -- 88 ---------------- 89 90 procedure Append_All (New_Vals : Table_Type) is 91 begin 92 for J in New_Vals'Range loop 93 Append (New_Vals (J)); 94 end loop; 95 end Append_All; 96 97 -------------------- 98 -- Decrement_Last -- 99 -------------------- 100 101 procedure Decrement_Last is 102 begin 103 Last_Val := Last_Val - 1; 104 end Decrement_Last; 105 106 ---------- 107 -- Free -- 108 ---------- 109 110 procedure Free is 111 begin 112 Free (To_Address (Table)); 113 Table := null; 114 Length := 0; 115 end Free; 116 117 -------------------- 118 -- Increment_Last -- 119 -------------------- 120 121 procedure Increment_Last is 122 begin 123 Last_Val := Last_Val + 1; 124 125 if Last_Val > Max then 126 Reallocate; 127 end if; 128 end Increment_Last; 129 130 ---------- 131 -- Init -- 132 ---------- 133 134 procedure Init is 135 Old_Length : constant Int := Length; 136 137 begin 138 Locked := False; 139 Last_Val := Min - 1; 140 Max := Min + (Table_Initial * Table_Factor) - 1; 141 Length := Max - Min + 1; 142 143 -- If table is same size as before (happens when table is never 144 -- expanded which is a common case), then simply reuse it. Note 145 -- that this also means that an explicit Init call right after 146 -- the implicit one in the package body is harmless. 147 148 if Old_Length = Length then 149 return; 150 151 -- Otherwise we can use Reallocate to get a table of the right size. 152 -- Note that Reallocate works fine to allocate a table of the right 153 -- initial size when it is first allocated. 154 155 else 156 Reallocate; 157 end if; 158 end Init; 159 160 ---------- 161 -- Last -- 162 ---------- 163 164 function Last return Table_Index_Type is 165 begin 166 return Table_Index_Type (Last_Val); 167 end Last; 168 169 ---------------- 170 -- Reallocate -- 171 ---------------- 172 173 procedure Reallocate is 174 New_Size : Memory.size_t; 175 New_Length : Long_Long_Integer; 176 177 begin 178 if Max < Last_Val then 179 pragma Assert (not Locked); 180 181 -- Make sure that we have at least the initial allocation. This 182 -- is needed in cases where a zero length table is written out. 183 184 Length := Int'Max (Length, Table_Initial); 185 186 -- Now increment table length until it is sufficiently large. Use 187 -- the increment value or 10, which ever is larger (the reason 188 -- for the use of 10 here is to ensure that the table does really 189 -- increase in size (which would not be the case for a table of 190 -- length 10 increased by 3% for instance). Do the intermediate 191 -- calculation in Long_Long_Integer to avoid overflow. 192 193 while Max < Last_Val loop 194 New_Length := 195 Long_Long_Integer (Length) * 196 (100 + Long_Long_Integer (Table_Increment)) / 100; 197 Length := Int'Max (Int (New_Length), Length + 10); 198 Max := Min + Length - 1; 199 end loop; 200 201 if Debug_Flag_D then 202 Write_Str ("--> Allocating new "); 203 Write_Str (Table_Name); 204 Write_Str (" table, size = "); 205 Write_Int (Max - Min + 1); 206 Write_Eol; 207 end if; 208 end if; 209 210 -- Do the intermediate calculation in size_t to avoid signed overflow 211 212 New_Size := 213 Memory.size_t (Max - Min + 1) * 214 (Table_Type'Component_Size / Storage_Unit); 215 216 if Table = null then 217 Table := To_Pointer (Alloc (New_Size)); 218 219 elsif New_Size > 0 then 220 Table := 221 To_Pointer (Realloc (Ptr => To_Address (Table), 222 Size => New_Size)); 223 end if; 224 225 if Length /= 0 and then Table = null then 226 Set_Standard_Error; 227 Write_Str ("available memory exhausted"); 228 Write_Eol; 229 Set_Standard_Output; 230 raise Unrecoverable_Error; 231 end if; 232 end Reallocate; 233 234 ------------- 235 -- Release -- 236 ------------- 237 238 procedure Release is 239 Extra_Length : Int; 240 Size : Memory.size_t; 241 242 begin 243 Length := Last_Val - Int (Table_Low_Bound) + 1; 244 Size := Memory.size_t (Length) * 245 (Table_Type'Component_Size / Storage_Unit); 246 247 -- If the size of the table exceeds the release threshold then leave 248 -- space to store as many extra elements as 0.1% of the table length. 249 250 if Release_Threshold > 0 251 and then Size > Memory.size_t (Release_Threshold) 252 then 253 Extra_Length := Length / 1000; 254 Length := Length + Extra_Length; 255 Max := Int (Table_Low_Bound) + Length - 1; 256 257 if Debug_Flag_D then 258 Write_Str ("--> Release_Threshold reached (length="); 259 Write_Int (Int (Size)); 260 Write_Str ("): leaving room space for "); 261 Write_Int (Extra_Length); 262 Write_Str (" components"); 263 Write_Eol; 264 end if; 265 else 266 Max := Last_Val; 267 end if; 268 269 Reallocate; 270 end Release; 271 272 ------------- 273 -- Restore -- 274 ------------- 275 276 procedure Restore (T : Saved_Table) is 277 begin 278 Free (To_Address (Table)); 279 Last_Val := T.Last_Val; 280 Max := T.Max; 281 Table := T.Table; 282 Length := Max - Min + 1; 283 end Restore; 284 285 ---------- 286 -- Save -- 287 ---------- 288 289 function Save return Saved_Table is 290 Res : Saved_Table; 291 292 begin 293 Res.Last_Val := Last_Val; 294 Res.Max := Max; 295 Res.Table := Table; 296 297 Table := null; 298 Length := 0; 299 Init; 300 return Res; 301 end Save; 302 303 -------------- 304 -- Set_Item -- 305 -------------- 306 307 procedure Set_Item 308 (Index : Table_Index_Type; 309 Item : Table_Component_Type) 310 is 311 -- If Item is a value within the current allocation, and we are going 312 -- to reallocate, then we must preserve an intermediate copy here 313 -- before calling Increment_Last. Otherwise, if Table_Component_Type 314 -- is passed by reference, we are going to end up copying from 315 -- storage that might have been deallocated from Increment_Last 316 -- calling Reallocate. 317 318 subtype Allocated_Table_T is 319 Table_Type (Table'First .. Table_Index_Type (Max + 1)); 320 -- A constrained table subtype one element larger than the currently 321 -- allocated table. 322 323 Allocated_Table_Address : constant System.Address := 324 Table.all'Address; 325 -- Used for address clause below (we can't use non-static expression 326 -- Table.all'Address directly in the clause because some older 327 -- versions of the compiler do not allow it). 328 329 Allocated_Table : Allocated_Table_T; 330 pragma Import (Ada, Allocated_Table); 331 pragma Suppress (Range_Check, On => Allocated_Table); 332 for Allocated_Table'Address use Allocated_Table_Address; 333 -- Allocated_Table represents the currently allocated array, plus one 334 -- element (the supplementary element is used to have a convenient 335 -- way of computing the address just past the end of the current 336 -- allocation). Range checks are suppressed because this unit 337 -- uses direct calls to System.Memory for allocation, and this can 338 -- yield misaligned storage (and we cannot rely on the bootstrap 339 -- compiler supporting specifically disabling alignment checks, so we 340 -- need to suppress all range checks). It is safe to suppress this 341 -- check here because we know that a (possibly misaligned) object 342 -- of that type does actually exist at that address. 343 -- ??? We should really improve the allocation circuitry here to 344 -- guarantee proper alignment. 345 346 Need_Realloc : constant Boolean := Int (Index) > Max; 347 -- True if this operation requires storage reallocation (which may 348 -- involve moving table contents around). 349 350 begin 351 -- If we're going to reallocate, check whether Item references an 352 -- element of the currently allocated table. 353 354 if Need_Realloc 355 and then Allocated_Table'Address <= Item'Address 356 and then Item'Address < 357 Allocated_Table (Table_Index_Type (Max + 1))'Address 358 then 359 -- If so, save a copy on the stack because Increment_Last will 360 -- reallocate storage and might deallocate the current table. 361 362 declare 363 Item_Copy : constant Table_Component_Type := Item; 364 begin 365 Set_Last (Index); 366 Table (Index) := Item_Copy; 367 end; 368 369 else 370 -- Here we know that either we won't reallocate (case of Index < 371 -- Max) or that Item is not in the currently allocated table. 372 373 if Int (Index) > Last_Val then 374 Set_Last (Index); 375 end if; 376 377 Table (Index) := Item; 378 end if; 379 end Set_Item; 380 381 -------------- 382 -- Set_Last -- 383 -------------- 384 385 procedure Set_Last (New_Val : Table_Index_Type) is 386 begin 387 if Int (New_Val) < Last_Val then 388 Last_Val := Int (New_Val); 389 390 else 391 Last_Val := Int (New_Val); 392 393 if Last_Val > Max then 394 Reallocate; 395 end if; 396 end if; 397 end Set_Last; 398 399 ---------------------------- 400 -- Tree_Get_Table_Address -- 401 ---------------------------- 402 403 function Tree_Get_Table_Address return Address is 404 begin 405 if Length = 0 then 406 return Null_Address; 407 else 408 return Table (First)'Address; 409 end if; 410 end Tree_Get_Table_Address; 411 412 --------------- 413 -- Tree_Read -- 414 --------------- 415 416 -- Note: we allocate only the space required to accommodate the data 417 -- actually written, which means that a Tree_Write/Tree_Read sequence 418 -- does an implicit Release. 419 420 procedure Tree_Read is 421 begin 422 Tree_Read_Int (Max); 423 Last_Val := Max; 424 Length := Max - Min + 1; 425 Reallocate; 426 427 Tree_Read_Data 428 (Tree_Get_Table_Address, 429 (Last_Val - Int (First) + 1) * 430 431 -- Note the importance of parenthesizing the following division 432 -- to avoid the possibility of intermediate overflow. 433 434 (Table_Type'Component_Size / Storage_Unit)); 435 end Tree_Read; 436 437 ---------------- 438 -- Tree_Write -- 439 ---------------- 440 441 -- Note: we write out only the currently valid data, not the entire 442 -- contents of the allocated array. See note above on Tree_Read. 443 444 procedure Tree_Write is 445 begin 446 Tree_Write_Int (Int (Last)); 447 Tree_Write_Data 448 (Tree_Get_Table_Address, 449 (Last_Val - Int (First) + 1) * 450 (Table_Type'Component_Size / Storage_Unit)); 451 end Tree_Write; 452 453 begin 454 Init; 455 end Table; 456end Table; 457