From: Eric Botcazou Date: Mon, 25 May 2020 07:18:03 +0000 (+0200) Subject: Fix wrong assignment to mutable Out parameter of task entry X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=5dce843f32edfd998ae4844d8115a9c9b9c394bc;p=gcc.git Fix wrong assignment to mutable Out parameter of task entry 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. gcc/ada/ChangeLog * 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) : Do not remove conversions between array types on the LHS. gcc/testsuite/ChangeLog * gnat.dg/array39.adb: New test. * gnat.dg/array39_pkg.ads: New helper. * gnat.dg/array39_pkg.adb: Likewise. --- 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..a18d50f8f00 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; } diff --git a/gcc/testsuite/gnat.dg/array39.adb b/gcc/testsuite/gnat.dg/array39.adb new file mode 100644 index 00000000000..3e886c1f606 --- /dev/null +++ b/gcc/testsuite/gnat.dg/array39.adb @@ -0,0 +1,13 @@ +-- { 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; diff --git a/gcc/testsuite/gnat.dg/array39_pkg.adb b/gcc/testsuite/gnat.dg/array39_pkg.adb new file mode 100644 index 00000000000..32fe8e2a555 --- /dev/null +++ b/gcc/testsuite/gnat.dg/array39_pkg.adb @@ -0,0 +1,20 @@ +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; diff --git a/gcc/testsuite/gnat.dg/array39_pkg.ads b/gcc/testsuite/gnat.dg/array39_pkg.ads new file mode 100644 index 00000000000..e5cc4b835e5 --- /dev/null +++ b/gcc/testsuite/gnat.dg/array39_pkg.ads @@ -0,0 +1,25 @@ +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;