1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- S Y S T E M . F I N A L I Z A T I O N _ M A S T E R S -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 2015-2020, 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 Ada.Exceptions; use Ada.Exceptions; 33 34with System.Address_Image; 35with System.HTable; use System.HTable; 36with System.IO; use System.IO; 37with System.Soft_Links; use System.Soft_Links; 38with System.Storage_Elements; use System.Storage_Elements; 39 40package body System.Finalization_Masters is 41 42 -- Finalize_Address hash table types. In general, masters are homogeneous 43 -- collections of controlled objects. Rare cases such as allocations on a 44 -- subpool require heterogeneous masters. The following table provides a 45 -- relation between object address and its Finalize_Address routine. 46 47 type Header_Num is range 0 .. 127; 48 49 function Hash (Key : System.Address) return Header_Num; 50 51 -- Address --> Finalize_Address_Ptr 52 53 package Finalize_Address_Table is new Simple_HTable 54 (Header_Num => Header_Num, 55 Element => Finalize_Address_Ptr, 56 No_Element => null, 57 Key => System.Address, 58 Hash => Hash, 59 Equal => "="); 60 61 --------------------------- 62 -- Add_Offset_To_Address -- 63 --------------------------- 64 65 function Add_Offset_To_Address 66 (Addr : System.Address; 67 Offset : System.Storage_Elements.Storage_Offset) return System.Address 68 is 69 begin 70 return System.Storage_Elements."+" (Addr, Offset); 71 end Add_Offset_To_Address; 72 73 ------------ 74 -- Attach -- 75 ------------ 76 77 procedure Attach (N : not null FM_Node_Ptr; L : not null FM_Node_Ptr) is 78 begin 79 Lock_Task.all; 80 Attach_Unprotected (N, L); 81 Unlock_Task.all; 82 83 -- Note: No need to unlock in case of an exception because the above 84 -- code can never raise one. 85 end Attach; 86 87 ------------------------ 88 -- Attach_Unprotected -- 89 ------------------------ 90 91 procedure Attach_Unprotected 92 (N : not null FM_Node_Ptr; 93 L : not null FM_Node_Ptr) 94 is 95 begin 96 L.Next.Prev := N; 97 N.Next := L.Next; 98 L.Next := N; 99 N.Prev := L; 100 end Attach_Unprotected; 101 102 --------------- 103 -- Base_Pool -- 104 --------------- 105 106 function Base_Pool 107 (Master : Finalization_Master) return Any_Storage_Pool_Ptr 108 is 109 begin 110 return Master.Base_Pool; 111 end Base_Pool; 112 113 ----------------------------------------- 114 -- Delete_Finalize_Address_Unprotected -- 115 ----------------------------------------- 116 117 procedure Delete_Finalize_Address_Unprotected (Obj : System.Address) is 118 begin 119 Finalize_Address_Table.Remove (Obj); 120 end Delete_Finalize_Address_Unprotected; 121 122 ------------------------ 123 -- Detach_Unprotected -- 124 ------------------------ 125 126 procedure Detach_Unprotected (N : not null FM_Node_Ptr) is 127 begin 128 if N.Prev /= null and then N.Next /= null then 129 N.Prev.Next := N.Next; 130 N.Next.Prev := N.Prev; 131 N.Prev := null; 132 N.Next := null; 133 end if; 134 end Detach_Unprotected; 135 136 -------------- 137 -- Finalize -- 138 -------------- 139 140 overriding procedure Finalize (Master : in out Finalization_Master) is 141 Cleanup : Finalize_Address_Ptr; 142 Curr_Ptr : FM_Node_Ptr; 143 Ex_Occur : Exception_Occurrence; 144 Obj_Addr : Address; 145 Raised : Boolean := False; 146 147 function Is_Empty_List (L : not null FM_Node_Ptr) return Boolean; 148 -- Determine whether a list contains only one element, the dummy head 149 150 ------------------- 151 -- Is_Empty_List -- 152 ------------------- 153 154 function Is_Empty_List (L : not null FM_Node_Ptr) return Boolean is 155 begin 156 return L.Next = L and then L.Prev = L; 157 end Is_Empty_List; 158 159 -- Start of processing for Finalize 160 161 begin 162 Lock_Task.all; 163 164 -- Synchronization: 165 -- Read - allocation, finalization 166 -- Write - finalization 167 168 if Master.Finalization_Started then 169 Unlock_Task.all; 170 171 -- Double finalization may occur during the handling of stand alone 172 -- libraries or the finalization of a pool with subpools. Due to the 173 -- potential aliasing of masters in these two cases, do not process 174 -- the same master twice. 175 176 return; 177 end if; 178 179 -- Lock the master to prevent any allocations while the objects are 180 -- being finalized. The master remains locked because either the master 181 -- is explicitly deallocated or the associated access type is about to 182 -- go out of scope. 183 184 -- Synchronization: 185 -- Read - allocation, finalization 186 -- Write - finalization 187 188 Master.Finalization_Started := True; 189 190 while not Is_Empty_List (Master.Objects'Unchecked_Access) loop 191 Curr_Ptr := Master.Objects.Next; 192 193 -- Synchronization: 194 -- Write - allocation, deallocation, finalization 195 196 Detach_Unprotected (Curr_Ptr); 197 198 -- Skip the list header in order to offer proper object layout for 199 -- finalization. 200 201 Obj_Addr := Curr_Ptr.all'Address + Header_Size; 202 203 -- Retrieve TSS primitive Finalize_Address depending on the master's 204 -- mode of operation. 205 206 -- Synchronization: 207 -- Read - allocation, finalization 208 -- Write - outside 209 210 if Master.Is_Homogeneous then 211 212 -- Synchronization: 213 -- Read - finalization 214 -- Write - allocation, outside 215 216 Cleanup := Master.Finalize_Address; 217 218 else 219 -- Synchronization: 220 -- Read - finalization 221 -- Write - allocation, deallocation 222 223 Cleanup := Finalize_Address_Unprotected (Obj_Addr); 224 end if; 225 226 begin 227 Cleanup (Obj_Addr); 228 exception 229 when Fin_Occur : others => 230 if not Raised then 231 Raised := True; 232 Save_Occurrence (Ex_Occur, Fin_Occur); 233 end if; 234 end; 235 236 -- When the master is a heterogeneous collection, destroy the object 237 -- - Finalize_Address pair since it is no longer needed. 238 239 -- Synchronization: 240 -- Read - finalization 241 -- Write - outside 242 243 if not Master.Is_Homogeneous then 244 245 -- Synchronization: 246 -- Read - finalization 247 -- Write - allocation, deallocation, finalization 248 249 Delete_Finalize_Address_Unprotected (Obj_Addr); 250 end if; 251 end loop; 252 253 Unlock_Task.all; 254 255 -- If the finalization of a particular object failed or Finalize_Address 256 -- was not set, reraise the exception now. 257 258 if Raised then 259 Reraise_Occurrence (Ex_Occur); 260 end if; 261 end Finalize; 262 263 ---------------------- 264 -- Finalize_Address -- 265 ---------------------- 266 267 function Finalize_Address 268 (Master : Finalization_Master) return Finalize_Address_Ptr 269 is 270 begin 271 return Master.Finalize_Address; 272 end Finalize_Address; 273 274 ---------------------------------- 275 -- Finalize_Address_Unprotected -- 276 ---------------------------------- 277 278 function Finalize_Address_Unprotected 279 (Obj : System.Address) return Finalize_Address_Ptr 280 is 281 begin 282 return Finalize_Address_Table.Get (Obj); 283 end Finalize_Address_Unprotected; 284 285 -------------------------- 286 -- Finalization_Started -- 287 -------------------------- 288 289 function Finalization_Started 290 (Master : Finalization_Master) return Boolean 291 is 292 begin 293 return Master.Finalization_Started; 294 end Finalization_Started; 295 296 ---------- 297 -- Hash -- 298 ---------- 299 300 function Hash (Key : System.Address) return Header_Num is 301 begin 302 return 303 Header_Num 304 (To_Integer (Key) mod Integer_Address (Header_Num'Range_Length)); 305 end Hash; 306 307 ----------------- 308 -- Header_Size -- 309 ----------------- 310 311 function Header_Size return System.Storage_Elements.Storage_Count is 312 begin 313 return FM_Node'Size / Storage_Unit; 314 end Header_Size; 315 316 ---------------- 317 -- Initialize -- 318 ---------------- 319 320 overriding procedure Initialize (Master : in out Finalization_Master) is 321 begin 322 -- The dummy head must point to itself in both directions 323 324 Master.Objects.Next := Master.Objects'Unchecked_Access; 325 Master.Objects.Prev := Master.Objects'Unchecked_Access; 326 end Initialize; 327 328 -------------------- 329 -- Is_Homogeneous -- 330 -------------------- 331 332 function Is_Homogeneous (Master : Finalization_Master) return Boolean is 333 begin 334 return Master.Is_Homogeneous; 335 end Is_Homogeneous; 336 337 ------------- 338 -- Objects -- 339 ------------- 340 341 function Objects (Master : Finalization_Master) return FM_Node_Ptr is 342 begin 343 return Master.Objects'Unrestricted_Access; 344 end Objects; 345 346 ------------------ 347 -- Print_Master -- 348 ------------------ 349 350 procedure Print_Master (Master : Finalization_Master) is 351 Head : constant FM_Node_Ptr := Master.Objects'Unrestricted_Access; 352 Head_Seen : Boolean := False; 353 N_Ptr : FM_Node_Ptr; 354 355 begin 356 -- Output the basic contents of a master 357 358 -- Master : 0x123456789 359 -- Is_Hmgen : TURE <or> FALSE 360 -- Base_Pool: null <or> 0x123456789 361 -- Fin_Addr : null <or> 0x123456789 362 -- Fin_Start: TRUE <or> FALSE 363 364 Put ("Master : "); 365 Put_Line (Address_Image (Master'Address)); 366 367 Put ("Is_Hmgen : "); 368 Put_Line (Master.Is_Homogeneous'Img); 369 370 Put ("Base_Pool: "); 371 if Master.Base_Pool = null then 372 Put_Line ("null"); 373 else 374 Put_Line (Address_Image (Master.Base_Pool'Address)); 375 end if; 376 377 Put ("Fin_Addr : "); 378 if Master.Finalize_Address = null then 379 Put_Line ("null"); 380 else 381 Put_Line (Address_Image (Master.Finalize_Address'Address)); 382 end if; 383 384 Put ("Fin_Start: "); 385 Put_Line (Master.Finalization_Started'Img); 386 387 -- Output all chained elements. The format is the following: 388 389 -- ^ <or> ? <or> null 390 -- |Header: 0x123456789 (dummy head) 391 -- | Prev: 0x123456789 392 -- | Next: 0x123456789 393 -- V 394 395 -- ^ - the current element points back to the correct element 396 -- ? - the current element points back to an erroneous element 397 -- n - the current element points back to null 398 399 -- Header - the address of the list header 400 -- Prev - the address of the list header which the current element 401 -- points back to 402 -- Next - the address of the list header which the current element 403 -- points to 404 -- (dummy head) - present if dummy head 405 406 N_Ptr := Head; 407 while N_Ptr /= null loop -- Should never be null 408 Put_Line ("V"); 409 410 -- We see the head initially; we want to exit when we see the head a 411 -- second time. 412 413 if N_Ptr = Head then 414 exit when Head_Seen; 415 416 Head_Seen := True; 417 end if; 418 419 -- The current element is null. This should never happen since the 420 -- list is circular. 421 422 if N_Ptr.Prev = null then 423 Put_Line ("null (ERROR)"); 424 425 -- The current element points back to the correct element 426 427 elsif N_Ptr.Prev.Next = N_Ptr then 428 Put_Line ("^"); 429 430 -- The current element points to an erroneous element 431 432 else 433 Put_Line ("? (ERROR)"); 434 end if; 435 436 -- Output the header and fields 437 438 Put ("|Header: "); 439 Put (Address_Image (N_Ptr.all'Address)); 440 441 -- Detect the dummy head 442 443 if N_Ptr = Head then 444 Put_Line (" (dummy head)"); 445 else 446 Put_Line (""); 447 end if; 448 449 Put ("| Prev: "); 450 451 if N_Ptr.Prev = null then 452 Put_Line ("null"); 453 else 454 Put_Line (Address_Image (N_Ptr.Prev.all'Address)); 455 end if; 456 457 Put ("| Next: "); 458 459 if N_Ptr.Next = null then 460 Put_Line ("null"); 461 else 462 Put_Line (Address_Image (N_Ptr.Next.all'Address)); 463 end if; 464 465 N_Ptr := N_Ptr.Next; 466 end loop; 467 end Print_Master; 468 469 ------------------- 470 -- Set_Base_Pool -- 471 ------------------- 472 473 procedure Set_Base_Pool 474 (Master : in out Finalization_Master; 475 Pool_Ptr : Any_Storage_Pool_Ptr) 476 is 477 begin 478 Master.Base_Pool := Pool_Ptr; 479 end Set_Base_Pool; 480 481 -------------------------- 482 -- Set_Finalize_Address -- 483 -------------------------- 484 485 procedure Set_Finalize_Address 486 (Master : in out Finalization_Master; 487 Fin_Addr_Ptr : Finalize_Address_Ptr) 488 is 489 begin 490 -- Synchronization: 491 -- Read - finalization 492 -- Write - allocation, outside 493 494 Lock_Task.all; 495 Set_Finalize_Address_Unprotected (Master, Fin_Addr_Ptr); 496 Unlock_Task.all; 497 end Set_Finalize_Address; 498 499 -------------------------------------- 500 -- Set_Finalize_Address_Unprotected -- 501 -------------------------------------- 502 503 procedure Set_Finalize_Address_Unprotected 504 (Master : in out Finalization_Master; 505 Fin_Addr_Ptr : Finalize_Address_Ptr) 506 is 507 begin 508 if Master.Finalize_Address = null then 509 Master.Finalize_Address := Fin_Addr_Ptr; 510 end if; 511 end Set_Finalize_Address_Unprotected; 512 513 ---------------------------------------------------- 514 -- Set_Heterogeneous_Finalize_Address_Unprotected -- 515 ---------------------------------------------------- 516 517 procedure Set_Heterogeneous_Finalize_Address_Unprotected 518 (Obj : System.Address; 519 Fin_Addr_Ptr : Finalize_Address_Ptr) 520 is 521 begin 522 Finalize_Address_Table.Set (Obj, Fin_Addr_Ptr); 523 end Set_Heterogeneous_Finalize_Address_Unprotected; 524 525 -------------------------- 526 -- Set_Is_Heterogeneous -- 527 -------------------------- 528 529 procedure Set_Is_Heterogeneous (Master : in out Finalization_Master) is 530 begin 531 -- Synchronization: 532 -- Read - finalization 533 -- Write - outside 534 535 Lock_Task.all; 536 Master.Is_Homogeneous := False; 537 Unlock_Task.all; 538 end Set_Is_Heterogeneous; 539 540end System.Finalization_Masters; 541