From: Javier Miranda <mira...@adacore.com> Add dummy build-in-place parameters when a BIP function does not require the BIP parameters but it is a dispatching operation that inherited them.
gcc/ada/ * einfo-utils.adb (Underlying_Type): Protect recursion call against non-available attribute Etype. * einfo.ads (Protected_Subprogram): Fix typo in documentation. * exp_ch3.adb (BIP_Function_Call_Id): New subprogram. (Expand_N_Object_Declaration): Improve code that evaluates if the object is initialized with a BIP function call. * exp_ch6.adb (Is_True_Build_In_Place_Function_Call): New subprogram. (Add_Task_Actuals_To_Build_In_Place_Call): Add dummy actuals if the function does not require the BIP task actuals but it is a dispatching operation that inherited them. (Build_In_Place_Formal): Improve code to avoid never-ending loop if the BIP formal is not found. (Add_Dummy_Build_In_Place_Actuals): New subprogram. (Expand_Call_Helper): Add calls to Add_Dummy_Build_In_Place_Actuals. (Expand_N_Extended_Return_Statement): Adjust assertion. (Expand_Simple_Function_Return): Adjust assertion. (Make_Build_In_Place_Call_In_Allocator): No action needed if the called function inherited the BIP extra formals but it is not a true BIP function. (Make_Build_In_Place_Call_In_Assignment): Ditto. * exp_intr.adb (Expand_Dispatching_Constructor_Call): Remove code reporting unsupported case (since this patch adds support for it). * sem_ch6.adb (Analyze_Subprogram_Body_Helper): Adding assertion to ensure matching of BIP formals when setting the Protected_Formal field of a protected subprogram to reference the corresponding extra formal of the subprogram that implements it. (Might_Need_BIP_Task_Actuals): New subprogram. (Create_Extra_Formals): Improve code adding inherited extra formals. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/einfo-utils.adb | 2 +- gcc/ada/einfo.ads | 2 +- gcc/ada/exp_ch3.adb | 101 ++++++++++++++--- gcc/ada/exp_ch6.adb | 234 +++++++++++++++++++++++++++++++++++++--- gcc/ada/exp_intr.adb | 45 -------- gcc/ada/sem_ch6.adb | 185 ++++++++++++++++++------------- 6 files changed, 418 insertions(+), 151 deletions(-) diff --git a/gcc/ada/einfo-utils.adb b/gcc/ada/einfo-utils.adb index 7fe517124d9..cb9a00dc4bb 100644 --- a/gcc/ada/einfo-utils.adb +++ b/gcc/ada/einfo-utils.adb @@ -3019,7 +3019,7 @@ package body Einfo.Utils is -- Otherwise check for the case where we have a derived type or -- subtype, and if so get the Underlying_Type of the parent type. - elsif Etype (Id) /= Id then + elsif Present (Etype (Id)) and then Etype (Id) /= Id then return Underlying_Type (Etype (Id)); -- Otherwise we have an incomplete or private type that has no full diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index d7690d9f88a..977392899f9 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -4112,7 +4112,7 @@ package Einfo is -- Protected_Subprogram -- Defined in functions and procedures. Set for the pair of subprograms -- which emulate the runtime semantics of a protected subprogram. Denotes --- the entity of the origial protected subprogram. +-- the entity of the original protected subprogram. -- Protection_Object -- Applies to protected entries, entry families and subprograms. Denotes diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index db27a5f68b6..04c3ad8c631 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -6256,6 +6256,11 @@ package body Exp_Ch3 is -- temporary. Func_Id is the enclosing function. Ret_Typ is the return -- type of Func_Id. Alloc_Expr is the actual allocator. + function BIP_Function_Call_Id return Entity_Id; + -- If the object initialization expression is a call to a build-in-place + -- function, return the id of the called function; otherwise return + -- Empty. + procedure Count_Default_Sized_Task_Stacks (Typ : Entity_Id; Pri_Stacks : out Int; @@ -6592,6 +6597,67 @@ package body Exp_Ch3 is end if; end Build_Heap_Or_Pool_Allocator; + -------------------------- + -- BIP_Function_Call_Id -- + -------------------------- + + function BIP_Function_Call_Id return Entity_Id is + + function Func_Call_Id (Function_Call : Node_Id) return Entity_Id; + -- Return the id of the called function. + + function Func_Call_Id (Function_Call : Node_Id) return Entity_Id is + Call_Node : constant Node_Id := Unqual_Conv (Function_Call); + + begin + if Is_Entity_Name (Name (Call_Node)) then + return Entity (Name (Call_Node)); + + elsif Nkind (Name (Call_Node)) = N_Explicit_Dereference then + return Etype (Name (Call_Node)); + + else + pragma Assert (Nkind (Name (Call_Node)) = N_Selected_Component); + return Etype (Entity (Selector_Name (Name (Call_Node)))); + end if; + end Func_Call_Id; + + -- Local declarations + + BIP_Func_Call : Node_Id; + Expr_Q : constant Node_Id := Unqual_Conv (Expr); + + -- Start of processing for BIP_Function_Call_Id + + begin + if Is_Build_In_Place_Function_Call (Expr_Q) then + return Func_Call_Id (Expr_Q); + end if; + + BIP_Func_Call := Unqual_BIP_Iface_Function_Call (Expr_Q); + + if Present (BIP_Func_Call) then + + -- In the case of an explicitly dereferenced call, return the + -- subprogram type. + + if Nkind (Name (BIP_Func_Call)) = N_Explicit_Dereference then + return Etype (Name (BIP_Func_Call)); + else + pragma Assert (Is_Entity_Name (Name (BIP_Func_Call))); + return Entity (Name (BIP_Func_Call)); + end if; + + elsif Nkind (Expr_Q) = N_Reference + and then Is_Build_In_Place_Function_Call (Prefix (Expr_Q)) + then + return Func_Call_Id (Prefix (Expr_Q)); + + else + return Empty; + end if; + end BIP_Function_Call_Id; + ------------------------------------- -- Count_Default_Sized_Task_Stacks -- ------------------------------------- @@ -7272,6 +7338,9 @@ package body Exp_Ch3 is -- which case the init proc call must be inserted only after the bodies -- of the shared variable procedures have been seen. + Has_BIP_Init_Expr : Boolean := False; + -- Whether the object is initialized with a BIP function call + Rewrite_As_Renaming : Boolean := False; -- Whether to turn the declaration into a renaming at the end @@ -7319,12 +7388,29 @@ package body Exp_Ch3 is Init_After := Make_Shared_Var_Procs (N); end if; + -- Determine whether the object is initialized with a BIP function call + + if Present (Expr) then + Expr_Q := Unqualify (Expr); + + Has_BIP_Init_Expr := + Is_Build_In_Place_Function_Call (Expr_Q) + or else Present (Unqual_BIP_Iface_Function_Call (Expr_Q)) + or else (Nkind (Expr_Q) = N_Reference + and then + Is_Build_In_Place_Function_Call (Prefix (Expr_Q))); + end if; + -- If tasks are being declared, make sure we have an activation chain -- defined for the tasks (has no effect if we already have one), and -- also that a Master variable is established (and that the appropriate -- enclosing construct is established as a task master). - if Has_Task (Typ) or else Might_Have_Tasks (Typ) then + if Has_Task (Typ) + or else Might_Have_Tasks (Typ) + or else (Has_BIP_Init_Expr + and then Needs_BIP_Task_Actuals (BIP_Function_Call_Id)) + then Build_Activation_Chain_Entity (N); if Has_Task (Typ) then @@ -7332,17 +7418,8 @@ package body Exp_Ch3 is -- Handle objects initialized with BIP function calls - elsif Present (Expr) then - Expr_Q := Unqualify (Expr); - - if Is_Build_In_Place_Function_Call (Expr_Q) - or else Present (Unqual_BIP_Iface_Function_Call (Expr_Q)) - or else (Nkind (Expr_Q) = N_Reference - and then - Is_Build_In_Place_Function_Call (Prefix (Expr_Q))) - then - Build_Master_Entity (Def_Id); - end if; + elsif Has_BIP_Init_Expr then + Build_Master_Entity (Def_Id); end if; end if; diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 2e3a2b3edcc..0d1f1fb1c3b 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -312,6 +312,30 @@ package body Exp_Ch6 is -- Insert the Post_Call list previously produced by routine Expand_Actuals -- or Expand_Call_Helper into the tree. + function Is_True_Build_In_Place_Function_Call (N : Node_Id) return Boolean; + -- Ada 2005 (AI-318-02): Returns True if N denotes a call to a function + -- that requires handling as a build-in-place call; returns False for + -- non-BIP function calls and also for calls to functions with inherited + -- BIP formals that do not require BIP formals. For example: + -- + -- type Iface is limited interface; + -- function Get_Object return Iface; + -- -- This function has BIP extra formals + -- + -- type Root1 is limited tagged record ... + -- type T1 is new Root1 and Iface with ... + -- function Get_Object return T1; + -- -- This primitive requires the BIP formals, and the evaluation of + -- -- Is_True_Build_In_Place_Function_Call returns True. + -- + -- type Root2 is tagged record ... + -- type T2 is new Root2 and Iface with ... + -- function Get_Object return T2; + -- -- This primitive inherits the BIP formals of the interface primitive + -- -- but, given that T2 is not a limited type, it does not require such + -- -- formals; therefore Is_True_Build_In_Place_Function_Call returns + -- -- False. + procedure Replace_Renaming_Declaration_Id (New_Decl : Node_Id; Orig_Decl : Node_Id); @@ -481,6 +505,8 @@ package body Exp_Ch6 is Desig_Typ : Entity_Id; begin + pragma Assert (Present (Formal)); + -- If there is a finalization master actual, such as the implicit -- finalization master of an enclosing build-in-place function, -- then this must be added as an extra actual of the call. @@ -621,6 +647,27 @@ package body Exp_Ch6 is -- No such extra parameters are needed if there are no tasks if not Needs_BIP_Task_Actuals (Function_Id) then + + -- However we must add dummy extra actuals if the function is + -- a dispatching operation that inherited these extra formals. + + if Is_Dispatching_Operation (Function_Id) + and then Has_BIP_Extra_Formal (Function_Id, BIP_Task_Master) + then + Master_Formal := + Build_In_Place_Formal (Function_Id, BIP_Task_Master); + Actual := Make_Integer_Literal (Loc, Uint_0); + Analyze_And_Resolve (Actual, Etype (Master_Formal)); + Add_Extra_Actual_To_Call (Function_Call, Master_Formal, Actual); + + Chain_Formal := + Build_In_Place_Formal (Function_Id, BIP_Activation_Chain); + Chain_Actual := Make_Null (Loc); + Analyze_And_Resolve (Chain_Actual, Etype (Chain_Formal)); + Add_Extra_Actual_To_Call + (Function_Call, Chain_Formal, Chain_Actual); + end if; + return; end if; @@ -894,8 +941,7 @@ package body Exp_Ch6 is -- the Alias of an instance, which will cause the formals to have -- "incorrect" names. - loop - pragma Assert (Present (Extra_Formal)); + while Present (Extra_Formal) loop declare Name : constant String := Get_Name_String (Chars (Extra_Formal)); begin @@ -907,6 +953,10 @@ package body Exp_Ch6 is Next_Formal_With_Extras (Extra_Formal); end loop; + if No (Extra_Formal) then + raise Program_Error; + end if; + return Extra_Formal; end Build_In_Place_Formal; @@ -2995,6 +3045,13 @@ package body Exp_Ch6 is -- actuals and must be handled in a recursive fashion since they can -- be embedded within each other. + procedure Add_Dummy_Build_In_Place_Actuals + (Function_Id : Entity_Id; + Num_Added_Extra_Actuals : Nat := 0); + -- Adds dummy actuals for the BIP extra formals of the called function. + -- Num_Added_Extra_Actuals is the number of non-BIP extra actuals added + -- to the actuals immediately before calling this subprogram. + procedure Add_Extra_Actual (Expr : Node_Id; EF : Entity_Id); -- Adds an extra actual to the list of extra actuals. Expr is the -- expression for the value of the actual, EF is the entity for the @@ -3253,6 +3310,83 @@ package body Exp_Ch6 is EF => Extra_Accessibility (Formal)); end Add_Cond_Expression_Extra_Actual; + -------------------------------------- + -- Add_Dummy_Build_In_Place_Actuals -- + -------------------------------------- + + procedure Add_Dummy_Build_In_Place_Actuals + (Function_Id : Entity_Id; + Num_Added_Extra_Actuals : Nat := 0) + is + Loc : constant Source_Ptr := Sloc (Call_Node); + Formal : Entity_Id := Extra_Formals (Function_Id); + Actual : Node_Id; + Skip_Extra : Nat; + + begin + -- We never generate extra formals if expansion is not active because + -- we don't need them unless we are generating code. No action needed + -- for thunks since they propagate all their extra actuals. + + if not Expander_Active + or else Is_Thunk (Current_Scope) + then + return; + end if; + + -- Skip already-added non-BIP extra actuals + + Skip_Extra := Num_Added_Extra_Actuals; + while Skip_Extra > 0 loop + pragma Assert (not Is_Build_In_Place_Entity (Formal)); + Formal := Extra_Formal (Formal); + Skip_Extra := Skip_Extra - 1; + end loop; + + -- Append the dummy BIP extra actuals + + while Present (Formal) loop + pragma Assert (Is_Build_In_Place_Entity (Formal)); + + -- BIPalloc + + if Etype (Formal) = Standard_Natural then + Actual := Make_Integer_Literal (Loc, Uint_0); + Analyze_And_Resolve (Actual, Standard_Natural); + Add_Extra_Actual_To_Call (N, Formal, Actual); + + -- BIPtaskmaster + + elsif Etype (Formal) = Standard_Integer then + Actual := Make_Integer_Literal (Loc, Uint_0); + Analyze_And_Resolve (Actual, Standard_Integer); + Add_Extra_Actual_To_Call (N, Formal, Actual); + + -- BIPstoragepool, BIPfinalizationmaster, BIPactivationchain, + -- and BIPaccess. + + elsif Is_Access_Type (Etype (Formal)) then + Actual := Make_Null (Loc); + Analyze_And_Resolve (Actual, Etype (Formal)); + Add_Extra_Actual_To_Call (N, Formal, Actual); + + else + pragma Assert (False); + raise Program_Error; + end if; + + Formal := Extra_Formal (Formal); + end loop; + + -- Mark the call as processed build-in-place call; required + -- to avoid adding the extra formals twice. + + Set_Is_Expanded_Build_In_Place_Call (Call_Node); + + pragma Assert (Check_Number_Of_Actuals (Call_Node, Function_Id)); + pragma Assert (Check_BIP_Actuals (Call_Node, Function_Id)); + end Add_Dummy_Build_In_Place_Actuals; + ---------------------- -- Add_Extra_Actual -- ---------------------- @@ -4698,10 +4832,35 @@ package body Exp_Ch6 is -- During that loop we gathered the extra actuals (the ones that -- correspond to Extra_Formals), so now they can be appended. - else - while Is_Non_Empty_List (Extra_Actuals) loop - Add_Actual_Parameter (Remove_Head (Extra_Actuals)); - end loop; + elsif Is_Non_Empty_List (Extra_Actuals) then + declare + Num_Extra_Actuals : constant Nat := List_Length (Extra_Actuals); + + begin + while Is_Non_Empty_List (Extra_Actuals) loop + Add_Actual_Parameter (Remove_Head (Extra_Actuals)); + end loop; + + -- Add dummy extra BIP actuals if we are calling a function that + -- inherited the BIP extra actuals but does not require them. + + if Nkind (Call_Node) = N_Function_Call + and then Is_Build_In_Place_Function_Call (Call_Node) + and then not Is_True_Build_In_Place_Function_Call (Call_Node) + then + Add_Dummy_Build_In_Place_Actuals (Subp, + Num_Added_Extra_Actuals => Num_Extra_Actuals); + end if; + end; + + -- Add dummy extra BIP actuals if we are calling a function that + -- inherited the BIP extra actuals but does not require them. + + elsif Nkind (Call_Node) = N_Function_Call + and then Is_Build_In_Place_Function_Call (Call_Node) + and then not Is_True_Build_In_Place_Function_Call (Call_Node) + then + Add_Dummy_Build_In_Place_Actuals (Subp); end if; -- At this point we have all the actuals, so this is the point at which @@ -5428,7 +5587,7 @@ package body Exp_Ch6 is pragma Assert (Ekind (Current_Subprogram) = E_Function); pragma Assert (Is_Build_In_Place_Function (Current_Subprogram) = - Is_Build_In_Place_Function_Call (Exp)); + Is_True_Build_In_Place_Function_Call (Exp)); null; end if; @@ -6623,14 +6782,9 @@ package body Exp_Ch6 is if Nkind (Exp) = N_Function_Call then pragma Assert (Ekind (Scope_Id) = E_Function); - - -- This assertion works fine because Is_Build_In_Place_Function_Call - -- returns True for BIP function calls but also for function calls - -- that have BIP formals. - pragma Assert - (Has_BIP_Formals (Scope_Id) = - Is_Build_In_Place_Function_Call (Exp)); + (Is_Build_In_Place_Function (Scope_Id) = + Is_True_Build_In_Place_Function_Call (Exp)); null; end if; @@ -6653,7 +6807,7 @@ package body Exp_Ch6 is pragma Assert (Comes_From_Extended_Return_Statement (N) - or else not Is_Build_In_Place_Function_Call (Exp) + or else not Is_True_Build_In_Place_Function_Call (Exp) or else Has_BIP_Formals (Scope_Id)); if not Comes_From_Extended_Return_Statement (N) @@ -8000,6 +8154,40 @@ package body Exp_Ch6 is end if; end Is_Build_In_Place_Function_Call; + ------------------------------------------ + -- Is_True_Build_In_Place_Function_Call -- + ------------------------------------------ + + function Is_True_Build_In_Place_Function_Call (N : Node_Id) return Boolean + is + Exp_Node : Node_Id; + Function_Id : Entity_Id; + + begin + -- No action needed if we know that this is not a BIP function call + + if not Is_Build_In_Place_Function_Call (N) then + return False; + end if; + + Exp_Node := Unqual_Conv (N); + + if Is_Entity_Name (Name (Exp_Node)) then + Function_Id := Entity (Name (Exp_Node)); + + elsif Nkind (Name (Exp_Node)) = N_Explicit_Dereference then + Function_Id := Etype (Name (Exp_Node)); + + elsif Nkind (Name (Exp_Node)) = N_Selected_Component then + Function_Id := Etype (Entity (Selector_Name (Name (Exp_Node)))); + + else + raise Program_Error; + end if; + + return Is_Build_In_Place_Function (Function_Id); + end Is_True_Build_In_Place_Function_Call; + ----------------------------------- -- Is_Build_In_Place_Result_Type -- ----------------------------------- @@ -8154,6 +8342,14 @@ package body Exp_Ch6 is Func_Call := Expression (Func_Call); end if; + -- No action needed if the called function inherited the BIP extra + -- formals but it is not a true BIP function. + + if not Is_True_Build_In_Place_Function_Call (Func_Call) then + pragma Assert (Is_Expanded_Build_In_Place_Call (Func_Call)); + return; + end if; + -- Mark the call as processed as a build-in-place call pragma Assert (not Is_Expanded_Build_In_Place_Call (Func_Call)); @@ -8559,6 +8755,14 @@ package body Exp_Ch6 is Result_Subt : Entity_Id; begin + -- No action needed if the called function inherited the BIP extra + -- formals but it is not a true BIP function. + + if not Is_True_Build_In_Place_Function_Call (Func_Call) then + pragma Assert (Is_Expanded_Build_In_Place_Call (Func_Call)); + return; + end if; + -- Mark the call as processed as a build-in-place call pragma Assert (not Is_Expanded_Build_In_Place_Call (Func_Call)); diff --git a/gcc/ada/exp_intr.adb b/gcc/ada/exp_intr.adb index 2eee892605e..95c5f18587e 100644 --- a/gcc/ada/exp_intr.adb +++ b/gcc/ada/exp_intr.adb @@ -24,16 +24,13 @@ ------------------------------------------------------------------------------ with Atree; use Atree; -with Aspects; use Aspects; with Checks; use Checks; with Einfo; use Einfo; with Einfo.Entities; use Einfo.Entities; with Einfo.Utils; use Einfo.Utils; with Elists; use Elists; -with Errout; use Errout; with Expander; use Expander; with Exp_Atag; use Exp_Atag; -with Exp_Ch6; use Exp_Ch6; with Exp_Ch7; use Exp_Ch7; with Exp_Ch11; use Exp_Ch11; with Exp_Code; use Exp_Code; @@ -288,48 +285,6 @@ package body Exp_Intr is begin pragma Assert (Is_Class_Wide_Type (Etype (Entity (Name (N))))); - -- Report case where we know that the generated code is wrong; that - -- is a dispatching constructor call whose controlling type has tasks - -- but its root type does not have tasks. In such case the constructor - -- subprogram of the root type does not have extra formals but the - -- constructor of the derivation must have extra formals. - - if not Global_No_Tasking - and then not No_Run_Time_Mode - and then Is_Build_In_Place_Function (Entity (Name (N))) - and then not Has_Task (Root_Type (Etype (Entity (Name (N))))) - and then not Has_Aspect (Root_Type (Etype (Entity (Name (N)))), - Aspect_No_Task_Parts) - then - -- Case 1: Explicit tag reference (which allows static check) - - if Nkind (Tag_Arg) = N_Identifier - and then Present (Entity (Tag_Arg)) - and then Is_Tag (Entity (Tag_Arg)) - then - if Has_Task (Related_Type (Entity (Tag_Arg))) then - Error_Msg_N ("unsupported dispatching constructor call", N); - Error_Msg_NE - ("\work around this problem by defining task component " - & "type& using access-to-task-type", - N, Related_Type (Entity (Tag_Arg))); - end if; - - -- Case 2: Dynamic tag which may fail at run time - - else - Error_Msg_N - ("unsupported dispatching constructor call if the type " - & "of the built object has task components??", N); - - Error_Msg_Sloc := Sloc (Root_Type (Etype (Entity (Name (N))))); - Error_Msg_NE - ("\work around this by adding ''with no_task_parts'' to " - & "the declaration of the root type& defined#???", - N, Root_Type (Etype (Entity (Name (N))))); - end if; - end if; - -- Remove side effects from tag argument early, before rewriting -- the dispatching constructor call, as Remove_Side_Effects relies -- on Tag_Arg's Parent link properly attached to the tree (once the diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 4e64833b3f7..53011f465a8 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -53,6 +53,7 @@ with Nlists; use Nlists; with Nmake; use Nmake; with Opt; use Opt; with Output; use Output; +with Restrict; use Restrict; with Rtsfind; use Rtsfind; with Sem; use Sem; with Sem_Aux; use Sem_Aux; @@ -4457,6 +4458,10 @@ package body Sem_Ch6 is begin while Present (Prot_Ext_Formal) loop pragma Assert (Present (Impl_Ext_Formal)); + pragma Assert (not Is_Build_In_Place_Entity (Prot_Ext_Formal) + or else BIP_Suffix_Kind (Impl_Ext_Formal) + = BIP_Suffix_Kind (Prot_Ext_Formal)); + Set_Protected_Formal (Prot_Ext_Formal, Impl_Ext_Formal); Next_Formal_With_Extras (Prot_Ext_Formal); Next_Formal_With_Extras (Impl_Ext_Formal); @@ -8581,6 +8586,11 @@ package body Sem_Ch6 is function Has_Extra_Formals (E : Entity_Id) return Boolean; -- Determines if E has its extra formals + function Might_Need_BIP_Task_Actuals (E : Entity_Id) return Boolean; + -- Determines if E is a dispatching primitive returning a limited tagged + -- type object since some descendant might return an object with tasks + -- (and therefore need the BIP task extra actuals). + function Needs_Accessibility_Check_Extra (E : Entity_Id; Formal : Node_Id) return Boolean; @@ -8656,6 +8666,58 @@ package body Sem_Ch6 is and then Present (Extra_Accessibility_Of_Result (E))); end Has_Extra_Formals; + --------------------------------- + -- Might_Need_BIP_Task_Actuals -- + --------------------------------- + + function Might_Need_BIP_Task_Actuals (E : Entity_Id) return Boolean is + Subp_Id : Entity_Id; + Func_Typ : Entity_Id; + + begin + if Global_No_Tasking or else No_Run_Time_Mode then + return False; + end if; + + -- No further check needed if we know that BIP task actuals are + -- required. + + if Needs_BIP_Task_Actuals (E) then + return True; + end if; + + -- For thunks we must rely on their target entity + + if Is_Thunk (E) then + Subp_Id := Thunk_Target (E); + + -- For protected subprograms we rely on the subprogram which + -- implements the body of the operation (since it is the entity + -- that may be a dispatching operation). + + elsif Is_Protected_Type (Scope (E)) + and then Present (Protected_Body_Subprogram (E)) + then + Subp_Id := Protected_Body_Subprogram (E); + + else + Subp_Id := E; + end if; + + -- We check the root type of the return type since the same + -- decision must be taken for all descendants overriding a + -- dispatching operation. + + Func_Typ := Root_Type (Underlying_Type (Etype (Subp_Id))); + + return Ekind (Subp_Id) = E_Function + and then not Has_Foreign_Convention (Func_Typ) + and then Is_Dispatching_Operation (Subp_Id) + and then Is_Tagged_Type (Func_Typ) + and then Is_Limited_Type (Func_Typ) + and then not Has_Aspect (Func_Typ, Aspect_No_Task_Parts); + end Might_Need_BIP_Task_Actuals; + ------------------------------------- -- Needs_Accessibility_Check_Extra -- ------------------------------------- @@ -8790,7 +8852,8 @@ package body Sem_Ch6 is then return; - -- Initialization procedures don't have extra formals + -- Extra formals of Initialization procedures are added by the function + -- Exp_Ch3.Init_Formals elsif Is_Init_Proc (E) then return; @@ -9076,20 +9139,16 @@ package body Sem_Ch6 is begin Ada_Version := Ada_2022; - if Needs_Result_Accessibility_Level (Ref_E) then - pragma Assert (No (Parent_Subp) - or else Needs_Result_Accessibility_Level (Parent_Subp)); - pragma Assert (No (Alias_Subp) - or else Needs_Result_Accessibility_Level (Alias_Subp)); - + if Needs_Result_Accessibility_Level (Ref_E) + or else + (Present (Parent_Subp) + and then Needs_Result_Accessibility_Level (Parent_Subp)) + or else + (Present (Alias_Subp) + and then Needs_Result_Accessibility_Level (Alias_Subp)) + then Set_Extra_Accessibility_Of_Result (E, Add_Extra_Formal (E, Standard_Natural, E, "L")); - - else - pragma Assert (No (Parent_Subp) - or else not Needs_Result_Accessibility_Level (Parent_Subp)); - pragma Assert (No (Alias_Subp) - or else not Needs_Result_Accessibility_Level (Alias_Subp)); end if; Ada_Version := Save_Ada_Version; @@ -9124,14 +9183,16 @@ package body Sem_Ch6 is -- dispatching context and such calls must be handled like calls -- to a class-wide function. - if Needs_BIP_Alloc_Form (Ref_E) then - pragma Assert (No (Parent_Subp) - or else Has_BIP_Extra_Formal (Parent_Subp, BIP_Alloc_Form, - Must_Be_Frozen => False)); - pragma Assert (No (Alias_Subp) - or else Has_BIP_Extra_Formal (Alias_Subp, BIP_Alloc_Form, - Must_Be_Frozen => False)); - + if Needs_BIP_Alloc_Form (Ref_E) + or else + (Present (Parent_Subp) + and then Has_BIP_Extra_Formal (Parent_Subp, BIP_Alloc_Form, + Must_Be_Frozen => False)) + or else + (Present (Alias_Subp) + and then Has_BIP_Extra_Formal (Alias_Subp, BIP_Alloc_Form, + Must_Be_Frozen => False)) + then Discard := Add_Extra_Formal (E, Standard_Natural, @@ -9147,87 +9208,57 @@ package body Sem_Ch6 is (E, RTE (RE_Root_Storage_Pool_Ptr), E, BIP_Formal_Suffix (BIP_Storage_Pool)); end if; - - else - pragma Assert (No (Parent_Subp) - or else not - Has_BIP_Extra_Formal (Parent_Subp, BIP_Alloc_Form, - Must_Be_Frozen => False)); - pragma Assert (No (Alias_Subp) - or else not - Has_BIP_Extra_Formal (Alias_Subp, BIP_Alloc_Form, - Must_Be_Frozen => False)); end if; -- In the case of functions whose result type needs finalization, -- add an extra formal which represents the finalization master. - if Needs_BIP_Finalization_Master (Ref_E) then - pragma Assert (No (Parent_Subp) - or else Has_BIP_Extra_Formal (Parent_Subp, - Kind => BIP_Finalization_Master, - Must_Be_Frozen => False)); - pragma Assert (No (Alias_Subp) - or else Has_BIP_Extra_Formal (Alias_Subp, - Kind => BIP_Finalization_Master, - Must_Be_Frozen => False)); - + if Needs_BIP_Finalization_Master (Ref_E) + or else + (Present (Parent_Subp) + and then Has_BIP_Extra_Formal (Parent_Subp, + Kind => BIP_Finalization_Master, + Must_Be_Frozen => False)) + or else + (Present (Alias_Subp) + and then Has_BIP_Extra_Formal (Alias_Subp, + Kind => BIP_Finalization_Master, + Must_Be_Frozen => False)) + then Discard := Add_Extra_Formal (E, RTE (RE_Finalization_Master_Ptr), E, BIP_Formal_Suffix (BIP_Finalization_Master)); - - else - pragma Assert (No (Parent_Subp) - or else not - Has_BIP_Extra_Formal (Parent_Subp, - Kind => BIP_Finalization_Master, - Must_Be_Frozen => False)); - pragma Assert (No (Alias_Subp) - or else not - Has_BIP_Extra_Formal (Alias_Subp, - Kind => BIP_Finalization_Master, - Must_Be_Frozen => False)); end if; -- When the result type contains tasks, add two extra formals: the -- master of the tasks to be created, and the caller's activation -- chain. - if Needs_BIP_Task_Actuals (Ref_E) then - pragma Assert (No (Parent_Subp) - or else Has_BIP_Extra_Formal (Parent_Subp, BIP_Task_Master, - Must_Be_Frozen => False)); - pragma Assert (No (Alias_Subp) - or else Has_BIP_Extra_Formal (Alias_Subp, BIP_Task_Master, - Must_Be_Frozen => False) - or else - (Is_Abstract_Subprogram (Ref_E) - and then Is_Predefined_Dispatching_Operation (Ref_E) - and then Is_Interface - (Find_Dispatching_Type (Alias_Subp)))); - + if Needs_BIP_Task_Actuals (Ref_E) + or else Might_Need_BIP_Task_Actuals (Ref_E) + or else + (Present (Parent_Subp) + and then Has_BIP_Extra_Formal (Parent_Subp, BIP_Task_Master, + Must_Be_Frozen => False)) + or else + (Present (Alias_Subp) + and then Has_BIP_Extra_Formal (Alias_Subp, BIP_Task_Master, + Must_Be_Frozen => False)) + then Discard := Add_Extra_Formal (E, Standard_Integer, E, BIP_Formal_Suffix (BIP_Task_Master)); - Set_Has_Master_Entity (E); + if Needs_BIP_Task_Actuals (Ref_E) then + Set_Has_Master_Entity (E); + end if; Discard := Add_Extra_Formal (E, RTE (RE_Activation_Chain_Access), E, BIP_Formal_Suffix (BIP_Activation_Chain)); - - else - pragma Assert (No (Parent_Subp) - or else not - Has_BIP_Extra_Formal (Parent_Subp, BIP_Task_Master, - Must_Be_Frozen => False)); - pragma Assert (No (Alias_Subp) - or else not - Has_BIP_Extra_Formal (Alias_Subp, BIP_Task_Master, - Must_Be_Frozen => False)); end if; -- All build-in-place functions get an extra formal that will be -- 2.40.0