mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-03-18 16:31:12 +08:00
Code Issues Packages Projects Releases Wiki Activity

Fix fortran/65894 elemental procedures wrong-code

Browse Source 
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 2015-05-09 13:36:14 +00:00
parent 1f0e2688af
commit 14aeb3cd27
7 changed files with 317 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
gcc/fortran/ChangeLog
View File

@ -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):

52
gcc/fortran/trans-array.c
View File

@ -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;

2
gcc/fortran/trans-array.h
View File

@ -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 *);

20
gcc/fortran/trans-expr.c
View File

@ -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;

3
gcc/fortran/trans.h
View File

@ -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;

5
gcc/testsuite/ChangeLog
View File

@ -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

248
gcc/testsuite/gfortran.dg/elemental_subroutine_11.f90 Normal file
View File

@ -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