https://gcc.gnu.org/g:a7c5e316e28c993952337ea7a5570cb5d1df1daa
commit r16-1156-ga7c5e316e28c993952337ea7a5570cb5d1df1daa
Author: Bob Duff <d...@adacore.com>
Date: Tue Feb 4 14:36:03 2025 -0500
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:
---
gcc/ada/sem_eval.adb | 95 ++++++++++++++++++++++++++--------------------------
gcc/ada/sem_eval.ads | 37 +++-----------------
2 files changed, 51 insertions(+), 81 deletions(-)
diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb
index b7dfe01f2973..5d1506364956 100644
--- 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 138278f7af3a..7df1c4c25e91 100644
--- 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
