From: Arnaud Charlet Date: Fri, 5 Aug 2011 14:27:16 +0000 (+0200) Subject: [multiple changes] X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=efe05dfc95b60b57abb6c57055982e25dc09c91e;p=gcc.git [multiple changes] 2011-08-05 Sergey Rybin * tree_io.ads: Update ASIS_Version_Number because of the change of the order of calling Tree_Write/Tree_Read routines made for aspects. 2011-08-05 Bob Duff * a-fihema.adb (Finalize): Fix race condition. From-SVN: r177445 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index e9b409c544f..7b8561bff94 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,12 @@ +2011-08-05 Sergey Rybin + + * tree_io.ads: Update ASIS_Version_Number because of the change of the + order of calling Tree_Write/Tree_Read routines made for aspects. + +2011-08-05 Bob Duff + + * a-fihema.adb (Finalize): Fix race condition. + 2011-08-05 Yannick Moy * sem_ch12.adb (Analyze_Package_Instantiation, diff --git a/gcc/ada/a-fihema.adb b/gcc/ada/a-fihema.adb index dca5b1e369e..1b8cd78a242 100644 --- a/gcc/ada/a-fihema.adb +++ b/gcc/ada/a-fihema.adb @@ -35,12 +35,16 @@ with Ada.Unchecked_Conversion; with System; use System; with System.Address_Image; with System.IO; use System.IO; +with System.OS_Lib; with System.Soft_Links; use System.Soft_Links; with System.Storage_Elements; use System.Storage_Elements; with System.Storage_Pools; use System.Storage_Pools; package body Ada.Finalization.Heap_Management is + Debug : constant Boolean := False; + -- True for debugging printouts. + Header_Size : constant Storage_Count := Node'Size / Storage_Unit; -- Size of the header in bytes. Added to Storage_Size requested by -- Allocate/Deallocate to determine the Storage_Size passed to the @@ -59,6 +63,42 @@ package body Ada.Finalization.Heap_Management is procedure Detach (N : Node_Ptr); -- Unhook a node from an arbitrary list + procedure Fin_Assert (Condition : Boolean; Message : String); + -- Asserts that the condition is True. Used instead of pragma Assert in + -- delicate places where raising an exception would cause re-invocation of + -- finalization. Instead of raising an exception, aborts the whole + -- process. + + function Is_Empty (Objects : Node_Ptr) return Boolean; + -- True if the Objects list is empty. + + ---------------- + -- Fin_Assert -- + ---------------- + + procedure Fin_Assert (Condition : Boolean; Message : String) is + + procedure Fail; + -- Use a separate procedure to make it easy to set a breakpoint here. + + ---------- + -- Fail -- + ---------- + + procedure Fail is + begin + Put_Line ("Heap_Management: Fin_Assert failed: " & Message); + OS_Lib.OS_Abort; + end Fail; + + -- Start of processing for Fin_Assert + + begin + if not Condition then + Fail; + end if; + end Fin_Assert; + --------------------------- -- Add_Offset_To_Address -- --------------------------- @@ -221,40 +261,24 @@ package body Ada.Finalization.Heap_Management is ------------ procedure Detach (N : Node_Ptr) is + begin + pragma Debug (Fin_Assert (N /= null, "Detach null")); - -- N must be attached to some list - - pragma Assert (N.Next /= null and then N.Prev /= null); + Lock_Task.all; - procedure Null_Out_Pointers; - -- Set Next/Prev pointer of N to null (for debugging) + if N.Next = null then + pragma Assert (N.Prev = null); - ---------- - -- Head -- - ---------- - - procedure Null_Out_Pointers is - begin + else + N.Prev.Next := N.Next; + N.Next.Prev := N.Prev; N.Next := null; N.Prev := null; - end Null_Out_Pointers; - - -- Start of processing for Detach - - begin - Lock_Task.all; - - N.Prev.Next := N.Next; - N.Next.Prev := N.Prev; + end if; Unlock_Task.all; -- Note: no need to unlock in case of exceptions; the above code cannot -- raise any. - - -- No need to null out the pointers, except that it makes pcol easier to - -- understand. - - pragma Debug (Null_Out_Pointers); end Detach; -------------- @@ -264,54 +288,81 @@ package body Ada.Finalization.Heap_Management is overriding procedure Finalize (Collection : in out Finalization_Collection) is - Curr_Ptr : Node_Ptr := Collection.Objects.Next; -- skip dummy head Ex_Occur : Exception_Occurrence; Raised : Boolean := False; - -- Start of processing for Finalize - begin + if Debug then + Put_Line ("-->Heap_Management: "); + pcol (Collection); + end if; + -- Set Finalization_Started to prevent any allocations of objects with -- controlled parts during finalization. The associated access type is -- about to go out of scope; Finalization_Started is never again -- modified. + if Collection.Finalization_Started then + -- ???Needed for shared libraries. + return; + end if; + pragma Debug (Fin_Assert (not Collection.Finalization_Started, + "Finalize: already started")); Collection.Finalization_Started := True; - -- Go through the Objects list, and finalize each one. There is no need - -- to detach items from the list, because the whole collection is about - -- to go away. - - while Curr_Ptr /= Collection.Objects'Unchecked_Access loop + -- For each object in the Objects list, detach it, and finalize it. Note + -- that other tasks can be doing Unchecked_Deallocations at the same + -- time, so we need to beware of race conditions. - -- ??? Kludge: Don't do anything until the proper place to set - -- primitive Finalize_Address has been determined. + while not Is_Empty (Collection.Objects'Unchecked_Access) loop - if Collection.Finalize_Address /= null then - declare - Object_Address : constant Address := - Curr_Ptr.all'Address + Header_Offset; - -- Get address of object from address of header - - begin - Collection.Finalize_Address (Object_Address); - - exception - when Fin_Except : others => - if not Raised then - Raised := True; - Save_Occurrence (Ex_Occur, Fin_Except); - end if; - end; - end if; - - Curr_Ptr := Curr_Ptr.Next; + declare + Node : constant Node_Ptr := Collection.Objects.Next; + begin + -- Remove the current node from the list first, in case some other + -- task is simultaneously doing Unchecked_Deallocation on this + -- object. Detach does Lock_Task. Note that we can't Lock_Task + -- during Finalize_Address, because finalization can do pretty + -- much anything. + + Detach (Node); + + -- ??? Kludge: Don't do anything until the proper place to set + -- primitive Finalize_Address has been determined. + + if Collection.Finalize_Address /= null then + declare + Object_Address : constant Address := + Node.all'Address + Header_Offset; + -- Get address of object from address of header + + begin + Collection.Finalize_Address (Object_Address); + + exception + when Fin_Except : others => + if not Raised then + Raised := True; + Save_Occurrence (Ex_Occur, Fin_Except); + end if; + end; + end if; + end; end loop; + if Debug then + Put_Line ("<--Heap_Management: "); + pcol (Collection); + end if; + -- If the finalization of a particular node raised an exception, reraise -- it after the remainder of the list has been finalized. if Raised then + if Debug then + Put_Line ("Heap_Management: reraised"); + end if; + Reraise_Occurrence (Ex_Occur); end if; end Finalize; @@ -328,8 +379,21 @@ package body Ada.Finalization.Heap_Management is Collection.Objects.Next := Collection.Objects'Unchecked_Access; Collection.Objects.Prev := Collection.Objects'Unchecked_Access; + pragma Assert (Is_Empty (Collection.Objects'Unchecked_Access)); end Initialize; + -------------- + -- Is_Empty -- + -------------- + + function Is_Empty (Objects : Node_Ptr) return Boolean is + begin + pragma Debug + (Fin_Assert ((Objects.Next = Objects) = (Objects.Prev = Objects), + "Is_Empty")); + return Objects.Next = Objects; + end Is_Empty; + ---------- -- pcol -- ---------- diff --git a/gcc/ada/tree_io.ads b/gcc/ada/tree_io.ads index fd7fa29cc06..bdc6f5d1b02 100644 --- a/gcc/ada/tree_io.ads +++ b/gcc/ada/tree_io.ads @@ -47,7 +47,7 @@ package Tree_IO is Tree_Format_Error : exception; -- Raised if a format error is detected in the input file - ASIS_Version_Number : constant := 25; + ASIS_Version_Number : constant := 26; -- ASIS Version. This is used to check for consistency between the compiler -- used to generate trees and an ASIS application that is reading the -- trees. It must be incremented whenever a change is made to the tree