CO_BROADCAST for derived types with allocatable components

From-SVN: r276164

gcc/fortran/ChangeLog

+2019-09-26  Alessandro Fanfarillo  <afanfa@gcc.gnu.org>
+
+	* trans-array.c (structure_alloc_comps):
+	Add new enum item for BCAST_ALLOC_COMP.
+	New argument for structure_alloc_comp, and new case to handle
+	recursive components in derived types.
+	* trans-array.c (gfc_bcast_alloc_comp): New function
+	used to handleco_broadcast for allocatable components
+	of derived types.
+	* trans-array.h: Add gfc_bcast_alloc_comp
+	* trans-intrinsics.c (conv_co_collective): Add check for
+	derived type variable and invocation of co_bcast_alloc_comp.
+	* trans.h: New data structure gfc_co_subroutines_args.
+
 2019-09-25  David Malcolm  <dmalcolm@redhat.com>
 
 	PR fortran/91426

gcc/fortran/trans-array.c

@@ -8580,13 +8580,15 @@ gfc_caf_is_dealloc_only (int caf_mode)
 
 enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP,
       COPY_ALLOC_COMP, COPY_ONLY_ALLOC_COMP, REASSIGN_CAF_COMP,
-      ALLOCATE_PDT_COMP, DEALLOCATE_PDT_COMP, CHECK_PDT_DUMMY};
+      ALLOCATE_PDT_COMP, DEALLOCATE_PDT_COMP, CHECK_PDT_DUMMY,
+      BCAST_ALLOC_COMP};
 
 static gfc_actual_arglist *pdt_param_list;
 
 static tree
 structure_alloc_comps (gfc_symbol * der_type, tree decl,
-		       tree dest, int rank, int purpose, int caf_mode)
+		       tree dest, int rank, int purpose, int caf_mode,
+		       gfc_co_subroutines_args *args)
 {
   gfc_component *c;
   gfc_loopinfo loop;
@@ -8672,14 +8674,14 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 	  && !caf_enabled (caf_mode))
 	{
 	  tmp = build_fold_indirect_ref_loc (input_location,
-					 gfc_conv_array_data (dest));
+					     gfc_conv_array_data (dest));
 	  dref = gfc_build_array_ref (tmp, index, NULL);
 	  tmp = structure_alloc_comps (der_type, vref, dref, rank,
-				       COPY_ALLOC_COMP, 0);
+				       COPY_ALLOC_COMP, 0, args);
 	}
       else
 	tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose,
-				     caf_mode);
+				     caf_mode, args);
 
       gfc_add_expr_to_block (&loopbody, tmp);
 
@@ -8713,13 +8715,13 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
   if (purpose == DEALLOCATE_ALLOC_COMP && der_type->attr.pdt_type)
     {
       tmp = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
-				   DEALLOCATE_PDT_COMP, 0);
+				   DEALLOCATE_PDT_COMP, 0, args);
       gfc_add_expr_to_block (&fnblock, tmp);
     }
   else if (purpose == ALLOCATE_PDT_COMP && der_type->attr.alloc_comp)
     {
       tmp = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
-				   NULLIFY_ALLOC_COMP, 0);
+				   NULLIFY_ALLOC_COMP, 0, args);
       gfc_add_expr_to_block (&fnblock, tmp);
     }
 
@@ -8741,6 +8743,125 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 
       switch (purpose)
 	{
+
+	case BCAST_ALLOC_COMP:
+
+	  tree ubound;
+	  tree cdesc;
+	  stmtblock_t derived_type_block;
+
+	  gfc_init_block (&tmpblock);
+
+	  comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
+				  decl, cdecl, NULL_TREE);
+
+	  /* Shortcut to get the attributes of the component.  */
+	  if (c->ts.type == BT_CLASS)
+	    {
+	      attr = &CLASS_DATA (c)->attr;
+	      if (attr->class_pointer)
+		continue;
+	    }
+	  else
+	    {
+	      attr = &c->attr;
+	      if (attr->pointer)
+		continue;
+	    }
+
+	  add_when_allocated = NULL_TREE;
+	  if (cmp_has_alloc_comps
+	      && !c->attr.pointer && !c->attr.proc_pointer)
+	    {
+	      if (c->ts.type == BT_CLASS)
+		{
+		  rank = CLASS_DATA (c)->as ? CLASS_DATA (c)->as->rank : 0;
+		  add_when_allocated
+		      = structure_alloc_comps (CLASS_DATA (c)->ts.u.derived,
+					       comp, NULL_TREE, rank, purpose,
+					       caf_mode, args);
+		}
+	      else
+		{
+		  rank = c->as ? c->as->rank : 0;
+		  add_when_allocated = structure_alloc_comps (c->ts.u.derived,
+							      comp, NULL_TREE,
+							      rank, purpose,
+							      caf_mode, args);
+		}
+	    }
+
+	  gfc_init_block (&derived_type_block);
+	  if (add_when_allocated)
+	    gfc_add_expr_to_block (&derived_type_block, add_when_allocated);
+	  tmp = gfc_finish_block (&derived_type_block);
+	  gfc_add_expr_to_block (&tmpblock, tmp);
+
+	  /* Convert the component into a rank 1 descriptor type.  */
+	  if (attr->dimension)
+	    {
+	      tmp = gfc_get_element_type (TREE_TYPE (comp));
+	      ubound = gfc_full_array_size (&tmpblock, comp,
+					    c->ts.type == BT_CLASS
+					    ? CLASS_DATA (c)->as->rank
+					    : c->as->rank);
+	    }
+	  else
+	    {
+	      tmp = TREE_TYPE (comp);
+	      ubound = build_int_cst (gfc_array_index_type, 1);
+	    }
+
+	  cdesc = gfc_get_array_type_bounds (tmp, 1, 0, &gfc_index_one_node,
+					     &ubound, 1,
+					     GFC_ARRAY_ALLOCATABLE, false);
+
+	  cdesc = gfc_create_var (cdesc, "cdesc");
+	  DECL_ARTIFICIAL (cdesc) = 1;
+  
+	  gfc_add_modify (&tmpblock, gfc_conv_descriptor_dtype (cdesc),
+	  		  gfc_get_dtype_rank_type (1, tmp));
+	  gfc_conv_descriptor_lbound_set (&tmpblock, cdesc,
+					  gfc_index_zero_node,
+					  gfc_index_one_node);
+	  gfc_conv_descriptor_stride_set (&tmpblock, cdesc,
+					  gfc_index_zero_node,
+					  gfc_index_one_node);
+	  gfc_conv_descriptor_ubound_set (&tmpblock, cdesc,
+					  gfc_index_zero_node, ubound);
+  
+	  if (attr->dimension)
+	    comp = gfc_conv_descriptor_data_get (comp);
+	  else
+	    {
+	      gfc_se se;
+
+	      gfc_init_se (&se, NULL);
+
+	      comp = gfc_conv_scalar_to_descriptor (&se, comp,
+	      					    c->ts.type == BT_CLASS
+	      					    ? CLASS_DATA (c)->attr
+	      					    : c->attr);
+	      comp = gfc_build_addr_expr (NULL_TREE, comp);
+	      gfc_add_block_to_block (&tmpblock, &se.pre);
+	    }
+
+	  gfc_conv_descriptor_data_set (&tmpblock, cdesc, comp);
+
+	  tree fndecl;
+
+	  fndecl = build_call_expr_loc (input_location,
+					gfor_fndecl_co_broadcast, 5,
+					gfc_build_addr_expr (pvoid_type_node,cdesc),
+					args->image_index,
+					null_pointer_node, null_pointer_node,
+					null_pointer_node);
+
+	  gfc_add_expr_to_block (&tmpblock, fndecl);
+	  gfc_add_block_to_block (&fnblock, &tmpblock);
+
+	  break;
+
 	case DEALLOCATE_ALLOC_COMP:
 
 	  gfc_init_block (&tmpblock);
@@ -8791,7 +8912,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 		  add_when_allocated
 		      = structure_alloc_comps (CLASS_DATA (c)->ts.u.derived,
 					       comp, NULL_TREE, rank, purpose,
-					       caf_mode);
+					       caf_mode, args);
 		}
 	      else
 		{
@@ -8799,7 +8920,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 		  add_when_allocated = structure_alloc_comps (c->ts.u.derived,
 							      comp, NULL_TREE,
 							      rank, purpose,
-							      caf_mode);
+							      caf_mode, args);
 		}
 	    }
 
@@ -9075,7 +9196,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 				      decl, cdecl, NULL_TREE);
 	      rank = c->as ? c->as->rank : 0;
 	      tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
-					   rank, purpose, caf_mode);
+					   rank, purpose, caf_mode, args);
 	      gfc_add_expr_to_block (&fnblock, tmp);
 	    }
 	  break;
@@ -9110,7 +9231,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 		{
 		  tmp = structure_alloc_comps (c->ts.u.derived, comp, dcmp,
 					       rank, purpose, caf_mode
-					   | GFC_STRUCTURE_CAF_MODE_IN_COARRAY);
+					       | GFC_STRUCTURE_CAF_MODE_IN_COARRAY,
+					       args);
 		  gfc_add_expr_to_block (&fnblock, tmp);
 		}
 	    }
@@ -9230,7 +9352,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 	      add_when_allocated = structure_alloc_comps (c->ts.u.derived,
 							  comp, dcmp,
 							  rank, purpose,
-							  caf_mode);
+							  caf_mode, args);
 	    }
 	  else
 	    add_when_allocated = NULL_TREE;
@@ -9594,7 +9716,7 @@ gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank,
 {
   return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
 				NULLIFY_ALLOC_COMP,
-			      GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode);
+				GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode, NULL);
 }
 
 
@@ -9607,9 +9729,47 @@ gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank,
 {
   return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
 				DEALLOCATE_ALLOC_COMP,
-			      GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode);
+				GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode, NULL);
 }
 
