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) 2011, 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_Offset; 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 -- Header_Offset -- 332 ------------------- 333 334 function Header_Offset return System.Storage_Elements.Storage_Offset is 335 begin 336 return FM_Node'Size / Storage_Unit; 337 end Header_Offset; 338 339 ---------------- 340 -- Initialize -- 341 ---------------- 342 343 overriding procedure Initialize (Master : in out Finalization_Master) is 344 begin 345 -- The dummy head must point to itself in both directions 346 347 Master.Objects.Next := Master.Objects'Unchecked_Access; 348 Master.Objects.Prev := Master.Objects'Unchecked_Access; 349 end Initialize; 350 351 -------------------- 352 -- Is_Homogeneous -- 353 -------------------- 354 355 function Is_Homogeneous (Master : Finalization_Master) return Boolean is 356 begin 357 return Master.Is_Homogeneous; 358 end Is_Homogeneous; 359 360 ------------- 361 -- Objects -- 362 ------------- 363 364 function Objects (Master : Finalization_Master) return FM_Node_Ptr is 365 begin 366 return Master.Objects'Unrestricted_Access; 367 end Objects; 368 369 ------------------ 370 -- Print_Master -- 371 ------------------ 372 373 procedure Print_Master (Master : Finalization_Master) is 374 Head : constant FM_Node_Ptr := Master.Objects'Unrestricted_Access; 375 Head_Seen : Boolean := False; 376 N_Ptr : FM_Node_Ptr; 377 378 begin 379 -- Output the basic contents of a master 380 381 -- Master : 0x123456789 382 -- Is_Hmgen : TURE <or> FALSE 383 -- Base_Pool: null <or> 0x123456789 384 -- Fin_Addr : null <or> 0x123456789 385 -- Fin_Start: TRUE <or> FALSE 386 387 Put ("Master : "); 388 Put_Line (Address_Image (Master'Address)); 389 390 Put ("Is_Hmgen : "); 391 Put_Line (Master.Is_Homogeneous'Img); 392 393 Put ("Base_Pool: "); 394 if Master.Base_Pool = null then 395 Put_Line ("null"); 396 else 397 Put_Line (Address_Image (Master.Base_Pool'Address)); 398 end if; 399 400 Put ("Fin_Addr : "); 401 if Master.Finalize_Address = null then 402 Put_Line ("null"); 403 else 404 Put_Line (Address_Image (Master.Finalize_Address'Address)); 405 end if; 406 407 Put ("Fin_Start: "); 408 Put_Line (Master.Finalization_Started'Img); 409 410 -- Output all chained elements. The format is the following: 411 412 -- ^ <or> ? <or> null 413 -- |Header: 0x123456789 (dummy head) 414 -- | Prev: 0x123456789 415 -- | Next: 0x123456789 416 -- V 417 418 -- ^ - the current element points back to the correct element 419 -- ? - the current element points back to an erroneous element 420 -- n - the current element points back to null 421 422 -- Header - the address of the list header 423 -- Prev - the address of the list header which the current element 424 -- points back to 425 -- Next - the address of the list header which the current element 426 -- points to 427 -- (dummy head) - present if dummy head 428 429 N_Ptr := Head; 430 while N_Ptr /= null loop -- Should never be null 431 Put_Line ("V"); 432 433 -- We see the head initially; we want to exit when we see the head a 434 -- second time. 435 436 if N_Ptr = Head then 437 exit when Head_Seen; 438 439 Head_Seen := True; 440 end if; 441 442 -- The current element is null. This should never happen since the 443 -- list is circular. 444 445 if N_Ptr.Prev = null then 446 Put_Line ("null (ERROR)"); 447 448 -- The current element points back to the correct element 449 450 elsif N_Ptr.Prev.Next = N_Ptr then 451 Put_Line ("^"); 452 453 -- The current element points to an erroneous element 454 455 else 456 Put_Line ("? (ERROR)"); 457 end if; 458 459 -- Output the header and fields 460 461 Put ("|Header: "); 462 Put (Address_Image (N_Ptr.all'Address)); 463 464 -- Detect the dummy head 465 466 if N_Ptr = Head then 467 Put_Line (" (dummy head)"); 468 else 469 Put_Line (""); 470 end if; 471 472 Put ("| Prev: "); 473 474 if N_Ptr.Prev = null then 475 Put_Line ("null"); 476 else 477 Put_Line (Address_Image (N_Ptr.Prev.all'Address)); 478 end if; 479 480 Put ("| Next: "); 481 482 if N_Ptr.Next = null then 483 Put_Line ("null"); 484 else 485 Put_Line (Address_Image (N_Ptr.Next.all'Address)); 486 end if; 487 488 N_Ptr := N_Ptr.Next; 489 end loop; 490 end Print_Master; 491 492 ------------------- 493 -- Set_Base_Pool -- 494 ------------------- 495 496 procedure Set_Base_Pool 497 (Master : in out Finalization_Master; 498 Pool_Ptr : Any_Storage_Pool_Ptr) 499 is 500 begin 501 Master.Base_Pool := Pool_Ptr; 502 end Set_Base_Pool; 503 504 -------------------------- 505 -- Set_Finalize_Address -- 506 -------------------------- 507 508 procedure Set_Finalize_Address 509 (Master : in out Finalization_Master; 510 Fin_Addr_Ptr : Finalize_Address_Ptr) 511 is 512 begin 513 -- Synchronization: 514 -- Read - finalization 515 -- Write - allocation, outside 516 517 Lock_Task.all; 518 Set_Finalize_Address_Unprotected (Master, Fin_Addr_Ptr); 519 Unlock_Task.all; 520 end Set_Finalize_Address; 521 522 -------------------------------------- 523 -- Set_Finalize_Address_Unprotected -- 524 -------------------------------------- 525 526 procedure Set_Finalize_Address_Unprotected 527 (Master : in out Finalization_Master; 528 Fin_Addr_Ptr : Finalize_Address_Ptr) 529 is 530 begin 531 if Master.Finalize_Address = null then 532 Master.Finalize_Address := Fin_Addr_Ptr; 533 end if; 534 end Set_Finalize_Address_Unprotected; 535 536 ---------------------------------------------------- 537 -- Set_Heterogeneous_Finalize_Address_Unprotected -- 538 ---------------------------------------------------- 539 540 procedure Set_Heterogeneous_Finalize_Address_Unprotected 541 (Obj : System.Address; 542 Fin_Addr_Ptr : Finalize_Address_Ptr) 543 is 544 begin 545 Finalize_Address_Table.Set (Obj, Fin_Addr_Ptr); 546 end Set_Heterogeneous_Finalize_Address_Unprotected; 547 548 -------------------------- 549 -- Set_Is_Heterogeneous -- 550 -------------------------- 551 552 procedure Set_Is_Heterogeneous (Master : in out Finalization_Master) is 553 begin 554 -- Synchronization: 555 -- Read - finalization 556 -- Write - outside 557 558 Lock_Task.all; 559 Master.Is_Homogeneous := False; 560 Unlock_Task.all; 561 end Set_Is_Heterogeneous; 562 563end System.Finalization_Masters; 564