These are the Ada front-end bits. They define the langhook to true and set
the flags on individual ADDR_EXPR and CALL_EXPR nodes with Ada convention; in
other words, descriptors are not activated for subprograms imported from or
exported to other languages.
2016-07-04 Eric Botcazou <ebotca...@adacore.com>
* gcc-interface/misc.c (LANG_HOOKS_CUSTOM_FUNCTION_DESCRIPTORS): Def.
* gcc-interface/trans.c (Attribute_to_gnu) <Attr_Access>: Deal with
a zero TARGET_CUSTOM_FUNCTION_DESCRIPTORS specially for Code_Address.
Otherwise, if TARGET_CUSTOM_FUNCTION_DESCRIPTORS is positive, set
FUNC_ADDR_BY_DESCRIPTOR for 'Access/'Unrestricted_Access of nested
subprograms if the type can use an internal representation.
(call_to_gnu): Likewise, but set CALL_EXPR_BY_DESCRIPTOR on indirect
calls if the type can use an internal representation.
--
Eric BotcazouIndex: ada/gcc-interface/misc.c
===================================================================
--- ada/gcc-interface/misc.c (revision 239944)
+++ ada/gcc-interface/misc.c (working copy)
@@ -1416,6 +1416,8 @@ get_lang_specific (tree node)
#define LANG_HOOKS_EH_PERSONALITY gnat_eh_personality
#undef LANG_HOOKS_DEEP_UNSHARING
#define LANG_HOOKS_DEEP_UNSHARING true
+#undef LANG_HOOKS_CUSTOM_FUNCTION_DESCRIPTORS
+#define LANG_HOOKS_CUSTOM_FUNCTION_DESCRIPTORS true
struct lang_hooks lang_hooks = LANG_HOOKS_INITIALIZER;
Index: ada/gcc-interface/trans.c
===================================================================
--- ada/gcc-interface/trans.c (revision 239944)
+++ ada/gcc-interface/trans.c (working copy)
@@ -1702,6 +1702,17 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_res
if (TREE_CODE (gnu_expr) == ADDR_EXPR)
TREE_NO_TRAMPOLINE (gnu_expr) = TREE_CONSTANT (gnu_expr) = 1;
+
+ /* On targets for which function symbols denote a descriptor, the
+ code address is stored within the first slot of the descriptor
+ so we do an additional dereference:
+ result = *((result_type *) result)
+ where we expect result to be of some pointer type already. */
+ if (targetm.calls.custom_function_descriptors == 0)
+ gnu_result
+ = build_unary_op (INDIRECT_REF, NULL_TREE,
+ convert (build_pointer_type (gnu_result_type),
+ gnu_result));
}
/* For 'Access, issue an error message if the prefix is a C++ method
@@ -1728,10 +1739,19 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_res
/* Also check the inlining status. */
check_inlining_for_nested_subprog (TREE_OPERAND (gnu_expr, 0));
- /* Check that we're not violating the No_Implicit_Dynamic_Code
- restriction. Be conservative if we don't know anything
- about the trampoline strategy for the target. */
- Check_Implicit_Dynamic_Code_Allowed (gnat_node);
+ /* Moreover, for 'Access or 'Unrestricted_Access with non-
+ foreign-compatible representation, mark the ADDR_EXPR so
+ that we can build a descriptor instead of a trampoline. */
+ if ((attribute == Attr_Access
+ || attribute == Attr_Unrestricted_Access)
+ && targetm.calls.custom_function_descriptors > 0
+ && Can_Use_Internal_Rep (Etype (gnat_node)))
+ FUNC_ADDR_BY_DESCRIPTOR (gnu_expr) = 1;
+
+ /* Otherwise, we need to check that we are not violating the
+ No_Implicit_Dynamic_Code restriction. */
+ else if (targetm.calls.custom_function_descriptors != 0)
+ Check_Implicit_Dynamic_Code_Allowed (gnat_node);
}
}
break;
@@ -4228,6 +4248,7 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_t
tree gnu_after_list = NULL_TREE;
tree gnu_retval = NULL_TREE;
tree gnu_call, gnu_result;
+ bool by_descriptor = false;
bool went_into_elab_proc = false;
bool pushed_binding_level = false;
Entity_Id gnat_formal;
@@ -4267,7 +4288,15 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_t
type the access type is pointing to. Otherwise, get the formals from the
entity being called. */
if (Nkind (Name (gnat_node)) == N_Explicit_Dereference)
- gnat_formal = First_Formal_With_Extras (Etype (Name (gnat_node)));
+ {
+ gnat_formal = First_Formal_With_Extras (Etype (Name (gnat_node)));
+
+ /* If the access type doesn't require foreign-compatible representation,
+ be prepared for descriptors. */
+ if (targetm.calls.custom_function_descriptors > 0
+ && Can_Use_Internal_Rep (Etype (Prefix (Name (gnat_node)))))
+ by_descriptor = true;
+ }
else if (Nkind (Name (gnat_node)) == N_Attribute_Reference)
/* Assume here that this must be 'Elab_Body or 'Elab_Spec. */
gnat_formal = Empty;
@@ -4670,6 +4699,7 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_t
gnu_call
= build_call_vec (gnu_result_type, gnu_subprog_addr, gnu_actual_vec);
+ CALL_EXPR_BY_DESCRIPTOR (gnu_call) = by_descriptor;
set_expr_location_from_node (gnu_call, gnat_node);
/* If we have created a temporary for the return value, initialize it. */
