Patchwork [Ada] Implement Pragma Partition_Elaboration_Policy

login
register
mail settings
Submitter Arnaud Charlet
Date Oct. 29, 2012, 11:01 a.m.
Message ID <20121029110141.GA17180@adacore.com>
Download mbox | patch
Permalink /patch/194965/
State New
Headers show

Comments

Arnaud Charlet - Oct. 29, 2012, 11:01 a.m.
Initial work to implement pragma Partition_Elaboration_Policy. Currently,
only consistency is checked, the runtime only implements one policy.
A following patch will add a pragma Partition_Elaboration_Policy in the
runtime to enforce the policy (when tasking is used).

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

2012-10-29  Tristan Gingold  <gingold@adacore.com>

	* lib-writ.adb (Write_ALI): Emit partition elaboration policy
	in P line.
	* lib-writ.ads: Document partition elaboration policy indication.
	* sem_prag.adb (Check_Arg_Is_Partition_Elaboration_Policy): New
	procedure.
	(Analyze_Pragma): Handle Partition_Elaboration_Policy.
	(Sig_Flags): Add flag for Pragma_Partition_Elaboration_Policy
	* ali.adb (Initialize_ALI): Init Partition_Elaboration_Policy_Specified.
	(Scan_ALI): Read Ex indications.
	* ali.ads: ALIs_Record: Add Partition_Elaboration_Policy.
	* par-prag.adb (Prag): Add Partition_Elaboration_Policy.
	* snames.adb-tmpl (Is_Partition_Elaboration_Policy_Name): New function.
	* opt.ads (Partition_Elaboration_Policy): Declare.
	(Partition_Elaboration_Policy_Sloc): Declare.
	* bcheck.adb (Check_Consistent_Partition_Elaboration_Policy):
	New procedure.	(Check_Configuration_Consistency): Check partition
	elaboration policy consistency.
	* snames.ads-tmpl (Name_Partition_Elaboration_Policy): New name.
	(First_Partition_Elaboration_Policy_Name, Name_Concurrent,
	Name_Sequential, Last_Partition_Elaboration_Policy_Name): Likewise.
	(Pragma_Partition_Elaboration_Policy): New literal.
	(Is_Partition_Elaboration_Policy_Name): New function.

Patch

Index: lib-writ.adb
===================================================================
--- lib-writ.adb	(revision 192918)
+++ lib-writ.adb	(working copy)
@@ -1099,6 +1099,11 @@ 
          end if;
       end if;
 
+      if Partition_Elaboration_Policy /= ' ' then
+         Write_Info_Str  (" E");
+         Write_Info_Char (Partition_Elaboration_Policy);
+      end if;
+
       if not Object then
          Write_Info_Str (" NO");
       end if;
Index: lib-writ.ads
===================================================================
--- lib-writ.ads	(revision 192918)
+++ lib-writ.ads	(working copy)
@@ -196,6 +196,10 @@ 
    --         DB   Detect_Blocking pragma is in effect for all units in this
    --              file.
    --
+   --         Ex   A valid Partition_Elaboration_Policy pragma applies to all
+   --              the units in this file, where x is the first character
+   --              (upper case) of the policy name (e.g. 'C' for Concurrent).
+   --
    --         FD   Configuration pragmas apply to all the units in this file
    --              specifying a possibly non-standard floating point format
    --              (VAX float with Long_Float using D_Float).
Index: sem_prag.adb
===================================================================
--- sem_prag.adb	(revision 192926)
+++ sem_prag.adb	(working copy)
@@ -505,6 +505,10 @@ 
       --  Check the specified argument Arg to make sure that it is a valid
       --  locking policy name. If not give error and raise Pragma_Exit.
 
+      procedure Check_Arg_Is_Partition_Elaboration_Policy (Arg : Node_Id);
+      --  Check the specified argument Arg to make sure that it is a valid
+      --  elaboration policy name. If not give error and raise Pragma_Exit.
+
       procedure Check_Arg_Is_One_Of
         (Arg                : Node_Id;
          N1, N2             : Name_Id);
@@ -1190,6 +1194,22 @@ 
          end if;
       end Check_Arg_Is_Locking_Policy;
 
