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 <ging...@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.
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);
