diff options
Diffstat (limited to 'gcc/ada/trans.c')
| -rw-r--r-- | gcc/ada/trans.c | 453 |
1 files changed, 272 insertions, 181 deletions
diff --git a/gcc/ada/trans.c b/gcc/ada/trans.c index fe820bf..eaa6fc6 100644 --- a/gcc/ada/trans.c +++ b/gcc/ada/trans.c @@ -149,7 +149,7 @@ static void insert_code_for (Node_Id); 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); @@ -171,7 +171,6 @@ static tree pos_to_constructor (Node_Id, tree, Entity_Id); 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 *); /* This is the main program of the back-end. It sets up all the table @@ -252,8 +251,15 @@ gigi (Node_Id gnat_root, int max_gnat_node, int number_name, 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. */ @@ -382,10 +388,17 @@ Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p) 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 @@ -452,18 +465,7 @@ Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p) == 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; @@ -795,10 +797,9 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute) 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: @@ -1145,6 +1146,7 @@ Case_Statement_to_gnu (Node_Id gnat_node) 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. */ @@ -1195,18 +1197,33 @@ Case_Statement_to_gnu (Node_Id gnat_node) 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. */ @@ -1484,7 +1501,7 @@ Subprogram_Body_to_gnu (Node_Id gnat_node) 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)) @@ -1570,7 +1587,7 @@ Subprogram_Body_to_gnu (Node_Id gnat_node) /* 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) @@ -1687,12 +1704,12 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target) 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 @@ -1741,6 +1758,11 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target) 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 @@ -1749,7 +1771,7 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target) 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", @@ -1889,6 +1911,13 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target) && !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)); @@ -2026,9 +2055,9 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target) } 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); @@ -2053,8 +2082,7 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target) : 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. */ @@ -2068,16 +2096,33 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target) (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)); @@ -2152,11 +2197,6 @@ Handled_Sequence_Of_Statements_to_gnu (Node_Id gnat_node) 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. */ @@ -2183,6 +2223,12 @@ Handled_Sequence_Of_Statements_to_gnu (Node_Id gnat_node) 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 (); @@ -2525,7 +2571,7 @@ Compilation_Unit_to_gnu (Node_Id gnat_node) process_inlined_subprograms (gnat_node); - if (type_annotate_only) + if (type_annotate_only && gnat_node == Cunit (Main_Unit)) { elaborate_all_entities (gnat_node); @@ -2558,14 +2604,10 @@ Compilation_Unit_to_gnu (Node_Id 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 (); } /* This function is the driver of the GNAT to GCC tree transformation @@ -3330,6 +3372,7 @@ gnat_to_gnu (Node_Id gnat_node) 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)); @@ -3378,17 +3421,32 @@ gnat_to_gnu (Node_Id 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); } @@ -3773,16 +3831,31 @@ gnat_to_gnu (Node_Id gnat_node) 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; @@ -3965,47 +4038,102 @@ gnat_to_gnu (Node_Id gnat_node) 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 @@ -4372,12 +4500,6 @@ void 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. */ @@ -4407,15 +4529,16 @@ add_decl_expr (tree gnu_decl, Entity_Id gnat_entity) && 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) @@ -4425,6 +4548,8 @@ add_decl_expr (tree gnu_decl, Entity_Id gnat_entity) 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. */ @@ -4455,8 +4580,12 @@ add_decl_expr (tree gnu_decl, Entity_Id gnat_entity) = 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); @@ -4486,13 +4615,16 @@ mark_visited (tree *tp, int *walk_subtrees, void *data ATTRIBUTE_UNUSED) 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; } @@ -4833,48 +4965,33 @@ gnat_gimplify_stmt (tree *stmt_p) } } -/* 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)); @@ -4897,23 +5014,23 @@ elaborate_all_entities (Node_Id gnat_node) && !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)); } @@ -4969,11 +5086,12 @@ process_freeze_entity (Node_Id gnat_node) && 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)))) @@ -4981,7 +5099,9 @@ process_freeze_entity (Node_Id gnat_node) 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; } @@ -5220,7 +5340,7 @@ emit_range_check (tree gnu_expr, Entity_Id gnat_range_type) /* 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 @@ -5619,15 +5739,8 @@ process_type (Entity_Id gnat_entity) 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); } @@ -6085,28 +6198,6 @@ gnat_stabilize_reference_1 (tree e, bool force) 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); -} extern char *__gnat_to_canonical_file_spec (char *); |