Re: [Patch, fortran] PR46897 - [OOP] type-bound defined ASSIGNMENT(=) not used for derived type component in intrinsic assign

[Mikael Morin <mikael dot morin at sfr dot fr>]

Hello,

On 10/09/2012 20:58, Paul Richard Thomas wrote:
> Dear All,
> 
> Please find attached a new attempt at the patch for PR46897.  It now
> uses temporaries to overcome the side effects that Mikael pointed out.

And here comes the next round of comments.


> Index: gcc/fortran/resolve.c
> ===================================================================
> *** gcc/fortran/resolve.c	(revision 191115)
> --- gcc/fortran/resolve.c	(working copy)
> *************** resolve_ordinary_assign (gfc_code *code,
> *** 9516,9521 ****
> --- 9516,9791 ----
>   }
>   
>   
> + /* Add a component reference onto an expression.  */
> + 
> + static void
> + add_comp_ref (gfc_expr *e, gfc_component *c)
> + {
> +   gfc_ref **ref;
> +   ref = &(e->ref);
> +   while (*ref)
> +     ref = &((*ref)->next);
> +   *ref = gfc_get_ref();
> +   (*ref)->type = REF_COMPONENT;
> +   (*ref)->u.c.sym = e->ts.u.derived;
> +   (*ref)->u.c.component = c;
> +   e->ts = c->ts;
> + 
> +   /* Add a full array ref, as necessary.  */
> +   e->rank = c && c->as ? c->as->rank : 0;
This is bogus if  e->rank was != 0 previously (think of the case
array(:)%scalar_comp).
The c == NULL case should be handled at the beginning (if at all).

> +   if (e->rank)
the condition should be on c->as (for the case array(:)%scalar_comp again).

> +     gfc_add_full_array_ref (e, c->as);
> + }
> + 
> + 
> + /* Build an assignment.  */
> + 
> + static gfc_code *
> + build_assignment (gfc_exec_op op, gfc_expr *expr1, gfc_expr *expr2,
> + 		  gfc_component *comp1, gfc_component *comp2, locus loc)
> + {
> +   gfc_code *this_code;
> + 
> +   this_code = gfc_get_code ();
> +   this_code->op = op;
all calls are with op == EXEC_ASSIGN, you may as well hardcode it.

> +   this_code->next = NULL;
> +   this_code->expr1 = gfc_copy_expr (expr1);
> +   this_code->expr2 = gfc_copy_expr (expr2);
> +   this_code->loc = loc;
> +   if (comp1 && comp2)
> +     {
> +       add_comp_ref (this_code->expr1, comp1);
> +       add_comp_ref (this_code->expr2, comp2);
> +     }
> + 
> +   return this_code;
> + }
> + 
> + 
> + /* Makes a temporary variable expression based on the characteristics of
> +    a given expression.  */
> + 
> + static gfc_expr*
> + get_temp_from_expr (gfc_expr *e, gfc_namespace *ns)
> + {
> +   static int serial = 0;
> +   char name[GFC_MAX_SYMBOL_LEN];
> +   gfc_symtree *tmp;
> +   gfc_ref *ref = NULL, *eref;
> + 
> +   gcc_assert (e->expr_type == EXPR_VARIABLE
> + 	      || e->expr_type == EXPR_FUNCTION);
As far as I know anything can be used, not only variables and functions.
The derived type cases are a bit specific but at least array/structure
constructors are missing.  There could be also typebound function calls
(I never know whether they are EXPR_FUNCTION or something else).

> +   sprintf (name, "da@%d", serial++);
> +   gfc_get_sym_tree (name, ns, &tmp, false);
> +   gfc_add_type (tmp->n.sym, &e->ts, NULL);
> + 
> +   for (eref = e->ref; eref; eref = eref->next)
> +     if (eref->type == REF_COMPONENT)
> +       ref = eref;
> + 
> +   if (!ref)
> +     {
> +       tmp->n.sym->attr = e->symtree->n.sym->attr;
> +       if (e->symtree->n.sym->as)
> + 	tmp->n.sym->as
> + 		= gfc_copy_array_spec (e->symtree->n.sym->as);
> +     }
> +   else
> +     {
> +       tmp->n.sym->attr = ref->u.c.component->attr;
> +       if (ref->u.c.component->as)
> + 	tmp->n.sym->as
> + 		= gfc_copy_array_spec (ref->u.c.component->as);
> +     }
> + 
> +   gfc_set_sym_referenced (tmp->n.sym);
> +   gfc_add_flavor (&tmp->n.sym->attr, FL_VARIABLE, name, NULL);
> +   return gfc_lval_expr_from_sym (tmp->n.sym);
> + }
> + 
> + 
> + /* Add one line of code to the code chain, making sure that 'head' and
> +    'tail' are appropriately updated.  */
> + 
> + static void
> + add_code_to_chain (gfc_code **this_code, gfc_code **head, gfc_code **tail)
> + {
> +   gcc_assert (this_code);
> +   if (*head == NULL)
> +     *head = *tail = *this_code;
> +   else
> +     *tail = gfc_append_code (*tail, *this_code);
> +   *this_code = NULL;
> + }
> + 
> + 
> + /* Implement 7.2.1.3 of the F08 standard:
> +    "An intrinsic assignment where the variable is of derived type is
> +    performed as if each component of the variable were assigned from the
> +    corresponding component of expr using pointer assignment (7.2.2) for
> +    each pointer component, deïned assignment for each nonpointer
> +    nonallocatable component of a type that has a type-bound deïned
> +    assignment consistent with the component, intrinsic assignment for
> +    each other nonpointer nonallocatable component, ..." 
> + 
> +    The pointer assignments are taken care of by the intrinsic
> +    assignment of the structure itself.  This function recursively adds
> +    defined assignments where required.
> + 
> +    Since the lhs in a defined assignment can have intent INOUT, the code
> +    to do this gets a bit messy.  In pseudo-code:
> + 
> +    ! Only call function lhs once.
> +       if (lhs is a function)
> + 	temp_x = expr2
> +       expr2 = expr(temp_x)
> +    ! Need two temporaries for lhs.
> +       t1 = expr1
> +       t2 = expr2
> +    ! Do the intrinsic assignment
> +       expr1 = expr2
> +    ! Now do the defined assignments
> +       do over components with typebound defined assignment [%cmp]
> + 	expr2%cmp {defined=} t1%cmp
I guess it should be `t1%cmp {defined=} expr2%cmp'?

> + 	expr1%cmp = t1%cmp           ! Store in the result
> +         t1%cmp = t2%cmp              ! Restore the original value
It seems to me that the last assignment isn't useful: once one component
has been taken care of, we proceed with the next one, so `t1' can have
garbage in the previous one without any impact.
Then if it can be removed, `t2' is useless and then `temp_x' as well, so
we could do with the simpler [still most of `t1' is useless]:
   t1 = expr1
   expr1 = expr2
   t1%cmp {defined=} expr1%cmp
   expr1%cmp = t1%cmp

It would be nice too if the temporaries were avoided in the case there
is no defined assignment with intent(inout) lhs, but I leave the
decision to do it to you.


> +       */
> + 
> + static void
> + generate_component_assignments (gfc_code **code, gfc_namespace *ns)
> + {
> +   gfc_component *comp1, *comp2;
> +   gfc_code *this_code = NULL, *head = NULL, *tail = NULL;
> +   gfc_expr *t1, *t2;
> + 
> +   /* Filter out continuing processing after an error.  */
> +   if ((*code)->expr1->ts.type != BT_DERIVED
> +       || (*code)->expr2->ts.type != BT_DERIVED)
> +     return;
> + 
> +   /* Create a temporary so that functions get called once.  */
> +   if ((*code)->expr2->expr_type != EXPR_VARIABLE)
> +     {
> +       gfc_expr *tmp_expr;
> +       
> +       /* Assign the rhs to the temporary.  */
> +       tmp_expr = get_temp_from_expr ((*code)->expr1, ns);
> +       this_code = build_assignment (EXEC_ASSIGN,
> + 				    tmp_expr, (*code)->expr2,
> + 				    NULL, NULL, (*code)->loc);
> + 
> +       /* Add the code and substitute the rhs expression. */
> +       add_code_to_chain (&this_code, &head, &tail);
> +       gfc_free_expr ((*code)->expr2);
> +       (*code)->expr2 = tmp_expr;
> +     }
> + 
> +   /* Build the two temporaries required for the assignment.  */
> +   t1 = get_temp_from_expr ((*code)->expr1, ns);
> +   this_code = build_assignment (EXEC_ASSIGN,
> + 				t1, (*code)->expr1,
> + 				NULL, NULL, (*code)->loc);
> +   add_code_to_chain (&this_code, &head, &tail);
> +   t2 = get_temp_from_expr ((*code)->expr1, ns);
> +   this_code = build_assignment (EXEC_ASSIGN,
> + 				t2, (*code)->expr1,
> + 				NULL, NULL, (*code)->loc);
> +   add_code_to_chain (&this_code, &head, &tail);
> + 
> +   /* Do the intrinsic assignment. This is not needed if the lhs is one
> +      of the temporaries generated here, since the intrinsic assignment
> +      to the final result already does this.  */
> +   if ((*code)->expr1->symtree->n.sym->name[2] != '@')
> +     {
> +       this_code = build_assignment (EXEC_ASSIGN,
> + 				    (*code)->expr1, (*code)->expr2,
> + 				    NULL, NULL, (*code)->loc);
> +       add_code_to_chain (&this_code, &head, &tail);
> +     }
> + 
> +   comp1 = (*code)->expr1->ts.u.derived->components;
> +   comp2 = (*code)->expr2->ts.u.derived->components;
> + 
> +   for (; comp1; comp1 = comp1->next, comp2 = comp2->next)
> +     {
> +       /* The intrinsic assignment does the right thing for pointers
> + 	 of all kinds and allocatable components.  */
> +       if (comp1->ts.type != BT_DERIVED
> + 	  || comp1->attr.pointer
> + 	  || comp1->attr.allocatable
> + 	  || comp1->attr.proc_pointer_comp
That one doesn't look right.

> + 	  || comp1->attr.class_pointer
> + 	  || comp1->attr.proc_pointer)
> + 	continue;
> + 
> +       if (this_code)
> + 	add_code_to_chain (&this_code, &head, &tail);
> + 
> +       /* Make an assigment for this component.  */
> +       this_code = gfc_get_code ();
> +       this_code = build_assignment (EXEC_ASSIGN,
> + 				    t1, (*code)->expr2,
> + 				    comp1, comp2, (*code)->loc);
> + 
> +       /* Convert the assignment if there is a defined assignment for
> + 	 this type.  Otherwise, using the call from resolve_code,	
> + 	 recurse into its components.  */
> +       resolve_code (this_code, ns);
> + 
> +       if (this_code->op == EXEC_ASSIGN_CALL)
> + 	{
> + 	  /* Check that there is a typebound defined assignment.  If not,
> + 	     then this must be a module defined assignment.  We cannot
> + 	     use the defined_assign_comp attribute here because it must
> + 	     be this derived type that has the defined assignment and not
> + 	     a parent type.  */
> + 	  if (!(comp1->ts.u.derived->f2k_derived
> + 	        && comp1->ts.u.derived->f2k_derived
> + 					->tb_op[INTRINSIC_ASSIGN]))
> + 	    {
> + 	      gfc_free_statements (this_code);
`this_code' should be cleared, otherwise it is used in the next iteration.

> + 	      continue;
> + 	    }
> + 	}
> +       else if (this_code->op == EXEC_ASSIGN && !this_code->next)
> + 	{
> + 	  /* Don't add intrinsic assignments since they are already
> + 	     effected by the intrinsic assignment of the structure.  */
> + 	  gfc_free_statements (this_code);
Same.

> + 	  continue;
> + 	}
> + 
> +       add_code_to_chain (&this_code, &head, &tail);
> + 
> +       /* Transfer the value to the final result.  */
> +       this_code = build_assignment (EXEC_ASSIGN,
> + 				    (*code)->expr1, t1,
> + 				    comp1, comp2, (*code)->loc);
> +       add_code_to_chain (&this_code, &head, &tail);
> + 
> +       /* Restore the value of t1.  This code is added to the chain at
> + 	 the start of the loop if more defined assignments.  */
> +       this_code = build_assignment (EXEC_ASSIGN,
> + 				    t1, t2,
> + 				    comp1, comp2, (*code)->loc);
> +     }
> + 
> +   if (this_code)
> +     gfc_free_statements (this_code);
> +     
> +   /* Now attach the remaining code chain to the input code. Step on
> +      to the end of the new code since resolution is complete.  */
> +   gcc_assert ((*code)->op == EXEC_ASSIGN);
> +   tail->next = (*code)->next;
> +   /* Overwrite 'code' because this would place the intrinsic assignment
> +      before the temporary for the lhs is created.  */
> +   gfc_free_expr ((*code)->expr1);
> +   gfc_free_expr ((*code)->expr2);
> +   **code = *head;

free (head); ?

> +   *code = tail;
> + }
> + 
> + 
>   /* Given a block of code, recursively resolve everything pointed to by this
>      code block.  */
>   
> *************** resolve_code (gfc_code *code, gfc_namesp
> *** 9678,9683 ****
> --- 9948,9959 ----
>   	      else
>   		goto call;
>   	    }
> + 
> + 	  /* F03 7.4.1.3 for non-allocatable, non-pointer components.  */
> + 	  if (code->expr1->ts.type == BT_DERIVED
> + 	      && code->expr1->ts.u.derived->attr.defined_assign_comp)
> + 	    generate_component_assignments (&code, ns);
> + 
>   	  break;
>   
>   	case EXEC_LABEL_ASSIGN:
> *************** resolve_fl_derived0 (gfc_symbol *sym)
> *** 12282,12289 ****
> --- 12558,12574 ----
>   					   || c->attr.proc_pointer
>   					   || c->attr.allocatable)) == FAILURE)
>   	return FAILURE;
> + 
> +       if (c->ts.type == BT_DERIVED
> + 	  && c->ts.u.derived->f2k_derived
> + 	  && c->ts.u.derived->f2k_derived->tb_op[INTRINSIC_ASSIGN])
> + 	sym->attr.defined_assign_comp = 1;
>       }
>   
> +   if (super_type)
> +     sym->attr.defined_assign_comp
> + 			= super_type->attr.defined_assign_comp;
I guess Tobias' reported bug is here.  The flag shouldn't be cleared
here if it was set just before.


> + 
>     /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
>        all DEFERRED bindings are overridden.  */
>     if (super_type && super_type->attr.abstract && !sym->attr.abstract


To finish, I would like to draw your attention on the scalarizer not
supporting multiple arrays in the reference chain.  The initial
expressions are guaranteed to have at most one array in the chain, but
as we add subfield references, that condition can not remain true.  We
could try adding multiple references support in the scalarizer, but I
don't know how difficult it would be.  Or maybe better fix it at the
front-end AST level by using elemental functions to split the
scalarization work.  Or something else.  What do you think?

Mikael