Re: [PATCH] Fortran: fixes for procedures with ALLOCATABLE,INTENT(OUT) arguments [PR92178]

[Harald Anlauf <anlauf@gmx.de>]

[-- Attachment #1: Type: text/plain, Size: 4164 bytes --]

Hi Mikael, all,

I think I've found it: there is a call to gfc_conv_class_to_class
that - according to a comment - does a repackaging to a class array.
Deferring that repackaging along with the deallocation not only fixes
the regression, but also the cases I tested.

Attached is a "sneak preview", hoping that the experts (Paul, Mikael,
...) can tell if I am going down the wrong road.

I'll wrap up all pieces and resubmit when the dust settles.

We can then address the other findings later.

Harald

Am 04.07.23 um 15:35 schrieb Mikael Morin:
> Le 03/07/2023 à 22:49, Harald Anlauf a écrit :
>> Hi Mikael,
>>
>> Am 03.07.23 um 13:46 schrieb Mikael Morin:
>>> These look good, but I'm surprised that there is no similar change at
>>> the 6819 line.
>>> This is the class array actual vs class array dummy case.
>>> It seems to be checked by the "bar" subroutine in your testcase, except
>>> that the intent(out) argument comes last there, whereas it was coming
>>> first with the original testcases in the PR.
>>> Can you double check?
>>
>> I believe I tried that before and encountered regressions.
>> The change
>>
>> diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
>> index 16e8f037cfc..43e013fa720 100644
>> --- a/gcc/fortran/trans-expr.cc
>> +++ b/gcc/fortran/trans-expr.cc
>> @@ -6844,7 +6844,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol *
>> sym,
>>                    else
>>                      tmp = gfc_finish_block (&block);
>>
>> -                 gfc_add_expr_to_block (&se->pre, tmp);
>> +//               gfc_add_expr_to_block (&se->pre, tmp);
>> +                 gfc_add_expr_to_block (&dealloc_blk, tmp);
>>                  }
>>
>>                /* The conversion does not repackage the reference to a 
>> class
>>
>> regresses on:
>> gfortran.dg/class_array_16.f90
>> gfortran.dg/finalize_12.f90
>> gfortran.dg/optional_class_1.f90
>>
>> A simplified testcase for further study:
>>
>> program p
>>    implicit none
>>    class(*),  allocatable :: c(:)
>>    c = [3, 4]
>>    call bar (allocated (c), c, allocated (c))
>>    if (allocated (c)) stop 14
>> contains
>>    subroutine bar (alloc, x, alloc2)
>>      logical :: alloc, alloc2
>>      class(*), allocatable, intent(out) :: x(:)
>>      if (allocated (x)) stop 5
>>      if (.not. alloc)   stop 6
>>      if (.not. alloc2)  stop 16
>>    end subroutine bar
>> end
>>
>> (This fails in a different place for the posted patch and for
>> the above trial change.  Need to go to the drawing board...)
>>
> I've had a quick look.
> 
> The code originally generated looks like:
> 
>      D.4343 = (void *[0:] * restrict) c._data.data != 0B;
>      if (c._data.data != 0B)
>        // free c._data.data
>      c._data.data = 0B;
>      ...
>      class.3._data = c._data;
>      ...
>      D.4345 = (void *[0:] * restrict) c._data.data != 0B;
>      bar (&D.4343, &class.3, &D.4345);
> 
> this fails because D.4345 has the wrong value.
> With your change, it becomes:
> 
>      D.4343 = (void *[0:] * restrict) c._data.data != 0B;
>      ...
>      class.3._data = c._data;
>      ...
>      D.4345 = (void *[0:] * restrict) c._data.data != 0B;
>      if (c._data.data != 0B)
>        // free c._data.data
>      c._data.data = 0B;
>      bar (&D.4343, &class.3, &D.4345);
> 
> and then it is class.3._data that has the wrong value.
> So basically the initialization of class.3 should move with the 
> deallocation.
> 
> I can reproduce a similar problem with your unmodified patch on the 
> following variant:
> 
> program p
>    implicit none
>    class(*),  allocatable :: c
>    c = 3
>    call bar (c, allocated (c))
>    if (allocated (c)) stop 14
> contains
>    subroutine bar (x, alloc2)
>      logical :: alloc, alloc2
>      class(*), allocatable, intent(out) :: x(..)
>      if (allocated (x)) stop 5
>      if (.not. alloc)   stop 6
>      if (.not. alloc2)  stop 16
>    end subroutine bar
> end
> 
> 
> 

[-- Attachment #2: pr92178-v2-partial.patch --]
[-- Type: text/x-patch, Size: 2317 bytes --]

diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 16e8f037cfc..a68c8d33acc 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -6804,6 +6804,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	      /* Pass a class array.  */
 	      parmse.use_offset = 1;
 	      gfc_conv_expr_descriptor (&parmse, e);
+	      bool defer_repackage = false;
 
 	      /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
 		 allocated on entry, it must be deallocated.  */
@@ -6844,7 +6845,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 		  else
 		    tmp = gfc_finish_block (&block);
 
-		  gfc_add_expr_to_block (&se->pre, tmp);
+		  gfc_add_expr_to_block (&dealloc_blk, tmp);
+		  defer_repackage = true;
 		}
 
 	      /* The conversion does not repackage the reference to a class
@@ -6858,6 +6860,10 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 				     && e->symtree->n.sym->attr.optional,
 				     CLASS_DATA (fsym)->attr.class_pointer
 				     || CLASS_DATA (fsym)->attr.allocatable);
+
+	      /* Defer repackaging after deallocation.  */
+	      if (defer_repackage)
+		gfc_add_block_to_block (&dealloc_blk, &parmse.pre);
 	    }
 	  else
 	    {
@@ -7131,17 +7137,12 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 
       /* If any actual argument of the procedure is allocatable and passed
 	 to an allocatable dummy with INTENT(OUT), we conservatively
-	 evaluate all actual argument expressions before deallocations are
+	 evaluate actual argument expressions before deallocations are
 	 performed and the procedure is executed.  This ensures we conform
-	 to F2023:15.5.3, 15.5.4.  Create temporaries except for constants,
-	 variables, and functions returning pointers that can appear in a
-	 variable definition context.  */
+	 to F2023:15.5.3, 15.5.4.  May create temporaries when needed.  */
       if (e && fsym && force_eval_args
-	  && e->expr_type != EXPR_VARIABLE
-	  && !gfc_is_constant_expr (e)
-	  && (e->expr_type != EXPR_FUNCTION
-	      || !(gfc_expr_attr (e).pointer
-		   || gfc_expr_attr (e).proc_pointer)))
+	  && fsym->attr.intent != INTENT_OUT
+	  && !gfc_is_constant_expr (e))
 	parmse.expr = gfc_evaluate_now (parmse.expr, &parmse.pre);
 
       if (fsym && need_interface_mapping && e)