diff options
Diffstat (limited to 'gcc')
| -rw-r--r-- | gcc/fortran/trans-array.c | 119 | ||||
| -rw-r--r-- | gcc/fortran/trans-array.h | 5 | ||||
| -rw-r--r-- | gcc/fortran/trans-decl.c | 44 | ||||
| -rw-r--r-- | gcc/fortran/trans-stmt.c | 39 | ||||
| -rw-r--r-- | gcc/fortran/trans.h | 3 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/caf-shared/allocate_1.f90 | 2 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/caf-shared/allocate_status_1.f90 | 15 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/caf-shared/automatic_deallocate_1.f90 | 19 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/caf-shared/save_allocatable_1.f90 | 20 |
9 files changed, 160 insertions, 106 deletions
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 58aaa5f..998ec95 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -5982,12 +5982,29 @@ gfc_cas_get_allocation_type (gfc_symbol * sym) return GFC_NCA_NORMAL_COARRAY; } +/* Allocate a shared coarray from a constructor, without checking. */ + +void +gfc_allocate_shared_coarray (stmtblock_t *b, tree decl, tree size, int corank, + int alloc_type) +{ + gfc_add_expr_to_block (b, + build_call_expr_loc (input_location, gfor_fndecl_cas_coarray_alloc, + 4, gfc_build_addr_expr (pvoid_type_node, decl), + size, build_int_cst (integer_type_node, corank), + build_int_cst (integer_type_node, alloc_type))); +} + +/* Allocate a shared coarray from user space, with checking. */ + void -gfc_allocate_shared_coarray (stmtblock_t *b, tree decl, tree size, int rank, - int corank, int alloc_type, tree status, - tree errmsg, tree errlen, bool calc_offset) +allocate_shared_coarray_chk (stmtblock_t *b, tree decl, tree size, int rank, + int corank, int alloc_type, tree status, + tree errmsg, tree errlen) { tree st, err, elen; + int i; + tree offset, stride, lbound, mult; if (status == NULL_TREE) st = null_pointer_node; @@ -5996,28 +6013,25 @@ gfc_allocate_shared_coarray (stmtblock_t *b, tree decl, tree size, int rank, err = errmsg == NULL_TREE ? null_pointer_node : errmsg; elen = errlen == NULL_TREE ? build_int_cst (gfc_charlen_type_node, 0) : errlen; + gfc_add_expr_to_block (b, - build_call_expr_loc (input_location, gfor_fndecl_cas_coarray_allocate, - 7, gfc_build_addr_expr (pvoid_type_node, decl), - size, build_int_cst (integer_type_node, corank), - build_int_cst (integer_type_node, alloc_type), - st, err, elen)); - if (calc_offset) - { - int i; - tree offset, stride, lbound, mult; - offset = build_int_cst (gfc_array_index_type, 0); - for (i = 0; i < rank + corank; i++) - { - stride = gfc_conv_array_stride (decl, i); - lbound = gfc_conv_array_lbound (decl, i); - mult = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, stride, lbound); - offset = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, offset, mult); - } - gfc_conv_descriptor_offset_set (b, decl, offset); + build_call_expr_loc (input_location, gfor_fndecl_cas_coarray_alloc_chk, + 7, gfc_build_addr_expr (pvoid_type_node, decl), + size, build_int_cst (integer_type_node, corank), + build_int_cst (integer_type_node, alloc_type), + st, err, elen)); + + offset = build_int_cst (gfc_array_index_type, 0); + for (i = 0; i < rank + corank; i++) + { + stride = gfc_conv_array_stride (decl, i); + lbound = gfc_conv_array_lbound (decl, i); + mult = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, + stride, lbound); + offset = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, offset, mult); } + gfc_conv_descriptor_offset_set (b, decl, offset); } /* Initializes the descriptor and generates a call to _gfor_allocate. Does @@ -6028,7 +6042,7 @@ bool gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg, tree errlen, tree label_finish, tree expr3_elem_size, tree *nelems, gfc_expr *expr3, tree e3_arr_desc, - bool e3_has_nodescriptor) + bool e3_has_nodescriptor, bool *shared_coarray) { tree tmp; tree allocation; @@ -6162,6 +6176,16 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg, expr3_elem_size, nelems, expr3, e3_arr_desc, e3_has_nodescriptor, expr, &element_size); + /* Update the array descriptor with the offset and the span. */ + if (dimension) + { + gfc_conv_descriptor_offset_set (&set_descriptor_block, se->expr, offset); + tmp = fold_convert (gfc_array_index_type, element_size); + gfc_conv_descriptor_span_set (&set_descriptor_block, se->expr, tmp); + } + + set_descriptor = gfc_finish_block (&set_descriptor_block); + if (dimension && !(flag_coarray == GFC_FCOARRAY_SHARED && coarray)) { var_overflow = gfc_create_var (integer_type_node, "overflow"); @@ -6224,12 +6248,17 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg, elem_size = expr3_elem_size; else elem_size = size_in_bytes (gfc_get_element_type (TREE_TYPE(se->expr))); + + /* Setting the descriptor needs to be done before allocation of the + shared coarray. */ + gfc_add_expr_to_block (&elseblock, set_descriptor); + int alloc_type = gfc_cas_get_allocation_type (expr->symtree->n.sym); - gfc_allocate_shared_coarray (&elseblock, se->expr, elem_size, + allocate_shared_coarray_chk (&elseblock, se->expr, elem_size, ref->u.ar.as->rank, ref->u.ar.as->corank, - alloc_type, status, errmsg, errlen, - true); + alloc_type, status, errmsg, errlen); + *shared_coarray = true; } /* The allocatable variant takes the old pointer as first argument. */ else if (allocatable) @@ -6255,40 +6284,27 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg, else allocation = gfc_finish_block (&elseblock); - - /* Update the array descriptor with the offset and the span. */ - if (dimension) - { - gfc_conv_descriptor_offset_set (&set_descriptor_block, se->expr, offset); - tmp = fold_convert (gfc_array_index_type, element_size); - gfc_conv_descriptor_span_set (&set_descriptor_block, se->expr, tmp); - } - - set_descriptor = gfc_finish_block (&set_descriptor_block); - - if (status != NULL_TREE) + if (status != NULL_TREE && !(coarray && flag_coarray == GFC_FCOARRAY_SHARED)) { cond = fold_build2_loc (input_location, EQ_EXPR, - logical_type_node, status, - build_int_cst (TREE_TYPE (status), 0)); + logical_type_node, status, + build_int_cst (TREE_TYPE (status), 0)); if (not_prev_allocated != NULL_TREE) cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, - logical_type_node, cond, not_prev_allocated); + logical_type_node, cond, + not_prev_allocated); - set_descriptor = fold_build3_loc (input_location, COND_EXPR, void_type_node, - cond, - set_descriptor, - build_empty_stmt (input_location)); + set_descriptor = fold_build3_loc (input_location, COND_EXPR, + void_type_node, cond, + set_descriptor, + build_empty_stmt (input_location)); } /* For native coarrays, the size must be set before the allocation routine can be called. */ if (coarray && flag_coarray == GFC_FCOARRAY_SHARED) - { - gfc_add_expr_to_block (&se->pre, set_descriptor); - gfc_add_expr_to_block (&se->pre, allocation); - } + gfc_add_expr_to_block (&se->pre, allocation); else { gfc_add_expr_to_block (&se->pre, allocation); @@ -10994,7 +11010,8 @@ gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block) /* Although static, derived types with default initializers and allocatable components must not be nulled wholesale; instead they are treated component by component. */ - if (TREE_STATIC (descriptor) && !sym_has_alloc_comp && !has_finalizer) + if (TREE_STATIC (descriptor) && !sym_has_alloc_comp && !has_finalizer + && !(flag_coarray == GFC_FCOARRAY_SHARED && sym->attr.codimension)) { /* SAVEd variables are not freed on exit. */ gfc_trans_static_array_pointer (sym); diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h index 2168e9d..bfd174b 100644 --- a/gcc/fortran/trans-array.h +++ b/gcc/fortran/trans-array.h @@ -21,7 +21,7 @@ along with GCC; see the file COPYING3. If not see /* 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, tree, - tree, tree *, gfc_expr *, tree, bool); + tree, tree *, gfc_expr *, tree, bool, bool *); enum gfc_coarray_allocation_type { GFC_NCA_NORMAL_COARRAY = 1, @@ -31,8 +31,7 @@ enum gfc_coarray_allocation_type { int gfc_cas_get_allocation_type (gfc_symbol *); -void gfc_allocate_shared_coarray (stmtblock_t *, tree, tree, int, int, int, - tree, tree, tree, bool); +void gfc_allocate_shared_coarray (stmtblock_t *, tree, tree, int, int); /* 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 *, diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index ab2725c..61d5667 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -174,7 +174,8 @@ tree gfor_fndecl_caf_is_present; /* Native coarray functions. */ tree gfor_fndecl_cas_master; -tree gfor_fndecl_cas_coarray_allocate; +tree gfor_fndecl_cas_coarray_alloc; +tree gfor_fndecl_cas_coarray_alloc_chk; tree gfor_fndecl_cas_coarray_free; tree gfor_fndecl_cas_this_image; tree gfor_fndecl_cas_num_images; @@ -4120,16 +4121,25 @@ gfc_build_builtin_function_decls (void) gfor_fndecl_cas_master = gfc_build_library_function_decl_with_spec ( get_identifier (PREFIX("cas_master")), ". r ", integer_type_node, 1, build_pointer_type (build_function_type_list (void_type_node, NULL_TREE))); - gfor_fndecl_cas_coarray_allocate = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("cas_coarray_alloc")), ". . R R R W W . ", integer_type_node, 7, - pvoid_type_node, /* desc. */ - size_type_node, /* elem_size. */ - integer_type_node, /* corank. */ - integer_type_node, /* alloc_type. */ - gfc_pint4_type_node, /* stat. */ - pchar1_type_node, /* errmsg. */ - gfc_charlen_type_node, /* errmsg_len. */ - NULL_TREE); + gfor_fndecl_cas_coarray_alloc_chk = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("cas_coarray_alloc_chk")), ". . R R R W W . ", + integer_type_node, 7, + pvoid_type_node, /* desc. */ + size_type_node, /* elem_size. */ + integer_type_node, /* corank. */ + integer_type_node, /* alloc_type. */ + gfc_pint4_type_node, /* stat. */ + pchar1_type_node, /* errmsg. */ + gfc_charlen_type_node); /* errmsg_len. */ + gfor_fndecl_cas_coarray_alloc + = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("cas_coarray_alloc")), ". . R R R ", + integer_type_node, 4, + pvoid_type_node, /* desc. */ + size_type_node, /* elem_size. */ + integer_type_node, /* corank. */ + integer_type_node); /* alloc_type. */ + gfor_fndecl_cas_coarray_free = gfc_build_library_function_decl_with_spec ( get_identifier (PREFIX("cas_coarray_free")), ". . R ", integer_type_node, 2, pvoid_type_node, /* Pointer to the descriptor to be deallocated. */ @@ -4699,11 +4709,8 @@ gfc_trans_shared_coarray (stmtblock_t * init, stmtblock_t *cleanup, gfc_symbol * NULL_TREE, &nelems, NULL, NULL_TREE, true, NULL, &element_size); elem_size = size_in_bytes (gfc_get_element_type (TREE_TYPE(decl))); - gfc_allocate_shared_coarray (init, decl, elem_size, sym->as->rank, - sym->as->corank, alloc_type, - NULL_TREE, NULL_TREE, - build_int_cst (gfc_charlen_type_node, 0), - false); + gfc_allocate_shared_coarray (init, decl, elem_size, sym->as->corank, + alloc_type); gfc_conv_descriptor_offset_set (init, decl, offset); } @@ -5055,7 +5062,10 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) else if (flag_coarray == GFC_FCOARRAY_SHARED && sym->attr.codimension) { - gfc_trans_shared_coarray_inline (block, sym); + if (sym->attr.save == SAVE_EXPLICIT) + gfc_trans_shared_coarray_static (sym); + else + gfc_trans_shared_coarray_inline (block, sym); } else { diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 1f656d4..09f6327 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -1336,7 +1336,7 @@ gfc_trans_sync (gfc_code *code, gfc_exec_op type) if (TREE_TYPE (stat) == integer_type_node) stat = gfc_build_addr_expr (NULL, stat); - if(type == EXEC_SYNC_MEMORY) + if (type == EXEC_SYNC_MEMORY) { /* For shared coarrays, there is no need for a memory fence here because that is emitted anyway below. */ @@ -6227,28 +6227,6 @@ allocate_get_initializer (gfc_code * code, gfc_expr * expr) return NULL; } -/* Helper function - return true if a coarray is allcoated via this - statement. */ - -static bool -coarray_alloc_p (gfc_code *code) -{ - if (code == NULL || code->op != EXEC_ALLOCATE) - return false; - - for (gfc_alloc *al = code->ext.alloc.list; al != NULL; al = al->next) - { - gfc_ref *ref, *last; - for (ref = al->expr->ref, last = ref; ref; last = ref, ref = ref->next) - ; - - ref = last; - if (ref && ref->type == REF_ARRAY && ref->u.ar.codimen) - return true; - } - return false; -} - /* Translate the ALLOCATE statement. */ tree @@ -6284,6 +6262,7 @@ gfc_trans_allocate (gfc_code * code) gfc_symtree *newsym = NULL; symbol_attribute caf_attr; gfc_actual_arglist *param_list; + bool shared_coarray = false; if (!code->ext.alloc.list) return NULL_TREE; @@ -6815,7 +6794,7 @@ gfc_trans_allocate (gfc_code * code) label_finish, tmp, &nelems, e3rhs ? e3rhs : code->expr3, e3_is == E3_DESC ? expr3 : NULL_TREE, - e3_has_nodescriptor)) + e3_has_nodescriptor, &shared_coarray)) { /* A scalar or derived type. First compute the size to allocate. @@ -6972,7 +6951,7 @@ gfc_trans_allocate (gfc_code * code) gfc_add_block_to_block (&block, &se.pre); /* Error checking -- Note: ERRMSG only makes sense with STAT. */ - if (code->expr1) + if (code->expr1 && !shared_coarray) { tmp = build1_v (GOTO_EXPR, label_errmsg); parm = fold_build2_loc (input_location, NE_EXPR, @@ -7193,14 +7172,14 @@ gfc_trans_allocate (gfc_code * code) gfc_free_expr (e3rhs); } /* STAT. */ - if (code->expr1) + if (code->expr1 && !shared_coarray) { tmp = build1_v (LABEL_EXPR, label_errmsg); gfc_add_expr_to_block (&block, tmp); } /* ERRMSG - only useful if STAT is present. */ - if (code->expr1 && code->expr2) + if (code->expr1 && code->expr2 && !shared_coarray) { const char *msg = "Attempt to allocate an allocated object"; tree slen, dlen, errmsg_str; @@ -7257,12 +7236,6 @@ gfc_trans_allocate (gfc_code * code) zero_size); gfc_add_expr_to_block (&post, tmp); } - else if (flag_coarray == GFC_FCOARRAY_SHARED && coarray_alloc_p (code)) - { - tmp = build_call_expr_loc (input_location, gfor_fndecl_cas_sync_all, - 1, null_pointer_node); - gfc_add_expr_to_block (&post, tmp); - } gfc_add_block_to_block (&block, &se.post); gfc_add_block_to_block (&block, &post); diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index d3340b3..9a3a72c 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -906,7 +906,8 @@ extern GTY(()) tree gfor_fndecl_caf_is_present; /* Native coarray library function decls. */ extern GTY(()) tree gfor_fndecl_cas_this_image; extern GTY(()) tree gfor_fndecl_cas_num_images; -extern GTY(()) tree gfor_fndecl_cas_coarray_allocate; +extern GTY(()) tree gfor_fndecl_cas_coarray_alloc; +extern GTY(()) tree gfor_fndecl_cas_coarray_alloc_chk; extern GTY(()) tree gfor_fndecl_cas_coarray_free; extern GTY(()) tree gfor_fndecl_cas_sync_images; extern GTY(()) tree gfor_fndecl_cas_sync_all; diff --git a/gcc/testsuite/gfortran.dg/caf-shared/allocate_1.f90 b/gcc/testsuite/gfortran.dg/caf-shared/allocate_1.f90 index 0703b42..f2bc8af 100644 --- a/gcc/testsuite/gfortran.dg/caf-shared/allocate_1.f90 +++ b/gcc/testsuite/gfortran.dg/caf-shared/allocate_1.f90 @@ -5,5 +5,5 @@ program main allocate (a[*]) deallocate (a) end program main -! { dg-final { scan-tree-dump-times "_gfortran_cas_coarray_sync_all" 2 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_cas_coarray_sync_all" 1 "original" } } diff --git a/gcc/testsuite/gfortran.dg/caf-shared/allocate_status_1.f90 b/gcc/testsuite/gfortran.dg/caf-shared/allocate_status_1.f90 new file mode 100644 index 0000000..fe66a07 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/caf-shared/allocate_status_1.f90 @@ -0,0 +1,15 @@ +! { dg-do run } +! { dg-set-target-env-var GFORTRAN_NUM_IMAGES "4" } +program main + integer, allocatable :: a[:] + character (len=80) :: errmsg + integer :: st + st = 42 + allocate (a[*],stat=st) + if (st /= 0) stop 1 + allocate (a[*], stat=st) + if (st == 0) stop 1 + allocate (a[*], stat=st,errmsg=errmsg) + if (st == 0) stop 2 + if (errmsg /= "Attempting to allocate already allocated variable") stop 3 +end program main diff --git a/gcc/testsuite/gfortran.dg/caf-shared/automatic_deallocate_1.f90 b/gcc/testsuite/gfortran.dg/caf-shared/automatic_deallocate_1.f90 new file mode 100644 index 0000000..3b7374f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/caf-shared/automatic_deallocate_1.f90 @@ -0,0 +1,19 @@ +! { dg-do run } +! { dg-set-target-env-var GFORTRAN_NUM_IMAGES "4" } +! { dg-options "-fdump-tree-original" } + +program main + integer :: n + n = 4096 + do i=1,3 + block + integer, allocatable :: a[:] + if (allocated(a)) stop 1 + allocate (a[*]) + a = 42 + n = n * 2 + end block + end do +end program main +! { dg-final { scan-tree-dump-times "_gfortran_cas_coarray_alloc_chk" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_cas_coarray_free" 1 "original" } } diff --git a/gcc/testsuite/gfortran.dg/caf-shared/save_allocatable_1.f90 b/gcc/testsuite/gfortran.dg/caf-shared/save_allocatable_1.f90 new file mode 100644 index 0000000..182e82e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/caf-shared/save_allocatable_1.f90 @@ -0,0 +1,20 @@ +! { dg-do run } +! { dg-set-target-env-var GFORTRAN_NUM_IMAGES "4" } +! { dg-options "-fdump-tree-original" } + +program main + call test(.true.) + call test(.false.) +contains + subroutine test(flag) + logical, intent(in) :: flag + integer, save, dimension(:), allocatable :: a[:] + if (flag) then + allocate (a(4)[*]) + a = this_image() + else + if (size(a,1) /= 4) stop 1 + if (any(a /= this_image())) stop 2 + end if + end subroutine test +end program main |