Hello All, The attached fixes the remaining dependency issues, where more than one temporary is required for elemental subroutine calls. Extra tests are now enabled in defined_assignment_13.f90.
Some of you have tested and commented on an earlier version of the patch, for which thanks are due. This submission is completely refactored and simplified. Note also the condition that the extra temporary should only correspond to INTENT_IN arguments. Using write-in and write-out for other intents would enable non-conforming code because of the possibility of aliasing. Regtests OK on FC43/x86_64. OK for mainline? Regards Paul
From a521d44a131d4b9a64c7fec5687e0c2b51f1c75b Mon Sep 17 00:00:00 2001 From: Paul Thomas <[email protected]> Date: Mon, 13 Apr 2026 09:50:42 +0100 Subject: [PATCH] Fortran: Fix dependencies in elemental subroutine calls [PR120140] This patch fixes situations in which more than one temporary is needed in elemental calls. Rather than increase complexity of the scalarizer, the extra temporaries are conveniently generated in resolve.cc. Note the requirement for the extra temporary to correspond to an INTENT_IN argument. This is done to avoid non-conforming code. If the user wishes to risk aliasing it is up to them! 2026-04-13 Paul Thomas <[email protected]> gcc/fortran PR fortran/120140 * resolve.cc (resolve_elemental_dependencies): New function, preceded by prototype for add_temp_assign_before_call. (resolve_call): If an elemental subroutine call has at least two actual erguments, call resolve_elemental_dependencies to generate temporary expressions for the arguments if required. (get_temp_from_expr): Add optional boolean argument, which if set, makes the resulting temporary unconditionally allocatable. (add_temp_assign_before_call): New function. gcc/testsuite/ PR fortran/123352 * gfortran.dg/defined_assignment_13.f90: Add previously failing tests. --- gcc/fortran/resolve.cc | 105 +++++++++++++++++- .../gfortran.dg/defined_assignment_13.f90 | 44 +++++--- 2 files changed, 130 insertions(+), 19 deletions(-) diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc index eac6e81c233..f6cb8f157dd 100644 --- a/gcc/fortran/resolve.cc +++ b/gcc/fortran/resolve.cc @@ -4129,6 +4129,55 @@ check_import_status (gfc_expr *e) } +/* If an elemental call has an INTENT_IN argument that has a dependency on an + argument which is not INTENT_IN and requires a temporary, build a temporary + for the INTENT_IN actual argument as well. */ + +static void +add_temp_assign_before_call (gfc_code *, gfc_namespace *, gfc_expr **); + +static void +resolve_elemental_dependencies (gfc_code *c) +{ + gfc_actual_arglist *arg1 = c->ext.actual; + gfc_actual_arglist *arg2 = NULL; + gfc_formal_arglist *formal1 = c->resolved_sym->formal; + gfc_formal_arglist *formal2 = NULL; + gfc_expr *expr1; + gfc_expr **expr2; + + for (; arg1 && formal1; arg1 = arg1->next, formal1 = formal1->next) + { + if (formal1->sym + && (formal1->sym->attr.intent == INTENT_IN + || formal1->sym->attr.value)) + continue; + + if (!arg1->expr || arg1->expr->expr_type != EXPR_VARIABLE) + continue; + + arg2 = c->ext.actual; + formal2 = c->resolved_sym->formal; + for (; arg2 && formal2; arg2 = arg2->next, formal2 = formal2->next) + { + if (arg2 == arg1 || !arg2->expr + || !(formal2->sym && formal2->sym->attr.intent == INTENT_IN)) + continue; + + expr1 = arg1->expr; + expr2 = &arg2->expr; + + /* If the arg1 has something horrible like a vector index and + there is a dependency between arg1 and arg2, build a + temporary from arg2, assign the arg2 to it and use the + temporary in the call expression. */ + if (expr1->rank && gfc_ref_needs_temporary_p (expr1->ref) + && gfc_check_dependency (expr1, *expr2, false)) + add_temp_assign_before_call (c, gfc_current_ns, expr2); + } + } +} + /* Resolve a subroutine call. Although it was tempting to use the same code for functions, subroutines and functions are stored differently and this makes things awkward. */ @@ -4289,6 +4338,11 @@ resolve_call (gfc_code *c) if (!resolve_elemental_actual (NULL, c)) return false; + /* Deal with complicated dependencies that the scalarizer cannot handle. */ + if (c->resolved_sym && c->resolved_sym->attr.elemental && !no_formal_args + && c->ext.actual && c->ext.actual->next) + resolve_elemental_dependencies (c); + if (!c->expr1) update_current_proc_array_outer_dependency (csym); else @@ -13308,10 +13362,12 @@ build_assignment (gfc_exec_op op, gfc_expr *expr1, gfc_expr *expr2, /* Makes a temporary variable expression based on the characteristics of - a given variable expression. */ + a given variable expression. If allocatable is set, the temporary is + unconditionally allocatable*/ static gfc_expr* -get_temp_from_expr (gfc_expr *e, gfc_namespace *ns) +get_temp_from_expr (gfc_expr *e, gfc_namespace *ns, + bool allocatable = false) { static int serial = 0; char name[GFC_MAX_SYMBOL_LEN]; @@ -13365,7 +13421,7 @@ get_temp_from_expr (gfc_expr *e, gfc_namespace *ns) tmp->n.sym->attr.intent = INTENT_UNKNOWN; - if (as) + if (as && !allocatable) { tmp->n.sym->as = gfc_copy_array_spec (as); if (!ref) @@ -13375,7 +13431,7 @@ get_temp_from_expr (gfc_expr *e, gfc_namespace *ns) } else if ((e->rank || e->corank) && (e->expr_type == EXPR_ARRAY || e->expr_type == EXPR_FUNCTION - || e->expr_type == EXPR_OP)) + || e->expr_type == EXPR_OP || allocatable)) { tmp->n.sym->as = gfc_get_array_spec (); tmp->n.sym->as->type = AS_DEFERRED; @@ -13394,7 +13450,7 @@ get_temp_from_expr (gfc_expr *e, gfc_namespace *ns) /* Should the lhs be a section, use its array ref for the temporary expression. */ - if (aref && aref->type != AR_FULL) + if (aref && aref->type != AR_FULL && !allocatable) { gfc_free_ref_list (e->ref); e->ref = gfc_copy_ref (ref); @@ -13403,6 +13459,45 @@ get_temp_from_expr (gfc_expr *e, gfc_namespace *ns) } +/* Helper function to take an argument in a subroutine call with a dependency + on another argument, copy it to an allocatable temporary and use the + temporary in the call expression. The new code is embedded in a block to + ensure local, automatic deallocation. */ + +static void +add_temp_assign_before_call (gfc_code *code, gfc_namespace *ns, + gfc_expr **rhsptr) +{ + gfc_namespace *block_ns; + gfc_expr *tmp_var; + + /* Wrap the new code in a block so that the temporary is deallocated. */ + block_ns = gfc_build_block_ns (ns); + + /* As it stands, the block_ns does not not stand up to resolution because the + the assignment would be converted to a call and, in any case, the modified + call fails in gfc_check_conformance. */ + block_ns->resolved = 1; + + /* Assign the original expression to the temporary. */ + tmp_var = get_temp_from_expr (*rhsptr, block_ns, true); + block_ns->code = build_assignment (EXEC_ASSIGN, tmp_var, *rhsptr, + NULL, NULL, (*rhsptr)->where); + + /* Transfer the call to the block and terminate block code. */ + *rhsptr = gfc_copy_expr (tmp_var); + block_ns->code->next = gfc_get_code (EXEC_NOP); + *(block_ns->code->next) = *code; + block_ns->code->next->next = NULL; + + /* Convert the original code to execute the block. */ + code->op = EXEC_BLOCK; + code->ext.block.ns = block_ns; + code->ext.block.assoc = NULL; + code->expr1 = code->expr2 = NULL; +} + + /* Add one line of code to the code chain, making sure that 'head' and 'tail' are appropriately updated. */ diff --git a/gcc/testsuite/gfortran.dg/defined_assignment_13.f90 b/gcc/testsuite/gfortran.dg/defined_assignment_13.f90 index 5a8a904fa25..ca0feaec7db 100644 --- a/gcc/testsuite/gfortran.dg/defined_assignment_13.f90 +++ b/gcc/testsuite/gfortran.dg/defined_assignment_13.f90 @@ -119,6 +119,12 @@ contains x%i = y%i + 42 end subroutine sub2 + impure elemental function f1 (x) + type(t1), intent(in) :: x + type(t1) :: f1 + f1%i = x%i + 99 + end function f1 + subroutine extra_tests () integer :: j type(t1) :: p1(4), q1(4) = [(t1(j),j=1,4)] @@ -127,6 +133,7 @@ contains integer :: iperm(2) = [1,2] integer :: expect1(4) = [25,24,0,0] integer :: expect2(4) = [44,43,0,0] + integer :: expect3(4) = [123,124,3,4] !----------------------------------- ! (1) l.h.s. not depending on r.h.s. @@ -261,21 +268,30 @@ contains ! l.h.s. vector indices, r.h.s. array section ! (this part currently disabled because the temporary for the l.h.s. ! is not yet implemented properly) -! p1%i = q1%i -! p1([2,1]) = p1(1:2) -! call check (p1%i, expect1, 71) -! -! p2%i = q2%i -! p2([2,1]) = p2(1:2) -! call check (p2%i, expect2, 73) + p1%i = q1%i + p1([2,1]) = p1(1:2) + call check (p1%i, expect1, 71) -! p1%i = q1%i -! call sub1 (p1([2,1]), (p1(1:2))) -! call check (p1%i, expect1, 72) -! -! p2%i = q2%i -! call sub2 (p2([2,1]), (p2(1:2))) -! call check (p2%i, expect2, 74) + p2%i = q2%i + p2([2,1]) = p2(1:2) + call check (p2%i, expect2, 72) + + p1%i = q1%i + call sub1 (p1([2,1]), (p1(1:2))) + call check (p1%i, expect1, 73) + + p2%i = q2%i + call sub2 (p2([2,1]), (p2(1:2))) + call check (p2%i, expect2, 74) + + ! l.h.s. vector indices, r.h.s. array section as a function arg. + p1%i = q1%i + p1([2,1]) = f1 (p1([2,1])) + call check (p1%i, expect3, 75) + + p1%i = q1%i + call sub1(p1([2,1]), f1 (p1([2,1]))) + call check (p1%i, expect3, 76) end subroutine extra_tests -- 2.53.0
