From patchwork Thu Jul 15 09:07:49 2010 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Daniel Kraft X-Patchwork-Id: 58967 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) by ozlabs.org (Postfix) with SMTP id A3593B6F11 for ; Thu, 15 Jul 2010 19:03:28 +1000 (EST) Received: (qmail 28441 invoked by alias); 15 Jul 2010 09:03:22 -0000 Received: (qmail 27562 invoked by uid 22791); 15 Jul 2010 09:03:09 -0000 X-SWARE-Spam-Status: No, hits=-1.1 required=5.0 tests=AWL, BAYES_50, RCVD_IN_DNSWL_LOW, SPF_HELO_PASS, TW_DL, TW_FN, TW_TM X-Spam-Check-By: sourceware.org Received: from tatiana.utanet.at (HELO tatiana.utanet.at) (213.90.36.46) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Thu, 15 Jul 2010 09:02:57 +0000 Received: from paris.xoc.tele2net.at ([213.90.36.7]) by tatiana.utanet.at with esmtp (Exim 4.71) (envelope-from ) id 1OZKLF-0008H7-QJ; Thu, 15 Jul 2010 11:02:53 +0200 Received: from d86-33-51-75.cust.tele2.at ([86.33.51.75] helo=[192.168.1.18]) by paris.xoc.tele2net.at with esmtpa (Exim 4.71) (envelope-from ) id 1OZKLE-0005pH-J8; Thu, 15 Jul 2010 11:02:53 +0200 Message-ID: <4C3ECFE5.1020602@domob.eu> Date: Thu, 15 Jul 2010 11:07:49 +0200 From: Daniel Kraft User-Agent: Thunderbird 2.0.0.0 (X11/20070425) MIME-Version: 1.0 To: Fortran List , gcc-patches Subject: [Patch, Fortran] PR fortran/44709: Clean up local variables with try-finally Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org Hi all, the attached patch does what I wrote about in http://gcc.gnu.org/ml/fortran/2010-07/msg00058.html. Briefly, I modified gfc_trans_deferred_vars and its callees such that init and cleanup code (like memory allocation / deallocation) is collected seperately rather than wrapped around the function body directly; this is then used to do the clean-up with a try-finally middle-end expression, so that all exits safely do the cleanup automagically. Which fixes the wrong-code / memory-leak part of PR 44709. Currently, multiple returns from procedures are handled via a jump to a label at the end of the function, from which on the cleanup was done before (in order to work around the problem in the PR for BLOCKs). I think that this may no longer be needed in fact now (am I right? Or is there another reason why we want only a single exit point from all procedures?). I'll work on a second patch to remove this (if it works out) as follow-up. Hopefully this can help the middle-end a little bit and make the code-structure clearer to it. Most of the attached patch are more or less mechanical changes (except the code directly working with gfc_wrapped_block); I used to introduce a mistake there (which was fortunately caught by a lot of regressions), but please take a careful look at all those. No regressions on GNU/Linux-x86-32, and additionally valgrind shows no longer any memory leaks for code like that in the PR (and the tree-dump also looks fine). This was with SVN trunk some days ago, though, so I'm at the moment building and testing with a fresh update. Ok for trunk if no failures with that, either? Yours, Daniel Index: gcc/fortran/trans-array.c =================================================================== --- gcc/fortran/trans-array.c (revision 162209) +++ gcc/fortran/trans-array.c (working copy) @@ -4265,10 +4265,11 @@ gfc_trans_array_bounds (tree type, gfc_s /* Generate code to initialize/allocate an array variable. */ -tree -gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym, tree fnbody) +void +gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym, + gfc_wrapped_block * block) { - stmtblock_t block; + stmtblock_t init; tree type; tree tmp; tree size; @@ -4279,32 +4280,32 @@ gfc_trans_auto_array_allocation (tree de /* Do nothing for USEd variables. */ if (sym->attr.use_assoc) - return fnbody; + return; type = TREE_TYPE (decl); gcc_assert (GFC_ARRAY_TYPE_P (type)); onstack = TREE_CODE (type) != POINTER_TYPE; - gfc_start_block (&block); + gfc_start_block (&init); /* Evaluate character string length. */ if (sym->ts.type == BT_CHARACTER && onstack && !INTEGER_CST_P (sym->ts.u.cl->backend_decl)) { - gfc_conv_string_length (sym->ts.u.cl, NULL, &block); + gfc_conv_string_length (sym->ts.u.cl, NULL, &init); - gfc_trans_vla_type_sizes (sym, &block); + gfc_trans_vla_type_sizes (sym, &init); /* Emit a DECL_EXPR for this variable, which will cause the gimplifier to allocate storage, and all that good stuff. */ tmp = fold_build1 (DECL_EXPR, TREE_TYPE (decl), decl); - gfc_add_expr_to_block (&block, tmp); + gfc_add_expr_to_block (&init, tmp); } if (onstack) { - gfc_add_expr_to_block (&block, fnbody); - return gfc_finish_block (&block); + gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE); + return; } type = TREE_TYPE (type); @@ -4315,17 +4316,18 @@ gfc_trans_auto_array_allocation (tree de if (sym->ts.type == BT_CHARACTER && !INTEGER_CST_P (sym->ts.u.cl->backend_decl)) - gfc_conv_string_length (sym->ts.u.cl, NULL, &block); + gfc_conv_string_length (sym->ts.u.cl, NULL, &init); - size = gfc_trans_array_bounds (type, sym, &offset, &block); + size = gfc_trans_array_bounds (type, sym, &offset, &init); /* Don't actually allocate space for Cray Pointees. */ if (sym->attr.cray_pointee) { if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL) - gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset); - gfc_add_expr_to_block (&block, fnbody); - return gfc_finish_block (&block); + gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset); + + gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE); + return; } /* The size is the number of elements in the array, so multiply by the @@ -4335,31 +4337,27 @@ gfc_trans_auto_array_allocation (tree de fold_convert (gfc_array_index_type, tmp)); /* Allocate memory to hold the data. */ - tmp = gfc_call_malloc (&block, TREE_TYPE (decl), size); - gfc_add_modify (&block, decl, tmp); + tmp = gfc_call_malloc (&init, TREE_TYPE (decl), size); + gfc_add_modify (&init, decl, tmp); /* Set offset of the array. */ if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL) - gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset); - + gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset); /* Automatic arrays should not have initializers. */ gcc_assert (!sym->value); - gfc_add_expr_to_block (&block, fnbody); - /* Free the temporary. */ tmp = gfc_call_free (convert (pvoid_type_node, decl)); - gfc_add_expr_to_block (&block, tmp); - return gfc_finish_block (&block); + gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp); } /* Generate entry and exit code for g77 calling convention arrays. */ -tree -gfc_trans_g77_array (gfc_symbol * sym, tree body) +void +gfc_trans_g77_array (gfc_symbol * sym, gfc_wrapped_block * block) { tree parm; tree type; @@ -4367,7 +4365,7 @@ gfc_trans_g77_array (gfc_symbol * sym, t tree offset; tree tmp; tree stmt; - stmtblock_t block; + stmtblock_t init; gfc_get_backend_locus (&loc); gfc_set_backend_locus (&sym->declared_at); @@ -4377,31 +4375,29 @@ gfc_trans_g77_array (gfc_symbol * sym, t type = TREE_TYPE (parm); gcc_assert (GFC_ARRAY_TYPE_P (type)); - gfc_start_block (&block); + gfc_start_block (&init); if (sym->ts.type == BT_CHARACTER && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL) - gfc_conv_string_length (sym->ts.u.cl, NULL, &block); + gfc_conv_string_length (sym->ts.u.cl, NULL, &init); /* Evaluate the bounds of the array. */ - gfc_trans_array_bounds (type, sym, &offset, &block); + gfc_trans_array_bounds (type, sym, &offset, &init); /* Set the offset. */ if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL) - gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset); + gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset); /* Set the pointer itself if we aren't using the parameter directly. */ if (TREE_CODE (parm) != PARM_DECL) { tmp = convert (TREE_TYPE (parm), GFC_DECL_SAVED_DESCRIPTOR (parm)); - gfc_add_modify (&block, parm, tmp); + gfc_add_modify (&init, parm, tmp); } - stmt = gfc_finish_block (&block); + stmt = gfc_finish_block (&init); gfc_set_backend_locus (&loc); - gfc_start_block (&block); - /* Add the initialization code to the start of the function. */ if (sym->attr.optional || sym->attr.not_always_present) @@ -4410,10 +4406,7 @@ gfc_trans_g77_array (gfc_symbol * sym, t stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location)); } - gfc_add_expr_to_block (&block, stmt); - gfc_add_expr_to_block (&block, body); - - return gfc_finish_block (&block); + gfc_add_init_cleanup (block, stmt, NULL_TREE); } @@ -4428,22 +4421,22 @@ gfc_trans_g77_array (gfc_symbol * sym, t Code is also added to copy the data back at the end of the function. */ -tree -gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body) +void +gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, + gfc_wrapped_block * block) { tree size; tree type; tree offset; locus loc; - stmtblock_t block; - stmtblock_t cleanup; + stmtblock_t init; + tree stmtInit, stmtCleanup; tree lbound; tree ubound; tree dubound; tree dlbound; tree dumdesc; tree tmp; - tree stmt; tree stride, stride2; tree stmt_packed; tree stmt_unpacked; @@ -4456,10 +4449,13 @@ gfc_trans_dummy_array_bias (gfc_symbol * /* Do nothing for pointer and allocatable arrays. */ if (sym->attr.pointer || sym->attr.allocatable) - return body; + return; if (sym->attr.dummy && gfc_is_nodesc_array (sym)) - return gfc_trans_g77_array (sym, body); + { + gfc_trans_g77_array (sym, block); + return; + } gfc_get_backend_locus (&loc); gfc_set_backend_locus (&sym->declared_at); @@ -4468,35 +4464,32 @@ gfc_trans_dummy_array_bias (gfc_symbol * type = TREE_TYPE (tmpdesc); gcc_assert (GFC_ARRAY_TYPE_P (type)); dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc); - dumdesc = build_fold_indirect_ref_loc (input_location, - dumdesc); - gfc_start_block (&block); + dumdesc = build_fold_indirect_ref_loc (input_location, dumdesc); + gfc_start_block (&init); if (sym->ts.type == BT_CHARACTER && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL) - gfc_conv_string_length (sym->ts.u.cl, NULL, &block); + gfc_conv_string_length (sym->ts.u.cl, NULL, &init); checkparm = (sym->as->type == AS_EXPLICIT && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)); no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc) - || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc)); + || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc)); if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc)) { /* For non-constant shape arrays we only check if the first dimension - is contiguous. Repacking higher dimensions wouldn't gain us - anything as we still don't know the array stride. */ + is contiguous. Repacking higher dimensions wouldn't gain us + anything as we still don't know the array stride. */ partial = gfc_create_var (boolean_type_node, "partial"); TREE_USED (partial) = 1; tmp = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]); tmp = fold_build2 (EQ_EXPR, boolean_type_node, tmp, gfc_index_one_node); - gfc_add_modify (&block, partial, tmp); + gfc_add_modify (&init, partial, tmp); } else - { - partial = NULL_TREE; - } + partial = NULL_TREE; /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive here, however I think it does the right thing. */ @@ -4504,14 +4497,14 @@ gfc_trans_dummy_array_bias (gfc_symbol * { /* Set the first stride. */ stride = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]); - stride = gfc_evaluate_now (stride, &block); + stride = gfc_evaluate_now (stride, &init); tmp = fold_build2 (EQ_EXPR, boolean_type_node, stride, gfc_index_zero_node); tmp = fold_build3 (COND_EXPR, gfc_array_index_type, tmp, gfc_index_one_node, stride); stride = GFC_TYPE_ARRAY_STRIDE (type, 0); - gfc_add_modify (&block, stride, tmp); + gfc_add_modify (&init, stride, tmp); /* Allow the user to disable array repacking. */ stmt_unpacked = NULL_TREE; @@ -4546,7 +4539,7 @@ gfc_trans_dummy_array_bias (gfc_symbol * } else tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked; - gfc_add_modify (&block, tmpdesc, fold_convert (type, tmp)); + gfc_add_modify (&init, tmpdesc, fold_convert (type, tmp)); offset = gfc_index_zero_node; size = gfc_index_one_node; @@ -4561,34 +4554,34 @@ gfc_trans_dummy_array_bias (gfc_symbol * dlbound = gfc_conv_descriptor_lbound_get (dumdesc, gfc_rank_cst[n]); } else - { + { dubound = NULL_TREE; dlbound = NULL_TREE; - } + } lbound = GFC_TYPE_ARRAY_LBOUND (type, n); if (!INTEGER_CST_P (lbound)) - { - gfc_init_se (&se, NULL); - gfc_conv_expr_type (&se, sym->as->lower[n], - gfc_array_index_type); - gfc_add_block_to_block (&block, &se.pre); - gfc_add_modify (&block, lbound, se.expr); - } + { + gfc_init_se (&se, NULL); + gfc_conv_expr_type (&se, sym->as->lower[n], + gfc_array_index_type); + gfc_add_block_to_block (&init, &se.pre); + gfc_add_modify (&init, lbound, se.expr); + } ubound = GFC_TYPE_ARRAY_UBOUND (type, n); /* Set the desired upper bound. */ if (sym->as->upper[n]) { /* We know what we want the upper bound to be. */ - if (!INTEGER_CST_P (ubound)) - { + if (!INTEGER_CST_P (ubound)) + { gfc_init_se (&se, NULL); gfc_conv_expr_type (&se, sym->as->upper[n], - gfc_array_index_type); - gfc_add_block_to_block (&block, &se.pre); - gfc_add_modify (&block, ubound, se.expr); - } + gfc_array_index_type); + gfc_add_block_to_block (&init, &se.pre); + gfc_add_modify (&init, ubound, se.expr); + } /* Check the sizes match. */ if (checkparm) @@ -4607,11 +4600,11 @@ gfc_trans_dummy_array_bias (gfc_symbol * stride2 = fold_build2 (PLUS_EXPR, gfc_array_index_type, gfc_index_one_node, stride2); - tmp = fold_build2 (NE_EXPR, gfc_array_index_type, temp, stride2); + tmp = fold_build2 (NE_EXPR, gfc_array_index_type, temp, stride2); asprintf (&msg, "Dimension %d of array '%s' has extent " - "%%ld instead of %%ld", n+1, sym->name); + "%%ld instead of %%ld", n+1, sym->name); - gfc_trans_runtime_check (true, false, tmp, &block, &loc, msg, + gfc_trans_runtime_check (true, false, tmp, &init, &loc, msg, fold_convert (long_integer_type_node, temp), fold_convert (long_integer_type_node, stride2)); @@ -4622,10 +4615,10 @@ gfc_trans_dummy_array_bias (gfc_symbol * { /* For assumed shape arrays move the upper bound by the same amount as the lower bound. */ - tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, + tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, dubound, dlbound); - tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp, lbound); - gfc_add_modify (&block, ubound, tmp); + tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp, lbound); + gfc_add_modify (&init, ubound, tmp); } /* The offset of this dimension. offset = offset - lbound * stride. */ tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, lbound, stride); @@ -4633,41 +4626,39 @@ gfc_trans_dummy_array_bias (gfc_symbol * /* The size of this dimension, and the stride of the next. */ if (n + 1 < sym->as->rank) - { - stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1); + { + stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1); - if (no_repack || partial != NULL_TREE) - { - stmt_unpacked = - gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[n+1]); - } - - /* Figure out the stride if not a known constant. */ - if (!INTEGER_CST_P (stride)) - { - if (no_repack) - stmt_packed = NULL_TREE; - else - { - /* Calculate stride = size * (ubound + 1 - lbound). */ - tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, + if (no_repack || partial != NULL_TREE) + stmt_unpacked = + gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[n+1]); + + /* Figure out the stride if not a known constant. */ + if (!INTEGER_CST_P (stride)) + { + if (no_repack) + stmt_packed = NULL_TREE; + else + { + /* Calculate stride = size * (ubound + 1 - lbound). */ + tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, gfc_index_one_node, lbound); - tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, + tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, ubound, tmp); - size = fold_build2 (MULT_EXPR, gfc_array_index_type, + size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp); - stmt_packed = size; - } + stmt_packed = size; + } - /* Assign the stride. */ - if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE) + /* Assign the stride. */ + if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE) tmp = fold_build3 (COND_EXPR, gfc_array_index_type, partial, stmt_unpacked, stmt_packed); - else - tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked; - gfc_add_modify (&block, stride, tmp); - } - } + else + tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked; + gfc_add_modify (&init, stride, tmp); + } + } else { stride = GFC_TYPE_ARRAY_SIZE (type); @@ -4681,20 +4672,18 @@ gfc_trans_dummy_array_bias (gfc_symbol * ubound, tmp); tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, GFC_TYPE_ARRAY_STRIDE (type, n), tmp); - gfc_add_modify (&block, stride, tmp); + gfc_add_modify (&init, stride, tmp); } } } /* Set the offset. */ if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL) - gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset); + gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset); - gfc_trans_vla_type_sizes (sym, &block); + gfc_trans_vla_type_sizes (sym, &init); - stmt = gfc_finish_block (&block); - - gfc_start_block (&block); + stmtInit = gfc_finish_block (&init); /* Only do the entry/initialization code if the arg is present. */ dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc); @@ -4704,18 +4693,18 @@ gfc_trans_dummy_array_bias (gfc_symbol * if (optional_arg) { tmp = gfc_conv_expr_present (sym); - stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location)); + stmtInit = build3_v (COND_EXPR, tmp, stmtInit, + build_empty_stmt (input_location)); } - gfc_add_expr_to_block (&block, stmt); - - /* Add the main function body. */ - gfc_add_expr_to_block (&block, body); /* Cleanup code. */ - if (!no_repack) + if (no_repack) + stmtCleanup = NULL_TREE; + else { + stmtblock_t cleanup; gfc_start_block (&cleanup); - + if (sym->attr.intent != INTENT_IN) { /* Copy the data back. */ @@ -4728,26 +4717,26 @@ gfc_trans_dummy_array_bias (gfc_symbol * tmp = gfc_call_free (tmpdesc); gfc_add_expr_to_block (&cleanup, tmp); - stmt = gfc_finish_block (&cleanup); + stmtCleanup = gfc_finish_block (&cleanup); /* Only do the cleanup if the array was repacked. */ - tmp = build_fold_indirect_ref_loc (input_location, - dumdesc); + tmp = build_fold_indirect_ref_loc (input_location, dumdesc); tmp = gfc_conv_descriptor_data_get (tmp); tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp, tmpdesc); - stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location)); + stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup, + build_empty_stmt (input_location)); if (optional_arg) - { - tmp = gfc_conv_expr_present (sym); - stmt = build3_v (COND_EXPR, tmp, stmt, - build_empty_stmt (input_location)); - } - gfc_add_expr_to_block (&block, stmt); + { + tmp = gfc_conv_expr_present (sym); + stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup, + build_empty_stmt (input_location)); + } } + /* We don't need to free any memory allocated by internal_pack as it will be freed at the end of the function by pop_context. */ - return gfc_finish_block (&block); + gfc_add_init_cleanup (block, stmtInit, stmtCleanup); } @@ -6217,13 +6206,14 @@ gfc_copy_only_alloc_comp (gfc_symbol * d Do likewise, recursively if necessary, with the allocatable components of derived types. */ -tree -gfc_trans_deferred_array (gfc_symbol * sym, tree body) +void +gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block) { tree type; tree tmp; tree descriptor; - stmtblock_t fnblock; + stmtblock_t init; + stmtblock_t cleanup; locus loc; int rank; bool sym_has_alloc_comp; @@ -6237,7 +6227,7 @@ gfc_trans_deferred_array (gfc_symbol * s "allocatable attribute or derived type without allocatable " "components."); - gfc_init_block (&fnblock); + gfc_init_block (&init); gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL || TREE_CODE (sym->backend_decl) == PARM_DECL); @@ -6245,16 +6235,15 @@ gfc_trans_deferred_array (gfc_symbol * s if (sym->ts.type == BT_CHARACTER && !INTEGER_CST_P (sym->ts.u.cl->backend_decl)) { - gfc_conv_string_length (sym->ts.u.cl, NULL, &fnblock); - gfc_trans_vla_type_sizes (sym, &fnblock); + gfc_conv_string_length (sym->ts.u.cl, NULL, &init); + gfc_trans_vla_type_sizes (sym, &init); } /* Dummy, use associated and result variables don't need anything special. */ if (sym->attr.dummy || sym->attr.use_assoc || sym->attr.result) { - gfc_add_expr_to_block (&fnblock, body); - - return gfc_finish_block (&fnblock); + gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE); + return; } gfc_get_backend_locus (&loc); @@ -6268,7 +6257,9 @@ gfc_trans_deferred_array (gfc_symbol * s { /* SAVEd variables are not freed on exit. */ gfc_trans_static_array_pointer (sym); - return body; + + gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE); + return; } /* Get the descriptor type. */ @@ -6283,14 +6274,12 @@ gfc_trans_deferred_array (gfc_symbol * s || !gfc_has_default_initializer (sym->ts.u.derived)) { rank = sym->as ? sym->as->rank : 0; - tmp = gfc_nullify_alloc_comp (sym->ts.u.derived, descriptor, rank); - gfc_add_expr_to_block (&fnblock, tmp); + tmp = gfc_nullify_alloc_comp (sym->ts.u.derived, + descriptor, rank); + gfc_add_expr_to_block (&init, tmp); } else - { - tmp = gfc_init_default_dt (sym, NULL, false); - gfc_add_expr_to_block (&fnblock, tmp); - } + gfc_init_default_dt (sym, &init, false); } } else if (!GFC_DESCRIPTOR_TYPE_P (type)) @@ -6298,16 +6287,15 @@ gfc_trans_deferred_array (gfc_symbol * s /* If the backend_decl is not a descriptor, we must have a pointer to one. */ descriptor = build_fold_indirect_ref_loc (input_location, - sym->backend_decl); + sym->backend_decl); type = TREE_TYPE (descriptor); } /* NULLIFY the data pointer. */ if (GFC_DESCRIPTOR_TYPE_P (type) && !sym->attr.save) - gfc_conv_descriptor_data_set (&fnblock, descriptor, null_pointer_node); - - gfc_add_expr_to_block (&fnblock, body); + gfc_conv_descriptor_data_set (&init, descriptor, null_pointer_node); + gfc_init_block (&cleanup); gfc_set_backend_locus (&loc); /* Allocatable arrays need to be freed when they go out of scope. @@ -6318,17 +6306,18 @@ gfc_trans_deferred_array (gfc_symbol * s int rank; rank = sym->as ? sym->as->rank : 0; tmp = gfc_deallocate_alloc_comp (sym->ts.u.derived, descriptor, rank); - gfc_add_expr_to_block (&fnblock, tmp); + gfc_add_expr_to_block (&cleanup, tmp); } if (sym->attr.allocatable && sym->attr.dimension && !sym->attr.save && !sym->attr.result) { tmp = gfc_trans_dealloc_allocated (sym->backend_decl); - gfc_add_expr_to_block (&fnblock, tmp); + gfc_add_expr_to_block (&cleanup, tmp); } - return gfc_finish_block (&fnblock); + gfc_add_init_cleanup (block, gfc_finish_block (&init), + gfc_finish_block (&cleanup)); } /************ Expression Walking Functions ******************/ Index: gcc/fortran/trans-array.h =================================================================== --- gcc/fortran/trans-array.h (revision 162209) +++ gcc/fortran/trans-array.h (working copy) @@ -37,11 +37,11 @@ tree gfc_trans_create_temp_array (stmtbl /* Generate function entry code for allocation of compiler allocated array variables. */ -tree gfc_trans_auto_array_allocation (tree, gfc_symbol *, tree); +void gfc_trans_auto_array_allocation (tree, gfc_symbol *, gfc_wrapped_block *); /* Generate entry and exit code for dummy array parameters. */ -tree gfc_trans_dummy_array_bias (gfc_symbol *, tree, tree); +void gfc_trans_dummy_array_bias (gfc_symbol *, tree, gfc_wrapped_block *); /* Generate entry and exit code for g77 calling convention arrays. */ -tree gfc_trans_g77_array (gfc_symbol *, tree); +void gfc_trans_g77_array (gfc_symbol *, gfc_wrapped_block *); /* Generate code to deallocate an array, if it is allocated. */ tree gfc_trans_dealloc_allocated (tree); @@ -58,7 +58,7 @@ tree gfc_copy_alloc_comp (gfc_symbol *, tree gfc_copy_only_alloc_comp (gfc_symbol *, tree, tree, int); /* Add initialization for deferred arrays. */ -tree gfc_trans_deferred_array (gfc_symbol *, tree); +void gfc_trans_deferred_array (gfc_symbol *, gfc_wrapped_block *); /* Generate an initializer for a static pointer or allocatable array. */ void gfc_trans_static_array_pointer (gfc_symbol *); Index: gcc/fortran/trans.c =================================================================== --- gcc/fortran/trans.c (revision 162209) +++ gcc/fortran/trans.c (working copy) @@ -977,31 +977,47 @@ gfc_call_realloc (stmtblock_t * block, t return res; } -/* Add a statement to a block. */ -void -gfc_add_expr_to_block (stmtblock_t * block, tree expr) -{ - gcc_assert (block); +/* Add an expression to another one, either at the front or the back. */ +static void +add_expr_to_chain (tree* chain, tree expr, bool front) +{ if (expr == NULL_TREE || IS_EMPTY_STMT (expr)) return; - if (block->head) + if (*chain) { - if (TREE_CODE (block->head) != STATEMENT_LIST) + if (TREE_CODE (*chain) != STATEMENT_LIST) { tree tmp; - tmp = block->head; - block->head = NULL_TREE; - append_to_statement_list (tmp, &block->head); + tmp = *chain; + *chain = NULL_TREE; + append_to_statement_list (tmp, chain); } - append_to_statement_list (expr, &block->head); + + if (front) + { + tree_stmt_iterator i; + + i = tsi_start (*chain); + tsi_link_before (&i, expr, TSI_CONTINUE_LINKING); + } + else + append_to_statement_list (expr, chain); } else - /* Don't bother creating a list if we only have a single statement. */ - block->head = expr; + *chain = expr; +} + +/* Add a statement to a block. */ + +void +gfc_add_expr_to_block (stmtblock_t * block, tree expr) +{ + gcc_assert (block); + add_expr_to_chain (&block->head, expr, false); } @@ -1393,3 +1409,55 @@ gfc_generate_module_code (gfc_namespace } } + +/* Initialize an init/cleanup block with existing code. */ + +void +gfc_start_wrapped_block (gfc_wrapped_block* block, tree code) +{ + gcc_assert (block); + + block->init = NULL_TREE; + block->code = code; + block->cleanup = NULL_TREE; +} + + +/* Add a new pair of initializers/clean-up code. */ + +void +gfc_add_init_cleanup (gfc_wrapped_block* block, tree init, tree cleanup) +{ + gcc_assert (block); + + /* The new pair of init/cleanup should be "wrapped around" the existing + block of code, thus the initialization is added to the front and the + cleanup to the back. */ + add_expr_to_chain (&block->init, init, true); + add_expr_to_chain (&block->cleanup, cleanup, false); +} + + +/* Finish up a wrapped block by building a corresponding try-finally expr. */ + +tree +gfc_finish_wrapped_block (gfc_wrapped_block* block) +{ + tree result; + + gcc_assert (block); + + /* Build the final expression. For this, just add init and body together, + and put clean-up with that into a TRY_FINALLY_EXPR. */ + result = block->init; + add_expr_to_chain (&result, block->code, false); + if (block->cleanup) + result = build2 (TRY_FINALLY_EXPR, void_type_node, result, block->cleanup); + + /* Clear the block. */ + block->init = NULL_TREE; + block->code = NULL_TREE; + block->cleanup = NULL_TREE; + + return result; +} Index: gcc/fortran/trans.h =================================================================== --- gcc/fortran/trans.h (revision 162209) +++ gcc/fortran/trans.h (working copy) @@ -258,6 +258,29 @@ typedef struct gfc_saved_var; +/* Store information about a block of code together with special + initialization and clean-up code. This can be used to incrementally add + init and cleanup, and in the end put everything together to a + try-finally expression. */ +typedef struct +{ + tree init; + tree cleanup; + tree code; +} +gfc_wrapped_block; + + +/* Initialize an init/cleanup block. */ +void gfc_start_wrapped_block (gfc_wrapped_block* block, tree code); +/* Add a pair of init/cleanup code to the block. Each one might be a + NULL_TREE if not required. */ +void gfc_add_init_cleanup (gfc_wrapped_block* block, tree init, tree cleanup); +/* Finalize the block, that is, create a single expression encapsulating the + original code together with init and clean-up code. */ +tree gfc_finish_wrapped_block (gfc_wrapped_block* block); + + /* Advance the SS chain to the next term. */ void gfc_advance_se_ss_chain (gfc_se *); @@ -403,7 +426,7 @@ tree gfc_get_symbol_decl (gfc_symbol *); tree gfc_conv_initializer (gfc_expr *, gfc_typespec *, tree, bool, bool); /* Assign a default initializer to a derived type. */ -tree gfc_init_default_dt (gfc_symbol *, tree, bool); +void gfc_init_default_dt (gfc_symbol *, stmtblock_t *, bool); /* Substitute a temporary variable in place of the real one. */ void gfc_shadow_sym (gfc_symbol *, tree, gfc_saved_var *); Index: gcc/fortran/trans-decl.c =================================================================== --- gcc/fortran/trans-decl.c (revision 162209) +++ gcc/fortran/trans-decl.c (working copy) @@ -2838,72 +2838,70 @@ gfc_build_builtin_function_decls (void) /* Evaluate the length of dummy character variables. */ -static tree -gfc_trans_dummy_character (gfc_symbol *sym, gfc_charlen *cl, tree fnbody) +static void +gfc_trans_dummy_character (gfc_symbol *sym, gfc_charlen *cl, + gfc_wrapped_block *block) { - stmtblock_t body; + stmtblock_t init; gfc_finish_decl (cl->backend_decl); - gfc_start_block (&body); + gfc_start_block (&init); /* Evaluate the string length expression. */ - gfc_conv_string_length (cl, NULL, &body); + gfc_conv_string_length (cl, NULL, &init); - gfc_trans_vla_type_sizes (sym, &body); + gfc_trans_vla_type_sizes (sym, &init); - gfc_add_expr_to_block (&body, fnbody); - return gfc_finish_block (&body); + gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE); } /* Allocate and cleanup an automatic character variable. */ -static tree -gfc_trans_auto_character_variable (gfc_symbol * sym, tree fnbody) +static void +gfc_trans_auto_character_variable (gfc_symbol * sym, gfc_wrapped_block * block) { - stmtblock_t body; + stmtblock_t init; tree decl; tree tmp; gcc_assert (sym->backend_decl); gcc_assert (sym->ts.u.cl && sym->ts.u.cl->length); - gfc_start_block (&body); + gfc_start_block (&init); /* Evaluate the string length expression. */ - gfc_conv_string_length (sym->ts.u.cl, NULL, &body); + gfc_conv_string_length (sym->ts.u.cl, NULL, &init); - gfc_trans_vla_type_sizes (sym, &body); + gfc_trans_vla_type_sizes (sym, &init); decl = sym->backend_decl; /* Emit a DECL_EXPR for this variable, which will cause the gimplifier to allocate storage, and all that good stuff. */ tmp = fold_build1 (DECL_EXPR, TREE_TYPE (decl), decl); - gfc_add_expr_to_block (&body, tmp); + gfc_add_expr_to_block (&init, tmp); - gfc_add_expr_to_block (&body, fnbody); - return gfc_finish_block (&body); + gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE); } /* Set the initial value of ASSIGN statement auxiliary variable explicitly. */ -static tree -gfc_trans_assign_aux_var (gfc_symbol * sym, tree fnbody) +static void +gfc_trans_assign_aux_var (gfc_symbol * sym, gfc_wrapped_block * block) { - stmtblock_t body; + stmtblock_t init; gcc_assert (sym->backend_decl); - gfc_start_block (&body); + gfc_start_block (&init); /* Set the initial value to length. See the comments in function gfc_add_assign_aux_vars in this file. */ - gfc_add_modify (&body, GFC_DECL_STRING_LEN (sym->backend_decl), - build_int_cst (NULL_TREE, -2)); + gfc_add_modify (&init, GFC_DECL_STRING_LEN (sym->backend_decl), + build_int_cst (NULL_TREE, -2)); - gfc_add_expr_to_block (&body, fnbody); - return gfc_finish_block (&body); + gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE); } static void @@ -3016,15 +3014,15 @@ gfc_trans_vla_type_sizes (gfc_symbol *sy /* Initialize a derived type by building an lvalue from the symbol and using trans_assignment to do the work. Set dealloc to false if no deallocation prior the assignment is needed. */ -tree -gfc_init_default_dt (gfc_symbol * sym, tree body, bool dealloc) +void +gfc_init_default_dt (gfc_symbol * sym, stmtblock_t * block, bool dealloc) { - stmtblock_t fnblock; gfc_expr *e; tree tmp; tree present; - gfc_init_block (&fnblock); + gcc_assert (block); + gcc_assert (!sym->attr.allocatable); gfc_set_sym_referenced (sym); e = gfc_lval_expr_from_sym (sym); @@ -3036,11 +3034,8 @@ gfc_init_default_dt (gfc_symbol * sym, t tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present, tmp, build_empty_stmt (input_location)); } - gfc_add_expr_to_block (&fnblock, tmp); + gfc_add_expr_to_block (block, tmp); gfc_free_expr (e); - if (body) - gfc_add_expr_to_block (&fnblock, body); - return gfc_finish_block (&fnblock); } @@ -3048,15 +3043,15 @@ gfc_init_default_dt (gfc_symbol * sym, t them their default initializer, if they do not have allocatable components, they have their allocatable components deallocated. */ -static tree -init_intent_out_dt (gfc_symbol * proc_sym, tree body) +static void +init_intent_out_dt (gfc_symbol * proc_sym, gfc_wrapped_block * block) { - stmtblock_t fnblock; + stmtblock_t init; gfc_formal_arglist *f; tree tmp; tree present; - gfc_init_block (&fnblock); + gfc_init_block (&init); for (f = proc_sym->formal; f; f = f->next) if (f->sym && f->sym->attr.intent == INTENT_OUT && !f->sym->attr.pointer @@ -3076,14 +3071,13 @@ init_intent_out_dt (gfc_symbol * proc_sy tmp, build_empty_stmt (input_location)); } - gfc_add_expr_to_block (&fnblock, tmp); + gfc_add_expr_to_block (&init, tmp); } else if (f->sym->value) - body = gfc_init_default_dt (f->sym, body, true); + gfc_init_default_dt (f->sym, &init, true); } - gfc_add_expr_to_block (&fnblock, body); - return gfc_finish_block (&fnblock); + gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE); } @@ -3101,9 +3095,12 @@ gfc_trans_deferred_vars (gfc_symbol * pr locus loc; gfc_symbol *sym; gfc_formal_arglist *f; - stmtblock_t body; + 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) @@ -3125,19 +3122,17 @@ gfc_trans_deferred_vars (gfc_symbol * pr else if (proc_sym->as) { tree result = TREE_VALUE (current_fake_result_decl); - fnbody = gfc_trans_dummy_array_bias (proc_sym, result, fnbody); + gfc_trans_dummy_array_bias (proc_sym, result, &try_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) - fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl, - fnbody); + gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl, &try_block); } else if (proc_sym->ts.type == BT_CHARACTER) { if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == VAR_DECL) - fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl, - fnbody); + gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl, &try_block); } else gcc_assert (gfc_option.flag_f2c @@ -3147,7 +3142,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. */ - fnbody = init_intent_out_dt (proc_sym, fnbody); + init_intent_out_dt (proc_sym, &try_block); for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink) { @@ -3159,8 +3154,7 @@ gfc_trans_deferred_vars (gfc_symbol * pr { case AS_EXPLICIT: if (sym->attr.dummy || sym->attr.result) - fnbody = - gfc_trans_dummy_array_bias (sym, sym->backend_decl, fnbody); + gfc_trans_dummy_array_bias (sym, sym->backend_decl, &try_block); else if (sym->attr.pointer || sym->attr.allocatable) { if (TREE_STATIC (sym->backend_decl)) @@ -3168,7 +3162,7 @@ gfc_trans_deferred_vars (gfc_symbol * pr else { seen_trans_deferred_array = true; - fnbody = gfc_trans_deferred_array (sym, fnbody); + gfc_trans_deferred_array (sym, &try_block); } } else @@ -3176,18 +3170,24 @@ gfc_trans_deferred_vars (gfc_symbol * pr if (sym_has_alloc_comp) { seen_trans_deferred_array = true; - fnbody = gfc_trans_deferred_array (sym, fnbody); + gfc_trans_deferred_array (sym, &try_block); } else if (sym->ts.type == BT_DERIVED && sym->value && !sym->attr.data && sym->attr.save == SAVE_NONE) - fnbody = gfc_init_default_dt (sym, fnbody, false); + { + gfc_start_block (&tmpblock); + gfc_init_default_dt (sym, &tmpblock, false); + gfc_add_init_cleanup (&try_block, + gfc_finish_block (&tmpblock), + NULL_TREE); + } gfc_get_backend_locus (&loc); gfc_set_backend_locus (&sym->declared_at); - fnbody = gfc_trans_auto_array_allocation (sym->backend_decl, - sym, fnbody); + gfc_trans_auto_array_allocation (sym->backend_decl, + sym, &try_block); gfc_set_backend_locus (&loc); } break; @@ -3198,27 +3198,26 @@ gfc_trans_deferred_vars (gfc_symbol * pr /* We should always pass assumed size arrays the g77 way. */ if (sym->attr.dummy) - fnbody = gfc_trans_g77_array (sym, fnbody); - break; + gfc_trans_g77_array (sym, &try_block); + break; case AS_ASSUMED_SHAPE: /* Must be a dummy parameter. */ gcc_assert (sym->attr.dummy); - fnbody = gfc_trans_dummy_array_bias (sym, sym->backend_decl, - fnbody); + gfc_trans_dummy_array_bias (sym, sym->backend_decl, &try_block); break; case AS_DEFERRED: seen_trans_deferred_array = true; - fnbody = gfc_trans_deferred_array (sym, fnbody); + gfc_trans_deferred_array (sym, &try_block); break; default: gcc_unreachable (); } if (sym_has_alloc_comp && !seen_trans_deferred_array) - fnbody = gfc_trans_deferred_array (sym, fnbody); + gfc_trans_deferred_array (sym, &try_block); } else if (sym->attr.allocatable || (sym->ts.type == BT_CLASS @@ -3231,7 +3230,7 @@ gfc_trans_deferred_vars (gfc_symbol * pr tree tmp; gfc_expr *e; gfc_se se; - stmtblock_t block; + stmtblock_t init; e = gfc_lval_expr_from_sym (sym); if (sym->ts.type == BT_CLASS) @@ -3243,49 +3242,53 @@ gfc_trans_deferred_vars (gfc_symbol * pr gfc_free_expr (e); /* Nullify when entering the scope. */ - gfc_start_block (&block); - gfc_add_modify (&block, se.expr, + gfc_start_block (&init); + gfc_add_modify (&init, se.expr, fold_convert (TREE_TYPE (se.expr), null_pointer_node)); - gfc_add_expr_to_block (&block, fnbody); /* Deallocate when leaving the scope. Nullifying is not needed. */ tmp = gfc_deallocate_with_status (se.expr, NULL_TREE, true, NULL); - gfc_add_expr_to_block (&block, tmp); - fnbody = gfc_finish_block (&block); + + gfc_add_init_cleanup (&try_block, gfc_finish_block (&init), tmp); } } else if (sym_has_alloc_comp) - fnbody = gfc_trans_deferred_array (sym, fnbody); + gfc_trans_deferred_array (sym, &try_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) - fnbody = gfc_trans_dummy_character (sym, sym->ts.u.cl, fnbody); + gfc_trans_dummy_character (sym, sym->ts.u.cl, &try_block); else - fnbody = gfc_trans_auto_character_variable (sym, fnbody); + gfc_trans_auto_character_variable (sym, &try_block); gfc_set_backend_locus (&loc); } else if (sym->attr.assign) { gfc_get_backend_locus (&loc); gfc_set_backend_locus (&sym->declared_at); - fnbody = gfc_trans_assign_aux_var (sym, fnbody); + gfc_trans_assign_aux_var (sym, &try_block); gfc_set_backend_locus (&loc); } else if (sym->ts.type == BT_DERIVED && sym->value && !sym->attr.data && sym->attr.save == SAVE_NONE) - fnbody = gfc_init_default_dt (sym, fnbody, false); + { + gfc_start_block (&tmpblock); + gfc_init_default_dt (sym, &tmpblock, false); + gfc_add_init_cleanup (&try_block, gfc_finish_block (&tmpblock), + NULL_TREE); + } else gcc_unreachable (); } - gfc_init_block (&body); + gfc_init_block (&tmpblock); for (f = proc_sym->formal; f; f = f->next) { @@ -3293,7 +3296,7 @@ gfc_trans_deferred_vars (gfc_symbol * pr { gcc_assert (f->sym->ts.u.cl->backend_decl != NULL); if (TREE_CODE (f->sym->ts.u.cl->backend_decl) == PARM_DECL) - gfc_trans_vla_type_sizes (f->sym, &body); + gfc_trans_vla_type_sizes (f->sym, &tmpblock); } } @@ -3302,11 +3305,12 @@ gfc_trans_deferred_vars (gfc_symbol * pr { gcc_assert (proc_sym->ts.u.cl->backend_decl != NULL); if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == PARM_DECL) - gfc_trans_vla_type_sizes (proc_sym, &body); + gfc_trans_vla_type_sizes (proc_sym, &tmpblock); } - gfc_add_expr_to_block (&body, fnbody); - return gfc_finish_block (&body); + gfc_add_init_cleanup (&try_block, gfc_finish_block (&tmpblock), NULL_TREE); + + return gfc_finish_wrapped_block (&try_block); } static GTY ((param_is (struct module_htab_entry))) htab_t module_htab;