From 756ef2a03df27c1998266ecae0ce335668fc2f8a Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Thu, 4 Aug 2011 12:01:08 +0200 Subject: [PATCH] [multiple changes] 2011-08-04 Emmanuel Briot * makeutl.adb (Complete_Mains): when a multi-unit source file is specified on the gprbuild command line, we need to compile all units within that file, not just the first one we find Fix error message for mains that are not found. 2011-08-04 Thomas Quinot * sem_ch6.adb: Update comment. * sem_ch12.adb: Minor reformatting. 2011-08-04 Bob Duff * s-tasren.adb (Task_Do_Or_Queue): Previous code was reading Acceptor.Terminate_Alternative without locking Acceptor, which causes a race condition whose symptom is to fail to lock Parent. That, in turn, causes Parent.Awake_Count to be accessed without locking Parent, which causes another race condition whose symptom is that Parent.Awake_Count can be off by 1 (either too high or too low). The solution is to lock Parent unconditionally, and then lock Acceptor, before reading Acceptor.Terminate_Alternative. From-SVN: r177352 --- gcc/ada/ChangeLog | 23 +++++++++++ gcc/ada/makeutl.adb | 86 +++++++++++++++++++++++++++++++++++++--- gcc/ada/s-tasren.adb | 44 +++++++-------------- gcc/ada/sem_ch12.adb | 93 ++++++++++++++++++++------------------------ gcc/ada/sem_ch6.adb | 5 ++- 5 files changed, 164 insertions(+), 87 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 40d753b8b01..29f972a3f32 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,26 @@ +2011-08-04 Emmanuel Briot + + * makeutl.adb (Complete_Mains): when a multi-unit source file is + specified on the gprbuild command line, we need to compile all units + within that file, not just the first one we find + Fix error message for mains that are not found. + +2011-08-04 Thomas Quinot + + * sem_ch6.adb: Update comment. + * sem_ch12.adb: Minor reformatting. + +2011-08-04 Bob Duff + + * s-tasren.adb (Task_Do_Or_Queue): Previous code was reading + Acceptor.Terminate_Alternative without locking Acceptor, which causes a + race condition whose symptom is to fail to lock Parent. That, in turn, + causes Parent.Awake_Count to be accessed without locking Parent, which + causes another race condition whose symptom is that Parent.Awake_Count + can be off by 1 (either too high or too low). The solution is to lock + Parent unconditionally, and then lock Acceptor, before reading + Acceptor.Terminate_Alternative. + 2011-08-04 Arnaud Charlet * debug.adb: Update comment. diff --git a/gcc/ada/makeutl.adb b/gcc/ada/makeutl.adb index 97bf8e16f97..8e9bd218436 100644 --- a/gcc/ada/makeutl.adb +++ b/gcc/ada/makeutl.adb @@ -1280,13 +1280,71 @@ package body Makeutl is procedure Complete_All is new For_Project_And_Aggregated (Do_Complete); + procedure Add_Multi_Unit_Sources + (Tree : Project_Tree_Ref; + Source : Prj.Source_Id); + -- Add all units from the same file as the multi-unit Source. + + ---------------------------- + -- Add_Multi_Unit_Sources -- + ---------------------------- + + procedure Add_Multi_Unit_Sources + (Tree : Project_Tree_Ref; + Source : Prj.Source_Id) + is + Iter : Source_Iterator; + Src : Prj.Source_Id; + begin + Debug_Output + ("Found multi-unit source file in project", Source.Project.Name); + + Iter := For_Each_Source + (In_Tree => Tree, Project => Source.Project); + + while Element (Iter) /= No_Source loop + Src := Element (Iter); + + if Src.File = Source.File + and then Src.Index /= Source.Index + then + if Src.File = Source.File then + Debug_Output + ("Add main in project, index=" & Src.Index'Img); + end if; + + Names.Increment_Last; + Names.Table (Names.Last) := + (File => Src.File, + Index => Src.Index, + Location => No_Location, + Source => Src, + Project => Src.Project, + Tree => Tree); + + Builder_Data (Tree).Number_Of_Mains := + Builder_Data (Tree).Number_Of_Mains + 1; + end if; + + Next (Iter); + end loop; + end Add_Multi_Unit_Sources; + + ----------------- + -- Do_Complete -- + ----------------- + procedure Do_Complete (Project : Project_Id; Tree : Project_Tree_Ref) is begin if Mains.Number_Of_Mains (Tree) > 0 or else Mains.Count_Of_Mains_With_No_Tree > 0 then - for J in Names.First .. Names.Last loop + -- Traverse in reverse order, since in the case of multi-unit + -- files we will be adding extra files at the end, and there's + -- no need to process them in tun. + + for J in reverse Names.First .. Names.Last loop declare File : Main_Info := Names.Table (J); Main_Id : File_Name_Type := File.File; @@ -1327,7 +1385,7 @@ package body Makeutl is if Current_Verbosity = High then Debug_Output ("Search for main """ & Main - & """ in " + & '"' & File.Index'Img & " in " & Get_Name_String (Debug_Name (File.Tree)) & ", project", Project.Name); end if; @@ -1402,6 +1460,19 @@ package body Makeutl is end if; if Source /= No_Source then + -- If we have found a multi-unit source file but + -- did not specify an index initially, we'll need + -- to compile all the units from the same source + -- file + + if Source.Index /= 0 + and then File.Index = 0 + then + Add_Multi_Unit_Sources (File.Tree, Source); + end if; + + -- Now update the original Main, otherwise it will + -- be reported as not found. Debug_Output ("Found main in project", Source.Project.Name); @@ -1412,7 +1483,8 @@ package body Makeutl is Names.Table (J).Tree := File.Tree; Builder_Data (File.Tree).Number_Of_Mains := - Builder_Data (File.Tree).Number_Of_Mains + 1; + Builder_Data (File.Tree).Number_Of_Mains + + 1; Mains.Count_Of_Mains_With_No_Tree := Mains.Count_Of_Mains_With_No_Tree - 1; end if; @@ -1451,9 +1523,11 @@ package body Makeutl is if Mains.Count_Of_Mains_With_No_Tree > 0 then for J in Names.First .. Names.Last loop - Fail_Program - (Project_Tree, '"' & Get_Name_String (Names.Table (J).File) - & """ is not a source of any project"); + if Names.Table (J).Source = No_Source then + Fail_Program + (Project_Tree, '"' & Get_Name_String (Names.Table (J).File) + & """ is not a source of any project"); + end if; end loop; end if; end Complete_Mains; diff --git a/gcc/ada/s-tasren.adb b/gcc/ada/s-tasren.adb index 1ea6699473e..aed3ec50445 100644 --- a/gcc/ada/s-tasren.adb +++ b/gcc/ada/s-tasren.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -1077,7 +1077,6 @@ package body System.Tasking.Rendezvous is Old_State : constant Entry_Call_State := Entry_Call.State; Acceptor : constant Task_Id := Entry_Call.Called_Task; Parent : constant Task_Id := Acceptor.Common.Parent; - Parent_Locked : Boolean := False; Null_Body : Boolean; begin @@ -1105,24 +1104,23 @@ package body System.Tasking.Rendezvous is -- record for another call. -- We rely on the Caller's lock for call State mod's. - -- We can't lock Acceptor.Parent while holding Acceptor, - -- so lock it in advance if we expect to need to lock it. - - if Acceptor.Terminate_Alternative then - STPO.Write_Lock (Parent); - Parent_Locked := True; - end if; + -- If Acceptor.Terminate_Alternative is True, we need to lock Parent and + -- Acceptor, in that order; otherwise, we only need a lock on + -- Acceptor. However, we can't check Acceptor.Terminate_Alternative + -- until Acceptor is locked. Therefore, we need to lock both. Attempts + -- to avoid locking Parent tend to result in race conditions. It would + -- work to unlock Parent immediately upon finding + -- Acceptor.Terminate_Alternative to be False, but that violates the + -- rule of properly nested locking (see System.Tasking). + STPO.Write_Lock (Parent); STPO.Write_Lock (Acceptor); -- If the acceptor is not callable, abort the call and return False if not Acceptor.Callable then STPO.Unlock (Acceptor); - - if Parent_Locked then - STPO.Unlock (Parent); - end if; + STPO.Unlock (Parent); pragma Assert (Entry_Call.State < Done); @@ -1186,10 +1184,7 @@ package body System.Tasking.Rendezvous is STPO.Wakeup (Acceptor, Acceptor_Sleep); STPO.Unlock (Acceptor); - - if Parent_Locked then - STPO.Unlock (Parent); - end if; + STPO.Unlock (Parent); STPO.Write_Lock (Entry_Call.Self); Initialization.Wakeup_Entry_Caller @@ -1207,10 +1202,7 @@ package body System.Tasking.Rendezvous is end if; STPO.Unlock (Acceptor); - - if Parent_Locked then - STPO.Unlock (Parent); - end if; + STPO.Unlock (Parent); end if; return True; @@ -1236,10 +1228,7 @@ package body System.Tasking.Rendezvous is and then Entry_Call.Cancellation_Attempted) then STPO.Unlock (Acceptor); - - if Parent_Locked then - STPO.Unlock (Parent); - end if; + STPO.Unlock (Parent); STPO.Write_Lock (Entry_Call.Self); @@ -1261,10 +1250,7 @@ package body System.Tasking.Rendezvous is New_State (Entry_Call.With_Abort, Entry_Call.State); STPO.Unlock (Acceptor); - - if Parent_Locked then - STPO.Unlock (Parent); - end if; + STPO.Unlock (Parent); if Old_State /= Entry_Call.State and then Entry_Call.State = Now_Abortable diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index b264d8bfd61..f0bc8e017de 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -3380,9 +3380,11 @@ package body Sem_Ch12 is end; -- If we are generating calling stubs, we never need a body for an - -- instantiation from source. However normal processing occurs for - -- any generic instantiation appearing in generated code, since we - -- do not generate stubs in that case. + -- instantiation from source in the visible part, because in that + -- case we'll be generating stubs for any subprogram in the instance. + -- However normal processing occurs for instantiations in generated + -- code or in the private part, since in those cases we do not + -- generate stubs. if Distribution_Stub_Mode = Generate_Caller_Stub_Body and then Comes_From_Source (N) @@ -6295,8 +6297,8 @@ package body Sem_Ch12 is end if; end if; - -- Do not copy the associated node, which points to - -- the generic copy of the aggregate. + -- Do not copy the associated node, which points to the generic copy + -- of the aggregate. declare use Atree.Unchecked_Access; @@ -6310,9 +6312,9 @@ package body Sem_Ch12 is Set_Field5 (New_N, Copy_Generic_Descendant (Field5 (N))); end; - -- Allocators do not have an identifier denoting the access type, - -- so we must locate it through the expression to check whether - -- the views are consistent. + -- Allocators do not have an identifier denoting the access type, so we + -- must locate it through the expression to check whether the views are + -- consistent. elsif Nkind (N) = N_Allocator and then Nkind (Expression (N)) = N_Qualified_Expression @@ -6373,16 +6375,13 @@ package body Sem_Ch12 is -- Don't copy Ident or Comment pragmas, since the comment belongs to the -- generic unit, not to the instantiating unit. - elsif Nkind (N) = N_Pragma - and then Instantiating - then + elsif Nkind (N) = N_Pragma and then Instantiating then declare Prag_Id : constant Pragma_Id := Get_Pragma_Id (N); begin - if Prag_Id = Pragma_Ident - or else Prag_Id = Pragma_Comment - then + if Prag_Id = Pragma_Ident or else Prag_Id = Pragma_Comment then New_N := Make_Null_Statement (Sloc (N)); + else Copy_Descendants; end if; @@ -6411,10 +6410,10 @@ package body Sem_Ch12 is else Copy_Descendants; - if Instantiating - and then Nkind (N) = N_Subprogram_Body - then + if Instantiating and then Nkind (N) = N_Subprogram_Body then Set_Generic_Parent (Specification (New_N), N); + + -- Should preserve Corresponding_Spec??? (12.3(14)) end if; end if; @@ -6455,9 +6454,7 @@ package body Sem_Ch12 is if Renamed_Object (E1) = Pack then return True; - elsif E1 = P - or else Renamed_Object (E1) = P - then + elsif E1 = P or else Renamed_Object (E1) = P then return False; elsif Is_Actual_Of_Previous_Formal (E1) then @@ -6479,7 +6476,7 @@ package body Sem_Ch12 is Instance_Envs.Table (Instance_Envs.Last).Instantiated_Parent.Act_Id; else - Par := Current_Instantiated_Parent.Act_Id; + Par := Current_Instantiated_Parent.Act_Id; end if; if Ekind (Scop) = E_Generic_Package @@ -6675,12 +6672,12 @@ package body Sem_Ch12 is end loop; -- At this point P1 and P2 are at the same distance from the root. - -- We examine their parents until we find a common declarative - -- list, at which point we can establish their relative placement - -- by comparing their ultimate slocs. If we reach the root, - -- N1 and N2 do not descend from the same declarative list (e.g. - -- one is nested in the declarative part and the other is in a block - -- in the statement part) and the earlier one is already frozen. + -- We examine their parents until we find a common declarative list, + -- at which point we can establish their relative placement by + -- comparing their ultimate slocs. If we reach the root, N1 and N2 + -- do not descend from the same declarative list (e.g. one is nested + -- in the declarative part and the other is in a block in the + -- statement part) and the earlier one is already frozen. while not Is_List_Member (P1) or else not Is_List_Member (P2) @@ -6814,9 +6811,9 @@ package body Sem_Ch12 is In_Same_Declarative_Part (Freeze_Node (Par), Parent (Enc_I))) then -- The enclosing package may contain several instances. Rather - -- than computing the earliest point at which to insert its - -- freeze node, we place it at the end of the declarative part - -- of the parent of the generic. + -- than computing the earliest point at which to insert its freeze + -- node, we place it at the end of the declarative part of the + -- parent of the generic. Insert_After_Last_Decl (Freeze_Node (Par), Package_Freeze_Node (Enc_I)); @@ -6838,12 +6835,12 @@ package body Sem_Ch12 is -- Freeze package that encloses instance, and place node after -- package that encloses generic. If enclosing package is already - -- frozen we have to assume it is at the proper place. This may be - -- a potential ABE that requires dynamic checking. Do not add a - -- freeze node if the package that encloses the generic is inside - -- the body that encloses the instance, because the freeze node - -- would be in the wrong scope. Additional contortions needed if - -- the bodies are within a subunit. + -- frozen we have to assume it is at the proper place. This may be a + -- potential ABE that requires dynamic checking. Do not add a freeze + -- node if the package that encloses the generic is inside the body + -- that encloses the instance, because the freeze node would be in + -- the wrong scope. Additional contortions needed if the bodies are + -- within a subunit. declare Enclosing_Body : Node_Id; @@ -6921,14 +6918,13 @@ package body Sem_Ch12 is -- investigated, and would allow this function to be significantly -- simplified. ??? - if Present (Package_Instantiation (A)) then - if Nkind (Package_Instantiation (A)) = N_Package_Instantiation then - return Package_Instantiation (A); + Inst := Package_Instantiation (A); + if Present (Inst) then + if Nkind (Inst) = N_Package_Instantiation then + return Inst; - elsif Nkind (Original_Node (Package_Instantiation (A))) = - N_Package_Instantiation - then - return Original_Node (Package_Instantiation (A)); + elsif Nkind (Original_Node (Inst)) = N_Package_Instantiation then + return Original_Node (Inst); end if; end if; @@ -7034,9 +7030,7 @@ package body Sem_Ch12 is -- now we depend on the user not redefining Standard itself in one of -- the parent units. - if Is_Immediately_Visible (C) - and then C /= Standard_Standard - then + if Is_Immediately_Visible (C) and then C /= Standard_Standard then Set_Is_Immediately_Visible (C, False); Append_Elmt (C, Hidden_Entities); end if; @@ -7143,8 +7137,7 @@ package body Sem_Ch12 is -- might produce false positives in rare cases, but guarantees -- that we produce all the instance bodies we will need. - if (Is_Entity_Name (Nam) - and then Chars (Nam) = Chars (E)) + if (Is_Entity_Name (Nam) and then Chars (Nam) = Chars (E)) or else (Nkind (Nam) = N_Selected_Component and then Chars (Selector_Name (Nam)) = Chars (E)) then @@ -7321,8 +7314,8 @@ package body Sem_Ch12 is begin - -- If the body is a subunit, the freeze point is the corresponding - -- stub in the current compilation, not the subunit itself. + -- If the body is a subunit, the freeze point is the corresponding stub + -- in the current compilation, not the subunit itself. if Nkind (Parent (Gen_Body)) = N_Subunit then Orig_Body := Corresponding_Stub (Parent (Gen_Body)); diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 054c7a82d40..1566890c3de 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -6423,8 +6423,9 @@ package body Sem_Ch6 is -- If the body already exists, then this is an error unless -- the previous declaration is the implicit declaration of a - -- derived subprogram, or this is a spurious overloading in an - -- instance. + -- derived subprogram. It is also legal for an instance to + -- contain type conformant overloadable declarations (but the + -- generic declaration may not), per 8.3(26/2). elsif No (Alias (E)) and then not Is_Intrinsic_Subprogram (E) -- 2.30.2