Patchwork [fortran] PR46896 [4.3/4.4/4.5/4.6 Regression] Wrong code with transpose(a) passed to subroutine

login
register
mail settings
Submitter Paul Richard Thomas
Date Jan. 8, 2011, 4:48 p.m.
Message ID <AANLkTincqBHZLTrTojQ4JL0zBDAxHByAhp7eaegQigqj@mail.gmail.com>
Download mbox | patch
Permalink /patch/77966/
State New
Headers show

Comments

Paul Richard Thomas - Jan. 8, 2011, 4:48 p.m.
Dear All,

I have reached a point of diminishing returns with this one!  The
original problem was fixed with a quite simple forcing of temporaries
in trans-expr.c (gfc_conv_procedure_call).  However, this caused some
regressions since temporaries were being produced for testsuite cases
where they had been optimised away.  What I have done is to ensure
that the conditions for writing temporaries are a stringent as
possible and I have added tests for "implicit_pure" procedures; ie.
procedures that could be declared as pure but are not.  Given that the
purpose here is to prevent aliasing, the pureness requirement of no
side-effects might be too strong.  I suggest though that producing too
many temporaries is preferable to wrong code.  As far as I know, this
patch does not make gfortran any worse in this respect.

Tobias asked if I would take a look at dealing with Cray pointers.  It
turns out that these are in a bit of a poor state in gfortran.  It is
possible to write pure functions that suffer side effects if they are
included.  I will write a separate PR for this.  In consequence, I do
not want to deal with ot now.

This patch bootstraps and regtests on FC9/x86_64.

OK for trunk?  How far back do I go?

Cheers

Paul


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  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/46896
	* gfortran.dg/transpose_optimization_2.f90 : New test.
Tobias Burnus - Jan. 8, 2011, 6:08 p.m.
Paul Richard Thomas wrote:
> [Cray pointers] It is possible to write pure functions that
> suffer side effects if they are included.  I will write
> a separate PR for this.
Thanks!

> This patch bootstraps and regtests on FC9/x86_64.
> OK for trunk?  How far back do I go?

OK with the changes discussed in IRC (indenting fix, another 
cray_pointee check, comment that implicit_pure is false if the function 
is explicitly marked as PURE).

Tobias


> 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  Paul Thomas<pault@gcc.gnu.org>
>
> 	PR fortran/46896
> 	* gfortran.dg/transpose_optimization_2.f90 : New test.

Patch

Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c	(revision 168596)
--- gcc/fortran/trans-expr.c	(working copy)
*************** gfc_conv_procedure_call (gfc_se * se, gf
*** 3078,3083 ****
--- 3078,3084 ----
  		 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
*** 3088,3093 ****
--- 3089,3113 ----
  		  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
*** 3382,3388 ****
  
  	  /* 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
--- 3402,3408 ----
  
  	  /* 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
*** 5376,5393 ****
    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
--- 5396,5428 ----
    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, 
*** 6003,6009 ****
  		      bool dealloc)
  {
    tree tmp;
!   
    if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
      {
        gfc_error ("Assignment to deferred-length character variable at %L "
--- 6038,6044 ----
  		      bool dealloc)
  {
    tree tmp;
! 
    if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
      {
        gfc_error ("Assignment to deferred-length character variable at %L "
Index: gcc/fortran/symbol.c
===================================================================
*** gcc/fortran/symbol.c	(revision 168596)
--- gcc/fortran/symbol.c	(working copy)
*************** gfc_add_save (symbol_attribute *attr, sa
*** 1110,1115 ****
--- 1110,1118 ----
        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, 
Index: gcc/fortran/decl.c
===================================================================
*** gcc/fortran/decl.c	(revision 168596)
--- gcc/fortran/decl.c	(working copy)
*************** match_old_style_init (const char *name)
*** 502,507 ****
--- 502,510 ----
        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)
*** 560,565 ****
--- 563,571 ----
        return MATCH_ERROR;
      }
  
+   if (gfc_implicit_pure (NULL))
+     gfc_current_ns->proc_name->attr.implicit_pure = 0;
+ 
    return MATCH_YES;
  
  cleanup:
Index: gcc/fortran/gfortran.h
===================================================================
*** gcc/fortran/gfortran.h	(revision 168596)
--- gcc/fortran/gfortran.h	(working copy)
*************** typedef struct
*** 723,728 ****
--- 723,733 ----
    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 *);
*** 2736,2741 ****
--- 2741,2747 ----
  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);
Index: gcc/fortran/expr.c
===================================================================
*** gcc/fortran/expr.c	(revision 168596)
--- gcc/fortran/expr.c	(working copy)
*************** gfc_check_pointer_assign (gfc_expr *lval
*** 3227,3233 ****
  {
    symbol_attribute attr;
    gfc_ref *ref;
!   bool is_pure, rank_remap;
    int proc_pointer;
  
    if (lvalue->symtree->n.sym->ts.type == BT_UNKNOWN
--- 3227,3233 ----
  {
    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
*** 3311,3316 ****
--- 3311,3317 ----
      }
  
    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
*** 3519,3524 ****
--- 3520,3529 ----
  		 "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
*** 4461,4466 ****
--- 4466,4474 ----
        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)
      {
Index: gcc/fortran/module.c
===================================================================
*** gcc/fortran/module.c	(revision 168596)
--- gcc/fortran/module.c	(working copy)
*************** typedef enum
*** 1675,1681 ****
    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;
  
--- 1675,1682 ----
    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[] =
*** 1725,1730 ****
--- 1726,1732 ----
      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 *
*** 1859,1864 ****
--- 1861,1868 ----
  	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 *
*** 1990,1995 ****
--- 1994,2002 ----
  	    case AB_PURE:
  	      attr->pure = 1;
  	      break;
+ 	    case AB_IMPLICIT_PURE:
+ 	      attr->implicit_pure = 1;
+ 	      break;
  	    case AB_RECURSIVE:
  	      attr->recursive = 1;
  	      break;
Index: gcc/fortran/io.c
===================================================================
*** gcc/fortran/io.c	(revision 168596)
--- gcc/fortran/io.c	(working copy)
*************** match_vtag (const io_tag *tag, gfc_expr 
*** 1315,1320 ****
--- 1315,1323 ----
        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)
*** 1824,1829 ****
--- 1827,1835 ----
        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)
*** 2238,2243 ****
--- 2244,2252 ----
        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:
*** 2385,2390 ****
--- 2394,2402 ----
        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) \
*** 3223,3228 ****
--- 3235,3244 ----
  		     "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)
*** 3753,3758 ****
--- 3769,3777 ----
        return MATCH_ERROR;
      }
  
+   if (gfc_implicit_pure (NULL))
+     gfc_current_ns->proc_name->attr.implicit_pure = 0;
+ 
    return MATCH_YES;
  }
  
*************** gfc_match_inquire (void)
*** 3909,3914 ****
--- 3928,3936 ----
  	  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)
*** 3959,3964 ****
--- 3981,3989 ----
        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)
*** 4142,4147 ****
--- 4167,4175 ----
        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;
  
Index: gcc/fortran/resolve.c
===================================================================
*** gcc/fortran/resolve.c	(revision 168596)
--- gcc/fortran/resolve.c	(working copy)
*************** resolve_formal_arglist (gfc_symbol *proc
*** 273,278 ****
--- 273,281 ----
  	      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
*** 345,350 ****
--- 348,363 ----
  		       &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, 
*** 1124,1129 ****
--- 1137,1148 ----
  		     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)
*** 3067,3072 ****
--- 3086,3094 ----
  	}
      }
  
+   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,
*** 8803,8809 ****
  	  return rval;
  	}
  
!       /* Fortran 2008, C1283.  */
        if (gfc_is_coindexed (lhs))
  	{
  	  gfc_error ("Assignment to coindexed variable at %L in a PURE "
--- 8825,8831 ----
  	  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,
*** 8812,8817 ****
--- 8834,8859 ----
  	}
      }
  
+   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)
*** 12763,12768 ****
--- 12805,12836 ----
    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.  */
  
Index: gcc/fortran/match.c
===================================================================
*** gcc/fortran/match.c	(revision 168596)
--- gcc/fortran/match.c	(working copy)
*************** gfc_match_critical (void)
*** 1746,1751 ****
--- 1746,1754 ----
        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)
*** 2189,2194 ****
--- 2192,2200 ----
        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)
*** 2321,2326 ****
--- 2327,2335 ----
        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)
*** 2920,2925 ****
--- 2929,2938 ----
  	  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)
*** 3263,3268 ****
--- 3276,3284 ----
  	  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
Index: gcc/fortran/parse.c
===================================================================
*** gcc/fortran/parse.c	(revision 168596)
--- gcc/fortran/parse.c	(working copy)
*************** decode_omp_directive (void)
*** 495,500 ****
--- 495,503 ----
        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)
*** 3850,3855 ****
--- 3853,3864 ----
  	  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.  */
Index: gcc/testsuite/gfortran.dg/transpose_optimization_2.f90
===================================================================
*** gcc/testsuite/gfortran.dg/transpose_optimization_2.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/transpose_optimization_2.f90	(revision 0)
***************
*** 0 ****
--- 1,65 ----
+ ! { 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" } }