exp_smem.ads, [...]: Construction of access and assign routines has been replaced...
authorKevin Pouget <pouget@adacore.com>
Tue, 20 May 2008 12:46:42 +0000 (14:46 +0200)
committerArnaud Charlet <charlet@gcc.gnu.org>
Tue, 20 May 2008 12:46:42 +0000 (14:46 +0200)
2008-05-20  Kevin Pouget  <pouget@adacore.com>

* exp_smem.ads, exp_smem.adb: Construction of access and assign
routines has been replaced by an instantiation of
System.Shared_Storage.Shared_Var_Procs generic package, while expanding
shared variable declaration.
Calls to access and assign routines have been replaced by calls to
Read/Write routines of System.Shared_Storage.Shared_Var_Procs
instantiated package.

* rtsfind.ads: RE_Shared_Var_Procs entry has been added in RE_Unit_Table
It identifies the new generic package added in s-shasto.

* s-shasto.adb, s-shasto.ads: A new generic package has been added, it
is instantiated for each shared passive variable. It provides
supporting procedures called upon each read or write access by the
expanded code.

* sem_attr.adb:
For this runtime unit (always compiled in GNAT mode), we allow
stream attributes references for limited types for the case where
shared passive objects are implemented using stream attributes,
which is the default in GNAT's persistent storage implementation.

From-SVN: r135627

gcc/ada/exp_smem.adb
gcc/ada/exp_smem.ads
gcc/ada/rtsfind.ads
gcc/ada/s-shasto.adb
gcc/ada/s-shasto.ads
gcc/ada/sem_attr.adb

index ae1ea9b68d0745f22cb11c08b3e42616ce71aa91..0e3fc2379a4c551896bf5950f9c8f9613bcc40f4 100644 (file)
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1998-2007, Free Software Foundation, Inc.         --
+--          Copyright (C) 1998-2008, 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- --
@@ -71,6 +71,29 @@ package body Exp_Smem is
    --  OUT or IN OUT parameter to a procedure call. If the result is
    --  True, then Insert_Node is set to point to the call.
 
+   function Build_Shared_Var_Proc_Call
+     (Loc : Source_Ptr;
+      E   : Node_Id;
+      N   : Name_Id) return Node_Id;
+   --  Build a call to support procedure N for shared object E (provided by
+   --  the instance of System.Shared_Storage.Shared_Var_Procs associated to E).
+
+   --------------------------------
+   -- Build_Shared_Var_Proc_Call --
+   --------------------------------
+
+   function Build_Shared_Var_Proc_Call
+     (Loc : Source_Ptr;
+      E   : Entity_Id;
+      N   : Name_Id) return Node_Id is
+   begin
+      return Make_Procedure_Call_Statement (Loc,
+        Name => Make_Selected_Component (Loc,
+          Prefix        =>
+            New_Occurrence_Of (Shared_Var_Procs_Instance (E), Loc),
+          Selector_Name => Make_Identifier (Loc, Chars => N)));
+   end Build_Shared_Var_Proc_Call;
+
    ---------------------
    -- Add_Read_Before --
    ---------------------
@@ -78,14 +101,9 @@ package body Exp_Smem is
    procedure Add_Read_Before (N : Node_Id) is
       Loc : constant Source_Ptr := Sloc (N);
       Ent : constant Node_Id    := Entity (N);
-
    begin
-      if Present (Shared_Var_Read_Proc (Ent)) then
-         Insert_Action (N,
-           Make_Procedure_Call_Statement (Loc,
-             Name =>
-               New_Occurrence_Of (Shared_Var_Read_Proc (Ent), Loc),
-             Parameter_Associations => Empty_List));
+      if Present (Shared_Var_Procs_Instance (Ent)) then
+         Insert_Action (N, Build_Shared_Var_Proc_Call (Loc, Ent, Name_Read));
       end if;
    end Add_Read_Before;
 
@@ -134,8 +152,7 @@ package body Exp_Smem is
       --  Now, right after the Lock, insert a call to read the object
 
       Insert_Before_And_Analyze (Inode,
-        Make_Procedure_Call_Statement (Loc,
-          Name => New_Occurrence_Of (Shared_Var_Read_Proc (Obj), Loc)));
+        Build_Shared_Var_Proc_Call (Loc, Obj, Name_Read));
 
       --  Now insert the Unlock call after
 
@@ -150,8 +167,7 @@ package body Exp_Smem is
 
       if Nkind (N) = N_Procedure_Call_Statement then
          Insert_After_And_Analyze (Inode,
-           Make_Procedure_Call_Statement (Loc,
-             Name => New_Occurrence_Of (Shared_Var_Assign_Proc (Obj), Loc)));
+           Build_Shared_Var_Proc_Call (Loc, Obj, Name_Write));
       end if;
 
    end Add_Shared_Var_Lock_Procs;
@@ -165,12 +181,9 @@ package body Exp_Smem is
       Ent : constant Node_Id    := Entity (N);
 
    begin
-      if Present (Shared_Var_Assign_Proc (Ent)) then
+      if Present (Shared_Var_Procs_Instance (Ent)) then
          Insert_After_And_Analyze (Insert_Node,
-           Make_Procedure_Call_Statement (Loc,
-             Name =>
-               New_Occurrence_Of (Shared_Var_Assign_Proc (Ent), Loc),
-             Parameter_Associations => Empty_List));
+           Build_Shared_Var_Proc_Call (Loc, Ent, Name_Write));
       end if;
    end Add_Write_After;
 
@@ -276,21 +289,18 @@ package body Exp_Smem is
       Ent : constant Entity_Id  := Defining_Identifier (N);
       Typ : constant Entity_Id  := Etype (Ent);
       Vnm : String_Id;
-      Atr : Node_Id;
 
       After : constant Node_Id := Next (N);
       --  Node located right after N originally (after insertion of the SV
       --  procs this node is right after the last inserted node).
 
-      Assign_Proc : constant Entity_Id :=
-                      Make_Defining_Identifier (Loc,
-                        Chars => New_External_Name (Chars (Ent), 'A'));
-
-      Read_Proc : constant Entity_Id :=
-                    Make_Defining_Identifier (Loc,
-                      Chars => New_External_Name (Chars (Ent), 'R'));
+      SVP_Instance : constant Entity_Id := Make_Defining_Identifier (Loc,
+                       Chars => New_External_Name (Chars (Ent), 'G'));
+      --  Instance of System.Shared_Storage.Shared_Var_Procs associated
+      --  with Ent.
 
-      S : Entity_Id;
+      Instantiation : Node_Id;
+      --  Package instanciation node for SVP_Instance
 
    --  Start of processing for Make_Shared_Var_Procs
 
@@ -298,149 +308,33 @@ package body Exp_Smem is
       Build_Full_Name (Ent, Vnm);
 
       --  We turn off Shared_Passive during construction and analysis of
-      --  the assign and read routines, to avoid improper attempts to
-      --  process the variable references within these procedures.
+      --  the generic package instantition, to avoid improper attempts to
+      --  process the variable references within these instantiation.
 
       Set_Is_Shared_Passive (Ent, False);
 
-      --  Construct assignment routine
-
-      --    procedure VarA is
-      --       S : Ada.Streams.Stream_IO.Stream_Access;
-      --    begin
-      --       S := Shared_Var_WOpen ("pkg.var");
-      --       typ'Write (S, var);
-      --       Shared_Var_Close (S);
-      --    end VarA;
-
-      S   := Make_Defining_Identifier (Loc, Name_uS);
-
-      Atr :=
-        Make_Attribute_Reference (Loc,
-          Prefix => New_Occurrence_Of (Typ, Loc),
-          Attribute_Name => Name_Write,
-          Expressions => New_List (
-            New_Reference_To (S, Loc),
-            New_Occurrence_Of (Ent, Loc)));
-
-      Insert_After_And_Analyze (N,
-        Make_Subprogram_Body (Loc,
-          Specification =>
-            Make_Procedure_Specification (Loc,
-              Defining_Unit_Name => Assign_Proc),
-
-         --  S : Ada.Streams.Stream_IO.Stream_Access;
-
-          Declarations => New_List (
-            Make_Object_Declaration (Loc,
-              Defining_Identifier => S,
-              Object_Definition =>
-                New_Occurrence_Of (RTE (RE_Stream_Access), Loc))),
-
-          Handled_Statement_Sequence =>
-            Make_Handled_Sequence_Of_Statements (Loc,
-              Statements => New_List (
-
-               --  S := Shared_Var_WOpen ("pkg.var");
-
-                Make_Assignment_Statement (Loc,
-                  Name => New_Reference_To (S, Loc),
-                  Expression =>
-                    Make_Function_Call (Loc,
-                      Name =>
-                        New_Occurrence_Of
-                          (RTE (RE_Shared_Var_WOpen), Loc),
-                      Parameter_Associations => New_List (
-                        Make_String_Literal (Loc, Vnm)))),
-
-                Atr,
-
-               --  Shared_Var_Close (S);
-
-                Make_Procedure_Call_Statement (Loc,
-                  Name =>
-                    New_Occurrence_Of (RTE (RE_Shared_Var_Close), Loc),
-                  Parameter_Associations =>
-                    New_List (New_Reference_To (S, Loc)))))));
-
-      --  Construct read routine
-
-      --    procedure varR is
-      --       S : Ada.Streams.Stream_IO.Stream_Access;
-      --    begin
-      --       S := Shared_Var_ROpen ("pkg.var");
-      --       if S /= null then
-      --          typ'Read (S, Var);
-      --          Shared_Var_Close (S);
-      --       end if;
-      --    end varR;
-
-      S   := Make_Defining_Identifier (Loc, Name_uS);
-
-      Atr :=
-        Make_Attribute_Reference (Loc,
-          Prefix => New_Occurrence_Of (Typ, Loc),
-          Attribute_Name => Name_Read,
-          Expressions => New_List (
-            New_Reference_To (S, Loc),
-            New_Occurrence_Of (Ent, Loc)));
-
-      Insert_After_And_Analyze (N,
-        Make_Subprogram_Body (Loc,
-          Specification =>
-            Make_Procedure_Specification (Loc,
-              Defining_Unit_Name => Read_Proc),
-
-         --  S : Ada.Streams.Stream_IO.Stream_Access;
-
-          Declarations => New_List (
-            Make_Object_Declaration (Loc,
-              Defining_Identifier => S,
-              Object_Definition =>
-                New_Occurrence_Of (RTE (RE_Stream_Access), Loc))),
-
-          Handled_Statement_Sequence =>
-            Make_Handled_Sequence_Of_Statements (Loc,
-              Statements => New_List (
-
-               --  S := Shared_Var_ROpen ("pkg.var");
-
-                Make_Assignment_Statement (Loc,
-                  Name => New_Reference_To (S, Loc),
-                  Expression =>
-                    Make_Function_Call (Loc,
-                      Name =>
-                        New_Occurrence_Of
-                          (RTE (RE_Shared_Var_ROpen), Loc),
-                      Parameter_Associations => New_List (
-                        Make_String_Literal (Loc, Vnm)))),
-
-               --  if S /= null then
-
-                Make_Implicit_If_Statement (N,
-                  Condition =>
-                    Make_Op_Ne (Loc,
-                      Left_Opnd  => New_Reference_To (S, Loc),
-                      Right_Opnd => Make_Null (Loc)),
-
-                   Then_Statements => New_List (
-
-                     --  typ'Read (S, Var);
-
-                     Atr,
-
-                     --  Shared_Var_Close (S);
-
-                     Make_Procedure_Call_Statement (Loc,
-                       Name =>
-                         New_Occurrence_Of
-                           (RTE (RE_Shared_Var_Close), Loc),
-                       Parameter_Associations =>
-                         New_List (New_Reference_To (S, Loc)))))))));
-
-      Set_Is_Shared_Passive      (Ent, True);
-      Set_Shared_Var_Assign_Proc (Ent, Assign_Proc);
-      Set_Shared_Var_Read_Proc   (Ent, Read_Proc);
+      --  Construct generic package instantiation
+
+      --  package varG is new Shared_Var_Procs (Typ, var, "pkg.var");
+
+      Instantiation :=
+        Make_Package_Instantiation (Loc,
+          Defining_Unit_Name   => SVP_Instance,
+          Name                 =>
+            New_Occurrence_Of (RTE (RE_Shared_Var_Procs), Loc),
+          Generic_Associations => New_List (
+            Make_Generic_Association (Loc, Explicit_Generic_Actual_Parameter =>
+              New_Occurrence_Of (Typ, Loc)),
+            Make_Generic_Association (Loc, Explicit_Generic_Actual_Parameter =>
+              New_Occurrence_Of (Ent, Loc)),
+            Make_Generic_Association (Loc, Explicit_Generic_Actual_Parameter =>
+              Make_String_Literal (Loc, Vnm))));
+
+      Insert_After_And_Analyze (N, Instantiation);
+
+      Set_Is_Shared_Passive (Ent, True);
+      Set_Shared_Var_Procs_Instance
+        (Ent, Defining_Entity (Instance_Spec (Instantiation)));
 
       --  Return last node before After
 
