From e02c8dffe35f2763ec42a4ca5b2cf1af11f8e5d6 Mon Sep 17 00:00:00 2001 From: Steve Baird Date: Thu, 12 Aug 2021 16:55:36 -0700 Subject: [PATCH] [Ada] Improved checking for invalid index values when accessing array elements 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. --- gcc/ada/checks.adb | 23 ++++++-- gcc/ada/checks.ads | 25 +++++++-- gcc/ada/exp_ch4.adb | 152 ++++++++++++++++++++++++++++++++++++++++++++++++++-- 3 files changed, 189 insertions(+), 11 deletions(-) diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 8f5c0b0..3b61208 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -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); diff --git a/gcc/ada/checks.ads b/gcc/ada/checks.ads index 3b97bd0..6df752f 100644 --- a/gcc/ada/checks.ads +++ b/gcc/ada/checks.ads @@ -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 diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index a4ed3a2..b899c2c 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -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. -- 2.7.4