diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 0134a76a111..f2dfb3e456a 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,24 @@ +2014-07-16 Vadim Godunko + + * a-coinho-shared.adb (Adjust): Create + copy of internal shared object and element when source container + is locked. + (Copy): Likewise. + (Query_Element): Likewise. + (Update_Element): Likewise. + (Constant_Reference): Likewise. Raise Constraint_Error on attempt + to get reference for empty holder. + (Reference): Likewise. + +2014-07-16 Thomas Quinot + + * exp_ch4.adb (Find_Hook_Context): New subprogram, extracted + from Process_Transient_Oject. + * exp_ch4.ads: Ditto. + * exp_ch9.adb (Build_Class_Wide_Master): Insert the _master + declaration as an action on the topmost enclosing expression, + not on a possibly conditional subexpreession. + 2014-07-16 Vadim Godunko * a-coinho.adb, a-coinho-shared.adb, a-coinho.ads, a-coinho-shared.ads: diff --git a/gcc/ada/a-coinho-shared.adb b/gcc/ada/a-coinho-shared.adb index defdf3ad17f..be45c90fd5a 100644 --- a/gcc/ada/a-coinho-shared.adb +++ b/gcc/ada/a-coinho-shared.adb @@ -57,7 +57,20 @@ package body Ada.Containers.Indefinite_Holders is overriding procedure Adjust (Container : in out Holder) is begin if Container.Reference /= null then - Reference (Container.Reference); + if Container.Busy = 0 then + -- Container is not locked, reuse existing internal shared object. + + Reference (Container.Reference); + else + -- Otherwise, create copy of both internal shared object and + -- element. + + Container.Reference := + new Shared_Holder' + (Counter => <>, + Element => + new Element_Type'(Container.Reference.Element.all)); + end if; end if; Container.Busy := 0; @@ -113,16 +126,34 @@ package body Ada.Containers.Indefinite_Holders is ------------------------ function Constant_Reference - (Container : aliased Holder) return Constant_Reference_Type - is - Ref : constant Constant_Reference_Type := - (Element => Container.Reference.Element.all'Access, - Control => (Controlled with Container'Unrestricted_Access)); - B : Natural renames Ref.Control.Container.Busy; + (Container : aliased Holder) return Constant_Reference_Type is begin - Reference (Ref.Control.Container.Reference); - B := B + 1; - return Ref; + if Container.Reference = null then + raise Constraint_Error with "container is empty"; + + elsif Container.Busy = 0 + and then not System.Atomic_Counters.Is_One + (Container.Reference.Counter) + then + -- Container is not locked and internal shared object is used by + -- other container, create copy of both internal shared object and + -- element. + + Container'Unrestricted_Access.Reference := + new Shared_Holder' + (Counter => <>, + Element => new Element_Type'(Container.Reference.Element.all)); + end if; + + declare + Ref : constant Constant_Reference_Type := + (Element => Container.Reference.Element.all'Access, + Control => (Controlled with Container'Unrestricted_Access)); + begin + Reference (Ref.Control.Container.Reference); + Ref.Control.Container.Busy := Ref.Control.Container.Busy + 1; + return Ref; + end; end Constant_Reference; ---------- @@ -133,10 +164,21 @@ package body Ada.Containers.Indefinite_Holders is begin if Source.Reference = null then return (Controlled with null, 0); - else + elsif Source.Busy = 0 then + -- Container is not locked, reuse internal shared object. + Reference (Source.Reference); return (Controlled with Source.Reference, 0); + else + -- Otherwise, create copy of both internal shared object and elemet. + + return + (Controlled with + new Shared_Holder' + (Counter => <>, + Element => new Element_Type'(Source.Reference.Element.all)), + 0); end if; end Copy; @@ -224,6 +266,19 @@ package body Ada.Containers.Indefinite_Holders is begin if Container.Reference = null then raise Constraint_Error with "container is empty"; + + elsif Container.Busy = 0 + and then not System.Atomic_Counters.Is_One + (Container.Reference.Counter) + then + -- Container is not locked and internal shared object is used by + -- other container, create copy of both internal shared object and + -- element. + + Container'Unrestricted_Access.Reference := + new Shared_Holder' + (Counter => <>, + Element => new Element_Type'(Container.Reference.Element.all)); end if; B := B + 1; @@ -284,15 +339,34 @@ package body Ada.Containers.Indefinite_Holders is end Reference; function Reference - (Container : aliased in out Holder) return Reference_Type - is - Ref : constant Reference_Type := - (Element => Container.Reference.Element.all'Access, - Control => (Controlled with Container'Unrestricted_Access)); + (Container : aliased in out Holder) return Reference_Type is begin - Reference (Ref.Control.Container.Reference); - Container.Busy := Container.Busy + 1; - return Ref; + if Container.Reference = null then + raise Constraint_Error with "container is empty"; + + elsif Container.Busy = 0 + and then not System.Atomic_Counters.Is_One + (Container.Reference.Counter) + then + -- Container is not locked and internal shared object is used by + -- other container, create copy of both internal shared object and + -- element. + + Container.Reference := + new Shared_Holder' + (Counter => <>, + Element => new Element_Type'(Container.Reference.Element.all)); + end if; + + declare + Ref : constant Reference_Type := + (Element => Container.Reference.Element.all'Access, + Control => (Controlled with Container'Unrestricted_Access)); + begin + Reference (Ref.Control.Container.Reference); + Ref.Control.Container.Busy := Ref.Control.Container.Busy + 1; + return Ref; + end; end Reference; --------------------- @@ -387,6 +461,19 @@ package body Ada.Containers.Indefinite_Holders is begin if Container.Reference = null then raise Constraint_Error with "container is empty"; + + elsif Container.Busy = 0 + and then not System.Atomic_Counters.Is_One + (Container.Reference.Counter) + then + -- Container is not locked and internal shared object is used by + -- other container, create copy of both internal shared object and + -- element. + + Container'Unrestricted_Access.Reference := + new Shared_Holder' + (Counter => <>, + Element => new Element_Type'(Container.Reference.Element.all)); end if; B := B + 1; diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 5b9eb86c2cb..7b97e25ccbe 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -11390,6 +11390,145 @@ package body Exp_Ch4 is Adjust_Result_Type (N, Typ); end Expand_Short_Circuit_Operator; + ----------------------- + -- Find_Hook_Context -- + ----------------------- + + function Find_Hook_Context (N : Node_Id) return Node_Id is + Par : Node_Id; + Top : Node_Id; + + Wrapped_Node : Node_Id; + -- Note: if we are in a transient scope, we want to reuse it as + -- the context for actions insertion, if possible. But if N is itself + -- part of the stored actions for the current transient scope, + -- then we need to insert at the appropriate (inner) location in + -- the not as an action on Node_To_Be_Wrapped. + + In_Cond_Expr : constant Boolean := Within_Case_Or_If_Expression (N); + + begin + -- When the node is inside a case/if expression, the lifetime of any + -- temporary controlled object is extended. Find a suitable insertion + -- node by locating the topmost case or if expressions. + + if In_Cond_Expr then + Par := N; + Top := N; + while Present (Par) loop + if Nkind_In (Original_Node (Par), N_Case_Expression, + N_If_Expression) + then + Top := Par; + + -- Prevent the search from going too far + + elsif Is_Body_Or_Package_Declaration (Par) then + exit; + end if; + + Par := Parent (Par); + end loop; + + -- The topmost case or if expression is now recovered, but it may + -- still not be the correct place to add generated code. Climb to + -- find a parent that is part of a declarative or statement list, + -- and is not a list of actuals in a call. + + Par := Top; + while Present (Par) loop + if Is_List_Member (Par) + and then not Nkind_In (Par, N_Component_Association, + N_Discriminant_Association, + N_Parameter_Association, + N_Pragma_Argument_Association) + and then not Nkind_In + (Parent (Par), N_Function_Call, + N_Procedure_Call_Statement, + N_Entry_Call_Statement) + + then + return Par; + + -- Prevent the search from going too far + + elsif Is_Body_Or_Package_Declaration (Par) then + exit; + end if; + + Par := Parent (Par); + end loop; + + return Par; + + else + Par := N; + while Present (Par) loop + + -- Keep climbing past various operators + + if Nkind (Parent (Par)) in N_Op + or else Nkind_In (Parent (Par), N_And_Then, N_Or_Else) + then + Par := Parent (Par); + else + exit; + end if; + end loop; + + Top := Par; + + -- The node may be located in a pragma in which case return the + -- pragma itself: + + -- pragma Precondition (... and then Ctrl_Func_Call ...); + + -- Similar case occurs when the node is related to an object + -- declaration or assignment: + + -- Obj [: Some_Typ] := ... and then Ctrl_Func_Call ...; + + -- Another case to consider is when the node is part of a return + -- statement: + + -- return ... and then Ctrl_Func_Call ...; + + -- Another case is when the node acts as a formal in a procedure + -- call statement: + + -- Proc (... and then Ctrl_Func_Call ...); + + if Scope_Is_Transient then + Wrapped_Node := Node_To_Be_Wrapped; + else + Wrapped_Node := Empty; + end if; + + while Present (Par) loop + if Par = Wrapped_Node + or else Nkind_In (Par, N_Assignment_Statement, + N_Object_Declaration, + N_Pragma, + N_Procedure_Call_Statement, + N_Simple_Return_Statement) + then + return Par; + + -- Prevent the search from going too far + + elsif Is_Body_Or_Package_Declaration (Par) then + exit; + end if; + + Par := Parent (Par); + end loop; + + -- Return the topmost short circuit operator + + return Top; + end if; + end Find_Hook_Context; + ------------------------------------- -- Fixup_Universal_Fixed_Operation -- ------------------------------------- @@ -12548,211 +12687,6 @@ package body Exp_Ch4 is (Decl : Node_Id; Rel_Node : Node_Id) is - Hook_Context : Node_Id; - -- Node on which to insert the hook pointer (as an action) - - Finalization_Context : Node_Id; - -- Node after which to insert finalization actions - - Finalize_Always : Boolean; - -- If False, call to finalizer includes a test of whether the - -- hook pointer is null. - - procedure Find_Enclosing_Contexts (N : Node_Id); - -- Find the logical context where N appears, and initialize - -- Hook_Context and Finalization_Context accordingly. Also - -- sets Finalize_Always. - - ----------------------------- - -- Find_Enclosing_Contexts -- - ----------------------------- - - procedure Find_Enclosing_Contexts (N : Node_Id) is - Par : Node_Id; - Top : Node_Id; - - Wrapped_Node : Node_Id; - -- Note: if we are in a transient scope, we want to reuse it as - -- the context for actions insertion, if possible. But if N is itself - -- part of the stored actions for the current transient scope, - -- then we need to insert at the appropriate (inner) location in - -- the not as an action on Node_To_Be_Wrapped. - - In_Cond_Expr : constant Boolean := Within_Case_Or_If_Expression (N); - - begin - -- When the node is inside a case/if expression, the lifetime of any - -- temporary controlled object is extended. Find a suitable insertion - -- node by locating the topmost case or if expressions. - - if In_Cond_Expr then - Par := N; - Top := N; - while Present (Par) loop - if Nkind_In (Original_Node (Par), N_Case_Expression, - N_If_Expression) - then - Top := Par; - - -- Prevent the search from going too far - - elsif Is_Body_Or_Package_Declaration (Par) then - exit; - end if; - - Par := Parent (Par); - end loop; - - -- The topmost case or if expression is now recovered, but it may - -- still not be the correct place to add generated code. Climb to - -- find a parent that is part of a declarative or statement list, - -- and is not a list of actuals in a call. - - Par := Top; - while Present (Par) loop - if Is_List_Member (Par) - and then not Nkind_In (Par, N_Component_Association, - N_Discriminant_Association, - N_Parameter_Association, - N_Pragma_Argument_Association) - and then not Nkind_In - (Parent (Par), N_Function_Call, - N_Procedure_Call_Statement, - N_Entry_Call_Statement) - - then - Hook_Context := Par; - goto Hook_Context_Found; - - -- Prevent the search from going too far - - elsif Is_Body_Or_Package_Declaration (Par) then - exit; - end if; - - Par := Parent (Par); - end loop; - - Hook_Context := Par; - goto Hook_Context_Found; - - else - Par := N; - while Present (Par) loop - - -- Keep climbing past various operators - - if Nkind (Parent (Par)) in N_Op - or else Nkind_In (Parent (Par), N_And_Then, N_Or_Else) - then - Par := Parent (Par); - else - exit; - end if; - end loop; - - Top := Par; - - -- The node may be located in a pragma in which case return the - -- pragma itself: - - -- pragma Precondition (... and then Ctrl_Func_Call ...); - - -- Similar case occurs when the node is related to an object - -- declaration or assignment: - - -- Obj [: Some_Typ] := ... and then Ctrl_Func_Call ...; - - -- Another case to consider is when the node is part of a return - -- statement: - - -- return ... and then Ctrl_Func_Call ...; - - -- Another case is when the node acts as a formal in a procedure - -- call statement: - - -- Proc (... and then Ctrl_Func_Call ...); - - if Scope_Is_Transient then - Wrapped_Node := Node_To_Be_Wrapped; - else - Wrapped_Node := Empty; - end if; - - while Present (Par) loop - if Par = Wrapped_Node - or else Nkind_In (Par, N_Assignment_Statement, - N_Object_Declaration, - N_Pragma, - N_Procedure_Call_Statement, - N_Simple_Return_Statement) - then - Hook_Context := Par; - goto Hook_Context_Found; - - -- Prevent the search from going too far - - elsif Is_Body_Or_Package_Declaration (Par) then - exit; - end if; - - Par := Parent (Par); - end loop; - - -- Return the topmost short circuit operator - - Hook_Context := Top; - end if; - - <> - - -- Special case for Boolean EWAs: capture expression in a temporary, - -- whose declaration will serve as the context around which to insert - -- finalization code. The finalization thus remains local to the - -- specific condition being evaluated. - - if Is_Boolean_Type (Etype (N)) then - - -- In this case, the finalization context is chosen so that - -- we know at finalization point that the hook pointer is - -- never null, so no need for a test, we can call the finalizer - -- unconditionally, except in the case where the object is - -- created in a specific branch of a conditional expression. - - Finalize_Always := - not (In_Cond_Expr - or else - Nkind_In (Original_Node (N), N_Case_Expression, - N_If_Expression)); - - declare - Loc : constant Source_Ptr := Sloc (N); - Temp : constant Entity_Id := Make_Temporary (Loc, 'E', N); - - begin - Append_To (Actions (N), - Make_Object_Declaration (Loc, - Defining_Identifier => Temp, - Constant_Present => True, - Object_Definition => - New_Occurrence_Of (Etype (N), Loc), - Expression => Expression (N))); - Finalization_Context := Last (Actions (N)); - - Analyze (Last (Actions (N))); - - Set_Expression (N, New_Occurrence_Of (Temp, Loc)); - Analyze (Expression (N)); - end; - - else - Finalize_Always := False; - Finalization_Context := Hook_Context; - end if; - end Find_Enclosing_Contexts; - - -- Local variables - Loc : constant Source_Ptr := Sloc (Decl); Obj_Id : constant Entity_Id := Defining_Identifier (Decl); Obj_Typ : constant Node_Id := Etype (Obj_Id); @@ -12763,10 +12697,66 @@ package body Exp_Ch4 is Temp_Id : Entity_Id; Temp_Ins : Node_Id; - -- Start of processing for Process_Transient_Object + Hook_Context : constant Node_Id := Find_Hook_Context (Rel_Node); + -- Node on which to insert the hook pointer (as an action): the + -- innermost enclosing non-transient scope. + + Finalization_Context : Node_Id; + -- Node after which to insert finalization actions + + Finalize_Always : Boolean; + -- If False, call to finalizer includes a test of whether the + -- hook pointer is null. + + In_Cond_Expr : constant Boolean := + Within_Case_Or_If_Expression (Rel_Node); begin - Find_Enclosing_Contexts (Rel_Node); + -- Step 0: determine where to attach finalization actions in the tree + + -- Special case for Boolean EWAs: capture expression in a temporary, + -- whose declaration will serve as the context around which to insert + -- finalization code. The finalization thus remains local to the + -- specific condition being evaluated. + + if Is_Boolean_Type (Etype (Rel_Node)) then + + -- In this case, the finalization context is chosen so that + -- we know at finalization point that the hook pointer is + -- never null, so no need for a test, we can call the finalizer + -- unconditionally, except in the case where the object is + -- created in a specific branch of a conditional expression. + + Finalize_Always := + not (In_Cond_Expr + or else + Nkind_In (Original_Node (Rel_Node), N_Case_Expression, + N_If_Expression)); + + declare + Loc : constant Source_Ptr := Sloc (Rel_Node); + Temp : constant Entity_Id := Make_Temporary (Loc, 'E', Rel_Node); + + begin + Append_To (Actions (Rel_Node), + Make_Object_Declaration (Loc, + Defining_Identifier => Temp, + Constant_Present => True, + Object_Definition => + New_Occurrence_Of (Etype (Rel_Node), Loc), + Expression => Expression (Rel_Node))); + Finalization_Context := Last (Actions (Rel_Node)); + + Analyze (Last (Actions (Rel_Node))); + + Set_Expression (Rel_Node, New_Occurrence_Of (Temp, Loc)); + Analyze (Expression (Rel_Node)); + end; + + else + Finalize_Always := False; + Finalization_Context := Hook_Context; + end if; -- Step 1: Create the access type which provides a reference to the -- transient controlled object. diff --git a/gcc/ada/exp_ch4.ads b/gcc/ada/exp_ch4.ads index 676aeb22588..c7686f746ed 100644 --- a/gcc/ada/exp_ch4.ads +++ b/gcc/ada/exp_ch4.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT 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- -- @@ -103,4 +103,11 @@ package Exp_Ch4 is -- have special circuitry in Expand_N_Type_Conversion to promote both of -- the operands to type Integer. + function Find_Hook_Context (N : Node_Id) return Node_Id; + -- Determine a suitable node on which to attach actions related to N + -- that need to be elaborated unconditionally (i.e. in general the topmost + -- expression of which N is a subexpression, which may or may not be + -- evaluated, for example if N is the right operand of a short circuit + -- operator). + end Exp_Ch4; diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index e1a4d0f49a5..c8f2943d18b 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -29,6 +29,7 @@ with Einfo; use Einfo; with Elists; use Elists; with Errout; use Errout; with Exp_Ch3; use Exp_Ch3; +with Exp_Ch4; use Exp_Ch4; with Exp_Ch6; use Exp_Ch6; with Exp_Ch11; use Exp_Ch11; with Exp_Dbug; use Exp_Dbug; @@ -1151,7 +1152,6 @@ package body Exp_Ch9 is then declare Master_Decl : Node_Id; - begin Set_Has_Master_Entity (Master_Scope); @@ -1169,7 +1169,7 @@ package body Exp_Ch9 is Make_Explicit_Dereference (Loc, New_Occurrence_Of (RTE (RE_Current_Master), Loc))); - Insert_Action (Related_Node, Master_Decl); + Insert_Action (Find_Hook_Context (Related_Node), Master_Decl); Analyze (Master_Decl); -- Mark the containing scope as a task master. Masters associated