Skip to content

R
riscv-gcc-1
Commit 756ef2a0 by Arnaud Charlet
Options

[multiple changes] 

2011-08-04  Emmanuel Briot  <briot@adacore.com>

	* 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  <quinot@adacore.com>

	* sem_ch6.adb: Update comment.
	* sem_ch12.adb: Minor reformatting.

2011-08-04  Bob Duff  <duff@adacore.com>

	* 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
parent 4fdebd93
Showing with 164 additions and 87 deletions
gcc/ada/ChangeLog
2011-08-04 Emmanuel Briot <briot@adacore.com>
* 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 <quinot@adacore.com>
* sem_ch6.adb: Update comment.
* sem_ch12.adb: Minor reformatting.
2011-08-04 Bob Duff <duff@adacore.com>
* 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 <charlet@adacore.com>
* debug.adb: Update comment.
......
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;
......
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
......
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));
......
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)
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment