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

[Ada] Improved checking for invalid index values when accessing array elements

Browse Source 
gcc/ada/

	* checks.ads: Define a type Dimension_Set. Add an out-mode
	parameter of this new type to Generate_Index_Checks so that
	callers can know for which dimensions a check was generated. Add
	an in-mode parameter of this new type to
	Apply_Subscript_Validity_Checks so that callers can indicate
	that no check is needed for certain dimensions.
	* checks.adb (Generate_Index_Checks): Implement new
	Checks_Generated parameter.
	(Apply_Subscript_Validity_Checks): Implement new No_Check_Needed
	parameter.
	* exp_ch4.adb (Expand_N_Indexed_Component): Call
	Apply_Subscript_Validity_Checks in more cases than before. This
	includes declaring two new local functions,
	(Is_Renamed_Variable_Name,
	Type_Requires_Subscript_Validity_Checks_For_Reads): To help in
	deciding whether to call Apply_Subscript_Validity_Checks.
	Adjust to parameter profile changes in Generate_Index_Checks and
	Apply_Subscript_Validity_Checks.
This commit is contained in:
Steve Baird 2021-08-12 16:55:36 -07:00 committed by Pierre-Marie de Rodat
parent f5d4b3fbf6
commit e02c8dffe3
3 changed files with 189 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
gcc/ada/checks.adb
View File

@ -3552,9 +3552,12 @@ package body Checks is
-- Apply_Subscript_Validity_Checks --
-------------------------------------
procedure Apply_Subscript_Validity_Checks (Expr : Node_Id) is
procedure Apply_Subscript_Validity_Checks
(Expr : Node_Id;
No_Check_Needed : Dimension_Set := Empty_Dimension_Set) is
Sub : Node_Id;
Dimension : Pos := 1;
begin
pragma Assert (Nkind (Expr) = N_Indexed_Component);
@ -3568,11 +3571,16 @@ package body Checks is
-- for the subscript, and that convert will do the necessary validity
-- check.
Ensure_Valid (Sub, Holes_OK => True);
if (No_Check_Needed = Empty_Dimension_Set)
or else not No_Check_Needed.Elements (Dimension)
then
Ensure_Valid (Sub, Holes_OK => True);
end if;
-- Move to next subscript
Next (Sub);
Dimension := Dimension + 1;
end loop;
end Apply_Subscript_Validity_Checks;
@ -7233,7 +7241,10 @@ package body Checks is
-- Generate_Index_Checks --
---------------------------
procedure Generate_Index_Checks (N : Node_Id) is
procedure Generate_Index_Checks
(N : Node_Id;
Checks_Generated : out Dimension_Set)
is
function Entity_Of_Prefix return Entity_Id;
-- Returns the entity of the prefix of N (or Empty if not found)
@ -7268,6 +7279,8 @@ package body Checks is
-- Start of processing for Generate_Index_Checks
begin
Checks_Generated.Elements := (others => False);
-- Ignore call if the prefix is not an array since we have a serious
-- error in the sources. Ignore it also if index checks are suppressed
-- for array object or type.
@ -7330,6 +7343,8 @@ package body Checks is
Prefix => New_Occurrence_Of (Etype (A), Loc),
Attribute_Name => Name_Range)),
Reason => CE_Index_Check_Failed));
Checks_Generated.Elements (1) := True;
end if;
-- General case
@ -7416,6 +7431,8 @@ package body Checks is
Duplicate_Subexpr_Move_Checks (Sub)),
Right_Opnd => Range_N),
Reason => CE_Index_Check_Failed));
Checks_Generated.Elements (Ind) := True;
end if;
Next_Index (A_Idx);

25
gcc/ada/checks.ads
View File

