[Ada] Usage of signed type in array bounds in CCG
authorJavier Miranda <miranda@adacore.com>
Mon, 22 Jul 2019 13:57:46 +0000 (13:57 +0000)
committerPierre-Marie de Rodat <pmderodat@gcc.gnu.org>
Mon, 22 Jul 2019 13:57:46 +0000 (13:57 +0000)
2019-07-22  Javier Miranda  <miranda@adacore.com>

gcc/ada/

* exp_ch4.adb (Size_In_Storage_Elements): Improve the expansion
to handle array indexes that are modular type.
(Expand_N_Allocator): For 32-bit targets improve the generation
of the runtime check associated with large arrays supporting
arrays initialized with a qualified expression.
* libgnat/s-imenne.adb (Image_Enumeration_8,
Image_Enumeration_16, Image_Enumeration_32): Define the index of
Index_Table with range Natural'First .. Names'Length since in
the worst case all the literals of the enumeration type would be
single letter literals and the Table built by the frontend would
have as many components as the length of the names string. As a
result of this enhancement, the internal tables declared using
Index_Table have a length closer to the real needs, thus
avoiding the declaration of large arrays on 32-bit CCG targets.

From-SVN: r273685

gcc/ada/ChangeLog
gcc/ada/exp_ch4.adb
gcc/ada/libgnat/s-imenne.adb

index f47d247281f2ac82d7ef9ab87a84b096949ed3f0..ac990bee17cca6d93e0b0449a256d8f70bbb94c6 100644 (file)
@@ -1,3 +1,20 @@
+2019-07-22  Javier Miranda  <miranda@adacore.com>
+
+       * exp_ch4.adb (Size_In_Storage_Elements): Improve the expansion
+       to handle array indexes that are modular type.
+       (Expand_N_Allocator): For 32-bit targets improve the generation
+       of the runtime check associated with large arrays supporting
+       arrays initialized with a qualified expression.
+       * libgnat/s-imenne.adb (Image_Enumeration_8,
+       Image_Enumeration_16, Image_Enumeration_32): Define the index of
+       Index_Table with range Natural'First .. Names'Length since in
+       the worst case all the literals of the enumeration type would be
+       single letter literals and the Table built by the frontend would
+       have as many components as the length of the names string. As a
+       result of this enhancement, the internal tables declared using
+       Index_Table have a length closer to the real needs, thus
+       avoiding the declaration of large arrays on 32-bit CCG targets.
+
 2019-07-22  Yannick Moy  <moy@adacore.com>
 
        * sem_ch3.adb (Constrain_Access): Issue a message about ignored
index 7ea96de1aaab0c7b51a7acec5ea006b41d29569c..117d6d67528a9127aa0b67855be306e2983fce3b 100644 (file)
@@ -4249,9 +4249,12 @@ package body Exp_Ch4 is
 
       function Size_In_Storage_Elements (E : Entity_Id) return Node_Id;
       --  Given a constrained array type E, returns a node representing the
-      --  code to compute the size in storage elements for the given type.
-      --  This is done without using the attribute (which malfunctions for
-      --  large sizes ???)
+      --  code to compute a close approximation of the size in storage elements
+      --  for the given type; for indexes that are modular types we compute
+      --  'Last - First (instead of 'Length) because for large arrays computing
+      --  'Last -'First + 1 causes overflow. This is done without using the
+      --  attribute 'Size_In_Storage_Elements (which malfunctions for large
+      --  sizes ???)
 
       -------------------------
       -- Rewrite_Coextension --
@@ -4310,17 +4313,77 @@ package body Exp_Ch4 is
          --  just a fraction of a storage element???
 
          declare
+            Idx : Node_Id := First_Index (E);
             Len : Node_Id;
             Res : Node_Id;
             pragma Warnings (Off, Res);
 
          begin
             for J in 1 .. Number_Dimensions (E) loop
