OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

exp_ch5.adb, [...]: This is a general change that deals with the fact that most of the special... 

2015-05-22  Robert Dewar  <dewar@adacore.com>

	* exp_ch5.adb, layout.adb, einfo.adb, einfo.ads, sem_prag.adb,
	freeze.adb, freeze.ads, sem_util.adb, sem_util.ads, exp_ch2.adb,
	exp_ch4.adb, errout.adb, exp_aggr.adb, sem_ch13.adb: This is a general
	change that deals with the fact that most of the special coding for
	Atomic should also apply to the case of Volatile_Full_Access.
	A new attribute Is_Atomic_Or_VFA is introduced, and many of the
	references to Is_Atomic now use this new attribute.

From-SVN: r223560
This commit is contained in:
Robert Dewar 2015-05-22 12:53:21 +00:00 committed by Arnaud Charlet
parent 878e58c85e
commit f280dd8f6d
15 changed files with 173 additions and 66 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
gcc/ada/ChangeLog
View File

@ -1,3 +1,13 @@
2015-05-22 Robert Dewar <dewar@adacore.com>
* exp_ch5.adb, layout.adb, einfo.adb, einfo.ads, sem_prag.adb,
freeze.adb, freeze.ads, sem_util.adb, sem_util.ads, exp_ch2.adb,
exp_ch4.adb, errout.adb, exp_aggr.adb, sem_ch13.adb: This is a general
change that deals with the fact that most of the special coding for
Atomic should also apply to the case of Volatile_Full_Access.
A new attribute Is_Atomic_Or_VFA is introduced, and many of the
references to Is_Atomic now use this new attribute.
2015-05-22 Robert Dewar <dewar@adacore.com>
* exp_ch4.adb (Expand_N_Op_Eq): Introduce 'Machine for 'Result

9
gcc/ada/einfo.adb
View File

@ -7329,6 +7329,15 @@ package body Einfo is
end if;
end Invariant_Procedure;
----------------------
-- Is_Atomic_Or_VFA --
----------------------
function Is_Atomic_Or_VFA (Id : E) return B is
begin
return Is_Atomic (Id) or else Has_Volatile_Full_Access (Id);
end Is_Atomic_Or_VFA;
------------------
-- Is_Base_Type --
------------------

14
gcc/ada/einfo.ads
View File

@ -2218,6 +2218,14 @@ package Einfo is
-- In the case of private and incomplete types, this flag is set in
-- both the partial view and the full view.
-- Is_Atomic_Or_VFA (synth)
-- Defined in all type entities, and also in constants, components and
-- variables. Set if a pragma Atomic or Shared or Volatile_Full_Access
-- applies to the entity. For many purposes VFA objects should be treated
-- the same as Atomic objects, and this predicate is intended for that
-- usage. In the case of private and incomplete types, the predicate
-- applies to both the partial view and the full view.
-- Is_Array_Type (synthesized)
-- Applies to all entities, true for array types and subtypes
@ -5476,6 +5484,7 @@ package Einfo is
-- Implementation_Base_Type (synth)
-- Invariant_Procedure (synth)
-- Is_Access_Protected_Subprogram_Type (synth)
-- Is_Atomic_Or_VFA (synth)
-- Predicate_Function (synth)
-- Predicate_Function_M (synth)
-- Root_Type (synth)
@ -5628,6 +5637,7 @@ package Einfo is
-- Is_Tag (Flag78)
-- Is_Volatile (Flag16)
-- Treat_As_Volatile (Flag41)
-- Is_Atomic_Or_VFA (synth)
-- Next_Component (synth)
-- Next_Component_Or_Discriminant (synth)
@ -5676,6 +5686,7 @@ package Einfo is
-- Treat_As_Volatile (Flag41)
-- Address_Clause (synth)
-- Alignment_Clause (synth)
-- Is_Atomic_Or_VFA (synth)
-- Size_Clause (synth)
-- E_Decimal_Fixed_Point_Type
@ -6413,6 +6424,7 @@ package Einfo is
-- Treat_As_Volatile (Flag41)
-- Address_Clause (synth)
-- Alignment_Clause (synth)
-- Is_Atomic_Or_VFA (synth)
-- Size_Clause (synth)
-- E_Void
@ -6869,6 +6881,7 @@ package Einfo is
function Is_Aliased (Id : E) return B;
function Is_Asynchronous (Id : E) return B;
function Is_Atomic (Id : E) return B;
function Is_Atomic_Or_VFA (Id : E) return B;
function Is_Bit_Packed_Array (Id : E) return B;
function Is_Called (Id : E) return B;
function Is_Character_Type (Id : E) return B;
@ -9041,6 +9054,7 @@ package Einfo is
-- be handled by xeinfo.
pragma Inline (Base_Type);
pragma Inline (Is_Atomic_Or_VFA);
pragma Inline (Is_Base_Type);
pragma Inline (Is_Package_Or_Generic_Package);
pragma Inline (Is_Packed_Array);

