return fold_convert (TYPE_MAIN_VARIANT (type), base);
}
- gcc_assert (TREE_CODE (type) == ARRAY_TYPE);
+ /* Scalar coarray, there is nothing to do. */
+ if (TREE_CODE (type) != ARRAY_TYPE)
+ {
+ gcc_assert (decl == NULL_TREE);
+ gcc_assert (integer_zerop (offset));
+ return base;
+ }
+
type = TREE_TYPE (type);
if (DECL_P (base))
gfc_array_index_type,
offset, GFC_DECL_SPAN(decl));
tmp = gfc_build_addr_expr (pvoid_type_node, base);
- tmp = fold_build2_loc (input_location, POINTER_PLUS_EXPR,
- pvoid_type_node, tmp,
- fold_convert (sizetype, offset));
+ tmp = fold_build_pointer_plus_loc (input_location, tmp, offset);
tmp = fold_convert (build_pointer_type (type), tmp);
if (!TYPE_STRING_FLAG (type))
tmp = build_fold_indirect_ref_loc (input_location, tmp);
tree
gfc_call_malloc (stmtblock_t * block, tree type, tree size)
{
- tree tmp, msg, malloc_result, null_result, res;
+ tree tmp, msg, malloc_result, null_result, res, malloc_tree;
stmtblock_t block2;
size = gfc_evaluate_now (size, block);
size = fold_build2_loc (input_location, MAX_EXPR, size_type_node, size,
build_int_cst (size_type_node, 1));
+ malloc_tree = builtin_decl_explicit (BUILT_IN_MALLOC);
gfc_add_modify (&block2, res,
fold_convert (prvoid_type_node,
build_call_expr_loc (input_location,
- built_in_decls[BUILT_IN_MALLOC], 1, size)));
+ malloc_tree, 1, size)));
/* Optionally check whether malloc was successful. */
if (gfc_option.rtcheck & GFC_RTCHECK_MEM)
This function follows the following pseudo-code:
void *
- allocate (size_t size, integer_type* stat)
+ allocate (size_t size, integer_type stat)
{
void *newmem;
- if (stat)
- *stat = 0;
+ if (stat requested)
+ stat = 0;
newmem = malloc (MAX (size, 1));
if (newmem == NULL)
}
return newmem;
} */
-tree
-gfc_allocate_with_status (stmtblock_t * block, tree size, tree status)
+void
+gfc_allocate_using_malloc (stmtblock_t * block, tree pointer,
+ tree size, tree status)
{
- stmtblock_t alloc_block;
- tree res, tmp, msg, cond;
- tree status_type = status ? TREE_TYPE (TREE_TYPE (status)) : NULL_TREE;
+ tree tmp, on_error, error_cond;
+ tree status_type = status ? TREE_TYPE (status) : NULL_TREE;
/* Evaluate size only once, and make sure it has the right type. */
size = gfc_evaluate_now (size, block);
if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
size = fold_convert (size_type_node, size);
- /* Create a variable to hold the result. */
- res = gfc_create_var (prvoid_type_node, NULL);
+ /* If successful and stat= is given, set status to 0. */
+ if (status != NULL_TREE)
+ gfc_add_expr_to_block (block,
+ fold_build2_loc (input_location, MODIFY_EXPR, status_type,
+ status, build_int_cst (status_type, 0)));
- /* Set the optional status variable to zero. */
- if (status != NULL_TREE && !integer_zerop (status))
+ /* The allocation itself. */
+ gfc_add_modify (block, pointer,
+ fold_convert (TREE_TYPE (pointer),
+ build_call_expr_loc (input_location,
+ builtin_decl_explicit (BUILT_IN_MALLOC), 1,
+ fold_build2_loc (input_location,
+ MAX_EXPR, size_type_node, size,
+ build_int_cst (size_type_node, 1)))));
+
+ /* What to do in case of error. */
+ if (status != NULL_TREE)
+ on_error = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
+ status, build_int_cst (status_type, LIBERROR_ALLOCATION));
+ else
+ on_error = build_call_expr_loc (input_location, gfor_fndecl_os_error, 1,
+ gfc_build_addr_expr (pchar_type_node,
+ gfc_build_localized_cstring_const
+ ("Allocation would exceed memory limit")));
+
+ error_cond = fold_build2_loc (input_location, EQ_EXPR,
+ boolean_type_node, pointer,
+ build_int_cst (prvoid_type_node, 0));
+ tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+ gfc_unlikely(error_cond), on_error,
+ build_empty_stmt (input_location));
+
+ gfc_add_expr_to_block (block, tmp);
+}
+
+
+/* Allocate memory, using an optional status argument.
+
+ This function follows the following pseudo-code:
+
+ void *
+ allocate (size_t size, void** token, int *stat, char* errmsg, int errlen)
{
- 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,
- fold_build2_loc (input_location, NE_EXPR,
- boolean_type_node, status,
- build_int_cst (TREE_TYPE (status), 0)),
- tmp, build_empty_stmt (input_location));
- gfc_add_expr_to_block (block, tmp);
- }
+ void *newmem;
- /* The allocation itself. */
- gfc_start_block (&alloc_block);
- gfc_add_modify (&alloc_block, res,
- fold_convert (prvoid_type_node,
- build_call_expr_loc (input_location,
- built_in_decls[BUILT_IN_MALLOC], 1,
- fold_build2_loc (input_location,
- MAX_EXPR, size_type_node, size,
- build_int_cst (size_type_node,
- 1)))));
+ newmem = _caf_register (size, regtype, token, &stat, errmsg, errlen);
+ return newmem;
+ } */
+static void
+gfc_allocate_using_lib (stmtblock_t * block, tree pointer, tree size,
+ tree token, tree status, tree errmsg, tree errlen)
+{
+ tree tmp, pstat;
- msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
- ("Allocation would exceed memory limit"));
- tmp = build_call_expr_loc (input_location,
- gfor_fndecl_os_error, 1, msg);
+ gcc_assert (token != NULL_TREE);
- if (status != NULL_TREE && !integer_zerop (status))
+ /* Evaluate size only once, and make sure it has the right type. */
+ size = gfc_evaluate_now (size, block);
+ if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
+ size = fold_convert (size_type_node, size);
+
+ /* The allocation itself. */
+ if (status == NULL_TREE)
+ pstat = null_pointer_node;
+ else
+ pstat = gfc_build_addr_expr (NULL_TREE, status);
+
+ if (errmsg == NULL_TREE)
{
- /* Set the status variable if it's present. */
- tree tmp2;
-
- cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
- status, build_int_cst (TREE_TYPE (status), 0));
- tmp2 = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
- fold_build1_loc (input_location, INDIRECT_REF,
- status_type, status),
- build_int_cst (status_type, LIBERROR_ALLOCATION));
- tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
- tmp, tmp2);
+ gcc_assert(errlen == NULL_TREE);
+ errmsg = null_pointer_node;
+ errlen = build_int_cst (integer_type_node, 0);
}
- tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
- fold_build2_loc (input_location, EQ_EXPR,
- boolean_type_node, res,
- build_int_cst (prvoid_type_node, 0)),
- tmp, build_empty_stmt (input_location));
- gfc_add_expr_to_block (&alloc_block, tmp);
- gfc_add_expr_to_block (block, gfc_finish_block (&alloc_block));
-
- return res;
+ tmp = build_call_expr_loc (input_location,
+ gfor_fndecl_caf_register, 6,
+ fold_build2_loc (input_location,
+ MAX_EXPR, size_type_node, size,
+ build_int_cst (size_type_node, 1)),
+ build_int_cst (integer_type_node,
+ GFC_CAF_COARRAY_ALLOC),
+ token, pstat, errmsg, errlen);
+
+ tmp = fold_build2_loc (input_location, MODIFY_EXPR,
+ TREE_TYPE (pointer), pointer,
+ fold_convert ( TREE_TYPE (pointer), tmp));
+ gfc_add_expr_to_block (block, tmp);
}
/* Generate code for an ALLOCATE statement when the argument is an
- allocatable array. If the array is currently allocated, it is an
+ allocatable variable. If the variable is currently allocated, it is an
error to allocate it again.
This function follows the following pseudo-code:
void *
- allocate_array (void *mem, size_t size, integer_type *stat)
+ allocate_allocatable (void *mem, size_t size, integer_type stat)
{
if (mem == NULL)
return allocate (size, stat);
else
{
if (stat)
- {
- free (mem);
- mem = allocate (size, stat);
- *stat = LIBERROR_ALLOCATION;
- return mem;
- }
+ stat = LIBERROR_ALLOCATION;
else
runtime_error ("Attempting to allocate already allocated variable");
}
expr must be set to the original expression being allocated for its locus
and variable name in case a runtime error has to be printed. */
-tree
-gfc_allocate_array_with_status (stmtblock_t * block, tree mem, tree size,
- tree status, gfc_expr* expr)
+void
+gfc_allocate_allocatable (stmtblock_t * block, tree mem, tree size, tree token,
+ tree status, tree errmsg, tree errlen, gfc_expr* expr)
{
stmtblock_t alloc_block;
- tree res, tmp, null_mem, alloc, error;
+ tree tmp, null_mem, alloc, error;
tree type = TREE_TYPE (mem);
if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
size = fold_convert (size_type_node, size);
- /* Create a variable to hold the result. */
- res = gfc_create_var (type, NULL);
- null_mem = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, mem,
- build_int_cst (type, 0));
+ null_mem = gfc_unlikely (fold_build2_loc (input_location, NE_EXPR,
+ boolean_type_node, mem,
+ build_int_cst (type, 0)));
- /* If mem is NULL, we call gfc_allocate_with_status. */
+ /* If mem is NULL, we call gfc_allocate_using_malloc or
+ gfc_allocate_using_lib. */
gfc_start_block (&alloc_block);
- tmp = gfc_allocate_with_status (&alloc_block, size, status);
- gfc_add_modify (&alloc_block, res, fold_convert (type, tmp));
+
+ if (gfc_option.coarray == GFC_FCOARRAY_LIB
+ && gfc_expr_attr (expr).codimension)
+ gfc_allocate_using_lib (&alloc_block, mem, size, token, status,
+ errmsg, errlen);
+ else
+ gfc_allocate_using_malloc (&alloc_block, mem, size, status);
+
alloc = gfc_finish_block (&alloc_block);
- /* Otherwise, we issue a runtime error or set the status variable. */
+ /* If mem is not NULL, we issue a runtime error or set the
+ status variable. */
if (expr)
{
tree varname;
"Attempting to allocate already allocated"
" variable");
- if (status != NULL_TREE && !integer_zerop (status))
+ if (status != NULL_TREE)
{
- tree status_type = TREE_TYPE (TREE_TYPE (status));
- stmtblock_t set_status_block;
-
- gfc_start_block (&set_status_block);
- tmp = build_call_expr_loc (input_location,
- built_in_decls[BUILT_IN_FREE], 1,
- fold_convert (pvoid_type_node, mem));
- gfc_add_expr_to_block (&set_status_block, tmp);
-
- tmp = gfc_allocate_with_status (&set_status_block, size, status);
- gfc_add_modify (&set_status_block, res, fold_convert (type, tmp));
-
- gfc_add_modify (&set_status_block,
- fold_build1_loc (input_location, INDIRECT_REF,
- status_type, status),
- build_int_cst (status_type, LIBERROR_ALLOCATION));
-
- tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
- status, build_int_cst (status_type, 0));
- error = fold_build3_loc (input_location, COND_EXPR, void_type_node, tmp,
- error, gfc_finish_block (&set_status_block));
+ tree status_type = TREE_TYPE (status);
+
+ error = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
+ status, build_int_cst (status_type, LIBERROR_ALLOCATION));
}
tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, null_mem,
- alloc, error);
+ error, alloc);
gfc_add_expr_to_block (block, tmp);
-
- return res;
}
cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, var,
build_int_cst (pvoid_type_node, 0));
call = build_call_expr_loc (input_location,
- built_in_decls[BUILT_IN_FREE], 1, var);
+ builtin_decl_explicit (BUILT_IN_FREE),
+ 1, var);
tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, call,
build_empty_stmt (input_location));
gfc_add_expr_to_block (&block, tmp);
/* When POINTER is not NULL, we free it. */
gfc_start_block (&non_null);
tmp = build_call_expr_loc (input_location,
- built_in_decls[BUILT_IN_FREE], 1,
- fold_convert (pvoid_type_node, pointer));
+ 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))
}
tmp = build_call_expr_loc (input_location,
- built_in_decls[BUILT_IN_FREE], 1,
- fold_convert (pvoid_type_node, pointer));
+ 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))
/* Call realloc and check the result. */
tmp = build_call_expr_loc (input_location,
- built_in_decls[BUILT_IN_REALLOC], 2,
+ builtin_decl_explicit (BUILT_IN_REALLOC), 2,
fold_convert (pvoid_type_node, mem), size);
gfc_add_modify (block, res, fold_convert (type, tmp));
null_result = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
{
case EXEC_NOP:
case EXEC_END_BLOCK:
+ case EXEC_END_NESTED_BLOCK:
case EXEC_END_PROCEDURE:
res = NULL_TREE;
break;
res = gfc_trans_do (code, cond);
break;
+ case EXEC_DO_CONCURRENT:
+ res = gfc_trans_do_concurrent (code);
+ break;
+
case EXEC_DO_WHILE:
res = gfc_trans_do_while (code);
break;
res = gfc_trans_sync (code, code->op);
break;
+ case EXEC_LOCK:
+ case EXEC_UNLOCK:
+ res = gfc_trans_lock_unlock (code, code->op);
+ break;
+
case EXEC_FORALL:
res = gfc_trans_forall (code);
break;
case EXEC_OMP_SINGLE:
case EXEC_OMP_TASK:
case EXEC_OMP_TASKWAIT:
+ case EXEC_OMP_TASKYIELD:
case EXEC_OMP_WORKSHARE:
res = gfc_trans_omp_directive (code);
break;
cond = fold_convert (long_integer_type_node, cond);
tmp = build_zero_cst (long_integer_type_node);
cond = build_call_expr_loc (input_location,
- built_in_decls[BUILT_IN_EXPECT], 2, cond, tmp);
+ builtin_decl_explicit (BUILT_IN_EXPECT),
+ 2, cond, tmp);
+ cond = fold_convert (boolean_type_node, cond);
+ return cond;
+}
+
+
+/* Helper function for marking a boolean expression tree as likely. */
+
+tree
+gfc_likely (tree cond)
+{
+ tree tmp;
+
+ cond = fold_convert (long_integer_type_node, cond);
+ tmp = build_one_cst (long_integer_type_node);
+ cond = build_call_expr_loc (input_location,
+ builtin_decl_explicit (BUILT_IN_EXPECT),
+ 2, cond, tmp);
cond = fold_convert (boolean_type_node, cond);
return cond;
}
OSDN Git Service
