ada: Improve efficiency of very large shift counts

For a call to an intrinsic shift function with a large Amount, for
example Shift_Right(..., Amount => Natural'Last), and a
compile-time-known value, the compiler would take an absurdly long time
to compute the value. This patch fixes that by special-casing shift
counts that are larger than the size of the thing being shifted.

gcc/ada/ChangeLog:

	* sem_eval.adb (Fold_Shift): If the Amount parameter is greater
	than the size in bits, use the size. For example, if we are
	shifting an Unsigned_8 value, then Amount => 1_000_001 gives the
	same result as Amount => 8. This change avoids computing the value
	of 2**1_000_000, which takes too long and uses too much memory.
	Note that the computation we're talking about is a compile-time
	computation. Minor cleanup. DRY.
	* sem_eval.ads (Fold_Str, Fold_Uint, Fold_Ureal): Fold the
	comments into one comment, because DRY. Remove useless
	verbiage.

diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb
index b7dfe01f29739165dccf73d65a0c56456483147b..5d1506364956ca4bb5d8d501e808f7d247e292c5 100644 (file)
--- a/gcc/ada/sem_eval.adb
+++ b/gcc/ada/sem_eval.adb
@@ -4989,27 +4989,41 @@ package body Sem_Eval is
          end if;
       end Check_Elab_Call;
 
-      Modulus, Val : Uint;
-
    begin
-      if Compile_Time_Known_Value (Left)
-        and then Compile_Time_Known_Value (Right)
+      if not (Compile_Time_Known_Value (Left)
+              and then Compile_Time_Known_Value (Right))
       then
-         pragma Assert (not Non_Binary_Modulus (Typ));
+         return;
+      end if;
+
+      pragma Assert (not Non_Binary_Modulus (Typ));
+      pragma Assert (Expr_Value (Right) >= Uint_0); -- Amount is always Natural
+
+      --  Shift by zero bits is a no-op
 
+      if Expr_Value (Right) = Uint_0 then
+         Fold_Uint (N, Expr_Value (Left), Static => Static);
+         return;
+      end if;
+
+      declare
+         Modulus : constant Uint :=
+           (if Is_Modular_Integer_Type (Typ) then Einfo.Entities.Modulus (Typ)
+            else Uint_2 ** RM_Size (Typ));
+         Amount : constant Uint := UI_Min (Expr_Value (Right), RM_Size (Typ));
+         --  Shift by an Amount greater than the size is all-zeros or all-ones.
+         --  Without this "min", we could use huge amounts of time and memory
+         --  below (e.g. 2**Amount, if Amount were a billion).
+
+         Val : Uint;
+      begin
          if Op = N_Op_Shift_Left then
             Check_Elab_Call;
 
-            if Is_Modular_Integer_Type (Typ) then
-               Modulus := Einfo.Entities.Modulus (Typ);
-            else
-               Modulus := Uint_2 ** RM_Size (Typ);
-            end if;
-
             --  Fold Shift_Left (X, Y) by computing
             --  (X * 2**Y) rem modulus [- Modulus]
 
-            Val := (Expr_Value (Left) * (Uint_2 ** Expr_Value (Right)))
+            Val := (Expr_Value (Left) * (Uint_2 ** Amount))
                      rem Modulus;
 
             if Is_Modular_Integer_Type (Typ)
@@ -5023,49 +5037,32 @@ package body Sem_Eval is
          elsif Op = N_Op_Shift_Right then
             Check_Elab_Call;
 
-            --  X >> 0 is a no-op
+            --  Fold X >> Y by computing (X [+ Modulus]) / 2**Y.
+            --  Note that after a Shift_Right operation (with Y > 0), the
+            --  result is always positive, even if the original operand was
+            --  negative.
 
-            if Expr_Value (Right) = Uint_0 then
-               Fold_Uint (N, Expr_Value (Left), Static => Static);
-            else
-               if Is_Modular_Integer_Type (Typ) then
-                  Modulus := Einfo.Entities.Modulus (Typ);
+            declare
+               M : Unat;
+            begin
+               if Expr_Value (Left) >= Uint_0 then
+                  M := Uint_0;
                else
-                  Modulus := Uint_2 ** RM_Size (Typ);
+                  M := Modulus;
                end if;
 
-               --  Fold X >> Y by computing (X [+ Modulus]) / 2**Y
-               --  Note that after a Shift_Right operation (with Y > 0), the
-               --  result is always positive, even if the original operand was
-               --  negative.
-
-               declare
-                  M : Unat;
-               begin
-                  if Expr_Value (Left) >= Uint_0 then
-                     M := Uint_0;
-                  else
-                     M := Modulus;
-                  end if;
+               Fold_Uint
+                 (N,
+                  (Expr_Value (Left) + M) / (Uint_2 ** Amount),
+                  Static => Static);
+            end;
 
-                  Fold_Uint
-                    (N,
-                     (Expr_Value (Left) + M) / (Uint_2 ** Expr_Value (Right)),
-                     Static => Static);
-               end;
-            end if;
          elsif Op = N_Op_Shift_Right_Arithmetic then
             Check_Elab_Call;
 
             declare
-               Two_Y : constant Uint := Uint_2 ** Expr_Value (Right);
+               Two_Y : constant Uint := Uint_2 ** Amount;
             begin
-               if Is_Modular_Integer_Type (Typ) then
-                  Modulus := Einfo.Entities.Modulus (Typ);
-               else
-                  Modulus := Uint_2 ** RM_Size (Typ);
-               end if;
-
                --  X / 2**Y if X if positive or a small enough modular integer
 
                if (Is_Modular_Integer_Type (Typ)
@@ -5096,7 +5093,7 @@ package body Sem_Eval is
                     (N,
                      (Expr_Value (Left)) / Two_Y
                         + (Two_Y - Uint_1)
-                          * Uint_2 ** (RM_Size (Typ) - Expr_Value (Right)),
+                          * Uint_2 ** (RM_Size (Typ) - Amount),
                      Static => Static);
 
                --  Negative signed integer, compute via multiple/divide the
@@ -5108,13 +5105,15 @@ package body Sem_Eval is
                     (N,
                      (Modulus + Expr_Value (Left)) / Two_Y
                         + (Two_Y - Uint_1)
-                          * Uint_2 ** (RM_Size (Typ) - Expr_Value (Right))
+                          * Uint_2 ** (RM_Size (Typ) - Amount)
                         - Modulus,
                      Static => Static);
                end if;
             end;
+         else
+            raise Program_Error;
          end if;
-      end if;
+      end;
    end Fold_Shift;
 
    --------------

diff --git a/gcc/ada/sem_eval.ads b/gcc/ada/sem_eval.ads
index 138278f7af3a158f4ad66b8e1ec41d393db8bd18..7df1c4c25e91e920c391c9ab4b62bd27de65081a 100644 (file)
--- a/gcc/ada/sem_eval.ads
+++ b/gcc/ada/sem_eval.ads
@@ -342,41 +342,12 @@ package Sem_Eval is
    --  set of messages is all posted.
 
    procedure Fold_Str (N : Node_Id; Val : String_Id; Static : Boolean);
-   --  Rewrite N with a new N_String_Literal node as the result of the compile
-   --  time evaluation of the node N. Val is the resulting string value from
-   --  the folding operation. The Is_Static_Expression flag is set in the
-   --  result node. The result is fully analyzed and resolved. Static indicates
-   --  whether the result should be considered static or not (True = consider
-   --  static). The point here is that normally all string literals are static,
-   --  but if this was the result of some sequence of evaluation where values
-   --  were known at compile time but not static, then the result is not
-   --  static. The call has no effect if Raises_Constraint_Error (N) is True,
-   --  since there is no point in folding if we have an error.
-
    procedure Fold_Uint (N : Node_Id; Val : Uint; Static : Boolean);
-   --  Rewrite N with a (N_Integer_Literal, N_Identifier, N_Character_Literal)
-   --  node as the result of the compile time evaluation of the node N. Val is
-   --  the result in the integer case and is the position of the literal in the
-   --  literals list for the enumeration case. Is_Static_Expression is set True
-   --  in the result node. The result is fully analyzed/resolved. Static
-   --  indicates whether the result should be considered static or not (True =
-   --  consider static). The point here is that normally all integer literals
-   --  are static, but if this was the result of some sequence of evaluation
-   --  where values were known at compile time but not static, then the result
-   --  is not static. The call has no effect if Raises_Constraint_Error (N) is
-   --  True, since there is no point in folding if we have an error.
-
    procedure Fold_Ureal (N : Node_Id; Val : Ureal; Static : Boolean);
-   --  Rewrite N with a new N_Real_Literal node as the result of the compile
-   --  time evaluation of the node N. Val is the resulting real value from the
-   --  folding operation. The Is_Static_Expression flag is set in the result
-   --  node. The result is fully analyzed and result. Static indicates whether
-   --  the result should be considered static or not (True = consider static).
-   --  The point here is that normally all string literals are static, but if
-   --  this was the result of some sequence of evaluation where values were
-   --  known at compile time but not static, then the result is not static.
-   --  The call has no effect if Raises_Constraint_Error (N) is True, since
-   --  there is no point in folding if we have an error.
+   --  Rewrite N with a new literal node with compile-time-known value Val.
+   --  Is_Static_Expression is set to Static. This has no effect if
+   --  Raises_Constraint_Error (N) is True, since there is no point in
+   --  folding if we have an error.
 
    procedure Fold (N : Node_Id);
    --  Rewrite N with the relevant value if Compile_Time_Known_Value (N) is