-               Len :=
-                 Make_Attribute_Reference (Loc,
-                   Prefix         => New_Occurrence_Of (E, Loc),
-                   Attribute_Name => Name_Length,
-                   Expressions    => New_List (Make_Integer_Literal (Loc, J)));
+
+               if not Is_Modular_Integer_Type (Etype (Idx)) then
+                  Len :=
+                    Make_Attribute_Reference (Loc,
+                      Prefix         => New_Occurrence_Of (E, Loc),
+                      Attribute_Name => Name_Length,
+                      Expressions    => New_List
+                                          (Make_Integer_Literal (Loc, J)));
+
+               --  For indexes that are modular types we cannot generate code
+               --  to compute 'Length since for large arrays 'Last -'First + 1
+               --  causes overflow; therefore we compute 'Last - 'First (which
+               --  is not the exact number of components but it is valid for
+               --  the purpose of this runtime check on 32-bit targets)
+
+               else
+                  declare
+                     Len_Minus_1_Expr : Node_Id;
+                     Test_Gt          : Node_Id;
+
+                  begin
+                     Test_Gt :=
+                       Make_Op_Gt (Loc,
+                         Make_Attribute_Reference (Loc,
+                           Prefix         => New_Occurrence_Of (E, Loc),
+                           Attribute_Name => Name_Last,
+                           Expressions    =>
+                             New_List (Make_Integer_Literal (Loc, J))),
+                         Make_Attribute_Reference (Loc,
+                           Prefix         => New_Occurrence_Of (E, Loc),
+                           Attribute_Name => Name_First,
+                           Expressions    =>
+                             New_List (Make_Integer_Literal (Loc, J))));
+
+                     Len_Minus_1_Expr :=
+                       Convert_To (Standard_Unsigned,
+                         Make_Op_Subtract (Loc,
+                           Make_Attribute_Reference (Loc,
+                             Prefix => New_Occurrence_Of (E, Loc),
+                             Attribute_Name => Name_Last,
+                             Expressions =>
+                               New_List
+                                 (Make_Integer_Literal (Loc, J))),
+                           Make_Attribute_Reference (Loc,
+                             Prefix => New_Occurrence_Of (E, Loc),
+                             Attribute_Name => Name_First,
+                             Expressions =>
+                               New_List
+                                 (Make_Integer_Literal (Loc, J)))));
+
+                     --  Handle superflat arrays, i.e. arrays with such bounds
+                     --  as 4 .. 2, to insure that the result is correct.
+
+                     --  Generate:
+                     --    (if X'Last > X'First then X'Last - X'First else 0)
+
+                     Len :=
+                       Make_If_Expression (Loc,
+                         Expressions => New_List (
+                           Test_Gt,
+                           Len_Minus_1_Expr,
+                           Make_Integer_Literal (Loc, Uint_0)));
+                  end;
+               end if;
 
                if J = 1 then
                   Res := Len;
@@ -4331,6 +4394,8 @@ package body Exp_Ch4 is
                       Left_Opnd  => Res,
                       Right_Opnd => Len);
                end if;
+
+               Next_Index (Idx);
             end loop;
 
             return
@@ -4573,15 +4638,83 @@ package body Exp_Ch4 is
          --  apply the check for constrained arrays, and manually compute the
          --  value of the attribute ???
 