index 69b4ee90eba7646be2bf9a79470608aa8d2e7a26..d1738255187e66f042ad38d81d054e48c2f768c0 100644 (file)
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1998-2007, Free Software Foundation, Inc.         --
+--          Copyright (C) 1998-2008, 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- --
@@ -49,10 +49,11 @@ package Exp_Smem is
    --  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. This
-   --  procedure constructs and inserts the read and assignment procedures
-   --  for the shared memory variable. See System.Shared_Storage for a full
-   --  description of these procedures and how they are used. The last inserted
-   --  node is returned.
+   --  N is the node for the declaration of a shared passive variable.
+   --  This procedure constructs an instantiation of
+   --  System.Shared_Storage.Shared_Var_Procs that contains the read and
+   --  assignment procedures for the shared memory variable.
+   --  See System.Shared_Storage for a full description of these procedures
+   --  and how they are used. The last inserted node is returned.
 
 end Exp_Smem;
index ef61b8fd0e51d911884968bfee45b28556139634..83f745499e252d4c6063dc3680c7db08a4055f42 100644 (file)
@@ -83,7 +83,7 @@ package Rtsfind is
 
    --    Names of the form System_Tasking_xxx are second level children of the
    --    package System.Tasking. For example, System_Tasking_Stages refers to
-   --    refers to the package System.Tasking.Stages.
+   --    the package System.Tasking.Stages.
 
    --    Other names stand for themselves (e.g. System for package System)
 
@@ -1255,6 +1255,7 @@ package Rtsfind is
      RE_Shared_Var_ROpen,                -- System.Shared_Storage
      RE_Shared_Var_Unlock,               -- System.Shared_Storage
      RE_Shared_Var_WOpen,                -- System.Shared_Storage
+     RE_Shared_Var_Procs,                -- System.Shared_Storage
 
      RE_Abort_Undefer_Direct,            -- System.Standard_Library
      RE_Exception_Code,                  -- System.Standard_Library
@@ -2382,6 +2383,7 @@ package Rtsfind is
      RE_Shared_Var_ROpen                 => System_Shared_Storage,
      RE_Shared_Var_Unlock                => System_Shared_Storage,
      RE_Shared_Var_WOpen                 => System_Shared_Storage,
+     RE_Shared_Var_Procs                 => System_Shared_Storage,
 
      RE_Abort_Undefer_Direct             => System_Standard_Library,
      RE_Exception_Code                   => System_Standard_Library,
index 5dd775725bb5874d8bc607e2e2baf01167df1dae..c4ef8628c0b6a6e00c2eb5bb5ec21c791caf9214 100644 (file)
@@ -6,8 +6,8 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1998-2007, Free Software Foundation, Inc.         --
---                                                                          --
+--          Copyright (C) 1998-2008, 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- --
 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
@@ -363,6 +363,43 @@ package body System.Shared_Storage is
          raise;
    end Shared_Var_Lock;
 
+   ----------------------
+   -- Shared_Var_Procs --
+   ----------------------
+
+   package body Shared_Var_Procs is
+
+      use type SIO.Stream_Access;
+
+      ----------
+      -- Read --
+      ----------
+
+      procedure Read is
+         S : SIO.Stream_Access := null;
+      begin
+         S := Shared_Var_ROpen (Full_Name);
+         if S /= null then
+            Typ'Read (S, V);
+            Shared_Var_Close (S);
+         end if;
+      end Read;
+
+      ------------
+      -- Write --
+      ------------
+
+      procedure Write is
+         S : SIO.Stream_Access := null;
+      begin
+         S := Shared_Var_WOpen (Full_Name);
+         Typ'Write (S, V);
+         Shared_Var_Close (S);
+         return;
+      end Write;
+
+   end Shared_Var_Procs;
+
    ----------------------
    -- Shared_Var_ROpen --
    ----------------------
index fc4055b982643f9a9e8f009a4938b7f2f3ac1947..8046fd5b2f601f780c7eb9e207733098b8afa49f 100644 (file)
 
 --  The approach is as follows:
 
---    For each shared variable, var, an access routine varR is created whose
---    body has the following form (this example is for Pkg.Var):
-
---      procedure varR is
---         S : Ada.Streams.Stream_IO.Stream_Access;
---      begin
---         S := Shared_Var_ROpen ("pkg.var");
---         if S /= null then
---            typ'Read (S);
---            Shared_Var_Close (S);
---         end if;
---      end varR;
+--    For each shared variable, var, an instanciation of the below generic
+--    package is created which provides Read and Write supporting procedures.
 
 --    The routine Shared_Var_ROpen in package System.Shared_Storage
 --    either returns null if the storage does not exist, or otherwise a
 --    Stream_Access value that references the corresponding shared
 --    storage, ready to read the current value.
 
