* *
* C Implementation File *
* *
- * Copyright (C) 1992-2011, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2012, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
VEC(parm_attr,gc) *parm_attr_cache;
bitmap named_ret_val;
VEC(tree,gc) *other_ret_val;
+ int gnat_ret;
};
#define f_parm_attr_cache \
#define f_other_ret_val \
DECL_STRUCT_FUNCTION (current_function_decl)->language->other_ret_val
+#define f_gnat_ret \
+ DECL_STRUCT_FUNCTION (current_function_decl)->language->gnat_ret
+
/* A structure used to gather together information about a statement group.
We use this to gather related statements, for example the "then" part
of a IF. In the case where it represents a lexical scope, we may also
type_annotate_only = (gigi_operating_mode == 1);
- gcc_assert (Nkind (gnat_root) == N_Compilation_Unit);
-
- /* Declare the name of the compilation unit as the first global
- name in order to make the middle-end fully deterministic. */
- t = create_concat_name (Defining_Entity (Unit (gnat_root)), NULL);
- first_global_object_name = ggc_strdup (IDENTIFIER_POINTER (t));
-
for (i = 0; i < number_file; i++)
{
/* Use the identifier table to make a permanent copy of the filename as
linemap_add (line_table, LC_LEAVE, 0, NULL, 0);
}
+ gcc_assert (Nkind (gnat_root) == N_Compilation_Unit);
+
+ /* Declare the name of the compilation unit as the first global
+ name in order to make the middle-end fully deterministic. */
+ t = create_concat_name (Defining_Entity (Unit (gnat_root)), NULL);
+ first_global_object_name = ggc_strdup (IDENTIFIER_POINTER (t));
+
/* Initialize ourselves. */
init_code_table ();
init_gnat_to_gnu ();
if (TREE_CODE (gnu_result) == INDIRECT_REF)
TREE_THIS_NOTRAP (gnu_result) = 1;
- if (read_only)
- TREE_READONLY (gnu_result) = 1;
+ /* The first reference, in case of a double reference, always points
+ to read-only, see gnat_to_gnu_param for the rationale. */
+ TREE_READONLY (gnu_result) = 1;
}
/* If it's a PARM_DECL to foreign convention subprogram, convert it. */
}
}
- /* The GNAT tree has the type of a function as the type of its result. Also
- use the type of the result if the Etype is a subtype which is nominally
- unconstrained. But remove any padding from the resulting type. */
- if (TREE_CODE (TREE_TYPE (gnu_result)) == FUNCTION_TYPE
- || Is_Constr_Subt_For_UN_Aliased (gnat_temp_type))
- {
- gnu_result_type = TREE_TYPE (gnu_result);
- if (TYPE_IS_PADDING_P (gnu_result_type))
- gnu_result_type = TREE_TYPE (TYPE_FIELDS (gnu_result_type));
- }
-
/* If we have a constant declaration and its initializer, try to return the
latter to avoid the need to call fold in lots of places and the need for
elaboration code if this identifier is used as an initializer itself.
gnu_result = unshare_expr (DECL_INITIAL (gnu_result));
}
+ /* The GNAT tree has the type of a function set to its result type, so we
+ adjust here. Also use the type of the result if the Etype is a subtype
+ that is nominally unconstrained. Likewise if this is a deferred constant
+ of a discriminated type whose full view can be elaborated statically, to
+ avoid problematic conversions to the nominal subtype. But remove any
+ padding from the resulting type. */
+ if (TREE_CODE (TREE_TYPE (gnu_result)) == FUNCTION_TYPE
+ || Is_Constr_Subt_For_UN_Aliased (gnat_temp_type)
+ || (Ekind (gnat_temp) == E_Constant
+ && Present (Full_View (gnat_temp))
+ && Has_Discriminants (gnat_temp_type)
+ && TREE_CODE (gnu_result) == CONSTRUCTOR))
+ {
+ gnu_result_type = TREE_TYPE (gnu_result);
+ if (TYPE_IS_PADDING_P (gnu_result_type))
+ gnu_result_type = TREE_TYPE (TYPE_FIELDS (gnu_result_type));
+ }
+
*gnu_result_type_p = gnu_result_type;
return gnu_result;
static tree
Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute)
{
- tree gnu_prefix = gnat_to_gnu (Prefix (gnat_node));
- tree gnu_type = TREE_TYPE (gnu_prefix);
- tree gnu_expr, gnu_result_type, gnu_result = error_mark_node;
+ tree gnu_prefix, gnu_type, gnu_expr;
+ tree gnu_result_type, gnu_result = error_mark_node;
bool prefix_unused = false;
+ /* ??? If this is an access attribute for a public subprogram to be used in
+ a dispatch table, do not translate its type as it's useless there and the
+ parameter types might be incomplete types coming from a limited with. */
+ if (Ekind (Etype (gnat_node)) == E_Access_Subprogram_Type
+ && Is_Dispatch_Table_Entity (Etype (gnat_node))
+ && Nkind (Prefix (gnat_node)) == N_Identifier
+ && Is_Subprogram (Entity (Prefix (gnat_node)))
+ && Is_Public (Entity (Prefix (gnat_node)))
+ && !present_gnu_tree (Entity (Prefix (gnat_node))))
+ gnu_prefix = get_minimal_subprog_decl (Entity (Prefix (gnat_node)));
+ else
+ gnu_prefix = gnat_to_gnu (Prefix (gnat_node));
+ gnu_type = TREE_TYPE (gnu_prefix);
+
/* If the input is a NULL_EXPR, make a new one. */
if (TREE_CODE (gnu_prefix) == NULL_EXPR)
{
TREE_NO_TRAMPOLINE (gnu_expr) = TREE_CONSTANT (gnu_expr) = 1;
}
+ /* For 'Access, issue an error message if the prefix is a C++ method
+ since it can use a special calling convention on some platforms,
+ which cannot be propagated to the access type. */
+ else if (attribute == Attr_Access
+ && Nkind (Prefix (gnat_node)) == N_Identifier
+ && is_cplusplus_method (Entity (Prefix (gnat_node))))
+ post_error ("access to C++ constructor or member function not allowed",
+ gnat_node);
+
/* For other address attributes applied to a nested function,
find an inner ADDR_EXPR and annotate it so that we can issue
a useful warning with -Wtrampolines. */
/* Otherwise, use the do-while form with the help of a special
induction variable in the unsigned version of the base type
- or the unsigned version of the size type, whichever is the
+ or the unsigned version of sizetype, whichever is the
largest, in order to have wrap-around arithmetics for it. */
else
{
- if (TYPE_PRECISION (gnu_base_type)
- > TYPE_PRECISION (size_type_node))
+ if (TYPE_PRECISION (gnu_base_type) > TYPE_PRECISION (sizetype))
gnu_base_type = gnat_unsigned_type (gnu_base_type);
else
- gnu_base_type = size_type_node;
+ gnu_base_type = sizetype;
gnu_first = convert (gnu_base_type, gnu_first);
gnu_last = convert (gnu_base_type, gnu_last);
on the C++ optimization of the same name. The main difference is that
we disregard any semantical considerations when applying it here, the
counterpart being that we don't try to apply it to semantically loaded
- return types, i.e. types with the TREE_ADDRESSABLE flag set.
+ return types, i.e. types with the TYPE_BY_REFERENCE_P flag set.
We consider a function body of the following GENERIC form:
first list. These are the Named Return Values.
4. Adjust the relevant RETURN_EXPRs and replace the occurrences of the
- Named Return Values in the function with the RESULT_DECL. */
+ Named Return Values in the function with the RESULT_DECL.
+
+ If the function returns an unconstrained type, things are a bit different
+ because the anonymous return object is allocated on the secondary stack
+ and RESULT_DECL is only a pointer to it. Each return object can be of a
+ different size and is allocated separately so we need not care about the
+ aforementioned overlapping issues. Therefore, we don't collect the other
+ expressions and skip step #2 in the algorithm. */
struct nrv_data
{
bitmap nrv;
tree result;
+ Node_Id gnat_ret;
struct pointer_set_t *visited;
};
*tp = convert (TREE_TYPE (t), dp->result);
/* Avoid walking into the same tree more than once. Unfortunately, we
- can't just use walk_tree_without_duplicates because it would only call
- us for the first occurrence of NRVs in the function body. */
+ can't just use walk_tree_without_duplicates because it would only
+ call us for the first occurrence of NRVs in the function body. */
+ if (pointer_set_insert (dp->visited, *tp))
+ *walk_subtrees = 0;
+
+ return NULL_TREE;
+}
+
+/* Likewise, but used when the function returns an unconstrained type. */
+
+static tree
+finalize_nrv_unc_r (tree *tp, int *walk_subtrees, void *data)
+{
+ struct nrv_data *dp = (struct nrv_data *)data;
+ tree t = *tp;
+
+ /* No need to walk into types. */
+ if (TYPE_P (t))
+ *walk_subtrees = 0;
+
+ /* We need to see the DECL_EXPR of NRVs before any other references so we
+ walk the body of BIND_EXPR before walking its variables. */
+ else if (TREE_CODE (t) == BIND_EXPR)
+ walk_tree (&BIND_EXPR_BODY (t), finalize_nrv_unc_r, data, NULL);
+
+ /* Change RETURN_EXPRs of NRVs to assign to the RESULT_DECL only the final
+ return value built by the allocator instead of the whole construct. */
+ else if (TREE_CODE (t) == RETURN_EXPR
+ && TREE_CODE (TREE_OPERAND (t, 0)) == MODIFY_EXPR)
+ {
+ tree ret_val = TREE_OPERAND (TREE_OPERAND (t, 0), 1);
+
+ /* This is the construct returned by the allocator. */
+ if (TREE_CODE (ret_val) == COMPOUND_EXPR
+ && TREE_CODE (TREE_OPERAND (ret_val, 0)) == INIT_EXPR)
+ {
+ if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (ret_val)))
+ ret_val
+ = VEC_index (constructor_elt,
+ CONSTRUCTOR_ELTS
+ (TREE_OPERAND (TREE_OPERAND (ret_val, 0), 1)),
+ 1)->value;
+ else
+ ret_val = TREE_OPERAND (TREE_OPERAND (ret_val, 0), 1);
+ }
+
+ /* Strip useless conversions around the return value. */
+ if (gnat_useless_type_conversion (ret_val)
+ || TREE_CODE (ret_val) == VIEW_CONVERT_EXPR)
+ ret_val = TREE_OPERAND (ret_val, 0);
+
+ /* Strip unpadding around the return value. */
+ if (TREE_CODE (ret_val) == COMPONENT_REF
+ && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (ret_val, 0))))
+ ret_val = TREE_OPERAND (ret_val, 0);
+
+ /* Assign the new return value to the RESULT_DECL. */
+ if (is_nrv_p (dp->nrv, ret_val))
+ TREE_OPERAND (TREE_OPERAND (t, 0), 1)
+ = TREE_OPERAND (DECL_INITIAL (ret_val), 0);
+ }
+
+ /* Adjust the DECL_EXPR of NRVs to call the allocator and save the result
+ into a new variable. */
+ else if (TREE_CODE (t) == DECL_EXPR
+ && is_nrv_p (dp->nrv, DECL_EXPR_DECL (t)))
+ {
+ tree saved_current_function_decl = current_function_decl;
+ tree var = DECL_EXPR_DECL (t);
+ tree alloc, p_array, new_var, new_ret;
+ VEC(constructor_elt,gc) *v = VEC_alloc (constructor_elt, gc, 2);
+
+ /* Create an artificial context to build the allocation. */
+ current_function_decl = decl_function_context (var);
+ start_stmt_group ();
+ gnat_pushlevel ();
+
+ /* This will return a COMPOUND_EXPR with the allocation in the first
+ arm and the final return value in the second arm. */
+ alloc = build_allocator (TREE_TYPE (var), DECL_INITIAL (var),
+ TREE_TYPE (dp->result),
+ Procedure_To_Call (dp->gnat_ret),
+ Storage_Pool (dp->gnat_ret),
+ Empty, false);
+
+ /* The new variable is built as a reference to the allocated space. */
+ new_var
+ = build_decl (DECL_SOURCE_LOCATION (var), VAR_DECL, DECL_NAME (var),
+ build_reference_type (TREE_TYPE (var)));
+ DECL_BY_REFERENCE (new_var) = 1;
+
+ if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (alloc)))
+ {
+ /* The new initial value is a COMPOUND_EXPR with the allocation in
+ the first arm and the value of P_ARRAY in the second arm. */
+ DECL_INITIAL (new_var)
+ = build2 (COMPOUND_EXPR, TREE_TYPE (new_var),
+ TREE_OPERAND (alloc, 0),
+ VEC_index (constructor_elt,
+ CONSTRUCTOR_ELTS (TREE_OPERAND (alloc, 1)),
+ 0)->value);
+
+ /* Build a modified CONSTRUCTOR that references NEW_VAR. */
+ p_array = TYPE_FIELDS (TREE_TYPE (alloc));
+ CONSTRUCTOR_APPEND_ELT (v, p_array,
+ fold_convert (TREE_TYPE (p_array), new_var));
+ CONSTRUCTOR_APPEND_ELT (v, DECL_CHAIN (p_array),
+ VEC_index (constructor_elt,
+ CONSTRUCTOR_ELTS
+ (TREE_OPERAND (alloc, 1)),
+ 1)->value);
+ new_ret = build_constructor (TREE_TYPE (alloc), v);
+ }
+ else
+ {
+ /* The new initial value is just the allocation. */
+ DECL_INITIAL (new_var) = alloc;
+ new_ret = fold_convert (TREE_TYPE (alloc), new_var);
+ }
+
+ gnat_pushdecl (new_var, Empty);
+
+ /* Destroy the artificial context and insert the new statements. */
+ gnat_zaplevel ();
+ *tp = end_stmt_group ();
+ current_function_decl = saved_current_function_decl;
+
+ /* Chain NEW_VAR immediately after VAR and ignore the latter. */
+ DECL_CHAIN (new_var) = DECL_CHAIN (var);
+ DECL_CHAIN (var) = new_var;
+ DECL_IGNORED_P (var) = 1;
+
+ /* Save the new return value and the dereference of NEW_VAR. */
+ DECL_INITIAL (var)
+ = build2 (COMPOUND_EXPR, TREE_TYPE (var), new_ret,
+ build1 (INDIRECT_REF, TREE_TYPE (var), new_var));
+ /* ??? Kludge to avoid messing up during inlining. */
+ DECL_CONTEXT (var) = NULL_TREE;
+ }
+
+ /* And replace all uses of NRVs with the dereference of NEW_VAR. */
+ else if (is_nrv_p (dp->nrv, t))
+ *tp = TREE_OPERAND (DECL_INITIAL (t), 1);
+
+ /* Avoid walking into the same tree more than once. Unfortunately, we
+ can't just use walk_tree_without_duplicates because it would only
+ call us for the first occurrence of NRVs in the function body. */
if (pointer_set_insert (dp->visited, *tp))
*walk_subtrees = 0;
/* Finalize the Named Return Value optimization for FNDECL. The NRV bitmap
contains the candidates for Named Return Value and OTHER is a list of
- the other return values. */
+ the other return values. GNAT_RET is a representative return node. */
static void
-finalize_nrv (tree fndecl, bitmap nrv, VEC(tree,gc) *other)
+finalize_nrv (tree fndecl, bitmap nrv, VEC(tree,gc) *other, Node_Id gnat_ret)
{
struct cgraph_node *node;
struct nrv_data data;
+ walk_tree_fn func;
unsigned int i;
tree iter;
/* We shouldn't be applying the optimization to return types that we aren't
allowed to manipulate freely. */
- gcc_assert (!TREE_ADDRESSABLE (TREE_TYPE (TREE_TYPE (fndecl))));
+ gcc_assert (!TYPE_IS_BY_REFERENCE_P (TREE_TYPE (TREE_TYPE (fndecl))));
/* Prune the candidates that are referenced by other return values. */
data.nrv = nrv;
/* Adjust the relevant RETURN_EXPRs and replace the occurrences of NRVs. */
data.nrv = nrv;
data.result = DECL_RESULT (fndecl);
+ data.gnat_ret = gnat_ret;
data.visited = pointer_set_create ();
- walk_tree (&DECL_SAVED_TREE (fndecl), finalize_nrv_r, &data, NULL);
+ if (TYPE_RETURN_UNCONSTRAINED_P (TREE_TYPE (fndecl)))
+ func = finalize_nrv_unc_r;
+ else
+ func = finalize_nrv_r;
+ walk_tree (&DECL_SAVED_TREE (fndecl), func, &data, NULL);
pointer_set_destroy (data.visited);
}
if (TREE_ADDRESSABLE (ret_val))
return false;
- if (DECL_ALIGN (ret_val) > DECL_ALIGN (ret_obj))
+ if (ret_obj && DECL_ALIGN (ret_val) > DECL_ALIGN (ret_obj))
return false;
return true;
save_gnu_tree (gnat_param, NULL_TREE, false);
}
+ /* Disconnect the variable created for the return value. */
if (gnu_return_var_elmt)
TREE_VALUE (gnu_return_var_elmt) = void_type_node;
a Named Return Value, finalize the optimization. */
if (optimize && gnu_subprog_language->named_ret_val)
{
- finalize_nrv (gnu_subprog_decl, gnu_subprog_language->named_ret_val,
- gnu_subprog_language->other_ret_val);
+ finalize_nrv (gnu_subprog_decl,
+ gnu_subprog_language->named_ret_val,
+ gnu_subprog_language->other_ret_val,
+ gnu_subprog_language->gnat_ret);
gnu_subprog_language->named_ret_val = NULL;
gnu_subprog_language->other_ret_val = NULL;
}
mark_out_of_scope (Defining_Unit_Name (Specification (gnat_node)));
}
\f
+/* Return true if GNAT_NODE requires atomic synchronization. */
+
+static bool
+atomic_sync_required_p (Node_Id gnat_node)
+{
+ const Node_Id gnat_parent = Parent (gnat_node);
+ Node_Kind kind;
+ unsigned char attr_id;
+
+ /* First, scan the node to find the Atomic_Sync_Required flag. */
+ kind = Nkind (gnat_node);
+ if (kind == N_Type_Conversion || kind == N_Unchecked_Type_Conversion)
+ {
+ gnat_node = Expression (gnat_node);
+ kind = Nkind (gnat_node);
+ }
+
+ switch (kind)
+ {
+ case N_Expanded_Name:
+ case N_Explicit_Dereference:
+ case N_Identifier:
+ case N_Indexed_Component:
+ case N_Selected_Component:
+ if (!Atomic_Sync_Required (gnat_node))
+ return false;
+ break;
+
+ default:
+ return false;
+ }
+
+ /* Then, scan the parent to find out cases where the flag is irrelevant. */
+ kind = Nkind (gnat_parent);
+ switch (kind)
+ {
+ case N_Attribute_Reference:
+ attr_id = Get_Attribute_Id (Attribute_Name (gnat_parent));
+ /* Do not mess up machine code insertions. */
+ if (attr_id == Attr_Asm_Input || attr_id == Attr_Asm_Output)
+ return false;
+ break;
+
+ case N_Object_Renaming_Declaration:
+ /* Do not generate a function call as a renamed object. */
+ return false;
+
+ default:
+ break;
+ }
+
+ return true;
+}
+\f
/* Create a temporary variable with PREFIX and TYPE, and return it. */
static tree
or an N_Procedure_Call_Statement, to a GCC tree, which is returned.
GNU_RESULT_TYPE_P is a pointer to where we should place the result type.
If GNU_TARGET is non-null, this must be a function call on the RHS of a
- N_Assignment_Statement and the result is to be placed into that object. */
+ N_Assignment_Statement and the result is to be placed into that object.
+ If, in addition, ATOMIC_SYNC is true, then the assignment to GNU_TARGET
+ requires atomic synchronization. */
static tree
-call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target)
+call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
+ bool atomic_sync)
{
const bool function_call = (Nkind (gnat_node) == N_Function_Call);
const bool returning_value = (function_call && !gnu_target);
went_into_elab_proc = true;
}
- /* First, create the temporary for the return value if we need it: for a
- variable-sized return type if there is no target or if this is slice,
- because the gimplifier doesn't support these cases; or for a function
- with copy-in/copy-out parameters if there is no target, because we'll
- need to preserve the return value before copying back the parameters.
- This must be done before we push a new binding level around the call
- as we will pop it before copying the return value. */
+ /* First, create the temporary for the return value when:
+
+ 1. There is no target and the function has copy-in/copy-out parameters,
+ because we need to preserve the return value before copying back the
+ parameters.
+
+ 2. There is no target and this is not an object declaration, and the
+ return type has variable size, because in these cases the gimplifier
+ cannot create the temporary.
+
+ 3. There is a target and it is a slice or an array with fixed size,
+ and the return type has variable size, because the gimplifier
+ doesn't handle these cases.
+
+ This must be done before we push a binding level around the call, since
+ we will pop it before copying the return value. */
if (function_call
- && ((TREE_CODE (TYPE_SIZE (gnu_result_type)) != INTEGER_CST
- && (!gnu_target || TREE_CODE (gnu_target) == ARRAY_RANGE_REF))
- || (!gnu_target && TYPE_CI_CO_LIST (gnu_subprog_type))))
+ && ((!gnu_target && TYPE_CI_CO_LIST (gnu_subprog_type))
+ || (!gnu_target
+ && Nkind (Parent (gnat_node)) != N_Object_Declaration
+ && TREE_CODE (TYPE_SIZE (gnu_result_type)) != INTEGER_CST)
+ || (gnu_target
+ && (TREE_CODE (gnu_target) == ARRAY_RANGE_REF
+ || (TREE_CODE (TREE_TYPE (gnu_target)) == ARRAY_TYPE
+ && TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_target)))
+ == INTEGER_CST))
+ && TREE_CODE (TYPE_SIZE (gnu_result_type)) != INTEGER_CST)))
gnu_retval = create_temporary ("R", gnu_result_type);
/* Create the list of the actual parameters as GCC expects it, namely a
tree gnu_formal_type = gnat_to_gnu_type (Etype (gnat_formal));
const bool is_true_formal_parm
= gnu_formal && TREE_CODE (gnu_formal) == PARM_DECL;
+ const bool is_by_ref_formal_parm
+ = is_true_formal_parm
+ && (DECL_BY_REF_P (gnu_formal)
+ || DECL_BY_COMPONENT_PTR_P (gnu_formal)
+ || DECL_BY_DESCRIPTOR_P (gnu_formal));
/* In the Out or In Out case, we must suppress conversions that yield
an lvalue but can nevertheless cause the creation of a temporary,
because we need the real object in this case, either to pass its
/* 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 (is_true_formal_parm
- && (DECL_BY_REF_P (gnu_formal)
- || DECL_BY_COMPONENT_PTR_P (gnu_formal)
- || DECL_BY_DESCRIPTOR_P (gnu_formal))
+ if (is_by_ref_formal_parm
&& (gnu_name_type = gnat_to_gnu_type (Etype (gnat_name)))
&& !addressable_p (gnu_name, gnu_name_type))
{
;
/* If the type is passed by reference, a copy is not allowed. */
- else if (TREE_ADDRESSABLE (gnu_formal_type))
+ else if (TYPE_IS_BY_REFERENCE_P (gnu_formal_type))
post_error ("misaligned actual cannot be passed by reference",
gnat_actual);
/* Start from the real object and build the actual. */
gnu_actual = gnu_name;
+ /* If this is an atomic access of an In or In Out parameter for which
+ synchronization is required, build the atomic load. */
+ if (is_true_formal_parm
+ && !is_by_ref_formal_parm
+ && Ekind (gnat_formal) != E_Out_Parameter
+ && atomic_sync_required_p (gnat_actual))
+ gnu_actual = build_atomic_load (gnu_actual);
+
/* If this was a procedure call, we may not have removed any padding.
So do it here for the part we will use as an input, if any. */
if (Ekind (gnat_formal) != E_Out_Parameter
/* The first entry is for the actual return value if this is a
function, so skip it. */
- if (TREE_VALUE (gnu_cico_list) == void_type_node)
+ if (function_call)
gnu_cico_list = TREE_CHAIN (gnu_cico_list);
if (Nkind (Name (gnat_node)) == N_Explicit_Dereference)
gnu_result = convert (TREE_TYPE (gnu_actual), gnu_result);
}
- gnu_result = build_binary_op (MODIFY_EXPR, NULL_TREE,
- gnu_actual, gnu_result);
+ if (atomic_sync_required_p (gnat_actual))
+ gnu_result = build_atomic_store (gnu_actual, gnu_result);
+ else
+ gnu_result = build_binary_op (MODIFY_EXPR, NULL_TREE,
+ gnu_actual, gnu_result);
set_expr_location_from_node (gnu_result, gnat_node);
append_to_statement_list (gnu_result, &gnu_stmt_list);
gnu_cico_list = TREE_CHAIN (gnu_cico_list);
return value from it and update the return type. */
if (TYPE_CI_CO_LIST (gnu_subprog_type))
{
- tree gnu_elmt = value_member (void_type_node,
- TYPE_CI_CO_LIST (gnu_subprog_type));
+ tree gnu_elmt = TYPE_CI_CO_LIST (gnu_subprog_type);
gnu_call = build_component_ref (gnu_call, NULL_TREE,
TREE_PURPOSE (gnu_elmt), false);
gnu_result_type = TREE_TYPE (gnu_call);
else
op_code = MODIFY_EXPR;
- gnu_call
- = build_binary_op (op_code, NULL_TREE, gnu_target, gnu_call);
+ if (atomic_sync)
+ gnu_call = build_atomic_store (gnu_target, gnu_call);
+ else
+ gnu_call
+ = build_binary_op (op_code, NULL_TREE, gnu_target, gnu_call);
set_expr_location_from_node (gnu_call, gnat_parent);
append_to_statement_list (gnu_call, &gnu_stmt_list);
}
invalidate_global_renaming_pointers ();
}
\f
+/* Return true if GNAT_NODE is on the LHS of an assignment or an actual
+ parameter of a call. */
+
+static bool
+lhs_or_actual_p (Node_Id gnat_node)
+{
+ Node_Id gnat_parent = Parent (gnat_node);
+ Node_Kind kind = Nkind (gnat_parent);
+
+ if (kind == N_Assignment_Statement && Name (gnat_parent) == gnat_node)
+ return true;
+
+ if ((kind == N_Procedure_Call_Statement || kind == N_Function_Call)
+ && Name (gnat_parent) != gnat_node)
+ return true;
+
+ if (kind == N_Parameter_Association)
+ return true;
+
+ return false;
+}
+
+/* Return true if either GNAT_NODE or a view of GNAT_NODE is on the LHS
+ of an assignment or an actual parameter of a call. */
+
+static bool
+present_in_lhs_or_actual_p (Node_Id gnat_node)
+{
+ Node_Kind kind;
+
+ if (lhs_or_actual_p (gnat_node))
+ return true;
+
+ kind = Nkind (Parent (gnat_node));
+
+ if ((kind == N_Type_Conversion || kind == N_Unchecked_Type_Conversion)
+ && lhs_or_actual_p (Parent (gnat_node)))
+ return true;
+
+ return false;
+}
+
/* Return true if GNAT_NODE, an unchecked type conversion, is a no-op as far
as gigi is concerned. This is used to avoid conversions on the LHS. */
/* The conversion must be on the LHS of an assignment or an actual parameter
of a call. Otherwise, even if the conversion was essentially a no-op, it
could de facto ensure type consistency and this should be preserved. */
- if (!(Nkind (Parent (gnat_node)) == N_Assignment_Statement
- && Name (Parent (gnat_node)) == gnat_node)
- && !((Nkind (Parent (gnat_node)) == N_Procedure_Call_Statement
- || Nkind (Parent (gnat_node)) == N_Function_Call)
- && Name (Parent (gnat_node)) != gnat_node))
+ if (!lhs_or_actual_p (gnat_node))
return false;
from_type = Etype (Expression (gnat_node));
case N_Operator_Symbol:
case N_Defining_Identifier:
gnu_result = Identifier_to_gnu (gnat_node, &gnu_result_type);
+
+ /* If this is an atomic access on the RHS for which synchronization is
+ required, build the atomic load. */
+ if (atomic_sync_required_p (gnat_node)
+ && !present_in_lhs_or_actual_p (gnat_node))
+ gnu_result = build_atomic_load (gnu_result);
break;
case N_Integer_Literal:
gnu_result = gnat_to_gnu (Prefix (gnat_node));
gnu_result_type = get_unpadded_type (Etype (gnat_node));
gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result);
+
+ /* If this is an atomic access on the RHS for which synchronization is
+ required, build the atomic load. */
+ if (atomic_sync_required_p (gnat_node)
+ && !present_in_lhs_or_actual_p (gnat_node))
+ gnu_result = build_atomic_load (gnu_result);
break;
case N_Indexed_Component:
gnu_result = build_binary_op (ARRAY_REF, NULL_TREE,
gnu_result, gnu_expr);
}
- }
- gnu_result_type = get_unpadded_type (Etype (gnat_node));
+ gnu_result_type = get_unpadded_type (Etype (gnat_node));
+
+ /* If this is an atomic access on the RHS for which synchronization is
+ required, build the atomic load. */
+ if (atomic_sync_required_p (gnat_node)
+ && !present_in_lhs_or_actual_p (gnat_node))
+ gnu_result = build_atomic_load (gnu_result);
+ }
break;
case N_Slice:
(Parent (gnat_node)));
}
- gcc_assert (gnu_result);
gnu_result_type = get_unpadded_type (Etype (gnat_node));
+
+ /* If this is an atomic access on the RHS for which synchronization is
+ required, build the atomic load. */
+ if (atomic_sync_required_p (gnat_node)
+ && !present_in_lhs_or_actual_p (gnat_node))
+ gnu_result = build_atomic_load (gnu_result);
}
break;
gnu_result = gnat_to_gnu (Expression (gnat_node));
gnu_result_type = get_unpadded_type (Etype (gnat_node));
+ /* If this is a qualified expression for a tagged type, we mark the type
+ as used. Because of polymorphism, this might be the only reference to
+ the tagged type in the program while objects have it as dynamic type.
+ The debugger needs to see it to display these objects properly. */
+ if (kind == N_Qualified_Expression && Is_Tagged_Type (Etype (gnat_node)))
+ used_types_insert (gnu_result_type);
+
gnu_result
= convert_with_check (Etype (gnat_node), gnu_result,
Do_Overflow_Check (gnat_node),
if (Is_Elementary_Type (gnat_desig_type)
|| Is_Constrained (gnat_desig_type))
- {
- gnu_type = gnat_to_gnu_type (gnat_desig_type);
- gnu_init = convert (gnu_type, gnu_init);
- }
+ gnu_type = gnat_to_gnu_type (gnat_desig_type);
else
{
gnu_type = gnat_to_gnu_type (Etype (Expression (gnat_temp)));
if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
gnu_type = TREE_TYPE (gnu_init);
-
- gnu_init = convert (gnu_type, gnu_init);
}
+
+ /* See the N_Qualified_Expression case for the rationale. */
+ if (Is_Tagged_Type (gnat_desig_type))
+ used_types_insert (gnu_type);
+
+ gnu_init = convert (gnu_type, gnu_init);
}
else
gcc_unreachable ();
the next statement that the middle-end knows how to preserve. */
if (!optimize && Comes_From_Source (gnat_node))
{
- tree stmt, label = create_label_decl (NULL_TREE);
+ tree stmt, label = create_label_decl (NULL_TREE, gnat_node);
+ DECL_IGNORED_P (label) = 1;
start_stmt_group ();
stmt = build1 (GOTO_EXPR, void_type_node, label);
set_expr_location_from_node (stmt, gnat_node);
N_Raise_Storage_Error);
else if (Nkind (Expression (gnat_node)) == N_Function_Call)
gnu_result
- = call_to_gnu (Expression (gnat_node), &gnu_result_type, gnu_lhs);
+ = call_to_gnu (Expression (gnat_node), &gnu_result_type, gnu_lhs,
+ atomic_sync_required_p (Name (gnat_node)));
else
{
gnu_rhs
gnu_rhs = emit_range_check (gnu_rhs, Etype (Name (gnat_node)),
gnat_node);
- gnu_result
- = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_lhs, gnu_rhs);
+ if (atomic_sync_required_p (Name (gnat_node)))
+ gnu_result = build_atomic_store (gnu_lhs, gnu_rhs);
+ else
+ gnu_result
+ = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_lhs, gnu_rhs);
/* If the type being assigned is an array type and the two sides are
not completely disjoint, play safe and use memmove. But don't do
else if (TYPE_RETURN_UNCONSTRAINED_P (gnu_subprog_type))
{
gnu_ret_val = maybe_unconstrained_array (gnu_ret_val);
+
+ /* And find out whether this is a candidate for Named Return
+ Value. If so, record it. */
+ if (!TYPE_CI_CO_LIST (gnu_subprog_type) && optimize)
+ {
+ tree ret_val = gnu_ret_val;
+
+ /* Strip useless conversions around the return value. */
+ if (gnat_useless_type_conversion (ret_val))
+ ret_val = TREE_OPERAND (ret_val, 0);
+
+ /* Strip unpadding around the return value. */
+ if (TREE_CODE (ret_val) == COMPONENT_REF
+ && TYPE_IS_PADDING_P
+ (TREE_TYPE (TREE_OPERAND (ret_val, 0))))
+ ret_val = TREE_OPERAND (ret_val, 0);
+
+ /* Now apply the test to the return value. */
+ if (return_value_ok_for_nrv_p (NULL_TREE, ret_val))
+ {
+ if (!f_named_ret_val)
+ f_named_ret_val = BITMAP_GGC_ALLOC ();
+ bitmap_set_bit (f_named_ret_val, DECL_UID (ret_val));
+ if (!f_gnat_ret)
+ f_gnat_ret = gnat_node;
+ }
+ }
+
gnu_ret_val = build_allocator (TREE_TYPE (gnu_ret_val),
gnu_ret_val,
TREE_TYPE (gnu_ret_obj),
gnat_node, false);
}
- /* If the function returns by invisible reference, dereference
+ /* Otherwise, if it returns by invisible reference, dereference
the pointer it is passed using the type of the return value
and build the copy operation manually. This ensures that we
don't copy too much data, for example if the return type is
unconstrained with a maximum size. */
- if (TREE_ADDRESSABLE (gnu_subprog_type))
+ else if (TREE_ADDRESSABLE (gnu_subprog_type))
{
tree gnu_ret_deref
= build_unary_op (INDIRECT_REF, TREE_TYPE (gnu_ret_val),
gnu_ret_val = NULL_TREE;
}
}
+
else
- {
- gnu_ret_obj = NULL_TREE;
- gnu_ret_val = NULL_TREE;
- }
+ gnu_ret_obj = gnu_ret_val = NULL_TREE;
/* If we have a return label defined, convert this into a branch to
that label. The return proper will be handled elsewhere. */
break;
case N_Goto_Statement:
- gnu_result = build1 (GOTO_EXPR, void_type_node,
- gnat_to_gnu (Name (gnat_node)));
+ gnu_result
+ = build1 (GOTO_EXPR, void_type_node, gnat_to_gnu (Name (gnat_node)));
break;
/***************************/
case N_Function_Call:
case N_Procedure_Call_Statement:
- gnu_result = call_to_gnu (gnat_node, &gnu_result_type, NULL_TREE);
+ gnu_result = call_to_gnu (gnat_node, &gnu_result_type, NULL_TREE, false);
break;
/************************/
: NULL_TREE;
tree gnu_target_desig_type = TREE_TYPE (gnu_target_type);
- if ((TYPE_DUMMY_P (gnu_target_desig_type)
+ if ((TYPE_IS_DUMMY_P (gnu_target_desig_type)
|| get_alias_set (gnu_target_desig_type) != 0)
&& (!POINTER_TYPE_P (gnu_source_type)
- || (TYPE_DUMMY_P (gnu_source_desig_type)
- != TYPE_DUMMY_P (gnu_target_desig_type))
- || (TYPE_DUMMY_P (gnu_source_desig_type)
+ || (TYPE_IS_DUMMY_P (gnu_source_desig_type)
+ != TYPE_IS_DUMMY_P (gnu_target_desig_type))
+ || (TYPE_IS_DUMMY_P (gnu_source_desig_type)
&& gnu_source_desig_type != gnu_target_desig_type)
|| !alias_sets_conflict_p
(get_alias_set (gnu_source_desig_type),
tree gnu_target_array_type
= TREE_TYPE (TREE_TYPE (TYPE_FIELDS (gnu_target_type)));
- if ((TYPE_DUMMY_P (gnu_target_array_type)
+ if ((TYPE_IS_DUMMY_P (gnu_target_array_type)
|| get_alias_set (gnu_target_array_type) != 0)
&& (!TYPE_IS_FAT_POINTER_P (gnu_source_type)
- || (TYPE_DUMMY_P (gnu_source_array_type)
- != TYPE_DUMMY_P (gnu_target_array_type))
- || (TYPE_DUMMY_P (gnu_source_array_type)
+ || (TYPE_IS_DUMMY_P (gnu_source_array_type)
+ != TYPE_IS_DUMMY_P (gnu_target_array_type))
+ || (TYPE_IS_DUMMY_P (gnu_source_array_type)
&& gnu_source_array_type != gnu_target_array_type)
|| !alias_sets_conflict_p
(get_alias_set (gnu_source_array_type),
N_Raise_Constraint_Error));
}
- /* If our result has side-effects and is of an unconstrained type,
- make a SAVE_EXPR so that we can be sure it will only be referenced
- once. Note we must do this before any conversions. */
+ /* If the result has side-effects and is of an unconstrained type, make a
+ SAVE_EXPR so that we can be sure it will only be referenced once. But
+ this is useless for a call to a function that returns an unconstrained
+ type with default discriminant, as we cannot compute the size of the
+ actual returned object. We must do this before any conversions. */
if (TREE_SIDE_EFFECTS (gnu_result)
+ && !(TREE_CODE (gnu_result) == CALL_EXPR
+ && TYPE_IS_PADDING_P (TREE_TYPE (gnu_result)))
&& (TREE_CODE (gnu_result_type) == UNCONSTRAINED_ARRAY_TYPE
|| CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type))))
gnu_result = gnat_stabilize_reference (gnu_result, false, NULL);
/* Now convert the result to the result type, unless we are in one of the
following cases:
- 1. If this is the Name of an assignment statement or a parameter of
- a procedure 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 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).
+ 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
+ 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).
2. If we have a label (which doesn't have any well-defined type), a
field or an error, return the result almost unmodified. Similarly,
3. If the type is void or if we have no result, return error_mark_node
to show we have no result.
- 4. Finally, if the type of the result is already correct. */
+ 4. If this a call to a function that returns an unconstrained type with
+ default discriminant, return the call expression unmodified since we
+ cannot compute the size of the actual returned object.
+
+ 5. Finally, if the type of the result is already correct. */
if (Present (Parent (gnat_node))
- && ((Nkind (Parent (gnat_node)) == N_Assignment_Statement
- && Name (Parent (gnat_node)) == gnat_node)
+ && (lhs_or_actual_p (gnat_node)
|| (Nkind (Parent (gnat_node)) == N_Unchecked_Type_Conversion
&& unchecked_conversion_nop (Parent (gnat_node)))
- || (Nkind (Parent (gnat_node)) == N_Procedure_Call_Statement
- && Name (Parent (gnat_node)) != gnat_node)
- || Nkind (Parent (gnat_node)) == N_Parameter_Association
|| (Nkind (Parent (gnat_node)) == N_Unchecked_Type_Conversion
&& !AGGREGATE_TYPE_P (gnu_result_type)
&& !AGGREGATE_TYPE_P (TREE_TYPE (gnu_result))))
else if (gnu_result == error_mark_node || gnu_result_type == void_type_node)
gnu_result = error_mark_node;
- else if (gnu_result_type != TREE_TYPE (gnu_result))
+ else if (TREE_CODE (gnu_result) == CALL_EXPR
+ && TYPE_IS_PADDING_P (TREE_TYPE (gnu_result))
+ && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type)))
+ {
+ /* ??? We need to convert if the padded type has fixed size because
+ gnat_types_compatible_p will say that padded types are compatible
+ but the gimplifier will not and, therefore, will ultimately choke
+ if there isn't a conversion added early. */
+ if (TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_result))) == INTEGER_CST)
+ gnu_result = convert (gnu_result_type, gnu_result);
+ }
+
+ else if (TREE_TYPE (gnu_result) != gnu_result_type)
gnu_result = convert (gnu_result_type, gnu_result);
/* We don't need any NOP_EXPR or NON_LVALUE_EXPR on the result. */
}
/* In any case, we have to deal with our own TYPE_ADA_SIZE field. */
else if (TREE_CODE (gnu_decl) == TYPE_DECL
- && ((TREE_CODE (type) == RECORD_TYPE
- && !TYPE_FAT_POINTER_P (type))
- || TREE_CODE (type) == UNION_TYPE
- || TREE_CODE (type) == QUAL_UNION_TYPE))
+ && RECORD_OR_UNION_TYPE_P (type)
+ && !TYPE_FAT_POINTER_P (type))
MARK_VISITED (TYPE_ADA_SIZE (type));
}
else if (!DECL_EXTERNAL (gnu_decl))
return GS_ALL_DONE;
}
- /* Otherwise, if we are taking the address of a non-constant CONSTRUCTOR
- or of a call, explicitly create the local temporary. That's required
- if the type is passed by reference. */
- if (TREE_CODE (op) == CONSTRUCTOR || TREE_CODE (op) == CALL_EXPR)
- {
- tree mod, new_var = create_tmp_var_raw (TREE_TYPE (op), "C");
- TREE_ADDRESSABLE (new_var) = 1;
- gimple_add_tmp_var (new_var);
-
- mod = build2 (INIT_EXPR, TREE_TYPE (new_var), new_var, op);
- gimplify_and_add (mod, pre_p);
-
- TREE_OPERAND (expr, 0) = new_var;
- recompute_tree_invariant_for_addr_expr (expr);
- return GS_ALL_DONE;
- }
-
return GS_UNHANDLED;
case VIEW_CONVERT_EXPR:
|| DECL_ALIGN (TREE_OPERAND (gnu_expr, 1))
>= TYPE_ALIGN (TREE_TYPE (gnu_expr))))
/* The field of a padding record is always addressable. */
- || TYPE_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_expr, 0))))
+ || TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_expr, 0))))
&& addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE));
case ARRAY_REF: case ARRAY_RANGE_REF:
OSDN Git Service
