From: Javier Miranda Date: Wed, 3 Jun 2020 18:07:27 +0000 (-0400) Subject: [Ada] Ada2020: AI12-0107 convention of By_Protected_Procedure X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=d9206abba7e6ac0328cafb3f3556c17220101024;p=gcc.git [Ada] Ada2020: AI12-0107 convention of By_Protected_Procedure gcc/ada/ * exp_attr.adb (Has_By_Protected_Procedure_Prefixed_View): New subprogram. (Expand_Access_To_Protected_Op): Adding support for prefixed class-wide view with By_Protected_Procedure convention. * sem_attr.adb (Get_Convention): New subprogram. (Get_Kind): Adapted to use Get_Convention. * sem_ch4.adb (Try_By_Protected_Procedure_Prefixed_View): New subprogram. (Analyze_Selected_Component): Invoke Try_By_Protected_Procedure_Prefixed_View. * sem_util.ads (Is_By_Protected_Procedure): New subprogram. * sem_util.adb (Is_By_Protected_Procedure): New subprogram. --- diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 14ffe8ec42f..08c711800e9 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -941,7 +941,30 @@ package body Exp_Attr is is -- The value of the attribute_reference is a record containing two -- fields: an access to the protected object, and an access to the - -- subprogram itself. The prefix is a selected component. + -- subprogram itself. The prefix is an identifier or a selected + -- component. + + function Has_By_Protected_Procedure_Prefixed_View return Boolean; + -- Determine whether Pref denotes the prefixed class-wide interface + -- view of a procedure with synchronization kind By_Protected_Procedure. + + ---------------------------------------------- + -- Has_By_Protected_Procedure_Prefixed_View -- + ---------------------------------------------- + + function Has_By_Protected_Procedure_Prefixed_View return Boolean is + begin + return Nkind (Pref) = N_Selected_Component + and then Nkind (Prefix (Pref)) in N_Has_Entity + and then Present (Entity (Prefix (Pref))) + and then Is_Class_Wide_Type (Etype (Entity (Prefix (Pref)))) + and then (Is_Synchronized_Interface (Etype (Entity (Prefix (Pref)))) + or else + Is_Protected_Interface (Etype (Entity (Prefix (Pref))))) + and then Is_By_Protected_Procedure (Entity (Selector_Name (Pref))); + end Has_By_Protected_Procedure_Prefixed_View; + + -- Local variables Loc : constant Source_Ptr := Sloc (N); Agg : Node_Id; @@ -1015,6 +1038,23 @@ package body Exp_Attr is Attribute_Name => Name_Address); end if; + elsif Has_By_Protected_Procedure_Prefixed_View then + Obj_Ref := + Make_Attribute_Reference (Loc, + Prefix => Relocate_Node (Prefix (Pref)), + Attribute_Name => Name_Address); + + -- Analyze the object address with expansion disabled. Required + -- because its expansion would displace the pointer to the object, + -- which is not correct at this stage since the object type is a + -- class-wide interface type and we are dispatching a call to a + -- thunk (which would erroneously displace the pointer again). + + Expander_Mode_Save_And_Set (False); + Analyze (Obj_Ref); + Set_Analyzed (Obj_Ref); + Expander_Mode_Restore; + -- Case where the prefix is not an entity name. Find the -- version of the protected operation to be called from -- outside the protected object. @@ -1031,26 +1071,64 @@ package body Exp_Attr is Attribute_Name => Name_Address); end if; - Sub_Ref := - Make_Attribute_Reference (Loc, - Prefix => Sub, - Attribute_Name => Name_Access); + if Has_By_Protected_Procedure_Prefixed_View then + declare + Ctrl_Tag : Node_Id := Duplicate_Subexpr (Prefix (Pref)); + Prim_Addr : Node_Id; + Subp : constant Entity_Id := Entity (Selector_Name (Pref)); + Typ : constant Entity_Id := + Etype (Etype (Entity (Prefix (Pref)))); + begin + -- The target subprogram is a thunk; retrieve its address from + -- its secondary dispatch table slot. + + Build_Get_Prim_Op_Address (Loc, + Typ => Typ, + Tag_Node => Ctrl_Tag, + Position => DT_Position (Subp), + New_Node => Prim_Addr); + + -- Mark the access to the target subprogram as an access to the + -- dispatch table and perform an unchecked type conversion to such + -- access type. This is required to allow the backend to properly + -- identify and handle the access to the dispatch table slot on + -- targets where the dispatch table contains descriptors (instead + -- of pointers). + + Set_Is_Dispatch_Table_Entity (Acc); + Sub_Ref := Unchecked_Convert_To (Acc, Prim_Addr); + Analyze (Sub_Ref); + + Agg := + Make_Aggregate (Loc, + Expressions => New_List (Obj_Ref, Sub_Ref)); + end; + + -- Common case - -- We set the type of the access reference to the already generated - -- access_to_subprogram type, and declare the reference analyzed, to - -- prevent further expansion when the enclosing aggregate is analyzed. + else + Sub_Ref := + Make_Attribute_Reference (Loc, + Prefix => Sub, + Attribute_Name => Name_Access); - Set_Etype (Sub_Ref, Acc); - Set_Analyzed (Sub_Ref); + -- We set the type of the access reference to the already generated + -- access_to_subprogram type, and declare the reference analyzed, + -- to prevent further expansion when the enclosing aggregate is + -- analyzed. - Agg := - Make_Aggregate (Loc, - Expressions => New_List (Obj_Ref, Sub_Ref)); + Set_Etype (Sub_Ref, Acc); + Set_Analyzed (Sub_Ref); - -- Sub_Ref has been marked as analyzed, but we still need to make sure - -- Sub is correctly frozen. + Agg := + Make_Aggregate (Loc, + Expressions => New_List (Obj_Ref, Sub_Ref)); - Freeze_Before (N, Entity (Sub)); + -- Sub_Ref has been marked as analyzed, but we still need to make + -- sure Sub is correctly frozen. + + Freeze_Before (N, Entity (Sub)); + end if; Rewrite (N, Agg); Analyze_And_Resolve (N, E_T); diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 1a80e798eab..78da069ba10 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -650,7 +650,8 @@ package body Sem_Attr is -- tracked value. If the scope is a loop or block, indicate that -- value tracking is disabled for the enclosing subprogram. - function Get_Kind (E : Entity_Id) return Entity_Kind; + function Get_Convention (E : Entity_Id) return Convention_Id; + function Get_Kind (E : Entity_Id) return Entity_Kind; -- Distinguish between access to regular/protected subprograms ------------------------ @@ -666,13 +667,33 @@ package body Sem_Attr is end if; end Check_Local_Access; + -------------------- + -- Get_Convention -- + -------------------- + + function Get_Convention (E : Entity_Id) return Convention_Id is + begin + -- Restrict handling by_protected_procedure access subprograms + -- to source entities; required to avoid building access to + -- subprogram types with convention protected when building + -- dispatch tables. + + if Comes_From_Source (P) + and then Is_By_Protected_Procedure (E) + then + return Convention_Protected; + else + return Convention (E); + end if; + end Get_Convention; + -------------- -- Get_Kind -- -------------- function Get_Kind (E : Entity_Id) return Entity_Kind is begin - if Convention (E) = Convention_Protected then + if Get_Convention (E) = Convention_Protected then return E_Access_Protected_Subprogram_Type; else return E_Access_Subprogram_Type; @@ -717,7 +738,7 @@ package body Sem_Attr is Acc_Type := Create_Itype (Get_Kind (Entity (P)), N); Set_Is_Public (Acc_Type, False); Set_Etype (Acc_Type, Acc_Type); - Set_Convention (Acc_Type, Convention (Entity (P))); + Set_Convention (Acc_Type, Get_Convention (Entity (P))); Set_Directly_Designated_Type (Acc_Type, Entity (P)); Set_Etype (N, Acc_Type); Freeze_Before (N, Acc_Type); @@ -732,7 +753,7 @@ package body Sem_Attr is Acc_Type := Create_Itype (Get_Kind (It.Nam), N); Set_Is_Public (Acc_Type, False); Set_Etype (Acc_Type, Acc_Type); - Set_Convention (Acc_Type, Convention (It.Nam)); + Set_Convention (Acc_Type, Get_Convention (It.Nam)); Set_Directly_Designated_Type (Acc_Type, It.Nam); Add_One_Interp (N, Acc_Type, Acc_Type); Freeze_Before (N, Acc_Type); diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 517f5fc8bec..8c9a0bf4dfb 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -4476,6 +4476,13 @@ package body Sem_Ch4 is -- Check whether prefix includes a dereference, explicit or implicit, -- at any recursive level. + function Try_By_Protected_Procedure_Prefixed_View return Boolean; + -- Return True if N is an access attribute whose prefix is a prefixed + -- class-wide (synchronized or protected) interface view for which some + -- interpretation is a procedure with synchronization kind By_Protected + -- _Procedure, and collect all its interpretations (since it may be an + -- overloaded interface primitive); otherwise return False. + -------------------------------- -- Find_Component_In_Instance -- -------------------------------- @@ -4597,6 +4604,65 @@ package body Sem_Ch4 is end if; end Has_Dereference; + ---------------------------------------------- + -- Try_By_Protected_Procedure_Prefixed_View -- + ---------------------------------------------- + + function Try_By_Protected_Procedure_Prefixed_View return Boolean is + Candidate : Node_Id := Empty; + Elmt : Elmt_Id; + Prim : Node_Id; + + begin + if Nkind (Parent (N)) = N_Attribute_Reference + and then Nam_In (Attribute_Name (Parent (N)), + Name_Access, + Name_Unchecked_Access, + Name_Unrestricted_Access) + and then Is_Class_Wide_Type (Prefix_Type) + and then (Is_Synchronized_Interface (Prefix_Type) + or else Is_Protected_Interface (Prefix_Type)) + then + -- If we have not found yet any interpretation then mark this + -- one as the first interpretation (cf. Add_One_Interp). + + if No (Etype (Sel)) then + Set_Etype (Sel, Any_Type); + end if; + + Elmt := First_Elmt (Primitive_Operations (Etype (Prefix_Type))); + while Present (Elmt) loop + Prim := Node (Elmt); + + if Chars (Prim) = Chars (Sel) + and then Is_By_Protected_Procedure (Prim) + then + Candidate := New_Copy (Prim); + + -- Skip the controlling formal; required to check type + -- conformance of the target access to protected type + -- (see Conforming_Types). + + Set_First_Entity (Candidate, + Next_Entity (First_Entity (Prim))); + + Add_One_Interp (Sel, Candidate, Etype (Prim)); + Set_Etype (N, Etype (Prim)); + end if; + + Next_Elmt (Elmt); + end loop; + end if; + + -- Propagate overloaded attribute + + if Present (Candidate) and then Is_Overloaded (Sel) then + Set_Is_Overloaded (N); + end if; + + return Present (Candidate); + end Try_By_Protected_Procedure_Prefixed_View; + -- Start of processing for Analyze_Selected_Component begin @@ -4892,6 +4958,9 @@ package body Sem_Ch4 is return; end if; + elsif Try_By_Protected_Procedure_Prefixed_View then + return; + elsif Try_Object_Operation (N) then return; end if; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 06e425de037..228cca21711 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -14565,6 +14565,17 @@ package body Sem_Util is Is_RTE (Root_Type (Under), RO_WW_Super_String)); end Is_Bounded_String; + ------------------------------- + -- Is_By_Protected_Procedure -- + ------------------------------- + + function Is_By_Protected_Procedure (Id : Entity_Id) return Boolean is + begin + return Ekind (Id) = E_Procedure + and then Present (Get_Rep_Pragma (Id, Name_Implemented)) + and then Implementation_Kind (Id) = Name_By_Protected_Procedure; + end Is_By_Protected_Procedure; + --------------------- -- Is_CCT_Instance -- --------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index cc28eedc565..9e62170e8f6 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -1640,6 +1640,10 @@ package Sem_Util is -- True if T is a bounded string type. Used to make sure "=" composes -- properly for bounded string types. + function Is_By_Protected_Procedure (Id : Entity_Id) return Boolean; + -- Determine whether entity Id denotes a procedure with synchronization + -- kind By_Protected_Procedure. + function Is_Constant_Bound (Exp : Node_Id) return Boolean; -- Exp is the expression for an array bound. Determines whether the -- bound is a compile-time known value, or a constant entity, or an