Commit f0bf503e by Eric Botcazou Committed by Eric Botcazou

trans.c (call_to_gnu): Make the temporary for non-addressable In parameters passed by reference.

	* trans.c (call_to_gnu): Make the temporary for non-addressable
	In parameters passed by reference.
	(addressable_p): Return true for STRING_CST and CALL_EXPR.

From-SVN: r131140
parent 111716e0
2007-12-23 Eric Botcazou <ebotcazou@adacore.com>
* trans.c (call_to_gnu): Make the temporary for non-addressable
In parameters passed by reference.
(addressable_p): Return true for STRING_CST and CALL_EXPR.
2007-12-19 Robert Dewar <dewar@adacore.com> 2007-12-19 Robert Dewar <dewar@adacore.com>
* g-expect-vms.adb, g-expect.adb, s-poosiz.adb: * g-expect-vms.adb, g-expect.adb, s-poosiz.adb:
...@@ -2089,80 +2089,77 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target) ...@@ -2089,80 +2089,77 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target)
tree gnu_actual; tree gnu_actual;
/* If it's possible we may need to use this expression twice, make sure /* If it's possible we may need to use this expression twice, make sure
than any side-effects are handled via SAVE_EXPRs. Likewise if we need that any side-effects are handled via SAVE_EXPRs. Likewise if we need
to force side-effects before the call. to force side-effects before the call.
??? This is more conservative than we need since we don't need to do ??? This is more conservative than we need since we don't need to do
this for pass-by-ref with no conversion. If we are passing a this for pass-by-ref with no conversion. */
non-addressable Out or In Out parameter by reference, pass the address
of a copy and set up to copy back out after the call. */
if (Ekind (gnat_formal) != E_In_Parameter) if (Ekind (gnat_formal) != E_In_Parameter)
gnu_name = gnat_stabilize_reference (gnu_name, true);
/* If we are passing a non-addressable parameter by reference, pass the
address of a copy. In the Out or In Out case, set up to copy back
out after the call. */
if (!addressable_p (gnu_name)
&& gnu_formal
&& (DECL_BY_REF_P (gnu_formal)
|| (TREE_CODE (gnu_formal) == PARM_DECL
&& (DECL_BY_COMPONENT_PTR_P (gnu_formal)
|| (DECL_BY_DESCRIPTOR_P (gnu_formal))))))
{ {
gnu_name = gnat_stabilize_reference (gnu_name, true); tree gnu_copy = gnu_name, gnu_temp;
if (!addressable_p (gnu_name)
&& gnu_formal
&& (DECL_BY_REF_P (gnu_formal)
|| (TREE_CODE (gnu_formal) == PARM_DECL
&& (DECL_BY_COMPONENT_PTR_P (gnu_formal)
|| (DECL_BY_DESCRIPTOR_P (gnu_formal))))))
{
tree gnu_copy = gnu_name;
tree gnu_temp;
/* If the type is by_reference, a copy is not allowed. */
if (Is_By_Reference_Type (Etype (gnat_formal)))
post_error
("misaligned & cannot be passed by reference", gnat_actual);
/* For users of Starlet we issue a warning because the
interface apparently assumes that by-ref parameters
outlive the procedure invocation. The code still
will not work as intended, but we cannot do much
better since other low-level parts of the back-end
would allocate temporaries at will because of the
misalignment if we did not do so here. */
else if (Is_Valued_Procedure (Entity (Name (gnat_node)))) /* If the type is by_reference, a copy is not allowed. */
{ if (Is_By_Reference_Type (Etype (gnat_formal)))
post_error post_error
("?possible violation of implicit assumption", ("misaligned & cannot be passed by reference", gnat_actual);
gnat_actual);
post_error_ne /* For users of Starlet we issue a warning because the
("?made by pragma Import_Valued_Procedure on &", interface apparently assumes that by-ref parameters
gnat_actual, Entity (Name (gnat_node))); outlive the procedure invocation. The code still
post_error_ne will not work as intended, but we cannot do much
("?because of misalignment of &", better since other low-level parts of the back-end
gnat_actual, gnat_formal); would allocate temporaries at will because of the
} misalignment if we did not do so here. */
else if (Is_Valued_Procedure (Entity (Name (gnat_node))))
{
post_error
("?possible violation of implicit assumption", gnat_actual);
post_error_ne
("?made by pragma Import_Valued_Procedure on &", gnat_actual,
Entity (Name (gnat_node)));
post_error_ne ("?because of misalignment of &", gnat_actual,
gnat_formal);
}
/* Remove any unpadding on the actual and make a copy. But if /* Remove any unpadding on the actual and make a copy. But if
the actual is a justified modular type, first convert the actual is a justified modular type, first convert to it. */
to it. */ if (TREE_CODE (gnu_name) == COMPONENT_REF
if (TREE_CODE (gnu_name) == COMPONENT_REF && ((TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_name, 0)))
&& ((TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_name, 0))) == RECORD_TYPE)
== RECORD_TYPE) && (TYPE_IS_PADDING_P
&& (TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_name, 0))))))
(TREE_TYPE (TREE_OPERAND (gnu_name, 0)))))) gnu_name = gnu_copy = TREE_OPERAND (gnu_name, 0);
gnu_name = gnu_copy = TREE_OPERAND (gnu_name, 0);
else if (TREE_CODE (gnu_name_type) == RECORD_TYPE else if (TREE_CODE (gnu_name_type) == RECORD_TYPE
&& (TYPE_JUSTIFIED_MODULAR_P (gnu_name_type))) && (TYPE_JUSTIFIED_MODULAR_P (gnu_name_type)))
gnu_name = convert (gnu_name_type, gnu_name); gnu_name = convert (gnu_name_type, gnu_name);
/* Make a SAVE_EXPR to both properly account for potential side /* Make a SAVE_EXPR to both properly account for potential side
effects and handle the creation of a temporary copy. Special effects and handle the creation of a temporary copy. Special
code in gnat_gimplify_expr ensures that the same temporary is code in gnat_gimplify_expr ensures that the same temporary is
used as the actual and copied back after the call. */ used as the actual and copied back after the call if needed. */
gnu_actual = save_expr (gnu_name); gnu_name = build1 (SAVE_EXPR, TREE_TYPE (gnu_name), gnu_name);
TREE_SIDE_EFFECTS (gnu_name) = 1;
/* Set up to move the copy back to the original. */ TREE_INVARIANT (gnu_name) = 1;
gnu_temp = build_binary_op (MODIFY_EXPR, NULL_TREE,
gnu_copy, gnu_actual); /* Set up to move the copy back to the original. */
if (Ekind (gnat_formal) != E_In_Parameter)
{
gnu_temp = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_copy,
gnu_name);
set_expr_location_from_node (gnu_temp, gnat_actual); set_expr_location_from_node (gnu_temp, gnat_actual);
append_to_statement_list (gnu_temp, &gnu_after_list); append_to_statement_list (gnu_temp, &gnu_after_list);
/* Account for next statement just below. */
gnu_name = gnu_actual;
} }
} }
...@@ -2222,7 +2219,8 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target) ...@@ -2222,7 +2219,8 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target)
copied in. Otherwise, look at the PARM_DECL to see if it is passed by copied in. Otherwise, look at the PARM_DECL to see if it is passed by
reference. */ reference. */
if (gnu_formal if (gnu_formal
&& TREE_CODE (gnu_formal) == PARM_DECL && DECL_BY_REF_P (gnu_formal)) && TREE_CODE (gnu_formal) == PARM_DECL
&& DECL_BY_REF_P (gnu_formal))
{ {
if (Ekind (gnat_formal) != E_In_Parameter) if (Ekind (gnat_formal) != E_In_Parameter)
{ {
...@@ -2250,32 +2248,13 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target) ...@@ -2250,32 +2248,13 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target)
gnu_actual); gnu_actual);
} }
/* Otherwise, if we have a non-addressable COMPONENT_REF of a
variable-size type see if it's doing a unpadding operation. If
so, remove that operation since we have no way of allocating the
required temporary. */
if (TREE_CODE (gnu_actual) == COMPONENT_REF
&& !TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_actual)))
&& (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_actual, 0)))
== RECORD_TYPE)
&& TYPE_IS_PADDING_P (TREE_TYPE
(TREE_OPERAND (gnu_actual, 0)))
&& !addressable_p (gnu_actual))
gnu_actual = TREE_OPERAND (gnu_actual, 0);
/* For In parameters, gnu_actual might still not be addressable at
this point and we need the creation of a temporary copy since
this is to be passed by ref. Resorting to save_expr to force a
SAVE_EXPR temporary creation here is not guaranteed to work
because the actual might be invariant or readonly without side
effects, so we let the gimplifier process this case. */
/* The symmetry of the paths to the type of an entity is broken here /* The symmetry of the paths to the type of an entity is broken here
since arguments don't know that they will be passed by ref. */ since arguments don't know that they will be passed by ref. */
gnu_formal_type = TREE_TYPE (get_gnu_tree (gnat_formal)); gnu_formal_type = TREE_TYPE (get_gnu_tree (gnat_formal));
gnu_actual = build_unary_op (ADDR_EXPR, gnu_formal_type, gnu_actual); gnu_actual = build_unary_op (ADDR_EXPR, gnu_formal_type, gnu_actual);
} }
else if (gnu_formal && TREE_CODE (gnu_formal) == PARM_DECL else if (gnu_formal
&& TREE_CODE (gnu_formal) == PARM_DECL
&& DECL_BY_COMPONENT_PTR_P (gnu_formal)) && DECL_BY_COMPONENT_PTR_P (gnu_formal))
{ {
gnu_formal_type = TREE_TYPE (get_gnu_tree (gnat_formal)); gnu_formal_type = TREE_TYPE (get_gnu_tree (gnat_formal));
...@@ -2299,7 +2278,8 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target) ...@@ -2299,7 +2278,8 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target)
build_unary_op (ADDR_EXPR, NULL_TREE, build_unary_op (ADDR_EXPR, NULL_TREE,
gnu_actual)); gnu_actual));
} }
else if (gnu_formal && TREE_CODE (gnu_formal) == PARM_DECL else if (gnu_formal
&& TREE_CODE (gnu_formal) == PARM_DECL
&& DECL_BY_DESCRIPTOR_P (gnu_formal)) && DECL_BY_DESCRIPTOR_P (gnu_formal))
{ {
/* If arg is 'Null_Parameter, pass zero descriptor. */ /* If arg is 'Null_Parameter, pass zero descriptor. */
...@@ -6077,8 +6057,10 @@ addressable_p (tree gnu_expr) ...@@ -6077,8 +6057,10 @@ addressable_p (tree gnu_expr)
case UNCONSTRAINED_ARRAY_REF: case UNCONSTRAINED_ARRAY_REF:
case INDIRECT_REF: case INDIRECT_REF:
case CONSTRUCTOR: case CONSTRUCTOR:
case STRING_CST:
case NULL_EXPR: case NULL_EXPR:
case SAVE_EXPR: case SAVE_EXPR:
case CALL_EXPR:
return true; return true;
case COMPONENT_REF: case COMPONENT_REF:
......
2007-12-23 Eric Botcazou <ebotcazou@adacore.com>
* gnat.dg/pack2.adb: New test.
2007-12-22 Daniel Franke <franke.daniel@gmail.com> 2007-12-22 Daniel Franke <franke.daniel@gmail.com>
PR fortran/34559 PR fortran/34559
-- { dg-do compile }
-- { dg-options "-gnatws" }
procedure Pack2 is
type Bits_T is record
B0, B1, B2: Boolean;
end record;
type State_T is record
Valid : Boolean;
Value : Bits_T;
end record;
pragma Pack (State_T);
procedure Process (Bits : Bits_T) is begin null; end;
State : State_T;
begin
Process (State.Value);
end;
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment