Ejemplo n.º 1
0
tree
gfc_omp_clause_default_ctor (tree clause, tree decl, tree outer)
{
  tree type = TREE_TYPE (decl), rank, size, esize, ptr, cond, then_b, else_b;
  stmtblock_t block, cond_block;

  if (! GFC_DESCRIPTOR_TYPE_P (type)
      || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
    return NULL;

  gcc_assert (outer != NULL);
  gcc_assert (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_PRIVATE
	      || OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_LASTPRIVATE);

  /* Allocatable arrays in PRIVATE clauses need to be set to
     "not currently allocated" allocation status if outer
     array is "not currently allocated", otherwise should be allocated.  */
  gfc_start_block (&block);

  gfc_init_block (&cond_block);

  gfc_add_modify (&cond_block, decl, outer);
  rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1];
  size = gfc_conv_descriptor_ubound_get (decl, rank);
  size = fold_build2 (MINUS_EXPR, gfc_array_index_type, size,
		      gfc_conv_descriptor_lbound_get (decl, rank));
  size = fold_build2 (PLUS_EXPR, gfc_array_index_type, size,
		      gfc_index_one_node);
  if (GFC_TYPE_ARRAY_RANK (type) > 1)
    size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
			gfc_conv_descriptor_stride_get (decl, rank));
  esize = fold_convert (gfc_array_index_type,
			TYPE_SIZE_UNIT (gfc_get_element_type (type)));
  size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, esize);
  size = gfc_evaluate_now (fold_convert (size_type_node, size), &cond_block);
  ptr = gfc_allocate_array_with_status (&cond_block,
					build_int_cst (pvoid_type_node, 0),
					size, NULL, NULL);
  gfc_conv_descriptor_data_set (&cond_block, decl, ptr);
  then_b = gfc_finish_block (&cond_block);

  gfc_init_block (&cond_block);
  gfc_conv_descriptor_data_set (&cond_block, decl, null_pointer_node);
  else_b = gfc_finish_block (&cond_block);

  cond = fold_build2 (NE_EXPR, boolean_type_node,
		      fold_convert (pvoid_type_node,
				    gfc_conv_descriptor_data_get (outer)),
		      null_pointer_node);
  gfc_add_expr_to_block (&block, build3 (COND_EXPR, void_type_node,
			 cond, then_b, else_b));

  return gfc_finish_block (&block);
}
Ejemplo n.º 2
0
tree
gfc_omp_clause_default_ctor (tree clause ATTRIBUTE_UNUSED, tree decl)
{
  tree type = TREE_TYPE (decl);
  stmtblock_t block;

  if (! GFC_DESCRIPTOR_TYPE_P (type))
    return NULL;

  /* Allocatable arrays in PRIVATE clauses need to be set to
     "not currently allocated" allocation status.  */
  gfc_init_block (&block);

  gfc_conv_descriptor_data_set (&block, decl, null_pointer_node);

  return gfc_finish_block (&block);
}
Ejemplo n.º 3
0
tree
gfc_omp_clause_copy_ctor (tree clause, tree dest, tree src)
{
  tree type = TREE_TYPE (dest), ptr, size, esize, rank, call;
  stmtblock_t block;

  if (! GFC_DESCRIPTOR_TYPE_P (type)
      || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
    return build2_v (MODIFY_EXPR, dest, src);

  gcc_assert (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_FIRSTPRIVATE);

  /* Allocatable arrays in FIRSTPRIVATE clauses need to be allocated
     and copied from SRC.  */
  gfc_start_block (&block);

  gfc_add_modify (&block, dest, src);
  rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1];
  size = gfc_conv_descriptor_ubound_get (dest, rank);
  size = fold_build2 (MINUS_EXPR, gfc_array_index_type, size,
		      gfc_conv_descriptor_lbound_get (dest, rank));
  size = fold_build2 (PLUS_EXPR, gfc_array_index_type, size,
		      gfc_index_one_node);
  if (GFC_TYPE_ARRAY_RANK (type) > 1)
    size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
			gfc_conv_descriptor_stride_get (dest, rank));
  esize = fold_convert (gfc_array_index_type,
			TYPE_SIZE_UNIT (gfc_get_element_type (type)));
  size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, esize);
  size = gfc_evaluate_now (fold_convert (size_type_node, size), &block);
  ptr = gfc_allocate_array_with_status (&block,
					build_int_cst (pvoid_type_node, 0),
					size, NULL, NULL);
  gfc_conv_descriptor_data_set (&block, dest, ptr);
  call = build_call_expr_loc (input_location,
			  built_in_decls[BUILT_IN_MEMCPY], 3, ptr,
			  fold_convert (pvoid_type_node,
					gfc_conv_descriptor_data_get (src)),
			  size);
  gfc_add_expr_to_block (&block, fold_convert (void_type_node, call));

  return gfc_finish_block (&block);
}
Ejemplo n.º 4
0
static void
gfc_trans_omp_array_reduction (tree c, gfc_symbol *sym, locus where)
{
  gfc_symtree *root1 = NULL, *root2 = NULL, *root3 = NULL, *root4 = NULL;
  gfc_symtree *symtree1, *symtree2, *symtree3, *symtree4 = NULL;
  gfc_symbol init_val_sym, outer_sym, intrinsic_sym;
  gfc_expr *e1, *e2, *e3, *e4;
  gfc_ref *ref;
  tree decl, backend_decl, stmt;
  locus old_loc = gfc_current_locus;
  const char *iname;
  gfc_try t;

  decl = OMP_CLAUSE_DECL (c);
  gfc_current_locus = where;

  /* Create a fake symbol for init value.  */
  memset (&init_val_sym, 0, sizeof (init_val_sym));
  init_val_sym.ns = sym->ns;
  init_val_sym.name = sym->name;
  init_val_sym.ts = sym->ts;
  init_val_sym.attr.referenced = 1;
  init_val_sym.declared_at = where;
  init_val_sym.attr.flavor = FL_VARIABLE;
  backend_decl = omp_reduction_init (c, gfc_sym_type (&init_val_sym));
  init_val_sym.backend_decl = backend_decl;

  /* Create a fake symbol for the outer array reference.  */
  outer_sym = *sym;
  outer_sym.as = gfc_copy_array_spec (sym->as);
  outer_sym.attr.dummy = 0;
  outer_sym.attr.result = 0;
  outer_sym.attr.flavor = FL_VARIABLE;
  outer_sym.backend_decl = create_tmp_var_raw (TREE_TYPE (decl), NULL);

  /* Create fake symtrees for it.  */
  symtree1 = gfc_new_symtree (&root1, sym->name);
  symtree1->n.sym = sym;
  gcc_assert (symtree1 == root1);

  symtree2 = gfc_new_symtree (&root2, sym->name);
  symtree2->n.sym = &init_val_sym;
  gcc_assert (symtree2 == root2);

  symtree3 = gfc_new_symtree (&root3, sym->name);
  symtree3->n.sym = &outer_sym;
  gcc_assert (symtree3 == root3);

  /* Create expressions.  */
  e1 = gfc_get_expr ();
  e1->expr_type = EXPR_VARIABLE;
  e1->where = where;
  e1->symtree = symtree1;
  e1->ts = sym->ts;
  e1->ref = ref = gfc_get_ref ();
  ref->type = REF_ARRAY;
  ref->u.ar.where = where;
  ref->u.ar.as = sym->as;
  ref->u.ar.type = AR_FULL;
  ref->u.ar.dimen = 0;
  t = gfc_resolve_expr (e1);
  gcc_assert (t == SUCCESS);

  e2 = gfc_get_expr ();
  e2->expr_type = EXPR_VARIABLE;
  e2->where = where;
  e2->symtree = symtree2;
  e2->ts = sym->ts;
  t = gfc_resolve_expr (e2);
  gcc_assert (t == SUCCESS);

  e3 = gfc_copy_expr (e1);
  e3->symtree = symtree3;
  t = gfc_resolve_expr (e3);
  gcc_assert (t == SUCCESS);

  iname = NULL;
  switch (OMP_CLAUSE_REDUCTION_CODE (c))
    {
    case PLUS_EXPR:
    case MINUS_EXPR:
      e4 = gfc_add (e3, e1);
      break;
    case MULT_EXPR:
      e4 = gfc_multiply (e3, e1);
      break;
    case TRUTH_ANDIF_EXPR:
      e4 = gfc_and (e3, e1);
      break;
    case TRUTH_ORIF_EXPR:
      e4 = gfc_or (e3, e1);
      break;
    case EQ_EXPR:
      e4 = gfc_eqv (e3, e1);
      break;
    case NE_EXPR:
      e4 = gfc_neqv (e3, e1);
      break;
    case MIN_EXPR:
      iname = "min";
      break;
    case MAX_EXPR:
      iname = "max";
      break;
    case BIT_AND_EXPR:
      iname = "iand";
      break;
    case BIT_IOR_EXPR:
      iname = "ior";
      break;
    case BIT_XOR_EXPR:
      iname = "ieor";
      break;
    default:
      gcc_unreachable ();
    }
  if (iname != NULL)
    {
      memset (&intrinsic_sym, 0, sizeof (intrinsic_sym));
      intrinsic_sym.ns = sym->ns;
      intrinsic_sym.name = iname;
      intrinsic_sym.ts = sym->ts;
      intrinsic_sym.attr.referenced = 1;
      intrinsic_sym.attr.intrinsic = 1;
      intrinsic_sym.attr.function = 1;
      intrinsic_sym.result = &intrinsic_sym;
      intrinsic_sym.declared_at = where;

      symtree4 = gfc_new_symtree (&root4, iname);
      symtree4->n.sym = &intrinsic_sym;
      gcc_assert (symtree4 == root4);

      e4 = gfc_get_expr ();
      e4->expr_type = EXPR_FUNCTION;
      e4->where = where;
      e4->symtree = symtree4;
      e4->value.function.isym = gfc_find_function (iname);
      e4->value.function.actual = gfc_get_actual_arglist ();
      e4->value.function.actual->expr = e3;
      e4->value.function.actual->next = gfc_get_actual_arglist ();
      e4->value.function.actual->next->expr = e1;
    }
  /* e1 and e3 have been stored as arguments of e4, avoid sharing.  */
  e1 = gfc_copy_expr (e1);
  e3 = gfc_copy_expr (e3);
  t = gfc_resolve_expr (e4);
  gcc_assert (t == SUCCESS);

  /* Create the init statement list.  */
  pushlevel (0);
  if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
      && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (decl)) == GFC_ARRAY_ALLOCATABLE)
    {
      /* If decl is an allocatable array, it needs to be allocated
	 with the same bounds as the outer var.  */
      tree type = TREE_TYPE (decl), rank, size, esize, ptr;
      stmtblock_t block;

      gfc_start_block (&block);

      gfc_add_modify (&block, decl, outer_sym.backend_decl);
      rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1];
      size = gfc_conv_descriptor_ubound_get (decl, rank);
      size = fold_build2 (MINUS_EXPR, gfc_array_index_type, size,
			  gfc_conv_descriptor_lbound_get (decl, rank));
      size = fold_build2 (PLUS_EXPR, gfc_array_index_type, size,
			  gfc_index_one_node);
      if (GFC_TYPE_ARRAY_RANK (type) > 1)
	size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
			    gfc_conv_descriptor_stride_get (decl, rank));
      esize = fold_convert (gfc_array_index_type,
			    TYPE_SIZE_UNIT (gfc_get_element_type (type)));
      size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, esize);
      size = gfc_evaluate_now (fold_convert (size_type_node, size), &block);
      ptr = gfc_allocate_array_with_status (&block,
					    build_int_cst (pvoid_type_node, 0),
					    size, NULL, NULL);
      gfc_conv_descriptor_data_set (&block, decl, ptr);
      gfc_add_expr_to_block (&block, gfc_trans_assignment (e1, e2, false));
      stmt = gfc_finish_block (&block);
    }
  else
    stmt = gfc_trans_assignment (e1, e2, false);
  if (TREE_CODE (stmt) != BIND_EXPR)
    stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0));
  else
    poplevel (0, 0, 0);
  OMP_CLAUSE_REDUCTION_INIT (c) = stmt;

  /* Create the merge statement list.  */
  pushlevel (0);
  if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
      && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (decl)) == GFC_ARRAY_ALLOCATABLE)
    {
      /* If decl is an allocatable array, it needs to be deallocated
	 afterwards.  */
      stmtblock_t block;

      gfc_start_block (&block);
      gfc_add_expr_to_block (&block, gfc_trans_assignment (e3, e4, false));
      gfc_add_expr_to_block (&block, gfc_trans_dealloc_allocated (decl));
      stmt = gfc_finish_block (&block);
    }
  else
    stmt = gfc_trans_assignment (e3, e4, false);
  if (TREE_CODE (stmt) != BIND_EXPR)
    stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0));
  else
    poplevel (0, 0, 0);
  OMP_CLAUSE_REDUCTION_MERGE (c) = stmt;

  /* And stick the placeholder VAR_DECL into the clause as well.  */
  OMP_CLAUSE_REDUCTION_PLACEHOLDER (c) = outer_sym.backend_decl;

  gfc_current_locus = old_loc;

  gfc_free_expr (e1);
  gfc_free_expr (e2);
  gfc_free_expr (e3);
  gfc_free_expr (e4);
  gfc_free (symtree1);
  gfc_free (symtree2);
  gfc_free (symtree3);
  if (symtree4)
    gfc_free (symtree4);
  gfc_free_array_spec (outer_sym.as);
}