[Ada] Ada2020: AI12-0107 convention of By_Protected_Procedure

Message ID 20200716092051.GA146410@adacore.com
State New
Headers show
Series
  • [Ada] Ada2020: AI12-0107 convention of By_Protected_Procedure
Related show

Commit Message

Pierre-Marie de Rodat July 16, 2020, 9:20 a.m.
A prefixed view of a subprogram with aspect Synchronization being
By_Protected_Procedure has convention protected.  This new feature is
documented in AI12-0107.

Tested on x86_64-pc-linux-gnu, committed on trunk

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.

Patch

diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb
--- 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
--- 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
--- 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
--- 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
--- 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