[Ada] Improved compile time eval of length attribute
Arnaud Charlet
charlet@adacore.com
Mon Apr 20 13:30:00 GMT 2009
This patch improves the compiler to catch some additional cases of
the length (and range_length) attributes applied to arrays and
slices, resulting in elimination of run time checks and improved
compile time warnings. The change involves a new version of the
routine Compile_Time_Compare in Sem_Eval which returns not only
GT and LT, but where possible the compile-time known difference.
Then this improved routine is used in Sem_Attr when evaluating
Length and Range_Length attributes.
Consider this test program:
procedure LengthEval (X : out String) is
begin
X (X'First .. X'First) := "a";
X (X'First .. X'First) := "aa";
end LengthEval;
Prior to this patch, both assignments did a run time length check.
With the patch, compiling with -gnatj60 -gnatG, we get:
Source recreated from tree for Lengtheval (body)
procedure lengtheval (x : out string) is
subtype lengtheval__S1b is string (x'first(1) .. x'last(1));
begin
[constraint_error when
x'first > x'last(1)
"range check failed"]
[subtype lengtheval__T5b is integer range x'first .. x'first]
[subtype lengtheval__T6b is string (lengtheval__T5b)]
x ({x'first .. x'first}) := lengtheval__T6b!("a");
[constraint_error when
x'first > x'last(1)
"range check failed"]
[constraint_error "length check failed"]
x ({x'first .. x'first}) := [constraint_error "length check failed"];
return;
end lengtheval;
lengtheval.adb:4:30: warning: wrong length for array of
subtype of "Standard.String" defined
at line 4, "Constraint_Error" will be
raised at run time
and the run time check is eliminate in both cases, with an
appropriate compile time warning in the second case.
Tested on x86_64-pc-linux-gnu, committed on trunk
2009-04-20 Robert Dewar <dewar@adacore.com>
* sem_attr.adb (Eval_Attribute, case Length): Catch more cases where
this attribute can be evaluated at compile time.
(Eval_Attribute, case Range_Length): Same improvement
* sem_eval.ads, sem_eval.adb (Compile_Time_Compare): New procedure
-------------- next part --------------
Index: sem_attr.adb
===================================================================
--- sem_attr.adb (revision 146417)
+++ sem_attr.adb (working copy)
@@ -6168,6 +6168,8 @@ package body Sem_Attr is
Set_Bounds;
+ -- For two compile time values, we can compute length
+
if Compile_Time_Known_Value (Lo_Bound)
and then Compile_Time_Known_Value (Hi_Bound)
then
@@ -6175,6 +6177,33 @@ package body Sem_Attr is
UI_Max (0, 1 + (Expr_Value (Hi_Bound) - Expr_Value (Lo_Bound))),
True);
end if;
+
+ -- One more case is where Hi_Bound and Lo_Bound are compile-time
+ -- comparable, and we can figure out the difference between them.
+
+ declare
+ Diff : aliased Uint;
+
+ begin
+ case
+ Compile_Time_Compare
+ (Lo_Bound, Hi_Bound, Diff'Access, Assume_Valid => False)
+ is
+ when EQ =>
+ Fold_Uint (N, Uint_1, False);
+
+ when GT =>
+ Fold_Uint (N, Uint_0, False);
+
+ when LT =>
+ if Diff /= No_Uint then
+ Fold_Uint (N, Diff + 1, False);
+ end if;
+
+ when others =>
+ null;
+ end case;
+ end;
end Length;
-------------
@@ -6666,6 +6695,8 @@ package body Sem_Attr is
when Attribute_Range_Length =>
Set_Bounds;
+ -- Can fold if both bounds are compile time known
+
if Compile_Time_Known_Value (Hi_Bound)
and then Compile_Time_Known_Value (Lo_Bound)
then
@@ -6675,6 +6706,33 @@ package body Sem_Attr is
Static);
end if;
+ -- One more case is where Hi_Bound and Lo_Bound are compile-time
+ -- comparable, and we can figure out the difference between them.
+
+ declare
+ Diff : aliased Uint;
+
+ begin
+ case
+ Compile_Time_Compare
+ (Lo_Bound, Hi_Bound, Diff'Access, Assume_Valid => False)
+ is
+ when EQ =>
+ Fold_Uint (N, Uint_1, False);
+
+ when GT =>
+ Fold_Uint (N, Uint_0, False);
+
+ when LT =>
+ if Diff /= No_Uint then
+ Fold_Uint (N, Diff + 1, False);
+ end if;
+
+ when others =>
+ null;
+ end case;
+ end;
+
---------------
-- Remainder --
---------------
Index: sem_eval.adb
===================================================================
--- sem_eval.adb (revision 146405)
+++ sem_eval.adb (working copy)
@@ -380,6 +380,16 @@ package body Sem_Eval is
function Compile_Time_Compare
(L, R : Node_Id;
+ Assume_Valid : Boolean) return Compare_Result
+ is
+ Discard : aliased Uint;
+ begin
+ return Compile_Time_Compare (L, R, Discard'Access, Assume_Valid);
+ end Compile_Time_Compare;
+
+ function Compile_Time_Compare
+ (L, R : Node_Id;
+ Diff : access Uint;
Assume_Valid : Boolean;
Rec : Boolean := False) return Compare_Result
is
@@ -390,6 +400,8 @@ package body Sem_Eval is
-- invalid representations using the value of the base type, in
-- accordance with RM 13.9.1(10).
+ Discard : aliased Uint;
+
procedure Compare_Decompose
(N : Node_Id;
R : out Node_Id;
@@ -654,6 +666,8 @@ package body Sem_Eval is
-- Start of processing for Compile_Time_Compare
begin
+ Diff.all := No_Uint;
+
-- If either operand could raise constraint error, then we cannot
-- know the result at compile time (since CE may be raised!)
@@ -724,10 +738,14 @@ package body Sem_Eval is
begin
if Lo < Hi then
+ Diff.all := Hi - Lo;
return LT;
+
elsif Lo = Hi then
return EQ;
+
else
+ Diff.all := Lo - Hi;
return GT;
end if;
end;
@@ -813,7 +831,9 @@ package body Sem_Eval is
-- a bound of the other operand (four possible tests here).
case Compile_Time_Compare (L, Type_Low_Bound (Rtyp),
- Assume_Valid, Rec => True) is
+ Discard'Access,
+ Assume_Valid, Rec => True)
+ is
when LT => return LT;
when LE => return LE;
when EQ => return LE;
@@ -821,7 +841,9 @@ package body Sem_Eval is
end case;
case Compile_Time_Compare (L, Type_High_Bound (Rtyp),
- Assume_Valid, Rec => True) is
+ Discard'Access,
+ Assume_Valid, Rec => True)
+ is
when GT => return GT;
when GE => return GE;
when EQ => return GE;
@@ -829,7 +851,9 @@ package body Sem_Eval is
end case;
case Compile_Time_Compare (Type_Low_Bound (Ltyp), R,
- Assume_Valid, Rec => True) is
+ Discard'Access,
+ Assume_Valid, Rec => True)
+ is
when GT => return GT;
when GE => return GE;
when EQ => return GE;
@@ -837,7 +861,9 @@ package body Sem_Eval is
end case;
case Compile_Time_Compare (Type_High_Bound (Ltyp), R,
- Assume_Valid, Rec => True) is
+ Discard'Access,
+ Assume_Valid, Rec => True)
+ is
when LT => return LT;
when LE => return LE;
when EQ => return LE;
@@ -871,9 +897,11 @@ package body Sem_Eval is
return EQ;
elsif Loffs < Roffs then
+ Diff.all := Roffs - Loffs;
return LT;
else
+ Diff.all := Loffs - Roffs;
return GT;
end if;
end if;
@@ -943,6 +971,7 @@ package body Sem_Eval is
if Op = N_Op_Le then
Op := N_Op_Lt;
Opv := Opv + 1;
+
elsif Op = N_Op_Ge then
Op := N_Op_Gt;
Opv := Opv - 1;
Index: sem_eval.ads
===================================================================
--- sem_eval.ads (revision 146405)
+++ sem_eval.ads (working copy)
@@ -132,10 +132,12 @@ package Sem_Eval is
type Compare_Result is (LT, LE, EQ, GT, GE, NE, Unknown);
subtype Compare_GE is Compare_Result range EQ .. GE;
subtype Compare_LE is Compare_Result range LT .. EQ;
+ -- Result subtypes for Compile_Time_Compare subprograms
+
function Compile_Time_Compare
(L, R : Node_Id;
- Assume_Valid : Boolean;
- Rec : Boolean := False) return Compare_Result;
+ Assume_Valid : Boolean) return Compare_Result;
+ pragma Inline (Compile_Time_Compare);
-- Given two expression nodes, finds out whether it can be determined at
-- compile time how the runtime values will compare. An Unknown result
-- means that the result of a comparison cannot be determined at compile
@@ -145,9 +147,19 @@ package Sem_Eval is
-- the result of assuming that entities involved in the comparison have
-- valid representations. If Assume_Valid is false, then the base type of
-- any involved entity is used so that no assumption of validity is made.
- -- Rec is a parameter that is set True for a recursive call from within
- -- Compile_Time_Compare to avoid some infinite recursion cases. It should
- -- never be set by a client.
+
+ function Compile_Time_Compare
+ (L, R : Node_Id;
+ Diff : access Uint;
+ Assume_Valid : Boolean;
+ Rec : Boolean := False) return Compare_Result;
+ -- This version of Compile_Time_Compare returns extra information if the
+ -- result is GT or LT. In these cases, if the magnitude of the difference
+ -- can be determined at compile time, this (positive) magnitude is returned
+ -- in Diff.all. If the magnitude of the difference cannot be determined
+ -- then Diff.all contains No_Uint on return. Rec is a parameter that is set
+ -- True for a recursive call from within Compile_Time_Compare to avoid some
+ -- infinite recursion cases. It should never be set by a client.
procedure Flag_Non_Static_Expr (Msg : String; Expr : Node_Id);
-- This procedure is called after it has been determined that Expr is not
@@ -311,7 +323,7 @@ package Sem_Eval is
-- 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 string literals
+ -- 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.
More information about the Gcc-patches
mailing list