10
gcc/ada/errout.adb
View File

@ -3159,6 +3159,16 @@ package body Errout is
return True;
end if;
-- Similar processing for "volatile full access cannot be guaranteed"
elsif Msg = "volatile full access to & cannot be guaranteed" then
if Is_Type (E)
and then Has_Volatile_Full_Access (E)
and then No (Get_Rep_Pragma (E, Name_Volatile_Full_Access))
then
return True;
end if;
-- Processing for "Size too small" messages
elsif Msg = "size for& too small, minimum allowed is ^" then

8
gcc/ada/exp_aggr.adb
View File

@ -4175,7 +4175,7 @@ package body Exp_Aggr is
Ctyp := Component_Type (Ctyp);
if Is_Atomic (Ctyp) then
if Is_Atomic_Or_VFA (Ctyp) then
return False;
end if;
end loop;
@ -5935,15 +5935,15 @@ package body Exp_Aggr is
-- Start of processing for Expand_Record_Aggregate
begin
-- If the aggregate is to be assigned to an atomic variable, we have
-- If the aggregate is to be assigned to an atomic/VFA variable, we have
-- to prevent a piecemeal assignment even if the aggregate is to be
-- expanded. We create a temporary for the aggregate, and assign the
-- temporary instead, so that the back end can generate an atomic move
-- for it.
if Is_Atomic (Typ)
if Is_Atomic_Or_VFA (Typ)
and then Comes_From_Source (Parent (N))
and then Is_Atomic_Aggregate (N, Typ)
and then Is_Atomic_VFA_Aggregate (N, Typ)
then
return;

5
gcc/ada/exp_ch2.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2015, 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- --
@ -396,7 +396,8 @@ package body Exp_Ch2 is
Write_Eol;
end if;
-- Set Atomic_Sync_Required if necessary for atomic variable
-- Set Atomic_Sync_Required if necessary for atomic variable. Note that
-- this processing does NOT apply to Volatile_Full_Access variables.
if Nkind_In (N, N_Identifier, N_Expanded_Name)
and then Ekind (E) = E_Variable

4
gcc/ada/exp_ch4.adb
View File

@ -7313,12 +7313,12 @@ package body Exp_Ch4 is
-- Where the component type is elementary we can use a block bit
-- comparison (if supported on the target) exception in the case
-- of floating-point (negative zero issues require element by
-- element comparison), and atomic types (where we must be sure
-- element comparison), and atomic/VFA types (where we must be sure
-- to load elements independently) and possibly unaligned arrays.
elsif Is_Elementary_Type (Component_Type (Typl))
and then not Is_Floating_Point_Type (Component_Type (Typl))
and then not Is_Atomic (Component_Type (Typl))
and then not Is_Atomic_Or_VFA (Component_Type (Typl))
and then not Is_Possibly_Unaligned_Object (Lhs)
and then not Is_Possibly_Unaligned_Object (Rhs)
and then Support_Composite_Compare_On_Target

12
gcc/ada/exp_ch5.adb
View File

@ -429,11 +429,11 @@ package body Exp_Ch5 is
elsif Has_Controlled_Component (L_Type) then
Loop_Required := True;
-- If object is atomic, we cannot tolerate a loop
-- If object is atomic/VFA, we cannot tolerate a loop
elsif Is_Atomic_Object (Act_Lhs)
elsif Is_Atomic_Or_VFA_Object (Act_Lhs)
or else
Is_Atomic_Object (Act_Rhs)
Is_Atomic_Or_VFA_Object (Act_Rhs)
then
return;
@ -442,8 +442,8 @@ package body Exp_Ch5 is
elsif Has_Atomic_Components (L_Type)
or else Has_Atomic_Components (R_Type)
or else Is_Atomic (Component_Type (L_Type))
or else Is_Atomic (Component_Type (R_Type))
or else Is_Atomic_Or_VFA (Component_Type (L_Type))
or else Is_Atomic_Or_VFA (Component_Type (R_Type))
then
Loop_Required := True;
@ -3395,7 +3395,7 @@ package body Exp_Ch5 is
Next_Elmt (Prim);
end loop;
-- default iterator must exist.
-- Default iterator must exist
pragma Assert (False);

