[Ada] Exponentiation works with extended overflow checks
Arnaud Charlet
charlet@adacore.com
Mon Oct 1 13:15:00 GMT 2012
This patch implements extended overflow checking modes
with the exonentiation operator.
The following is a test program:
1. with Text_IO; use Text_IO;
2. procedure Overflowm4 is
3. function r1 (a, b : Integer) return Boolean is
4. begin
5. return a ** 2 - b ** 2 <= Integer'Last;
6. end;
7. function r2 (a, b : Integer) return Boolean is
8. begin
9. return a ** 10 - b ** 10 in Integer;
10. end;
11. begin
12. begin
13. Put_Line
14. ("r1 returns " &
15. Boolean'Image (r1 (Integer'Last, Integer'Last)));
16. exception
17. when Constraint_Error =>
18. Put_Line ("r1 raises exception");
19. end;
20.
21. begin
22. Put_Line
23. ("r2 returns " &
24. Boolean'Image (r2 (Integer'Last, Integer'Last)));
25. exception
26. when Constraint_Error =>
27. Put_Line ("r2 raises exception");
28. end;
29. end Overflowm4;
In CHECKED mode (-gnato1) we get:
r1 raises exception
r2 raises exception
since the first exponentiation in both r1 and r2 result
in values outside the bounds of Integer'Base.
In MINIMIZED mode (-gnato2) we get:
r1 returns TRUE
r2 raises exception
since we can compute the exponentiation results in r1 in
Long_Long_Integer mode, but that's not true for r2.
In ELIMINATE mode (-gnato3) we get:
r1 returns TRUE
r2 returns TRUE
Because now we use Bignum arithmetic for the exponentiation
operations in r2.
Tested on x86_64-pc-linux-gnu, committed on trunk
2012-10-01 Robert Dewar <dewar@adacore.com>
* checks.adb (Minimize_Eliminate_Overflow_Checks): Changes
for exponentiation.
* exp_ch4.adb (Expand_N_Op_Expon): Changes for Minimize/Eliminate
overflow checks.
* s-bignum.adb (Compare): Fix bad precondition.
-------------- next part --------------
Index: checks.adb
===================================================================
--- checks.adb (revision 191918)
+++ checks.adb (working copy)
@@ -6548,7 +6548,7 @@
when N_Op_Abs =>
Lo := Uint_0;
- Hi := UI_Max (UI_Abs (Rlo), UI_Abs (Rhi));
+ Hi := UI_Max (abs Rlo, abs Rhi);
-- Addition
@@ -6564,8 +6564,80 @@
-- Exponentiation
when N_Op_Expon =>
- raise Program_Error;
+ -- Discard negative values for the exponent, since they will
+ -- simply result in an exception in any case.
+
+ if Rhi < 0 then
+ Rhi := Uint_0;
+ elsif Rlo < 0 then
+ Rlo := Uint_0;
+ end if;
+
+ -- Estimate number of bits in result before we go computing
+ -- giant useless bounds. Basically the number of bits in the
+ -- result is the number of bits in the base multiplied by the
+ -- value of the exponent. If this is big enough that the result
+ -- definitely won't fit in Long_Long_Integer, switch to bignum
+ -- mode immediately, and avoid computing giant bounds.
+
+ -- The comparison here is approximate, but conservative, it
+ -- only clicks on cases that are sure to exceed the bounds.
+
+ if Num_Bits (UI_Max (abs Llo, abs Lhi)) * Rhi + 1 > 100 then
+ Lo := No_Uint;
+ Hi := No_Uint;
+
+ -- If right operand is zero then result is 1
+
+ elsif Rhi = 0 then
+ Lo := Uint_1;
+ Hi := Uint_1;
+
+ else
+ -- High bound comes either from exponentiation of largest
+ -- positive value to largest exponent value, or from the
+ -- exponentiation of most negative value to an odd exponent.
+
+ declare
+ Hi1, Hi2 : Uint;
+
+ begin
+ if Lhi >= 0 then
+ Hi1 := Lhi ** Rhi;
+ else
+ Hi1 := Uint_0;
+ end if;
+
+ if Llo < 0 then
+ if Rhi mod 2 = 0 then
+ Hi2 := Llo ** (Rhi - 1);
+ else
+ Hi2 := Llo ** Rhi;
+ end if;
+ else
+ Hi2 := Uint_0;
+ end if;
+
+ Hi := UI_Max (Hi1, Hi2);
+ end;
+
+ -- Result can only be negative if base can be negative
+
+ if Llo < 0 then
+ if UI_Mod (Rhi, 2) = 0 then
+ Lo := Llo ** (Rhi - 1);
+ else
+ Lo := Llo ** Rhi;
+ end if;
+
+ -- Otherwise low bound is minimium ** minimum
+
+ else
+ Lo := Llo ** Rlo;
+ end if;
+ end if;
+
-- Negation
when N_Op_Minus =>
@@ -6623,13 +6695,13 @@
when others =>
raise Program_Error;
-
end case;
end if;
-- Case where we do the operation in Bignum mode. This happens either
-- because one of our operands is in Bignum mode already, or because
- -- the computed bounds are outside the bounds of Long_Long_Integer.
+ -- the computed bounds are outside the bounds of Long_Long_Integer,
+ -- which in some cases can be indicated by Hi and Lo being No_Uint.
-- Note: we could do better here and in some cases switch back from
-- Bignum mode to normal mode, e.g. big mod 2 must be in the range
@@ -6641,21 +6713,13 @@
if Lo = No_Uint or else Lo < LLLo or else Hi > LLHi then
- -- In MINIMIZED mode, just give up and apply an overflow check
+ -- In MINIMIZED mode, note that an overflow check is required
-- Note that we know we don't have a Bignum, since Bignums only
-- appear in Eliminated mode.
if Check_Mode = Minimized then
- pragma Assert (Lo /= No_Uint);
Enable_Overflow_Check (N);
- -- It's fine to just return here, we may generate an overflow
- -- exception, but this is the case in MINIMIZED mode where we
- -- can't avoid this possibility.
-
- Apply_Arithmetic_Overflow_Normal (N);
- return;
-
-- Otherwise we are in ELIMINATED mode, switch to bignum
else
@@ -6721,38 +6785,64 @@
Name => New_Occurrence_Of (Fent, Loc),
Parameter_Associations => Args));
Analyze_And_Resolve (N, RTE (RE_Bignum));
+ return;
end;
end if;
-- Otherwise we are in range of Long_Long_Integer, so no overflow
- -- check is required, at least not yet. Adjust the operands to
- -- Long_Long_Integer and mark the result type as Long_Long_Integer.
+ -- check is required, at least not yet.
else
- -- Convert right or only operand to Long_Long_Integer, except that
- -- we do not touch the exponentiation right operand.
+ Set_Do_Overflow_Check (N, False);
+ end if;
- if Nkind (N) /= N_Op_Expon then
- Convert_To_And_Rewrite (LLIB, Right_Opnd (N));
- end if;
+ -- Here we will do the operation in Long_Long_Integer. We do this even
+ -- if we know an overflow check is required, better to do this in long
+ -- long integer mode, since we are less likely to overflow!
- -- Convert left operand to Long_Long_Integer for binary case
+ -- Convert right or only operand to Long_Long_Integer, except that
+ -- we do not touch the exponentiation right operand.
- if Binary then
- Convert_To_And_Rewrite (LLIB, Left_Opnd (N));
- end if;
+ if Nkind (N) /= N_Op_Expon then
+ Convert_To_And_Rewrite (LLIB, Right_Opnd (N));
+ end if;
- -- Reset node to unanalyzed
+ -- Convert left operand to Long_Long_Integer for binary case
- Set_Analyzed (N, False);
- Set_Etype (N, Empty);
- Set_Entity (N, Empty);
- Set_Do_Overflow_Check (N, False);
+ if Binary then
+ Convert_To_And_Rewrite (LLIB, Left_Opnd (N));
+ end if;
- -- Now analyze this new node with checks off (since we know that
- -- we do not need an overflow check).
+ -- Reset node to unanalyzed
+ Set_Analyzed (N, False);
+ Set_Etype (N, Empty);
+ Set_Entity (N, Empty);
+
+ -- Now analyze this new node
+
+ -- If no overflow check, suppress all checks
+
+ if not Do_Overflow_Check (N) then
Analyze_And_Resolve (N, LLIB, Suppress => All_Checks);
+
+ -- If an overflow check is required, do it in normal CHECKED mode.
+ -- That avoids an infinite recursion, makes sure we get a normal
+ -- overflow check, and also completes expansion of Exponentiation.
+
+ else
+ declare
+ SG : constant Overflow_Check_Type :=
+ Scope_Suppress.Overflow_Checks_General;
+ SA : constant Overflow_Check_Type :=
+ Scope_Suppress.Overflow_Checks_Assertions;
+ begin
+ Scope_Suppress.Overflow_Checks_General := Checked;
+ Scope_Suppress.Overflow_Checks_Assertions := Checked;
+ Analyze_And_Resolve (N, LLIB);
+ Scope_Suppress.Overflow_Checks_General := SG;
+ Scope_Suppress.Overflow_Checks_Assertions := SA;
+ end;
end if;
end Minimize_Eliminate_Overflow_Checks;
Index: exp_ch4.adb
===================================================================
--- exp_ch4.adb (revision 191918)
+++ exp_ch4.adb (working copy)
@@ -3708,7 +3708,6 @@
(N => Cnode,
Msg => "concatenation result upper bound out of range?",
Reason => CE_Range_Check_Failed);
- -- Set_Etype (Cnode, Atyp);
end Expand_Concatenate;
---------------------------------------------------
@@ -7134,7 +7133,7 @@
Reason => PE_Unchecked_Union_Restriction));
-- Prevent Gigi from generating incorrect code by rewriting the
- -- equality as a standard False.
+ -- equality as a standard False. (is this documented somewhere???)
Rewrite (N,
New_Occurrence_Of (Standard_False, Loc));
@@ -7161,7 +7160,7 @@
Reason => PE_Unchecked_Union_Restriction));
-- Prevent Gigi from generating incorrect code by rewriting
- -- the equality as a standard False.
+ -- the equality as a standard False (documented where???).
Rewrite (N,
New_Occurrence_Of (Standard_False, Loc));
@@ -7260,6 +7259,23 @@
end;
end if;
+ -- Normally we complete expansion of exponentiation (e.g. converting
+ -- to multplications) right here, but there is one exception to this.
+ -- If we have a signed integer type and the overflow checking mode
+ -- is MINIMIZED or ELIMINATED and overflow checking is activated, then
+ -- we don't yet want to expand, since that will intefere with handling
+ -- of extended precision intermediate value. In this situation we just
+ -- apply the arithmetic overflow check, and then the overflow check
+ -- circuit will re-expand the exponentiation node in CHECKED mode.
+
+ if Is_Signed_Integer_Type (Rtyp)
+ and then Overflow_Check_Mode (Typ) in Minimized_Or_Eliminated
+ and then Do_Overflow_Check (N)
+ then
+ Apply_Arithmetic_Overflow_Check (N);
+ return;
+ end if;
+
-- Test for case of known right argument
if Compile_Time_Known_Value (Exp) then
@@ -10157,7 +10173,7 @@
then
-- To prevent Gigi from generating illegal code, we generate a
-- Program_Error node, but we give it the target type of the
- -- conversion.
+ -- conversion (is this requirement documented somewhere ???)
declare
PE : constant Node_Id := Make_Raise_Program_Error (Loc,
Index: s-bignum.adb
===================================================================
--- s-bignum.adb (revision 191918)
+++ s-bignum.adb (working copy)
@@ -81,7 +81,7 @@
function Compare
(X, Y : Digit_Vector;
X_Neg, Y_Neg : Boolean) return Compare_Result
- with Pre => X'First = 1 and then X'Last = 1;
+ with Pre => X'First = 1 and then Y'First = 1;
-- Compare (X with sign X_Neg) with (Y with sign Y_Neg), and return the
-- result of the signed comparison.
More information about the Gcc-patches
mailing list