@ -44,6 +44,14 @@ with Urealp; use Urealp;
package Checks is
type Bit_Vector is array (Pos range <>) of Boolean;
type Dimension_Set (Dimensions : Nat) is
record
Elements : Bit_Vector (1 .. Dimensions);
end record;
Empty_Dimension_Set : constant Dimension_Set
:= (Dimensions => 0, Elements => (others => <>));
procedure Initialize;
-- Called for each new main source program, to initialize internal
-- variables used in the package body of the Checks unit.
@ -721,11 +729,16 @@ package Checks is
-- Do_Range_Check flag, and if it is set, this routine is called, which
-- turns the flag off in code-generation mode.
procedure Generate_Index_Checks (N : Node_Id);
procedure Generate_Index_Checks
(N : Node_Id;
Checks_Generated : out Dimension_Set);
-- This procedure is called to generate index checks on the subscripts for
-- the indexed component node N. Each subscript expression is examined, and
-- if the Do_Range_Check flag is set, an appropriate index check is
-- generated and the flag is reset.
-- The out-mode parameter Checks_Generated indicates the dimensions for
-- which checks were generated. Checks_Generated.Dimensions must match
-- the number of dimensions of the array type.
-- Similarly, we set the flag Do_Discriminant_Check in the semantic
-- analysis to indicate that a discriminant check is required for selected
@ -858,10 +871,14 @@ package Checks is
-- The following procedures are used in handling validity checking
procedure Apply_Subscript_Validity_Checks (Expr : Node_Id);
procedure Apply_Subscript_Validity_Checks
(Expr : Node_Id;
No_Check_Needed : Dimension_Set := Empty_Dimension_Set);
-- Expr is the node for an indexed component. If validity checking and
-- range checking are enabled, all subscripts for this indexed component
-- are checked for validity.
-- range checking are enabled, each subscript for this indexed component
-- whose dimension does not belong to the No_Check_Needed set is checked
-- for validity. No_Check_Needed.Dimensions must match the number of
-- dimensions of the array type or be zero.
procedure Check_Valid_Lvalue_Subscripts (Expr : Node_Id);
-- Expr is a lvalue, i.e. an expression representing the target of an

152
gcc/ada/exp_ch4.adb
View File

