Fix fortran/65894 elemental procedures wrong-code
gcc/fortran/ 2015-05-09 Mikael Morin <mikael@gcc.gnu.org> 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. gcc/testsuite/ 2015-05-09 Andre Vehreschild <vehre@gmx.de> PR fortran/65894 * gfortran.dg/elemental_subroutine_11.f90: New test. From-SVN: r222968
This commit is contained in:
Mikael Morin
parent
1f0e2688af
commit
14aeb3cd27
|
|
@ -1,3 +1,19 @@
|
|||
2015-05-09 Mikael Morin <mikael@gcc.gnu.org>
|
||||
|
||||
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 <mikael@gcc.gnu.org>
|
||||
|
||||
* trans-array.c (gfc_walk_elemental_function_args):
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
|
|
|||
|
|
@ -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 *);
|
||||
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
|
|
|||
|
|
@ -1,3 +1,8 @@
|
|||
2015-05-09 Andre Vehreschild <vehre@gmx.de>
|
||||
|
||||
PR fortran/65894
|
||||
* gfortran.dg/elemental_subroutine_11.f90: New test.
|
||||
|
||||
2015-05-08 Richard Biener <rguenther@suse.de>
|
||||
|
||||
PR tree-optimization/66036
|
||||
|
|
|
|||
|
|
@ -0,0 +1,248 @@
|
|||
! { dg-do run }
|
||||
!
|
||||
! Check error of pr65894 are fixed.
|
||||
! Contributed by Juergen Reuter <juergen.reuter@desy.de>
|
||||
! Andre Vehreschild <vehre@gcc.gnu.org>
|
||||
|
||||
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
|
||||
Loading…
Reference in New Issue