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, 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 -- 124 ------------ 125 126 procedure Detach (N : not null FM_Node_Ptr) is 127 begin 128 Lock_Task.all; 129 Detach_Unprotected (N); 130 Unlock_Task.all; 131 132 -- Note: No need to unlock in case of an exception because the above 133 -- code can never raise one. 134 end Detach; 135 136 ------------------------ 137 -- Detach_Unprotected -- 138 ------------------------ 139 140 procedure Detach_Unprotected (N : not null FM_Node_Ptr) is 141 begin 142 if N.Prev /= null and then N.Next /= null then 143 N.Prev.Next := N.Next; 144 N.Next.Prev := N.Prev; 145 N.Prev := null; 146 N.Next := null; 147 end if; 148 end Detach_Unprotected; 149 150 -------------- 151 -- Finalize -- 152 -------------- 153 154 overriding procedure Finalize (Master : in out Finalization_Master) is 155 Cleanup : Finalize_Address_Ptr; 156 Curr_Ptr : FM_Node_Ptr; 157 Ex_Occur : Exception_Occurrence; 158 Obj_Addr : Address; 159 Raised : Boolean := False; 160 161 function Is_Empty_List (L : not null FM_Node_Ptr) return Boolean; 162 -- Determine whether a list contains only one element, the dummy head 163 164 ------------------- 165 -- Is_Empty_List -- 166 ------------------- 167 168 function Is_Empty_List (L : not null FM_Node_Ptr) return Boolean is 169 begin 170 return L.Next = L and then L.Prev = L; 171 end Is_Empty_List; 172 173 -- Start of processing for Finalize 174 175 begin 176 Lock_Task.all; 177 178 -- Synchronization: 179 -- Read - allocation, finalization 180 -- Write - finalization 181 182 if Master.Finalization_Started then 183 Unlock_Task.all; 184 185 -- Double finalization may occur during the handling of stand alone 186 -- libraries or the finalization of a pool with subpools. Due to the 187 -- potential aliasing of masters in these two cases, do not process 188 -- the same master twice. 189 190 return; 191 end if; 192 193 -- Lock the master to prevent any allocations while the objects are 194 -- being finalized. The master remains locked because either the master 195 -- is explicitly deallocated or the associated access type is about to 196 -- go out of scope. 197 198 -- Synchronization: 199 -- Read - allocation, finalization 200 -- Write - finalization 201 202 Master.Finalization_Started := True; 203 204 while not Is_Empty_List (Master.Objects'Unchecked_Access) loop 205 Curr_Ptr := Master.Objects.Next; 206 207 -- Synchronization: 208 -- Write - allocation, deallocation, finalization 209 210 Detach_Unprotected (Curr_Ptr); 211 212 -- Skip the list header in order to offer proper object layout for 213 -- finalization. 214 215 Obj_Addr := Curr_Ptr.all'Address + Header_Size; 216 217 -- Retrieve TSS primitive Finalize_Address depending on the master's 218 -- mode of operation. 219 220 -- Synchronization: 221 -- Read - allocation, finalization 222 -- Write - outside 223 224 if Master.Is_Homogeneous then 225 226 -- Synchronization: 227 -- Read - finalization 228 -- Write - allocation, outside 229 230 Cleanup := Master.Finalize_Address; 231 232 else 233 -- Synchronization: 234 -- Read - finalization 235 -- Write - allocation, deallocation 236 237 Cleanup := Finalize_Address_Unprotected (Obj_Addr); 238 end if; 239 240 begin 241 Cleanup (Obj_Addr); 242 exception 243 when Fin_Occur : others => 244 if not Raised then 245 Raised := True; 246 Save_Occurrence (Ex_Occur, Fin_Occur); 247 end if; 248 end; 249 250 -- When the master is a heterogeneous collection, destroy the object 251 -- - Finalize_Address pair since it is no longer needed. 252 253 -- Synchronization: 254 -- Read - finalization 255 -- Write - outside 256 257 if not Master.Is_Homogeneous then 258 259 -- Synchronization: 260 -- Read - finalization 261 -- Write - allocation, deallocation, finalization 262 263 Delete_Finalize_Address_Unprotected (Obj_Addr); 264 end if; 265 end loop; 266 267 Unlock_Task.all; 268 269 -- If the finalization of a particular object failed or Finalize_Address 270 -- was not set, reraise the exception now. 271 272 if Raised then 273 Reraise_Occurrence (Ex_Occur); 274 end if; 275 end Finalize; 276 277 ---------------------- 278 -- Finalize_Address -- 279 ---------------------- 280 281 function Finalize_Address 282 (Master : Finalization_Master) return Finalize_Address_Ptr 283 is 284 begin 285 return Master.Finalize_Address; 286 end Finalize_Address; 287 288 ---------------------------------- 289 -- Finalize_Address_Unprotected -- 290 ---------------------------------- 291 292 function Finalize_Address_Unprotected 293 (Obj : System.Address) return Finalize_Address_Ptr 294 is 295 begin 296 return Finalize_Address_Table.Get (Obj); 297 end Finalize_Address_Unprotected; 298 299 -------------------------- 300 -- Finalization_Started -- 301 -------------------------- 302 303 function Finalization_Started 304 (Master : Finalization_Master) return Boolean 305 is 306 begin 307 return Master.Finalization_Started; 308 end Finalization_Started; 309 310 ---------- 311 -- Hash -- 312 ---------- 313 314 function Hash (Key : System.Address) return Header_Num is 315 begin 316 return 317 Header_Num 318 (To_Integer (Key) mod Integer_Address (Header_Num'Range_Length)); 319 end Hash; 320 321 ----------------- 322 -- Header_Size -- 323 ----------------- 324 325 function Header_Size return System.Storage_Elements.Storage_Count is 326 begin 327 return FM_Node'Size / Storage_Unit; 328 end Header_Size; 329 330 ---------------- 331 -- Initialize -- 332 ---------------- 333 334 overriding procedure Initialize (Master : in out Finalization_Master) is 335 begin 336 -- The dummy head must point to itself in both directions 337 338 Master.Objects.Next := Master.Objects'Unchecked_Access; 339 Master.Objects.Prev := Master.Objects'Unchecked_Access; 340 end Initialize; 341 342 -------------------- 343 -- Is_Homogeneous -- 344 -------------------- 345 346 function Is_Homogeneous (Master : Finalization_Master) return Boolean is 347 begin 348 return Master.Is_Homogeneous; 349 end Is_Homogeneous; 350 351 ------------- 352 -- Objects -- 353 ------------- 354 355 function Objects (Master : Finalization_Master) return FM_Node_Ptr is 356 begin 357 return Master.Objects'Unrestricted_Access; 358 end Objects; 359 360 ------------------ 361 -- Print_Master -- 362 ------------------ 363 364 procedure Print_Master (Master : Finalization_Master) is 365 Head : constant FM_Node_Ptr := Master.Objects'Unrestricted_Access; 366 Head_Seen : Boolean := False; 367 N_Ptr : FM_Node_Ptr; 368 369 begin 370 -- Output the basic contents of a master 371 372 -- Master : 0x123456789 373 -- Is_Hmgen : TURE <or> FALSE 374 -- Base_Pool: null <or> 0x123456789 375 -- Fin_Addr : null <or> 0x123456789 376 -- Fin_Start: TRUE <or> FALSE 377 378 Put ("Master : "); 379 Put_Line (Address_Image (Master'Address)); 380 381 Put ("Is_Hmgen : "); 382 Put_Line (Master.Is_Homogeneous'Img); 383 384 Put ("Base_Pool: "); 385 if Master.Base_Pool = null then 386 Put_Line ("null"); 387 else 388 Put_Line (Address_Image (Master.Base_Pool'Address)); 389 end if; 390 391 Put ("Fin_Addr : "); 392 if Master.Finalize_Address = null then 393 Put_Line ("null"); 394 else 395 Put_Line (Address_Image (Master.Finalize_Address'Address)); 396 end if; 397 398 Put ("Fin_Start: "); 399 Put_Line (Master.Finalization_Started'Img); 400 401 -- Output all chained elements. The format is the following: 402 403 -- ^ <or> ? <or> null 404 -- |Header: 0x123456789 (dummy head) 405 -- | Prev: 0x123456789 406 -- | Next: 0x123456789 407 -- V 408 409 -- ^ - the current element points back to the correct element 410 -- ? - the current element points back to an erroneous element 411 -- n - the current element points back to null 412 413 -- Header - the address of the list header 414 -- Prev - the address of the list header which the current element 415 -- points back to 416 -- Next - the address of the list header which the current element 417 -- points to 418 -- (dummy head) - present if dummy head 419 420 N_Ptr := Head; 421 while N_Ptr /= null loop -- Should never be null 422 Put_Line ("V"); 423 424 -- We see the head initially; we want to exit when we see the head a 425 -- second time. 426 427 if N_Ptr = Head then 428 exit when Head_Seen; 429 430 Head_Seen := True; 431 end if; 432 433 -- The current element is null. This should never happen since the 434 -- list is circular. 435 436 if N_Ptr.Prev = null then 437 Put_Line ("null (ERROR)"); 438 439 -- The current element points back to the correct element 440 441 elsif N_Ptr.Prev.Next = N_Ptr then 442 Put_Line ("^"); 443 444 -- The current element points to an erroneous element 445 446 else 447 Put_Line ("? (ERROR)"); 448 end if; 449 450 -- Output the header and fields 451 452 Put ("|Header: "); 453 Put (Address_Image (N_Ptr.all'Address)); 454 455 -- Detect the dummy head 456 457 if N_Ptr = Head then 458 Put_Line (" (dummy head)"); 459 else 460 Put_Line (""); 461 end if; 462 463 Put ("| Prev: "); 464 465 if N_Ptr.Prev = null then 466 Put_Line ("null"); 467 else 468 Put_Line (Address_Image (N_Ptr.Prev.all'Address)); 469 end if; 470 471 Put ("| Next: "); 472 473 if N_Ptr.Next = null then 474 Put_Line ("null"); 475 else 476 Put_Line (Address_Image (N_Ptr.Next.all'Address)); 477 end if; 478 479 N_Ptr := N_Ptr.Next; 480 end loop; 481 end Print_Master; 482 483 ------------------- 484 -- Set_Base_Pool -- 485 ------------------- 486 487 procedure Set_Base_Pool 488 (Master : in out Finalization_Master; 489 Pool_Ptr : Any_Storage_Pool_Ptr) 490 is 491 begin 492 Master.Base_Pool := Pool_Ptr; 493 end Set_Base_Pool; 494 495 -------------------------- 496 -- Set_Finalize_Address -- 497 -------------------------- 498 499 procedure Set_Finalize_Address 500 (Master : in out Finalization_Master; 501 Fin_Addr_Ptr : Finalize_Address_Ptr) 502 is 503 begin 504 -- Synchronization: 505 -- Read - finalization 506 -- Write - allocation, outside 507 508 Lock_Task.all; 509 Set_Finalize_Address_Unprotected (Master, Fin_Addr_Ptr); 510 Unlock_Task.all; 511 end Set_Finalize_Address; 512 513 -------------------------------------- 514 -- Set_Finalize_Address_Unprotected -- 515 -------------------------------------- 516 517 procedure Set_Finalize_Address_Unprotected 518 (Master : in out Finalization_Master; 519 Fin_Addr_Ptr : Finalize_Address_Ptr) 520 is 521 begin 522 if Master.Finalize_Address = null then 523 Master.Finalize_Address := Fin_Addr_Ptr; 524 end if; 525 end Set_Finalize_Address_Unprotected; 526 527 ---------------------------------------------------- 528 -- Set_Heterogeneous_Finalize_Address_Unprotected -- 529 ---------------------------------------------------- 530 531 procedure Set_Heterogeneous_Finalize_Address_Unprotected 532 (Obj : System.Address; 533 Fin_Addr_Ptr : Finalize_Address_Ptr) 534 is 535 begin 536 Finalize_Address_Table.Set (Obj, Fin_Addr_Ptr); 537 end Set_Heterogeneous_Finalize_Address_Unprotected; 538 539 -------------------------- 540 -- Set_Is_Heterogeneous -- 541 -------------------------- 542 543 procedure Set_Is_Heterogeneous (Master : in out Finalization_Master) is 544 begin 545 -- Synchronization: 546 -- Read - finalization 547 -- Write - outside 548 549 Lock_Task.all; 550 Master.Is_Homogeneous := False; 551 Unlock_Task.all; 552 end Set_Is_Heterogeneous; 553 554end System.Finalization_Masters; 555