1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- T A B L E -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2012, 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 New_Size := 211 Memory.size_t ((Max - Min + 1) * 212 (Table_Type'Component_Size / Storage_Unit)); 213 214 if Table = null then 215 Table := To_Pointer (Alloc (New_Size)); 216 217 elsif New_Size > 0 then 218 Table := 219 To_Pointer (Realloc (Ptr => To_Address (Table), 220 Size => New_Size)); 221 end if; 222 223 if Length /= 0 and then Table = null then 224 Set_Standard_Error; 225 Write_Str ("available memory exhausted"); 226 Write_Eol; 227 Set_Standard_Output; 228 raise Unrecoverable_Error; 229 end if; 230 231 end Reallocate; 232 233 ------------- 234 -- Release -- 235 ------------- 236 237 procedure Release is 238 begin 239 Length := Last_Val - Int (Table_Low_Bound) + 1; 240 Max := Last_Val; 241 Reallocate; 242 end Release; 243 244 ------------- 245 -- Restore -- 246 ------------- 247 248 procedure Restore (T : Saved_Table) is 249 begin 250 Free (To_Address (Table)); 251 Last_Val := T.Last_Val; 252 Max := T.Max; 253 Table := T.Table; 254 Length := Max - Min + 1; 255 end Restore; 256 257 ---------- 258 -- Save -- 259 ---------- 260 261 function Save return Saved_Table is 262 Res : Saved_Table; 263 264 begin 265 Res.Last_Val := Last_Val; 266 Res.Max := Max; 267 Res.Table := Table; 268 269 Table := null; 270 Length := 0; 271 Init; 272 return Res; 273 end Save; 274 275 -------------- 276 -- Set_Item -- 277 -------------- 278 279 procedure Set_Item 280 (Index : Table_Index_Type; 281 Item : Table_Component_Type) 282 is 283 -- If Item is a value within the current allocation, and we are going 284 -- to reallocate, then we must preserve an intermediate copy here 285 -- before calling Increment_Last. Otherwise, if Table_Component_Type 286 -- is passed by reference, we are going to end up copying from 287 -- storage that might have been deallocated from Increment_Last 288 -- calling Reallocate. 289 290 subtype Allocated_Table_T is 291 Table_Type (Table'First .. Table_Index_Type (Max + 1)); 292 -- A constrained table subtype one element larger than the currently 293 -- allocated table. 294 295 Allocated_Table_Address : constant System.Address := 296 Table.all'Address; 297 -- Used for address clause below (we can't use non-static expression 298 -- Table.all'Address directly in the clause because some older 299 -- versions of the compiler do not allow it). 300 301 Allocated_Table : Allocated_Table_T; 302 pragma Import (Ada, Allocated_Table); 303 pragma Suppress (Range_Check, On => Allocated_Table); 304 for Allocated_Table'Address use Allocated_Table_Address; 305 -- Allocated_Table represents the currently allocated array, plus one 306 -- element (the supplementary element is used to have a convenient 307 -- way of computing the address just past the end of the current 308 -- allocation). Range checks are suppressed because this unit 309 -- uses direct calls to System.Memory for allocation, and this can 310 -- yield misaligned storage (and we cannot rely on the bootstrap 311 -- compiler supporting specifically disabling alignment checks, so we 312 -- need to suppress all range checks). It is safe to suppress this 313 -- check here because we know that a (possibly misaligned) object 314 -- of that type does actually exist at that address. 315 -- ??? We should really improve the allocation circuitry here to 316 -- guarantee proper alignment. 317 318 Need_Realloc : constant Boolean := Int (Index) > Max; 319 -- True if this operation requires storage reallocation (which may 320 -- involve moving table contents around). 321 322 begin 323 -- If we're going to reallocate, check whether Item references an 324 -- element of the currently allocated table. 325 326 if Need_Realloc 327 and then Allocated_Table'Address <= Item'Address 328 and then Item'Address < 329 Allocated_Table (Table_Index_Type (Max + 1))'Address 330 then 331 -- If so, save a copy on the stack because Increment_Last will 332 -- reallocate storage and might deallocate the current table. 333 334 declare 335 Item_Copy : constant Table_Component_Type := Item; 336 begin 337 Set_Last (Index); 338 Table (Index) := Item_Copy; 339 end; 340 341 else 342 -- Here we know that either we won't reallocate (case of Index < 343 -- Max) or that Item is not in the currently allocated table. 344 345 if Int (Index) > Last_Val then 346 Set_Last (Index); 347 end if; 348 349 Table (Index) := Item; 350 end if; 351 end Set_Item; 352 353 -------------- 354 -- Set_Last -- 355 -------------- 356 357 procedure Set_Last (New_Val : Table_Index_Type) is 358 begin 359 if Int (New_Val) < Last_Val then 360 Last_Val := Int (New_Val); 361 362 else 363 Last_Val := Int (New_Val); 364 365 if Last_Val > Max then 366 Reallocate; 367 end if; 368 end if; 369 end Set_Last; 370 371 ---------------------------- 372 -- Tree_Get_Table_Address -- 373 ---------------------------- 374 375 function Tree_Get_Table_Address return Address is 376 begin 377 if Length = 0 then 378 return Null_Address; 379 else 380 return Table (First)'Address; 381 end if; 382 end Tree_Get_Table_Address; 383 384 --------------- 385 -- Tree_Read -- 386 --------------- 387 388 -- Note: we allocate only the space required to accommodate the data 389 -- actually written, which means that a Tree_Write/Tree_Read sequence 390 -- does an implicit Release. 391 392 procedure Tree_Read is 393 begin 394 Tree_Read_Int (Max); 395 Last_Val := Max; 396 Length := Max - Min + 1; 397 Reallocate; 398 399 Tree_Read_Data 400 (Tree_Get_Table_Address, 401 (Last_Val - Int (First) + 1) * 402 Table_Type'Component_Size / Storage_Unit); 403 end Tree_Read; 404 405 ---------------- 406 -- Tree_Write -- 407 ---------------- 408 409 -- Note: we write out only the currently valid data, not the entire 410 -- contents of the allocated array. See note above on Tree_Read. 411 412 procedure Tree_Write is 413 begin 414 Tree_Write_Int (Int (Last)); 415 Tree_Write_Data 416 (Tree_Get_Table_Address, 417 (Last_Val - Int (First) + 1) * 418 Table_Type'Component_Size / Storage_Unit); 419 end Tree_Write; 420 421 begin 422 Init; 423 end Table; 424end Table; 425