+      -----------------------------------------------
+      -- Check_Arg_Is_Partition_Elaboration_Policy --
+      -----------------------------------------------
+
+      procedure Check_Arg_Is_Partition_Elaboration_Policy (Arg : Node_Id) is
+         Argx : constant Node_Id := Get_Pragma_Arg (Arg);
+
+      begin
+         Check_Arg_Is_Identifier (Argx);
+
+         if not Is_Partition_Elaboration_Policy_Name (Chars (Argx)) then
+            Error_Pragma_Arg
+              ("& is not a valid partition elaboration policy name", Argx);
+         end if;
+      end Check_Arg_Is_Partition_Elaboration_Policy;
+
       -------------------------
       -- Check_Arg_Is_One_Of --
       -------------------------
@@ -12039,6 +12059,53 @@ 
          when Pragma_Page =>
             null;
 
+         ----------------------------------
+         -- Partition_Elaboration_Policy --
+         ----------------------------------
+
+         --  pragma Partition_Elaboration_Policy (policy_IDENTIFIER);
+
+         when Pragma_Partition_Elaboration_Policy => declare
+            subtype PEP_Range is Name_Id
+              range First_Partition_Elaboration_Policy_Name
+                 .. Last_Partition_Elaboration_Policy_Name;
+            PEP_Val : PEP_Range;
+            PEP     : Character;
+
+         begin
+            Ada_2005_Pragma;
+            Check_Arg_Count (1);
+            Check_No_Identifiers;
+            Check_Arg_Is_Partition_Elaboration_Policy (Arg1);
+            Check_Valid_Configuration_Pragma;
+            PEP_Val := Chars (Get_Pragma_Arg (Arg1));
+
+            case PEP_Val is
+               when Name_Concurrent =>
+                  PEP := 'C';
+               when Name_Sequential =>
+                  PEP := 'S';
+            end case;
+
+            if Partition_Elaboration_Policy /= ' '
+              and then Partition_Elaboration_Policy /= PEP
+            then
+               Error_Msg_Sloc := Partition_Elaboration_Policy_Sloc;
+               Error_Pragma
+                 ("partition elaboration policy incompatible with policy#");
+
+            --  Set new policy, but always preserve System_Location since we
+            --  like the error message with the run time name.
+
+            else
+               Partition_Elaboration_Policy := PEP;
+
+               if Partition_Elaboration_Policy_Sloc /= System_Location then
+                  Partition_Elaboration_Policy_Sloc := Loc;
+               end if;
+            end if;
+         end;
+
          -------------
          -- Passive --
          -------------
@@ -15312,6 +15379,7 @@ 
       Pragma_Ordered                        =>  0,
       Pragma_Pack                           =>  0,
       Pragma_Page                           => -1,
+      Pragma_Partition_Elaboration_Policy   => -1,
       Pragma_Passive                        => -1,
       Pragma_Preelaborable_Initialization   => -1,
       Pragma_Polling                        => -1,
Index: ali.adb
===================================================================
--- ali.adb	(revision 192918)
+++ ali.adb	(working copy)
@@ -107,17 +107,18 @@ 
       --  Initialize global variables recording cumulative options in all
       --  ALI files that are read for a given processing run in gnatbind.
 
-      Dynamic_Elaboration_Checks_Specified := False;
-      Float_Format_Specified               := ' ';
-      Locking_Policy_Specified             := ' ';
-      No_Normalize_Scalars_Specified       := False;
-      No_Object_Specified                  := False;
-      Normalize_Scalars_Specified          := False;
-      Queuing_Policy_Specified             := ' ';
-      Static_Elaboration_Model_Used        := False;
-      Task_Dispatching_Policy_Specified    := ' ';
-      Unreserve_All_Interrupts_Specified   := False;
-      Zero_Cost_Exceptions_Specified       := False;
+      Dynamic_Elaboration_Checks_Specified   := False;
+      Float_Format_Specified                 := ' ';
+      Locking_Policy_Specified               := ' ';
+      No_Normalize_Scalars_Specified         := False;
+      No_Object_Specified                    := False;
+      Normalize_Scalars_Specified            := False;
+      Partition_Elaboration_Policy_Specified := ' ';
+      Queuing_Policy_Specified               := ' ';
+      Static_Elaboration_Model_Used          := False;
+      Task_Dispatching_Policy_Specified      := ' ';
+      Unreserve_All_Interrupts_Specified     := False;
+      Zero_Cost_Exceptions_Specified         := False;
    end Initialize_ALI;
 
    --------------
