/* OpenMP directive matching and resolving.
|
/* OpenMP directive matching and resolving.
|
Copyright (C) 2005, 2006, 2007, 2008, 2010
|
Copyright (C) 2005, 2006, 2007, 2008, 2010
|
Free Software Foundation, Inc.
|
Free Software Foundation, Inc.
|
Contributed by Jakub Jelinek
|
Contributed by Jakub Jelinek
|
|
|
This file is part of GCC.
|
This file is part of GCC.
|
|
|
GCC is free software; you can redistribute it and/or modify it under
|
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
|
the terms of the GNU General Public License as published by the Free
|
Software Foundation; either version 3, or (at your option) any later
|
Software Foundation; either version 3, or (at your option) any later
|
version.
|
version.
|
|
|
GCC is distributed in the hope that it will be useful, but WITHOUT ANY
|
GCC is distributed in the hope that it will be useful, but WITHOUT ANY
|
WARRANTY; without even the implied warranty of MERCHANTABILITY or
|
WARRANTY; without even the implied warranty of MERCHANTABILITY or
|
FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
|
FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
|
for more details.
|
for more details.
|
|
|
You should have received a copy of the GNU General Public License
|
You should have received a copy of the GNU General Public License
|
along with GCC; see the file COPYING3. If not see
|
along with GCC; see the file COPYING3. If not see
|
<http://www.gnu.org/licenses/>. */
|
<http://www.gnu.org/licenses/>. */
|
|
|
#include "config.h"
|
#include "config.h"
|
#include "system.h"
|
#include "system.h"
|
#include "flags.h"
|
#include "flags.h"
|
#include "gfortran.h"
|
#include "gfortran.h"
|
#include "match.h"
|
#include "match.h"
|
#include "parse.h"
|
#include "parse.h"
|
#include "pointer-set.h"
|
#include "pointer-set.h"
|
#include "target.h"
|
#include "target.h"
|
#include "toplev.h"
|
#include "toplev.h"
|
|
|
/* Match an end of OpenMP directive. End of OpenMP directive is optional
|
/* Match an end of OpenMP directive. End of OpenMP directive is optional
|
whitespace, followed by '\n' or comment '!'. */
|
whitespace, followed by '\n' or comment '!'. */
|
|
|
match
|
match
|
gfc_match_omp_eos (void)
|
gfc_match_omp_eos (void)
|
{
|
{
|
locus old_loc;
|
locus old_loc;
|
char c;
|
char c;
|
|
|
old_loc = gfc_current_locus;
|
old_loc = gfc_current_locus;
|
gfc_gobble_whitespace ();
|
gfc_gobble_whitespace ();
|
|
|
c = gfc_next_ascii_char ();
|
c = gfc_next_ascii_char ();
|
switch (c)
|
switch (c)
|
{
|
{
|
case '!':
|
case '!':
|
do
|
do
|
c = gfc_next_ascii_char ();
|
c = gfc_next_ascii_char ();
|
while (c != '\n');
|
while (c != '\n');
|
/* Fall through */
|
/* Fall through */
|
|
|
case '\n':
|
case '\n':
|
return MATCH_YES;
|
return MATCH_YES;
|
}
|
}
|
|
|
gfc_current_locus = old_loc;
|
gfc_current_locus = old_loc;
|
return MATCH_NO;
|
return MATCH_NO;
|
}
|
}
|
|
|
/* Free an omp_clauses structure. */
|
/* Free an omp_clauses structure. */
|
|
|
void
|
void
|
gfc_free_omp_clauses (gfc_omp_clauses *c)
|
gfc_free_omp_clauses (gfc_omp_clauses *c)
|
{
|
{
|
int i;
|
int i;
|
if (c == NULL)
|
if (c == NULL)
|
return;
|
return;
|
|
|
gfc_free_expr (c->if_expr);
|
gfc_free_expr (c->if_expr);
|
gfc_free_expr (c->num_threads);
|
gfc_free_expr (c->num_threads);
|
gfc_free_expr (c->chunk_size);
|
gfc_free_expr (c->chunk_size);
|
for (i = 0; i < OMP_LIST_NUM; i++)
|
for (i = 0; i < OMP_LIST_NUM; i++)
|
gfc_free_namelist (c->lists[i]);
|
gfc_free_namelist (c->lists[i]);
|
gfc_free (c);
|
gfc_free (c);
|
}
|
}
|
|
|
/* Match a variable/common block list and construct a namelist from it. */
|
/* Match a variable/common block list and construct a namelist from it. */
|
|
|
static match
|
static match
|
gfc_match_omp_variable_list (const char *str, gfc_namelist **list,
|
gfc_match_omp_variable_list (const char *str, gfc_namelist **list,
|
bool allow_common)
|
bool allow_common)
|
{
|
{
|
gfc_namelist *head, *tail, *p;
|
gfc_namelist *head, *tail, *p;
|
locus old_loc;
|
locus old_loc;
|
char n[GFC_MAX_SYMBOL_LEN+1];
|
char n[GFC_MAX_SYMBOL_LEN+1];
|
gfc_symbol *sym;
|
gfc_symbol *sym;
|
match m;
|
match m;
|
gfc_symtree *st;
|
gfc_symtree *st;
|
|
|
head = tail = NULL;
|
head = tail = NULL;
|
|
|
old_loc = gfc_current_locus;
|
old_loc = gfc_current_locus;
|
|
|
m = gfc_match (str);
|
m = gfc_match (str);
|
if (m != MATCH_YES)
|
if (m != MATCH_YES)
|
return m;
|
return m;
|
|
|
for (;;)
|
for (;;)
|
{
|
{
|
m = gfc_match_symbol (&sym, 1);
|
m = gfc_match_symbol (&sym, 1);
|
switch (m)
|
switch (m)
|
{
|
{
|
case MATCH_YES:
|
case MATCH_YES:
|
gfc_set_sym_referenced (sym);
|
gfc_set_sym_referenced (sym);
|
p = gfc_get_namelist ();
|
p = gfc_get_namelist ();
|
if (head == NULL)
|
if (head == NULL)
|
head = tail = p;
|
head = tail = p;
|
else
|
else
|
{
|
{
|
tail->next = p;
|
tail->next = p;
|
tail = tail->next;
|
tail = tail->next;
|
}
|
}
|
tail->sym = sym;
|
tail->sym = sym;
|
goto next_item;
|
goto next_item;
|
case MATCH_NO:
|
case MATCH_NO:
|
break;
|
break;
|
case MATCH_ERROR:
|
case MATCH_ERROR:
|
goto cleanup;
|
goto cleanup;
|
}
|
}
|
|
|
if (!allow_common)
|
if (!allow_common)
|
goto syntax;
|
goto syntax;
|
|
|
m = gfc_match (" / %n /", n);
|
m = gfc_match (" / %n /", n);
|
if (m == MATCH_ERROR)
|
if (m == MATCH_ERROR)
|
goto cleanup;
|
goto cleanup;
|
if (m == MATCH_NO)
|
if (m == MATCH_NO)
|
goto syntax;
|
goto syntax;
|
|
|
st = gfc_find_symtree (gfc_current_ns->common_root, n);
|
st = gfc_find_symtree (gfc_current_ns->common_root, n);
|
if (st == NULL)
|
if (st == NULL)
|
{
|
{
|
gfc_error ("COMMON block /%s/ not found at %C", n);
|
gfc_error ("COMMON block /%s/ not found at %C", n);
|
goto cleanup;
|
goto cleanup;
|
}
|
}
|
for (sym = st->n.common->head; sym; sym = sym->common_next)
|
for (sym = st->n.common->head; sym; sym = sym->common_next)
|
{
|
{
|
gfc_set_sym_referenced (sym);
|
gfc_set_sym_referenced (sym);
|
p = gfc_get_namelist ();
|
p = gfc_get_namelist ();
|
if (head == NULL)
|
if (head == NULL)
|
head = tail = p;
|
head = tail = p;
|
else
|
else
|
{
|
{
|
tail->next = p;
|
tail->next = p;
|
tail = tail->next;
|
tail = tail->next;
|
}
|
}
|
tail->sym = sym;
|
tail->sym = sym;
|
}
|
}
|
|
|
next_item:
|
next_item:
|
if (gfc_match_char (')') == MATCH_YES)
|
if (gfc_match_char (')') == MATCH_YES)
|
break;
|
break;
|
if (gfc_match_char (',') != MATCH_YES)
|
if (gfc_match_char (',') != MATCH_YES)
|
goto syntax;
|
goto syntax;
|
}
|
}
|
|
|
while (*list)
|
while (*list)
|
list = &(*list)->next;
|
list = &(*list)->next;
|
|
|
*list = head;
|
*list = head;
|
return MATCH_YES;
|
return MATCH_YES;
|
|
|
syntax:
|
syntax:
|
gfc_error ("Syntax error in OpenMP variable list at %C");
|
gfc_error ("Syntax error in OpenMP variable list at %C");
|
|
|
cleanup:
|
cleanup:
|
gfc_free_namelist (head);
|
gfc_free_namelist (head);
|
gfc_current_locus = old_loc;
|
gfc_current_locus = old_loc;
|
return MATCH_ERROR;
|
return MATCH_ERROR;
|
}
|
}
|
|
|
#define OMP_CLAUSE_PRIVATE (1 << 0)
|
#define OMP_CLAUSE_PRIVATE (1 << 0)
|
#define OMP_CLAUSE_FIRSTPRIVATE (1 << 1)
|
#define OMP_CLAUSE_FIRSTPRIVATE (1 << 1)
|
#define OMP_CLAUSE_LASTPRIVATE (1 << 2)
|
#define OMP_CLAUSE_LASTPRIVATE (1 << 2)
|
#define OMP_CLAUSE_COPYPRIVATE (1 << 3)
|
#define OMP_CLAUSE_COPYPRIVATE (1 << 3)
|
#define OMP_CLAUSE_SHARED (1 << 4)
|
#define OMP_CLAUSE_SHARED (1 << 4)
|
#define OMP_CLAUSE_COPYIN (1 << 5)
|
#define OMP_CLAUSE_COPYIN (1 << 5)
|
#define OMP_CLAUSE_REDUCTION (1 << 6)
|
#define OMP_CLAUSE_REDUCTION (1 << 6)
|
#define OMP_CLAUSE_IF (1 << 7)
|
#define OMP_CLAUSE_IF (1 << 7)
|
#define OMP_CLAUSE_NUM_THREADS (1 << 8)
|
#define OMP_CLAUSE_NUM_THREADS (1 << 8)
|
#define OMP_CLAUSE_SCHEDULE (1 << 9)
|
#define OMP_CLAUSE_SCHEDULE (1 << 9)
|
#define OMP_CLAUSE_DEFAULT (1 << 10)
|
#define OMP_CLAUSE_DEFAULT (1 << 10)
|
#define OMP_CLAUSE_ORDERED (1 << 11)
|
#define OMP_CLAUSE_ORDERED (1 << 11)
|
#define OMP_CLAUSE_COLLAPSE (1 << 12)
|
#define OMP_CLAUSE_COLLAPSE (1 << 12)
|
#define OMP_CLAUSE_UNTIED (1 << 13)
|
#define OMP_CLAUSE_UNTIED (1 << 13)
|
|
|
/* Match OpenMP directive clauses. MASK is a bitmask of
|
/* Match OpenMP directive clauses. MASK is a bitmask of
|
clauses that are allowed for a particular directive. */
|
clauses that are allowed for a particular directive. */
|
|
|
static match
|
static match
|
gfc_match_omp_clauses (gfc_omp_clauses **cp, int mask)
|
gfc_match_omp_clauses (gfc_omp_clauses **cp, int mask)
|
{
|
{
|
gfc_omp_clauses *c = gfc_get_omp_clauses ();
|
gfc_omp_clauses *c = gfc_get_omp_clauses ();
|
locus old_loc;
|
locus old_loc;
|
bool needs_space = true, first = true;
|
bool needs_space = true, first = true;
|
|
|
*cp = NULL;
|
*cp = NULL;
|
while (1)
|
while (1)
|
{
|
{
|
if ((first || gfc_match_char (',') != MATCH_YES)
|
if ((first || gfc_match_char (',') != MATCH_YES)
|
&& (needs_space && gfc_match_space () != MATCH_YES))
|
&& (needs_space && gfc_match_space () != MATCH_YES))
|
break;
|
break;
|
needs_space = false;
|
needs_space = false;
|
first = false;
|
first = false;
|
gfc_gobble_whitespace ();
|
gfc_gobble_whitespace ();
|
if ((mask & OMP_CLAUSE_IF) && c->if_expr == NULL
|
if ((mask & OMP_CLAUSE_IF) && c->if_expr == NULL
|
&& gfc_match ("if ( %e )", &c->if_expr) == MATCH_YES)
|
&& gfc_match ("if ( %e )", &c->if_expr) == MATCH_YES)
|
continue;
|
continue;
|
if ((mask & OMP_CLAUSE_NUM_THREADS) && c->num_threads == NULL
|
if ((mask & OMP_CLAUSE_NUM_THREADS) && c->num_threads == NULL
|
&& gfc_match ("num_threads ( %e )", &c->num_threads) == MATCH_YES)
|
&& gfc_match ("num_threads ( %e )", &c->num_threads) == MATCH_YES)
|
continue;
|
continue;
|
if ((mask & OMP_CLAUSE_PRIVATE)
|
if ((mask & OMP_CLAUSE_PRIVATE)
|
&& gfc_match_omp_variable_list ("private (",
|
&& gfc_match_omp_variable_list ("private (",
|
&c->lists[OMP_LIST_PRIVATE], true)
|
&c->lists[OMP_LIST_PRIVATE], true)
|
== MATCH_YES)
|
== MATCH_YES)
|
continue;
|
continue;
|
if ((mask & OMP_CLAUSE_FIRSTPRIVATE)
|
if ((mask & OMP_CLAUSE_FIRSTPRIVATE)
|
&& gfc_match_omp_variable_list ("firstprivate (",
|
&& gfc_match_omp_variable_list ("firstprivate (",
|
&c->lists[OMP_LIST_FIRSTPRIVATE],
|
&c->lists[OMP_LIST_FIRSTPRIVATE],
|
true)
|
true)
|
== MATCH_YES)
|
== MATCH_YES)
|
continue;
|
continue;
|
if ((mask & OMP_CLAUSE_LASTPRIVATE)
|
if ((mask & OMP_CLAUSE_LASTPRIVATE)
|
&& gfc_match_omp_variable_list ("lastprivate (",
|
&& gfc_match_omp_variable_list ("lastprivate (",
|
&c->lists[OMP_LIST_LASTPRIVATE],
|
&c->lists[OMP_LIST_LASTPRIVATE],
|
true)
|
true)
|
== MATCH_YES)
|
== MATCH_YES)
|
continue;
|
continue;
|
if ((mask & OMP_CLAUSE_COPYPRIVATE)
|
if ((mask & OMP_CLAUSE_COPYPRIVATE)
|
&& gfc_match_omp_variable_list ("copyprivate (",
|
&& gfc_match_omp_variable_list ("copyprivate (",
|
&c->lists[OMP_LIST_COPYPRIVATE],
|
&c->lists[OMP_LIST_COPYPRIVATE],
|
true)
|
true)
|
== MATCH_YES)
|
== MATCH_YES)
|
continue;
|
continue;
|
if ((mask & OMP_CLAUSE_SHARED)
|
if ((mask & OMP_CLAUSE_SHARED)
|
&& gfc_match_omp_variable_list ("shared (",
|
&& gfc_match_omp_variable_list ("shared (",
|
&c->lists[OMP_LIST_SHARED], true)
|
&c->lists[OMP_LIST_SHARED], true)
|
== MATCH_YES)
|
== MATCH_YES)
|
continue;
|
continue;
|
if ((mask & OMP_CLAUSE_COPYIN)
|
if ((mask & OMP_CLAUSE_COPYIN)
|
&& gfc_match_omp_variable_list ("copyin (",
|
&& gfc_match_omp_variable_list ("copyin (",
|
&c->lists[OMP_LIST_COPYIN], true)
|
&c->lists[OMP_LIST_COPYIN], true)
|
== MATCH_YES)
|
== MATCH_YES)
|
continue;
|
continue;
|
old_loc = gfc_current_locus;
|
old_loc = gfc_current_locus;
|
if ((mask & OMP_CLAUSE_REDUCTION)
|
if ((mask & OMP_CLAUSE_REDUCTION)
|
&& gfc_match ("reduction ( ") == MATCH_YES)
|
&& gfc_match ("reduction ( ") == MATCH_YES)
|
{
|
{
|
int reduction = OMP_LIST_NUM;
|
int reduction = OMP_LIST_NUM;
|
char buffer[GFC_MAX_SYMBOL_LEN + 1];
|
char buffer[GFC_MAX_SYMBOL_LEN + 1];
|
if (gfc_match_char ('+') == MATCH_YES)
|
if (gfc_match_char ('+') == MATCH_YES)
|
reduction = OMP_LIST_PLUS;
|
reduction = OMP_LIST_PLUS;
|
else if (gfc_match_char ('*') == MATCH_YES)
|
else if (gfc_match_char ('*') == MATCH_YES)
|
reduction = OMP_LIST_MULT;
|
reduction = OMP_LIST_MULT;
|
else if (gfc_match_char ('-') == MATCH_YES)
|
else if (gfc_match_char ('-') == MATCH_YES)
|
reduction = OMP_LIST_SUB;
|
reduction = OMP_LIST_SUB;
|
else if (gfc_match (".and.") == MATCH_YES)
|
else if (gfc_match (".and.") == MATCH_YES)
|
reduction = OMP_LIST_AND;
|
reduction = OMP_LIST_AND;
|
else if (gfc_match (".or.") == MATCH_YES)
|
else if (gfc_match (".or.") == MATCH_YES)
|
reduction = OMP_LIST_OR;
|
reduction = OMP_LIST_OR;
|
else if (gfc_match (".eqv.") == MATCH_YES)
|
else if (gfc_match (".eqv.") == MATCH_YES)
|
reduction = OMP_LIST_EQV;
|
reduction = OMP_LIST_EQV;
|
else if (gfc_match (".neqv.") == MATCH_YES)
|
else if (gfc_match (".neqv.") == MATCH_YES)
|
reduction = OMP_LIST_NEQV;
|
reduction = OMP_LIST_NEQV;
|
else if (gfc_match_name (buffer) == MATCH_YES)
|
else if (gfc_match_name (buffer) == MATCH_YES)
|
{
|
{
|
gfc_symbol *sym;
|
gfc_symbol *sym;
|
const char *n = buffer;
|
const char *n = buffer;
|
|
|
gfc_find_symbol (buffer, NULL, 1, &sym);
|
gfc_find_symbol (buffer, NULL, 1, &sym);
|
if (sym != NULL)
|
if (sym != NULL)
|
{
|
{
|
if (sym->attr.intrinsic)
|
if (sym->attr.intrinsic)
|
n = sym->name;
|
n = sym->name;
|
else if ((sym->attr.flavor != FL_UNKNOWN
|
else if ((sym->attr.flavor != FL_UNKNOWN
|
&& sym->attr.flavor != FL_PROCEDURE)
|
&& sym->attr.flavor != FL_PROCEDURE)
|
|| sym->attr.external
|
|| sym->attr.external
|
|| sym->attr.generic
|
|| sym->attr.generic
|
|| sym->attr.entry
|
|| sym->attr.entry
|
|| sym->attr.result
|
|| sym->attr.result
|
|| sym->attr.dummy
|
|| sym->attr.dummy
|
|| sym->attr.subroutine
|
|| sym->attr.subroutine
|
|| sym->attr.pointer
|
|| sym->attr.pointer
|
|| sym->attr.target
|
|| sym->attr.target
|
|| sym->attr.cray_pointer
|
|| sym->attr.cray_pointer
|
|| sym->attr.cray_pointee
|
|| sym->attr.cray_pointee
|
|| (sym->attr.proc != PROC_UNKNOWN
|
|| (sym->attr.proc != PROC_UNKNOWN
|
&& sym->attr.proc != PROC_INTRINSIC)
|
&& sym->attr.proc != PROC_INTRINSIC)
|
|| sym->attr.if_source != IFSRC_UNKNOWN
|
|| sym->attr.if_source != IFSRC_UNKNOWN
|
|| sym == sym->ns->proc_name)
|
|| sym == sym->ns->proc_name)
|
{
|
{
|
gfc_error_now ("%s is not INTRINSIC procedure name "
|
gfc_error_now ("%s is not INTRINSIC procedure name "
|
"at %C", buffer);
|
"at %C", buffer);
|
sym = NULL;
|
sym = NULL;
|
}
|
}
|
else
|
else
|
n = sym->name;
|
n = sym->name;
|
}
|
}
|
if (strcmp (n, "max") == 0)
|
if (strcmp (n, "max") == 0)
|
reduction = OMP_LIST_MAX;
|
reduction = OMP_LIST_MAX;
|
else if (strcmp (n, "min") == 0)
|
else if (strcmp (n, "min") == 0)
|
reduction = OMP_LIST_MIN;
|
reduction = OMP_LIST_MIN;
|
else if (strcmp (n, "iand") == 0)
|
else if (strcmp (n, "iand") == 0)
|
reduction = OMP_LIST_IAND;
|
reduction = OMP_LIST_IAND;
|
else if (strcmp (n, "ior") == 0)
|
else if (strcmp (n, "ior") == 0)
|
reduction = OMP_LIST_IOR;
|
reduction = OMP_LIST_IOR;
|
else if (strcmp (n, "ieor") == 0)
|
else if (strcmp (n, "ieor") == 0)
|
reduction = OMP_LIST_IEOR;
|
reduction = OMP_LIST_IEOR;
|
if (reduction != OMP_LIST_NUM
|
if (reduction != OMP_LIST_NUM
|
&& sym != NULL
|
&& sym != NULL
|
&& ! sym->attr.intrinsic
|
&& ! sym->attr.intrinsic
|
&& ! sym->attr.use_assoc
|
&& ! sym->attr.use_assoc
|
&& ((sym->attr.flavor == FL_UNKNOWN
|
&& ((sym->attr.flavor == FL_UNKNOWN
|
&& gfc_add_flavor (&sym->attr, FL_PROCEDURE,
|
&& gfc_add_flavor (&sym->attr, FL_PROCEDURE,
|
sym->name, NULL) == FAILURE)
|
sym->name, NULL) == FAILURE)
|
|| gfc_add_intrinsic (&sym->attr, NULL) == FAILURE))
|
|| gfc_add_intrinsic (&sym->attr, NULL) == FAILURE))
|
{
|
{
|
gfc_free_omp_clauses (c);
|
gfc_free_omp_clauses (c);
|
return MATCH_ERROR;
|
return MATCH_ERROR;
|
}
|
}
|
}
|
}
|
if (reduction != OMP_LIST_NUM
|
if (reduction != OMP_LIST_NUM
|
&& gfc_match_omp_variable_list (" :", &c->lists[reduction],
|
&& gfc_match_omp_variable_list (" :", &c->lists[reduction],
|
false)
|
false)
|
== MATCH_YES)
|
== MATCH_YES)
|
continue;
|
continue;
|
else
|
else
|
gfc_current_locus = old_loc;
|
gfc_current_locus = old_loc;
|
}
|
}
|
if ((mask & OMP_CLAUSE_DEFAULT)
|
if ((mask & OMP_CLAUSE_DEFAULT)
|
&& c->default_sharing == OMP_DEFAULT_UNKNOWN)
|
&& c->default_sharing == OMP_DEFAULT_UNKNOWN)
|
{
|
{
|
if (gfc_match ("default ( shared )") == MATCH_YES)
|
if (gfc_match ("default ( shared )") == MATCH_YES)
|
c->default_sharing = OMP_DEFAULT_SHARED;
|
c->default_sharing = OMP_DEFAULT_SHARED;
|
else if (gfc_match ("default ( private )") == MATCH_YES)
|
else if (gfc_match ("default ( private )") == MATCH_YES)
|
c->default_sharing = OMP_DEFAULT_PRIVATE;
|
c->default_sharing = OMP_DEFAULT_PRIVATE;
|
else if (gfc_match ("default ( none )") == MATCH_YES)
|
else if (gfc_match ("default ( none )") == MATCH_YES)
|
c->default_sharing = OMP_DEFAULT_NONE;
|
c->default_sharing = OMP_DEFAULT_NONE;
|
else if (gfc_match ("default ( firstprivate )") == MATCH_YES)
|
else if (gfc_match ("default ( firstprivate )") == MATCH_YES)
|
c->default_sharing = OMP_DEFAULT_FIRSTPRIVATE;
|
c->default_sharing = OMP_DEFAULT_FIRSTPRIVATE;
|
if (c->default_sharing != OMP_DEFAULT_UNKNOWN)
|
if (c->default_sharing != OMP_DEFAULT_UNKNOWN)
|
continue;
|
continue;
|
}
|
}
|
old_loc = gfc_current_locus;
|
old_loc = gfc_current_locus;
|
if ((mask & OMP_CLAUSE_SCHEDULE)
|
if ((mask & OMP_CLAUSE_SCHEDULE)
|
&& c->sched_kind == OMP_SCHED_NONE
|
&& c->sched_kind == OMP_SCHED_NONE
|
&& gfc_match ("schedule ( ") == MATCH_YES)
|
&& gfc_match ("schedule ( ") == MATCH_YES)
|
{
|
{
|
if (gfc_match ("static") == MATCH_YES)
|
if (gfc_match ("static") == MATCH_YES)
|
c->sched_kind = OMP_SCHED_STATIC;
|
c->sched_kind = OMP_SCHED_STATIC;
|
else if (gfc_match ("dynamic") == MATCH_YES)
|
else if (gfc_match ("dynamic") == MATCH_YES)
|
c->sched_kind = OMP_SCHED_DYNAMIC;
|
c->sched_kind = OMP_SCHED_DYNAMIC;
|
else if (gfc_match ("guided") == MATCH_YES)
|
else if (gfc_match ("guided") == MATCH_YES)
|
c->sched_kind = OMP_SCHED_GUIDED;
|
c->sched_kind = OMP_SCHED_GUIDED;
|
else if (gfc_match ("runtime") == MATCH_YES)
|
else if (gfc_match ("runtime") == MATCH_YES)
|
c->sched_kind = OMP_SCHED_RUNTIME;
|
c->sched_kind = OMP_SCHED_RUNTIME;
|
else if (gfc_match ("auto") == MATCH_YES)
|
else if (gfc_match ("auto") == MATCH_YES)
|
c->sched_kind = OMP_SCHED_AUTO;
|
c->sched_kind = OMP_SCHED_AUTO;
|
if (c->sched_kind != OMP_SCHED_NONE)
|
if (c->sched_kind != OMP_SCHED_NONE)
|
{
|
{
|
match m = MATCH_NO;
|
match m = MATCH_NO;
|
if (c->sched_kind != OMP_SCHED_RUNTIME
|
if (c->sched_kind != OMP_SCHED_RUNTIME
|
&& c->sched_kind != OMP_SCHED_AUTO)
|
&& c->sched_kind != OMP_SCHED_AUTO)
|
m = gfc_match (" , %e )", &c->chunk_size);
|
m = gfc_match (" , %e )", &c->chunk_size);
|
if (m != MATCH_YES)
|
if (m != MATCH_YES)
|
m = gfc_match_char (')');
|
m = gfc_match_char (')');
|
if (m != MATCH_YES)
|
if (m != MATCH_YES)
|
c->sched_kind = OMP_SCHED_NONE;
|
c->sched_kind = OMP_SCHED_NONE;
|
}
|
}
|
if (c->sched_kind != OMP_SCHED_NONE)
|
if (c->sched_kind != OMP_SCHED_NONE)
|
continue;
|
continue;
|
else
|
else
|
gfc_current_locus = old_loc;
|
gfc_current_locus = old_loc;
|
}
|
}
|
if ((mask & OMP_CLAUSE_ORDERED) && !c->ordered
|
if ((mask & OMP_CLAUSE_ORDERED) && !c->ordered
|
&& gfc_match ("ordered") == MATCH_YES)
|
&& gfc_match ("ordered") == MATCH_YES)
|
{
|
{
|
c->ordered = needs_space = true;
|
c->ordered = needs_space = true;
|
continue;
|
continue;
|
}
|
}
|
if ((mask & OMP_CLAUSE_UNTIED) && !c->untied
|
if ((mask & OMP_CLAUSE_UNTIED) && !c->untied
|
&& gfc_match ("untied") == MATCH_YES)
|
&& gfc_match ("untied") == MATCH_YES)
|
{
|
{
|
c->untied = needs_space = true;
|
c->untied = needs_space = true;
|
continue;
|
continue;
|
}
|
}
|
if ((mask & OMP_CLAUSE_COLLAPSE) && !c->collapse)
|
if ((mask & OMP_CLAUSE_COLLAPSE) && !c->collapse)
|
{
|
{
|
gfc_expr *cexpr = NULL;
|
gfc_expr *cexpr = NULL;
|
match m = gfc_match ("collapse ( %e )", &cexpr);
|
match m = gfc_match ("collapse ( %e )", &cexpr);
|
|
|
if (m == MATCH_YES)
|
if (m == MATCH_YES)
|
{
|
{
|
int collapse;
|
int collapse;
|
const char *p = gfc_extract_int (cexpr, &collapse);
|
const char *p = gfc_extract_int (cexpr, &collapse);
|
if (p)
|
if (p)
|
{
|
{
|
gfc_error_now (p);
|
gfc_error_now (p);
|
collapse = 1;
|
collapse = 1;
|
}
|
}
|
else if (collapse <= 0)
|
else if (collapse <= 0)
|
{
|
{
|
gfc_error_now ("COLLAPSE clause argument not"
|
gfc_error_now ("COLLAPSE clause argument not"
|
" constant positive integer at %C");
|
" constant positive integer at %C");
|
collapse = 1;
|
collapse = 1;
|
}
|
}
|
c->collapse = collapse;
|
c->collapse = collapse;
|
gfc_free_expr (cexpr);
|
gfc_free_expr (cexpr);
|
continue;
|
continue;
|
}
|
}
|
}
|
}
|
|
|
break;
|
break;
|
}
|
}
|
|
|
if (gfc_match_omp_eos () != MATCH_YES)
|
if (gfc_match_omp_eos () != MATCH_YES)
|
{
|
{
|
gfc_free_omp_clauses (c);
|
gfc_free_omp_clauses (c);
|
return MATCH_ERROR;
|
return MATCH_ERROR;
|
}
|
}
|
|
|
*cp = c;
|
*cp = c;
|
return MATCH_YES;
|
return MATCH_YES;
|
}
|
}
|
|
|
#define OMP_PARALLEL_CLAUSES \
|
#define OMP_PARALLEL_CLAUSES \
|
(OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_SHARED \
|
(OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_SHARED \
|
| OMP_CLAUSE_COPYIN | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_IF \
|
| OMP_CLAUSE_COPYIN | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_IF \
|
| OMP_CLAUSE_NUM_THREADS | OMP_CLAUSE_DEFAULT)
|
| OMP_CLAUSE_NUM_THREADS | OMP_CLAUSE_DEFAULT)
|
#define OMP_DO_CLAUSES \
|
#define OMP_DO_CLAUSES \
|
(OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
|
(OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
|
| OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION \
|
| OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION \
|
| OMP_CLAUSE_SCHEDULE | OMP_CLAUSE_ORDERED | OMP_CLAUSE_COLLAPSE)
|
| OMP_CLAUSE_SCHEDULE | OMP_CLAUSE_ORDERED | OMP_CLAUSE_COLLAPSE)
|
#define OMP_SECTIONS_CLAUSES \
|
#define OMP_SECTIONS_CLAUSES \
|
(OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
|
(OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
|
| OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION)
|
| OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION)
|
#define OMP_TASK_CLAUSES \
|
#define OMP_TASK_CLAUSES \
|
(OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_SHARED \
|
(OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_SHARED \
|
| OMP_CLAUSE_IF | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_UNTIED)
|
| OMP_CLAUSE_IF | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_UNTIED)
|
|
|
match
|
match
|
gfc_match_omp_parallel (void)
|
gfc_match_omp_parallel (void)
|
{
|
{
|
gfc_omp_clauses *c;
|
gfc_omp_clauses *c;
|
if (gfc_match_omp_clauses (&c, OMP_PARALLEL_CLAUSES) != MATCH_YES)
|
if (gfc_match_omp_clauses (&c, OMP_PARALLEL_CLAUSES) != MATCH_YES)
|
return MATCH_ERROR;
|
return MATCH_ERROR;
|
new_st.op = EXEC_OMP_PARALLEL;
|
new_st.op = EXEC_OMP_PARALLEL;
|
new_st.ext.omp_clauses = c;
|
new_st.ext.omp_clauses = c;
|
return MATCH_YES;
|
return MATCH_YES;
|
}
|
}
|
|
|
|
|
match
|
match
|
gfc_match_omp_task (void)
|
gfc_match_omp_task (void)
|
{
|
{
|
gfc_omp_clauses *c;
|
gfc_omp_clauses *c;
|
if (gfc_match_omp_clauses (&c, OMP_TASK_CLAUSES) != MATCH_YES)
|
if (gfc_match_omp_clauses (&c, OMP_TASK_CLAUSES) != MATCH_YES)
|
return MATCH_ERROR;
|
return MATCH_ERROR;
|
new_st.op = EXEC_OMP_TASK;
|
new_st.op = EXEC_OMP_TASK;
|
new_st.ext.omp_clauses = c;
|
new_st.ext.omp_clauses = c;
|
return MATCH_YES;
|
return MATCH_YES;
|
}
|
}
|
|
|
|
|
match
|
match
|
gfc_match_omp_taskwait (void)
|
gfc_match_omp_taskwait (void)
|
{
|
{
|
if (gfc_match_omp_eos () != MATCH_YES)
|
if (gfc_match_omp_eos () != MATCH_YES)
|
return MATCH_ERROR;
|
return MATCH_ERROR;
|
new_st.op = EXEC_OMP_TASKWAIT;
|
new_st.op = EXEC_OMP_TASKWAIT;
|
new_st.ext.omp_clauses = NULL;
|
new_st.ext.omp_clauses = NULL;
|
return MATCH_YES;
|
return MATCH_YES;
|
}
|
}
|
|
|
|
|
match
|
match
|
gfc_match_omp_critical (void)
|
gfc_match_omp_critical (void)
|
{
|
{
|
char n[GFC_MAX_SYMBOL_LEN+1];
|
char n[GFC_MAX_SYMBOL_LEN+1];
|
|
|
if (gfc_match (" ( %n )", n) != MATCH_YES)
|
if (gfc_match (" ( %n )", n) != MATCH_YES)
|
n[0] = '\0';
|
n[0] = '\0';
|
if (gfc_match_omp_eos () != MATCH_YES)
|
if (gfc_match_omp_eos () != MATCH_YES)
|
return MATCH_ERROR;
|
return MATCH_ERROR;
|
new_st.op = EXEC_OMP_CRITICAL;
|
new_st.op = EXEC_OMP_CRITICAL;
|
new_st.ext.omp_name = n[0] ? xstrdup (n) : NULL;
|
new_st.ext.omp_name = n[0] ? xstrdup (n) : NULL;
|
return MATCH_YES;
|
return MATCH_YES;
|
}
|
}
|
|
|
|
|
match
|
match
|
gfc_match_omp_do (void)
|
gfc_match_omp_do (void)
|
{
|
{
|
gfc_omp_clauses *c;
|
gfc_omp_clauses *c;
|
if (gfc_match_omp_clauses (&c, OMP_DO_CLAUSES) != MATCH_YES)
|
if (gfc_match_omp_clauses (&c, OMP_DO_CLAUSES) != MATCH_YES)
|
return MATCH_ERROR;
|
return MATCH_ERROR;
|
new_st.op = EXEC_OMP_DO;
|
new_st.op = EXEC_OMP_DO;
|
new_st.ext.omp_clauses = c;
|
new_st.ext.omp_clauses = c;
|
return MATCH_YES;
|
return MATCH_YES;
|
}
|
}
|
|
|
|
|
match
|
match
|
gfc_match_omp_flush (void)
|
gfc_match_omp_flush (void)
|
{
|
{
|
gfc_namelist *list = NULL;
|
gfc_namelist *list = NULL;
|
gfc_match_omp_variable_list (" (", &list, true);
|
gfc_match_omp_variable_list (" (", &list, true);
|
if (gfc_match_omp_eos () != MATCH_YES)
|
if (gfc_match_omp_eos () != MATCH_YES)
|
{
|
{
|
gfc_free_namelist (list);
|
gfc_free_namelist (list);
|
return MATCH_ERROR;
|
return MATCH_ERROR;
|
}
|
}
|
new_st.op = EXEC_OMP_FLUSH;
|
new_st.op = EXEC_OMP_FLUSH;
|
new_st.ext.omp_namelist = list;
|
new_st.ext.omp_namelist = list;
|
return MATCH_YES;
|
return MATCH_YES;
|
}
|
}
|
|
|
|
|
match
|
match
|
gfc_match_omp_threadprivate (void)
|
gfc_match_omp_threadprivate (void)
|
{
|
{
|
locus old_loc;
|
locus old_loc;
|
char n[GFC_MAX_SYMBOL_LEN+1];
|
char n[GFC_MAX_SYMBOL_LEN+1];
|
gfc_symbol *sym;
|
gfc_symbol *sym;
|
match m;
|
match m;
|
gfc_symtree *st;
|
gfc_symtree *st;
|
|
|
old_loc = gfc_current_locus;
|
old_loc = gfc_current_locus;
|
|
|
m = gfc_match (" (");
|
m = gfc_match (" (");
|
if (m != MATCH_YES)
|
if (m != MATCH_YES)
|
return m;
|
return m;
|
|
|
for (;;)
|
for (;;)
|
{
|
{
|
m = gfc_match_symbol (&sym, 0);
|
m = gfc_match_symbol (&sym, 0);
|
switch (m)
|
switch (m)
|
{
|
{
|
case MATCH_YES:
|
case MATCH_YES:
|
if (sym->attr.in_common)
|
if (sym->attr.in_common)
|
gfc_error_now ("Threadprivate variable at %C is an element of "
|
gfc_error_now ("Threadprivate variable at %C is an element of "
|
"a COMMON block");
|
"a COMMON block");
|
else if (gfc_add_threadprivate (&sym->attr, sym->name,
|
else if (gfc_add_threadprivate (&sym->attr, sym->name,
|
&sym->declared_at) == FAILURE)
|
&sym->declared_at) == FAILURE)
|
goto cleanup;
|
goto cleanup;
|
goto next_item;
|
goto next_item;
|
case MATCH_NO:
|
case MATCH_NO:
|
break;
|
break;
|
case MATCH_ERROR:
|
case MATCH_ERROR:
|
goto cleanup;
|
goto cleanup;
|
}
|
}
|
|
|
m = gfc_match (" / %n /", n);
|
m = gfc_match (" / %n /", n);
|
if (m == MATCH_ERROR)
|
if (m == MATCH_ERROR)
|
goto cleanup;
|
goto cleanup;
|
if (m == MATCH_NO || n[0] == '\0')
|
if (m == MATCH_NO || n[0] == '\0')
|
goto syntax;
|
goto syntax;
|
|
|
st = gfc_find_symtree (gfc_current_ns->common_root, n);
|
st = gfc_find_symtree (gfc_current_ns->common_root, n);
|
if (st == NULL)
|
if (st == NULL)
|
{
|
{
|
gfc_error ("COMMON block /%s/ not found at %C", n);
|
gfc_error ("COMMON block /%s/ not found at %C", n);
|
goto cleanup;
|
goto cleanup;
|
}
|
}
|
st->n.common->threadprivate = 1;
|
st->n.common->threadprivate = 1;
|
for (sym = st->n.common->head; sym; sym = sym->common_next)
|
for (sym = st->n.common->head; sym; sym = sym->common_next)
|
if (gfc_add_threadprivate (&sym->attr, sym->name,
|
if (gfc_add_threadprivate (&sym->attr, sym->name,
|
&sym->declared_at) == FAILURE)
|
&sym->declared_at) == FAILURE)
|
goto cleanup;
|
goto cleanup;
|
|
|
next_item:
|
next_item:
|
if (gfc_match_char (')') == MATCH_YES)
|
if (gfc_match_char (')') == MATCH_YES)
|
break;
|
break;
|
if (gfc_match_char (',') != MATCH_YES)
|
if (gfc_match_char (',') != MATCH_YES)
|
goto syntax;
|
goto syntax;
|
}
|
}
|
|
|
return MATCH_YES;
|
return MATCH_YES;
|
|
|
syntax:
|
syntax:
|
gfc_error ("Syntax error in !$OMP THREADPRIVATE list at %C");
|
gfc_error ("Syntax error in !$OMP THREADPRIVATE list at %C");
|
|
|
cleanup:
|
cleanup:
|
gfc_current_locus = old_loc;
|
gfc_current_locus = old_loc;
|
return MATCH_ERROR;
|
return MATCH_ERROR;
|
}
|
}
|
|
|
|
|
match
|
match
|
gfc_match_omp_parallel_do (void)
|
gfc_match_omp_parallel_do (void)
|
{
|
{
|
gfc_omp_clauses *c;
|
gfc_omp_clauses *c;
|
if (gfc_match_omp_clauses (&c, OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES)
|
if (gfc_match_omp_clauses (&c, OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES)
|
!= MATCH_YES)
|
!= MATCH_YES)
|
return MATCH_ERROR;
|
return MATCH_ERROR;
|
new_st.op = EXEC_OMP_PARALLEL_DO;
|
new_st.op = EXEC_OMP_PARALLEL_DO;
|
new_st.ext.omp_clauses = c;
|
new_st.ext.omp_clauses = c;
|
return MATCH_YES;
|
return MATCH_YES;
|
}
|
}
|
|
|
|
|
match
|
match
|
gfc_match_omp_parallel_sections (void)
|
gfc_match_omp_parallel_sections (void)
|
{
|
{
|
gfc_omp_clauses *c;
|
gfc_omp_clauses *c;
|
if (gfc_match_omp_clauses (&c, OMP_PARALLEL_CLAUSES | OMP_SECTIONS_CLAUSES)
|
if (gfc_match_omp_clauses (&c, OMP_PARALLEL_CLAUSES | OMP_SECTIONS_CLAUSES)
|
!= MATCH_YES)
|
!= MATCH_YES)
|
return MATCH_ERROR;
|
return MATCH_ERROR;
|
new_st.op = EXEC_OMP_PARALLEL_SECTIONS;
|
new_st.op = EXEC_OMP_PARALLEL_SECTIONS;
|
new_st.ext.omp_clauses = c;
|
new_st.ext.omp_clauses = c;
|
return MATCH_YES;
|
return MATCH_YES;
|
}
|
}
|
|
|
|
|
match
|
match
|
gfc_match_omp_parallel_workshare (void)
|
gfc_match_omp_parallel_workshare (void)
|
{
|
{
|
gfc_omp_clauses *c;
|
gfc_omp_clauses *c;
|
if (gfc_match_omp_clauses (&c, OMP_PARALLEL_CLAUSES) != MATCH_YES)
|
if (gfc_match_omp_clauses (&c, OMP_PARALLEL_CLAUSES) != MATCH_YES)
|
return MATCH_ERROR;
|
return MATCH_ERROR;
|
new_st.op = EXEC_OMP_PARALLEL_WORKSHARE;
|
new_st.op = EXEC_OMP_PARALLEL_WORKSHARE;
|
new_st.ext.omp_clauses = c;
|
new_st.ext.omp_clauses = c;
|
return MATCH_YES;
|
return MATCH_YES;
|
}
|
}
|
|
|
|
|
match
|
match
|
gfc_match_omp_sections (void)
|
gfc_match_omp_sections (void)
|
{
|
{
|
gfc_omp_clauses *c;
|
gfc_omp_clauses *c;
|
if (gfc_match_omp_clauses (&c, OMP_SECTIONS_CLAUSES) != MATCH_YES)
|
if (gfc_match_omp_clauses (&c, OMP_SECTIONS_CLAUSES) != MATCH_YES)
|
return MATCH_ERROR;
|
return MATCH_ERROR;
|
new_st.op = EXEC_OMP_SECTIONS;
|
new_st.op = EXEC_OMP_SECTIONS;
|
new_st.ext.omp_clauses = c;
|
new_st.ext.omp_clauses = c;
|
return MATCH_YES;
|
return MATCH_YES;
|
}
|
}
|
|
|
|
|
match
|
match
|
gfc_match_omp_single (void)
|
gfc_match_omp_single (void)
|
{
|
{
|
gfc_omp_clauses *c;
|
gfc_omp_clauses *c;
|
if (gfc_match_omp_clauses (&c, OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE)
|
if (gfc_match_omp_clauses (&c, OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE)
|
!= MATCH_YES)
|
!= MATCH_YES)
|
return MATCH_ERROR;
|
return MATCH_ERROR;
|
new_st.op = EXEC_OMP_SINGLE;
|
new_st.op = EXEC_OMP_SINGLE;
|
new_st.ext.omp_clauses = c;
|
new_st.ext.omp_clauses = c;
|
return MATCH_YES;
|
return MATCH_YES;
|
}
|
}
|
|
|
|
|
match
|
match
|
gfc_match_omp_workshare (void)
|
gfc_match_omp_workshare (void)
|
{
|
{
|
if (gfc_match_omp_eos () != MATCH_YES)
|
if (gfc_match_omp_eos () != MATCH_YES)
|
return MATCH_ERROR;
|
return MATCH_ERROR;
|
new_st.op = EXEC_OMP_WORKSHARE;
|
new_st.op = EXEC_OMP_WORKSHARE;
|
new_st.ext.omp_clauses = gfc_get_omp_clauses ();
|
new_st.ext.omp_clauses = gfc_get_omp_clauses ();
|
return MATCH_YES;
|
return MATCH_YES;
|
}
|
}
|
|
|
|
|
match
|
match
|
gfc_match_omp_master (void)
|
gfc_match_omp_master (void)
|
{
|
{
|
if (gfc_match_omp_eos () != MATCH_YES)
|
if (gfc_match_omp_eos () != MATCH_YES)
|
return MATCH_ERROR;
|
return MATCH_ERROR;
|
new_st.op = EXEC_OMP_MASTER;
|
new_st.op = EXEC_OMP_MASTER;
|
new_st.ext.omp_clauses = NULL;
|
new_st.ext.omp_clauses = NULL;
|
return MATCH_YES;
|
return MATCH_YES;
|
}
|
}
|
|
|
|
|
match
|
match
|
gfc_match_omp_ordered (void)
|
gfc_match_omp_ordered (void)
|
{
|
{
|
if (gfc_match_omp_eos () != MATCH_YES)
|
if (gfc_match_omp_eos () != MATCH_YES)
|
return MATCH_ERROR;
|
return MATCH_ERROR;
|
new_st.op = EXEC_OMP_ORDERED;
|
new_st.op = EXEC_OMP_ORDERED;
|
new_st.ext.omp_clauses = NULL;
|
new_st.ext.omp_clauses = NULL;
|
return MATCH_YES;
|
return MATCH_YES;
|
}
|
}
|
|
|
|
|
match
|
match
|
gfc_match_omp_atomic (void)
|
gfc_match_omp_atomic (void)
|
{
|
{
|
if (gfc_match_omp_eos () != MATCH_YES)
|
if (gfc_match_omp_eos () != MATCH_YES)
|
return MATCH_ERROR;
|
return MATCH_ERROR;
|
new_st.op = EXEC_OMP_ATOMIC;
|
new_st.op = EXEC_OMP_ATOMIC;
|
new_st.ext.omp_clauses = NULL;
|
new_st.ext.omp_clauses = NULL;
|
return MATCH_YES;
|
return MATCH_YES;
|
}
|
}
|
|
|
|
|
match
|
match
|
gfc_match_omp_barrier (void)
|
gfc_match_omp_barrier (void)
|
{
|
{
|
if (gfc_match_omp_eos () != MATCH_YES)
|
if (gfc_match_omp_eos () != MATCH_YES)
|
return MATCH_ERROR;
|
return MATCH_ERROR;
|
new_st.op = EXEC_OMP_BARRIER;
|
new_st.op = EXEC_OMP_BARRIER;
|
new_st.ext.omp_clauses = NULL;
|
new_st.ext.omp_clauses = NULL;
|
return MATCH_YES;
|
return MATCH_YES;
|
}
|
}
|
|
|
|
|
match
|
match
|
gfc_match_omp_end_nowait (void)
|
gfc_match_omp_end_nowait (void)
|
{
|
{
|
bool nowait = false;
|
bool nowait = false;
|
if (gfc_match ("% nowait") == MATCH_YES)
|
if (gfc_match ("% nowait") == MATCH_YES)
|
nowait = true;
|
nowait = true;
|
if (gfc_match_omp_eos () != MATCH_YES)
|
if (gfc_match_omp_eos () != MATCH_YES)
|
return MATCH_ERROR;
|
return MATCH_ERROR;
|
new_st.op = EXEC_OMP_END_NOWAIT;
|
new_st.op = EXEC_OMP_END_NOWAIT;
|
new_st.ext.omp_bool = nowait;
|
new_st.ext.omp_bool = nowait;
|
return MATCH_YES;
|
return MATCH_YES;
|
}
|
}
|
|
|
|
|
match
|
match
|
gfc_match_omp_end_single (void)
|
gfc_match_omp_end_single (void)
|
{
|
{
|
gfc_omp_clauses *c;
|
gfc_omp_clauses *c;
|
if (gfc_match ("% nowait") == MATCH_YES)
|
if (gfc_match ("% nowait") == MATCH_YES)
|
{
|
{
|
new_st.op = EXEC_OMP_END_NOWAIT;
|
new_st.op = EXEC_OMP_END_NOWAIT;
|
new_st.ext.omp_bool = true;
|
new_st.ext.omp_bool = true;
|
return MATCH_YES;
|
return MATCH_YES;
|
}
|
}
|
if (gfc_match_omp_clauses (&c, OMP_CLAUSE_COPYPRIVATE) != MATCH_YES)
|
if (gfc_match_omp_clauses (&c, OMP_CLAUSE_COPYPRIVATE) != MATCH_YES)
|
return MATCH_ERROR;
|
return MATCH_ERROR;
|
new_st.op = EXEC_OMP_END_SINGLE;
|
new_st.op = EXEC_OMP_END_SINGLE;
|
new_st.ext.omp_clauses = c;
|
new_st.ext.omp_clauses = c;
|
return MATCH_YES;
|
return MATCH_YES;
|
}
|
}
|
|
|
|
|
/* OpenMP directive resolving routines. */
|
/* OpenMP directive resolving routines. */
|
|
|
static void
|
static void
|
resolve_omp_clauses (gfc_code *code)
|
resolve_omp_clauses (gfc_code *code)
|
{
|
{
|
gfc_omp_clauses *omp_clauses = code->ext.omp_clauses;
|
gfc_omp_clauses *omp_clauses = code->ext.omp_clauses;
|
gfc_namelist *n;
|
gfc_namelist *n;
|
int list;
|
int list;
|
static const char *clause_names[]
|
static const char *clause_names[]
|
= { "PRIVATE", "FIRSTPRIVATE", "LASTPRIVATE", "COPYPRIVATE", "SHARED",
|
= { "PRIVATE", "FIRSTPRIVATE", "LASTPRIVATE", "COPYPRIVATE", "SHARED",
|
"COPYIN", "REDUCTION" };
|
"COPYIN", "REDUCTION" };
|
|
|
if (omp_clauses == NULL)
|
if (omp_clauses == NULL)
|
return;
|
return;
|
|
|
if (omp_clauses->if_expr)
|
if (omp_clauses->if_expr)
|
{
|
{
|
gfc_expr *expr = omp_clauses->if_expr;
|
gfc_expr *expr = omp_clauses->if_expr;
|
if (gfc_resolve_expr (expr) == FAILURE
|
if (gfc_resolve_expr (expr) == FAILURE
|
|| expr->ts.type != BT_LOGICAL || expr->rank != 0)
|
|| expr->ts.type != BT_LOGICAL || expr->rank != 0)
|
gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
|
gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
|
&expr->where);
|
&expr->where);
|
}
|
}
|
if (omp_clauses->num_threads)
|
if (omp_clauses->num_threads)
|
{
|
{
|
gfc_expr *expr = omp_clauses->num_threads;
|
gfc_expr *expr = omp_clauses->num_threads;
|
if (gfc_resolve_expr (expr) == FAILURE
|
if (gfc_resolve_expr (expr) == FAILURE
|
|| expr->ts.type != BT_INTEGER || expr->rank != 0)
|
|| expr->ts.type != BT_INTEGER || expr->rank != 0)
|
gfc_error ("NUM_THREADS clause at %L requires a scalar "
|
gfc_error ("NUM_THREADS clause at %L requires a scalar "
|
"INTEGER expression", &expr->where);
|
"INTEGER expression", &expr->where);
|
}
|
}
|
if (omp_clauses->chunk_size)
|
if (omp_clauses->chunk_size)
|
{
|
{
|
gfc_expr *expr = omp_clauses->chunk_size;
|
gfc_expr *expr = omp_clauses->chunk_size;
|
if (gfc_resolve_expr (expr) == FAILURE
|
if (gfc_resolve_expr (expr) == FAILURE
|
|| expr->ts.type != BT_INTEGER || expr->rank != 0)
|
|| expr->ts.type != BT_INTEGER || expr->rank != 0)
|
gfc_error ("SCHEDULE clause's chunk_size at %L requires "
|
gfc_error ("SCHEDULE clause's chunk_size at %L requires "
|
"a scalar INTEGER expression", &expr->where);
|
"a scalar INTEGER expression", &expr->where);
|
}
|
}
|
|
|
/* Check that no symbol appears on multiple clauses, except that
|
/* Check that no symbol appears on multiple clauses, except that
|
a symbol can appear on both firstprivate and lastprivate. */
|
a symbol can appear on both firstprivate and lastprivate. */
|
for (list = 0; list < OMP_LIST_NUM; list++)
|
for (list = 0; list < OMP_LIST_NUM; list++)
|
for (n = omp_clauses->lists[list]; n; n = n->next)
|
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)
|
if (n->sym->attr.flavor == FL_VARIABLE)
|
continue;
|
continue;
|
if (n->sym->attr.flavor == FL_PROCEDURE
|
if (n->sym->attr.flavor == FL_PROCEDURE
|
&& n->sym->result == n->sym
|
&& n->sym->result == n->sym
|
&& n->sym->attr.function)
|
&& n->sym->attr.function)
|
{
|
{
|
if (gfc_current_ns->proc_name == n->sym
|
if (gfc_current_ns->proc_name == n->sym
|
|| (gfc_current_ns->parent
|
|| (gfc_current_ns->parent
|
&& gfc_current_ns->parent->proc_name == n->sym))
|
&& gfc_current_ns->parent->proc_name == n->sym))
|
continue;
|
continue;
|
if (gfc_current_ns->proc_name->attr.entry_master)
|
if (gfc_current_ns->proc_name->attr.entry_master)
|
{
|
{
|
gfc_entry_list *el = gfc_current_ns->entries;
|
gfc_entry_list *el = gfc_current_ns->entries;
|
for (; el; el = el->next)
|
for (; el; el = el->next)
|
if (el->sym == n->sym)
|
if (el->sym == n->sym)
|
break;
|
break;
|
if (el)
|
if (el)
|
continue;
|
continue;
|
}
|
}
|
if (gfc_current_ns->parent
|
if (gfc_current_ns->parent
|
&& gfc_current_ns->parent->proc_name->attr.entry_master)
|
&& gfc_current_ns->parent->proc_name->attr.entry_master)
|
{
|
{
|
gfc_entry_list *el = gfc_current_ns->parent->entries;
|
gfc_entry_list *el = gfc_current_ns->parent->entries;
|
for (; el; el = el->next)
|
for (; el; el = el->next)
|
if (el->sym == n->sym)
|
if (el->sym == n->sym)
|
break;
|
break;
|
if (el)
|
if (el)
|
continue;
|
continue;
|
}
|
}
|
if (n->sym->attr.proc_pointer)
|
if (n->sym->attr.proc_pointer)
|
continue;
|
continue;
|
}
|
}
|
gfc_error ("Object '%s' is not a variable at %L", n->sym->name,
|
gfc_error ("Object '%s' is not a variable at %L", n->sym->name,
|
&code->loc);
|
&code->loc);
|
}
|
}
|
|
|
for (list = 0; list < OMP_LIST_NUM; list++)
|
for (list = 0; list < OMP_LIST_NUM; list++)
|
if (list != OMP_LIST_FIRSTPRIVATE && list != OMP_LIST_LASTPRIVATE)
|
if (list != OMP_LIST_FIRSTPRIVATE && list != OMP_LIST_LASTPRIVATE)
|
for (n = omp_clauses->lists[list]; n; n = n->next)
|
for (n = omp_clauses->lists[list]; n; n = n->next)
|
if (n->sym->mark)
|
if (n->sym->mark)
|
gfc_error ("Symbol '%s' present on multiple clauses at %L",
|
gfc_error ("Symbol '%s' present on multiple clauses at %L",
|
n->sym->name, &code->loc);
|
n->sym->name, &code->loc);
|
else
|
else
|
n->sym->mark = 1;
|
n->sym->mark = 1;
|
|
|
gcc_assert (OMP_LIST_LASTPRIVATE == OMP_LIST_FIRSTPRIVATE + 1);
|
gcc_assert (OMP_LIST_LASTPRIVATE == OMP_LIST_FIRSTPRIVATE + 1);
|
for (list = OMP_LIST_FIRSTPRIVATE; list <= OMP_LIST_LASTPRIVATE; list++)
|
for (list = OMP_LIST_FIRSTPRIVATE; list <= OMP_LIST_LASTPRIVATE; list++)
|
for (n = omp_clauses->lists[list]; n; n = n->next)
|
for (n = omp_clauses->lists[list]; n; n = n->next)
|
if (n->sym->mark)
|
if (n->sym->mark)
|
{
|
{
|
gfc_error ("Symbol '%s' present on multiple clauses at %L",
|
gfc_error ("Symbol '%s' present on multiple clauses at %L",
|
n->sym->name, &code->loc);
|
n->sym->name, &code->loc);
|
n->sym->mark = 0;
|
n->sym->mark = 0;
|
}
|
}
|
|
|
for (n = omp_clauses->lists[OMP_LIST_FIRSTPRIVATE]; n; n = n->next)
|
for (n = omp_clauses->lists[OMP_LIST_FIRSTPRIVATE]; n; n = n->next)
|
if (n->sym->mark)
|
if (n->sym->mark)
|
gfc_error ("Symbol '%s' present on multiple clauses at %L",
|
gfc_error ("Symbol '%s' present on multiple clauses at %L",
|
n->sym->name, &code->loc);
|
n->sym->name, &code->loc);
|
else
|
else
|
n->sym->mark = 1;
|
n->sym->mark = 1;
|
|
|
for (n = omp_clauses->lists[OMP_LIST_LASTPRIVATE]; n; n = n->next)
|
for (n = omp_clauses->lists[OMP_LIST_LASTPRIVATE]; n; n = n->next)
|
n->sym->mark = 0;
|
n->sym->mark = 0;
|
|
|
for (n = omp_clauses->lists[OMP_LIST_LASTPRIVATE]; n; n = n->next)
|
for (n = omp_clauses->lists[OMP_LIST_LASTPRIVATE]; n; n = n->next)
|
if (n->sym->mark)
|
if (n->sym->mark)
|
gfc_error ("Symbol '%s' present on multiple clauses at %L",
|
gfc_error ("Symbol '%s' present on multiple clauses at %L",
|
n->sym->name, &code->loc);
|
n->sym->name, &code->loc);
|
else
|
else
|
n->sym->mark = 1;
|
n->sym->mark = 1;
|
|
|
for (list = 0; list < OMP_LIST_NUM; list++)
|
for (list = 0; list < OMP_LIST_NUM; list++)
|
if ((n = omp_clauses->lists[list]) != NULL)
|
if ((n = omp_clauses->lists[list]) != NULL)
|
{
|
{
|
const char *name;
|
const char *name;
|
|
|
if (list < OMP_LIST_REDUCTION_FIRST)
|
if (list < OMP_LIST_REDUCTION_FIRST)
|
name = clause_names[list];
|
name = clause_names[list];
|
else if (list <= OMP_LIST_REDUCTION_LAST)
|
else if (list <= OMP_LIST_REDUCTION_LAST)
|
name = clause_names[OMP_LIST_REDUCTION_FIRST];
|
name = clause_names[OMP_LIST_REDUCTION_FIRST];
|
else
|
else
|
gcc_unreachable ();
|
gcc_unreachable ();
|
|
|
switch (list)
|
switch (list)
|
{
|
{
|
case OMP_LIST_COPYIN:
|
case OMP_LIST_COPYIN:
|
for (; n != NULL; n = n->next)
|
for (; n != NULL; n = n->next)
|
{
|
{
|
if (!n->sym->attr.threadprivate)
|
if (!n->sym->attr.threadprivate)
|
gfc_error ("Non-THREADPRIVATE object '%s' in COPYIN clause"
|
gfc_error ("Non-THREADPRIVATE object '%s' in COPYIN clause"
|
" at %L", n->sym->name, &code->loc);
|
" at %L", n->sym->name, &code->loc);
|
if (n->sym->ts.type == BT_DERIVED && n->sym->ts.u.derived->attr.alloc_comp)
|
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",
|
gfc_error ("COPYIN clause object '%s' at %L has ALLOCATABLE components",
|
n->sym->name, &code->loc);
|
n->sym->name, &code->loc);
|
}
|
}
|
break;
|
break;
|
case OMP_LIST_COPYPRIVATE:
|
case OMP_LIST_COPYPRIVATE:
|
for (; n != NULL; n = n->next)
|
for (; n != NULL; n = n->next)
|
{
|
{
|
if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
|
if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
|
gfc_error ("Assumed size array '%s' in COPYPRIVATE clause "
|
gfc_error ("Assumed size array '%s' in COPYPRIVATE clause "
|
"at %L", n->sym->name, &code->loc);
|
"at %L", n->sym->name, &code->loc);
|
if (n->sym->ts.type == BT_DERIVED && n->sym->ts.u.derived->attr.alloc_comp)
|
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",
|
gfc_error ("COPYPRIVATE clause object '%s' at %L has ALLOCATABLE components",
|
n->sym->name, &code->loc);
|
n->sym->name, &code->loc);
|
}
|
}
|
break;
|
break;
|
case OMP_LIST_SHARED:
|
case OMP_LIST_SHARED:
|
for (; n != NULL; n = n->next)
|
for (; n != NULL; n = n->next)
|
{
|
{
|
if (n->sym->attr.threadprivate)
|
if (n->sym->attr.threadprivate)
|
gfc_error ("THREADPRIVATE object '%s' in SHARED clause at "
|
gfc_error ("THREADPRIVATE object '%s' in SHARED clause at "
|
"%L", n->sym->name, &code->loc);
|
"%L", n->sym->name, &code->loc);
|
if (n->sym->attr.cray_pointee)
|
if (n->sym->attr.cray_pointee)
|
gfc_error ("Cray pointee '%s' in SHARED clause at %L",
|
gfc_error ("Cray pointee '%s' in SHARED clause at %L",
|
n->sym->name, &code->loc);
|
n->sym->name, &code->loc);
|
}
|
}
|
break;
|
break;
|
default:
|
default:
|
for (; n != NULL; n = n->next)
|
for (; n != NULL; n = n->next)
|
{
|
{
|
if (n->sym->attr.threadprivate)
|
if (n->sym->attr.threadprivate)
|
gfc_error ("THREADPRIVATE object '%s' in %s clause at %L",
|
gfc_error ("THREADPRIVATE object '%s' in %s clause at %L",
|
n->sym->name, name, &code->loc);
|
n->sym->name, name, &code->loc);
|
if (n->sym->attr.cray_pointee)
|
if (n->sym->attr.cray_pointee)
|
gfc_error ("Cray pointee '%s' in %s clause at %L",
|
gfc_error ("Cray pointee '%s' in %s clause at %L",
|
n->sym->name, name, &code->loc);
|
n->sym->name, name, &code->loc);
|
if (list != OMP_LIST_PRIVATE)
|
if (list != OMP_LIST_PRIVATE)
|
{
|
{
|
if (n->sym->attr.pointer)
|
if (n->sym->attr.pointer)
|
gfc_error ("POINTER object '%s' in %s clause at %L",
|
gfc_error ("POINTER object '%s' in %s clause at %L",
|
n->sym->name, name, &code->loc);
|
n->sym->name, name, &code->loc);
|
/* Variables in REDUCTION-clauses must be of intrinsic type (flagged below). */
|
/* Variables in REDUCTION-clauses must be of intrinsic type (flagged below). */
|
if ((list < OMP_LIST_REDUCTION_FIRST || list > OMP_LIST_REDUCTION_LAST) &&
|
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)
|
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",
|
gfc_error ("%s clause object '%s' has ALLOCATABLE components at %L",
|
name, n->sym->name, &code->loc);
|
name, n->sym->name, &code->loc);
|
if (n->sym->attr.cray_pointer)
|
if (n->sym->attr.cray_pointer)
|
gfc_error ("Cray pointer '%s' in %s clause at %L",
|
gfc_error ("Cray pointer '%s' in %s clause at %L",
|
n->sym->name, name, &code->loc);
|
n->sym->name, name, &code->loc);
|
}
|
}
|
if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
|
if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
|
gfc_error ("Assumed size array '%s' in %s clause at %L",
|
gfc_error ("Assumed size array '%s' in %s clause at %L",
|
n->sym->name, name, &code->loc);
|
n->sym->name, name, &code->loc);
|
if (n->sym->attr.in_namelist
|
if (n->sym->attr.in_namelist
|
&& (list < OMP_LIST_REDUCTION_FIRST
|
&& (list < OMP_LIST_REDUCTION_FIRST
|
|| list > OMP_LIST_REDUCTION_LAST))
|
|| list > OMP_LIST_REDUCTION_LAST))
|
gfc_error ("Variable '%s' in %s clause is used in "
|
gfc_error ("Variable '%s' in %s clause is used in "
|
"NAMELIST statement at %L",
|
"NAMELIST statement at %L",
|
n->sym->name, name, &code->loc);
|
n->sym->name, name, &code->loc);
|
switch (list)
|
switch (list)
|
{
|
{
|
case OMP_LIST_PLUS:
|
case OMP_LIST_PLUS:
|
case OMP_LIST_MULT:
|
case OMP_LIST_MULT:
|
case OMP_LIST_SUB:
|
case OMP_LIST_SUB:
|
if (!gfc_numeric_ts (&n->sym->ts))
|
if (!gfc_numeric_ts (&n->sym->ts))
|
gfc_error ("%c REDUCTION variable '%s' at %L must be of numeric type, got %s",
|
gfc_error ("%c REDUCTION variable '%s' at %L must be of numeric type, got %s",
|
list == OMP_LIST_PLUS ? '+'
|
list == OMP_LIST_PLUS ? '+'
|
: list == OMP_LIST_MULT ? '*' : '-',
|
: list == OMP_LIST_MULT ? '*' : '-',
|
n->sym->name, &code->loc,
|
n->sym->name, &code->loc,
|
gfc_typename (&n->sym->ts));
|
gfc_typename (&n->sym->ts));
|
break;
|
break;
|
case OMP_LIST_AND:
|
case OMP_LIST_AND:
|
case OMP_LIST_OR:
|
case OMP_LIST_OR:
|
case OMP_LIST_EQV:
|
case OMP_LIST_EQV:
|
case OMP_LIST_NEQV:
|
case OMP_LIST_NEQV:
|
if (n->sym->ts.type != BT_LOGICAL)
|
if (n->sym->ts.type != BT_LOGICAL)
|
gfc_error ("%s REDUCTION variable '%s' must be LOGICAL "
|
gfc_error ("%s REDUCTION variable '%s' must be LOGICAL "
|
"at %L",
|
"at %L",
|
list == OMP_LIST_AND ? ".AND."
|
list == OMP_LIST_AND ? ".AND."
|
: list == OMP_LIST_OR ? ".OR."
|
: list == OMP_LIST_OR ? ".OR."
|
: list == OMP_LIST_EQV ? ".EQV." : ".NEQV.",
|
: list == OMP_LIST_EQV ? ".EQV." : ".NEQV.",
|
n->sym->name, &code->loc);
|
n->sym->name, &code->loc);
|
break;
|
break;
|
case OMP_LIST_MAX:
|
case OMP_LIST_MAX:
|
case OMP_LIST_MIN:
|
case OMP_LIST_MIN:
|
if (n->sym->ts.type != BT_INTEGER
|
if (n->sym->ts.type != BT_INTEGER
|
&& n->sym->ts.type != BT_REAL)
|
&& n->sym->ts.type != BT_REAL)
|
gfc_error ("%s REDUCTION variable '%s' must be "
|
gfc_error ("%s REDUCTION variable '%s' must be "
|
"INTEGER or REAL at %L",
|
"INTEGER or REAL at %L",
|
list == OMP_LIST_MAX ? "MAX" : "MIN",
|
list == OMP_LIST_MAX ? "MAX" : "MIN",
|
n->sym->name, &code->loc);
|
n->sym->name, &code->loc);
|
break;
|
break;
|
case OMP_LIST_IAND:
|
case OMP_LIST_IAND:
|
case OMP_LIST_IOR:
|
case OMP_LIST_IOR:
|
case OMP_LIST_IEOR:
|
case OMP_LIST_IEOR:
|
if (n->sym->ts.type != BT_INTEGER)
|
if (n->sym->ts.type != BT_INTEGER)
|
gfc_error ("%s REDUCTION variable '%s' must be INTEGER "
|
gfc_error ("%s REDUCTION variable '%s' must be INTEGER "
|
"at %L",
|
"at %L",
|
list == OMP_LIST_IAND ? "IAND"
|
list == OMP_LIST_IAND ? "IAND"
|
: list == OMP_LIST_MULT ? "IOR" : "IEOR",
|
: list == OMP_LIST_MULT ? "IOR" : "IEOR",
|
n->sym->name, &code->loc);
|
n->sym->name, &code->loc);
|
break;
|
break;
|
/* Workaround for PR middle-end/26316, nothing really needs
|
/* Workaround for PR middle-end/26316, nothing really needs
|
to be done here for OMP_LIST_PRIVATE. */
|
to be done here for OMP_LIST_PRIVATE. */
|
case OMP_LIST_PRIVATE:
|
case OMP_LIST_PRIVATE:
|
gcc_assert (code->op != EXEC_NOP);
|
gcc_assert (code->op != EXEC_NOP);
|
default:
|
default:
|
break;
|
break;
|
}
|
}
|
}
|
}
|
break;
|
break;
|
}
|
}
|
}
|
}
|
}
|
}
|
|
|
|
|
/* Return true if SYM is ever referenced in EXPR except in the SE node. */
|
/* Return true if SYM is ever referenced in EXPR except in the SE node. */
|
|
|
static bool
|
static bool
|
expr_references_sym (gfc_expr *e, gfc_symbol *s, gfc_expr *se)
|
expr_references_sym (gfc_expr *e, gfc_symbol *s, gfc_expr *se)
|
{
|
{
|
gfc_actual_arglist *arg;
|
gfc_actual_arglist *arg;
|
if (e == NULL || e == se)
|
if (e == NULL || e == se)
|
return false;
|
return false;
|
switch (e->expr_type)
|
switch (e->expr_type)
|
{
|
{
|
case EXPR_CONSTANT:
|
case EXPR_CONSTANT:
|
case EXPR_NULL:
|
case EXPR_NULL:
|
case EXPR_VARIABLE:
|
case EXPR_VARIABLE:
|
case EXPR_STRUCTURE:
|
case EXPR_STRUCTURE:
|
case EXPR_ARRAY:
|
case EXPR_ARRAY:
|
if (e->symtree != NULL
|
if (e->symtree != NULL
|
&& e->symtree->n.sym == s)
|
&& e->symtree->n.sym == s)
|
return true;
|
return true;
|
return false;
|
return false;
|
case EXPR_SUBSTRING:
|
case EXPR_SUBSTRING:
|
if (e->ref != NULL
|
if (e->ref != NULL
|
&& (expr_references_sym (e->ref->u.ss.start, s, se)
|
&& (expr_references_sym (e->ref->u.ss.start, s, se)
|
|| expr_references_sym (e->ref->u.ss.end, s, se)))
|
|| expr_references_sym (e->ref->u.ss.end, s, se)))
|
return true;
|
return true;
|
return false;
|
return false;
|
case EXPR_OP:
|
case EXPR_OP:
|
if (expr_references_sym (e->value.op.op2, s, se))
|
if (expr_references_sym (e->value.op.op2, s, se))
|
return true;
|
return true;
|
return expr_references_sym (e->value.op.op1, s, se);
|
return expr_references_sym (e->value.op.op1, s, se);
|
case EXPR_FUNCTION:
|
case EXPR_FUNCTION:
|
for (arg = e->value.function.actual; arg; arg = arg->next)
|
for (arg = e->value.function.actual; arg; arg = arg->next)
|
if (expr_references_sym (arg->expr, s, se))
|
if (expr_references_sym (arg->expr, s, se))
|
return true;
|
return true;
|
return false;
|
return false;
|
default:
|
default:
|
gcc_unreachable ();
|
gcc_unreachable ();
|
}
|
}
|
}
|
}
|
|
|
|
|
/* If EXPR is a conversion function that widens the type
|
/* If EXPR is a conversion function that widens the type
|
if WIDENING is true or narrows the type if WIDENING is false,
|
if WIDENING is true or narrows the type if WIDENING is false,
|
return the inner expression, otherwise return NULL. */
|
return the inner expression, otherwise return NULL. */
|
|
|
static gfc_expr *
|
static gfc_expr *
|
is_conversion (gfc_expr *expr, bool widening)
|
is_conversion (gfc_expr *expr, bool widening)
|
{
|
{
|
gfc_typespec *ts1, *ts2;
|
gfc_typespec *ts1, *ts2;
|
|
|
if (expr->expr_type != EXPR_FUNCTION
|
if (expr->expr_type != EXPR_FUNCTION
|
|| expr->value.function.isym == NULL
|
|| expr->value.function.isym == NULL
|
|| expr->value.function.esym != NULL
|
|| expr->value.function.esym != NULL
|
|| expr->value.function.isym->id != GFC_ISYM_CONVERSION)
|
|| expr->value.function.isym->id != GFC_ISYM_CONVERSION)
|
return NULL;
|
return NULL;
|
|
|
if (widening)
|
if (widening)
|
{
|
{
|
ts1 = &expr->ts;
|
ts1 = &expr->ts;
|
ts2 = &expr->value.function.actual->expr->ts;
|
ts2 = &expr->value.function.actual->expr->ts;
|
}
|
}
|
else
|
else
|
{
|
{
|
ts1 = &expr->value.function.actual->expr->ts;
|
ts1 = &expr->value.function.actual->expr->ts;
|
ts2 = &expr->ts;
|
ts2 = &expr->ts;
|
}
|
}
|
|
|
if (ts1->type > ts2->type
|
if (ts1->type > ts2->type
|
|| (ts1->type == ts2->type && ts1->kind > ts2->kind))
|
|| (ts1->type == ts2->type && ts1->kind > ts2->kind))
|
return expr->value.function.actual->expr;
|
return expr->value.function.actual->expr;
|
|
|
return NULL;
|
return NULL;
|
}
|
}
|
|
|
|
|
static void
|
static void
|
resolve_omp_atomic (gfc_code *code)
|
resolve_omp_atomic (gfc_code *code)
|
{
|
{
|
gfc_symbol *var;
|
gfc_symbol *var;
|
gfc_expr *expr2;
|
gfc_expr *expr2;
|
|
|
code = code->block->next;
|
code = code->block->next;
|
gcc_assert (code->op == EXEC_ASSIGN);
|
gcc_assert (code->op == EXEC_ASSIGN);
|
gcc_assert (code->next == NULL);
|
gcc_assert (code->next == NULL);
|
|
|
if (code->expr1->expr_type != EXPR_VARIABLE
|
if (code->expr1->expr_type != EXPR_VARIABLE
|
|| code->expr1->symtree == NULL
|
|| code->expr1->symtree == NULL
|
|| code->expr1->rank != 0
|
|| code->expr1->rank != 0
|
|| (code->expr1->ts.type != BT_INTEGER
|
|| (code->expr1->ts.type != BT_INTEGER
|
&& code->expr1->ts.type != BT_REAL
|
&& code->expr1->ts.type != BT_REAL
|
&& code->expr1->ts.type != BT_COMPLEX
|
&& code->expr1->ts.type != BT_COMPLEX
|
&& code->expr1->ts.type != BT_LOGICAL))
|
&& code->expr1->ts.type != BT_LOGICAL))
|
{
|
{
|
gfc_error ("!$OMP ATOMIC statement must set a scalar variable of "
|
gfc_error ("!$OMP ATOMIC statement must set a scalar variable of "
|
"intrinsic type at %L", &code->loc);
|
"intrinsic type at %L", &code->loc);
|
return;
|
return;
|
}
|
}
|
|
|
var = code->expr1->symtree->n.sym;
|
var = code->expr1->symtree->n.sym;
|
expr2 = is_conversion (code->expr2, false);
|
expr2 = is_conversion (code->expr2, false);
|
if (expr2 == NULL)
|
if (expr2 == NULL)
|
expr2 = code->expr2;
|
expr2 = code->expr2;
|
|
|
if (expr2->expr_type == EXPR_OP)
|
if (expr2->expr_type == EXPR_OP)
|
{
|
{
|
gfc_expr *v = NULL, *e, *c;
|
gfc_expr *v = NULL, *e, *c;
|
gfc_intrinsic_op op = expr2->value.op.op;
|
gfc_intrinsic_op op = expr2->value.op.op;
|
gfc_intrinsic_op alt_op = INTRINSIC_NONE;
|
gfc_intrinsic_op alt_op = INTRINSIC_NONE;
|
|
|
switch (op)
|
switch (op)
|
{
|
{
|
case INTRINSIC_PLUS:
|
case INTRINSIC_PLUS:
|
alt_op = INTRINSIC_MINUS;
|
alt_op = INTRINSIC_MINUS;
|
break;
|
break;
|
case INTRINSIC_TIMES:
|
case INTRINSIC_TIMES:
|
alt_op = INTRINSIC_DIVIDE;
|
alt_op = INTRINSIC_DIVIDE;
|
break;
|
break;
|
case INTRINSIC_MINUS:
|
case INTRINSIC_MINUS:
|
alt_op = INTRINSIC_PLUS;
|
alt_op = INTRINSIC_PLUS;
|
break;
|
break;
|
case INTRINSIC_DIVIDE:
|
case INTRINSIC_DIVIDE:
|
alt_op = INTRINSIC_TIMES;
|
alt_op = INTRINSIC_TIMES;
|
break;
|
break;
|
case INTRINSIC_AND:
|
case INTRINSIC_AND:
|
case INTRINSIC_OR:
|
case INTRINSIC_OR:
|
break;
|
break;
|
case INTRINSIC_EQV:
|
case INTRINSIC_EQV:
|
alt_op = INTRINSIC_NEQV;
|
alt_op = INTRINSIC_NEQV;
|
break;
|
break;
|
case INTRINSIC_NEQV:
|
case INTRINSIC_NEQV:
|
alt_op = INTRINSIC_EQV;
|
alt_op = INTRINSIC_EQV;
|
break;
|
break;
|
default:
|
default:
|
gfc_error ("!$OMP ATOMIC assignment operator must be "
|
gfc_error ("!$OMP ATOMIC assignment operator must be "
|
"+, *, -, /, .AND., .OR., .EQV. or .NEQV. at %L",
|
"+, *, -, /, .AND., .OR., .EQV. or .NEQV. at %L",
|
&expr2->where);
|
&expr2->where);
|
return;
|
return;
|
}
|
}
|
|
|
/* Check for var = var op expr resp. var = expr op var where
|
/* Check for var = var op expr resp. var = expr op var where
|
expr doesn't reference var and var op expr is mathematically
|
expr doesn't reference var and var op expr is mathematically
|
equivalent to var op (expr) resp. expr op var equivalent to
|
equivalent to var op (expr) resp. expr op var equivalent to
|
(expr) op var. We rely here on the fact that the matcher
|
(expr) op var. We rely here on the fact that the matcher
|
for x op1 y op2 z where op1 and op2 have equal precedence
|
for x op1 y op2 z where op1 and op2 have equal precedence
|
returns (x op1 y) op2 z. */
|
returns (x op1 y) op2 z. */
|
e = expr2->value.op.op2;
|
e = expr2->value.op.op2;
|
if (e->expr_type == EXPR_VARIABLE
|
if (e->expr_type == EXPR_VARIABLE
|
&& e->symtree != NULL
|
&& e->symtree != NULL
|
&& e->symtree->n.sym == var)
|
&& e->symtree->n.sym == var)
|
v = e;
|
v = e;
|
else if ((c = is_conversion (e, true)) != NULL
|
else if ((c = is_conversion (e, true)) != NULL
|
&& c->expr_type == EXPR_VARIABLE
|
&& c->expr_type == EXPR_VARIABLE
|
&& c->symtree != NULL
|
&& c->symtree != NULL
|
&& c->symtree->n.sym == var)
|
&& c->symtree->n.sym == var)
|
v = c;
|
v = c;
|
else
|
else
|
{
|
{
|
gfc_expr **p = NULL, **q;
|
gfc_expr **p = NULL, **q;
|
for (q = &expr2->value.op.op1; (e = *q) != NULL; )
|
for (q = &expr2->value.op.op1; (e = *q) != NULL; )
|
if (e->expr_type == EXPR_VARIABLE
|
if (e->expr_type == EXPR_VARIABLE
|
&& e->symtree != NULL
|
&& e->symtree != NULL
|
&& e->symtree->n.sym == var)
|
&& e->symtree->n.sym == var)
|
{
|
{
|
v = e;
|
v = e;
|
break;
|
break;
|
}
|
}
|
else if ((c = is_conversion (e, true)) != NULL)
|
else if ((c = is_conversion (e, true)) != NULL)
|
q = &e->value.function.actual->expr;
|
q = &e->value.function.actual->expr;
|
else if (e->expr_type != EXPR_OP
|
else if (e->expr_type != EXPR_OP
|
|| (e->value.op.op != op
|
|| (e->value.op.op != op
|
&& e->value.op.op != alt_op)
|
&& e->value.op.op != alt_op)
|
|| e->rank != 0)
|
|| e->rank != 0)
|
break;
|
break;
|
else
|
else
|
{
|
{
|
p = q;
|
p = q;
|
q = &e->value.op.op1;
|
q = &e->value.op.op1;
|
}
|
}
|
|
|
if (v == NULL)
|
if (v == NULL)
|
{
|
{
|
gfc_error ("!$OMP ATOMIC assignment must be var = var op expr "
|
gfc_error ("!$OMP ATOMIC assignment must be var = var op expr "
|
"or var = expr op var at %L", &expr2->where);
|
"or var = expr op var at %L", &expr2->where);
|
return;
|
return;
|
}
|
}
|
|
|
if (p != NULL)
|
if (p != NULL)
|
{
|
{
|
e = *p;
|
e = *p;
|
switch (e->value.op.op)
|
switch (e->value.op.op)
|
{
|
{
|
case INTRINSIC_MINUS:
|
case INTRINSIC_MINUS:
|
case INTRINSIC_DIVIDE:
|
case INTRINSIC_DIVIDE:
|
case INTRINSIC_EQV:
|
case INTRINSIC_EQV:
|
case INTRINSIC_NEQV:
|
case INTRINSIC_NEQV:
|
gfc_error ("!$OMP ATOMIC var = var op expr not "
|
gfc_error ("!$OMP ATOMIC var = var op expr not "
|
"mathematically equivalent to var = var op "
|
"mathematically equivalent to var = var op "
|
"(expr) at %L", &expr2->where);
|
"(expr) at %L", &expr2->where);
|
break;
|
break;
|
default:
|
default:
|
break;
|
break;
|
}
|
}
|
|
|
/* Canonicalize into var = var op (expr). */
|
/* Canonicalize into var = var op (expr). */
|
*p = e->value.op.op2;
|
*p = e->value.op.op2;
|
e->value.op.op2 = expr2;
|
e->value.op.op2 = expr2;
|
e->ts = expr2->ts;
|
e->ts = expr2->ts;
|
if (code->expr2 == expr2)
|
if (code->expr2 == expr2)
|
code->expr2 = expr2 = e;
|
code->expr2 = expr2 = e;
|
else
|
else
|
code->expr2->value.function.actual->expr = expr2 = e;
|
code->expr2->value.function.actual->expr = expr2 = e;
|
|
|
if (!gfc_compare_types (&expr2->value.op.op1->ts, &expr2->ts))
|
if (!gfc_compare_types (&expr2->value.op.op1->ts, &expr2->ts))
|
{
|
{
|
for (p = &expr2->value.op.op1; *p != v;
|
for (p = &expr2->value.op.op1; *p != v;
|
p = &(*p)->value.function.actual->expr)
|
p = &(*p)->value.function.actual->expr)
|
;
|
;
|
*p = NULL;
|
*p = NULL;
|
gfc_free_expr (expr2->value.op.op1);
|
gfc_free_expr (expr2->value.op.op1);
|
expr2->value.op.op1 = v;
|
expr2->value.op.op1 = v;
|
gfc_convert_type (v, &expr2->ts, 2);
|
gfc_convert_type (v, &expr2->ts, 2);
|
}
|
}
|
}
|
}
|
}
|
}
|
|
|
if (e->rank != 0 || expr_references_sym (code->expr2, var, v))
|
if (e->rank != 0 || expr_references_sym (code->expr2, var, v))
|
{
|
{
|
gfc_error ("expr in !$OMP ATOMIC assignment var = var op expr "
|
gfc_error ("expr in !$OMP ATOMIC assignment var = var op expr "
|
"must be scalar and cannot reference var at %L",
|
"must be scalar and cannot reference var at %L",
|
&expr2->where);
|
&expr2->where);
|
return;
|
return;
|
}
|
}
|
}
|
}
|
else if (expr2->expr_type == EXPR_FUNCTION
|
else if (expr2->expr_type == EXPR_FUNCTION
|
&& expr2->value.function.isym != NULL
|
&& expr2->value.function.isym != NULL
|
&& expr2->value.function.esym == NULL
|
&& expr2->value.function.esym == NULL
|
&& expr2->value.function.actual != NULL
|
&& expr2->value.function.actual != NULL
|
&& expr2->value.function.actual->next != NULL)
|
&& expr2->value.function.actual->next != NULL)
|
{
|
{
|
gfc_actual_arglist *arg, *var_arg;
|
gfc_actual_arglist *arg, *var_arg;
|
|
|
switch (expr2->value.function.isym->id)
|
switch (expr2->value.function.isym->id)
|
{
|
{
|
case GFC_ISYM_MIN:
|
case GFC_ISYM_MIN:
|
case GFC_ISYM_MAX:
|
case GFC_ISYM_MAX:
|
break;
|
break;
|
case GFC_ISYM_IAND:
|
case GFC_ISYM_IAND:
|
case GFC_ISYM_IOR:
|
case GFC_ISYM_IOR:
|
case GFC_ISYM_IEOR:
|
case GFC_ISYM_IEOR:
|
if (expr2->value.function.actual->next->next != NULL)
|
if (expr2->value.function.actual->next->next != NULL)
|
{
|
{
|
gfc_error ("!$OMP ATOMIC assignment intrinsic IAND, IOR "
|
gfc_error ("!$OMP ATOMIC assignment intrinsic IAND, IOR "
|
"or IEOR must have two arguments at %L",
|
"or IEOR must have two arguments at %L",
|
&expr2->where);
|
&expr2->where);
|
return;
|
return;
|
}
|
}
|
break;
|
break;
|
default:
|
default:
|
gfc_error ("!$OMP ATOMIC assignment intrinsic must be "
|
gfc_error ("!$OMP ATOMIC assignment intrinsic must be "
|
"MIN, MAX, IAND, IOR or IEOR at %L",
|
"MIN, MAX, IAND, IOR or IEOR at %L",
|
&expr2->where);
|
&expr2->where);
|
return;
|
return;
|
}
|
}
|
|
|
var_arg = NULL;
|
var_arg = NULL;
|
for (arg = expr2->value.function.actual; arg; arg = arg->next)
|
for (arg = expr2->value.function.actual; arg; arg = arg->next)
|
{
|
{
|
if ((arg == expr2->value.function.actual
|
if ((arg == expr2->value.function.actual
|
|| (var_arg == NULL && arg->next == NULL))
|
|| (var_arg == NULL && arg->next == NULL))
|
&& arg->expr->expr_type == EXPR_VARIABLE
|
&& arg->expr->expr_type == EXPR_VARIABLE
|
&& arg->expr->symtree != NULL
|
&& arg->expr->symtree != NULL
|
&& arg->expr->symtree->n.sym == var)
|
&& arg->expr->symtree->n.sym == var)
|
var_arg = arg;
|
var_arg = arg;
|
else if (expr_references_sym (arg->expr, var, NULL))
|
else if (expr_references_sym (arg->expr, var, NULL))
|
gfc_error ("!$OMP ATOMIC intrinsic arguments except one must not "
|
gfc_error ("!$OMP ATOMIC intrinsic arguments except one must not "
|
"reference '%s' at %L", var->name, &arg->expr->where);
|
"reference '%s' at %L", var->name, &arg->expr->where);
|
if (arg->expr->rank != 0)
|
if (arg->expr->rank != 0)
|
gfc_error ("!$OMP ATOMIC intrinsic arguments must be scalar "
|
gfc_error ("!$OMP ATOMIC intrinsic arguments must be scalar "
|
"at %L", &arg->expr->where);
|
"at %L", &arg->expr->where);
|
}
|
}
|
|
|
if (var_arg == NULL)
|
if (var_arg == NULL)
|
{
|
{
|
gfc_error ("First or last !$OMP ATOMIC intrinsic argument must "
|
gfc_error ("First or last !$OMP ATOMIC intrinsic argument must "
|
"be '%s' at %L", var->name, &expr2->where);
|
"be '%s' at %L", var->name, &expr2->where);
|
return;
|
return;
|
}
|
}
|
|
|
if (var_arg != expr2->value.function.actual)
|
if (var_arg != expr2->value.function.actual)
|
{
|
{
|
/* Canonicalize, so that var comes first. */
|
/* Canonicalize, so that var comes first. */
|
gcc_assert (var_arg->next == NULL);
|
gcc_assert (var_arg->next == NULL);
|
for (arg = expr2->value.function.actual;
|
for (arg = expr2->value.function.actual;
|
arg->next != var_arg; arg = arg->next)
|
arg->next != var_arg; arg = arg->next)
|
;
|
;
|
var_arg->next = expr2->value.function.actual;
|
var_arg->next = expr2->value.function.actual;
|
expr2->value.function.actual = var_arg;
|
expr2->value.function.actual = var_arg;
|
arg->next = NULL;
|
arg->next = NULL;
|
}
|
}
|
}
|
}
|
else
|
else
|
gfc_error ("!$OMP ATOMIC assignment must have an operator or intrinsic "
|
gfc_error ("!$OMP ATOMIC assignment must have an operator or intrinsic "
|
"on right hand side at %L", &expr2->where);
|
"on right hand side at %L", &expr2->where);
|
}
|
}
|
|
|
|
|
struct omp_context
|
struct omp_context
|
{
|
{
|
gfc_code *code;
|
gfc_code *code;
|
struct pointer_set_t *sharing_clauses;
|
struct pointer_set_t *sharing_clauses;
|
struct pointer_set_t *private_iterators;
|
struct pointer_set_t *private_iterators;
|
struct omp_context *previous;
|
struct omp_context *previous;
|
} *omp_current_ctx;
|
} *omp_current_ctx;
|
static gfc_code *omp_current_do_code;
|
static gfc_code *omp_current_do_code;
|
static int omp_current_do_collapse;
|
static int omp_current_do_collapse;
|
|
|
void
|
void
|
gfc_resolve_omp_do_blocks (gfc_code *code, gfc_namespace *ns)
|
gfc_resolve_omp_do_blocks (gfc_code *code, gfc_namespace *ns)
|
{
|
{
|
if (code->block->next && code->block->next->op == EXEC_DO)
|
if (code->block->next && code->block->next->op == EXEC_DO)
|
{
|
{
|
int i;
|
int i;
|
gfc_code *c;
|
gfc_code *c;
|
|
|
omp_current_do_code = code->block->next;
|
omp_current_do_code = code->block->next;
|
omp_current_do_collapse = code->ext.omp_clauses->collapse;
|
omp_current_do_collapse = code->ext.omp_clauses->collapse;
|
for (i = 1, c = omp_current_do_code; i < omp_current_do_collapse; i++)
|
for (i = 1, c = omp_current_do_code; i < omp_current_do_collapse; i++)
|
{
|
{
|
c = c->block;
|
c = c->block;
|
if (c->op != EXEC_DO || c->next == NULL)
|
if (c->op != EXEC_DO || c->next == NULL)
|
break;
|
break;
|
c = c->next;
|
c = c->next;
|
if (c->op != EXEC_DO)
|
if (c->op != EXEC_DO)
|
break;
|
break;
|
}
|
}
|
if (i < omp_current_do_collapse || omp_current_do_collapse <= 0)
|
if (i < omp_current_do_collapse || omp_current_do_collapse <= 0)
|
omp_current_do_collapse = 1;
|
omp_current_do_collapse = 1;
|
}
|
}
|
gfc_resolve_blocks (code->block, ns);
|
gfc_resolve_blocks (code->block, ns);
|
omp_current_do_collapse = 0;
|
omp_current_do_collapse = 0;
|
omp_current_do_code = NULL;
|
omp_current_do_code = NULL;
|
}
|
}
|
|
|
|
|
void
|
void
|
gfc_resolve_omp_parallel_blocks (gfc_code *code, gfc_namespace *ns)
|
gfc_resolve_omp_parallel_blocks (gfc_code *code, gfc_namespace *ns)
|
{
|
{
|
struct omp_context ctx;
|
struct omp_context ctx;
|
gfc_omp_clauses *omp_clauses = code->ext.omp_clauses;
|
gfc_omp_clauses *omp_clauses = code->ext.omp_clauses;
|
gfc_namelist *n;
|
gfc_namelist *n;
|
int list;
|
int list;
|
|
|
ctx.code = code;
|
ctx.code = code;
|
ctx.sharing_clauses = pointer_set_create ();
|
ctx.sharing_clauses = pointer_set_create ();
|
ctx.private_iterators = pointer_set_create ();
|
ctx.private_iterators = pointer_set_create ();
|
ctx.previous = omp_current_ctx;
|
ctx.previous = omp_current_ctx;
|
omp_current_ctx = &ctx;
|
omp_current_ctx = &ctx;
|
|
|
for (list = 0; list < OMP_LIST_NUM; list++)
|
for (list = 0; list < OMP_LIST_NUM; list++)
|
for (n = omp_clauses->lists[list]; n; n = n->next)
|
for (n = omp_clauses->lists[list]; n; n = n->next)
|
pointer_set_insert (ctx.sharing_clauses, n->sym);
|
pointer_set_insert (ctx.sharing_clauses, n->sym);
|
|
|
if (code->op == EXEC_OMP_PARALLEL_DO)
|
if (code->op == EXEC_OMP_PARALLEL_DO)
|
gfc_resolve_omp_do_blocks (code, ns);
|
gfc_resolve_omp_do_blocks (code, ns);
|
else
|
else
|
gfc_resolve_blocks (code->block, ns);
|
gfc_resolve_blocks (code->block, ns);
|
|
|
omp_current_ctx = ctx.previous;
|
omp_current_ctx = ctx.previous;
|
pointer_set_destroy (ctx.sharing_clauses);
|
pointer_set_destroy (ctx.sharing_clauses);
|
pointer_set_destroy (ctx.private_iterators);
|
pointer_set_destroy (ctx.private_iterators);
|
}
|
}
|
|
|
|
|
/* Note a DO iterator variable. This is special in !$omp parallel
|
/* Note a DO iterator variable. This is special in !$omp parallel
|
construct, where they are predetermined private. */
|
construct, where they are predetermined private. */
|
|
|
void
|
void
|
gfc_resolve_do_iterator (gfc_code *code, gfc_symbol *sym)
|
gfc_resolve_do_iterator (gfc_code *code, gfc_symbol *sym)
|
{
|
{
|
int i = omp_current_do_collapse;
|
int i = omp_current_do_collapse;
|
gfc_code *c = omp_current_do_code;
|
gfc_code *c = omp_current_do_code;
|
|
|
if (sym->attr.threadprivate)
|
if (sym->attr.threadprivate)
|
return;
|
return;
|
|
|
/* !$omp do and !$omp parallel do iteration variable is predetermined
|
/* !$omp do and !$omp parallel do iteration variable is predetermined
|
private just in the !$omp do resp. !$omp parallel do construct,
|
private just in the !$omp do resp. !$omp parallel do construct,
|
with no implications for the outer parallel constructs. */
|
with no implications for the outer parallel constructs. */
|
|
|
while (i-- >= 1)
|
while (i-- >= 1)
|
{
|
{
|
if (code == c)
|
if (code == c)
|
return;
|
return;
|
|
|
c = c->block->next;
|
c = c->block->next;
|
}
|
}
|
|
|
if (omp_current_ctx == NULL)
|
if (omp_current_ctx == NULL)
|
return;
|
return;
|
|
|
if (pointer_set_contains (omp_current_ctx->sharing_clauses, sym))
|
if (pointer_set_contains (omp_current_ctx->sharing_clauses, sym))
|
return;
|
return;
|
|
|
if (! pointer_set_insert (omp_current_ctx->private_iterators, sym))
|
if (! pointer_set_insert (omp_current_ctx->private_iterators, sym))
|
{
|
{
|
gfc_omp_clauses *omp_clauses = omp_current_ctx->code->ext.omp_clauses;
|
gfc_omp_clauses *omp_clauses = omp_current_ctx->code->ext.omp_clauses;
|
gfc_namelist *p;
|
gfc_namelist *p;
|
|
|
p = gfc_get_namelist ();
|
p = gfc_get_namelist ();
|
p->sym = sym;
|
p->sym = sym;
|
p->next = omp_clauses->lists[OMP_LIST_PRIVATE];
|
p->next = omp_clauses->lists[OMP_LIST_PRIVATE];
|
omp_clauses->lists[OMP_LIST_PRIVATE] = p;
|
omp_clauses->lists[OMP_LIST_PRIVATE] = p;
|
}
|
}
|
}
|
}
|
|
|
|
|
static void
|
static void
|
resolve_omp_do (gfc_code *code)
|
resolve_omp_do (gfc_code *code)
|
{
|
{
|
gfc_code *do_code, *c;
|
gfc_code *do_code, *c;
|
int list, i, collapse;
|
int list, i, collapse;
|
gfc_namelist *n;
|
gfc_namelist *n;
|
gfc_symbol *dovar;
|
gfc_symbol *dovar;
|
|
|
if (code->ext.omp_clauses)
|
if (code->ext.omp_clauses)
|
resolve_omp_clauses (code);
|
resolve_omp_clauses (code);
|
|
|
do_code = code->block->next;
|
do_code = code->block->next;
|
collapse = code->ext.omp_clauses->collapse;
|
collapse = code->ext.omp_clauses->collapse;
|
if (collapse <= 0)
|
if (collapse <= 0)
|
collapse = 1;
|
collapse = 1;
|
for (i = 1; i <= collapse; i++)
|
for (i = 1; i <= collapse; i++)
|
{
|
{
|
if (do_code->op == EXEC_DO_WHILE)
|
if (do_code->op == EXEC_DO_WHILE)
|
{
|
{
|
gfc_error ("!$OMP DO cannot be a DO WHILE or DO without loop control "
|
gfc_error ("!$OMP DO cannot be a DO WHILE or DO without loop control "
|
"at %L", &do_code->loc);
|
"at %L", &do_code->loc);
|
break;
|
break;
|
}
|
}
|
gcc_assert (do_code->op == EXEC_DO);
|
gcc_assert (do_code->op == EXEC_DO);
|
if (do_code->ext.iterator->var->ts.type != BT_INTEGER)
|
if (do_code->ext.iterator->var->ts.type != BT_INTEGER)
|
gfc_error ("!$OMP DO iteration variable must be of type integer at %L",
|
gfc_error ("!$OMP DO iteration variable must be of type integer at %L",
|
&do_code->loc);
|
&do_code->loc);
|
dovar = do_code->ext.iterator->var->symtree->n.sym;
|
dovar = do_code->ext.iterator->var->symtree->n.sym;
|
if (dovar->attr.threadprivate)
|
if (dovar->attr.threadprivate)
|
gfc_error ("!$OMP DO iteration variable must not be THREADPRIVATE "
|
gfc_error ("!$OMP DO iteration variable must not be THREADPRIVATE "
|
"at %L", &do_code->loc);
|
"at %L", &do_code->loc);
|
if (code->ext.omp_clauses)
|
if (code->ext.omp_clauses)
|
for (list = 0; list < OMP_LIST_NUM; list++)
|
for (list = 0; list < OMP_LIST_NUM; list++)
|
if (list != OMP_LIST_PRIVATE && list != OMP_LIST_LASTPRIVATE)
|
if (list != OMP_LIST_PRIVATE && list != OMP_LIST_LASTPRIVATE)
|
for (n = code->ext.omp_clauses->lists[list]; n; n = n->next)
|
for (n = code->ext.omp_clauses->lists[list]; n; n = n->next)
|
if (dovar == n->sym)
|
if (dovar == n->sym)
|
{
|
{
|
gfc_error ("!$OMP DO iteration variable present on clause "
|
gfc_error ("!$OMP DO iteration variable present on clause "
|
"other than PRIVATE or LASTPRIVATE at %L",
|
"other than PRIVATE or LASTPRIVATE at %L",
|
&do_code->loc);
|
&do_code->loc);
|
break;
|
break;
|
}
|
}
|
if (i > 1)
|
if (i > 1)
|
{
|
{
|
gfc_code *do_code2 = code->block->next;
|
gfc_code *do_code2 = code->block->next;
|
int j;
|
int j;
|
|
|
for (j = 1; j < i; j++)
|
for (j = 1; j < i; j++)
|
{
|
{
|
gfc_symbol *ivar = do_code2->ext.iterator->var->symtree->n.sym;
|
gfc_symbol *ivar = do_code2->ext.iterator->var->symtree->n.sym;
|
if (dovar == ivar
|
if (dovar == ivar
|
|| gfc_find_sym_in_expr (ivar, do_code->ext.iterator->start)
|
|| 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->end)
|
|| gfc_find_sym_in_expr (ivar, do_code->ext.iterator->step))
|
|| 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",
|
gfc_error ("!$OMP DO collapsed loops don't form rectangular iteration space at %L",
|
&do_code->loc);
|
&do_code->loc);
|
break;
|
break;
|
}
|
}
|
if (j < i)
|
if (j < i)
|
break;
|
break;
|
do_code2 = do_code2->block->next;
|
do_code2 = do_code2->block->next;
|
}
|
}
|
}
|
}
|
if (i == collapse)
|
if (i == collapse)
|
break;
|
break;
|
for (c = do_code->next; c; c = c->next)
|
for (c = do_code->next; c; c = c->next)
|
if (c->op != EXEC_NOP && c->op != EXEC_CONTINUE)
|
if (c->op != EXEC_NOP && c->op != EXEC_CONTINUE)
|
{
|
{
|
gfc_error ("collapsed !$OMP DO loops not perfectly nested at %L",
|
gfc_error ("collapsed !$OMP DO loops not perfectly nested at %L",
|
&c->loc);
|
&c->loc);
|
break;
|
break;
|
}
|
}
|
if (c)
|
if (c)
|
break;
|
break;
|
do_code = do_code->block;
|
do_code = do_code->block;
|
if (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE)
|
if (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE)
|
{
|
{
|
gfc_error ("not enough DO loops for collapsed !$OMP DO at %L",
|
gfc_error ("not enough DO loops for collapsed !$OMP DO at %L",
|
&code->loc);
|
&code->loc);
|
break;
|
break;
|
}
|
}
|
do_code = do_code->next;
|
do_code = do_code->next;
|
if (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE)
|
if (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE)
|
{
|
{
|
gfc_error ("not enough DO loops for collapsed !$OMP DO at %L",
|
gfc_error ("not enough DO loops for collapsed !$OMP DO at %L",
|
&code->loc);
|
&code->loc);
|
break;
|
break;
|
}
|
}
|
}
|
}
|
}
|
}
|
|
|
|
|
/* Resolve OpenMP directive clauses and check various requirements
|
/* Resolve OpenMP directive clauses and check various requirements
|
of each directive. */
|
of each directive. */
|
|
|
void
|
void
|
gfc_resolve_omp_directive (gfc_code *code, gfc_namespace *ns ATTRIBUTE_UNUSED)
|
gfc_resolve_omp_directive (gfc_code *code, gfc_namespace *ns ATTRIBUTE_UNUSED)
|
{
|
{
|
if (code->op != EXEC_OMP_ATOMIC)
|
if (code->op != EXEC_OMP_ATOMIC)
|
gfc_maybe_initialize_eh ();
|
gfc_maybe_initialize_eh ();
|
|
|
switch (code->op)
|
switch (code->op)
|
{
|
{
|
case EXEC_OMP_DO:
|
case EXEC_OMP_DO:
|
case EXEC_OMP_PARALLEL_DO:
|
case EXEC_OMP_PARALLEL_DO:
|
resolve_omp_do (code);
|
resolve_omp_do (code);
|
break;
|
break;
|
case EXEC_OMP_WORKSHARE:
|
case EXEC_OMP_WORKSHARE:
|
case EXEC_OMP_PARALLEL_WORKSHARE:
|
case EXEC_OMP_PARALLEL_WORKSHARE:
|
case EXEC_OMP_PARALLEL:
|
case EXEC_OMP_PARALLEL:
|
case EXEC_OMP_PARALLEL_SECTIONS:
|
case EXEC_OMP_PARALLEL_SECTIONS:
|
case EXEC_OMP_SECTIONS:
|
case EXEC_OMP_SECTIONS:
|
case EXEC_OMP_SINGLE:
|
case EXEC_OMP_SINGLE:
|
if (code->ext.omp_clauses)
|
if (code->ext.omp_clauses)
|
resolve_omp_clauses (code);
|
resolve_omp_clauses (code);
|
break;
|
break;
|
case EXEC_OMP_ATOMIC:
|
case EXEC_OMP_ATOMIC:
|
resolve_omp_atomic (code);
|
resolve_omp_atomic (code);
|
break;
|
break;
|
default:
|
default:
|
break;
|
break;
|
}
|
}
|
}
|
}
|
|
|
