From patchwork Sat Jan 8 16:48:47 2011 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Paul Richard Thomas X-Patchwork-Id: 77966 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) by ozlabs.org (Postfix) with SMTP id D048FB7125 for ; Sun, 9 Jan 2011 03:49:11 +1100 (EST) Received: (qmail 1909 invoked by alias); 8 Jan 2011 16:49:05 -0000 Received: (qmail 1881 invoked by uid 22791); 8 Jan 2011 16:49:00 -0000 X-SWARE-Spam-Status: No, hits=-0.8 required=5.0 tests=AWL, BAYES_50, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, FREEMAIL_FROM, RCVD_IN_DNSWL_LOW, RFC_ABUSE_POST X-Spam-Check-By: sourceware.org Received: from mail-ey0-f175.google.com (HELO mail-ey0-f175.google.com) (209.85.215.175) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Sat, 08 Jan 2011 16:48:51 +0000 Received: by eya28 with SMTP id 28so8101561eya.20 for ; Sat, 08 Jan 2011 08:48:47 -0800 (PST) MIME-Version: 1.0 Received: by 10.213.108.208 with SMTP id g16mr19797351ebp.40.1294505327411; Sat, 08 Jan 2011 08:48:47 -0800 (PST) Received: by 10.213.3.15 with HTTP; Sat, 8 Jan 2011 08:48:47 -0800 (PST) Date: Sat, 8 Jan 2011 17:48:47 +0100 Message-ID: Subject: [Patch, fortran] PR46896 [4.3/4.4/4.5/4.6 Regression] Wrong code with transpose(a) passed to subroutine From: Paul Richard Thomas To: fortran@gcc.gnu.org, gcc-patches Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org 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 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 PR fortran/46896 * gfortran.dg/transpose_optimization_2.f90 : New test. 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 + ! + 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" } }