@@ -813,36 +814,37 @@ 
       Set_Name_Table_Info (F, Int (Id));
 
       ALIs.Table (Id) := (
-        Afile                      => F,
-        Compile_Errors             => False,
-        First_Interrupt_State      => Interrupt_States.Last + 1,
-        First_Sdep                 => No_Sdep_Id,
-        First_Specific_Dispatching => Specific_Dispatching.Last + 1,
-        First_Unit                 => No_Unit_Id,
-        Float_Format               => 'I',
-        Last_Interrupt_State       => Interrupt_States.Last,
-        Last_Sdep                  => No_Sdep_Id,
-        Last_Specific_Dispatching  => Specific_Dispatching.Last,
-        Last_Unit                  => No_Unit_Id,
-        Locking_Policy             => ' ',
-        Main_Priority              => -1,
-        Main_CPU                   => -1,
-        Main_Program               => None,
-        No_Object                  => False,
-        Normalize_Scalars          => False,
-        Ofile_Full_Name            => Full_Object_File_Name,
-        Queuing_Policy             => ' ',
-        Restrictions               => No_Restrictions,
-        SAL_Interface              => False,
-        Sfile                      => No_File,
-        Task_Dispatching_Policy    => ' ',
-        Time_Slice_Value           => -1,
-        Allocator_In_Body          => False,
-        WC_Encoding                => 'b',
-        Unit_Exception_Table       => False,
-        Ver                        => (others => ' '),
-        Ver_Len                    => 0,
-        Zero_Cost_Exceptions       => False);
+        Afile                        => F,
+        Compile_Errors               => False,
+        First_Interrupt_State        => Interrupt_States.Last + 1,
+        First_Sdep                   => No_Sdep_Id,
+        First_Specific_Dispatching   => Specific_Dispatching.Last + 1,
+        First_Unit                   => No_Unit_Id,
+        Float_Format                 => 'I',
+        Last_Interrupt_State         => Interrupt_States.Last,
+        Last_Sdep                    => No_Sdep_Id,
+        Last_Specific_Dispatching    => Specific_Dispatching.Last,
+        Last_Unit                    => No_Unit_Id,
+        Locking_Policy               => ' ',
+        Main_Priority                => -1,
+        Main_CPU                     => -1,
+        Main_Program                 => None,
+        No_Object                    => False,
+        Normalize_Scalars            => False,
+        Ofile_Full_Name              => Full_Object_File_Name,
+        Partition_Elaboration_Policy => ' ',
+        Queuing_Policy               => ' ',
+        Restrictions                 => No_Restrictions,
+        SAL_Interface                => False,
+        Sfile                        => No_File,
+        Task_Dispatching_Policy      => ' ',
+        Time_Slice_Value             => -1,
+        Allocator_In_Body            => False,
+        WC_Encoding                  => 'b',
+        Unit_Exception_Table         => False,
+        Ver                          => (others => ' '),
+        Ver_Len                      => 0,
+        Zero_Cost_Exceptions         => False);
 
       --  Now we acquire the input lines from the ALI file. Note that the
       --  convention in the following code is that as we enter each section,
@@ -1027,6 +1029,13 @@ 
                Checkc ('B');
                Detect_Blocking := True;
 
+            --  Processing for Ex
+
+            elsif C = 'E' then
+               Partition_Elaboration_Policy_Specified := Getc;
+               ALIs.Table (Id).Partition_Elaboration_Policy :=
+                 Partition_Elaboration_Policy_Specified;
+
             --  Processing for FD/FG/FI
 
             elsif C = 'F' then
Index: ali.ads
===================================================================
--- ali.ads	(revision 192918)
+++ ali.ads	(working copy)
@@ -156,6 +156,12 @@ 
       --  this is a language defined unit. Otherwise set to first character
       --  (upper case) of policy name. Not set if 'P' appears in Ignore_Lines.
 
+      Partition_Elaboration_Policy : Character;
+      --  Indicates partition elaboration policy for units in this file. Space
+      --  means that no Partition_Elaboration_Policy pragma was present or that
+      --  this is a language defined unit. Otherwise set to first character
+      --  (upper case) of policy name. Not set if 'P' appears in Ignore_Lines.
+
       Queuing_Policy : Character;
       --  Indicates queuing policy for units in this file. Space means tasking
       --  was not used, or that no Queuing_Policy pragma was present or that
@@ -485,6 +491,11 @@ 
    --  Set to False by Initialize_ALI. Set to True if an ali file indicates
    --  that the file was compiled in Normalize_Scalars mode.
 
