diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 1091b187d06..9c952a1012b 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,19 @@ +2015-05-09 Mikael Morin + + PR fortran/65894 + * trans-array.h (gfc_scalar_elemental_arg_saved_as_reference): + New prototype. + * trans-array.c (gfc_scalar_elemental_arg_saved_as_reference): + New function. + (gfc_add_loop_ss_code): Use gfc_scalar_elemental_arg_saved_as_reference + as conditional. + (gfc_walk_elemental_function_args): Set the dummy_arg field. + * trans.h (gfc_ss_info): New subfield dummy_arg. + * trans-expr.c (gfc_conv_procedure_call): Revert the change + of revision 222361. + (gfc_conv_expr): Use gfc_scalar_elemental_arg_saved_as_reference + as conditional. + 2015-05-08 Mikael Morin * trans-array.c (gfc_walk_elemental_function_args): diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 00334b13191..8267f6a41f9 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -2427,6 +2427,41 @@ set_vector_loop_bounds (gfc_ss * ss) } +/* Tells whether a scalar argument to an elemental procedure is saved out + of a scalarization loop as a value or as a reference. */ + +bool +gfc_scalar_elemental_arg_saved_as_reference (gfc_ss_info * ss_info) +{ + if (ss_info->type != GFC_SS_REFERENCE) + return false; + + /* If the actual argument can be absent (in other words, it can + be a NULL reference), don't try to evaluate it; pass instead + the reference directly. */ + if (ss_info->can_be_null_ref) + return true; + + /* If the expression is of polymorphic type, it's actual size is not known, + so we avoid copying it anywhere. */ + if (ss_info->data.scalar.dummy_arg + && ss_info->data.scalar.dummy_arg->ts.type == BT_CLASS + && ss_info->expr->ts.type == BT_CLASS) + return true; + + /* If the expression is a data reference of aggregate type, + avoid a copy by saving a reference to the content. */ + if (ss_info->expr->expr_type == EXPR_VARIABLE + && (ss_info->expr->ts.type == BT_DERIVED + || ss_info->expr->ts.type == BT_CLASS)) + return true; + + /* Otherwise the expression is evaluated to a temporary variable before the + scalarization loop. */ + return false; +} + + /* Add the pre and post chains for all the scalar expressions in a SS chain to loop. This is called after the loop parameters have been calculated, but before the actual scalarizing loops. */ @@ -2495,19 +2530,11 @@ gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript, case GFC_SS_REFERENCE: /* Scalar argument to elemental procedure. */ gfc_init_se (&se, NULL); - if (ss_info->can_be_null_ref || (expr->symtree - && (expr->symtree->n.sym->ts.type == BT_DERIVED - || expr->symtree->n.sym->ts.type == BT_CLASS))) - { - /* If the actual argument can be absent (in other words, it can - be a NULL reference), don't try to evaluate it; pass instead - the reference directly. The reference is also needed when - expr is of type class or derived. */ - gfc_conv_expr_reference (&se, expr); - } + if (gfc_scalar_elemental_arg_saved_as_reference (ss_info)) + gfc_conv_expr_reference (&se, expr); else { - /* Otherwise, evaluate the argument outside the loop and pass + /* Evaluate the argument outside the loop and pass a reference to the value. */ gfc_conv_expr (&se, expr); } @@ -9101,7 +9128,8 @@ gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg, gcc_assert (type == GFC_SS_SCALAR || type == GFC_SS_REFERENCE); newss = gfc_get_scalar_ss (head, arg->expr); newss->info->type = type; - + if (dummy_arg) + newss->info->data.scalar.dummy_arg = dummy_arg->sym; } else scalar = 0; diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h index 2310b659a49..2155b58ba8e 100644 --- a/gcc/fortran/trans-array.h +++ b/gcc/fortran/trans-array.h @@ -103,6 +103,8 @@ gfc_ss *gfc_get_temp_ss (tree, tree, int); /* Allocate a new scalar type ss. */ gfc_ss *gfc_get_scalar_ss (gfc_ss *, gfc_expr *); +bool gfc_scalar_elemental_arg_saved_as_reference (gfc_ss_info *); + /* Calculates the lower bound and stride of array sections. */ void gfc_conv_ss_startstride (gfc_loopinfo *); diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 9c5ce7d9df0..c71037f7b9a 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -4735,19 +4735,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, gfc_init_se (&parmse, se); parm_kind = ELEMENTAL; - /* For all value functions or polymorphic scalar non-pointer - non-allocatable variables use the expression in e directly. This - ensures, that initializers of polymorphic entities are correctly - copied. */ - if (fsym && (fsym->attr.value - || (e->expr_type == EXPR_VARIABLE - && fsym->ts.type == BT_DERIVED - && e->ts.type == BT_DERIVED - && !e->ts.u.derived->attr.dimension - && !e->rank - && (!e->symtree - || (!e->symtree->n.sym->attr.allocatable - && !e->symtree->n.sym->attr.pointer))))) + if (fsym && fsym->attr.value) gfc_conv_expr (&parmse, e); else gfc_conv_expr_reference (&parmse, e); @@ -7310,11 +7298,9 @@ gfc_conv_expr (gfc_se * se, gfc_expr * expr) ss_info = ss->info; /* Substitute a scalar expression evaluated outside the scalarization - loop. */ + loop. */ se->expr = ss_info->data.scalar.value; - /* If the reference can be NULL, the value field contains the reference, - not the value the reference points to (see gfc_add_loop_ss_code). */ - if (ss_info->can_be_null_ref) + if (gfc_scalar_elemental_arg_saved_as_reference (ss_info)) se->expr = build_fold_indirect_ref_loc (input_location, se->expr); se->string_length = ss_info->string_length; diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index e2a1fea9814..570b5b88e30 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -206,6 +206,9 @@ typedef struct gfc_ss_info /* If type is GFC_SS_SCALAR or GFC_SS_REFERENCE. */ struct { + /* If the scalar is passed as actual argument to an (elemental) procedure, + this is the symbol of the corresponding dummy argument. */ + gfc_symbol *dummy_arg; tree value; } scalar; diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 2b6f663cc01..d3beeb9ce9f 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2015-05-09 Andre Vehreschild + + PR fortran/65894 + * gfortran.dg/elemental_subroutine_11.f90: New test. + 2015-05-08 Richard Biener PR tree-optimization/66036 diff --git a/gcc/testsuite/gfortran.dg/elemental_subroutine_11.f90 b/gcc/testsuite/gfortran.dg/elemental_subroutine_11.f90 new file mode 100644 index 00000000000..02ac7c7251b --- /dev/null +++ b/gcc/testsuite/gfortran.dg/elemental_subroutine_11.f90 @@ -0,0 +1,248 @@ +! { dg-do run } +! +! Check error of pr65894 are fixed. +! Contributed by Juergen Reuter +! Andre Vehreschild + +module simple_string + ! Minimal iso_varying_string implementation needed. + implicit none + + type string_t + private + character(len=1), dimension(:), allocatable :: cs + end type string_t + +contains + elemental function var_str(c) result (s) + character(*), intent(in) :: c + type(string_t) :: s + integer :: l,i + + l = len(c) + allocate(s%cs(l)) + forall(i = 1:l) + s%cs(i) = c(i:i) + end forall + end function var_str + +end module simple_string +module model_data + use simple_string + + implicit none + private + + public :: field_data_t + public :: model_data_t + + type :: field_data_t + !private + integer :: pdg = 0 + type(string_t), dimension(:), allocatable :: name + contains + procedure :: init => field_data_init + procedure :: get_pdg => field_data_get_pdg + end type field_data_t + + type :: model_data_t + !private + type(string_t) :: name + type(field_data_t), dimension(:), allocatable :: field + contains + generic :: init => model_data_init + procedure, private :: model_data_init + generic :: get_pdg => & + model_data_get_field_pdg_index + procedure, private :: model_data_get_field_pdg_index + generic :: get_field_ptr => & + model_data_get_field_ptr_pdg + procedure, private :: model_data_get_field_ptr_pdg + procedure :: get_field_ptr_by_index => model_data_get_field_ptr_index + procedure :: init_sm_test => model_data_init_sm_test + end type model_data_t + +contains + + subroutine field_data_init (prt, pdg) + class(field_data_t), intent(out) :: prt + integer, intent(in) :: pdg + prt%pdg = pdg + end subroutine field_data_init + + elemental function field_data_get_pdg (prt) result (pdg) + integer :: pdg + class(field_data_t), intent(in) :: prt + pdg = prt%pdg + end function field_data_get_pdg + + subroutine model_data_init (model, name, & + n_field) + class(model_data_t), intent(out) :: model + type(string_t), intent(in) :: name + integer, intent(in) :: n_field + model%name = name + allocate (model%field (n_field)) + end subroutine model_data_init + + function model_data_get_field_pdg_index (model, i) result (pdg) + class(model_data_t), intent(in) :: model + integer, intent(in) :: i + integer :: pdg + pdg = model%field(i)%get_pdg () + end function model_data_get_field_pdg_index + + function model_data_get_field_ptr_pdg (model, pdg, check) result (ptr) + class(model_data_t), intent(in), target :: model + integer, intent(in) :: pdg + logical, intent(in), optional :: check + type(field_data_t), pointer :: ptr + integer :: i, pdg_abs + if (pdg == 0) then + ptr => null () + return + end if + pdg_abs = abs (pdg) + if (lbound(model%field, 1) /= 1) call abort() + if (ubound(model%field, 1) /= 19) call abort() + do i = 1, size (model%field) + if (model%field(i)%get_pdg () == pdg_abs) then + ptr => model%field(i) + return + end if + end do + ptr => null () + end function model_data_get_field_ptr_pdg + + function model_data_get_field_ptr_index (model, i) result (ptr) + class(model_data_t), intent(in), target :: model + integer, intent(in) :: i + type(field_data_t), pointer :: ptr + if (lbound(model%field, 1) /= 1) call abort() + if (ubound(model%field, 1) /= 19) call abort() + ptr => model%field(i) + end function model_data_get_field_ptr_index + + subroutine model_data_init_sm_test (model) + class(model_data_t), intent(out) :: model + type(field_data_t), pointer :: field + integer, parameter :: n_field = 19 + call model%init (var_str ("SM_test"), & + n_field) + field => model%get_field_ptr_by_index (1) + call field%init (1) + end subroutine model_data_init_sm_test + +end module model_data + +module flavors + use model_data + + implicit none + private + + public :: flavor_t + + type :: flavor_t + private + integer :: f = 0 + type(field_data_t), pointer :: field_data => null () + contains + generic :: init => & + flavor_init0_model + procedure, private :: flavor_init0_model + end type flavor_t + +contains + + impure elemental subroutine flavor_init0_model (flv, f, model) + class(flavor_t), intent(inout) :: flv + integer, intent(in) :: f + class(model_data_t), intent(in), target :: model + ! Check the field l/ubound at various stages, because w/o the patch + ! the bounds get mixed up. + if (lbound(model%field, 1) /= 1) call abort() + if (ubound(model%field, 1) /= 19) call abort() + flv%f = f + flv%field_data => model%get_field_ptr (f, check=.true.) + end subroutine flavor_init0_model +end module flavors + +module beams + use model_data + use flavors + implicit none + private + public :: beam_1 + public :: beam_2 +contains + subroutine beam_1 (u) + integer, intent(in) :: u + type(flavor_t), dimension(2) :: flv + real, dimension(2) :: pol_f + type(model_data_t), target :: model + call model%init_sm_test () + call flv%init ([1,-1], model) + pol_f(1) = 0.5 + end subroutine beam_1 + subroutine beam_2 (u, model) + integer, intent(in) :: u + type(flavor_t), dimension(2) :: flv + real, dimension(2) :: pol_f + class(model_data_t), intent(in), target :: model + call flv%init ([1,-1], model) + pol_f(1) = 0.5 + end subroutine beam_2 +end module beams + +module evaluators + ! This module is just here for a compile check. + implicit none + private + type :: quantum_numbers_mask_t + contains + generic :: operator(.or.) => quantum_numbers_mask_or + procedure, private :: quantum_numbers_mask_or + end type quantum_numbers_mask_t + + type :: index_map_t + integer, dimension(:), allocatable :: entry + end type index_map_t + type :: prt_mask_t + logical, dimension(:), allocatable :: entry + end type prt_mask_t + type :: qn_mask_array_t + type(quantum_numbers_mask_t), dimension(:), allocatable :: mask + end type qn_mask_array_t + +contains + elemental function quantum_numbers_mask_or (mask1, mask2) result (mask) + type(quantum_numbers_mask_t) :: mask + class(quantum_numbers_mask_t), intent(in) :: mask1, mask2 + end function quantum_numbers_mask_or + + subroutine make_product_interaction & + (prt_is_connected, qn_mask_in, qn_mask_rest) + type(prt_mask_t), dimension(2), intent(in) :: prt_is_connected + type(qn_mask_array_t), dimension(2), intent(in) :: qn_mask_in + type(quantum_numbers_mask_t), intent(in) :: qn_mask_rest + type(index_map_t), dimension(2) :: prt_index_in + integer :: i + type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask + allocate (qn_mask (2)) + do i = 1, 2 + qn_mask(prt_index_in(i)%entry) = & + pack (qn_mask_in(i)%mask, prt_is_connected(i)%entry) & + .or. qn_mask_rest + ! Without the patch above line produced an ICE. + end do + end subroutine make_product_interaction +end module evaluators +program main + use beams + use model_data + type(model_data_t) :: model + call model%init_sm_test() + call beam_1 (6) + call beam_2 (6, model) +end program main