---    Each reference to the shared variable, var, is preceded by a
---    call to the corresponding varR procedure, which either leaves the
---    initial value unchanged if the storage does not exist, or reads
---    the current value from the shared storage.
-
---    In addition, for each shared variable, var, an assignment routine
---    is created whose body has the following form (again for Pkg.Var)
-
---      procedure VarA is
---         S : Ada.Streams.Stream_IO.Stream_Access;
---      begin
---         S := Shared_Var_WOpen ("pkg.var");
---         typ'Write (S, var);
---         Shared_Var_Close (S);
---      end VarA;
-
 --    The routine Shared_Var_WOpen in package System.Shared_Storage
 --    returns a Stream_Access value that references the corresponding
 --    shared storage, ready to write the new value.
 
---    Each assignment to the shared variable, var, is followed by a call
---    to the corresponding varA procedure, which writes the new value to
---    the shared storage.
-
 --    Note that there is no general synchronization for these storage
 --    read and write operations, since it is assumed that a correctly
 --    operating programs will provide appropriate synchronization. In
@@ -219,4 +189,35 @@ package System.Shared_Storage is
    --  generated as the last operation in the body of a protected
    --  subprogram.
 
+   --  This generic package is instantiated for each shared passive
+   --  variable. It provides supporting procedures called upon each
+   --  read or write access by the expanded code.
+
+   generic
+
+      type Typ is limited private;
+      --  Shared passive variable type
+
+      V : in out Typ;
+      --  Shared passive variable
+
+      Full_Name : String;
+      --  Shared passive variable storage name
+
+   package Shared_Var_Procs is
+
+      procedure Read;
+      --  Shared passive variable access routine. Each reference to the
+      --  shared variable, V, is preceded by a call to the corresponding
+      --  Read procedure, which either leaves the initial value unchanged
+      --  if the storage does not exist, or reads the current value from
+      --  the shared storage.
+
+      procedure Write;
+      --  Shared passive variable assignement routine. Each assignment to
+      --  the shared variable, V, is followed by a call to the corresponding
+      --  Write procedure, which writes the new value to the shared storage.
+
+   end Shared_Var_Procs;
+
 end System.Shared_Storage;
index 6a7846eacba6befd861e407b741dd03282738c51..c2536dfc70c08e5069806363d2cac31b7a65cb4e 100644 (file)
@@ -1278,7 +1278,8 @@ package body Sem_Attr is
            and then Convention (Etype (P)) = Convention_CPP
            and then Is_CPP_Class (Root_Type (Etype (P)))
          then
-            Error_Attr_P ("invalid use of % attribute with CPP tagged type");
+            Error_Attr_P
+              ("invalid use of % attribute with 'C'P'P tagged type");
          end if;
       end Check_Not_CPP_Type;
 
@@ -1459,6 +1460,14 @@ package body Sem_Attr is
          Etyp : Entity_Id;
          Btyp : Entity_Id;
 
+         In_Shared_Var_Procs : Boolean;
+         --  True when compiling the body of System.Shared_Storage.
+         --  Shared_Var_Procs. For this runtime package (always compiled in
+         --  GNAT mode), we allow stream attributes references for limited
+         --  types for the case where shared passive objects are implemented
+         --  using stream attributes, which is the default in GNAT's persistent
+         --  storage implementation.
+
       begin
          Validate_Non_Static_Attribute_Function_Call;
 
@@ -1492,7 +1501,19 @@ package body Sem_Attr is
          --  in Ada 2005 mode), or a pragma Stream_Convert applies to Btyp
          --  (with no visibility restriction).
 
-         if Comes_From_Source (N)
+         declare
+            Gen_Body : constant Node_Id := Enclosing_Generic_Body (N);
+         begin
+            if Present (Gen_Body) then
+               In_Shared_Var_Procs :=
+                 Is_RTE (Corresponding_Spec (Gen_Body), RE_Shared_Var_Procs);
+            else
+               In_Shared_Var_Procs := False;
+            end if;
+         end;
+
+         if (Comes_From_Source (N)
+              and then not (In_Shared_Var_Procs or In_Instance))
            and then not Stream_Attribute_Available (P_Type, Nam)
            and then not Has_Rep_Pragma (Btyp, Name_Stream_Convert)
          then