* [COMMITTED 01/30] ada: Rework and augment documentation on strict aliasing
@ 2024-05-20 7:48 Marc Poulhiès
2024-05-20 7:48 ` [COMMITTED 02/30] ada: Small cleanup in System.Finalization_Primitives unit Marc Poulhiès
` (28 more replies)
0 siblings, 29 replies; 30+ messages in thread
From: Marc Poulhiès @ 2024-05-20 7:48 UTC (permalink / raw)
To: gcc-patches; +Cc: Eric Botcazou
From: Eric Botcazou <ebotcazou@adacore.com>
The documentation was originally centered around pragma No_Strict_Aliasing
and pragma Universal_Aliasing was mentioned only as an afterthought. It
also contained a warning about the usage of overlays implemented by means
of address clauses that has been obsolete for long.
gcc/ada/
* doc/gnat_rm/implementation_defined_pragmas.rst
(Universal_Aliasing): Remove reference to No_Strict_Aliasing.
* doc/gnat_ugn/gnat_and_program_execution.rst
(Optimization and Strict Aliasinng): Simplify first example and
make it more consistent with the second. Add description of the
effects of pragma Universal_Aliasing and document new warning
issued for unchecked conversions. Remove obsolete stuff.
* gnat_rm.texi: Regenerate.
* gnat_ugn.texi: Regenerate.
Tested on x86_64-pc-linux-gnu, committed on master.
---
.../implementation_defined_pragmas.rst | 7 +-
.../gnat_ugn/gnat_and_program_execution.rst | 296 +++++++++--------
gcc/ada/gnat_rm.texi | 7 +-
gcc/ada/gnat_ugn.texi | 306 ++++++++++--------
4 files changed, 353 insertions(+), 263 deletions(-)
diff --git a/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst b/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst
index 7f221e32344..bcbd85984dc 100644
--- a/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst
+++ b/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst
@@ -6949,10 +6949,9 @@ Syntax:
``type_LOCAL_NAME`` must refer to a type declaration in the current
declarative part. The effect is to inhibit strict type-based aliasing
-optimization for the given type. In other words, the effect is as though
-access types designating this type were subject to pragma No_Strict_Aliasing.
-For a detailed description of the strict aliasing optimization, and the
-situations in which it must be suppressed, see the section on
+optimizations for the given type. For a detailed description of the
+strict type-based aliasing optimizations and the situations in which
+they need to be suppressed, see the section on
``Optimization and Strict Aliasing`` in the :title:`GNAT User's Guide`.
.. _Pragma-Unmodified:
diff --git a/gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst b/gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst
index 35e34772658..d502da87eb0 100644
--- a/gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst
+++ b/gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst
@@ -2072,37 +2072,36 @@ the following example:
.. code-block:: ada
- procedure R is
+ procedure M is
type Int1 is new Integer;
+ I1 : Int1;
+
type Int2 is new Integer;
- type Int1A is access Int1;
- type Int2A is access Int2;
- Int1V : Int1A;
- Int2V : Int2A;
+ type A2 is access Int2;
+ V2 : A2;
...
begin
...
for J in Data'Range loop
- if Data (J) = Int1V.all then
- Int2V.all := Int2V.all + 1;
+ if Data (J) = I1 then
+ V2.all := V2.all + 1;
end if;
end loop;
...
- end R;
+ end;
-In this example, since the variable ``Int1V`` can only access objects
-of type ``Int1``, and ``Int2V`` can only access objects of type
-``Int2``, there is no possibility that the assignment to
-``Int2V.all`` affects the value of ``Int1V.all``. This means that
-the compiler optimizer can "know" that the value ``Int1V.all`` is constant
-for all iterations of the loop and avoid the extra memory reference
-required to dereference it each time through the loop.
+In this example, since ``V2`` can only access objects of type ``Int2``
+and ``I1`` is not one of them, there is no possibility that the assignment
+to ``V2.all`` affects the value of ``I1``. This means that the compiler
+optimizer can infer that the value ``I1`` is constant for all iterations
+of the loop and load it from memory only once, before entering the loop,
+instead of in every iteration (this is called load hoisting).
-This kind of optimization, called strict aliasing analysis, is
+This kind of optimizations, based on strict type-based aliasing, is
triggered by specifying an optimization level of :switch:`-O2` or
-higher or :switch:`-Os` and allows GNAT to generate more efficient code
-when access values are involved.
+higher (or :switch:`-Os`) and allows the compiler to generate more
+efficient code.
However, although this optimization is always correct in terms of
the formal semantics of the Ada Reference Manual, difficulties can
@@ -2111,173 +2110,214 @@ the typing system. Consider the following complete program example:
.. code-block:: ada
- package p1 is
- type int1 is new integer;
- type int2 is new integer;
- type a1 is access int1;
- type a2 is access int2;
- end p1;
+ package P1 is
+ type Int1 is new Integer;
+ type A1 is access Int1;
+
+ type Int2 is new Integer;
+ type A2 is access Int2;
+ end P1;
- with p1; use p1;
- package p2 is
- function to_a2 (Input : a1) return a2;
+ with P1; use P1;
+ package P2 is
+ function To_A2 (Input : A1) return A2;
end p2;
with Ada.Unchecked_Conversion;
- package body p2 is
- function to_a2 (Input : a1) return a2 is
- function to_a2u is
- new Ada.Unchecked_Conversion (a1, a2);
+ package body P2 is
+ function To_A2 (Input : A1) return A2 is
+ function Conv is
+ new Ada.Unchecked_Conversion (A1, A2);
begin
- return to_a2u (Input);
- end to_a2;
- end p2;
+ return Conv (Input);
+ end To_A2;
+ end P2;
- with p2; use p2;
- with p1; use p1;
+ with P1; use P1;
+ with P2; use P2;
with Text_IO; use Text_IO;
- procedure m is
- v1 : a1 := new int1;
- v2 : a2 := to_a2 (v1);
+ procedure M is
+ V1 : A1 := new Int1;
+ V2 : A2 := To_A2 (V1);
begin
- v1.all := 1;
- v2.all := 0;
- put_line (int1'image (v1.all));
+ V1.all := 1;
+ V2.all := 0;
+ Put_Line (Int1'Image (V1.all));
end;
-This program prints out 0 in :switch:`-O0` or :switch:`-O1`
-mode, but it prints out 1 in :switch:`-O2` mode. That's
-because in strict aliasing mode, the compiler can and
-does assume that the assignment to ``v2.all`` could not
-affect the value of ``v1.all``, since different types
-are involved.
+This program prints out ``0`` in :switch:`-O0` or :switch:`-O1` modes,
+but it prints out ``1`` in :switch:`-O2` mode. That's because in strict
+aliasing mode, the compiler may and does assume that the assignment to
+``V2.all`` could not affect the value of ``V1.all``, since different
+types are involved.
This behavior is not a case of non-conformance with the standard, since
the Ada RM specifies that an unchecked conversion where the resulting
bit pattern is not a correct value of the target type can result in an
abnormal value and attempting to reference an abnormal value makes the
execution of a program erroneous. That's the case here since the result
-does not point to an object of type ``int2``. This means that the
-effect is entirely unpredictable.
+does not point to an object of type ``Int2``. This means that the effect
+is entirely unpredictable.
-However, although that explanation may satisfy a language
-lawyer, in practice an applications programmer expects an
-unchecked conversion involving pointers to create true
-aliases and the behavior of printing 1 seems plain wrong.
-In this case, the strict aliasing optimization is unwelcome.
+However, although that explanation may satisfy a language lawyer, in
+practice an application programmer expects an unchecked conversion
+involving pointers to create true aliases and the behavior of printing
+``1`` is questionable. In this case, the strict type-based aliasing
+optimizations are clearly unwelcome.
-Indeed the compiler recognizes this possibility, and the
-unchecked conversion generates a warning:
+Indeed the compiler recognizes this possibility and the instantiation of
+Unchecked_Conversion generates a warning:
::
- p2.adb:5:07: warning: possible aliasing problem with type "a2"
+ p2.adb:5:07: warning: possible aliasing problem with type "A2"
p2.adb:5:07: warning: use -fno-strict-aliasing switch for references
- p2.adb:5:07: warning: or use "pragma No_Strict_Aliasing (a2);"
+ p2.adb:5:07: warning: or use "pragma No_Strict_Aliasing (A2);"
-Unfortunately the problem is recognized when compiling the body of
-package ``p2``, but the actual "bad" code is generated while
-compiling the body of ``m`` and this latter compilation does not see
-the suspicious ``Unchecked_Conversion``.
+Unfortunately the problem is only recognized when compiling the body of
+package ``P2``, but the actual problematic code is generated while
+compiling the body of ``M`` and this latter compilation does not see
+the suspicious instance of ``Unchecked_Conversion``.
As implied by the warning message, there are approaches you can use to
-avoid the unwanted strict aliasing optimization in a case like this.
+avoid the unwanted strict aliasing optimizations in a case like this.
One possibility is to simply avoid the use of :switch:`-O2`, but
-that is a bit drastic, since it throws away a number of useful
+that is quite drastic, since it throws away a number of useful
optimizations that do not involve strict aliasing assumptions.
A less drastic approach is to compile the program using the
option :switch:`-fno-strict-aliasing`. Actually it is only the
unit containing the dereferencing of the suspicious pointer
that needs to be compiled. So in this case, if we compile
-unit ``m`` with this switch, then we get the expected
+unit ``M`` with this switch, then we get the expected
value of zero printed. Analyzing which units might need
the switch can be painful, so a more reasonable approach
is to compile the entire program with options :switch:`-O2`
and :switch:`-fno-strict-aliasing`. If the performance is
satisfactory with this combination of options, then the
-advantage is that the entire issue of possible "wrong"
-optimization due to strict aliasing is avoided.
+advantage is that the entire issue of possible problematic
+optimizations due to strict aliasing is avoided.
To avoid the use of compiler switches, the configuration
pragma ``No_Strict_Aliasing`` with no parameters may be
used to specify that for all access types, the strict
-aliasing optimization should be suppressed.
+aliasing optimizations should be suppressed.
-However, these approaches are still overkill, in that they causes
+However, these approaches are still overkill, in that they cause
all manipulations of all access values to be deoptimized. A more
refined approach is to concentrate attention on the specific
access type identified as problematic.
-First, if a careful analysis of uses of the pointer shows
-that there are no possible problematic references, then
-the warning can be suppressed by bracketing the
-instantiation of ``Unchecked_Conversion`` to turn
-the warning off:
+The first possibility is to move the instantiation of unchecked
+conversion to the unit in which the type is declared. In this
+example, we would move the instantiation of ``Unchecked_Conversion``
+from the body of package ``P2`` to the spec of package ``P1``.
+Now the warning disappears because any use of the access type
+knows there is a suspicious unchecked conversion, and the strict
+aliasing optimizations are automatically suppressed for it.
+
+If it is not practical to move the unchecked conversion to the same unit
+in which the destination access type is declared (perhaps because the
+source type is not visible in that unit), the second possibiliy is to
+use pragma ``No_Strict_Aliasing`` for the type. This pragma must occur
+in the same declarative part as the declaration of the access type:
.. code-block:: ada
- pragma Warnings (Off);
- function to_a2u is
- new Ada.Unchecked_Conversion (a1, a2);
- pragma Warnings (On);
+ type A2 is access Int2;
+ pragma No_Strict_Aliasing (A2);
-Of course that approach is not appropriate for this particular
-example, since indeed there is a problematic reference. In this
-case we can take one of two other approaches.
+Here again, the compiler now knows that strict aliasing optimizations
+should be suppressed for any dereference made through type ``A2`` and
+the expected behavior is obtained.
-The first possibility is to move the instantiation of unchecked
-conversion to the unit in which the type is declared. In
-this example, we would move the instantiation of
-``Unchecked_Conversion`` from the body of package
-``p2`` to the spec of package ``p1``. Now the
-warning disappears. That's because any use of the
-access type knows there is a suspicious unchecked
-conversion, and the strict aliasing optimization
-is automatically suppressed for the type.
-
-If it is not practical to move the unchecked conversion to the same unit
-in which the destination access type is declared (perhaps because the
-source type is not visible in that unit), you may use pragma
-``No_Strict_Aliasing`` for the type. This pragma must occur in the
-same declarative sequence as the declaration of the access type:
+The third possibility is to declare that one of the designated types
+involved, namely ``Int1`` or ``Int2``, is allowed to alias any other
+type in the universe, by using pragma ``Universal_Aliasing``:
.. code-block:: ada
- type a2 is access int2;
- pragma No_Strict_Aliasing (a2);
-
-Here again, the compiler now knows that the strict aliasing optimization
-should be suppressed for any reference to type ``a2`` and the
-expected behavior is obtained.
-
-Finally, note that although the compiler can generate warnings for
-simple cases of unchecked conversions, there are tricker and more
-indirect ways of creating type incorrect aliases which the compiler
-cannot detect. Examples are the use of address overlays and unchecked
-conversions involving composite types containing access types as
-components. In such cases, no warnings are generated, but there can
-still be aliasing problems. One safe coding practice is to forbid the
-use of address clauses for type overlaying, and to allow unchecked
-conversion only for primitive types. This is not really a significant
-restriction since any possible desired effect can be achieved by
-unchecked conversion of access values.
-
-The aliasing analysis done in strict aliasing mode can certainly
-have significant benefits. We have seen cases of large scale
-application code where the time is increased by up to 5% by turning
-this optimization off. If you have code that includes significant
-usage of unchecked conversion, you might want to just stick with
-:switch:`-O1` and avoid the entire issue. If you get adequate
-performance at this level of optimization level, that's probably
-the safest approach. If tests show that you really need higher
-levels of optimization, then you can experiment with :switch:`-O2`
-and :switch:`-O2 -fno-strict-aliasing` to see how much effect this
+ type Int2 is new Integer;
+ pragma Universal_Aliasing (Int2);
+
+The effect is equivalent to applying pragma ``No_Strict_Aliasing`` to
+every access type designating ``Int2``, in particular ``A2``, and more
+generally to every reference made to an object of declared type ``Int2``,
+so it is very powerful and effectively takes ``Int2`` out of the alias
+analysis performed by the compiler in all circumstances.
+
+This pragma can also be used to deal with aliasing issues that arise
+again from the use of ``Unchecked_Conversion`` in the source code but
+without the presence of access types. The typical example is code
+that streams data by means of arrays of storage units (bytes):
+
+ .. code-block:: ada
+
+ type Byte is mod 2**System.Storage_Unit;
+ for Byte'Size use System.Storage_Unit;
+
+ type Chunk_Of_Bytes is array (1 .. 64) of Byte;
+
+ procedure Send (S : Chunk_Of_Bytes);
+
+ type Rec is record
+ ...
+ end record;
+
+ procedure Dump (R : Rec) is
+ function To_Stream is
+ new Ada.Unchecked_Conversion (Rec, Chunk_Of_Bytes);
+ begin
+ Send (To_Stream (R));
+ end;
+
+This generates the following warning for the call to ``Send``:
+
+ ::
+
+ dump.adb:8:25: warning: unchecked conversion implemented by copy
+ dump.adb:8:25: warning: use pragma Universal_Aliasing on either type
+ dump.adb:8:25: warning: to enable RM 13.9(12) implementation permission
+
+This occurs because the formal parameter ``S`` of ``Send`` is passed by
+reference by the compiler and it is not possible to pass a reference to
+``R`` directly in the call without violating strict type-based aliasing.
+That's why the compiler generates a temporary of type ``Chunk_Of_Bytes``
+just before the call and passes a reference to this temporary instead.
+
+As implied by the warning message, it is possible to avoid the temporary
+(and the warning) by means of pragma ``Universal_Aliasing``:
+
+ .. code-block:: ada
+
+ type Chunk_Of_Bytes is array (1 .. 64) of Byte;
+ pragma Universal_Aliasing (Chunk_Of_Bytes);
+
+The pragma can also be applied to the component type instead:
+
+ .. code-block:: ada
+
+ type Byte is mod 2**System.Storage_Unit;
+ for Byte'Size use System.Storage_Unit;
+ pragma Universal_Aliasing (Byte);
+
+and every array type whose component is ``Byte`` will inherit the pragma.
+
+To sum up, the alias analysis performed in strict aliasing mode by the
+compiler can have significant benefits. We have seen cases of large scale
+application code where the execution time is increased by up to 5% when
+these optimizations are turned off. However, if you have code that make
+significant use of unchecked conversion, you might want to just stick
+with :switch:`-O1` and avoid the entire issue. If you get adequate
+performance at this level of optimization, that's probably the safest
+approach. If tests show that you really need higher levels of
+optimization, then you can experiment with :switch:`-O2` and
+:switch:`-O2 -fno-strict-aliasing` to see how much effect this
has on size and speed of the code. If you really need to use
:switch:`-O2` with strict aliasing in effect, then you should
-review any uses of unchecked conversion of access types,
-particularly if you are getting the warnings described above.
+review any uses of unchecked conversion, particularly if you are
+getting the warnings described above.
.. _Aliased_Variables_and_Optimization:
diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi
index 8dcdd6ca14c..40516121b7a 100644
--- a/gcc/ada/gnat_rm.texi
+++ b/gcc/ada/gnat_rm.texi
@@ -8497,10 +8497,9 @@ pragma Universal_Aliasing [([Entity =>] type_LOCAL_NAME)];
@code{type_LOCAL_NAME} must refer to a type declaration in the current
declarative part. The effect is to inhibit strict type-based aliasing
-optimization for the given type. In other words, the effect is as though
-access types designating this type were subject to pragma No_Strict_Aliasing.
-For a detailed description of the strict aliasing optimization, and the
-situations in which it must be suppressed, see the section on
+optimizations for the given type. For a detailed description of the
+strict type-based aliasing optimizations and the situations in which
+they need to be suppressed, see the section on
@code{Optimization and Strict Aliasing} in the @cite{GNAT User’s Guide}.
@node Pragma Unmodified,Pragma Unreferenced,Pragma Universal_Aliasing,Implementation Defined Pragmas
diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi
index 7bad8b4e161..ebc10288c20 100644
--- a/gcc/ada/gnat_ugn.texi
+++ b/gcc/ada/gnat_ugn.texi
@@ -20716,39 +20716,38 @@ the following example:
@quotation
@example
-procedure R is
+procedure M is
type Int1 is new Integer;
+ I1 : Int1;
+
type Int2 is new Integer;
- type Int1A is access Int1;
- type Int2A is access Int2;
- Int1V : Int1A;
- Int2V : Int2A;
+ type A2 is access Int2;
+ V2 : A2;
...
begin
...
for J in Data'Range loop
- if Data (J) = Int1V.all then
- Int2V.all := Int2V.all + 1;
+ if Data (J) = I1 then
+ V2.all := V2.all + 1;
end if;
end loop;
...
-end R;
+end;
@end example
@end quotation
-In this example, since the variable @code{Int1V} can only access objects
-of type @code{Int1}, and @code{Int2V} can only access objects of type
-@code{Int2}, there is no possibility that the assignment to
-@code{Int2V.all} affects the value of @code{Int1V.all}. This means that
-the compiler optimizer can “know” that the value @code{Int1V.all} is constant
-for all iterations of the loop and avoid the extra memory reference
-required to dereference it each time through the loop.
+In this example, since @code{V2} can only access objects of type @code{Int2}
+and @code{I1} is not one of them, there is no possibility that the assignment
+to @code{V2.all} affects the value of @code{I1}. This means that the compiler
+optimizer can infer that the value @code{I1} is constant for all iterations
+of the loop and load it from memory only once, before entering the loop,
+instead of in every iteration (this is called load hoisting).
-This kind of optimization, called strict aliasing analysis, is
+This kind of optimizations, based on strict type-based aliasing, is
triggered by specifying an optimization level of @code{-O2} or
-higher or @code{-Os} and allows GNAT to generate more efficient code
-when access values are involved.
+higher (or @code{-Os}) and allows the compiler to generate more
+efficient code.
However, although this optimization is always correct in terms of
the formal semantics of the Ada Reference Manual, difficulties can
@@ -20758,184 +20757,237 @@ the typing system. Consider the following complete program example:
@quotation
@example
-package p1 is
- type int1 is new integer;
- type int2 is new integer;
- type a1 is access int1;
- type a2 is access int2;
-end p1;
+package P1 is
+ type Int1 is new Integer;
+ type A1 is access Int1;
-with p1; use p1;
-package p2 is
- function to_a2 (Input : a1) return a2;
+ type Int2 is new Integer;
+ type A2 is access Int2;
+end P1;
+
+with P1; use P1;
+package P2 is
+ function To_A2 (Input : A1) return A2;
end p2;
with Ada.Unchecked_Conversion;
-package body p2 is
- function to_a2 (Input : a1) return a2 is
- function to_a2u is
- new Ada.Unchecked_Conversion (a1, a2);
+package body P2 is
+ function To_A2 (Input : A1) return A2 is
+ function Conv is
+ new Ada.Unchecked_Conversion (A1, A2);
begin
- return to_a2u (Input);
- end to_a2;
-end p2;
+ return Conv (Input);
+ end To_A2;
+end P2;
-with p2; use p2;
-with p1; use p1;
+with P1; use P1;
+with P2; use P2;
with Text_IO; use Text_IO;
-procedure m is
- v1 : a1 := new int1;
- v2 : a2 := to_a2 (v1);
+procedure M is
+ V1 : A1 := new Int1;
+ V2 : A2 := To_A2 (V1);
begin
- v1.all := 1;
- v2.all := 0;
- put_line (int1'image (v1.all));
+ V1.all := 1;
+ V2.all := 0;
+ Put_Line (Int1'Image (V1.all));
end;
@end example
@end quotation
-This program prints out 0 in @code{-O0} or @code{-O1}
-mode, but it prints out 1 in @code{-O2} mode. That’s
-because in strict aliasing mode, the compiler can and
-does assume that the assignment to @code{v2.all} could not
-affect the value of @code{v1.all}, since different types
-are involved.
+This program prints out @code{0} in @code{-O0} or @code{-O1} modes,
+but it prints out @code{1} in @code{-O2} mode. That’s because in strict
+aliasing mode, the compiler may and does assume that the assignment to
+@code{V2.all} could not affect the value of @code{V1.all}, since different
+types are involved.
This behavior is not a case of non-conformance with the standard, since
the Ada RM specifies that an unchecked conversion where the resulting
bit pattern is not a correct value of the target type can result in an
abnormal value and attempting to reference an abnormal value makes the
execution of a program erroneous. That’s the case here since the result
-does not point to an object of type @code{int2}. This means that the
-effect is entirely unpredictable.
+does not point to an object of type @code{Int2}. This means that the effect
+is entirely unpredictable.
-However, although that explanation may satisfy a language
-lawyer, in practice an applications programmer expects an
-unchecked conversion involving pointers to create true
-aliases and the behavior of printing 1 seems plain wrong.
-In this case, the strict aliasing optimization is unwelcome.
+However, although that explanation may satisfy a language lawyer, in
+practice an application programmer expects an unchecked conversion
+involving pointers to create true aliases and the behavior of printing
+@code{1} is questionable. In this case, the strict type-based aliasing
+optimizations are clearly unwelcome.
-Indeed the compiler recognizes this possibility, and the
-unchecked conversion generates a warning:
+Indeed the compiler recognizes this possibility and the instantiation of
+Unchecked_Conversion generates a warning:
@quotation
@example
-p2.adb:5:07: warning: possible aliasing problem with type "a2"
+p2.adb:5:07: warning: possible aliasing problem with type "A2"
p2.adb:5:07: warning: use -fno-strict-aliasing switch for references
-p2.adb:5:07: warning: or use "pragma No_Strict_Aliasing (a2);"
+p2.adb:5:07: warning: or use "pragma No_Strict_Aliasing (A2);"
@end example
@end quotation
-Unfortunately the problem is recognized when compiling the body of
-package @code{p2}, but the actual “bad” code is generated while
-compiling the body of @code{m} and this latter compilation does not see
-the suspicious @code{Unchecked_Conversion}.
+Unfortunately the problem is only recognized when compiling the body of
+package @code{P2}, but the actual problematic code is generated while
+compiling the body of @code{M} and this latter compilation does not see
+the suspicious instance of @code{Unchecked_Conversion}.
As implied by the warning message, there are approaches you can use to
-avoid the unwanted strict aliasing optimization in a case like this.
+avoid the unwanted strict aliasing optimizations in a case like this.
One possibility is to simply avoid the use of @code{-O2}, but
-that is a bit drastic, since it throws away a number of useful
+that is quite drastic, since it throws away a number of useful
optimizations that do not involve strict aliasing assumptions.
A less drastic approach is to compile the program using the
option @code{-fno-strict-aliasing}. Actually it is only the
unit containing the dereferencing of the suspicious pointer
that needs to be compiled. So in this case, if we compile
-unit @code{m} with this switch, then we get the expected
+unit @code{M} with this switch, then we get the expected
value of zero printed. Analyzing which units might need
the switch can be painful, so a more reasonable approach
is to compile the entire program with options @code{-O2}
and @code{-fno-strict-aliasing}. If the performance is
satisfactory with this combination of options, then the
-advantage is that the entire issue of possible “wrong”
-optimization due to strict aliasing is avoided.
+advantage is that the entire issue of possible problematic
+optimizations due to strict aliasing is avoided.
To avoid the use of compiler switches, the configuration
pragma @code{No_Strict_Aliasing} with no parameters may be
used to specify that for all access types, the strict
-aliasing optimization should be suppressed.
+aliasing optimizations should be suppressed.
-However, these approaches are still overkill, in that they causes
+However, these approaches are still overkill, in that they cause
all manipulations of all access values to be deoptimized. A more
refined approach is to concentrate attention on the specific
access type identified as problematic.
-First, if a careful analysis of uses of the pointer shows
-that there are no possible problematic references, then
-the warning can be suppressed by bracketing the
-instantiation of @code{Unchecked_Conversion} to turn
-the warning off:
+The first possibility is to move the instantiation of unchecked
+conversion to the unit in which the type is declared. In this
+example, we would move the instantiation of @code{Unchecked_Conversion}
+from the body of package @code{P2} to the spec of package @code{P1}.
+Now the warning disappears because any use of the access type
+knows there is a suspicious unchecked conversion, and the strict
+aliasing optimizations are automatically suppressed for it.
+
+If it is not practical to move the unchecked conversion to the same unit
+in which the destination access type is declared (perhaps because the
+source type is not visible in that unit), the second possibiliy is to
+use pragma @code{No_Strict_Aliasing} for the type. This pragma must occur
+in the same declarative part as the declaration of the access type:
@quotation
@example
-pragma Warnings (Off);
-function to_a2u is
- new Ada.Unchecked_Conversion (a1, a2);
-pragma Warnings (On);
+type A2 is access Int2;
+pragma No_Strict_Aliasing (A2);
@end example
@end quotation
-Of course that approach is not appropriate for this particular
-example, since indeed there is a problematic reference. In this
-case we can take one of two other approaches.
+Here again, the compiler now knows that strict aliasing optimizations
+should be suppressed for any dereference made through type @code{A2} and
+the expected behavior is obtained.
-The first possibility is to move the instantiation of unchecked
-conversion to the unit in which the type is declared. In
-this example, we would move the instantiation of
-@code{Unchecked_Conversion} from the body of package
-@code{p2} to the spec of package @code{p1}. Now the
-warning disappears. That’s because any use of the
-access type knows there is a suspicious unchecked
-conversion, and the strict aliasing optimization
-is automatically suppressed for the type.
+The third possibility is to declare that one of the designated types
+involved, namely @code{Int1} or @code{Int2}, is allowed to alias any other
+type in the universe, by using pragma @code{Universal_Aliasing}:
-If it is not practical to move the unchecked conversion to the same unit
-in which the destination access type is declared (perhaps because the
-source type is not visible in that unit), you may use pragma
-@code{No_Strict_Aliasing} for the type. This pragma must occur in the
-same declarative sequence as the declaration of the access type:
+@quotation
+
+@example
+type Int2 is new Integer;
+pragma Universal_Aliasing (Int2);
+@end example
+@end quotation
+
+The effect is equivalent to applying pragma @code{No_Strict_Aliasing} to
+every access type designating @code{Int2}, in particular @code{A2}, and more
+generally to every reference made to an object of declared type @code{Int2},
+so it is very powerful and effectively takes @code{Int2} out of the alias
+analysis performed by the compiler in all circumstances.
+
+This pragma can also be used to deal with aliasing issues that arise
+again from the use of @code{Unchecked_Conversion} in the source code but
+without the presence of access types. The typical example is code
+that streams data by means of arrays of storage units (bytes):
@quotation
@example
-type a2 is access int2;
-pragma No_Strict_Aliasing (a2);
+type Byte is mod 2**System.Storage_Unit;
+for Byte'Size use System.Storage_Unit;
+
+type Chunk_Of_Bytes is array (1 .. 64) of Byte;
+
+procedure Send (S : Chunk_Of_Bytes);
+
+type Rec is record
+ ...
+end record;
+
+procedure Dump (R : Rec) is
+ function To_Stream is
+ new Ada.Unchecked_Conversion (Rec, Chunk_Of_Bytes);
+begin
+ Send (To_Stream (R));
+end;
+@end example
+@end quotation
+
+This generates the following warning for the call to @code{Send}:
+
+@quotation
+
+@example
+dump.adb:8:25: warning: unchecked conversion implemented by copy
+dump.adb:8:25: warning: use pragma Universal_Aliasing on either type
+dump.adb:8:25: warning: to enable RM 13.9(12) implementation permission
+@end example
+@end quotation
+
+This occurs because the formal parameter @code{S} of @code{Send} is passed by
+reference by the compiler and it is not possible to pass a reference to
+@code{R} directly in the call without violating strict type-based aliasing.
+That’s why the compiler generates a temporary of type @code{Chunk_Of_Bytes}
+just before the call and passes a reference to this temporary instead.
+
+As implied by the warning message, it is possible to avoid the temporary
+(and the warning) by means of pragma @code{Universal_Aliasing}:
+
+@quotation
+
+@example
+type Chunk_Of_Bytes is array (1 .. 64) of Byte;
+pragma Universal_Aliasing (Chunk_Of_Bytes);
@end example
@end quotation
-Here again, the compiler now knows that the strict aliasing optimization
-should be suppressed for any reference to type @code{a2} and the
-expected behavior is obtained.
-
-Finally, note that although the compiler can generate warnings for
-simple cases of unchecked conversions, there are tricker and more
-indirect ways of creating type incorrect aliases which the compiler
-cannot detect. Examples are the use of address overlays and unchecked
-conversions involving composite types containing access types as
-components. In such cases, no warnings are generated, but there can
-still be aliasing problems. One safe coding practice is to forbid the
-use of address clauses for type overlaying, and to allow unchecked
-conversion only for primitive types. This is not really a significant
-restriction since any possible desired effect can be achieved by
-unchecked conversion of access values.
-
-The aliasing analysis done in strict aliasing mode can certainly
-have significant benefits. We have seen cases of large scale
-application code where the time is increased by up to 5% by turning
-this optimization off. If you have code that includes significant
-usage of unchecked conversion, you might want to just stick with
-@code{-O1} and avoid the entire issue. If you get adequate
-performance at this level of optimization level, that’s probably
-the safest approach. If tests show that you really need higher
-levels of optimization, then you can experiment with @code{-O2}
-and @code{-O2 -fno-strict-aliasing} to see how much effect this
+The pragma can also be applied to the component type instead:
+
+@quotation
+
+@example
+type Byte is mod 2**System.Storage_Unit;
+for Byte'Size use System.Storage_Unit;
+pragma Universal_Aliasing (Byte);
+@end example
+@end quotation
+
+and every array type whose component is @code{Byte} will inherit the pragma.
+
+To sum up, the alias analysis performed in strict aliasing mode by the
+compiler can have significant benefits. We have seen cases of large scale
+application code where the execution time is increased by up to 5% when
+these optimizations are turned off. However, if you have code that make
+significant use of unchecked conversion, you might want to just stick
+with @code{-O1} and avoid the entire issue. If you get adequate
+performance at this level of optimization, that’s probably the safest
+approach. If tests show that you really need higher levels of
+optimization, then you can experiment with @code{-O2} and
+@code{-O2 -fno-strict-aliasing} to see how much effect this
has on size and speed of the code. If you really need to use
@code{-O2} with strict aliasing in effect, then you should
-review any uses of unchecked conversion of access types,
-particularly if you are getting the warnings described above.
+review any uses of unchecked conversion, particularly if you are
+getting the warnings described above.
@node Aliased Variables and Optimization,Atomic Variables and Optimization,Optimization and Strict Aliasing,Performance Considerations
@anchor{gnat_ugn/gnat_and_program_execution aliased-variables-and-optimization}@anchor{18f}@anchor{gnat_ugn/gnat_and_program_execution id37}@anchor{190}
@@ -29580,8 +29632,8 @@ to permit their use in free software.
@printindex ge
-@anchor{d1}@w{ }
@anchor{gnat_ugn/gnat_utility_programs switches-related-to-project-files}@w{ }
+@anchor{d1}@w{ }
@c %**end of body
@bye
--
2.43.2
^ permalink raw reply [flat|nested] 30+ messages in thread
* [COMMITTED 02/30] ada: Small cleanup in System.Finalization_Primitives unit
2024-05-20 7:48 [COMMITTED 01/30] ada: Rework and augment documentation on strict aliasing Marc Poulhiès
@ 2024-05-20 7:48 ` Marc Poulhiès
2024-05-20 7:48 ` [COMMITTED 03/30] ada: Implement representation aspect Max_Entry_Queue_Length Marc Poulhiès
` (27 subsequent siblings)
28 siblings, 0 replies; 30+ messages in thread
From: Marc Poulhiès @ 2024-05-20 7:48 UTC (permalink / raw)
To: gcc-patches; +Cc: Eric Botcazou
From: Eric Botcazou <ebotcazou@adacore.com>
It has been made possible by recent changes.
gcc/ada/
* libgnat/s-finpri.ads (Collection_Node): Move to private part.
(Collection_Node_Ptr): Likewise.
(Header_Alignment): Change to declaration and move completion to
private part.
(Header_Size): Likewise.
(Lock_Type): Delete.
(Finalization_Collection): Move Lock component and remove default
value for Finalization_Started component.
* libgnat/s-finpri.adb (Initialize): Reorder statements.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/libgnat/s-finpri.adb | 4 +--
gcc/ada/libgnat/s-finpri.ads | 48 +++++++++++++++++++-----------------
2 files changed, 28 insertions(+), 24 deletions(-)
diff --git a/gcc/ada/libgnat/s-finpri.adb b/gcc/ada/libgnat/s-finpri.adb
index 028c9d76062..bc90fe23ac9 100644
--- a/gcc/ada/libgnat/s-finpri.adb
+++ b/gcc/ada/libgnat/s-finpri.adb
@@ -394,14 +394,14 @@ package body System.Finalization_Primitives is
(Collection : in out Finalization_Collection)
is
begin
- Collection.Finalization_Started := False;
-
-- The dummy head must point to itself in both directions
Collection.Head.Prev := Collection.Head'Unchecked_Access;
Collection.Head.Next := Collection.Head'Unchecked_Access;
Initialize_RTS_Lock (Collection.Lock'Address);
+
+ Collection.Finalization_Started := False;
end Initialize;
---------------------
diff --git a/gcc/ada/libgnat/s-finpri.ads b/gcc/ada/libgnat/s-finpri.ads
index 62c2474b4f4..a821f1db657 100644
--- a/gcc/ada/libgnat/s-finpri.ads
+++ b/gcc/ada/libgnat/s-finpri.ads
@@ -146,16 +146,6 @@ package System.Finalization_Primitives with Preelaborate is
-- collection, in some arbitrary order. Calls to this procedure with
-- a collection that has already been finalized have no effect.
- type Collection_Node is private;
- -- Each controlled object associated with a finalization collection has
- -- an associated object of this type.
-
- type Collection_Node_Ptr is access all Collection_Node;
- for Collection_Node_Ptr'Storage_Size use 0;
- pragma No_Strict_Aliasing (Collection_Node_Ptr);
- -- A reference to a collection node. Since this type may not be used to
- -- allocate objects, its storage size is zero.
-
procedure Attach_Object_To_Collection
(Object_Address : System.Address;
Finalize_Address : not null Finalize_Address_Ptr;
@@ -171,13 +161,13 @@ package System.Finalization_Primitives with Preelaborate is
-- Calls to the procedure with an object that has already been detached
-- have no effects.
- function Header_Alignment return System.Storage_Elements.Storage_Count is
- (Collection_Node'Alignment);
- -- Return the alignment of type Collection_Node as Storage_Count
+ function Header_Alignment return System.Storage_Elements.Storage_Count;
+ -- Return the alignment of the header to be placed immediately in front of
+ -- a controlled object allocated for some access type, in storage units.
- function Header_Size return System.Storage_Elements.Storage_Count is
- (Collection_Node'Object_Size / Storage_Unit);
- -- Return the object size of type Collection_Node as Storage_Count
+ function Header_Size return System.Storage_Elements.Storage_Count;
+ -- Return the size of the header to be placed immediately in front of a
+ -- controlled object allocated for some access type, in storage units.
private
@@ -221,6 +211,16 @@ private
-- Finalization collections:
+ type Collection_Node;
+ -- Each controlled object associated with a finalization collection has
+ -- an associated object of this type.
+
+ type Collection_Node_Ptr is access all Collection_Node;
+ for Collection_Node_Ptr'Storage_Size use 0;
+ pragma No_Strict_Aliasing (Collection_Node_Ptr);
+ -- A reference to a collection node. Since this type may not be used to
+ -- allocate objects, its storage size is zero.
+
-- Collection node type structure. Finalize_Address comes first because it
-- is an access-to-subprogram and, therefore, might be twice as large and
-- as aligned as an access-to-object on some platforms.
@@ -237,7 +237,11 @@ private
-- Collection nodes are managed as a circular doubly-linked list
end record;
- type Lock_Type is mod 2**8 with Size => 8;
+ function Header_Alignment return System.Storage_Elements.Storage_Count is
+ (Collection_Node'Alignment);
+
+ function Header_Size return System.Storage_Elements.Storage_Count is
+ (Collection_Node'Object_Size / Storage_Unit);
-- Finalization collection type structure
@@ -245,15 +249,15 @@ private
new Ada.Finalization.Limited_Controlled with
record
Head : aliased Collection_Node;
- -- The head of the circular doubly-linked list of Collection_Nodes
+ -- The head of the circular doubly-linked list of collection nodes
+
+ Lock : aliased System.OS_Locks.RTS_Lock;
+ -- A lock to synchronize concurrent accesses to the collection
- Finalization_Started : Boolean := False;
+ Finalization_Started : Boolean;
-- A flag used to detect allocations which occur during the finalization
-- of a collection. The allocations must raise Program_Error. This may
-- arise in a multitask environment.
-
- Lock : aliased System.OS_Locks.RTS_Lock;
- -- A lock to synchronize concurrent accesses to the collection
end record;
-- This operation is very simple and thus can be performed in line
--
2.43.2
^ permalink raw reply [flat|nested] 30+ messages in thread
* [COMMITTED 03/30] ada: Implement representation aspect Max_Entry_Queue_Length
2024-05-20 7:48 [COMMITTED 01/30] ada: Rework and augment documentation on strict aliasing Marc Poulhiès
2024-05-20 7:48 ` [COMMITTED 02/30] ada: Small cleanup in System.Finalization_Primitives unit Marc Poulhiès
@ 2024-05-20 7:48 ` Marc Poulhiès
2024-05-20 7:48 ` [COMMITTED 04/30] ada: Detect only conflict with synomyms of max queue length Marc Poulhiès
` (26 subsequent siblings)
28 siblings, 0 replies; 30+ messages in thread
From: Marc Poulhiès @ 2024-05-20 7:48 UTC (permalink / raw)
To: gcc-patches; +Cc: Jose Ruiz
From: Jose Ruiz <ruiz@adacore.com>
Enforce Max_Entry_Queue_Length (and its
synonym Max_Entry_Queue_Depth) when applied to individual
protected entries.
gcc/ada/
* exp_ch9.adb (Expand_N_Protected_Type_Declaration): Clarify
comments.
* sem_prag.adb (Analyze_Pragma): Check for duplicates
Max_Entry_Queue_Length, Max_Entry_Queue_Depth and Max_Queue_Length
for the same protected entry.
* sem_util.adb (Get_Max_Queue_Length): Take into account all three
representation aspects that can be used to set this restriction.
(Has_Max_Queue_Length): Likewise.
* doc/gnat_rm/implementation_defined_pragmas.rst:
(pragma Max_Queue_Length): Fix pragma in example.
* gnat_rm.texi: Regenerate.
Tested on x86_64-pc-linux-gnu, committed on master.
---
.../implementation_defined_pragmas.rst | 2 +-
gcc/ada/exp_ch9.adb | 6 ++--
gcc/ada/gnat_rm.texi | 2 +-
gcc/ada/sem_prag.adb | 11 +++++++
gcc/ada/sem_util.adb | 33 ++++++++++++++-----
5 files changed, 41 insertions(+), 13 deletions(-)
diff --git a/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst b/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst
index bcbd85984dc..0661670e047 100644
--- a/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst
+++ b/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst
@@ -3771,7 +3771,7 @@ Pragma Max_Queue_Length
Syntax::
- pragma Max_Entry_Queue (static_integer_EXPRESSION);
+ pragma Max_Queue_Length (static_integer_EXPRESSION);
This pragma is used to specify the maximum callers per entry queue for
diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb
index 051b1df060f..4de253ab6e8 100644
--- a/gcc/ada/exp_ch9.adb
+++ b/gcc/ada/exp_ch9.adb
@@ -9405,7 +9405,8 @@ package body Exp_Ch9 is
end loop;
-- Create the declaration of an array object which contains the values
- -- of aspect/pragma Max_Queue_Length for all entries of the protected
+ -- of any aspect/pragma Max_Queue_Length, Max_Entry_Queue_Length or
+ -- Max_EntryQueue_Depth for all entries of the protected
-- type. This object is later passed to the appropriate protected object
-- initialization routine.
@@ -9422,7 +9423,8 @@ package body Exp_Ch9 is
Need_Array : Boolean := False;
begin
- -- First check if there is any Max_Queue_Length pragma
+ -- First check if there is any Max_Queue_Length,
+ -- Max_Entry_Queue_Length or Max_Entry_Queue_Depth pragma.
Item := First_Entity (Prot_Typ);
while Present (Item) loop
diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi
index 40516121b7a..4dbbb036a25 100644
--- a/gcc/ada/gnat_rm.texi
+++ b/gcc/ada/gnat_rm.texi
@@ -5312,7 +5312,7 @@ no effect in GNAT, other than being syntax checked.
Syntax:
@example
-pragma Max_Entry_Queue (static_integer_EXPRESSION);
+pragma Max_Queue_Length (static_integer_EXPRESSION);
@end example
This pragma is used to specify the maximum callers per entry queue for
diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index f27e40edcbb..0e2ce9de4b5 100644
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -20388,6 +20388,17 @@ package body Sem_Prag is
("pragma % must apply to a protected entry declaration");
end if;
+ -- Check for duplicates
+
+ if Has_Rep_Pragma (Entry_Id, Name_Max_Entry_Queue_Length)
+ or else
+ Has_Rep_Pragma (Entry_Id, Name_Max_Entry_Queue_Depth)
+ or else
+ Has_Rep_Pragma (Entry_Id, Name_Max_Queue_Length)
+ then
+ Error_Msg_N ("??duplicate Max_Entry_Queue_Length pragma", N);
+ end if;
+
-- Mark the pragma as Ghost if the related subprogram is also
-- Ghost. This also ensures that any expansion performed further
-- below will produce Ghost nodes.
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index d512d462b44..09358278210 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -10714,26 +10714,38 @@ package body Sem_Util is
function Get_Max_Queue_Length (Id : Entity_Id) return Uint is
pragma Assert (Is_Entry (Id));
- Prag : constant Entity_Id := Get_Pragma (Id, Pragma_Max_Queue_Length);
- Max : Uint;
+ PMQL : constant Entity_Id := Get_Pragma (Id, Pragma_Max_Queue_Length);
+ PMEQD : constant Entity_Id :=
+ Get_Pragma (Id, Pragma_Max_Entry_Queue_Depth);
+ PMEQL : constant Entity_Id :=
+ Get_Pragma (Id, Pragma_Max_Entry_Queue_Length);
+ Max : Uint;
begin
-- A value of 0 or -1 represents no maximum specified, and entries and
-- entry families with no Max_Queue_Length aspect or pragma default to
-- it.
- if No (Prag) then
- return Uint_0;
+ -- We have already checked that there is at most one of these pragmas
+
+ if Present (PMQL) then
+ Max := Expr_Value
+ (Expression (First (Pragma_Argument_Associations (PMQL))));
+ elsif Present (PMEQD) then
+ Max := Expr_Value
+ (Expression (First (Pragma_Argument_Associations (PMEQD))));
+ elsif Present (PMEQL) then
+ Max := Expr_Value
+ (Expression (First (Pragma_Argument_Associations (PMEQL))));
+ else
+ Max := Uint_0;
end if;
- Max := Expr_Value
- (Expression (First (Pragma_Argument_Associations (Prag))));
-
-- Since -1 and 0 are equivalent, return 0 for instances of -1 for
-- uniformity.
if Max = -1 then
- return Uint_0;
+ Max := Uint_0;
end if;
return Max;
@@ -12217,7 +12229,10 @@ package body Sem_Util is
begin
return
Ekind (Id) = E_Entry
- and then Present (Get_Pragma (Id, Pragma_Max_Queue_Length));
+ and then
+ (Present (Get_Pragma (Id, Pragma_Max_Queue_Length)) or else
+ Present (Get_Pragma (Id, Pragma_Max_Entry_Queue_Depth)) or else
+ Present (Get_Pragma (Id, Pragma_Max_Entry_Queue_Length)));
end Has_Max_Queue_Length;
---------------------------------
--
2.43.2
^ permalink raw reply [flat|nested] 30+ messages in thread
* [COMMITTED 04/30] ada: Detect only conflict with synomyms of max queue length
2024-05-20 7:48 [COMMITTED 01/30] ada: Rework and augment documentation on strict aliasing Marc Poulhiès
2024-05-20 7:48 ` [COMMITTED 02/30] ada: Small cleanup in System.Finalization_Primitives unit Marc Poulhiès
2024-05-20 7:48 ` [COMMITTED 03/30] ada: Implement representation aspect Max_Entry_Queue_Length Marc Poulhiès
@ 2024-05-20 7:48 ` Marc Poulhiès
2024-05-20 7:48 ` [COMMITTED 05/30] ada: One more adjustment coming from aliasing considerations Marc Poulhiès
` (25 subsequent siblings)
28 siblings, 0 replies; 30+ messages in thread
From: Marc Poulhiès @ 2024-05-20 7:48 UTC (permalink / raw)
To: gcc-patches; +Cc: Jose Ruiz
From: Jose Ruiz <ruiz@adacore.com>
Use of duplicated representation aspect is detected elsewhere
so we do not try to detect them here to avoid repetition of
messages.
gcc/ada/
* sem_prag.adb (Analyze_Pragma): Exclude detection of duplicates
because they are detected elsewhere.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/sem_prag.adb | 18 +++++++++++++-----
1 file changed, 13 insertions(+), 5 deletions(-)
diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index 0e2ce9de4b5..a895fd2053a 100644
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -20388,15 +20388,23 @@ package body Sem_Prag is
("pragma % must apply to a protected entry declaration");
end if;
- -- Check for duplicates
+ -- Check for conflicting use of synonyms. Note that we exclude
+ -- the detection of duplicates here because they are detected
+ -- elsewhere.
- if Has_Rep_Pragma (Entry_Id, Name_Max_Entry_Queue_Length)
+ if (Has_Rep_Pragma (Entry_Id, Name_Max_Entry_Queue_Length)
+ and then
+ Prag_Id /= Pragma_Max_Entry_Queue_Length)
or else
- Has_Rep_Pragma (Entry_Id, Name_Max_Entry_Queue_Depth)
+ (Has_Rep_Pragma (Entry_Id, Name_Max_Entry_Queue_Depth)
+ and then
+ Prag_Id /= Pragma_Max_Entry_Queue_Depth)
or else
- Has_Rep_Pragma (Entry_Id, Name_Max_Queue_Length)
+ (Has_Rep_Pragma (Entry_Id, Name_Max_Queue_Length)
+ and then
+ Prag_Id /= Pragma_Max_Queue_Length)
then
- Error_Msg_N ("??duplicate Max_Entry_Queue_Length pragma", N);
+ Error_Msg_N ("??maximum entry queue length already set", N);
end if;
-- Mark the pragma as Ghost if the related subprogram is also
--
2.43.2
^ permalink raw reply [flat|nested] 30+ messages in thread
* [COMMITTED 05/30] ada: One more adjustment coming from aliasing considerations
2024-05-20 7:48 [COMMITTED 01/30] ada: Rework and augment documentation on strict aliasing Marc Poulhiès
` (2 preceding siblings ...)
2024-05-20 7:48 ` [COMMITTED 04/30] ada: Detect only conflict with synomyms of max queue length Marc Poulhiès
@ 2024-05-20 7:48 ` Marc Poulhiès
2024-05-20 7:48 ` [COMMITTED 06/30] ada: Reject too-strict alignment specifications Marc Poulhiès
` (24 subsequent siblings)
28 siblings, 0 replies; 30+ messages in thread
From: Marc Poulhiès @ 2024-05-20 7:48 UTC (permalink / raw)
To: gcc-patches; +Cc: Eric Botcazou
From: Eric Botcazou <ebotcazou@adacore.com>
It is needed on PowerPC platforms because of specific calling conventions.
gcc/ada/
* libgnat/g-sothco.ads (In_Addr): Add aspect Universal_Aliasing.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/libgnat/g-sothco.ads | 7 +++++--
1 file changed, 5 insertions(+), 2 deletions(-)
diff --git a/gcc/ada/libgnat/g-sothco.ads b/gcc/ada/libgnat/g-sothco.ads
index 8c219333649..da1e6f5bcdd 100644
--- a/gcc/ada/libgnat/g-sothco.ads
+++ b/gcc/ada/libgnat/g-sothco.ads
@@ -123,10 +123,13 @@ package GNAT.Sockets.Thin_Common is
type In_Addr is record
S_B1, S_B2, S_B3, S_B4 : C.unsigned_char;
- end record with Convention => C, Alignment => C.int'Alignment;
+ end record
+ with Convention => C, Alignment => C.int'Alignment, Universal_Aliasing;
-- IPv4 address, represented as a network-order C.int. Note that the
-- underlying operating system may assume that values of this type have
- -- C.int alignment, so we need to provide a suitable alignment clause here.
+ -- C.int's alignment, so we need to provide a suitable alignment clause.
+ -- We also need to inhibit strict type-based aliasing optimizations in
+ -- order to implement the following unchecked conversions efficiently.
function To_In_Addr is new Ada.Unchecked_Conversion (C.int, In_Addr);
function To_Int is new Ada.Unchecked_Conversion (In_Addr, C.int);
--
2.43.2
^ permalink raw reply [flat|nested] 30+ messages in thread
* [COMMITTED 06/30] ada: Reject too-strict alignment specifications.
2024-05-20 7:48 [COMMITTED 01/30] ada: Rework and augment documentation on strict aliasing Marc Poulhiès
` (3 preceding siblings ...)
2024-05-20 7:48 ` [COMMITTED 05/30] ada: One more adjustment coming from aliasing considerations Marc Poulhiès
@ 2024-05-20 7:48 ` Marc Poulhiès
2024-05-20 7:48 ` [COMMITTED 07/30] ada: Use System.Address for address computation in System.Pool_Global Marc Poulhiès
` (23 subsequent siblings)
28 siblings, 0 replies; 30+ messages in thread
From: Marc Poulhiès @ 2024-05-20 7:48 UTC (permalink / raw)
To: gcc-patches; +Cc: Steve Baird
From: Steve Baird <baird@adacore.com>
For a discrete (or fixed-point) type T, GNAT requires that T'Object_Size
shall be a multiple of T'Alignment * 8 .
GNAT also requires that T'Object_Size shall be no larger than
Standard'Max_Integer_Size.
For a sufficiently-large alignment specification, these requirements can
conflict.
The conflict is resolved by rejecting such alignment specifications (which
were previously accepted in some cases).
gcc/ada/
* freeze.adb (Adjust_Esize_For_Alignment): Assert that a valid
Alignment specification cannot result in adjusting the given
type's Esize to be larger than System_Max_Integer_Size.
* sem_ch13.adb (Analyze_Attribute_Definition_Clause): In analyzing
an Alignment specification, enforce the rule that a specified
Alignment value for a discrete or fixed-point type shall not be
larger than System_Max_Integer_Size / 8 .
gcc/testsuite/ChangeLog:
* gnat.dg/specs/alignment2.ads: Adjust.
* gnat.dg/specs/alignment2_bis.ads: New test.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/freeze.adb | 8 +++--
gcc/ada/sem_ch13.adb | 15 ++++++++
gcc/testsuite/gnat.dg/specs/alignment2.ads | 14 --------
.../gnat.dg/specs/alignment2_bis.ads | 36 +++++++++++++++++++
4 files changed, 57 insertions(+), 16 deletions(-)
create mode 100644 gcc/testsuite/gnat.dg/specs/alignment2_bis.ads
diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb
index a980c7e5b47..26e9d01d8b2 100644
--- a/gcc/ada/freeze.adb
+++ b/gcc/ada/freeze.adb
@@ -303,8 +303,12 @@ package body Freeze is
if Known_Esize (Typ) and then Known_Alignment (Typ) then
Align := Alignment_In_Bits (Typ);
- if Align > Esize (Typ) and then Align <= System_Max_Integer_Size then
- Set_Esize (Typ, Align);
+ if Align > Esize (Typ) then
+ if Align > System_Max_Integer_Size then
+ pragma Assert (Serious_Errors_Detected > 0);
+ else
+ Set_Esize (Typ, Align);
+ end if;
end if;
end if;
end Adjust_Esize_For_Alignment;
diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
index 13bf93ca548..59c80022c20 100644
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -6573,6 +6573,21 @@ package body Sem_Ch13 is
("alignment for & set to Maximum_Aligment??", Nam);
Set_Alignment (U_Ent, Max_Align);
+ -- Because Object_Size must be multiple of Alignment (in bits),
+ -- System_Max_Integer_Size limit for discrete and fixed point
+ -- types implies a limit on alignment for such types.
+
+ elsif (Is_Discrete_Type (U_Ent)
+ or else Is_Fixed_Point_Type (U_Ent))
+ and then Align > System_Max_Integer_Size / System_Storage_Unit
+ then
+ Error_Msg_N
+ ("specified alignment too large for discrete or fixed " &
+ "point type", Expr);
+ Set_Alignment
+ (U_Ent, UI_From_Int (System_Max_Integer_Size /
+ System_Storage_Unit));
+
-- All other cases
else
diff --git a/gcc/testsuite/gnat.dg/specs/alignment2.ads b/gcc/testsuite/gnat.dg/specs/alignment2.ads
index 0b6c14f1b7d..75a002e9bee 100644
--- a/gcc/testsuite/gnat.dg/specs/alignment2.ads
+++ b/gcc/testsuite/gnat.dg/specs/alignment2.ads
@@ -32,18 +32,4 @@ package Alignment2 is
end record;
for R4'Alignment use 32;
- -- warning
- type I1 is new Integer_32;
- for I1'Size use 32;
- for I1'Alignment use 32; -- { dg-warning "suspiciously large alignment" }
-
- -- warning
- type I2 is new Integer_32;
- for I2'Alignment use 32; -- { dg-warning "suspiciously large alignment" }
-
- -- OK, big size
- type I3 is new Integer_32;
- for I3'Size use 32 * 8; -- { dg-warning "unused" }
- for I3'Alignment use 32;
-
end Alignment2;
diff --git a/gcc/testsuite/gnat.dg/specs/alignment2_bis.ads b/gcc/testsuite/gnat.dg/specs/alignment2_bis.ads
new file mode 100644
index 00000000000..ad31a400b84
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/specs/alignment2_bis.ads
@@ -0,0 +1,36 @@
+-- { dg-do compile }
+
+with Interfaces; use Interfaces;
+
+package Alignment2_Bis is
+
+ pragma Warnings (Off, "*size*");
+
+ -- OK, big size
+ type R3 is record
+ A, B, C, D : Integer_8;
+ end record;
+ for R3'Size use 32 * 8;
+ for R3'Alignment use 32;
+
+ -- OK, big size
+ type R4 is record
+ A, B, C, D, E, F, G, H : Integer_32;
+ end record;
+ for R4'Alignment use 32;
+
+ -- warning
+ type I1 is new Integer_32;
+ for I1'Size use 32;
+ for I1'Alignment use 32; -- { dg-error "error: specified alignment too large for discrete or fixed point type" }
+
+ -- warning
+ type I2 is new Integer_32;
+ for I2'Alignment use 32; -- { dg-error "error: specified alignment too large for discrete or fixed point type" }
+
+ -- OK, big size
+ type I3 is new Integer_32;
+ for I3'Size use 32 * 8;
+ for I3'Alignment use 32; -- { dg-error "error: specified alignment too large for discrete or fixed point type" }
+
+end Alignment2_Bis;
--
2.43.2
^ permalink raw reply [flat|nested] 30+ messages in thread
* [COMMITTED 07/30] ada: Use System.Address for address computation in System.Pool_Global
2024-05-20 7:48 [COMMITTED 01/30] ada: Rework and augment documentation on strict aliasing Marc Poulhiès
` (4 preceding siblings ...)
2024-05-20 7:48 ` [COMMITTED 06/30] ada: Reject too-strict alignment specifications Marc Poulhiès
@ 2024-05-20 7:48 ` Marc Poulhiès
2024-05-20 7:48 ` [COMMITTED 08/30] ada: Fix for attribute Width on enumeration types with Discard_Name Marc Poulhiès
` (22 subsequent siblings)
28 siblings, 0 replies; 30+ messages in thread
From: Marc Poulhiès @ 2024-05-20 7:48 UTC (permalink / raw)
To: gcc-patches; +Cc: Sebastian Poeplau
From: Sebastian Poeplau <poeplau@adacore.com>
Some architectures don't let us convert
System.Storage_Elements.Integer_Address back to a valid System.Address.
Using the arithmetic operations on System.Address from
System.Storage_Elements prevents the problem while leaving semantics
unchanged.
gcc/ada/
* libgnat/s-pooglo.adb (Allocate): Use arithmetic on
System.Address to compute the aligned address.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/libgnat/s-pooglo.adb | 7 ++++---
1 file changed, 4 insertions(+), 3 deletions(-)
diff --git a/gcc/ada/libgnat/s-pooglo.adb b/gcc/ada/libgnat/s-pooglo.adb
index dea3de15cc5..9ce21c8fd0d 100644
--- a/gcc/ada/libgnat/s-pooglo.adb
+++ b/gcc/ada/libgnat/s-pooglo.adb
@@ -75,9 +75,10 @@ package body System.Pool_Global is
-- Realign the returned address
- Aligned_Address := To_Address
- (To_Integer (Allocated) + Integer_Address (Alignment)
- - (To_Integer (Allocated) mod Integer_Address (Alignment)));
+ Aligned_Address :=
+ Allocated + Alignment
+ - Storage_Offset (To_Integer (Allocated)
+ mod Integer_Address (Alignment));
-- Save the block address
--
2.43.2
^ permalink raw reply [flat|nested] 30+ messages in thread
* [COMMITTED 08/30] ada: Fix for attribute Width on enumeration types with Discard_Name
2024-05-20 7:48 [COMMITTED 01/30] ada: Rework and augment documentation on strict aliasing Marc Poulhiès
` (5 preceding siblings ...)
2024-05-20 7:48 ` [COMMITTED 07/30] ada: Use System.Address for address computation in System.Pool_Global Marc Poulhiès
@ 2024-05-20 7:48 ` Marc Poulhiès
2024-05-20 7:48 ` [COMMITTED 09/30] ada: Fix static 'Img for enumeration type with Discard_Names Marc Poulhiès
` (21 subsequent siblings)
28 siblings, 0 replies; 30+ messages in thread
From: Marc Poulhiès @ 2024-05-20 7:48 UTC (permalink / raw)
To: gcc-patches; +Cc: Piotr Trojanek
From: Piotr Trojanek <trojanek@adacore.com>
Fix computation of attribute 'Width for enumeration types with
Discard_Name aspect enabled.
gcc/ada/
* exp_imgv.adb (Expand_Width_Attribute): Fix for 'Width that
is computed at run time.
* sem_attr.adb (Eval_Attribute): Fix for 'Width that is computed
at compilation time.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/exp_imgv.adb | 25 +++++++++++++++----------
gcc/ada/sem_attr.adb | 7 ++++---
2 files changed, 19 insertions(+), 13 deletions(-)
diff --git a/gcc/ada/exp_imgv.adb b/gcc/ada/exp_imgv.adb
index 6dc59f2c6f3..e5d84cc52e3 100644
--- a/gcc/ada/exp_imgv.adb
+++ b/gcc/ada/exp_imgv.adb
@@ -2294,7 +2294,7 @@ package body Exp_Imgv is
-- in the range of the subtype + 1 for the space at the start. We
-- build:
- -- Tnn : constant Integer := Rtyp'Pos (Ptyp'Last)
+ -- Tnn : constant Integer := Rtyp'Pos (Ptyp'Last);
-- and replace the expression by
@@ -2320,9 +2320,15 @@ package body Exp_Imgv is
declare
Tnn : constant Entity_Id := Make_Temporary (Loc, 'T');
Cexpr : Node_Id;
- P : Int;
- M : Int;
- K : Int;
+
+ P : constant Nat :=
+ UI_To_Int (Enumeration_Pos (Entity (Type_High_Bound (Rtyp))));
+ -- The largest value that might need to be represented
+
+ K : Pos;
+ M : Pos;
+ -- K is the number of chars that will fit the image of 0..M-1;
+ -- M is the smallest number that won't fit in K chars.
begin
Insert_Action (N,
@@ -2342,14 +2348,13 @@ package body Exp_Imgv is
Attribute_Name => Name_Last))))));
-- OK, now we need to build the if expression. First get the
- -- value of M, the largest possible value needed.
+ -- values of K and M for the largest possible value P.
- P := UI_To_Int
- (Enumeration_Pos (Entity (Type_High_Bound (Rtyp))));
+ K := 2;
+ M := 10;
+ -- With 2 characters we can represent values in 0..9
- K := 1;
- M := 1;
- while M < P loop
+ while P >= M loop
M := M * 10;
K := K + 1;
end loop;
diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
index a921909685a..96f216cc587 100644
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -10906,9 +10906,10 @@ package body Sem_Attr is
-- that accommodates the Pos of the largest value, which
-- is the high bound of the range + one for the space.
- W := 1;
- T := Hi;
- while T /= 0 loop
+ W := 1; -- one character for the leading space
+ W := W + 1; -- one character for the 0 .. 9 digit
+ T := Hi; -- one character for every decimal digit
+ while T >= 10 loop
T := T / 10;
W := W + 1;
end loop;
--
2.43.2
^ permalink raw reply [flat|nested] 30+ messages in thread
* [COMMITTED 09/30] ada: Fix static 'Img for enumeration type with Discard_Names
2024-05-20 7:48 [COMMITTED 01/30] ada: Rework and augment documentation on strict aliasing Marc Poulhiès
` (6 preceding siblings ...)
2024-05-20 7:48 ` [COMMITTED 08/30] ada: Fix for attribute Width on enumeration types with Discard_Name Marc Poulhiès
@ 2024-05-20 7:48 ` Marc Poulhiès
2024-05-20 7:48 ` [COMMITTED 10/30] ada: Another small cleanup about allocators and aggregates Marc Poulhiès
` (20 subsequent siblings)
28 siblings, 0 replies; 30+ messages in thread
From: Marc Poulhiès @ 2024-05-20 7:48 UTC (permalink / raw)
To: gcc-patches; +Cc: Piotr Trojanek
From: Piotr Trojanek <trojanek@adacore.com>
Fix a short-circuit folding of 'Img for enumeration type, which wrongly
ignored Discard_Names and exposed enumeration literals.
gcc/ada/
* sem_attr.adb (Eval_Attribute): Handle enumeration type with
Discard_Names.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/sem_attr.adb | 19 ++++++++++++++++---
1 file changed, 16 insertions(+), 3 deletions(-)
diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
index 96f216cc587..2b22cf13ad0 100644
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -8221,13 +8221,26 @@ package body Sem_Attr is
then
declare
Lit : constant Entity_Id := Expr_Value_E (P);
+ Typ : constant Entity_Id := Etype (Entity (P));
Str : String_Id;
begin
Start_String;
- Get_Unqualified_Decoded_Name_String (Chars (Lit));
- Set_Casing (All_Upper_Case);
- Store_String_Chars (Name_Buffer (1 .. Name_Len));
+
+ -- If Discard_Names is in effect for the type, then we emit the
+ -- numeric representation of the prefix literal 'Pos attribute,
+ -- prefixed with a single space.
+
+ if Discard_Names (Typ) then
+ UI_Image (Enumeration_Pos (Lit), Decimal);
+ Store_String_Char (' ');
+ Store_String_Chars (UI_Image_Buffer (1 .. UI_Image_Length));
+ else
+ Get_Unqualified_Decoded_Name_String (Chars (Lit));
+ Set_Casing (All_Upper_Case);
+ Store_String_Chars (Name_Buffer (1 .. Name_Len));
+ end if;
+
Str := End_String;
Rewrite (N, Make_String_Literal (Loc, Strval => Str));
--
2.43.2
^ permalink raw reply [flat|nested] 30+ messages in thread
* [COMMITTED 10/30] ada: Another small cleanup about allocators and aggregates
2024-05-20 7:48 [COMMITTED 01/30] ada: Rework and augment documentation on strict aliasing Marc Poulhiès
` (7 preceding siblings ...)
2024-05-20 7:48 ` [COMMITTED 09/30] ada: Fix static 'Img for enumeration type with Discard_Names Marc Poulhiès
@ 2024-05-20 7:48 ` Marc Poulhiès
2024-05-20 7:48 ` [COMMITTED 11/30] ada: Fix incorrect free with Task_Info pragma Marc Poulhiès
` (19 subsequent siblings)
28 siblings, 0 replies; 30+ messages in thread
From: Marc Poulhiès @ 2024-05-20 7:48 UTC (permalink / raw)
To: gcc-patches; +Cc: Eric Botcazou
From: Eric Botcazou <ebotcazou@adacore.com>
This eliminates a few more oddities present in the expander for allocators
and aggregates nested in allocators and other constructs:
- Convert_Aggr_In_Allocator takes both the N_Allocator and the aggregate
as parameters, while the sibling procedures Convert_Aggr_In_Assignment
and Convert_Aggr_In_Object_Decl only take the former. This changes the
first to be consistent with the two others and propagates the change to
Convert_Array_Aggr_In_Allocator.
- Convert_Aggr_In_Object_Decl contains an awkward code structure with a
useless inner block statement.
- In_Place_Assign_OK and Convert_To_Assignments have some declarations of
local variables not in the right place.
No functional changes (presumably).
gcc/ada/
* exp_aggr.ads (Convert_Aggr_In_Allocator): Remove Aggr parameter
and adjust description.
(Convert_Aggr_In_Object_Decl): Adjust description.
* exp_aggr.adb (Convert_Aggr_In_Allocator): Remove Aggr parameter
and add local variable of the same name instead. Adjust call to
Convert_Array_Aggr_In_Allocator.
(Convert_Aggr_In_Object_Decl): Add comment for early return and
remove useless inner block statement.
(Convert_Array_Aggr_In_Allocator): Remove Aggr parameter and add
local variable of the same name instead.
(In_Place_Assign_OK): Move down declarations of local variables.
(Convert_To_Assignments): Put all declarations of local variables
in the same place. Fix typo in comment. Replace T with Full_Typ.
* exp_ch4.adb (Expand_Allocator_Expression): Call Unqualify instead
of Expression on the qualified expression of the allocator for the
sake of consistency. Adjust call to Convert_Aggr_In_Allocator.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/exp_aggr.adb | 188 +++++++++++++++++++++----------------------
gcc/ada/exp_aggr.ads | 18 ++---
gcc/ada/exp_ch4.adb | 4 +-
3 files changed, 104 insertions(+), 106 deletions(-)
diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb
index 2476675604c..8a3d1685cb3 100644
--- a/gcc/ada/exp_aggr.adb
+++ b/gcc/ada/exp_aggr.adb
@@ -282,10 +282,7 @@ package body Exp_Aggr is
-- Indexes is the current list of expressions used to index the object we
-- are writing into.
- procedure Convert_Array_Aggr_In_Allocator
- (N : Node_Id;
- Aggr : Node_Id;
- Target : Node_Id);
+ procedure Convert_Array_Aggr_In_Allocator (N : Node_Id; Target : Node_Id);
-- If the aggregate appears within an allocator and can be expanded in
-- place, this routine generates the individual assignments to components
-- of the designated object. This is an optimization over the general
@@ -3543,11 +3540,8 @@ package body Exp_Aggr is
-- Convert_Aggr_In_Allocator --
-------------------------------
- procedure Convert_Aggr_In_Allocator
- (N : Node_Id;
- Aggr : Node_Id;
- Temp : Entity_Id)
- is
+ procedure Convert_Aggr_In_Allocator (N : Node_Id; Temp : Entity_Id) is
+ Aggr : constant Node_Id := Unqualify (Expression (N));
Loc : constant Source_Ptr := Sloc (Aggr);
Typ : constant Entity_Id := Etype (Aggr);
@@ -3557,7 +3551,7 @@ package body Exp_Aggr is
begin
if Is_Array_Type (Typ) then
- Convert_Array_Aggr_In_Allocator (N, Aggr, Occ);
+ Convert_Array_Aggr_In_Allocator (N, Occ);
elsif Has_Default_Init_Comps (Aggr) then
declare
@@ -3605,12 +3599,9 @@ package body Exp_Aggr is
Aggr : constant Node_Id := Unqualify (Expression (N));
Loc : constant Source_Ptr := Sloc (Aggr);
Typ : constant Entity_Id := Etype (Aggr);
- Occ : constant Node_Id := New_Occurrence_Of (Obj, Loc);
-
- Has_Transient_Scope : Boolean := False;
function Discriminants_Ok return Boolean;
- -- If the object type is constrained, the discriminants in the
+ -- If the object's subtype is constrained, the discriminants in the
-- aggregate must be checked against the discriminants of the subtype.
-- This cannot be done using Apply_Discriminant_Checks because after
-- expansion there is no aggregate left to check.
@@ -3677,10 +3668,19 @@ package body Exp_Aggr is
return True;
end Discriminants_Ok;
+ -- Local variables
+
+ Has_Transient_Scope : Boolean;
+ Occ : Node_Id;
+ Param : Node_Id;
+ Stmt : Node_Id;
+ Stmts : List_Id;
+
-- Start of processing for Convert_Aggr_In_Object_Decl
begin
- Set_Assignment_OK (Occ);
+ -- First generate discriminant checks if need be, and bail out if one
+ -- of them fails statically.
if Has_Discriminants (Typ)
and then Typ /= Etype (Obj)
@@ -3706,61 +3706,59 @@ package body Exp_Aggr is
then
Establish_Transient_Scope (Aggr, Manage_Sec_Stack => False);
Has_Transient_Scope := True;
+ else
+ Has_Transient_Scope := False;
end if;
- declare
- Stmts : constant List_Id := Late_Expansion (Aggr, Typ, Occ);
- Stmt : Node_Id;
- Param : Node_Id;
+ Occ := New_Occurrence_Of (Obj, Loc);
+ Set_Assignment_OK (Occ);
+ Stmts := Late_Expansion (Aggr, Typ, Occ);
- begin
- -- If Obj is already frozen or if N is wrapped in a transient scope,
- -- Stmts do not need to be saved in Initialization_Statements since
- -- there is no freezing issue.
+ -- If Obj is already frozen or if N is wrapped in a transient scope,
+ -- Stmts do not need to be saved in Initialization_Statements since
+ -- there is no freezing issue.
- if Is_Frozen (Obj) or else Has_Transient_Scope then
- Insert_Actions_After (N, Stmts);
- else
- Stmt := Make_Compound_Statement (Sloc (N), Actions => Stmts);
- Insert_Action_After (N, Stmt);
+ if Is_Frozen (Obj) or else Has_Transient_Scope then
+ Insert_Actions_After (N, Stmts);
- -- Insert_Action_After may freeze Obj in which case we should
- -- remove the compound statement just created and simply insert
- -- Stmts after N.
+ else
+ Stmt := Make_Compound_Statement (Sloc (N), Actions => Stmts);
+ Insert_Action_After (N, Stmt);
- if Is_Frozen (Obj) then
- Remove (Stmt);
- Insert_Actions_After (N, Stmts);
- else
- Set_Initialization_Statements (Obj, Stmt);
- end if;
- end if;
+ -- Insert_Action_After may freeze Obj in which case we should
+ -- remove the compound statement just created and simply insert
+ -- Stmts after N.
- -- If Typ has controlled components and a call to a Slice_Assign
- -- procedure is part of the initialization statements, then we
- -- need to initialize the array component since Slice_Assign will
- -- need to adjust it.
+ if Is_Frozen (Obj) then
+ Remove (Stmt);
+ Insert_Actions_After (N, Stmts);
- if Has_Controlled_Component (Typ) then
- Stmt := First (Stmts);
+ else
+ Set_Initialization_Statements (Obj, Stmt);
+ end if;
+ end if;
- while Present (Stmt) loop
- if Nkind (Stmt) = N_Procedure_Call_Statement
- and then Is_TSS (Entity (Name (Stmt)), TSS_Slice_Assign)
- then
- Param := First (Parameter_Associations (Stmt));
- Insert_Actions
- (Stmt,
- Build_Initialization_Call (N,
- New_Copy_Tree (Param), Etype (Param)));
- end if;
+ -- If Typ has controlled components and a call to a Slice_Assign
+ -- procedure is part of the initialization statements, then we
+ -- need to initialize the array component since Slice_Assign will
+ -- need to adjust it.
- Next (Stmt);
- end loop;
- end if;
- end;
+ if Has_Controlled_Component (Typ) then
+ Stmt := First (Stmts);
- Set_No_Initialization (N);
+ while Present (Stmt) loop
+ if Nkind (Stmt) = N_Procedure_Call_Statement
+ and then Is_TSS (Entity (Name (Stmt)), TSS_Slice_Assign)
+ then
+ Param := First (Parameter_Associations (Stmt));
+ Insert_Actions (Stmt,
+ Build_Initialization_Call (N,
+ New_Copy_Tree (Param), Etype (Param)));
+ end if;
+
+ Next (Stmt);
+ end loop;
+ end if;
-- After expansion the expression can be removed from the declaration
-- except if the object is class-wide, in which case the aggregate
@@ -3770,6 +3768,8 @@ package body Exp_Aggr is
Set_Expression (N, Empty);
end if;
+ Set_No_Initialization (N);
+
Initialize_Discriminants (N, Typ);
end Convert_Aggr_In_Object_Decl;
@@ -3777,13 +3777,11 @@ package body Exp_Aggr is
-- Convert_Array_Aggr_In_Allocator --
-------------------------------------
- procedure Convert_Array_Aggr_In_Allocator
- (N : Node_Id;
- Aggr : Node_Id;
- Target : Node_Id)
- is
- Typ : constant Entity_Id := Etype (Aggr);
- Ctyp : constant Entity_Id := Component_Type (Typ);
+ procedure Convert_Array_Aggr_In_Allocator (N : Node_Id; Target : Node_Id) is
+ Aggr : constant Node_Id := Unqualify (Expression (N));
+ Typ : constant Entity_Id := Etype (Aggr);
+ Ctyp : constant Entity_Id := Component_Type (Typ);
+
Aggr_Code : List_Id;
New_Aggr : Node_Id;
@@ -3846,13 +3844,6 @@ package body Exp_Aggr is
is
Is_Array : constant Boolean := Is_Array_Type (Etype (N));
- Aggr_In : Node_Id;
- Aggr_Bounds : Range_Nodes;
- Obj_In : Node_Id;
- Obj_Bounds : Range_Nodes;
- Parent_Kind : Node_Kind;
- Parent_Node : Node_Id;
-
function Safe_Aggregate (Aggr : Node_Id) return Boolean;
-- Check recursively that each component of a (sub)aggregate does not
-- depend on the variable being assigned to.
@@ -4106,6 +4097,15 @@ package body Exp_Aggr is
end if;
end Safe_Component;
+ -- Local variables
+
+ Aggr_In : Node_Id;
+ Aggr_Bounds : Range_Nodes;
+ Obj_In : Node_Id;
+ Obj_Bounds : Range_Nodes;
+ Parent_Kind : Node_Kind;
+ Parent_Node : Node_Id;
+
-- Start of processing for In_Place_Assign_OK
begin
@@ -4214,16 +4214,16 @@ package body Exp_Aggr is
----------------------------
procedure Convert_To_Assignments (N : Node_Id; Typ : Entity_Id) is
- Loc : constant Source_Ptr := Sloc (N);
- T : Entity_Id;
- Temp : Entity_Id;
+ Loc : constant Source_Ptr := Sloc (N);
Aggr_Code : List_Id;
+ Full_Typ : Entity_Id;
Instr : Node_Id;
- Target_Expr : Node_Id;
Parent_Kind : Node_Kind;
- Unc_Decl : Boolean := False;
Parent_Node : Node_Id;
+ Target_Expr : Node_Id;
+ Temp : Entity_Id;
+ Unc_Decl : Boolean := False;
begin
pragma Assert (Nkind (N) in N_Aggregate | N_Extension_Aggregate);
@@ -4275,7 +4275,7 @@ package body Exp_Aggr is
or else (Parent_Kind = N_Object_Declaration and then not Unc_Decl)
- -- Safe assignment (see Convert_Aggr_Assignments). So far only the
+ -- Safe assignment (see Convert_Aggr_In_Assignment). So far only the
-- assignments in init procs are taken into account.
or else (Parent_Kind = N_Assignment_Statement
@@ -4304,14 +4304,12 @@ package body Exp_Aggr is
Establish_Transient_Scope (N, Manage_Sec_Stack => False);
end if;
- -- If the aggregate is nonlimited, create a temporary, since aggregates
- -- have "by copy" semantics. If it is limited and context is an
- -- assignment, this is a subaggregate for an enclosing aggregate being
- -- expanded. It must be built in place, so use target of the current
- -- assignment.
+ -- If the context is an assignment and the aggregate is limited, this
+ -- is a subaggregate of an enclosing aggregate being expanded; it must
+ -- be built in place, so use the target of the current assignment.
- if Is_Limited_Type (Typ)
- and then Parent_Kind = N_Assignment_Statement
+ if Parent_Kind = N_Assignment_Statement
+ and then Is_Limited_Type (Typ)
then
Target_Expr := New_Copy_Tree (Name (Parent_Node));
Insert_Actions (Parent_Node,
@@ -4320,7 +4318,7 @@ package body Exp_Aggr is
-- Do not declare a temporary to initialize an aggregate assigned to
-- a target when in-place assignment is possible, i.e. preserving the
- -- by-copy semantic of aggregates. This avoids large stack usage and
+ -- by-copy semantics of aggregates. This avoids large stack usage and
-- generates more efficient code.
elsif Parent_Kind = N_Assignment_Statement
@@ -4345,6 +4343,8 @@ package body Exp_Aggr is
end if;
end;
+ -- Otherwise, create a temporary since aggregates have by-copy semantics
+
else
Temp := Make_Temporary (Loc, 'A', N);
@@ -4354,35 +4354,35 @@ package body Exp_Aggr is
if Has_Unknown_Discriminants (Typ)
and then Present (Underlying_Record_View (Typ))
then
- T := Underlying_Record_View (Typ);
+ Full_Typ := Underlying_Record_View (Typ);
else
- T := Typ;
+ Full_Typ := Typ;
end if;
Instr :=
Make_Object_Declaration (Loc,
Defining_Identifier => Temp,
- Object_Definition => New_Occurrence_Of (T, Loc));
+ Object_Definition => New_Occurrence_Of (Full_Typ, Loc));
Set_No_Initialization (Instr);
Insert_Action (N, Instr);
- Initialize_Discriminants (Instr, T);
+ Initialize_Discriminants (Instr, Full_Typ);
Target_Expr := New_Occurrence_Of (Temp, Loc);
- Aggr_Code := Build_Record_Aggr_Code (N, T, Target_Expr);
+ Aggr_Code := Build_Record_Aggr_Code (N, Full_Typ, Target_Expr);
-- Save the last assignment statement associated with the aggregate
-- when building a controlled object. This reference is utilized by
-- the finalization machinery when marking an object as successfully
-- initialized.
- if Needs_Finalization (T) then
+ if Needs_Finalization (Full_Typ) then
Set_Last_Aggregate_Assignment (Temp, Last (Aggr_Code));
end if;
Insert_Actions (N, Aggr_Code);
Rewrite (N, New_Occurrence_Of (Temp, Loc));
- Analyze_And_Resolve (N, T);
+ Analyze_And_Resolve (N, Full_Typ);
end if;
end Convert_To_Assignments;
diff --git a/gcc/ada/exp_aggr.ads b/gcc/ada/exp_aggr.ads
index 30765efe944..a9eb0518d7a 100644
--- a/gcc/ada/exp_aggr.ads
+++ b/gcc/ada/exp_aggr.ads
@@ -31,14 +31,12 @@ package Exp_Aggr is
procedure Expand_N_Delta_Aggregate (N : Node_Id);
procedure Expand_N_Extension_Aggregate (N : Node_Id);
- procedure Convert_Aggr_In_Allocator
- (N : Node_Id;
- Aggr : Node_Id;
- Temp : Entity_Id);
- -- N is an N_Allocator whose (ultimate) expression is the aggregate Aggr.
+ procedure Convert_Aggr_In_Allocator (N : Node_Id; Temp : Entity_Id);
+ -- N is an N_Allocator whose (ultimate) expression must be an N_Aggregate
+ -- or N_Extension_Aggregate with Expansion_Delayed.
-- This procedure performs an in-place aggregate assignment into an object
- -- allocated with the subtype of Aggr and designated by Temp, so that N
- -- can be rewritten as a mere occurrence of Temp.
+ -- allocated with the subtype of the aggregate and designated by Temp, so
+ -- that N can be rewritten as a mere occurrence of Temp.
procedure Convert_Aggr_In_Assignment (N : Node_Id);
-- If the right-hand side of an assignment is an aggregate, expand the
@@ -48,9 +46,9 @@ package Exp_Aggr is
-- backend.
procedure Convert_Aggr_In_Object_Decl (N : Node_Id);
- -- N is an N_Object_Declaration with an expression which must be an
- -- N_Aggregate or N_Extension_Aggregate with Expansion_Delayed.
- -- This procedure performs in-place aggregate assignment.
+ -- N is an N_Object_Declaration whose expression must be an N_Aggregate or
+ -- N_Extension_Aggregate with Expansion_Delayed.
+ -- This procedure performs an in-place aggregate assignment.
function Is_Delayed_Aggregate (N : Node_Id) return Boolean;
-- Returns True if N is an aggregate of some kind whose Expansion_Delayed
diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
index 29249eb4c18..69a042115c9 100644
--- a/gcc/ada/exp_ch4.adb
+++ b/gcc/ada/exp_ch4.adb
@@ -555,7 +555,7 @@ package body Exp_Ch4 is
procedure Expand_Allocator_Expression (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
- Exp : constant Node_Id := Expression (Expression (N));
+ Exp : constant Node_Id := Unqualify (Expression (N));
Indic : constant Node_Id := Subtype_Mark (Expression (N));
T : constant Entity_Id := Entity (Indic);
PtrT : constant Entity_Id := Etype (N);
@@ -595,7 +595,7 @@ package body Exp_Ch4 is
-- Insert the declaration and generate the in-place assignment
Insert_Action (N, Temp_Decl);
- Convert_Aggr_In_Allocator (N, Exp, Temp);
+ Convert_Aggr_In_Allocator (N, Temp);
end Build_Aggregate_In_Place;
-- Local variables
--
2.43.2
^ permalink raw reply [flat|nested] 30+ messages in thread
* [COMMITTED 11/30] ada: Fix incorrect free with Task_Info pragma
2024-05-20 7:48 [COMMITTED 01/30] ada: Rework and augment documentation on strict aliasing Marc Poulhiès
` (8 preceding siblings ...)
2024-05-20 7:48 ` [COMMITTED 10/30] ada: Another small cleanup about allocators and aggregates Marc Poulhiès
@ 2024-05-20 7:48 ` Marc Poulhiès
2024-05-20 7:48 ` [COMMITTED 12/30] ada: Resolve ACATS compilation and execution issues with container aggregates Marc Poulhiès
` (18 subsequent siblings)
28 siblings, 0 replies; 30+ messages in thread
From: Marc Poulhiès @ 2024-05-20 7:48 UTC (permalink / raw)
To: gcc-patches; +Cc: Ronan Desplanques
From: Ronan Desplanques <desplanques@adacore.com>
Before this patch, on Linux, the procedure
System.Task_Primitives.Operations.Set_Task_Affinity called CPU_FREE on
instances of cpu_set_t_ptr that it didn't own when the obsolescent
Task_Info pragma was in play. This patch fixes that issue.
gcc/ada/
* libgnarl/s-taprop__linux.adb (Set_Task_Affinity): Fix
decision about whether to call CPU_FREE.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/libgnarl/s-taprop__linux.adb | 17 +++++++++++------
1 file changed, 11 insertions(+), 6 deletions(-)
diff --git a/gcc/ada/libgnarl/s-taprop__linux.adb b/gcc/ada/libgnarl/s-taprop__linux.adb
index 1faa3d8914e..0c09817739c 100644
--- a/gcc/ada/libgnarl/s-taprop__linux.adb
+++ b/gcc/ada/libgnarl/s-taprop__linux.adb
@@ -1466,12 +1466,13 @@ package body System.Task_Primitives.Operations is
and then T.Common.LL.Thread /= Null_Thread_Id
then
declare
- CPUs : constant size_t :=
- C.size_t (Multiprocessors.Number_Of_CPUs);
- CPU_Set : cpu_set_t_ptr := null;
- Size : constant size_t := CPU_ALLOC_SIZE (CPUs);
+ CPUs : constant size_t :=
+ C.size_t (Multiprocessors.Number_Of_CPUs);
+ CPU_Set : cpu_set_t_ptr := null;
+ Is_Set_Owned : Boolean := False;
+ Size : constant size_t := CPU_ALLOC_SIZE (CPUs);
- Result : C.int;
+ Result : C.int;
begin
-- We look at the specific CPU (Base_CPU) first, then at the
@@ -1483,6 +1484,7 @@ package body System.Task_Primitives.Operations is
-- Set the affinity to an unique CPU
CPU_Set := CPU_ALLOC (CPUs);
+ Is_Set_Owned := True;
System.OS_Interface.CPU_ZERO (Size, CPU_Set);
System.OS_Interface.CPU_SET
(int (T.Common.Base_CPU), Size, CPU_Set);
@@ -1499,6 +1501,7 @@ package body System.Task_Primitives.Operations is
-- dispatching domain.
CPU_Set := CPU_ALLOC (CPUs);
+ Is_Set_Owned := True;
System.OS_Interface.CPU_ZERO (Size, CPU_Set);
for Proc in T.Common.Domain'Range loop
@@ -1512,7 +1515,9 @@ package body System.Task_Primitives.Operations is
pthread_setaffinity_np (T.Common.LL.Thread, Size, CPU_Set);
pragma Assert (Result = 0);
- CPU_FREE (CPU_Set);
+ if Is_Set_Owned then
+ CPU_FREE (CPU_Set);
+ end if;
end;
end if;
end Set_Task_Affinity;
--
2.43.2
^ permalink raw reply [flat|nested] 30+ messages in thread
* [COMMITTED 12/30] ada: Resolve ACATS compilation and execution issues with container aggregates
2024-05-20 7:48 [COMMITTED 01/30] ada: Rework and augment documentation on strict aliasing Marc Poulhiès
` (9 preceding siblings ...)
2024-05-20 7:48 ` [COMMITTED 11/30] ada: Fix incorrect free with Task_Info pragma Marc Poulhiès
@ 2024-05-20 7:48 ` Marc Poulhiès
2024-05-20 7:48 ` [COMMITTED 13/30] ada: Extend expansion delaying mechanism to conditional expressions Marc Poulhiès
` (17 subsequent siblings)
28 siblings, 0 replies; 30+ messages in thread
From: Marc Poulhiès @ 2024-05-20 7:48 UTC (permalink / raw)
To: gcc-patches; +Cc: Gary Dismukes
From: Gary Dismukes <dismukes@adacore.com>
This change set addresses various compilation and execution problems
encountered in the draft ACATS tests for container aggregates:
C435001 (container aggregates with Assign_Indexed)
C435002 (container aggregates with Add_Unnamed)
C435003 (container aggregates with Add_Named)
C435004 (container aggregates with Assign_Indexed and Add_Unnamed)
gcc/ada/
* exp_aggr.adb (Expand_Container_Aggregate): Add top-level
variables Choice_{Lo|Hi} and Int_Choice_{Lo|Hi} used for
determining the low and high bounds of component association
choices. Replace code for determining whether we have an indexed
aggregate with call to new function Sem_Aggr.Is_Indexed_Aggregate.
Remove test of whether Empty_Subp is a function, since it must be
a function. Move Default and Count_Type to be locals of a new
block enclosing the code that creates the object to hold the
aggregate length, and set them according to the default and type
of the Empty function's parameter when present (and to Empty and
Standard_Natural otherwise). Use Siz_Exp for the aggregate length
when set, and use Empty's default length when available, and use
zero for the length otherwise. In generating the call to the
New_Indexed function, use the determined lower and upper bounds if
determined earlier by Aggregate_Size, and otherwise compute those
from the index type's lower bound and the determined aggregate
length. In the case where a call to Empty is generated and the
function has a formal parameter, pass the value saved in Siz_Decl
(otherwise the parameter list is empty). Remove code specific to
making a parameterless call to the Empty function. Extend the code
for handling positional container aggregates to account for types
that define Assign_Indexed, rather than just Add_Unnamed, and in
the case of indexed aggregates, create a temporary object to hold
values of the aggregate's key index, and initialize and increment
that temporary for each call generated to the Assign_Indexed
procedure. For named container aggregates that have key choices
given by ranges, call Expand_Range_Component to generate a loop
that will call the appropriate insertion procedure for each value
of the range. For indexed aggregates with a Component_Associations
list, set and use the Assign_Indexed procedure for each component
association, whether or not there's an iterator specification.
(Add_Range_Size): Add code to determine the low and high bounds of
the range and capture those in up-level variables when their value
is less than or greater than (respectively) the current minimum
and maximum bounds values.
(Aggregate_Size): Separately handle the case where a single choice
is of a discrete type, and call Add_Range_Size to take its value
into consideration for determination of min and max bounds of the
aggregate. Add comments in a couple of places.
(Build_Siz_Exp): Remove the last sentence and "???" from the
comment that talks about accumulating nonstatic sizes, since that
sentence seems to be obsolete. Record the low and high bound
values in Choice_Lo and Choice_Hi in the case of a nonstatic
range.
(Expand_Iterated_Component): Set the Defining_Identifier of the
iterator specification to the Loop_Id in the
N_Iterated_Component_Association case.
(Expand_Range_Component): Procedure unnested from the block
handling indexed aggregates in Expand_Container_Aggregate, and
moved to top level of that procedure so it can also be called for
Add_Named cases. A formal parameter Insert_Op is added, and
existing calls to this procedure are changed to pass the
appropriate insertion procedure's Entity.
* sem_aggr.ads: Add with_clause for Sinfo.Nodes.
(Is_Indexed_Aggregate): New function for use by
Resolve_Container_Aggregate and Expand_Container_Aggregate.
* sem_aggr.adb: Add with_clause for Sem_Ch5. Move with_clause for
Sinfo.Nodes to sem_aggr.ads.
(Is_Indexed_Aggregate): New function to determine whether a
container aggregate is a container aggregate (replacing local
variable of the same name in Resolve_Container_Aggregate).
(Resolve_Iterated_Association): Remove part of comment saying that
a Key_Expression is always present. Set Parent field of the copy
of a component association with a loop parameter specification. On
the setting of Loop_Param_Id, account for a
Loop_Parameter_Specification being changed into an
Iterator_Specification as a result of being analyzed. Only call
Preanalyze_And_Resolve on Key_Expr when a key expression is
actually present. Remove loop for handling choices for the case of
an N_Component_Association with a Defining_Identifier (there
shouldn't be more than one choice in this case, and add an
assertion to ensure that). Also add code here to handle the case
where the choice is a function call, creating an
iterator_specification analyzing it, and call
Resolve_Iterated_Association recursively to process it. Add error
check to enforce RM22 4.3.5(27), which requires that the type of
the loop parameter must be the same as the key type when there is
no key expression and the aggregate is an indexed aggregate or has
an Add_Named op.
(Resolve_Container_Aggregate): In the Add_Unnamed case, call
Resolve_Iterated_Association for both
N_Iterated_Element_Association and N_Component_Association (rather
than just the latter). Remove error check for nonstatic choices in
component associations in Add_Named cases (multiple named
nonstatic associations are fine except in indexed aggregates).
Remove local variable Is_Indexed_Aggregate, replaced with new
library-level function of the same name, and add test of
Is_Indexed_Aggregate in the case where the aggregate type has an
Assign_Indexed operation, as a guard for doing error checks for
indexed aggregates. For indexed aggregate resolution, do not call
Analyze_And_Resolve on the expression of an
N_Component_Association in the "box association" case. Move error
checks for indexed aggregates with iterated associations that flag
cases where an association is a loop_parameter_specification with
an iterator filter or a key expression (violation of RM22
4.3.5(28/5)), from the loop that checks for contiguous and
nonoverlapping choices and into the preceding association loop
after the call to Resolve_Iterated_Association. The RM reference
is added to the error-message strings.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/exp_aggr.adb | 444 ++++++++++++++++++++++++++-----------------
gcc/ada/sem_aggr.adb | 382 +++++++++++++++++++++++++++----------
gcc/ada/sem_aggr.ads | 16 ++
3 files changed, 569 insertions(+), 273 deletions(-)
diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb
index 8a3d1685cb3..6208b49ffd9 100644
--- a/gcc/ada/exp_aggr.adb
+++ b/gcc/ada/exp_aggr.adb
@@ -6614,8 +6614,6 @@ package body Exp_Aggr is
Temp : constant Entity_Id := Make_Temporary (Loc, 'C', N);
Comp : Node_Id;
- Decl : Node_Id;
- Default : Node_Id;
Init_Stat : Node_Id;
Siz : Int;
@@ -6623,7 +6621,15 @@ package body Exp_Aggr is
-- static and requires a dynamic evaluation.
Siz_Decl : Node_Id;
Siz_Exp : Node_Id := Empty;
- Count_Type : Entity_Id;
+
+ -- These variables are used to determine the smallest and largest
+ -- choice values. Choice_Lo and Choice_Hi are passed to the New_Indexed
+ -- function, for allocating an indexed aggregate object.
+
+ Choice_Lo : Node_Id := Empty;
+ Choice_Hi : Node_Id := Empty;
+ Int_Choice_Lo : Int;
+ Int_Choice_Hi : Int;
Is_Indexed_Aggregate : Boolean := False;
@@ -6649,6 +6655,14 @@ package body Exp_Aggr is
-- given either by a loop parameter specification or an iterator
-- specification.
+ function Expand_Range_Component
+ (Rng : Node_Id;
+ Expr : Node_Id;
+ Insert_Op : Entity_Id) return Node_Id;
+ -- Transform a component association with a range into an explicit loop
+ -- that calls the appropriate operation Insert_Op to add the value of
+ -- Expr to each container element with an index in the range.
+
--------------------
-- Aggregate_Size --
--------------------
@@ -6668,16 +6682,32 @@ package body Exp_Aggr is
--------------------
procedure Add_Range_Size is
+ Range_Int_Lo : Int;
+ Range_Int_Hi : Int;
+
begin
-- The bounds of the discrete range are integers or enumeration
-- literals
if Nkind (Lo) = N_Integer_Literal then
- Siz := Siz + UI_To_Int (Intval (Hi))
- - UI_To_Int (Intval (Lo)) + 1;
+ Range_Int_Lo := UI_To_Int (Intval (Lo));
+ Range_Int_Hi := UI_To_Int (Intval (Hi));
+
else
- Siz := Siz + UI_To_Int (Enumeration_Pos (Hi))
- - UI_To_Int (Enumeration_Pos (Lo)) + 1;
+ Range_Int_Lo := UI_To_Int (Enumeration_Pos (Lo));
+ Range_Int_Hi := UI_To_Int (Enumeration_Pos (Hi));
+ end if;
+
+ Siz := Siz + Range_Int_Hi - Range_Int_Lo + 1;
+
+ if No (Choice_Lo) or else Range_Int_Lo < Int_Choice_Lo then
+ Choice_Lo := Lo;
+ Int_Choice_Lo := Range_Int_Lo;
+ end if;
+
+ if No (Choice_Hi) or else Range_Int_Hi > Int_Choice_Hi then
+ Choice_Hi := Hi;
+ Int_Choice_Hi := Range_Int_Hi;
end if;
end Add_Range_Size;
@@ -6736,6 +6766,8 @@ package body Exp_Aggr is
Hi := High_Bound (Choice);
Add_Range_Size;
+ -- Choice is subtype_mark; add range based on its bounds
+
elsif Is_Entity_Name (Choice)
and then Is_Type (Entity (Choice))
then
@@ -6748,6 +6780,15 @@ package body Exp_Aggr is
New_Copy_Tree (Lo),
New_Copy_Tree (Hi)));
+ -- Choice is a single discrete value
+
+ elsif Is_Discrete_Type (Etype (Choice)) then
+ Lo := Choice;
+ Hi := Choice;
+ Add_Range_Size;
+
+ -- Choice is a single value of some nondiscrete type
+
else
-- Single choice (syntax excludes a subtype
-- indication).
@@ -6812,10 +6853,8 @@ package body Exp_Aggr is
return Siz;
-- The possibility of having multiple associations with nonstatic
- -- ranges (plus static ranges) means that in general we really
- -- should be accumulating a sum of the various sizes. The current
- -- code can end up overwriting Siz_Exp on subsequent associations
- -- (plus won't account for associations with static ranges). ???
+ -- ranges (plus static ranges) means that in general we have to
+ -- accumulate a sum of the various sizes.
else
Temp_Siz_Exp :=
@@ -6827,6 +6866,12 @@ package body Exp_Aggr is
Right_Opnd =>
Make_Integer_Literal (Loc, 1));
+ -- Capture the nonstatic bounds, for later use in passing on
+ -- the call to New_Indexed.
+
+ Choice_Lo := Lo;
+ Choice_Hi := Hi;
+
-- Include this nonstatic length in the total length being
-- accumulated in Siz_Exp.
@@ -6939,6 +6984,8 @@ package body Exp_Aggr is
L_Iteration_Scheme :=
Make_Iteration_Scheme (Loc,
Iterator_Specification => Iterator_Specification (Comp));
+ Set_Defining_Identifier
+ (Iterator_Specification (L_Iteration_Scheme), Loop_Id);
else
-- Loop_Parameter_Specification is parsed with a choice list.
@@ -7004,6 +7051,45 @@ package body Exp_Aggr is
end Expand_Iterated_Component;
+ ----------------------------
+ -- Expand_Range_Component --
+ ----------------------------
+
+ function Expand_Range_Component
+ (Rng : Node_Id;
+ Expr : Node_Id;
+ Insert_Op : Entity_Id) return Node_Id
+ is
+ Loop_Id : constant Entity_Id :=
+ Make_Temporary (Loc, 'T');
+
+ L_Iteration_Scheme : Node_Id;
+ Stats : List_Id;
+
+ begin
+ L_Iteration_Scheme :=
+ Make_Iteration_Scheme (Loc,
+ Loop_Parameter_Specification =>
+ Make_Loop_Parameter_Specification (Loc,
+ Defining_Identifier => Loop_Id,
+ Discrete_Subtype_Definition => New_Copy_Tree (Rng)));
+
+ Stats := New_List
+ (Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Occurrence_Of (Insert_Op, Loc),
+ Parameter_Associations =>
+ New_List (New_Occurrence_Of (Temp, Loc),
+ New_Occurrence_Of (Loop_Id, Loc),
+ New_Copy_Tree (Expr))));
+
+ return Make_Implicit_Loop_Statement
+ (Node => N,
+ Identifier => Empty,
+ Iteration_Scheme => L_Iteration_Scheme,
+ Statements => Stats);
+ end Expand_Range_Component;
+
-- Start of processing for Expand_Container_Aggregate
begin
@@ -7013,34 +7099,9 @@ package body Exp_Aggr is
-- Determine whether this is an indexed aggregate (see RM 4.3.5(25/5))
- if Present (New_Indexed_Subp) then
- if No (Add_Unnamed_Subp) then
- Is_Indexed_Aggregate := True;
-
- else
- declare
- Comp_Assns : constant List_Id := Component_Associations (N);
- Comp_Assn : Node_Id;
-
- begin
- if not Is_Empty_List (Comp_Assns) then
-
- -- It suffices to look at the first association to determine
- -- whether the aggregate is an indexed aggregate.
-
- Comp_Assn := First (Comp_Assns);
-
- if Nkind (Comp_Assn) = N_Component_Association
- or else
- (Nkind (Comp_Assn) = N_Iterated_Component_Association
- and then Present (Defining_Identifier (Comp_Assn)))
- then
- Is_Indexed_Aggregate := True;
- end if;
- end if;
- end;
- end if;
- end if;
+ Is_Indexed_Aggregate
+ := Sem_Aggr.Is_Indexed_Aggregate
+ (N, Add_Unnamed_Subp, New_Indexed_Subp);
-- The constructor for bounded containers is a function with
-- a parameter that sets the size of the container. If the
@@ -7049,35 +7110,50 @@ package body Exp_Aggr is
Siz := Aggregate_Size;
- ---------------------
- -- Empty function --
- ---------------------
-
- if Ekind (Entity (Empty_Subp)) = E_Function
- and then Present (First_Formal (Entity (Empty_Subp)))
- then
- Default := Default_Value (First_Formal (Entity (Empty_Subp)));
+ declare
+ Count_Type : Entity_Id := Standard_Natural;
+ Default : Node_Id := Empty;
+ Empty_First_Formal : constant Entity_Id
+ := First_Formal (Entity (Empty_Subp));
+ Param_List : List_Id;
- -- If aggregate size is not static, we can use default value
- -- of formal parameter for allocation. We assume that this
- -- (implementation-dependent) value is static, even though
- -- the AI does not require it.
+ begin
+ -- If aggregate size is not static, we use the default value of the
+ -- Empty operation's formal parameter for the allocation. We assume
+ -- that this (implementation-dependent) value is static, even though
+ -- the AI does not require it.
+
+ if Present (Empty_First_Formal) then
+ Default := Default_Value (Empty_First_Formal);
+ Count_Type := Etype (Empty_First_Formal);
+ end if;
- -- Create declaration for size: a constant literal in the simple
- -- case, an expression if iterated component associations may be
- -- involved, the default otherwise.
+ -- Create an object initialized by the aggregate's determined size
+ -- (number of elements): a constant literal in the simple case, an
+ -- expression if iterated component associations may be involved,
+ -- and the default otherwise.
- Count_Type := Etype (First_Formal (Entity (Empty_Subp)));
if Siz = -1 then
- if No (Siz_Exp) then
+ if No (Siz_Exp)
+ and Present (Default)
+ then
Siz := UI_To_Int (Intval (Default));
Siz_Exp := Make_Integer_Literal (Loc, Siz);
- else
+ elsif Present (Siz_Exp) then
Siz_Exp := Make_Type_Conversion (Loc,
Subtype_Mark =>
New_Occurrence_Of (Count_Type, Loc),
Expression => Siz_Exp);
+
+ -- If the length isn't known and there's not a default, then use
+ -- zero for the initial container length.
+
+ else
+ Siz_Exp := Make_Type_Conversion (Loc,
+ Subtype_Mark =>
+ New_Occurrence_Of (Count_Type, Loc),
+ Expression => Make_Integer_Literal (Loc, 0));
end if;
else
@@ -7100,21 +7176,30 @@ package body Exp_Aggr is
Entity (Assign_Indexed_Subp);
Index_Type : constant Entity_Id :=
Etype (Next_Formal (First_Formal (Insert)));
- Index : Node_Id;
begin
- Index := Make_Op_Add (Loc,
- Left_Opnd => New_Copy_Tree (Type_Low_Bound (Index_Type)),
- Right_Opnd =>
- Make_Op_Subtract (Loc,
- Left_Opnd => Make_Type_Conversion (Loc,
- Subtype_Mark =>
- New_Occurrence_Of (Index_Type, Loc),
- Expression =>
- New_Occurrence_Of
- (Defining_Identifier (Siz_Decl),
- Loc)),
- Right_Opnd => Make_Integer_Literal (Loc, 1)));
+ if No (Choice_Lo) then
+ pragma Assert (No (Choice_Hi));
+
+ Choice_Lo := New_Copy_Tree (Type_Low_Bound (Index_Type));
+
+ Choice_Hi := Make_Op_Add (Loc,
+ Left_Opnd => New_Copy_Tree (Type_Low_Bound (Index_Type)),
+ Right_Opnd =>
+ Make_Op_Subtract (Loc,
+ Left_Opnd => Make_Type_Conversion (Loc,
+ Subtype_Mark =>
+ New_Occurrence_Of (Index_Type, Loc),
+ Expression =>
+ New_Occurrence_Of
+ (Defining_Identifier (Siz_Decl),
+ Loc)),
+ Right_Opnd => Make_Integer_Literal (Loc, 1)));
+
+ else
+ Choice_Lo := New_Copy_Tree (Choice_Lo);
+ Choice_Hi := New_Copy_Tree (Choice_Hi);
+ end if;
Init_Stat :=
Make_Object_Declaration (Loc,
@@ -7124,52 +7209,33 @@ package body Exp_Aggr is
Name =>
New_Occurrence_Of (Entity (New_Indexed_Subp), Loc),
Parameter_Associations =>
- New_List (
- New_Copy_Tree (Type_Low_Bound (Index_Type)),
- Index)));
+ New_List (Choice_Lo, Choice_Hi)));
end;
- -- Otherwise we generate a call to the Empty operation, passing
- -- the determined number of elements as saved in Siz_Decl.
+ -- Otherwise we generate a call to the Empty function, passing the
+ -- determined number of elements as saved in Siz_Decl if the function
+ -- has a formal parameter, and otherwise making a parameterless call.
else
+ if Present (Empty_First_Formal) then
+ Param_List :=
+ New_List
+ (New_Occurrence_Of (Defining_Identifier (Siz_Decl), Loc));
+ else
+ Param_List := No_List;
+ end if;
+
Init_Stat :=
Make_Object_Declaration (Loc,
Defining_Identifier => Temp,
Object_Definition => New_Occurrence_Of (Typ, Loc),
Expression => Make_Function_Call (Loc,
Name => New_Occurrence_Of (Entity (Empty_Subp), Loc),
- Parameter_Associations =>
- New_List
- (New_Occurrence_Of
- (Defining_Identifier (Siz_Decl), Loc))));
+ Parameter_Associations => Param_List));
end if;
Append (Init_Stat, Aggr_Code);
-
- -- The container will grow dynamically. Create a declaration for
- -- the object, and initialize it from a call to the parameterless
- -- Empty function.
-
- else
- pragma Assert (Ekind (Entity (Empty_Subp)) = E_Function);
-
- Decl :=
- Make_Object_Declaration (Loc,
- Defining_Identifier => Temp,
- Object_Definition => New_Occurrence_Of (Typ, Loc));
-
- Insert_Action (N, Decl);
-
- -- The Empty entity is a parameterless function
-
- Init_Stat := Make_Assignment_Statement (Loc,
- Name => New_Occurrence_Of (Temp, Loc),
- Expression => Make_Function_Call (Loc,
- Name => New_Occurrence_Of (Entity (Empty_Subp), Loc)));
-
- Append (Init_Stat, Aggr_Code);
- end if;
+ end;
-- Report warning on infinite recursion if an empty container aggregate
-- appears in the return statement of its Empty function.
@@ -7192,24 +7258,88 @@ package body Exp_Aggr is
-- Positional aggregate --
---------------------------
- -- If the aggregate is positional the aspect must include
- -- an Add_Unnamed subprogram.
+ -- If the aggregate is positional, then the aspect must include
+ -- an Add_Unnamed or Assign_Indexed procedure.
- if Present (Add_Unnamed_Subp) then
+ if not Is_Null_Aggregate (N)
+ and then
+ (Present (Add_Unnamed_Subp) or else Present (Assign_Indexed_Subp))
+ then
if Present (Expressions (N)) then
declare
- Insert : constant Entity_Id := Entity (Add_Unnamed_Subp);
+ Insert : constant Entity_Id :=
+ (if Is_Indexed_Aggregate
+ then Entity (Assign_Indexed_Subp)
+ else Entity (Add_Unnamed_Subp));
Comp : Node_Id;
Stat : Node_Id;
+ Param_List : List_Id;
+ Key_Type : Entity_Id;
+ Key_Index : Entity_Id;
begin
+ -- For an indexed aggregate, use Etype of the Assign_Indexed
+ -- procedure's second formal as the key type, and declare an
+ -- index object of that type, which will iterate over the key
+ -- type values while traversing the component associations.
+
+ if Is_Indexed_Aggregate then
+ Key_Type :=
+ Etype (Next_Formal
+ (First_Formal (Entity (Assign_Indexed_Subp))));
+
+ Key_Index := Make_Temporary (Loc, 'I', N);
+
+ Append_To (Aggr_Code,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Key_Index,
+ Object_Definition =>
+ New_Occurrence_Of (Key_Type, Loc)));
+ end if;
+
Comp := First (Expressions (N));
while Present (Comp) loop
+ if Is_Indexed_Aggregate then
+
+ -- Generate an assignment to set the first key value of
+ -- the key index object from the key type's lower bound.
+
+ if Comp = First (Expressions (N)) then
+ Append_To (Aggr_Code,
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Key_Index, Loc),
+ Expression =>
+ New_Copy (Type_Low_Bound (Key_Type))));
+
+ -- Generate an assignment to increment the key value
+ -- for the subsequent component assignments.
+
+ else
+ Append_To (Aggr_Code,
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Key_Index, Loc),
+ Expression =>
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Key_Type, Loc),
+ Attribute_Name => Name_Succ,
+ Expressions => New_List (
+ New_Occurrence_Of (Key_Index, Loc)))));
+ end if;
+
+ Param_List :=
+ New_List (New_Occurrence_Of (Temp, Loc),
+ New_Occurrence_Of (Key_Index, Loc),
+ New_Copy_Tree (Comp));
+ else
+ Param_List :=
+ New_List (New_Occurrence_Of (Temp, Loc),
+ New_Copy_Tree (Comp));
+ end if;
+
Stat := Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (Insert, Loc),
- Parameter_Associations =>
- New_List (New_Occurrence_Of (Temp, Loc),
- New_Copy_Tree (Comp)));
+ Parameter_Associations => Param_List);
Append (Stat, Aggr_Code);
Next (Comp);
end loop;
@@ -7221,7 +7351,9 @@ package body Exp_Aggr is
elsif not Is_Indexed_Aggregate then
Comp := First (Component_Associations (N));
while Present (Comp) loop
- if Nkind (Comp) = N_Iterated_Component_Association then
+ if Nkind (Comp) = N_Iterated_Component_Association
+ or else Nkind (Comp) = N_Iterated_Element_Association
+ then
Expand_Iterated_Component (Comp);
end if;
Next (Comp);
@@ -7252,12 +7384,23 @@ package body Exp_Aggr is
Key := First (Choices (Comp));
while Present (Key) loop
- Stat := Make_Procedure_Call_Statement (Loc,
- Name => New_Occurrence_Of (Insert, Loc),
- Parameter_Associations =>
- New_List (New_Occurrence_Of (Temp, Loc),
- New_Copy_Tree (Key),
- New_Copy_Tree (Expression (Comp))));
+ if Nkind (Key) = N_Range then
+
+ -- Create loop for the specified range, with copies of
+ -- the expression.
+
+ Stat := Expand_Range_Component
+ (Key, Expression (Comp), Insert);
+
+ else
+ Stat := Make_Procedure_Call_Statement (Loc,
+ Name => New_Occurrence_Of (Insert, Loc),
+ Parameter_Associations =>
+ New_List (New_Occurrence_Of (Temp, Loc),
+ New_Copy_Tree (Key),
+ New_Copy_Tree (Expression (Comp))));
+ end if;
+
Append (Stat, Aggr_Code);
Next (Key);
@@ -7285,57 +7428,11 @@ package body Exp_Aggr is
and then not Is_Empty_List (Component_Associations (N))
then
declare
-
- function Expand_Range_Component
- (Rng : Node_Id;
- Expr : Node_Id) return Node_Id;
- -- Transform a component association with a range into an
- -- explicit loop. If the choice is a subtype name, it is
- -- rewritten as a range with the corresponding bounds, which
- -- are known to be static.
-
+ Insert : constant Entity_Id := Entity (Assign_Indexed_Subp);
Comp : Node_Id;
Stat : Node_Id;
Key : Node_Id;
- ----------------------------
- -- Expand_Range_Component --
- ----------------------------
-
- function Expand_Range_Component
- (Rng : Node_Id;
- Expr : Node_Id) return Node_Id
- is
- Loop_Id : constant Entity_Id :=
- Make_Temporary (Loc, 'T');
-
- L_Iteration_Scheme : Node_Id;
- Stats : List_Id;
-
- begin
- L_Iteration_Scheme :=
- Make_Iteration_Scheme (Loc,
- Loop_Parameter_Specification =>
- Make_Loop_Parameter_Specification (Loc,
- Defining_Identifier => Loop_Id,
- Discrete_Subtype_Definition => New_Copy_Tree (Rng)));
-
- Stats := New_List
- (Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of (Entity (Assign_Indexed_Subp), Loc),
- Parameter_Associations =>
- New_List (New_Occurrence_Of (Temp, Loc),
- New_Occurrence_Of (Loop_Id, Loc),
- New_Copy_Tree (Expr))));
-
- return Make_Implicit_Loop_Statement
- (Node => N,
- Identifier => Empty,
- Iteration_Scheme => L_Iteration_Scheme,
- Statements => Stats);
- end Expand_Range_Component;
-
begin
pragma Assert (No (Expressions (N)));
@@ -7357,20 +7454,20 @@ package body Exp_Aggr is
elsif Nkind (Key) = N_Range then
- -- Create loop for tne specified range,
+ -- Create loop for the specified range,
-- with copies of the expression.
Stat :=
- Expand_Range_Component (Key, Expression (Comp));
+ Expand_Range_Component
+ (Key, Expression (Comp), Insert);
else
Stat := Make_Procedure_Call_Statement (Loc,
- Name => New_Occurrence_Of
- (Entity (Assign_Indexed_Subp), Loc),
- Parameter_Associations =>
- New_List (New_Occurrence_Of (Temp, Loc),
- New_Copy_Tree (Key),
- New_Copy_Tree (Expression (Comp))));
+ Name => New_Occurrence_Of (Insert, Loc),
+ Parameter_Associations =>
+ New_List (New_Occurrence_Of (Temp, Loc),
+ New_Copy_Tree (Key),
+ New_Copy_Tree (Expression (Comp))));
end if;
Append (Stat, Aggr_Code);
@@ -7384,10 +7481,11 @@ package body Exp_Aggr is
-- positional insertion procedure.
if No (Iterator_Specification (Comp)) then
- Add_Named_Subp := Assign_Indexed_Subp;
Add_Unnamed_Subp := Empty;
end if;
+ Add_Named_Subp := Assign_Indexed_Subp;
+
Expand_Iterated_Component (Comp);
end if;
diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb
index 14c68b5eaf3..658b3a4634c 100644
--- a/gcc/ada/sem_aggr.adb
+++ b/gcc/ada/sem_aggr.adb
@@ -49,6 +49,7 @@ with Sem_Aux; use Sem_Aux;
with Sem_Case; use Sem_Case;
with Sem_Cat; use Sem_Cat;
with Sem_Ch3; use Sem_Ch3;
+with Sem_Ch5; use Sem_Ch5;
with Sem_Ch8; use Sem_Ch8;
with Sem_Ch13; use Sem_Ch13;
with Sem_Dim; use Sem_Dim;
@@ -58,7 +59,6 @@ with Sem_Util; use Sem_Util;
with Sem_Type; use Sem_Type;
with Sem_Warn; use Sem_Warn;
with Sinfo; use Sinfo;
-with Sinfo.Nodes; use Sinfo.Nodes;
with Sinfo.Utils; use Sinfo.Utils;
with Snames; use Snames;
with Stringt; use Stringt;
@@ -781,6 +781,102 @@ package body Sem_Aggr is
end if;
end Is_Deep_Choice;
+ --------------------------
+ -- Is_Indexed_Aggregate --
+ --------------------------
+
+ function Is_Indexed_Aggregate
+ (N : N_Aggregate_Id;
+ Add_Unnamed : Node_Id;
+ New_Indexed : Node_Id) return Boolean
+ is
+ begin
+ if Present (New_Indexed)
+ and then not Is_Null_Aggregate (N)
+ then
+ if No (Add_Unnamed) then
+ return True;
+
+ else
+ declare
+ Comp_Assns : constant List_Id := Component_Associations (N);
+ Comp_Assn : Node_Id;
+
+ begin
+ if not Is_Empty_List (Comp_Assns) then
+
+ -- It suffices to look at the first association to determine
+ -- whether the aggregate is an indexed aggregate.
+
+ Comp_Assn := First (Comp_Assns);
+
+ -- Test for the component association being either:
+ --
+ -- 1) an N_Component_Association node, in which case there
+ -- is a list of choices (the "key choices");
+ --
+ -- or else:
+ --
+ -- 2) an N_Iterated_Component_Association node that has
+ -- a Defining_Identifier, in which case it has
+ -- Discrete_Choices that effectively make it
+ -- equivalent to a Loop_Parameter_Specification;
+ --
+ -- or else:
+ --
+ -- 3) an N_Iterated_Element_Association node with
+ -- a Loop_Parameter_Specification with a discrete
+ -- subtype or range.
+ --
+ -- This basically corresponds to the definition of indexed
+ -- aggregates (in RM22 4.3.5(25/5)), but the GNAT tree
+ -- representation doesn't always directly match the RM
+ -- syntax for various reasons.
+
+ if Nkind (Comp_Assn) = N_Component_Association
+ or else
+ (Nkind (Comp_Assn) = N_Iterated_Component_Association
+ and then Present (Defining_Identifier (Comp_Assn)))
+ then
+ return True;
+
+ -- In the case of an iterated_element_association with a
+ -- loop_parameter_specification, we have to look deeper to
+ -- confirm that it is not actually an iterator_specification
+ -- masquerading as a loop_parameter_specification. Those can
+ -- share syntax (for example, having the iterator of form
+ -- "for C in <function-call>") and a rewrite into an
+ -- iterator_specification can happen later.
+
+ elsif Nkind (Comp_Assn) = N_Iterated_Element_Association
+ and then Present (Loop_Parameter_Specification (Comp_Assn))
+ then
+ declare
+ Loop_Parm_Spec : constant Node_Id :=
+ Loop_Parameter_Specification (Comp_Assn);
+ Discr_Subt_Defn : constant Node_Id :=
+ Discrete_Subtype_Definition (Loop_Parm_Spec);
+ begin
+ if Nkind (Discr_Subt_Defn) = N_Range
+ or else
+ Nkind (Discr_Subt_Defn) = N_Subtype_Indication
+ or else
+ (Is_Entity_Name (Discr_Subt_Defn)
+ and then
+ Is_Type (Entity (Discr_Subt_Defn)))
+ then
+ return True;
+ end if;
+ end;
+ end if;
+ end if;
+ end;
+ end if;
+ end if;
+
+ return False;
+ end Is_Indexed_Aggregate;
+
-------------------------
-- Is_Others_Aggregate --
-------------------------
@@ -3227,22 +3323,23 @@ package body Sem_Aggr is
Key_Type : Entity_Id;
Elmt_Type : Entity_Id)
is
- Loc : constant Source_Ptr := Sloc (N);
- Choice : Node_Id;
- Copy : Node_Id;
- Ent : Entity_Id;
- Expr : Node_Id;
- Key_Expr : Node_Id;
- Id : Entity_Id;
- Id_Name : Name_Id;
- Typ : Entity_Id := Empty;
+ Loc : constant Source_Ptr := Sloc (N);
+ Choice : Node_Id;
+ Copy : Node_Id;
+ Ent : Entity_Id;
+ Expr : Node_Id;
+ Key_Expr : Node_Id := Empty;
+ Id : Entity_Id;
+ Id_Name : Name_Id;
+ Typ : Entity_Id := Empty;
+ Loop_Param_Id : Entity_Id := Empty;
begin
Error_Msg_Ada_2022_Feature ("iterated component", Loc);
-- If this is an Iterated_Element_Association then either a
-- an Iterator_Specification or a Loop_Parameter specification
- -- is present. In both cases a Key_Expression is present.
+ -- is present.
if Nkind (Comp) = N_Iterated_Element_Association then
@@ -3258,18 +3355,27 @@ package body Sem_Aggr is
if Present (Loop_Parameter_Specification (Comp)) then
Copy := Copy_Separate_Tree (Comp);
+ Set_Parent (Copy, Parent (Comp));
Analyze
(Loop_Parameter_Specification (Copy));
- Id_Name := Chars (Defining_Identifier
- (Loop_Parameter_Specification (Comp)));
+ if Present (Iterator_Specification (Copy)) then
+ Loop_Param_Id :=
+ Defining_Identifier (Iterator_Specification (Copy));
+ else
+ Loop_Param_Id :=
+ Defining_Identifier (Loop_Parameter_Specification (Copy));
+ end if;
+
+ Id_Name := Chars (Loop_Param_Id);
else
Copy := Copy_Separate_Tree (Iterator_Specification (Comp));
Analyze (Copy);
- Id_Name := Chars (Defining_Identifier
- (Iterator_Specification (Comp)));
+ Loop_Param_Id := Defining_Identifier (Copy);
+
+ Id_Name := Chars (Loop_Param_Id);
end if;
-- Key expression must have the type of the key. We preanalyze
@@ -3278,10 +3384,12 @@ package body Sem_Aggr is
-- corresponding loop.
Key_Expr := Key_Expression (Comp);
- Preanalyze_And_Resolve (New_Copy_Tree (Key_Expr), Key_Type);
+ if Present (Key_Expr) then
+ Preanalyze_And_Resolve (New_Copy_Tree (Key_Expr), Key_Type);
+ end if;
End_Scope;
- Typ := Key_Type;
+ Typ := Etype (Loop_Param_Id);
elsif Present (Iterator_Specification (Comp)) then
-- Create a temporary scope to avoid some modifications from
@@ -3294,9 +3402,12 @@ package body Sem_Aggr is
Set_Parent (Ent, Parent (Comp));
Push_Scope (Ent);
- Copy := Copy_Separate_Tree (Iterator_Specification (Comp));
- Id_Name :=
- Chars (Defining_Identifier (Iterator_Specification (Comp)));
+ Copy := Copy_Separate_Tree (Iterator_Specification (Comp));
+
+ Loop_Param_Id :=
+ Defining_Identifier (Iterator_Specification (Comp));
+
+ Id_Name := Chars (Loop_Param_Id);
Preanalyze (Copy);
@@ -3307,28 +3418,58 @@ package body Sem_Aggr is
else
Choice := First (Discrete_Choices (Comp));
- while Present (Choice) loop
- Analyze (Choice);
+ -- This is an N_Component_Association with a Defining_Identifier
+ -- and Discrete_Choice_List, but the latter can only have a single
+ -- choice, as it's a stand-in for a Loop_Parameter_Specification
+ -- (or possibly even an Iterator_Specification, see below).
- -- Choice can be a subtype name, a range, or an expression
+ pragma Assert (No (Next (Choice)));
- if Is_Entity_Name (Choice)
- and then Is_Type (Entity (Choice))
- and then Base_Type (Entity (Choice)) = Base_Type (Key_Type)
- then
- null;
+ Analyze (Choice);
- elsif Present (Key_Type) then
- Analyze_And_Resolve (Choice, Key_Type);
- Typ := Key_Type;
- else
- Typ := Etype (Choice); -- assume unique for now
- end if;
+ -- Choice can be a subtype name, a range, or an expression
- Next (Choice);
- end loop;
+ if Is_Entity_Name (Choice)
+ and then Is_Type (Entity (Choice))
+ and then Base_Type (Entity (Choice)) = Base_Type (Key_Type)
+ then
+ null;
+
+ elsif Nkind (Choice) = N_Function_Call then
+ declare
+ I_Spec : constant Node_Id :=
+ Make_Iterator_Specification (Sloc (N),
+ Defining_Identifier =>
+ Relocate_Node (Defining_Identifier (Comp)),
+ Name => New_Copy_Tree (Choice),
+ Reverse_Present => False,
+ Iterator_Filter => Empty,
+ Subtype_Indication => Empty);
+ begin
+ Set_Iterator_Specification (Comp, I_Spec);
+ Set_Defining_Identifier (Comp, Empty);
+
+ Analyze_Iterator_Specification
+ (Iterator_Specification (Comp));
+
+ Resolve_Iterated_Association (Comp, Key_Type, Elmt_Type);
+ -- Recursive call to expand association as iterator_spec
+
+ return;
+ end;
+
+ elsif Present (Key_Type) then
+ Analyze_And_Resolve (Choice, Key_Type);
+ Typ := Key_Type;
+
+ else
+ Typ := Etype (Choice); -- assume unique for now
+ end if;
+
+ Loop_Param_Id :=
+ Defining_Identifier (Comp);
- Id_Name := Chars (Defining_Identifier (Comp));
+ Id_Name := Chars (Loop_Param_Id);
end if;
-- Create a scope in which to introduce an index, which is usually
@@ -3358,6 +3499,21 @@ package body Sem_Aggr is
Set_Scope (Id, Ent);
Set_Referenced (Id);
+ -- Check for violation of 4.3.5(27/5)
+
+ if No (Key_Expr)
+ and then Present (Key_Type)
+ and then
+ (Is_Indexed_Aggregate (N, Add_Unnamed_Subp, New_Indexed_Subp)
+ or else Present (Add_Named_Subp))
+ and then Base_Type (Key_Type) /= Base_Type (Typ)
+ then
+ Error_Msg_Node_2 := Key_Type;
+ Error_Msg_NE
+ ("loop parameter type & must be same as key type & " &
+ "(RM22 4.3.5(27))", Loop_Param_Id, Typ);
+ end if;
+
-- Analyze a copy of the expression, to verify legality. We use
-- a copy because the expression will be analyzed anew when the
-- enclosing aggregate is expanded, and the construct is rewritten
@@ -3409,15 +3565,16 @@ package body Sem_Aggr is
Comp : Node_Id := First (Component_Associations (N));
begin
while Present (Comp) loop
- if Nkind (Comp) /=
- N_Iterated_Component_Association
+ if Nkind (Comp) in
+ N_Iterated_Component_Association |
+ N_Iterated_Element_Association
then
+ Resolve_Iterated_Association
+ (Comp, Empty, Elmt_Type);
+ else
Error_Msg_N ("illegal component association "
& "for unnamed container aggregate", Comp);
return;
- else
- Resolve_Iterated_Association
- (Comp, Empty, Elmt_Type);
end if;
Next (Comp);
@@ -3463,10 +3620,6 @@ package body Sem_Aggr is
while Present (Choice) loop
Analyze_And_Resolve (Choice, Key_Type);
- if not Is_Static_Expression (Choice) then
- Error_Msg_N ("choice must be static", Choice);
- end if;
-
Next (Choice);
end loop;
@@ -3535,7 +3688,9 @@ package body Sem_Aggr is
Next (Choice);
end loop;
- Analyze_And_Resolve (Expression (Comp), Comp_Type);
+ if not Box_Present (Comp) then
+ Analyze_And_Resolve (Expression (Comp), Comp_Type);
+ end if;
elsif Nkind (Comp) in
N_Iterated_Component_Association |
@@ -3543,6 +3698,56 @@ package body Sem_Aggr is
then
Resolve_Iterated_Association
(Comp, Index_Type, Comp_Type);
+
+ -- Check the legality rule of RM22 4.3.5(28/5). Note that
+ -- Is_Indexed_Aggregate can change its status (to False)
+ -- as a result of calling Resolve_Iterated_Association,
+ -- due to possible expansion of iterator_specifications
+ -- there.
+
+ if Is_Indexed_Aggregate
+ (N, Add_Unnamed_Subp, New_Indexed_Subp)
+ then
+ if Nkind (Comp) = N_Iterated_Element_Association then
+ if Present (Loop_Parameter_Specification (Comp))
+ then
+ if Present (Iterator_Filter
+ (Loop_Parameter_Specification (Comp)))
+ then
+ Error_Msg_N
+ ("iterator filter not allowed " &
+ "in indexed aggregate (RM22 4.3.5(28))",
+ Iterator_Filter
+ (Loop_Parameter_Specification (Comp)));
+ return;
+
+ elsif Present (Key_Expression (Comp)) then
+ Error_Msg_N
+ ("key expression not allowed " &
+ "in indexed aggregate (RM22 4.3.5(28))",
+ Key_Expression (Comp));
+ return;
+ end if;
+
+ elsif Present (Iterator_Specification (Comp)) then
+ Error_Msg_N
+ ("iterator specification not allowed " &
+ "in indexed aggregate (RM22 4.3.5(28))",
+ Iterator_Specification (Comp));
+ return;
+ end if;
+
+ elsif Nkind (Comp) = N_Iterated_Component_Association
+ and then Present (Iterator_Specification (Comp))
+ then
+ Error_Msg_N
+ ("iterator specification not allowed " &
+ "in indexed aggregate (RM22 4.3.5(28))",
+ Iterator_Specification (Comp));
+ return;
+ end if;
+ end if;
+
Num_Choices := Num_Choices + 1;
end if;
@@ -3569,67 +3774,44 @@ package body Sem_Aggr is
begin
Comp := First (Component_Associations (N));
while Present (Comp) loop
- if Nkind (Comp) = N_Iterated_Element_Association then
- if Present
- (Loop_Parameter_Specification (Comp))
- then
- if Present (Iterator_Filter
- (Loop_Parameter_Specification (Comp)))
- then
- Error_Msg_N
- ("iterator filter not allowed " &
- "in indexed aggregate", Comp);
- return;
-
- elsif Present (Key_Expression
- (Loop_Parameter_Specification (Comp)))
- then
- Error_Msg_N
- ("key expression not allowed " &
- "in indexed aggregate", Comp);
- return;
- end if;
- end if;
- else
- -- If Nkind is N_Iterated_Component_Association,
- -- this corresponds to an iterator_specification
- -- with a loop_parameter_specification, and we
- -- have to pick up Discrete_Choices. In this case
- -- there will be just one "choice", which will
- -- typically be a range.
+ -- If Nkind is N_Iterated_Component_Association,
+ -- this corresponds to an iterator_specification
+ -- with a loop_parameter_specification, and we
+ -- have to pick up Discrete_Choices. In this case
+ -- there will be just one "choice", which will
+ -- typically be a range.
- if Nkind (Comp) = N_Iterated_Component_Association
- then
- Choice := First (Discrete_Choices (Comp));
+ if Nkind (Comp) = N_Iterated_Component_Association
+ then
+ Choice := First (Discrete_Choices (Comp));
- -- Case where there's a list of choices
+ -- Case where there's a list of choices
- else
- Choice := First (Choices (Comp));
- end if;
+ else
+ Choice := First (Choices (Comp));
+ end if;
- while Present (Choice) loop
- Get_Index_Bounds (Choice, Lo, Hi);
- Table (No_Choice).Choice := Choice;
- Table (No_Choice).Lo := Lo;
- Table (No_Choice).Hi := Hi;
+ while Present (Choice) loop
+ Get_Index_Bounds (Choice, Lo, Hi);
+ Table (No_Choice).Choice := Choice;
+ Table (No_Choice).Lo := Lo;
+ Table (No_Choice).Hi := Hi;
- -- Verify staticness of value or range
+ -- Verify staticness of value or range
- if not Is_Static_Expression (Lo)
- or else not Is_Static_Expression (Hi)
- then
- Error_Msg_N
- ("nonstatic expression for index " &
- "for indexed aggregate", Choice);
- return;
- end if;
+ if not Is_Static_Expression (Lo)
+ or else not Is_Static_Expression (Hi)
+ then
+ Error_Msg_N
+ ("nonstatic expression for index " &
+ "for indexed aggregate", Choice);
+ return;
+ end if;
- No_Choice := No_Choice + 1;
- Next (Choice);
- end loop;
- end if;
+ No_Choice := No_Choice + 1;
+ Next (Choice);
+ end loop;
Next (Comp);
end loop;
diff --git a/gcc/ada/sem_aggr.ads b/gcc/ada/sem_aggr.ads
index 36827fa3267..36dc0ebc893 100644
--- a/gcc/ada/sem_aggr.ads
+++ b/gcc/ada/sem_aggr.ads
@@ -27,6 +27,7 @@
-- part of Sem_Res, but is split off since the aggregate code is so complex.
with Einfo.Entities; use Einfo.Entities;
+with Sinfo.Nodes; use Sinfo.Nodes;
with Types; use Types;
package Sem_Aggr is
@@ -44,6 +45,21 @@ package Sem_Aggr is
-- WARNING: There is a matching C declaration of this subprogram in fe.h
+ function Is_Indexed_Aggregate
+ (N : N_Aggregate_Id;
+ Add_Unnamed : Node_Id;
+ New_Indexed : Node_Id) return Boolean;
+ -- Returns True if N satisfies the criteria for being an indexed aggregate,
+ -- that is, N is a container aggregate whose type has an Aggregate aspect
+ -- that specifies a New_Indexed operation (it's Present), the aggregate
+ -- is not a null aggregate, and either the type doesn't specify Add_Unnamed
+ -- or there is a component association that is an N_Component_Association
+ -- or is an N_Iterated_Component_Association with a Defining_Identifier.
+ -- Returns False otherwise. The actuals for the Add_Unnamed and New_Indexed
+ -- formals must be nodes that are names denoting the subprograms specified
+ -- for those operations in the Aggregate aspect of the aggregate's type,
+ -- or else Empty if the operation was not specified.
+
function Is_Null_Aggregate (N : Node_Id) return Boolean;
-- Returns True for a "[]" aggregate (an Ada 2022 feature), even after
-- it has been transformed by expansion. Returns False otherwise.
--
2.43.2
^ permalink raw reply [flat|nested] 30+ messages in thread
* [COMMITTED 13/30] ada: Extend expansion delaying mechanism to conditional expressions
2024-05-20 7:48 [COMMITTED 01/30] ada: Rework and augment documentation on strict aliasing Marc Poulhiès
` (10 preceding siblings ...)
2024-05-20 7:48 ` [COMMITTED 12/30] ada: Resolve ACATS compilation and execution issues with container aggregates Marc Poulhiès
@ 2024-05-20 7:48 ` Marc Poulhiès
2024-05-20 7:48 ` [COMMITTED 14/30] ada: Tweak handling of thread ID on POSIX Marc Poulhiès
` (16 subsequent siblings)
28 siblings, 0 replies; 30+ messages in thread
From: Marc Poulhiès @ 2024-05-20 7:48 UTC (permalink / raw)
To: gcc-patches; +Cc: Eric Botcazou
From: Eric Botcazou <ebotcazou@adacore.com>
When an aggregate that needs to be converted into a series of assignments is
present in an expression of a parent aggregate, or in the expression of an
allocator, an object declaration, or an assignment in very specific cases,
its expansion is delayed until its parent itself is expanded. This makes
it possible to avoid creating a superfluous temporary for the aggregate.
This change extends the delaying mechanism in the case of record aggregates
to intermediate conditional expressions, that is to say, to the conditional
expressions that are present between the parent and the aggregate, provided
that the aggregate be a dependent expression, directly or recursively. This
again makes it possible to avoid creating a temporary for the aggregate.
gcc/ada/
* exp_aggr.ads (Is_Delayed_Conditional_Expression): New predicate.
* exp_aggr.adb (Convert_To_Assignments.Known_Size): Likewise.
(Convert_To_Assignments): Climb the parent chain, looking through
qualified expressions and dependent expressions of conditional
expressions, to find out whether the expansion may be delayed.
Call Known_Size for this in the case of an object declaration.
If so, set Expansion_Delayed on the aggregate as well as all the
intermediate conditional expressions.
(Initialize_Component): Reset the Analyzed flag on an initialization
expression that is a conditional expression whose expansion has been
delayed.
(Is_Delayed_Conditional_Expression): New predicate.
* exp_ch3.adb (Expand_N_Object_Declaration): Handle initialization
expressions that are conditional expressions whose expansion has
been delayed.
* exp_ch4.adb (Build_Explicit_Assignment): New procedure.
(Expand_Allocator_Expression): Handle initialization expressions
that are conditional expressions whose expansion has been delayed.
(Expand_N_Case_Expression): Deal with expressions whose expansion
has been delayed by waiting for the rewriting of their parent as
an assignment statement and then optimizing the assignment.
(Expand_N_If_Expression): Likewise.
(Expand_N_Qualified_Expression): Do not apply a predicate check to
an operand that is a delayed aggregate or conditional expression.
* gen_il-gen-gen_nodes.adb (N_If_Expression): Add Expansion_Delayed
semantic flag.
(N_Case_Expression): Likewise.
* sinfo.ads (Expansion_Delayed): Document extended usage.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/exp_aggr.adb | 201 ++++++++++++-----
gcc/ada/exp_aggr.ads | 4 +
gcc/ada/exp_ch3.adb | 38 ++++
gcc/ada/exp_ch4.adb | 363 ++++++++++++++++++++++++-------
gcc/ada/gen_il-gen-gen_nodes.adb | 4 +-
gcc/ada/sinfo.ads | 4 +
6 files changed, 479 insertions(+), 135 deletions(-)
diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb
index 6208b49ffd9..a386aa85ae4 100644
--- a/gcc/ada/exp_aggr.adb
+++ b/gcc/ada/exp_aggr.adb
@@ -4216,84 +4216,152 @@ package body Exp_Aggr is
procedure Convert_To_Assignments (N : Node_Id; Typ : Entity_Id) is
Loc : constant Source_Ptr := Sloc (N);
- Aggr_Code : List_Id;
- Full_Typ : Entity_Id;
- Instr : Node_Id;
- Parent_Kind : Node_Kind;
- Parent_Node : Node_Id;
- Target_Expr : Node_Id;
- Temp : Entity_Id;
- Unc_Decl : Boolean := False;
+ function Known_Size (Decl : Node_Id; Cond_Init : Boolean) return Boolean;
+ -- Decl is an N_Object_Declaration node. Return true if it declares an
+ -- object with a known size; in this context, that is always the case,
+ -- except for a declaration without explicit constraints of an object,
+ -- either whose nominal subtype is class-wide, or whose initialization
+ -- contains a conditional expression and whose nominal subtype is both
+ -- discriminated and unconstrained.
+
+ ----------------
+ -- Known_Size --
+ ----------------
+
+ function Known_Size (Decl : Node_Id; Cond_Init : Boolean) return Boolean
+ is
+ begin
+ if Is_Entity_Name (Object_Definition (Decl)) then
+ declare
+ Typ : constant Entity_Id := Entity (Object_Definition (Decl));
+
+ begin
+ return not Is_Class_Wide_Type (Typ)
+ and then not (Cond_Init
+ and then Has_Discriminants (Typ)
+ and then not Is_Constrained (Typ));
+ end;
+
+ else
+ return True;
+ end if;
+ end Known_Size;
+
+ -- Local variables
+
+ Aggr_Code : List_Id;
+ Full_Typ : Entity_Id;
+ In_Cond_Expr : Boolean;
+ Instr : Node_Id;
+ Node : Node_Id;
+ Parent_Node : Node_Id;
+ Target_Expr : Node_Id;
+ Temp : Entity_Id;
+
+ -- Start of processing for Convert_To_Assignments
begin
pragma Assert (Nkind (N) in N_Aggregate | N_Extension_Aggregate);
pragma Assert (not Is_Static_Dispatch_Table_Aggregate (N));
pragma Assert (Is_Record_Type (Typ));
- Parent_Node := Parent (N);
- Parent_Kind := Nkind (Parent_Node);
+ In_Cond_Expr := False;
+ Node := N;
+ Parent_Node := Parent (Node);
- if Parent_Kind = N_Qualified_Expression then
- -- Check if we are in an unconstrained declaration because in this
- -- case the current delayed expansion mechanism doesn't work when
- -- the declared object size depends on the initializing expr.
+ -- First, climb the parent chain, looking through qualified expressions
+ -- and dependent expressions of conditional expressions.
- Parent_Node := Parent (Parent_Node);
- Parent_Kind := Nkind (Parent_Node);
+ while True loop
+ case Nkind (Parent_Node) is
+ when N_Case_Expression_Alternative =>
+ null;
- if Parent_Kind = N_Object_Declaration then
- Unc_Decl :=
- not Is_Entity_Name (Object_Definition (Parent_Node))
- or else (Nkind (N) = N_Aggregate
- and then
- Has_Discriminants
- (Entity (Object_Definition (Parent_Node))))
- or else Is_Class_Wide_Type
- (Entity (Object_Definition (Parent_Node)));
- end if;
- end if;
+ when N_Case_Expression =>
+ exit when Node = Expression (Parent_Node);
+ In_Cond_Expr := True;
+
+ when N_If_Expression =>
+ exit when Node = First (Expressions (Parent_Node));
+ In_Cond_Expr := True;
- -- Just set the Delay flag in the cases where the transformation will be
- -- done top down from above.
+ when N_Qualified_Expression =>
+ null;
+
+ when others =>
+ exit;
+ end case;
+
+ Node := Parent_Node;
+ Parent_Node := Parent (Node);
+ end loop;
+
+ -- Set the Expansion_Delayed flag in the cases where the transformation
+ -- will be done top down from above.
if
-- Internal aggregates (transformed when expanding the parent),
-- excluding container aggregates as these are transformed into
- -- subprogram calls later.
+ -- subprogram calls later. So far aggregates with self-references
+ -- are not supported if they appear in a conditional expression.
- (Parent_Kind = N_Component_Association
- and then not Is_Container_Aggregate (Parent (Parent_Node)))
+ (Nkind (Parent_Node) = N_Component_Association
+ and then not Is_Container_Aggregate (Parent (Parent_Node))
+ and then not (In_Cond_Expr and then Has_Self_Reference (N)))
- or else (Parent_Kind in N_Aggregate | N_Extension_Aggregate
- and then not Is_Container_Aggregate (Parent_Node))
+ or else (Nkind (Parent_Node) in N_Aggregate | N_Extension_Aggregate
+ and then not Is_Container_Aggregate (Parent_Node)
+ and then not (In_Cond_Expr and then Has_Self_Reference (N)))
-- Allocator (see Convert_Aggr_In_Allocator)
- or else Parent_Kind = N_Allocator
+ or else Nkind (Parent_Node) = N_Allocator
- -- Object declaration (see Convert_Aggr_In_Object_Decl)
+ -- Object declaration (see Convert_Aggr_In_Object_Decl). So far only
+ -- declarations with a known size are supported.
- or else (Parent_Kind = N_Object_Declaration and then not Unc_Decl)
+ or else (Nkind (Parent_Node) = N_Object_Declaration
+ and then Known_Size (Parent_Node, In_Cond_Expr))
-- Safe assignment (see Convert_Aggr_In_Assignment). So far only the
-- assignments in init procs are taken into account.
- or else (Parent_Kind = N_Assignment_Statement
+ or else (Nkind (Parent_Node) = N_Assignment_Statement
and then Inside_Init_Proc)
-
- -- (Ada 2005) An inherently limited type in a return statement, which
- -- will be handled in a build-in-place fashion, and may be rewritten
- -- as an extended return and have its own finalization machinery.
- -- In the case of a simple return, the aggregate needs to be delayed
- -- until the scope for the return statement has been created, so
- -- that any finalization chain will be associated with that scope.
- -- For extended returns, we delay expansion to avoid the creation
- -- of an unwanted transient scope that could result in premature
- -- finalization of the return object (which is built in place
- -- within the caller's scope).
-
- or else Is_Build_In_Place_Aggregate_Return (N)
then
+ Node := N;
+
+ -- Mark the aggregate, as well as all the intermediate conditional
+ -- expressions, as having expansion delayed. This will block the
+ -- usual (bottom-up) expansion of the marked nodes and replace it
+ -- with a top-down expansion from the parent node.
+
+ while Node /= Parent_Node loop
+ if Nkind (Node) in N_Aggregate
+ | N_Case_Expression
+ | N_Extension_Aggregate
+ | N_If_Expression
+ then
+ Set_Expansion_Delayed (Node);
+ end if;
+
+ Node := Parent (Node);
+ end loop;
+
+ return;
+
+ -- (Ada 2005) An inherently limited type in a return statement, which
+ -- will be handled in a build-in-place fashion, and may be rewritten
+ -- as an extended return and have its own finalization machinery.
+ -- In the case of a simple return, the aggregate needs to be delayed
+ -- until the scope for the return statement has been created, so
+ -- that any finalization chain will be associated with that scope.
+ -- For extended returns, we delay expansion to avoid the creation
+ -- of an unwanted transient scope that could result in premature
+ -- finalization of the return object (which is built in place
+ -- within the caller's scope).
+
+ elsif Is_Build_In_Place_Aggregate_Return (N) then
Set_Expansion_Delayed (N);
return;
end if;
@@ -4304,11 +4372,19 @@ package body Exp_Aggr is
Establish_Transient_Scope (N, Manage_Sec_Stack => False);
end if;
+ -- Now get back to the immediate parent, modulo qualified expression
+
+ Parent_Node := Parent (N);
+
+ if Nkind (Parent_Node) = N_Qualified_Expression then
+ Parent_Node := Parent (Parent_Node);
+ end if;
+
-- If the context is an assignment and the aggregate is limited, this
-- is a subaggregate of an enclosing aggregate being expanded; it must
-- be built in place, so use the target of the current assignment.
- if Parent_Kind = N_Assignment_Statement
+ if Nkind (Parent_Node) = N_Assignment_Statement
and then Is_Limited_Type (Typ)
then
Target_Expr := New_Copy_Tree (Name (Parent_Node));
@@ -4321,7 +4397,7 @@ package body Exp_Aggr is
-- by-copy semantics of aggregates. This avoids large stack usage and
-- generates more efficient code.
- elsif Parent_Kind = N_Assignment_Statement
+ elsif Nkind (Parent_Node) = N_Assignment_Statement
and then In_Place_Assign_OK (N, Get_Base_Object (Name (Parent_Node)))
then
declare
@@ -8678,6 +8754,13 @@ package body Exp_Aggr is
Name => New_Copy_Tree (Comp),
Expression => Relocate_Node (Init_Expr));
+ -- If the initialization expression is a conditional expression whose
+ -- expansion has been delayed, analyze it again and expand it.
+
+ if Is_Delayed_Conditional_Expression (Expression (Init_Stmt)) then
+ Set_Analyzed (Expression (Init_Stmt), False);
+ end if;
+
Append_To (Blk_Stmts, Init_Stmt);
-- Arrange for the component to be adjusted if need be (the call will be
@@ -8796,6 +8879,18 @@ package body Exp_Aggr is
and then Expansion_Delayed (Unqual_N);
end Is_Delayed_Aggregate;
+ ---------------------------------------
+ -- Is_Delayed_Conditional_Expression --
+ ---------------------------------------
+
+ function Is_Delayed_Conditional_Expression (N : Node_Id) return Boolean is
+ Unqual_N : constant Node_Id := Unqualify (N);
+
+ begin
+ return Nkind (Unqual_N) in N_Case_Expression | N_If_Expression
+ and then Expansion_Delayed (Unqual_N);
+ end Is_Delayed_Conditional_Expression;
+
--------------------------------
-- Is_CCG_Supported_Aggregate --
--------------------------------
diff --git a/gcc/ada/exp_aggr.ads b/gcc/ada/exp_aggr.ads
index a9eb0518d7a..17fa38b7ca3 100644
--- a/gcc/ada/exp_aggr.ads
+++ b/gcc/ada/exp_aggr.ads
@@ -54,6 +54,10 @@ package Exp_Aggr is
-- Returns True if N is an aggregate of some kind whose Expansion_Delayed
-- flag is set (see sinfo for meaning of flag).
+ function Is_Delayed_Conditional_Expression (N : Node_Id) return Boolean;
+ -- Returns True if N is a conditional expression whose Expansion_Delayed
+ -- flag is set (see sinfo for meaning of flag).
+
function Static_Array_Aggregate (N : Node_Id) return Boolean;
-- N is an array aggregate that may have a component association with
-- an others clause and a range. If bounds are static and the expressions
diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index f6314dff285..8ddae1eb1be 100644
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -7689,10 +7689,48 @@ package body Exp_Ch3 is
Expander_Mode_Restore;
end if;
+ -- For a special return object, the transformation must wait until
+ -- after the object is turned into an allocator.
+
if not Special_Ret_Obj then
Convert_Aggr_In_Object_Decl (N);
end if;
+ -- If the initialization expression is a conditional expression whose
+ -- expansion has been delayed, assign it explicitly to the object but
+ -- only after analyzing it again and expanding it.
+
+ elsif Is_Delayed_Conditional_Expression (Expr_Q) then
+ -- For a special return object, the transformation must wait until
+ -- after the object is turned into an allocator, and will be done
+ -- during the expansion of the allocator.
+
+ if not Special_Ret_Obj then
+ declare
+ Assign : constant Node_Id :=
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Def_Id, Loc),
+ Expression => Relocate_Node (Expr));
+
+ begin
+ Set_Assignment_OK (Name (Assign));
+ Set_Analyzed (Expression (Assign), False);
+ Set_No_Finalize_Actions (Assign);
+ Insert_Action_After (Init_After, Assign);
+
+ -- Save the assignment statement when declaring a controlled
+ -- object. This reference is used later by the finalization
+ -- machinery to mark the object as successfully initialized
+
+ if Needs_Finalization (Typ) then
+ Set_Last_Aggregate_Assignment (Def_Id, Assign);
+ end if;
+
+ Set_Expression (N, Empty);
+ Set_No_Initialization (N);
+ end;
+ end if;
+
-- Ada 2005 (AI-318-02): If the initialization expression is a call
-- to a build-in-place function, then access to the declared object
-- must be passed to the function. Currently we limit such functions
diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
index 69a042115c9..6ceffdf8302 100644
--- a/gcc/ada/exp_ch4.adb
+++ b/gcc/ada/exp_ch4.adb
@@ -564,10 +564,16 @@ package body Exp_Ch4 is
procedure Build_Aggregate_In_Place (Temp : Entity_Id; Typ : Entity_Id);
-- If Exp is an aggregate to build in place, build the declaration of
- -- Temp with Typ and with expression an uninitialized allocator for
- -- Etype (Exp), then perform an in-place aggregate assignment of Exp
+ -- Temp with Typ and initializing expression an uninitialized allocator
+ -- for Etype (Exp), then perform an in-place aggregate assignment of Exp
-- into the allocated memory.
+ procedure Build_Explicit_Assignment (Temp : Entity_Id; Typ : Entity_Id);
+ -- If Exp is a conditional expression whose expansion has been delayed,
+ -- build the declaration of Temp with Typ and initializing expression an
+ -- uninitialized allocator for Etype (Exp), then perform an assignment
+ -- of Exp into the allocated memory.
+
------------------------------
-- Build_Aggregate_In_Place --
------------------------------
@@ -598,13 +604,58 @@ package body Exp_Ch4 is
Convert_Aggr_In_Allocator (N, Temp);
end Build_Aggregate_In_Place;
+ -------------------------------
+ -- Build_Explicit_Assignment --
+ -------------------------------
+
+ procedure Build_Explicit_Assignment (Temp : Entity_Id; Typ : Entity_Id)
+ is
+ Assign : constant Node_Id :=
+ Make_Assignment_Statement (Loc,
+ Name =>
+ Make_Explicit_Dereference (Loc,
+ New_Occurrence_Of (Temp, Loc)),
+ Expression => Relocate_Node (Exp));
+
+ Temp_Decl : constant Node_Id :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Temp,
+ Object_Definition => New_Occurrence_Of (Typ, Loc),
+ Expression =>
+ Make_Allocator (Loc,
+ Expression => New_Occurrence_Of (Etype (Exp), Loc)));
+
+ begin
+ -- Prevent default initialization of the allocator
+
+ Set_No_Initialization (Expression (Temp_Decl));
+
+ -- Copy the Comes_From_Source flag onto the allocator since logically
+ -- this allocator is a replacement of the original allocator. This is
+ -- for proper handling of restriction No_Implicit_Heap_Allocations.
+
+ Preserve_Comes_From_Source (Expression (Temp_Decl), N);
+
+ -- Insert the declaration
+
+ Insert_Action (N, Temp_Decl);
+
+ -- Arrange for the expression to be analyzed again and expanded
+
+ Set_Assignment_OK (Name (Assign));
+ Set_Analyzed (Expression (Assign), False);
+ Set_No_Finalize_Actions (Assign);
+ Insert_Action (N, Assign);
+ end Build_Explicit_Assignment;
+
-- Local variables
- Adj_Call : Node_Id;
- Aggr_In_Place : Boolean;
- Node : Node_Id;
- Temp : Entity_Id;
- Temp_Decl : Node_Id;
+ Adj_Call : Node_Id;
+ Aggr_In_Place : Boolean;
+ Delayed_Cond_Expr : Boolean;
+ Node : Node_Id;
+ Temp : Entity_Id;
+ Temp_Decl : Node_Id;
TagT : Entity_Id := Empty;
-- Type used as source for tag assignment
@@ -631,13 +682,16 @@ package body Exp_Ch4 is
Apply_Constraint_Check (Exp, T, No_Sliding => True);
- Aggr_In_Place := Is_Delayed_Aggregate (Exp);
+ Aggr_In_Place := Is_Delayed_Aggregate (Exp);
+ Delayed_Cond_Expr := Is_Delayed_Conditional_Expression (Exp);
-- If the expression is an aggregate to be built in place, then we need
-- to delay applying predicate checks, because this would result in the
- -- creation of a temporary, which is illegal for limited types,
+ -- creation of a temporary, which is illegal for limited types and just
+ -- inefficient in the other cases. Likewise for a conditional expression
+ -- whose expansion has been delayed.
- if not Aggr_In_Place then
+ if not Aggr_In_Place and then not Delayed_Cond_Expr then
Apply_Predicate_Check (Exp, T);
end if;
@@ -741,6 +795,7 @@ package body Exp_Ch4 is
-- or this is a return/secondary stack allocation.
if not Aggr_In_Place
+ and then not Delayed_Cond_Expr
and then Present (Storage_Pool (N))
and then not Is_RTE (Storage_Pool (N), RE_RS_Pool)
and then not Is_RTE (Storage_Pool (N), RE_SS_Pool)
@@ -793,6 +848,9 @@ package body Exp_Ch4 is
if Aggr_In_Place then
Build_Aggregate_In_Place (Temp, PtrT);
+ elsif Delayed_Cond_Expr then
+ Build_Explicit_Assignment (Temp, PtrT);
+
else
Node := Relocate_Node (N);
Set_Analyzed (Node);
@@ -845,6 +903,9 @@ package body Exp_Ch4 is
if Aggr_In_Place then
Build_Aggregate_In_Place (Temp, Def_Id);
+ elsif Delayed_Cond_Expr then
+ Build_Explicit_Assignment (Temp, Def_Id);
+
else
Node := Relocate_Node (N);
Set_Analyzed (Node);
@@ -940,6 +1001,7 @@ package body Exp_Ch4 is
and then Needs_Finalization (T)
and then not Is_Inherently_Limited_Type (T)
and then not Aggr_In_Place
+ and then not Delayed_Cond_Expr
and then Nkind (Exp) /= N_Function_Call
and then not Special_Return
then
@@ -975,7 +1037,7 @@ package body Exp_Ch4 is
Rewrite (N, New_Occurrence_Of (Temp, Loc));
Analyze_And_Resolve (N, PtrT);
- if Aggr_In_Place then
+ if Aggr_In_Place or else Delayed_Cond_Expr then
Apply_Predicate_Check (N, T, Deref => True);
end if;
@@ -1003,6 +1065,19 @@ package body Exp_Ch4 is
Apply_Predicate_Check (N, T, Deref => True);
end if;
+ -- If the initialization expression is a conditional expression whose
+ -- expansion has been delayed, assign it explicitly to the allocator,
+ -- but only after analyzing it again and expanding it.
+
+ elsif Delayed_Cond_Expr then
+ Temp := Make_Temporary (Loc, 'P', N);
+ Build_Explicit_Assignment (Temp, PtrT);
+ Build_Allocate_Deallocate_Proc (Declaration_Node (Temp), Mark => N);
+ Rewrite (N, New_Occurrence_Of (Temp, Loc));
+ Analyze_And_Resolve (N, PtrT);
+
+ Apply_Predicate_Check (N, T, Deref => True);
+
elsif Is_Access_Type (T) and then Can_Never_Be_Null (T) then
Install_Null_Excluding_Check (Exp);
@@ -4886,6 +4961,32 @@ package body Exp_Ch4 is
------------------------------
procedure Expand_N_Case_Expression (N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+ Par : constant Node_Id := Parent (N);
+ Typ : constant Entity_Id := Etype (N);
+
+ In_Predicate : constant Boolean :=
+ Ekind (Current_Scope) in E_Function | E_Procedure
+ and then Is_Predicate_Function (Current_Scope);
+ -- Flag set when the case expression appears within a predicate
+
+ Optimize_Return_Stmt : constant Boolean :=
+ Nkind (Par) = N_Simple_Return_Statement and then not In_Predicate;
+ -- Small optimization: when the case expression appears in the context
+ -- of a simple return statement, expand into
+
+ -- case X is
+ -- when A =>
+ -- return AX;
+ -- when B =>
+ -- return BX;
+ -- ...
+ -- end case;
+
+ -- This makes the expansion much easier when expressions are calls to
+ -- a BIP function. But do not perform it when the return statement is
+ -- within a predicate function, as this causes spurious errors.
+
function Is_Copy_Type (Typ : Entity_Id) return Boolean;
-- Return True if we can copy objects of this type when expanding a case
-- expression.
@@ -4909,10 +5010,6 @@ package body Exp_Ch4 is
-- Local variables
- Loc : constant Source_Ptr := Sloc (N);
- Par : constant Node_Id := Parent (N);
- Typ : constant Entity_Id := Etype (N);
-
Acts : List_Id;
Alt : Node_Id;
Case_Stmt : Node_Id;
@@ -4920,16 +5017,39 @@ package body Exp_Ch4 is
Target : Entity_Id := Empty;
Target_Typ : Entity_Id;
- In_Predicate : Boolean := False;
- -- Flag set when the case expression appears within a predicate
+ Optimize_Assignment_Stmt : Boolean;
+ -- Small optimization: when the case expression appears in the context
+ -- of a safe assignment statement, expand into
- Optimize_Return_Stmt : Boolean := False;
- -- Flag set when the case expression can be optimized in the context of
- -- a simple return statement.
+ -- case X is
+ -- when A =>
+ -- lhs := AX;
+ -- when B =>
+ -- lhs := BX;
+ -- ...
+ -- end case;
+
+ -- This makes the expansion much more efficient in the context of an
+ -- aggregate converted into assignments.
-- Start of processing for Expand_N_Case_Expression
begin
+ -- If the expansion of the expression has been delayed, we wait for the
+ -- rewriting of its parent as an assignment statement; when that's done,
+ -- we optimize the assignment (the very purpose of the manipulation).
+
+ if Expansion_Delayed (N) then
+ if Nkind (Par) /= N_Assignment_Statement then
+ return;
+ end if;
+
+ Optimize_Assignment_Stmt := True;
+
+ else
+ Optimize_Assignment_Stmt := False;
+ end if;
+
-- Check for MINIMIZED/ELIMINATED overflow mode
if Minimized_Eliminated_Overflow_Check (N) then
@@ -4941,15 +5061,11 @@ package body Exp_Ch4 is
-- to which it applies has a static predicate aspect, do not expand,
-- because it will be converted to the proper predicate form later.
- if Ekind (Current_Scope) in E_Function | E_Procedure
- and then Is_Predicate_Function (Current_Scope)
+ if In_Predicate
+ and then
+ Has_Static_Predicate_Aspect (Etype (First_Entity (Current_Scope)))
then
- In_Predicate := True;
-
- if Has_Static_Predicate_Aspect (Etype (First_Entity (Current_Scope)))
- then
- return;
- end if;
+ return;
end if;
-- When the type of the case expression is elementary, expand
@@ -5002,24 +5118,6 @@ package body Exp_Ch4 is
Set_From_Conditional_Expression (Case_Stmt);
Acts := New_List;
- -- Small optimization: when the case expression appears in the context
- -- of a simple return statement, expand into
-
- -- case X is
- -- when A =>
- -- return AX;
- -- when B =>
- -- return BX;
- -- ...
- -- end case;
-
- -- This makes the expansion much easier when expressions are calls to
- -- a BIP function. But do not perform it when the return statement is
- -- within a predicate function, as this causes spurious errors.
-
- Optimize_Return_Stmt :=
- Nkind (Par) = N_Simple_Return_Statement and then not In_Predicate;
-
-- Scalar/Copy case
if Is_Copy_Type (Typ) then
@@ -5060,7 +5158,10 @@ package body Exp_Ch4 is
-- Generate:
-- Target : [Ptr_]Typ;
- if not Optimize_Return_Stmt then
+ if Optimize_Assignment_Stmt then
+ Remove_Side_Effects (Name (Par), Name_Req => True);
+
+ elsif not Optimize_Return_Stmt then
Target := Make_Temporary (Loc, 'T');
Decl :=
@@ -5077,24 +5178,42 @@ package body Exp_Ch4 is
Alt := First (Alternatives (N));
while Present (Alt) loop
declare
- Alt_Expr : Node_Id := Expression (Alt);
+ Alt_Expr : Node_Id := Relocate_Node (Expression (Alt));
Alt_Loc : constant Source_Ptr := Sloc (Alt_Expr);
LHS : Node_Id;
Stmts : List_Id;
begin
- -- Take the unrestricted access of the expression value for non-
- -- scalar types. This approach avoids big copies and covers the
- -- limited and unconstrained cases.
+ -- Generate:
+ -- lhs := AX;
+
+ if Optimize_Assignment_Stmt then
+ -- We directly copy the parent node to preserve its flags
+
+ Stmts := New_List (New_Copy (Par));
+ Set_Sloc (First (Stmts), Alt_Loc);
+ Set_Name (First (Stmts), New_Copy_Tree (Name (Par)));
+ Set_Expression (First (Stmts), Alt_Expr);
+
+ -- If the expression is itself a conditional expression whose
+ -- expansion has been delayed, analyze it again and expand it.
+
+ if Is_Delayed_Conditional_Expression (Alt_Expr) then
+ Set_Analyzed (Alt_Expr, False);
+ end if;
-- Generate:
- -- return AX['Unrestricted_Access];
+ -- return AX;
- if Optimize_Return_Stmt then
+ elsif Optimize_Return_Stmt then
Stmts := New_List (
Make_Simple_Return_Statement (Alt_Loc,
Expression => Alt_Expr));
+ -- Take the unrestricted access of the expression value for non-
+ -- scalar types. This approach avoids big copies and covers the
+ -- limited and unconstrained cases.
+
-- Generate:
-- Target := AX['Unrestricted_Access];
@@ -5150,9 +5269,9 @@ package body Exp_Ch4 is
Next (Alt);
end loop;
- -- Rewrite the parent return statement as a case statement
+ -- Rewrite the parent statement as a case statement
- if Optimize_Return_Stmt then
+ if Optimize_Assignment_Stmt or else Optimize_Return_Stmt then
Rewrite (Par, Case_Stmt);
Analyze (Par);
@@ -5332,6 +5451,26 @@ package body Exp_Ch4 is
Par : constant Node_Id := Parent (N);
Typ : constant Entity_Id := Etype (N);
+ In_Predicate : constant Boolean :=
+ Ekind (Current_Scope) in E_Function | E_Procedure
+ and then Is_Predicate_Function (Current_Scope);
+ -- Flag set when the if expression appears within a predicate
+
+ Optimize_Return_Stmt : constant Boolean :=
+ Nkind (Par) = N_Simple_Return_Statement and then not In_Predicate;
+ -- Small optimization: when the if expression appears in the context of
+ -- a simple return statement, expand into
+
+ -- if cond then
+ -- return then-expr
+ -- else
+ -- return else-expr;
+ -- end if;
+
+ -- This makes the expansion much easier when expressions are calls to
+ -- a BIP function. But do not perform it when the return statement is
+ -- within a predicate function, as this causes spurious errors.
+
Force_Expand : constant Boolean := Is_Anonymous_Access_Actual (N);
-- Determine if we are dealing with a special case of a conditional
-- expression used as an actual for an anonymous access type which
@@ -5365,18 +5504,44 @@ package body Exp_Ch4 is
-- Local variables
Actions : List_Id;
- Decl : Node_Id;
- Expr : Node_Id;
- New_If : Node_Id;
- New_N : Node_Id;
+ Decl : Node_Id;
+ Expr : Node_Id;
+ New_Else : Node_Id;
+ New_If : Node_Id;
+ New_N : Node_Id;
+ New_Then : Node_Id;
+
+ Optimize_Assignment_Stmt : Boolean;
+ -- Small optimization: when the if expression appears in the context of
+ -- a safe assignment statement, expand into
+
+ -- if cond then
+ -- lhs := then-expr
+ -- else
+ -- lhs := else-expr;
+ -- end if;
- Optimize_Return_Stmt : Boolean := False;
- -- Flag set when the if expression can be optimized in the context of
- -- a simple return statement.
+ -- This makes the expansion much more efficient in the context of an
+ -- aggregate converted into assignments.
-- Start of processing for Expand_N_If_Expression
begin
+ -- If the expansion of the expression has been delayed, we wait for the
+ -- rewriting of its parent as an assignment statement; when that's done,
+ -- we optimize the assignment (the very purpose of the manipulation).
+
+ if Expansion_Delayed (N) then
+ if Nkind (Par) /= N_Assignment_Statement then
+ return;
+ end if;
+
+ Optimize_Assignment_Stmt := True;
+
+ else
+ Optimize_Assignment_Stmt := False;
+ end if;
+
-- Deal with non-standard booleans
Adjust_Condition (Cond);
@@ -5457,25 +5622,54 @@ package body Exp_Ch4 is
end;
end if;
- -- Small optimization: when the if expression appears in the context of
- -- a simple return statement, expand into
+ if Optimize_Assignment_Stmt then
+ Remove_Side_Effects (Name (Par), Name_Req => True);
- -- if cond then
- -- return then-expr
- -- else
- -- return else-expr;
- -- end if;
+ -- When the "then" or "else" expressions involve controlled function
+ -- calls, generated temporaries are chained on the corresponding list
+ -- of actions. These temporaries need to be finalized after the if
+ -- expression is evaluated.
- -- This makes the expansion much easier when expressions are calls to
- -- a BIP function. But do not perform it when the return statement is
- -- within a predicate function, as this causes spurious errors.
+ Process_Transients_In_Expression (N, Then_Actions (N));
+ Process_Transients_In_Expression (N, Else_Actions (N));
+
+ -- We directly copy the parent node to preserve its flags
+
+ New_Then := New_Copy (Par);
+ Set_Sloc (New_Then, Sloc (Thenx));
+ Set_Name (New_Then, New_Copy_Tree (Name (Par)));
+ Set_Expression (New_Then, Relocate_Node (Thenx));
+
+ -- If the expression is itself a conditional expression whose
+ -- expansion has been delayed, analyze it again and expand it.
- Optimize_Return_Stmt :=
- Nkind (Par) = N_Simple_Return_Statement
- and then not (Ekind (Current_Scope) in E_Function | E_Procedure
- and then Is_Predicate_Function (Current_Scope));
+ if Is_Delayed_Conditional_Expression (Expression (New_Then)) then
+ Set_Analyzed (Expression (New_Then), False);
+ end if;
+
+ New_Else := New_Copy (Par);
+ Set_Sloc (New_Else, Sloc (Elsex));
+ Set_Name (New_Else, New_Copy_Tree (Name (Par)));
+ Set_Expression (New_Else, Relocate_Node (Elsex));
+
+ if Is_Delayed_Conditional_Expression (Expression (New_Else)) then
+ Set_Analyzed (Expression (New_Else), False);
+ end if;
- if Optimize_Return_Stmt then
+ New_If :=
+ Make_Implicit_If_Statement (N,
+ Condition => Relocate_Node (Cond),
+ Then_Statements => New_List (New_Then),
+ Else_Statements => New_List (New_Else));
+
+ -- Preserve the original context for which the if statement is
+ -- being generated. This is needed by the finalization machinery
+ -- to prevent the premature finalization of controlled objects
+ -- found within the if statement.
+
+ Set_From_Conditional_Expression (New_If);
+
+ elsif Optimize_Return_Stmt then
-- When the "then" or "else" expressions involve controlled function
-- calls, generated temporaries are chained on the corresponding list
-- of actions. These temporaries need to be finalized after the if
@@ -6085,9 +6279,9 @@ package body Exp_Ch4 is
Prepend_List (Else_Actions (N), Else_Statements (New_If));
end if;
- -- Rewrite the parent return statement as an if statement
+ -- Rewrite the parent statement as an if statement
- if Optimize_Return_Stmt then
+ if Optimize_Assignment_Stmt or else Optimize_Return_Stmt then
Rewrite (Par, New_If);
Analyze (Par);
@@ -10354,9 +10548,16 @@ package body Exp_Ch4 is
Apply_Constraint_Check (Operand, Target_Type, No_Sliding => True);
- -- Apply possible predicate check
+ -- Apply possible predicate check but, for a delayed aggregate, the
+ -- check is effectively delayed until after the aggregate is expanded
+ -- into a series of assignments. Likewise for a conditional expression
+ -- whose expansion has been delayed.
- Apply_Predicate_Check (Operand, Target_Type);
+ if not Is_Delayed_Aggregate (Operand)
+ and then not Is_Delayed_Conditional_Expression (Operand)
+ then
+ Apply_Predicate_Check (Operand, Target_Type);
+ end if;
if Do_Range_Check (Operand) then
Generate_Range_Check (Operand, Target_Type, CE_Range_Check_Failed);
diff --git a/gcc/ada/gen_il-gen-gen_nodes.adb b/gcc/ada/gen_il-gen-gen_nodes.adb
index a7021dc49bb..580723666c5 100644
--- a/gcc/ada/gen_il-gen-gen_nodes.adb
+++ b/gcc/ada/gen_il-gen-gen_nodes.adb
@@ -464,6 +464,7 @@ begin -- Gen_IL.Gen.Gen_Nodes
(Sy (Expressions, List_Id, Default_No_List),
Sy (Is_Elsif, Flag),
Sm (Do_Overflow_Check, Flag),
+ Sm (Expansion_Delayed, Flag),
Sm (Else_Actions, List_Id),
Sm (Then_Actions, List_Id)));
@@ -513,7 +514,8 @@ begin -- Gen_IL.Gen.Gen_Nodes
Cc (N_Case_Expression, N_Subexpr,
(Sy (Expression, Node_Id, Default_Empty),
Sy (Alternatives, List_Id, Default_No_List),
- Sm (Do_Overflow_Check, Flag)));
+ Sm (Do_Overflow_Check, Flag),
+ Sm (Expansion_Delayed, Flag)));
Cc (N_Delta_Aggregate, N_Subexpr,
(Sy (Expression, Node_Id, Default_Empty),
diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads
index 7cad6cf1d29..228082eb823 100644
--- a/gcc/ada/sinfo.ads
+++ b/gcc/ada/sinfo.ads
@@ -1322,6 +1322,8 @@ package Sinfo is
-- assignment or initialization. When the full context is known, the
-- target of the assignment or initialization is used to generate the
-- left-hand side of individual assignment to each subcomponent.
+ -- Also set on conditional expressions whose dependent expressions are
+ -- nested aggregates, in order to avoid creating a temporary for them.
-- Expression_Copy
-- Present in N_Pragma_Argument_Association nodes. Contains a copy of the
@@ -4657,6 +4659,7 @@ package Sinfo is
-- Else_Actions
-- Is_Elsif (set if comes from ELSIF)
-- Do_Overflow_Check
+ -- Expansion_Delayed
-- plus fields for expression
-- Expressions here is a three-element list, whose first element is the
@@ -4695,6 +4698,7 @@ package Sinfo is
-- Alternatives (the case expression alternatives)
-- Etype
-- Do_Overflow_Check
+ -- Expansion_Delayed
----------------------------------------
-- 4.5.7 Case Expression Alternative --
--
2.43.2
^ permalink raw reply [flat|nested] 30+ messages in thread
* [COMMITTED 14/30] ada: Tweak handling of thread ID on POSIX
2024-05-20 7:48 [COMMITTED 01/30] ada: Rework and augment documentation on strict aliasing Marc Poulhiès
` (11 preceding siblings ...)
2024-05-20 7:48 ` [COMMITTED 13/30] ada: Extend expansion delaying mechanism to conditional expressions Marc Poulhiès
@ 2024-05-20 7:48 ` Marc Poulhiès
2024-05-20 7:48 ` [COMMITTED 15/30] ada: Fix style in list of implementation-defined attributes Marc Poulhiès
` (15 subsequent siblings)
28 siblings, 0 replies; 30+ messages in thread
From: Marc Poulhiès @ 2024-05-20 7:48 UTC (permalink / raw)
To: gcc-patches; +Cc: Ronan Desplanques
From: Ronan Desplanques <desplanques@adacore.com>
This patch changes the task initialization subprograms on POSIX
platforms so that the thread ID of an ATCB is only set once.
This has the advantage of getting rid of the Atomic aspect on
the corresponding record component, and silences a Helgrind
warning about a data race.
gcc/ada/
* libgnarl/s-taprop__linux.adb (Enter_Task): Move setting
of thread ID out of Enter_Task.
(Initialize): Set thread ID for the environment task.
(Create_Task): Remove now unnecessary Unrestricted_Access
attribute and add justification for a memory write.
* libgnarl/s-taprop__posix.adb: Likewise.
* libgnarl/s-taprop__qnx.adb: Likewise.
* libgnarl/s-taprop__rtems.adb: Likewise.
* libgnarl/s-taprop__solaris.adb: Likewise.
* libgnarl/s-taspri__posix.ads: Remove pragma Atomic for
Private_Data.Thread, and update documentation comment.
* libgnarl/s-taspri__lynxos.ads: Likewise.
* libgnarl/s-taspri__posix-noaltstack.ads: Likewise.
* libgnarl/s-taspri__solaris.ads: Likewise.
* libgnarl/s-tporft.adb (Register_Foreign_Thread): Adapt to
Enter_Task not setting the thread ID anymore.
* libgnarl/s-tassta.adb (Task_Wrapper): Update comment.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/libgnarl/s-taprop__linux.adb | 14 +++++++-------
gcc/ada/libgnarl/s-taprop__posix.adb | 14 +++++++-------
gcc/ada/libgnarl/s-taprop__qnx.adb | 14 +++++++-------
gcc/ada/libgnarl/s-taprop__rtems.adb | 14 +++++++-------
gcc/ada/libgnarl/s-taprop__solaris.adb | 16 ++++++++--------
gcc/ada/libgnarl/s-taspri__lynxos.ads | 16 ++++++++++------
gcc/ada/libgnarl/s-taspri__posix-noaltstack.ads | 16 ++++++++++------
gcc/ada/libgnarl/s-taspri__posix.ads | 16 ++++++++++------
gcc/ada/libgnarl/s-taspri__solaris.ads | 16 ++++++++++------
gcc/ada/libgnarl/s-tassta.adb | 2 +-
gcc/ada/libgnarl/s-tporft.adb | 1 +
11 files changed, 78 insertions(+), 61 deletions(-)
diff --git a/gcc/ada/libgnarl/s-taprop__linux.adb b/gcc/ada/libgnarl/s-taprop__linux.adb
index 0c09817739c..0a51b3601c0 100644
--- a/gcc/ada/libgnarl/s-taprop__linux.adb
+++ b/gcc/ada/libgnarl/s-taprop__linux.adb
@@ -730,7 +730,6 @@ package body System.Task_Primitives.Operations is
raise Invalid_CPU_Number;
end if;
- Self_ID.Common.LL.Thread := pthread_self;
Self_ID.Common.LL.LWP := lwp_self;
-- Set thread name to ease debugging. If the name of the task is
@@ -1004,14 +1003,14 @@ package body System.Task_Primitives.Operations is
-- do not need to manipulate caller's signal mask at this point.
-- All tasks in RTS will have All_Tasks_Mask initially.
- -- Note: the use of Unrestricted_Access in the following call is needed
- -- because otherwise we have an error of getting a access-to-volatile
- -- value which points to a non-volatile object. But in this case it is
- -- safe to do this, since we know we have no problems with aliasing and
- -- Unrestricted_Access bypasses this check.
+ -- The write to T.Common.LL.Thread is not racy with regard to the
+ -- created thread because the created thread will not access it until
+ -- we release the RTS lock (or the current task's lock when
+ -- Restricted.Stages is used). One can verify that by inspecting the
+ -- Task_Wrapper procedures.
Result := pthread_create
- (T.Common.LL.Thread'Unrestricted_Access,
+ (T.Common.LL.Thread'Access,
Thread_Attr'Access,
Thread_Body_Access (Wrapper),
To_Address (T));
@@ -1385,6 +1384,7 @@ package body System.Task_Primitives.Operations is
begin
Environment_Task_Id := Environment_Task;
+ Environment_Task.Common.LL.Thread := pthread_self;
Interrupt_Management.Initialize;
diff --git a/gcc/ada/libgnarl/s-taprop__posix.adb b/gcc/ada/libgnarl/s-taprop__posix.adb
index 7ed52ea2d82..fb70aaf4976 100644
--- a/gcc/ada/libgnarl/s-taprop__posix.adb
+++ b/gcc/ada/libgnarl/s-taprop__posix.adb
@@ -636,7 +636,6 @@ package body System.Task_Primitives.Operations is
procedure Enter_Task (Self_ID : Task_Id) is
begin
- Self_ID.Common.LL.Thread := pthread_self;
Self_ID.Common.LL.LWP := lwp_self;
Specific.Set (Self_ID);
@@ -841,14 +840,14 @@ package body System.Task_Primitives.Operations is
-- do not need to manipulate caller's signal mask at this point.
-- All tasks in RTS will have All_Tasks_Mask initially.
- -- Note: the use of Unrestricted_Access in the following call is needed
- -- because otherwise we have an error of getting a access-to-volatile
- -- value which points to a non-volatile object. But in this case it is
- -- safe to do this, since we know we have no problems with aliasing and
- -- Unrestricted_Access bypasses this check.
+ -- The write to T.Common.LL.Thread is not racy with regard to the
+ -- created thread because the created thread will not access it until
+ -- we release the RTS lock (or the current task's lock when
+ -- Restricted.Stages is used). One can verify that by inspecting the
+ -- Task_Wrapper procedures.
Result := pthread_create
- (T.Common.LL.Thread'Unrestricted_Access,
+ (T.Common.LL.Thread'Access,
Attributes'Access,
Thread_Body_Access (Wrapper),
To_Address (T));
@@ -1260,6 +1259,7 @@ package body System.Task_Primitives.Operations is
begin
Environment_Task_Id := Environment_Task;
+ Environment_Task.Common.LL.Thread := pthread_self;
Interrupt_Management.Initialize;
diff --git a/gcc/ada/libgnarl/s-taprop__qnx.adb b/gcc/ada/libgnarl/s-taprop__qnx.adb
index 108180d0617..f475c05c562 100644
--- a/gcc/ada/libgnarl/s-taprop__qnx.adb
+++ b/gcc/ada/libgnarl/s-taprop__qnx.adb
@@ -654,7 +654,6 @@ package body System.Task_Primitives.Operations is
procedure Enter_Task (Self_ID : Task_Id) is
begin
- Self_ID.Common.LL.Thread := pthread_self;
Self_ID.Common.LL.LWP := lwp_self;
Specific.Set (Self_ID);
@@ -846,14 +845,14 @@ package body System.Task_Primitives.Operations is
-- do not need to manipulate caller's signal mask at this point.
-- All tasks in RTS will have All_Tasks_Mask initially.
- -- Note: the use of Unrestricted_Access in the following call is needed
- -- because otherwise we have an error of getting a access-to-volatile
- -- value which points to a non-volatile object. But in this case it is
- -- safe to do this, since we know we have no problems with aliasing and
- -- Unrestricted_Access bypasses this check.
+ -- The write to T.Common.LL.Thread is not racy with regard to the
+ -- created thread because the created thread will not access it until
+ -- we release the RTS lock (or the current task's lock when
+ -- Restricted.Stages is used). One can verify that by inspecting the
+ -- Task_Wrapper procedures.
Result := pthread_create
- (T.Common.LL.Thread'Unrestricted_Access,
+ (T.Common.LL.Thread'Access,
Attributes'Access,
Thread_Body_Access (Wrapper),
To_Address (T));
@@ -1261,6 +1260,7 @@ package body System.Task_Primitives.Operations is
begin
Environment_Task_Id := Environment_Task;
+ Environment_Task.Common.LL.Thread := pthread_self;
Interrupt_Management.Initialize;
diff --git a/gcc/ada/libgnarl/s-taprop__rtems.adb b/gcc/ada/libgnarl/s-taprop__rtems.adb
index 3feafd8bc3a..ea8422cb454 100644
--- a/gcc/ada/libgnarl/s-taprop__rtems.adb
+++ b/gcc/ada/libgnarl/s-taprop__rtems.adb
@@ -646,7 +646,6 @@ package body System.Task_Primitives.Operations is
procedure Enter_Task (Self_ID : Task_Id) is
begin
- Self_ID.Common.LL.Thread := pthread_self;
Self_ID.Common.LL.LWP := lwp_self;
Specific.Set (Self_ID);
@@ -851,14 +850,14 @@ package body System.Task_Primitives.Operations is
-- do not need to manipulate caller's signal mask at this point.
-- All tasks in RTS will have All_Tasks_Mask initially.
- -- Note: the use of Unrestricted_Access in the following call is needed
- -- because otherwise we have an error of getting a access-to-volatile
- -- value which points to a non-volatile object. But in this case it is
- -- safe to do this, since we know we have no problems with aliasing and
- -- Unrestricted_Access bypasses this check.
+ -- The write to T.Common.LL.Thread is not racy with regard to the
+ -- created thread because the created thread will not access it until
+ -- we release the RTS lock (or the current task's lock when
+ -- Restricted.Stages is used). One can verify that by inspecting the
+ -- Task_Wrapper procedures.
Result := pthread_create
- (T.Common.LL.Thread'Unrestricted_Access,
+ (T.Common.LL.Thread'Access,
Attributes'Access,
Thread_Body_Access (Wrapper),
To_Address (T));
@@ -1270,6 +1269,7 @@ package body System.Task_Primitives.Operations is
begin
Environment_Task_Id := Environment_Task;
+ Environment_Task.Common.LL.Thread := pthread_self;
Interrupt_Management.Initialize;
diff --git a/gcc/ada/libgnarl/s-taprop__solaris.adb b/gcc/ada/libgnarl/s-taprop__solaris.adb
index 82e51b8d25c..09f90e6e204 100644
--- a/gcc/ada/libgnarl/s-taprop__solaris.adb
+++ b/gcc/ada/libgnarl/s-taprop__solaris.adb
@@ -424,6 +424,7 @@ package body System.Task_Primitives.Operations is
begin
Environment_Task_Id := Environment_Task;
+ Self_ID.Common.LL.Thread := thr_self;
Interrupt_Management.Initialize;
@@ -868,8 +869,7 @@ package body System.Task_Primitives.Operations is
procedure Enter_Task (Self_ID : Task_Id) is
begin
- Self_ID.Common.LL.Thread := thr_self;
- Self_ID.Common.LL.LWP := lwp_self;
+ Self_ID.Common.LL.LWP := lwp_self;
Set_Task_Affinity (Self_ID);
Specific.Set (Self_ID);
@@ -997,11 +997,11 @@ package body System.Task_Primitives.Operations is
Opts := THR_DETACHED + THR_BOUND;
end if;
- -- Note: the use of Unrestricted_Access in the following call is needed
- -- because otherwise we have an error of getting a access-to-volatile
- -- value which points to a non-volatile object. But in this case it is
- -- safe to do this, since we know we have no problems with aliasing and
- -- Unrestricted_Access bypasses this check.
+ -- The write to T.Common.LL.Thread is not racy with regard to the
+ -- created thread because the created thread will not access it until
+ -- we release the RTS lock (or the current task's lock when
+ -- Restricted.Stages is used). One can verify that by inspecting the
+ -- Task_Wrapper procedures.
Result :=
thr_create
@@ -1010,7 +1010,7 @@ package body System.Task_Primitives.Operations is
Thread_Body_Access (Wrapper),
To_Address (T),
Opts,
- T.Common.LL.Thread'Unrestricted_Access);
+ T.Common.LL.Thread'Access);
Succeeded := Result = 0;
pragma Assert
diff --git a/gcc/ada/libgnarl/s-taspri__lynxos.ads b/gcc/ada/libgnarl/s-taspri__lynxos.ads
index a3307000c80..f5e434eada6 100644
--- a/gcc/ada/libgnarl/s-taspri__lynxos.ads
+++ b/gcc/ada/libgnarl/s-taspri__lynxos.ads
@@ -86,12 +86,16 @@ private
type Private_Data is limited record
Thread : aliased System.OS_Interface.pthread_t;
- pragma Atomic (Thread);
- -- Thread field may be updated by two different threads of control.
- -- (See, Enter_Task and Create_Task in s-taprop.adb). They put the same
- -- value (thr_self value). We do not want to use lock on those
- -- operations and the only thing we have to make sure is that they are
- -- updated in atomic fashion.
+ -- This component is written to once before concurrent access to it is
+ -- possible, and then remains constant. The place where it is written to
+ -- depends on how the enclosing ATCB comes into existence:
+ --
+ -- 1. For the environment task, the component is set in
+ -- System.Task_Primitive.Operations.Initialize.
+ -- 2. For foreign threads, it happens in
+ -- System.Task_Primitives.Operations.Register_Foreign_Thread.
+ -- 3. For others tasks, it's in
+ -- System.Task_Primitives.Operations.Create_Task.
LWP : aliased System.OS_Interface.pthread_t;
-- The purpose of this field is to provide a better tasking support on
diff --git a/gcc/ada/libgnarl/s-taspri__posix-noaltstack.ads b/gcc/ada/libgnarl/s-taspri__posix-noaltstack.ads
index b92f1dd4ab2..fb7e07d10cd 100644
--- a/gcc/ada/libgnarl/s-taspri__posix-noaltstack.ads
+++ b/gcc/ada/libgnarl/s-taspri__posix-noaltstack.ads
@@ -89,12 +89,16 @@ private
type Private_Data is limited record
Thread : aliased System.OS_Interface.pthread_t;
- pragma Atomic (Thread);
- -- Thread field may be updated by two different threads of control.
- -- (See, Enter_Task and Create_Task in s-taprop.adb). They put the same
- -- value (thr_self value). We do not want to use lock on those
- -- operations and the only thing we have to make sure is that they are
- -- updated in atomic fashion.
+ -- This component is written to once before concurrent access to it is
+ -- possible, and then remains constant. The place where it is written to
+ -- depends on how the enclosing ATCB comes into existence:
+ --
+ -- 1. For the environment task, the component is set in
+ -- System.Task_Primitive.Operations.Initialize.
+ -- 2. For foreign threads, it happens in
+ -- System.Task_Primitives.Operations.Register_Foreign_Thread.
+ -- 3. For others tasks, it's in
+ -- System.Task_Primitives.Operations.Create_Task.
LWP : aliased System.Address;
-- The purpose of this field is to provide a better tasking support on
diff --git a/gcc/ada/libgnarl/s-taspri__posix.ads b/gcc/ada/libgnarl/s-taspri__posix.ads
index 4d0b379556d..3453f4fea4c 100644
--- a/gcc/ada/libgnarl/s-taspri__posix.ads
+++ b/gcc/ada/libgnarl/s-taspri__posix.ads
@@ -88,12 +88,16 @@ private
type Private_Data is limited record
Thread : aliased System.OS_Interface.pthread_t;
- pragma Atomic (Thread);
- -- Thread field may be updated by two different threads of control.
- -- (See, Enter_Task and Create_Task in s-taprop.adb). They put the same
- -- value (thr_self value). We do not want to use lock on those
- -- operations and the only thing we have to make sure is that they are
- -- updated in atomic fashion.
+ -- This component is written to once before concurrent access to it is
+ -- possible, and then remains constant. The place where it is written to
+ -- depends on how the enclosing ATCB comes into existence:
+ --
+ -- 1. For the environment task, the component is set in
+ -- System.Task_Primitive.Operations.Initialize.
+ -- 2. For foreign threads, it happens in
+ -- System.Task_Primitives.Operations.Register_Foreign_Thread.
+ -- 3. For others tasks, it's in
+ -- System.Task_Primitives.Operations.Create_Task.
LWP : aliased System.Address;
-- The purpose of this field is to provide a better tasking support on
diff --git a/gcc/ada/libgnarl/s-taspri__solaris.ads b/gcc/ada/libgnarl/s-taspri__solaris.ads
index 16fc4196b00..586c971dce6 100644
--- a/gcc/ada/libgnarl/s-taspri__solaris.ads
+++ b/gcc/ada/libgnarl/s-taspri__solaris.ads
@@ -95,12 +95,16 @@ private
type Private_Data is limited record
Thread : aliased System.OS_Interface.thread_t;
- pragma Atomic (Thread);
- -- Thread field may be updated by two different threads of control.
- -- (See, Enter_Task and Create_Task in s-taprop.adb). They put the same
- -- value (thr_self value). We do not want to use lock on those
- -- operations and the only thing we have to make sure is that they are
- -- updated in atomic fashion.
+ -- This component is written to once before concurrent access to it is
+ -- possible, and then remains constant. The place where it is written to
+ -- depends on how the enclosing ATCB comes into existence:
+ --
+ -- 1. For the environment task, the component is set in
+ -- System.Task_Primitive.Operations.Initialize.
+ -- 2. For foreign threads, it happens in
+ -- System.Task_Primitives.Operations.Register_Foreign_Thread.
+ -- 3. For others tasks, it's in
+ -- System.Task_Primitives.Operations.Create_Task.
LWP : System.OS_Interface.lwpid_t;
-- The LWP id of the thread. Set by self in Enter_Task
diff --git a/gcc/ada/libgnarl/s-tassta.adb b/gcc/ada/libgnarl/s-tassta.adb
index 01c94b950ba..594a1672866 100644
--- a/gcc/ada/libgnarl/s-tassta.adb
+++ b/gcc/ada/libgnarl/s-tassta.adb
@@ -1079,7 +1079,7 @@ package body System.Tasking.Stages is
Stack_Guard (Self_ID, True);
-- Initialize low-level TCB components, that cannot be initialized by
- -- the creator. Enter_Task sets Self_ID.LL.Thread.
+ -- the creator.
Enter_Task (Self_ID);
diff --git a/gcc/ada/libgnarl/s-tporft.adb b/gcc/ada/libgnarl/s-tporft.adb
index a7b4ce5e29a..66a9f02656e 100644
--- a/gcc/ada/libgnarl/s-tporft.adb
+++ b/gcc/ada/libgnarl/s-tporft.adb
@@ -98,6 +98,7 @@ begin
System.Soft_Links.Create_TSD
(Self_Id.Common.Compiler_Data, null, Sec_Stack_Size);
+ Self_Id.Common.LL.Thread := Thread;
Enter_Task (Self_Id);
return Self_Id;
--
2.43.2
^ permalink raw reply [flat|nested] 30+ messages in thread
* [COMMITTED 15/30] ada: Fix style in list of implementation-defined attributes
2024-05-20 7:48 [COMMITTED 01/30] ada: Rework and augment documentation on strict aliasing Marc Poulhiès
` (12 preceding siblings ...)
2024-05-20 7:48 ` [COMMITTED 14/30] ada: Tweak handling of thread ID on POSIX Marc Poulhiès
@ 2024-05-20 7:48 ` Marc Poulhiès
2024-05-20 7:48 ` [COMMITTED 16/30] ada: Use discrete choice list in declaration of universal type attributes Marc Poulhiès
` (14 subsequent siblings)
28 siblings, 0 replies; 30+ messages in thread
From: Marc Poulhiès @ 2024-05-20 7:48 UTC (permalink / raw)
To: gcc-patches; +Cc: Piotr Trojanek
From: Piotr Trojanek <trojanek@adacore.com>
Code cleanup.
gcc/ada/
* sem_attr.ads (Attribute_Impl_Def): Fix style in comment.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/sem_attr.ads | 8 ++++++++
1 file changed, 8 insertions(+)
diff --git a/gcc/ada/sem_attr.ads b/gcc/ada/sem_attr.ads
index 0e7d1693682..d18bd5b0667 100644
--- a/gcc/ada/sem_attr.ads
+++ b/gcc/ada/sem_attr.ads
@@ -288,6 +288,10 @@ package Sem_Attr is
-- attribute is primarily intended for use in implementation of the
-- standard input-output functions for fixed-point values.
+ --------------------
+ -- Invalid_Value --
+ --------------------
+
Attribute_Invalid_Value => True,
-- For every scalar type, S'Invalid_Value designates an undefined value
-- of the type. If possible this value is an invalid value, and in fact
@@ -298,6 +302,10 @@ package Sem_Attr is
-- coding standards in use), but logically no initialization is needed,
-- and the value should never be accessed.
+ ----------------
+ -- Loop_Entry --
+ ----------------
+
Attribute_Loop_Entry => True,
-- For every object of a non-limited type, S'Loop_Entry [(Loop_Name)]
-- denotes the constant value of prefix S at the point of entry into the
--
2.43.2
^ permalink raw reply [flat|nested] 30+ messages in thread
* [COMMITTED 16/30] ada: Use discrete choice list in declaration of universal type attributes
2024-05-20 7:48 [COMMITTED 01/30] ada: Rework and augment documentation on strict aliasing Marc Poulhiès
` (13 preceding siblings ...)
2024-05-20 7:48 ` [COMMITTED 15/30] ada: Fix style in list of implementation-defined attributes Marc Poulhiès
@ 2024-05-20 7:48 ` Marc Poulhiès
2024-05-20 7:48 ` [COMMITTED 17/30] ada: Remove repeated condition in check for implementation attributes Marc Poulhiès
` (13 subsequent siblings)
28 siblings, 0 replies; 30+ messages in thread
From: Marc Poulhiès @ 2024-05-20 7:48 UTC (permalink / raw)
To: gcc-patches; +Cc: Piotr Trojanek
From: Piotr Trojanek <trojanek@adacore.com>
Code cleanup.
gcc/ada/
* sem_attr.ads (Universal_Type_Attribute): Simplify using
array aggregate syntax with discrete choice list.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/sem_attr.ads | 62 ++++++++++++++++++++++----------------------
1 file changed, 31 insertions(+), 31 deletions(-)
diff --git a/gcc/ada/sem_attr.ads b/gcc/ada/sem_attr.ads
index d18bd5b0667..40ec423c4c7 100644
--- a/gcc/ada/sem_attr.ads
+++ b/gcc/ada/sem_attr.ads
@@ -615,37 +615,37 @@ package Sem_Attr is
-- universal type.
Universal_Type_Attribute : constant array (Attribute_Id) of Boolean :=
- (Attribute_Aft => True,
- Attribute_Alignment => True,
- Attribute_Component_Size => True,
- Attribute_Count => True,
- Attribute_Delta => True,
- Attribute_Digits => True,
- Attribute_Exponent => True,
- Attribute_First_Bit => True,
- Attribute_Fore => True,
- Attribute_Last_Bit => True,
- Attribute_Length => True,
- Attribute_Machine_Emax => True,
- Attribute_Machine_Emin => True,
- Attribute_Machine_Mantissa => True,
- Attribute_Machine_Radix => True,
- Attribute_Max_Alignment_For_Allocation => True,
- Attribute_Max_Size_In_Storage_Elements => True,
- Attribute_Model_Emin => True,
- Attribute_Model_Epsilon => True,
- Attribute_Model_Mantissa => True,
- Attribute_Model_Small => True,
- Attribute_Modulus => True,
- Attribute_Pos => True,
- Attribute_Position => True,
- Attribute_Safe_First => True,
- Attribute_Safe_Last => True,
- Attribute_Scale => True,
- Attribute_Size => True,
- Attribute_Small => True,
- Attribute_Wide_Wide_Width => True,
- Attribute_Wide_Width => True,
+ (Attribute_Aft |
+ Attribute_Alignment |
+ Attribute_Component_Size |
+ Attribute_Count |
+ Attribute_Delta |
+ Attribute_Digits |
+ Attribute_Exponent |
+ Attribute_First_Bit |
+ Attribute_Fore |
+ Attribute_Last_Bit |
+ Attribute_Length |
+ Attribute_Machine_Emax |
+ Attribute_Machine_Emin |
+ Attribute_Machine_Mantissa |
+ Attribute_Machine_Radix |
+ Attribute_Max_Alignment_For_Allocation |
+ Attribute_Max_Size_In_Storage_Elements |
+ Attribute_Model_Emin |
+ Attribute_Model_Epsilon |
+ Attribute_Model_Mantissa |
+ Attribute_Model_Small |
+ Attribute_Modulus |
+ Attribute_Pos |
+ Attribute_Position |
+ Attribute_Safe_First |
+ Attribute_Safe_Last |
+ Attribute_Scale |
+ Attribute_Size |
+ Attribute_Small |
+ Attribute_Wide_Wide_Width |
+ Attribute_Wide_Width |
Attribute_Width => True,
others => False);
--
2.43.2
^ permalink raw reply [flat|nested] 30+ messages in thread
* [COMMITTED 17/30] ada: Remove repeated condition in check for implementation attributes
2024-05-20 7:48 [COMMITTED 01/30] ada: Rework and augment documentation on strict aliasing Marc Poulhiès
` (14 preceding siblings ...)
2024-05-20 7:48 ` [COMMITTED 16/30] ada: Use discrete choice list in declaration of universal type attributes Marc Poulhiès
@ 2024-05-20 7:48 ` Marc Poulhiès
2024-05-20 7:48 ` [COMMITTED 18/30] ada: Apply restriction No_Implementation_Attributes to source nodes only Marc Poulhiès
` (12 subsequent siblings)
28 siblings, 0 replies; 30+ messages in thread
From: Marc Poulhiès @ 2024-05-20 7:48 UTC (permalink / raw)
To: gcc-patches; +Cc: Piotr Trojanek
From: Piotr Trojanek <trojanek@adacore.com>
Code cleanup; semantics is unaffected.
gcc/ada/
* sem_attr.adb (Analyze_Attribute): Remove condition that is
already checked by an enclosing IF statement.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/sem_attr.adb | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
index 2b22cf13ad0..6c32d201c55 100644
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -3225,7 +3225,7 @@ package body Sem_Attr is
if Comes_From_Source (N) then
if not Attribute_83 (Attr_Id) then
- if Ada_Version = Ada_83 and then Comes_From_Source (N) then
+ if Ada_Version = Ada_83 then
Error_Msg_Name_1 := Aname;
Error_Msg_N ("(Ada 83) attribute% is not standard??", N);
end if;
--
2.43.2
^ permalink raw reply [flat|nested] 30+ messages in thread
* [COMMITTED 18/30] ada: Apply restriction No_Implementation_Attributes to source nodes only
2024-05-20 7:48 [COMMITTED 01/30] ada: Rework and augment documentation on strict aliasing Marc Poulhiès
` (15 preceding siblings ...)
2024-05-20 7:48 ` [COMMITTED 17/30] ada: Remove repeated condition in check for implementation attributes Marc Poulhiès
@ 2024-05-20 7:48 ` Marc Poulhiès
2024-05-20 7:48 ` [COMMITTED 19/30] ada: Fix list of attributes defined by Ada 2012 Marc Poulhiès
` (11 subsequent siblings)
28 siblings, 0 replies; 30+ messages in thread
From: Marc Poulhiès @ 2024-05-20 7:48 UTC (permalink / raw)
To: gcc-patches; +Cc: Piotr Trojanek
From: Piotr Trojanek <trojanek@adacore.com>
Restriction No_Implementation_Attributes must not be applied to nodes
that come from expansion. In particular, it must not be applied to
Object_Size, which is implementation-defined attribute before Ada 2022,
but appears in expansion of tagged types since Ada 95.
gcc/ada/
* sem_attr.adb (Analyze_Attribute): Move IF statement that
checks restriction No_Implementation_Attributes for Ada 2005,
2012 and Ada 2022 attributes inside Comes_From_Source condition
that checks the same restriction for Ada 83 attributes.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/sem_attr.adb | 27 ++++++++++++++-------------
1 file changed, 14 insertions(+), 13 deletions(-)
diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
index 6c32d201c55..414224e86b6 100644
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -3221,9 +3221,10 @@ package body Sem_Attr is
Check_Restriction_No_Use_Of_Attribute (N);
- -- Deal with Ada 83 issues
-
if Comes_From_Source (N) then
+
+ -- Deal with Ada 83 issues
+
if not Attribute_83 (Attr_Id) then
if Ada_Version = Ada_83 then
Error_Msg_Name_1 := Aname;
@@ -3234,19 +3235,19 @@ package body Sem_Attr is
Check_Restriction (No_Implementation_Attributes, N);
end if;
end if;
- end if;
- -- Deal with Ada 2005 attributes that are implementation attributes
- -- because they appear in a version of Ada before Ada 2005, ditto for
- -- Ada 2012 and Ada 2022 attributes appearing in an earlier version.
+ -- Deal with Ada 2005 attributes that are implementation attributes
+ -- because they appear in a version of Ada before Ada 2005, ditto for
+ -- Ada 2012 and Ada 2022 attributes appearing in an earlier version.
- if (Attribute_05 (Attr_Id) and then Ada_Version < Ada_2005)
- or else
- (Attribute_12 (Attr_Id) and then Ada_Version < Ada_2012)
- or else
- (Attribute_22 (Attr_Id) and then Ada_Version < Ada_2022)
- then
- Check_Restriction (No_Implementation_Attributes, N);
+ if (Attribute_05 (Attr_Id) and then Ada_Version < Ada_2005)
+ or else
+ (Attribute_12 (Attr_Id) and then Ada_Version < Ada_2012)
+ or else
+ (Attribute_22 (Attr_Id) and then Ada_Version < Ada_2022)
+ then
+ Check_Restriction (No_Implementation_Attributes, N);
+ end if;
end if;
-- Remote access to subprogram type access attribute reference needs
--
2.43.2
^ permalink raw reply [flat|nested] 30+ messages in thread
* [COMMITTED 19/30] ada: Fix list of attributes defined by Ada 2012
2024-05-20 7:48 [COMMITTED 01/30] ada: Rework and augment documentation on strict aliasing Marc Poulhiès
` (16 preceding siblings ...)
2024-05-20 7:48 ` [COMMITTED 18/30] ada: Apply restriction No_Implementation_Attributes to source nodes only Marc Poulhiès
@ 2024-05-20 7:48 ` Marc Poulhiès
2024-05-20 7:48 ` [COMMITTED 20/30] ada: Fix list of implementation-defined attributes Marc Poulhiès
` (10 subsequent siblings)
28 siblings, 0 replies; 30+ messages in thread
From: Marc Poulhiès @ 2024-05-20 7:48 UTC (permalink / raw)
To: gcc-patches; +Cc: Piotr Trojanek
From: Piotr Trojanek <trojanek@adacore.com>
Recognize references to attributes Old, Overlaps_Storage and Result as
language-defined in Ada 2012 and implementation-defined in earlier
versions of Ada. Other attributes introduced by Ada 2012 RM are
correctly categorized.
This change only affects code with restriction
No_Implementation_Attributes.
gcc/ada/
* sem_attr.adb (Attribute_12): Add attributes Old,
Overlaps_Storage and Result.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/sem_attr.adb | 5 ++++-
1 file changed, 4 insertions(+), 1 deletion(-)
diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
index 414224e86b6..df52229b6aa 100644
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -170,7 +170,10 @@ package body Sem_Attr is
(Attribute_First_Valid |
Attribute_Has_Same_Storage |
Attribute_Last_Valid |
- Attribute_Max_Alignment_For_Allocation => True,
+ Attribute_Max_Alignment_For_Allocation |
+ Attribute_Old |
+ Attribute_Overlaps_Storage |
+ Attribute_Result => True,
others => False);
-- The following array is the list of attributes defined in the Ada 2022
--
2.43.2
^ permalink raw reply [flat|nested] 30+ messages in thread
* [COMMITTED 20/30] ada: Fix list of implementation-defined attributes
2024-05-20 7:48 [COMMITTED 01/30] ada: Rework and augment documentation on strict aliasing Marc Poulhiès
` (17 preceding siblings ...)
2024-05-20 7:48 ` [COMMITTED 19/30] ada: Fix list of attributes defined by Ada 2012 Marc Poulhiès
@ 2024-05-20 7:48 ` Marc Poulhiès
2024-05-20 7:48 ` [COMMITTED 21/30] ada: Further refine 'Super attribute Marc Poulhiès
` (9 subsequent siblings)
28 siblings, 0 replies; 30+ messages in thread
From: Marc Poulhiès @ 2024-05-20 7:48 UTC (permalink / raw)
To: gcc-patches; +Cc: Piotr Trojanek
From: Piotr Trojanek <trojanek@adacore.com>
Several of the implementation-defined attributes were wrongly recognized
as defined by the Ada RM.
This change only affects code with restriction
No_Implementation_Attributes.
gcc/ada/
* sem_attr.ads (Attribute_Impl_Def): Fix list of
implementation-defined attributes.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/sem_attr.ads | 27 +++++++++++++++++++++++++++
1 file changed, 27 insertions(+)
diff --git a/gcc/ada/sem_attr.ads b/gcc/ada/sem_attr.ads
index 40ec423c4c7..52359e40ef6 100644
--- a/gcc/ada/sem_attr.ads
+++ b/gcc/ada/sem_attr.ads
@@ -609,6 +609,33 @@ package Sem_Attr is
-- for constructing this definition in package System (see note above
-- in Default_Bit_Order description). This is a static attribute.
+ Attribute_Atomic_Always_Lock_Free |
+ Attribute_Bit_Position |
+ Attribute_Compiler_Version |
+ Attribute_Descriptor_Size |
+ Attribute_Enabled |
+ Attribute_Fast_Math |
+ Attribute_From_Any |
+ Attribute_Has_Access_Values |
+ Attribute_Has_Tagged_Values |
+ Attribute_Initialized |
+ Attribute_Library_Level |
+ Attribute_Pool_Address |
+ Attribute_Restriction_Set |
+ Attribute_Scalar_Storage_Order |
+ Attribute_Simple_Storage_Pool |
+ Attribute_Small_Denominator |
+ Attribute_Small_Numerator |
+ Attribute_System_Allocator_Alignment |
+ Attribute_To_Any |
+ Attribute_TypeCode |
+ Attribute_Type_Key |
+ Attribute_Unconstrained_Array |
+ Attribute_Update |
+ Attribute_Valid_Value |
+ Attribute_Wchar_T_Size => True,
+ -- See description in GNAT RM
+
others => False);
-- The following table lists all attributes that yield a result of a
--
2.43.2
^ permalink raw reply [flat|nested] 30+ messages in thread
* [COMMITTED 21/30] ada: Further refine 'Super attribute
2024-05-20 7:48 [COMMITTED 01/30] ada: Rework and augment documentation on strict aliasing Marc Poulhiès
` (18 preceding siblings ...)
2024-05-20 7:48 ` [COMMITTED 20/30] ada: Fix list of implementation-defined attributes Marc Poulhiès
@ 2024-05-20 7:48 ` Marc Poulhiès
2024-05-20 7:48 ` [COMMITTED 22/30] ada: Handle accessibility calculations for 'First and 'Last Marc Poulhiès
` (8 subsequent siblings)
28 siblings, 0 replies; 30+ messages in thread
From: Marc Poulhiès @ 2024-05-20 7:48 UTC (permalink / raw)
To: gcc-patches; +Cc: Justin Squirek
From: Justin Squirek <squirek@adacore.com>
This patch relaxes the restriction on 'Super such that it can apply to abstract
type objects.
gcc/ada/
* sem_attr.adb (Analyze_Attribute): Remove restriction on 'Super
for abstract types.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/sem_attr.adb | 4 ----
1 file changed, 4 deletions(-)
diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
index df52229b6aa..403810c8b5e 100644
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -6683,10 +6683,6 @@ package body Sem_Attr is
elsif Depends_On_Private (P_Type) then
Error_Attr_P ("prefix type of % is a private extension");
- -- Check that we don't view convert to an abstract type
-
- elsif Is_Abstract_Type (Node (First_Elmt (Parents))) then
- Error_Attr_P ("type of % cannot be abstract");
end if;
-- Generate a view conversion and analyze it
--
2.43.2
^ permalink raw reply [flat|nested] 30+ messages in thread
* [COMMITTED 22/30] ada: Handle accessibility calculations for 'First and 'Last
2024-05-20 7:48 [COMMITTED 01/30] ada: Rework and augment documentation on strict aliasing Marc Poulhiès
` (19 preceding siblings ...)
2024-05-20 7:48 ` [COMMITTED 21/30] ada: Further refine 'Super attribute Marc Poulhiès
@ 2024-05-20 7:48 ` Marc Poulhiès
2024-05-20 7:48 ` [COMMITTED 23/30] ada: Error on instantiation of generic containing legal container aggregate Marc Poulhiès
` (7 subsequent siblings)
28 siblings, 0 replies; 30+ messages in thread
From: Marc Poulhiès @ 2024-05-20 7:48 UTC (permalink / raw)
To: gcc-patches; +Cc: Justin Squirek
From: Justin Squirek <squirek@adacore.com>
This patch fixes a crash in the compiler whereby calculating the accessibility
level of of a local variable whose original expression is an 'First on an
array type led to an error during compilation.
gcc/ada/
* accessibility.adb (Accessibility_Level): Add cases for 'First
and 'Last.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/accessibility.adb | 10 +++++++++-
1 file changed, 9 insertions(+), 1 deletion(-)
diff --git a/gcc/ada/accessibility.adb b/gcc/ada/accessibility.adb
index c0a9d50f38a..33ce001718a 100644
--- a/gcc/ada/accessibility.adb
+++ b/gcc/ada/accessibility.adb
@@ -465,7 +465,15 @@ package body Accessibility is
-- so handle these cases explicitly.
elsif Attribute_Name (E)
- in Name_Old | Name_Loop_Entry | Name_Result | Name_Super
+ in Name_Old |
+ Name_Loop_Entry |
+ Name_Result |
+ Name_Super |
+ Name_Tag |
+ Name_Safe_First |
+ Name_Safe_Last |
+ Name_First |
+ Name_Last
then
-- Named access types
--
2.43.2
^ permalink raw reply [flat|nested] 30+ messages in thread
* [COMMITTED 23/30] ada: Error on instantiation of generic containing legal container aggregate
2024-05-20 7:48 [COMMITTED 01/30] ada: Rework and augment documentation on strict aliasing Marc Poulhiès
` (20 preceding siblings ...)
2024-05-20 7:48 ` [COMMITTED 22/30] ada: Handle accessibility calculations for 'First and 'Last Marc Poulhiès
@ 2024-05-20 7:48 ` Marc Poulhiès
2024-05-20 7:48 ` [COMMITTED 24/30] " Marc Poulhiès
` (6 subsequent siblings)
28 siblings, 0 replies; 30+ messages in thread
From: Marc Poulhiès @ 2024-05-20 7:48 UTC (permalink / raw)
To: gcc-patches; +Cc: Gary Dismukes
From: Gary Dismukes <dismukes@adacore.com>
When a container aggregate for a predefined container type (such as
a Vector type) that has an iterated component association occurs within
a generic unit and that generic is instantiated, the compiler reports
a spurious error message "iterated component association can only appear
in an array aggregate" and the compilation aborts (because Unrecoverable_Error
is raised unconditionally after that error). The problem is that as part of
the instantiation process, for aggregates whose type has a partial view,
in Copy_Generic_Node the compiler switches the visibility so that the full
view of the type is available, and for a type whose full view is a record
type this leads to incorrectly trying to process the aggregate as a record
aggregate in Resolve_Aggregate (making a call to Resolve_Record_Aggregate).
Rather than trying to address this by changing what Copy_Generic_Node does,
this can be fixed by reordering and adjusting the code in Resolve_Aggregate,
so that we first test whether we need to resolve as a record aggregate
(if the aggregate is not homogeneous), followed by testing whether the
type has an Aggregate aspect and calling Resolve_Container_Aggregate.
As a bonus, we also remove the subsequent complex condition and redundant
code for handling null container aggregates.
gcc/ada/
* sem_aggr.adb (Resolve_Aggregate): Move condition and call for
Resolve_Record_Aggregate in front of code related to calling
Resolve_Container_Aggregate (and add test that the aggregate
is not homogeneous), and remove special-case testing and call
to Resolve_Container_Aggregate for empty aggregates.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/sem_aggr.adb | 22 +++++-----------------
1 file changed, 5 insertions(+), 17 deletions(-)
diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb
index 658b3a4634c..6e40e5c2564 100644
--- a/gcc/ada/sem_aggr.adb
+++ b/gcc/ada/sem_aggr.adb
@@ -1182,8 +1182,12 @@ package body Sem_Aggr is
elsif Is_Array_Type (Typ) and then Null_Record_Present (N) then
Error_Msg_N ("null record forbidden in array aggregate", N);
+ elsif Is_Record_Type (Typ)
+ and then not Is_Homogeneous_Aggregate (N)
+ then
+ Resolve_Record_Aggregate (N, Typ);
+
elsif Has_Aspect (Typ, Aspect_Aggregate)
- and then Ekind (Typ) /= E_Record_Type
and then Ada_Version >= Ada_2022
then
-- Check for Ada 2022 and () aggregate.
@@ -1194,22 +1198,6 @@ package body Sem_Aggr is
Resolve_Container_Aggregate (N, Typ);
- -- Check Ada 2022 empty aggregate [] initializing a record type that has
- -- aspect aggregate; the empty aggregate will be expanded into a call to
- -- the empty function specified in the aspect aggregate.
-
- elsif Has_Aspect (Typ, Aspect_Aggregate)
- and then Ekind (Typ) = E_Record_Type
- and then Is_Homogeneous_Aggregate (N)
- and then Is_Empty_List (Expressions (N))
- and then Is_Empty_List (Component_Associations (N))
- and then Ada_Version >= Ada_2022
- then
- Resolve_Container_Aggregate (N, Typ);
-
- elsif Is_Record_Type (Typ) then
- Resolve_Record_Aggregate (N, Typ);
-
elsif Is_Array_Type (Typ) then
-- First a special test, for the case of a positional aggregate of
--
2.43.2
^ permalink raw reply [flat|nested] 30+ messages in thread
* [COMMITTED 24/30] ada: Error on instantiation of generic containing legal container aggregate
2024-05-20 7:48 [COMMITTED 01/30] ada: Rework and augment documentation on strict aliasing Marc Poulhiès
` (21 preceding siblings ...)
2024-05-20 7:48 ` [COMMITTED 23/30] ada: Error on instantiation of generic containing legal container aggregate Marc Poulhiès
@ 2024-05-20 7:48 ` Marc Poulhiès
2024-05-20 7:48 ` [COMMITTED 25/30] ada: Add Is_Base_Type predicate to C interface Marc Poulhiès
` (5 subsequent siblings)
28 siblings, 0 replies; 30+ messages in thread
From: Marc Poulhiès @ 2024-05-20 7:48 UTC (permalink / raw)
To: gcc-patches; +Cc: Gary Dismukes
From: Gary Dismukes <dismukes@adacore.com>
When a container aggregate for a predefined container type (such as
a Vector type) that has an iterated component association occurs within
a generic unit and that generic is instantiated, the compiler reports
a spurious error message "iterated component association can only appear
in an array aggregate" and the compilation aborts (because Unrecoverable_Error
is raised unconditionally after that error). The problem is that as part of
the instantiation process, for aggregates whose type has a partial view,
in Copy_Generic_Node the compiler switches the visibility so that the full
view of the type is available, and for a type whose full view is a record
type this leads to incorrectly trying to process the aggregate as a record
aggregate in Resolve_Aggregate (making a call to Resolve_Record_Aggregate).
Rather than trying to address this by changing what Copy_Generic_Node does,
this can be fixed by reordering and adjusting the code in Resolve_Aggregate,
so that we first test whether we need to resolve as a record aggregate
(if the aggregate is not homogeneous), followed by testing whether the
type has an Aggregate aspect and calling Resolve_Container_Aggregate.
As a bonus, we also remove the subsequent complex condition and redundant
code for handling null container aggregates.
gcc/ada/
* sem_aggr.adb (Resolve_Aggregate): Move condition and call for
Resolve_Record_Aggregate in front of code related to calling
Resolve_Container_Aggregate (and add test that the aggregate is
not homogeneous), and remove special-case testing and call to
Resolve_Container_Aggregate for empty aggregates. Also, add error
check for an attempt to use "[]" for an aggregate of a record type
that does not specify an Aggregate aspect.
(Resolve_Record_Aggregate): Remove error check for record
aggregates with "[]" (now done by Resolve_Aggregate).
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/sem_aggr.adb | 17 ++++++++---------
1 file changed, 8 insertions(+), 9 deletions(-)
diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb
index 6e40e5c2564..60738550ec1 100644
--- a/gcc/ada/sem_aggr.adb
+++ b/gcc/ada/sem_aggr.adb
@@ -1198,6 +1198,14 @@ package body Sem_Aggr is
Resolve_Container_Aggregate (N, Typ);
+ -- Check for an attempt to use "[]" for an aggregate of a record type
+ -- after handling the case where the type has an Aggregate aspect,
+ -- because the aspect can be specified for record types, but if it
+ -- wasn't specified, then this is an error.
+
+ elsif Is_Record_Type (Typ) and then Is_Homogeneous_Aggregate (N) then
+ Error_Msg_N ("record aggregate must use (), not '[']", N);
+
elsif Is_Array_Type (Typ) then
-- First a special test, for the case of a positional aggregate of
@@ -5518,15 +5526,6 @@ package body Sem_Aggr is
return;
end if;
- -- A record aggregate can only use parentheses
-
- if Nkind (N) = N_Aggregate
- and then Is_Homogeneous_Aggregate (N)
- then
- Error_Msg_N ("record aggregate must use (), not '[']", N);
- return;
- end if;
-
-- STEP 2: Verify aggregate structure
Step_2 : declare
--
2.43.2
^ permalink raw reply [flat|nested] 30+ messages in thread
* [COMMITTED 25/30] ada: Add Is_Base_Type predicate to C interface
2024-05-20 7:48 [COMMITTED 01/30] ada: Rework and augment documentation on strict aliasing Marc Poulhiès
` (22 preceding siblings ...)
2024-05-20 7:48 ` [COMMITTED 24/30] " Marc Poulhiès
@ 2024-05-20 7:48 ` Marc Poulhiès
2024-05-20 7:48 ` [COMMITTED 26/30] ada: Formal package comment corrections in sinfo.ads Marc Poulhiès
` (4 subsequent siblings)
28 siblings, 0 replies; 30+ messages in thread
From: Marc Poulhiès @ 2024-05-20 7:48 UTC (permalink / raw)
To: gcc-patches; +Cc: Eric Botcazou
From: Eric Botcazou <ebotcazou@adacore.com>
This also documents what the predicate effectively does.
gcc/ada/
* einfo-utils.ads (Is_Base_Type): Move to Miscellaneous Subprograms
section and add description.
* fe.h (Is_Base_Type): Declare.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/einfo-utils.ads | 8 ++++++--
gcc/ada/fe.h | 4 +++-
2 files changed, 9 insertions(+), 3 deletions(-)
diff --git a/gcc/ada/einfo-utils.ads b/gcc/ada/einfo-utils.ads
index d87a3e34f49..01953c35bc3 100644
--- a/gcc/ada/einfo-utils.ads
+++ b/gcc/ada/einfo-utils.ads
@@ -183,8 +183,6 @@ package Einfo.Utils is
function Has_Null_Abstract_State (Id : E) return B;
function Has_Null_Visible_Refinement (Id : E) return B;
function Implementation_Base_Type (Id : E) return E;
- function Is_Base_Type (Id : E) return B with Inline;
- -- Note that Is_Base_Type returns True for nontypes
function Is_Boolean_Type (Id : E) return B with Inline;
function Is_Constant_Object (Id : E) return B with Inline;
function Is_Controlled (Id : E) return B with Inline;
@@ -504,6 +502,12 @@ package Einfo.Utils is
-- is the name of a class_wide type whose root is incomplete, return the
-- corresponding full declaration, else return T itself.
+ function Is_Base_Type (Id : E) return B with Inline;
+ -- Return True for a type entity and False for a subtype entity. Note that
+ -- this returns True for nontypes.
+
+ -- WARNING: There is a matching C declaration of this subprogram in fe.h
+
function Is_Entity_Name (N : Node_Id) return Boolean with Inline;
-- Test if the node N is the name of an entity (i.e. is an identifier,
-- expanded name, or an attribute reference that returns an entity).
diff --git a/gcc/ada/fe.h b/gcc/ada/fe.h
index 692c29a70af..b4c1aea5c8b 100644
--- a/gcc/ada/fe.h
+++ b/gcc/ada/fe.h
@@ -98,9 +98,11 @@ extern void Set_Normalized_First_Bit (Entity_Id, Uint);
extern void Set_Normalized_Position (Entity_Id, Uint);
extern void Set_RM_Size (Entity_Id, Uint);
+#define Is_Base_Type einfo__utils__is_base_type
#define Is_Entity_Name einfo__utils__is_entity_name
-extern Boolean Is_Entity_Name (Node_Id);
+extern Boolean Is_Base_Type (Entity_Id);
+extern Boolean Is_Entity_Name (Node_Id);
#define Get_Attribute_Definition_Clause einfo__utils__get_attribute_definition_clause
--
2.43.2
^ permalink raw reply [flat|nested] 30+ messages in thread
* [COMMITTED 26/30] ada: Formal package comment corrections in sinfo.ads
2024-05-20 7:48 [COMMITTED 01/30] ada: Rework and augment documentation on strict aliasing Marc Poulhiès
` (23 preceding siblings ...)
2024-05-20 7:48 ` [COMMITTED 25/30] ada: Add Is_Base_Type predicate to C interface Marc Poulhiès
@ 2024-05-20 7:48 ` Marc Poulhiès
2024-05-20 7:48 ` [COMMITTED 27/30] ada: Get rid of secondary stack for indefinite record types with size clause Marc Poulhiès
` (3 subsequent siblings)
28 siblings, 0 replies; 30+ messages in thread
From: Marc Poulhiès @ 2024-05-20 7:48 UTC (permalink / raw)
To: gcc-patches; +Cc: Bob Duff
From: Bob Duff <duff@adacore.com>
Misc comment corrections and clarifications in sinfo.ads
related to generic formal packages.
gcc/ada/
* sinfo.ads: Misc comment corrections and clarifications.
The syntax for GENERIC_ASSOCIATION and FORMAL_PACKAGE_ACTUAL_PART
was wrong.
Emphasize that "others => <>" is not represented as an
N_Generic_Association (with or without Box_Present set),
and give examples illustrating the various possibilities.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/sinfo.ads | 61 +++++++++++++++++++++++++++++++++++------------
1 file changed, 46 insertions(+), 15 deletions(-)
diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads
index 228082eb823..599f4f63cce 100644
--- a/gcc/ada/sinfo.ads
+++ b/gcc/ada/sinfo.ads
@@ -1574,9 +1574,9 @@ package Sinfo is
-- Instance_Spec
-- This field is present in generic instantiation nodes, and also in
-- formal package declaration nodes (formal package declarations are
- -- treated in a manner very similar to package instantiations). It points
- -- to the node for the spec of the instance, inserted as part of the
- -- semantic processing for instantiations in Sem_Ch12.
+ -- treated similarly to package instantiations). It points to the node
+ -- for the spec of the instance, inserted as part of the semantic
+ -- processing for instantiations in Sem_Ch12.
-- Is_Abort_Block
-- Present in N_Block_Statement nodes. True if the block protects a list
@@ -3639,8 +3639,8 @@ package Sinfo is
-- The only choice that appears explicitly is the OTHERS choice, as
-- defined here. Other cases of discrete choice (expression and
- -- discrete range) appear directly. This production is also used
- -- for the OTHERS possibility of an exception choice.
+ -- discrete range) appear directly. N_Others_Choice is also used
+ -- in exception handlers and generic formal packages.
-- Note: in accordance with the syntax, the parser does not check that
-- OTHERS appears at the end on its own in a choice list context. This
@@ -7139,6 +7139,7 @@ package Sinfo is
-- GENERIC_ASSOCIATION ::=
-- [generic_formal_parameter_SELECTOR_NAME =>]
+ -- EXPLICIT_GENERIC_ACTUAL_PARAMETER
-- Note: unlike the procedure call case, a generic association node
-- is generated for every association, even if no formal parameter
@@ -7149,7 +7150,8 @@ package Sinfo is
-- In Ada 2005, a formal may be associated with a box, if the
-- association is part of the list of actuals for a formal package.
-- If the association is given by OTHERS => <>, the association is
- -- an N_Others_Choice.
+ -- an N_Others_Choice (not an N_Generic_Association whose Selector_Name
+ -- is an N_Others_Choice).
-- N_Generic_Association
-- Sloc points to first token of generic association
@@ -7442,7 +7444,7 @@ package Sinfo is
-- Defining_Identifier
-- Name
-- Generic_Associations (set to No_List if (<>) case or
- -- empty generic actual part)
+ -- empty formal package actual part)
-- Box_Present
-- Instance_Spec
-- Is_Known_Guaranteed_ABE
@@ -7452,21 +7454,50 @@ package Sinfo is
--------------------------------------
-- FORMAL_PACKAGE_ACTUAL_PART ::=
- -- ([OTHERS] => <>)
+ -- ([OTHERS =>] <>)
-- | [GENERIC_ACTUAL_PART]
- -- (FORMAL_PACKAGE_ASSOCIATION {. FORMAL_PACKAGE_ASSOCIATION}
+ -- | (FORMAL_PACKAGE_ASSOCIATION {, FORMAL_PACKAGE_ASSOCIATION}
+ -- [, OTHERS => <>])
-- FORMAL_PACKAGE_ASSOCIATION ::=
-- GENERIC_ASSOCIATION
-- | GENERIC_FORMAL_PARAMETER_SELECTOR_NAME => <>
-- There is no explicit node in the tree for a formal package actual
- -- part. Instead the information appears in the parent node (i.e. the
- -- formal package declaration node itself).
-
- -- There is no explicit node for a formal package association. All of
- -- them are represented either by a generic association, possibly with
- -- Box_Present, or by an N_Others_Choice.
+ -- part, nor for a formal package association. A formal package
+ -- association is represented as a generic association, possibly with
+ -- Box_Present.
+ --
+ -- The "others => <>" syntax (both cases) is represented as an
+ -- N_Others_Choice (not an N_Generic_Association whose Selector_Name
+ -- is an N_Others_Choice). This admittedly odd representation does not
+ -- lose information, because "others" cannot be followed by anything
+ -- other than "=> <>". Thus:
+ --
+ -- "... is new G;"
+ -- The N_Formal_Package_Declaration has empty Generic_Associations,
+ -- and Box_Present = False.
+ --
+ -- "... is new G(<>);"
+ -- The N_Formal_Package_Declaration has empty Generic_Associations,
+ -- and Box_Present = True.
+ --
+ -- "... is new G(others => <>);"
+ -- The N_Formal_Package_Declaration has Generic_Associations with a
+ -- single element, which is an N_Others_Choice.
+ -- The N_Formal_Package_Declaration has Box_Present = False.
+ --
+ -- "... is new G(X, F => Y, others => <>);"
+ -- The N_Formal_Package_Declaration has Generic_Associations with
+ -- three elements, the last of which is an N_Others_Choice.
+ -- The N_Formal_Package_Declaration has Box_Present = False.
+ --
+ -- "... is new G(F1 => X, F2 => <>, others => <>);"
+ -- The N_Formal_Package_Declaration has Generic_Associations with
+ -- three elements. The first is an N_Generic_Association with
+ -- Box_Present = False. The second is an N_Generic_Association with
+ -- Box_Present = True. The last is an N_Others_Choice.
+ -- The N_Formal_Package_Declaration has Box_Present = False.
---------------------------------
-- 13.1 Representation clause --
--
2.43.2
^ permalink raw reply [flat|nested] 30+ messages in thread
* [COMMITTED 27/30] ada: Get rid of secondary stack for indefinite record types with size clause
2024-05-20 7:48 [COMMITTED 01/30] ada: Rework and augment documentation on strict aliasing Marc Poulhiès
` (24 preceding siblings ...)
2024-05-20 7:48 ` [COMMITTED 26/30] ada: Formal package comment corrections in sinfo.ads Marc Poulhiès
@ 2024-05-20 7:48 ` Marc Poulhiès
2024-05-20 7:48 ` [COMMITTED 28/30] ada: Fix internal error on nested aggregate in conditional expression Marc Poulhiès
` (2 subsequent siblings)
28 siblings, 0 replies; 30+ messages in thread
From: Marc Poulhiès @ 2024-05-20 7:48 UTC (permalink / raw)
To: gcc-patches; +Cc: Eric Botcazou
From: Eric Botcazou <ebotcazou@adacore.com>
This change eliminates the use of the secondary stack for indefinite record
types for which a valid (object) size clause is specified. In accordance
with the RM, the compiler accepts (object) size clauses on such types only
if all the components, including those of the variants of the variant part
if any, have a size known at compile time, and only if the clauses specify
a value that is at least as large as the largest possible size of objects
of the types when all the variants are considered. However, it would still
have used the secondary stack, despite valid (object) size clauses, before
the change, as soon as a variant part was present in the types.
gcc/ada/
* freeze.ads (Check_Compile_Time_Size): Remove obsolete description
of usage for the Size_Known_At_Compile_Time flag.
* freeze.adb (Check_Compile_Time_Size.Size_Known): In the case where
a variant part is present, do not return False if Esize is known.
* sem_util.adb (Needs_Secondary_Stack.Caller_Known_Size_Record): Add
missing "Start of processing" comment. Return true if either a size
clause or an object size clause has been given for the first subtype
of the type.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/freeze.adb | 1 +
gcc/ada/freeze.ads | 11 +++++------
gcc/ada/sem_util.adb | 12 ++++++++++++
3 files changed, 18 insertions(+), 6 deletions(-)
diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb
index 26e9d01d8b2..ea6106e6455 100644
--- a/gcc/ada/freeze.adb
+++ b/gcc/ada/freeze.adb
@@ -1077,6 +1077,7 @@ package body Freeze is
and then
No (Discriminant_Default_Value (First_Discriminant (T)))
and then not Known_RM_Size (T)
+ and then not Known_Esize (T)
then
return False;
end if;
diff --git a/gcc/ada/freeze.ads b/gcc/ada/freeze.ads
index fc0b7678fdc..066d8f054f6 100644
--- a/gcc/ada/freeze.ads
+++ b/gcc/ada/freeze.ads
@@ -156,17 +156,16 @@ package Freeze is
-- RM_Size field is set to the required size, allowing for possible front
-- end packing of an array using this type as a component type.
--
- -- Note: the flag Size_Known_At_Compile_Time is used to determine if the
- -- secondary stack must be used to return a value of the type, and also
- -- to determine whether a component clause is allowed for a component
- -- of the given type.
- --
- -- Note: this is public because of one dubious use in Sem_Res???
+ -- Note: the flag Size_Known_At_Compile_Time is used to determine whether a
+ -- size clause is allowed for the type, and also whether a component clause
+ -- is allowed for a component of the type.
--
-- Note: Check_Compile_Time_Size does not test the case of the size being
-- known because a size clause is specifically given. That is because we
-- do not allow a size clause if the size would not otherwise be known at
-- compile time in any case.
+ --
+ -- ??? This is public because of dubious uses in Sem_Ch3 and Sem_Res
procedure Check_Inherited_Conditions
(R : Entity_Id;
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 09358278210..15994b4d1e9 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -22409,6 +22409,8 @@ package body Sem_Util is
return False;
end Depends_On_Discriminant;
+ -- Start of processing for Caller_Known_Size_Record
+
begin
-- This is a protected type without Corresponding_Record_Type set,
-- typically because expansion is disabled. The safe thing to do is
@@ -22418,6 +22420,16 @@ package body Sem_Util is
return True;
end if;
+ -- If either size is specified for the type, then it's known in the
+ -- caller in particular. Note that, even if the clause is confirming,
+ -- this does not change the outcome since the size was already known.
+
+ if Has_Size_Clause (First_Subtype (Typ))
+ or else Has_Object_Size_Clause (First_Subtype (Typ))
+ then
+ return True;
+ end if;
+
-- First see if we have a variant part and return False if it depends
-- on discriminants.
--
2.43.2
^ permalink raw reply [flat|nested] 30+ messages in thread
* [COMMITTED 28/30] ada: Fix internal error on nested aggregate in conditional expression
2024-05-20 7:48 [COMMITTED 01/30] ada: Rework and augment documentation on strict aliasing Marc Poulhiès
` (25 preceding siblings ...)
2024-05-20 7:48 ` [COMMITTED 27/30] ada: Get rid of secondary stack for indefinite record types with size clause Marc Poulhiès
@ 2024-05-20 7:48 ` Marc Poulhiès
2024-05-20 7:48 ` [COMMITTED 29/30] ada: Add direct workaround for limitations of RTSfind mechanism Marc Poulhiès
2024-05-20 7:48 ` [COMMITTED 30/30] ada: Allow 'others' in formal packages with overloaded formals Marc Poulhiès
28 siblings, 0 replies; 30+ messages in thread
From: Marc Poulhiès @ 2024-05-20 7:48 UTC (permalink / raw)
To: gcc-patches; +Cc: Eric Botcazou
From: Eric Botcazou <ebotcazou@adacore.com>
This plugs a loophole in the change improving code generation for nested
aggregates present in conditional expressions: once the delayed expansion
is chosen for the nested aggregate, the expansion of the parent aggregate
cannot be left to the back-end and the test must be adjusted to implement
this in the presence of conditional expressions too.
gcc/ada/
* exp_aggr.adb (Expand_Record_Aggregate.Component_OK_For_Backend):
Also return False for a delayed conditional expression.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/exp_aggr.adb | 4 +++-
1 file changed, 3 insertions(+), 1 deletion(-)
diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb
index a386aa85ae4..796b0f1e0de 100644
--- a/gcc/ada/exp_aggr.adb
+++ b/gcc/ada/exp_aggr.adb
@@ -8376,7 +8376,9 @@ package body Exp_Aggr is
Static_Components := False;
return False;
- elsif Is_Delayed_Aggregate (Expr_Q) then
+ elsif Is_Delayed_Aggregate (Expr_Q)
+ or else Is_Delayed_Conditional_Expression (Expr_Q)
+ then
Static_Components := False;
return False;
--
2.43.2
^ permalink raw reply [flat|nested] 30+ messages in thread
* [COMMITTED 29/30] ada: Add direct workaround for limitations of RTSfind mechanism
2024-05-20 7:48 [COMMITTED 01/30] ada: Rework and augment documentation on strict aliasing Marc Poulhiès
` (26 preceding siblings ...)
2024-05-20 7:48 ` [COMMITTED 28/30] ada: Fix internal error on nested aggregate in conditional expression Marc Poulhiès
@ 2024-05-20 7:48 ` Marc Poulhiès
2024-05-20 7:48 ` [COMMITTED 30/30] ada: Allow 'others' in formal packages with overloaded formals Marc Poulhiès
28 siblings, 0 replies; 30+ messages in thread
From: Marc Poulhiès @ 2024-05-20 7:48 UTC (permalink / raw)
To: gcc-patches; +Cc: Eric Botcazou
From: Eric Botcazou <ebotcazou@adacore.com>
This adds a direct workaround for the spurious compilation errors caused by
the presence of preconditions/postconditions in the Interfaces.C unit, which
trip on limitations of the RTSfind mechanism when it comes to visibility, as
well as removes an indirect workaround that was added very recently.
These errors were first triggered in the context of finalization and worked
around by preloading the System.Finalization_Primitives unit. Now they also
appear in the context of tasking, and it turns out that the preloading trick
does not work for separate compilation units.
gcc/ada/
* exp_ch7.ads (Preload_Finalization_Collection): Delete.
* exp_ch7.adb (Allows_Finalization_Collection): Revert change.
(Preload_Finalization_Collection): Delete.
* opt.ads (Interface_Seen): Likewise.
* scng.adb (Scan): Revert latest change.
* sem_ch10.adb: Remove clause for Exp_Ch7.
(Analyze_Compilation_Unit): Revert latest change.
* libgnat/i-c.ads: Use a fully qualified name for the standard "+"
operator in the preconditons/postconditions of subprograms.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/exp_ch7.adb | 38 --------------------------------------
gcc/ada/exp_ch7.ads | 6 ------
gcc/ada/libgnat/i-c.ads | 19 +++++++++++--------
gcc/ada/opt.ads | 4 ----
gcc/ada/scng.adb | 5 +----
gcc/ada/sem_ch10.adb | 3 ---
6 files changed, 12 insertions(+), 63 deletions(-)
diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb
index fdacf1cdc01..993c13c7318 100644
--- a/gcc/ada/exp_ch7.adb
+++ b/gcc/ada/exp_ch7.adb
@@ -965,12 +965,6 @@ package body Exp_Ch7 is
if Restriction_Active (No_Finalization) then
return False;
- -- The System.Finalization_Primitives unit must have been preloaded if
- -- finalization is really required.
-
- elsif not RTU_Loaded (System_Finalization_Primitives) then
- return False;
-
-- Do not consider C and C++ types since it is assumed that the non-Ada
-- side will handle their cleanup.
@@ -8630,38 +8624,6 @@ package body Exp_Ch7 is
return Scope_Stack.Table (Scope_Stack.Last).Node_To_Be_Wrapped;
end Node_To_Be_Wrapped;
- --------------------------------------
- -- Preload_Finalization_Collection --
- --------------------------------------
-
- procedure Preload_Finalization_Collection (Compilation_Unit : Node_Id) is
- begin
- -- We can't call RTE (Finalization_Collection) for at least some
- -- predefined units, because it would introduce cyclic dependences,
- -- as the type is itself a controlled type.
- --
- -- It's only needed when finalization is involved in the unit, which
- -- requires the presence of controlled or class-wide types in the unit
- -- (see the Sem_Util.Needs_Finalization predicate for the rationale).
- -- But controlled types are tagged or contain tagged (sub)components
- -- so it is sufficient for the parser to detect the "interface" and
- -- "tagged" keywords.
- --
- -- Don't do it if Finalization_Collection is unavailable in the runtime
-
- if not In_Predefined_Unit (Compilation_Unit)
- and then (Interface_Seen or else Tagged_Seen)
- and then not No_Run_Time_Mode
- and then RTE_Available (RE_Finalization_Collection)
- then
- declare
- Ignore : constant Entity_Id := RTE (RE_Finalization_Collection);
- begin
- null;
- end;
- end if;
- end Preload_Finalization_Collection;
-
----------------------------
-- Store_Actions_In_Scope --
----------------------------
diff --git a/gcc/ada/exp_ch7.ads b/gcc/ada/exp_ch7.ads
index 386a02b9283..712671a427e 100644
--- a/gcc/ada/exp_ch7.ads
+++ b/gcc/ada/exp_ch7.ads
@@ -257,12 +257,6 @@ package Exp_Ch7 is
-- Build a call to suppress the finalization of the object Obj, only after
-- creating the Master_Node of Obj if it does not already exist.
- procedure Preload_Finalization_Collection (Compilation_Unit : Node_Id);
- -- Call RTE (RE_Finalization_Collection) if necessary to load the packages
- -- involved in finalization support. We need to do this explicitly, fairly
- -- early during compilation, because otherwise it happens during freezing,
- -- which triggers visibility bugs in generic instantiations.
-
--------------------------------------------
-- Task and Protected Object finalization --
--------------------------------------------
diff --git a/gcc/ada/libgnat/i-c.ads b/gcc/ada/libgnat/i-c.ads
index fe87fba32b6..f9f9f75fc03 100644
--- a/gcc/ada/libgnat/i-c.ads
+++ b/gcc/ada/libgnat/i-c.ads
@@ -24,6 +24,9 @@ pragma Assertion_Policy (Pre => Ignore,
Contract_Cases => Ignore,
Ghost => Ignore);
+-- Pre/postconditions use a fully qualified name for the standard "+" operator
+-- in order to work around an internal limitation of the compiler.
+
with System;
with System.Parameters;
@@ -146,7 +149,7 @@ is
Pre => not (Append_Nul = False and then Item'Length = 0),
Post => To_C'Result'First = 0
and then To_C'Result'Length =
- (if Append_Nul then Item'Length + 1 else Item'Length)
+ (if Append_Nul then Standard."+" (Item'Length, 1) else Item'Length)
and then (for all J in Item'Range =>
To_C'Result (size_t (J - Item'First)) = To_C (Item (J)))
and then (if Append_Nul then To_C'Result (To_C'Result'Last) = nul);
@@ -190,7 +193,7 @@ is
with
Relaxed_Initialization => Target,
Pre => Target'Length >=
- (if Append_Nul then Item'Length + 1 else Item'Length),
+ (if Append_Nul then Standard."+" (Item'Length, 1) else Item'Length),
Post => Count = (if Append_Nul then Item'Length + 1 else Item'Length)
and then
(if Count /= 0 then
@@ -287,7 +290,7 @@ is
Pre => not (Append_Nul = False and then Item'Length = 0),
Post => To_C'Result'First = 0
and then To_C'Result'Length =
- (if Append_Nul then Item'Length + 1 else Item'Length)
+ (if Append_Nul then Standard."+" (Item'Length, 1) else Item'Length)
and then (for all J in Item'Range =>
To_C'Result (size_t (J - Item'First)) = To_C (Item (J)))
and then (if Append_Nul then To_C'Result (To_C'Result'Last) = wide_nul);
@@ -316,7 +319,7 @@ is
with
Relaxed_Initialization => Target,
Pre => Target'Length >=
- (if Append_Nul then Item'Length + 1 else Item'Length),
+ (if Append_Nul then Standard."+" (Item'Length, 1) else Item'Length),
Post => Count = (if Append_Nul then Item'Length + 1 else Item'Length)
and then
(if Count /= 0 then
@@ -408,7 +411,7 @@ is
Pre => not (Append_Nul = False and then Item'Length = 0),
Post => To_C'Result'First = 0
and then To_C'Result'Length =
- (if Append_Nul then Item'Length + 1 else Item'Length)
+ (if Append_Nul then Standard."+" (Item'Length, 1) else Item'Length)
and then (for all J in Item'Range =>
To_C'Result (size_t (J - Item'First)) = To_C (Item (J)))
and then
@@ -440,7 +443,7 @@ is
with
Relaxed_Initialization => Target,
Pre => Target'Length >=
- (if Append_Nul then Item'Length + 1 else Item'Length),
+ (if Append_Nul then Standard."+" (Item'Length, 1) else Item'Length),
Post => Count = (if Append_Nul then Item'Length + 1 else Item'Length)
and then
(if Count /= 0 then
@@ -528,7 +531,7 @@ is
Pre => not (Append_Nul = False and then Item'Length = 0),
Post => To_C'Result'First = 0
and then To_C'Result'Length =
- (if Append_Nul then Item'Length + 1 else Item'Length)
+ (if Append_Nul then Standard."+" (Item'Length, 1) else Item'Length)
and then (for all J in Item'Range =>
To_C'Result (size_t (J - Item'First)) = To_C (Item (J)))
and then
@@ -560,7 +563,7 @@ is
with
Relaxed_Initialization => Target,
Pre => Target'Length >=
- (if Append_Nul then Item'Length + 1 else Item'Length),
+ (if Append_Nul then Standard."+" (Item'Length, 1) else Item'Length),
Post => Count = (if Append_Nul then Item'Length + 1 else Item'Length)
and then
(if Count /= 0 then
diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads
index e56a40884e4..5f402cf5d6e 100644
--- a/gcc/ada/opt.ads
+++ b/gcc/ada/opt.ads
@@ -1919,10 +1919,6 @@ package Opt is
-- be in the spec of Expander, but it is referenced by Errout, and it
-- really seems wrong for Errout to depend on Expander.
- Interface_Seen : Boolean := False;
- -- Set True by the parser if the "interface" reserved word is seen. This is
- -- needed in Exp_Ch7 (see that package for documentation).
-
Tagged_Seen : Boolean := False;
-- Set True by the parser if the "tagged" reserved word is seen. This is
-- needed in Exp_Put_Image (see that package for documentation).
diff --git a/gcc/ada/scng.adb b/gcc/ada/scng.adb
index 8b2829ffbbf..c9ccc4d9b52 100644
--- a/gcc/ada/scng.adb
+++ b/gcc/ada/scng.adb
@@ -2786,12 +2786,9 @@ package body Scng is
Accumulate_Token_Checksum;
Token := Token_Type'Val (Get_Name_Table_Byte (Token_Name));
- if Token = Tok_Interface then
- Interface_Seen := True;
-
-- See Exp_Put_Image for documentation of Tagged_Seen
- elsif Token = Tok_Tagged then
+ if Token = Tok_Tagged then
Tagged_Seen := True;
end if;
diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb
index 82b4e1cf3f5..73e5388affd 100644
--- a/gcc/ada/sem_ch10.adb
+++ b/gcc/ada/sem_ch10.adb
@@ -31,7 +31,6 @@ with Einfo; use Einfo;
with Einfo.Entities; use Einfo.Entities;
with Einfo.Utils; use Einfo.Utils;
with Errout; use Errout;
-with Exp_Ch7;
with Exp_Disp; use Exp_Disp;
with Exp_Put_Image;
with Exp_Util; use Exp_Util;
@@ -926,8 +925,6 @@ package body Sem_Ch10 is
Set_Context_Pending (N, False);
- Exp_Ch7.Preload_Finalization_Collection (N);
-
-- If the unit is a package body, the spec is already loaded and must be
-- analyzed first, before we analyze the body.
--
2.43.2
^ permalink raw reply [flat|nested] 30+ messages in thread
* [COMMITTED 30/30] ada: Allow 'others' in formal packages with overloaded formals
2024-05-20 7:48 [COMMITTED 01/30] ada: Rework and augment documentation on strict aliasing Marc Poulhiès
` (27 preceding siblings ...)
2024-05-20 7:48 ` [COMMITTED 29/30] ada: Add direct workaround for limitations of RTSfind mechanism Marc Poulhiès
@ 2024-05-20 7:48 ` Marc Poulhiès
28 siblings, 0 replies; 30+ messages in thread
From: Marc Poulhiès @ 2024-05-20 7:48 UTC (permalink / raw)
To: gcc-patches; +Cc: Bob Duff
From: Bob Duff <duff@adacore.com>
If a generic package has two or more generic formal parameters with the
same defining name (which can happen only for formal subprograms), then
RM-12.7(4.1/3) disallows named associations in a corresponding formal
package. This is not intended to cover "others => <>".
This patch allows "others => <>" even when it applies to such
formals. Previously, the compiler incorrectly gave an error.
Minor related cleanups involving type Text_Ptr.
gcc/ada/
* sem_ch12.adb: Misc cleanups and comment fixes.
(Check_Overloaded_Formal_Subprogram): Remove the Others_Choice
error message.
(Others_Choice): Remove this variable; no longer needed.
* types.ads (Text_Ptr): Add a range constraint limiting the
subtype to values that are actually used. This has the advantage
that when the compiler is compiled with validity checks,
uninitialized values of subtypes Text_Ptr and Source_Ptr will be
caught.
* sinput.ads (Sloc_Adjust): Use the base subtype; this is used as
an offset, so we need to allow arbitrary negative values.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/sem_ch12.adb | 27 ++++++++++-----------------
gcc/ada/sinput.ads | 2 +-
gcc/ada/types.ads | 7 +++----
3 files changed, 14 insertions(+), 22 deletions(-)
diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb
index 4ceddda2052..9919cda6340 100644
--- a/gcc/ada/sem_ch12.adb
+++ b/gcc/ada/sem_ch12.adb
@@ -1130,10 +1130,11 @@ package body Sem_Ch12 is
Saved_Formal : Node_Id;
Default_Formals : constant List_Id := New_List;
- -- If an Others_Choice is present, some of the formals may be defaulted.
- -- To simplify the treatment of visibility in an instance, we introduce
- -- individual defaults for each such formal. These defaults are
- -- appended to the list of associations and replace the Others_Choice.
+ -- If an N_Others_Choice is present, some of the formals may be
+ -- defaulted. To simplify the treatment of visibility in an instance,
+ -- we introduce individual defaults for each such formal. These
+ -- defaults are appended to the list of associations and replace the
+ -- N_Others_Choice.
Found_Assoc : Node_Id;
-- Association for the current formal being match. Empty if there are
@@ -1145,9 +1146,8 @@ package body Sem_Ch12 is
Num_Actuals : Nat := 0;
Others_Present : Boolean := False;
- Others_Choice : Node_Id := Empty;
-- In Ada 2005, indicates partial parameterization of a formal
- -- package. As usual an other association must be last in the list.
+ -- package. As usual an 'others' association must be last in the list.
procedure Build_Subprogram_Wrappers;
-- Ada 2022: AI12-0272 introduces pre/postconditions for formal
@@ -1195,7 +1195,7 @@ package body Sem_Ch12 is
procedure Process_Default (Formal : Node_Id);
-- Add a copy of the declaration of a generic formal to the list of
-- associations, and add an explicit box association for its entity
- -- if there is none yet, and the default comes from an Others_Choice.
+ -- if there is none yet, and the default comes from an N_Others_Choice.
function Renames_Standard_Subprogram (Subp : Entity_Id) return Boolean;
-- Determine whether Subp renames one of the subprograms defined in the
@@ -1314,14 +1314,8 @@ package body Sem_Ch12 is
Error_Msg_N
("named association not allowed for overloaded formal",
Found_Assoc);
-
- else
- Error_Msg_N
- ("named association not allowed for overloaded formal",
- Others_Choice);
+ Abandon_Instantiation (Instantiation_Node);
end if;
-
- Abandon_Instantiation (Instantiation_Node);
end if;
Next (Temp_Formal);
@@ -1592,7 +1586,7 @@ package body Sem_Ch12 is
Append (Decl, Assoc_List);
- if No (Found_Assoc) then
+ if No (Found_Assoc) then -- i.e. 'others'
Default :=
Make_Generic_Association (Loc,
Selector_Name =>
@@ -1686,7 +1680,6 @@ package body Sem_Ch12 is
while Present (Actual) loop
if Nkind (Actual) = N_Others_Choice then
Others_Present := True;
- Others_Choice := Actual;
if Present (Next (Actual)) then
Error_Msg_N ("OTHERS must be last association", Actual);
@@ -2311,7 +2304,7 @@ package body Sem_Ch12 is
-- If this is a formal package, normalize the parameter list by adding
-- explicit box associations for the formals that are covered by an
- -- Others_Choice.
+ -- N_Others_Choice.
Append_List (Default_Formals, Formals);
diff --git a/gcc/ada/sinput.ads b/gcc/ada/sinput.ads
index b22314770bd..1045acd3e2d 100644
--- a/gcc/ada/sinput.ads
+++ b/gcc/ada/sinput.ads
@@ -804,7 +804,7 @@ private
-- The following fields are for internal use only (i.e. only in the
-- body of Sinput or its children, with no direct access by clients).
- Sloc_Adjust : Source_Ptr;
+ Sloc_Adjust : Source_Ptr'Base; -- can be (very) negative
-- A value to be added to Sloc values for this file to reference the
-- corresponding lines table. This is zero for the non-instantiation
-- case, and set so that the addition references the ultimate template
diff --git a/gcc/ada/types.ads b/gcc/ada/types.ads
index 8a1d9054261..4fd75d46787 100644
--- a/gcc/ada/types.ads
+++ b/gcc/ada/types.ads
@@ -145,9 +145,8 @@ package Types is
-- standard 32-bit integer as an index value, since we count on all index
-- values being the same size.
- type Text_Ptr is new Int;
- -- Type used for subscripts in text buffer
-
+ type Text_Ptr is new Int range -4 .. Int'Last;
+ -- -4 .. -1 are special; see constants below
type Text_Buffer is array (Text_Ptr range <>) of Character;
-- Text buffer used to hold source file or library information file
@@ -265,7 +264,7 @@ package Types is
-- the location is in System, but we don't know exactly what line.
First_Source_Ptr : constant Source_Ptr := 0;
- -- Starting source pointer index value for first source program
+ -- Starting source pointer index value for first source file
-------------------------------------
-- Range Definitions for Tree Data --
--
2.43.2
^ permalink raw reply [flat|nested] 30+ messages in thread
end of thread, other threads:[~2024-05-20 7:49 UTC | newest]
Thread overview: 30+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2024-05-20 7:48 [COMMITTED 01/30] ada: Rework and augment documentation on strict aliasing Marc Poulhiès
2024-05-20 7:48 ` [COMMITTED 02/30] ada: Small cleanup in System.Finalization_Primitives unit Marc Poulhiès
2024-05-20 7:48 ` [COMMITTED 03/30] ada: Implement representation aspect Max_Entry_Queue_Length Marc Poulhiès
2024-05-20 7:48 ` [COMMITTED 04/30] ada: Detect only conflict with synomyms of max queue length Marc Poulhiès
2024-05-20 7:48 ` [COMMITTED 05/30] ada: One more adjustment coming from aliasing considerations Marc Poulhiès
2024-05-20 7:48 ` [COMMITTED 06/30] ada: Reject too-strict alignment specifications Marc Poulhiès
2024-05-20 7:48 ` [COMMITTED 07/30] ada: Use System.Address for address computation in System.Pool_Global Marc Poulhiès
2024-05-20 7:48 ` [COMMITTED 08/30] ada: Fix for attribute Width on enumeration types with Discard_Name Marc Poulhiès
2024-05-20 7:48 ` [COMMITTED 09/30] ada: Fix static 'Img for enumeration type with Discard_Names Marc Poulhiès
2024-05-20 7:48 ` [COMMITTED 10/30] ada: Another small cleanup about allocators and aggregates Marc Poulhiès
2024-05-20 7:48 ` [COMMITTED 11/30] ada: Fix incorrect free with Task_Info pragma Marc Poulhiès
2024-05-20 7:48 ` [COMMITTED 12/30] ada: Resolve ACATS compilation and execution issues with container aggregates Marc Poulhiès
2024-05-20 7:48 ` [COMMITTED 13/30] ada: Extend expansion delaying mechanism to conditional expressions Marc Poulhiès
2024-05-20 7:48 ` [COMMITTED 14/30] ada: Tweak handling of thread ID on POSIX Marc Poulhiès
2024-05-20 7:48 ` [COMMITTED 15/30] ada: Fix style in list of implementation-defined attributes Marc Poulhiès
2024-05-20 7:48 ` [COMMITTED 16/30] ada: Use discrete choice list in declaration of universal type attributes Marc Poulhiès
2024-05-20 7:48 ` [COMMITTED 17/30] ada: Remove repeated condition in check for implementation attributes Marc Poulhiès
2024-05-20 7:48 ` [COMMITTED 18/30] ada: Apply restriction No_Implementation_Attributes to source nodes only Marc Poulhiès
2024-05-20 7:48 ` [COMMITTED 19/30] ada: Fix list of attributes defined by Ada 2012 Marc Poulhiès
2024-05-20 7:48 ` [COMMITTED 20/30] ada: Fix list of implementation-defined attributes Marc Poulhiès
2024-05-20 7:48 ` [COMMITTED 21/30] ada: Further refine 'Super attribute Marc Poulhiès
2024-05-20 7:48 ` [COMMITTED 22/30] ada: Handle accessibility calculations for 'First and 'Last Marc Poulhiès
2024-05-20 7:48 ` [COMMITTED 23/30] ada: Error on instantiation of generic containing legal container aggregate Marc Poulhiès
2024-05-20 7:48 ` [COMMITTED 24/30] " Marc Poulhiès
2024-05-20 7:48 ` [COMMITTED 25/30] ada: Add Is_Base_Type predicate to C interface Marc Poulhiès
2024-05-20 7:48 ` [COMMITTED 26/30] ada: Formal package comment corrections in sinfo.ads Marc Poulhiès
2024-05-20 7:48 ` [COMMITTED 27/30] ada: Get rid of secondary stack for indefinite record types with size clause Marc Poulhiès
2024-05-20 7:48 ` [COMMITTED 28/30] ada: Fix internal error on nested aggregate in conditional expression Marc Poulhiès
2024-05-20 7:48 ` [COMMITTED 29/30] ada: Add direct workaround for limitations of RTSfind mechanism Marc Poulhiès
2024-05-20 7:48 ` [COMMITTED 30/30] ada: Allow 'others' in formal packages with overloaded formals Marc Poulhiès
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).