static bool cp_ubsan_maybe_instrument_member_access (tree stmt, cp_ubsan_check_member_access_data *ucmd) { if (DECL_ARTIFICIAL (TREE_OPERAND (stmt, 1))) return false; tree base = TREE_OPERAND (stmt, 0); if (!cp_ubsan_instrument_vptr_p (TREE_TYPE (base))) return false; cp_walk_tree (&base, cp_ubsan_check_member_access_r, ucmd, ucmd->pset); base = cp_ubsan_instrument_vptr (EXPR_LOCATION (stmt), base, TREE_TYPE (base), false, UBSAN_MEMBER_ACCESS); TREE_OPERAND (stmt, 0) = build_fold_indirect_ref_loc (EXPR_LOCATION (stmt), base); return true; }
static tree cp_ubsan_instrument_vptr (location_t loc, tree op, tree type, bool is_addr, enum ubsan_null_ckind ckind) { type = TYPE_MAIN_VARIANT (type); const char *mangled = mangle_type_string (type); hashval_t str_hash1 = htab_hash_string (mangled); hashval_t str_hash2 = iterative_hash (mangled, strlen (mangled), 0); tree str_hash = wide_int_to_tree (uint64_type_node, wi::uhwi (((uint64_t) str_hash1 << 32) | str_hash2, 64)); if (!is_addr) op = build_fold_addr_expr_loc (loc, op); op = save_expr (op); tree vptr = fold_build3_loc (loc, COMPONENT_REF, TREE_TYPE (TYPE_VFIELD (type)), build_fold_indirect_ref_loc (loc, op), TYPE_VFIELD (type), NULL_TREE); vptr = fold_convert_loc (loc, pointer_sized_int_node, vptr); vptr = fold_convert_loc (loc, uint64_type_node, vptr); if (ckind == UBSAN_DOWNCAST_POINTER) { tree cond = build2_loc (loc, NE_EXPR, boolean_type_node, op, build_zero_cst (TREE_TYPE (op))); /* This is a compiler generated comparison, don't emit e.g. -Wnonnull-compare warning for it. */ TREE_NO_WARNING (cond) = 1; vptr = build3_loc (loc, COND_EXPR, uint64_type_node, cond, vptr, build_int_cst (uint64_type_node, 0)); } tree ti_decl = get_tinfo_decl (type); mark_used (ti_decl); tree ptype = build_pointer_type (type); tree call = build_call_expr_internal_loc (loc, IFN_UBSAN_VPTR, void_type_node, 5, op, vptr, str_hash, build_address (ti_decl), build_int_cst (ptype, ckind)); TREE_SIDE_EFFECTS (call) = 1; return fold_build2 (COMPOUND_EXPR, TREE_TYPE (op), call, op); }
tree gfc_build_array_ref (tree base, tree offset, tree decl) { tree type = TREE_TYPE (base); tree tmp; gcc_assert (TREE_CODE (type) == ARRAY_TYPE); type = TREE_TYPE (type); if (DECL_P (base)) TREE_ADDRESSABLE (base) = 1; /* Strip NON_LVALUE_EXPR nodes. */ STRIP_TYPE_NOPS (offset); /* If the array reference is to a pointer, whose target contains a subreference, use the span that is stored with the backend decl and reference the element with pointer arithmetic. */ if (decl && (TREE_CODE (decl) == FIELD_DECL || TREE_CODE (decl) == VAR_DECL || TREE_CODE (decl) == PARM_DECL) && GFC_DECL_SUBREF_ARRAY_P (decl) && !integer_zerop (GFC_DECL_SPAN(decl))) { offset = fold_build2_loc (input_location, MULT_EXPR, 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_convert (build_pointer_type (type), tmp); if (!TYPE_STRING_FLAG (type)) tmp = build_fold_indirect_ref_loc (input_location, tmp); return tmp; } else /* Otherwise use a straightforward array reference. */ return build4_loc (input_location, ARRAY_REF, type, base, offset, NULL_TREE, NULL_TREE); }
/* 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 gfc_build_array_ref (tree base, tree offset, tree decl) { tree type = TREE_TYPE (base); tree tmp; tree span; if (GFC_ARRAY_TYPE_P (type) && GFC_TYPE_ARRAY_RANK (type) == 0) { gcc_assert (GFC_TYPE_ARRAY_CORANK (type) > 0); return fold_convert (TYPE_MAIN_VARIANT (type), base); } /* 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)) TREE_ADDRESSABLE (base) = 1; /* Strip NON_LVALUE_EXPR nodes. */ STRIP_TYPE_NOPS (offset); /* If the array reference is to a pointer, whose target contains a subreference, use the span that is stored with the backend decl and reference the element with pointer arithmetic. */ if (decl && (TREE_CODE (decl) == FIELD_DECL || TREE_CODE (decl) == VAR_DECL || TREE_CODE (decl) == PARM_DECL) && ((GFC_DECL_SUBREF_ARRAY_P (decl) && !integer_zerop (GFC_DECL_SPAN(decl))) || GFC_DECL_CLASS (decl))) { if (GFC_DECL_CLASS (decl)) { /* Allow for dummy arguments and other good things. */ if (POINTER_TYPE_P (TREE_TYPE (decl))) decl = build_fold_indirect_ref_loc (input_location, decl); /* Check if '_data' is an array descriptor. If it is not, the array must be one of the components of the class object, so return a normal array reference. */ if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_class_data_get (decl)))) return build4_loc (input_location, ARRAY_REF, type, base, offset, NULL_TREE, NULL_TREE); span = gfc_vtable_size_get (decl); } else if (GFC_DECL_SUBREF_ARRAY_P (decl)) span = GFC_DECL_SPAN(decl); else gcc_unreachable (); offset = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, offset, span); tmp = gfc_build_addr_expr (pvoid_type_node, base); 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); return tmp; } else /* Otherwise use a straightforward array reference. */ return build4_loc (input_location, ARRAY_REF, type, base, offset, NULL_TREE, NULL_TREE); }
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)); }
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); }
static tree gfc_trans_omp_atomic (gfc_code *code) { gfc_se lse; gfc_se rse; gfc_expr *expr2, *e; gfc_symbol *var; stmtblock_t block; tree lhsaddr, type, rhs, x; enum tree_code op = ERROR_MARK; bool var_on_left = false; code = code->block->next; gcc_assert (code->op == EXEC_ASSIGN); gcc_assert (code->next == NULL); var = code->expr1->symtree->n.sym; gfc_init_se (&lse, NULL); gfc_init_se (&rse, NULL); gfc_start_block (&block); gfc_conv_expr (&lse, code->expr1); gfc_add_block_to_block (&block, &lse.pre); type = TREE_TYPE (lse.expr); lhsaddr = gfc_build_addr_expr (NULL, lse.expr); expr2 = code->expr2; if (expr2->expr_type == EXPR_FUNCTION && expr2->value.function.isym->id == GFC_ISYM_CONVERSION) expr2 = expr2->value.function.actual->expr; if (expr2->expr_type == EXPR_OP) { gfc_expr *e; switch (expr2->value.op.op) { case INTRINSIC_PLUS: op = PLUS_EXPR; break; case INTRINSIC_TIMES: op = MULT_EXPR; break; case INTRINSIC_MINUS: op = MINUS_EXPR; break; case INTRINSIC_DIVIDE: if (expr2->ts.type == BT_INTEGER) op = TRUNC_DIV_EXPR; else op = RDIV_EXPR; break; case INTRINSIC_AND: op = TRUTH_ANDIF_EXPR; break; case INTRINSIC_OR: op = TRUTH_ORIF_EXPR; break; case INTRINSIC_EQV: op = EQ_EXPR; break; case INTRINSIC_NEQV: op = NE_EXPR; break; default: gcc_unreachable (); } e = expr2->value.op.op1; if (e->expr_type == EXPR_FUNCTION && e->value.function.isym->id == GFC_ISYM_CONVERSION) e = e->value.function.actual->expr; if (e->expr_type == EXPR_VARIABLE && e->symtree != NULL && e->symtree->n.sym == var) { expr2 = expr2->value.op.op2; var_on_left = true; } else { e = expr2->value.op.op2; if (e->expr_type == EXPR_FUNCTION && e->value.function.isym->id == GFC_ISYM_CONVERSION) e = e->value.function.actual->expr; gcc_assert (e->expr_type == EXPR_VARIABLE && e->symtree != NULL && e->symtree->n.sym == var); expr2 = expr2->value.op.op1; var_on_left = false; } gfc_conv_expr (&rse, expr2); gfc_add_block_to_block (&block, &rse.pre); } else { gcc_assert (expr2->expr_type == EXPR_FUNCTION); switch (expr2->value.function.isym->id) { case GFC_ISYM_MIN: op = MIN_EXPR; break; case GFC_ISYM_MAX: op = MAX_EXPR; break; case GFC_ISYM_IAND: op = BIT_AND_EXPR; break; case GFC_ISYM_IOR: op = BIT_IOR_EXPR; break; case GFC_ISYM_IEOR: op = BIT_XOR_EXPR; break; default: gcc_unreachable (); } e = expr2->value.function.actual->expr; gcc_assert (e->expr_type == EXPR_VARIABLE && e->symtree != NULL && e->symtree->n.sym == var); gfc_conv_expr (&rse, expr2->value.function.actual->next->expr); gfc_add_block_to_block (&block, &rse.pre); if (expr2->value.function.actual->next->next != NULL) { tree accum = gfc_create_var (TREE_TYPE (rse.expr), NULL); gfc_actual_arglist *arg; gfc_add_modify (&block, accum, rse.expr); for (arg = expr2->value.function.actual->next->next; arg; arg = arg->next) { gfc_init_block (&rse.pre); gfc_conv_expr (&rse, arg->expr); gfc_add_block_to_block (&block, &rse.pre); x = fold_build2 (op, TREE_TYPE (accum), accum, rse.expr); gfc_add_modify (&block, accum, x); } rse.expr = accum; } expr2 = expr2->value.function.actual->next->expr; } lhsaddr = save_expr (lhsaddr); rhs = gfc_evaluate_now (rse.expr, &block); x = convert (TREE_TYPE (rhs), build_fold_indirect_ref_loc (input_location, lhsaddr)); if (var_on_left) x = fold_build2 (op, TREE_TYPE (rhs), x, rhs); else x = fold_build2 (op, TREE_TYPE (rhs), rhs, x); if (TREE_CODE (TREE_TYPE (rhs)) == COMPLEX_TYPE && TREE_CODE (type) != COMPLEX_TYPE) x = fold_build1 (REALPART_EXPR, TREE_TYPE (TREE_TYPE (rhs)), x); x = build2_v (OMP_ATOMIC, lhsaddr, convert (type, x)); gfc_add_expr_to_block (&block, x); gfc_add_block_to_block (&block, &lse.pre); gfc_add_block_to_block (&block, &rse.pre); return gfc_finish_block (&block); }