-         if Is_Array_Type (Etyp) and then Is_Constrained (Etyp) then
-            Insert_Action (N,
-              Make_Raise_Storage_Error (Loc,
-                Condition =>
-                  Make_Op_Gt (Loc,
-                    Left_Opnd  => Size_In_Storage_Elements (Etyp),
-                    Right_Opnd =>
-                      Make_Integer_Literal (Loc, Uint_7 * (Uint_2 ** 29))),
-                Reason    => SE_Object_Too_Large));
+         --  The check on No_Initialization is used here to prevent generating
+         --  this runtime check twice when the allocator is locally replaced by
+         --  the expander by another one.
+
+         if Is_Array_Type (Etyp) and then not No_Initialization (N) then
+            declare
+               Cond    : Node_Id;
+               Ins_Nod : Node_Id   := N;
+               Siz_Typ : Entity_Id := Etyp;
+               Expr    : Node_Id;
+
+            begin
+               --  For unconstrained array types initialized with a qualified
+               --  expression we use its type to perform this check
+
+               if not Is_Constrained (Etyp)
+                 and then not No_Initialization (N)
+                 and then Nkind (Expression (N)) = N_Qualified_Expression
+               then
+                  Expr    := Expression (Expression (N));
+                  Siz_Typ := Etype (Expression (Expression (N)));
+
+                  --  If the qualified expression has been moved to an internal
+                  --  temporary (to remove side effects) then we must insert
+                  --  the runtime check before its declaration to ensure that
+                  --  the check is performed before the execution of the code
+                  --  computing the qualified expression.
+
+                  if Nkind (Expr) = N_Identifier
+                    and then Is_Internal_Name (Chars (Expr))
+                    and then
+                      Nkind (Parent (Entity (Expr))) = N_Object_Declaration
+                  then
+                     Ins_Nod := Parent (Entity (Expr));
+                  else
+                     Ins_Nod := Expr;
+                  end if;
+               end if;
+
+               if Is_Constrained (Siz_Typ)
+                 and then Ekind (Siz_Typ) /= E_String_Literal_Subtype
+               then
+                  --  For CCG targets the largest array may have up to 2**31-1
+                  --  components (i.e. 2 Gigabytes if each array component is
+                  --  1-byte). This insures that fat pointer fields do not
+                  --  overflow, since they are 32-bit integer types, and also
+                  --  insures that 'Length can be computed at run time.
+
+                  if Modify_Tree_For_C then
+                     Cond :=
+                       Make_Op_Gt (Loc,
+                         Left_Opnd  => Size_In_Storage_Elements (Siz_Typ),
+                         Right_Opnd => Make_Integer_Literal (Loc,
+                                         Uint_2 ** 31 - Uint_1));
+
+                  --  For native targets the largest object is 3.5 gigabytes
+
+                  else
+                     Cond :=
+                       Make_Op_Gt (Loc,
+                         Left_Opnd  => Size_In_Storage_Elements (Siz_Typ),
+                         Right_Opnd => Make_Integer_Literal (Loc,
+                                         Uint_7 * (Uint_2 ** 29)));
+                  end if;
+
+                  Insert_Action (Ins_Nod,
+                    Make_Raise_Storage_Error (Loc,
+                      Condition => Cond,
+                      Reason    => SE_Object_Too_Large));
+
+                  if Entity (Cond) = Standard_True then
+                     Error_Msg_N
+                       ("object too large: Storage_Error will be raised at "
+                        & "run time??", N);
+                  end if;
+               end if;
+            end;
          end if;
       end if;
 
index 2ea9fc7106ff4b492e7c676746488cade079bc71..30df1a4d9b6549bb95c59cc96dcdfbbfbb2c0504 100644 (file)
@@ -49,7 +49,8 @@ package body System.Img_Enum_New is
       pragma Assert (S'First = 1);
 
       type Natural_8 is range 0 .. 2 ** 7 - 1;
-      type Index_Table is array (Natural) of Natural_8;
+      subtype Index is Natural range Natural'First .. Names'Length;
+      type Index_Table is array (Index) of Natural_8;
       type Index_Table_Ptr is access Index_Table;
 
       function To_Index_Table_Ptr is
@@ -79,7 +80,8 @@ package body System.Img_Enum_New is
       pragma Assert (S'First = 1);
 
       type Natural_16 is range 0 .. 2 ** 15 - 1;
-      type Index_Table is array (Natural) of Natural_16;
+      subtype Index is Natural range Natural'First .. Names'Length;
+      type Index_Table is array (Index) of Natural_16;
       type Index_Table_Ptr is access Index_Table;
 
       function To_Index_Table_Ptr is
@@ -109,7 +111,8 @@ package body System.Img_Enum_New is
       pragma Assert (S'First = 1);
 
       type Natural_32 is range 0 .. 2 ** 31 - 1;
-      type Index_Table is array (Natural) of Natural_32;
+      subtype Index is Natural range Natural'First .. Names'Length;
+      type Index_Table is array (Index) of Natural_32;
       type Index_Table_Ptr is access Index_Table;
 
       function To_Index_Table_Ptr is