+   Partition_Elaboration_Policy_Specified : Character := ' ';
+   --  Set to blank by Initialize_ALI. Set to the appropriate partition
+   --  elaboration policy character if an ali file contains a P line setting
+   --  the policy.
+
    Queuing_Policy_Specified : Character := ' ';
    --  Set to blank by Initialize_ALI. Set to the appropriate queuing policy
    --  character if an ali file contains a P line setting the queuing policy.
Index: par-prag.adb
===================================================================
--- par-prag.adb	(revision 192923)
+++ par-prag.adb	(working copy)
@@ -1202,6 +1202,7 @@ 
            Pragma_Optimize_Alignment             |
            Pragma_Overflow_Checks                |
            Pragma_Pack                           |
+           Pragma_Partition_Elaboration_Policy   |
            Pragma_Passive                        |
            Pragma_Preelaborable_Initialization   |
            Pragma_Polling                        |
Index: snames.adb-tmpl
===================================================================
--- snames.adb-tmpl	(revision 192918)
+++ snames.adb-tmpl	(working copy)
@@ -419,6 +419,17 @@ 
       return N in First_Locking_Policy_Name .. Last_Locking_Policy_Name;
    end Is_Locking_Policy_Name;
 
+   -------------------------------------
+   -- Is_Partition_Elaboration_Policy --
+   -------------------------------------
+
+   function Is_Partition_Elaboration_Policy_Name (N : Name_Id)
+      return Boolean is
+   begin
+      return N in First_Partition_Elaboration_Policy_Name
+           ..  Last_Partition_Elaboration_Policy_Name;
+   end Is_Partition_Elaboration_Policy_Name;
+
    -----------------------------
    -- Is_Operator_Symbol_Name --
    -----------------------------
Index: opt.ads
===================================================================
--- opt.ads	(revision 192918)
+++ opt.ads	(working copy)
@@ -1085,6 +1085,18 @@ 
    --  True if output of list of objects is requested (-O switch set). List is
    --  output under the given filename, or standard output if not specified.
 
+   Partition_Elaboration_Policy : Character := ' ';
+   --  GNAT, GNATBIND
+   --  Set to ' ' for the default case (no elaboration policy specified). Reset
+   --  to first character (uppercase) of locking policy name if a valid pragma
+   --  Partition_Elaboration_Policy is encountered.
+
+   Partition_Elaboration_Policy_Sloc : Source_Ptr := No_Location;
+   --  GNAT, GNATBIND
+   --  Remember location of previous Partition_Elaboration_Policy pragma. This
+   --  is used for inconsistency error messages. A value of System_Location is
+   --  used if the policy is set in package System.
+
    Persistent_BSS_Mode : Boolean := False;
    --  GNAT
    --  True if a Persistent_BSS configuration pragma is in effect, causing
Index: bcheck.adb
===================================================================
--- bcheck.adb	(revision 192918)
+++ bcheck.adb	(working copy)
@@ -52,6 +52,7 @@ 
    procedure Check_Consistent_Locking_Policy;
    procedure Check_Consistent_Normalize_Scalars;
    procedure Check_Consistent_Optimize_Alignment;
+   procedure Check_Consistent_Partition_Elaboration_Policy;
    procedure Check_Consistent_Queuing_Policy;
    procedure Check_Consistent_Restrictions;
    procedure Check_Consistent_Restriction_No_Default_Initialization;
@@ -83,6 +84,10 @@ 
          Check_Consistent_Locking_Policy;
       end if;
 
+      if Partition_Elaboration_Policy_Specified /= ' ' then
+         Check_Consistent_Partition_Elaboration_Policy;
+      end if;
+
       if Zero_Cost_Exceptions_Specified then
          Check_Consistent_Zero_Cost_Exception_Handling;
       end if;
@@ -744,6 +749,59 @@ 
       end loop;
    end Check_Consistent_Optimize_Alignment;
 
