From d0d776fb3221737c425028a15362787b9ce4f372 Mon Sep 17 00:00:00 2001 From: burnus Date: Fri, 6 Jan 2012 13:38:49 +0000 Subject: 2012-01-06 Tobias Burnus * trans-openmp.c (gfc_omp_clause_dtor, * gfc_trans_omp_array_reduction): Update call to gfc_trans_dealloc_allocated. * trans.c (gfc_allocate_using_malloc): Fix spacing. (gfc_allocate_allocatable): For gfc_allocate_using_lib, jump to label_finish when an error occurs. (gfc_deallocate_with_status): Call caf_deregister for -fcoarray=lib. * trans.h (gfc_allocate_allocatable, * gfc_deallocate_with_status): Update prototype. (gfor_fndecl_caf_deregister): New tree symbol. * trans-expr.c (gfc_conv_procedure_call): Update gfc_deallocate_with_status and gfc_trans_dealloc_allocated calls. * trans-array.c (gfc_array_allocate, * gfc_trans_dealloc_allocated, structure_alloc_comps, gfc_trans_deferred_array): Ditto. (gfc_array_deallocate): Handle coarrays with -fcoarray=lib. * trans-array.h (gfc_array_deallocate, gfc_array_allocate, gfc_trans_dealloc_allocated): Update prototypes. * trans-stmt.c (gfc_trans_sync): Fix indentation. (gfc_trans_allocate): Fix errmsg padding and label handling. (gfc_trans_deallocate): Ditto and handle -fcoarray=lib. * expr.c (gfc_is_coarray): Fix algorithm for BT_CLASS. * libgfortran.h (GFC_STAT_STOPPED_IMAGE): Use large value to avoid other stats accidentally matching this one. * trans-decl.c (gfor_fndecl_caf_deregister): New global var. (gfc_build_builtin_function_decls): Fix prototype decl of caf_register and add decl for caf_deregister. (gfc_trans_deferred_vars): Handle CAF vars with -fcoarrays=lib. * trans-intrinsic.c (conv_intrinsic_move_alloc): Update call to gfc_deallocate_with_status. 2012-01-06 Tobias Burnus * caf/single.c (_gfortran_caf_register, * _gfortran_caf_deregister): Fix token handling. * caf/mpi.c (_gfortran_caf_register, _gfortran_caf_deregister): * Ditto. * caf/libcaf.h (STAT_STOPPED_IMAGE): Sync with libgfortran.h. (_gfortran_caf_register, _gfortran_caf_deregister): Update prototype. 2012-01-06 Tobias Burnus * gfortran.dg/deallocate_stat_2.f90: New. * coarray/allocate_errgmsg.f90: New. * gfortran.dg/coarray_lib_alloc_1.f90: New. * gfortran.dg/coarray_lib_alloc_2.f90: New. * coarray/subobject_1.f90: Fix for num_images > 1. * gfortran.dg/deallocate_stat.f90: Update due to changed stat= handling. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@182951 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/ChangeLog | 31 ++++++++ gcc/fortran/expr.c | 16 ++-- gcc/fortran/libgfortran.h | 4 +- gcc/fortran/trans-array.c | 40 +++++++--- gcc/fortran/trans-array.h | 9 ++- gcc/fortran/trans-decl.c | 27 +++++-- gcc/fortran/trans-expr.c | 10 ++- gcc/fortran/trans-intrinsic.c | 6 +- gcc/fortran/trans-openmp.c | 6 +- gcc/fortran/trans-stmt.c | 168 +++++++++++++++++++++++------------------- gcc/fortran/trans.c | 144 +++++++++++++++++++++++++++++------- gcc/fortran/trans.h | 9 ++- 12 files changed, 330 insertions(+), 140 deletions(-) (limited to 'gcc/fortran') diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 879c564027e..19f7d7bf496 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,34 @@ +2012-01-06 Tobias Burnus + + * trans-openmp.c (gfc_omp_clause_dtor, gfc_trans_omp_array_reduction): + Update call to gfc_trans_dealloc_allocated. + * trans.c (gfc_allocate_using_malloc): Fix spacing. + (gfc_allocate_allocatable): For gfc_allocate_using_lib, jump to + label_finish when an error occurs. + (gfc_deallocate_with_status): Call caf_deregister for -fcoarray=lib. + * trans.h (gfc_allocate_allocatable, gfc_deallocate_with_status): + Update prototype. + (gfor_fndecl_caf_deregister): New tree symbol. + * trans-expr.c (gfc_conv_procedure_call): Update + gfc_deallocate_with_status and gfc_trans_dealloc_allocated calls. + * trans-array.c (gfc_array_allocate, gfc_trans_dealloc_allocated, + structure_alloc_comps, gfc_trans_deferred_array): Ditto. + (gfc_array_deallocate): Handle coarrays with -fcoarray=lib. + * trans-array.h (gfc_array_deallocate, gfc_array_allocate, + gfc_trans_dealloc_allocated): Update prototypes. + * trans-stmt.c (gfc_trans_sync): Fix indentation. + (gfc_trans_allocate): Fix errmsg padding and label handling. + (gfc_trans_deallocate): Ditto and handle -fcoarray=lib. + * expr.c (gfc_is_coarray): Fix algorithm for BT_CLASS. + * libgfortran.h (GFC_STAT_STOPPED_IMAGE): Use large value + to avoid other stats accidentally matching this one. + * trans-decl.c (gfor_fndecl_caf_deregister): New global var. + (gfc_build_builtin_function_decls): Fix prototype decl of caf_register + and add decl for caf_deregister. + (gfc_trans_deferred_vars): Handle CAF vars with -fcoarrays=lib. + * trans-intrinsic.c (conv_intrinsic_move_alloc): Update call to + gfc_deallocate_with_status. + 2012-01-05 Paul Thomas PR fortran/PR48946 diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index 182738cbf3d..a6baa68168f 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -1,6 +1,6 @@ /* Routines for manipulation of expression nodes. Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, - 2009, 2010, 2011 + 2009, 2010, 2011, 2012 Free Software Foundation, Inc. Contributed by Andy Vaught @@ -4264,13 +4264,17 @@ gfc_is_coarray (gfc_expr *e) { case REF_COMPONENT: comp = ref->u.c.component; - if (comp->attr.pointer || comp->attr.allocatable) + if (comp->ts.type == BT_CLASS && comp->attr.class_ok + && (CLASS_DATA (comp)->attr.class_pointer + || CLASS_DATA (comp)->attr.allocatable)) { coindexed = false; - if (comp->ts.type == BT_CLASS && comp->attr.class_ok) - coarray = CLASS_DATA (comp)->attr.codimension; - else - coarray = comp->attr.codimension; + coarray = CLASS_DATA (comp)->attr.codimension; + } + else if (comp->attr.pointer || comp->attr.allocatable) + { + coindexed = false; + coarray = comp->attr.codimension; } break; diff --git a/gcc/fortran/libgfortran.h b/gcc/fortran/libgfortran.h index 874cd9537bb..3f36fe88bbf 100644 --- a/gcc/fortran/libgfortran.h +++ b/gcc/fortran/libgfortran.h @@ -1,5 +1,5 @@ /* Header file to the Fortran front-end and runtime library - Copyright (C) 2007, 2008, 2009, 2010, 2011 + Copyright (C) 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. This file is part of GCC. @@ -105,7 +105,7 @@ typedef enum GFC_STAT_UNLOCKED = 0, GFC_STAT_LOCKED, GFC_STAT_LOCKED_OTHER_IMAGE, - GFC_STAT_STOPPED_IMAGE /* See LIBERROR_INQUIRE_INTERNAL_UNIT above. */ + GFC_STAT_STOPPED_IMAGE = 6000 /* See LIBERROR_INQUIRE_INTERNAL_UNIT above. */ } libgfortran_stat_codes; diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 494721ee476..b9902b9d52e 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -4938,7 +4938,7 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, bool gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg, - tree errlen, gfc_expr *expr3) + tree errlen, tree label_finish, gfc_expr *expr3) { tree tmp; tree pointer; @@ -5064,7 +5064,7 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg, /* The allocatable variant takes the old pointer as first argument. */ if (allocatable) gfc_allocate_allocatable (&elseblock, pointer, size, token, - status, errmsg, errlen, expr); + status, errmsg, errlen, label_finish, expr); else gfc_allocate_using_malloc (&elseblock, pointer, size, status); @@ -5127,24 +5127,40 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg, /*GCC ARRAYS*/ tree -gfc_array_deallocate (tree descriptor, tree pstat, gfc_expr* expr) +gfc_array_deallocate (tree descriptor, tree pstat, tree errmsg, tree errlen, + tree label_finish, gfc_expr* expr) { tree var; tree tmp; stmtblock_t block; + bool coarray = gfc_is_coarray (expr); gfc_start_block (&block); + /* Get a pointer to the data. */ var = gfc_conv_descriptor_data_get (descriptor); STRIP_NOPS (var); /* Parameter is the address of the data component. */ - tmp = gfc_deallocate_with_status (var, pstat, false, expr); + tmp = gfc_deallocate_with_status (coarray ? descriptor : var, pstat, errmsg, + errlen, label_finish, false, expr, coarray); gfc_add_expr_to_block (&block, tmp); - /* Zero the data pointer. */ + /* Zero the data pointer; only for coarrays an error can occur and then + the allocation status may not be changed. */ tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, var, build_int_cst (TREE_TYPE (var), 0)); + if (pstat != NULL_TREE && coarray && gfc_option.coarray == GFC_FCOARRAY_LIB) + { + tree cond; + tree stat = build_fold_indirect_ref_loc (input_location, pstat); + + cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, + stat, build_int_cst (TREE_TYPE (stat), 0)); + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, + cond, tmp, build_empty_stmt (input_location)); + } + gfc_add_expr_to_block (&block, tmp); return gfc_finish_block (&block); @@ -7055,7 +7071,7 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77, /* Generate code to deallocate an array, if it is allocated. */ tree -gfc_trans_dealloc_allocated (tree descriptor) +gfc_trans_dealloc_allocated (tree descriptor, bool coarray) { tree tmp; tree var; @@ -7069,7 +7085,9 @@ gfc_trans_dealloc_allocated (tree descriptor) /* Call array_deallocate with an int * present in the second argument. Although it is ignored here, it's presence ensures that arrays that are already deallocated are ignored. */ - tmp = gfc_deallocate_with_status (var, NULL_TREE, true, NULL); + tmp = gfc_deallocate_with_status (coarray ? descriptor : var, NULL_TREE, + NULL_TREE, NULL_TREE, NULL_TREE, true, + NULL, coarray); gfc_add_expr_to_block (&block, tmp); /* Zero the data pointer. */ @@ -7358,7 +7376,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, { comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, decl, cdecl, NULL_TREE); - tmp = gfc_trans_dealloc_allocated (comp); + tmp = gfc_trans_dealloc_allocated (comp, c->attr.codimension); gfc_add_expr_to_block (&fnblock, tmp); } else if (c->attr.allocatable) @@ -7388,7 +7406,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, TREE_TYPE (tmp), comp, tmp, NULL_TREE); if (GFC_DESCRIPTOR_TYPE_P(TREE_TYPE (comp))) - tmp = gfc_trans_dealloc_allocated (comp); + tmp = gfc_trans_dealloc_allocated (comp, + CLASS_DATA (c)->attr.codimension); else { tmp = gfc_deallocate_scalar_with_status (comp, NULL, true, NULL, @@ -8094,7 +8113,8 @@ gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block) if (sym->attr.allocatable && (sym->attr.dimension || sym->attr.codimension) && !sym->attr.save && !sym->attr.result) { - tmp = gfc_trans_dealloc_allocated (sym->backend_decl); + tmp = gfc_trans_dealloc_allocated (sym->backend_decl, + sym->attr.codimension); gfc_add_expr_to_block (&cleanup, tmp); } diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h index 19cfac52b7f..ed922d02814 100644 --- a/gcc/fortran/trans-array.h +++ b/gcc/fortran/trans-array.h @@ -1,5 +1,5 @@ /* Header for array handling functions - Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 + Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2012 Free Software Foundation, Inc. Contributed by Paul Brook @@ -20,11 +20,12 @@ along with GCC; see the file COPYING3. If not see . */ /* Generate code to free an array. */ -tree gfc_array_deallocate (tree, tree, gfc_expr*); +tree gfc_array_deallocate (tree, tree, tree, tree, tree, gfc_expr*); /* Generate code to initialize and allocate an array. Statements are added to se, which should contain an expression for the array descriptor. */ -bool gfc_array_allocate (gfc_se *, gfc_expr *, tree, tree, tree, gfc_expr *); +bool gfc_array_allocate (gfc_se *, gfc_expr *, tree, tree, tree, tree, + gfc_expr *); /* Allow the bounds of a loop to be set from a callee's array spec. */ void gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping *, @@ -42,7 +43,7 @@ void gfc_trans_dummy_array_bias (gfc_symbol *, tree, gfc_wrapped_block *); /* Generate entry and exit code for g77 calling convention arrays. */ 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); +tree gfc_trans_dealloc_allocated (tree, bool); tree gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank); diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 14332f69f6d..0761ebb26d1 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -1,6 +1,6 @@ /* Backend function setup Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, - 2011 + 2011, 2012 Free Software Foundation, Inc. Contributed by Paul Brook @@ -121,6 +121,7 @@ tree gfor_fndecl_associated; tree gfor_fndecl_caf_init; tree gfor_fndecl_caf_finalize; tree gfor_fndecl_caf_register; +tree gfor_fndecl_caf_deregister; tree gfor_fndecl_caf_critical; tree gfor_fndecl_caf_end_critical; tree gfor_fndecl_caf_sync_all; @@ -3163,7 +3164,11 @@ gfc_build_builtin_function_decls (void) gfor_fndecl_caf_register = gfc_build_library_function_decl_with_spec ( get_identifier (PREFIX("caf_register")), "...WWW", pvoid_type_node, 6, size_type_node, integer_type_node, ppvoid_type_node, pint_type, - build_pointer_type (pchar_type_node), integer_type_node); + pchar_type_node, integer_type_node); + + gfor_fndecl_caf_deregister = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("caf_deregister")), ".WWW", void_type_node, 4, + ppvoid_type_node, pint_type, pchar_type_node, integer_type_node); gfor_fndecl_caf_critical = gfc_build_library_function_decl ( get_identifier (PREFIX("caf_critical")), void_type_node, 0); @@ -3688,6 +3693,8 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) { if (!sym->attr.save) { + tree descriptor = NULL_TREE; + /* Nullify and automatic deallocation of allocatable scalars. */ e = gfc_lval_expr_from_sym (sym); @@ -3712,6 +3719,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) else { gfc_conv_expr (&se, e); + descriptor = se.expr; se.expr = gfc_conv_descriptor_data_addr (se.expr); se.expr = build_fold_indirect_ref_loc (input_location, se.expr); } @@ -3761,9 +3769,18 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) /* Deallocate when leaving the scope. Nullifying is not needed. */ if (!sym->attr.result && !sym->attr.dummy) - tmp = gfc_deallocate_scalar_with_status (se.expr, NULL, true, - NULL, sym->ts); - + { + if (sym->ts.type == BT_CLASS + && CLASS_DATA (sym)->attr.codimension) + tmp = gfc_deallocate_with_status (descriptor, NULL_TREE, + NULL_TREE, NULL_TREE, + NULL_TREE, true, NULL, + true); + else + tmp = gfc_deallocate_scalar_with_status (se.expr, NULL, + true, NULL, + sym->ts); + } if (sym->ts.type == BT_CLASS) { /* Initialize _vptr to declared type. */ diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 54572fbf3db..14411e05cde 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -3525,7 +3525,9 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, gfc_init_block (&block); tmp = gfc_deallocate_with_status (parmse.expr, NULL_TREE, - true, NULL); + NULL_TREE, NULL_TREE, + NULL_TREE, true, NULL, + false); gfc_add_expr_to_block (&block, tmp); tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, parmse.expr, @@ -3665,7 +3667,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, { tmp = build_fold_indirect_ref_loc (input_location, parmse.expr); - tmp = gfc_trans_dealloc_allocated (tmp); + tmp = gfc_trans_dealloc_allocated (tmp, false); if (fsym->attr.optional && e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional) @@ -4335,7 +4337,9 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, /* Finally free the temporary's data field. */ tmp = gfc_conv_descriptor_data_get (tmp2); - tmp = gfc_deallocate_with_status (tmp, NULL_TREE, true, NULL); + tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE, + NULL_TREE, NULL_TREE, true, + NULL, false); gfc_add_expr_to_block (&se->pre, tmp); } } diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index 0caa59d0bb4..cb742733df8 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -1,5 +1,6 @@ /* Intrinsic translation - Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 + Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, + 2011, 2012 Free Software Foundation, Inc. Contributed by Paul Brook and Steven Bosscher @@ -7355,7 +7356,8 @@ conv_intrinsic_move_alloc (gfc_code *code) gfc_conv_expr_descriptor (&from_se, from_expr, from_ss); tmp = gfc_conv_descriptor_data_get (to_se.expr); - tmp = gfc_deallocate_with_status (tmp, NULL_TREE, true, to_expr); + tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE, NULL_TREE, + NULL_TREE, true, to_expr, false); gfc_add_expr_to_block (&block, tmp); /* Move the pointer and update the array descriptor data. */ diff --git a/gcc/fortran/trans-openmp.c b/gcc/fortran/trans-openmp.c index a41e97bdadf..f8b3e2280d0 100644 --- a/gcc/fortran/trans-openmp.c +++ b/gcc/fortran/trans-openmp.c @@ -1,5 +1,5 @@ /* OpenMP directive translation -- generate GCC trees from gfc_code. - Copyright (C) 2005, 2006, 2007, 2008, 2009, 2010, 2011 + Copyright (C) 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. Contributed by Jakub Jelinek @@ -326,7 +326,7 @@ gfc_omp_clause_dtor (tree clause ATTRIBUTE_UNUSED, tree decl) /* Allocatable arrays in FIRSTPRIVATE/LASTPRIVATE etc. clauses need to be deallocated if they were allocated. */ - return gfc_trans_dealloc_allocated (decl); + return gfc_trans_dealloc_allocated (decl, false); } @@ -708,7 +708,7 @@ gfc_trans_omp_array_reduction (tree c, gfc_symbol *sym, locus where) gfc_start_block (&block); gfc_add_expr_to_block (&block, gfc_trans_assignment (e3, e4, false, true)); - gfc_add_expr_to_block (&block, gfc_trans_dealloc_allocated (decl)); + gfc_add_expr_to_block (&block, gfc_trans_dealloc_allocated (decl, false)); stmt = gfc_finish_block (&block); } else diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 92f7f43729b..9456e2d3b05 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -1,6 +1,6 @@ /* Statement translation -- generate GCC trees from gfc_code. Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, - 2011 + 2011, 2012 Free Software Foundation, Inc. Contributed by Paul Brook and Steven Bosscher @@ -755,8 +755,8 @@ gfc_trans_sync (gfc_code *code, gfc_exec_op type) if (gfc_option.coarray == GFC_FCOARRAY_LIB) { tmp = builtin_decl_explicit (BUILT_IN_SYNC_SYNCHRONIZE); - tmp = build_call_expr_loc (input_location, tmp, 0); - gfc_add_expr_to_block (&se.pre, tmp); + tmp = build_call_expr_loc (input_location, tmp, 0); + gfc_add_expr_to_block (&se.pre, tmp); } if (gfc_option.coarray != GFC_FCOARRAY_LIB || type == EXEC_SYNC_MEMORY) @@ -4738,10 +4738,10 @@ gfc_trans_allocate (gfc_code * code) if (code->expr2) { gfc_init_se (&se, NULL); + se.want_pointer = 1; gfc_conv_expr_lhs (&se, code->expr2); - - errlen = gfc_get_expr_charlen (code->expr2); - errmsg = gfc_build_addr_expr (pchar_type_node, se.expr); + errmsg = se.expr; + errlen = se.string_length; } else { @@ -4752,8 +4752,7 @@ gfc_trans_allocate (gfc_code * code) /* GOTO destinations. */ label_errmsg = gfc_build_label_decl (NULL_TREE); label_finish = gfc_build_label_decl (NULL_TREE); - TREE_USED (label_errmsg) = 1; - TREE_USED (label_finish) = 1; + TREE_USED (label_finish) = 0; } expr3 = NULL_TREE; @@ -4772,7 +4771,8 @@ gfc_trans_allocate (gfc_code * code) se.descriptor_only = 1; gfc_conv_expr (&se, expr); - if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen, code->expr3)) + if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen, label_finish, + code->expr3)) { /* A scalar or derived type. */ @@ -4892,7 +4892,7 @@ gfc_trans_allocate (gfc_code * code) /* Allocate - for non-pointers with re-alloc checking. */ if (gfc_expr_attr (expr).allocatable) gfc_allocate_allocatable (&se.pre, se.expr, memsz, NULL_TREE, - stat, errmsg, errlen, expr); + stat, errmsg, errlen, label_finish, expr); else gfc_allocate_using_malloc (&se.pre, se.expr, memsz, stat); @@ -4919,18 +4919,12 @@ gfc_trans_allocate (gfc_code * code) /* Error checking -- Note: ERRMSG only makes sense with STAT. */ if (code->expr1) { - /* The coarray library already sets the errmsg. */ - if (gfc_option.coarray == GFC_FCOARRAY_LIB - && gfc_expr_attr (expr).codimension) - tmp = build1_v (GOTO_EXPR, label_finish); - else - tmp = build1_v (GOTO_EXPR, label_errmsg); - + tmp = build1_v (GOTO_EXPR, label_errmsg); parm = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, stat, build_int_cst (TREE_TYPE (stat), 0)); tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, - gfc_unlikely(parm), tmp, + gfc_unlikely (parm), tmp, build_empty_stmt (input_location)); gfc_add_expr_to_block (&block, tmp); } @@ -5102,26 +5096,24 @@ gfc_trans_allocate (gfc_code * code) gfc_free_expr (expr); } - /* STAT (ERRMSG only makes sense with STAT). */ + /* STAT. */ if (code->expr1) { tmp = build1_v (LABEL_EXPR, label_errmsg); gfc_add_expr_to_block (&block, tmp); } - /* ERRMSG block. */ - if (code->expr2) + /* ERRMSG - only useful if STAT is present. */ + if (code->expr1 && code->expr2) { - /* A better error message may be possible, but not required. */ const char *msg = "Attempt to allocate an allocated object"; - tree slen, dlen; + tree slen, dlen, errmsg_str; + stmtblock_t errmsg_block; - gfc_init_se (&se, NULL); - gfc_conv_expr_lhs (&se, code->expr2); + gfc_init_block (&errmsg_block); - errmsg = gfc_create_var (pchar_type_node, "ERRMSG"); - - gfc_add_modify (&block, errmsg, + errmsg_str = gfc_create_var (pchar_type_node, "ERRMSG"); + gfc_add_modify (&errmsg_block, errmsg_str, gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const (msg))); @@ -5130,9 +5122,9 @@ gfc_trans_allocate (gfc_code * code) slen = fold_build2_loc (input_location, MIN_EXPR, TREE_TYPE (slen), dlen, slen); - dlen = build_call_expr_loc (input_location, - builtin_decl_explicit (BUILT_IN_MEMCPY), 3, - gfc_build_addr_expr (pvoid_type_node, se.expr), errmsg, slen); + gfc_trans_string_copy (&errmsg_block, dlen, errmsg, code->expr2->ts.kind, + slen, errmsg_str, gfc_default_character_kind); + dlen = gfc_finish_block (&errmsg_block); tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, stat, build_int_cst (TREE_TYPE (stat), 0)); @@ -5142,16 +5134,15 @@ gfc_trans_allocate (gfc_code * code) gfc_add_expr_to_block (&block, tmp); } - /* STAT (ERRMSG only makes sense with STAT). */ - if (code->expr1) - { - tmp = build1_v (LABEL_EXPR, label_finish); - gfc_add_expr_to_block (&block, tmp); - } - /* STAT block. */ if (code->expr1) { + if (TREE_USED (label_finish)) + { + tmp = build1_v (LABEL_EXPR, label_finish); + gfc_add_expr_to_block (&block, tmp); + } + gfc_init_se (&se, NULL); gfc_conv_expr_lhs (&se, code->expr1); tmp = convert (TREE_TYPE (se.expr), stat); @@ -5172,29 +5163,39 @@ gfc_trans_deallocate (gfc_code *code) { gfc_se se; gfc_alloc *al; - tree apstat, astat, pstat, stat, tmp; + tree apstat, pstat, stat, errmsg, errlen, tmp; + tree label_finish, label_errmsg; stmtblock_t block; - pstat = apstat = stat = astat = tmp = NULL_TREE; + pstat = apstat = stat = errmsg = errlen = tmp = NULL_TREE; + label_finish = label_errmsg = NULL_TREE; gfc_start_block (&block); /* Count the number of failed deallocations. If deallocate() was called with STAT= , then set STAT to the count. If deallocate was called with ERRMSG, then set ERRMG to a string. */ - if (code->expr1 || code->expr2) + if (code->expr1) { tree gfc_int4_type_node = gfc_get_int_type (4); stat = gfc_create_var (gfc_int4_type_node, "stat"); pstat = gfc_build_addr_expr (NULL_TREE, stat); - /* Running total of possible deallocation failures. */ - astat = gfc_create_var (gfc_int4_type_node, "astat"); - apstat = gfc_build_addr_expr (NULL_TREE, astat); + /* GOTO destinations. */ + label_errmsg = gfc_build_label_decl (NULL_TREE); + label_finish = gfc_build_label_decl (NULL_TREE); + TREE_USED (label_finish) = 0; + } - /* Initialize astat to 0. */ - gfc_add_modify (&block, astat, build_int_cst (TREE_TYPE (astat), 0)); + /* Set ERRMSG - only needed if STAT is available. */ + if (code->expr1 && code->expr2) + { + gfc_init_se (&se, NULL); + se.want_pointer = 1; + gfc_conv_expr_lhs (&se, code->expr2); + errmsg = se.expr; + errlen = se.string_length; } for (al = code->ext.alloc.list; al != NULL; al = al->next) @@ -5212,7 +5213,7 @@ gfc_trans_deallocate (gfc_code *code) se.descriptor_only = 1; gfc_conv_expr (&se, expr); - if (expr->rank || gfc_expr_attr (expr).codimension) + if (expr->rank || gfc_is_coarray (expr)) { if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp) { @@ -5232,7 +5233,8 @@ gfc_trans_deallocate (gfc_code *code) gfc_add_expr_to_block (&se.pre, tmp); } } - tmp = gfc_array_deallocate (se.expr, pstat, expr); + tmp = gfc_array_deallocate (se.expr, pstat, errmsg, errlen, + label_finish, expr); gfc_add_expr_to_block (&se.pre, tmp); } else @@ -5261,13 +5263,17 @@ gfc_trans_deallocate (gfc_code *code) } } - /* Keep track of the number of failed deallocations by adding stat - of the last deallocation to the running total. */ - if (code->expr1 || code->expr2) + if (code->expr1) { - apstat = fold_build2_loc (input_location, PLUS_EXPR, - TREE_TYPE (stat), astat, stat); - gfc_add_modify (&se.pre, astat, apstat); + tree cond; + + cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, stat, + build_int_cst (TREE_TYPE (stat), 0)); + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, + gfc_unlikely (cond), + build1_v (GOTO_EXPR, label_errmsg), + build_empty_stmt (input_location)); + gfc_add_expr_to_block (&se.pre, tmp); } tmp = gfc_finish_block (&se.pre); @@ -5275,48 +5281,56 @@ gfc_trans_deallocate (gfc_code *code) gfc_free_expr (expr); } - /* Set STAT. */ if (code->expr1) { - gfc_init_se (&se, NULL); - gfc_conv_expr_lhs (&se, code->expr1); - tmp = convert (TREE_TYPE (se.expr), astat); - gfc_add_modify (&block, se.expr, tmp); + tmp = build1_v (LABEL_EXPR, label_errmsg); + gfc_add_expr_to_block (&block, tmp); } - /* Set ERRMSG. */ - if (code->expr2) + /* Set ERRMSG - only needed if STAT is available. */ + if (code->expr1 && code->expr2) { - /* A better error message may be possible, but not required. */ const char *msg = "Attempt to deallocate an unallocated object"; - tree errmsg, slen, dlen; + stmtblock_t errmsg_block; + tree errmsg_str, slen, dlen, cond; - gfc_init_se (&se, NULL); - gfc_conv_expr_lhs (&se, code->expr2); + gfc_init_block (&errmsg_block); - errmsg = gfc_create_var (pchar_type_node, "ERRMSG"); - - gfc_add_modify (&block, errmsg, + errmsg_str = gfc_create_var (pchar_type_node, "ERRMSG"); + gfc_add_modify (&errmsg_block, errmsg_str, gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const (msg))); - slen = build_int_cst (gfc_charlen_type_node, ((int) strlen (msg))); dlen = gfc_get_expr_charlen (code->expr2); - slen = fold_build2_loc (input_location, MIN_EXPR, TREE_TYPE (slen), dlen, - slen); - dlen = build_call_expr_loc (input_location, - builtin_decl_explicit (BUILT_IN_MEMCPY), 3, - gfc_build_addr_expr (pvoid_type_node, se.expr), errmsg, slen); + gfc_trans_string_copy (&errmsg_block, dlen, errmsg, code->expr2->ts.kind, + slen, errmsg_str, gfc_default_character_kind); + tmp = gfc_finish_block (&errmsg_block); - tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, astat, - build_int_cst (TREE_TYPE (astat), 0)); + cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, stat, + build_int_cst (TREE_TYPE (stat), 0)); + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, + gfc_unlikely (cond), tmp, + build_empty_stmt (input_location)); - tmp = build3_v (COND_EXPR, tmp, dlen, build_empty_stmt (input_location)); + gfc_add_expr_to_block (&block, tmp); + } + if (code->expr1 && TREE_USED (label_finish)) + { + tmp = build1_v (LABEL_EXPR, label_finish); gfc_add_expr_to_block (&block, tmp); } + /* Set STAT. */ + if (code->expr1) + { + gfc_init_se (&se, NULL); + gfc_conv_expr_lhs (&se, code->expr1); + tmp = convert (TREE_TYPE (se.expr), stat); + gfc_add_modify (&block, se.expr, tmp); + } + return gfc_finish_block (&block); } diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c index 085f58f608a..8075dbc32e1 100644 --- a/gcc/fortran/trans.c +++ b/gcc/fortran/trans.c @@ -1,5 +1,5 @@ /* Code translation -- generate GCC trees from gfc_code. - Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 + Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2012 Free Software Foundation, Inc. Contributed by Paul Brook @@ -653,7 +653,7 @@ gfc_allocate_using_malloc (stmtblock_t * block, tree pointer, boolean_type_node, pointer, build_int_cst (prvoid_type_node, 0)); tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, - gfc_unlikely(error_cond), on_error, + gfc_unlikely (error_cond), on_error, build_empty_stmt (input_location)); gfc_add_expr_to_block (block, tmp); @@ -738,7 +738,8 @@ gfc_allocate_using_lib (stmtblock_t * block, tree pointer, tree size, and variable name in case a runtime error has to be printed. */ void gfc_allocate_allocatable (stmtblock_t * block, tree mem, tree size, tree token, - tree status, tree errmsg, tree errlen, gfc_expr* expr) + tree status, tree errmsg, tree errlen, tree label_finish, + gfc_expr* expr) { stmtblock_t alloc_block; tree tmp, null_mem, alloc, error; @@ -757,8 +758,23 @@ gfc_allocate_allocatable (stmtblock_t * block, tree mem, tree size, tree token, if (gfc_option.coarray == GFC_FCOARRAY_LIB && gfc_expr_attr (expr).codimension) - gfc_allocate_using_lib (&alloc_block, mem, size, token, status, - errmsg, errlen); + { + tree cond; + + gfc_allocate_using_lib (&alloc_block, mem, size, token, status, + errmsg, errlen); + if (status != NULL_TREE) + { + TREE_USED (label_finish) = 1; + tmp = build1_v (GOTO_EXPR, label_finish); + cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + status, build_zero_cst (TREE_TYPE (status))); + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, + gfc_unlikely (cond), tmp, + build_empty_stmt (input_location)); + gfc_add_expr_to_block (&alloc_block, tmp); + } + } else gfc_allocate_using_malloc (&alloc_block, mem, size, status); @@ -852,13 +868,27 @@ gfc_call_free (tree var) each procedure). If a runtime-message is possible, `expr' must point to the original - expression being deallocated for its locus and variable name. */ + expression being deallocated for its locus and variable name. + + For coarrays, "pointer" must be the array descriptor and not its + "data" component. */ tree -gfc_deallocate_with_status (tree pointer, tree status, bool can_fail, - gfc_expr* expr) +gfc_deallocate_with_status (tree pointer, tree status, tree errmsg, + tree errlen, tree label_finish, + bool can_fail, gfc_expr* expr, bool coarray) { stmtblock_t null, non_null; tree cond, tmp, error; + tree status_type = NULL_TREE; + tree caf_decl = NULL_TREE; + + if (coarray) + { + gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (pointer))); + caf_decl = pointer; + pointer = gfc_conv_descriptor_data_get (caf_decl); + STRIP_NOPS (pointer); + } cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, pointer, build_int_cst (TREE_TYPE (pointer), 0)); @@ -884,9 +914,9 @@ gfc_deallocate_with_status (tree pointer, tree status, bool can_fail, if (status != NULL_TREE && !integer_zerop (status)) { - tree status_type = TREE_TYPE (TREE_TYPE (status)); tree cond2; + status_type = TREE_TYPE (TREE_TYPE (status)); cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, status, build_int_cst (TREE_TYPE (status), 0)); tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type, @@ -901,26 +931,90 @@ gfc_deallocate_with_status (tree pointer, tree status, bool can_fail, /* When POINTER is not NULL, we free it. */ gfc_start_block (&non_null); - tmp = build_call_expr_loc (input_location, - builtin_decl_explicit (BUILT_IN_FREE), 1, - fold_convert (pvoid_type_node, pointer)); - gfc_add_expr_to_block (&non_null, tmp); + if (!coarray || gfc_option.coarray != GFC_FCOARRAY_LIB) + { + tmp = build_call_expr_loc (input_location, + builtin_decl_explicit (BUILT_IN_FREE), 1, + fold_convert (pvoid_type_node, pointer)); + gfc_add_expr_to_block (&non_null, tmp); - if (status != NULL_TREE && !integer_zerop (status)) + if (status != NULL_TREE && !integer_zerop (status)) + { + /* We set STATUS to zero if it is present. */ + tree status_type = TREE_TYPE (TREE_TYPE (status)); + tree cond2; + + cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + status, + build_int_cst (TREE_TYPE (status), 0)); + tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type, + fold_build1_loc (input_location, INDIRECT_REF, + status_type, status), + build_int_cst (status_type, 0)); + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, + gfc_unlikely (cond2), tmp, + build_empty_stmt (input_location)); + gfc_add_expr_to_block (&non_null, tmp); + } + } + else { - /* We set STATUS to zero if it is present. */ - tree status_type = TREE_TYPE (TREE_TYPE (status)); - tree cond2; + tree caf_type, token, cond2; + tree pstat = null_pointer_node; - cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, - status, build_int_cst (TREE_TYPE (status), 0)); - tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type, - fold_build1_loc (input_location, INDIRECT_REF, - status_type, status), - build_int_cst (status_type, 0)); - tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2, - tmp, build_empty_stmt (input_location)); + if (errmsg == NULL_TREE) + { + gcc_assert (errlen == NULL_TREE); + errmsg = null_pointer_node; + errlen = build_zero_cst (integer_type_node); + } + else + { + gcc_assert (errlen != NULL_TREE); + if (!POINTER_TYPE_P (TREE_TYPE (errmsg))) + errmsg = gfc_build_addr_expr (NULL_TREE, errmsg); + } + + caf_type = TREE_TYPE (caf_decl); + + if (status != NULL_TREE && !integer_zerop (status)) + { + gcc_assert (status_type == integer_type_node); + pstat = status; + } + + if (GFC_DESCRIPTOR_TYPE_P (caf_type) + && GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE) + token = gfc_conv_descriptor_token (caf_decl); + else if (DECL_LANG_SPECIFIC (caf_decl) + && GFC_DECL_TOKEN (caf_decl) != NULL_TREE) + token = GFC_DECL_TOKEN (caf_decl); + else + { + gcc_assert (GFC_ARRAY_TYPE_P (caf_type) + && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) != NULL_TREE); + token = GFC_TYPE_ARRAY_CAF_TOKEN (caf_type); + } + + token = gfc_build_addr_expr (NULL_TREE, token); + tmp = build_call_expr_loc (input_location, + gfor_fndecl_caf_deregister, 4, + token, pstat, errmsg, errlen); gfc_add_expr_to_block (&non_null, tmp); + + if (status != NULL_TREE) + { + tree stat = build_fold_indirect_ref_loc (input_location, status); + + TREE_USED (label_finish) = 1; + tmp = build1_v (GOTO_EXPR, label_finish); + cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + stat, build_zero_cst (TREE_TYPE (stat))); + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, + gfc_unlikely (cond2), tmp, + build_empty_stmt (input_location)); + gfc_add_expr_to_block (&non_null, tmp); + } } return fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 61a48172e5c..b7c25b34488 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -1,5 +1,6 @@ /* Header for code translation functions - Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 + Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, + 2011, 2012 Free Software Foundation, Inc. Contributed by Paul Brook @@ -587,14 +588,15 @@ tree gfc_call_malloc (stmtblock_t *, tree, tree); tree gfc_build_memcpy_call (tree, tree, tree); /* Allocate memory for allocatable variables, with optional status variable. */ -void gfc_allocate_allocatable (stmtblock_t*, tree, tree, tree, +void gfc_allocate_allocatable (stmtblock_t*, tree, tree, tree, tree, tree, tree, tree, gfc_expr*); /* Allocate memory, with optional status variable. */ void gfc_allocate_using_malloc (stmtblock_t *, tree, tree, tree); /* Generate code to deallocate an array. */ -tree gfc_deallocate_with_status (tree, tree, bool, gfc_expr*); +tree gfc_deallocate_with_status (tree, tree, tree, tree, tree, bool, + gfc_expr *, bool); tree gfc_deallocate_scalar_with_status (tree, tree, bool, gfc_expr*, gfc_typespec); /* Generate code to call realloc(). */ @@ -676,6 +678,7 @@ extern GTY(()) tree gfor_fndecl_associated; extern GTY(()) tree gfor_fndecl_caf_init; extern GTY(()) tree gfor_fndecl_caf_finalize; extern GTY(()) tree gfor_fndecl_caf_register; +extern GTY(()) tree gfor_fndecl_caf_deregister; extern GTY(()) tree gfor_fndecl_caf_critical; extern GTY(()) tree gfor_fndecl_caf_end_critical; extern GTY(()) tree gfor_fndecl_caf_sync_all; -- cgit v1.2.1