gfc_match_omp_eos (void)
{
locus old_loc;
- int c;
+ char c;
old_loc = gfc_current_locus;
gfc_gobble_whitespace ();
- c = gfc_next_char ();
+ c = gfc_next_ascii_char ();
switch (c)
{
case '!':
do
- c = gfc_next_char ();
+ c = gfc_next_ascii_char ();
while (c != '\n');
/* Fall through */
#define OMP_CLAUSE_SCHEDULE (1 << 9)
#define OMP_CLAUSE_DEFAULT (1 << 10)
#define OMP_CLAUSE_ORDERED (1 << 11)
+#define OMP_CLAUSE_COLLAPSE (1 << 12)
+#define OMP_CLAUSE_UNTIED (1 << 13)
/* Match OpenMP directive clauses. MASK is a bitmask of
clauses that are allowed for a particular directive. */
c->default_sharing = OMP_DEFAULT_PRIVATE;
else if (gfc_match ("default ( none )") == MATCH_YES)
c->default_sharing = OMP_DEFAULT_NONE;
+ else if (gfc_match ("default ( firstprivate )") == MATCH_YES)
+ c->default_sharing = OMP_DEFAULT_FIRSTPRIVATE;
if (c->default_sharing != OMP_DEFAULT_UNKNOWN)
continue;
}
c->sched_kind = OMP_SCHED_GUIDED;
else if (gfc_match ("runtime") == MATCH_YES)
c->sched_kind = OMP_SCHED_RUNTIME;
+ else if (gfc_match ("auto") == MATCH_YES)
+ c->sched_kind = OMP_SCHED_AUTO;
if (c->sched_kind != OMP_SCHED_NONE)
{
match m = MATCH_NO;
- if (c->sched_kind != OMP_SCHED_RUNTIME)
+ if (c->sched_kind != OMP_SCHED_RUNTIME
+ && c->sched_kind != OMP_SCHED_AUTO)
m = gfc_match (" , %e )", &c->chunk_size);
if (m != MATCH_YES)
m = gfc_match_char (')');
c->ordered = needs_space = true;
continue;
}
+ if ((mask & OMP_CLAUSE_UNTIED) && !c->untied
+ && gfc_match ("untied") == MATCH_YES)
+ {
+ c->untied = needs_space = true;
+ continue;
+ }
+ if ((mask & OMP_CLAUSE_COLLAPSE) && !c->collapse)
+ {
+ gfc_expr *cexpr = NULL;
+ match m = gfc_match ("collapse ( %e )", &cexpr);
+
+ if (m == MATCH_YES)
+ {
+ int collapse;
+ const char *p = gfc_extract_int (cexpr, &collapse);
+ if (p)
+ {
+ gfc_error (p);
+ collapse = 1;
+ }
+ else if (collapse <= 0)
+ {
+ gfc_error ("COLLAPSE clause argument not constant positive integer at %C");
+ collapse = 1;
+ }
+ c->collapse = collapse;
+ gfc_free_expr (cexpr);
+ continue;
+ }
+ }
break;
}
#define OMP_DO_CLAUSES \
(OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
| OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION \
- | OMP_CLAUSE_SCHEDULE | OMP_CLAUSE_ORDERED)
+ | OMP_CLAUSE_SCHEDULE | OMP_CLAUSE_ORDERED | OMP_CLAUSE_COLLAPSE)
#define OMP_SECTIONS_CLAUSES \
(OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
| OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION)
+#define OMP_TASK_CLAUSES \
+ (OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_SHARED \
+ | OMP_CLAUSE_IF | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_UNTIED)
match
gfc_match_omp_parallel (void)
match
+gfc_match_omp_task (void)
+{
+ gfc_omp_clauses *c;
+ if (gfc_match_omp_clauses (&c, OMP_TASK_CLAUSES) != MATCH_YES)
+ return MATCH_ERROR;
+ new_st.op = EXEC_OMP_TASK;
+ new_st.ext.omp_clauses = c;
+ return MATCH_YES;
+}
+
+
+match
+gfc_match_omp_taskwait (void)
+{
+ if (gfc_match_omp_eos () != MATCH_YES)
+ return MATCH_ERROR;
+ new_st.op = EXEC_OMP_TASKWAIT;
+ new_st.ext.omp_clauses = NULL;
+ return MATCH_YES;
+}
+
+
+match
gfc_match_omp_critical (void)
{
char n[GFC_MAX_SYMBOL_LEN+1];
a symbol can appear on both firstprivate and lastprivate. */
for (list = 0; list < OMP_LIST_NUM; list++)
for (n = omp_clauses->lists[list]; n; n = n->next)
- n->sym->mark = 0;
+ {
+ n->sym->mark = 0;
+ if (n->sym->attr.flavor == FL_VARIABLE)
+ continue;
+ if (n->sym->attr.flavor == FL_PROCEDURE
+ && n->sym->result == n->sym
+ && n->sym->attr.function)
+ {
+ if (gfc_current_ns->proc_name == n->sym
+ || (gfc_current_ns->parent
+ && gfc_current_ns->parent->proc_name == n->sym))
+ continue;
+ if (gfc_current_ns->proc_name->attr.entry_master)
+ {
+ gfc_entry_list *el = gfc_current_ns->entries;
+ for (; el; el = el->next)
+ if (el->sym == n->sym)
+ break;
+ if (el)
+ continue;
+ }
+ if (gfc_current_ns->parent
+ && gfc_current_ns->parent->proc_name->attr.entry_master)
+ {
+ gfc_entry_list *el = gfc_current_ns->parent->entries;
+ for (; el; el = el->next)
+ if (el->sym == n->sym)
+ break;
+ if (el)
+ continue;
+ }
+ }
+ gfc_error ("Object '%s' is not a variable at %L", n->sym->name,
+ &code->loc);
+ }
for (list = 0; list < OMP_LIST_NUM; list++)
if (list != OMP_LIST_FIRSTPRIVATE && list != OMP_LIST_LASTPRIVATE)
if (!n->sym->attr.threadprivate)
gfc_error ("Non-THREADPRIVATE object '%s' in COPYIN clause"
" at %L", n->sym->name, &code->loc);
- if (n->sym->attr.allocatable)
- gfc_error ("COPYIN clause object '%s' is ALLOCATABLE at %L",
- n->sym->name, &code->loc);
if (n->sym->ts.type == BT_DERIVED && n->sym->ts.derived->attr.alloc_comp)
gfc_error ("COPYIN clause object '%s' at %L has ALLOCATABLE components",
n->sym->name, &code->loc);
if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
gfc_error ("Assumed size array '%s' in COPYPRIVATE clause "
"at %L", n->sym->name, &code->loc);
- if (n->sym->attr.allocatable)
- gfc_error ("COPYPRIVATE clause object '%s' is ALLOCATABLE "
- "at %L", n->sym->name, &code->loc);
if (n->sym->ts.type == BT_DERIVED && n->sym->ts.derived->attr.alloc_comp)
gfc_error ("COPYPRIVATE clause object '%s' at %L has ALLOCATABLE components",
n->sym->name, &code->loc);
if (n->sym->attr.pointer)
gfc_error ("POINTER object '%s' in %s clause at %L",
n->sym->name, name, &code->loc);
- if (n->sym->attr.allocatable)
- gfc_error ("%s clause object '%s' is ALLOCATABLE at %L",
- name, n->sym->name, &code->loc);
/* Variables in REDUCTION-clauses must be of intrinsic type (flagged below). */
if ((list < OMP_LIST_REDUCTION_FIRST || list > OMP_LIST_REDUCTION_LAST) &&
n->sym->ts.type == BT_DERIVED && n->sym->ts.derived->attr.alloc_comp)
if (expr2->expr_type == EXPR_OP)
{
gfc_expr *v = NULL, *e, *c;
- gfc_intrinsic_op op = expr2->value.op.operator;
+ gfc_intrinsic_op op = expr2->value.op.op;
gfc_intrinsic_op alt_op = INTRINSIC_NONE;
switch (op)
else if ((c = is_conversion (e, true)) != NULL)
q = &e->value.function.actual->expr;
else if (e->expr_type != EXPR_OP
- || (e->value.op.operator != op
- && e->value.op.operator != alt_op)
+ || (e->value.op.op != op
+ && e->value.op.op != alt_op)
|| e->rank != 0)
break;
else
if (p != NULL)
{
e = *p;
- switch (e->value.op.operator)
+ switch (e->value.op.op)
{
case INTRINSIC_MINUS:
case INTRINSIC_DIVIDE:
struct pointer_set_t *private_iterators;
struct omp_context *previous;
} *omp_current_ctx;
-gfc_code *omp_current_do_code;
-
+static gfc_code *omp_current_do_code;
+static int omp_current_do_collapse;
void
gfc_resolve_omp_do_blocks (gfc_code *code, gfc_namespace *ns)
{
if (code->block->next && code->block->next->op == EXEC_DO)
- omp_current_do_code = code->block->next;
+ {
+ int i;
+ gfc_code *c;
+
+ omp_current_do_code = code->block->next;
+ omp_current_do_collapse = code->ext.omp_clauses->collapse;
+ for (i = 1, c = omp_current_do_code; i < omp_current_do_collapse; i++)
+ {
+ c = c->block;
+ if (c->op != EXEC_DO || c->next == NULL)
+ break;
+ c = c->next;
+ if (c->op != EXEC_DO)
+ break;
+ }
+ if (i < omp_current_do_collapse || omp_current_do_collapse <= 0)
+ omp_current_do_collapse = 1;
+ }
gfc_resolve_blocks (code->block, ns);
+ omp_current_do_collapse = 0;
+ omp_current_do_code = NULL;
}
gfc_resolve_do_iterator (gfc_code *code, gfc_symbol *sym)
{
struct omp_context *ctx;
+ int i = omp_current_do_collapse;
+ gfc_code *c = omp_current_do_code;
if (sym->attr.threadprivate)
return;
/* !$omp do and !$omp parallel do iteration variable is predetermined
private just in the !$omp do resp. !$omp parallel do construct,
with no implications for the outer parallel constructs. */
- if (code == omp_current_do_code)
- return;
+
+ while (i-- >= 1)
+ {
+ if (code == c)
+ return;
+
+ c = c->block->next;
+ }
for (ctx = omp_current_ctx; ctx; ctx = ctx->previous)
{
static void
resolve_omp_do (gfc_code *code)
{
- gfc_code *do_code;
- int list;
+ gfc_code *do_code, *c;
+ int list, i, collapse;
gfc_namelist *n;
gfc_symbol *dovar;
resolve_omp_clauses (code);
do_code = code->block->next;
- if (do_code->op == EXEC_DO_WHILE)
- gfc_error ("!$OMP DO cannot be a DO WHILE or DO without loop control "
- "at %L", &do_code->loc);
- else
+ collapse = code->ext.omp_clauses->collapse;
+ if (collapse <= 0)
+ collapse = 1;
+ for (i = 1; i <= collapse; i++)
{
+ if (do_code->op == EXEC_DO_WHILE)
+ {
+ gfc_error ("!$OMP DO cannot be a DO WHILE or DO without loop control "
+ "at %L", &do_code->loc);
+ break;
+ }
gcc_assert (do_code->op == EXEC_DO);
if (do_code->ext.iterator->var->ts.type != BT_INTEGER)
gfc_error ("!$OMP DO iteration variable must be of type integer at %L",
&do_code->loc);
break;
}
+ if (i > 1)
+ {
+ gfc_code *do_code2 = code->block->next;
+ int j;
+
+ for (j = 1; j < i; j++)
+ {
+ gfc_symbol *ivar = do_code2->ext.iterator->var->symtree->n.sym;
+ if (dovar == ivar
+ || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->start)
+ || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->end)
+ || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->step))
+ {
+ gfc_error ("!$OMP DO collapsed loops don't form rectangular iteration space at %L",
+ &do_code->loc);
+ break;
+ }
+ if (j < i)
+ break;
+ do_code2 = do_code2->block->next;
+ }
+ }
+ if (i == collapse)
+ break;
+ for (c = do_code->next; c; c = c->next)
+ if (c->op != EXEC_NOP && c->op != EXEC_CONTINUE)
+ {
+ gfc_error ("collapsed !$OMP DO loops not perfectly nested at %L",
+ &c->loc);
+ break;
+ }
+ if (c)
+ break;
+ do_code = do_code->block;
+ if (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE)
+ {
+ gfc_error ("not enough DO loops for collapsed !$OMP DO at %L",
+ &code->loc);
+ break;
+ }
+ do_code = do_code->next;
+ if (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE)
+ {
+ gfc_error ("not enough DO loops for collapsed !$OMP DO at %L",
+ &code->loc);
+ break;
+ }
}
}
OSDN Git Service