53
gcc/ada/freeze.adb
View File

@ -942,13 +942,13 @@ package body Freeze is
Packed_Size_Known := False;
end if;
-- We do not know the packed size if we have an atomic type
-- We do not know the packed size for an atomic/VFA type
-- or component, or an independent type or component, or a
-- by reference type or aliased component (because packing
-- does not touch these).
if Is_Atomic (Ctyp)
or else Is_Atomic (Comp)
if Is_Atomic_Or_VFA (Ctyp)
or else Is_Atomic_Or_VFA (Comp)
or else Is_Independent (Ctyp)
or else Is_Independent (Comp)
or else Is_By_Reference_Type (Ctyp)
@ -1036,11 +1036,11 @@ package body Freeze is
and then Is_Modular_Integer_Type
(Packed_Array_Impl_Type (Ctyp)))
then
-- Packed size unknown if we have an atomic type
-- or a by reference type, since the back end
-- knows how these are layed out.
-- Packed size unknown if we have an atomic/VFA type
-- or a by reference type, since the back end knows
-- how these are layed out.
if Is_Atomic (Ctyp)
if Is_Atomic_Or_VFA (Ctyp)
or else Is_By_Reference_Type (Ctyp)
then
Packed_Size_Known := False;
@ -1455,11 +1455,11 @@ package body Freeze is
end loop;
end Check_Unsigned_Type;
-------------------------
-- Is_Atomic_Aggregate --
-------------------------
-----------------------------
-- Is_Atomic_VFA_Aggregate --
-----------------------------
function Is_Atomic_Aggregate
function Is_Atomic_VFA_Aggregate
(E : Entity_Id;
Typ : Entity_Id) return Boolean
is
@ -1495,7 +1495,7 @@ package body Freeze is
else
return False;
end if;
end Is_Atomic_Aggregate;
end Is_Atomic_VFA_Aggregate;
-----------------------------------------------
-- Explode_Initialization_Compound_Statement --
@ -2423,12 +2423,12 @@ package body Freeze is
end if;
end;
-- Check for Aliased or Atomic_Components/Atomic with unsuitable
-- packing or explicit component size clause given.
-- Check for Aliased or Atomic_Components/Atomic/VFA with
-- unsuitable packing or explicit component size clause given.
if (Has_Aliased_Components (Arr)
or else Has_Atomic_Components (Arr)
or else Is_Atomic (Ctyp))
or else Is_Atomic_Or_VFA (Ctyp))
and then
(Has_Component_Size_Clause (Arr) or else Is_Packed (Arr))
then
@ -2436,8 +2436,8 @@ package body Freeze is
procedure Complain_CS (T : String);
-- Outputs error messages for incorrect CS clause or pragma
-- Pack for aliased or atomic components (T is "aliased" or
-- "atomic");
-- Pack for aliased or atomic/VFA components (T is "aliased"
-- or "atomic/vfa");
-----------------
-- Complain_CS --
@ -2498,9 +2498,13 @@ package body Freeze is
elsif Has_Aliased_Components (Arr) then
Complain_CS ("aliased");
elsif Has_Atomic_Components (Arr) or else Is_Atomic (Ctyp)
elsif Has_Atomic_Components (Arr)
or else Is_Atomic (Ctyp)
then
Complain_CS ("atomic");
elsif Has_Volatile_Full_Access (Ctyp) then
Complain_CS ("volatile full access");
end if;
end Alias_Atomic_Check;
end if;
@ -2509,8 +2513,8 @@ package body Freeze is
-- packing or explicit component size clause given.
if (Has_Independent_Components (Arr) or else Is_Independent (Ctyp))
and then
(Has_Component_Size_Clause (Arr) or else Is_Packed (Arr))
and then
(Has_Component_Size_Clause (Arr) or else Is_Packed (Arr))
then
begin
-- If object size of component type isn't known, we cannot
@ -2772,7 +2776,7 @@ package body Freeze is
-- For non-packed arrays set the alignment of the array to the
-- alignment of the component type if it is unknown. Skip this
-- in atomic case (atomic arrays may need larger alignments).
-- in atomic/VFA case (atomic/VFA arrays may need larger alignments).
if not Is_Packed (Arr)
and then Unknown_Alignment (Arr)
@ -2780,7 +2784,7 @@ package body Freeze is
and then Known_Static_Component_Size (Arr)
and then Known_Static_Esize (Ctyp)
and then Esize (Ctyp) = Component_Size (Arr)
and then not Is_Atomic (Arr)
and then not Is_Atomic_Or_VFA (Arr)
then
Set_Alignment (Arr, Alignment (Component_Type (Arr)));
end if;
@ -4813,11 +4817,12 @@ package body Freeze is
-- than component-wise (the assignment to the temp may be done
-- component-wise, but that is harmless).
elsif Is_Atomic (E)
elsif Is_Atomic_Or_VFA (E)
and then Nkind (Parent (E)) = N_Object_Declaration
and then Present (Expression (Parent (E)))
and then Nkind (Expression (Parent (E))) = N_Aggregate
and then Is_Atomic_Aggregate (Expression (Parent (E)), Etype (E))
and then
Is_Atomic_VFA_Aggregate (Expression (Parent (E)), Etype (E))
then
null;
end if;

