Hello, as promised, here is a fix for pr50981.
Currently, for a call to an elemental procedure, every scalar actual
argument is evaluated before the loop containing the function call.
The bug is, we can't evaluate the actual argument if it is a reference
to an absent optional dummy argument, as it will result in a NULL
pointer dereference. We must pass the reference directly in that case.
To fix this, the call to gfc_conv_expr in gfc_add_loop_ss_code, must be
changed to a call to gfc_conv_expr_reference. Such a change is
basically a revert of PR43841's fix, so we are back with a missed
optimization bug. To avoid this we have to do the change only when it
is necessary, i.e. when the dummy argument is optional and the actual
argument is a reference to an optional dummy. This information is
not available in gfc_add_loop_ss_code, so I make for it a new field
can_be_null_ref in the gfc_ss_info struct: this is the second patch.
Then, the third patch is about setting that field: as the dummy argument
information isn't either available in gfc_walk_elemental_function_args,
a new argument, proc_expr, is added, which holds the reference to the
procedure. It is of type gfc_expr* so that it can handle direct calls
and type-bound calls equally well.
The first patch is for consistency: gfc_conv_expr should return values,
not references, so the address taking is moved where it is
actually requested (in gfc_conv_expr_reference).
Regression tested on x86_64-unknown-linux-gnu. OK for 4.7/4.6/4.5[/4.4] ?
Mikael.
PS: Greetings for the new year.
2011-12-29 Mikael Morin <[email protected]>
* trans-expr.c (gfc_conv_expr): Move address taking...
(gfc_conv_expr_reference): ... here.
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 83d8087..20da730 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -5120,8 +5120,6 @@ gfc_conv_expr (gfc_se * se, gfc_expr * expr)
/* Substitute a scalar expression evaluated outside the scalarization
loop. */
se->expr = ss_info->data.scalar.value;
- if (ss_info->type == GFC_SS_REFERENCE)
- se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
se->string_length = ss_info->string_length;
gfc_advance_se_ss_chain (se);
return;
@@ -5254,6 +5252,7 @@ gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
/* Returns a reference to the scalar evaluated outside the loop
for this case. */
gfc_conv_expr (se, expr);
+ se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
return;
}
2011-12-29 Mikael Morin <[email protected]>
PR fortran/50981
* trans.h (struct gfc_ss_info): New field data::scalar::can_be_null_ref
* trans-array.c: If the reference can be NULL, save the reference
instead of the value.
* trans-expr.c (gfc_conv_expr): If we have saved a reference,
dereference it.
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index a644312..19e081b 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -2422,10 +2422,21 @@ gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript,
break;
case GFC_SS_REFERENCE:
- /* Scalar argument to elemental procedure. Evaluate this
- now. */
+ /* Scalar argument to elemental procedure. */
gfc_init_se (&se, NULL);
- gfc_conv_expr (&se, expr);
+ if (ss_info->data.scalar.can_be_null_ref)
+ {
+ /* 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. */
+ gfc_conv_expr_reference (&se, expr);
+ }
+ else
+ {
+ /* Otherwise, evaluate the argument out of the loop and pass
+ a reference to the value. */
+ gfc_conv_expr (&se, expr);
+ }
gfc_add_block_to_block (&outer_loop->pre, &se.pre);
gfc_add_block_to_block (&outer_loop->post, &se.post);
if (gfc_is_class_scalar_expr (expr))
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 20da730..00f38e1 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -5120,6 +5120,11 @@ gfc_conv_expr (gfc_se * se, gfc_expr * expr)
/* Substitute a scalar expression evaluated outside the scalarization
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->data.scalar.can_be_null_ref)
+ se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
+
se->string_length = ss_info->string_length;
gfc_advance_se_ss_chain (se);
return;
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 259a08a..61a4817 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -145,8 +145,9 @@ typedef enum
GFC_SS_SCALAR,
/* Like GFC_SS_SCALAR it evaluates the expression outside the
- loop. Is always evaluated as a reference to the temporary.
- Used for elemental function arguments. */
+ loop. Is always evaluated as a reference to the temporary, unless
+ temporary evaluation can result in a NULL pointer dereferencing (case of
+ optional arguments). Used for elemental function arguments. */
GFC_SS_REFERENCE,
/* An array section. Scalarization indices will be substituted during
@@ -196,6 +197,9 @@ typedef struct gfc_ss_info
struct
{
tree value;
+ /* Tells whether the reference can be null in the GFC_SS_REFERENCE case.
+ Used to handle elemental procedures' optional arguments. */
+ bool can_be_null_ref;
}
scalar;
2011-12-29 Mikael Morin <[email protected]>
PR fortran/50981
* trans-array.h (gfc_walk_elemental_function_args): New argument.
* trans-intrinsic.c (gfc_walk_intrinsic_function): Update call.
* trans-stmt.c (gfc_trans_call): Ditto.
* trans-array.c (gfc_walk_function_expr): Ditto.
(gfc_walk_elemental_function_args): Get the dummy argument list
if possible. Check that the dummy and the actual argument are both
optional, and set can_be_null_ref accordingly.
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 19e081b..f8aece6 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -8295,12 +8295,16 @@ gfc_reverse_ss (gfc_ss * ss)
}
-/* Walk the arguments of an elemental function. */
+/* Walk the arguments of an elemental function.
+ PROC_EXPR is used to check whether an argument is permitted to be absent. If
+ it is NULL, we don't do the check and the argument is assumed to be present.
+*/
gfc_ss *
gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
- gfc_ss_type type)
+ gfc_expr *proc_expr, gfc_ss_type type)
{
+ gfc_formal_arglist *dummy_arg;
int scalar;
gfc_ss *head;
gfc_ss *tail;
@@ -8308,6 +8312,28 @@ gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
head = gfc_ss_terminator;
tail = NULL;
+
+ if (proc_expr)
+ {
+ gfc_ref *ref;
+
+ /* Normal procedure case. */
+ dummy_arg = proc_expr->symtree->n.sym->formal;
+
+ /* Typebound procedure case. */
+ for (ref = proc_expr->ref; ref; ref = ref->next)
+ {
+ if (ref->type == REF_COMPONENT
+ && ref->u.c.component->attr.proc_pointer
+ && ref->u.c.component->ts.interface)
+ dummy_arg = ref->u.c.component->ts.interface->formal;
+ else
+ dummy_arg = NULL;
+ }
+ }
+ else
+ dummy_arg = NULL;
+
scalar = 1;
for (; arg; arg = arg->next)
{
@@ -8321,6 +8347,14 @@ 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 != NULL
+ && dummy_arg->sym->attr.optional
+ && arg->expr
+ && arg->expr->symtree
+ && arg->expr->symtree->n.sym->attr.optional
+ && arg->expr->ref == NULL)
+ newss->info->data.scalar.can_be_null_ref = true;
}
else
scalar = 0;
@@ -8332,6 +8366,9 @@ gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
while (tail->next != gfc_ss_terminator)
tail = tail->next;
}
+
+ if (dummy_arg != NULL)
+ dummy_arg = dummy_arg->next;
}
if (scalar)
@@ -8381,7 +8418,7 @@ gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
by reference. */
if (sym->attr.elemental || (comp && comp->attr.elemental))
return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
- GFC_SS_REFERENCE);
+ expr, GFC_SS_REFERENCE);
/* Scalar functions are OK as these are evaluated outside the scalarization
loop. Pass back and let the caller deal with it. */
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 340c1a7..19cfac5 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -73,7 +73,7 @@ gfc_ss *gfc_walk_subexpr (gfc_ss *, gfc_expr *);
gfc_ss *gfc_walk_array_ref (gfc_ss *, gfc_expr *, gfc_ref * ref);
/* Walk the arguments of an elemental function. */
gfc_ss *gfc_walk_elemental_function_args (gfc_ss *, gfc_actual_arglist *,
- gfc_ss_type);
+ gfc_expr *, gfc_ss_type);
/* Walk an intrinsic function. */
gfc_ss *gfc_walk_intrinsic_function (gfc_ss *, gfc_expr *,
gfc_intrinsic_sym *);
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index 5c964c1..900d546 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -7145,7 +7145,7 @@ gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
if (isym->elemental)
return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
- GFC_SS_SCALAR);
+ NULL, GFC_SS_SCALAR);
if (expr->rank == 0)
return ss;
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 9e903d8..92f7f43 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -348,7 +348,8 @@ gfc_trans_call (gfc_code * code, bool dependency_check,
ss = gfc_ss_terminator;
if (code->resolved_sym->attr.elemental)
- ss = gfc_walk_elemental_function_args (ss, code->ext.actual, GFC_SS_REFERENCE);
+ ss = gfc_walk_elemental_function_args (ss, code->ext.actual,
+ code->expr1, GFC_SS_REFERENCE);
/* Is not an elemental subroutine call with array valued arguments. */
if (ss == gfc_ss_terminator)
2011-12-29 Mikael Morin <[email protected]>
* elemental_optional_args_2.f90: New test.
! { dg-do run }
!
! PR fortran/50981
! The program used to dereference a NULL pointer when trying to access
! an optional dummy argument to be passed to an elemental subprocedure.
!
! Original testcase from Andriy Kostyuk <[email protected]>
PROGRAM test
IMPLICIT NONE
REAL(KIND=8), DIMENSION(2) :: aa, rr
aa(1)=10.
aa(2)=11.
! WRITE(*,*) 'Both f1 and ff work if the optional parameter is present:'
rr=f1(aa,1)
! WRITE(*,*) ' rr(1)=', rr(1), ' rr(2)=', rr(2)
IF (ANY(rr /= (/ 110, 132 /))) CALL ABORT
rr=0
rr=ff(aa,1)
! WRITE(*,*) ' rr(1)=', rr(1), ' rr(2)=', rr(2)
IF (ANY(rr /= (/ 110, 132 /))) CALL ABORT
! WRITE(*,*) 'But only f1 works if the optional parameter is absent:'
rr=0
rr=f1(aa)
! WRITE(*,*) ' rr(1)=', rr(1), ' rr(2)=', rr(2)
IF (ANY(rr /= (/ 110, 132 /))) CALL ABORT
rr = 0
rr=ff(aa)
! WRITE(*,*) ' rr(1)=', rr(1), ' rr(2)=', rr(2)
IF (ANY(rr /= (/ 110, 132 /))) CALL ABORT
CONTAINS
ELEMENTAL REAL(KIND=8) FUNCTION ff(a,b)
IMPLICIT NONE
REAL(KIND=8), INTENT(IN) :: a
INTEGER, INTENT(IN), OPTIONAL :: b
REAL(KIND=8), DIMENSION(2) :: ac
ac(1)=a
ac(2)=a**2
ff=SUM(gg(ac,b))
END FUNCTION ff
ELEMENTAL REAL(KIND=8) FUNCTION f1(a,b)
IMPLICIT NONE
REAL(KIND=8), INTENT(IN) :: a
INTEGER, INTENT(IN), OPTIONAL :: b
REAL(KIND=8), DIMENSION(2) :: ac
ac(1)=a
ac(2)=a**2
f1=gg(ac(1),b)+gg(ac(2),b) ! This is the same as in ff, but without using the elemental feature of gg
END FUNCTION f1
ELEMENTAL REAL(KIND=8) FUNCTION gg(a,b)
IMPLICIT NONE
REAL(KIND=8), INTENT(IN) :: a
INTEGER, INTENT(IN), OPTIONAL :: b
INTEGER ::b1
IF(PRESENT(b)) THEN
b1=b
ELSE
b1=1
ENDIF
gg=a**b1
END FUNCTION gg
END PROGRAM test
