[Ada] Narrow large arithmetic and comparison operations

Message ID 20200618091320.GA2175@adacore.com
State New
Headers show
Series
  • [Ada] Narrow large arithmetic and comparison operations
Related show

Commit Message

Pierre-Marie de Rodat June 18, 2020, 9:13 a.m.
The goal of this enhancement is to make it possible for the expander
to rewrite both arithmetic and comparison operations that have been
resolved to a large type, namely Universal_Integer, into equivalent
operations in a smaller type, namely Integer (or Long_Long_Integer).

In certain contexts involving attributes whose result type is fixed
to Universal_Integer by the RM, the resolver cannot do anything else
than resolving these operations to Universal_Integer.  Later, after
the expander has rewritten the attributes, e.g. info function calls,
the magnitude of the actual type of the attribute is reduced, but
this is too late for the resolution phase and the large operations
are handed down to the code generator.

The change implements a new procedure Narrow_Large_Operation in the
expander, which uses the value ranges machinery to determine whether
the operation can be done in a narrower type; if so, it rewrites the
operation into the narrower type, without overflow checks in almost
all cases, and adds the required type conversions for consistency.

The change also contains a fixlet for Is_Pure_Barrier, which was a
little confused about whether a type conversion can raise CE.

Tested on x86_64-pc-linux-gnu, committed on trunk

2020-06-18  Eric Botcazou  <ebotcazou@adacore.com>

gcc/ada/

	* exp_ch4.adb (Narrow_Large_Operation): New procedure to try
	and narrow large arithmetic and comparison operations.
	(Expand_N_In): Call it.
	(Expand_N_Op_Abs): Likewise.
	(Expand_N_Op_Add): Likewise.
	(Expand_N_Op_Divide): Likewise.
	(Expand_N_Op_Eq): Likewise.
	(Expand_N_Op_Ge): Likewise.
	(Expand_N_Op_Gt): Likewise.
	(Expand_N_Op_Le): Likewise.
	(Expand_N_Op_Lt): Likewise.
	(Expand_N_Op_Minus): Likewise.
	(Expand_N_Op_Mod): Likewise.
	(Expand_N_Op_Multiply): Likewise.
	(Expand_N_Op_Ne): Likewise.
	(Expand_N_Op_Plus): Likewise.
	(Expand_N_Op_Rem): Likewise.
	(Expand_N_Op_Subtract): Likewise.
	(Expand_N_Type_Conversion): Use Convert_To procedure.
	* exp_ch9.adb (Is_Pure_Barrier) <N_Identifier>: Skip all
	numeric types.
	<N_Type_Conversion>: Use explicit criterion.

Patch

--- gcc/ada/exp_ch4.adb
+++ gcc/ada/exp_ch4.adb
@@ -224,6 +224,11 @@  package body Exp_Ch4 is
    --  skipped if the operation is done in Bignum mode but that's fine, since
    --  the Bignum call takes care of everything.
 
+   procedure Narrow_Large_Operation (N : Node_Id);
+   --  Try to compute the result of a large operation in a narrower type than
+   --  its nominal type. This is mainly aimed to get rid of operations done in
+   --  Universal_Integer that can be generated for attributes.
+
    procedure Optimize_Length_Comparison (N : Node_Id);
    --  Given an expression, if it is of the form X'Length op N (or the other
    --  way round), where N is known at compile time to be 0 or 1, or something
@@ -6545,6 +6550,12 @@  package body Exp_Ch4 is
             end if;
          end;
 
+         --  Try to narrow the operation
+
+         if Ltyp = Universal_Integer and then Nkind (N) = N_In then
+            Narrow_Large_Operation (N);
+         end if;
+
          --  For all other cases of an explicit range, nothing to be done
 
          goto Leave;
@@ -7224,6 +7235,7 @@  package body Exp_Ch4 is
    procedure Expand_N_Op_Abs (N : Node_Id) is
       Loc  : constant Source_Ptr := Sloc (N);
       Expr : constant Node_Id    := Right_Opnd (N);
+      Typ  : constant Entity_Id  := Etype (N);
 
    begin
       Unary_Op_Validity_Checks (N);
