[COMMITTED] ada: Remove the body of System.Storage_Elements
Marc Poulhiès
poulhies@adacore.com
Tue May 23 08:08:26 GMT 2023
From: Eric Botcazou <ebotcazou@adacore.com>
All the subprograms declared in the unit have convention Intrinsic and
their current implementation makes some implicit assumptions that are
not valid universally, so it is replaced by a direct expansion.
This is mostly straightforward because Resolve_Intrinsic_Operator already
contains the required circuitry, but a few adjustements are necessary.
gcc/ada/
* exp_ch4.adb (Expand_N_Op_Mod): Deal with the special mod
operator of System.Storage_Elements.
* exp_intr.adb (Expand_To_Integer): New procedure.
(Expand_Intrinsic_Call): Call Expand_To_Integer appropriately.
(Expand_To_Address): Deal with an argument with modular type.
* sem_ch3.adb (Derive_Subprogram): Also set convention Intrinsic
on a derived intrinsic subprogram.
* sem_res.adb (Resolve_Arithmetic_Op): Deal with intrinsic
operators not coming from source exactly as those coming from
source and also generate a reference in both cases.
(Resolve_Op_Expon): Likewise.
(Resolve_Intrinsic_Operator): Call Implementation_Base_Type to get
a nonprivate base type.
* snames.ads-tmpl (Name_To_Integer): New intrinsic name.
* libgnat/s-stoele.ads: Replace pragma Convention with pragma
Import throughout and remove pragma Inline_Always and
Pure_Function.
* libgnat/s-stoele.adb: Replace entire contents with pragma
No_Body.
* libgnat/s-atacco.adb: Adjust comment about pragma No_Body.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/exp_ch4.adb | 28 +++++++++-
gcc/ada/exp_intr.adb | 27 ++++++++++
gcc/ada/libgnat/s-atacco.adb | 6 +--
gcc/ada/libgnat/s-stoele.adb | 101 ++---------------------------------
gcc/ada/libgnat/s-stoele.ads | 36 +++----------
gcc/ada/sem_ch3.adb | 1 +
gcc/ada/sem_res.adb | 10 ++--
gcc/ada/snames.ads-tmpl | 3 +-
8 files changed, 75 insertions(+), 137 deletions(-)
diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
index 70e779d0406..c974a9e8d44 100644
--- a/gcc/ada/exp_ch4.adb
+++ b/gcc/ada/exp_ch4.adb
@@ -9560,6 +9560,12 @@ package body Exp_Ch4 is
Typ : constant Entity_Id := Etype (N);
DDC : constant Boolean := Do_Division_Check (N);
+ Is_Stoele_Mod : constant Boolean :=
+ Is_RTE (First_Subtype (Typ), RE_Storage_Offset)
+ and then Nkind (Left_Opnd (N)) = N_Unchecked_Type_Conversion
+ and then Is_RTE (Etype (Expression (Left_Opnd (N))), RE_Address);
+ -- True if this is the special mod operator of System.Storage_Elements
+
Left : Node_Id;
Right : Node_Id;
@@ -9593,7 +9599,10 @@ package body Exp_Ch4 is
end if;
end if;
- if Is_Integer_Type (Typ) then
+ -- For the special mod operator of System.Storage_Elements, the checks
+ -- are subsumed into the handling of the negative case below.
+
+ if Is_Integer_Type (Typ) and then not Is_Stoele_Mod then
Apply_Divide_Checks (N);
-- All done if we don't have a MOD any more, which can happen as a
@@ -9663,6 +9672,23 @@ package body Exp_Ch4 is
return;
end if;
+ -- The negative case makes no sense since it is a case of a mod where
+ -- the left argument is unsigned and the right argument is signed. In
+ -- accordance with the (spirit of the) permission of RM 13.7.1(16),
+ -- we raise CE, and also include the zero case here. Yes, the RM says
+ -- PE, but this really is so obviously more like a constraint error.
+
+ if Is_Stoele_Mod and then (not ROK or else Rlo <= 0) then
+ Insert_Action (N,
+ Make_Raise_Constraint_Error (Loc,
+ Condition =>
+ Make_Op_Le (Loc,
+ Left_Opnd => Duplicate_Subexpr_No_Checks (Right),
+ Right_Opnd => Make_Integer_Literal (Loc, 0)),
+ Reason => CE_Overflow_Check_Failed));
+ return;
+ end if;
+
-- If we still have a mod operator and we are in Modify_Tree_For_C
-- mode, and we have a signed integer type, then here is where we do
-- the rewrite in terms of Rem. Note this rewrite bypasses the need
diff --git a/gcc/ada/exp_intr.adb b/gcc/ada/exp_intr.adb
index a1e55882391..2eee892605e 100644
--- a/gcc/ada/exp_intr.adb
+++ b/gcc/ada/exp_intr.adb
@@ -102,6 +102,12 @@ package body Exp_Intr is
-- N_Free_Statement and appropriate context.
procedure Expand_To_Address (N : Node_Id);
+ -- Expand a call to corresponding function from System.Storage_Elements or
+ -- declared in an instance of System.Address_To_Access_Conversions.
+
+ procedure Expand_To_Integer (N : Node_Id);
+ -- Expand a call to corresponding function from System.Storage_Elements
+
procedure Expand_To_Pointer (N : Node_Id);
-- Expand a call to corresponding function, declared in an instance of
-- System.Address_To_Access_Conversions.
@@ -708,6 +714,9 @@ package body Exp_Intr is
elsif Nam = Name_To_Address then
Expand_To_Address (N);
+ elsif Nam = Name_To_Integer then
+ Expand_To_Integer (N);
+
elsif Nam = Name_To_Pointer then
Expand_To_Pointer (N);
@@ -1356,6 +1365,12 @@ package body Exp_Intr is
Obj : Node_Id;
begin
+ if Is_Modular_Integer_Type (Etype (Arg)) then
+ Rewrite (N, Unchecked_Convert_To (Etype (N), Arg));
+ Analyze (N);
+ return;
+ end if;
+
Remove_Side_Effects (Arg);
Obj := Make_Explicit_Dereference (Loc, Relocate_Node (Arg));
@@ -1374,6 +1389,18 @@ package body Exp_Intr is
Analyze_And_Resolve (N, RTE (RE_Address));
end Expand_To_Address;
+ -----------------------
+ -- Expand_To_Integer --
+ -----------------------
+
+ procedure Expand_To_Integer (N : Node_Id) is
+ Arg : constant Node_Id := First_Actual (N);
+
+ begin
+ Rewrite (N, Unchecked_Convert_To (Etype (N), Arg));
+ Analyze (N);
+ end Expand_To_Integer;
+
-----------------------
-- Expand_To_Pointer --
-----------------------
diff --git a/gcc/ada/libgnat/s-atacco.adb b/gcc/ada/libgnat/s-atacco.adb
index a98b25ce184..8c10681ac0c 100644
--- a/gcc/ada/libgnat/s-atacco.adb
+++ b/gcc/ada/libgnat/s-atacco.adb
@@ -29,8 +29,8 @@
-- --
------------------------------------------------------------------------------
--- This package does not require a body, since it is a package renaming. We
--- provide a dummy file containing a No_Body pragma so that previous versions
--- of the body (which did exist) will not interfere.
+-- This package does not require a body. We provide a dummy file containing a
+-- No_Body pragma so that previous versions of the body (which did exist) will
+-- not interfere.
pragma No_Body;
diff --git a/gcc/ada/libgnat/s-stoele.adb b/gcc/ada/libgnat/s-stoele.adb
index e029f510468..dfd1ba36601 100644
--- a/gcc/ada/libgnat/s-stoele.adb
+++ b/gcc/ada/libgnat/s-stoele.adb
@@ -29,101 +29,8 @@
-- --
------------------------------------------------------------------------------
-with Ada.Unchecked_Conversion;
+-- This package does not require a body. We provide a dummy file containing a
+-- No_Body pragma so that previous versions of the body (which did exist) will
+-- not interfere.
-package body System.Storage_Elements is
-
- pragma Suppress (All_Checks);
-
- -- Conversion to/from address
-
- -- Note qualification below of To_Address to avoid ambiguities systems
- -- where Address is a visible integer type.
-
- function To_Address is
- new Ada.Unchecked_Conversion (Storage_Offset, Address);
- function To_Offset is
- new Ada.Unchecked_Conversion (Address, Storage_Offset);
-
- -- Conversion to/from integers
-
- -- These functions must be place first because they are inlined_always
- -- and are used and inlined in other subprograms defined in this unit.
-
- ----------------
- -- To_Address --
- ----------------
-
- function To_Address (Value : Integer_Address) return Address is
- begin
- return Address (Value);
- end To_Address;
-
- ----------------
- -- To_Integer --
- ----------------
-
- function To_Integer (Value : Address) return Integer_Address is
- begin
- return Integer_Address (Value);
- end To_Integer;
-
- -- Address arithmetic
-
- ---------
- -- "+" --
- ---------
-
- function "+" (Left : Address; Right : Storage_Offset) return Address is
- begin
- return Storage_Elements.To_Address
- (To_Integer (Left) + To_Integer (To_Address (Right)));
- end "+";
-
- function "+" (Left : Storage_Offset; Right : Address) return Address is
- begin
- return Storage_Elements.To_Address
- (To_Integer (To_Address (Left)) + To_Integer (Right));
- end "+";
-
- ---------
- -- "-" --
- ---------
-
- function "-" (Left : Address; Right : Storage_Offset) return Address is
- begin
- return Storage_Elements.To_Address
- (To_Integer (Left) - To_Integer (To_Address (Right)));
- end "-";
-
- function "-" (Left, Right : Address) return Storage_Offset is
- begin
- return To_Offset (Storage_Elements.To_Address
- (To_Integer (Left) - To_Integer (Right)));
- end "-";
-
- -----------
- -- "mod" --
- -----------
-
- function "mod"
- (Left : Address;
- Right : Storage_Offset) return Storage_Offset
- is
- begin
- if Right > 0 then
- return Storage_Offset
- (To_Integer (Left) mod Integer_Address (Right));
-
- -- The negative case makes no sense since it is a case of a mod where
- -- the left argument is unsigned and the right argument is signed. In
- -- accordance with the (spirit of the) permission of RM 13.7.1(16),
- -- we raise CE, and also include the zero case here. Yes, the RM says
- -- PE, but this really is so obviously more like a constraint error.
-
- else
- raise Constraint_Error;
- end if;
- end "mod";
-
-end System.Storage_Elements;
+pragma No_Body;
diff --git a/gcc/ada/libgnat/s-stoele.ads b/gcc/ada/libgnat/s-stoele.ads
index 9fd31e7d030..99a195a1338 100644
--- a/gcc/ada/libgnat/s-stoele.ads
+++ b/gcc/ada/libgnat/s-stoele.ads
@@ -45,12 +45,6 @@ package System.Storage_Elements is
pragma Annotate (GNATprove, Always_Return, Storage_Elements);
- -- We also add the pragma Pure_Function to the operations in this package,
- -- because otherwise functions with parameters derived from Address are
- -- treated as non-pure by the back-end (see exp_ch6.adb). This is because
- -- in many cases such a parameter is used to hide read/out access to
- -- objects, and it would be unsafe to treat such functions as pure.
-
type Storage_Offset is range
-(2 ** (Integer'(Standard'Address_Size) - 1)) ..
+(2 ** (Integer'(Standard'Address_Size) - 1)) - Long_Long_Integer'(1);
@@ -73,44 +67,26 @@ package System.Storage_Elements is
-- Address arithmetic
function "+" (Left : Address; Right : Storage_Offset) return Address;
- pragma Convention (Intrinsic, "+");
- pragma Inline_Always ("+");
- pragma Pure_Function ("+");
-
function "+" (Left : Storage_Offset; Right : Address) return Address;
- pragma Convention (Intrinsic, "+");
- pragma Inline_Always ("+");
- pragma Pure_Function ("+");
+ pragma Import (Intrinsic, "+");
function "-" (Left : Address; Right : Storage_Offset) return Address;
- pragma Convention (Intrinsic, "-");
- pragma Inline_Always ("-");
- pragma Pure_Function ("-");
-
function "-" (Left, Right : Address) return Storage_Offset;
- pragma Convention (Intrinsic, "-");
- pragma Inline_Always ("-");
- pragma Pure_Function ("-");
+ pragma Import (Intrinsic, "-");
function "mod"
(Left : Address;
- Right : Storage_Offset) return Storage_Offset;
- pragma Convention (Intrinsic, "mod");
- pragma Inline_Always ("mod");
- pragma Pure_Function ("mod");
+ Right : Storage_Offset) return Storage_Offset;
+ pragma Import (Intrinsic, "mod");
-- Conversion to/from integers
type Integer_Address is mod Memory_Size;
function To_Address (Value : Integer_Address) return Address;
- pragma Convention (Intrinsic, To_Address);
- pragma Inline_Always (To_Address);
- pragma Pure_Function (To_Address);
+ pragma Import (Intrinsic, To_Address);
function To_Integer (Value : Address) return Integer_Address;
- pragma Convention (Intrinsic, To_Integer);
- pragma Inline_Always (To_Integer);
- pragma Pure_Function (To_Integer);
+ pragma Import (Intrinsic, To_Integer);
end System.Storage_Elements;
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index bace2cf616a..50ccb390363 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -16206,6 +16206,7 @@ package body Sem_Ch3 is
if No (Actual_Subp) then
if Is_Intrinsic_Subprogram (Parent_Subp) then
+ Set_Convention (New_Subp, Convention_Intrinsic);
Set_Is_Intrinsic_Subprogram (New_Subp);
if Present (Alias (Parent_Subp))
diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index 365c75041a9..a99bed00118 100644
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -6037,11 +6037,11 @@ package body Sem_Res is
-- Start of processing for Resolve_Arithmetic_Op
begin
- if Comes_From_Source (N)
- and then Ekind (Entity (N)) = E_Function
+ if Ekind (Entity (N)) = E_Function
and then Is_Imported (Entity (N))
and then Is_Intrinsic_Subprogram (Entity (N))
then
+ Generate_Reference (Entity (N), N);
Resolve_Intrinsic_Operator (N, Typ);
return;
@@ -9710,7 +9710,7 @@ package body Sem_Res is
--------------------------------
procedure Resolve_Intrinsic_Operator (N : Node_Id; Typ : Entity_Id) is
- Btyp : constant Entity_Id := Base_Type (Underlying_Type (Typ));
+ Btyp : constant Entity_Id := Implementation_Base_Type (Typ);
Op : Entity_Id;
Arg1 : Node_Id;
Arg2 : Node_Id;
@@ -10641,11 +10641,11 @@ package body Sem_Res is
end if;
end if;
- if Comes_From_Source (N)
- and then Ekind (Entity (N)) = E_Function
+ if Ekind (Entity (N)) = E_Function
and then Is_Imported (Entity (N))
and then Is_Intrinsic_Subprogram (Entity (N))
then
+ Generate_Reference (Entity (N), N);
Resolve_Intrinsic_Operator (N, Typ);
return;
end if;
diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl
index afe7508ac28..cf2efbbbb63 100644
--- a/gcc/ada/snames.ads-tmpl
+++ b/gcc/ada/snames.ads-tmpl
@@ -1337,9 +1337,10 @@ package Snames is
Name_Shift_Right : constant Name_Id := N + $;
Name_Shift_Right_Arithmetic : constant Name_Id := N + $;
Name_Source_Location : constant Name_Id := N + $;
+ Name_To_Integer : constant Name_Id := N + $;
+ Name_To_Pointer : constant Name_Id := N + $;
Name_Unchecked_Conversion : constant Name_Id := N + $;
Name_Unchecked_Deallocation : constant Name_Id := N + $;
- Name_To_Pointer : constant Name_Id := N + $;
Last_Intrinsic_Name : constant Name_Id := N + $;
-- Names used in processing intrinsic calls
--
2.40.0
More information about the Gcc-patches
mailing list