@ -23,6 +23,7 @@
-- --
------------------------------------------------------------------------------
with Aspects; use Aspects;
with Atree; use Atree;
with Checks; use Checks;
with Debug; use Debug;
@ -7087,11 +7088,123 @@ package body Exp_Ch4 is
--------------------------------
procedure Expand_N_Indexed_Component (N : Node_Id) is
Wild_Reads_May_Have_Bad_Side_Effects : Boolean
renames Validity_Check_Subscripts;
-- This Boolean needs to be True if reading from a bad address can
-- have a bad side effect (e.g., a segmentation fault that is not
-- transformed into a Storage_Error exception, or interactions with
-- memory-mapped I/O) that needs to be prevented. This refers to the
-- act of reading itself, not to any damage that might be caused later
-- by making use of whatever value was read. We assume here that
-- Validity_Check_Subscripts meets this requirement, but introduce
-- this declaration in order to document this assumption.
function Is_Renamed_Variable_Name (N : Node_Id) return Boolean;
-- Returns True if the given name occurs as part of the renaming
-- of a variable. In this case, the indexing operation should be
-- treated as a write, rather than a read, with respect to validity
-- checking. This is because the renamed variable can later be
-- written to.
function Type_Requires_Subscript_Validity_Checks_For_Reads
(Typ : Entity_Id) return Boolean;
-- If Wild_Reads_May_Have_Bad_Side_Effects is False and we are indexing
-- into an array of characters in order to read an element, it is ok
-- if an invalid index value goes undetected. But if it is an array of
-- pointers or an array of tasks, the consequences of such a read are
-- potentially more severe and so we want to detect an invalid index
-- value. This function captures that distinction; this is intended to
-- be consistent with the "but does not by itself lead to erroneous
-- ... execution" rule of RM 13.9.1(11).
------------------------------
-- Is_Renamed_Variable_Name --
------------------------------
function Is_Renamed_Variable_Name (N : Node_Id) return Boolean is
Rover : Node_Id := N;
begin
if Is_Variable (N) then
loop
declare
Rover_Parent : constant Node_Id := Parent (Rover);
begin
case Nkind (Rover_Parent) is
when N_Object_Renaming_Declaration =>
return Rover = Name (Rover_Parent);
when N_Indexed_Component
| N_Slice
| N_Selected_Component
=>
exit when Rover /= Prefix (Rover_Parent);
Rover := Rover_Parent;
-- No need to check for qualified expressions or type
-- conversions here, mostly because of the Is_Variable
-- test. It is possible to have a view conversion for
-- which Is_Variable yields True and which occurs as
-- part of an object renaming, but only if the type is
-- tagged; in that case this function will not be called.
when others =>
exit;
end case;
end;
end loop;
end if;
return False;
end Is_Renamed_Variable_Name;
-------------------------------------------------------
-- Type_Requires_Subscript_Validity_Checks_For_Reads --
-------------------------------------------------------
function Type_Requires_Subscript_Validity_Checks_For_Reads
(Typ : Entity_Id) return Boolean
is
-- a shorter name for recursive calls
function Needs_Check (Typ : Entity_Id) return Boolean renames
Type_Requires_Subscript_Validity_Checks_For_Reads;
begin
if Is_Access_Type (Typ)
or else Is_Tagged_Type (Typ)
or else Is_Concurrent_Type (Typ)
or else (Is_Array_Type (Typ)
and then Needs_Check (Component_Type (Typ)))
or else (Is_Scalar_Type (Typ)
and then Has_Aspect (Typ, Aspect_Default_Value))
then
return True;
end if;
if Is_Record_Type (Typ) then
declare
Comp : Entity_Id := First_Component_Or_Discriminant (Typ);
begin
while Present (Comp) loop
if Needs_Check (Etype (Comp)) then
return True;
end if;
Next_Component_Or_Discriminant (Comp);
end loop;
end;
end if;
return False;
end Type_Requires_Subscript_Validity_Checks_For_Reads;
-- Local constants
Loc : constant Source_Ptr := Sloc (N);
Typ : constant Entity_Id := Etype (N);
P : constant Node_Id := Prefix (N);
T : constant Entity_Id := Etype (P);
-- Start of processing for Expand_N_Indexed_Component
begin
-- A special optimization, if we have an indexed component that is
-- selecting from a slice, then we can eliminate the slice, since, for
@ -7141,11 +7254,42 @@ package body Exp_Ch4 is
-- Generate index and validity checks
Generate_Index_Checks (N);
declare
Dims_Checked : Dimension_Set (Dimensions => Number_Dimensions (T));
-- Dims_Checked is used to avoid generating two checks (one in
-- Generate_Index_Checks, one in Apply_Subscript_Validity_Checks)
-- for the same index value in cases where the index check eliminates
-- the need for the validity check.
if Validity_Checks_On and then Validity_Check_Subscripts then
Apply_Subscript_Validity_Checks (N);
end if;
begin
Generate_Index_Checks (N, Checks_Generated => Dims_Checked);
if Validity_Checks_On
and then (Validity_Check_Subscripts
or else Wild_Reads_May_Have_Bad_Side_Effects
or else Type_Requires_Subscript_Validity_Checks_For_Reads
(Typ)
or else Is_Renamed_Variable_Name (N))
then
if Validity_Check_Subscripts then
-- If we index into an array with an uninitialized variable
-- and we generate an index check that passes at run time,
-- passing that check does not ensure that the variable is
-- valid (although it does in the common case where the
-- object's subtype matches the index subtype).
-- Consider an uninitialized variable with subtype 1 .. 10
-- used to index into an array with bounds 1 .. 20 when the
-- value of the uninitialized variable happens to be 15.
-- The index check will succeed but the variable is invalid.
-- If Validity_Check_Subscripts is True then we need to
-- ensure validity, so we adjust Dims_Checked accordingly.
Dims_Checked.Elements := (others => False);
end if;
Apply_Subscript_Validity_Checks
(N, No_Check_Needed => Dims_Checked);
end if;
end;
-- If selecting from an array with atomic components, and atomic sync
-- is not suppressed for this array type, set atomic sync flag.