@@ -7235,9 +7247,19 @@  package body Exp_Ch4 is
          return;
       end if;
 
+      --  Try to narrow the operation
+
+      if Typ = Universal_Integer then
+         Narrow_Large_Operation (N);
+
+         if Nkind (N) /= N_Op_Abs then
+            return;
+         end if;
+      end if;
+
       --  Deal with software overflow checking
 
-      if Is_Signed_Integer_Type (Etype (N))
+      if Is_Signed_Integer_Type (Typ)
         and then Do_Overflow_Check (N)
       then
          --  The only case to worry about is when the argument is equal to the
@@ -7297,6 +7319,16 @@  package body Exp_Ch4 is
          end if;
       end if;
 
+      --  Try to narrow the operation
+
+      if Typ = Universal_Integer then
+         Narrow_Large_Operation (N);
+
+         if Nkind (N) /= N_Op_Add then
+            return;
+         end if;
+      end if;
+
       --  Arithmetic overflow checks for signed integer/fixed point types
 
       if Is_Signed_Integer_Type (Typ) or else Is_Fixed_Point_Type (Typ) then
@@ -7474,6 +7506,16 @@  package body Exp_Ch4 is
          return;
       end if;
 
+      --  Try to narrow the operation
+
+      if Typ = Universal_Integer then
+         Narrow_Large_Operation (N);
+
+         if Nkind (N) /= N_Op_Divide then
+            return;
+         end if;
+      end if;
+
       --  Convert x / 2 ** y to Shift_Right (x, y). Note that the fact that
       --  Is_Power_Of_2_For_Shift is set means that we know that our left
       --  operand is an unsigned integer, as required for this to work.
@@ -8437,6 +8479,12 @@  package body Exp_Ch4 is
 
       Rewrite_Comparison (N);
 
+      --  Try to narrow the operation
+
+      if Typl = Universal_Integer and then Nkind (N) = N_Op_Eq then
+         Narrow_Large_Operation (N);
+      end if;
+
       --  Special optimization of length comparison
 
       Optimize_Length_Comparison (N);
@@ -9053,6 +9101,12 @@  package body Exp_Ch4 is
 
       Rewrite_Comparison (N);
 
+      --  Try to narrow the operation
+
+      if Typ1 = Universal_Integer and then Nkind (N) = N_Op_Ge then
+         Narrow_Large_Operation (N);
+      end if;
+
       Optimize_Length_Comparison (N);
    end Expand_N_Op_Ge;
 
@@ -9096,6 +9150,12 @@  package body Exp_Ch4 is
 
       Rewrite_Comparison (N);
 
+      --  Try to narrow the operation
+
+      if Typ1 = Universal_Integer and then Nkind (N) = N_Op_Gt then
+         Narrow_Large_Operation (N);
+      end if;
+
       Optimize_Length_Comparison (N);
    end Expand_N_Op_Gt;
 
@@ -9139,6 +9199,12 @@  package body Exp_Ch4 is
 
       Rewrite_Comparison (N);
 
+      --  Try to narrow the operation
+
+      if Typ1 = Universal_Integer and then Nkind (N) = N_Op_Le then
+         Narrow_Large_Operation (N);
+      end if;
+
       Optimize_Length_Comparison (N);
    end Expand_N_Op_Le;
 
@@ -9182,6 +9248,12 @@  package body Exp_Ch4 is
 
       Rewrite_Comparison (N);
 
+      --  Try to narrow the operation
+
+      if Typ1 = Universal_Integer and then Nkind (N) = N_Op_Lt then
+         Narrow_Large_Operation (N);
+      end if;
+
       Optimize_Length_Comparison (N);
    end Expand_N_Op_Lt;
 
@@ -9203,8 +9275,18 @@  package body Exp_Ch4 is
          return;
       end if;
 
+      --  Try to narrow the operation
+
+      if Typ = Universal_Integer then
+         Narrow_Large_Operation (N);
+
+         if Nkind (N) /= N_Op_Minus then
+            return;
+         end if;
+      end if;
+
       if not Backend_Overflow_Checks_On_Target
