[Ada] Add support for compile time evaluation of Shift_Right_Arithmetic

gcc/ada/

	* sem_eval.adb (Eval_Intrinsic_Call, Fold_Shift): Add support
	for Shift_Right_Arithmetic and for signed integers.
	* exp_ch4.adb (Expand_N_Op_Rotate_Left,
	Expand_N_Op_Rotate_Right, Expand_N_Op_Shift_Left,
	Expand_N_Op_Shift_Right_Arithmetic): Minor reformatting and code
	cleanup to ensure a consistent handling. Update comments and add
	assertion.

diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
index 30824c69fea19b687eb22e215a416983818f69d1..b61c428182e2b59a8ba991c497183b26f305c5a6 100644 (file)
--- a/gcc/ada/exp_ch4.adb
+++ b/gcc/ada/exp_ch4.adb
@@ -10265,15 +10265,17 @@ package body Exp_Ch4 is
       --  where Bits is the shift count mod Esize (the mod operation here
       --  deals with ludicrous large shift counts, which are apparently OK).
 
-      --  What about nonbinary modulus ???
+      if Modify_Tree_For_C then
+         declare
+            Loc : constant Source_Ptr := Sloc (N);
+            Rtp : constant Entity_Id  := Etype (Right_Opnd (N));
+            Typ : constant Entity_Id  := Etype (N);
 
-      declare
-         Loc : constant Source_Ptr := Sloc (N);
-         Rtp : constant Entity_Id  := Etype (Right_Opnd (N));
-         Typ : constant Entity_Id  := Etype (N);
+         begin
+            --  Sem_Intr should prevent getting there with a non binary modulus
+
+            pragma Assert (not Non_Binary_Modulus (Typ));
 
-      begin
-         if Modify_Tree_For_C then
             Rewrite (Right_Opnd (N),
               Make_Op_Rem (Loc,
                 Left_Opnd  => Relocate_Node (Right_Opnd (N)),
@@ -10298,8 +10300,8 @@ package body Exp_Ch4 is
                           Duplicate_Subexpr_No_Checks (Right_Opnd (N))))));
 
             Analyze_And_Resolve (N, Typ);
-         end if;
-      end;
+         end;
+      end if;
    end Expand_N_Op_Rotate_Left;
 
    ------------------------------
@@ -10318,22 +10320,24 @@ package body Exp_Ch4 is
       --  where Bits is the shift count mod Esize (the mod operation here
       --  deals with ludicrous large shift counts, which are apparently OK).
 
-      --  What about nonbinary modulus ???
+      if Modify_Tree_For_C then
+         declare
+            Loc : constant Source_Ptr := Sloc (N);
+            Rtp : constant Entity_Id  := Etype (Right_Opnd (N));
+            Typ : constant Entity_Id  := Etype (N);
 
-      declare
-         Loc : constant Source_Ptr := Sloc (N);
-         Rtp : constant Entity_Id  := Etype (Right_Opnd (N));
-         Typ : constant Entity_Id  := Etype (N);
+         begin
+            --  Sem_Intr should prevent getting there with a non binary modulus
 
-      begin
-         Rewrite (Right_Opnd (N),
-           Make_Op_Rem (Loc,
-             Left_Opnd  => Relocate_Node (Right_Opnd (N)),
-             Right_Opnd => Make_Integer_Literal (Loc, Esize (Typ))));
+            pragma Assert (not Non_Binary_Modulus (Typ));
+
+            Rewrite (Right_Opnd (N),
+              Make_Op_Rem (Loc,
+                Left_Opnd  => Relocate_Node (Right_Opnd (N)),
+                Right_Opnd => Make_Integer_Literal (Loc, Esize (Typ))));
 
-         Analyze_And_Resolve (Right_Opnd (N), Rtp);
+            Analyze_And_Resolve (Right_Opnd (N), Rtp);
 
-         if Modify_Tree_For_C then
             Rewrite (N,
               Make_Op_Or (Loc,
                 Left_Opnd =>
@@ -10351,8 +10355,8 @@ package body Exp_Ch4 is
                           Duplicate_Subexpr_No_Checks (Right_Opnd (N))))));
 
             Analyze_And_Resolve (N, Typ);
