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);
}
tree
gfc_omp_clause_assign_op (tree clause ATTRIBUTE_UNUSED, tree dest, tree src)
{
tree type = TREE_TYPE (dest), rank, size, esize, 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);
/* Handle copying allocatable arrays. */
gfc_start_block (&block);
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);
call = build_call_expr_loc (input_location,
built_in_decls[BUILT_IN_MEMCPY], 3,
fold_convert (pvoid_type_node,
gfc_conv_descriptor_data_get (dest)),
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);
}
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);
}
/* User-deallocate; we emit the code directly from the front-end, and the
logic is the same as the previous library function:
void
deallocate (void *pointer, GFC_INTEGER_4 * stat)
{
if (!pointer)
{
if (stat)
*stat = 1;
else
runtime_error ("Attempt to DEALLOCATE unallocated memory.");
}
else
{
free (pointer);
if (stat)
*stat = 0;
}
}
In this front-end version, status doesn't have to be GFC_INTEGER_4.
Moreover, if CAN_FAIL is true, then we will not emit a runtime error,
even when no status variable is passed to us (this is used for
unconditional deallocation generated by the front-end at end of
each procedure).
If a runtime-message is possible, `expr' must point to the original
expression being deallocated for its locus and variable name.
For coarrays, "pointer" must be the array descriptor and not its
"data" component. */
tree
gfc_deallocate_with_status (tree pointer, tree status, tree errmsg,
tree errlen, tree label_finish,
bool can_fail, gfc_expr* expr, bool coarray)
{
stmtblock_t null, non_null;
tree cond, tmp, error;
tree status_type = NULL_TREE;
tree caf_decl = NULL_TREE;
if (coarray)
{
gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (pointer)));
caf_decl = pointer;
pointer = gfc_conv_descriptor_data_get (caf_decl);
STRIP_NOPS (pointer);
}
cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, pointer,
build_int_cst (TREE_TYPE (pointer), 0));
/* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise
we emit a runtime error. */
gfc_start_block (&null);
if (!can_fail)
{
tree varname;
gcc_assert (expr && expr->expr_type == EXPR_VARIABLE && expr->symtree);
varname = gfc_build_cstring_const (expr->symtree->name);
varname = gfc_build_addr_expr (pchar_type_node, varname);
error = gfc_trans_runtime_error (true, &expr->where,
"Attempt to DEALLOCATE unallocated '%s'",
varname);
}
else
error = build_empty_stmt (input_location);
if (status != NULL_TREE && !integer_zerop (status))
{
tree cond2;
status_type = TREE_TYPE (TREE_TYPE (status));
cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
status, build_int_cst (TREE_TYPE (status), 0));
tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
fold_build1_loc (input_location, INDIRECT_REF,
status_type, status),
build_int_cst (status_type, 1));
error = fold_build3_loc (input_location, COND_EXPR, void_type_node,
cond2, tmp, error);
}
gfc_add_expr_to_block (&null, error);
/* When POINTER is not NULL, we free it. */
gfc_start_block (&non_null);
if (!coarray || gfc_option.coarray != GFC_FCOARRAY_LIB)
{
tmp = build_call_expr_loc (input_location,
builtin_decl_explicit (BUILT_IN_FREE), 1,
fold_convert (pvoid_type_node, pointer));
gfc_add_expr_to_block (&non_null, tmp);
if (status != NULL_TREE && !integer_zerop (status))
{
/* We set STATUS to zero if it is present. */
tree status_type = TREE_TYPE (TREE_TYPE (status));
tree cond2;
cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
status,
build_int_cst (TREE_TYPE (status), 0));
tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
fold_build1_loc (input_location, INDIRECT_REF,
status_type, status),
build_int_cst (status_type, 0));
tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
gfc_unlikely (cond2), tmp,
build_empty_stmt (input_location));
gfc_add_expr_to_block (&non_null, tmp);
}
}
else
{
tree caf_type, token, cond2;
tree pstat = null_pointer_node;
if (errmsg == NULL_TREE)
{
gcc_assert (errlen == NULL_TREE);
errmsg = null_pointer_node;
errlen = build_zero_cst (integer_type_node);
}
else
{
gcc_assert (errlen != NULL_TREE);
if (!POINTER_TYPE_P (TREE_TYPE (errmsg)))
errmsg = gfc_build_addr_expr (NULL_TREE, errmsg);
}
caf_type = TREE_TYPE (caf_decl);
if (status != NULL_TREE && !integer_zerop (status))
{
gcc_assert (status_type == integer_type_node);
pstat = status;
}
if (GFC_DESCRIPTOR_TYPE_P (caf_type)
&& GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE)
token = gfc_conv_descriptor_token (caf_decl);
else if (DECL_LANG_SPECIFIC (caf_decl)
&& GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
token = GFC_DECL_TOKEN (caf_decl);
else
{
gcc_assert (GFC_ARRAY_TYPE_P (caf_type)
&& GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) != NULL_TREE);
token = GFC_TYPE_ARRAY_CAF_TOKEN (caf_type);
}
token = gfc_build_addr_expr (NULL_TREE, token);
tmp = build_call_expr_loc (input_location,
gfor_fndecl_caf_deregister, 4,
token, pstat, errmsg, errlen);
gfc_add_expr_to_block (&non_null, tmp);
if (status != NULL_TREE)
{
tree stat = build_fold_indirect_ref_loc (input_location, status);
TREE_USED (label_finish) = 1;
tmp = build1_v (GOTO_EXPR, label_finish);
cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
stat, build_zero_cst (TREE_TYPE (stat)));
tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
gfc_unlikely (cond2), tmp,
build_empty_stmt (input_location));
gfc_add_expr_to_block (&non_null, tmp);
}
}
return fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
gfc_finish_block (&null),
gfc_finish_block (&non_null));
}