-         and then Is_Signed_Integer_Type (Etype (N))
+         and then Is_Signed_Integer_Type (Typ)
          and then Do_Overflow_Check (N)
       then
          --  Software overflow checking expands -expr into (0 - expr)
@@ -9252,7 +9334,17 @@  package body Exp_Ch4 is
          return;
       end if;
 
-      if Is_Integer_Type (Etype (N)) then
+      --  Try to narrow the operation
+
+      if Typ = Universal_Integer then
+         Narrow_Large_Operation (N);
+
+         if Nkind (N) /= N_Op_Mod then
+            return;
+         end if;
+      end if;
+
+      if Is_Integer_Type (Typ) then
          Apply_Divide_Checks (N);
 
          --  All done if we don't have a MOD any more, which can happen as a
@@ -9551,6 +9643,16 @@  package body Exp_Ch4 is
          end if;
       end if;
 
+      --  Try to narrow the operation
+
+      if Typ = Universal_Integer then
+         Narrow_Large_Operation (N);
+
+         if Nkind (N) /= N_Op_Multiply then
+            return;
+         end if;
+      end if;
+
       --  Convert x * 2 ** y to Shift_Left (x, y). Note that the fact that
       --  Is_Power_Of_2_For_Shift is set means that we know that our left
       --  operand is an integer, as required for this to work.
@@ -9734,6 +9836,12 @@  package body Exp_Ch4 is
 
          Rewrite_Comparison (N);
 
+         --  Try to narrow the operation
+
+         if Typ = Universal_Integer and then Nkind (N) = N_Op_Ne then
+            Narrow_Large_Operation (N);
+         end if;
+
       --  For all cases other than elementary types, we rewrite node as the
       --  negation of an equality operation, and reanalyze. The equality to be
       --  used is defined in the same scope and has the same signature. This
@@ -10016,6 +10124,8 @@  package body Exp_Ch4 is
    ----------------------
 
    procedure Expand_N_Op_Plus (N : Node_Id) is
+      Typ : constant Entity_Id := Etype (N);
+
    begin
       Unary_Op_Validity_Checks (N);
 
@@ -10025,6 +10135,12 @@  package body Exp_Ch4 is
          Apply_Arithmetic_Overflow_Check (N);
          return;
       end if;
+
+      --  Try to narrow the operation
+
+      if Typ = Universal_Integer then
+         Narrow_Large_Operation (N);
+      end if;
    end Expand_N_Op_Plus;
 
    ---------------------
@@ -10058,6 +10174,16 @@  package body Exp_Ch4 is
          return;
       end if;
 
+      --  Try to narrow the operation
+
+      if Typ = Universal_Integer then
+         Narrow_Large_Operation (N);
+
+         if Nkind (N) /= N_Op_Rem then
+            return;
+         end if;
+      end if;
+
       if Is_Integer_Type (Etype (N)) then
          Apply_Divide_Checks (N);
 
@@ -10422,6 +10548,16 @@  package body Exp_Ch4 is
          return;
       end if;
 
+      --  Try to narrow the operation
+
+      if Typ = Universal_Integer then
+         Narrow_Large_Operation (N);
+
+         if Nkind (N) /= N_Op_Subtract then
+            return;
+         end if;
+      end if;
+
       --  N - 0 = N for integer types
 
       if Is_Integer_Type (Typ)
@@ -11876,20 +12012,13 @@  package body Exp_Ch4 is
             L, R : Node_Id;
 
          begin
-            R :=
-              Make_Type_Conversion (Loc,
-                Subtype_Mark => New_Occurrence_Of (Standard_Integer, Loc),
-                Expression   => Relocate_Node (Right_Opnd (Operand)));
-
             Opnd := New_Op_Node (Nkind (Operand), Loc);
+
+            R := Convert_To (Standard_Integer, Right_Opnd (Operand));
             Set_Right_Opnd (Opnd, R);
 
             if Nkind (Operand) in N_Binary_Op then
