[gcc r12-4028] [Ada] Improved checking for invalid index values when accessing array elements

[gcc r12-4028] [Ada] Improved checking for invalid index values when accessing array elements

[Pierre-Marie de Rodat]

https://gcc.gnu.org/g:e02c8dffe35f2763ec42a4ca5b2cf1af11f8e5d6

commit r12-4028-ge02c8dffe35f2763ec42a4ca5b2cf1af11f8e5d6
Author: Steve Baird <baird@adacore.com>
Date:   Thu Aug 12 16:55:36 2021 -0700

    [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.

Diff:
---
 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 8f5c0b0b56a..3b61208270d 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 3b97bd0802c..6df752ffc14 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 a4ed3a2d1ca..b899c2c7abb 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.