From patchwork Sun Jul 18 19:33:29 2010 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit Subject: [Fortran] More clean-up with try-finally Date: Sun, 18 Jul 2010 09:33:29 -0000 From: Daniel Kraft X-Patchwork-Id: 59172 Message-Id: <4C435709.9030007@domob.eu> To: Fortran List Cc: gcc-patches Hi, the attached patch takes my last one a step further. In gfc_generate_function_code, there still was some init/clean-up code (for instance, for bounds/recursion checking but also other stuff); this is now also handled via gfc_wrapped_block and the clean-up done as try-finally. As a side effect, I now got rid of the "return label" philosophy for procedures. Instead, a RETURN statement actually returns; all follow-up code that needs to be executed is done so as part of try-finally. I hope this makes the code structure clearer to the middle-end (and at least seems simpler and more intuitive to me). I've marked two points in the patch with an XXX comment: First, I created a new global variable in trans-decl that keeps track of the currently trans'ed procedure's gfc_symbol (instead of its return label). I did not find any existing feature to get it, although I may well image there is one. Did I miss it? Second, in gfc_trans_return, se.post is added to the code after the exit jump -- maybe I did completely misunderstand something, but to me this makes no sense (as it will not be executed anyway); I guess that this just never really mattered. But I may be wrong -- so can this line go? And if so, why can we be sure that se.post needs never be handled? And if I'm wrong, why? This patch passed the test-suite, but when I wanted to re-check with a fresh svn update, bootstrap failed (since) with Comparing stages 2 and 3 warning: gcc/cc1-checksum.o differs Bootstrap comparison failure! gcc/dwarf2out.o differs gcc/recog.o differs gcc/reload.o differs gcc/i386.o differs gcc/reg-stack.o differs libiberty/hashtab.o differs. I can't image how this is related to my patch; is anyone else seeing this, too? Ok for trunk once I can bootstrap again and there are no regressions? Daniel Index: gcc/fortran/trans-stmt.c =================================================================== --- gcc/fortran/trans-stmt.c (revision 162282) +++ gcc/fortran/trans-stmt.c (working copy) @@ -491,7 +491,7 @@ gfc_trans_call (gfc_code * code, bool de /* Translate the RETURN statement. */ tree -gfc_trans_return (gfc_code * code ATTRIBUTE_UNUSED) +gfc_trans_return (gfc_code * code) { if (code->expr1) { @@ -500,16 +500,16 @@ gfc_trans_return (gfc_code * code ATTRIB tree result; /* If code->expr is not NULL, this return statement must appear - in a subroutine and current_fake_result_decl has already + in a subroutine and current_fake_result_decl has already been generated. */ result = gfc_get_fake_result_decl (NULL, 0); if (!result) - { - gfc_warning ("An alternate return at %L without a * dummy argument", - &code->expr1->where); - return build1_v (GOTO_EXPR, gfc_get_return_label ()); - } + { + gfc_warning ("An alternate return at %L without a * dummy argument", + &code->expr1->where); + return gfc_generate_return (); + } /* Start a new block for this statement. */ gfc_init_se (&se, NULL); @@ -521,13 +521,14 @@ gfc_trans_return (gfc_code * code ATTRIB fold_convert (TREE_TYPE (result), se.expr)); gfc_add_expr_to_block (&se.pre, tmp); - tmp = build1_v (GOTO_EXPR, gfc_get_return_label ()); + tmp = gfc_generate_return (); gfc_add_expr_to_block (&se.pre, tmp); + /* XXX: Why this after the exit jump??? */ gfc_add_block_to_block (&se.pre, &se.post); return gfc_finish_block (&se.pre); } - else - return build1_v (GOTO_EXPR, gfc_get_return_label ()); + + return gfc_generate_return (); } @@ -847,8 +848,7 @@ gfc_trans_block_construct (gfc_code* cod { gfc_namespace* ns; gfc_symbol* sym; - stmtblock_t body; - tree tmp; + gfc_wrapped_block body; ns = code->ext.block.ns; gcc_assert (ns); @@ -858,14 +858,12 @@ gfc_trans_block_construct (gfc_code* cod gcc_assert (!sym->tlink); sym->tlink = sym; - gfc_start_block (&body); gfc_process_block_locals (ns); - tmp = gfc_trans_code (ns->code); - tmp = gfc_trans_deferred_vars (sym, tmp); + gfc_start_wrapped_block (&body, gfc_trans_code (ns->code)); + gfc_trans_deferred_vars (sym, &body); - gfc_add_expr_to_block (&body, tmp); - return gfc_finish_block (&body); + return gfc_finish_wrapped_block (&body); } Index: gcc/fortran/trans.h =================================================================== --- gcc/fortran/trans.h (revision 162282) +++ gcc/fortran/trans.h (working copy) @@ -408,9 +408,6 @@ tree gfc_build_label_decl (tree); Do not use if the function has an explicit result variable. */ tree gfc_get_fake_result_decl (gfc_symbol *, int); -/* Get the return label for the current function. */ -tree gfc_get_return_label (void); - /* Add a decl to the binding level for the current function. */ void gfc_add_decl_to_function (tree); @@ -456,6 +453,8 @@ void gfc_generate_function_code (gfc_nam void gfc_generate_block_data (gfc_namespace *); /* Output a decl for a module variable. */ void gfc_generate_module_vars (gfc_namespace *); +/* Get the appropriate return statement for a procedure. */ +tree gfc_generate_return (void); struct GTY(()) module_htab_entry { const char *name; @@ -533,7 +532,7 @@ tree gfc_build_library_function_decl_wit void gfc_process_block_locals (gfc_namespace*); /* Output initialization/clean-up code that was deferred. */ -tree gfc_trans_deferred_vars (gfc_symbol*, tree); +void gfc_trans_deferred_vars (gfc_symbol*, gfc_wrapped_block *); /* somewhere! */ tree pushdecl (tree); Index: gcc/fortran/trans-decl.c =================================================================== --- gcc/fortran/trans-decl.c (revision 162282) +++ gcc/fortran/trans-decl.c (working copy) @@ -55,8 +55,6 @@ along with GCC; see the file COPYING3. static GTY(()) tree current_fake_result_decl; static GTY(()) tree parent_fake_result_decl; -static GTY(()) tree current_function_return_label; - /* Holds the variable DECLs for the current function. */ @@ -75,6 +73,10 @@ static GTY(()) tree saved_local_decls; static gfc_namespace *module_namespace; +/* The currently processed procedure symbol. */ +/* XXX: Is there already something like this? */ +static gfc_symbol* current_procedure_symbol = NULL; + /* List of static constructor functions. */ @@ -237,28 +239,6 @@ gfc_build_label_decl (tree label_id) } -/* Returns the return label for the current function. */ - -tree -gfc_get_return_label (void) -{ - char name[GFC_MAX_SYMBOL_LEN + 10]; - - if (current_function_return_label) - return current_function_return_label; - - sprintf (name, "__return_%s", - IDENTIFIER_POINTER (DECL_NAME (current_function_decl))); - - current_function_return_label = - gfc_build_label_decl (get_identifier (name)); - - DECL_ARTIFICIAL (current_function_return_label) = 1; - - return current_function_return_label; -} - - /* Set the backend source location of a decl. */ void @@ -3089,18 +3069,15 @@ init_intent_out_dt (gfc_symbol * proc_sy Initialization of ASSIGN statement auxiliary variable. Automatic deallocation. */ -tree -gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody) +void +gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) { locus loc; gfc_symbol *sym; gfc_formal_arglist *f; stmtblock_t tmpblock; - gfc_wrapped_block try_block; bool seen_trans_deferred_array = false; - gfc_start_wrapped_block (&try_block, fnbody); - /* Deal with implicit return variables. Explicit return variables will already have been added. */ if (gfc_return_by_reference (proc_sym) && proc_sym->result == proc_sym) @@ -3122,17 +3099,17 @@ gfc_trans_deferred_vars (gfc_symbol * pr else if (proc_sym->as) { tree result = TREE_VALUE (current_fake_result_decl); - gfc_trans_dummy_array_bias (proc_sym, result, &try_block); + gfc_trans_dummy_array_bias (proc_sym, result, block); /* An automatic character length, pointer array result. */ if (proc_sym->ts.type == BT_CHARACTER && TREE_CODE (proc_sym->ts.u.cl->backend_decl) == VAR_DECL) - gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl, &try_block); + gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl, block); } else if (proc_sym->ts.type == BT_CHARACTER) { if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == VAR_DECL) - gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl, &try_block); + gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl, block); } else gcc_assert (gfc_option.flag_f2c @@ -3142,7 +3119,7 @@ gfc_trans_deferred_vars (gfc_symbol * pr /* Initialize the INTENT(OUT) derived type dummy arguments. This should be done here so that the offsets and lbounds of arrays are available. */ - init_intent_out_dt (proc_sym, &try_block); + init_intent_out_dt (proc_sym, block); for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink) { @@ -3154,7 +3131,7 @@ gfc_trans_deferred_vars (gfc_symbol * pr { case AS_EXPLICIT: if (sym->attr.dummy || sym->attr.result) - gfc_trans_dummy_array_bias (sym, sym->backend_decl, &try_block); + gfc_trans_dummy_array_bias (sym, sym->backend_decl, block); else if (sym->attr.pointer || sym->attr.allocatable) { if (TREE_STATIC (sym->backend_decl)) @@ -3162,7 +3139,7 @@ gfc_trans_deferred_vars (gfc_symbol * pr else { seen_trans_deferred_array = true; - gfc_trans_deferred_array (sym, &try_block); + gfc_trans_deferred_array (sym, block); } } else @@ -3170,7 +3147,7 @@ gfc_trans_deferred_vars (gfc_symbol * pr if (sym_has_alloc_comp) { seen_trans_deferred_array = true; - gfc_trans_deferred_array (sym, &try_block); + gfc_trans_deferred_array (sym, block); } else if (sym->ts.type == BT_DERIVED && sym->value @@ -3179,7 +3156,7 @@ gfc_trans_deferred_vars (gfc_symbol * pr { gfc_start_block (&tmpblock); gfc_init_default_dt (sym, &tmpblock, false); - gfc_add_init_cleanup (&try_block, + gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), NULL_TREE); } @@ -3187,7 +3164,7 @@ gfc_trans_deferred_vars (gfc_symbol * pr gfc_get_backend_locus (&loc); gfc_set_backend_locus (&sym->declared_at); gfc_trans_auto_array_allocation (sym->backend_decl, - sym, &try_block); + sym, block); gfc_set_backend_locus (&loc); } break; @@ -3198,26 +3175,26 @@ gfc_trans_deferred_vars (gfc_symbol * pr /* We should always pass assumed size arrays the g77 way. */ if (sym->attr.dummy) - gfc_trans_g77_array (sym, &try_block); + gfc_trans_g77_array (sym, block); break; case AS_ASSUMED_SHAPE: /* Must be a dummy parameter. */ gcc_assert (sym->attr.dummy); - gfc_trans_dummy_array_bias (sym, sym->backend_decl, &try_block); + gfc_trans_dummy_array_bias (sym, sym->backend_decl, block); break; case AS_DEFERRED: seen_trans_deferred_array = true; - gfc_trans_deferred_array (sym, &try_block); + gfc_trans_deferred_array (sym, block); break; default: gcc_unreachable (); } if (sym_has_alloc_comp && !seen_trans_deferred_array) - gfc_trans_deferred_array (sym, &try_block); + gfc_trans_deferred_array (sym, block); } else if (sym->attr.allocatable || (sym->ts.type == BT_CLASS @@ -3252,26 +3229,26 @@ gfc_trans_deferred_vars (gfc_symbol * pr tmp = gfc_deallocate_with_status (se.expr, NULL_TREE, true, NULL); - gfc_add_init_cleanup (&try_block, gfc_finish_block (&init), tmp); + gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp); } } else if (sym_has_alloc_comp) - gfc_trans_deferred_array (sym, &try_block); + gfc_trans_deferred_array (sym, block); else if (sym->ts.type == BT_CHARACTER) { gfc_get_backend_locus (&loc); gfc_set_backend_locus (&sym->declared_at); if (sym->attr.dummy || sym->attr.result) - gfc_trans_dummy_character (sym, sym->ts.u.cl, &try_block); + gfc_trans_dummy_character (sym, sym->ts.u.cl, block); else - gfc_trans_auto_character_variable (sym, &try_block); + gfc_trans_auto_character_variable (sym, block); gfc_set_backend_locus (&loc); } else if (sym->attr.assign) { gfc_get_backend_locus (&loc); gfc_set_backend_locus (&sym->declared_at); - gfc_trans_assign_aux_var (sym, &try_block); + gfc_trans_assign_aux_var (sym, block); gfc_set_backend_locus (&loc); } else if (sym->ts.type == BT_DERIVED @@ -3281,7 +3258,7 @@ gfc_trans_deferred_vars (gfc_symbol * pr { gfc_start_block (&tmpblock); gfc_init_default_dt (sym, &tmpblock, false); - gfc_add_init_cleanup (&try_block, gfc_finish_block (&tmpblock), + gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), NULL_TREE); } else @@ -3308,9 +3285,7 @@ gfc_trans_deferred_vars (gfc_symbol * pr gfc_trans_vla_type_sizes (proc_sym, &tmpblock); } - gfc_add_init_cleanup (&try_block, gfc_finish_block (&tmpblock), NULL_TREE); - - return gfc_finish_wrapped_block (&try_block); + gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), NULL_TREE); } static GTY ((param_is (struct module_htab_entry))) htab_t module_htab; @@ -4308,6 +4283,56 @@ create_main_function (tree fndecl) } +/* Get the result expression for a procedure. */ + +static tree +get_proc_result (gfc_symbol* sym) +{ + if (sym->attr.subroutine || sym == sym->result) + { + if (current_fake_result_decl != NULL) + return TREE_VALUE (current_fake_result_decl); + + return NULL_TREE; + } + + return sym->result->backend_decl; +} + + +/* Generate an appropriate return-statement for a procedure. */ + +tree +gfc_generate_return (void) +{ + gfc_symbol* sym; + tree result; + tree fndecl; + + sym = current_procedure_symbol; + fndecl = sym->backend_decl; + + if (TREE_TYPE (DECL_RESULT (fndecl)) == void_type_node) + result = NULL_TREE; + else + { + result = get_proc_result (sym); + + /* Set the return value to the dummy result variable. The + types may be different for scalar default REAL functions + with -ff2c, therefore we have to convert. */ + if (result != NULL_TREE) + { + result = convert (TREE_TYPE (DECL_RESULT (fndecl)), result); + result = fold_build2 (MODIFY_EXPR, TREE_TYPE (result), + DECL_RESULT (fndecl), result); + } + } + + return build1_v (RETURN_EXPR, result); +} + + /* Generate code for a function. */ void @@ -4317,16 +4342,18 @@ gfc_generate_function_code (gfc_namespac tree old_context; tree decl; tree tmp; - tree tmp2; - stmtblock_t block; + stmtblock_t init, cleanup; stmtblock_t body; - tree result; + gfc_wrapped_block try_block; tree recurcheckvar = NULL_TREE; gfc_symbol *sym; + gfc_symbol *previous_procedure_symbol; int rank; bool is_recursive; sym = ns->proc_name; + previous_procedure_symbol = current_procedure_symbol; + current_procedure_symbol = sym; /* Check that the frontend isn't still using this. */ gcc_assert (sym->tlink == NULL); @@ -4348,7 +4375,7 @@ gfc_generate_function_code (gfc_namespac trans_function_start (sym); - gfc_init_block (&block); + gfc_init_block (&init); if (ns->entries && ns->proc_name->ts.type == BT_CHARACTER) { @@ -4387,34 +4414,32 @@ gfc_generate_function_code (gfc_namespac else current_fake_result_decl = NULL_TREE; - current_function_return_label = NULL; + is_recursive = sym->attr.recursive + || (sym->attr.entry_master + && sym->ns->entries->sym->attr.recursive); + if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION) + && !is_recursive + && !gfc_option.flag_recursive) + { + char * msg; + + asprintf (&msg, "Recursive call to nonrecursive procedure '%s'", + sym->name); + recurcheckvar = gfc_create_var (boolean_type_node, "is_recursive"); + TREE_STATIC (recurcheckvar) = 1; + DECL_INITIAL (recurcheckvar) = boolean_false_node; + gfc_add_expr_to_block (&init, recurcheckvar); + gfc_trans_runtime_check (true, false, recurcheckvar, &init, + &sym->declared_at, msg); + gfc_add_modify (&init, recurcheckvar, boolean_true_node); + gfc_free (msg); + } /* Now generate the code for the body of this function. */ gfc_init_block (&body); - is_recursive = sym->attr.recursive - || (sym->attr.entry_master - && sym->ns->entries->sym->attr.recursive); - if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION) - && !is_recursive - && !gfc_option.flag_recursive) - { - char * msg; - - asprintf (&msg, "Recursive call to nonrecursive procedure '%s'", - sym->name); - recurcheckvar = gfc_create_var (boolean_type_node, "is_recursive"); - TREE_STATIC (recurcheckvar) = 1; - DECL_INITIAL (recurcheckvar) = boolean_false_node; - gfc_add_expr_to_block (&block, recurcheckvar); - gfc_trans_runtime_check (true, false, recurcheckvar, &block, - &sym->declared_at, msg); - gfc_add_modify (&block, recurcheckvar, boolean_true_node); - gfc_free (msg); - } - if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node - && sym->attr.subroutine) + && sym->attr.subroutine) { tree alternate_return; alternate_return = gfc_get_fake_result_decl (sym, 0); @@ -4437,29 +4462,9 @@ gfc_generate_function_code (gfc_namespac tmp = gfc_trans_code (ns->code); gfc_add_expr_to_block (&body, tmp); - /* Add a return label if needed. */ - if (current_function_return_label) - { - tmp = build1_v (LABEL_EXPR, current_function_return_label); - gfc_add_expr_to_block (&body, tmp); - } - - tmp = gfc_finish_block (&body); - /* Add code to create and cleanup arrays. */ - tmp = gfc_trans_deferred_vars (sym, tmp); - if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node) { - if (sym->attr.subroutine || sym == sym->result) - { - if (current_fake_result_decl != NULL) - result = TREE_VALUE (current_fake_result_decl); - else - result = NULL_TREE; - current_fake_result_decl = NULL_TREE; - } - else - result = sym->result->backend_decl; + tree result = get_proc_result (sym); if (result != NULL_TREE && sym->attr.function @@ -4469,24 +4474,12 @@ gfc_generate_function_code (gfc_namespac && sym->ts.u.derived->attr.alloc_comp) { rank = sym->as ? sym->as->rank : 0; - tmp2 = gfc_nullify_alloc_comp (sym->ts.u.derived, result, rank); - gfc_add_expr_to_block (&block, tmp2); + tmp = gfc_nullify_alloc_comp (sym->ts.u.derived, result, rank); + gfc_add_expr_to_block (&init, tmp); } else if (sym->attr.allocatable && sym->attr.dimension == 0) - gfc_add_modify (&block, result, fold_convert (TREE_TYPE (result), - null_pointer_node)); - } - - gfc_add_expr_to_block (&block, tmp); - - /* Reset recursion-check variable. */ - if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION) - && !is_recursive - && !gfc_option.flag_openmp - && recurcheckvar != NULL_TREE) - { - gfc_add_modify (&block, recurcheckvar, boolean_false_node); - recurcheckvar = NULL; + gfc_add_modify (&init, result, fold_convert (TREE_TYPE (result), + null_pointer_node)); } if (result == NULL_TREE) @@ -4499,31 +4492,28 @@ gfc_generate_function_code (gfc_namespac TREE_NO_WARNING(sym->backend_decl) = 1; } else - { - /* Set the return value to the dummy result variable. The - types may be different for scalar default REAL functions - with -ff2c, therefore we have to convert. */ - tmp = convert (TREE_TYPE (DECL_RESULT (fndecl)), result); - tmp = fold_build2 (MODIFY_EXPR, TREE_TYPE (tmp), - DECL_RESULT (fndecl), tmp); - tmp = build1_v (RETURN_EXPR, tmp); - gfc_add_expr_to_block (&block, tmp); - } + gfc_add_expr_to_block (&body, gfc_generate_return ()); } - else + + gfc_init_block (&cleanup); + + /* Reset recursion-check variable. */ + if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION) + && !is_recursive + && !gfc_option.flag_openmp + && recurcheckvar != NULL_TREE) { - gfc_add_expr_to_block (&block, tmp); - /* Reset recursion-check variable. */ - if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION) - && !is_recursive - && !gfc_option.flag_openmp - && recurcheckvar != NULL_TREE) - { - gfc_add_modify (&block, recurcheckvar, boolean_false_node); - recurcheckvar = NULL_TREE; - } + gfc_add_modify (&cleanup, recurcheckvar, boolean_false_node); + recurcheckvar = NULL; } + /* Finish the function body and add init and cleanup code. */ + tmp = gfc_finish_block (&body); + gfc_start_wrapped_block (&try_block, tmp); + /* Add code to create and cleanup arrays. */ + gfc_trans_deferred_vars (sym, &try_block); + gfc_add_init_cleanup (&try_block, gfc_finish_block (&init), + gfc_finish_block (&cleanup)); /* Add all the decls we created during processing. */ decl = saved_function_decls; @@ -4538,7 +4528,7 @@ gfc_generate_function_code (gfc_namespac } saved_function_decls = NULL_TREE; - DECL_SAVED_TREE (fndecl) = gfc_finish_block (&block); + DECL_SAVED_TREE (fndecl) = gfc_finish_wrapped_block (&try_block); decl = getdecls (); /* Finish off this function and send it for code generation. */ @@ -4589,6 +4579,8 @@ gfc_generate_function_code (gfc_namespac if (sym->attr.is_main_program) create_main_function (fndecl); + + current_procedure_symbol = previous_procedure_symbol; }