===================================================================
@@ -6488,32 +6488,48 @@
---------------------
function Make_Range_Test return Node_Id is
- Temp : constant Node_Id := Duplicate_Subexpr (Pref);
+ Temp : Node_Id;
begin
- -- The value whose validity is being checked has been captured in
- -- an object declaration. We certainly don't want this object to
- -- appear valid because the declaration initializes it.
+ -- The prefix of attribute 'Valid should always denote an object
+ -- reference. The reference is either coming directly from source
+ -- or is produced by validity check expansion.
- if Is_Entity_Name (Temp) then
- Set_Is_Known_Valid (Entity (Temp), False);
+ -- If the prefix denotes a variable which captures the value of
+ -- an object for validation purposes, use the variable in the
+ -- range test. This ensures that no extra copies or extra reads
+ -- are produced as part of the test. Generate:
+
+ -- Temp : ... := Object;
+ -- if not Temp in ... then
+
+ if Is_Validation_Variable_Reference (Pref) then
+ Temp := New_Occurrence_Of (Entity (Pref), Loc);
+
+ -- Otherwise the prefix is either a source object or a constant
+ -- produced by validity check expansion. Generate:
+
+ -- Temp : constant ... := Pref;
+ -- if not Temp in ... then
+
+ else
+ Temp := Duplicate_Subexpr (Pref);
end if;
return
Make_In (Loc,
- Left_Opnd =>
- Unchecked_Convert_To (Btyp, Temp),
+ Left_Opnd => Unchecked_Convert_To (Btyp, Temp),
Right_Opnd =>
Make_Range (Loc,
- Low_Bound =>
+ Low_Bound =>
Unchecked_Convert_To (Btyp,
Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Ptyp, Loc),
+ Prefix => New_Occurrence_Of (Ptyp, Loc),
Attribute_Name => Name_First)),
High_Bound =>
Unchecked_Convert_To (Btyp,
Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Ptyp, Loc),
+ Prefix => New_Occurrence_Of (Ptyp, Loc),
Attribute_Name => Name_Last))));
end Make_Range_Test;
===================================================================
@@ -270,6 +270,8 @@
-- Entry_Max_Queue_Lengths_Array Node35
-- Import_Pragma Node35
+ -- Validated_Object Node36
+
-- Class_Wide_Preconds List38
-- Class_Wide_Postconds List39
@@ -3477,6 +3479,12 @@
return Flag95 (Id);
end Uses_Sec_Stack;
+ function Validated_Object (Id : E) return N is
+ begin
+ pragma Assert (Ekind (Id) = E_Variable);
+ return Node36 (Id);
+ end Validated_Object;
+
function Warnings_Off (Id : E) return B is
begin
return Flag96 (Id);
@@ -6618,6 +6626,12 @@
Set_Flag95 (Id, V);
end Set_Uses_Sec_Stack;
+ procedure Set_Validated_Object (Id : E; V : N) is
+ begin
+ pragma Assert (Ekind (Id) = E_Variable);
+ Set_Node36 (Id, V);
+ end Set_Validated_Object;
+
procedure Set_Warnings_Off (Id : E; V : B := True) is
begin
Set_Flag96 (Id, V);
@@ -10881,9 +10895,14 @@
------------------------
procedure Write_Field36_Name (Id : Entity_Id) is
- pragma Unreferenced (Id);
begin
- Write_Str ("Field36??");
+ case Ekind (Id) is
+ when E_Variable =>
+ Write_Str ("Validated_Object");
+
+ when others =>
+ Write_Str ("Field36??");
+ end case;
end Write_Field36_Name;
------------------------
===================================================================
@@ -4514,6 +4514,10 @@
-- task). Set to True when secondary stack is used in this scope and must
-- be released on exit unless Sec_Stack_Needed_For_Return is set.
+-- Validated_Object (Node36)
+-- Defined in variables. Contains the object whose value is captured by
+-- the variable for validity check purposes.
+
-- Warnings_Off (Flag96)
-- Defined in all entities. Set if a pragma Warnings (Off, entity-name)
-- is used to suppress warnings for a given entity. It is also used by
@@ -6609,6 +6613,7 @@
-- Linker_Section_Pragma (Node33)
-- Contract (Node34)
-- Anonymous_Designated_Type (Node35)
+ -- Validated_Object (Node36)
-- SPARK_Pragma (Node40)
-- Has_Alignment_Clause (Flag46)
-- Has_Atomic_Components (Flag86)
@@ -7342,6 +7347,7 @@
function Used_As_Generic_Actual (Id : E) return B;
function Uses_Lock_Free (Id : E) return B;
function Uses_Sec_Stack (Id : E) return B;
+ function Validated_Object (Id : E) return N;
function Warnings_Off (Id : E) return B;
function Warnings_Off_Used (Id : E) return B;
function Warnings_Off_Used_Unmodified (Id : E) return B;
@@ -8029,6 +8035,7 @@
procedure Set_Used_As_Generic_Actual (Id : E; V : B := True);
procedure Set_Uses_Lock_Free (Id : E; V : B := True);
procedure Set_Uses_Sec_Stack (Id : E; V : B := True);
+ procedure Set_Validated_Object (Id : E; V : N);
procedure Set_Warnings_Off (Id : E; V : B := True);
procedure Set_Warnings_Off_Used (Id : E; V : B := True);
procedure Set_Warnings_Off_Used_Unmodified (Id : E; V : B := True);
@@ -8871,6 +8878,7 @@
pragma Inline (Used_As_Generic_Actual);
pragma Inline (Uses_Lock_Free);
pragma Inline (Uses_Sec_Stack);
+ pragma Inline (Validated_Object);
pragma Inline (Warnings_Off);
pragma Inline (Warnings_Off_Used);
pragma Inline (Warnings_Off_Used_Unmodified);
@@ -9346,6 +9354,7 @@
pragma Inline (Set_Used_As_Generic_Actual);
pragma Inline (Set_Uses_Lock_Free);
pragma Inline (Set_Uses_Sec_Stack);
+ pragma Inline (Set_Validated_Object);
pragma Inline (Set_Warnings_Off);
pragma Inline (Set_Warnings_Off_Used);
pragma Inline (Set_Warnings_Off_Used_Unmodified);
===================================================================
@@ -7180,52 +7180,93 @@
Exp := Expression (Exp);
end loop;
+ -- Do not generate a check for a variable which already validates the
+ -- value of an assignable object.
+
+ if Is_Validation_Variable_Reference (Exp) then
+ return;
+ end if;
+
-- We are about to insert the validity check for Exp. We save and
-- reset the Do_Range_Check flag over this validity check, and then
-- put it back for the final original reference (Exp may be rewritten).
declare
DRC : constant Boolean := Do_Range_Check (Exp);
+ CE : Node_Id;
+ Obj : Node_Id;
PV : Node_Id;
- CE : Node_Id;
+ Var : Entity_Id;
begin
Set_Do_Range_Check (Exp, False);
- -- Force evaluation to avoid multiple reads for atomic/volatile
+ -- If the expression denotes an assignable object, capture its value
+ -- in a variable and replace the original expression by the variable.
+ -- This approach has several effects:
- -- Note: we set Name_Req to False. We used to set it to True, with
- -- the thinking that a name is required as the prefix of the 'Valid
- -- call, but in fact the check that the prefix of an attribute is
- -- a name is in the parser, and we just don't require it here.
- -- Moreover, when we set Name_Req to True, that interfered with the
- -- checking for Volatile, since we couldn't just capture the value.
+ -- 1) The evaluation of the object results in only one read in the
+ -- case where the object is atomic or volatile.
- if Is_Entity_Name (Exp)
- and then Is_Volatile (Entity (Exp))
- then
- -- Same reasoning as above for setting Name_Req to False
+ -- Temp ... := Object; -- read
- Force_Evaluation (Exp, Name_Req => False);
- end if;
+ -- 2) The captured value is the one verified by attribute 'Valid.
+ -- As a result the object is not evaluated again, which would
+ -- result in an unwanted read in the case where the object is
+ -- atomic or volatile.
- -- Build the prefix for the 'Valid call. If the expression denotes
- -- a non-volatile name, use a renaming to alias it, otherwise use a
- -- constant to capture the value of the expression.
+ -- if not Temp'Valid then -- OK, no read of Object
- -- Temp : ... renames Expr; -- non-volatile name
- -- Temp : constant ... := Expr; -- all other cases
+ -- if not Object'Valid then -- Wrong, extra read of Object
- PV :=
- Duplicate_Subexpr_No_Checks
- (Exp => Exp,
- Name_Req => False,
- Renaming_Req =>
- Is_Name_Reference (Exp) and then not Is_Volatile (Typ),
- Related_Id => Related_Id,
- Is_Low_Bound => Is_Low_Bound,
- Is_High_Bound => Is_High_Bound);
+ -- 3) The captured value replaces the original object reference.
+ -- As a result the object is not evaluated again, in the same
+ -- vein as 2).
+ -- ... Temp ... -- OK, no read of Object
+
+ -- ... Object ... -- Wrong, extra read of Object
+
+ -- 4) The use of a variable to capture the value of the object
+ -- allows the propagation of any changes back to the original
+ -- object.
+
+ -- procedure Call (Val : in out ...);
+
+ -- Temp : ... := Object; -- read Object
+ -- if not Temp'Valid then -- validity check
+ -- Call (Temp); -- modify Temp
+ -- Object := Temp; -- update Object
+
+ if Is_Variable (Exp) then
+ Obj := New_Copy_Tree (Exp);
+ Var := Make_Temporary (Loc, 'T', Exp);
+
+ Insert_Action (Exp,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Var,
+ Object_Definition => New_Occurrence_Of (Typ, Loc),
+ Expression => Relocate_Node (Exp)));
+ Set_Validated_Object (Var, Obj);
+
+ Rewrite (Exp, New_Occurrence_Of (Var, Loc));
+ PV := New_Occurrence_Of (Var, Loc);
+
+ -- Otherwise the expression does not denote a variable. Force its
+ -- evaluation by capturing its value in a constant. Generate:
+
+ -- Temp : constant ... := Exp;
+
+ else
+ Force_Evaluation
+ (Exp => Exp,
+ Related_Id => Related_Id,
+ Is_Low_Bound => Is_Low_Bound,
+ Is_High_Bound => Is_High_Bound);
+
+ PV := New_Copy_Tree (Exp);
+ end if;
+
-- A rather specialized test. If PV is an analyzed expression which
-- is an indexed component of a packed array that has not been
-- properly expanded, turn off its Analyzed flag to make sure it
===================================================================
@@ -15277,6 +15277,19 @@
return T = Universal_Integer or else T = Universal_Real;
end Is_Universal_Numeric_Type;
+ --------------------------------------
+ -- Is_Validation_Variable_Reference --
+ --------------------------------------
+
+ function Is_Validation_Variable_Reference (N : Node_Id) return Boolean is
+ begin
+ return
+ Is_Entity_Name (N)
+ and then Present (Entity (N))
+ and then Ekind (Entity (N)) = E_Variable
+ and then Present (Validated_Object (Entity (N)));
+ end Is_Validation_Variable_Reference;
+
----------------------------
-- Is_Variable_Size_Array --
----------------------------
@@ -15643,7 +15656,6 @@
------------------------
function Is_Volatile_Object (N : Node_Id) return Boolean is
-
function Is_Volatile_Prefix (N : Node_Id) return Boolean;
-- If prefix is an implicit dereference, examine designated type
===================================================================
@@ -1786,6 +1786,10 @@
pragma Inline (Is_Universal_Numeric_Type);
-- True if T is Universal_Integer or Universal_Real
+ function Is_Validation_Variable_Reference (N : Node_Id) return Boolean;
+ -- Determine whether N denotes a reference to a variable which captures the
+ -- value of an object for validation purposes.
+
function Is_Variable_Size_Array (E : Entity_Id) return Boolean;
-- Returns true if E has variable size components
===================================================================
@@ -1901,6 +1901,21 @@
then
Add_Call_By_Copy_Code;
+ -- The actual denotes a variable which captures the value of an
+ -- object for validation purposes. Add a copy-back to reflect any
+ -- potential changes in value back into the original object.
+
+ -- Temp : ... := Object;
+ -- if not Temp'Valid then ...
+ -- Call (Temp);
+ -- Object := Temp;
+
+ elsif Is_Validation_Variable_Reference (Actual) then
+ Append_To (Post_Call,
+ Make_Assignment_Statement (Loc,
+ Name => Validated_Object (Entity (Actual)),
+ Expression => New_Occurrence_Of (Entity (Actual), Loc)));
+
elsif Nkind (Actual) = N_Indexed_Component
and then Is_Entity_Name (Prefix (Actual))
and then Has_Volatile_Components (Entity (Prefix (Actual)))
This patch partially reimplements validity checks to prevent multiple reads or copies of volatile expressions. This is achieved by first capturing the value of a volatile object into a variable (rather than a constant). The variable is then tested for validity (rather than the object again) and used in place of the original object reference (rather than the object again). In addition, if the object reference is utilized as an actual in a call where the corresponding formal is of mode IN OUT or OUT, any changes to the value upon return from the call are now properly reflected back into the object. ------------ -- Source -- ------------ -- main.adb with Ada.Text_IO; use Ada.Text_IO; procedure Main is type Small_Int is new Integer range 1 .. 31; pragma Volatile (Small_Int); procedure Double_Swap (A : in out Small_Int; B : in out Small_Int); procedure Read (A : Small_Int; B : Small_Int); function Self (A : Small_Int) return Small_Int; procedure Swap (A : in out Small_Int; B : in out Small_Int); procedure Tripple_Swap (A : in out Small_Int; B : in out Small_Int); procedure Write (A : out Small_Int; B : out Small_Int); procedure Double_Swap (A : in out Small_Int; B : in out Small_Int) is begin Swap (A, B); Swap (B, A); end Double_Swap; procedure Read (A : Small_Int; B : Small_Int) is begin Put_Line ("A:" & A'Img); Put_Line ("B:" & B'Img); end Read; function Self (A : Small_Int) return Small_Int is begin return A; end Self; procedure Swap (A : in out Small_Int; B : in out Small_Int) is T : Small_Int; begin T := A; A := B; B := T; end Swap; procedure Tripple_Swap (A : in out Small_Int; B : in out Small_Int) is begin Swap (A, B); Swap (B, A); Swap (A, B); end Tripple_Swap; procedure Write (A : out Small_Int; B : out Small_Int) is begin A := 3; B := 4; end Write; X : Small_Int := 1; Y : Small_Int := 2; begin Double_Swap (X, Y); if X /= 1 or else Y /= 2 then Put_Line ("ERROR: Double_Swap failed"); end if; Read (X, Y); Read (Self (X), Self (Y)); Swap (X, Y); if X /= 2 or else Y /= 1 then Put_Line ("ERROR: Swap failed"); end if; Tripple_Swap (X, Y); if X /= 1 or else Y /= 2 then Put_Line ("ERROR: Tripple_Swap failed"); end if; Write (X, Y); if X /= 3 or else Y /= 4 then Put_Line ("ERROR: Write failed"); end if; end Main; ---------------------------- -- Compilation and output -- ---------------------------- $ gnatmake -q -gnatVa main.adb $ ./main A: 1 B: 2 A: 1 B: 2 Tested on x86_64-pc-linux-gnu, committed on trunk 2017-04-25 Steve Baird <baird@adacore.com> * exp_ch7.adb (Build_Array_Deep_Procs, Build_Record_Deep_Procs, Make_Finalize_Address_Body): Don't generate Finalize_Address routines for CodePeer.