2006-10-31 Eric Botcazou <ebotcazou@adacore.com>
Nicolas Setton <setton@adacore.com>
Olivier Hainque <hainque@adacore.com>
Gary Dismukes <dismukes@adacore.com>
* gigi.h: (tree_code_for_record_type): Declare.
(add_global_renaming_pointer): Rename to record_global_renaming_pointer.
(get_global_renaming_pointers): Rename to
invalidate_global_renaming_pointers.
(static_ctors): Delete.
(static_dtors): Likewise.
(gnat_write_global_declarations): Declare.
(create_var_decl): Adjust descriptive comment to indicate that the
subprogram may return a CONST_DECL node.
(create_true_var_decl): Declare new function, similar to
create_var_decl but forcing the creation of a VAR_DECL node.
(get_global_renaming_pointers): Declare.
(add_global_renaming_pointer): Likewise.
* ada-tree.h (DECL_READONLY_ONCE_ELAB): New macro.
* decl.c (gnat_to_gnu_entity) <case E_Function>: Don't copy the type
tree before setting TREE_ADDRESSABLE for by-reference return mechanism
processing.
(gnat_to_gnu_entity): Remove From_With_Type from computation for
imported_p.
<E_Access_Type>: Use the Non_Limited_View as the full view of the
designated type if the pointer comes from a limited_with clause. Make
incomplete designated type if it is in the main unit and has a freeze
node.
<E_Incomplete_Type>: Rework to treat Non_Limited_View, Full_View, and
Underlying_Full_View similarly. Return earlier if the full view already
has an associated tree.
(gnat_to_gnu_entity) <E_Record_Type>: Restore comment.
(gnat_to_gnu_entity) <E_Record_Type>: Do not use a dummy type.
(gnat_to_gnu_entity) <E_Variable>: Set TYPE_REF_CAN_ALIAS_ALL on the
reference type built for objects with an address clause.
Use create_true_var_decl with const_flag set for
DECL_CONST_CORRESPONDING_VARs, ensuring a VAR_DECL is created with
TREE_READONLY set.
(gnat_to_gnu_entity, case E_Enumeration_Type): Set TYPE_NAME
for Character and Wide_Character types. This info is read by the
dwarf-2 writer, and is needed to be able to use the command "ptype
character" in the debugger.
(gnat_to_gnu_entity): When generating a type representing
a Character or Wide_Character type, set the flag TYPE_STRING_FLAG,
so that debug writers can distinguish it from ordinary integers.
(elaborate_expression_1): Test the DECL_READONLY_ONCE_ELAB flag in
addition to TREE_READONLY to assert the constantness of variables for
elaboration purposes.
(gnat_to_gnu_entity, subprogram cases): Change loops on formal
parameters to call new Einfo function First_Formal_With_Extras.
(gnat_to_gnu_entity): In type_annotate mode, replace a discriminant of a
protected type with its corresponding discriminant, to obtain a usable
declaration
(gnat_to_gnu_entity) <E_Access_Protected_Subprogram_Type>: Be prepared
for a multiple elaboration of the "equivalent" type.
(gnat_to_gnu_entity): Adjust for renaming of add_global_renaming_pointer
into record_global_renaming_pointer.
(gnat_to_gnu_entity) <E_Array_Type>: Do not force
TYPE_NONALIASED_COMPONENT to 0 if the element type is an aggregate.
<E_Array_Subtype>: Likewise.
(gnat_to_gnu_entity) <E_Incomplete_Subtype>: Add support for regular
incomplete subtypes and incomplete subtypes of incomplete types visible
through a limited with clause.
(gnat_to_gnu_entity) <E_Array_Subtype>: Take into account the bounds of
the base index type for the maximum size of the array only if they are
constant.
(gnat_to_gnu_entity, renaming object case): Do not wrap up the
expression into a SAVE_EXPR if stabilization failed.
* utils.c (create_subprog_decl): Turn TREE_ADDRESSABLE on the type of
a result decl into DECL_BY_REFERENCE on this decl, now what is expected
by lower level compilation passes.
(gnat_genericize): New function, lowering a function body to GENERIC.
Turn the type of RESULT_DECL into a real reference type if the decl
has been marked DECL_BY_REFERENCE, and adjust references to the latter
accordingly.
(gnat_genericize_r): New function. Tree walking callback for
gnat_genericize.
(convert_from_reference, is_byref_result): New functions. Helpers for
gnat_genericize_r.
(create_type_decl): Call gnat_pushdecl before calling
rest_of_decl_compilation, to make sure that field TYPE_NAME of
type_decl is properly set before calling the debug information writers.
(write_record_type_debug_info): The heuristics which compute the
alignment of a field in a variant record might not be accurate. Add a
safety test to make sure no alignment is set to a smaller value than
the alignment of the field type.
(make_dummy_type): Use the Non_Limited_View as the underlying type if
the type comes from a limited_with clause. Do not loop on the full view.
(GET_GNU_TREE, SET_GNU_TREE, PRESENT_GNU_TREE): New macros.
(dummy_node_table): New global variable, moved from decl.c.
(GET_DUMMY_NODE, SET_DUMMY_NODE, PRESENT_DUMMY_NODE): New macros.
(save_gnu_tree): Use above macros.
(get_gnu_tree): Likewise.
(present_gnu_tree): Likewise.
(init_dummy_type): New function, moved from decl.c. Use above macros.
(make_dummy_type): Likewise.
(tree_code_for_record_type): New function extracted from make_dummy_type
(init_gigi_decls): Set DECL_IS_MALLOC on gnat_malloc.
(static_ctors): Change it to a vector, make static.
(static_dtors): Likewise.
(end_subprog_body): Adjust for above change.
(build_global_cdtor): Moved from trans.c.
(gnat_write_global_declarations): Emit global constructor and
destructor, and call cgraph_optimize before emitting debug info for
global declarations.
(global_decls): New global variable.
(gnat_pushdecl): Store the global declarations in global_decls, for
later use.
(gnat_write_global_declarations): Emit debug information for global
declarations.
(create_var_decl_1): Former create_var_decl, with an extra argument to
state whether the creation of a CONST_DECL is allowed.
(create_var_decl): Behavior unchanged. Now a wrapper around
create_var_decl_1 allowing CONST_DECL creation.
(create_true_var_decl): New function, similar to create_var_decl but
forcing the creation of a VAR_DECL node (CONST_DECL not allowed).
(create_field_decl): Do not always mark the field as addressable
if its type is an aggregate.
(global_renaming_pointers): New static variable.
(add_global_renaming_pointer): New function.
(get_global_renaming_pointers): Likewise.
* misc.c (gnat_dwarf_name): New function.
(LANG_HOOKS_DWARF_NAME): Define to gnat_dwarf_name.
(gnat_post_options): Add comment about structural alias analysis.
(gnat_parse_file): Do not call cgraph_optimize here.
(LANG_HOOKS_WRITE_GLOBALS): Define to gnat_write_global_declarations.
* trans.c (process_freeze_entity): Don't abort if we already have a
non dummy GCC tree for a Concurrent_Record_Type, as it might
legitimately have been elaborated while processing the associated
Concurrent_Type prior to this explicit freeze node.
(Identifier_to_gnu): Do not make a variable referenced in a SJLJ
exception handler volatile if it is of variable size.
(process_type): Remove bypass for types coming from a limited_with
clause.
(call_to_gnu): When processing the copy-out of a N_Type_Conversion GNAT
actual, convert the corresponding gnu_actual to the real destination
type when necessary.
(add_decl_expr): Set the DECL_READONLY_ONCE_ELAB flag on variables
originally TREE_READONLY but whose elaboration cannot be performed
statically.
Part of fix for F504-021.
(tree_transform, subprogram cases): Change loops on formal parameters to
call new Einfo function First_Formal_With_Extras.
(gnat_to_gnu) <N_Op_Shift_Right_Arithmetic>: Ignore constant overflow
stemming from type conversion for the lhs.
(Attribute_to_gnu) <Attr_Alignment>: Also divide the alignment by the
number of bits per unit for components of records.
(gnat_to_gnu) <N_Code_Statement>: Mark operands addressable if needed.
(Handled_Sequence_Of_Statements_to_gnu): Register the cleanup associated
with At_End_Proc after the SJLJ EH cleanup.
(Compilation_Unit_to_gnu): Call elaborate_all_entities only on the main
compilation unit.
(elaborate_all_entities): Do not retest type_annotate_only.
(tree_transform) <N_Abstract_Subprogram_Declaration>: Process the
result type of an abstract subprogram, which may be an itype associated
with an anonymous access result (related to AI-318-02).
(build_global_cdtor): Move to utils.c.
(Case_Statement_to_gnu): Avoid adding the choice of a when statement if
this choice is not a null tree nor an integer constant.
(gigi): Run unshare_save_expr via walk_tree_without_duplicates
on the body of elaboration routines instead of mark_unvisited.
(add_stmt): Do not mark the tree.
(add_decl_expr): Tweak comment.
(mark_unvisited): Delete.
(unshare_save_expr): New static function.
(call_to_gnu): Issue an error when making a temporary around a
procedure call because of non-addressable actual parameter if the
type of the formal is by_reference.
(Compilation_Unit_to_gnu): Invalidate the global renaming pointers
after building the elaboration routine.
From-SVN: r118331
discriminant. */
#define DECL_STUBBED_P(NODE) DECL_LANG_FLAG_0 (FUNCTION_DECL_CHECK (NODE))
+/* Nonzero in a VAR_DECL if it is guaranteed to be constant after having
+ been elaborated and TREE_READONLY is not set on it. */
+#define DECL_READONLY_ONCE_ELAB(NODE) DECL_LANG_FLAG_0 (VAR_DECL_CHECK (NODE))
+
/* Nonzero if this decl is always used by reference; i.e., an INDIRECT_REF
is needed to access the object. */
#define DECL_BY_REF_P(NODE) DECL_LANG_FLAG_1 (NODE)
: LONG_LONG_TYPE_SIZE);
tree gnu_size = 0;
bool imported_p
- = ((Is_Imported (gnat_entity) && No (Address_Clause (gnat_entity)))
- || From_With_Type (gnat_entity));
+ = (Is_Imported (gnat_entity) && No (Address_Clause (gnat_entity)));
unsigned int align = 0;
/* Since a use of an Itype is a definition, process it as such if it
break;
}
+ else if (Present (CR_Discriminant (gnat_entity))
+ && type_annotate_only)
+ {
+ gnu_decl = gnat_to_gnu_entity (CR_Discriminant (gnat_entity),
+ gnu_expr, definition);
+ saved = 1;
+ break;
+ }
+
/* If the enclosing record has explicit stored discriminants,
then it is an untagged record. If the Corresponding_Discriminant
is not empty then this must be a renamed discriminant and its
object, we just make a "bare" pointer, and the renamed
entity is always accessed indirectly through it. */
{
- bool expr_has_side_effects = TREE_SIDE_EFFECTS (gnu_expr);
-
inner_const_flag = TREE_READONLY (gnu_expr);
const_flag = true;
gnu_type = build_reference_type (gnu_type);
/* If a previous attempt at unrestricted stabilization
failed, there is no point trying again and we can reuse
- the result without attaching it to the pointer. */
+ the result without attaching it to the pointer. In this
+ case it will only be used as the initializing expression
+ of the pointer and thus needs no special treatment with
+ regard to multiple evaluations. */
if (maybe_stable_expr)
;
- /* Otherwise, try to stabilize now, restricting to
- lvalues only, and attach the expression to the pointer
- if the stabilization succeeds.
+ /* Otherwise, try to stabilize now, restricting to lvalues
+ only, and attach the expression to the pointer if the
+ stabilization succeeds.
Note that this might introduce SAVE_EXPRs and we don't
check whether we're at the global level or not. This is
if (stabilized)
renamed_obj = maybe_stable_expr;
+
/* Attaching is actually performed downstream, as soon
- as we have a DECL for the pointer we make. */
+ as we have a VAR_DECL for the pointer we make. */
}
gnu_expr
= build_unary_op (ADDR_EXPR, gnu_type, maybe_stable_expr);
- /* If the initial expression has side effects, we might
- still have an unstabilized version at this point (for
- instance if it involves a function call). Wrap the
- result into a SAVE_EXPR now, in case it happens to be
- referenced several times. */
- if (expr_has_side_effects && ! stabilized)
- gnu_expr = save_expr (gnu_expr);
-
gnu_size = NULL_TREE;
used_by_ref = true;
}
/* Ignore the size. It's either meaningless or was handled
above. */
gnu_size = NULL_TREE;
- gnu_type = build_reference_type (gnu_type);
+ /* The address expression contains a conversion from pointer type
+ to the system__address integer type, which means the address
+ of the underlying object escapes. We therefore have no other
+ choice than forcing the type of the object being defined to
+ alias everything in order to make type-based alias analysis
+ aware that it will dereference the escaped address.
+ ??? This uncovers problems in ACATS at -O2 with the volatility
+ of the original type: it may not be correctly propagated, thus
+ causing PRE to enter an infinite loop creating value numbers
+ out of volatile expressions. Disable it for now. */
+ gnu_type
+ = build_reference_type_for_mode (gnu_type, ptr_mode, false);
gnu_address = convert (gnu_type, gnu_address);
used_by_ref = true;
const_flag = !Is_Public (gnat_entity);
|| (Is_Imported (gnat_entity)
&& Has_Stdcall_Convention (gnat_entity)))
{
- gnu_type = build_reference_type (gnu_type);
+ /* See the definition case above for the rationale. */
+ gnu_type
+ = build_reference_type_for_mode (gnu_type, ptr_mode, false);
gnu_size = NULL_TREE;
gnu_expr = NULL_TREE;
if (TREE_CODE (gnu_decl) == VAR_DECL && renamed_obj)
{
SET_DECL_RENAMED_OBJECT (gnu_decl, renamed_obj);
- DECL_RENAMING_GLOBAL_P (gnu_decl) = global_bindings_p ();
+ if (global_bindings_p ())
+ {
+ DECL_RENAMING_GLOBAL_P (gnu_decl) = 1;
+ record_global_renaming_pointer (gnu_decl);
+ }
}
- /* If we have an address clause and we've made this indirect, it's
- not enough to merely mark the type as volatile since volatile
- references only conflict with other volatile references while this
- reference must conflict with all other references. So ensure that
- the dereferenced value has alias set 0. */
- if (Present (Address_Clause (gnat_entity)) && used_by_ref)
- DECL_POINTER_ALIAS_SET (gnu_decl) = 0;
-
if (definition && DECL_SIZE (gnu_decl)
&& get_block_jmpbuf_decl ()
&& (TREE_CODE (DECL_SIZE (gnu_decl)) != INTEGER_CST
|| Is_Aliased (Etype (gnat_entity))))
{
tree gnu_corr_var
- = create_var_decl (gnu_entity_id, gnu_ext_name, gnu_type,
- gnu_expr, false, Is_Public (gnat_entity),
- false, static_p, NULL, gnat_entity);
+ = create_true_var_decl (gnu_entity_id, gnu_ext_name, gnu_type,
+ gnu_expr, true, Is_Public (gnat_entity),
+ false, static_p, NULL, gnat_entity);
SET_DECL_CONST_CORRESPONDING_VAR (gnu_decl, gnu_corr_var);
}
if (No (First_Literal (gnat_entity)))
{
gnu_type = make_unsigned_type (esize);
+ TYPE_NAME (gnu_type) = gnu_entity_id;
+
+ /* Set the TYPE_STRING_FLAG for Ada Character and
+ Wide_Character types. This is needed by the dwarf-2 debug writer to
+ distinguish between unsigned integer types and character types. */
+ TYPE_STRING_FLAG (gnu_type) = 1;
break;
}
tem = build_array_type (tem, gnu_index_types[index]);
TYPE_MULTI_ARRAY_P (tem) = (index > 0);
- /* If the type below this an multi-array type, then this
- does not not have aliased components.
-
- ??? Otherwise, for now, we say that any component of aggregate
- type is addressable because the front end may take 'Reference
- of it. But we have to make it addressable if it must be passed
- by reference or it that is the default. */
- TYPE_NONALIASED_COMPONENT (tem)
- = ((TREE_CODE (TREE_TYPE (tem)) == ARRAY_TYPE
- && TYPE_MULTI_ARRAY_P (TREE_TYPE (tem))) ? 1
- : (!Has_Aliased_Components (gnat_entity)
- && !AGGREGATE_TYPE_P (TREE_TYPE (tem))));
+ /* If the type below this is a multi-array type, then this
+ does not have aliased components. But we have to make
+ them addressable if it must be passed by reference or
+ if that is the default. */
+ if ((TREE_CODE (TREE_TYPE (tem)) == ARRAY_TYPE
+ && TYPE_MULTI_ARRAY_P (TREE_TYPE (tem)))
+ || (!Has_Aliased_Components (gnat_entity)
+ && !must_pass_by_ref (TREE_TYPE (tem))
+ && !default_pass_by_ref (TREE_TYPE (tem))))
+ TYPE_NONALIASED_COMPONENT (tem) = 1;
}
/* If an alignment is specified, use it if valid. But ignore it for
if ((TREE_CODE (gnu_min) == INTEGER_CST
&& !TREE_OVERFLOW (gnu_min)
&& !operand_equal_p (gnu_min, gnu_base_base_min, 0))
- || !CONTAINS_PLACEHOLDER_P (gnu_min))
+ || !CONTAINS_PLACEHOLDER_P (gnu_min)
+ || !(TREE_CODE (gnu_base_min) == INTEGER_CST
+ && !TREE_OVERFLOW (gnu_base_min)))
gnu_base_min = gnu_min;
if ((TREE_CODE (gnu_max) == INTEGER_CST
&& !TREE_OVERFLOW (gnu_max)
&& !operand_equal_p (gnu_max, gnu_base_base_max, 0))
- || !CONTAINS_PLACEHOLDER_P (gnu_max))
+ || !CONTAINS_PLACEHOLDER_P (gnu_max)
+ || !(TREE_CODE (gnu_base_max) == INTEGER_CST
+ && !TREE_OVERFLOW (gnu_base_max)))
gnu_base_max = gnu_max;
if ((TREE_CODE (gnu_base_min) == INTEGER_CST
{
gnu_type = build_array_type (gnu_type, gnu_index_type[index]);
TYPE_MULTI_ARRAY_P (gnu_type) = (index > 0);
- /* If the type below this an multi-array type, then this
- does not not have aliased components.
-
- ??? Otherwise, for now, we say that any component of aggregate
- type is addressable because the front end may take 'Reference
- of it. But we have to make it addressable if it must be passed
- by reference or it that is the default. */
- TYPE_NONALIASED_COMPONENT (gnu_type)
- = ((TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE
- && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type))) ? 1
- : (!Has_Aliased_Components (gnat_entity)
- && !AGGREGATE_TYPE_P (TREE_TYPE (gnu_type))));
+
+ /* If the type below this is a multi-array type, then this
+ does not have aliased components. But we have to make
+ them addressable if it must be passed by reference or
+ if that is the default. */
+ if ((TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE
+ && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type)))
+ || (!Has_Aliased_Components (gnat_entity)
+ && !must_pass_by_ref (TREE_TYPE (gnu_type))
+ && !default_pass_by_ref (TREE_TYPE (gnu_type))))
+ TYPE_NONALIASED_COMPONENT (gnu_type) = 1;
}
/* If we are at file level and this is a multi-dimensional array, we
}
/* Make a node for the record. If we are not defining the record,
- suppress expanding incomplete types. We use the same RECORD_TYPE
- as for a dummy type and reset TYPE_DUMMY_P to show it's no longer
- a dummy.
-
- It is very tempting to delay resetting this bit until we are done
- with completing the type, e.g. to let possible intermediate
- elaboration of access types designating the record know it is not
- complete and arrange for update_pointer_to to fix things up later.
-
- It would be wrong, however, because dummy types are expected only
- to be created for Ada incomplete or private types, which is not
- what we have here. Doing so would make other parts of gigi think
- we are dealing with a really incomplete or private type, and have
- nasty side effects, typically on the generation of the associated
- debugging information. */
- gnu_type = make_dummy_type (gnat_entity);
- TYPE_DUMMY_P (gnu_type) = 0;
-
- if (TREE_CODE (TYPE_NAME (gnu_type)) == TYPE_DECL && debug_info_p)
- DECL_IGNORED_P (TYPE_NAME (gnu_type)) = 0;
-
+ suppress expanding incomplete types. */
+ gnu_type = make_node (tree_code_for_record_type (gnat_entity));
+ TYPE_NAME (gnu_type) = gnu_entity_id;
+ /* ??? We should have create_type_decl like in the E_Record_Subtype
+ case below. Unfortunately this would cause GNU_TYPE to be marked
+ as visited, thus precluding the subtrees of the type that will be
+ built below from being marked as visited when the real TYPE_DECL
+ is eventually created. A solution could be to devise a special
+ version of the function under the name create_type_stub_decl. */
+ TYPE_STUB_DECL (gnu_type)
+ = build_decl (TYPE_DECL, NULL_TREE, gnu_type);
TYPE_ALIGN (gnu_type) = 0;
TYPE_PACKED (gnu_type) = packed || has_rep;
case E_General_Access_Type:
{
Entity_Id gnat_desig_type = Directly_Designated_Type (gnat_entity);
+ /* Get the "full view" of this entity. If this is an incomplete
+ entity from a limited with, treat its non-limited view as the
+ full view. Otherwise, if this is an incomplete or private
+ type, use the full view. */
Entity_Id gnat_desig_full
- = ((IN (Ekind (Etype (gnat_desig_type)),
- Incomplete_Or_Private_Kind))
- ? Full_View (gnat_desig_type) : 0);
+ = (IN (Ekind (gnat_desig_type), Incomplete_Kind)
+ && From_With_Type (gnat_desig_type))
+ ? Non_Limited_View (gnat_desig_type)
+ : IN (Ekind (gnat_desig_type), Incomplete_Or_Private_Kind)
+ ? Full_View (gnat_desig_type)
+ : Empty;
/* We want to know if we'll be seeing the freeze node for any
incomplete type we may be pointing to. */
bool in_main_unit
&& defer_incomplete_level
&& !present_gnu_tree (gnat_desig_type)
&& Is_Array_Type (gnat_desig_type)
+ && ! Is_Constrained (gnat_desig_type))
+ || (in_main_unit && From_With_Type (gnat_entity)
+ && (Present (gnat_desig_full)
+ ? Present (Freeze_Node (gnat_desig_full))
+ : Present (Freeze_Node (gnat_desig_type)))
+ && Is_Array_Type (gnat_desig_type)
&& !Is_Constrained (gnat_desig_type)))
{
tree gnu_old
gnu_desig_type = make_dummy_type (gnat_desig_type);
made_dummy = true;
}
+
+ /* If this is a reference from a limited_with type back to our
+ main unit and there's a Freeze_Node for it, either we have
+ already processed the declaration and made the dummy type,
+ in which case we just reuse the latter, or we have not yet,
+ in which case we make the dummy type and it will be reused
+ when the declaration is processed. In both cases, the pointer
+ eventually created below will be automatically adjusted when
+ the Freeze_Node is processed. Note that the unconstrained
+ array case is handled above. */
+ else if (in_main_unit && From_With_Type (gnat_entity)
+ && (Present (gnat_desig_full)
+ ? Present (Freeze_Node (gnat_desig_full))
+ : Present (Freeze_Node (gnat_desig_type))))
+ {
+ gnu_desig_type = make_dummy_type (gnat_desig_type);
+ made_dummy = true;
+ }
+
else if (gnat_desig_type == gnat_entity)
{
gnu_type
No_Strict_Aliasing (gnat_entity));
TREE_TYPE (gnu_type) = TYPE_POINTER_TO (gnu_type) = gnu_type;
}
+
else
gnu_desig_type = gnat_to_gnu_type (gnat_desig_type);
if (type_annotate_only && No (Equivalent_Type (gnat_entity)))
gnu_type = build_pointer_type (void_type_node);
else
- /* The runtime representation is the equivalent type. */
- gnu_type = gnat_to_gnu_type (Equivalent_Type (gnat_entity));
+ {
+ /* The runtime representation is the equivalent type. */
+ gnu_type = gnat_to_gnu_type (Equivalent_Type (gnat_entity));
+ maybe_present = 1;
+ }
if (Is_Itype (Directly_Designated_Type (gnat_entity))
&& !present_gnu_tree (Directly_Designated_Type (gnat_entity))
gnu_expr, 0);
/* Elaborate any Itypes in the parameters of this entity. */
- for (gnat_temp = First_Formal (gnat_entity);
+ for (gnat_temp = First_Formal_With_Extras (gnat_entity);
Present (gnat_temp);
gnat_temp = Next_Formal_With_Extras (gnat_temp))
if (Is_Itype (Etype (gnat_temp)))
else if (kind == E_Function
&& Mechanism (gnat_entity) == By_Reference)
{
- gnu_return_type = copy_type (gnu_return_type);
TREE_ADDRESSABLE (gnu_return_type) = 1;
+
+ /* We expect this bit to be reset by gigi shortly, so can avoid a
+ type node copy here. This actually also prevents troubles with
+ the generation of debug information for the function, because
+ we might have issued such info for this type already, and would
+ be attaching a distinct type node to the function if we made a
+ copy here. */
}
/* If we are supposed to return an unconstrained array,
each. While doing this, build a copy-out structure if
we need one. */
- for (gnat_param = First_Formal (gnat_entity), parmnum = 0;
+ for (gnat_param = First_Formal_With_Extras (gnat_entity), parmnum = 0;
Present (gnat_param);
gnat_param = Next_Formal_With_Extras (gnat_param), parmnum++)
{
break;
case E_Incomplete_Type:
+ case E_Incomplete_Subtype:
case E_Private_Type:
- case E_Limited_Private_Type:
- case E_Record_Type_With_Private:
case E_Private_Subtype:
+ case E_Limited_Private_Type:
case E_Limited_Private_Subtype:
+ case E_Record_Type_With_Private:
case E_Record_Subtype_With_Private:
-
- /* If this type does not have a full view in the unit we are
- compiling, then just get the type from its Etype. */
- if (No (Full_View (gnat_entity)))
- {
- /* If this is an incomplete type with no full view, it must be
- either a limited view brought in by a limited_with clause, in
- which case we use the non-limited view, or a Taft Amendement
- type, in which case we just return a dummy type. */
- if (kind == E_Incomplete_Type)
- {
- if (From_With_Type (gnat_entity)
- && Present (Non_Limited_View (gnat_entity)))
- gnu_decl = gnat_to_gnu_entity (Non_Limited_View (gnat_entity),
+ {
+ /* Get the "full view" of this entity. If this is an incomplete
+ entity from a limited with, treat its non-limited view as the
+ full view. Otherwise, use either the full view or the underlying
+ full view, whichever is present. This is used in all the tests
+ below. */
+ Entity_Id full_view
+ = (IN (Ekind (gnat_entity), Incomplete_Kind)
+ && From_With_Type (gnat_entity))
+ ? Non_Limited_View (gnat_entity)
+ : Present (Full_View (gnat_entity))
+ ? Full_View (gnat_entity)
+ : Underlying_Full_View (gnat_entity);
+
+ /* If this is an incomplete type with no full view, it must be a Taft
+ Amendment type, in which case we return a dummy type. Otherwise,
+ just get the type from its Etype. */
+ if (No (full_view))
+ {
+ if (kind == E_Incomplete_Type)
+ gnu_type = make_dummy_type (gnat_entity);
+ else
+ {
+ gnu_decl = gnat_to_gnu_entity (Etype (gnat_entity),
NULL_TREE, 0);
- else
- gnu_type = make_dummy_type (gnat_entity);
- }
-
- else if (Present (Underlying_Full_View (gnat_entity)))
- gnu_decl = gnat_to_gnu_entity (Underlying_Full_View (gnat_entity),
- NULL_TREE, 0);
- else
- {
- gnu_decl = gnat_to_gnu_entity (Etype (gnat_entity),
- NULL_TREE, 0);
- maybe_present = true;
- }
-
- break;
- }
+ maybe_present = true;
+ }
+ break;
+ }
- /* Otherwise, if we are not defining the type now, get the
- type from the full view. But always get the type from the full
- view for define on use types, since otherwise we won't see them! */
+ /* If we already made a type for the full view, reuse it. */
+ else if (present_gnu_tree (full_view))
+ {
+ gnu_decl = get_gnu_tree (full_view);
+ break;
+ }
- else if (!definition
- || (Is_Itype (Full_View (gnat_entity))
+ /* Otherwise, if we are not defining the type now, get the type
+ from the full view. But always get the type from the full view
+ for define on use types, since otherwise we won't see them! */
+ else if (!definition
+ || (Is_Itype (full_view)
&& No (Freeze_Node (gnat_entity)))
- || (Is_Itype (gnat_entity)
- && No (Freeze_Node (Full_View (gnat_entity)))))
- {
- gnu_decl = gnat_to_gnu_entity (Full_View (gnat_entity),
- NULL_TREE, 0);
- maybe_present = true;
- break;
- }
+ || (Is_Itype (gnat_entity)
+ && No (Freeze_Node (full_view))))
+ {
+ gnu_decl = gnat_to_gnu_entity (full_view, NULL_TREE, 0);
+ maybe_present = true;
+ break;
+ }
- /* For incomplete types, make a dummy type entry which will be
- replaced later. */
- gnu_type = make_dummy_type (gnat_entity);
+ /* For incomplete types, make a dummy type entry which will be
+ replaced later. */
+ gnu_type = make_dummy_type (gnat_entity);
- /* Save this type as the full declaration's type so we can do any needed
- updates when we see it. */
- gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
- !Comes_From_Source (gnat_entity),
- debug_info_p, gnat_entity);
- save_gnu_tree (Full_View (gnat_entity), gnu_decl, false);
- break;
+ /* Save this type as the full declaration's type so we can do any
+ needed updates when we see it. */
+ gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
+ !Comes_From_Source (gnat_entity),
+ debug_info_p, gnat_entity);
+ save_gnu_tree (full_view, gnu_decl, 0);
+ break;
+ }
/* Simple class_wide types are always viewed as their root_type
by Gigi unless an Equivalent_Type is specified. */
return gnu_list;
}
\f
-/* For the following two functions: for each GNAT entity, the GCC
- tree node used as a dummy for that entity, if any. */
-
-static GTY((length ("max_gnat_nodes"))) tree * dummy_node_table;
-
-/* Initialize the above table. */
-
-void
-init_dummy_type (void)
-{
- Node_Id gnat_node;
-
- dummy_node_table = (tree *) ggc_alloc (max_gnat_nodes * sizeof (tree));
-
- for (gnat_node = 0; gnat_node < max_gnat_nodes; gnat_node++)
- dummy_node_table[gnat_node] = NULL_TREE;
-
- dummy_node_table -= First_Node_Id;
-}
-
-/* Make a dummy type corresponding to GNAT_TYPE. */
-
-tree
-make_dummy_type (Entity_Id gnat_type)
-{
- Entity_Id gnat_underlying;
- tree gnu_type;
- enum tree_code code;
-
- /* Find a full type for GNAT_TYPE, taking into account any class wide
- types. */
- if (Is_Class_Wide_Type (gnat_type) && Present (Equivalent_Type (gnat_type)))
- gnat_type = Equivalent_Type (gnat_type);
- else if (Ekind (gnat_type) == E_Class_Wide_Type)
- gnat_type = Root_Type (gnat_type);
-
- for (gnat_underlying = gnat_type;
- (IN (Ekind (gnat_underlying), Incomplete_Or_Private_Kind)
- && Present (Full_View (gnat_underlying)));
- gnat_underlying = Full_View (gnat_underlying))
- ;
-
- /* If it there already a dummy type, use that one. Else make one. */
- if (dummy_node_table[gnat_underlying])
- return dummy_node_table[gnat_underlying];
-
- /* If this is a record, make this a RECORD_TYPE or UNION_TYPE; else make
- it an ENUMERAL_TYPE. */
- if (Is_Record_Type (gnat_underlying))
- {
- Node_Id component_list
- = Component_List (Type_Definition
- (Declaration_Node
- (Implementation_Base_Type (gnat_underlying))));
- Node_Id component;
-
- /* Make this a UNION_TYPE unless it's either not an Unchecked_Union or
- we have a non-discriminant field outside a variant. In either case,
- it's a RECORD_TYPE. */
- code = UNION_TYPE;
- if (!Is_Unchecked_Union (gnat_underlying))
- code = RECORD_TYPE;
- else
- for (component = First_Non_Pragma (Component_Items (component_list));
- Present (component); component = Next_Non_Pragma (component))
- if (Ekind (Defining_Entity (component)) == E_Component)
- code = RECORD_TYPE;
- }
- else
- code = ENUMERAL_TYPE;
-
- gnu_type = make_node (code);
- TYPE_NAME (gnu_type) = get_entity_name (gnat_type);
- TYPE_DUMMY_P (gnu_type) = 1;
- if (AGGREGATE_TYPE_P (gnu_type))
- TYPE_STUB_DECL (gnu_type) = build_decl (TYPE_DECL, NULL_TREE, gnu_type);
-
- dummy_node_table[gnat_underlying] = gnu_type;
-
- return gnu_type;
-}
-\f
/* Return true if the size represented by GNU_SIZE can be handled by an
allocation. If STATIC_P is true, consider only what can be done with a
static allocation. */
expr_variable = (!CONSTANT_CLASS_P (gnu_expr)
&& !(TREE_CODE (gnu_inner_expr) == VAR_DECL
- && TREE_READONLY (gnu_inner_expr))
+ && (TREE_READONLY (gnu_inner_expr)
+ || DECL_READONLY_ONCE_ELAB (gnu_inner_expr)))
&& !CONTAINS_PLACEHOLDER_P (gnu_expr));
/* If this is a static expression or contains a discriminant, we don't
strcpy (Name_Buffer + len, suffix);
return get_identifier (Name_Buffer);
}
-
-#include "gt-ada-decl.h"
extern GTY(()) tree gnat_std_decls[(int) ADT_LAST];
extern GTY(()) tree gnat_raise_decls[(int) LAST_REASON_CODE + 1];
-extern GTY(()) tree static_ctors;
-extern GTY(()) tree static_dtors;
-
#define longest_float_type_node gnat_std_decls[(int) ADT_longest_float_type]
#define void_type_decl_node gnat_std_decls[(int) ADT_void_type_decl]
#define except_type_node gnat_std_decls[(int) ADT_except_type]
an unsigned type; otherwise a signed type is returned. */
extern tree gnat_type_for_mode (enum machine_mode mode, int unsignedp);
+/* Emit debug info for all global variable declarations. */
+extern void gnat_write_global_declarations (void);
+
/* Return the unsigned version of a TYPE_NODE, a scalar type. */
extern tree gnat_unsigned_type (tree type_node);
bool artificial_p, bool debug_info_p,
Node_Id gnat_node);
-/* Returns a GCC VAR_DECL node. VAR_NAME gives the name of the variable.
- ASM_NAME is its assembler name (if provided). TYPE is
- its data type (a GCC ..._TYPE node). VAR_INIT is the GCC tree for an
- optional initial expression; NULL_TREE if none.
+/* Returns a GCC VAR_DECL or CONST_DECL node.
+
+ VAR_NAME gives the name of the variable. ASM_NAME is its assembler name
+ (if provided). TYPE is its data type (a GCC ..._TYPE node). VAR_INIT is
+ the GCC tree for an optional initial expression; NULL_TREE if none.
CONST_FLAG is true if this variable is constant.
bool static_flag,
struct attrib *attr_list, Node_Id gnat_node);
+/* Similar to create_var_decl, forcing the creation of a VAR_DECL node. */
+extern tree create_true_var_decl (tree var_name, tree asm_name, tree type,
+ tree var_init, bool const_flag,
+ bool public_flag, bool extern_flag,
+ bool static_flag,
+ struct attrib *attr_list, Node_Id gnat_node);
+
/* Given a DECL and ATTR_LIST, apply the listed attributes. */
extern void process_attributes (tree decl, struct attrib *attr_list);
+/* Record a global renaming pointer. */
+void record_global_renaming_pointer (tree);
+
+/* Invalidate the global renaming pointers. */
+void invalidate_global_renaming_pointers (void);
+
/* Returns a FIELD_DECL node. FIELD_NAME the field name, FIELD_TYPE is its
type, and RECORD_TYPE is the type of the parent. PACKED is nonzero if
this field is in a record type with a "pragma pack". If SIZE is nonzero
If NOTRUNC_P is true, truncation operations should be suppressed. */
extern tree unchecked_convert (tree type, tree expr, bool notrunc_p);
+/* Return the appropriate GCC tree code for the specified GNAT type,
+ the latter being a record type as predicated by Is_Record_Type. */
+extern enum tree_code tree_code_for_record_type (Entity_Id);
+
/* Prepare expr to be an argument of a TRUTH_NOT_EXPR or other logical
operation.
#define LANG_HOOKS_GETDECLS lhd_return_null_tree_v
#undef LANG_HOOKS_PUSHDECL
#define LANG_HOOKS_PUSHDECL lhd_return_tree
+#undef LANG_HOOKS_WRITE_GLOBALS
+#define LANG_HOOKS_WRITE_GLOBALS gnat_write_global_declarations
#undef LANG_HOOKS_FINISH_INCOMPLETE_DECL
#define LANG_HOOKS_FINISH_INCOMPLETE_DECL gnat_finish_incomplete_decl
#undef LANG_HOOKS_REDUCE_BIT_FIELD_OPERATIONS
{
int seh[2];
- /* call the target specific initializations */
+ /* Call the target specific initializations. */
__gnat_initialize (NULL);
- /* ??? call the SEH initialization routine, this is to workaround a
- bootstrap path problem. The call below should be removed at some point and
- the seh pointer passed to __gnat_initialize() above. */
-
+ /* ??? Call the SEH initialization routine. This is to workaround
+ a bootstrap path problem. The call below should be removed at some
+ point and the SEH pointer passed to __gnat_initialize() above. */
__gnat_install_SEH_handler((void *)seh);
- /* Call the front-end elaboration procedures */
+ /* Call the front-end elaboration procedures. */
adainit ();
- /* Call the front end */
+ /* Call the front end. */
_ada_gnat1drv ();
+ /* We always have a single compilation unit in Ada. */
cgraph_finalize_compilation_unit ();
- cgraph_optimize ();
}
/* Decode all the language specific options that cannot be decoded by GCC.
if (flag_inline_functions)
flag_inline_trees = 2;
+ /* The structural alias analysis machinery essentially assumes that
+ everything is addressable (modulo bit-fields) by disregarding
+ the TYPE_NONALIASED_COMPONENT and DECL_NONADDRESSABLE_P macros. */
flag_tree_salias = 0;
return false;
&& TYPE_ADA_SIZE (gnu_type))
{
tree max_adasize = max_size (TYPE_ADA_SIZE (gnu_type), true);
-
+
/* If we have succeded in finding a constant, round it up to the
type's alignment and return the result in byte units. */
static void start_stmt_group (void);
static void add_cleanup (tree);
static tree mark_visited (tree *, int *, void *);
-static tree mark_unvisited (tree *, int *, void *);
+static tree unshare_save_expr (tree *, int *, void *);
static tree end_stmt_group (void);
static void add_stmt_list (List_Id);
static tree build_stmt_group (List_Id, bool);
static tree maybe_implicit_deref (tree);
static tree gnat_stabilize_reference_1 (tree, bool);
static void annotate_with_node (tree, Node_Id);
-static void build_global_cdtor (int, tree *);
\f
/* This is the main program of the back-end. It sets up all the table
tree gnu_body = DECL_SAVED_TREE (info->elab_proc);
tree gnu_stmts;
- /* Mark everything we have as not visited. */
- walk_tree_without_duplicates (&gnu_body, mark_unvisited, NULL);
+ /* Unshare SAVE_EXPRs between subprograms. These are not unshared by
+ the gimplifier for obvious reasons, but it turns out that we need to
+ unshare them for the global level because of SAVE_EXPRs made around
+ checks for global objects and around allocators for global objects
+ of variable size, in order to prevent node sharing in the underlying
+ expression. Note that this implicitly assumes that the SAVE_EXPR
+ nodes themselves are not shared between subprograms, which would be
+ an upstream bug for which we would not change the outcome. */
+ walk_tree_without_duplicates (&gnu_body, unshare_save_expr, NULL);
/* Set the current function to be the elaboration procedure and gimplify
what we have. */
handler, only if it is referenced in the handler and declared in an
enclosing block, but we have no way of testing that right now.
- ??? Also, for now all we can do is make it volatile. But we only
- do this for SJLJ. */
+ ??? We used to essentially set the TREE_ADDRESSABLE flag on the variable
+ here, but it can now be removed by the Tree aliasing machinery if the
+ address of the variable is never taken. All we can do is to make the
+ variable volatile, which might incur the generation of temporaries just
+ to access the memory in some circumstances. This can be avoided for
+ variables of non-constant size because they are automatically allocated
+ to memory. There might be no way of allocating a proper temporary for
+ them in any case. We only do this for SJLJ though. */
if (TREE_VALUE (gnu_except_ptr_stack)
- && TREE_CODE (gnu_result) == VAR_DECL)
+ && TREE_CODE (gnu_result) == VAR_DECL
+ && TREE_CODE (DECL_SIZE_UNIT (gnu_result)) == INTEGER_CST)
TREE_THIS_VOLATILE (gnu_result) = TREE_SIDE_EFFECTS (gnu_result) = 1;
/* Some objects (such as parameters passed by reference, globals of
== Attr_Unchecked_Access)
|| (Get_Attribute_Id (Attribute_Name (gnat_temp))
== Attr_Unrestricted_Access)))))
- {
- gnu_result = DECL_INITIAL (gnu_result);
- /* ??? The mark/unmark mechanism implemented in Gigi to prevent tree
- sharing between global level and subprogram level doesn't apply
- to elaboration routines. As a result, the DECL_INITIAL tree may
- be shared between the static initializer of a global object and
- the elaboration routine, thus wreaking havoc if a local temporary
- is created in place during gimplification of the latter and the
- former is emitted afterwards. Manually unshare for now. */
- if (TREE_VISITED (gnu_result))
- gnu_result = unshare_expr (gnu_result);
- }
+ gnu_result = DECL_INITIAL (gnu_result);
}
*gnu_result_type_p = gnu_result_type;
gnu_result_type = get_unpadded_type (Etype (gnat_node));
prefix_unused = true;
- if (TREE_CODE (gnu_prefix) == COMPONENT_REF)
- gnu_result = size_int (DECL_ALIGN (TREE_OPERAND (gnu_prefix, 1)));
- else
- gnu_result = size_int (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT);
+ gnu_result = size_int ((TREE_CODE (gnu_prefix) == COMPONENT_REF
+ ? DECL_ALIGN (TREE_OPERAND (gnu_prefix, 1))
+ : TYPE_ALIGN (gnu_type)) / BITS_PER_UNIT);
break;
case Attr_First:
gnat_when = Next_Non_Pragma (gnat_when))
{
Node_Id gnat_choice;
+ int choices_added = 0;
/* First compile all the different case choices for the current WHEN
alternative. */
gcc_unreachable ();
}
- add_stmt_with_node (build3 (CASE_LABEL_EXPR, void_type_node,
- gnu_low, gnu_high,
- create_artificial_label ()),
- gnat_choice);
+ /* If the case value is a subtype that raises Constraint_Error at
+ run-time because of a wrong bound, then gnu_low or gnu_high
+ is not transtaleted into an INTEGER_CST. In such a case, we need
+ to ensure that the when statement is not added in the tree,
+ otherwise it will crash the gimplifier. */
+ if ((!gnu_low || TREE_CODE (gnu_low) == INTEGER_CST)
+ && (!gnu_high || TREE_CODE (gnu_high) == INTEGER_CST))
+ {
+
+ add_stmt_with_node (build3 (CASE_LABEL_EXPR, void_type_node,
+ gnu_low, gnu_high,
+ create_artificial_label ()),
+ gnat_choice);
+ choices_added++;
+ }
}
/* Push a binding level here in case variables are declared since we want
- them to be local to this set of statements instead of the block
- containing the Case statement. */
- add_stmt (build_stmt_group (Statements (gnat_when), true));
- add_stmt (build1 (GOTO_EXPR, void_type_node,
- TREE_VALUE (gnu_switch_label_stack)));
+ them to be local to this set of statements instead of the block
+ containing the Case statement. */
+
+ if (choices_added > 0)
+ {
+ add_stmt (build_stmt_group (Statements (gnat_when), true));
+ add_stmt (build1 (GOTO_EXPR, void_type_node,
+ TREE_VALUE (gnu_switch_label_stack)));
+ }
}
/* Now emit a definition of the label all the cases branched to. */
nodes here. Fill them in to TYPE_CI_CO_LIST, which must contain the empty
entry as well. We can match up the entries because TYPE_CI_CO_LIST is in
the order of the parameters. */
- for (gnat_param = First_Formal (gnat_subprog_id);
+ for (gnat_param = First_Formal_With_Extras (gnat_subprog_id);
Present (gnat_param);
gnat_param = Next_Formal_With_Extras (gnat_param))
if (!present_gnu_tree (gnat_param))
/* Disconnect the trees for parameters that we made variables for from the
GNAT entities since these are unusable after we end the function. */
- for (gnat_param = First_Formal (gnat_subprog_id);
+ for (gnat_param = First_Formal_With_Extras (gnat_subprog_id);
Present (gnat_param);
gnat_param = Next_Formal_With_Extras (gnat_param))
if (TREE_CODE (get_gnu_tree (gnat_param)) == VAR_DECL)
type the access type is pointing to. Otherwise, get the formals from
entity being called. */
if (Nkind (Name (gnat_node)) == N_Explicit_Dereference)
- gnat_formal = First_Formal (Etype (Name (gnat_node)));
+ gnat_formal = First_Formal_With_Extras (Etype (Name (gnat_node)));
else if (Nkind (Name (gnat_node)) == N_Attribute_Reference)
/* Assume here that this must be 'Elab_Body or 'Elab_Spec. */
gnat_formal = 0;
else
- gnat_formal = First_Formal (Entity (Name (gnat_node)));
+ gnat_formal = First_Formal_With_Extras (Entity (Name (gnat_node)));
/* Create the list of the actual parameters as GCC expects it, namely a chain
of TREE_LIST nodes in which the TREE_VALUE field of each node is a
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
would allocate temporaries at will because of the
misalignment if we did not do so here. */
- if (Is_Valued_Procedure (Entity (Name (gnat_node))))
+ else if (Is_Valued_Procedure (Entity (Name (gnat_node))))
{
post_error
("?possible violation of implicit assumption",
&& !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
since arguments don't know that they will be passed by ref. */
gnu_formal_type = TREE_TYPE (get_gnu_tree (gnat_formal));
}
if (Nkind (Name (gnat_node)) == N_Explicit_Dereference)
- gnat_formal = First_Formal (Etype (Name (gnat_node)));
+ gnat_formal = First_Formal_With_Extras (Etype (Name (gnat_node)));
else
- gnat_formal = First_Formal (Entity (Name (gnat_node)));
+ gnat_formal = First_Formal_With_Extras (Entity (Name (gnat_node)));
for (gnat_actual = First_Actual (gnat_node);
Present (gnat_actual);
: build_component_ref (gnu_subprog_call, NULL_TREE,
TREE_PURPOSE (scalar_return_list),
false);
- bool unchecked_conversion = (Nkind (gnat_actual)
- == N_Unchecked_Type_Conversion);
+
/* If the actual is a conversion, get the inner expression, which
will be the real destination, and convert the result to the
type of the actual parameter. */
(TREE_TYPE (gnu_result))),
gnu_result);
- /* If the result is a type conversion, do it. */
+ /* If the actual is a type conversion, the real target object is
+ denoted by the inner Expression and we need to convert the
+ result to the associated type.
+
+ We also need to convert our gnu assignment target to this type
+ if the corresponding gnu_name was constructed from the GNAT
+ conversion node and not from the inner Expression. */
if (Nkind (gnat_actual) == N_Type_Conversion)
- gnu_result
- = convert_with_check
- (Etype (Expression (gnat_actual)), gnu_result,
- Do_Overflow_Check (gnat_actual),
- Do_Range_Check (Expression (gnat_actual)),
- Float_Truncate (gnat_actual));
+ {
+ gnu_result
+ = convert_with_check
+ (Etype (Expression (gnat_actual)), gnu_result,
+ Do_Overflow_Check (gnat_actual),
+ Do_Range_Check (Expression (gnat_actual)),
+ Float_Truncate (gnat_actual));
+
+ if (!Is_Composite_Type
+ (Underlying_Type (Etype (gnat_formal))))
+ gnu_actual
+ = convert (TREE_TYPE (gnu_result), gnu_actual);
+ }
- else if (unchecked_conversion)
+ /* Unchecked conversions as actuals for out parameters are not
+ allowed in user code because they are not variables, but do
+ occur in front-end expansions. The associated gnu_name is
+ always obtained from the inner expression in such cases. */
+ else if (Nkind (gnat_actual) == N_Unchecked_Type_Conversion)
gnu_result = unchecked_convert (TREE_TYPE (gnu_actual),
gnu_result,
No_Truncation (gnat_actual));
gnat_pushlevel ();
}
- /* If we are to call a function when exiting this block add a cleanup
- to the binding level we made above. */
- if (at_end)
- add_cleanup (build_call_0_expr (gnat_to_gnu (At_End_Proc (gnat_node))));
-
/* If using setjmp_longjmp, make the variables for the setjmp buffer and save
area for address of previous buffer. Do this first since we need to have
the setjmp buf known for any decls in this block. */
add_cleanup (build_call_1_expr (set_jmpbuf_decl, gnu_jmpsave_decl));
}
+ /* If we are to call a function when exiting this block, add a cleanup
+ to the binding level we made above. Note that add_cleanup is FIFO
+ so we must register this cleanup after the EH cleanup just above. */
+ if (at_end)
+ add_cleanup (build_call_0_expr (gnat_to_gnu (At_End_Proc (gnat_node))));
+
/* Now build the tree for the declarations and statements inside this block.
If this is SJLJ, set our jmp_buf as the current buffer. */
start_stmt_group ();
process_inlined_subprograms (gnat_node);
- if (type_annotate_only)
+ if (type_annotate_only && gnat_node == Cunit (Main_Unit))
{
elaborate_all_entities (gnat_node);
we did or not. */
pop_stack (&gnu_elab_proc_stack);
- /* Generate functions to call static constructors and destructors
- for targets that do not support .ctors/.dtors sections. These
- functions have magic names which are detected by collect2. */
- if (static_ctors)
- build_global_cdtor ('I', &static_ctors);
-
- if (static_dtors)
- build_global_cdtor ('D', &static_dtors);
+ /* Invalidate the global renaming pointers. This is necessary because
+ stabilization of the renamed entities may create SAVE_EXPRs which
+ have been tied to a specific elaboration routine just above. */
+ invalidate_global_renaming_pointers ();
}
\f
/* This function is the driver of the GNAT to GCC tree transformation
case N_And_Then: case N_Or_Else:
{
enum tree_code code = gnu_codes[Nkind (gnat_node)];
+ bool ignore_lhs_overflow = false;
tree gnu_type;
gnu_lhs = gnat_to_gnu (Left_Opnd (gnat_node));
}
/* For right shifts, the type says what kind of shift to do,
- so we may need to choose a different type. */
+ so we may need to choose a different type. In this case,
+ we have to ignore integer overflow lest it propagates all
+ the way down and causes a CE to be explicitly raised. */
if (Nkind (gnat_node) == N_Op_Shift_Right
&& !TYPE_UNSIGNED (gnu_type))
- gnu_type = gnat_unsigned_type (gnu_type);
+ {
+ gnu_type = gnat_unsigned_type (gnu_type);
+ ignore_lhs_overflow = true;
+ }
else if (Nkind (gnat_node) == N_Op_Shift_Right_Arithmetic
&& TYPE_UNSIGNED (gnu_type))
- gnu_type = gnat_signed_type (gnu_type);
+ {
+ gnu_type = gnat_signed_type (gnu_type);
+ ignore_lhs_overflow = true;
+ }
if (gnu_type != gnu_result_type)
{
+ tree gnu_old_lhs = gnu_lhs;
gnu_lhs = convert (gnu_type, gnu_lhs);
+ if (TREE_CODE (gnu_lhs) == INTEGER_CST && ignore_lhs_overflow)
+ {
+ TREE_OVERFLOW (gnu_lhs) = TREE_OVERFLOW (gnu_old_lhs);
+ TREE_CONSTANT_OVERFLOW (gnu_lhs)
+ = TREE_CONSTANT_OVERFLOW (gnu_old_lhs);
+ }
gnu_rhs = convert (gnu_type, gnu_rhs);
}
case N_Abstract_Subprogram_Declaration:
/* This subprogram doesn't exist for code generation purposes, but we
- have to elaborate the types of any parameters, unless they are
- imported types (nothing to generate in this case). */
+ have to elaborate the types of any parameters and result, unless
+ they are imported types (nothing to generate in this case). */
+
+ /* Process the parameter types first. */
+
for (gnat_temp
- = First_Formal (Defining_Entity (Specification (gnat_node)));
+ = First_Formal_With_Extras
+ (Defining_Entity (Specification (gnat_node)));
Present (gnat_temp);
gnat_temp = Next_Formal_With_Extras (gnat_temp))
if (Is_Itype (Etype (gnat_temp))
&& !From_With_Type (Etype (gnat_temp)))
gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, 0);
+
+ /* Then the result type, set to Standard_Void_Type for procedures. */
+
+ {
+ Entity_Id gnat_temp_type
+ = Etype (Defining_Entity (Specification (gnat_node)));
+
+ if (Is_Itype (gnat_temp_type) && !From_With_Type (gnat_temp_type))
+ gnat_to_gnu_entity (Etype (gnat_temp_type), NULL_TREE, 0);
+ }
+
gnu_result = alloc_stmt_list ();
break;
if (!type_annotate_only)
{
tree gnu_template = gnat_to_gnu (Asm_Template (gnat_node));
- tree gnu_input_list = NULL_TREE, gnu_output_list = NULL_TREE;
- tree gnu_clobber_list = NULL_TREE;
+ tree gnu_inputs = NULL_TREE, gnu_outputs = NULL_TREE;
+ tree gnu_clobbers = NULL_TREE, tail;
+ bool allows_mem, allows_reg, fake;
+ int ninputs, noutputs, i;
+ const char **oconstraints;
+ const char *constraint;
char *clobber;
- /* First process inputs, then outputs, then clobbers. */
- Setup_Asm_Inputs (gnat_node);
- while (Present (gnat_temp = Asm_Input_Value ()))
+ /* First retrieve the 3 operand lists built by the front-end. */
+ Setup_Asm_Outputs (gnat_node);
+ while (Present (gnat_temp = Asm_Output_Variable ()))
{
tree gnu_value = gnat_to_gnu (gnat_temp);
tree gnu_constr = build_tree_list (NULL_TREE, gnat_to_gnu
- (Asm_Input_Constraint ()));
+ (Asm_Output_Constraint ()));
- gnu_input_list
- = tree_cons (gnu_constr, gnu_value, gnu_input_list);
- Next_Asm_Input ();
+ gnu_outputs = tree_cons (gnu_constr, gnu_value, gnu_outputs);
+ Next_Asm_Output ();
}
- Setup_Asm_Outputs (gnat_node);
- while (Present (gnat_temp = Asm_Output_Variable ()))
+ Setup_Asm_Inputs (gnat_node);
+ while (Present (gnat_temp = Asm_Input_Value ()))
{
tree gnu_value = gnat_to_gnu (gnat_temp);
tree gnu_constr = build_tree_list (NULL_TREE, gnat_to_gnu
- (Asm_Output_Constraint ()));
+ (Asm_Input_Constraint ()));
- gnu_output_list
- = tree_cons (gnu_constr, gnu_value, gnu_output_list);
- Next_Asm_Output ();
+ gnu_inputs = tree_cons (gnu_constr, gnu_value, gnu_inputs);
+ Next_Asm_Input ();
}
Clobber_Setup (gnat_node);
while ((clobber = Clobber_Get_Next ()))
- gnu_clobber_list
+ gnu_clobbers
= tree_cons (NULL_TREE,
build_string (strlen (clobber) + 1, clobber),
- gnu_clobber_list);
+ gnu_clobbers);
+
+ /* Then perform some standard checking and processing on the
+ operands. In particular, mark them addressable if needed. */
+ gnu_outputs = nreverse (gnu_outputs);
+ noutputs = list_length (gnu_outputs);
+ gnu_inputs = nreverse (gnu_inputs);
+ ninputs = list_length (gnu_inputs);
+ oconstraints
+ = (const char **) alloca (noutputs * sizeof (const char *));
+
+ for (i = 0, tail = gnu_outputs; tail; ++i, tail = TREE_CHAIN (tail))
+ {
+ tree output = TREE_VALUE (tail);
+ constraint
+ = TREE_STRING_POINTER (TREE_VALUE (TREE_PURPOSE (tail)));
+ oconstraints[i] = constraint;
+
+ if (parse_output_constraint (&constraint, i, ninputs, noutputs,
+ &allows_mem, &allows_reg, &fake))
+ {
+ /* If the operand is going to end up in memory,
+ mark it addressable. Note that we don't test
+ allows_mem like in the input case below; this
+ is modelled on the C front-end. */
+ if (!allows_reg
+ && !gnat_mark_addressable (output))
+ output = error_mark_node;
+ }
+ else
+ output = error_mark_node;
+
+ TREE_VALUE (tail) = output;
+ }
+
+ for (i = 0, tail = gnu_inputs; tail; ++i, tail = TREE_CHAIN (tail))
+ {
+ tree input = TREE_VALUE (tail);
+ constraint
+ = TREE_STRING_POINTER (TREE_VALUE (TREE_PURPOSE (tail)));
+
+ if (parse_input_constraint (&constraint, i, ninputs, noutputs,
+ 0, oconstraints,
+ &allows_mem, &allows_reg))
+ {
+ /* If the operand is going to end up in memory,
+ mark it addressable. */
+ if (!allows_reg && allows_mem
+ && !gnat_mark_addressable (input))
+ input = error_mark_node;
+ }
+ else
+ input = error_mark_node;
+
+ TREE_VALUE (tail) = input;
+ }
- gnu_input_list = nreverse (gnu_input_list);
- gnu_output_list = nreverse (gnu_output_list);
gnu_result = build4 (ASM_EXPR, void_type_node,
- gnu_template, gnu_output_list,
- gnu_input_list, gnu_clobber_list);
+ gnu_template, gnu_outputs,
+ gnu_inputs, gnu_clobbers);
ASM_VOLATILE_P (gnu_result) = Is_Asm_Volatile (gnat_node);
}
else
add_stmt (tree gnu_stmt)
{
append_to_statement_list (gnu_stmt, ¤t_stmt_group->stmt_list);
-
- /* If we're at top level, show everything in here is in use in case
- any of it is shared by a subprogram. */
- if (global_bindings_p ())
- walk_tree (&gnu_stmt, mark_visited, NULL, NULL);
-
}
/* Similar, but set the location of GNU_STMT to that of GNAT_NODE. */
&& TREE_CODE (TREE_TYPE (gnu_decl)) == UNCONSTRAINED_ARRAY_TYPE))
return;
+ gnu_stmt = build1 (DECL_EXPR, void_type_node, gnu_decl);
+
/* If we are global, we don't want to actually output the DECL_EXPR for
this decl since we already have evaluated the expressions in the
- sizes and positions as globals and doing it again would be wrong.
- But we do have to mark everything as used. */
- gnu_stmt = build1 (DECL_EXPR, void_type_node, gnu_decl);
- if (!global_bindings_p ())
- add_stmt_with_node (gnu_stmt, gnat_entity);
- else
+ sizes and positions as globals and doing it again would be wrong. */
+ if (global_bindings_p ())
{
+ /* Mark everything as used to prevent node sharing with subprograms.
+ Note that walk_tree knows how to handle TYPE_DECL, but neither
+ VAR_DECL nor CONST_DECL. This appears to be somewhat arbitrary. */
walk_tree (&gnu_stmt, mark_visited, NULL, NULL);
if (TREE_CODE (gnu_decl) == VAR_DECL
|| TREE_CODE (gnu_decl) == CONST_DECL)
walk_tree (&DECL_INITIAL (gnu_decl), mark_visited, NULL, NULL);
}
}
+ else
+ add_stmt_with_node (gnu_stmt, gnat_entity);
/* If this is a DECL_EXPR for a variable with DECL_INITIAL set,
there are two cases we need to handle here. */
= build_binary_op (MODIFY_EXPR, NULL_TREE,
gnu_lhs, DECL_INITIAL (gnu_decl));
- DECL_INITIAL (gnu_decl) = 0;
- TREE_READONLY (gnu_decl) = 0;
+ DECL_INITIAL (gnu_decl) = NULL_TREE;
+ if (TREE_READONLY (gnu_decl))
+ {
+ TREE_READONLY (gnu_decl) = 0;
+ DECL_READONLY_ONCE_ELAB (gnu_decl) = 1;
+ }
annotate_with_locus (gnu_assign_stmt,
DECL_SOURCE_LOCATION (gnu_decl));
add_stmt (gnu_assign_stmt);
return NULL_TREE;
}
-/* Likewise, but to mark as unvisited. */
+/* Utility function to unshare expressions wrapped up in a SAVE_EXPR. */
static tree
-mark_unvisited (tree *tp, int *walk_subtrees ATTRIBUTE_UNUSED,
- void *data ATTRIBUTE_UNUSED)
+unshare_save_expr (tree *tp, int *walk_subtrees ATTRIBUTE_UNUSED,
+ void *data ATTRIBUTE_UNUSED)
{
- TREE_VISITED (*tp) = 0;
+ tree t = *tp;
+
+ if (TREE_CODE (t) == SAVE_EXPR)
+ TREE_OPERAND (t, 0) = unshare_expr (TREE_OPERAND (t, 0));
return NULL_TREE;
}
}
}
\f
-/* Force references to each of the entities in packages GNAT_NODE with's
- so that the debugging information for all of them are identical
- in all clients. Operate recursively on anything it with's, but check
- that we aren't elaborating something more than once. */
-
-/* The reason for this routine's existence is two-fold.
- First, with some debugging formats, notably MDEBUG on SGI
- IRIX, the linker will remove duplicate debugging information if two
- clients have identical debugging information. With the normal scheme
- of elaboration, this does not usually occur, since entities in with'ed
- packages are elaborated on demand, and if clients have different usage
- patterns, the normal case, then the order and selection of entities
- will differ. In most cases however, it seems that linkers do not know
- how to eliminate duplicate debugging information, even if it is
- identical, so the use of this routine would increase the total amount
- of debugging information in the final executable.
-
- Second, this routine is called in type_annotate mode, to compute DDA
- information for types in withed units, for ASIS use */
+/* Force references to each of the entities in packages withed by GNAT_NODE.
+ Operate recursively but check that we aren't elaborating something more
+ than once.
+
+ This routine is exclusively called in type_annotate mode, to compute DDA
+ information for types in withed units, for ASIS use. */
static void
elaborate_all_entities (Node_Id gnat_node)
{
Entity_Id gnat_with_clause, gnat_entity;
- /* Process each unit only once. As we trace the context of all relevant
+ /* Process each unit only once. As we trace the context of all relevant
units transitively, including generic bodies, we may encounter the
- same generic unit repeatedly */
-
+ same generic unit repeatedly. */
if (!present_gnu_tree (gnat_node))
save_gnu_tree (gnat_node, integer_zero_node, true);
- /* Save entities in all context units. A body may have an implicit_with
+ /* Save entities in all context units. A body may have an implicit_with
on its own spec, if the context includes a child unit, so don't save
the spec twice. */
-
for (gnat_with_clause = First (Context_Items (gnat_node));
Present (gnat_with_clause);
gnat_with_clause = Next (gnat_with_clause))
if (Nkind (gnat_with_clause) == N_With_Clause
&& !present_gnu_tree (Library_Unit (gnat_with_clause))
- && Library_Unit (gnat_with_clause) != Library_Unit (Cunit (Main_Unit)))
+ && Library_Unit (gnat_with_clause) != Library_Unit (Cunit (Main_Unit)))
{
elaborate_all_entities (Library_Unit (gnat_with_clause));
&& !IN (Ekind (gnat_entity), Generic_Unit_Kind))
gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
}
- else if (Ekind (Entity (Name (gnat_with_clause))) == E_Generic_Package)
- {
- Node_Id gnat_body
+ else if (Ekind (Entity (Name (gnat_with_clause))) == E_Generic_Package)
+ {
+ Node_Id gnat_body
= Corresponding_Body (Unit (Library_Unit (gnat_with_clause)));
- /* Retrieve compilation unit node of generic body. */
- while (Present (gnat_body)
+ /* Retrieve compilation unit node of generic body. */
+ while (Present (gnat_body)
&& Nkind (gnat_body) != N_Compilation_Unit)
gnat_body = Parent (gnat_body);
- /* If body is available, elaborate its context. */
- if (Present (gnat_body))
- elaborate_all_entities (gnat_body);
- }
+ /* If body is available, elaborate its context. */
+ if (Present (gnat_body))
+ elaborate_all_entities (gnat_body);
+ }
}
- if (Nkind (Unit (gnat_node)) == N_Package_Body && type_annotate_only)
+ if (Nkind (Unit (gnat_node)) == N_Package_Body)
elaborate_all_entities (Library_Unit (gnat_node));
}
\f
&& Ekind (gnat_entity) == E_Subprogram_Type)))
return;
- /* If we have a non-dummy type old tree, we have nothing to do. Unless
- this is the public view of a private type whose full view was not
- delayed, this node was never delayed as it should have been.
- Also allow this to happen for concurrent types since we may have
- frozen both the Corresponding_Record_Type and this type. */
+ /* If we have a non-dummy type old tree, we have nothing to do, except
+ aborting if this is the public view of a private type whose full view was
+ not delayed, as this node was never delayed as it should have been. We
+ let this happen for concurrent types and their Corresponding_Record_Type,
+ however, because each might legitimately be elaborated before it's own
+ freeze node, e.g. while processing the other. */
if (gnu_old
&& !(TREE_CODE (gnu_old) == TYPE_DECL
&& TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old))))
gcc_assert ((IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
&& Present (Full_View (gnat_entity))
&& No (Freeze_Node (Full_View (gnat_entity))))
- || Is_Concurrent_Type (gnat_entity));
+ || Is_Concurrent_Type (gnat_entity)
+ || (IN (Ekind (gnat_entity), Record_Kind)
+ && Is_Concurrent_Record_Type (gnat_entity)));
return;
}
/* There's no good type to use here, so we might as well use
integer_type_node. Note that the form of the check is
- (not (expr >= lo)) or (not (expr >= hi))
+ (not (expr >= lo)) or (not (expr <= hi))
the reason for this slightly convoluted form is that NaN's
are not considered to be in range in the float case. */
return emit_check
pointers. */
if (gnu_old)
{
- if (TREE_CODE (gnu_old) != TYPE_DECL
- || !TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old)))
- {
- /* If this was a withed access type, this is not an error
- and merely indicates we've already elaborated the type
- already. */
- gcc_assert (Is_Type (gnat_entity) && From_With_Type (gnat_entity));
- return;
- }
+ gcc_assert (TREE_CODE (gnu_old) == TYPE_DECL
+ && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old)));
save_gnu_tree (gnat_entity, NULL_TREE, false);
}
TREE_SIDE_EFFECTS (result) |= TREE_SIDE_EFFECTS (e);
return result;
}
-
-/* Build a global constructor or destructor function. METHOD_TYPE gives
- the type of the function and CDTORS points to the list of constructor
- or destructor functions to be invoked. FIXME: Migrate into cgraph. */
-
-static void
-build_global_cdtor (int method_type, tree *cdtors)
-{
- tree body = 0;
-
- for (; *cdtors; *cdtors = TREE_CHAIN (*cdtors))
- {
- tree fn = TREE_VALUE (*cdtors);
- tree fntype = TREE_TYPE (fn);
- tree fnaddr = build1 (ADDR_EXPR, build_pointer_type (fntype), fn);
- tree fncall = build3 (CALL_EXPR, TREE_TYPE (fntype), fnaddr, NULL_TREE,
- NULL_TREE);
- append_to_statement_list (fncall, &body);
- }
-
- cgraph_build_static_cdtor (method_type, body, DEFAULT_INIT_PRIORITY);
-}
\f
extern char *__gnat_to_canonical_file_spec (char *);
#include "tree-inline.h"
#include "tree-gimple.h"
#include "tree-dump.h"
+#include "pointer-set.h"
#include "ada.h"
#include "types.h"
/* Functions to call for each of the possible raise reasons. */
tree gnat_raise_decls[(int) LAST_REASON_CODE + 1];
-/* List of functions called automatically at the beginning and
- end of execution, on targets without .ctors/.dtors sections. */
-tree static_ctors;
-tree static_dtors;
-
/* Forward declarations for handlers of attributes. */
static tree handle_const_attribute (tree *, tree, tree, int, bool *);
static tree handle_nothrow_attribute (tree *, tree, tree, int, bool *);
of `save_gnu_tree' for more info. */
static GTY((length ("max_gnat_nodes"))) tree *associate_gnat_to_gnu;
+#define GET_GNU_TREE(GNAT_ENTITY) \
+ associate_gnat_to_gnu[(GNAT_ENTITY) - First_Node_Id]
+
+#define SET_GNU_TREE(GNAT_ENTITY,VAL) \
+ associate_gnat_to_gnu[(GNAT_ENTITY) - First_Node_Id] = (VAL)
+
+#define PRESENT_GNU_TREE(GNAT_ENTITY) \
+ (associate_gnat_to_gnu[(GNAT_ENTITY) - First_Node_Id] != NULL_TREE)
+
+/* Associates a GNAT entity to a GCC tree node used as a dummy, if any. */
+static GTY((length ("max_gnat_nodes"))) tree *dummy_node_table;
+
+#define GET_DUMMY_NODE(GNAT_ENTITY) \
+ dummy_node_table[(GNAT_ENTITY) - First_Node_Id]
+
+#define SET_DUMMY_NODE(GNAT_ENTITY,VAL) \
+ dummy_node_table[(GNAT_ENTITY) - First_Node_Id] = (VAL)
+
+#define PRESENT_DUMMY_NODE(GNAT_ENTITY) \
+ (dummy_node_table[(GNAT_ENTITY) - First_Node_Id] != NULL_TREE)
+
/* This variable keeps a table for types for each precision so that we only
allocate each of them once. Signed and unsigned types are kept separate.
/* A chain of gnat_binding_level structures awaiting reuse. */
static GTY((deletable)) struct gnat_binding_level *free_binding_level;
+/* An array of global declarations. */
+static GTY(()) VEC (tree,gc) *global_decls;
+
+/* An array of global renaming pointers. */
+static GTY(()) VEC (tree,gc) *global_renaming_pointers;
+
+/* Arrays of functions called automatically at the beginning and
+ end of execution, on targets without .ctors/.dtors sections. */
+static GTY(()) VEC (tree,gc) *static_ctors;
+static GTY(()) VEC (tree,gc) *static_dtors;
+
/* A chain of unused BLOCK nodes. */
static GTY((deletable)) tree free_block_chain;
to something which is a decl. Raise gigi 401 if not. Usually, this
means GNAT_ENTITY is defined twice, but occasionally is due to some
Gigi problem. */
- gcc_assert (!gnu_decl
- || (!associate_gnat_to_gnu[gnat_entity - First_Node_Id]
- && (no_check || DECL_P (gnu_decl))));
- associate_gnat_to_gnu[gnat_entity - First_Node_Id] = gnu_decl;
+ gcc_assert (!(gnu_decl
+ && (PRESENT_GNU_TREE (gnat_entity)
+ || (!no_check && !DECL_P (gnu_decl)))));
+
+ SET_GNU_TREE (gnat_entity, gnu_decl);
}
/* GNAT_ENTITY is a GNAT tree node for a defining identifier.
tree
get_gnu_tree (Entity_Id gnat_entity)
{
- gcc_assert (associate_gnat_to_gnu[gnat_entity - First_Node_Id]);
- return associate_gnat_to_gnu[gnat_entity - First_Node_Id];
+ gcc_assert (PRESENT_GNU_TREE (gnat_entity));
+ return GET_GNU_TREE (gnat_entity);
}
/* Return nonzero if a GCC tree has been associated with GNAT_ENTITY. */
bool
present_gnu_tree (Entity_Id gnat_entity)
{
- return (associate_gnat_to_gnu[gnat_entity - First_Node_Id]) != 0;
+ return PRESENT_GNU_TREE (gnat_entity);
+}
+\f
+/* Initialize the association of GNAT nodes to GCC trees as dummies. */
+
+void
+init_dummy_type (void)
+{
+ dummy_node_table
+ = (tree *) ggc_alloc_cleared (max_gnat_nodes * sizeof (tree));
}
+/* Make a dummy type corresponding to GNAT_TYPE. */
+
+tree
+make_dummy_type (Entity_Id gnat_type)
+{
+ Entity_Id gnat_underlying;
+ tree gnu_type;
+ enum tree_code code;
+
+ /* Find a full type for GNAT_TYPE, taking into account any class wide
+ types. */
+ if (Is_Class_Wide_Type (gnat_type) && Present (Equivalent_Type (gnat_type)))
+ gnat_type = Equivalent_Type (gnat_type);
+ else if (Ekind (gnat_type) == E_Class_Wide_Type)
+ gnat_type = Root_Type (gnat_type);
+
+ /* Find a full view for GNAT_TYPE, looking through any incomplete or
+ private types. */
+ if (IN (Ekind (gnat_type), Incomplete_Kind)
+ && From_With_Type (gnat_type))
+ gnat_underlying = Non_Limited_View (gnat_type);
+ else if (IN (Ekind (gnat_type), Incomplete_Or_Private_Kind)
+ && Present (Full_View (gnat_type)))
+ gnat_underlying = Full_View (gnat_type);
+ else
+ gnat_underlying = gnat_type;
+
+ /* If it there already a dummy type, use that one. Else make one. */
+ if (PRESENT_DUMMY_NODE (gnat_underlying))
+ return GET_DUMMY_NODE (gnat_underlying);
+
+ /* If this is a record, make this a RECORD_TYPE or UNION_TYPE; else make
+ it an ENUMERAL_TYPE. */
+ if (Is_Record_Type (gnat_underlying))
+ code = tree_code_for_record_type (gnat_underlying);
+ else
+ code = ENUMERAL_TYPE;
+
+ gnu_type = make_node (code);
+ TYPE_NAME (gnu_type) = get_entity_name (gnat_type);
+ TYPE_DUMMY_P (gnu_type) = 1;
+ if (AGGREGATE_TYPE_P (gnu_type))
+ TYPE_STUB_DECL (gnu_type) = build_decl (TYPE_DECL, NULL_TREE, gnu_type);
+
+ SET_DUMMY_NODE (gnat_underlying, gnu_type);
+
+ return gnu_type;
+}
\f
/* Return nonzero if we are currently in the global binding level. */
add_decl_expr (decl, gnat_node);
/* Put the declaration on the list. The list of declarations is in reverse
- order. The list will be reversed later. We don't do this for global
- variables. Also, don't put TYPE_DECLs for UNCONSTRAINED_ARRAY_TYPE into
- the list. They will cause trouble with the debugger and aren't needed
+ order. The list will be reversed later. Put global variables in the
+ globals list. Don't put TYPE_DECLs for UNCONSTRAINED_ARRAY_TYPE into the
+ list, as they will cause trouble with the debugger and aren't needed
anyway. */
- if (!global_bindings_p ()
- && (TREE_CODE (decl) != TYPE_DECL
- || TREE_CODE (TREE_TYPE (decl)) != UNCONSTRAINED_ARRAY_TYPE))
+ if (TREE_CODE (decl) != TYPE_DECL
+ || TREE_CODE (TREE_TYPE (decl)) != UNCONSTRAINED_ARRAY_TYPE)
{
- TREE_CHAIN (decl) = BLOCK_VARS (current_binding_level->block);
- BLOCK_VARS (current_binding_level->block) = decl;
+ if (global_bindings_p ())
+ VEC_safe_push (tree, gc, global_decls, decl);
+ else
+ {
+ TREE_CHAIN (decl) = BLOCK_VARS (current_binding_level->block);
+ BLOCK_VARS (current_binding_level->block) = decl;
+ }
}
/* For the declaration of a type, set its name if it either is not already
endlink)),
NULL_TREE, false, true, true, NULL,
Empty);
+ DECL_IS_MALLOC (malloc_decl) = 1;
/* free is a function declaration tree for a function to free memory. */
free_decl
var = true;
}
+ /* The heuristics above might get the alignment wrong.
+ Adjust the obvious case where align is smaller than the
+ alignments necessary for objects of field_type. */
+ if (align < TYPE_ALIGN(field_type))
+ align = TYPE_ALIGN(field_type);
+
/* Make a new field name, if necessary. */
if (var || align != 0)
{
DECL_ARTIFICIAL (type_decl) = artificial_p;
+ if (!TYPE_IS_DUMMY_P (type))
+ gnat_pushdecl (type_decl, gnat_node);
+
process_attributes (type_decl, attr_list);
/* Pass type declaration information to the debugger unless this is an
&& TYPE_IS_DUMMY_P (TREE_TYPE (type))))
rest_of_decl_compilation (type_decl, global_bindings_p (), 0);
- if (!TYPE_IS_DUMMY_P (type))
- gnat_pushdecl (type_decl, gnat_node);
-
return type_decl;
}
-/* Returns a GCC VAR_DECL node. VAR_NAME gives the name of the variable.
- ASM_NAME is its assembler name (if provided). TYPE is its data type
- (a GCC ..._TYPE node). VAR_INIT is the GCC tree for an optional initial
- expression; NULL_TREE if none.
+/* Helper for create_var_decl and create_true_var_decl. Returns a GCC VAR_DECL
+ or CONST_DECL node.
- CONST_FLAG is true if this variable is constant.
+ VAR_NAME gives the name of the variable. ASM_NAME is its assembler name
+ (if provided). TYPE is its data type (a GCC ..._TYPE node). VAR_INIT is
+ the GCC tree for an optional initial expression; NULL_TREE if none.
+
+ CONST_FLAG is true if this variable is constant, in which case we might
+ return a CONST_DECL node unless CONST_DECL_ALLOWED_FLAG is false.
PUBLIC_FLAG is true if this definition is to be made visible outside of
the current compilation unit. This flag should be set when processing the
GNAT_NODE is used for the position of the decl. */
-tree
-create_var_decl (tree var_name, tree asm_name, tree type, tree var_init,
- bool const_flag, bool public_flag, bool extern_flag,
- bool static_flag, struct attrib *attr_list, Node_Id gnat_node)
+static tree
+create_var_decl_1 (tree var_name, tree asm_name, tree type, tree var_init,
+ bool const_flag, bool const_decl_allowed_flag,
+ bool public_flag, bool extern_flag, bool static_flag,
+ struct attrib *attr_list, Node_Id gnat_node)
{
bool init_const
= (!var_init
TREE_TYPE (var_init))
: TREE_CONSTANT (var_init))));
tree var_decl
- = build_decl ((const_flag && init_const
+ = build_decl ((const_flag && const_decl_allowed_flag && init_const
/* Only make a CONST_DECL for sufficiently-small objects.
We consider complex double "sufficiently-small" */
&& TYPE_SIZE (type) != 0
return var_decl;
}
+
+/* Wrapper around create_var_decl_1 for cases where we don't care whether
+ a VAR or a CONST decl node is created. */
+
+tree
+create_var_decl (tree var_name, tree asm_name, tree type, tree var_init,
+ bool const_flag, bool public_flag, bool extern_flag,
+ bool static_flag, struct attrib *attr_list,
+ Node_Id gnat_node)
+{
+ return create_var_decl_1 (var_name, asm_name, type, var_init,
+ const_flag, true,
+ public_flag, extern_flag, static_flag,
+ attr_list, gnat_node);
+}
+
+/* Wrapper around create_var_decl_1 for cases where a VAR_DECL node is
+ required. The primary intent is for DECL_CONST_CORRESPONDING_VARs, which
+ must be VAR_DECLs and on which we want TREE_READONLY set to have them
+ possibly assigned to a readonly data section. */
+
+tree
+create_true_var_decl (tree var_name, tree asm_name, tree type, tree var_init,
+ bool const_flag, bool public_flag, bool extern_flag,
+ bool static_flag, struct attrib *attr_list,
+ Node_Id gnat_node)
+{
+ return create_var_decl_1 (var_name, asm_name, type, var_init,
+ const_flag, false,
+ public_flag, extern_flag, static_flag,
+ attr_list, gnat_node);
+}
\f
/* Returns a FIELD_DECL node. FIELD_NAME the field name, FIELD_TYPE is its
type, and RECORD_TYPE is the type of the parent. PACKED is nonzero if
if (must_pass_by_ref (field_type) || default_pass_by_ref (field_type))
addressable = 1;
- /* ??? For now, we say that any field of aggregate type is addressable
- because the front end may take 'Reference of it. */
- if (AGGREGATE_TYPE_P (field_type))
- addressable = 1;
-
/* Mark the decl as nonaddressable if it is indicated so semantically,
meaning we won't ever attempt to take the address of the field.
}
}
\f
+/* Record a global renaming pointer. */
+
+void
+record_global_renaming_pointer (tree decl)
+{
+ gcc_assert (DECL_RENAMED_OBJECT (decl));
+ VEC_safe_push (tree, gc, global_renaming_pointers, decl);
+}
+
+/* Invalidate the global renaming pointers. */
+
+void
+invalidate_global_renaming_pointers (void)
+{
+ unsigned int i;
+ tree iter;
+
+ for (i = 0; VEC_iterate(tree, global_renaming_pointers, i, iter); i++)
+ SET_DECL_RENAMED_OBJECT (iter, NULL_TREE);
+
+ VEC_free (tree, gc, global_renaming_pointers);
+}
+
/* Return true if VALUE is a known to be a multiple of FACTOR, which must be
a power of 2. */
DECL_ARTIFICIAL (DECL_RESULT (subprog_decl)) = 1;
DECL_IGNORED_P (DECL_RESULT (subprog_decl)) = 1;
+ /* TREE_ADDRESSABLE is set on the result type to request the use of the
+ target by-reference return mechanism. This is not supported all the
+ way down to RTL expansion with GCC 4, which ICEs on temporary creation
+ attempts with such a type and expects DECL_BY_REFERENCE to be set on
+ the RESULT_DECL instead - see gnat_genericize for more details. */
+ if (TREE_ADDRESSABLE (TREE_TYPE (DECL_RESULT (subprog_decl))))
+ {
+ tree result_decl = DECL_RESULT (subprog_decl);
+
+ TREE_ADDRESSABLE (TREE_TYPE (result_decl)) = 0;
+ DECL_BY_REFERENCE (result_decl) = 1;
+ }
+
if (inline_flag)
DECL_DECLARED_INLINE_P (subprog_decl) = 1;
get_pending_sizes ();
}
+
+/* Helper for the genericization callback. Return a dereference of VAL
+ if it is of a reference type. */
+
+static tree
+convert_from_reference (tree val)
+{
+ tree value_type, ref;
+
+ if (TREE_CODE (TREE_TYPE (val)) != REFERENCE_TYPE)
+ return val;
+
+ value_type = TREE_TYPE (TREE_TYPE (val));
+ ref = build1 (INDIRECT_REF, value_type, val);
+
+ /* See if what we reference is CONST or VOLATILE, which requires
+ looking into array types to get to the component type. */
+
+ while (TREE_CODE (value_type) == ARRAY_TYPE)
+ value_type = TREE_TYPE (value_type);
+
+ TREE_READONLY (ref)
+ = (TYPE_QUALS (value_type) & TYPE_QUAL_CONST);
+ TREE_THIS_VOLATILE (ref)
+ = (TYPE_QUALS (value_type) & TYPE_QUAL_VOLATILE);
+
+ TREE_SIDE_EFFECTS (ref)
+ = (TREE_THIS_VOLATILE (ref) || TREE_SIDE_EFFECTS (val));
+
+ return ref;
+}
+
+/* Helper for the genericization callback. Returns true if T denotes
+ a RESULT_DECL with DECL_BY_REFERENCE set. */
+
+static inline bool
+is_byref_result (tree t)
+{
+ return (TREE_CODE (t) == RESULT_DECL && DECL_BY_REFERENCE (t));
+}
+
+
+/* Tree walking callback for gnat_genericize. Currently ...
+
+ o Adjust references to the function's DECL_RESULT if it is marked
+ DECL_BY_REFERENCE and so has had its type turned into a reference
+ type at the end of the function compilation. */
+
+static tree
+gnat_genericize_r (tree *stmt_p, int *walk_subtrees, void *data)
+{
+ /* This implementation is modeled after what the C++ front-end is
+ doing, basis of the downstream passes behavior. */
+
+ tree stmt = *stmt_p;
+ struct pointer_set_t *p_set = (struct pointer_set_t*) data;
+
+ /* If we have a direct mention of the result decl, dereference. */
+ if (is_byref_result (stmt))
+ {
+ *stmt_p = convert_from_reference (stmt);
+ *walk_subtrees = 0;
+ return NULL;
+ }
+
+ /* Otherwise, no need to walk the the same tree twice. */
+ if (pointer_set_contains (p_set, stmt))
+ {
+ *walk_subtrees = 0;
+ return NULL_TREE;
+ }
+
+ /* If we are taking the address of what now is a reference, just get the
+ reference value. */
+ if (TREE_CODE (stmt) == ADDR_EXPR
+ && is_byref_result (TREE_OPERAND (stmt, 0)))
+ {
+ *stmt_p = convert (TREE_TYPE (stmt), TREE_OPERAND (stmt, 0));
+ *walk_subtrees = 0;
+ }
+
+ /* Don't dereference an by-reference RESULT_DECL inside a RETURN_EXPR. */
+ else if (TREE_CODE (stmt) == RETURN_EXPR
+ && TREE_OPERAND (stmt, 0)
+ && is_byref_result (TREE_OPERAND (stmt, 0)))
+ *walk_subtrees = 0;
+
+ /* Don't look inside trees that cannot embed references of interest. */
+ else if (IS_TYPE_OR_DECL_P (stmt))
+ *walk_subtrees = 0;
+
+ pointer_set_insert (p_set, *stmt_p);
+
+ return NULL;
+}
+
+/* Perform lowering of Ada trees to GENERIC. In particular:
+
+ o Turn a DECL_BY_REFERENCE RESULT_DECL into a real by-reference decl
+ and adjust all the references to this decl accordingly. */
+
+static void
+gnat_genericize (tree fndecl)
+{
+ /* Prior to GCC 4, an explicit By_Reference result mechanism for a function
+ was handled by simply setting TREE_ADDRESSABLE on the result type.
+ Everything required to actually pass by invisible ref using the target
+ mechanism (e.g. extra parameter) was handled at RTL expansion time.
+
+ This doesn't work with GCC 4 any more for several reasons. First, the
+ gimplification process might need the creation of temporaries of this
+ type, and the gimplifier ICEs on such attempts. Second, the middle-end
+ now relies on a different attribute for such cases (DECL_BY_REFERENCE on
+ RESULT/PARM_DECLs), and expects the user invisible by-reference-ness to
+ be explicitely accounted for by the front-end in the function body.
+
+ We achieve the complete transformation in two steps:
+
+ 1/ create_subprog_decl performs early attribute tweaks: it clears
+ TREE_ADDRESSABLE from the result type and sets DECL_BY_REFERENCE on
+ the result decl. The former ensures that the bit isn't set in the GCC
+ tree saved for the function, so prevents ICEs on temporary creation.
+ The latter we use here to trigger the rest of the processing.
+
+ 2/ This function performs the type transformation on the result decl
+ and adjusts all the references to this decl from the function body
+ accordingly.
+
+ Clearing TREE_ADDRESSABLE from the type differs from the C++ front-end
+ strategy, which escapes the gimplifier temporary creation issues by
+ creating it's own temporaries using TARGET_EXPR nodes. Our way relies
+ on simple specific support code in aggregate_value_p to look at the
+ target function result decl explicitely. */
+
+ struct pointer_set_t *p_set;
+ tree decl_result = DECL_RESULT (fndecl);
+
+ if (!DECL_BY_REFERENCE (decl_result))
+ return;
+
+ /* Make the DECL_RESULT explicitely by-reference and adjust all the
+ occurrences in the function body using the common tree-walking facility.
+ We want to see every occurrence of the result decl to adjust the
+ referencing tree, so need to use our own pointer set to control which
+ trees should be visited again or not. */
+
+ p_set = pointer_set_create ();
+
+ TREE_TYPE (decl_result) = build_reference_type (TREE_TYPE (decl_result));
+ TREE_ADDRESSABLE (decl_result) = 0;
+ relayout_decl (decl_result);
+
+ walk_tree (&DECL_SAVED_TREE (fndecl), gnat_genericize_r, p_set, NULL);
+
+ pointer_set_destroy (p_set);
+}
+
/* Finish the definition of the current subprogram and compile it all the way
to assembler language output. BODY is the tree corresponding to
the subprogram. */
/* If we don't have .ctors/.dtors sections, and this is a static
constructor or destructor, it must be recorded now. */
if (DECL_STATIC_CONSTRUCTOR (fndecl) && !targetm.have_ctors_dtors)
- static_ctors = tree_cons (NULL_TREE, fndecl, static_ctors);
+ VEC_safe_push (tree, gc, static_ctors, fndecl);
if (DECL_STATIC_DESTRUCTOR (fndecl) && !targetm.have_ctors_dtors)
- static_dtors = tree_cons (NULL_TREE, fndecl, static_dtors);
+ VEC_safe_push (tree, gc, static_dtors, fndecl);
+
+ /* Perform the required pre-gimplfication transformations on the tree. */
+ gnat_genericize (fndecl);
/* We do different things for nested and non-nested functions.
??? This should be in cgraph. */
/* Search the chain of currently reachable declarations for a builtin
FUNCTION_DECL node corresponding to function NAME (an IDENTIFIER_NODE).
Return the first node found, if any, or NULL_TREE otherwise. */
-
tree
builtin_decl_for (tree name __attribute__ ((unused)))
{
return NULL_TREE;
}
+/* Return the appropriate GCC tree code for the specified GNAT type,
+ the latter being a record type as predicated by Is_Record_Type. */
+
+enum tree_code
+tree_code_for_record_type (Entity_Id gnat_type)
+{
+ Node_Id component_list
+ = Component_List (Type_Definition
+ (Declaration_Node
+ (Implementation_Base_Type (gnat_type))));
+ Node_Id component;
+
+ /* Make this a UNION_TYPE unless it's either not an Unchecked_Union or
+ we have a non-discriminant field outside a variant. In either case,
+ it's a RECORD_TYPE. */
+
+ if (!Is_Unchecked_Union (gnat_type))
+ return RECORD_TYPE;
+
+ for (component = First_Non_Pragma (Component_Items (component_list));
+ Present (component);
+ component = Next_Non_Pragma (component))
+ if (Ekind (Defining_Entity (component)) == E_Component)
+ return RECORD_TYPE;
+
+ return UNION_TYPE;
+}
+
+/* Build a global constructor or destructor function. METHOD_TYPE gives
+ the type of the function and VEC points to the vector of constructor
+ or destructor functions to be invoked. FIXME: Migrate into cgraph. */
+
+static void
+build_global_cdtor (int method_type, tree *vec, int len)
+{
+ tree body = NULL_TREE;
+ int i;
+
+ for (i = 0; i < len; i++)
+ {
+ tree fntype = TREE_TYPE (vec[i]);
+ tree fnaddr = build1 (ADDR_EXPR, build_pointer_type (fntype), vec[i]);
+ tree fncall = build3 (CALL_EXPR, TREE_TYPE (fntype), fnaddr, NULL_TREE,
+ NULL_TREE);
+ append_to_statement_list (fncall, &body);
+ }
+
+ if (body)
+ cgraph_build_static_cdtor (method_type, body, DEFAULT_INIT_PRIORITY);
+}
+
+/* Perform final processing on global variables. */
+
+void
+gnat_write_global_declarations (void)
+{
+ /* Generate functions to call static constructors and destructors
+ for targets that do not support .ctors/.dtors sections. These
+ functions have magic names which are detected by collect2. */
+ build_global_cdtor ('I', VEC_address (tree, static_ctors),
+ VEC_length (tree, static_ctors));
+ build_global_cdtor ('D', VEC_address (tree, static_dtors),
+ VEC_length (tree, static_dtors));
+
+ /* Proceed to optimize and emit assembly.
+ FIXME: shouldn't be the front end's responsibility to call this. */
+ cgraph_optimize ();
+
+ /* Emit debug info for all global declarations. */
+ emit_debug_global_declarations (VEC_address (tree, global_decls),
+ VEC_length (tree, global_decls));
+}
+
#include "gt-ada-utils.h"
#include "gtype-ada.h"
projects / gcc.git / commitdiff