* [Ada] Fix wrong assignment to mutable Out parameter of task entry
@ 2020-05-25 7:27 Eric Botcazou
0 siblings, 0 replies; only message in thread
From: Eric Botcazou @ 2020-05-25 7:27 UTC (permalink / raw)
To: gcc-patches
[-- Attachment #1: Type: text/plain, Size: 802 bytes --]
Under very specific circumstances the compiler can generate a wrong assignment
to a mutable record object which contains an array component, because it does
not correctly handle the update of the discriminant.
Tested on x86-64/Linux, applied on the mainline.
2020-05-25 Eric Botcazou <ebotcazou@adacore.com>
* gcc-interface/gigi.h (operand_type): New static inline function.
* gcc-interface/trans.c (gnat_to_gnu): Do not suppress conversion
to the resulty type at the end for array types.
* gcc-interface/utils2.c (build_binary_op) <MODIFY_EXPR>: Do not
remove conversions between array types on the LHS.
2020-05-25 Eric Botcazou <ebotcazou@adacore.com>
* gnat.dg/array39.adb: New test.
* gnat.dg/array39_pkg.ads: New helper.
* gnat.dg/array39_pkg.adb: Likewise.
--
Eric Botcazou
[-- Attachment #2: p.diff --]
[-- Type: text/x-patch, Size: 5847 bytes --]
diff --git a/gcc/ada/gcc-interface/gigi.h b/gcc/ada/gcc-interface/gigi.h
index fcdea320c3a..e43b3db59a9 100644
--- a/gcc/ada/gcc-interface/gigi.h
+++ b/gcc/ada/gcc-interface/gigi.h
@@ -1209,3 +1209,11 @@ maybe_padded_object (tree expr)
return expr;
}
+
+/* Return the type of operand #0 of EXPR. */
+
+static inline tree
+operand_type (tree expr)
+{
+ return TREE_TYPE (TREE_OPERAND (expr, 0));
+}
diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c
index b7a4cadb7e6..969a480c3da 100644
--- a/gcc/ada/gcc-interface/trans.c
+++ b/gcc/ada/gcc-interface/trans.c
@@ -8821,7 +8821,8 @@ gnat_to_gnu (Node_Id gnat_node)
1. If this is the LHS of an assignment or an actual parameter of a
call, return the result almost unmodified since the RHS will have
to be converted to our type in that case, unless the result type
- has a simpler size. Likewise if there is just a no-op unchecked
+ has a simpler size or for array types because this size might be
+ changed in-between. Likewise if there is just a no-op unchecked
conversion in-between. Similarly, don't convert integral types
that are the operands of an unchecked conversion since we need
to ignore those conversions (for 'Valid).
@@ -8856,15 +8857,17 @@ gnat_to_gnu (Node_Id gnat_node)
&& !AGGREGATE_TYPE_P (TREE_TYPE (gnu_result))))
&& !(TYPE_SIZE (gnu_result_type)
&& TYPE_SIZE (TREE_TYPE (gnu_result))
- && (AGGREGATE_TYPE_P (gnu_result_type)
- == AGGREGATE_TYPE_P (TREE_TYPE (gnu_result)))
+ && AGGREGATE_TYPE_P (gnu_result_type)
+ == AGGREGATE_TYPE_P (TREE_TYPE (gnu_result))
&& ((TREE_CODE (TYPE_SIZE (gnu_result_type)) == INTEGER_CST
&& (TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_result)))
!= INTEGER_CST))
|| (TREE_CODE (TYPE_SIZE (gnu_result_type)) != INTEGER_CST
&& !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type))
&& (CONTAINS_PLACEHOLDER_P
- (TYPE_SIZE (TREE_TYPE (gnu_result))))))
+ (TYPE_SIZE (TREE_TYPE (gnu_result)))))
+ || (TREE_CODE (gnu_result_type) == ARRAY_TYPE
+ && TREE_CODE (TREE_TYPE (gnu_result)) == ARRAY_TYPE))
&& !(TREE_CODE (gnu_result_type) == RECORD_TYPE
&& TYPE_JUSTIFIED_MODULAR_P (gnu_result_type))))
{
diff --git a/gcc/ada/gcc-interface/utils2.c b/gcc/ada/gcc-interface/utils2.c
index 7799776e1db..a56a4f45adc 100644
--- a/gcc/ada/gcc-interface/utils2.c
+++ b/gcc/ada/gcc-interface/utils2.c
@@ -875,31 +875,21 @@ build_binary_op (enum tree_code op_code, tree result_type,
/* If there were integral or pointer conversions on the LHS, remove
them; we'll be putting them back below if needed. Likewise for
- conversions between array and record types, except for justified
- modular types. But don't do this if the right operand is not
- BLKmode (for packed arrays) unless we are not changing the mode. */
+ conversions between record types, except for justified modular types.
+ But don't do this if the right operand is not BLKmode (for packed
+ arrays) unless we are not changing the mode. */
while ((CONVERT_EXPR_P (left_operand)
|| TREE_CODE (left_operand) == VIEW_CONVERT_EXPR)
&& (((INTEGRAL_TYPE_P (left_type)
|| POINTER_TYPE_P (left_type))
- && (INTEGRAL_TYPE_P (TREE_TYPE
- (TREE_OPERAND (left_operand, 0)))
- || POINTER_TYPE_P (TREE_TYPE
- (TREE_OPERAND (left_operand, 0)))))
- || (((TREE_CODE (left_type) == RECORD_TYPE
- && !TYPE_JUSTIFIED_MODULAR_P (left_type))
- || TREE_CODE (left_type) == ARRAY_TYPE)
- && ((TREE_CODE (TREE_TYPE
- (TREE_OPERAND (left_operand, 0)))
- == RECORD_TYPE)
- || (TREE_CODE (TREE_TYPE
- (TREE_OPERAND (left_operand, 0)))
- == ARRAY_TYPE))
+ && (INTEGRAL_TYPE_P (operand_type (left_operand))
+ || POINTER_TYPE_P (operand_type (left_operand))))
+ || (TREE_CODE (left_type) == RECORD_TYPE
+ && !TYPE_JUSTIFIED_MODULAR_P (left_type)
+ && TREE_CODE (operand_type (left_operand)) == RECORD_TYPE
&& (TYPE_MODE (right_type) == BLKmode
- || (TYPE_MODE (left_type)
- == TYPE_MODE (TREE_TYPE
- (TREE_OPERAND
- (left_operand, 0))))))))
+ || TYPE_MODE (left_type)
+ == TYPE_MODE (operand_type (left_operand))))))
{
left_operand = TREE_OPERAND (left_operand, 0);
left_type = TREE_TYPE (left_operand);
@@ -921,8 +911,7 @@ build_binary_op (enum tree_code op_code, tree result_type,
&& TREE_CONSTANT (TYPE_SIZE (left_type))
&& ((TREE_CODE (right_operand) == COMPONENT_REF
&& TYPE_MAIN_VARIANT (left_type)
- == TYPE_MAIN_VARIANT
- (TREE_TYPE (TREE_OPERAND (right_operand, 0))))
+ == TYPE_MAIN_VARIANT (operand_type (right_operand)))
|| (TREE_CODE (right_operand) == CONSTRUCTOR
&& !CONTAINS_PLACEHOLDER_P
(DECL_SIZE (TYPE_FIELDS (left_type)))))
@@ -976,22 +965,23 @@ build_binary_op (enum tree_code op_code, tree result_type,
|| TREE_CODE (result) == ARRAY_RANGE_REF)
while (handled_component_p (result))
result = TREE_OPERAND (result, 0);
+
else if (TREE_CODE (result) == REALPART_EXPR
|| TREE_CODE (result) == IMAGPART_EXPR
|| (CONVERT_EXPR_P (result)
&& (((TREE_CODE (restype)
- == TREE_CODE (TREE_TYPE
- (TREE_OPERAND (result, 0))))
- && (TYPE_MODE (TREE_TYPE
- (TREE_OPERAND (result, 0)))
- == TYPE_MODE (restype)))
+ == TREE_CODE (operand_type (result))
+ && TYPE_MODE (restype)
+ == TYPE_MODE (operand_type (result))))
|| TYPE_ALIGN_OK (restype))))
result = TREE_OPERAND (result, 0);
+
else if (TREE_CODE (result) == VIEW_CONVERT_EXPR)
{
TREE_ADDRESSABLE (result) = 1;
result = TREE_OPERAND (result, 0);
}
+
else
break;
}
[-- Attachment #3: array39.adb --]
[-- Type: text/x-adasrc, Size: 183 bytes --]
-- { dg-do run }
with Array39_Pkg; use Array39_Pkg;
procedure Array39 is
T : Tsk;
R : Rec2;
begin
T.E (R, 1);
if R.A (1) /= Val then
raise Program_Error;
end if;
end;
[-- Attachment #4: array39_pkg.ads --]
[-- Type: text/x-adasrc, Size: 502 bytes --]
package Array39_Pkg is
subtype Index1 is Natural range 0 .. 2;
type Arr1 is array (Index1 range <>) of Integer;
type Rec1 (D : Index1 := 0) is record
A : Arr1 (1 .. D);
end record;
subtype Index2 is Natural range 0 .. 7;
type Arr2 is array (Index2 range <>) of Rec1;
type Rec2 (D : Index2 := 0) is record
A : Arr2 (1 .. D);
end record;
Val : Rec1 := (D => 1, A => (others => 1));
task type Tsk is
entry E (R : out Rec2; L : Index2);
end Tsk;
end Array39_Pkg;
[-- Attachment #5: array39_pkg.adb --]
[-- Type: text/x-adasrc, Size: 375 bytes --]
package body Array39_Pkg is
task Body Tsk is
begin
select
accept E (R : out Rec2; L : Index2) do
declare
A : Arr2 (Index2);
LL : Index2 := L;
begin
for I in 1 .. LL loop
A (I) := Val;
end loop;
R := (D => LL, A => A (1 .. LL));
end;
end E;
end select;
end Tsk;
end Array39_Pkg;
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2020-05-25 7:27 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2020-05-25 7:27 [Ada] Fix wrong assignment to mutable Out parameter of task entry Eric Botcazou
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).