+2011-01-08 Paul Thomas <pault@gcc.gnu.org>
+
+ PR fortran/46896
+ * trans-expr.c (gfc_conv_procedure_call): With a non-copying
+ procedure argument (eg TRANSPOSE) use a temporary if there is
+ any chance of aliasing due to host or use association.
+ (arrayfunc_assign_needs_temporary): Correct logic for function
+ results and do not use a temporary for implicitly PURE
+ variables. Use a temporary for Cray pointees.
+ * symbol.c (gfc_add_save): Explicit SAVE not compatible with
+ implicit pureness of containing procedure.
+ * decl.c (match_old_style_init, gfc_match_data): Where decl
+ would fail in PURE procedure, set implicit_pure to zero.
+ * gfortran.h : Add implicit_pure to structure symbol_attr and
+ add prototype for function gfc_implicit_pure.
+ * expr.c (gfc_check_pointer_assign, gfc_check_vardef_context):
+ Where decl would fail in PURE procedure, reset implicit_pure.
+ * io.c (match_vtag, gfc_match_open, gfc_match_close,
+ gfc_match_print, gfc_match_inquire, gfc_match_wait): The same.
+ * match.c (gfc_match_critical, gfc_match_stopcode,
+ sync_statement, gfc_match_allocate, gfc_match_deallocate): The
+ same.
+ * parse.c (decode_omp_directive): The same.
+ (parse_contained): If not PURE, set implicit pure attribute.
+ * resolve.c (resolve_formal_arglist, resolve_structure_cons,
+ resolve_function, resolve_ordinary_assign) : The same.
+ (gfc_implicit_pure): New function.
+ * module.c (mio_symbol_attribute): Introduce AB_IMPLICIT_PURE
+ to ab_attribute enum and use it in this function.
+
2011-01-08 Thomas Koenig <tkoenig@gcc.gnu.org>
PR fortran/45777
/* Declaration statement matcher
- Copyright (C) 2002, 2004, 2005, 2006, 2007, 2008, 2009, 2010
+ Copyright (C) 2002, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
Free Software Foundation, Inc.
Contributed by Andy Vaught
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)
{
return MATCH_ERROR;
}
+ if (gfc_implicit_pure (NULL))
+ gfc_current_ns->proc_name->attr.implicit_pure = 0;
+
return MATCH_YES;
cleanup:
/* Routines for manipulation of expression nodes.
Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
- 2009, 2010
+ 2009, 2010, 2011
Free Software Foundation, Inc.
Contributed by Andy Vaught
{
symbol_attribute attr;
gfc_ref *ref;
- bool is_pure, rank_remap;
+ bool is_pure, is_implicit_pure, rank_remap;
int proc_pointer;
if (lvalue->symtree->n.sym->ts.type == BT_UNKNOWN
}
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
"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 "
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)
{
/* gfortran header file
Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
- 2009, 2010
+ 2009, 2010, 2011
Free Software Foundation, Inc.
Contributed by Andy Vaught
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. Note that this is zero for PURE procedures. */
+ 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_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);
/* Deal with I/O statements & related stuff.
Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
- 2009, 2010
+ 2009, 2010, 2011
Free Software Foundation, Inc.
Contributed by Andy Vaught
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;
}
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. */
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. */
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;
"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)
return MATCH_ERROR;
}
+ if (gfc_implicit_pure (NULL))
+ gfc_current_ns->proc_name->attr.implicit_pure = 0;
+
return MATCH_YES;
}
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_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)
{
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;
/* Matching subroutines in all sizes, shapes and colors.
Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
- 2009, 2010
- 2010 Free Software Foundation, Inc.
+ 2009, 2010, 2011
+ Free Software Foundation, Inc.
Contributed by Andy Vaught
This file is part of GCC.
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;
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");
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;
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;
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
/* Handle modules, which amounts to loading and saving symbols and
their attendant structures.
Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
- 2009, 2010
+ 2009, 2010, 2011
Free Software Foundation, Inc.
Contributed by Andy Vaught
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_COARRAY_COMP, AB_VTYPE, AB_VTAB, AB_CONTIGUOUS, AB_CLASS_POINTER,
+ AB_IMPLICIT_PURE
}
ab_attribute;
minit ("VTYPE", AB_VTYPE),
minit ("VTAB", AB_VTAB),
minit ("CLASS_POINTER", AB_CLASS_POINTER),
+ minit ("IMPLICIT_PURE", AB_IMPLICIT_PURE),
minit (NULL, -1)
};
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)
case AB_PURE:
attr->pure = 1;
break;
+ case AB_IMPLICIT_PURE:
+ attr->implicit_pure = 1;
+ break;
case AB_RECURSIVE:
attr->recursive = 1;
break;
/* Main parser.
Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
- 2009, 2010
+ 2009, 2010, 2011
Free Software Foundation, Inc.
Contributed by Andy Vaught
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
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. */
/* Perform type resolution on the various structures.
- Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
+ Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
+ 2010, 2011
Free Software Foundation, Inc.
Contributed by Andy Vaught
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 "
&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. */
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;
}
}
+ 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)
}
}
+ 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. */
}
+/* Test whether a symbol is implicitly pure or not. For a NULL pointer,
+ checks if the current namespace is implicitly pure. Note that this
+ function returns false for a PURE procedure. */
+
+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. */
int
/* Maintain binary trees of symbols.
Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
- 2009, 2010
+ 2009, 2010, 2011
Free Software Foundation, Inc.
Contributed by Andy Vaught
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,
/* Expression translation
- Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
+ Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
+ 2011
Free Software Foundation, Inc.
Contributed by Paul Brook <paul@nowt.org>
and Steven Bosscher <s.bosscher@student.tudelft.nl>
argument and another one. */
if (gfc_get_noncopying_intrinsic_argument (e) != NULL)
{
+ gfc_expr *iarg;
sym_intent intent;
if (fsym != NULL)
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
/* 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. */
+ 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
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.cray_pointee
+ || 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;
- /* TODO a function that could correctly be declared PURE but is not
- could do with returning false as well. */
+ /* 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
bool dealloc)
{
tree tmp;
-
+
if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
{
gfc_error ("Assignment to deferred-length character variable at %L "
+2011-01-08 Paul Thomas <pault@gcc.gnu.org>
+
+ PR fortran/46896
+ * gfortran.dg/transpose_optimization_2.f90 : New test.
+
2011-01-08 Jan Hubicka <jh@suse.cz>
PR tree-optmization/46469
--- /dev/null
+! { 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" } }
OSDN Git Service