-         end if;
-      end;
+         end;
+      end if;
    end Expand_N_Op_Rotate_Right;
 
    ----------------------------
@@ -10382,6 +10386,10 @@ package body Exp_Ch4 is
             Hi    : Uint;
 
          begin
+            --  Sem_Intr should prevent getting there with a non binary modulus
+
+            pragma Assert (not Non_Binary_Modulus (Typ));
+
             if Compile_Time_Known_Value (Right) then
                if Expr_Value (Right) >= Siz then
                   Rewrite (N, Make_Integer_Literal (Loc, 0));
@@ -10439,7 +10447,14 @@ package body Exp_Ch4 is
       Binary_Op_Validity_Checks (N);
 
       --  If we are in Modify_Tree_For_C mode, there is no shift right
-      --  arithmetic in C, so we rewrite in terms of logical shifts.
+      --  arithmetic in C, so we rewrite in terms of logical shifts for
+      --  modular integers, and keep the Shift_Right intrinsic for signed
+      --  integers: even though doing a shift on a signed integer is not
+      --  fully guaranteed by the C standard, this is what C compilers
+      --  implement in practice.
+      --  Consider also taking advantage of this for modular integers by first
+      --  performing an unchecked conversion of the modular integer to a signed
+      --  integer of the same sign, and then convert back.
 
       --    Shift_Right (Num, Bits) or
       --      (if Num >= Sign
@@ -10448,26 +10463,24 @@ package body Exp_Ch4 is
 
       --  Here Mask is all 1 bits (2**size - 1), and Sign is 2**(size - 1)
 
-      --  Note: in almost all C compilers it would work to just shift a
-      --  signed integer right, but it's undefined and we cannot rely on it.
-
       --  Note: the above works fine for shift counts greater than or equal
       --  to the word size, since in this case (not (Shift_Right (Mask, bits)))
       --  generates all 1'bits.
 
-      --  What about nonbinary modulus ???
+      if Modify_Tree_For_C and then Is_Modular_Integer_Type (Etype (N)) then
+         declare
+            Loc   : constant Source_Ptr := Sloc (N);
+            Typ   : constant Entity_Id  := Etype (N);
+            Sign  : constant Uint       := 2 ** (Esize (Typ) - 1);
+            Mask  : constant Uint       := (2 ** Esize (Typ)) - 1;
+            Left  : constant Node_Id    := Left_Opnd (N);
+            Right : constant Node_Id    := Right_Opnd (N);
+            Maskx : Node_Id;
 
-      declare
-         Loc   : constant Source_Ptr := Sloc (N);
-         Typ   : constant Entity_Id  := Etype (N);
-         Sign  : constant Uint       := 2 ** (Esize (Typ) - 1);
-         Mask  : constant Uint       := (2 ** Esize (Typ)) - 1;
-         Left  : constant Node_Id    := Left_Opnd (N);
-         Right : constant Node_Id    := Right_Opnd (N);
-         Maskx : Node_Id;
+         begin
+            --  Sem_Intr should prevent getting there with a non binary modulus
 
-      begin
-         if Modify_Tree_For_C then
+            pragma Assert (not Non_Binary_Modulus (Typ));
 
             --  Here if not (Shift_Right (Mask, bits)) can be computed at
             --  compile time as a single constant.
@@ -10513,8 +10526,8 @@ package body Exp_Ch4 is
                       Maskx,
                       Make_Integer_Literal (Loc, 0)))));
             Analyze_And_Resolve (N, Typ);
-         end if;
-      end;
+         end;
+      end if;
    end Expand_N_Op_Shift_Right_Arithmetic;
 
    --------------------------

diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb
index 8c13abc7000979a8dcf4bca09a189f5b7c3df56f..872112d03ebae615be3646bd8aa3e33e12d6eea0 100644 (file)
--- a/gcc/ada/sem_eval.adb
+++ b/gcc/ada/sem_eval.adb
@@ -2941,9 +2941,14 @@ package body Sem_Eval is
       end if;
 
       case Nam is