-               L :=
-                 Make_Type_Conversion (Loc,
-                   Subtype_Mark => New_Occurrence_Of (Standard_Integer, Loc),
-                   Expression   => Relocate_Node (Left_Opnd (Operand)));
-
+               L := Convert_To (Standard_Integer, Left_Opnd (Operand));
                Set_Left_Opnd  (Opnd, L);
             end if;
 
@@ -13777,6 +13906,207 @@  package body Exp_Ch4 is
           and then Overflow_Check_Mode in Minimized_Or_Eliminated;
    end Minimized_Eliminated_Overflow_Check;
 
+   ----------------------------
+   -- Narrow_Large_Operation --
+   ----------------------------
+
+   procedure Narrow_Large_Operation (N : Node_Id) is
+      Kind   : constant Node_Kind := Nkind (N);
+      In_Rng : constant Boolean   := Kind = N_In;
+      Binary : constant Boolean   := Kind in N_Binary_Op or else In_Rng;
+      Compar : constant Boolean   := Kind in N_Op_Compare or else In_Rng;
+      R      : constant Node_Id   := Right_Opnd (N);
+      Typ    : constant Entity_Id := Etype (R);
+
+      function Get_Size_For_Range (Lo, Hi : Uint) return Nat;
+      --  Return the size of the smallest signed integer type covering Lo .. Hi
+
+      ------------------------
+      -- Get_Size_For_Range --
+      ------------------------
+
+      function Get_Size_For_Range (Lo, Hi : Uint) return Nat is
+         B : Uint;
+         S : Nat;
+
+      begin
+         S := 1;
+         B := Uint_1;
+
+         --  S = size, B = 2 ** (size - 1) (can accommodate -B .. +(B - 1))
+
+         while Lo < -B or else Hi < -B or else Lo >= B or else Hi >= B loop
+            B := Uint_2 ** S;
+            S := S + 1;
+         end loop;
+
+         return S;
+      end Get_Size_For_Range;
+
+      --  Local variables
+
+      L          : Node_Id;
+      Llo, Lhi   : Uint;
+      Rlo, Rhi   : Uint;
+      Lsiz, Rsiz : Nat;
+      Nlo, Nhi   : Uint;
+      Nsiz       : Nat;
+      Ntyp       : Entity_Id;
+      Nop        : Node_Id;
+      OK         : Boolean;
+
+   --  Start of processing for Narrow_Large_Operation
+
+   begin
+      --  First, determine the range of the left operand, if any
+
+      if Binary then
+         L := Left_Opnd (N);
+         Determine_Range (L, OK, Llo, Lhi, Assume_Valid => True);
+         if not OK then
+            return;
+         end if;
+
+      else
+         L   := Empty;
+         Llo := Uint_0;
+         Lhi := Uint_0;
+      end if;
+
+      --  Second, determine the range of the right operand, which can itself
+      --  be a range, in which case we take the lower bound of the low bound
+      --  and the upper bound of the high bound.
+
+      if In_Rng then
+         declare
+            Zlo, Zhi : Uint;
+
+         begin
+            Determine_Range
+              (Low_Bound (R), OK, Rlo, Zhi, Assume_Valid => True);
+            if not OK then
+               return;
+            end if;
+
+            Determine_Range
+              (High_Bound (R), OK, Zlo, Rhi, Assume_Valid => True);
+            if not OK then
+               return;
+            end if;
+         end;
+
+      else
+         Determine_Range (R, OK, Rlo, Rhi, Assume_Valid => True);
+         if not OK then
+            return;
+         end if;
+      end if;
+
+      --  Then compute a size suitable for each range
+
+      if Binary then
+         Lsiz := Get_Size_For_Range (Llo, Lhi);
+      else
+         Lsiz := 0;
+      end if;
+
+      Rsiz := Get_Size_For_Range (Rlo, Rhi);
+
+      --  Now compute the size of the narrower type
+
+      if Compar then
+         --  The type must be able to accomodate the operands
+
+         Nsiz := Nat'Max (Lsiz, Rsiz);
+
+      else
+         --  The type must be able to accomodate the operand(s) and the result.
+
+         --  Note that Determine_Range typically does not report the bounds of
+         --  the value as being larger than those of the base type, which means
+         --  that it does not report overflow (see also Enable_Overflow_Check).
+
+         Determine_Range (N, OK, Nlo, Nhi, Assume_Valid => True);
+         if not OK then
+            return;
+         end if;
+
+         --  Therefore, if Nsiz is not lower than the size of the original type
+         --  here, we cannot be sure that the operation does not overflow.
+
+         Nsiz := Get_Size_For_Range (Nlo, Nhi);
+         Nsiz := Nat'Max (Nsiz, Lsiz);
+         Nsiz := Nat'Max (Nsiz, Rsiz);
+      end if;
+
+      --  If the size is not lower than the size of the original type, then
+      --  there is no point in changing the type, except in the case where
+      --  we can remove a conversion to the original type from an operand.
+
+      if Nsiz >= RM_Size (Typ)
+        and then not (Binary
+                       and then Nkind (L) = N_Type_Conversion
+                       and then Entity (Subtype_Mark (L)) = Typ)
+        and then not (Nkind (R) = N_Type_Conversion
+                       and then Entity (Subtype_Mark (R)) = Typ)
+      then
+         return;
+      end if;
+
+      --  Now pick the narrower type according to the size
+
+      if Nsiz <= RM_Size (Standard_Integer) then
+         Ntyp := Standard_Integer;
+
+      elsif Nsiz <= RM_Size (Standard_Long_Long_Integer) then
+         Ntyp := Standard_Long_Long_Integer;
+
+      else
+         return;
+      end if;
+
+      --  Finally rewrite the operation in the narrower type
+
+      Nop := New_Op_Node (Kind, Sloc (N));
+
+      if Binary then
+         Set_Left_Opnd (Nop, Convert_To (Ntyp, L));
+      end if;
+
+      if In_Rng then
+         Set_Right_Opnd (Nop,
+           Make_Range (Sloc (N),
+             Convert_To (Ntyp, Low_Bound (R)),
+             Convert_To (Ntyp, High_Bound (R))));
+      else
+         Set_Right_Opnd (Nop, Convert_To (Ntyp, R));
+      end if;
+
+      Rewrite (N, Nop);
+
+      if Compar then
+         --  Analyze it with the comparison type and checks suppressed since
+         --  the conversions of the operands cannot overflow.
+
+         Analyze_And_Resolve
+           (N, Etype (Original_Node (N)), Suppress => Overflow_Check);
+
+      else
+         --  Analyze it with the narrower type and checks suppressed, but only
+         --  when we are sure that the operation does not overflow, see above.
+
+         if Nsiz < RM_Size (Typ) then
+            Analyze_And_Resolve (N, Ntyp, Suppress => Overflow_Check);
+         else
+            Analyze_And_Resolve (N, Ntyp);
+         end if;
+
+         --  Put back a conversion to the original type
+
+         Convert_To_And_Rewrite (Typ, N);
+      end if;
+   end Narrow_Large_Operation;
+
    --------------------------------
    -- Optimize_Length_Comparison --
    --------------------------------

--- gcc/ada/exp_ch9.adb
+++ gcc/ada/exp_ch9.adb
@@ -6185,7 +6185,7 @@  package body Exp_Ch9 is
                if No (Entity (N)) then
                   return Abandon;
 
-               elsif Is_Universal_Numeric_Type (Entity (N)) then
+               elsif Is_Numeric_Type (Entity (N)) then
                   return Skip;
                end if;
 
@@ -6283,11 +6283,13 @@  package body Exp_Ch9 is
 
             when N_Type_Conversion =>
 
-               --  Conversions to Universal_Integer will not raise constraint
-               --  errors.
+               --  Conversions to Universal_Integer do not raise constraint
+               --  errors. Likewise if the expression's type is statically
+               --  compatible with the target's type.
 
-               if Cannot_Raise_Constraint_Error (N)
-                 or else Etype (N) = Universal_Integer
+               if Etype (N) = Universal_Integer
+                 or else Subtypes_Statically_Compatible
+                           (Etype (Expression (N)), Etype (N))
                then
                   return OK;
                end if;