This change addresses a missing unlock operation for the case of a call to a protected function appearing as the expression of a RETURN statement: the unlock was inserted after the statement containing the protected function call, which means that in the case of a RETURN statement it would never be executed. It is now properly generated as a cleanup action that is executed in all cases.
The following test case must display '42' without hanging when executed repeatedly: $ gnatmake -q shared_prot_func_ret.adb $ ./shared_prot_func_ret 42 $ ./shared_prot_func_ret 42 package body Session_Db is type Table_Entry is record V, N : Integer; end record; protected Table is procedure Add (Name, Value : Integer); function Find (Name : Integer) return Integer; private T : Table_Entry; end Table; protected body Table is procedure Add (Name, Value : Integer) is begin T := (N => Name, V => Value); end Add; function Find (Name : Integer) return Integer is begin return T.V; end Find; end Table; --------- -- Add -- --------- procedure Add (Name : Integer; Value : Integer) is begin Table.Add (Name, Value); end Add; ---------- -- Find -- ---------- function Find (Name : Integer) return Integer is begin return Table.Find (Name); end Find; end Session_Db; package Session_Db is pragma Shared_Passive; procedure Add (Name : Integer; Value : Integer); function Find (Name : Integer) return Integer; end Session_Db; with Session_Db; use Session_Db; with Ada.Text_IO; use Ada.Text_IO; procedure Shared_Prot_Func_Ret is begin Session_Db.Add (3, 42); Put_Line (Session_Db.Find (3)'Img); end; Tested on x86_64-pc-linux-gnu, committed on trunk 2014-07-17 Thomas Quinot <qui...@adacore.com> * sem.ads (Scope_Stack_Entry): Reorganize storage of action lists; introduce a new list (cleanup actions) for each (transient) scope. * sinfo.ads, sinfo.adb (Cleanup_Actions): New attribute for N_Block_Statement * exp_ch7.ads (Store_Cleanup_Actions_In_Scope): New subprogram. * exp_ch7.adb (Store_Actions_In_Scope): New subprogram, common processing for Store_xxx_Actions_In_Scope. (Build_Cleanup_Statements): Allow for a list of additional cleanup statements to be passed by the caller. (Expand_Cleanup_Actions): Take custom cleanup actions associated with an N_Block_Statement into account. (Insert_Actions_In_Scope_Around): Account for Scope_Stack_Entry reorganization (refactoring only, no behaviour change). (Make_Transient_Block): Add assertion to ensure that the current scope is indeed a block (namely, the entity for the transient block being constructed syntactically, which has already been established as a scope). If cleanup actions are present in the transient scope, transfer them now to the transient block. * exp_ch6.adb (Expand_Protected_Subprogram_Call): Freeze the called function while it is still present as the name in a call in the tree. This may not be the case later on if the call is rewritten into a transient block. * exp_smem.adb (Add_Shared_Var_Lock_Procs): The post-actions inserted after calling a protected operation on a shared passive protected must be performed in a block finalizer, not just inserted in the tree, so that they are executed even in case of a normal (RETURN) or abnormal (exception) transfer of control outside of the current scope. * exp_smem.ads (Add_Shared_Var_Lock_Procs): Update documentation * sem_ch8.adb, expander.adb, exp_ch11.adb: Adjust for Scope_Stack_Entry reorganization.
Index: exp_ch7.adb =================================================================== --- exp_ch7.adb (revision 212718) +++ exp_ch7.adb (working copy) @@ -150,6 +150,9 @@ -- ??? The entire comment needs to be rewritten -- ??? which entire comment? + procedure Store_Actions_In_Scope (AK : Scope_Action_Kind; L : List_Id); + -- Shared processing for Store_xxx_Actions_In_Scope + ----------------------------- -- Finalization Management -- ----------------------------- @@ -296,11 +299,14 @@ -- Build the deep Initialize/Adjust/Finalize for a record Typ with -- Has_Controlled_Component set and store them using the TSS mechanism. - function Build_Cleanup_Statements (N : Node_Id) return List_Id; + function Build_Cleanup_Statements + (N : Node_Id; + Additional_Cleanup : List_Id) return List_Id; -- Create the clean up calls for an asynchronous call block, task master, - -- protected subprogram body, task allocation block or task body. If the - -- context does not contain the above constructs, the routine returns an - -- empty list. + -- protected subprogram body, task allocation block or task body, or + -- additional cleanup actions parked on a transient block. If the context + -- does not contain the above constructs, the routine returns an empty + -- list. procedure Build_Finalizer (N : Node_Id; @@ -467,7 +473,10 @@ -- Build_Cleanup_Statements -- ------------------------------ - function Build_Cleanup_Statements (N : Node_Id) return List_Id is + function Build_Cleanup_Statements + (N : Node_Id; + Additional_Cleanup : List_Id) return List_Id + is Is_Asynchronous_Call : constant Boolean := Nkind (N) = N_Block_Statement and then Is_Asynchronous_Call_Block (N); @@ -626,6 +635,7 @@ end; end if; + Append_List_To (Stmts, Additional_Cleanup); return Stmts; end Build_Cleanup_Statements; @@ -792,9 +802,7 @@ -- Start of processing for Build_Finalization_Master begin - if Is_Private_Type (Ptr_Typ) - and then Present (Full_View (Ptr_Typ)) - then + if Is_Private_Type (Ptr_Typ) and then Present (Full_View (Ptr_Typ)) then Ptr_Typ := Full_View (Ptr_Typ); end if; @@ -887,9 +895,7 @@ -- inserted in the same source unit only once. The only exception to -- this are instances using the same access type as generic actual. - if Comes_From_Source (Ptr_Typ) - and then not Inside_A_Generic - then + if Comes_From_Source (Ptr_Typ) and then not Inside_A_Generic then Fin_Mas_Id := Make_Defining_Identifier (Loc, Chars => New_External_Name (Chars (Ptr_Typ), "FM")); @@ -1436,9 +1442,7 @@ Expression => Make_Identifier (Loc, Chars (Counter_Id)), Alternatives => Jump_Alts); - if Acts_As_Clean - and then Present (Jump_Block_Insert_Nod) - then + if Acts_As_Clean and then Present (Jump_Block_Insert_Nod) then Insert_After (Jump_Block_Insert_Nod, Jump_Block); else Prepend_To (Finalizer_Stmts, Jump_Block); @@ -1481,10 +1485,7 @@ -- aborts are allowed and the clean up statements require deferral or -- there are controlled objects to be finalized. - if Abort_Allowed - and then - (Defer_Abort or else Has_Ctrl_Objs) - then + if Abort_Allowed and then (Defer_Abort or Has_Ctrl_Objs) then Prepend_To (Finalizer_Stmts, Make_Procedure_Call_Statement (Loc, Name => New_Occurrence_Of (RTE (RE_Abort_Defer), Loc))); @@ -1502,10 +1503,7 @@ -- Raise_From_Controlled_Operation (E); -- end if; - if Has_Ctrl_Objs - and then Exceptions_OK - and then not For_Package - then + if Has_Ctrl_Objs and Exceptions_OK and not For_Package then Append_To (Finalizer_Stmts, Build_Raise_Statement (Finalizer_Data)); end if; @@ -1608,9 +1606,7 @@ -- When the finalizer acts solely as a clean up routine, the body -- is inserted right after the spec. - if Acts_As_Clean - and then not Has_Ctrl_Objs - then + if Acts_As_Clean and then not Has_Ctrl_Objs then Insert_After (Fin_Spec, Fin_Body); -- In all other cases the body is inserted after either: @@ -1706,9 +1702,7 @@ if Preprocess then Has_Tagged_Types := True; - if Top_Level - and then No (Last_Top_Level_Ctrl_Construct) - then + if Top_Level and then No (Last_Top_Level_Ctrl_Construct) then Last_Top_Level_Ctrl_Construct := Decl; end if; @@ -1723,9 +1717,7 @@ Counter_Val := Counter_Val + 1; Has_Ctrl_Objs := True; - if Top_Level - and then No (Last_Top_Level_Ctrl_Construct) - then + if Top_Level and then No (Last_Top_Level_Ctrl_Construct) then Last_Top_Level_Ctrl_Construct := Decl; end if; @@ -1774,9 +1766,7 @@ -- finalization disabled. This applies only to objects at the -- library level. - if For_Package - and then Finalize_Storage_Only (Obj_Typ) - then + if For_Package and then Finalize_Storage_Only (Obj_Typ) then null; -- Transient variables are treated separately in order to @@ -1824,7 +1814,7 @@ elsif Is_Access_Type (Obj_Typ) and then Present (Status_Flag_Or_Transient_Decl (Obj_Id)) and then Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) = - N_Object_Declaration + N_Object_Declaration and then Is_Finalizable_Transient (Status_Flag_Or_Transient_Decl (Obj_Id), Decl) then @@ -1893,9 +1883,7 @@ -- finalization disabled. This applies only to objects at the -- library level. - if For_Package - and then Finalize_Storage_Only (Obj_Typ) - then + if For_Package and then Finalize_Storage_Only (Obj_Typ) then null; -- Return object of a build-in-place function. This case is @@ -3534,9 +3522,7 @@ begin Func_Id := E; - while Present (Func_Id) - and then Func_Id /= Standard_Standard - loop + while Present (Func_Id) and then Func_Id /= Standard_Standard loop if Ekind (Func_Id) = E_Function then return Func_Id; end if; @@ -3691,6 +3677,9 @@ and then not Sec_Stack_Needed_For_Return (Scop) and then VM_Target = No_VM; + Needs_Custom_Cleanup : constant Boolean := + Nkind (N) = N_Block_Statement + and then Present (Cleanup_Actions (N)); Actions_Required : constant Boolean := Requires_Cleanup_Actions (N, True) @@ -3699,10 +3688,12 @@ or else Is_Protected_Body or else Is_Task_Allocation or else Is_Task_Body - or else Needs_Sec_Stack_Mark; + or else Needs_Sec_Stack_Mark + or else Needs_Custom_Cleanup; HSS : Node_Id := Handled_Statement_Sequence (N); Loc : Source_Ptr; + Cln : List_Id; procedure Wrap_HSS_In_Block; -- Move HSS inside a new block along with the original exception @@ -3761,6 +3752,12 @@ return; end if; + if Needs_Custom_Cleanup then + Cln := Cleanup_Actions (N); + else + Cln := No_List; + end if; + declare Decls : List_Id := Declarations (N); Fin_Id : Entity_Id; @@ -3898,7 +3895,7 @@ Build_Finalizer (N => N, - Clean_Stmts => Build_Cleanup_Statements (N), + Clean_Stmts => Build_Cleanup_Statements (N, Cln), Mark_Id => Mark, Top_Decls => New_Decls, Defer_Abort => Nkind (Original_Node (N)) = N_Task_Body @@ -4440,10 +4437,10 @@ ------------------------------------ procedure Insert_Actions_In_Scope_Around (N : Node_Id) is - After : constant List_Id := - Scope_Stack.Table (Scope_Stack.Last).Actions_To_Be_Wrapped_After; - Before : constant List_Id := - Scope_Stack.Table (Scope_Stack.Last).Actions_To_Be_Wrapped_Before; + Act_After : constant List_Id := + Scope_Stack.Table (Scope_Stack.Last).Actions_To_Be_Wrapped (After); + Act_Before : constant List_Id := + Scope_Stack.Table (Scope_Stack.Last).Actions_To_Be_Wrapped (Before); -- Note: We used to use renamings of Scope_Stack.Table (Scope_Stack. -- Last), but this was incorrect as Process_Transient_Object may -- introduce new scopes and cause a reallocation of Scope_Stack.Table. @@ -4794,7 +4791,7 @@ -- Start of processing for Insert_Actions_In_Scope_Around begin - if No (Before) and then No (After) then + if No (Act_Before) and then No (Act_After) then return; end if; @@ -4833,22 +4830,22 @@ -- 3) Target ........ Last_Obj - if Present (Before) then + if Present (Act_Before) then -- Flag declarations are inserted before the first object - First_Obj := First (Before); + First_Obj := First (Act_Before); - Insert_List_Before (Target, Before); + Insert_List_Before (Target, Act_Before); end if; - if Present (After) then + if Present (Act_After) then -- Finalization calls are inserted after the last object - Last_Obj := Last (After); + Last_Obj := Last (Act_After); - Insert_List_After (Target, After); + Insert_List_After (Target, Act_After); end if; -- Check for transient controlled objects associated with Target and @@ -4861,14 +4858,14 @@ -- Reset the action lists - if Present (Before) then + if Present (Act_Before) then Scope_Stack.Table (Scope_Stack.Last). - Actions_To_Be_Wrapped_Before := No_List; + Actions_To_Be_Wrapped (Before) := No_List; end if; - if Present (After) then + if Present (Act_After) then Scope_Stack.Table (Scope_Stack.Last). - Actions_To_Be_Wrapped_After := No_List; + Actions_To_Be_Wrapped (After) := No_List; end if; end; end Insert_Actions_In_Scope_Around; @@ -6564,9 +6561,7 @@ -- order to generate the same state counter names as those from -- Build_Initialize_Statements. - if Num_Comps > 0 - and then Is_Local - then + if Num_Comps > 0 and then Is_Local then Counter := Counter + 1; Counter_Id := @@ -7253,7 +7248,7 @@ Ekind (Typ) = E_Record_Type and then Is_Concurrent_Record_Type (Typ) and then Ekind (Corresponding_Concurrent_Type (Typ)) = - E_Task_Type; + E_Task_Type; Loc : constant Source_Ptr := Sloc (Typ); Proc_Id : Entity_Id; Stmts : List_Id; @@ -7832,8 +7827,10 @@ end if; -- Create the transient block. Set the parent now since the block itself - -- is not part of the tree. + -- is not part of the tree. The current scope is the E_Block entity + -- that has been pushed by Establish_Transient_Scope. + pragma Assert (Ekind (Current_Scope) = E_Block); Block := Make_Block_Statement (Loc, Identifier => New_Occurrence_Of (Current_Scope, Loc), @@ -7853,6 +7850,17 @@ Freeze_All (First_Entity (Current_Scope), Insert); end if; + -- Transfer cleanup actions to the newly created block + + declare + Cleanup_Actions : List_Id + renames Scope_Stack.Table (Scope_Stack.Last). + Actions_To_Be_Wrapped (Cleanup); + begin + Set_Cleanup_Actions (Block, Cleanup_Actions); + Cleanup_Actions := No_List; + end; + -- When the transient scope was established, we pushed the entry for the -- transient scope onto the scope stack, so that the scope was active -- for the installation of finalizable entities etc. Now we must remove @@ -7881,21 +7889,18 @@ Scope_Stack.Table (Scope_Stack.Last).Node_To_Be_Wrapped := N; end Set_Node_To_Be_Wrapped; - ---------------------------------- - -- Store_After_Actions_In_Scope -- - ---------------------------------- + ---------------------------- + -- Store_Actions_In_Scope -- + ---------------------------- - procedure Store_After_Actions_In_Scope (L : List_Id) is - SE : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last); + procedure Store_Actions_In_Scope (AK : Scope_Action_Kind; L : List_Id) is + SE : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last); + Actions : List_Id renames SE.Actions_To_Be_Wrapped (AK); begin - if Present (SE.Actions_To_Be_Wrapped_After) then - Insert_List_Before_And_Analyze - (First (SE.Actions_To_Be_Wrapped_After), L); + if No (Actions) then + Actions := L; - else - SE.Actions_To_Be_Wrapped_After := L; - if Is_List_Member (SE.Node_To_Be_Wrapped) then Set_Parent (L, Parent (SE.Node_To_Be_Wrapped)); else @@ -7903,7 +7908,22 @@ end if; Analyze_List (L); + + elsif AK = Before then + Insert_List_After_And_Analyze (Last (Actions), L); + + else + Insert_List_Before_And_Analyze (First (Actions), L); end if; + end Store_Actions_In_Scope; + + ---------------------------------- + -- Store_After_Actions_In_Scope -- + ---------------------------------- + + procedure Store_After_Actions_In_Scope (L : List_Id) is + begin + Store_Actions_In_Scope (After, L); end Store_After_Actions_In_Scope; ----------------------------------- @@ -7911,26 +7931,19 @@ ----------------------------------- procedure Store_Before_Actions_In_Scope (L : List_Id) is - SE : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last); - begin - if Present (SE.Actions_To_Be_Wrapped_Before) then - Insert_List_After_And_Analyze - (Last (SE.Actions_To_Be_Wrapped_Before), L); + Store_Actions_In_Scope (Before, L); + end Store_Before_Actions_In_Scope; - else - SE.Actions_To_Be_Wrapped_Before := L; + ----------------------------------- + -- Store_Cleanup_Actions_In_Scope -- + ----------------------------------- - if Is_List_Member (SE.Node_To_Be_Wrapped) then - Set_Parent (L, Parent (SE.Node_To_Be_Wrapped)); - else - Set_Parent (L, SE.Node_To_Be_Wrapped); - end if; + procedure Store_Cleanup_Actions_In_Scope (L : List_Id) is + begin + Store_Actions_In_Scope (Cleanup, L); + end Store_Cleanup_Actions_In_Scope; - Analyze_List (L); - end if; - end Store_Before_Actions_In_Scope; - -------------------------------- -- Wrap_Transient_Declaration -- -------------------------------- Index: exp_ch7.ads =================================================================== --- exp_ch7.ads (revision 212716) +++ exp_ch7.ads (working copy) @@ -302,6 +302,10 @@ -- stored in the top of the scope stack (also analyzes these actions). -- Why prepend rather than append ??? + procedure Store_Cleanup_Actions_In_Scope (L : List_Id); + -- Prepend the list L of actions to the beginning of the cleanup-actions + -- store in the top of the scope stack. + procedure Wrap_Transient_Declaration (N : Node_Id); -- N is an object declaration. Expand the finalization calls after the -- declaration and make the outer scope being the transient one. Index: sinfo.adb =================================================================== --- sinfo.adb (revision 212662) +++ sinfo.adb (working copy) @@ -432,6 +432,14 @@ return Node3 (N); end Classifications; + function Cleanup_Actions + (N : Node_Id) return List_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Block_Statement); + return List5 (N); + end Cleanup_Actions; + function Comes_From_Extended_Return_Statement (N : Node_Id) return Boolean is begin @@ -3599,6 +3607,14 @@ Set_Node3 (N, Val); -- semantic field, no parent set end Set_Classifications; + procedure Set_Cleanup_Actions + (N : Node_Id; Val : List_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Block_Statement); + Set_List5 (N, Val); -- semantic field, no parent set + end Set_Cleanup_Actions; + procedure Set_Comes_From_Extended_Return_Statement (N : Node_Id; Val : Boolean := True) is begin Index: sinfo.ads =================================================================== --- sinfo.ads (revision 212716) +++ sinfo.ads (working copy) @@ -832,6 +832,10 @@ -- the secondary stack and thus the result is passed by reference rather -- than copied another time. + -- Cleanup_Actions (List5-Sem) + -- Present in block statements created for transient blocks, contains + -- additional cleanup actions carried over from the transient scope. + -- Check_Address_Alignment (Flag11-Sem) -- A flag present in N_Attribute_Definition clause for a 'Address -- attribute definition. This flag is set if a dynamic check should be @@ -4731,6 +4735,7 @@ -- Identifier (Node1) block direct name (set to Empty if not present) -- Declarations (List2) (set to No_List if no DECLARE part) -- Handled_Statement_Sequence (Node4) + -- Cleanup_Actions (List5-Sem) -- Is_Task_Master (Flag5-Sem) -- Activation_Chain_Entity (Node3-Sem) -- Has_Created_Identifier (Flag15) @@ -8689,6 +8694,9 @@ function Classifications (N : Node_Id) return Node_Id; -- Node3 + function Cleanup_Actions + (N : Node_Id) return List_Id; -- List5 + function Comes_From_Extended_Return_Statement (N : Node_Id) return Boolean; -- Flag18 @@ -9696,6 +9704,9 @@ procedure Set_Classifications (N : Node_Id; Val : Node_Id); -- Node3 + procedure Set_Cleanup_Actions + (N : Node_Id; Val : List_Id); -- List5 + procedure Set_Comes_From_Extended_Return_Statement (N : Node_Id; Val : Boolean := True); -- Flag18 @@ -12369,6 +12380,7 @@ pragma Inline (Choices); pragma Inline (Class_Present); pragma Inline (Classifications); + pragma Inline (Cleanup_Actions); pragma Inline (Comes_From_Extended_Return_Statement); pragma Inline (Compile_Time_Known_Aggregate); pragma Inline (Component_Associations); @@ -12702,6 +12714,7 @@ pragma Inline (Set_Choices); pragma Inline (Set_Class_Present); pragma Inline (Set_Classifications); + pragma Inline (Set_Cleanup_Actions); pragma Inline (Set_Comes_From_Extended_Return_Statement); pragma Inline (Set_Compile_Time_Known_Aggregate); pragma Inline (Set_Component_Associations); Index: sem.ads =================================================================== --- sem.ads (revision 212640) +++ sem.ads (working copy) @@ -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- -- @@ -450,6 +450,11 @@ -- units and their instantiations, have led to a hybrid model that carries -- more state than one would wish. + type Scope_Action_Kind is (Before, After, Cleanup); + type Scope_Actions is array (Scope_Action_Kind) of List_Id; + -- Transient blocks have three associated actions list, to be inserted + -- before and after the block's statements, and as cleanup actions. + type Scope_Stack_Entry is record Entity : Entity_Id; -- Entity representing the scope @@ -496,11 +501,11 @@ -- Only used in transient scopes. Records the node which will -- be wrapped by the transient block. - Actions_To_Be_Wrapped_Before : List_Id; - Actions_To_Be_Wrapped_After : List_Id; - -- Actions that have to be inserted at the start or at the end of a - -- transient block. Used to temporarily hold these actions until the - -- block is created, at which time the actions are moved to the block. + Actions_To_Be_Wrapped : Scope_Actions; + -- Actions that have to be inserted at the start, at the end, or as + -- cleanup actions of a transient block. Used to temporarily hold these + -- actions until the block is created, at which time the actions are + -- moved to the block. Pending_Freeze_Actions : List_Id; -- Used to collect freeze entity nodes and associated actions that are Index: exp_smem.adb =================================================================== --- exp_smem.adb (revision 212640) +++ exp_smem.adb (working copy) @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1998-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1998-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- -- @@ -129,62 +129,65 @@ ------------------------------- procedure Add_Shared_Var_Lock_Procs (N : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); - Obj : constant Entity_Id := Entity (Expression (First_Actual (N))); - Inode : Node_Id; - Vnm : String_Id; + Loc : constant Source_Ptr := Sloc (N); + Obj : constant Entity_Id := Entity (Expression (First_Actual (N))); + Vnm : String_Id; + Vid : Entity_Id; + Aft : constant List_Id := New_List; begin - -- We have to add Shared_Var_Lock and Shared_Var_Unlock calls around - -- the procedure or function call node. First we locate the right place - -- to do the insertion, which is the call itself in the procedure call - -- case, or else the nearest non subexpression node that contains the - -- function call. + Build_Full_Name (Obj, Vnm); - Inode := N; - while Nkind (Inode) /= N_Procedure_Call_Statement - and then Nkind (Inode) in N_Subexpr - loop - Inode := Parent (Inode); - end loop; + -- Create constant string. Note that this must be done prior to + -- establishing the transient scope, as the finalizer needs to have + -- access to this object. - -- Now insert the Lock and Unlock calls and the read/write calls + Vid := Make_Temporary (Loc, 'N', Obj); + Insert_Action (N, + Make_Object_Declaration (Loc, + Defining_Identifier => Vid, + Constant_Present => True, + Object_Definition => New_Occurrence_Of (Standard_String, Loc), + Expression => Make_String_Literal (Loc, Vnm))); - -- Two concerns here. First we are not dealing with the exception case, - -- really we need some kind of cleanup routine to do the Unlock. Second, - -- these lock calls should be inside the protected object processing, - -- not outside, otherwise they can be done at the wrong priority, - -- resulting in dead lock situations ??? + -- Now set up a transient scope around the call, which will hold the + -- required lock/unlock actions. - Build_Full_Name (Obj, Vnm); + Establish_Transient_Scope (N, Sec_Stack => False); -- First insert the Lock call before - Insert_Before_And_Analyze (Inode, + Insert_Action (N, Make_Procedure_Call_Statement (Loc, Name => New_Occurrence_Of (RTE (RE_Shared_Var_Lock), Loc), - Parameter_Associations => New_List ( - Make_String_Literal (Loc, Vnm)))); + Parameter_Associations => New_List (New_Occurrence_Of (Vid, Loc)))); -- Now, right after the Lock, insert a call to read the object - Insert_Before_And_Analyze (Inode, + Insert_Action (N, Build_Shared_Var_Proc_Call (Loc, Obj, Name_Read)); - -- Now insert the Unlock call after + -- Now for a procedure call, but not a function call, insert the + -- call to write the object just before the unlock. - Insert_After_And_Analyze (Inode, + if Nkind (N) = N_Procedure_Call_Statement then + Append_To (Aft, + Build_Shared_Var_Proc_Call (Loc, Obj, Name_Write)); + end if; + + -- Finally insert the Unlock call after + + Append_To (Aft, Make_Procedure_Call_Statement (Loc, Name => New_Occurrence_Of (RTE (RE_Shared_Var_Unlock), Loc), - Parameter_Associations => New_List ( - Make_String_Literal (Loc, Vnm)))); + Parameter_Associations => New_List (New_Occurrence_Of (Vid, Loc)))); - -- Now for a procedure call, but not a function call, insert the - -- call to write the object just before the unlock. + Store_Cleanup_Actions_In_Scope (Aft); if Nkind (N) = N_Procedure_Call_Statement then - Insert_After_And_Analyze (Inode, - Build_Shared_Var_Proc_Call (Loc, Obj, Name_Write)); + Wrap_Transient_Statement (N); + else + Wrap_Transient_Expression (N); end if; end Add_Shared_Var_Lock_Procs; Index: exp_smem.ads =================================================================== --- exp_smem.ads (revision 212640) +++ exp_smem.ads (working copy) @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1998-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1998-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- -- @@ -44,9 +44,10 @@ -- The argument is a protected subprogram call, before it is rewritten -- by Exp_Ch9.Build_Protected_Subprogram_Call. This routine, which is -- called only in the case of an external call to a protected object - -- that has Is_Shared_Passive set, deals with installing the required - -- global lock calls for this case. It also generates the necessary - -- read/write calls for the protected object within the lock region. + -- that has Is_Shared_Passive set, deals with installing a transient scope + -- and acquiring the appropriate global lock calls for this case. It also + -- generates the necessary read/write calls for the protected object within + -- the lock region. function Make_Shared_Var_Procs (N : Node_Id) return Node_Id; -- N is the node for the declaration of a shared passive variable. Index: expander.adb =================================================================== --- expander.adb (revision 212640) +++ expander.adb (working copy) @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- 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- -- @@ -119,10 +119,7 @@ if Serious_Errors_Detected > 0 and then Scope_Is_Transient then Scope_Stack.Table - (Scope_Stack.Last).Actions_To_Be_Wrapped_Before := No_List; - Scope_Stack.Table - (Scope_Stack.Last).Actions_To_Be_Wrapped_After := No_List; - + (Scope_Stack.Last).Actions_To_Be_Wrapped := (others => No_List); Pop_Scope; end if; Index: exp_ch11.adb =================================================================== --- exp_ch11.adb (revision 212640) +++ exp_ch11.adb (working copy) @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- 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- -- @@ -1960,9 +1960,11 @@ begin if LCN = Statements (P) or else - LCN = SSE.Actions_To_Be_Wrapped_Before + LCN = SSE.Actions_To_Be_Wrapped (Before) or else - LCN = SSE.Actions_To_Be_Wrapped_After + LCN = SSE.Actions_To_Be_Wrapped (After) + or else + LCN = SSE.Actions_To_Be_Wrapped (Cleanup) then -- Loop through exception handlers Index: exp_ch6.adb =================================================================== --- exp_ch6.adb (revision 212718) +++ exp_ch6.adb (working copy) @@ -7150,6 +7150,26 @@ is Rec : Node_Id; + procedure Freeze_Called_Function; + -- If it is a function call it can appear in elaboration code and + -- the called entity must be frozen before the call. This must be + -- done before the call is expanded, as the expansion may rewrite it + -- to something other than a call (e.g. a temporary initialized in a + -- transient block). + + ---------------------------- + -- Freeze_Called_Function -- + ---------------------------- + + procedure Freeze_Called_Function is + begin + if Ekind (Subp) = E_Function then + Freeze_Expression (Name (N)); + end if; + end Freeze_Called_Function; + + -- Start of processing for Expand_Protected_Subprogram_Call + begin -- If the protected object is not an enclosing scope, this is an inter- -- object function call. Inter-object procedure calls are expanded by @@ -7170,6 +7190,7 @@ Rec := Prefix (Prefix (Name (N))); end if; + Freeze_Called_Function; Build_Protected_Subprogram_Call (N, Name => New_Occurrence_Of (Subp, Sloc (N)), Rec => Convert_Concurrent (Rec, Etype (Rec)), @@ -7182,6 +7203,7 @@ return; end if; + Freeze_Called_Function; Build_Protected_Subprogram_Call (N, Name => Name (N), Rec => Rec, @@ -7189,13 +7211,6 @@ end if; - -- If it is a function call it can appear in elaboration code and - -- the called entity must be frozen here. - - if Ekind (Subp) = E_Function then - Freeze_Expression (Name (N)); - end if; - -- Analyze and resolve the new call. The actuals have already been -- resolved, but expansion of a function call will add extra actuals -- if needed. Analysis of a procedure call already includes resolution. Index: sem_ch8.adb =================================================================== --- sem_ch8.adb (revision 212640) +++ sem_ch8.adb (working copy) @@ -7541,10 +7541,7 @@ -- this case (and we do the abort even with assertions off since the -- penalty is incorrect code generation). - if SST.Actions_To_Be_Wrapped_Before /= No_List - or else - SST.Actions_To_Be_Wrapped_After /= No_List - then + if SST.Actions_To_Be_Wrapped /= Scope_Actions'(others => No_List) then raise Program_Error; end if; @@ -7611,8 +7608,7 @@ SST.Is_Transient := False; SST.Node_To_Be_Wrapped := Empty; SST.Pending_Freeze_Actions := No_List; - SST.Actions_To_Be_Wrapped_Before := No_List; - SST.Actions_To_Be_Wrapped_After := No_List; + SST.Actions_To_Be_Wrapped := (others => No_List); SST.First_Use_Clause := Empty; SST.Is_Active_Stack_Base := False; SST.Previous_Visibility := False;