9
gcc/ada/freeze.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2015, 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- --
@ -174,12 +174,11 @@ package Freeze is
-- do not allow a size clause if the size would not otherwise be known at
-- compile time in any case.
function Is_Atomic_Aggregate
function Is_Atomic_VFA_Aggregate
(E : Entity_Id;
Typ : Entity_Id) return Boolean;
-- If an atomic object is initialized with an aggregate or is assigned an
-- aggregate, we have to prevent a piecemeal access or assignment to the
-- If an atomic/VFA object is initialized with an aggregate or is assigned
-- an aggregate, we have to prevent a piecemeal access or assignment to the
-- object, even if the aggregate is to be expanded. We create a temporary
-- for the aggregate, and assign the temporary instead, so that the back
-- end can generate an atomic move for it. This is only done in the context

44
gcc/ada/layout.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2001-2014, Free Software Foundation, Inc. --
-- Copyright (C) 2001-2015, 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- --
@ -2684,11 +2684,11 @@ package body Layout is
elsif Is_Array_Type (E) then
-- For arrays that are required to be atomic, we do the same
-- For arrays that are required to be atomic/VFA, we do the same
-- processing as described above for short records, since we
-- really need to have the alignment set for the whole array.
if Is_Atomic (E) and then not Debug_Flag_Q then
if Is_Atomic_Or_VFA (E) and then not Debug_Flag_Q then
Set_Composite_Alignment (E);
end if;
@ -2903,11 +2903,19 @@ package body Layout is
and then Is_Record_Type (E)
and then Is_Packed (E)
then
-- No effect for record with atomic components
-- No effect for record with atomic/VFA components
if Is_Atomic (E) then
if Is_Atomic_Or_VFA (E) then
Error_Msg_N ("Optimize_Alignment has no effect for &??", E);
Error_Msg_N ("\pragma ignored for atomic record??", E);
if Is_Atomic (E) then
Error_Msg_N
("\pragma ignored for atomic record??", E);
else
Error_Msg_N
("\pragma ignored for bolatile full access record??", E);
end if;
return;
end if;
@ -2920,20 +2928,30 @@ package body Layout is
return;
end if;
-- No effect if any component is atomic or is a by reference type
-- No effect if any component is atomic/VFA or is a by reference type
declare
Ent : Entity_Id;
begin
Ent := First_Component_Or_Discriminant (E);
while Present (Ent) loop
if Is_By_Reference_Type (Etype (Ent))
or else Is_Atomic (Etype (Ent))
or else Is_Atomic (Ent)
or else Is_Atomic_Or_VFA (Etype (Ent))
or else Is_Atomic_Or_VFA (Ent)
then
Error_Msg_N ("Optimize_Alignment has no effect for &??", E);
Error_Msg_N
("\pragma is ignored if atomic components present??", E);
if Is_Atomic (Etype (Ent)) or else Is_Atomic (Ent) then
Error_Msg_N
("\pragma is ignored if atomic "
& "components present??", E);
else
Error_Msg_N
("\pragma is ignored if bolatile full access "
& "components present??", E);
end if;
return;
else
Next_Component_Or_Discriminant (Ent);
@ -3026,9 +3044,9 @@ package body Layout is
-- Further processing for record types only to reduce the alignment
-- set by the above processing in some specific cases. We do not
-- do this for atomic records, since we need max alignment there,
-- do this for atomic/VFA records, since we need max alignment there,
if Is_Record_Type (E) and then not Is_Atomic (E) then
if Is_Record_Type (E) and then not Is_Atomic_Or_VFA (E) then
-- For records, there is generally no point in setting alignment
-- higher than word size since we cannot do better than move by

25
gcc/ada/sem_ch13.adb
View File

