From: Javier Miranda Date: Thu, 16 Apr 2020 15:06:31 +0000 (-0400) Subject: [Ada] Crash in tagged type constructor with task components X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=765005dd6791889af2731073bb7c5f6305d14f01;p=gcc.git [Ada] Crash in tagged type constructor with task components 2020-06-17 Javier Miranda gcc/ada/ * exp_ch6.adb (Has_BIP_Extra_Formal): New subprogram. (Needs_BIP_Task_Actuals): Add support for the subprogram type internally generated for dispatching calls. * exp_disp.adb (Expand_Dispatching_Call): Adding code to explicitly duplicate the extra formals of the target subprogram. * freeze.adb (Check_Extra_Formals): New subprogram. (Freeze_Subprogram): Fix decoration of Extra_Formals. * sem_ch3.adb (Derive_Subprogram): Fix decoration of Extra_Formals. --- diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 2d065aa8e14..daa672f0193 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -272,6 +272,15 @@ package body Exp_Ch6 is -- Expand simple return from function. In the case where we are returning -- from a function body this is called by Expand_N_Simple_Return_Statement. + function Has_BIP_Extra_Formal + (E : Entity_Id; + Kind : BIP_Formal_Kind) return Boolean; + -- Given a frozen subprogram, subprogram type, entry or entry family, + -- return True if E has the BIP extra formal associated with Kind. It must + -- be invoked with a frozen entity or a subprogram type of a dispatching + -- call since we can only rely on the availability of the extra formals + -- on these entities. + procedure Insert_Post_Call_Actions (N : Node_Id; Post_Call : List_Id); -- Insert the Post_Call list previously produced by routine Expand_Actuals -- or Expand_Call_Helper into the tree. @@ -828,8 +837,8 @@ package body Exp_Ch6 is (Func : Entity_Id; Kind : BIP_Formal_Kind) return Entity_Id is + Extra_Formal : Entity_Id := Extra_Formals (Func); Formal_Suffix : constant String := BIP_Formal_Suffix (Kind); - Extra_Formal : Entity_Id := Extra_Formals (Func); begin -- Maybe it would be better for each implicit formal of a build-in-place @@ -8230,6 +8239,41 @@ package body Exp_Ch6 is end if; end Freeze_Subprogram; + -------------------------- + -- Has_BIP_Extra_Formal -- + -------------------------- + + function Has_BIP_Extra_Formal + (E : Entity_Id; + Kind : BIP_Formal_Kind) return Boolean + is + Extra_Formal : Entity_Id := Extra_Formals (E); + + begin + -- We can only rely on the availability of the extra formals in frozen + -- entities or in subprogram types of dispatching calls (since their + -- extra formals are added when the target subprogram is frozen; see + -- Expand_Dispatching_Call). + + pragma Assert (Is_Frozen (E) + or else (Ekind (E) = E_Subprogram_Type + and then Is_Dispatch_Table_Entity (E)) + or else (Is_Dispatching_Operation (E) + and then Is_Frozen (Find_Dispatching_Type (E)))); + + while Present (Extra_Formal) loop + if Is_Build_In_Place_Entity (Extra_Formal) + and then BIP_Suffix_Kind (Extra_Formal) = Kind + then + return True; + end if; + + Next_Formal_With_Extras (Extra_Formal); + end loop; + + return False; + end Has_BIP_Extra_Formal; + ------------------------------ -- Insert_Post_Call_Actions -- ------------------------------ @@ -9871,6 +9915,10 @@ package body Exp_Ch6 is Func_Typ : Entity_Id; begin + if Global_No_Tasking or else No_Run_Time_Mode then + return False; + end if; + -- For thunks we must rely on their target entity; otherwise, given that -- the profile of thunks for functions returning a limited interface -- type returns a class-wide type, we would erroneously add these extra @@ -9887,8 +9935,34 @@ package body Exp_Ch6 is Func_Typ := Underlying_Type (Etype (Subp_Id)); - return not Global_No_Tasking - and then (Has_Task (Func_Typ) or else Might_Have_Tasks (Func_Typ)); + -- At first sight, for all the following cases, we could add assertions + -- to ensure that if Func_Id is frozen then the computed result matches + -- with the availability of the task master extra formal; unfortunately + -- this is not feasible because we may be precisely freezing this entity + -- (ie. Is_Frozen has been set by Freeze_Entity but it has not completed + -- its work). + + if Has_Task (Func_Typ) then + return True; + + elsif Ekind (Func_Id) = E_Function then + return Might_Have_Tasks (Func_Typ); + + -- Handle subprogram type internally generated for dispatching call. We + -- can not rely on the return type of the subprogram type of dispatching + -- calls since it is always a class-wide type (cf. Expand_Dispatching_ + -- _Call). + + elsif Ekind (Func_Id) = E_Subprogram_Type then + if Is_Dispatch_Table_Entity (Func_Id) then + return Has_BIP_Extra_Formal (Func_Id, BIP_Task_Master); + else + return Might_Have_Tasks (Func_Typ); + end if; + + else + raise Program_Error; + end if; end Needs_BIP_Task_Actuals; ----------------------------------- diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index b57ba586062..1585998df32 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -1023,9 +1023,9 @@ package body Exp_Disp is -- list including the creation of a new set of matching entities. declare - Old_Formal : Entity_Id := First_Formal (Subp); - New_Formal : Entity_Id; - Extra : Entity_Id := Empty; + Old_Formal : Entity_Id := First_Formal (Subp); + New_Formal : Entity_Id; + Last_Formal : Entity_Id := Empty; begin if Present (Old_Formal) then @@ -1049,7 +1049,7 @@ package body Exp_Disp is -- errors when the itype is the completion of a type derived -- from a private type. - Extra := New_Formal; + Last_Formal := New_Formal; Next_Formal (Old_Formal); exit when No (Old_Formal); @@ -1059,17 +1059,41 @@ package body Exp_Disp is end loop; Unlink_Next_Entity (New_Formal); - Set_Last_Entity (Subp_Typ, Extra); + Set_Last_Entity (Subp_Typ, Last_Formal); end if; -- Now that the explicit formals have been duplicated, any extra - -- formals needed by the subprogram must be created. + -- formals needed by the subprogram must be duplicated; we know + -- that extra formals are available because they were added when + -- the tagged type was frozen (see Expand_Freeze_Record_Type). - if Present (Extra) then - Set_Extra_Formal (Extra, Empty); - end if; + pragma Assert (Is_Frozen (Typ)); + + -- Warning: The addition of the extra formals cannot be performed + -- here invoking Create_Extra_Formals since we must ensure that all + -- the extra formals of the pointer type and the target subprogram + -- match (and for functions that return a tagged type the profile of + -- the built subprogram type always returns a class-wide type, which + -- may affect the addition of some extra formals). + + if Present (Last_Formal) + and then Present (Extra_Formal (Last_Formal)) + then + Old_Formal := Extra_Formal (Last_Formal); + New_Formal := New_Copy (Old_Formal); - Create_Extra_Formals (Subp_Typ); + Set_Extra_Formal (Last_Formal, New_Formal); + Set_Extra_Formals (Subp_Typ, New_Formal); + + Old_Formal := Extra_Formal (Old_Formal); + while Present (Old_Formal) loop + Set_Extra_Formal (New_Formal, New_Copy (Old_Formal)); + New_Formal := Extra_Formal (New_Formal); + Set_Scope (New_Formal, Subp_Typ); + + Old_Formal := Extra_Formal (Old_Formal); + end loop; + end if; end; -- Complete description of pointer type, including size information, as diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 0f6739f97bc..4862c7df084 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -8700,10 +8700,60 @@ package body Freeze is ----------------------- procedure Freeze_Subprogram (E : Entity_Id) is + function Check_Extra_Formals (E : Entity_Id) return Boolean; + -- Return True if the decoration of the attributes associated with extra + -- formals are properly set. + procedure Set_Profile_Convention (Subp_Id : Entity_Id); -- Set the conventions of all anonymous access-to-subprogram formals and -- result subtype of subprogram Subp_Id to the convention of Subp_Id. + ------------------------- + -- Check_Extra_Formals -- + ------------------------- + + function Check_Extra_Formals (E : Entity_Id) return Boolean is + Last_Formal : Entity_Id := Empty; + Formal : Entity_Id; + Has_Extra_Formals : Boolean := False; + + begin + -- Check attribute Extra_Formal: if available it must be set only + -- in the last formal of E + + Formal := First_Formal (E); + while Present (Formal) loop + if Present (Extra_Formal (Formal)) then + if Has_Extra_Formals then + return False; + end if; + + Has_Extra_Formals := True; + end if; + + Last_Formal := Formal; + Next_Formal (Formal); + end loop; + + -- Check attribute Extra_Formals: if E has extra formals then this + -- attribute must must point to the first extra formal of E. + + if Has_Extra_Formals then + return Present (Extra_Formals (E)) + and then Present (Extra_Formal (Last_Formal)) + and then Extra_Formal (Last_Formal) = Extra_Formals (E); + + -- When E has no formals the first extra formal is available through + -- the Extra_Formals attribute. + + elsif Present (Extra_Formals (E)) then + return No (First_Formal (E)); + + else + return True; + end if; + end Check_Extra_Formals; + ---------------------------- -- Set_Profile_Convention -- ---------------------------- @@ -8840,9 +8890,27 @@ package body Freeze is if not Has_Foreign_Convention (E) then if No (Extra_Formals (E)) then - Create_Extra_Formals (E); + + -- Extra formals are shared by derived subprograms; therefore if + -- the ultimate alias of E has been frozen before E then the extra + -- formals have been added but the attribute Extra_Formals is + -- still unset (and must be set now). + + if Present (Alias (E)) + and then Present (Extra_Formals (Ultimate_Alias (E))) + and then Last_Formal (Ultimate_Alias (E)) = Last_Formal (E) + then + pragma Assert (Is_Frozen (Ultimate_Alias (E))); + pragma Assert (No (First_Formal (Ultimate_Alias (E))) + or else + Present (Extra_Formal (Last_Formal (Ultimate_Alias (E))))); + Set_Extra_Formals (E, Extra_Formals (Ultimate_Alias (E))); + else + Create_Extra_Formals (E); + end if; end if; + pragma Assert (Check_Extra_Formals (E)); Set_Mechanisms (E); -- If this is convention Ada and a Valued_Procedure, that's odd diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 63d0c6ddd39..4c3212d3dee 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -15557,6 +15557,12 @@ package body Sem_Ch3 is Next_Formal (Formal); end loop; + -- Extra formals are shared between the parent subprogram and the + -- derived subprogram (implicit in the above copy of formals), and + -- hence we must inherit also the reference to the first extra formal. + + Set_Extra_Formals (New_Subp, Extra_Formals (Parent_Subp)); + -- If this derivation corresponds to a tagged generic actual, then -- primitive operations rename those of the actual. Otherwise the -- primitive operations rename those of the parent type, If the parent