static int gfc_check_argument_var_dependency (gfc_expr * var, sym_intent intent, gfc_expr * expr) { gcc_assert (var->expr_type == EXPR_VARIABLE); gcc_assert (var->rank > 0); switch (expr->expr_type) { case EXPR_VARIABLE: return (gfc_ref_needs_temporary_p (expr->ref) || gfc_check_dependency (var, expr, 1)); case EXPR_ARRAY: return gfc_check_dependency (var, expr, 1); case EXPR_FUNCTION: if (intent != INTENT_IN && expr->inline_noncopying_intrinsic) { expr = gfc_get_noncopying_intrinsic_argument (expr); return gfc_check_argument_var_dependency (var, intent, expr); } return 0; default: return 0; } }
int gfc_check_dependency (gfc_expr *expr1, gfc_expr *expr2, bool identical) { gfc_actual_arglist *actual; gfc_constructor *c; int n; gcc_assert (expr1->expr_type == EXPR_VARIABLE); switch (expr2->expr_type) { case EXPR_OP: n = gfc_check_dependency (expr1, expr2->value.op.op1, identical); if (n) return n; if (expr2->value.op.op2) return gfc_check_dependency (expr1, expr2->value.op.op2, identical); return 0; case EXPR_VARIABLE: /* The interesting cases are when the symbols don't match. */ if (expr1->symtree->n.sym != expr2->symtree->n.sym) { gfc_typespec *ts1 = &expr1->symtree->n.sym->ts; gfc_typespec *ts2 = &expr2->symtree->n.sym->ts; /* Return 1 if expr1 and expr2 are equivalenced arrays. */ if (gfc_are_equivalenced_arrays (expr1, expr2)) return 1; /* Symbols can only alias if they have the same type. */ if (ts1->type != BT_UNKNOWN && ts2->type != BT_UNKNOWN && ts1->type != BT_DERIVED && ts2->type != BT_DERIVED) { if (ts1->type != ts2->type || ts1->kind != ts2->kind) return 0; } /* If either variable is a pointer, assume the worst. */ /* TODO: -fassume-no-pointer-aliasing */ if (gfc_is_data_pointer (expr1) || gfc_is_data_pointer (expr2)) { if (check_data_pointer_types (expr1, expr2) && check_data_pointer_types (expr2, expr1)) return 0; return 1; } else { gfc_symbol *sym1 = expr1->symtree->n.sym; gfc_symbol *sym2 = expr2->symtree->n.sym; if (sym1->attr.target && sym2->attr.target && ((sym1->attr.dummy && !sym1->attr.contiguous && (!sym1->attr.dimension || sym2->as->type == AS_ASSUMED_SHAPE)) || (sym2->attr.dummy && !sym2->attr.contiguous && (!sym2->attr.dimension || sym2->as->type == AS_ASSUMED_SHAPE)))) return 1; } /* Otherwise distinct symbols have no dependencies. */ return 0; } if (identical) return 1; /* Identical and disjoint ranges return 0, overlapping ranges return 1. */ if (expr1->ref && expr2->ref) return gfc_dep_resolver (expr1->ref, expr2->ref, NULL); return 1; case EXPR_FUNCTION: if (expr2->inline_noncopying_intrinsic) identical = 1; /* Remember possible differences between elemental and transformational functions. All functions inside a FORALL will be pure. */ for (actual = expr2->value.function.actual; actual; actual = actual->next) { if (!actual->expr) continue; n = gfc_check_dependency (expr1, actual->expr, identical); if (n) return n; } return 0; case EXPR_CONSTANT: case EXPR_NULL: return 0; case EXPR_ARRAY: /* Loop through the array constructor's elements. */ for (c = gfc_constructor_first (expr2->value.constructor); c; c = gfc_constructor_next (c)) { /* If this is an iterator, assume the worst. */ if (c->iterator) return 1; /* Avoid recursion in the common case. */ if (c->expr->expr_type == EXPR_CONSTANT) continue; if (gfc_check_dependency (expr1, c->expr, 1)) return 1; } return 0; default: return 1; } }
static int gfc_check_argument_var_dependency (gfc_expr *var, sym_intent intent, gfc_expr *expr, gfc_dep_check elemental) { gfc_expr *arg; gcc_assert (var->expr_type == EXPR_VARIABLE); gcc_assert (var->rank > 0); switch (expr->expr_type) { case EXPR_VARIABLE: /* In case of elemental subroutines, there is no dependency between two same-range array references. */ if (gfc_ref_needs_temporary_p (expr->ref) || gfc_check_dependency (var, expr, elemental == NOT_ELEMENTAL)) { if (elemental == ELEM_DONT_CHECK_VARIABLE) { /* Too many false positive with pointers. */ if (!gfc_is_data_pointer (var) && !gfc_is_data_pointer (expr)) { /* Elemental procedures forbid unspecified intents, and we don't check dependencies for INTENT_IN args. */ gcc_assert (intent == INTENT_OUT || intent == INTENT_INOUT); /* We are told not to check dependencies. We do it, however, and issue a warning in case we find one. If a dependency is found in the case elemental == ELEM_CHECK_VARIABLE, we will generate a temporary, so we don't need to bother the user. */ gfc_warning ("INTENT(%s) actual argument at %L might " "interfere with actual argument at %L.", intent == INTENT_OUT ? "OUT" : "INOUT", &var->where, &expr->where); } return 0; } else return 1; } return 0; case EXPR_ARRAY: return gfc_check_dependency (var, expr, 1); case EXPR_FUNCTION: if (intent != INTENT_IN && expr->inline_noncopying_intrinsic && (arg = gfc_get_noncopying_intrinsic_argument (expr)) && gfc_check_argument_var_dependency (var, intent, arg, elemental)) return 1; if (elemental) { if ((expr->value.function.esym && expr->value.function.esym->attr.elemental) || (expr->value.function.isym && expr->value.function.isym->elemental)) return gfc_check_fncall_dependency (var, intent, NULL, expr->value.function.actual, ELEM_CHECK_VARIABLE); } return 0; case EXPR_OP: /* In case of non-elemental procedures, there is no need to catch dependencies, as we will make a temporary anyway. */ if (elemental) { /* If the actual arg EXPR is an expression, we need to catch a dependency between variables in EXPR and VAR, an intent((IN)OUT) variable. */ if (expr->value.op.op1 && gfc_check_argument_var_dependency (var, intent, expr->value.op.op1, ELEM_CHECK_VARIABLE)) return 1; else if (expr->value.op.op2 && gfc_check_argument_var_dependency (var, intent, expr->value.op.op2, ELEM_CHECK_VARIABLE)) return 1; } return 0; default: return 0; } }
int gfc_check_dependency (gfc_expr * expr1, gfc_expr * expr2, gfc_expr ** vars, int nvars) { gfc_ref *ref; int n; gfc_actual_arglist *actual; gcc_assert (expr1->expr_type == EXPR_VARIABLE); /* TODO: -fassume-no-pointer-aliasing */ if (expr1->symtree->n.sym->attr.pointer) return 1; for (ref = expr1->ref; ref; ref = ref->next) { if (ref->type == REF_COMPONENT && ref->u.c.component->pointer) return 1; } switch (expr2->expr_type) { case EXPR_OP: n = gfc_check_dependency (expr1, expr2->op1, vars, nvars); if (n) return n; if (expr2->op2) return gfc_check_dependency (expr1, expr2->op2, vars, nvars); return 0; case EXPR_VARIABLE: if (expr2->symtree->n.sym->attr.pointer) return 1; for (ref = expr2->ref; ref; ref = ref->next) { if (ref->type == REF_COMPONENT && ref->u.c.component->pointer) return 1; } if (expr1->symtree->n.sym != expr2->symtree->n.sym) return 0; for (ref = expr2->ref; ref; ref = ref->next) { /* Identical ranges return 0, overlapping ranges return 1. */ if (ref->type == REF_ARRAY) return 1; } return 1; case EXPR_FUNCTION: /* Remember possible differences between elemental and transformational functions. All functions inside a FORALL will be pure. */ for (actual = expr2->value.function.actual; actual; actual = actual->next) { if (!actual->expr) continue; n = gfc_check_dependency (expr1, actual->expr, vars, nvars); if (n) return n; } return 0; case EXPR_CONSTANT: return 0; case EXPR_ARRAY: /* Probably ok in the majority of (constant) cases. */ return 1; default: return 1; } }
int gfc_check_fncall_dependency (gfc_expr * dest, gfc_expr * fncall) { gfc_actual_arglist *actual; gfc_ref *ref; gfc_expr *expr; int n; gcc_assert (dest->expr_type == EXPR_VARIABLE && fncall->expr_type == EXPR_FUNCTION); gcc_assert (fncall->rank > 0); for (actual = fncall->value.function.actual; actual; actual = actual->next) { expr = actual->expr; /* Skip args which are not present. */ if (!expr) continue; /* Non-variable expressions will be allocated temporaries anyway. */ switch (expr->expr_type) { case EXPR_VARIABLE: if (expr->rank > 1) { /* This is an array section. */ for (ref = expr->ref; ref; ref = ref->next) { if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT) break; } gcc_assert (ref); /* AR_FULL can't contain vector subscripts. */ if (ref->u.ar.type == AR_SECTION) { for (n = 0; n < ref->u.ar.dimen; n++) { if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR) break; } /* Vector subscript array sections will be copied to a temporary. */ if (n != ref->u.ar.dimen) continue; } } if (gfc_check_dependency (dest, actual->expr, NULL, 0)) return 1; break; case EXPR_ARRAY: if (gfc_check_dependency (dest, expr, NULL, 0)) return 1; break; default: break; } } return 0; }
int gfc_check_dependency (gfc_expr * expr1, gfc_expr * expr2, bool identical) { gfc_ref *ref; int n; gfc_actual_arglist *actual; gcc_assert (expr1->expr_type == EXPR_VARIABLE); switch (expr2->expr_type) { case EXPR_OP: n = gfc_check_dependency (expr1, expr2->value.op.op1, identical); if (n) return n; if (expr2->value.op.op2) return gfc_check_dependency (expr1, expr2->value.op.op2, identical); return 0; case EXPR_VARIABLE: /* The interesting cases are when the symbols don't match. */ if (expr1->symtree->n.sym != expr2->symtree->n.sym) { gfc_typespec *ts1 = &expr1->symtree->n.sym->ts; gfc_typespec *ts2 = &expr2->symtree->n.sym->ts; /* Return 1 if expr1 and expr2 are equivalenced arrays. */ if (gfc_are_equivalenced_arrays (expr1, expr2)) return 1; /* Symbols can only alias if they have the same type. */ if (ts1->type != BT_UNKNOWN && ts2->type != BT_UNKNOWN && ts1->type != BT_DERIVED && ts2->type != BT_DERIVED) { if (ts1->type != ts2->type || ts1->kind != ts2->kind) return 0; } /* If either variable is a pointer, assume the worst. */ /* TODO: -fassume-no-pointer-aliasing */ if (expr1->symtree->n.sym->attr.pointer) return 1; for (ref = expr1->ref; ref; ref = ref->next) if (ref->type == REF_COMPONENT && ref->u.c.component->pointer) return 1; if (expr2->symtree->n.sym->attr.pointer) return 1; for (ref = expr2->ref; ref; ref = ref->next) if (ref->type == REF_COMPONENT && ref->u.c.component->pointer) return 1; /* Otherwise distinct symbols have no dependencies. */ return 0; } if (identical) return 1; /* Identical and disjoint ranges return 0, overlapping ranges return 1. */ /* Return zero if we refer to the same full arrays. */ if (expr1->ref->type == REF_ARRAY && expr2->ref->type == REF_ARRAY) return gfc_dep_resolver (expr1->ref, expr2->ref); return 1; case EXPR_FUNCTION: if (expr2->inline_noncopying_intrinsic) identical = 1; /* Remember possible differences between elemental and transformational functions. All functions inside a FORALL will be pure. */ for (actual = expr2->value.function.actual; actual; actual = actual->next) { if (!actual->expr) continue; n = gfc_check_dependency (expr1, actual->expr, identical); if (n) return n; } return 0; case EXPR_CONSTANT: case EXPR_NULL: return 0; case EXPR_ARRAY: /* Probably ok in the majority of (constant) cases. */ return 1; default: return 1; } }