tree
ubsan_instrument_vla (location_t loc, tree size)
{
tree type = TREE_TYPE (size);
tree t, tt;
t = fold_build2 (LE_EXPR, boolean_type_node, size, build_int_cst (type, 0));
if (flag_sanitize_undefined_trap_on_error)
tt = build_call_expr_loc (loc, builtin_decl_explicit (BUILT_IN_TRAP), 0);
else
{
tree data = ubsan_create_data ("__ubsan_vla_data", 1, &loc,
ubsan_type_descriptor (type), NULL_TREE,
NULL_TREE);
data = build_fold_addr_expr_loc (loc, data);
enum built_in_function bcode
= (flag_sanitize_recover & SANITIZE_VLA)
? BUILT_IN_UBSAN_HANDLE_VLA_BOUND_NOT_POSITIVE
: BUILT_IN_UBSAN_HANDLE_VLA_BOUND_NOT_POSITIVE_ABORT;
tt = builtin_decl_explicit (bcode);
tt = build_call_expr_loc (loc, tt, 2, data, ubsan_encode_value (size));
}
t = fold_build3 (COND_EXPR, void_type_node, t, tt, void_node);
return t;
}
tree
ubsan_instrument_division (location_t loc, tree op0, tree op1)
{
tree t, tt;
tree type = TREE_TYPE (op0);
/* At this point both operands should have the same type,
because they are already converted to RESULT_TYPE.
Use TYPE_MAIN_VARIANT since typedefs can confuse us. */
gcc_assert (TYPE_MAIN_VARIANT (TREE_TYPE (op0))
== TYPE_MAIN_VARIANT (TREE_TYPE (op1)));
/* TODO: REAL_TYPE is not supported yet. */
if (TREE_CODE (type) != INTEGER_TYPE)
return NULL_TREE;
t = fold_build2 (EQ_EXPR, boolean_type_node,
op1, build_int_cst (type, 0));
/* We check INT_MIN / -1 only for signed types. */
if (!TYPE_UNSIGNED (type))
{
tree x;
tt = fold_build2 (EQ_EXPR, boolean_type_node, op1,
build_int_cst (type, -1));
x = fold_build2 (EQ_EXPR, boolean_type_node, op0,
TYPE_MIN_VALUE (type));
x = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, x, tt);
t = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, t, x);
}
/* If the condition was folded to 0, no need to instrument
this expression. */
if (integer_zerop (t))
return NULL_TREE;
/* In case we have a SAVE_EXPR in a conditional context, we need to
make sure it gets evaluated before the condition. */
t = fold_build2 (COMPOUND_EXPR, TREE_TYPE (t), op0, t);
if (flag_sanitize_undefined_trap_on_error)
tt = build_call_expr_loc (loc, builtin_decl_explicit (BUILT_IN_TRAP), 0);
else
{
tree data = ubsan_create_data ("__ubsan_overflow_data", &loc, NULL,
ubsan_type_descriptor (type, false),
NULL_TREE);
data = build_fold_addr_expr_loc (loc, data);
enum built_in_function bcode
= flag_sanitize_recover
? BUILT_IN_UBSAN_HANDLE_DIVREM_OVERFLOW
: BUILT_IN_UBSAN_HANDLE_DIVREM_OVERFLOW_ABORT;
tt = builtin_decl_explicit (bcode);
tt = build_call_expr_loc (loc, tt, 3, data, ubsan_encode_value (op0),
ubsan_encode_value (op1));
}
t = fold_build3 (COND_EXPR, void_type_node, t, tt, void_zero_node);
return t;
}
tree
ubsan_instrument_return (location_t loc)
{
if (flag_sanitize_undefined_trap_on_error)
return build_call_expr_loc (loc, builtin_decl_explicit (BUILT_IN_TRAP), 0);
tree data = ubsan_create_data ("__ubsan_missing_return_data", 1, &loc,
NULL_TREE, NULL_TREE);
tree t = builtin_decl_explicit (BUILT_IN_UBSAN_HANDLE_MISSING_RETURN);
return build_call_expr_loc (loc, t, 1, build_fold_addr_expr_loc (loc, data));
}
/* Reallocate MEM so it has SIZE bytes of data. This behaves like the
following pseudo-code:
void *
internal_realloc (void *mem, size_t size)
{
if (size < 0)
runtime_error ("Attempt to allocate a negative amount of memory.");
res = realloc (mem, size);
if (!res && size != 0)
_gfortran_os_error ("Out of memory");
if (size == 0)
return NULL;
return res;
} */
tree
gfc_call_realloc (stmtblock_t * block, tree mem, tree size)
{
tree msg, res, negative, nonzero, zero, null_result, tmp;
tree type = TREE_TYPE (mem);
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 (type, NULL);
/* size < 0 ? */
negative = fold_build2 (LT_EXPR, boolean_type_node, size,
build_int_cst (size_type_node, 0));
msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
("Attempt to allocate a negative amount of memory."));
tmp = fold_build3 (COND_EXPR, void_type_node, negative,
build_call_expr_loc (input_location,
gfor_fndecl_runtime_error, 1, msg),
build_empty_stmt (input_location));
gfc_add_expr_to_block (block, tmp);
/* Call realloc and check the result. */
tmp = build_call_expr_loc (input_location,
built_in_decls[BUILT_IN_REALLOC], 2,
fold_convert (pvoid_type_node, mem), size);
gfc_add_modify (block, res, fold_convert (type, tmp));
null_result = fold_build2 (EQ_EXPR, boolean_type_node, res,
build_int_cst (pvoid_type_node, 0));
nonzero = fold_build2 (NE_EXPR, boolean_type_node, size,
build_int_cst (size_type_node, 0));
null_result = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, null_result,
nonzero);
msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
("Out of memory"));
tmp = fold_build3 (COND_EXPR, void_type_node, null_result,
build_call_expr_loc (input_location,
gfor_fndecl_os_error, 1, msg),
build_empty_stmt (input_location));
gfc_add_expr_to_block (block, tmp);
/* if (size == 0) then the result is NULL. */
tmp = fold_build2 (MODIFY_EXPR, type, res, build_int_cst (type, 0));
zero = fold_build1 (TRUTH_NOT_EXPR, boolean_type_node, nonzero);
tmp = fold_build3 (COND_EXPR, void_type_node, zero, tmp,
build_empty_stmt (input_location));
gfc_add_expr_to_block (block, tmp);
return res;
}
tree
ubsan_instrument_unreachable (location_t loc)
{
if (flag_sanitize_undefined_trap_on_error)
return build_call_expr_loc (loc, builtin_decl_explicit (BUILT_IN_TRAP), 0);
initialize_sanitizer_builtins ();
tree data = ubsan_create_data ("__ubsan_unreachable_data", &loc, NULL,
NULL_TREE);
tree t = builtin_decl_explicit (BUILT_IN_UBSAN_HANDLE_BUILTIN_UNREACHABLE);
return build_call_expr_loc (loc, t, 1, build_fold_addr_expr_loc (loc, data));
}
/* Call malloc to allocate size bytes of memory, with special conditions:
+ if size == 0, return a malloced area of size 1,
+ if malloc returns NULL, issue a runtime error. */
tree
gfc_call_malloc (stmtblock_t * block, tree type, tree size)
{
tree tmp, msg, malloc_result, null_result, res, malloc_tree;
stmtblock_t block2;
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);
/* Call malloc. */
gfc_start_block (&block2);
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,
malloc_tree, 1, size)));
/* Optionally check whether malloc was successful. */
if (gfc_option.rtcheck & GFC_RTCHECK_MEM)
{
null_result = fold_build2_loc (input_location, EQ_EXPR,
boolean_type_node, res,
build_int_cst (pvoid_type_node, 0));
msg = gfc_build_addr_expr (pchar_type_node,
gfc_build_localized_cstring_const ("Memory allocation failed"));
tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
null_result,
build_call_expr_loc (input_location,
gfor_fndecl_os_error, 1, msg),
build_empty_stmt (input_location));
gfc_add_expr_to_block (&block2, tmp);
}
malloc_result = gfc_finish_block (&block2);
gfc_add_expr_to_block (block, malloc_result);
if (type != NULL)
res = fold_convert (type, res);
return res;
}
tree
ubsan_instrument_return (location_t loc)
{
if (flag_sanitize_undefined_trap_on_error)
return build_call_expr_loc (loc, builtin_decl_explicit (BUILT_IN_TRAP), 0);
/* It is possible that PCH zapped table with definitions of sanitizer
builtins. Reinitialize them if needed. */
initialize_sanitizer_builtins ();
tree data = ubsan_create_data ("__ubsan_missing_return_data", 1, &loc,
NULL_TREE, NULL_TREE);
tree t = builtin_decl_explicit (BUILT_IN_UBSAN_HANDLE_MISSING_RETURN);
return build_call_expr_loc (loc, t, 1, build_fold_addr_expr_loc (loc, data));
}
tree
ubsan_build_overflow_builtin (tree_code code, location_t loc, tree lhstype,
tree op0, tree op1)
{
tree data = ubsan_create_data ("__ubsan_overflow_data", loc, NULL,
ubsan_type_descriptor (lhstype, false),
NULL_TREE);
enum built_in_function fn_code;
switch (code)
{
case PLUS_EXPR:
fn_code = BUILT_IN_UBSAN_HANDLE_ADD_OVERFLOW;
break;
case MINUS_EXPR:
fn_code = BUILT_IN_UBSAN_HANDLE_SUB_OVERFLOW;
break;
case MULT_EXPR:
fn_code = BUILT_IN_UBSAN_HANDLE_MUL_OVERFLOW;
break;
case NEGATE_EXPR:
fn_code = BUILT_IN_UBSAN_HANDLE_NEGATE_OVERFLOW;
break;
default:
gcc_unreachable ();
}
tree fn = builtin_decl_explicit (fn_code);
return build_call_expr_loc (loc, fn, 2 + (code != NEGATE_EXPR),
build_fold_addr_expr_loc (loc, data),
ubsan_encode_value (op0, true),
op1 ? ubsan_encode_value (op1, true)
: NULL_TREE);
}
tree
ubsan_instrument_unreachable (location_t loc)
{
tree data = ubsan_create_data ("__ubsan_unreachable_data", loc, NULL_TREE);
tree t = builtin_decl_explicit (BUILT_IN_UBSAN_HANDLE_BUILTIN_UNREACHABLE);
return build_call_expr_loc (loc, t, 1, build_fold_addr_expr_loc (loc, data));
}
/* Allocate memory, using an optional status argument.
This function follows the following pseudo-code:
void *
allocate (size_t size, integer_type stat)
{
void *newmem;
if (stat requested)
stat = 0;
newmem = malloc (MAX (size, 1));
if (newmem == NULL)
{
if (stat)
*stat = LIBERROR_ALLOCATION;
else
runtime_error ("Allocation would exceed memory limit");
}
return newmem;
} */
void
gfc_allocate_using_malloc (stmtblock_t * block, tree pointer,
tree size, tree status)
{
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);
/* 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)));
/* 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);
}
void
gfc_trans_runtime_check (bool error, bool once, tree cond, stmtblock_t * pblock,
locus * where, const char * msgid, ...)
{
va_list ap;
stmtblock_t block;
tree body;
tree tmp;
tree tmpvar = NULL;
if (integer_zerop (cond))
return;
if (once)
{
tmpvar = gfc_create_var (boolean_type_node, "print_warning");
TREE_STATIC (tmpvar) = 1;
DECL_INITIAL (tmpvar) = boolean_true_node;
gfc_add_expr_to_block (pblock, tmpvar);
}
gfc_start_block (&block);
/* The code to generate the error. */
va_start (ap, msgid);
gfc_add_expr_to_block (&block,
trans_runtime_error_vararg (error, where,
msgid, ap));
if (once)
gfc_add_modify (&block, tmpvar, boolean_false_node);
body = gfc_finish_block (&block);
if (integer_onep (cond))
{
gfc_add_expr_to_block (pblock, body);
}
else
{
/* Tell the compiler that this isn't likely. */
if (once)
cond = fold_build2_loc (where->lb->location, TRUTH_AND_EXPR,
long_integer_type_node, tmpvar, cond);
else
cond = fold_convert (long_integer_type_node, cond);
tmp = build_int_cst (long_integer_type_node, 0);
cond = build_call_expr_loc (where->lb->location,
built_in_decls[BUILT_IN_EXPECT], 2, cond, tmp);
cond = fold_convert (boolean_type_node, cond);
tmp = fold_build3_loc (where->lb->location, COND_EXPR, void_type_node,
cond, body,
build_empty_stmt (where->lb->location));
gfc_add_expr_to_block (pblock, tmp);
}
}
/* Reallocate MEM so it has SIZE bytes of data. This behaves like the
following pseudo-code:
void *
internal_realloc (void *mem, size_t size)
{
res = realloc (mem, size);
if (!res && size != 0)
_gfortran_os_error ("Allocation would exceed memory limit");
if (size == 0)
return NULL;
return res;
} */
tree
gfc_call_realloc (stmtblock_t * block, tree mem, tree size)
{
tree msg, res, nonzero, zero, null_result, tmp;
tree type = TREE_TYPE (mem);
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 (type, NULL);
/* Call realloc and check the result. */
tmp = build_call_expr_loc (input_location,
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,
res, build_int_cst (pvoid_type_node, 0));
nonzero = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, size,
build_int_cst (size_type_node, 0));
null_result = fold_build2_loc (input_location, TRUTH_AND_EXPR, boolean_type_node,
null_result, nonzero);
msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
("Allocation would exceed memory limit"));
tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
null_result,
build_call_expr_loc (input_location,
gfor_fndecl_os_error, 1, msg),
build_empty_stmt (input_location));
gfc_add_expr_to_block (block, tmp);
/* if (size == 0) then the result is NULL. */
tmp = fold_build2_loc (input_location, MODIFY_EXPR, type, res,
build_int_cst (type, 0));
zero = fold_build1_loc (input_location, TRUTH_NOT_EXPR, boolean_type_node,
nonzero);
tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, zero, tmp,
build_empty_stmt (input_location));
gfc_add_expr_to_block (block, tmp);
return res;
}
void
c_finish_omp_taskwait (location_t loc)
{
tree x;
x = built_in_decls[BUILT_IN_GOMP_TASKWAIT];
x = build_call_expr_loc (loc, x, 0);
add_stmt (x);
}
void
c_finish_omp_taskyield (location_t loc)
{
tree x;
x = builtin_decl_explicit (BUILT_IN_GOMP_TASKYIELD);
x = build_call_expr_loc (loc, x, 0);
add_stmt (x);
}
void
c_finish_omp_flush (location_t loc)
{
tree x;
x = builtin_decl_explicit (BUILT_IN_SYNC_SYNCHRONIZE);
x = build_call_expr_loc (loc, x, 0);
add_stmt (x);
}
void
c_finish_omp_barrier (location_t loc)
{
tree x;
x = builtin_decl_explicit (BUILT_IN_GOMP_BARRIER);
x = build_call_expr_loc (loc, x, 0);
add_stmt (x);
}
tree
ubsan_instrument_division (location_t loc, tree op0, tree op1)
{
tree t, tt;
tree type = TREE_TYPE (op0);
/* At this point both operands should have the same type,
because they are already converted to RESULT_TYPE.
Use TYPE_MAIN_VARIANT since typedefs can confuse us. */
gcc_assert (TYPE_MAIN_VARIANT (TREE_TYPE (op0))
== TYPE_MAIN_VARIANT (TREE_TYPE (op1)));
/* TODO: REAL_TYPE is not supported yet. */
if (TREE_CODE (type) != INTEGER_TYPE)
return NULL_TREE;
/* If we *know* that the divisor is not -1 or 0, we don't have to
instrument this expression.
??? We could use decl_constant_value to cover up more cases. */
if (TREE_CODE (op1) == INTEGER_CST
&& integer_nonzerop (op1)
&& !integer_minus_onep (op1))
return NULL_TREE;
t = fold_build2 (EQ_EXPR, boolean_type_node,
op1, build_int_cst (type, 0));
/* We check INT_MIN / -1 only for signed types. */
if (!TYPE_UNSIGNED (type))
{
tree x;
tt = fold_build2 (EQ_EXPR, boolean_type_node, op1,
build_int_cst (type, -1));
x = fold_build2 (EQ_EXPR, boolean_type_node, op0,
TYPE_MIN_VALUE (type));
x = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, x, tt);
t = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, t, x);
}
/* In case we have a SAVE_EXPR in a conditional context, we need to
make sure it gets evaluated before the condition. */
t = fold_build2 (COMPOUND_EXPR, TREE_TYPE (t), op0, t);
tree data = ubsan_create_data ("__ubsan_overflow_data",
loc, ubsan_type_descriptor (type),
NULL_TREE);
data = build_fold_addr_expr_loc (loc, data);
tt = builtin_decl_explicit (BUILT_IN_UBSAN_HANDLE_DIVREM_OVERFLOW);
tt = build_call_expr_loc (loc, tt, 3, data, ubsan_encode_value (op0),
ubsan_encode_value (op1));
t = fold_build3 (COND_EXPR, void_type_node, t, tt, void_zero_node);
return t;
}
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;
}
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);
}
/* Free a given variable, if it's not NULL. */
tree
gfc_call_free (tree var)
{
stmtblock_t block;
tree tmp, cond, call;
if (TREE_TYPE (var) != TREE_TYPE (pvoid_type_node))
var = fold_convert (pvoid_type_node, var);
gfc_start_block (&block);
var = gfc_evaluate_now (var, &block);
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);
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);
return gfc_finish_block (&block);
}
/* 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)
{
void *newmem;
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;
gcc_assert (token != 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);
/* The allocation itself. */
if (status == NULL_TREE)
pstat = null_pointer_node;
else
pstat = gfc_build_addr_expr (NULL_TREE, status);
if (errmsg == NULL_TREE)
{
gcc_assert(errlen == NULL_TREE);
errmsg = null_pointer_node;
errlen = build_int_cst (integer_type_node, 0);
}
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);
}
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
ubsan_instrument_shift (location_t loc, enum tree_code code,
tree op0, tree op1)
{
tree t, tt = NULL_TREE;
tree type0 = TREE_TYPE (op0);
tree type1 = TREE_TYPE (op1);
if (!INTEGRAL_TYPE_P (type0))
return NULL_TREE;
tree op1_utype = unsigned_type_for (type1);
HOST_WIDE_INT op0_prec = TYPE_PRECISION (type0);
tree uprecm1 = build_int_cst (op1_utype, op0_prec - 1);
op0 = unshare_expr (op0);
op1 = unshare_expr (op1);
t = fold_convert_loc (loc, op1_utype, op1);
t = fold_build2 (GT_EXPR, boolean_type_node, t, uprecm1);
/* If this is not a signed operation, don't perform overflow checks.
Also punt on bit-fields. */
if (TYPE_OVERFLOW_WRAPS (type0)
|| GET_MODE_BITSIZE (TYPE_MODE (type0)) != TYPE_PRECISION (type0)
|| (flag_sanitize & SANITIZE_SHIFT_BASE) == 0)
;
/* For signed x << y, in C99/C11, the following:
(unsigned) x >> (uprecm1 - y)
if non-zero, is undefined. */
else if (code == LSHIFT_EXPR && flag_isoc99 && cxx_dialect < cxx11)
{
tree x = fold_build2 (MINUS_EXPR, op1_utype, uprecm1,
fold_convert (op1_utype, unshare_expr (op1)));
tt = fold_convert_loc (loc, unsigned_type_for (type0), op0);
tt = fold_build2 (RSHIFT_EXPR, TREE_TYPE (tt), tt, x);
tt = fold_build2 (NE_EXPR, boolean_type_node, tt,
build_int_cst (TREE_TYPE (tt), 0));
}
/* For signed x << y, in C++11 and later, the following:
x < 0 || ((unsigned) x >> (uprecm1 - y))
if > 1, is undefined. */
else if (code == LSHIFT_EXPR && cxx_dialect >= cxx11)
{
tree x = fold_build2 (MINUS_EXPR, op1_utype, uprecm1,
fold_convert (op1_utype, unshare_expr (op1)));
tt = fold_convert_loc (loc, unsigned_type_for (type0),
unshare_expr (op0));
tt = fold_build2 (RSHIFT_EXPR, TREE_TYPE (tt), tt, x);
tt = fold_build2 (GT_EXPR, boolean_type_node, tt,
build_int_cst (TREE_TYPE (tt), 1));
x = fold_build2 (LT_EXPR, boolean_type_node, unshare_expr (op0),
build_int_cst (type0, 0));
tt = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, x, tt);
}
/* If the condition was folded to 0, no need to instrument
this expression. */
if (integer_zerop (t) && (tt == NULL_TREE || integer_zerop (tt)))
return NULL_TREE;
/* In case we have a SAVE_EXPR in a conditional context, we need to
make sure it gets evaluated before the condition. */
t = fold_build2 (COMPOUND_EXPR, TREE_TYPE (t), unshare_expr (op0), t);
enum sanitize_code recover_kind = SANITIZE_SHIFT_EXPONENT;
tree else_t = void_node;
if (tt)
{
if ((flag_sanitize & SANITIZE_SHIFT_EXPONENT) == 0)
{
t = fold_build1 (TRUTH_NOT_EXPR, boolean_type_node, t);
t = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, t, tt);
recover_kind = SANITIZE_SHIFT_BASE;
}
else
{
if (flag_sanitize_undefined_trap_on_error
|| ((!(flag_sanitize_recover & SANITIZE_SHIFT_EXPONENT))
== (!(flag_sanitize_recover & SANITIZE_SHIFT_BASE))))
t = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, t, tt);
else
else_t = tt;
}
}
if (flag_sanitize_undefined_trap_on_error)
tt = build_call_expr_loc (loc, builtin_decl_explicit (BUILT_IN_TRAP), 0);
else
{
tree data = ubsan_create_data ("__ubsan_shift_data", 1, &loc,
ubsan_type_descriptor (type0),
ubsan_type_descriptor (type1), NULL_TREE,
NULL_TREE);
data = build_fold_addr_expr_loc (loc, data);
enum built_in_function bcode
= (flag_sanitize_recover & recover_kind)
? BUILT_IN_UBSAN_HANDLE_SHIFT_OUT_OF_BOUNDS
: BUILT_IN_UBSAN_HANDLE_SHIFT_OUT_OF_BOUNDS_ABORT;
tt = builtin_decl_explicit (bcode);
op0 = unshare_expr (op0);
op1 = unshare_expr (op1);
tt = build_call_expr_loc (loc, tt, 3, data, ubsan_encode_value (op0),
ubsan_encode_value (op1));
if (else_t != void_node)
{
bcode = (flag_sanitize_recover & SANITIZE_SHIFT_BASE)
? BUILT_IN_UBSAN_HANDLE_SHIFT_OUT_OF_BOUNDS
: BUILT_IN_UBSAN_HANDLE_SHIFT_OUT_OF_BOUNDS_ABORT;
tree else_tt = builtin_decl_explicit (bcode);
op0 = unshare_expr (op0);
op1 = unshare_expr (op1);
else_tt = build_call_expr_loc (loc, else_tt, 3, data,
ubsan_encode_value (op0),
ubsan_encode_value (op1));
else_t = fold_build3 (COND_EXPR, void_type_node, else_t,
else_tt, void_node);
}
}
t = fold_build3 (COND_EXPR, void_type_node, t, tt, else_t);
return t;
}
static tree
pop_binding (void)
{
tree res;
struct binding_level *cur;
cur = cur_binding_level;
res = cur->bind;
if (cur->save_stack)
{
tree tmp_var;
tree save;
tree save_call;
tree restore;
tree t;
/* Create an artificial var to save the stack pointer. */
/* build_decl got a new parameter
* http://www.mail-archive.com/[email protected]/msg01245.html
*/
tmp_var = build_decl (UNKNOWN_LOCATION, VAR_DECL, NULL, ptr_type_node);
DECL_ARTIFICIAL (tmp_var) = true;
DECL_IGNORED_P (tmp_var) = true;
TREE_USED (tmp_var) = true;
push_decl (tmp_var);
/*
* The functions
* build_function_call_expr
*
* were eliminated in newer versions of GCC. See
* http://patchwork.ozlabs.org/patch/57555/
* http://patchwork.ozlabs.org/patch/57906/
* http://patchwork.ozlabs.org/patch/57911/
* http://patchwork.ozlabs.org/patch/57962/
*
*
*/
/* Create the save stmt. */
/*
* build_function_call_expr was removed with patch 57962
* http://patchwork.ozlabs.org/patch/57962/
*
* The signature was
* build_function_call_expr (location_t loc, tree fndecl, tree arglist)
* A new function build_call_expr_loc_vec was introduced.
* See examples in the patch how to replace that function.
*/
save_call = build_call_expr_loc
(UNKNOWN_LOCATION,
implicit_built_in_decls[BUILT_IN_STACK_SAVE],
0);
save = build2 (MODIFY_EXPR, ptr_type_node, tmp_var, save_call);
TREE_SIDE_EFFECTS (save) = true;
/* Create the restore stmt. */
restore = build_call_expr_loc
(UNKNOWN_LOCATION,
implicit_built_in_decls[BUILT_IN_STACK_RESTORE],
1,
tmp_var);
/* Build a try-finally block.
The statement list is the block of current statements. */
t = build2 (TRY_FINALLY_EXPR, void_type_node, cur_stmts, NULL_TREE);
TREE_SIDE_EFFECTS (t) = true;
/* The finally block is the restore stmt. */
append_to_statement_list (restore, &TREE_OPERAND (t, 1));
/* The body of the BIND_BLOCK is the save stmt, followed by the
try block. */
BIND_EXPR_BODY (res) = NULL_TREE;
append_to_statement_list (save, &BIND_EXPR_BODY (res));
append_to_statement_list (t, &BIND_EXPR_BODY (res));
}
else
{
/* The body of the BIND_BLOCK is the statement block. */
BIND_EXPR_BODY (res) = cur_stmts;
}
BIND_EXPR_VARS (res) = cur->first_decl;
BLOCK_SUBBLOCKS (cur->block) = cur->first_block;
BLOCK_VARS (cur->block) = cur->first_decl;
cur_binding_level = cur->prev;
cur->prev = old_binding_levels;
old_binding_levels = cur;
return res;
}
/* Generate code for an ALLOCATE statement when the argument is an
allocatable array. If the array 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)
{
if (mem == NULL)
return allocate (size, stat);
else
{
if (stat)
{
free (mem);
mem = allocate (size, stat);
*stat = LIBERROR_ALLOCATION;
return mem;
}
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)
{
stmtblock_t alloc_block;
tree res, 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));
/* If mem is NULL, we call gfc_allocate_with_status. */
gfc_start_block (&alloc_block);
tmp = gfc_allocate_with_status (&alloc_block, size, status);
gfc_add_modify (&alloc_block, res, fold_convert (type, tmp));
alloc = gfc_finish_block (&alloc_block);
/* Otherwise, we issue a runtime error or set the status variable. */
if (expr)
{
tree varname;
gcc_assert (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,
"Attempting to allocate already"
" allocated variable '%s'",
varname);
}
else
error = gfc_trans_runtime_error (true, NULL,
"Attempting to allocate already allocated"
" variable");
if (status != NULL_TREE && !integer_zerop (status))
{
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));
}
tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, null_mem,
alloc, error);
gfc_add_expr_to_block (block, tmp);
return res;
}
tree
gfc_deallocate_scalar_with_status (tree pointer, tree status, bool can_fail,
gfc_expr* expr, gfc_typespec ts)
{
stmtblock_t null, non_null;
tree cond, tmp, error;
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 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, 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);
/* Free allocatable components. */
if (ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp)
{
tmp = build_fold_indirect_ref_loc (input_location, pointer);
tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0);
gfc_add_expr_to_block (&non_null, tmp);
}
else if (ts.type == BT_CLASS
&& ts.u.derived->components->ts.u.derived->attr.alloc_comp)
{
tmp = build_fold_indirect_ref_loc (input_location, pointer);
tmp = gfc_deallocate_alloc_comp (ts.u.derived->components->ts.u.derived,
tmp, 0);
gfc_add_expr_to_block (&non_null, tmp);
}
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, 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));
}
tree
ubsan_instrument_shift (location_t loc, enum tree_code code,
tree op0, tree op1)
{
tree t, tt = NULL_TREE;
tree type0 = TREE_TYPE (op0);
tree type1 = TREE_TYPE (op1);
tree op1_utype = unsigned_type_for (type1);
HOST_WIDE_INT op0_prec = TYPE_PRECISION (type0);
tree uprecm1 = build_int_cst (op1_utype, op0_prec - 1);
tree precm1 = build_int_cst (type1, op0_prec - 1);
t = fold_convert_loc (loc, op1_utype, op1);
t = fold_build2 (GT_EXPR, boolean_type_node, t, uprecm1);
/* For signed x << y, in C99/C11, the following:
(unsigned) x >> (precm1 - y)
if non-zero, is undefined. */
if (code == LSHIFT_EXPR
&& !TYPE_UNSIGNED (type0)
&& flag_isoc99)
{
tree x = fold_build2 (MINUS_EXPR, integer_type_node, precm1, op1);
tt = fold_convert_loc (loc, unsigned_type_for (type0), op0);
tt = fold_build2 (RSHIFT_EXPR, TREE_TYPE (tt), tt, x);
tt = fold_build2 (NE_EXPR, boolean_type_node, tt,
build_int_cst (TREE_TYPE (tt), 0));
}
/* For signed x << y, in C++11/C++14, the following:
x < 0 || ((unsigned) x >> (precm1 - y))
if > 1, is undefined. */
if (code == LSHIFT_EXPR
&& !TYPE_UNSIGNED (TREE_TYPE (op0))
&& (cxx_dialect == cxx11 || cxx_dialect == cxx1y))
{
tree x = fold_build2 (MINUS_EXPR, integer_type_node, precm1, op1);
tt = fold_convert_loc (loc, unsigned_type_for (type0), op0);
tt = fold_build2 (RSHIFT_EXPR, TREE_TYPE (tt), tt, x);
tt = fold_build2 (GT_EXPR, boolean_type_node, tt,
build_int_cst (TREE_TYPE (tt), 1));
x = fold_build2 (LT_EXPR, boolean_type_node, op0,
build_int_cst (type0, 0));
tt = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, x, tt);
}
/* In case we have a SAVE_EXPR in a conditional context, we need to
make sure it gets evaluated before the condition. */
t = fold_build2 (COMPOUND_EXPR, TREE_TYPE (t), op0, t);
tree data = ubsan_create_data ("__ubsan_shift_data",
loc, ubsan_type_descriptor (type0),
ubsan_type_descriptor (type1), NULL_TREE);
data = build_fold_addr_expr_loc (loc, data);
t = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, t,
tt ? tt : integer_zero_node);
tt = builtin_decl_explicit (BUILT_IN_UBSAN_HANDLE_SHIFT_OUT_OF_BOUNDS);
tt = build_call_expr_loc (loc, tt, 3, data, ubsan_encode_value (op0),
ubsan_encode_value (op1));
t = fold_build3 (COND_EXPR, void_type_node, t, tt, void_zero_node);
return t;
}
static tree
gfc_build_final_call (gfc_typespec ts, gfc_expr *final_wrapper, gfc_expr *var,
bool fini_coarray, gfc_expr *class_size)
{
stmtblock_t block;
gfc_se se;
tree final_fndecl, array, size, tmp;
symbol_attribute attr;
gcc_assert (final_wrapper->expr_type == EXPR_VARIABLE);
gcc_assert (var);
gfc_start_block (&block);
gfc_init_se (&se, NULL);
gfc_conv_expr (&se, final_wrapper);
final_fndecl = se.expr;
if (POINTER_TYPE_P (TREE_TYPE (final_fndecl)))
final_fndecl = build_fold_indirect_ref_loc (input_location, final_fndecl);
if (ts.type == BT_DERIVED)
{
tree elem_size;
gcc_assert (!class_size);
elem_size = gfc_typenode_for_spec (&ts);
elem_size = TYPE_SIZE_UNIT (elem_size);
size = fold_convert (gfc_array_index_type, elem_size);
gfc_init_se (&se, NULL);
se.want_pointer = 1;
if (var->rank)
{
se.descriptor_only = 1;
gfc_conv_expr_descriptor (&se, var);
array = se.expr;
}
else
{
gfc_conv_expr (&se, var);
gcc_assert (se.pre.head == NULL_TREE && se.post.head == NULL_TREE);
array = se.expr;
/* No copy back needed, hence set attr's allocatable/pointer
to zero. */
gfc_clear_attr (&attr);
gfc_init_se (&se, NULL);
array = gfc_conv_scalar_to_descriptor (&se, array, attr);
gcc_assert (se.post.head == NULL_TREE);
}
}
else
{
gfc_expr *array_expr;
gcc_assert (class_size);
gfc_init_se (&se, NULL);
gfc_conv_expr (&se, class_size);
gfc_add_block_to_block (&block, &se.pre);
gcc_assert (se.post.head == NULL_TREE);
size = se.expr;
array_expr = gfc_copy_expr (var);
gfc_init_se (&se, NULL);
se.want_pointer = 1;
if (array_expr->rank)
{
gfc_add_class_array_ref (array_expr);
se.descriptor_only = 1;
gfc_conv_expr_descriptor (&se, array_expr);
array = se.expr;
}
else
{
gfc_add_data_component (array_expr);
gfc_conv_expr (&se, array_expr);
gfc_add_block_to_block (&block, &se.pre);
gcc_assert (se.post.head == NULL_TREE);
array = se.expr;
if (TREE_CODE (array) == ADDR_EXPR
&& POINTER_TYPE_P (TREE_TYPE (TREE_OPERAND (array, 0))))
tmp = TREE_OPERAND (array, 0);
if (!gfc_is_coarray (array_expr))
{
/* No copy back needed, hence set attr's allocatable/pointer
to zero. */
gfc_clear_attr (&attr);
gfc_init_se (&se, NULL);
array = gfc_conv_scalar_to_descriptor (&se, array, attr);
}
gcc_assert (se.post.head == NULL_TREE);
}
gfc_free_expr (array_expr);
}
if (!POINTER_TYPE_P (TREE_TYPE (array)))
array = gfc_build_addr_expr (NULL, array);
gfc_add_block_to_block (&block, &se.pre);
tmp = build_call_expr_loc (input_location,
final_fndecl, 3, array,
size, fini_coarray ? boolean_true_node
: boolean_false_node);
gfc_add_block_to_block (&block, &se.post);
gfc_add_expr_to_block (&block, tmp);
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));
}
tree
ubsan_instrument_float_cast (location_t loc, tree type, tree expr)
{
tree expr_type = TREE_TYPE (expr);
tree t, tt, fn, min, max;
enum machine_mode mode = TYPE_MODE (expr_type);
int prec = TYPE_PRECISION (type);
bool uns_p = TYPE_UNSIGNED (type);
/* Float to integer conversion first truncates toward zero, so
even signed char c = 127.875f; is not problematic.
Therefore, we should complain only if EXPR is unordered or smaller
or equal than TYPE_MIN_VALUE - 1.0 or greater or equal than
TYPE_MAX_VALUE + 1.0. */
if (REAL_MODE_FORMAT (mode)->b == 2)
{
/* For maximum, TYPE_MAX_VALUE might not be representable
in EXPR_TYPE, e.g. if TYPE is 64-bit long long and
EXPR_TYPE is IEEE single float, but TYPE_MAX_VALUE + 1.0 is
either representable or infinity. */
REAL_VALUE_TYPE maxval = dconst1;
SET_REAL_EXP (&maxval, REAL_EXP (&maxval) + prec - !uns_p);
real_convert (&maxval, mode, &maxval);
max = build_real (expr_type, maxval);
/* For unsigned, assume -1.0 is always representable. */
if (uns_p)
min = build_minus_one_cst (expr_type);
else
{
/* TYPE_MIN_VALUE is generally representable (or -inf),
but TYPE_MIN_VALUE - 1.0 might not be. */
REAL_VALUE_TYPE minval = dconstm1, minval2;
SET_REAL_EXP (&minval, REAL_EXP (&minval) + prec - 1);
real_convert (&minval, mode, &minval);
real_arithmetic (&minval2, MINUS_EXPR, &minval, &dconst1);
real_convert (&minval2, mode, &minval2);
if (real_compare (EQ_EXPR, &minval, &minval2)
&& !real_isinf (&minval))
{
/* If TYPE_MIN_VALUE - 1.0 is not representable and
rounds to TYPE_MIN_VALUE, we need to subtract
more. As REAL_MODE_FORMAT (mode)->p is the number
of base digits, we want to subtract a number that
will be 1 << (REAL_MODE_FORMAT (mode)->p - 1)
times smaller than minval. */
minval2 = dconst1;
gcc_assert (prec > REAL_MODE_FORMAT (mode)->p);
SET_REAL_EXP (&minval2,
REAL_EXP (&minval2) + prec - 1
- REAL_MODE_FORMAT (mode)->p + 1);
real_arithmetic (&minval2, MINUS_EXPR, &minval, &minval2);
real_convert (&minval2, mode, &minval2);
}
min = build_real (expr_type, minval2);
}
}
else if (REAL_MODE_FORMAT (mode)->b == 10)
{
/* For _Decimal128 up to 34 decimal digits, - sign,
dot, e, exponent. */
char buf[64];
mpfr_t m;
int p = REAL_MODE_FORMAT (mode)->p;
REAL_VALUE_TYPE maxval, minval;
/* Use mpfr_snprintf rounding to compute the smallest
representable decimal number greater or equal than
1 << (prec - !uns_p). */
mpfr_init2 (m, prec + 2);
mpfr_set_ui_2exp (m, 1, prec - !uns_p, GMP_RNDN);
mpfr_snprintf (buf, sizeof buf, "%.*RUe", p - 1, m);
decimal_real_from_string (&maxval, buf);
max = build_real (expr_type, maxval);
/* For unsigned, assume -1.0 is always representable. */
if (uns_p)
min = build_minus_one_cst (expr_type);
else
{
/* Use mpfr_snprintf rounding to compute the largest
representable decimal number less or equal than
(-1 << (prec - 1)) - 1. */
mpfr_set_si_2exp (m, -1, prec - 1, GMP_RNDN);
mpfr_sub_ui (m, m, 1, GMP_RNDN);
mpfr_snprintf (buf, sizeof buf, "%.*RDe", p - 1, m);
decimal_real_from_string (&minval, buf);
min = build_real (expr_type, minval);
}
mpfr_clear (m);
}
else
return NULL_TREE;
if (flag_sanitize_undefined_trap_on_error)
fn = build_call_expr_loc (loc, builtin_decl_explicit (BUILT_IN_TRAP), 0);
else
{
/* Create the __ubsan_handle_float_cast_overflow fn call. */
tree data = ubsan_create_data ("__ubsan_float_cast_overflow_data", NULL,
NULL, ubsan_type_descriptor (expr_type),
ubsan_type_descriptor (type), NULL_TREE);
enum built_in_function bcode
= flag_sanitize_recover
? BUILT_IN_UBSAN_HANDLE_FLOAT_CAST_OVERFLOW
: BUILT_IN_UBSAN_HANDLE_FLOAT_CAST_OVERFLOW_ABORT;
fn = builtin_decl_explicit (bcode);
fn = build_call_expr_loc (loc, fn, 2,
build_fold_addr_expr_loc (loc, data),
ubsan_encode_value (expr, false));
}
t = fold_build2 (UNLE_EXPR, boolean_type_node, expr, min);
tt = fold_build2 (UNGE_EXPR, boolean_type_node, expr, max);
return fold_build3 (COND_EXPR, void_type_node,
fold_build2 (TRUTH_OR_EXPR, boolean_type_node, t, tt),
fn, integer_zero_node);
}