-         when Name_Shift_Left  => Eval_Shift (N, E, N_Op_Shift_Left);
-         when Name_Shift_Right => Eval_Shift (N, E, N_Op_Shift_Right);
-         when others           => null;
+         when Name_Shift_Left  =>
+            Eval_Shift (N, E, N_Op_Shift_Left);
+         when Name_Shift_Right =>
+            Eval_Shift (N, E, N_Op_Shift_Right);
+         when Name_Shift_Right_Arithmetic =>
+            Eval_Shift (N, E, N_Op_Shift_Right_Arithmetic);
+         when others           =>
+            null;
       end case;
    end Eval_Intrinsic_Call;
 
@@ -4800,13 +4805,11 @@ package body Sem_Eval is
       end Check_Elab_Call;
 
    begin
-      --  Evaluate logical shift operators on binary modular types
-
-      if Is_Modular_Integer_Type (Typ)
-        and then not Non_Binary_Modulus (Typ)
-        and then Compile_Time_Known_Value (Left)
+      if Compile_Time_Known_Value (Left)
         and then Compile_Time_Known_Value (Right)
       then
+         pragma Assert (not Non_Binary_Modulus (Typ));
+
          if Op = N_Op_Shift_Left then
             Check_Elab_Call;
 
@@ -4821,12 +4824,73 @@ package body Sem_Eval is
          elsif Op = N_Op_Shift_Right then
             Check_Elab_Call;
 
-            --  Fold Shift_Right (X, Y) by computing X / 2**Y
+            --  Fold Shift_Right (X, Y) by computing abs X / 2**Y
 
             Fold_Uint
               (N,
-               Expr_Value (Left) / (Uint_2 ** Expr_Value (Right)),
+               abs Expr_Value (Left) / (Uint_2 ** Expr_Value (Right)),
                Static => Static);
+
+         elsif Op = N_Op_Shift_Right_Arithmetic then
+            Check_Elab_Call;
+
+            declare
+               Two_Y   : constant Uint := Uint_2 ** Expr_Value (Right);
+               Modulus : Uint;
+            begin
+               if Is_Modular_Integer_Type (Typ) then
+                  Modulus := Einfo.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)
+                    and then Expr_Value (Left) < Modulus / Uint_2)
+                 or else
+                   (not Is_Modular_Integer_Type (Typ)
+                     and then Expr_Value (Left) >= 0)
+               then
+                  Fold_Uint (N, Expr_Value (Left) / Two_Y, Static => Static);
+
+               --  -1 (aka all 1's) if Y is larger than the number of bits
+               --  available or if X = -1.
+
+               elsif Two_Y > Modulus
+                 or else Expr_Value (Left) = Uint_Minus_1
+               then
+                  if Is_Modular_Integer_Type (Typ) then
+                     Fold_Uint (N, Modulus - Uint_1, Static => Static);
+                  else
+                     Fold_Uint (N, Uint_Minus_1, Static => Static);
+                  end if;
+
+               --  Large modular integer, compute via multiply/divide the
+               --  following: X >> Y + (1 << Y - 1) << (RM_Size - Y)
+
+               elsif Is_Modular_Integer_Type (Typ) then
+                  Fold_Uint
+                    (N,
+                     (Expr_Value (Left)) / Two_Y
+                        + (Two_Y - Uint_1)
+                          * Uint_2 ** (RM_Size (Typ) - Expr_Value (Right)),
+                     Static => Static);
+
+               --  Negative signed integer, compute via multiple/divide the
+               --  following:
+               --  (Modulus + X) >> Y + (1 << Y - 1) << (RM_Size - Y) - Modulus
+
+               else
+                  Fold_Uint
+                    (N,
+                     (Modulus + Expr_Value (Left)) / Two_Y
+                        + (Two_Y - Uint_1)
+                          * Uint_2 ** (RM_Size (Typ) - Expr_Value (Right))
+                        - Modulus,
+                     Static => Static);
+               end if;
+            end;
          end if;
       end if;
    end Fold_Shift;