/* OpenMP directive matching and resolving.
- Copyright (C) 2005, 2006, 2007
+ Copyright (C) 2005, 2006, 2007, 2008, 2010
Free Software Foundation, Inc.
Contributed by Jakub Jelinek
GCC is free software; you can redistribute it and/or modify it under
the terms of the GNU General Public License as published by the Free
-Software Foundation; either version 2, or (at your option) any later
+Software Foundation; either version 3, or (at your option) any later
version.
GCC is distributed in the hope that it will be useful, but WITHOUT ANY
for more details.
You should have received a copy of the GNU General Public License
-along with GCC; see the file COPYING. If not, write to the Free
-Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
-02110-1301, USA. */
+along with GCC; see the file COPYING3. If not see
+<http://www.gnu.org/licenses/>. */
#include "config.h"
#include "system.h"
#include "match.h"
#include "parse.h"
#include "pointer-set.h"
-#include "target.h"
-#include "toplev.h"
/* Match an end of OpenMP directive. End of OpenMP directive is optional
whitespace, followed by '\n' or comment '!'. */
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_now (p);
+ collapse = 1;
+ }
+ else if (collapse <= 0)
+ {
+ gfc_error_now ("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)
+ {
+ gfc_error ("Unexpected junk after TASKWAIT clause at %C");
+ 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];
if (gfc_match (" ( %n )", n) != MATCH_YES)
n[0] = '\0';
if (gfc_match_omp_eos () != MATCH_YES)
- return MATCH_ERROR;
+ {
+ gfc_error ("Unexpected junk after $OMP CRITICAL statement at %C");
+ return MATCH_ERROR;
+ }
new_st.op = EXEC_OMP_CRITICAL;
new_st.ext.omp_name = n[0] ? xstrdup (n) : NULL;
return MATCH_YES;
gfc_match_omp_variable_list (" (", &list, true);
if (gfc_match_omp_eos () != MATCH_YES)
{
+ gfc_error ("Unexpected junk after $OMP FLUSH statement at %C");
gfc_free_namelist (list);
return MATCH_ERROR;
}
gfc_match_omp_workshare (void)
{
if (gfc_match_omp_eos () != MATCH_YES)
- return MATCH_ERROR;
+ {
+ gfc_error ("Unexpected junk after $OMP WORKSHARE statement at %C");
+ return MATCH_ERROR;
+ }
new_st.op = EXEC_OMP_WORKSHARE;
new_st.ext.omp_clauses = gfc_get_omp_clauses ();
return MATCH_YES;
gfc_match_omp_master (void)
{
if (gfc_match_omp_eos () != MATCH_YES)
- return MATCH_ERROR;
+ {
+ gfc_error ("Unexpected junk after $OMP MASTER statement at %C");
+ return MATCH_ERROR;
+ }
new_st.op = EXEC_OMP_MASTER;
new_st.ext.omp_clauses = NULL;
return MATCH_YES;
gfc_match_omp_ordered (void)
{
if (gfc_match_omp_eos () != MATCH_YES)
- return MATCH_ERROR;
+ {
+ gfc_error ("Unexpected junk after $OMP ORDERED statement at %C");
+ return MATCH_ERROR;
+ }
new_st.op = EXEC_OMP_ORDERED;
new_st.ext.omp_clauses = NULL;
return MATCH_YES;
gfc_match_omp_atomic (void)
{
if (gfc_match_omp_eos () != MATCH_YES)
- return MATCH_ERROR;
+ {
+ gfc_error ("Unexpected junk after $OMP ATOMIC statement at %C");
+ return MATCH_ERROR;
+ }
new_st.op = EXEC_OMP_ATOMIC;
new_st.ext.omp_clauses = NULL;
return MATCH_YES;
gfc_match_omp_barrier (void)
{
if (gfc_match_omp_eos () != MATCH_YES)
- return MATCH_ERROR;
+ {
+ gfc_error ("Unexpected junk after $OMP BARRIER statement at %C");
+ return MATCH_ERROR;
+ }
new_st.op = EXEC_OMP_BARRIER;
new_st.ext.omp_clauses = NULL;
return MATCH_YES;
if (gfc_match ("% nowait") == MATCH_YES)
nowait = true;
if (gfc_match_omp_eos () != MATCH_YES)
- return MATCH_ERROR;
+ {
+ gfc_error ("Unexpected junk after NOWAIT clause at %C");
+ return MATCH_ERROR;
+ }
new_st.op = EXEC_OMP_END_NOWAIT;
new_st.ext.omp_bool = nowait;
return MATCH_YES;
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;
+ }
+ if (n->sym->attr.proc_pointer)
+ 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",
+ if (n->sym->ts.type == BT_DERIVED && n->sym->ts.u.derived->attr.alloc_comp)
+ gfc_error ("COPYIN clause object '%s' at %L has ALLOCATABLE components",
n->sym->name, &code->loc);
}
break;
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.u.derived->attr.alloc_comp)
+ gfc_error ("COPYPRIVATE clause object '%s' at %L has ALLOCATABLE components",
+ n->sym->name, &code->loc);
}
break;
case OMP_LIST_SHARED:
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",
+ /* 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.u.derived->attr.alloc_comp)
+ gfc_error ("%s clause object '%s' has ALLOCATABLE components at %L",
name, n->sym->name, &code->loc);
if (n->sym->attr.cray_pointer)
gfc_error ("Cray pointer '%s' in %s clause at %L",
case OMP_LIST_MULT:
case OMP_LIST_SUB:
if (!gfc_numeric_ts (&n->sym->ts))
- gfc_error ("%c REDUCTION variable '%s' is %s at %L",
+ gfc_error ("%c REDUCTION variable '%s' at %L must be of numeric type, got %s",
list == OMP_LIST_PLUS ? '+'
: list == OMP_LIST_MULT ? '*' : '-',
- n->sym->name, gfc_typename (&n->sym->ts),
- &code->loc);
+ n->sym->name, &code->loc,
+ gfc_typename (&n->sym->ts));
break;
case OMP_LIST_AND:
case OMP_LIST_OR:
gcc_assert (code->op == EXEC_ASSIGN);
gcc_assert (code->next == NULL);
- if (code->expr->expr_type != EXPR_VARIABLE
- || code->expr->symtree == NULL
- || code->expr->rank != 0
- || (code->expr->ts.type != BT_INTEGER
- && code->expr->ts.type != BT_REAL
- && code->expr->ts.type != BT_COMPLEX
- && code->expr->ts.type != BT_LOGICAL))
+ if (code->expr1->expr_type != EXPR_VARIABLE
+ || code->expr1->symtree == NULL
+ || code->expr1->rank != 0
+ || (code->expr1->ts.type != BT_INTEGER
+ && code->expr1->ts.type != BT_REAL
+ && code->expr1->ts.type != BT_COMPLEX
+ && code->expr1->ts.type != BT_LOGICAL))
{
gfc_error ("!$OMP ATOMIC statement must set a scalar variable of "
"intrinsic type at %L", &code->loc);
return;
}
- var = code->expr->symtree->n.sym;
+ var = code->expr1->symtree->n.sym;
expr2 = is_conversion (code->expr2, false);
if (expr2 == NULL)
expr2 = code->expr2;
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;
}
void
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;
- for (ctx = omp_current_ctx; ctx; ctx = ctx->previous)
+ while (i-- >= 1)
{
- if (pointer_set_contains (ctx->sharing_clauses, sym))
- continue;
+ if (code == c)
+ return;
- if (! pointer_set_insert (ctx->private_iterators, sym))
- {
- gfc_omp_clauses *omp_clauses = ctx->code->ext.omp_clauses;
- gfc_namelist *p;
+ c = c->block->next;
+ }
- p = gfc_get_namelist ();
- p->sym = sym;
- p->next = omp_clauses->lists[OMP_LIST_PRIVATE];
- omp_clauses->lists[OMP_LIST_PRIVATE] = p;
- }
+ if (omp_current_ctx == NULL)
+ return;
+
+ if (pointer_set_contains (omp_current_ctx->sharing_clauses, sym))
+ return;
+
+ if (! pointer_set_insert (omp_current_ctx->private_iterators, sym))
+ {
+ gfc_omp_clauses *omp_clauses = omp_current_ctx->code->ext.omp_clauses;
+ gfc_namelist *p;
+
+ p = gfc_get_namelist ();
+ p->sym = sym;
+ p->next = omp_clauses->lists[OMP_LIST_PRIVATE];
+ omp_clauses->lists[OMP_LIST_PRIVATE] = p;
}
}
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;
+ }
}
}
void
gfc_resolve_omp_directive (gfc_code *code, gfc_namespace *ns ATTRIBUTE_UNUSED)
{
+ if (code->op != EXEC_OMP_ATOMIC)
+ gfc_maybe_initialize_eh ();
+
switch (code->op)
{
case EXEC_OMP_DO:
OSDN Git Service