@ -965,6 +965,13 @@ package body Sem_Ch13 is
Set_Is_Volatile (E);
end if;
-- Volatile_Full_Access
when Aspect_Volatile_Full_Access =>
if Has_Volatile_Full_Access (P) then
Set_Has_Volatile_Full_Access (E);
end if;
-- Volatile_Components
when Aspect_Volatile_Components =>
@ -1057,6 +1064,11 @@ package body Sem_Ch13 is
return;
end if;
when Aspect_Volatile_Full_Access =>
if not Has_Volatile_Full_Access (Par) then
return;
end if;
when others =>
return;
end case;
@ -1066,7 +1078,6 @@ package body Sem_Ch13 is
Error_Msg_Name_1 := A_Name;
Error_Msg_NE
("derived type& inherits aspect%, cannot cancel", Expr, E);
end Check_False_Aspect_For_Derived_Type;
-- Start of processing for Make_Pragma_From_Boolean_Aspect
@ -11164,6 +11175,18 @@ package body Sem_Ch13 is
Set_Is_Volatile (Typ);
end if;
-- Volatile_Full_Access
if not Has_Rep_Item (Typ, Name_Volatile_Full_Access, False)
and then Has_Rep_Pragma (Typ, Name_Volatile_Full_Access)
and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
(Get_Rep_Item (Typ, Name_Volatile_Full_Access))
then
Set_Has_Volatile_Full_Access (Typ);
Set_Treat_As_Volatile (Typ);
Set_Is_Volatile (Typ);
end if;
-- Inheritance for derived types only
if Is_Derived_Type (Typ) then

18
gcc/ada/sem_prag.adb
View File

@ -5842,17 +5842,17 @@ package body Sem_Prag is
K : Node_Kind;
Utyp : Entity_Id;
procedure Set_Atomic_Full (E : Entity_Id);
procedure Set_Atomic_VFA (E : Entity_Id);
-- Set given type as Is_Atomic or Has_Volatile_Full_Access. Also, if
-- no explicit alignment was given, set alignment to unknown, since
-- back end knows what the alignment requirements are for atomic and
-- full access arrays. Note: this is necessary for derived types.
---------------------
-- Set_Atomic_Full --
---------------------
--------------------
-- Set_Atomic_VFA --
--------------------
procedure Set_Atomic_Full (E : Entity_Id) is
procedure Set_Atomic_VFA (E : Entity_Id) is
begin
if Prag_Id = Pragma_Volatile_Full_Access then
Set_Has_Volatile_Full_Access (E);
@ -5863,7 +5863,7 @@ package body Sem_Prag is
if not Has_Alignment_Clause (E) then
Set_Alignment (E, Uint_0);
end if;
end Set_Atomic_Full;
end Set_Atomic_VFA;
-- Start of processing for Process_Atomic_Independent_Shared_Volatile
@ -5956,9 +5956,9 @@ package body Sem_Prag is
or else
Prag_Id = Pragma_Volatile_Full_Access
then
Set_Atomic_Full (E);
Set_Atomic_Full (Base_Type (E));
Set_Atomic_Full (Underlying_Type (E));
Set_Atomic_VFA (E);
Set_Atomic_VFA (Base_Type (E));
Set_Atomic_VFA (Underlying_Type (E));
end if;
-- Atomic/Shared/Volatile_Full_Access imply Independent

14
gcc/ada/sem_util.adb
View File

@ -10276,6 +10276,20 @@ package body Sem_Util is
end if;
end Is_Atomic_Object;
-----------------------------
-- Is_Atomic_Or_VFA_Object --
-----------------------------
function Is_Atomic_Or_VFA_Object (N : Node_Id) return Boolean is
begin
return Is_Atomic_Object (N)
or else (Is_Object_Reference (N)
and then Is_Entity_Name (N)
and then (Has_Volatile_Full_Access (Entity (N))
or else
Has_Volatile_Full_Access (Etype (Entity (N)))));
end Is_Atomic_Or_VFA_Object;
-------------------------
-- Is_Attribute_Result --
-------------------------

4
gcc/ada/sem_util.ads
View File

@ -1168,6 +1168,10 @@ package Sem_Util is
-- Determines if the given node denotes an atomic object in the sense of
-- the legality checks described in RM C.6(12).
function Is_Atomic_Or_VFA_Object (N : Node_Id) return Boolean;
-- Determines if the given node is an atomic object (Is_Atomic_Object true)
-- or else is an object for which VFA is present.
function Is_Attribute_Result (N : Node_Id) return Boolean;
-- Determine whether node N denotes attribute 'Result