From 6d16658d7d0aa0b3d1cede5d7a5853b2d62caf1c Mon Sep 17 00:00:00 2001 From: Bob Duff Date: Mon, 8 Aug 2022 14:45:31 -0400 Subject: [Ada] Place "at end" on body nodes This patch fixes a bug where finalization code might refer to variables outside their lifetime. The previous version moved declarations into the Handled_Statement_Sequence (HSS), so that the "at end" handler of the HSS could handle exceptions raised by those declarations. The First_Real_Statement field was used to find the first statement after the moved declarations. In addition, if the HSS already had exception handlers, it was wrapped in another layer of block_statement. This doesn't work if there are variable-sized objects allocated on the (primary) stack, because the stack will be popped before the "at end" is invoked. In the new version, we allow "at end" on nodes such as N_Subprogram_Body, in addition to HSS. We modify gigi so that such an "at end" applies to the whole body (declarations and HSS) by extending support for At_End_Proc mechanism to N_Block_Statement and N_*_Body nodes. This also removes the support for First_Real_Statement. In particular, an exception raised by the declarations will trigger the "at end". We no longer move declarations into the HSS, we no longer have a First_Real_Statement field, and we no longer do the wrapping mentioned above. This change requires various other changes, in cases where we depended on the First_Real_Statement and the moving/wrapping mentioned above. gcc/ada/ * gen_il-fields.ads (First_Real_Statement): Remove this field. * gen_il-gen-gen_nodes.adb: Remove the First_Real_Statement field. Add the At_End_Proc field to nodes that have both Declarations and HSS. * sinfo.ads (At_End_Proc): Document new semantics. (First_Real_Statement): Remove comment. * exp_ch11.adb (Expand_N_Handled_Sequence_Of_Statements): Remove First_Real_Statement. * exp_ch7.adb (Build_Cleanup_Statements): Remove "Historical note"; it doesn't seem useful, and we have revision history. (Create_Finalizer): Insert the finalizer later, typically in the statement list, in some cases. (Build_Finalizer_Call): Attach the "at end" handler to the parent of the HSS node in most cases, so it applies to declarations. (Expand_Cleanup_Actions): Remove Wrap_HSS_In_Block and the call to it. Remove the code that moves declarations. Remove some redundant code. * exp_ch9.adb (Build_Protected_Entry): Copy the At_End_Proc. (Build_Protected_Subprogram_Body): Reverse the sense of Exc_Safe, to avoid double negatives. Remove "Historical note" as in exp_ch7.adb. (Build_Unprotected_Subprogram_Body): Copy the At_End_Proc from the protected version. (Expand_N_Conditional_Entry_Call): Use First (Statements(...)) instead of First_Real_Statement(...). (Expand_N_Task_Body): Put the Abort_Undefer call at the beginning of the declarations, rather than in the HSS. Use First (Statements(...)) instead of First_Real_Statement(...). Copy the At_End_Proc. * inline.adb (Has_Initialized_Type): Return False if the declaration does not come from source. * libgnarl/s-tpoben.ads (Lock_Entries, Lock_Entries_With_Status): Document when these things raise Program_Error. It's not clear that Lock_Entries_With_Status ought to be raising exceptions, but at least it's documented now. * sem.ads: Minor comment fixes. * sem_ch6.adb (Analyze_Subprogram_Body_Helper): Use First (Statements(...)) instead of First_Real_Statement(...). (Analyze_Null_Procedure): Minor comment fix. * sem_util.adb (Might_Raise): Return True for N_Raise_Expression. Adjust the part about exceptions generated by the back end to match the reality of what the back end generates. (Update_First_Real_Statement): Remove. * sem_util.ads: Remove First_Real_Statement from comment. * sinfo-utils.ads (First_Real_Statement): New function that always returns Empty. This should be removed once gnat-llvm and codepeer have been updated to not refer to First_Real_Statement. * sprint.adb (Sprint_At_End_Proc): Deal with printing At_End_Proc. * sem_prag.adb: Minor comment fixes. * gcc-interface/trans.cc (At_End_Proc_to_gnu): New function. (Subprogram_Body_to_gnu): Call it to handle an At_End_Proc. (Handled_Sequence_Of_Statements_to_gnu): Likewise. Remove the support for First_Real_Statement and clean up the rest. (Exception_Handler_to_gnu): Do not push binding levels. (Compilation_Unit_to_gnu): Adjust call to process_decls. (gnat_to_gnu) : Likewise. : Likewise. : Likewise. : Likewise and call At_End_Proc_to_gnu to handle an At_End_Proc. : Likewise. (process_decls): Remove GNAT_END_LIST parameter and adjust recursive calls. Co-authored-by: Eric Botcazou --- gcc/ada/gcc-interface/trans.cc | 156 +++++++++++++++++++---------------------- 1 file changed, 71 insertions(+), 85 deletions(-) (limited to 'gcc/ada/gcc-interface') diff --git a/gcc/ada/gcc-interface/trans.cc b/gcc/ada/gcc-interface/trans.cc index c1dd567..58412a0 100644 --- a/gcc/ada/gcc-interface/trans.cc +++ b/gcc/ada/gcc-interface/trans.cc @@ -234,7 +234,7 @@ static inline bool stmt_group_may_fallthru (void); static enum gimplify_status gnat_gimplify_stmt (tree *); static void elaborate_all_entities (Node_Id); static void process_freeze_entity (Node_Id); -static void process_decls (List_Id, List_Id, Node_Id, bool, bool); +static void process_decls (List_Id, List_Id, bool, bool); static tree emit_check (tree, tree, int, Node_Id); static tree build_unary_op_trapv (enum tree_code, tree, tree, Node_Id); static tree build_binary_op_trapv (enum tree_code, tree, tree, tree, Node_Id); @@ -3778,6 +3778,30 @@ build_return_expr (tree ret_obj, tree ret_val) return build1 (RETURN_EXPR, void_type_node, result_expr); } +/* Subroutine of gnat_to_gnu to translate the At_End_Proc of GNAT_NODE, an + N_Block_Statement or N_Handled_Sequence_Of_Statements or N_*_Body node. + + To invoked the GCC mechanism, we call add_cleanup and when we leave the + group, end_stmt_group will create the TRY_FINALLY_EXPR construct. */ + +static void +At_End_Proc_to_gnu (Node_Id gnat_node) +{ + tree proc_decl = gnat_to_gnu (At_End_Proc (gnat_node)); + + /* When not optimizing, disable inlining of finalizers as this can + create a more complex CFG in the parent function. */ + if (!optimize || optimize_debug) + DECL_DECLARED_INLINE_P (proc_decl) = 0; + + /* If there is no end label attached, we use the location of the At_End + procedure because Expand_Cleanup_Actions might reset the location of + the enclosing construct to that of an inner statement. */ + add_cleanup (build_call_n_expr (proc_decl, 0), + Present (End_Label (gnat_node)) + ? End_Label (gnat_node) : At_End_Proc (gnat_node)); +} + /* Subroutine of gnat_to_gnu to translate GNAT_NODE, an N_Subprogram_Body. */ static void @@ -3928,12 +3952,16 @@ Subprogram_Body_to_gnu (Node_Id gnat_node) gnat_pushlevel (); /* First translate the declarations of the subprogram. */ - process_decls (Declarations (gnat_node), Empty, Empty, true, true); + process_decls (Declarations (gnat_node), Empty, true, true); /* Then generate the code of the subprogram itself. A return statement will be present and any Out parameters will be handled there. */ add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node))); + /* Process the At_End_Proc, if any. */ + if (Present (At_End_Proc (gnat_node))) + At_End_Proc_to_gnu (gnat_node); + gnat_poplevel (); tree gnu_result = end_stmt_group (); @@ -5305,76 +5333,39 @@ static tree Handled_Sequence_Of_Statements_to_gnu (Node_Id gnat_node) { /* If just annotating, ignore all EH and cleanups. */ - const bool gcc_eh + const bool eh = !type_annotate_only && Present (Exception_Handlers (gnat_node)); const bool at_end = !type_annotate_only && Present (At_End_Proc (gnat_node)); - const bool binding_for_block = (at_end || gcc_eh); - tree gnu_inner_block; /* The statement(s) for the block itself. */ tree gnu_result; Node_Id gnat_temp; - /* The GCC exception handling mechanism can handle both ZCX and SJLJ schemes. - To call the GCC mechanism, we call add_cleanup, and when we leave the - binding, end_stmt_group will create the TRY_FINALLY_EXPR construct. + /* The exception handling mechanism can handle both ZCX and SJLJ schemes, and + is exposed through the TRY_CATCH_EXPR construct that we build manually. ??? The region level calls down there have been specifically put in place for a ZCX context and currently the order in which things are emitted (region/handlers) is different from the SJLJ case. Instead of putting other calls with different conditions at other places for the SJLJ case, it seems cleaner to reorder things for the SJLJ case and generalize the - condition to make it not ZCX specific. + condition to make it not ZCX specific. */ - If there are any exceptions or cleanup processing involved, we need an - outer statement group and binding level. */ - if (binding_for_block) - { - start_stmt_group (); - gnat_pushlevel (); - } - - /* 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) - { - tree proc_decl = gnat_to_gnu (At_End_Proc (gnat_node)); - - /* When not optimizing, disable inlining of finalizers as this can - create a more complex CFG in the parent function. */ - if (!optimize || optimize_debug) - DECL_DECLARED_INLINE_P (proc_decl) = 0; - - /* If there is no end label attached, we use the location of the At_End - procedure because Expand_Cleanup_Actions might reset the location of - the enclosing construct to that of an inner statement. */ - add_cleanup (build_call_n_expr (proc_decl, 0), - Present (End_Label (gnat_node)) - ? End_Label (gnat_node) : At_End_Proc (gnat_node)); - } - - /* Now build the tree for the declarations and statements inside this - block. */ + /* First build the tree for the statements inside the sequence. */ start_stmt_group (); - if (Present (First_Real_Statement (gnat_node))) - process_decls (Statements (gnat_node), Empty, - First_Real_Statement (gnat_node), true, true); - - /* Generate code for each statement in the block. */ - for (gnat_temp = (Present (First_Real_Statement (gnat_node)) - ? First_Real_Statement (gnat_node) - : First (Statements (gnat_node))); - Present (gnat_temp); gnat_temp = Next (gnat_temp)) + for (gnat_temp = First (Statements (gnat_node)); + Present (gnat_temp); + gnat_temp = Next (gnat_temp)) add_stmt (gnat_to_gnu (gnat_temp)); - gnu_inner_block = end_stmt_group (); + gnu_result = end_stmt_group (); - if (gcc_eh) + /* Then process the exception handlers, if any. */ + if (eh) { tree gnu_handlers; location_t locus; - /* First make a block containing the handlers. */ + /* First make a group containing the handlers. */ start_stmt_group (); for (gnat_temp = First_Non_Pragma (Exception_Handlers (gnat_node)); Present (gnat_temp); @@ -5382,9 +5373,10 @@ Handled_Sequence_Of_Statements_to_gnu (Node_Id gnat_node) add_stmt (gnat_to_gnu (gnat_temp)); gnu_handlers = end_stmt_group (); - /* Now make the TRY_CATCH_EXPR for the block. */ - gnu_result = build2 (TRY_CATCH_EXPR, void_type_node, - gnu_inner_block, gnu_handlers); + /* Now make the TRY_CATCH_EXPR for the group. */ + gnu_result + = build2 (TRY_CATCH_EXPR, void_type_node, gnu_result, gnu_handlers); + /* Set a location. We need to find a unique location for the dispatching code, otherwise we can get coverage or debugging issues. Try with the location of the end label. */ @@ -5398,14 +5390,13 @@ Handled_Sequence_Of_Statements_to_gnu (Node_Id gnat_node) coverage analysis tools. */ set_expr_location_from_node (gnu_result, gnat_node, true); } - else - gnu_result = gnu_inner_block; - /* Now close our outer block, if we had to make one. */ - if (binding_for_block) + /* Process the At_End_Proc, if any. */ + if (at_end) { + start_stmt_group (); add_stmt (gnu_result); - gnat_poplevel (); + At_End_Proc_to_gnu (gnat_node); gnu_result = end_stmt_group (); } @@ -5493,7 +5484,6 @@ Exception_Handler_to_gnu (Node_Id gnat_node) } start_stmt_group (); - gnat_pushlevel (); /* Expand a call to the begin_handler hook at the beginning of the handler, and arrange for a call to the end_handler hook to occur @@ -5584,7 +5574,7 @@ Exception_Handler_to_gnu (Node_Id gnat_node) else { start_stmt_group (); - gnat_pushlevel (); + /* CODE: void *EXPRP = __builtin_eh_handler (0); */ tree prop_ptr = create_var_decl (get_identifier ("EXPRP"), NULL_TREE, @@ -5604,14 +5594,11 @@ Exception_Handler_to_gnu (Node_Id gnat_node) add_stmt_with_node (ecall, gnat_node); /* CODE: } */ - gnat_poplevel (); tree eblk = end_stmt_group (); tree ehls = build2 (EH_ELSE_EXPR, void_type_node, call, eblk); add_cleanup (ehls, gnat_node); } - gnat_poplevel (); - gnu_incoming_exc_ptr = prev_gnu_incoming_exc_ptr; return @@ -5677,7 +5664,7 @@ Compilation_Unit_to_gnu (Node_Id gnat_node) gnat_pragma = Next (gnat_pragma)) if (Nkind (gnat_pragma) == N_Pragma) add_stmt (gnat_to_gnu (gnat_pragma)); - process_decls (Declarations (Aux_Decls_Node (gnat_node)), Empty, Empty, + process_decls (Declarations (Aux_Decls_Node (gnat_node)), Empty, true, true); /* Process the unit itself. */ @@ -7365,8 +7352,10 @@ gnat_to_gnu (Node_Id gnat_node) { start_stmt_group (); gnat_pushlevel (); - process_decls (Declarations (gnat_node), Empty, Empty, true, true); + process_decls (Declarations (gnat_node), Empty, true, true); add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node))); + if (Present (At_End_Proc (gnat_node))) + At_End_Proc_to_gnu (gnat_node); gnat_poplevel (); gnu_result = end_stmt_group (); } @@ -7606,15 +7595,14 @@ gnat_to_gnu (Node_Id gnat_node) break; case N_Package_Specification: - start_stmt_group (); process_decls (Visible_Declarations (gnat_node), - Private_Declarations (gnat_node), Empty, true, true); + Private_Declarations (gnat_node), + true, true); gnu_result = end_stmt_group (); break; case N_Package_Body: - /* If this is the body of a generic package - do nothing. */ if (Ekind (Corresponding_Spec (gnat_node)) == E_Generic_Package) { @@ -7623,11 +7611,11 @@ gnat_to_gnu (Node_Id gnat_node) } start_stmt_group (); - process_decls (Declarations (gnat_node), Empty, Empty, true, true); - + process_decls (Declarations (gnat_node), Empty, true, true); if (Present (Handled_Statement_Sequence (gnat_node))) add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node))); - + if (Present (At_End_Proc (gnat_node))) + At_End_Proc_to_gnu (gnat_node); gnu_result = end_stmt_group (); break; @@ -7673,7 +7661,7 @@ gnat_to_gnu (Node_Id gnat_node) case N_Task_Body: /* These nodes should only be present when annotating types. */ gcc_assert (type_annotate_only); - process_decls (Declarations (gnat_node), Empty, Empty, true, true); + process_decls (Declarations (gnat_node), Empty, true, true); gnu_result = alloc_stmt_list (); break; @@ -7975,7 +7963,7 @@ gnat_to_gnu (Node_Id gnat_node) case N_Freeze_Entity: start_stmt_group (); process_freeze_entity (gnat_node); - process_decls (Actions (gnat_node), Empty, Empty, true, true); + process_decls (Actions (gnat_node), Empty, true, true); gnu_result = end_stmt_group (); break; @@ -9203,17 +9191,13 @@ process_freeze_entity (Node_Id gnat_node) we declare a function if there was no spec). The second pass elaborates the bodies. - GNAT_END_LIST gives the element in the list past the end. Normally, - this is Empty, but can be First_Real_Statement for a - Handled_Sequence_Of_Statements. - We make a complete pass through both lists if PASS1P is true, then make the second pass over both lists if PASS2P is true. The lists usually correspond to the public and private parts of a package. */ static void process_decls (List_Id gnat_decls, List_Id gnat_decls2, - Node_Id gnat_end_list, bool pass1p, bool pass2p) + bool pass1p, bool pass2p) { List_Id gnat_decl_array[2]; Node_Id gnat_decl; @@ -9225,7 +9209,8 @@ process_decls (List_Id gnat_decls, List_Id gnat_decls2, for (i = 0; i <= 1; i++) if (Present (gnat_decl_array[i])) for (gnat_decl = First (gnat_decl_array[i]); - gnat_decl != gnat_end_list; gnat_decl = Next (gnat_decl)) + Present (gnat_decl); + gnat_decl = Next (gnat_decl)) { /* For package specs, we recurse inside the declarations, thus taking the two pass approach inside the boundary. */ @@ -9234,14 +9219,14 @@ process_decls (List_Id gnat_decls, List_Id gnat_decls2, == N_Package_Specification))) process_decls (Visible_Declarations (Specification (gnat_decl)), Private_Declarations (Specification (gnat_decl)), - Empty, true, false); + true, false); /* Similarly for any declarations in the actions of a freeze node. */ else if (Nkind (gnat_decl) == N_Freeze_Entity) { process_freeze_entity (gnat_decl); - process_decls (Actions (gnat_decl), Empty, Empty, true, false); + process_decls (Actions (gnat_decl), Empty, true, false); } /* Package bodies with freeze nodes get their elaboration deferred @@ -9308,7 +9293,8 @@ process_decls (List_Id gnat_decls, List_Id gnat_decls2, for (i = 0; i <= 1; i++) if (Present (gnat_decl_array[i])) for (gnat_decl = First (gnat_decl_array[i]); - gnat_decl != gnat_end_list; gnat_decl = Next (gnat_decl)) + Present (gnat_decl); + gnat_decl = Next (gnat_decl)) { if (Nkind (gnat_decl) == N_Subprogram_Body || Nkind (gnat_decl) == N_Subprogram_Body_Stub @@ -9321,10 +9307,10 @@ process_decls (List_Id gnat_decls, List_Id gnat_decls2, == N_Package_Specification))) process_decls (Visible_Declarations (Specification (gnat_decl)), Private_Declarations (Specification (gnat_decl)), - Empty, false, true); + false, true); else if (Nkind (gnat_decl) == N_Freeze_Entity) - process_decls (Actions (gnat_decl), Empty, Empty, false, true); + process_decls (Actions (gnat_decl), Empty, false, true); else if (Nkind (gnat_decl) == N_Subprogram_Renaming_Declaration) add_stmt (gnat_to_gnu (gnat_decl)); -- cgit v1.1 From a80e0583973cb1664adf663d499c43c0425018b6 Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Tue, 12 Jul 2022 14:22:53 +0200 Subject: [Ada] Extend No_Dependence restriction to code generation (continued) gcc/ada/ * gcc-interface/trans.cc (gnat_to_gnu) : Report a violation of No_Dependence on System.GCC if the result type is larger than a word. : Likewise. : Likewise. : Likewise. (convert_with_check): Report a violation of No_Dependence on System.GCC for a conversion between an integer type larger than a word and a floating-point type. --- gcc/ada/gcc-interface/trans.cc | 25 +++++++++++++++++++++++++ 1 file changed, 25 insertions(+) (limited to 'gcc/ada/gcc-interface') diff --git a/gcc/ada/gcc-interface/trans.cc b/gcc/ada/gcc-interface/trans.cc index 58412a0..eae15dc 100644 --- a/gcc/ada/gcc-interface/trans.cc +++ b/gcc/ada/gcc-interface/trans.cc @@ -6864,6 +6864,11 @@ gnat_to_gnu (Node_Id gnat_node) : (Rounded_Result (gnat_node) ? ROUND_DIV_EXPR : TRUNC_DIV_EXPR), gnu_result_type, gnu_lhs, gnu_rhs); + /* If the result type is larger than a word, then declare the dependence + on the libgcc routine. */ + if (INTEGRAL_TYPE_P (gnu_result_type) + && TYPE_PRECISION (gnu_result_type) > BITS_PER_WORD) + Check_Restriction_No_Dependence_On_System (Name_Gcc, gnat_node); break; case N_Op_Eq: @@ -6923,6 +6928,10 @@ gnat_to_gnu (Node_Id gnat_node) gnu_rhs = convert (gnu_count_type, gnu_rhs); gnu_max_shift = convert (TREE_TYPE (gnu_rhs), TYPE_SIZE (gnu_type)); + /* If the result type is larger than a word, then declare the dependence + on the libgcc routine. */ + if (TYPE_PRECISION (gnu_result_type) > BITS_PER_WORD) + Check_Restriction_No_Dependence_On_System (Name_Gcc, gnat_node); } /* If this is a comparison between (potentially) large aggregates, then @@ -6935,6 +6944,12 @@ gnat_to_gnu (Node_Id gnat_node) Check_Restriction_No_Dependence_On_System (Name_Memory_Compare, gnat_node); + /* If this is a modulo/remainder and the result type is larger than a + word, then declare the dependence on the libgcc routine. */ + else if ((kind == N_Op_Mod ||kind == N_Op_Rem) + && TYPE_PRECISION (gnu_result_type) > BITS_PER_WORD) + Check_Restriction_No_Dependence_On_System (Name_Gcc, gnat_node); + /* Pending generic support for efficient vector logical operations in GCC, convert vectors to their representative array type view. */ gnu_lhs = maybe_vector_array (gnu_lhs); @@ -9749,6 +9764,16 @@ convert_with_check (Entity_Id gnat_type, tree gnu_expr, bool overflow_p, else gnu_result = convert (gnu_base_type, gnu_result); + /* If this is a conversion between an integer type larger than a word and a + floating-point type, then declare the dependence on the libgcc routine. */ + if ((INTEGRAL_TYPE_P (gnu_in_base_type) + && TYPE_PRECISION (gnu_in_base_type) > BITS_PER_WORD + && FLOAT_TYPE_P (gnu_base_type)) + || (FLOAT_TYPE_P (gnu_in_base_type) + && INTEGRAL_TYPE_P (gnu_base_type) + && TYPE_PRECISION (gnu_base_type) > BITS_PER_WORD)) + Check_Restriction_No_Dependence_On_System (Name_Gcc, gnat_node); + return convert (gnu_type, gnu_result); } -- cgit v1.1 From e2909e105d26a13b860d071f7491923f318f999c Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Tue, 19 Jul 2022 20:55:05 +0200 Subject: [Ada] Fix missing name for access type in generic instantiation Pointer types aren't named types in C so we need to take extra care in Ada to make sure that the name of access types is preserved. gcc/ada/ * gcc-interface/utils.cc (gnat_pushdecl): Preserve named TYPE_DECLs consistently for all kind of pointer types. --- gcc/ada/gcc-interface/utils.cc | 28 ++++++++++++++++------------ 1 file changed, 16 insertions(+), 12 deletions(-) (limited to 'gcc/ada/gcc-interface') diff --git a/gcc/ada/gcc-interface/utils.cc b/gcc/ada/gcc-interface/utils.cc index a571430..3d4c1c1 100644 --- a/gcc/ada/gcc-interface/utils.cc +++ b/gcc/ada/gcc-interface/utils.cc @@ -868,6 +868,13 @@ gnat_pushdecl (tree decl, Node_Id gnat_node) } } +/* Pointer types aren't named types in the C sense so we need to generate a + typedef in DWARF for them. Also do that for fat pointer types because, + even though they are named types in the C sense, they are still the XUP + types created for the base array type at this point. */ +#define TYPE_IS_POINTER_P(NODE) \ + (TREE_CODE (NODE) == POINTER_TYPE || TYPE_IS_FAT_POINTER_P (NODE)) + /* For the declaration of a type, set its name either if it isn't already set or if the previous type name was not derived from a source name. We'd rather have the type named with a real name and all the pointer @@ -877,18 +884,14 @@ gnat_pushdecl (tree decl, Node_Id gnat_node) { tree t = TREE_TYPE (decl); - /* Pointer types aren't named types in the C sense so we need to generate - a typedef in DWARF for them and make sure it is preserved, unless the - type is artificial. */ + /* For pointer types, make sure the typedef is generated and preserved + in DWARF, unless the type is artificial. */ if (!(TYPE_NAME (t) && TREE_CODE (TYPE_NAME (t)) == TYPE_DECL) - && (TREE_CODE (t) != POINTER_TYPE || DECL_ARTIFICIAL (decl))) + && (!TYPE_IS_POINTER_P (t) || DECL_ARTIFICIAL (decl))) ; /* For pointer types, create the DECL_ORIGINAL_TYPE that will generate - the typedef in DWARF. Also do that for fat pointer types because, - even though they are named types in the C sense, they are still the - XUP types created for the base array type at this point. */ - else if (!DECL_ARTIFICIAL (decl) - && (TREE_CODE (t) == POINTER_TYPE || TYPE_IS_FAT_POINTER_P (t))) + the typedef in DWARF. */ + else if (TYPE_IS_POINTER_P (t) && !DECL_ARTIFICIAL (decl)) { tree tt = build_variant_type_copy (t); TYPE_NAME (tt) = decl; @@ -920,9 +923,8 @@ gnat_pushdecl (tree decl, Node_Id gnat_node) to all parallel types too thanks to gnat_set_type_context. */ if (t) for (t = TYPE_MAIN_VARIANT (t); t; t = TYPE_NEXT_VARIANT (t)) - /* ??? Because of the previous kludge, we can have variants of fat - pointer types with different names. */ - if (!(TYPE_IS_FAT_POINTER_P (t) + /* Skip it for pointer types to preserve the typedef. */ + if (!(TYPE_IS_POINTER_P (t) && TYPE_NAME (t) && TREE_CODE (TYPE_NAME (t)) == TYPE_DECL)) { @@ -932,6 +934,8 @@ gnat_pushdecl (tree decl, Node_Id gnat_node) deferred_decl_context); } } + +#undef TYPE_IS_POINTER_P } /* Create a record type that contains a SIZE bytes long field of TYPE with a -- cgit v1.1 From ef12e74ce7b1b00cce13d27e1273656926a4a25d Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Tue, 16 Aug 2022 17:54:59 +0200 Subject: [Ada] Fix internal error on double renaming of private constant The first renaming uses the type of the full view of the constant but not the second, which introduces problematic view conversions downstream. gcc/ada/ * gcc-interface/trans.cc (Full_View_Of_Private_Constant): New function returning the Full_View of a private constant, after looking through a chain of renamings, if any. (Identifier_to_gnu): Call it on the entity. Small cleanup. --- gcc/ada/gcc-interface/trans.cc | 68 ++++++++++++++++++++++++++---------------- 1 file changed, 43 insertions(+), 25 deletions(-) (limited to 'gcc/ada/gcc-interface') diff --git a/gcc/ada/gcc-interface/trans.cc b/gcc/ada/gcc-interface/trans.cc index eae15dc..b6c42f5 100644 --- a/gcc/ada/gcc-interface/trans.cc +++ b/gcc/ada/gcc-interface/trans.cc @@ -1088,6 +1088,28 @@ Gigi_Types_Compatible (Entity_Id type, Entity_Id def_type) return false; } +/* Return the full view of a private constant E, or of a renaming thereof, if + its type has discriminants, and Empty otherwise. */ + +static Entity_Id +Full_View_Of_Private_Constant (Entity_Id E) +{ + while (Present (Renamed_Object (E)) && Is_Entity_Name (Renamed_Object (E))) + E = Entity (Renamed_Object (E)); + + if (Ekind (E) != E_Constant || No (Full_View (E))) + return Empty; + + const Entity_Id T = Etype (E); + + if (Is_Private_Type (T) + && (Has_Unknown_Discriminants (T) + || (Present (Full_View (T)) && Has_Discriminants (Full_View (T))))) + return Full_View (E); + + return Empty; +} + /* Subroutine of gnat_to_gnu to translate GNAT_NODE, an N_Identifier, to a GCC tree, which is returned. GNU_RESULT_TYPE_P is a pointer to where we should place the result type. */ @@ -1095,21 +1117,19 @@ Gigi_Types_Compatible (Entity_Id type, Entity_Id def_type) static tree Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p) { - /* The entity of GNAT_NODE and its type. */ - Node_Id gnat_entity = (Nkind (gnat_node) == N_Defining_Identifier - || Nkind (gnat_node) == N_Defining_Operator_Symbol) - ? gnat_node : Entity (gnat_node); - Node_Id gnat_entity_type = Etype (gnat_entity); + Entity_Id gnat_entity = (Nkind (gnat_node) == N_Defining_Identifier + || Nkind (gnat_node) == N_Defining_Operator_Symbol) + ? gnat_node : Entity (gnat_node); + Entity_Id gnat_result_type; + tree gnu_result, gnu_result_type; /* If GNAT_NODE is a constant, whether we should use the initialization value instead of the constant entity, typically for scalars with an address clause when the parent doesn't require an lvalue. */ - bool use_constant_initializer = false; + bool use_constant_initializer; /* Whether we should require an lvalue for GNAT_NODE. Needed in specific circumstances only, so evaluated lazily. < 0 means unknown, > 0 means known true, 0 means known false. */ - int require_lvalue = -1; - Entity_Id gnat_result_type; - tree gnu_result, gnu_result_type; + int require_lvalue; /* If the Etype of this node is not the same as that of the Entity, then something went wrong, probably in generic instantiation. However, this @@ -1118,25 +1138,17 @@ Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p) may have been changed to a subtype by Exp_Ch3.Adjust_Discriminants. */ gcc_assert (!Is_Object (gnat_entity) || Ekind (gnat_entity) == E_Discriminant - || Etype (gnat_node) == gnat_entity_type - || Gigi_Types_Compatible (Etype (gnat_node), gnat_entity_type)); + || Etype (gnat_node) == Etype (gnat_entity) + || Gigi_Types_Compatible (Etype (gnat_node), + Etype (gnat_entity))); - /* If this is a reference to a deferred constant whose partial view is an + /* If this is a reference to a deferred constant whose partial view is of unconstrained private type, the proper type is on the full view of the - constant, not on the full view of the type, which may be unconstrained. - - This may be a reference to a type, for example in the prefix of the - attribute Position, generated for dispatching code (see Make_DT in - exp_disp,adb). In that case we need the type itself, not is parent, - in particular if it is a derived type */ - if (Ekind (gnat_entity) == E_Constant - && Is_Private_Type (gnat_entity_type) - && (Has_Unknown_Discriminants (gnat_entity_type) - || (Present (Full_View (gnat_entity_type)) - && Has_Discriminants (Full_View (gnat_entity_type)))) - && Present (Full_View (gnat_entity))) + constant, not on the full view of the type which may be unconstrained. */ + const Entity_Id gnat_full_view = Full_View_Of_Private_Constant (gnat_entity); + if (Present (gnat_full_view)) { - gnat_entity = Full_View (gnat_entity); + gnat_entity = gnat_full_view; gnat_result_type = Etype (gnat_entity); } else @@ -1184,7 +1196,13 @@ Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p) = lvalue_required_p (gnat_node, gnu_result_type, true, false); use_constant_initializer = !require_lvalue; } + else + { + require_lvalue = -1; + use_constant_initializer = false; + } + /* Fetch the initialization value of a constant if requested. */ if (use_constant_initializer) { /* If this is a deferred constant, the initializer is attached to -- cgit v1.1 From 0b66f882f7c2d3fb23faf4d7046ed391e8da5bd5 Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Mon, 22 Aug 2022 23:23:52 +0200 Subject: [Ada] Fix problematic line debug info attached to call to finalizer The End_Label is not defined for body nodes so a small tweak is needed. gcc/ada/ * gcc-interface/trans.cc (At_End_Proc_to_gnu): Use the End_Label of the child Handled_Statement_Sequence for body nodes. (set_end_locus_from_node): Minor tweaks. --- gcc/ada/gcc-interface/trans.cc | 18 +++++++++++++----- 1 file changed, 13 insertions(+), 5 deletions(-) (limited to 'gcc/ada/gcc-interface') diff --git a/gcc/ada/gcc-interface/trans.cc b/gcc/ada/gcc-interface/trans.cc index b6c42f5..f2e0cb2 100644 --- a/gcc/ada/gcc-interface/trans.cc +++ b/gcc/ada/gcc-interface/trans.cc @@ -3806,18 +3806,27 @@ static void At_End_Proc_to_gnu (Node_Id gnat_node) { tree proc_decl = gnat_to_gnu (At_End_Proc (gnat_node)); + Node_Id gnat_end_label; /* When not optimizing, disable inlining of finalizers as this can create a more complex CFG in the parent function. */ if (!optimize || optimize_debug) DECL_DECLARED_INLINE_P (proc_decl) = 0; + /* Retrieve the end label attached to the node, if any. */ + if (Nkind (gnat_node) == N_Handled_Sequence_Of_Statements) + gnat_end_label = End_Label (gnat_node); + else if (Present (Handled_Statement_Sequence (gnat_node))) + gnat_end_label = End_Label (Handled_Statement_Sequence (gnat_node)); + else + gnat_end_label = Empty; + /* If there is no end label attached, we use the location of the At_End procedure because Expand_Cleanup_Actions might reset the location of - the enclosing construct to that of an inner statement. */ + the enclosing construct to that of an inner statement. */ add_cleanup (build_call_n_expr (proc_decl, 0), - Present (End_Label (gnat_node)) - ? End_Label (gnat_node) : At_End_Proc (gnat_node)); + Present (gnat_end_label) + ? gnat_end_label : At_End_Proc (gnat_node)); } /* Subroutine of gnat_to_gnu to translate GNAT_NODE, an N_Subprogram_Body. */ @@ -10418,7 +10427,6 @@ set_end_locus_from_node (tree gnu_node, Node_Id gnat_node) gnat_end_label = End_Label (Handled_Statement_Sequence (gnat_node)); else gnat_end_label = Empty; - break; case N_Package_Declaration: @@ -10439,7 +10447,7 @@ set_end_locus_from_node (tree gnu_node, Node_Id gnat_node) transient block does not receive the sloc of a source condition. */ if (!Sloc_to_locus (Sloc (gnat_node), &end_locus, No (gnat_end_label) - && (Nkind (gnat_node) == N_Block_Statement))) + && Nkind (gnat_node) == N_Block_Statement)) return false; switch (TREE_CODE (gnu_node)) -- cgit v1.1 From fc52efeb9c6fe214ea78f9d506aa9e8ee9ebdd61 Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Mon, 22 Aug 2022 23:32:05 +0200 Subject: [Ada] Mark artificial formal parameters in the debug info gcc/ada/ * gcc-interface/decl.cc (gnat_to_gnu_param): Set DECL_ARTIFICIAL. --- gcc/ada/gcc-interface/decl.cc | 1 + 1 file changed, 1 insertion(+) (limited to 'gcc/ada/gcc-interface') diff --git a/gcc/ada/gcc-interface/decl.cc b/gcc/ada/gcc-interface/decl.cc index 96ea13e..504920d 100644 --- a/gcc/ada/gcc-interface/decl.cc +++ b/gcc/ada/gcc-interface/decl.cc @@ -5602,6 +5602,7 @@ gnat_to_gnu_param (Entity_Id gnat_param, tree gnu_param_type, bool first, gnu_param = create_param_decl (gnu_param_name, gnu_param_type); TREE_READONLY (gnu_param) = ro_param || by_ref || by_component_ptr; + DECL_ARTIFICIAL (gnu_param) = !Comes_From_Source (gnat_param); DECL_BY_REF_P (gnu_param) = by_ref; DECL_FORCED_BY_REF_P (gnu_param) = forced_by_ref; DECL_BY_COMPONENT_PTR_P (gnu_param) = by_component_ptr; -- cgit v1.1 From 643ae816f17745a77b62188b6bf169211609a59b Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Thu, 1 Sep 2022 16:21:07 +0200 Subject: [Ada] Fix immediate assertion failure with -gnatd.1 The switch enables the front-end unnesting pass. gcc/ada/ * gcc-interface/decl.cc (gnat_to_gnu_entity): Relax assertion when front-end unnesting is enabled. --- gcc/ada/gcc-interface/decl.cc | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) (limited to 'gcc/ada/gcc-interface') diff --git a/gcc/ada/gcc-interface/decl.cc b/gcc/ada/gcc-interface/decl.cc index 504920d..c5a93fb 100644 --- a/gcc/ada/gcc-interface/decl.cc +++ b/gcc/ada/gcc-interface/decl.cc @@ -436,7 +436,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) /* If this is a numeric or enumeral type, or an access type, a nonzero Esize must be specified unless it was specified by the programmer. Exceptions are for access-to-protected-subprogram types and all access subtypes, as - another GNAT type is used to lay out the GCC type for them. */ + another GNAT type is used to lay out the GCC type for them, as well as + access-to-subprogram types if front-end unnesting is enabled. */ gcc_assert (!is_type || Known_Esize (gnat_entity) || Has_Size_Clause (gnat_entity) @@ -445,6 +446,9 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) && (!IN (kind, Access_Kind) || kind == E_Access_Protected_Subprogram_Type || kind == E_Anonymous_Access_Protected_Subprogram_Type + || ((kind == E_Access_Subprogram_Type + || kind == E_Anonymous_Access_Subprogram_Type) + && Unnest_Subprogram_Mode) || kind == E_Access_Subtype || type_annotate_only))); -- cgit v1.1