+tree
+gfc_bcast_alloc_comp (gfc_symbol *derived, gfc_expr *expr, int rank,
+		      tree image_index, tree stat, tree errmsg,
+		      tree errmsg_len)
+{
+  tree tmp, array;
+  gfc_se argse;
+  stmtblock_t block, post_block;
+  gfc_co_subroutines_args args;
+
+  args.image_index = image_index;
+  args.stat = stat;
+  args.errmsg = errmsg;
+  args.errmsg = errmsg_len;
+
+  if (rank == 0)
+    {
+      gfc_start_block (&block);
+      gfc_init_block (&post_block);
+      gfc_init_se (&argse, NULL);
+      gfc_conv_expr (&argse, expr);
+      gfc_add_block_to_block (&block, &argse.pre);
+      gfc_add_block_to_block (&post_block, &argse.post);
+      array = argse.expr;
+    }
+  else
+    {
+      gfc_init_se (&argse, NULL);
+      argse.want_pointer = 1;
+      gfc_conv_expr_descriptor (&argse, expr);
+      array = argse.expr;
+    }
+
+  tmp = structure_alloc_comps (derived, array, NULL_TREE, rank,
+			       BCAST_ALLOC_COMP,
+  			       GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY, &args);
+  return tmp;
+}
 
 /* Recursively traverse an object of derived type, generating code to
    deallocate allocatable components.  But do not deallocate coarrays.
@@ -9620,7 +9780,7 @@ tree
 gfc_deallocate_alloc_comp_no_caf (gfc_symbol * der_type, tree decl, int rank)
 {
   return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
-				DEALLOCATE_ALLOC_COMP, 0);
+				DEALLOCATE_ALLOC_COMP, 0, NULL);
 }
 
 
@@ -9628,7 +9788,7 @@ tree
 gfc_reassign_alloc_comp_caf (gfc_symbol *der_type, tree decl, tree dest)
 {
   return structure_alloc_comps (der_type, decl, dest, 0, REASSIGN_CAF_COMP,
-				GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY);
+				GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY, NULL);
 }
 
 
@@ -9640,7 +9800,7 @@ gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank,
 		     int caf_mode)
 {
   return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP,
-				caf_mode);
+				caf_mode, NULL);
 }
 
 
@@ -9651,7 +9811,7 @@ tree
 gfc_copy_only_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
 {
   return structure_alloc_comps (der_type, decl, dest, rank,
-				COPY_ONLY_ALLOC_COMP, 0);
+				COPY_ONLY_ALLOC_COMP, 0, NULL);
 }
 
 
@@ -9666,7 +9826,7 @@ gfc_allocate_pdt_comp (gfc_symbol * der_type, tree decl, int rank,
   gfc_actual_arglist *old_param_list = pdt_param_list;
   pdt_param_list = param_list;
   res = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
-			       ALLOCATE_PDT_COMP, 0);
+			       ALLOCATE_PDT_COMP, 0, NULL);
   pdt_param_list = old_param_list;
   return res;
 }
@@ -9678,7 +9838,7 @@ tree
 gfc_deallocate_pdt_comp (gfc_symbol * der_type, tree decl, int rank)
 {
   return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
-				DEALLOCATE_PDT_COMP, 0);
+				DEALLOCATE_PDT_COMP, 0, NULL);
 }
 
 
@@ -9693,7 +9853,7 @@ gfc_check_pdt_dummy (gfc_symbol * der_type, tree decl, int rank,
   gfc_actual_arglist *old_param_list = pdt_param_list;
   pdt_param_list = param_list;
   res = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
-			       CHECK_PDT_DUMMY, 0);
+			       CHECK_PDT_DUMMY, 0, NULL);
   pdt_param_list = old_param_list;
   return res;
 }

gcc/fortran/trans-array.h

@@ -52,6 +52,8 @@ bool gfc_caf_is_dealloc_only (int);
 tree gfc_nullify_alloc_comp (gfc_symbol *, tree, int, int cm = 0);
 
 tree gfc_deallocate_alloc_comp (gfc_symbol *, tree, int, int cm = 0);
+tree gfc_bcast_alloc_comp (gfc_symbol *, gfc_expr *, int, tree,
+			   tree, tree, tree);
 tree gfc_deallocate_alloc_comp_no_caf (gfc_symbol *, tree, int);
 tree gfc_reassign_alloc_comp_caf (gfc_symbol *, tree, tree);
 

gcc/fortran/trans-intrinsic.c

@@ -10786,13 +10786,12 @@ gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
     }
 }
 
-
 static tree
 conv_co_collective (gfc_code *code)
 {
   gfc_se argse;
   stmtblock_t block, post_block;
-  tree fndecl, array, strlen, image_index, stat, errmsg, errmsg_len;
+  tree fndecl, array = NULL_TREE, strlen, image_index, stat, errmsg, errmsg_len;
   gfc_expr *image_idx_expr, *stat_expr, *errmsg_expr, *opr_expr;
 
   gfc_start_block (&block);
@@ -10857,6 +10856,7 @@ conv_co_collective (gfc_code *code)
       gfc_conv_expr_descriptor (&argse, code->ext.actual->expr);
       array = argse.expr;
     }
+
   gfc_add_block_to_block (&block, &argse.pre);
   gfc_add_block_to_block (&post_block, &argse.post);
 
@@ -10915,46 +10915,64 @@ conv_co_collective (gfc_code *code)
       gcc_unreachable ();
     }
 
-  if (code->resolved_isym->id == GFC_ISYM_CO_SUM
-      || code->resolved_isym->id == GFC_ISYM_CO_BROADCAST)
-    fndecl = build_call_expr_loc (input_location, fndecl, 5, array,
-				  image_index, stat, errmsg, errmsg_len);
-  else if (code->resolved_isym->id != GFC_ISYM_CO_REDUCE)
-    fndecl = build_call_expr_loc (input_location, fndecl, 6, array, image_index,
-				  stat, errmsg, strlen, errmsg_len);
+  gfc_symbol *derived = code->ext.actual->expr->ts.type == BT_DERIVED
+    ? code->ext.actual->expr->ts.u.derived : NULL;
+
+  if (derived && derived->attr.alloc_comp
+      && code->resolved_isym->id == GFC_ISYM_CO_BROADCAST)
+    /* The derived type has the attribute 'alloc_comp'.  */
+    {
+      tree tmp = gfc_bcast_alloc_comp (derived, code->ext.actual->expr,
+				       code->ext.actual->expr->rank,
+				       image_index, stat, errmsg, errmsg_len);
+      gfc_add_expr_to_block (&block, tmp);
+    }
   else
     {
-      tree opr, opr_flags;
-
-      // FIXME: Handle TS29113's bind(C) strings with descriptor.
-      int opr_flag_int;
-      if (gfc_is_proc_ptr_comp (opr_expr))
-	{
-	  gfc_symbol *sym = gfc_get_proc_ptr_comp (opr_expr)->ts.interface;
-	  opr_flag_int = sym->attr.dimension
-			 || (sym->ts.type == BT_CHARACTER
-			     && !sym->attr.is_bind_c)
-			 ? GFC_CAF_BYREF : 0;
-	  opr_flag_int |= opr_expr->ts.type == BT_CHARACTER
-			  && !sym->attr.is_bind_c
-			  ? GFC_CAF_HIDDENLEN : 0;
-	  opr_flag_int |= sym->formal->sym->attr.value ? GFC_CAF_ARG_VALUE : 0;
-	}
+      if (code->resolved_isym->id == GFC_ISYM_CO_SUM
+	  || code->resolved_isym->id == GFC_ISYM_CO_BROADCAST)
+	fndecl = build_call_expr_loc (input_location, fndecl, 5, array,
+				      image_index, stat, errmsg, errmsg_len);
+      else if (code->resolved_isym->id != GFC_ISYM_CO_REDUCE)
+	fndecl = build_call_expr_loc (input_location, fndecl, 6, array,
+				      image_index, stat, errmsg,
+				      strlen, errmsg_len);
       else
 	{
-	  opr_flag_int = gfc_return_by_reference (opr_expr->symtree->n.sym)
-			 ? GFC_CAF_BYREF : 0;
-	  opr_flag_int |= opr_expr->ts.type == BT_CHARACTER
-			  && !opr_expr->symtree->n.sym->attr.is_bind_c
-			  ? GFC_CAF_HIDDENLEN : 0;
-	  opr_flag_int |= opr_expr->symtree->n.sym->formal->sym->attr.value
-			  ? GFC_CAF_ARG_VALUE : 0;
+	  tree opr, opr_flags;
+
+	  // FIXME: Handle TS29113's bind(C) strings with descriptor.
+	  int opr_flag_int;
+	  if (gfc_is_proc_ptr_comp (opr_expr))
+	    {
+	      gfc_symbol *sym = gfc_get_proc_ptr_comp (opr_expr)->ts.interface;
+	      opr_flag_int = sym->attr.dimension
+		|| (sym->ts.type == BT_CHARACTER
+		    && !sym->attr.is_bind_c)
+		? GFC_CAF_BYREF : 0;
+	      opr_flag_int |= opr_expr->ts.type == BT_CHARACTER
+		&& !sym->attr.is_bind_c
+		? GFC_CAF_HIDDENLEN : 0;
+	      opr_flag_int |= sym->formal->sym->attr.value
+		? GFC_CAF_ARG_VALUE : 0;
+	    }
+	  else
+	    {
+	      opr_flag_int = gfc_return_by_reference (opr_expr->symtree->n.sym)
+		? GFC_CAF_BYREF : 0;
+	      opr_flag_int |= opr_expr->ts.type == BT_CHARACTER
+		&& !opr_expr->symtree->n.sym->attr.is_bind_c
+		? GFC_CAF_HIDDENLEN : 0;
+	      opr_flag_int |= opr_expr->symtree->n.sym->formal->sym->attr.value
+		? GFC_CAF_ARG_VALUE : 0;
+	    }
+	  opr_flags = build_int_cst (integer_type_node, opr_flag_int);
+	  gfc_conv_expr (&argse, opr_expr);
+	  opr = argse.expr;
+	  fndecl = build_call_expr_loc (input_location, fndecl, 8, array, opr,
+					opr_flags, image_index, stat, errmsg,
+					strlen, errmsg_len);
 	}
-      opr_flags = build_int_cst (integer_type_node, opr_flag_int);
-      gfc_conv_expr (&argse, opr_expr);
-      opr = argse.expr;
-      fndecl = build_call_expr_loc (input_location, fndecl, 8, array, opr, opr_flags,
-				    image_index, stat, errmsg, strlen, errmsg_len);
     }
 
   gfc_add_expr_to_block (&block, fndecl);

gcc/fortran/trans.h

@@ -107,6 +107,14 @@ typedef struct gfc_se
 }
 gfc_se;
 
+typedef struct gfc_co_subroutines_args
+{
+  tree image_index;
+  tree stat;
+  tree errmsg;
+  tree errmsg_len;
+}
+gfc_co_subroutines_args;
 
 /* Denotes different types of coarray.
    Please keep in sync with libgfortran/caf/libcaf.h.  */