+   ---------------------------------------------------
+   -- Check_Consistent_Partition_Elaboration_Policy --
+   ---------------------------------------------------
+
+   --  The rule is that all files for which the partition elaboration policy is
+   --  significant must be compiled with the same setting.
+
+   procedure Check_Consistent_Partition_Elaboration_Policy is
+   begin
+      --  First search for a unit specifying a policy and then
+      --  check all remaining units against it.
+
+      Find_Policy : for A1 in ALIs.First .. ALIs.Last loop
+         if ALIs.Table (A1).Partition_Elaboration_Policy /= ' ' then
+            Check_Policy : declare
+               Policy : constant Character :=
+                  ALIs.Table (A1).Partition_Elaboration_Policy;
+
+            begin
+               for A2 in A1 + 1 .. ALIs.Last loop
+                  if ALIs.Table (A2).Partition_Elaboration_Policy /= ' '
+                       and then
+                     ALIs.Table (A2).Partition_Elaboration_Policy /= Policy
+                  then
+                     Error_Msg_File_1 := ALIs.Table (A1).Sfile;
+                     Error_Msg_File_2 := ALIs.Table (A2).Sfile;
+
+                     Consistency_Error_Msg
+                       ("{ and { compiled with different partition "
+                          & "elaboration policies");
+                     exit Find_Policy;
+                  end if;
+               end loop;
+            end Check_Policy;
+
+            --  A No_Task_Hierarchy restriction must be specified for the
+            --  Sequential policy (RM H.6(6/2)).
+
+            if Partition_Elaboration_Policy_Specified = 'S'
+              and then not Cumulative_Restrictions.Set (No_Task_Hierarchy)
+            then
+               Error_Msg_File_1 := ALIs.Table (A1).Sfile;
+               Error_Msg
+                 ("{ has sequential partition elaboration policy, but no");
+               Error_Msg
+                 ("pragma Restrictions (No_Task_Hierarchy) was specified");
+            end if;
+
+            exit Find_Policy;
+         end if;
+      end loop Find_Policy;
+   end Check_Consistent_Partition_Elaboration_Policy;
+
    -------------------------------------
    -- Check_Consistent_Queuing_Policy --
    -------------------------------------
Index: snames.ads-tmpl
===================================================================
--- snames.ads-tmpl	(revision 192923)
+++ snames.ads-tmpl	(working copy)
@@ -409,6 +409,7 @@ 
    Name_Normalize_Scalars              : constant Name_Id := N + $;
    Name_Optimize_Alignment             : constant Name_Id := N + $; -- GNAT
    Name_Overflow_Checks                : constant Name_Id := N + $; -- GNAT
+   Name_Partition_Elaboration_Policy   : constant Name_Id := N + $; -- Ada 05
    Name_Persistent_BSS                 : constant Name_Id := N + $; -- GNAT
    Name_Polling                        : constant Name_Id := N + $; -- GNAT
    Name_Priority_Specific_Dispatching  : constant Name_Id := N + $; -- Ada 05
@@ -1015,6 +1016,17 @@ 
    Name_Round_Robin_Within_Priorities    : constant Name_Id := N + $;
    Last_Task_Dispatching_Policy_Name     : constant Name_Id := N + $;
 
+   --  Names of recognized partition elaboration policy identifiers
+
+   --  Note: policies are identified by the first character of the name (e.g. S
+   --  for Sequential). If new policy names are added, the first character must
+   --  be distinct.
+
+   First_Partition_Elaboration_Policy_Name : constant Name_Id := N + $;
+   Name_Concurrent                         : constant Name_Id := N + $;
+   Name_Sequential                         : constant Name_Id := N + $;
+   Last_Partition_Elaboration_Policy_Name  : constant Name_Id := N + $;
+
    --  Names of recognized checks for pragma Suppress
 
    --  Note: the name Atomic_Synchronization can only be specified internally
@@ -1666,6 +1678,7 @@ 
       Pragma_Normalize_Scalars,
       Pragma_Optimize_Alignment,
       Pragma_Overflow_Checks,
+      Pragma_Partition_Elaboration_Policy,
       Pragma_Persistent_BSS,
       Pragma_Polling,
       Pragma_Priority_Specific_Dispatching,
@@ -1902,6 +1915,10 @@ 
    function Is_Locking_Policy_Name (N : Name_Id) return Boolean;
    --  Test to see if the name N is the name of a recognized locking policy
 
+   function Is_Partition_Elaboration_Policy_Name (N : Name_Id) return Boolean;
+   --  Test to see if the name N is the name of a recognized partition
+   --  elaboration policy.
+
    function Is_Operator_Symbol_Name (N : Name_Id) return Boolean;
    --  Test to see if the name N is the name of an operator symbol
 
@@ -1978,6 +1995,7 @@ 
    pragma Inline (Is_Entity_Attribute_Name);
    pragma Inline (Is_Type_Attribute_Name);
    pragma Inline (Is_Locking_Policy_Name);
+   pragma Inline (Is_Partition_Elaboration_Policy_Name);
    pragma Inline (Is_Operator_Symbol_Name);
    pragma Inline (Is_Queuing_Policy_Name);
    pragma Inline (Is_Pragma_Name);