===================================================================
*************** gfc_conv_procedure_call (gfc_se * se, gf
argument and another one. */
if (gfc_get_noncopying_intrinsic_argument (e) != NULL)
{
+ gfc_expr *iarg;
sym_intent intent;
if (fsym != NULL)
*************** gfc_conv_procedure_call (gfc_se * se, gf
if (gfc_check_fncall_dependency (e, intent, sym, args,
NOT_ELEMENTAL))
parmse.force_tmp = 1;
+
+ iarg = e->value.function.actual->expr;
+
+ /* Temporary needed if aliasing due to host association. */
+ if (sym->attr.contained
+ && !sym->attr.pure
+ && !sym->attr.implicit_pure
+ && !sym->attr.use_assoc
+ && iarg->expr_type == EXPR_VARIABLE
+ && sym->ns == iarg->symtree->n.sym->ns)
+ parmse.force_tmp = 1;
+
+ /* Ditto within module. */
+ if (sym->attr.use_assoc
+ && !sym->attr.pure
+ && !sym->attr.implicit_pure
+ && iarg->expr_type == EXPR_VARIABLE
+ && sym->module == iarg->symtree->n.sym->module)
+ parmse.force_tmp = 1;
}
if (e->expr_type == EXPR_VARIABLE
*************** gfc_conv_procedure_call (gfc_se * se, gf
/* If the lhs of an assignment x = f(..) is allocatable and
f2003 is allowed, we must do the automatic reallocation.
! TODO - deal with instrinsics, without using a temporary. */
if (gfc_option.flag_realloc_lhs
&& se->ss && se->ss->loop_chain
&& se->ss->loop_chain->is_alloc_lhs
/* If the lhs of an assignment x = f(..) is allocatable and
f2003 is allowed, we must do the automatic reallocation.
! TODO - deal with intrinsics, without using a temporary. */
if (gfc_option.flag_realloc_lhs
&& se->ss && se->ss->loop_chain
&& se->ss->loop_chain->is_alloc_lhs
*************** arrayfunc_assign_needs_temporary (gfc_ex
if (sym->attr.dummy && sym->attr.intent != INTENT_OUT)
return true;
/* A PURE function can unconditionally be called without a temporary. */
if (expr2->value.function.esym != NULL
&& expr2->value.function.esym->attr.pure)
return false;
! /* TODO a function that could correctly be declared PURE but is not
! could do with returning false as well. */
if (!sym->attr.use_assoc
&& !sym->attr.in_common
&& !sym->attr.pointer
&& !sym->attr.target
&& expr2->value.function.esym)
{
/* A temporary is not needed if the function is not contained and
if (sym->attr.dummy && sym->attr.intent != INTENT_OUT)
return true;
+ /* If the lhs has been host_associated, is in common, a pointer or is
+ a target and the function is not using a RESULT variable, aliasing
+ can occur and a temporary is needed. */
+ if ((sym->attr.host_assoc
+ || sym->attr.in_common
+ || sym->attr.pointer
+ || sym->attr.target)
+ && expr2->symtree != NULL
+ && expr2->symtree->n.sym == expr2->symtree->n.sym->result)
+ return true;
+
/* A PURE function can unconditionally be called without a temporary. */
if (expr2->value.function.esym != NULL
&& expr2->value.function.esym->attr.pure)
return false;
! /* Implicit_pure functions are those which could legally be declared
! to be PURE. */
! if (expr2->value.function.esym != NULL
! && expr2->value.function.esym->attr.implicit_pure)
! return false;
if (!sym->attr.use_assoc
&& !sym->attr.in_common
&& !sym->attr.pointer
&& !sym->attr.target
+ && !sym->attr.cray_pointee
&& expr2->value.function.esym)
{
/* A temporary is not needed if the function is not contained and
*************** gfc_trans_assignment (gfc_expr * expr1,
bool dealloc)
{
tree tmp;
!
if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
{
gfc_error ("Assignment to deferred-length character variable at %L "
bool dealloc)
{
tree tmp;
!
if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
{
gfc_error ("Assignment to deferred-length character variable at %L "
===================================================================
*************** gfc_add_save (symbol_attribute *attr, sa
return FAILURE;
}
+ if (s == SAVE_EXPLICIT && gfc_implicit_pure (NULL))
+ gfc_current_ns->proc_name->attr.implicit_pure = 0;
+
if (s == SAVE_EXPLICIT && attr->save == SAVE_EXPLICIT)
{
if (gfc_notify_std (GFC_STD_LEGACY,
===================================================================
*************** match_old_style_init (const char *name)
return MATCH_ERROR;
}
+ if (gfc_implicit_pure (NULL))
+ gfc_current_ns->proc_name->attr.implicit_pure = 0;
+
/* Mark the variable as having appeared in a data statement. */
if (gfc_add_data (&sym->attr, sym->name, &sym->declared_at) == FAILURE)
{
*************** gfc_match_data (void)
return MATCH_ERROR;
}
+ if (gfc_implicit_pure (NULL))
+ gfc_current_ns->proc_name->attr.implicit_pure = 0;
+
return MATCH_YES;
cleanup:
===================================================================
*************** typedef struct
unsigned sequence:1, elemental:1, pure:1, recursive:1;
unsigned unmaskable:1, masked:1, contained:1, mod_proc:1, abstract:1;
+ /* This is set if a contained procedure could be declared pure. This is
+ used for certain optimizations that require the result or arguments
+ cannot alias. */
+ unsigned implicit_pure:1;
+
/* This is set if the subroutine doesn't return. Currently, this
is only possible for intrinsic subroutines. */
unsigned noreturn:1;
*************** void gfc_resolve (gfc_namespace *);
void gfc_resolve_blocks (gfc_code *, gfc_namespace *);
int gfc_impure_variable (gfc_symbol *);
int gfc_pure (gfc_symbol *);
+ int gfc_implicit_pure (gfc_symbol *);
int gfc_elemental (gfc_symbol *);
gfc_try gfc_resolve_iterator (gfc_iterator *, bool);
gfc_try find_forall_index (gfc_expr *, gfc_symbol *, int);
===================================================================
*************** gfc_check_pointer_assign (gfc_expr *lval
{
symbol_attribute attr;
gfc_ref *ref;
! bool is_pure, rank_remap;
int proc_pointer;
if (lvalue->symtree->n.sym->ts.type == BT_UNKNOWN
{
symbol_attribute attr;
gfc_ref *ref;
! bool is_pure, is_implicit_pure, rank_remap;
int proc_pointer;
if (lvalue->symtree->n.sym->ts.type == BT_UNKNOWN
*************** gfc_check_pointer_assign (gfc_expr *lval
}
is_pure = gfc_pure (NULL);
+ is_implicit_pure = gfc_implicit_pure (NULL);
/* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
kind, etc for lvalue and rvalue must match, and rvalue must be a
*************** gfc_check_pointer_assign (gfc_expr *lval
"procedure at %L", &rvalue->where);
}
+ if (is_implicit_pure && gfc_impure_variable (rvalue->symtree->n.sym))
+ gfc_current_ns->proc_name->attr.implicit_pure = 0;
+
+
if (gfc_has_vector_index (rvalue))
{
gfc_error ("Pointer assignment with vector subscript "
*************** gfc_check_vardef_context (gfc_expr* e, b
return FAILURE;
}
+ if (!pointer && gfc_implicit_pure (NULL) && gfc_impure_variable (sym))
+ gfc_current_ns->proc_name->attr.implicit_pure = 0;
+
/* Check variable definition context for associate-names. */
if (!pointer && sym->assoc)
{
===================================================================
*************** typedef enum
AB_POINTER_COMP, AB_PRIVATE_COMP, AB_VALUE, AB_VOLATILE, AB_PROTECTED,
AB_IS_BIND_C, AB_IS_C_INTEROP, AB_IS_ISO_C, AB_ABSTRACT, AB_ZERO_COMP,
AB_IS_CLASS, AB_PROCEDURE, AB_PROC_POINTER, AB_ASYNCHRONOUS, AB_CODIMENSION,
! AB_COARRAY_COMP, AB_VTYPE, AB_VTAB, AB_CONTIGUOUS, AB_CLASS_POINTER
}
ab_attribute;
AB_POINTER_COMP, AB_PRIVATE_COMP, AB_VALUE, AB_VOLATILE, AB_PROTECTED,
AB_IS_BIND_C, AB_IS_C_INTEROP, AB_IS_ISO_C, AB_ABSTRACT, AB_ZERO_COMP,
AB_IS_CLASS, AB_PROCEDURE, AB_PROC_POINTER, AB_ASYNCHRONOUS, AB_CODIMENSION,
! AB_COARRAY_COMP, AB_VTYPE, AB_VTAB, AB_CONTIGUOUS, AB_CLASS_POINTER,
! AB_IMPLICIT_PURE
}
ab_attribute;
*************** static const mstring attr_bits[] =
minit ("VTYPE", AB_VTYPE),
minit ("VTAB", AB_VTAB),
minit ("CLASS_POINTER", AB_CLASS_POINTER),
+ minit ("IMPLICIT_PURE", AB_IMPLICIT_PURE),
minit (NULL, -1)
};
*************** mio_symbol_attribute (symbol_attribute *
MIO_NAME (ab_attribute) (AB_ELEMENTAL, attr_bits);
if (attr->pure)
MIO_NAME (ab_attribute) (AB_PURE, attr_bits);
+ if (attr->implicit_pure)
+ MIO_NAME (ab_attribute) (AB_IMPLICIT_PURE, attr_bits);
if (attr->recursive)
MIO_NAME (ab_attribute) (AB_RECURSIVE, attr_bits);
if (attr->always_explicit)
*************** mio_symbol_attribute (symbol_attribute *
case AB_PURE:
attr->pure = 1;
break;
+ case AB_IMPLICIT_PURE:
+ attr->implicit_pure = 1;
+ break;
case AB_RECURSIVE:
attr->recursive = 1;
break;
===================================================================
*************** match_vtag (const io_tag *tag, gfc_expr
return MATCH_ERROR;
}
+ if (gfc_implicit_pure (NULL) && gfc_impure_variable (result->symtree->n.sym))
+ gfc_current_ns->proc_name->attr.implicit_pure = 0;
+
*v = result;
return MATCH_YES;
}
*************** gfc_match_open (void)
goto cleanup;
}
+ if (gfc_implicit_pure (NULL))
+ gfc_current_ns->proc_name->attr.implicit_pure = 0;
+
warn = (open->err || open->iostat) ? true : false;
/* Checks on NEWUNIT specifier. */
*************** gfc_match_close (void)
goto cleanup;
}
+ if (gfc_implicit_pure (NULL))
+ gfc_current_ns->proc_name->attr.implicit_pure = 0;
+
warn = (close->iostat || close->err) ? true : false;
/* Checks on the STATUS specifier. */
*************** done:
goto cleanup;
}
+ if (gfc_implicit_pure (NULL))
+ gfc_current_ns->proc_name->attr.implicit_pure = 0;
+
new_st.op = op;
new_st.ext.filepos = fp;
return MATCH_YES;
*************** if (condition) \
"IO UNIT in %s statement at %C must be "
"an internal file in a PURE procedure",
io_kind_name (k));
+
+ if (gfc_implicit_pure (NULL) && (k == M_READ || k == M_WRITE))
+ gfc_current_ns->proc_name->attr.implicit_pure = 0;
+
}
if (k != M_READ)
*************** gfc_match_print (void)
return MATCH_ERROR;
}
+ if (gfc_implicit_pure (NULL))
+ gfc_current_ns->proc_name->attr.implicit_pure = 0;
+
return MATCH_YES;
}
*************** gfc_match_inquire (void)
return MATCH_ERROR;
}
+ if (gfc_implicit_pure (NULL))
+ gfc_current_ns->proc_name->attr.implicit_pure = 0;
+
new_st.block = gfc_get_code ();
new_st.block->op = EXEC_IOLENGTH;
terminate_io (code);
*************** gfc_match_inquire (void)
gfc_error ("INQUIRE statement not allowed in PURE procedure at %C");
goto cleanup;
}
+
+ if (gfc_implicit_pure (NULL))
+ gfc_current_ns->proc_name->attr.implicit_pure = 0;
if (inquire->id != NULL && inquire->pending == NULL)
{
*************** gfc_match_wait (void)
goto cleanup;
}
+ if (gfc_implicit_pure (NULL))
+ gfc_current_ns->proc_name->attr.implicit_pure = 0;
+
new_st.op = EXEC_WAIT;
new_st.ext.wait = wait;
===================================================================
*************** resolve_formal_arglist (gfc_symbol *proc
continue;
}
+ if (proc->attr.implicit_pure && !gfc_pure(sym))
+ proc->attr.implicit_pure = 0;
+
if (gfc_elemental (proc))
{
gfc_error ("Dummy procedure at %L not allowed in ELEMENTAL "
*************** resolve_formal_arglist (gfc_symbol *proc
&sym->declared_at);
}
+ if (proc->attr.implicit_pure && !sym->attr.pointer
+ && sym->attr.flavor != FL_PROCEDURE)
+ {
+ if (proc->attr.function && sym->attr.intent != INTENT_IN)
+ proc->attr.implicit_pure = 0;
+
+ if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN)
+ proc->attr.implicit_pure = 0;
+ }
+
if (gfc_elemental (proc))
{
/* F2008, C1289. */
*************** resolve_structure_cons (gfc_expr *expr,
comp->name, &cons->expr->where);
}
+ if (gfc_implicit_pure (NULL)
+ && cons->expr->expr_type == EXPR_VARIABLE
+ && (gfc_impure_variable (cons->expr->symtree->n.sym)
+ || gfc_is_coindexed (cons->expr)))
+ gfc_current_ns->proc_name->attr.implicit_pure = 0;
+
}
return t;
*************** resolve_function (gfc_expr *expr)
}
}
+ if (!pure_function (expr, &name) && name && gfc_implicit_pure (NULL))
+ gfc_current_ns->proc_name->attr.implicit_pure = 0;
+
/* Functions without the RECURSIVE attribution are not allowed to
* call themselves. */
if (expr->value.function.esym && !expr->value.function.esym->attr.recursive)
*************** resolve_ordinary_assign (gfc_code *code,
return rval;
}
! /* Fortran 2008, C1283. */
if (gfc_is_coindexed (lhs))
{
gfc_error ("Assignment to coindexed variable at %L in a PURE "
return rval;
}
! /* Fortran 2008, C1283. */
if (gfc_is_coindexed (lhs))
{
gfc_error ("Assignment to coindexed variable at %L in a PURE "
*************** resolve_ordinary_assign (gfc_code *code,
}
}
+ if (gfc_implicit_pure (NULL))
+ {
+ if (lhs->expr_type == EXPR_VARIABLE
+ && lhs->symtree->n.sym != gfc_current_ns->proc_name
+ && lhs->symtree->n.sym->ns != gfc_current_ns)
+ gfc_current_ns->proc_name->attr.implicit_pure = 0;
+
+ if (lhs->ts.type == BT_DERIVED
+ && lhs->expr_type == EXPR_VARIABLE
+ && lhs->ts.u.derived->attr.pointer_comp
+ && rhs->expr_type == EXPR_VARIABLE
+ && (gfc_impure_variable (rhs->symtree->n.sym)
+ || gfc_is_coindexed (rhs)))
+ gfc_current_ns->proc_name->attr.implicit_pure = 0;
+
+ /* Fortran 2008, C1283. */
+ if (gfc_is_coindexed (lhs))
+ gfc_current_ns->proc_name->attr.implicit_pure = 0;
+ }
+
/* F03:7.4.1.2. */
/* FIXME: Valid in Fortran 2008, unless the LHS is both polymorphic
and coindexed; cf. F2008, 7.2.1.2 and PR 43366. */
*************** gfc_pure (gfc_symbol *sym)
return attr.flavor == FL_PROCEDURE && attr.pure;
}
+ /* Test whether a symbol is implicitly pure or not. For a NULL pointer,
+ checks if the current namespace is implicitly pure. */
+
+ int
+ gfc_implicit_pure (gfc_symbol *sym)
+ {
+ symbol_attribute attr;
+
+ if (sym == NULL)
+ {
+ /* Check if the current namespace is implicit_pure. */
+ sym = gfc_current_ns->proc_name;
+ if (sym == NULL)
+ return 0;
+ attr = sym->attr;
+ if (attr.flavor == FL_PROCEDURE
+ && attr.implicit_pure && !attr.pure)
+ return 1;
+ return 0;
+ }
+
+ attr = sym->attr;
+
+ return attr.flavor == FL_PROCEDURE && attr.implicit_pure && !attr.pure;
+ }
+
/* Test whether the current procedure is elemental or not. */
===================================================================
*************** gfc_match_critical (void)
return MATCH_ERROR;
}
+ if (gfc_implicit_pure (NULL))
+ gfc_current_ns->proc_name->attr.implicit_pure = 0;
+
if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: CRITICAL statement at %C")
== FAILURE)
return MATCH_ERROR;
*************** gfc_match_stopcode (gfc_statement st)
goto cleanup;
}
+ if (gfc_implicit_pure (NULL))
+ gfc_current_ns->proc_name->attr.implicit_pure = 0;
+
if (st == ST_STOP && gfc_find_state (COMP_CRITICAL) == SUCCESS)
{
gfc_error ("Image control statement STOP at %C in CRITICAL block");
*************** sync_statement (gfc_statement st)
return MATCH_ERROR;
}
+ if (gfc_implicit_pure (NULL))
+ gfc_current_ns->proc_name->attr.implicit_pure = 0;
+
if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: SYNC statement at %C")
== FAILURE)
return MATCH_ERROR;
*************** gfc_match_allocate (void)
goto cleanup;
}
+ if (gfc_implicit_pure (NULL)
+ && gfc_impure_variable (tail->expr->symtree->n.sym))
+ gfc_current_ns->proc_name->attr.implicit_pure = 0;
+
if (tail->expr->ts.deferred)
{
saw_deferred = true;
*************** gfc_match_deallocate (void)
goto cleanup;
}
+ if (gfc_implicit_pure (NULL) && gfc_impure_variable (sym))
+ gfc_current_ns->proc_name->attr.implicit_pure = 0;
+
/* FIXME: disable the checking on derived types. */
b1 = !(tail->expr->ref
&& (tail->expr->ref->type == REF_COMPONENT
===================================================================
*************** decode_omp_directive (void)
return ST_NONE;
}
+ if (gfc_implicit_pure (NULL))
+ gfc_current_ns->proc_name->attr.implicit_pure = 0;
+
old_locus = gfc_current_locus;
/* General OpenMP directive matching: Instead of testing every possible
*************** parse_contained (int module)
sym->attr.contained = 1;
sym->attr.referenced = 1;
+ /* Set implicit_pure so that it can be reset if any of the
+ tests for purity fail. This is used for some optimisation
+ during translation. */
+ if (!sym->attr.pure)
+ sym->attr.implicit_pure = 1;
+
parse_progunit (ST_NONE);
/* Fix up any sibling functions that refer to this one. */
===================================================================
***************
+ ! { dg-do run }
+ ! { dg-options "-fdump-tree-original " }
+ ! Checks the fix for PR46896, in which the optimization that passes
+ ! the argument of TRANSPOSE directly missed the possible aliasing
+ ! through host association.
+ !
+ ! Contributed by Jerry DeLisle <jvdelisle@gcc.gnu.org>
+ !
+ module mod
+ integer :: b(2,3) = reshape([1,2,3,4,5,6], [2,3])
+ contains
+ subroutine msub(x)
+ integer :: x(:,:)
+ b(1,:) = 99
+ b(2,:) = x(:,1)
+ if (any (b(:,1) /= [99, 1]).or.any (b(:,2) /= [99, 3])) call abort()
+ end subroutine msub
+ subroutine pure_msub(x, y)
+ integer, intent(in) :: x(:,:)
+ integer, intent(OUT) :: y(size (x, 2), size (x, 1))
+ y = transpose (x)
+ end subroutine pure_msub
+ end
+
+ use mod
+ integer :: a(2,3) = reshape([1,2,3,4,5,6], [2,3])
+ call impure
+ call purity
+ contains
+ !
+ ! pure_sub and pure_msub could be PURE, if so declared. They do not
+ ! need a temporary.
+ !
+ subroutine purity
+ integer :: c(2,3)
+ call pure_sub(transpose(a), c)
+ if (any (c .ne. a)) call abort
+ call pure_msub(transpose(b), c)
+ if (any (c .ne. b)) call abort
+ end subroutine purity
+ !
+ ! sub and msub both need temporaries to avoid aliasing.
+ !
+ subroutine impure
+ call sub(transpose(a))
+ end subroutine impure
+
+ subroutine sub(x)
+ integer :: x(:,:)
+ a(1,:) = 88
+ a(2,:) = x(:,1)
+ if (any (a(:,1) /= [88, 1]).or.any (a(:,2) /= [88, 3])) call abort()
+ end subroutine sub
+ subroutine pure_sub(x, y)
+ integer, intent(in) :: x(:,:)
+ integer, intent(OUT) :: y(size (x, 2), size (x, 1))
+ y = transpose (x)
+ end subroutine pure_sub
+ end
+ !
+ ! The check below for temporaries gave 14 and 33 for "parm" and "atmp".
+ !
+ ! { dg-final { scan-tree-dump-times "parm" 66 "original" } }
+ ! { dg-final { scan-tree-dump-times "atmp" 12 "original" } }
+ ! { dg-final { cleanup-modules "mod" } }