From patchwork Fri Dec 10 17:31:08 2021 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Kwok Cheung Yeung X-Patchwork-Id: 48793 Return-Path: X-Original-To: patchwork@sourceware.org Delivered-To: patchwork@sourceware.org Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 14727385783B for ; Fri, 10 Dec 2021 17:32:34 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from esa1.mentor.iphmx.com (esa1.mentor.iphmx.com [68.232.129.153]) by sourceware.org (Postfix) with ESMTPS id 04C173857C79 for ; Fri, 10 Dec 2021 17:31:52 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.1 sourceware.org 04C173857C79 Authentication-Results: sourceware.org; dmarc=none (p=none dis=none) header.from=codesourcery.com Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=mentor.com IronPort-SDR: 9AC+09MUGvdtay7L675N6B4X48Aoye5+SAg0cbML9e9U6OL57NTdM96Prkv0cLKkhmkC/ULwAe nH60RSt+4E8okfsNpOldJWQPOMnD8Iei0M59tfrSH02a1E6tQ8Sf1n6mBeKjyLhBEVKtbOy6A+ U//+rAoou6gh052EzxA3aqyr6ENrfUBu+2N1xfgxDwgpWiXQMUhVyRJbzzyBC2O8lRUBPmb6Pe uOoFml85prYUbWaXp1+Pr+y/YAiQuJerPb4NXO07FhFl8v0Zsom0l5gqwThypomc+vjKDH24xG O0CEES3ZOr4dqWdYwS6Hd1K1 X-IronPort-AV: E=Sophos;i="5.88,196,1635235200"; d="scan'208,223";a="72064089" Received: from orw-gwy-01-in.mentorg.com ([192.94.38.165]) by esa1.mentor.iphmx.com with ESMTP; 10 Dec 2021 09:31:52 -0800 IronPort-SDR: FKD0gW24bX1CsTvcUBH5Bk25ZBSn/QvEVgL49lwW1EpSYACntRkiRzzvXFuqPSjhI6ZP4cb1Ul nMB2gd0BaxmSbnY4dKqm//qOOzCQBeuIFqD3Uer0BGb/EQfgCfk6UVbp7pj6CHYQlUaZFI25J6 N9iB/V4FU7be2pvIqNlBzTT3BDH2ExOJ0TDIOzXWTHpELlnlIbfRJzwfDo0Wbq5NkP1Lan2D40 ge4CRb0+o3iPfRlIOmPG/QzLIh9+SMs6IzJYYeDPv17InJFdELG6wxqLzIc+AqcqDfEj0vHAhs 9Jo= Message-ID: <4a277a5e-6070-b287-7bc8-c2bcc72532a0@codesourcery.com> Date: Fri, 10 Dec 2021 17:31:08 +0000 MIME-Version: 1.0 User-Agent: Mozilla/5.0 (Windows NT 10.0; Win64; x64; rv:91.0) Gecko/20100101 Thunderbird/91.4.0 To: gcc-patches , Jakub Jelinek References: Subject: [PATCH 1/7] openmp: Add C support for parsing metadirectives From: Kwok Cheung Yeung In-Reply-To: X-Originating-IP: [137.202.0.90] X-ClientProxiedBy: svr-ies-mbx-12.mgc.mentorg.com (139.181.222.12) To SVR-IES-MBX-04.mgc.mentorg.com (139.181.222.4) X-Spam-Status: No, score=-11.9 required=5.0 tests=BAYES_00, GIT_PATCH_0, HEADER_FROM_DIFFERENT_DOMAINS, KAM_DMARC_STATUS, SPF_HELO_PASS, SPF_PASS, TXREP autolearn=ham autolearn_force=no version=3.4.4 X-Spam-Checker-Version: SpamAssassin 3.4.4 (2020-01-24) on server2.sourceware.org X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: gcc-patches-bounces+patchwork=sourceware.org@gcc.gnu.org Sender: "Gcc-patches" This patch adds support for parsing metadirectives in the C parser. Metadirectives are represented by a OMP_METADIRECTIVE tree node. It has a single operand (accessed by OMP_METADIRECTIVE_CLAUSES) which contains a chain of TREE_LIST nodes, each one representing a clause from the metadirective. TREE_PURPOSE(clause) contains the selector of the clause, while TREE_VALUE(clause) contains another TREE_LIST - the TREE_PURPOSE contains the tree for the directive, while the TREE_VALUE contains the standalone body (if any). If an OMP directive has an associated body, it will be part of the tree at TREE_PURPOSE(TREE_VALUE(clause)) - the standalone body at TREE_VALUE(TREE_VALUE(clause) is only used for standalone directives that do not have an associated body (strictly speaking, it isn't a part of the directive variant at all). At present, all standalone bodies in a metadirective are shared, and will point to the same tree node. Labels in the statement body are handled by first scanning the body for labels, then enclosing the statements in a lexical block with the found labels declared as local using __label__. This prevents labels in the body interfering with each other when the body is re-parsed. I have removed support for the 'omp begin metadirective'..'omp end metadirective' form of the directive that was originally in the WIP patch. According to the spec, the only variant directives that can be used in this form must have an 'end ' form (apart from the 'nothing' directive), and in C/C++, the only directive that we support with an end form is 'declare target', which we currently forbid since it is declarative. Kwok From dc88559b0295104472a0cbf79de03b0549bd35f5 Mon Sep 17 00:00:00 2001 From: Kwok Cheung Yeung Date: Mon, 6 Dec 2021 19:15:23 +0000 Subject: [PATCH 1/7] openmp: Add C support for parsing metadirectives This patch implements parsing for the OpenMP metadirective introduced in OpenMP 5.0. Metadirectives are parsed into an OMP_METADIRECTIVE node, with the variant clauses forming a chain accessible via OMP_METADIRECTIVE_CLAUSES. Each clause contains the context selector and tree for the variant. User conditions in the selector are now permitted to be non-constant when used in metadirectives as specified in OpenMP 5.1. 2021-12-10 Kwok Cheung Yeung gcc/ * omp-general.c (omp_context_selector_matches): Add extra argument. (omp_resolve_metadirective): New stub function. * omp-general.h (struct omp_metadirective_variant): New. (omp_context_selector_matches): Add extra argument. (omp_resolve_metadirective): New prototype. * tree.def (OMP_METADIRECTIVE): New. * tree.h (OMP_METADIRECTIVE_CLAUSES): New macro. gcc/c/ * c-parser.c (c_parser_skip_to_end_of_block_or_statement): Handle parentheses in statement. (c_parser_omp_metadirective): New prototype. (c_parser_omp_context_selector): Add extra argument. Allow non-constant expressions. (c_parser_omp_context_selector_specification): Add extra argument and propagate it to c_parser_omp_context_selector. (analyze_metadirective_body): New. (c_parser_omp_metadirective): New. (c_parser_omp_construct): Handle PRAGMA_OMP_METADIRECTIVE. gcc/c-family * c-common.h (enum c_omp_directive_kind): Add C_OMP_DIR_META. (c_omp_expand_metadirective): New prototype. * c-gimplify.c (genericize_omp_metadirective_stmt): New. (c_genericize_control_stmt): Handle OMP_METADIRECTIVE tree nodes. * c-omp.c (omp_directives): Classify metadirectives as C_OMP_DIR_META. (c_omp_expand_metadirective): New stub function. * c-pragma.c (omp_pragmas): Add entry for metadirective. * c-pragma.h (enum pragma_kind): Add PRAGMA_OMP_METADIRECTIVE. --- gcc/c-family/c-common.h | 4 +- gcc/c-family/c-gimplify.c | 25 +++ gcc/c-family/c-omp.c | 14 +- gcc/c-family/c-pragma.c | 1 + gcc/c-family/c-pragma.h | 1 + gcc/c/c-parser.c | 403 +++++++++++++++++++++++++++++++++++++- gcc/omp-general.c | 14 +- gcc/omp-general.h | 9 +- gcc/tree.def | 5 + gcc/tree.h | 3 + 10 files changed, 465 insertions(+), 14 deletions(-) diff --git a/gcc/c-family/c-common.h b/gcc/c-family/c-common.h index c089fda12e4..ef37051791f 100644 --- a/gcc/c-family/c-common.h +++ b/gcc/c-family/c-common.h @@ -1257,7 +1257,8 @@ enum c_omp_directive_kind { C_OMP_DIR_CONSTRUCT, C_OMP_DIR_DECLARATIVE, C_OMP_DIR_UTILITY, - C_OMP_DIR_INFORMATIONAL + C_OMP_DIR_INFORMATIONAL, + C_OMP_DIR_META }; struct c_omp_directive { @@ -1270,6 +1271,7 @@ struct c_omp_directive { extern const struct c_omp_directive *c_omp_categorize_directive (const char *, const char *, const char *); +extern tree c_omp_expand_metadirective (vec &); /* Return next tree in the chain for chain_next walking of tree nodes. */ static inline tree diff --git a/gcc/c-family/c-gimplify.c b/gcc/c-family/c-gimplify.c index 0d38b706f4c..4c5feddf041 100644 --- a/gcc/c-family/c-gimplify.c +++ b/gcc/c-family/c-gimplify.c @@ -449,6 +449,26 @@ genericize_omp_for_stmt (tree *stmt_p, int *walk_subtrees, void *data, finish_bc_block (&OMP_FOR_BODY (stmt), bc_continue, clab); } +/* Genericize a OMP_METADIRECTIVE node *STMT_P. */ + +static void +genericize_omp_metadirective_stmt (tree *stmt_p, int *walk_subtrees, + void *data, walk_tree_fn func, + walk_tree_lh lh) +{ + tree stmt = *stmt_p; + + for (tree clause = OMP_METADIRECTIVE_CLAUSES (stmt); + clause != NULL_TREE; + clause = TREE_CHAIN (clause)) + { + tree variant = TREE_VALUE (clause); + walk_tree_1 (&TREE_PURPOSE (variant), func, data, NULL, lh); + walk_tree_1 (&TREE_VALUE (variant), func, data, NULL, lh); + } + + *walk_subtrees = 0; +} /* Lower structured control flow tree nodes, such as loops. The STMT_P, WALK_SUBTREES, and DATA arguments are as for the walk_tree_fn @@ -497,6 +517,11 @@ c_genericize_control_stmt (tree *stmt_p, int *walk_subtrees, void *data, genericize_omp_for_stmt (stmt_p, walk_subtrees, data, func, lh); break; + case OMP_METADIRECTIVE: + genericize_omp_metadirective_stmt (stmt_p, walk_subtrees, data, func, + lh); + break; + case STATEMENT_LIST: if (TREE_SIDE_EFFECTS (stmt)) { diff --git a/gcc/c-family/c-omp.c b/gcc/c-family/c-omp.c index 3f84fd1b5cb..9a7a6834f1b 100644 --- a/gcc/c-family/c-omp.c +++ b/gcc/c-family/c-omp.c @@ -3133,7 +3133,7 @@ static const struct c_omp_directive omp_directives[] = { /* { "begin", "declare", "variant", PRAGMA_OMP_BEGIN, C_OMP_DIR_DECLARATIVE, false }, */ /* { "begin", "metadirective", nullptr, PRAGMA_OMP_BEGIN, - C_OMP_DIR_???, ??? }, */ + C_OMP_DIR_META, false }, */ { "cancel", nullptr, nullptr, PRAGMA_OMP_CANCEL, C_OMP_DIR_STANDALONE, false }, { "cancellation", "point", nullptr, PRAGMA_OMP_CANCELLATION_POINT, @@ -3163,7 +3163,7 @@ static const struct c_omp_directive omp_directives[] = { /* { "end", "declare", "variant", PRAGMA_OMP_END, C_OMP_DIR_DECLARATIVE, false }, */ /* { "end", "metadirective", nullptr, PRAGMA_OMP_END, - C_OMP_DIR_???, ??? }, */ + C_OMP_DIR_META, false }, */ /* error with at(execution) is C_OMP_DIR_STANDALONE. */ { "error", nullptr, nullptr, PRAGMA_OMP_ERROR, C_OMP_DIR_UTILITY, false }, @@ -3179,8 +3179,8 @@ static const struct c_omp_directive omp_directives[] = { C_OMP_DIR_CONSTRUCT, true }, { "master", nullptr, nullptr, PRAGMA_OMP_MASTER, C_OMP_DIR_CONSTRUCT, true }, - /* { "metadirective", nullptr, nullptr, PRAGMA_OMP_METADIRECTIVE, - C_OMP_DIR_???, ??? }, */ + { "metadirective", nullptr, nullptr, PRAGMA_OMP_METADIRECTIVE, + C_OMP_DIR_META, false }, { "nothing", nullptr, nullptr, PRAGMA_OMP_NOTHING, C_OMP_DIR_UTILITY, false }, /* ordered with depend clause is C_OMP_DIR_STANDALONE. */ @@ -3263,3 +3263,9 @@ c_omp_categorize_directive (const char *first, const char *second, } return NULL; } + +tree +c_omp_expand_metadirective (vec &) +{ + return NULL_TREE; +} diff --git a/gcc/c-family/c-pragma.c b/gcc/c-family/c-pragma.c index c4ed4205820..bd27de7f126 100644 --- a/gcc/c-family/c-pragma.c +++ b/gcc/c-family/c-pragma.c @@ -1365,6 +1365,7 @@ static const struct omp_pragma_def omp_pragmas[] = { { "error", PRAGMA_OMP_ERROR }, { "end", PRAGMA_OMP_END_DECLARE_TARGET }, { "flush", PRAGMA_OMP_FLUSH }, + { "metadirective", PRAGMA_OMP_METADIRECTIVE }, { "nothing", PRAGMA_OMP_NOTHING }, { "requires", PRAGMA_OMP_REQUIRES }, { "scope", PRAGMA_OMP_SCOPE }, diff --git a/gcc/c-family/c-pragma.h b/gcc/c-family/c-pragma.h index 0c5b07ab4e1..145260e0c20 100644 --- a/gcc/c-family/c-pragma.h +++ b/gcc/c-family/c-pragma.h @@ -61,6 +61,7 @@ enum pragma_kind { PRAGMA_OMP_NOTHING, PRAGMA_OMP_MASKED, PRAGMA_OMP_MASTER, + PRAGMA_OMP_METADIRECTIVE, PRAGMA_OMP_ORDERED, PRAGMA_OMP_PARALLEL, PRAGMA_OMP_REQUIRES, diff --git a/gcc/c/c-parser.c b/gcc/c/c-parser.c index e99c84776f1..9689a221975 100644 --- a/gcc/c/c-parser.c +++ b/gcc/c/c-parser.c @@ -1390,6 +1390,17 @@ c_parser_skip_to_end_of_block_or_statement (c_parser *parser) ++nesting_depth; break; + case CPP_OPEN_PAREN: + /* Track parentheses in case the statement is a standalone 'for' + statement - we want to skip over the semicolons separating the + operands. */ + nesting_depth++; + break; + + case CPP_CLOSE_PAREN: + nesting_depth--; + break; + case CPP_PRAGMA: /* If we see a pragma, consume the whole thing at once. We have some safeguards against consuming pragmas willy-nilly. @@ -1586,6 +1597,8 @@ static bool c_parser_omp_cancellation_point (c_parser *, enum pragma_context); static bool c_parser_omp_target (c_parser *, enum pragma_context, bool *); static void c_parser_omp_end_declare_target (c_parser *); static bool c_parser_omp_declare (c_parser *, enum pragma_context); +static tree c_parser_omp_metadirective (location_t, c_parser *, char *, + omp_clause_mask, tree *, bool *); static void c_parser_omp_requires (c_parser *); static bool c_parser_omp_error (c_parser *, enum pragma_context); static bool c_parser_omp_ordered (c_parser *, enum pragma_context, bool *); @@ -19187,6 +19200,7 @@ c_parser_omp_for_loop (location_t loc, c_parser *parser, enum tree_code code, location_t for_loc; bool tiling = false; bool inscan = false; + vec *for_block = make_tree_vector (); for (cl = clauses; cl; cl = OMP_CLAUSE_CHAIN (cl)) @@ -21398,7 +21412,8 @@ static const char *const omp_user_selectors[] = { score(score-expression) */ static tree -c_parser_omp_context_selector (c_parser *parser, tree set, tree parms) +c_parser_omp_context_selector (c_parser *parser, tree set, tree parms, + bool metadirective_p) { tree ret = NULL_TREE; do @@ -21606,10 +21621,16 @@ c_parser_omp_context_selector (c_parser *parser, tree set, tree parms) { mark_exp_read (t); t = c_fully_fold (t, false, NULL); - if (!INTEGRAL_TYPE_P (TREE_TYPE (t)) - || !tree_fits_shwi_p (t)) + if (!metadirective_p + && (!INTEGRAL_TYPE_P (TREE_TYPE (t)) + || !tree_fits_shwi_p (t))) error_at (token->location, "property must be " - "constant integer expression"); + "constant integer expression"); + else if (metadirective_p + && !INTEGRAL_TYPE_P (TREE_TYPE (t))) + /* Allow non-constant user expressions in metadirectives. */ + error_at (token->location, "property must be " + "integer expression"); else properties = tree_cons (NULL_TREE, t, properties); } @@ -21675,7 +21696,8 @@ c_parser_omp_context_selector (c_parser *parser, tree set, tree parms) user */ static tree -c_parser_omp_context_selector_specification (c_parser *parser, tree parms) +c_parser_omp_context_selector_specification (c_parser *parser, tree parms, + bool metadirective_p = false) { tree ret = NULL_TREE; do @@ -21721,7 +21743,8 @@ c_parser_omp_context_selector_specification (c_parser *parser, tree parms) if (!braces.require_open (parser)) return error_mark_node; - tree selectors = c_parser_omp_context_selector (parser, set, parms); + tree selectors = c_parser_omp_context_selector (parser, set, parms, + metadirective_p); if (selectors == error_mark_node) ret = error_mark_node; else if (ret != error_mark_node) @@ -22930,6 +22953,368 @@ c_parser_omp_error (c_parser *parser, enum pragma_context context) return false; } +/* Helper function for c_parser_omp_metadirective. */ + +static void +analyze_metadirective_body (c_parser *parser, + vec &tokens, + vec &labels) +{ + int nesting_depth = 0; + int bracket_depth = 0; + bool ignore_label = false; + + /* Read in the body tokens to the tokens for each candidate directive. */ + while (1) + { + c_token *token = c_parser_peek_token (parser); + bool stop = false; + + if (c_parser_next_token_is_keyword (parser, RID_CASE)) + ignore_label = true; + + switch (token->type) + { + case CPP_EOF: + break; + case CPP_NAME: + if (!ignore_label + && c_parser_peek_2nd_token (parser)->type == CPP_COLON) + labels.safe_push (token->value); + goto add; + case CPP_OPEN_BRACE: + ++nesting_depth; + goto add; + case CPP_CLOSE_BRACE: + if (--nesting_depth == 0) + stop = true; + goto add; + case CPP_OPEN_PAREN: + ++bracket_depth; + goto add; + case CPP_CLOSE_PAREN: + --bracket_depth; + goto add; + case CPP_COLON: + ignore_label = false; + goto add; + case CPP_SEMICOLON: + if (nesting_depth == 0 && bracket_depth == 0) + stop = true; + goto add; + default: + add: + tokens.safe_push (*token); + if (token->type == CPP_PRAGMA) + c_parser_consume_pragma (parser); + else if (token->type == CPP_PRAGMA_EOL) + c_parser_skip_to_pragma_eol (parser); + else + c_parser_consume_token (parser); + if (stop) + break; + continue; + } + break; + } +} + +/* OpenMP 5.0: + + # pragma omp metadirective [clause[, clause]] +*/ + +static tree +c_parser_omp_metadirective (location_t loc, c_parser *parser, + char *p_name, omp_clause_mask, tree *, + bool *if_p) +{ + tree ret; + auto_vec directive_tokens; + auto_vec body_tokens; + auto_vec body_labels; + auto_vec directives; + auto_vec ctxs; + vec candidates; + bool default_seen = false; + int directive_token_idx = 0; + tree standalone_body = NULL_TREE; + + ret = make_node (OMP_METADIRECTIVE); + SET_EXPR_LOCATION (ret, loc); + TREE_TYPE (ret) = void_type_node; + OMP_METADIRECTIVE_CLAUSES (ret) = NULL_TREE; + strcat (p_name, " metadirective"); + + while (c_parser_next_token_is_not (parser, CPP_PRAGMA_EOL)) + { + if (c_parser_next_token_is_not (parser, CPP_NAME) + && c_parser_next_token_is_not (parser, CPP_KEYWORD)) + { + c_parser_error (parser, "expected % or %"); + goto error; + } + + location_t match_loc = c_parser_peek_token (parser)->location; + const char *p = IDENTIFIER_POINTER (c_parser_peek_token (parser)->value); + c_parser_consume_token (parser); + bool default_p = strcmp (p, "default") == 0; + if (default_p) + { + if (default_seen) + { + c_parser_error (parser, "there can only be one default clause " + "in a metadirective"); + goto error; + } + default_seen = true; + } + if (!(strcmp (p, "when") == 0 || default_p)) + { + c_parser_error (parser, "expected % or %"); + goto error; + } + + matching_parens parens; + tree ctx = NULL_TREE; + bool skip = false; + + if (!parens.require_open (parser)) + goto error; + + if (!default_p) + { + ctx = c_parser_omp_context_selector_specification (parser, + NULL_TREE, true); + if (ctx == error_mark_node) + goto error; + ctx = omp_check_context_selector (match_loc, ctx); + if (ctx == error_mark_node) + goto error; + + /* Remove the selector from further consideration if can be + evaluated as a non-match at this point. */ + skip = (omp_context_selector_matches (ctx, true) == 0); + + if (c_parser_next_token_is_not (parser, CPP_COLON)) + { + c_parser_error (parser, "expected colon"); + goto error; + } + c_parser_consume_token (parser); + } + + /* Read in the directive type and create a dummy pragma token for + it. */ + location_t loc = c_parser_peek_token (parser)->location; + + p = NULL; + if (c_parser_next_token_is (parser, CPP_CLOSE_PAREN)) + p = "nothing"; + else if (c_parser_next_token_is_keyword (parser, RID_FOR)) + { + p = "for"; + c_parser_consume_token (parser); + } + else if (c_parser_next_token_is (parser, CPP_NAME)) + { + p = IDENTIFIER_POINTER (c_parser_peek_token (parser)->value); + c_parser_consume_token (parser); + } + + if (p == NULL) + { + c_parser_error (parser, "expected directive name"); + goto error; + } + + const struct c_omp_directive *omp_directive + = c_omp_categorize_directive (p, NULL, NULL); + + if (omp_directive == NULL) + { + c_parser_error (parser, "unknown directive name"); + goto error; + } + if (omp_directive->id == PRAGMA_OMP_METADIRECTIVE) + { + c_parser_error (parser, + "metadirectives cannot be used as directive " + "variants"); + goto error; + } + if (omp_directive->kind == C_OMP_DIR_DECLARATIVE) + { + sorry_at (loc, "declarative directive variants are not supported"); + goto error; + } + + if (!skip) + { + c_token pragma_token; + pragma_token.type = CPP_PRAGMA; + pragma_token.location = loc; + pragma_token.pragma_kind = (enum pragma_kind) omp_directive->id; + + directives.safe_push (omp_directive); + directive_tokens.safe_push (pragma_token); + ctxs.safe_push (ctx); + } + + /* Read in tokens for the directive clauses. */ + int nesting_depth = 0; + while (1) + { + c_token *token = c_parser_peek_token (parser); + switch (token->type) + { + case CPP_EOF: + case CPP_PRAGMA_EOL: + break; + case CPP_OPEN_PAREN: + ++nesting_depth; + goto add; + case CPP_CLOSE_PAREN: + if (nesting_depth-- == 0) + break; + goto add; + default: + add: + if (!skip) + directive_tokens.safe_push (*token); + c_parser_consume_token (parser); + continue; + } + break; + } + + c_parser_consume_token (parser); + + if (!skip) + { + c_token eol_token; + memset (&eol_token, 0, sizeof (eol_token)); + eol_token.type = CPP_PRAGMA_EOL; + directive_tokens.safe_push (eol_token); + } + } + c_parser_skip_to_pragma_eol (parser); + + if (!default_seen) + { + /* Add a default clause that evaluates to 'omp nothing'. */ + const struct c_omp_directive *omp_directive + = c_omp_categorize_directive ("nothing", NULL, NULL); + + c_token pragma_token; + pragma_token.type = CPP_PRAGMA; + pragma_token.location = UNKNOWN_LOCATION; + pragma_token.pragma_kind = PRAGMA_OMP_NOTHING; + + directives.safe_push (omp_directive); + directive_tokens.safe_push (pragma_token); + ctxs.safe_push (NULL_TREE); + + c_token eol_token; + memset (&eol_token, 0, sizeof (eol_token)); + eol_token.type = CPP_PRAGMA_EOL; + directive_tokens.safe_push (eol_token); + } + + analyze_metadirective_body (parser, body_tokens, body_labels); + + /* Process each candidate directive. */ + unsigned i; + tree ctx; + + FOR_EACH_VEC_ELT (ctxs, i, ctx) + { + auto_vec tokens; + + /* Add the directive tokens. */ + do + tokens.safe_push (directive_tokens [directive_token_idx++]); + while (tokens.last ().type != CPP_PRAGMA_EOL); + + /* Add the body tokens. */ + for (unsigned j = 0; j < body_tokens.length (); j++) + tokens.safe_push (body_tokens[j]); + + /* Make sure nothing tries to read past the end of the tokens. */ + c_token eof_token; + memset (&eof_token, 0, sizeof (eof_token)); + eof_token.type = CPP_EOF; + tokens.safe_push (eof_token); + tokens.safe_push (eof_token); + + unsigned int old_tokens_avail = parser->tokens_avail; + c_token *old_tokens = parser->tokens; + + parser->tokens = tokens.address (); + parser->tokens_avail = tokens.length (); + + tree directive = c_begin_compound_stmt (true); + + /* Declare all non-local labels that occur within the directive body + as local. */ + for (unsigned j = 0; j < body_labels.length (); j++) + { + tree label = declare_label (body_labels[j]); + + C_DECLARED_LABEL_FLAG (label) = 1; + add_stmt (build_stmt (loc, DECL_EXPR, label)); + } + + c_parser_pragma (parser, pragma_compound, if_p); + directive = c_end_compound_stmt (loc, directive, true); + bool standalone_p + = directives[i]->kind == C_OMP_DIR_STANDALONE + || directives[i]->kind == C_OMP_DIR_UTILITY; + if (standalone_p) + { + /* Parsing standalone directives will not consume the body + tokens, so do that here. */ + if (standalone_body == NULL_TREE) + { + standalone_body = push_stmt_list (); + c_parser_statement (parser, if_p); + standalone_body = pop_stmt_list (standalone_body); + } + else + c_parser_skip_to_end_of_block_or_statement (parser); + } + + tree body = standalone_p ? standalone_body : NULL_TREE; + tree variant = build_tree_list (ctx, build_tree_list (directive, body)); + OMP_METADIRECTIVE_CLAUSES (ret) + = chainon (OMP_METADIRECTIVE_CLAUSES (ret), variant); + + /* Check that all valid tokens have been consumed. */ + gcc_assert (parser->tokens_avail == 2); + gcc_assert (c_parser_next_token_is (parser, CPP_EOF)); + gcc_assert (c_parser_peek_2nd_token (parser)->type == CPP_EOF); + + parser->tokens = old_tokens; + parser->tokens_avail = old_tokens_avail; + } + + /* Try to resolve the metadirective early. */ + candidates = omp_resolve_metadirective (ret); + if (!candidates.is_empty ()) + ret = c_omp_expand_metadirective (candidates); + + add_stmt (ret); + + return ret; + +error: + if (parser->in_pragma) + c_parser_skip_to_pragma_eol (parser); + c_parser_skip_to_end_of_block_or_statement (parser); + + return NULL_TREE; +} + /* Main entry point to parsing most OpenMP pragmas. */ static void @@ -23003,6 +23388,11 @@ c_parser_omp_construct (c_parser *parser, bool *if_p) strcpy (p_name, "#pragma omp"); stmt = c_parser_omp_master (loc, parser, p_name, mask, NULL, if_p); break; + case PRAGMA_OMP_METADIRECTIVE: + strcpy (p_name, "#pragma omp"); + stmt = c_parser_omp_metadirective (loc, parser, p_name, mask, NULL, + if_p); + break; case PRAGMA_OMP_PARALLEL: strcpy (p_name, "#pragma omp"); stmt = c_parser_omp_parallel (loc, parser, p_name, mask, NULL, if_p); @@ -23043,7 +23433,6 @@ c_parser_omp_construct (c_parser *parser, bool *if_p) gcc_assert (EXPR_LOCATION (stmt) != UNKNOWN_LOCATION); } - /* OpenMP 2.5: # pragma omp threadprivate (variable-list) */ diff --git a/gcc/omp-general.c b/gcc/omp-general.c index 8fcca730471..9926cfd9d5f 100644 --- a/gcc/omp-general.c +++ b/gcc/omp-general.c @@ -1260,7 +1260,7 @@ omp_context_name_list_prop (tree prop) IPA, others until vectorization. */ int -omp_context_selector_matches (tree ctx) +omp_context_selector_matches (tree ctx, bool) { int ret = 1; for (tree t1 = ctx; t1; t1 = TREE_CHAIN (t1)) @@ -2624,6 +2624,18 @@ omp_lto_input_declare_variant_alt (lto_input_block *ib, cgraph_node *node, INSERT) = entryp; } +/* Return a vector of dynamic replacement candidates for the metadirective + statement in METADIRECTIVE. Return an empty vector if the metadirective + cannot be resolved. */ + +vec +omp_resolve_metadirective (tree) +{ + vec variants = {}; + + return variants; +} + /* Encode an oacc launch argument. This matches the GOMP_LAUNCH_PACK macro on gomp-constants.h. We do not check for overflow. */ diff --git a/gcc/omp-general.h b/gcc/omp-general.h index a0c7c71148c..8c6009e9854 100644 --- a/gcc/omp-general.h +++ b/gcc/omp-general.h @@ -89,6 +89,12 @@ struct omp_for_data tree adjn1; }; +/* A structure describing a variant in a metadirective. */ + +struct omp_metadirective_variant +{ +}; + #define OACC_FN_ATTRIB "oacc function" extern tree omp_find_clause (tree clauses, enum omp_clause_code kind); @@ -108,10 +114,11 @@ extern int omp_constructor_traits_to_codes (tree, enum tree_code *); extern tree omp_check_context_selector (location_t loc, tree ctx); extern void omp_mark_declare_variant (location_t loc, tree variant, tree construct); -extern int omp_context_selector_matches (tree); +extern int omp_context_selector_matches (tree, bool = false); extern int omp_context_selector_set_compare (const char *, tree, tree); extern tree omp_get_context_selector (tree, const char *, const char *); extern tree omp_resolve_declare_variant (tree); +extern vec omp_resolve_metadirective (tree); extern tree oacc_launch_pack (unsigned code, tree device, unsigned op); extern tree oacc_replace_fn_attrib_attr (tree attribs, tree dims); extern void oacc_replace_fn_attrib (tree fn, tree dims); diff --git a/gcc/tree.def b/gcc/tree.def index e27bc3e2b1f..91f8c4db1e3 100644 --- a/gcc/tree.def +++ b/gcc/tree.def @@ -1274,6 +1274,11 @@ DEFTREECODE (OMP_TARGET_ENTER_DATA, "omp_target_enter_data", tcc_statement, 1) Operand 0: OMP_TARGET_EXIT_DATA_CLAUSES: List of clauses. */ DEFTREECODE (OMP_TARGET_EXIT_DATA, "omp_target_exit_data", tcc_statement, 1) +/* OpenMP - #pragma omp metadirective [clause1 ... clauseN] + Operand 0: OMP_METADIRECTIVE_CLAUSES: List of selectors and directive + variants. */ +DEFTREECODE (OMP_METADIRECTIVE, "omp_metadirective", tcc_statement, 1) + /* OMP_ATOMIC through OMP_ATOMIC_CAPTURE_NEW must be consecutive, or OMP_ATOMIC_SEQ_CST needs adjusting. */ diff --git a/gcc/tree.h b/gcc/tree.h index 094501bd9b1..06c8140e011 100644 --- a/gcc/tree.h +++ b/gcc/tree.h @@ -1471,6 +1471,9 @@ class auto_suppress_location_wrappers #define OMP_TARGET_EXIT_DATA_CLAUSES(NODE)\ TREE_OPERAND (OMP_TARGET_EXIT_DATA_CHECK (NODE), 0) +#define OMP_METADIRECTIVE_CLAUSES(NODE) \ + TREE_OPERAND (OMP_METADIRECTIVE_CHECK (NODE), 0) + #define OMP_SCAN_BODY(NODE) TREE_OPERAND (OMP_SCAN_CHECK (NODE), 0) #define OMP_SCAN_CLAUSES(NODE) TREE_OPERAND (OMP_SCAN_CHECK (NODE), 1) From patchwork Fri Dec 10 17:33:25 2021 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Kwok Cheung Yeung X-Patchwork-Id: 48794 Return-Path: X-Original-To: patchwork@sourceware.org Delivered-To: patchwork@sourceware.org Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id E904C3857C63 for ; Fri, 10 Dec 2021 17:34:17 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from esa2.mentor.iphmx.com (esa2.mentor.iphmx.com [68.232.141.98]) by sourceware.org (Postfix) with ESMTPS id 2E4D5385801D for ; Fri, 10 Dec 2021 17:33:58 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.1 sourceware.org 2E4D5385801D Authentication-Results: sourceware.org; dmarc=none (p=none dis=none) header.from=codesourcery.com Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=mentor.com IronPort-SDR: aIYGsMxVgx4YahJpUjJrQfpb7wbwLPNBiUpHdrhLFHWp4zsCkEyzQTlg6CAbKzL2ipvWPZ4Wdp ZderGTkDYVD4ahlU9VzrQZMypUWzKXHQvmeLesf/qmsmPmWRVIkewGYRJbNnYVPf5B/iesvkQL NSn7nFD6knkZuZIgDtrG1rjmUNbGn+vFZkalaaVkRJ2Jan4L1fPyPMjN+FxPVwNoBh8YKrFbLB 3r7bnQoeOStjHYRtxY2ocporXEtM9GSQyipfgZggaiBYnDYGD+auuoO2WQCVKlhpVYfC84kZsq 37cW2nkVfcxztsMEsW6kv8ow X-IronPort-AV: E=Sophos;i="5.88,196,1635235200"; d="scan'208,223";a="69539954" Received: from orw-gwy-01-in.mentorg.com ([192.94.38.165]) by esa2.mentor.iphmx.com with ESMTP; 10 Dec 2021 09:33:57 -0800 IronPort-SDR: dPCfseDxvx23j2+21ZbGG6L9UDgAJge74eRv5dbzmYaeFJ0DqpWcCdlskcUzUoNZZQe4rhXiqs 5+zV/bZ07nIF66hKsdTdZaAs6mNOzxpwQG3qOv8kP1l9XeVokkGHvTu2LsXPI0dASjQzXYMcpC QACU0SRGpPvhQmzVFYBMac/fcNprLX3urqcH6gwHx6WmR145gO/AhRQ6yJlID3ofOfhNW/Xp5b 8+z4IrHxy6LNiGNWxyt3t4HkCxeLZRcfIGhQ+hURDCDrcKupbx4eVDbqX823xh3FK+7YkO8v4F sRg= Message-ID: Date: Fri, 10 Dec 2021 17:33:25 +0000 MIME-Version: 1.0 User-Agent: Mozilla/5.0 (Windows NT 10.0; Win64; x64; rv:91.0) Gecko/20100101 Thunderbird/91.4.0 To: gcc-patches , Jakub Jelinek References: Subject: [PATCH 2/7] openmp: Add middle-end support for metadirectives From: Kwok Cheung Yeung In-Reply-To: X-Originating-IP: [137.202.0.90] X-ClientProxiedBy: svr-ies-mbx-11.mgc.mentorg.com (139.181.222.11) To SVR-IES-MBX-04.mgc.mentorg.com (139.181.222.4) X-Spam-Status: No, score=-11.9 required=5.0 tests=BAYES_00, GIT_PATCH_0, HEADER_FROM_DIFFERENT_DOMAINS, KAM_DMARC_STATUS, SPF_HELO_PASS, SPF_PASS, TXREP autolearn=ham autolearn_force=no version=3.4.4 X-Spam-Checker-Version: SpamAssassin 3.4.4 (2020-01-24) on server2.sourceware.org X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: gcc-patches-bounces+patchwork=sourceware.org@gcc.gnu.org Sender: "Gcc-patches" This patch contains the required support for metadirectives in the middle-end. The tree metadirective representation is gimplified into the high Gimple representation, which is structured like this: #pragma omp metadirective when (): goto body_label|end_label when (>: goto body_label|end_label default: goto body_label|end_label body_label: end_label: Each variant ends with an explicit goto to either the shared standalone body (if the variant uses it) or to the point after the body (if it does not). When lowered to low Gimple, the directive bodies move outside of the metadirective statement, retaining only the labels to the bodies, so it looks like this instead: #pragma omp metadirective when (): goto body1_label when (>: goto body2_label default: goto default_label body1_label: goto body_label|end_label body2_label: goto body_label|end_label default_label: goto body_label|end_label body_label: end_label: When scanning the OpenMP regions in the ompexp pass, we create a 'clone' of the surrounding context when recursively scanning the directive variants. If the same outer context was used for all variants, then it would appear as if all the variants were inside the region at the same time (only one variant of the metadirective is ever active at a time), which can lead to spurious errors. The rest of the code is the plumbing required to allow the Gimple metadirective statement to pass through the middle-end. GCC will emit an ICE if it makes it through to the back-end though, as the metadirective is supposed to be eliminated before it gets that far. Kwok From 1a2fcbb2191fd1dd694ea5730e54fab19d6465b4 Mon Sep 17 00:00:00 2001 From: Kwok Cheung Yeung Date: Mon, 6 Dec 2021 22:29:34 +0000 Subject: [PATCH 2/7] openmp: Add middle-end support for metadirectives This adds a new Gimple statement type GIMPLE_OMP_METADIRECTIVE, which represents the metadirective in Gimple. In high Gimple, the statement contains the body of the directive variants, whereas in low Gimple, it only contains labels to the bodies. This patch adds support for converting metadirectives from tree to Gimple form, and handling of the Gimple form (Gimple lowering, OpenMP lowering and expansion, inlining, SSA handling etc). Metadirectives should be resolved before they reach the back-end, otherwise the compiler will crash as GCC does not know how to convert metadirective Gimple statements to RTX. 2021-12-10 Kwok Cheung Yeung gcc/ * gimple-low.c (lower_omp_metadirective): New. (lower_stmt): Handle GIMPLE_OMP_METADIRECTIVE. * gimple-pretty-print.c (dump_gimple_omp_metadirective): New. (pp_gimple_stmt_1): Handle GIMPLE_OMP_METADIRECTIVE. * gimple-walk.c (walk_gimple_op): Handle GIMPLE_OMP_METADIRECTIVE. (walk_gimple_stmt): Likewise. * gimple.c (gimple_alloc_omp_metadirective): New. (gimple_build_omp_metadirective): New. (gimple_build_omp_metadirective_variant): New. * gimple.def (GIMPLE_OMP_METADIRECTIVE): New. (GIMPLE_OMP_METADIRECTIVE_VARIANT): New. * gimple.h (gomp_metadirective_variant): New. (gomp_metadirective): New. (is_a_helper ::test): New. (is_a_helper ::test): New. (is_a_helper ::test): New. (is_a_helper ::test): New. (gimple_alloc_omp_metadirective): New prototype. (gimple_build_omp_metadirective): New prototype. (gimple_build_omp_metadirective_variant): New prototype. (gimple_has_substatements): Add GIMPLE_OMP_METADIRECTIVE case. (gimple_has_ops): Add GIMPLE_OMP_METADIRECTIVE. (gimple_omp_metadirective_label): New. (gimple_omp_metadirective_set_label): New. (gimple_omp_metadirective_variants): New. (gimple_omp_metadirective_set_variants): New. (CASE_GIMPLE_OMP): Add GIMPLE_OMP_METADIRECTIVE. * gimplify.c (is_gimple_stmt): Add OMP_METADIRECTIVE. (expand_omp_metadirective): New. (gimplify_omp_metadirective): New. (gimplify_expr): Add case for OMP_METADIRECTIVE. * gsstruct.def (GSS_OMP_METADIRECTIVE): New. (GSS_OMP_METADIRECTIVE_VARIANT): New. * omp-expand.c (build_omp_regions_1): Handle GIMPLE_OMP_METADIRECTIVE. (omp_make_gimple_edges): Likewise. * omp-low.c (struct omp_context): Add next_clone field. (new_omp_context): Initialize next_clone field. (clone_omp_context): New. (delete_omp_context): Delete clone contexts. (scan_omp_metadirective): New. (scan_omp_1_stmt): Handle GIMPLE_OMP_METADIRECTIVE. (lower_omp_metadirective): New. (lower_omp_1): Handle GIMPLE_OMP_METADIRECTIVE. * tree-cfg.c (cleanup_dead_labels): Handle GIMPLE_OMP_METADIRECTIVE. (gimple_redirect_edge_and_branch): Likewise. * tree-inline.c (remap_gimple_stmt): Handle GIMPLE_OMP_METADIRECTIVE. (estimate_num_insns): Likewise. * tree-pretty-print.c (dump_generic_node): Handle OMP_METADIRECTIVE. * tree-ssa-operands.c (parse_ssa_operands): Handle GIMPLE_OMP_METADIRECTIVE. --- gcc/gimple-low.c | 34 +++++++++++++ gcc/gimple-pretty-print.c | 63 ++++++++++++++++++++++++ gcc/gimple-walk.c | 31 ++++++++++++ gcc/gimple.c | 35 +++++++++++++ gcc/gimple.def | 7 +++ gcc/gimple.h | 100 +++++++++++++++++++++++++++++++++++++- gcc/gimplify.c | 94 +++++++++++++++++++++++++++++++++++ gcc/gsstruct.def | 2 + gcc/omp-expand.c | 28 +++++++++++ gcc/omp-low.c | 66 +++++++++++++++++++++++++ gcc/tree-cfg.c | 24 +++++++++ gcc/tree-inline.c | 36 ++++++++++++++ gcc/tree-pretty-print.c | 34 +++++++++++++ gcc/tree-ssa-operands.c | 27 ++++++++++ 14 files changed, 580 insertions(+), 1 deletion(-) diff --git a/gcc/gimple-low.c b/gcc/gimple-low.c index 7e39c22df44..723c8b1d516 100644 --- a/gcc/gimple-low.c +++ b/gcc/gimple-low.c @@ -234,6 +234,34 @@ lower_omp_directive (gimple_stmt_iterator *gsi, struct lower_data *data) gsi_next (gsi); } +/* Lower the OpenMP metadirective statement pointed by GSI. */ + +static void +lower_omp_metadirective (gimple_stmt_iterator *gsi, struct lower_data *data) +{ + gimple *stmt = gsi_stmt (*gsi); + gimple *variant = gimple_omp_metadirective_variants (stmt); + unsigned i; + + /* The variants are not used after lowering. */ + gimple_omp_metadirective_set_variants (stmt, NULL); + + for (i = 0; i < gimple_num_ops (stmt); i++) + { + tree label = create_artificial_label (UNKNOWN_LOCATION); + gimple_omp_metadirective_set_label (stmt, i, label); + gsi_insert_after (gsi, gimple_build_label (label), GSI_CONTINUE_LINKING); + + gimple_seq *directive_ptr = gimple_omp_body_ptr (variant); + lower_sequence (directive_ptr, data); + gsi_insert_seq_after (gsi, *directive_ptr, GSI_CONTINUE_LINKING); + + variant = variant->next; + } + + gsi_next (gsi); +} + /* Lower statement GSI. DATA is passed through the recursion. We try to track the fallthruness of statements and get rid of unreachable return @@ -400,6 +428,12 @@ lower_stmt (gimple_stmt_iterator *gsi, struct lower_data *data) data->cannot_fallthru = false; return; + case GIMPLE_OMP_METADIRECTIVE: + data->cannot_fallthru = false; + lower_omp_metadirective (gsi, data); + data->cannot_fallthru = false; + return; + case GIMPLE_TRANSACTION: lower_sequence (gimple_transaction_body_ptr ( as_a (stmt)), diff --git a/gcc/gimple-pretty-print.c b/gcc/gimple-pretty-print.c index 1cd1597359e..da263137f5b 100644 --- a/gcc/gimple-pretty-print.c +++ b/gcc/gimple-pretty-print.c @@ -2051,6 +2051,63 @@ dump_gimple_omp_return (pretty_printer *buffer, const gimple *gs, int spc, } } +/* Dump a GIMPLE_OMP_METADIRECTIVE tuple on the pretty_printer BUFFER. */ + +static void +dump_gimple_omp_metadirective (pretty_printer *buffer, const gimple *gs, + int spc, dump_flags_t flags) +{ + if (flags & TDF_RAW) + { + dump_gimple_fmt (buffer, spc, flags, "%G <%+BODY <%S> >", gs, + gimple_omp_body (gs)); + } + else + { + pp_string (buffer, "#pragma omp metadirective"); + newline_and_indent (buffer, spc + 2); + + gimple *variant = gimple_omp_metadirective_variants (gs); + + for (unsigned i = 0; i < gimple_num_ops (gs); i++) + { + tree selector = gimple_op (gs, i); + + if (selector == NULL_TREE) + pp_string (buffer, "default:"); + else + { + pp_string (buffer, "when ("); + dump_generic_node (buffer, selector, spc, flags, false); + pp_string (buffer, "):"); + } + + if (variant != NULL) + { + newline_and_indent (buffer, spc + 4); + pp_left_brace (buffer); + pp_newline (buffer); + dump_gimple_seq (buffer, gimple_omp_body (variant), spc + 6, + flags); + newline_and_indent (buffer, spc + 4); + pp_right_brace (buffer); + + variant = variant->next; + } + else + { + tree label = gimple_omp_metadirective_label (gs, i); + + pp_string (buffer, " "); + dump_generic_node (buffer, label, spc, flags, false); + } + + if (i != gimple_num_ops (gs) - 1) + newline_and_indent (buffer, spc + 2); + } + } +} + /* Dump a GIMPLE_TRANSACTION tuple on the pretty_printer BUFFER. */ static void @@ -2823,6 +2880,12 @@ pp_gimple_stmt_1 (pretty_printer *buffer, const gimple *gs, int spc, flags); break; + case GIMPLE_OMP_METADIRECTIVE: + dump_gimple_omp_metadirective (buffer, + as_a (gs), + spc, flags); + break; + case GIMPLE_CATCH: dump_gimple_catch (buffer, as_a (gs), spc, flags); break; diff --git a/gcc/gimple-walk.c b/gcc/gimple-walk.c index e15fd4697ba..b8db0fe34b2 100644 --- a/gcc/gimple-walk.c +++ b/gcc/gimple-walk.c @@ -485,6 +485,21 @@ walk_gimple_op (gimple *stmt, walk_tree_fn callback_op, } break; + case GIMPLE_OMP_METADIRECTIVE: + { + gimple *variant = gimple_omp_metadirective_variants (stmt); + + while (variant) + { + ret = walk_gimple_op (gimple_omp_body (variant), callback_op, wi); + if (ret) + return ret; + + variant = variant->next; + } + } + break; + case GIMPLE_TRANSACTION: { gtransaction *txn = as_a (stmt); @@ -700,6 +715,22 @@ walk_gimple_stmt (gimple_stmt_iterator *gsi, walk_stmt_fn callback_stmt, return wi->callback_result; break; + case GIMPLE_OMP_METADIRECTIVE: + { + gimple *variant = gimple_omp_metadirective_variants (stmt); + + while (variant) + { + ret = walk_gimple_seq_mod (gimple_omp_body_ptr (variant), + callback_stmt, callback_op, wi); + if (ret) + return wi->callback_result; + + variant = variant->next; + } + } + break; + case GIMPLE_WITH_CLEANUP_EXPR: ret = walk_gimple_seq_mod (gimple_wce_cleanup_ptr (stmt), callback_stmt, callback_op, wi); diff --git a/gcc/gimple.c b/gcc/gimple.c index 037c6e4c827..99f3a8de2ea 100644 --- a/gcc/gimple.c +++ b/gcc/gimple.c @@ -1267,6 +1267,41 @@ gimple_build_omp_atomic_store (tree val, enum omp_memory_order mo) return p; } +/* Allocate extra memory for a GIMPLE_OMP_METADIRECTIVE statement. */ + +void +gimple_alloc_omp_metadirective (gimple *g) +{ + gomp_metadirective *p = as_a (g); + + p->labels = ggc_cleared_vec_alloc (gimple_num_ops (p)); +} + +/* Build a GIMPLE_OMP_METADIRECTIVE statement. */ + +gomp_metadirective * +gimple_build_omp_metadirective (int num_variants) +{ + gomp_metadirective *p + = as_a (gimple_alloc (GIMPLE_OMP_METADIRECTIVE, + num_variants)); + gimple_alloc_omp_metadirective (p); + gimple_omp_metadirective_set_variants (p, NULL); + + return p; +} + +/* Build a GIMPLE_OMP_METADIRECTIVE_VARIANT statement. */ + +gomp_metadirective_variant * +gimple_build_omp_metadirective_variant (gimple_seq body) +{ + gomp_metadirective_variant *variant = as_a + (gimple_alloc (GIMPLE_OMP_METADIRECTIVE_VARIANT, 0)); + gimple_omp_set_body (variant, body); + return variant; +} + /* Build a GIMPLE_TRANSACTION statement. */ gtransaction * diff --git a/gcc/gimple.def b/gcc/gimple.def index 193b2506523..55ff9883193 100644 --- a/gcc/gimple.def +++ b/gcc/gimple.def @@ -393,6 +393,13 @@ DEFGSCODE(GIMPLE_OMP_TEAMS, "gimple_omp_teams", GSS_OMP_PARALLEL_LAYOUT) CLAUSES is an OMP_CLAUSE chain holding the associated clauses. */ DEFGSCODE(GIMPLE_OMP_ORDERED, "gimple_omp_ordered", GSS_OMP_SINGLE_LAYOUT) +/* GIMPLE_OMP_METADIRECTIVE represents #pragma omp metadirective. */ +DEFGSCODE(GIMPLE_OMP_METADIRECTIVE, "gimple_omp_metadirective", + GSS_OMP_METADIRECTIVE) + +DEFGSCODE(GIMPLE_OMP_METADIRECTIVE_VARIANT, + "gimple_omp_metadirective_variant", GSS_OMP_METADIRECTIVE_VARIANT) + /* GIMPLE_PREDICT specifies a hint for branch prediction. PREDICT is one of the predictors from predict.def. diff --git a/gcc/gimple.h b/gcc/gimple.h index f7fdefc5362..8554d288e42 100644 --- a/gcc/gimple.h +++ b/gcc/gimple.h @@ -824,6 +824,30 @@ struct GTY((tag("GSS_OMP_ATOMIC_STORE_LAYOUT"))) stmt->code == GIMPLE_OMP_RETURN. */ }; +struct GTY((tag("GSS_OMP_METADIRECTIVE_VARIANT"))) + gomp_metadirective_variant : public gimple_statement_omp +{ + /* The body in the base class contains the directive for this variant. */ + + /* No extra fields; adds invariant: + stmt->code == GIMPLE_OMP_METADIRECTIVE_VARIANT. */}; + +struct GTY((tag("GSS_OMP_METADIRECTIVE"))) + gomp_metadirective : public gimple_statement_with_ops_base +{ + /* [ WORD 1-7 ] : base class */ + + /* [ WORD 8 ] : a list of bodies associated with the directive variants. */ + gomp_metadirective_variant *variants; + + /* [ WORD 9 ] : label vector. */ + tree * GTY((length ("%h.num_ops"))) labels; + + /* [ WORD 10 ] : operand vector. Used to hold the selectors for the + directive variants. */ + tree GTY((length ("%h.num_ops"))) op[1]; +}; + /* GIMPLE_TRANSACTION. */ /* Bits to be stored in the GIMPLE_TRANSACTION subcode. */ @@ -1235,6 +1259,22 @@ is_a_helper ::test (gimple *gs) return gs->code == GIMPLE_OMP_TASK; } +template <> +template <> +inline bool +is_a_helper ::test (gimple *gs) +{ + return gs->code == GIMPLE_OMP_METADIRECTIVE; +} + +template <> +template <> +inline bool +is_a_helper ::test (gimple *gs) +{ + return gs->code == GIMPLE_OMP_METADIRECTIVE_VARIANT; +} + template <> template <> inline bool @@ -1477,6 +1517,22 @@ is_a_helper ::test (const gimple *gs) return gs->code == GIMPLE_OMP_TASK; } +template <> +template <> +inline bool +is_a_helper ::test (const gimple *gs) +{ + return gs->code == GIMPLE_OMP_METADIRECTIVE; +} + +template <> +template <> +inline bool +is_a_helper ::test (const gimple *gs) +{ + return gs->code == GIMPLE_OMP_METADIRECTIVE_VARIANT; +} + template <> template <> inline bool @@ -1576,6 +1632,9 @@ gomp_teams *gimple_build_omp_teams (gimple_seq, tree); gomp_atomic_load *gimple_build_omp_atomic_load (tree, tree, enum omp_memory_order); gomp_atomic_store *gimple_build_omp_atomic_store (tree, enum omp_memory_order); +void gimple_alloc_omp_metadirective (gimple *g); +gomp_metadirective *gimple_build_omp_metadirective (int num_variants); +gomp_metadirective_variant *gimple_build_omp_metadirective_variant (gimple_seq body); gtransaction *gimple_build_transaction (gimple_seq); extern void gimple_seq_add_stmt (gimple_seq *, gimple *); extern void gimple_seq_add_stmt_without_update (gimple_seq *, gimple *); @@ -1853,6 +1912,7 @@ gimple_has_substatements (gimple *g) case GIMPLE_OMP_TARGET: case GIMPLE_OMP_TEAMS: case GIMPLE_OMP_CRITICAL: + case GIMPLE_OMP_METADIRECTIVE: case GIMPLE_WITH_CLEANUP_EXPR: case GIMPLE_TRANSACTION: return true; @@ -2110,7 +2170,8 @@ gimple_init_singleton (gimple *g) static inline bool gimple_has_ops (const gimple *g) { - return gimple_code (g) >= GIMPLE_COND && gimple_code (g) <= GIMPLE_RETURN; + return (gimple_code (g) >= GIMPLE_COND && gimple_code (g) <= GIMPLE_RETURN) + || gimple_code (g) == GIMPLE_OMP_METADIRECTIVE; } template <> @@ -6488,6 +6549,42 @@ gimple_omp_continue_set_control_use (gomp_continue *cont_stmt, tree use) cont_stmt->control_use = use; } + +static inline tree +gimple_omp_metadirective_label (const gimple *g, unsigned i) +{ + const gomp_metadirective *omp_metadirective + = as_a (g); + return omp_metadirective->labels[i]; +} + + +static inline void +gimple_omp_metadirective_set_label (gimple *g, unsigned i, tree label) +{ + gomp_metadirective *omp_metadirective = as_a (g); + omp_metadirective->labels[i] = label; +} + + +static inline gomp_metadirective_variant * +gimple_omp_metadirective_variants (const gimple *g) +{ + const gomp_metadirective *omp_metadirective + = as_a (g); + return omp_metadirective->variants; +} + + +static inline void +gimple_omp_metadirective_set_variants (gimple *g, gimple *variants) +{ + gomp_metadirective *omp_metadirective = as_a (g); + omp_metadirective->variants + = variants ? as_a (variants) : NULL; +} + + /* Return a pointer to the body for the GIMPLE_TRANSACTION statement TRANSACTION_STMT. */ @@ -6638,6 +6735,7 @@ gimple_return_set_retval (greturn *gs, tree retval) case GIMPLE_OMP_RETURN: \ case GIMPLE_OMP_ATOMIC_LOAD: \ case GIMPLE_OMP_ATOMIC_STORE: \ + case GIMPLE_OMP_METADIRECTIVE: \ case GIMPLE_OMP_CONTINUE static inline bool diff --git a/gcc/gimplify.c b/gcc/gimplify.c index b118c72f62c..ed72162bb7f 100644 --- a/gcc/gimplify.c +++ b/gcc/gimplify.c @@ -5787,6 +5787,7 @@ is_gimple_stmt (tree t) case OMP_TASKGROUP: case OMP_ORDERED: case OMP_CRITICAL: + case OMP_METADIRECTIVE: case OMP_TASK: case OMP_TARGET: case OMP_TARGET_DATA: @@ -14680,6 +14681,94 @@ gimplify_omp_ordered (tree expr, gimple_seq body) return gimple_build_omp_ordered (body, OMP_ORDERED_CLAUSES (expr)); } +/* Replace a metadirective with the candidate directive variants in + CANDIDATES. */ + +static enum gimplify_status +expand_omp_metadirective (vec &, + gimple_seq *) +{ + return GS_ERROR; +} + +/* Gimplify an OMP_METADIRECTIVE construct. EXPR is the tree version. + The metadirective will be resolved at this point if possible. */ + +static enum gimplify_status +gimplify_omp_metadirective (tree *expr_p, gimple_seq *pre_p, gimple_seq *, + bool (*) (tree), fallback_t) +{ + auto_vec selectors; + + /* Try to resolve the metadirective. */ + vec candidates + = omp_resolve_metadirective (*expr_p); + if (!candidates.is_empty ()) + return expand_omp_metadirective (candidates, pre_p); + + /* The metadirective cannot be resolved yet. */ + + gomp_metadirective_variant *first_variant = NULL; + gomp_metadirective_variant *prev_variant = NULL; + gimple_seq standalone_body = NULL; + tree body_label = NULL; + tree end_label = create_artificial_label (UNKNOWN_LOCATION); + + for (tree clause = OMP_METADIRECTIVE_CLAUSES (*expr_p); clause != NULL_TREE; + clause = TREE_CHAIN (clause)) + { + tree selector = TREE_PURPOSE (clause); + tree directive = TREE_PURPOSE (TREE_VALUE (clause)); + tree body = TREE_VALUE (TREE_VALUE (clause)); + + selectors.safe_push (selector); + gomp_metadirective_variant *variant + = gimple_build_omp_metadirective_variant (NULL); + gimple_seq *directive_p = gimple_omp_body_ptr (variant); + + gimplify_stmt (&directive, directive_p); + if (body != NULL_TREE) + { + if (standalone_body == NULL) + { + gimplify_stmt (&body, &standalone_body); + body_label = create_artificial_label (UNKNOWN_LOCATION); + } + gimplify_seq_add_stmt (directive_p, gimple_build_goto (body_label)); + } + else + gimplify_seq_add_stmt (directive_p, gimple_build_goto (end_label)); + + if (!first_variant) + first_variant = variant; + if (prev_variant) + { + prev_variant->next = variant; + variant->prev = prev_variant; + } + prev_variant = variant; + } + + gomp_metadirective *stmt + = gimple_build_omp_metadirective (selectors.length ()); + gimple_omp_metadirective_set_variants (stmt, first_variant); + + tree selector; + unsigned int i; + FOR_EACH_VEC_ELT (selectors, i, selector) + gimple_set_op (stmt, i, selector); + + gimplify_seq_add_stmt (pre_p, stmt); + if (standalone_body) + { + gimplify_seq_add_stmt (pre_p, gimple_build_label (body_label)); + gimplify_seq_add_stmt (pre_p, standalone_body); + } + gimplify_seq_add_stmt (pre_p, gimple_build_label (end_label)); + + return GS_ALL_DONE; +} + /* Convert the GENERIC expression tree *EXPR_P to GIMPLE. If the expression produces a value to be used as an operand inside a GIMPLE statement, the value will be stored back in *EXPR_P. This value will @@ -15586,6 +15675,11 @@ gimplify_expr (tree *expr_p, gimple_seq *pre_p, gimple_seq *post_p, ret = gimplify_omp_atomic (expr_p, pre_p); break; + case OMP_METADIRECTIVE: + ret = gimplify_omp_metadirective (expr_p, pre_p, post_p, + gimple_test_f, fallback); + break; + case TRANSACTION_EXPR: ret = gimplify_transaction (expr_p, pre_p); break; diff --git a/gcc/gsstruct.def b/gcc/gsstruct.def index 8f777e2bb95..ff10605baec 100644 --- a/gcc/gsstruct.def +++ b/gcc/gsstruct.def @@ -50,4 +50,6 @@ DEFGSSTRUCT(GSS_OMP_SINGLE_LAYOUT, gimple_statement_omp_single_layout, false) DEFGSSTRUCT(GSS_OMP_CONTINUE, gomp_continue, false) DEFGSSTRUCT(GSS_OMP_ATOMIC_LOAD, gomp_atomic_load, false) DEFGSSTRUCT(GSS_OMP_ATOMIC_STORE_LAYOUT, gomp_atomic_store, false) +DEFGSSTRUCT(GSS_OMP_METADIRECTIVE, gomp_metadirective, true) +DEFGSSTRUCT(GSS_OMP_METADIRECTIVE_VARIANT, gomp_metadirective_variant, false) DEFGSSTRUCT(GSS_TRANSACTION, gtransaction, false) diff --git a/gcc/omp-expand.c b/gcc/omp-expand.c index c5fa5a01aac..3bf81e1ae95 100644 --- a/gcc/omp-expand.c +++ b/gcc/omp-expand.c @@ -10418,6 +10418,10 @@ build_omp_regions_1 (basic_block bb, struct omp_region *parent, /* GIMPLE_OMP_SECTIONS_SWITCH is part of GIMPLE_OMP_SECTIONS, and we do nothing for it. */ } + else if (code == GIMPLE_OMP_METADIRECTIVE) + { + /* Do nothing for metadirectives. */ + } else { region = new_omp_region (bb, code, parent); @@ -10791,6 +10795,30 @@ omp_make_gimple_edges (basic_block bb, struct omp_region **region, } break; + case GIMPLE_OMP_METADIRECTIVE: + /* Create an edge to the beginning of the body of each candidate + directive. */ + { + gimple *stmt = last_stmt (bb); + unsigned i; + bool seen_default = false; + + for (i = 0; i < gimple_num_ops (stmt); i++) + { + tree dest = gimple_omp_metadirective_label (stmt, i); + basic_block dest_bb = label_to_block (cfun, dest); + make_edge (bb, dest_bb, 0); + + if (gimple_op (stmt, i) == NULL_TREE) + seen_default = true; + } + + gcc_assert (seen_default); + + fallthru = false; + } + break; + default: gcc_unreachable (); } diff --git a/gcc/omp-low.c b/gcc/omp-low.c index 2a07beb4eaf..accea81e8af 100644 --- a/gcc/omp-low.c +++ b/gcc/omp-low.c @@ -183,6 +183,10 @@ struct omp_context /* Candidates for adjusting OpenACC privatization level. */ vec oacc_privatization_candidates; + + /* Only used for omp metadirectives. Links to the next shallow + clone of this context. */ + struct omp_context *next_clone; }; static splay_tree all_contexts; @@ -985,6 +989,7 @@ new_omp_context (gimple *stmt, omp_context *outer_ctx) splay_tree_insert (all_contexts, (splay_tree_key) stmt, (splay_tree_value) ctx); ctx->stmt = stmt; + ctx->next_clone = NULL; if (outer_ctx) { @@ -1014,6 +1019,18 @@ new_omp_context (gimple *stmt, omp_context *outer_ctx) return ctx; } +static omp_context * +clone_omp_context (omp_context *ctx) +{ + omp_context *clone_ctx = XCNEW (omp_context); + + memcpy (clone_ctx, ctx, sizeof (omp_context)); + ctx->next_clone = clone_ctx; + clone_ctx->next_clone = NULL; + + return clone_ctx; +} + static gimple_seq maybe_catch_exception (gimple_seq); /* Finalize task copyfn. */ @@ -1060,6 +1077,15 @@ delete_omp_context (splay_tree_value value) { omp_context *ctx = (omp_context *) value; + /* Delete clones. */ + omp_context *clone = ctx->next_clone; + while (clone) + { + omp_context *next_clone = clone->next_clone; + XDELETE (clone); + clone = next_clone; + } + delete ctx->cb.decl_map; if (ctx->field_map) @@ -3091,6 +3117,24 @@ scan_omp_teams (gomp_teams *stmt, omp_context *outer_ctx) ctx->record_type = ctx->receiver_decl = NULL; } +/* Scan an OpenMP metadirective. */ + +static void +scan_omp_metadirective (gomp_metadirective *stmt, omp_context *outer_ctx) +{ + gomp_metadirective_variant *variant + = gimple_omp_metadirective_variants (stmt); + + while (variant) + { + gimple_seq *directive_p = gimple_omp_body_ptr (variant); + omp_context *ctx = outer_ctx ? clone_omp_context (outer_ctx) : NULL; + + scan_omp (directive_p, ctx); + variant = (gomp_metadirective_variant *) variant->next; + } +} + /* Check nesting restrictions. */ static bool check_omp_nesting_restrictions (gimple *stmt, omp_context *ctx) @@ -4235,6 +4279,10 @@ scan_omp_1_stmt (gimple_stmt_iterator *gsi, bool *handled_ops_p, scan_omp_teams (as_a (stmt), ctx); break; + case GIMPLE_OMP_METADIRECTIVE: + scan_omp_metadirective (as_a (stmt), ctx); + break; + case GIMPLE_BIND: { tree var; @@ -10654,6 +10702,21 @@ oacc_privatization_scan_decl_chain (omp_context *ctx, tree decls) } } +static void +lower_omp_metadirective (gimple_stmt_iterator *gsi_p, omp_context *ctx) +{ + gimple *stmt = gsi_stmt (*gsi_p); + gomp_metadirective_variant *variant + = gimple_omp_metadirective_variants (stmt); + while (variant) + { + gimple_seq *directive_p = gimple_omp_body_ptr (variant); + lower_omp (directive_p, ctx); + + variant = (gomp_metadirective_variant *) (variant->next); + } +} + /* Callback for walk_gimple_seq. Find #pragma omp scan statement. */ static tree @@ -14230,6 +14293,9 @@ lower_omp_1 (gimple_stmt_iterator *gsi_p, omp_context *ctx) else lower_omp_teams (gsi_p, ctx); break; + case GIMPLE_OMP_METADIRECTIVE: + lower_omp_metadirective (gsi_p, ctx); + break; case GIMPLE_CALL: tree fndecl; call_stmt = as_a (stmt); diff --git a/gcc/tree-cfg.c b/gcc/tree-cfg.c index ebbd894ae03..7066d9fb471 100644 --- a/gcc/tree-cfg.c +++ b/gcc/tree-cfg.c @@ -1670,6 +1670,18 @@ cleanup_dead_labels (void) } break; + case GIMPLE_OMP_METADIRECTIVE: + { + for (unsigned i = 0; i < gimple_num_ops (stmt); i++) + { + label = gimple_omp_metadirective_label (stmt, i); + new_label = main_block_label (label, label_for_bb); + if (new_label != label) + gimple_omp_metadirective_set_label (stmt, i, new_label); + } + } + break; + default: break; } @@ -6147,6 +6159,18 @@ gimple_redirect_edge_and_branch (edge e, basic_block dest) gimple_block_label (dest)); break; + case GIMPLE_OMP_METADIRECTIVE: + { + for (unsigned i = 0; i < gimple_num_ops (stmt); i++) + { + tree label = gimple_omp_metadirective_label (stmt, i); + if (label_to_block (cfun, label) == e->dest) + gimple_omp_metadirective_set_label (stmt, i, + gimple_block_label (dest)); + } + } + break; + default: /* Otherwise it must be a fallthru edge, and we don't need to do anything besides redirecting it. */ diff --git a/gcc/tree-inline.c b/gcc/tree-inline.c index bc5ff0bb052..0f0035fef3b 100644 --- a/gcc/tree-inline.c +++ b/gcc/tree-inline.c @@ -1674,6 +1674,35 @@ remap_gimple_stmt (gimple *stmt, copy_body_data *id) (s1, gimple_omp_masked_clauses (stmt)); break; + case GIMPLE_OMP_METADIRECTIVE: + copy = gimple_build_omp_metadirective (gimple_num_ops (stmt)); + { + gimple *first_variant = NULL; + gimple **prev_next = &first_variant; + for (gimple *variant = gimple_omp_metadirective_variants (stmt); + variant; variant = variant->next) + { + s1 = remap_gimple_seq (gimple_omp_body (variant), id); + gimple *new_variant + = gimple_build_omp_metadirective_variant (s1); + + *prev_next = new_variant; + prev_next = &new_variant->next; + } + gimple_omp_metadirective_set_variants (copy, first_variant); + } + + memset (&wi, 0, sizeof (wi)); + wi.info = id; + for (unsigned i = 0; i < gimple_num_ops (stmt); i++) + { + tree label = gimple_omp_metadirective_label (stmt, i); + walk_tree (&label, remap_gimple_op_r, &wi, NULL); + gimple_omp_metadirective_set_label (copy, i, label); + gimple_set_op (copy, i, gimple_op (stmt, i)); + } + break; + case GIMPLE_OMP_SCOPE: s1 = remap_gimple_seq (gimple_omp_body (stmt), id); copy = gimple_build_omp_scope @@ -4590,6 +4619,13 @@ estimate_num_insns (gimple *stmt, eni_weights *weights) return (weights->omp_cost + estimate_num_insns_seq (gimple_omp_body (stmt), weights)); + case GIMPLE_OMP_METADIRECTIVE: + /* The actual instruction will disappear eventually, so metadirective + statements have zero additional cost (if only static selectors + are used). */ + /* TODO: Estimate the cost of evaluating dynamic selectors */ + return 0; + case GIMPLE_TRANSACTION: return (weights->tm_cost + estimate_num_insns_seq (gimple_transaction_body ( diff --git a/gcc/tree-pretty-print.c b/gcc/tree-pretty-print.c index a81ba401ef9..eb45f7d6bdf 100644 --- a/gcc/tree-pretty-print.c +++ b/gcc/tree-pretty-print.c @@ -3751,6 +3751,40 @@ dump_generic_node (pretty_printer *pp, tree node, int spc, dump_flags_t flags, is_expr = false; break; + case OMP_METADIRECTIVE: + { + pp_string (pp, "#pragma omp metadirective"); + newline_and_indent (pp, spc + 2); + pp_left_brace (pp); + + tree clause = OMP_METADIRECTIVE_CLAUSES (node); + while (clause != NULL_TREE) + { + newline_and_indent (pp, spc + 4); + if (TREE_PURPOSE (clause) == NULL_TREE) + pp_string (pp, "default:"); + else + { + pp_string (pp, "when ("); + dump_generic_node (pp, TREE_PURPOSE (clause), spc + 4, flags, + false); + pp_string (pp, "):"); + } + newline_and_indent (pp, spc + 6); + + tree variant = TREE_VALUE (clause); + dump_generic_node (pp, TREE_PURPOSE (variant), spc + 6, flags, + false); + newline_and_indent (pp, spc + 6); + dump_generic_node (pp, TREE_VALUE (variant), spc + 6, flags, + false); + clause = TREE_CHAIN (clause); + } + newline_and_indent (pp, spc + 2); + pp_right_brace (pp); + } + break; + case TRANSACTION_EXPR: if (TRANSACTION_EXPR_OUTER (node)) pp_string (pp, "__transaction_atomic [[outer]]"); diff --git a/gcc/tree-ssa-operands.c b/gcc/tree-ssa-operands.c index ebf7eea3b04..d17e4144df7 100644 --- a/gcc/tree-ssa-operands.c +++ b/gcc/tree-ssa-operands.c @@ -973,6 +973,33 @@ operands_scanner::parse_ssa_operands () append_vuse (gimple_vop (fn)); goto do_default; + case GIMPLE_OMP_METADIRECTIVE: + n = gimple_num_ops (stmt); + for (i = start; i < n; i++) + { + for (tree selector = gimple_op (stmt, i); + selector != NULL; + selector = TREE_CHAIN (selector)) + { + if (TREE_PURPOSE (selector) == get_identifier ("user")) + { + for (tree property = TREE_VALUE (selector); + property != NULL; + property = TREE_CHAIN (property)) + if (TREE_PURPOSE (property) + == get_identifier ("condition")) + { + for (tree condition = TREE_VALUE (property); + condition != NULL; + condition = TREE_CHAIN (condition)) + get_expr_operands (&TREE_VALUE (condition), + opf_use); + } + } + } + } + break; + case GIMPLE_CALL: /* Add call-clobbered operands, if needed. */ maybe_add_call_vops (as_a (stmt)); From patchwork Fri Dec 10 17:35:05 2021 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Kwok Cheung Yeung X-Patchwork-Id: 48795 Return-Path: X-Original-To: patchwork@sourceware.org Delivered-To: patchwork@sourceware.org Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 120E03857820 for ; Fri, 10 Dec 2021 17:35:56 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from esa1.mentor.iphmx.com (esa1.mentor.iphmx.com [68.232.129.153]) by sourceware.org (Postfix) with ESMTPS id 9D8B5385801D for ; Fri, 10 Dec 2021 17:35:36 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.1 sourceware.org 9D8B5385801D Authentication-Results: sourceware.org; dmarc=none (p=none dis=none) header.from=codesourcery.com Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=mentor.com IronPort-SDR: FDuwCnhhdXAOCWf2+Kd5ZMoXOi8gcb5A4P0p4TYI7z/6YCRdiKepsDHLu+Fw4xfGE2+RgyKGaJ TBY7OOkdBLRulZAFsN4z1lAjogM+hiByiw2uEF9HQvBnpOpjrf0eivi1M2Qz9eljw3PzetZDbV EUPvkQNNWUVTOAAI6rGfjxXzXPw5z3PdINpEXrh+ZagkgKmSiC71JepTZ5TuFKRJhlQjNBtUK+ 6tHsmIo1BaWkNmNoHaLH+649G22D93WBlmlIBFEBbqcwKpuRCwk6RaIPeTiI1RNcFOshlXjqpT hYBq57P5f4LuEMBMZwe1NSX6 X-IronPort-AV: E=Sophos;i="5.88,196,1635235200"; d="scan'208,223";a="72064202" Received: from orw-gwy-01-in.mentorg.com ([192.94.38.165]) by esa1.mentor.iphmx.com with ESMTP; 10 Dec 2021 09:35:36 -0800 IronPort-SDR: lNMoIvwLMr8qDxzqzGIDaAcIT0PUBuaGqIT0J0wg6XYwDQOWQt18y0R4yt2vKdyXzFAK4CJDJQ QrPyw4Wvyabd9D+P38X+8y8/OYtvWqisUOQbuFqa9WTbyjyXKr/s10Srn6rZp+FwKxklRTmRgP +N/5vJC9rBj03YPFrkX72FS8nIdszXclx/KCqK1XcmS+NkfpsyENMMoQc7cEwO44Is9pnVI3RN /N48TLdW0o96rMq7FU1mY6fImNvFXUchcJQZJcof7utpLg5JhA315XTptHulFh4P89RkAFv8Qz 9I0= Message-ID: <3570a7bc-fbf1-93f1-9a20-a788e4e707f2@codesourcery.com> Date: Fri, 10 Dec 2021 17:35:05 +0000 MIME-Version: 1.0 User-Agent: Mozilla/5.0 (Windows NT 10.0; Win64; x64; rv:91.0) Gecko/20100101 Thunderbird/91.4.0 References: Subject: [PATCH 3/7] openmp: Add support for resolving metadirectives during parsing and Gimplification To: gcc-patches , Jakub Jelinek From: Kwok Cheung Yeung In-Reply-To: X-Originating-IP: [137.202.0.90] X-ClientProxiedBy: svr-ies-mbx-10.mgc.mentorg.com (139.181.222.10) To SVR-IES-MBX-04.mgc.mentorg.com (139.181.222.4) X-Spam-Status: No, score=-11.9 required=5.0 tests=BAYES_00, GIT_PATCH_0, HEADER_FROM_DIFFERENT_DOMAINS, KAM_DMARC_STATUS, SPF_HELO_PASS, SPF_PASS, TXREP autolearn=ham autolearn_force=no version=3.4.4 X-Spam-Checker-Version: SpamAssassin 3.4.4 (2020-01-24) on server2.sourceware.org X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: gcc-patches-bounces+patchwork=sourceware.org@gcc.gnu.org Sender: "Gcc-patches" This patch contains code to resolve metadirectives, either during parsing or Gimplification. The dynamic candidate selection algorithm from the OpenMP 5.1 spec is implemented in omp_get_dynamic_candidates in omp-general.c, which returns a vector containing information on the top-scoring candidate variants. The vector always consists of entries with dynamic selectors first, followed by a single entry with an all-static selector (which can be the default clause if all the other clauses are dynamic). If all selectors are static (i.e. OpenMP 5.0), then omp_get_dynamic_candidates will return a vector of at most length 1. If any part of the selectors in the candidate list cannot be resolved at the current stage of compilation, an empty list is returned. Note that it is possible to resolve metadirectives even with some selectors unresolvable as long as those selectors are not part of the candidate list. omp_context_selector_matches should always return 1 for dynamic selectors (since we can generate code to evaluate the condition at any time). omp_dynamic_cond, when given a selector, should return just the part of it that must be evaluated at run-time. Metadirectives are resolved in both tree and Gimple form by generating a sequence of if..then..else statements that evaluate the dynamic selector of each candidate returned from omp_get_dynamic_candidates in order, jumping to the directive body if true, to the next evaluation if not. Kwok From 65ee7342256db3c81cc6741ce2c96e36dd4a9ca6 Mon Sep 17 00:00:00 2001 From: Kwok Cheung Yeung Date: Mon, 6 Dec 2021 22:49:23 +0000 Subject: [PATCH 3/7] openmp: Add support for resolving metadirectives during parsing and Gimplification This adds support for resolving metadirectives according to the OpenMP 5.1 specification. The variants are sorted by score, then gathered into a list of dynamic replacement candidates. The metadirective is then expanded into a sequence of 'if..else' statements to test the dynamic selector and execute the variant if the selector is satisfied. If any of the selectors in the list are unresolvable, GCC will give up on resolving the metadirective and try again later. 2021-12-10 Kwok Cheung Yeung gcc/ * gimplify.c (expand_omp_metadirective): New. * omp-general.c: Include tree-pretty-print.h. (DELAY_METADIRECTIVES_AFTER_LTO): New macro. (omp_context_selector_matches): Delay resolution of selectors. Allow non-constant expressions. (omp_dynamic_cond): New. (omp_dynamic_selector_p): New. (sort_variant): New. (omp_get_dynamic_candidates): New. (omp_resolve_metadirective): New. (omp_resolve_metadirective): New. * omp-general.h (struct omp_metadirective_variant): New. (omp_resolve_metadirective): New prototype. gcc/c-family/ * c-omp.c (c_omp_expand_metadirective_r): New. (c_omp_expand_metadirective): New. --- gcc/c-family/c-omp.c | 45 ++++++++- gcc/gimplify.c | 72 +++++++++++++- gcc/omp-general.c | 232 ++++++++++++++++++++++++++++++++++++++++++- gcc/omp-general.h | 7 ++ 4 files changed, 346 insertions(+), 10 deletions(-) diff --git a/gcc/c-family/c-omp.c b/gcc/c-family/c-omp.c index 9a7a6834f1b..fedaec566ee 100644 --- a/gcc/c-family/c-omp.c +++ b/gcc/c-family/c-omp.c @@ -3264,8 +3264,49 @@ c_omp_categorize_directive (const char *first, const char *second, return NULL; } +static tree +c_omp_expand_metadirective_r (vec &candidates, + hash_map &body_labels, + unsigned index) +{ + struct omp_metadirective_variant &candidate = candidates[index]; + tree if_block = push_stmt_list (); + if (candidate.directive != NULL_TREE) + add_stmt (candidate.directive); + if (candidate.body != NULL_TREE) + { + tree *label = body_labels.get (candidate.body); + if (label != NULL) + add_stmt (build1 (GOTO_EXPR, void_type_node, *label)); + else + { + tree body_label = create_artificial_label (UNKNOWN_LOCATION); + add_stmt (build1 (LABEL_EXPR, void_type_node, body_label)); + add_stmt (candidate.body); + body_labels.put (candidate.body, body_label); + } + } + if_block = pop_stmt_list (if_block); + + if (index == candidates.length () - 1) + return if_block; + + tree cond = candidate.selector; + gcc_assert (cond != NULL_TREE); + + tree else_block = c_omp_expand_metadirective_r (candidates, body_labels, + index + 1); + tree ret = push_stmt_list (); + tree stmt = build3 (COND_EXPR, void_type_node, cond, if_block, else_block); + add_stmt (stmt); + ret = pop_stmt_list (ret); + + return ret; +} + tree -c_omp_expand_metadirective (vec &) +c_omp_expand_metadirective (vec &candidates) { - return NULL_TREE; + hash_map body_labels; + return c_omp_expand_metadirective_r (candidates, body_labels, 0); } diff --git a/gcc/gimplify.c b/gcc/gimplify.c index ed72162bb7f..5d9aa2c2145 100644 --- a/gcc/gimplify.c +++ b/gcc/gimplify.c @@ -14685,10 +14685,76 @@ gimplify_omp_ordered (tree expr, gimple_seq body) CANDIDATES. */ static enum gimplify_status -expand_omp_metadirective (vec &, - gimple_seq *) +expand_omp_metadirective (vec &candidates, + gimple_seq *pre_p) { - return GS_ERROR; + auto_vec selectors; + auto_vec directive_labels; + auto_vec directive_bodies; + tree body_label = NULL_TREE; + tree end_label = create_artificial_label (UNKNOWN_LOCATION); + + /* Construct bodies for each candidate. */ + for (unsigned i = 0; i < candidates.length(); i++) + { + struct omp_metadirective_variant &candidate = candidates[i]; + gimple_seq body = NULL; + + selectors.safe_push (candidate.selector); + directive_labels.safe_push (create_artificial_label (UNKNOWN_LOCATION)); + + gimplify_seq_add_stmt (&body, + gimple_build_label (directive_labels.last ())); + if (candidate.directive != NULL_TREE) + gimplify_stmt (&candidate.directive, &body); + if (candidate.body != NULL_TREE) + { + if (body_label != NULL_TREE) + gimplify_seq_add_stmt (&body, gimple_build_goto (body_label)); + else + { + body_label = create_artificial_label (UNKNOWN_LOCATION); + gimplify_seq_add_stmt (&body, gimple_build_label (body_label)); + gimplify_stmt (&candidate.body, &body); + } + } + + directive_bodies.safe_push (body); + } + + auto_vec cond_labels; + + cond_labels.safe_push (NULL_TREE); + for (unsigned i = 1; i < candidates.length () - 1; i++) + cond_labels.safe_push (create_artificial_label (UNKNOWN_LOCATION)); + if (candidates.length () > 1) + cond_labels.safe_push (directive_labels.last ()); + + /* Generate conditionals to test each dynamic selector in turn, executing + the directive candidate if successful. */ + for (unsigned i = 0; i < candidates.length () - 1; i++) + { + if (i != 0) + gimplify_seq_add_stmt (pre_p, gimple_build_label (cond_labels [i])); + + enum gimplify_status ret = gimplify_expr (&selectors[i], pre_p, NULL, + is_gimple_val, fb_rvalue); + if (ret == GS_ERROR || ret == GS_UNHANDLED) + return ret; + + gcond *cond_stmt + = gimple_build_cond_from_tree (selectors[i], directive_labels[i], + cond_labels[i + 1]); + + gimplify_seq_add_stmt (pre_p, cond_stmt); + gimplify_seq_add_seq (pre_p, directive_bodies[i]); + gimplify_seq_add_stmt (pre_p, gimple_build_goto (end_label)); + } + + gimplify_seq_add_seq (pre_p, directive_bodies.last ()); + gimplify_seq_add_stmt (pre_p, gimple_build_label (end_label)); + + return GS_ALL_DONE; } /* Gimplify an OMP_METADIRECTIVE construct. EXPR is the tree version. diff --git a/gcc/omp-general.c b/gcc/omp-general.c index 9926cfd9d5f..6340d1600a6 100644 --- a/gcc/omp-general.c +++ b/gcc/omp-general.c @@ -45,6 +45,7 @@ along with GCC; see the file COPYING3. If not see #include "data-streamer.h" #include "streamer-hooks.h" #include "opts.h" +#include "tree-pretty-print.h" enum omp_requires omp_requires_mask; @@ -1253,14 +1254,22 @@ omp_context_name_list_prop (tree prop) } } +#define DELAY_METADIRECTIVES_AFTER_LTO { \ + if (metadirective_p && !(cfun->curr_properties & PROP_gimple_lomp_dev)) \ + return -1; \ +} + /* Return 1 if context selector matches the current OpenMP context, 0 if it does not and -1 if it is unknown and need to be determined later. Some properties can be checked right away during parsing (this routine), others need to wait until the whole TU is parsed, others need to wait until - IPA, others until vectorization. */ + IPA, others until vectorization. + + Dynamic properties (which are evaluated at run-time) should always + return 1. */ int -omp_context_selector_matches (tree ctx, bool) +omp_context_selector_matches (tree ctx, bool metadirective_p) { int ret = 1; for (tree t1 = ctx; t1; t1 = TREE_CHAIN (t1)) @@ -1381,6 +1390,8 @@ omp_context_selector_matches (tree ctx, bool) const char *arch = omp_context_name_list_prop (t3); if (arch == NULL) return 0; + DELAY_METADIRECTIVES_AFTER_LTO; + int r = 0; if (targetm.omp.device_kind_arch_isa != NULL) r = targetm.omp.device_kind_arch_isa (omp_device_arch, @@ -1505,6 +1516,8 @@ omp_context_selector_matches (tree ctx, bool) #endif continue; } + DELAY_METADIRECTIVES_AFTER_LTO; + int r = 0; if (targetm.omp.device_kind_arch_isa != NULL) r = targetm.omp.device_kind_arch_isa (omp_device_kind, @@ -1544,6 +1557,8 @@ omp_context_selector_matches (tree ctx, bool) const char *isa = omp_context_name_list_prop (t3); if (isa == NULL) return 0; + DELAY_METADIRECTIVES_AFTER_LTO; + int r = 0; if (targetm.omp.device_kind_arch_isa != NULL) r = targetm.omp.device_kind_arch_isa (omp_device_isa, @@ -1595,6 +1610,12 @@ omp_context_selector_matches (tree ctx, bool) for (tree t3 = TREE_VALUE (t2); t3; t3 = TREE_CHAIN (t3)) if (TREE_PURPOSE (t3) == NULL_TREE) { + /* OpenMP 5.1 allows non-constant conditions for + metadirectives. */ + if (metadirective_p + && !tree_fits_shwi_p (TREE_VALUE (t3))) + break; + if (integer_zerop (TREE_VALUE (t3))) return 0; if (integer_nonzerop (TREE_VALUE (t3))) @@ -1610,6 +1631,8 @@ omp_context_selector_matches (tree ctx, bool) return ret; } +#undef DELAY_METADIRECTIVES_AFTER_LTO + /* Compare construct={simd} CLAUSES1 with CLAUSES2, return 0/-1/1/2 as in omp_context_selector_set_compare. */ @@ -1967,6 +1990,32 @@ omp_get_context_selector (tree ctx, const char *set, const char *sel) return NULL_TREE; } +/* Return a tree expression representing the dynamic part of the context + * selector CTX. */ + +static tree +omp_dynamic_cond (tree ctx) +{ + tree user = omp_get_context_selector (ctx, "user", "condition"); + if (user) + { + tree expr_list = TREE_VALUE (user); + + gcc_assert (TREE_PURPOSE (expr_list) == NULL_TREE); + return TREE_VALUE (expr_list); + } + return NULL_TREE; +} + +/* Return true iff the context selector CTX contains a dynamic element + that cannot be resolved at compile-time. */ + +static bool +omp_dynamic_selector_p (tree ctx) +{ + return omp_dynamic_cond (ctx) != NULL_TREE; +} + /* Compute *SCORE for context selector CTX. Return true if the score would be different depending on whether it is a declare simd clone or not. DECLARE_SIMD should be true for the case when it would be @@ -2624,16 +2673,189 @@ omp_lto_input_declare_variant_alt (lto_input_block *ib, cgraph_node *node, INSERT) = entryp; } +static int +sort_variant (const void * a, const void *b, void *) +{ + widest_int score1 = ((const struct omp_metadirective_variant *) a)->score; + widest_int score2 = ((const struct omp_metadirective_variant *) b)->score; + + if (score1 > score2) + return -1; + else if (score1 < score2) + return 1; + else + return 0; +} + +/* Return a vector of dynamic replacement candidates for the directive + candidates in ALL_VARIANTS. Return an empty vector if the metadirective + cannot be resolved. */ + +static vec +omp_get_dynamic_candidates (vec &all_variants) +{ + auto_vec variants; + struct omp_metadirective_variant default_variant; + bool default_found = false; + + for (unsigned int i = 0; i < all_variants.length (); i++) + { + struct omp_metadirective_variant variant = all_variants[i]; + + if (all_variants[i].selector == NULL_TREE) + { + default_found = true; + default_variant = all_variants[i]; + default_variant.score = 0; + default_variant.resolvable_p = true; + default_variant.dynamic_p = false; + continue; + } + + variant.resolvable_p = true; + + if (dump_file) + { + fprintf (dump_file, "Considering selector "); + print_generic_expr (dump_file, variant.selector); + fprintf (dump_file, " as candidate - "); + } + + switch (omp_context_selector_matches (variant.selector, true)) + { + case -1: + variant.resolvable_p = false; + if (dump_file) + fprintf (dump_file, "unresolvable"); + /* FALLTHRU */ + case 1: + /* TODO: Handle SIMD score?. */ + omp_context_compute_score (variant.selector, &variant.score, false); + variant.dynamic_p = omp_dynamic_selector_p (variant.selector); + variants.safe_push (variant); + break; + case 0: + if (dump_file) + fprintf (dump_file, "no match"); + break; + } + + if (dump_file) + fprintf (dump_file, "\n"); + } + + /* There must be one default variant. */ + gcc_assert (default_found); + + /* A context selector that is a strict subset of another context selector + has a score of zero. */ + for (unsigned int i = 0; i < variants.length (); i++) + for (unsigned int j = i + 1; j < variants.length (); j++) + { + int r = omp_context_selector_compare (variants[i].selector, + variants[j].selector); + if (r == -1) + { + /* variant1 is a strict subset of variant2. */ + variants[i].score = 0; + break; + } + else if (r == 1) + /* variant2 is a strict subset of variant1. */ + variants[j].score = 0; + } + + /* Sort the variants by decreasing score, preserving the original order + in case of a tie. */ + variants.stablesort (sort_variant, NULL); + + /* Add the default as a final choice. */ + variants.safe_push (default_variant); + + /* Build the dynamic candidate list. */ + for (unsigned i = 0; i < variants.length (); i++) + { + /* If one of the candidates is unresolvable, give up for now. */ + if (!variants[i].resolvable_p) + { + variants.truncate (0); + break; + } + + /* Replace the original selector with just the dynamic part. */ + variants[i].selector = omp_dynamic_cond (variants[i].selector); + + if (dump_file) + { + fprintf (dump_file, "Adding directive variant with "); + + if (variants[i].selector) + { + fprintf (dump_file, "selector "); + print_generic_expr (dump_file, variants[i].selector); + } + else + fprintf (dump_file, "default selector"); + + fprintf (dump_file, " as candidate.\n"); + } + + /* The last of the candidates is ended by a static selector. */ + if (!variants[i].dynamic_p) + { + variants.truncate (i + 1); + break; + } + } + + return variants.copy (); +} + /* Return a vector of dynamic replacement candidates for the metadirective statement in METADIRECTIVE. Return an empty vector if the metadirective cannot be resolved. */ vec -omp_resolve_metadirective (tree) +omp_resolve_metadirective (tree metadirective) +{ + auto_vec variants; + tree clause = OMP_METADIRECTIVE_CLAUSES (metadirective); + + while (clause) + { + struct omp_metadirective_variant variant; + + variant.selector = TREE_PURPOSE (clause); + variant.directive = TREE_PURPOSE (TREE_VALUE (clause)); + variant.body = TREE_VALUE (TREE_VALUE (clause)); + + variants.safe_push (variant); + clause = TREE_CHAIN (clause); + } + + return omp_get_dynamic_candidates (variants); +} + +/* Return a vector of dynamic replacement candidates for the metadirective + Gimple statement in GS. Return an empty vector if the metadirective + cannot be resolved. */ + +vec +omp_resolve_metadirective (gimple *gs) { - vec variants = {}; + auto_vec variants; + + for (unsigned i = 0; i < gimple_num_ops (gs); i++) + { + struct omp_metadirective_variant variant; + + variant.selector = gimple_op (gs, i); + variant.directive = gimple_omp_metadirective_label (gs, i); + + variants.safe_push (variant); + } - return variants; + return omp_get_dynamic_candidates (variants); } /* Encode an oacc launch argument. This matches the GOMP_LAUNCH_PACK diff --git a/gcc/omp-general.h b/gcc/omp-general.h index 8c6009e9854..5a0747b2791 100644 --- a/gcc/omp-general.h +++ b/gcc/omp-general.h @@ -93,6 +93,12 @@ struct omp_for_data struct omp_metadirective_variant { + widest_int score; + tree selector; + tree directive; + tree body; + bool dynamic_p : 1; + bool resolvable_p : 1; }; #define OACC_FN_ATTRIB "oacc function" @@ -119,6 +125,7 @@ extern int omp_context_selector_set_compare (const char *, tree, tree); extern tree omp_get_context_selector (tree, const char *, const char *); extern tree omp_resolve_declare_variant (tree); extern vec omp_resolve_metadirective (tree); +extern vec omp_resolve_metadirective (gimple *); extern tree oacc_launch_pack (unsigned code, tree device, unsigned op); extern tree oacc_replace_fn_attrib_attr (tree attribs, tree dims); extern void oacc_replace_fn_attrib (tree fn, tree dims); From patchwork Fri Dec 10 17:36:20 2021 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Kwok Cheung Yeung X-Patchwork-Id: 48796 Return-Path: X-Original-To: patchwork@sourceware.org Delivered-To: patchwork@sourceware.org Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 1EC483857829 for ; Fri, 10 Dec 2021 17:37:32 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from esa2.mentor.iphmx.com (esa2.mentor.iphmx.com [68.232.141.98]) by sourceware.org (Postfix) with ESMTPS id 5D72C385801D for ; Fri, 10 Dec 2021 17:36:52 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.1 sourceware.org 5D72C385801D Authentication-Results: sourceware.org; dmarc=none (p=none dis=none) header.from=codesourcery.com Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=mentor.com IronPort-SDR: Hj98bOzIokKG9A1fphSgs4HDGdkTZ5vD2YJA6StZHylajMJXRo/vJL5cmXACYQBObM4yj5Z+1Q aVKE/LNwPF2PnHWOTWYyfeBGN4EoK2d9uBPs+/2QJpNzbZmsD7creSohIRd0PBvyjJtOuRmq1W cR8zgD2brZ3B6cK0X14ueUGUjjiitaF3VBCMj1Ron21u5bfyPwEbYiXWEnjF4JJmxXaFlpgA5x ij/GIvz5QqwCBMDHxb5dUMBMKKr5nBo2pM9UpZi+BnC+5kriC4LRo+UsiM59/l2O0WXUxplykb Lb7O+2ceqZqrDel2MBoxQsiw X-IronPort-AV: E=Sophos;i="5.88,196,1635235200"; d="scan'208,223";a="69540032" Received: from orw-gwy-01-in.mentorg.com ([192.94.38.165]) by esa2.mentor.iphmx.com with ESMTP; 10 Dec 2021 09:36:51 -0800 IronPort-SDR: 8iOBBzkFnH2St0Ohb8o3/EhlbLqkyJBOIFJ9w+2vttcZMbAOZETSQjQGx1jubt1MbSH1UJDvXL F3yiPSUZegEskFBlnan9pKYKjnchPn2Ldcu0SBaZlj1wQrhe/tve97wArjb66h1qLJIw4hOi/I n2XdU4T1s0E4L+2QyXBlpLK0444DZWgkabp0UjJeRw6JCgS6Ln2O14DY7Ao6byYVkb6PY0hw/Z qq/dTnQMiRfLF6F/N9ol3/msamqfDkKuSqOy4rmKoUv/JHfUMVOCUIrfUpnamJI/iTLrOCTHW5 Zag= Message-ID: <0813fb26-b6ec-0a39-11aa-4a4687947531@codesourcery.com> Date: Fri, 10 Dec 2021 17:36:20 +0000 MIME-Version: 1.0 User-Agent: Mozilla/5.0 (Windows NT 10.0; Win64; x64; rv:91.0) Gecko/20100101 Thunderbird/91.4.0 References: Subject: [PATCH 4/7] openmp: Add support for streaming metadirectives and resolving them after LTO To: gcc-patches , Jakub Jelinek From: Kwok Cheung Yeung In-Reply-To: X-Originating-IP: [137.202.0.90] X-ClientProxiedBy: svr-ies-mbx-09.mgc.mentorg.com (139.181.222.9) To SVR-IES-MBX-04.mgc.mentorg.com (139.181.222.4) X-Spam-Status: No, score=-12.0 required=5.0 tests=BAYES_00, GIT_PATCH_0, HEADER_FROM_DIFFERENT_DOMAINS, KAM_DMARC_STATUS, KAM_SHORT, SPF_HELO_PASS, SPF_PASS, TXREP autolearn=ham autolearn_force=no version=3.4.4 X-Spam-Checker-Version: SpamAssassin 3.4.4 (2020-01-24) on server2.sourceware.org X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: gcc-patches-bounces+patchwork=sourceware.org@gcc.gnu.org Sender: "Gcc-patches" This patch adds support for streaming the Gimple metadirective representation during LTO. An extra pass (also using omp_get_dynamic_candidates) is also added to resolve metadirectives after LTO, which is required for selectors that need to be resolved on the accel compiler. Kwok From 85826d05e029571fd003dd629aa04ce3e17d9c71 Mon Sep 17 00:00:00 2001 From: Kwok Cheung Yeung Date: Mon, 6 Dec 2021 22:56:07 +0000 Subject: [PATCH 4/7] openmp: Add support for streaming metadirectives and resolving them after LTO This patch adds support for streaming metadirective Gimple statements during LTO, and adds a metadirective expansion pass that runs after LTO. This is required for metadirectives with selectors that can only be resolved from within the accel compiler. 2021-12-10 Kwok Cheung Yeung gcc/ * Makefile.in (OBJS): Add omp-expand-metadirective.o. * gimple-streamer-in.c (input_gimple_stmt): Add case for GIMPLE_OMP_METADIRECTIVE. Handle metadirective labels. * gimple-streamer-out.c (output_gimple_stmt): Likewise. * omp-expand-metadirective.cc: New. * passes.def: Add pass_omp_expand_metadirective. * tree-pass.h (make_pass_omp_expand_metadirective): New prototype. --- gcc/Makefile.in | 1 + gcc/gimple-streamer-in.c | 10 ++ gcc/gimple-streamer-out.c | 6 + gcc/omp-expand-metadirective.cc | 191 ++++++++++++++++++++++++++++++++ gcc/passes.def | 1 + gcc/tree-pass.h | 1 + 6 files changed, 210 insertions(+) create mode 100644 gcc/omp-expand-metadirective.cc diff --git a/gcc/Makefile.in b/gcc/Makefile.in index 2a0be9e66a6..34a17f36922 100644 --- a/gcc/Makefile.in +++ b/gcc/Makefile.in @@ -1519,6 +1519,7 @@ OBJS = \ omp-oacc-kernels-decompose.o \ omp-oacc-neuter-broadcast.o \ omp-simd-clone.o \ + omp-expand-metadirective.o \ opt-problem.o \ optabs.o \ optabs-libfuncs.o \ diff --git a/gcc/gimple-streamer-in.c b/gcc/gimple-streamer-in.c index 1c979f438a5..b821aa3ca30 100644 --- a/gcc/gimple-streamer-in.c +++ b/gcc/gimple-streamer-in.c @@ -151,6 +151,7 @@ input_gimple_stmt (class lto_input_block *ib, class data_in *data_in, case GIMPLE_COND: case GIMPLE_GOTO: case GIMPLE_DEBUG: + case GIMPLE_OMP_METADIRECTIVE: for (i = 0; i < num_ops; i++) { tree *opp, op = stream_read_tree (ib, data_in); @@ -188,6 +189,15 @@ input_gimple_stmt (class lto_input_block *ib, class data_in *data_in, else gimple_call_set_fntype (call_stmt, stream_read_tree (ib, data_in)); } + if (gomp_metadirective *metadirective_stmt + = dyn_cast (stmt)) + { + gimple_alloc_omp_metadirective (metadirective_stmt); + for (i = 0; i < num_ops; i++) + gimple_omp_metadirective_set_label (metadirective_stmt, i, + stream_read_tree (ib, + data_in)); + } break; case GIMPLE_NOP: diff --git a/gcc/gimple-streamer-out.c b/gcc/gimple-streamer-out.c index fcbf92300d4..c19dff74261 100644 --- a/gcc/gimple-streamer-out.c +++ b/gcc/gimple-streamer-out.c @@ -127,6 +127,7 @@ output_gimple_stmt (struct output_block *ob, struct function *fn, gimple *stmt) case GIMPLE_COND: case GIMPLE_GOTO: case GIMPLE_DEBUG: + case GIMPLE_OMP_METADIRECTIVE: for (i = 0; i < gimple_num_ops (stmt); i++) { tree op = gimple_op (stmt, i); @@ -169,6 +170,11 @@ output_gimple_stmt (struct output_block *ob, struct function *fn, gimple *stmt) else stream_write_tree (ob, gimple_call_fntype (stmt), true); } + if (gimple_code (stmt) == GIMPLE_OMP_METADIRECTIVE) + for (i = 0; i < gimple_num_ops (stmt); i++) + stream_write_tree (ob, gimple_omp_metadirective_label (stmt, i), + true); + break; case GIMPLE_NOP: diff --git a/gcc/omp-expand-metadirective.cc b/gcc/omp-expand-metadirective.cc new file mode 100644 index 00000000000..aaf048a699a --- /dev/null +++ b/gcc/omp-expand-metadirective.cc @@ -0,0 +1,191 @@ +/* Expand an OpenMP metadirective. + + Copyright (C) 2021 Free Software Foundation, Inc. + +This file is part of GCC. + +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 3, or (at your option) any later +version. + +GCC is distributed in the hope that it will be useful, but WITHOUT ANY +WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with GCC; see the file COPYING3. If not see +. */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "backend.h" +#include "target.h" +#include "tree.h" +#include "langhooks.h" +#include "gimple.h" +#include "tree-pass.h" +#include "cgraph.h" +#include "fold-const.h" +#include "gimplify.h" +#include "gimple-iterator.h" +#include "gimple-walk.h" +#include "gomp-constants.h" +#include "omp-general.h" +#include "diagnostic-core.h" +#include "tree-cfg.h" +#include "cfganal.h" +#include "ssa.h" +#include "tree-into-ssa.h" +#include "cfghooks.h" + +static void +omp_expand_metadirective (function *fun, basic_block bb) +{ + gimple *stmt = last_stmt (bb); + vec candidates + = omp_resolve_metadirective (stmt); + + /* This is the last chance for the metadirective to be resolved. */ + if (candidates.is_empty ()) + gcc_unreachable (); + + auto_vec labels; + + for (unsigned int i = 0; i < candidates.length (); i++) + labels.safe_push (candidates[i].directive); + + /* Delete BBs for all variants not in the candidate list. */ + for (unsigned i = 0; i < gimple_num_ops (stmt); i++) + { + tree label = gimple_omp_metadirective_label (stmt, i); + if (!labels.contains (label)) + { + edge e = find_edge (bb, label_to_block (fun, label)); + remove_edge_and_dominated_blocks (e); + } + } + + /* Remove the metadirective statement. */ + gimple_stmt_iterator gsi = gsi_last_bb (bb); + gsi_remove (&gsi, true); + + if (candidates.length () == 1) + { + /* Special case if there is only one selector - there should be one + remaining edge from BB to the selected variant. */ + edge e = find_edge (bb, label_to_block (fun, + candidates.last ().directive)); + e->flags |= EDGE_FALLTHRU; + + return; + } + + basic_block cur_bb = bb; + + /* For each candidate, create a conditional that checks the dynamic + condition, branching to the candidate directive if true, to the + next candidate check if false. */ + for (unsigned i = 0; i < candidates.length () - 1; i++) + { + basic_block next_bb = NULL; + gcond *cond_stmt = gimple_build_cond_from_tree (candidates[i].selector, + NULL_TREE, NULL_TREE); + gsi = gsi_last_bb (cur_bb); + gsi_insert_seq_after (&gsi, cond_stmt, GSI_NEW_STMT); + + if (i < candidates.length () - 2) + { + edge e_false = split_block (cur_bb, cond_stmt); + e_false->flags &= ~EDGE_FALLTHRU; + e_false->flags |= EDGE_FALSE_VALUE; + e_false->probability = profile_probability::uninitialized (); + + next_bb = e_false->dest; + } + + /* Redirect the source of the edge from BB to the candidate directive + to the conditional. Reusing the edge avoids disturbing phi nodes in + the destination BB. */ + edge e = find_edge (bb, label_to_block (fun, candidates[i].directive)); + redirect_edge_pred (e, cur_bb); + e->flags |= EDGE_TRUE_VALUE; + + if (next_bb) + cur_bb = next_bb; + } + + /* The last of the candidates is always static. */ + edge e = find_edge (cur_bb, label_to_block (fun, + candidates.last ().directive)); + e->flags |= EDGE_FALSE_VALUE; +} + +namespace { + +const pass_data pass_data_omp_expand_metadirective = +{ + GIMPLE_PASS, /* type */ + "omp_expand_metadirective", /* name */ + OPTGROUP_OMP, /* optinfo_flags */ + TV_NONE, /* tv_id */ + PROP_gimple_lcf, /* properties_required */ + 0, /* properties_provided */ + 0, /* properties_destroyed */ + 0, /* todo_flags_start */ + TODO_update_ssa | TODO_cleanup_cfg, /* todo_flags_finish */ +}; + +class pass_omp_expand_metadirective : public gimple_opt_pass +{ +public: + pass_omp_expand_metadirective (gcc::context *ctxt) + : gimple_opt_pass (pass_data_omp_expand_metadirective, ctxt) + {} + + /* opt_pass methods: */ + virtual bool gate (function *) + { + return (flag_openmp); + } + + virtual unsigned int execute (function *fun); +}; // class pass_omp_oacc_kernels_decompose + +unsigned int +pass_omp_expand_metadirective::execute (function *fun) +{ + basic_block bb; + auto_vec metadirective_bbs; + + FOR_EACH_BB_FN (bb, fun) + { + gimple *stmt = last_stmt (bb); + if (stmt && is_a (stmt)) + metadirective_bbs.safe_push (bb); + } + + if (metadirective_bbs.is_empty ()) + return 0; + + calculate_dominance_info (CDI_DOMINATORS); + + for (unsigned i = 0; i < metadirective_bbs.length (); i++) + omp_expand_metadirective (fun, metadirective_bbs[i]); + + free_dominance_info (fun, CDI_DOMINATORS); + mark_virtual_operands_for_renaming (fun); + + return 0; +} + +} // anon namespace + + +gimple_opt_pass * +make_pass_omp_expand_metadirective (gcc::context *ctxt) +{ + return new pass_omp_expand_metadirective (ctxt); +} diff --git a/gcc/passes.def b/gcc/passes.def index 37ea0d318d1..b80a53c4051 100644 --- a/gcc/passes.def +++ b/gcc/passes.def @@ -189,6 +189,7 @@ along with GCC; see the file COPYING3. If not see NEXT_PASS (pass_oacc_device_lower); NEXT_PASS (pass_omp_device_lower); NEXT_PASS (pass_omp_target_link); + NEXT_PASS (pass_omp_expand_metadirective); NEXT_PASS (pass_adjust_alignment); NEXT_PASS (pass_all_optimizations); PUSH_INSERT_PASSES_WITHIN (pass_all_optimizations) diff --git a/gcc/tree-pass.h b/gcc/tree-pass.h index 3559c3c9f1b..e4315e2fe85 100644 --- a/gcc/tree-pass.h +++ b/gcc/tree-pass.h @@ -422,6 +422,7 @@ extern gimple_opt_pass *make_pass_lower_switch_O0 (gcc::context *ctxt); extern gimple_opt_pass *make_pass_lower_vector (gcc::context *ctxt); extern gimple_opt_pass *make_pass_lower_vector_ssa (gcc::context *ctxt); extern gimple_opt_pass *make_pass_omp_oacc_kernels_decompose (gcc::context *ctxt); +extern gimple_opt_pass *make_pass_omp_expand_metadirective (gcc::context *ctxt); extern gimple_opt_pass *make_pass_lower_omp (gcc::context *ctxt); extern gimple_opt_pass *make_pass_diagnose_omp_blocks (gcc::context *ctxt); extern gimple_opt_pass *make_pass_expand_omp (gcc::context *ctxt); From patchwork Fri Dec 10 17:37:34 2021 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Kwok Cheung Yeung X-Patchwork-Id: 48797 Return-Path: X-Original-To: patchwork@sourceware.org Delivered-To: patchwork@sourceware.org Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id CE3A1385780E for ; Fri, 10 Dec 2021 17:38:23 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from esa1.mentor.iphmx.com (esa1.mentor.iphmx.com [68.232.129.153]) by sourceware.org (Postfix) with ESMTPS id 6BFB93858025 for ; Fri, 10 Dec 2021 17:38:06 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.1 sourceware.org 6BFB93858025 Authentication-Results: sourceware.org; dmarc=none (p=none dis=none) header.from=codesourcery.com Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=mentor.com IronPort-SDR: ktOKyLkb1CLZlP6hRnNbQUncCb0tq2uEo/K8+y1XIVLNV2fzLMuXt+kVanlwYWFLDPVMXRJ3u4 Gn3wOYCf4MEd0xjqgFSP3dsoCkzEd0/UvES0Ytlr2wG032EeaKKJGQ5fAR/zdbxOZJnqC7iec4 oNtX8/hMNcj+QwJXhUebRhj+JkWinkti+7ZvAaBDaMsuGjoGQyBxy4xaFe4syQQy0cMtZwGpBC YK/LRtgyhglImxQH1lU3eZiFEZReyoHtCDpGSGNYBwWSOs/LuCf/FVu4Iwqfky5q3oIcgDciAu 5HXWiGK85YQ1EMlYl8kjoQZi X-IronPort-AV: E=Sophos;i="5.88,196,1635235200"; d="scan'208,223";a="72064284" Received: from orw-gwy-01-in.mentorg.com ([192.94.38.165]) by esa1.mentor.iphmx.com with ESMTP; 10 Dec 2021 09:38:06 -0800 IronPort-SDR: 7Kw2nSqP5fXo9iLxcWiXjfP3uAjm9cyWAIdbgzMqTULDDVDmkuF0/zzJIwqZDtGSKZndLoPiq9 XpImndeWxxURmkqBFS2ogB6KWIGKqvZSBmSbrlDLd6pK/fXwZdjua09cQJhUsaZ4OeKz37m7o0 PW99JbAXAgamg4EMJ662W9xQ0yvcYjCnrv0D0i8/8E61RDFYZE6xBugIk4x+Atrf/7QO8joCbZ +W+rfOk947wdbwcgVDyftBMnp5gPsmTexPu2C34z4+hHQMmWgyEHPRzU/vsKju1U5LCyqPFKeN JQI= Message-ID: <8e830d64-4a71-2799-fda4-5ca77917f832@codesourcery.com> Date: Fri, 10 Dec 2021 17:37:34 +0000 MIME-Version: 1.0 User-Agent: Mozilla/5.0 (Windows NT 10.0; Win64; x64; rv:91.0) Gecko/20100101 Thunderbird/91.4.0 References: Subject: [PATCH 5/7] openmp: Add C++ support for parsing metadirectives To: gcc-patches , Jakub Jelinek From: Kwok Cheung Yeung In-Reply-To: X-Originating-IP: [137.202.0.90] X-ClientProxiedBy: SVR-IES-MBX-07.mgc.mentorg.com (139.181.222.7) To SVR-IES-MBX-04.mgc.mentorg.com (139.181.222.4) X-Spam-Status: No, score=-12.0 required=5.0 tests=BAYES_00, GIT_PATCH_0, HEADER_FROM_DIFFERENT_DOMAINS, KAM_DMARC_STATUS, SPF_HELO_PASS, SPF_PASS, TXREP autolearn=ham autolearn_force=no version=3.4.4 X-Spam-Checker-Version: SpamAssassin 3.4.4 (2020-01-24) on server2.sourceware.org X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: gcc-patches-bounces+patchwork=sourceware.org@gcc.gnu.org Sender: "Gcc-patches" This patch adds metadirective parsing support to the C++ parser. This is basically just a straight port of the C code to the C++ front end. Kwok From e9bb138d4c3f560e48e408facce2361533685a98 Mon Sep 17 00:00:00 2001 From: Kwok Cheung Yeung Date: Mon, 6 Dec 2021 22:58:01 +0000 Subject: [PATCH 5/7] openmp: Add C++ support for parsing metadirectives This adds support for parsing OpenMP metadirectives in the C++ front end. 2021-12-10 Kwok Cheung Yeung gcc/cp/ * parser.c (cp_parser_skip_to_end_of_statement): Handle parentheses. (cp_parser_skip_to_end_of_block_or_statement): Likewise. (cp_parser_omp_context_selector): Add extra argument. Allow non-constant expressions. (cp_parser_omp_context_selector_specification): Add extra argument and propagate to cp_parser_omp_context_selector. (analyze_metadirective_body): New. (cp_parser_omp_metadirective): New. (cp_parser_omp_construct): Handle PRAGMA_OMP_METADIRECTIVE. (cp_parser_pragma): Handle PRAGMA_OMP_METADIRECTIVE. --- gcc/cp/parser.c | 425 +++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 417 insertions(+), 8 deletions(-) diff --git a/gcc/cp/parser.c b/gcc/cp/parser.c index 6f273bfe21f..afbfe148949 100644 --- a/gcc/cp/parser.c +++ b/gcc/cp/parser.c @@ -3907,6 +3907,17 @@ cp_parser_skip_to_end_of_statement (cp_parser* parser) ++nesting_depth; break; + case CPP_OPEN_PAREN: + /* Track parentheses in case the statement is a standalone 'for' + statement - we want to skip over the semicolons separating the + operands. */ + ++nesting_depth; + break; + + case CPP_CLOSE_PAREN: + --nesting_depth; + break; + case CPP_KEYWORD: if (token->keyword != RID__EXPORT && token->keyword != RID__MODULE @@ -3996,6 +4007,17 @@ cp_parser_skip_to_end_of_block_or_statement (cp_parser* parser) nesting_depth++; break; + case CPP_OPEN_PAREN: + /* Track parentheses in case the statement is a standalone 'for' + statement - we want to skip over the semicolons separating the + operands. */ + nesting_depth++; + break; + + case CPP_CLOSE_PAREN: + nesting_depth--; + break; + case CPP_KEYWORD: if (token->keyword != RID__EXPORT && token->keyword != RID__MODULE @@ -44972,7 +44994,8 @@ static const char *const omp_user_selectors[] = { score(score-expression) */ static tree -cp_parser_omp_context_selector (cp_parser *parser, tree set, bool has_parms_p) +cp_parser_omp_context_selector (cp_parser *parser, tree set, bool has_parms_p, + bool metadirective_p) { tree ret = NULL_TREE; do @@ -45188,15 +45211,21 @@ cp_parser_omp_context_selector (cp_parser *parser, tree set, bool has_parms_p) while (1); break; case CTX_PROPERTY_EXPR: - t = cp_parser_constant_expression (parser); + /* Allow non-constant expressions in metadirectives. */ + t = metadirective_p + ? cp_parser_expression (parser) + : cp_parser_constant_expression (parser); if (t != error_mark_node) { t = fold_non_dependent_expr (t); - if (!value_dependent_expression_p (t) - && (!INTEGRAL_TYPE_P (TREE_TYPE (t)) - || !tree_fits_shwi_p (t))) + if (metadirective_p && !INTEGRAL_TYPE_P (TREE_TYPE (t))) error_at (token->location, "property must be " - "constant integer expression"); + "integer expression"); + else if (!metadirective_p && !value_dependent_expression_p (t) + && (!INTEGRAL_TYPE_P (TREE_TYPE (t)) + || !tree_fits_shwi_p (t))) + error_at (token->location, "property must be constant " + "integer expression"); else properties = tree_cons (NULL_TREE, t, properties); } @@ -45260,7 +45289,8 @@ cp_parser_omp_context_selector (cp_parser *parser, tree set, bool has_parms_p) static tree cp_parser_omp_context_selector_specification (cp_parser *parser, - bool has_parms_p) + bool has_parms_p, + bool metadirective_p = false) { tree ret = NULL_TREE; do @@ -45308,7 +45338,8 @@ cp_parser_omp_context_selector_specification (cp_parser *parser, return error_mark_node; tree selectors - = cp_parser_omp_context_selector (parser, set, has_parms_p); + = cp_parser_omp_context_selector (parser, set, has_parms_p, + metadirective_p); if (selectors == error_mark_node) { cp_parser_skip_to_closing_brace (parser); @@ -45831,6 +45862,378 @@ cp_parser_omp_end_declare_target (cp_parser *parser, cp_token *pragma_tok) } } + +/* Helper function for c_parser_omp_metadirective. */ + +static void +analyze_metadirective_body (cp_parser *parser, + vec &tokens, + vec &labels) +{ + int nesting_depth = 0; + int bracket_depth = 0; + bool in_case = false; + bool in_label_decl = false; + + while (1) + { + cp_token *token = cp_lexer_peek_token (parser->lexer); + bool stop = false; + + if (cp_lexer_next_token_is_keyword (parser->lexer, RID_CASE)) + in_case = true; + else if (cp_lexer_next_token_is_keyword (parser->lexer, RID_LABEL)) + in_label_decl = true; + + switch (token->type) + { + case CPP_EOF: + break; + case CPP_NAME: + if ((!in_case + && cp_lexer_nth_token_is (parser->lexer, 2, CPP_COLON)) + || in_label_decl) + labels.safe_push (token->u.value); + goto add; + case CPP_OPEN_BRACE: + ++nesting_depth; + goto add; + case CPP_CLOSE_BRACE: + if (--nesting_depth == 0) + stop = true; + goto add; + case CPP_OPEN_PAREN: + ++bracket_depth; + goto add; + case CPP_CLOSE_PAREN: + --bracket_depth; + goto add; + case CPP_COLON: + in_case = false; + goto add; + case CPP_SEMICOLON: + if (nesting_depth == 0 && bracket_depth == 0) + stop = true; + /* Local label declarations are terminated by a semicolon. */ + in_label_decl = false; + goto add; + default: + add: + tokens.safe_push (*token); + cp_lexer_consume_token (parser->lexer); + if (stop) + break; + continue; + } + break; + } +} + +/* OpenMP 5.0: + + # pragma omp metadirective [clause[, clause]] +*/ + +static tree +cp_parser_omp_metadirective (cp_parser *parser, cp_token *pragma_tok, + char *p_name, omp_clause_mask, tree *, + bool *if_p) +{ + tree ret; + auto_vec directive_tokens; + auto_vec body_tokens; + auto_vec body_labels; + auto_vec directives; + auto_vec ctxs; + bool default_seen = false; + int directive_token_idx = 0; + location_t loc = cp_lexer_peek_token (parser->lexer)->location; + tree standalone_body = NULL_TREE; + vec candidates; + + ret = make_node (OMP_METADIRECTIVE); + SET_EXPR_LOCATION (ret, loc); + TREE_TYPE (ret) = void_type_node; + OMP_METADIRECTIVE_CLAUSES (ret) = NULL_TREE; + strcat (p_name, " metadirective"); + + while (cp_lexer_next_token_is_not (parser->lexer, CPP_PRAGMA_EOL)) + { + if (cp_lexer_next_token_is_not (parser->lexer, CPP_NAME) + && cp_lexer_next_token_is_not (parser->lexer, CPP_KEYWORD)) + { + cp_parser_error (parser, "expected % or %"); + goto fail; + } + + location_t match_loc = cp_lexer_peek_token (parser->lexer)->location; + const char *p + = IDENTIFIER_POINTER (cp_lexer_peek_token (parser->lexer)->u.value); + cp_lexer_consume_token (parser->lexer); + bool default_p = strcmp (p, "default") == 0; + if (default_p) + { + if (default_seen) + { + cp_parser_error (parser, "there can only be one default clause " + "in a metadirective"); + goto fail; + } + else + default_seen = true; + } + if (!strcmp (p, "when") == 0 && !default_p) + { + cp_parser_error (parser, "expected % or %"); + goto fail; + } + + matching_parens parens; + tree ctx = NULL_TREE; + bool skip = false; + + if (!parens.require_open (parser)) + goto fail; + + if (!default_p) + { + ctx = cp_parser_omp_context_selector_specification (parser, false, + true); + if (ctx == error_mark_node) + goto fail; + ctx = omp_check_context_selector (match_loc, ctx); + if (ctx == error_mark_node) + goto fail; + + /* Remove the selector from further consideration if can be + evaluated as a non-match at this point. */ + skip = (omp_context_selector_matches (ctx, true) == 0); + + if (cp_lexer_next_token_is_not (parser->lexer, CPP_COLON)) + { + cp_parser_error (parser, "expected colon"); + goto fail; + } + cp_lexer_consume_token (parser->lexer); + } + + /* Read in the directive type and create a dummy pragma token for + it. */ + location_t loc = cp_lexer_peek_token (parser->lexer)->location; + + p = NULL; + if (cp_lexer_next_token_is (parser->lexer, CPP_CLOSE_PAREN)) + p = "nothing"; + else if (cp_lexer_next_token_is_keyword (parser->lexer, RID_FOR)) + { + p = "for"; + cp_lexer_consume_token (parser->lexer); + } + else if (cp_lexer_next_token_is (parser->lexer, CPP_NAME)) + { + cp_token *token = cp_lexer_consume_token (parser->lexer); + p = IDENTIFIER_POINTER (token->u.value); + } + + if (p == NULL) + { + cp_parser_error (parser, "expected directive name"); + goto fail; + } + + const struct c_omp_directive *omp_directive + = c_omp_categorize_directive (p, NULL, NULL); + + if (omp_directive == NULL) + { + cp_parser_error (parser, "unknown directive name"); + goto fail; + } + if (omp_directive->id == PRAGMA_OMP_METADIRECTIVE) + { + cp_parser_error (parser, + "metadirectives cannot be used as directive " + "variants"); + goto fail; + } + if (omp_directive->kind == C_OMP_DIR_DECLARATIVE) + { + sorry_at (loc, "declarative directive variants are not supported"); + goto fail; + } + + if (!skip) + { + cp_token pragma_token; + pragma_token.type = CPP_PRAGMA; + pragma_token.location = loc; + pragma_token.u.value = build_int_cst (NULL, omp_directive->id); + + directives.safe_push (omp_directive); + directive_tokens.safe_push (pragma_token); + ctxs.safe_push (ctx); + } + + /* Read in tokens for the directive clauses. */ + int nesting_depth = 0; + while (1) + { + cp_token *token = cp_lexer_peek_token (parser->lexer); + switch (token->type) + { + case CPP_EOF: + case CPP_PRAGMA_EOL: + break; + case CPP_OPEN_PAREN: + ++nesting_depth; + goto add; + case CPP_CLOSE_PAREN: + if (nesting_depth-- == 0) + break; + goto add; + default: + add: + if (!skip) + directive_tokens.safe_push (*token); + cp_lexer_consume_token (parser->lexer); + continue; + } + break; + } + + cp_lexer_consume_token (parser->lexer); + + if (!skip) + { + cp_token eol_token = {}; + eol_token.type = CPP_PRAGMA_EOL; + eol_token.keyword = RID_MAX; + directive_tokens.safe_push (eol_token); + } + } + cp_parser_skip_to_pragma_eol (parser, pragma_tok); + + if (!default_seen) + { + /* Add a default clause that evaluates to 'omp nothing'. */ + const struct c_omp_directive *omp_directive + = c_omp_categorize_directive ("nothing", NULL, NULL); + + cp_token pragma_token = {}; + pragma_token.type = CPP_PRAGMA; + pragma_token.keyword = RID_MAX; + pragma_token.location = UNKNOWN_LOCATION; + pragma_token.u.value = build_int_cst (NULL, PRAGMA_OMP_NOTHING); + + directives.safe_push (omp_directive); + directive_tokens.safe_push (pragma_token); + ctxs.safe_push (NULL_TREE); + + cp_token eol_token = {}; + eol_token.type = CPP_PRAGMA_EOL; + eol_token.keyword = RID_MAX; + directive_tokens.safe_push (eol_token); + } + + analyze_metadirective_body (parser, body_tokens, body_labels); + + /* Process each candidate directive. */ + unsigned i; + tree ctx; + cp_lexer *lexer; + + lexer = cp_lexer_alloc (); + lexer->debugging_p = parser->lexer->debugging_p; + vec_safe_reserve (lexer->buffer, + directive_tokens.length () + body_tokens.length () + 2); + + FOR_EACH_VEC_ELT (ctxs, i, ctx) + { + lexer->buffer->truncate (0); + + /* Add the directive tokens. */ + do + lexer->buffer->quick_push (directive_tokens [directive_token_idx++]); + while (lexer->buffer->last ().type != CPP_PRAGMA_EOL); + + /* Add the body tokens. */ + for (unsigned j = 0; j < body_tokens.length (); j++) + lexer->buffer->quick_push (body_tokens[j]); + + /* Make sure nothing tries to read past the end of the tokens. */ + cp_token eof_token = {}; + eof_token.type = CPP_EOF; + eof_token.keyword = RID_MAX; + lexer->buffer->quick_push (eof_token); + lexer->buffer->quick_push (eof_token); + + lexer->next_token = lexer->buffer->address(); + lexer->last_token = lexer->next_token + lexer->buffer->length () - 1; + + cp_lexer *old_lexer = parser->lexer; + parser->lexer = lexer; + cp_lexer_set_source_position_from_token (lexer->next_token); + + tree directive = push_stmt_list (); + tree directive_stmt = begin_compound_stmt (0); + + /* Declare all labels that occur within the directive body as + local. */ + for (unsigned j = 0; j < body_labels.length (); j++) + finish_label_decl (body_labels[j]); + cp_parser_pragma (parser, pragma_compound, if_p); + + finish_compound_stmt (directive_stmt); + directive = pop_stmt_list (directive); + + bool standalone_p + = directives[i]->kind == C_OMP_DIR_STANDALONE + || directives[i]->kind == C_OMP_DIR_UTILITY; + if (standalone_p) + { + /* Parsing standalone directives will not consume the body + tokens, so do that here. */ + if (standalone_body == NULL_TREE) + { + standalone_body = push_stmt_list (); + cp_parser_statement (parser, NULL_TREE, false, if_p); + standalone_body = pop_stmt_list (standalone_body); + } + else + cp_parser_skip_to_end_of_block_or_statement (parser); + } + + tree body = standalone_p ? standalone_body : NULL_TREE; + tree variant = build_tree_list (ctx, build_tree_list (directive, body)); + OMP_METADIRECTIVE_CLAUSES (ret) + = chainon (OMP_METADIRECTIVE_CLAUSES (ret), variant); + + /* Check that all valid tokens have been consumed. */ + gcc_assert (cp_lexer_next_token_is (parser->lexer, CPP_EOF)); + + parser->lexer = old_lexer; + cp_lexer_set_source_position_from_token (old_lexer->next_token); + } + + /* Try to resolve the metadirective early. */ + candidates = omp_resolve_metadirective (ret); + if (!candidates.is_empty ()) + ret = c_omp_expand_metadirective (candidates); + + add_stmt (ret); + + return ret; + +fail: + /* Skip the metadirective pragma. */ + cp_parser_skip_to_pragma_eol (parser, pragma_tok); + + /* Skip the metadirective body. */ + cp_parser_skip_to_end_of_block_or_statement (parser); + return error_mark_node; +} + + /* Helper function of cp_parser_omp_declare_reduction. Parse the combiner expression and optional initializer clause of #pragma omp declare reduction. We store the expression(s) as @@ -47077,6 +47480,11 @@ cp_parser_omp_construct (cp_parser *parser, cp_token *pragma_tok, bool *if_p) stmt = cp_parser_omp_master (parser, pragma_tok, p_name, mask, NULL, if_p); break; + case PRAGMA_OMP_METADIRECTIVE: + strcpy (p_name, "#pragma omp"); + stmt = cp_parser_omp_metadirective (parser, pragma_tok, p_name, mask, + NULL, if_p); + break; case PRAGMA_OMP_PARALLEL: strcpy (p_name, "#pragma omp"); stmt = cp_parser_omp_parallel (parser, pragma_tok, p_name, mask, NULL, @@ -47727,6 +48135,7 @@ cp_parser_pragma (cp_parser *parser, enum pragma_context context, bool *if_p) case PRAGMA_OMP_LOOP: case PRAGMA_OMP_MASKED: case PRAGMA_OMP_MASTER: + case PRAGMA_OMP_METADIRECTIVE: case PRAGMA_OMP_PARALLEL: case PRAGMA_OMP_SCOPE: case PRAGMA_OMP_SECTIONS: From patchwork Fri Dec 10 17:39:17 2021 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Kwok Cheung Yeung X-Patchwork-Id: 48798 Return-Path: X-Original-To: patchwork@sourceware.org Delivered-To: patchwork@sourceware.org Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id C58B83857C7A for ; Fri, 10 Dec 2021 17:40:21 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from esa1.mentor.iphmx.com (esa1.mentor.iphmx.com [68.232.129.153]) by sourceware.org (Postfix) with ESMTPS id AC6A3385801D; Fri, 10 Dec 2021 17:39:50 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.1 sourceware.org AC6A3385801D Authentication-Results: sourceware.org; dmarc=none (p=none dis=none) header.from=codesourcery.com Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=mentor.com IronPort-SDR: t+KNs9JhL9KQwwEdWuZ5297EBqfGI7iWp/gSZEWp1hyI/Boe1+96kpPSIgOJh51myLdhBLxBNx FdmIxXq1TtCKEq3DdGAQ6poM6di1HB9r1Axd1LIaHOfIYTmozlOsG0xvwb3K+Xh+Hh3X7xL1zv JJ7BAg6Py57jbL8m/oGQNS8VRajI3XPgjEd+hdvV4PhFQvHYS0vkM08FDfsYCZqT2hyRhi95Bw ccoXeFK5EmKn/vcZsScGHbIOiXIgApDqSLsxiVXkqGlrkzEBYS5w4SJFXVuIWOkaa4lUK4yN0/ PEElr1TvUNCrE9HNOezYeZtY X-IronPort-AV: E=Sophos;i="5.88,196,1635235200"; d="scan'208,223";a="72064323" Received: from orw-gwy-02-in.mentorg.com ([192.94.38.167]) by esa1.mentor.iphmx.com with ESMTP; 10 Dec 2021 09:39:50 -0800 IronPort-SDR: P1cTAH/LdBA5M6txm3saAGhyP5IAVLlDWqIktg8pBsY1Y+UYQOWbNhKepT8SSgVPbgCKNvVb5j ziDoKz6s0Yx9m7T3JwUMJ9e3uEhsuvaPzCcP2oqblWCxktAqYJMVpcehi/8d0Esw5DJTge5skZ h5frDFLLuNlKr3tti+TMumIsInCoKr6BOnwXqm4niCAQErtmzow/qDIsiXL8iaGBmqh2mjJvI5 ZL8dDlYc9sw38dDbycm4ln72lIViOfRFMctfq2rSNiD7Aje8YqzNL/ey2xOD7d6JdjTPvDrxHP y1k= Message-ID: <88facbcc-5be6-5c3b-1e73-f5ceba75ef6f@codesourcery.com> Date: Fri, 10 Dec 2021 17:39:17 +0000 MIME-Version: 1.0 User-Agent: Mozilla/5.0 (Windows NT 10.0; Win64; x64; rv:91.0) Gecko/20100101 Thunderbird/91.4.0 References: Subject: [PATCH 6/7] openmp, fortran: Add Fortran support for parsing metadirectives To: gcc-patches , fortran , Jakub Jelinek , Tobias Burnus From: Kwok Cheung Yeung In-Reply-To: X-Originating-IP: [137.202.0.90] X-ClientProxiedBy: svr-ies-mbx-05.mgc.mentorg.com (139.181.222.5) To SVR-IES-MBX-04.mgc.mentorg.com (139.181.222.4) X-Spam-Status: No, score=-12.0 required=5.0 tests=BAYES_00, GIT_PATCH_0, HEADER_FROM_DIFFERENT_DOMAINS, KAM_DMARC_STATUS, SPF_HELO_PASS, SPF_PASS, TXREP autolearn=ham autolearn_force=no version=3.4.4 X-Spam-Checker-Version: SpamAssassin 3.4.4 (2020-01-24) on server2.sourceware.org X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: gcc-patches-bounces+patchwork=sourceware.org@gcc.gnu.org Sender: "Gcc-patches" This patch implements metadirective parsing in the Fortran frontend. The code previously used to process context selectors in 'declare variant' is refactored so that it can be reused in metadirectives. The big case lists in parse_executable are moved into macros, since parse_omp_metadirective_body needs to know how to act depending on the type of directive variant. The selection of end statements in parse_omp_do and parse_omp_structured_block are also delegated to gfc_omp_end_stmt. Labels in directive variant bodies are handled by assigning a unique number to each statement body parsed in a metadirective, and adding this number as a field to gfc_st_label, such that labels with identical numbers but different region ids are considered different. I have also reverted my previous changes to the TREE_STRING_LENGTH check in omp_check_context_selector and omp_context_name_list_prop. This is because in the accel compiler, lang_GNU_Fortran returns 0 even when the code is in Fortran, resulting in the selector failing to match. Instead, I opted to increment the TREE_STRING_LENGTH when it is created in gfc_trans_omp_set_selector - this should be safe as it is an internal implementation detail not visible to end users. Kwok From eed8a06fca397edd5fb451f08c8b1a6f7d67951a Mon Sep 17 00:00:00 2001 From: Kwok Cheung Yeung Date: Mon, 6 Dec 2021 22:59:36 +0000 Subject: [PATCH 6/7] openmp, fortran: Add Fortran support for parsing metadirectives This adds support for parsing OpenMP metadirectives in the Fortran front end. 2021-12-10 Kwok Cheung Yeung gcc/ * omp-general.c (omp_check_context_selector): Revert string length check. (omp_context_name_list_prop): Likewise. gcc/fortran/ * decl.c (gfc_match_end): Handle COMP_OMP_METADIRECTIVE and COMP_OMP_BEGIN_METADIRECTIVE. * dump-parse-tree.c (show_omp_node): Handle EXEC_OMP_METADIRECTIVE. (show_code_node): Handle EXEC_OMP_METADIRECTIVE. * gfortran.h (enum gfc_statement): Add ST_OMP_METADIRECTIVE, ST_OMP_BEGIN_METADIRECTIVE and ST_OMP_END_METADIRECTIVE. (struct gfc_omp_metadirective_clause): New structure. (gfc_get_omp_metadirective_clause): New macro. (struct gfc_st_label): Add omp_region field. (enum gfc_exec_op): Add EXEC_OMP_METADIRECTIVE. (struct gfc_code): Add omp_metadirective_clauses field. (gfc_free_omp_metadirective_clauses): New prototype. (match_omp_directive): New prototype. * io.c (format_asterisk): Initialize omp_region field. * match.h (gfc_match_omp_begin_metadirective): New prototype. (gfc_match_omp_metadirective): New prototype. * openmp.c (gfc_match_omp_eos): Match ')' in context selectors. (gfc_free_omp_metadirective_clauses): New. (gfc_match_omp_clauses): Remove context_selector argument. Rely on gfc_match_omp_eos to match end of clauses. (match_omp): Remove extra argument to gfc_match_omp_clauses. (gfc_match_omp_context_selector): Remove extra argument to gfc_match_omp_clauses. Set gfc_matching_omp_context_selector before call to gfc_match_omp_clauses and reset after. (gfc_match_omp_context_selector_specification): Modify to take a gfc_omp_set_selector** argument. (gfc_match_omp_declare_variant): Pass set_selectors to gfc_match_omp_context_selector_specification. (match_omp_metadirective): New. (gfc_match_omp_begin_metadirective): New. (gfc_match_omp_metadirective): New. (resolve_omp_metadirective): New. (gfc_resolve_omp_directive): Handle EXEC_OMP_METADIRECTIVE. * parse.c (gfc_matching_omp_context_selector): New variable. (gfc_in_metadirective_body): New variable. (gfc_omp_region_count): New variable. (decode_omp_directive): Match 'begin metadirective', 'end metadirective' and 'metadirective'. (match_omp_directive): New. (case_omp_structured_block): New. (case_omp_do): New. (gfc_ascii_statement): Handle metadirective statements. (gfc_omp_end_stmt): New. (parse_omp_do): Delegate to gfc_omp_end_stmt. (parse_omp_structured_block): Delegate to gfc_omp_end_stmt. Handle ST_OMP_END_METADIRECTIVE. (parse_omp_metadirective_body): New. (parse_executable): Delegate to case_omp_structured_block and case_omp_do. Return after one statement if compiling regular metadirective. Handle metadirective statements. (gfc_parse_file): Reset gfc_omp_region_count, gfc_in_metadirective_body and gfc_matching_omp_context_selector. * parse.h (enum gfc_compile_state): Add COMP_OMP_METADIRECTIVE and COMP_OMP_BEGIN_METADIRECTIVE. (gfc_omp_end_stmt): New prototype. (gfc_matching_omp_context_selector): New declaration. (gfc_in_metadirective_body): New declaration. (gfc_omp_region_count): New declaration. * resolve.c (gfc_resolve_code): Handle EXEC_OMP_METADIRECTIVE. * st.c (gfc_free_statement): Handle EXEC_OMP_METADIRECTIVE. * symbol.c (compare_st_labels): Take omp_region into account. (gfc_get_st_labels): Incorporate omp_region into label. * trans-decl.c (gfc_get_label_decl): Add omp_region into translated label name. * trans-openmp.c (gfc_trans_omp_directive): Handle EXEC_OMP_METADIRECTIVE. (gfc_trans_omp_set_selector): Hoist code from... (gfc_trans_omp_declare_variant): ...here. (gfc_trans_omp_metadirective): New. * trans-stmt.h (gfc_trans_omp_metadirective): New prototype. * trans.c (trans_code): Handle EXEC_OMP_METADIRECTIVE. --- gcc/fortran/decl.c | 8 + gcc/fortran/dump-parse-tree.c | 20 ++ gcc/fortran/gfortran.h | 17 ++ gcc/fortran/io.c | 2 +- gcc/fortran/match.h | 2 + gcc/fortran/openmp.c | 222 ++++++++++++-- gcc/fortran/parse.c | 532 ++++++++++++++++++++-------------- gcc/fortran/parse.h | 8 +- gcc/fortran/resolve.c | 12 + gcc/fortran/st.c | 4 + gcc/fortran/symbol.c | 18 +- gcc/fortran/trans-decl.c | 5 +- gcc/fortran/trans-openmp.c | 190 +++++++----- gcc/fortran/trans-stmt.h | 1 + gcc/fortran/trans.c | 1 + gcc/omp-general.c | 5 +- 16 files changed, 729 insertions(+), 318 deletions(-) diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index 4971638f9b6..d50c3ea2277 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -8323,6 +8323,8 @@ gfc_match_end (gfc_statement *st) case COMP_CONTAINS: case COMP_DERIVED_CONTAINS: + case COMP_OMP_METADIRECTIVE: + case COMP_OMP_BEGIN_METADIRECTIVE: state = gfc_state_stack->previous->state; block_name = gfc_state_stack->previous->sym == NULL ? NULL : gfc_state_stack->previous->sym->name; @@ -8475,6 +8477,12 @@ gfc_match_end (gfc_statement *st) gfc_free_enum_history (); break; + case COMP_OMP_BEGIN_METADIRECTIVE: + *st = ST_OMP_END_METADIRECTIVE; + target = " metadirective"; + eos_ok = 0; + break; + default: gfc_error ("Unexpected END statement at %C"); goto cleanup; diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c index 2aa44ff864c..4ec64ad5ea3 100644 --- a/gcc/fortran/dump-parse-tree.c +++ b/gcc/fortran/dump-parse-tree.c @@ -2015,6 +2015,7 @@ show_omp_node (int level, gfc_code *c) case EXEC_OMP_MASTER: name = "MASTER"; break; case EXEC_OMP_MASTER_TASKLOOP: name = "MASTER TASKLOOP"; break; case EXEC_OMP_MASTER_TASKLOOP_SIMD: name = "MASTER TASKLOOP SIMD"; break; + case EXEC_OMP_METADIRECTIVE: name = "METADIRECTIVE"; break; case EXEC_OMP_ORDERED: name = "ORDERED"; break; case EXEC_OMP_DEPOBJ: name = "DEPOBJ"; break; case EXEC_OMP_PARALLEL: name = "PARALLEL"; break; @@ -2209,6 +2210,24 @@ show_omp_node (int level, gfc_code *c) d = d->block; } } + else if (c->op == EXEC_OMP_METADIRECTIVE) + { + gfc_omp_metadirective_clause *clause = c->ext.omp_metadirective_clauses; + + while (clause) + { + code_indent (level + 1, 0); + if (clause->selectors) + fputs ("WHEN ()\n", dumpfile); + else + fputs ("DEFAULT ()\n", dumpfile); + /* TODO: Print selector. */ + show_code (level + 2, clause->code); + if (clause->next) + fputs ("\n", dumpfile); + clause = clause->next; + } + } else show_code (level + 1, c->block->next); if (c->op == EXEC_OMP_ATOMIC) @@ -3335,6 +3354,7 @@ show_code_node (int level, gfc_code *c) case EXEC_OMP_MASTER: case EXEC_OMP_MASTER_TASKLOOP: case EXEC_OMP_MASTER_TASKLOOP_SIMD: + case EXEC_OMP_METADIRECTIVE: case EXEC_OMP_ORDERED: case EXEC_OMP_PARALLEL: case EXEC_OMP_PARALLEL_DO: diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index e5d2dd7971e..5025df1bda2 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -316,6 +316,7 @@ enum gfc_statement ST_OMP_END_PARALLEL_MASKED_TASKLOOP_SIMD, ST_OMP_MASKED_TASKLOOP, ST_OMP_END_MASKED_TASKLOOP, ST_OMP_MASKED_TASKLOOP_SIMD, ST_OMP_END_MASKED_TASKLOOP_SIMD, ST_OMP_SCOPE, ST_OMP_END_SCOPE, + ST_OMP_METADIRECTIVE, ST_OMP_BEGIN_METADIRECTIVE, ST_OMP_END_METADIRECTIVE, ST_OMP_ERROR, ST_NONE }; @@ -1658,6 +1659,17 @@ typedef struct gfc_omp_declare_variant gfc_omp_declare_variant; #define gfc_get_omp_declare_variant() XCNEW (gfc_omp_declare_variant) +typedef struct gfc_omp_metadirective_clause +{ + struct gfc_omp_metadirective_clause *next; + locus where; /* Where the metadirective clause occurred. */ + + gfc_omp_set_selector *selectors; + enum gfc_statement stmt; + struct gfc_code *code; + +} gfc_omp_metadirective_clause; +#define gfc_get_omp_metadirective_clause() XCNEW (gfc_omp_metadirective_clause) typedef struct gfc_omp_udr { @@ -1706,6 +1718,7 @@ typedef struct gfc_st_label locus where; gfc_namespace *ns; + int omp_region; } gfc_st_label; @@ -2922,6 +2935,7 @@ enum gfc_exec_op EXEC_OMP_TARGET_TEAMS_LOOP, EXEC_OMP_MASKED, EXEC_OMP_PARALLEL_MASKED, EXEC_OMP_PARALLEL_MASKED_TASKLOOP, EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD, EXEC_OMP_MASKED_TASKLOOP, EXEC_OMP_MASKED_TASKLOOP_SIMD, EXEC_OMP_SCOPE, + EXEC_OMP_METADIRECTIVE, EXEC_OMP_ERROR }; @@ -2978,6 +2992,7 @@ typedef struct gfc_code gfc_omp_clauses *omp_clauses; const char *omp_name; gfc_omp_namelist *omp_namelist; + gfc_omp_metadirective_clause *omp_metadirective_clauses; bool omp_bool; } ext; /* Points to additional structures required by statement */ @@ -3552,6 +3567,7 @@ void gfc_free_omp_declare_variant_list (gfc_omp_declare_variant *list); void gfc_free_omp_declare_simd (gfc_omp_declare_simd *); void gfc_free_omp_declare_simd_list (gfc_omp_declare_simd *); void gfc_free_omp_udr (gfc_omp_udr *); +void gfc_free_omp_metadirective_clauses (gfc_omp_metadirective_clause *); gfc_omp_udr *gfc_omp_udr_find (gfc_symtree *, gfc_typespec *); void gfc_resolve_omp_directive (gfc_code *, gfc_namespace *); void gfc_resolve_do_iterator (gfc_code *, gfc_symbol *, bool); @@ -3827,6 +3843,7 @@ void debug (gfc_expr *); bool gfc_parse_file (void); void gfc_global_used (gfc_gsymbol *, locus *); gfc_namespace* gfc_build_block_ns (gfc_namespace *); +gfc_statement match_omp_directive (void); /* dependency.c */ int gfc_dep_compare_functions (gfc_expr *, gfc_expr *, bool); diff --git a/gcc/fortran/io.c b/gcc/fortran/io.c index fc97df79eca..adb811a423c 100644 --- a/gcc/fortran/io.c +++ b/gcc/fortran/io.c @@ -29,7 +29,7 @@ along with GCC; see the file COPYING3. If not see gfc_st_label format_asterisk = {0, NULL, NULL, -1, ST_LABEL_FORMAT, ST_LABEL_FORMAT, NULL, - 0, {NULL, NULL}, NULL}; + 0, {NULL, NULL}, NULL, 0}; typedef struct { diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h index e9368db281d..cf0f711f4ec 100644 --- a/gcc/fortran/match.h +++ b/gcc/fortran/match.h @@ -151,6 +151,7 @@ match gfc_match_oacc_routine (void); match gfc_match_omp_eos_error (void); match gfc_match_omp_atomic (void); match gfc_match_omp_barrier (void); +match gfc_match_omp_begin_metadirective (void); match gfc_match_omp_cancel (void); match gfc_match_omp_cancellation_point (void); match gfc_match_omp_critical (void); @@ -174,6 +175,7 @@ match gfc_match_omp_masked_taskloop_simd (void); match gfc_match_omp_master (void); match gfc_match_omp_master_taskloop (void); match gfc_match_omp_master_taskloop_simd (void); +match gfc_match_omp_metadirective (void); match gfc_match_omp_nothing (void); match gfc_match_omp_ordered (void); match gfc_match_omp_ordered_depend (void); diff --git a/gcc/fortran/openmp.c b/gcc/fortran/openmp.c index 846fd7b5c5a..1a423c8e041 100644 --- a/gcc/fortran/openmp.c +++ b/gcc/fortran/openmp.c @@ -31,7 +31,8 @@ along with GCC; see the file COPYING3. If not see #include "target-memory.h" /* For gfc_encode_character. */ /* Match an end of OpenMP directive. End of OpenMP directive is optional - whitespace, followed by '\n' or comment '!'. */ + whitespace, followed by '\n' or comment '!'. In the special case where a + context selector is being matched, match against ')' instead. */ static match gfc_match_omp_eos (void) @@ -42,17 +43,25 @@ gfc_match_omp_eos (void) old_loc = gfc_current_locus; gfc_gobble_whitespace (); - c = gfc_next_ascii_char (); - switch (c) + if (gfc_matching_omp_context_selector) { - case '!': - do - c = gfc_next_ascii_char (); - while (c != '\n'); - /* Fall through */ + if (gfc_peek_ascii_char () == ')') + return MATCH_YES; + } + else + { + c = gfc_next_ascii_char (); + switch (c) + { + case '!': + do + c = gfc_next_ascii_char (); + while (c != '\n'); + /* Fall through */ - case '\n': - return MATCH_YES; + case '\n': + return MATCH_YES; + } } gfc_current_locus = old_loc; @@ -248,6 +257,19 @@ gfc_free_omp_udr (gfc_omp_udr *omp_udr) } } +/* Free clauses of an !$omp metadirective construct. */ + +void +gfc_free_omp_metadirective_clauses (gfc_omp_metadirective_clause *clause) +{ + while (clause) + { + gfc_omp_metadirective_clause *next_clause = clause->next; + gfc_free_omp_set_selector_list (clause->selectors); + free (clause); + clause = next_clause; + } +} static gfc_omp_udr * gfc_find_omp_udr (gfc_namespace *ns, const char *name, gfc_typespec *ts) @@ -1434,8 +1456,7 @@ gfc_match_dupl_atomic (bool not_dupl, const char *name) static match gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, bool first = true, bool needs_space = true, - bool openacc = false, bool context_selector = false, - bool openmp_target = false) + bool openacc = false, bool openmp_target = false) { bool error = false; gfc_omp_clauses *c = gfc_get_omp_clauses (); @@ -2982,9 +3003,7 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, } end: - if (error - || (context_selector && gfc_peek_ascii_char () != ')') - || (!context_selector && gfc_match_omp_eos () != MATCH_YES)) + if (error || gfc_match_omp_eos () != MATCH_YES) { if (!gfc_error_flag_test ()) gfc_error ("Failed to match clause at %C"); @@ -3655,7 +3674,7 @@ static match match_omp (gfc_exec_op op, const omp_mask mask) { gfc_omp_clauses *c; - if (gfc_match_omp_clauses (&c, mask, true, true, false, false, + if (gfc_match_omp_clauses (&c, mask, true, true, false, op == EXEC_OMP_TARGET) != MATCH_YES) return MATCH_ERROR; new_st.op = op; @@ -4804,14 +4823,17 @@ gfc_match_omp_context_selector (gfc_omp_set_selector *oss) break; case CTX_PROPERTY_SIMD: { + gfc_matching_omp_context_selector = true; if (gfc_match_omp_clauses (&otp->clauses, OMP_DECLARE_SIMD_CLAUSES, - true, false, false, true) + true, false, false) != MATCH_YES) { - gfc_error ("expected simd clause at %C"); + gfc_matching_omp_context_selector = false; + gfc_error ("expected simd clause at %C"); return MATCH_ERROR; } + gfc_matching_omp_context_selector = false; break; } default: @@ -4857,7 +4879,7 @@ gfc_match_omp_context_selector (gfc_omp_set_selector *oss) user */ match -gfc_match_omp_context_selector_specification (gfc_omp_declare_variant *odv) +gfc_match_omp_context_selector_specification (gfc_omp_set_selector **oss_head) { do { @@ -4897,9 +4919,9 @@ gfc_match_omp_context_selector_specification (gfc_omp_declare_variant *odv) } gfc_omp_set_selector *oss = gfc_get_omp_set_selector (); - oss->next = odv->set_selectors; + oss->next = *oss_head; oss->trait_set_selector_name = selector_sets[i]; - odv->set_selectors = oss; + *oss_head = oss; if (gfc_match_omp_context_selector (oss) != MATCH_YES) return MATCH_ERROR; @@ -5000,7 +5022,8 @@ gfc_match_omp_declare_variant (void) return MATCH_ERROR; } - if (gfc_match_omp_context_selector_specification (odv) != MATCH_YES) + if (gfc_match_omp_context_selector_specification (&odv->set_selectors) + != MATCH_YES) return MATCH_ERROR; if (gfc_match (" )") != MATCH_YES) @@ -5016,6 +5039,145 @@ gfc_match_omp_declare_variant (void) } +static match +match_omp_metadirective (bool begin_p) +{ + locus old_loc = gfc_current_locus; + gfc_omp_metadirective_clause *clause_head; + gfc_omp_metadirective_clause **next_clause = &clause_head; + bool default_seen = false; + + /* Parse the context selectors. */ + for (;;) + { + bool default_p = false; + gfc_omp_set_selector *selectors = NULL; + + if (gfc_match (" default ( ") == MATCH_YES) + default_p = true; + else if (gfc_match_eos () == MATCH_YES) + break; + else if (gfc_match (" when ( ") != MATCH_YES) + { + gfc_error ("expected 'default' or 'when' at %C"); + gfc_current_locus = old_loc; + return MATCH_ERROR; + } + + if (default_p && default_seen) + { + gfc_error ("there can only be one default clause in a " + "metadirective at %C"); + gfc_current_locus = old_loc; + return MATCH_ERROR; + } + + if (!default_p) + { + if (gfc_match_omp_context_selector_specification (&selectors) + != MATCH_YES) + return MATCH_ERROR; + + if (gfc_match (" : ") != MATCH_YES) + { + gfc_error ("expected ':' at %C"); + gfc_current_locus = old_loc; + return MATCH_ERROR; + } + + gfc_commit_symbols (); + } + + gfc_matching_omp_context_selector = true; + gfc_statement directive = match_omp_directive (); + gfc_matching_omp_context_selector = false; + + if (gfc_error_flag_test ()) + { + gfc_current_locus = old_loc; + return MATCH_ERROR; + } + + if (gfc_match (" )") != MATCH_YES) + { + gfc_error ("Expected ')' at %C"); + gfc_current_locus = old_loc; + return MATCH_ERROR; + } + + gfc_commit_symbols (); + + if (begin_p && directive != ST_NONE + && gfc_omp_end_stmt (directive) == ST_NONE) + { + gfc_error ("variant directive used in OMP BEGIN METADIRECTIVE " + "at %C must have a corresponding end directive"); + gfc_current_locus = old_loc; + return MATCH_ERROR; + } + + if (default_p) + default_seen = true; + + gfc_omp_metadirective_clause *omc = gfc_get_omp_metadirective_clause (); + omc->selectors = selectors; + omc->stmt = directive; + if (directive == ST_NONE) + { + /* The directive was a 'nothing' directive. */ + omc->code = gfc_get_code (EXEC_CONTINUE); + omc->code->ext.omp_clauses = NULL; + } + else + { + omc->code = gfc_get_code (new_st.op); + omc->code->ext.omp_clauses = new_st.ext.omp_clauses; + /* Prevent the OpenMP clauses from being freed via NEW_ST. */ + new_st.ext.omp_clauses = NULL; + } + + *next_clause = omc; + next_clause = &omc->next; + } + + if (gfc_match_omp_eos () != MATCH_YES) + { + gfc_error ("Unexpected junk after OMP METADIRECTIVE at %C"); + gfc_current_locus = old_loc; + return MATCH_ERROR; + } + + /* Add a 'default (nothing)' clause if no default is explicitly given. */ + if (!default_seen) + { + gfc_omp_metadirective_clause *omc = gfc_get_omp_metadirective_clause (); + omc->stmt = ST_NONE; + omc->code = gfc_get_code (EXEC_CONTINUE); + omc->code->ext.omp_clauses = NULL; + omc->selectors = NULL; + + *next_clause = omc; + next_clause = &omc->next; + } + + new_st.op = EXEC_OMP_METADIRECTIVE; + new_st.ext.omp_metadirective_clauses = clause_head; + + return MATCH_YES; +} + +match +gfc_match_omp_begin_metadirective (void) +{ + return match_omp_metadirective (true); +} + +match +gfc_match_omp_metadirective (void) +{ + return match_omp_metadirective (false); +} + match gfc_match_omp_threadprivate (void) { @@ -8486,6 +8648,19 @@ resolve_omp_do (gfc_code *code) } } +static void +resolve_omp_metadirective (gfc_code *code, gfc_namespace *ns) +{ + gfc_omp_metadirective_clause *clause = code->ext.omp_metadirective_clauses; + + while (clause) + { + gfc_code *clause_code = clause->code; + gfc_resolve_code (clause_code, ns); + clause = clause->next; + } +} + static gfc_statement omp_code_to_statement (gfc_code *code) @@ -9113,6 +9288,9 @@ gfc_resolve_omp_directive (gfc_code *code, gfc_namespace *ns) code->ext.omp_clauses->if_present = false; resolve_omp_clauses (code, code->ext.omp_clauses, ns); break; + case EXEC_OMP_METADIRECTIVE: + resolve_omp_metadirective (code, ns); + break; default: break; } diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index 1f111091b0a..a96c892c608 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -40,6 +40,10 @@ static jmp_buf eof_buf; gfc_state_data *gfc_state_stack; static bool last_was_use_stmt = false; +bool gfc_matching_omp_context_selector; +bool gfc_in_metadirective_body; +int gfc_omp_region_count; + /* TODO: Re-order functions to kill these forward decls. */ static void check_statement_label (gfc_statement); static void undo_new_statement (void); @@ -889,6 +893,8 @@ decode_omp_directive (void) break; case 'b': matcho ("barrier", gfc_match_omp_barrier, ST_OMP_BARRIER); + matcho ("begin metadirective", gfc_match_omp_begin_metadirective, + ST_OMP_BEGIN_METADIRECTIVE); break; case 'c': matcho ("cancellation% point", gfc_match_omp_cancellation_point, @@ -936,6 +942,8 @@ decode_omp_directive (void) matcho ("end master taskloop", gfc_match_omp_eos_error, ST_OMP_END_MASTER_TASKLOOP); matcho ("end master", gfc_match_omp_eos_error, ST_OMP_END_MASTER); + matcho ("end metadirective", gfc_match_omp_eos_error, + ST_OMP_END_METADIRECTIVE); matchs ("end ordered", gfc_match_omp_eos_error, ST_OMP_END_ORDERED); matchs ("end parallel do simd", gfc_match_omp_eos_error, ST_OMP_END_PARALLEL_DO_SIMD); @@ -1018,6 +1026,8 @@ decode_omp_directive (void) matcho ("master taskloop", gfc_match_omp_master_taskloop, ST_OMP_MASTER_TASKLOOP); matcho ("master", gfc_match_omp_master, ST_OMP_MASTER); + matcho ("metadirective", gfc_match_omp_metadirective, + ST_OMP_METADIRECTIVE); break; case 'n': matcho ("nothing", gfc_match_omp_nothing, ST_NONE); @@ -1146,6 +1156,10 @@ decode_omp_directive (void) gfc_error_now ("Unclassifiable OpenMP directive at %C"); } + /* If parsing a metadirective, let the caller deal with the cleanup. */ + if (gfc_matching_omp_context_selector) + return ST_NONE; + reject_statement (); gfc_error_recovery (); @@ -1213,6 +1227,12 @@ decode_omp_directive (void) return ST_GET_FCN_CHARACTERISTICS; } +gfc_statement +match_omp_directive (void) +{ + return decode_omp_directive (); +} + static gfc_statement decode_gcc_attribute (void) { @@ -1734,6 +1754,43 @@ next_statement (void) case ST_OMP_DECLARE_VARIANT: \ case ST_OMP_REQUIRES: case ST_OACC_ROUTINE: case ST_OACC_DECLARE +/* OpenMP statements that are followed by a structured block. */ + +#define case_omp_structured_block case ST_OMP_PARALLEL: \ + case ST_OMP_PARALLEL_MASKED: case ST_OMP_PARALLEL_MASTER: \ + case ST_OMP_PARALLEL_SECTIONS: case ST_OMP_ORDERED: \ + case ST_OMP_CRITICAL: case ST_OMP_MASKED: case ST_OMP_MASTER: \ + case ST_OMP_SCOPE: case ST_OMP_SECTIONS: case ST_OMP_SINGLE: \ + case ST_OMP_TARGET: case ST_OMP_TARGET_DATA: case ST_OMP_TARGET_PARALLEL: \ + case ST_OMP_TARGET_TEAMS: case ST_OMP_TEAMS: case ST_OMP_TASK: \ + case ST_OMP_TASKGROUP: \ + case ST_OMP_WORKSHARE: case ST_OMP_PARALLEL_WORKSHARE + +/* OpenMP statements that are followed by a do loop. */ + +#define case_omp_do case ST_OMP_DISTRIBUTE: \ + case ST_OMP_DISTRIBUTE_PARALLEL_DO: \ + case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: case ST_OMP_DISTRIBUTE_SIMD: \ + case ST_OMP_DO: case ST_OMP_DO_SIMD: case ST_OMP_LOOP: \ + case ST_OMP_PARALLEL_DO: case ST_OMP_PARALLEL_DO_SIMD: \ + case ST_OMP_PARALLEL_LOOP: case ST_OMP_PARALLEL_MASKED_TASKLOOP: \ + case ST_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: \ + case ST_OMP_PARALLEL_MASTER_TASKLOOP: \ + case ST_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: \ + case ST_OMP_MASKED_TASKLOOP: case ST_OMP_MASKED_TASKLOOP_SIMD: \ + case ST_OMP_MASTER_TASKLOOP: case ST_OMP_MASTER_TASKLOOP_SIMD: \ + case ST_OMP_SIMD: \ + case ST_OMP_TARGET_PARALLEL_DO: case ST_OMP_TARGET_PARALLEL_DO_SIMD: \ + case ST_OMP_TARGET_PARALLEL_LOOP: case ST_OMP_TARGET_SIMD: \ + case ST_OMP_TARGET_TEAMS_DISTRIBUTE: \ + case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: \ + case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: \ + case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: case ST_OMP_TARGET_TEAMS_LOOP: \ + case ST_OMP_TASKLOOP: case ST_OMP_TASKLOOP_SIMD: \ + case ST_OMP_TEAMS_DISTRIBUTE: case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: \ + case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: \ + case ST_OMP_TEAMS_DISTRIBUTE_SIMD: case ST_OMP_TEAMS_LOOP + /* Block end statements. Errors associated with interchanging these are detected in gfc_match_end(). */ @@ -2357,6 +2414,9 @@ gfc_ascii_statement (gfc_statement st) case ST_OMP_BARRIER: p = "!$OMP BARRIER"; break; + case ST_OMP_BEGIN_METADIRECTIVE: + p = "!$OMP BEGIN METADIRECTIVE"; + break; case ST_OMP_CANCEL: p = "!$OMP CANCEL"; break; @@ -2450,6 +2510,9 @@ gfc_ascii_statement (gfc_statement st) case ST_OMP_END_MASTER_TASKLOOP_SIMD: p = "!$OMP END MASTER TASKLOOP SIMD"; break; + case ST_OMP_END_METADIRECTIVE: + p = "!OMP END METADIRECTIVE"; + break; case ST_OMP_END_ORDERED: p = "!$OMP END ORDERED"; break; @@ -2594,6 +2657,9 @@ gfc_ascii_statement (gfc_statement st) case ST_OMP_MASTER_TASKLOOP_SIMD: p = "!$OMP MASTER TASKLOOP SIMD"; break; + case ST_OMP_METADIRECTIVE: + p = "!$OMP METADIRECTIVE"; + break; case ST_OMP_ORDERED: case ST_OMP_ORDERED_DEPEND: p = "!$OMP ORDERED"; @@ -2848,6 +2914,8 @@ accept_statement (gfc_statement st) break; case ST_ENTRY: + case ST_OMP_METADIRECTIVE: + case ST_OMP_BEGIN_METADIRECTIVE: case_executable: case_exec_markers: add_statement (); @@ -5124,6 +5192,138 @@ loop: accept_statement (st); } +/* Get the corresponding ending statement type for the OpenMP directive + OMP_ST. If it does not have one, return ST_NONE. */ + +gfc_statement +gfc_omp_end_stmt (gfc_statement omp_st, + bool omp_do_p, bool omp_structured_p) +{ + if (omp_do_p) + { + switch (omp_st) + { + case ST_OMP_DISTRIBUTE: return ST_OMP_END_DISTRIBUTE; + case ST_OMP_DISTRIBUTE_PARALLEL_DO: + return ST_OMP_END_DISTRIBUTE_PARALLEL_DO; + case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: + return ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD; + case ST_OMP_DISTRIBUTE_SIMD: + return ST_OMP_END_DISTRIBUTE_SIMD; + case ST_OMP_DO: return ST_OMP_END_DO; + case ST_OMP_DO_SIMD: return ST_OMP_END_DO_SIMD; + case ST_OMP_LOOP: return ST_OMP_END_LOOP; + case ST_OMP_PARALLEL_DO: return ST_OMP_END_PARALLEL_DO; + case ST_OMP_PARALLEL_DO_SIMD: + return ST_OMP_END_PARALLEL_DO_SIMD; + case ST_OMP_PARALLEL_LOOP: + return ST_OMP_END_PARALLEL_LOOP; + case ST_OMP_SIMD: return ST_OMP_END_SIMD; + case ST_OMP_TARGET_PARALLEL_DO: + return ST_OMP_END_TARGET_PARALLEL_DO; + case ST_OMP_TARGET_PARALLEL_DO_SIMD: + return ST_OMP_END_TARGET_PARALLEL_DO_SIMD; + case ST_OMP_TARGET_PARALLEL_LOOP: + return ST_OMP_END_TARGET_PARALLEL_LOOP; + case ST_OMP_TARGET_SIMD: return ST_OMP_END_TARGET_SIMD; + case ST_OMP_TARGET_TEAMS_DISTRIBUTE: + return ST_OMP_END_TARGET_TEAMS_DISTRIBUTE; + case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: + return ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO; + case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: + return ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD; + case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: + return ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD; + case ST_OMP_TARGET_TEAMS_LOOP: + return ST_OMP_END_TARGET_TEAMS_LOOP; + case ST_OMP_TASKLOOP: return ST_OMP_END_TASKLOOP; + case ST_OMP_TASKLOOP_SIMD: return ST_OMP_END_TASKLOOP_SIMD; + case ST_OMP_MASKED_TASKLOOP: return ST_OMP_END_MASKED_TASKLOOP; + case ST_OMP_MASKED_TASKLOOP_SIMD: + return ST_OMP_END_MASKED_TASKLOOP_SIMD; + case ST_OMP_MASTER_TASKLOOP: return ST_OMP_END_MASTER_TASKLOOP; + case ST_OMP_MASTER_TASKLOOP_SIMD: + return ST_OMP_END_MASTER_TASKLOOP_SIMD; + case ST_OMP_PARALLEL_MASKED_TASKLOOP: + return ST_OMP_END_PARALLEL_MASKED_TASKLOOP; + case ST_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: + return ST_OMP_END_PARALLEL_MASKED_TASKLOOP_SIMD; + case ST_OMP_PARALLEL_MASTER_TASKLOOP: + return ST_OMP_END_PARALLEL_MASTER_TASKLOOP; + case ST_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: + return ST_OMP_END_PARALLEL_MASTER_TASKLOOP_SIMD; + case ST_OMP_TEAMS_DISTRIBUTE: + return ST_OMP_END_TEAMS_DISTRIBUTE; + case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: + return ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO; + case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: + return ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD; + case ST_OMP_TEAMS_DISTRIBUTE_SIMD: + return ST_OMP_END_TEAMS_DISTRIBUTE_SIMD; + case ST_OMP_TEAMS_LOOP: + return ST_OMP_END_TEAMS_LOOP; + default: + break; + } + } + + if (omp_structured_p) + { + switch (omp_st) + { + case ST_OMP_PARALLEL: + return ST_OMP_END_PARALLEL; + case ST_OMP_PARALLEL_MASKED: + return ST_OMP_END_PARALLEL_MASKED; + case ST_OMP_PARALLEL_MASTER: + return ST_OMP_END_PARALLEL_MASTER; + case ST_OMP_PARALLEL_SECTIONS: + return ST_OMP_END_PARALLEL_SECTIONS; + case ST_OMP_SCOPE: + return ST_OMP_END_SCOPE; + case ST_OMP_SECTIONS: + return ST_OMP_END_SECTIONS; + case ST_OMP_ORDERED: + return ST_OMP_END_ORDERED; + case ST_OMP_CRITICAL: + return ST_OMP_END_CRITICAL; + case ST_OMP_MASKED: + return ST_OMP_END_MASKED; + case ST_OMP_MASTER: + return ST_OMP_END_MASTER; + case ST_OMP_SINGLE: + return ST_OMP_END_SINGLE; + case ST_OMP_TARGET: + return ST_OMP_END_TARGET; + case ST_OMP_TARGET_DATA: + return ST_OMP_END_TARGET_DATA; + case ST_OMP_TARGET_PARALLEL: + return ST_OMP_END_TARGET_PARALLEL; + case ST_OMP_TARGET_TEAMS: + return ST_OMP_END_TARGET_TEAMS; + case ST_OMP_TASK: + return ST_OMP_END_TASK; + case ST_OMP_TASKGROUP: + return ST_OMP_END_TASKGROUP; + case ST_OMP_TEAMS: + return ST_OMP_END_TEAMS; + case ST_OMP_TEAMS_DISTRIBUTE: + return ST_OMP_END_TEAMS_DISTRIBUTE; + case ST_OMP_DISTRIBUTE: + return ST_OMP_END_DISTRIBUTE; + case ST_OMP_WORKSHARE: + return ST_OMP_END_WORKSHARE; + case ST_OMP_PARALLEL_WORKSHARE: + return ST_OMP_END_PARALLEL_WORKSHARE; + case ST_OMP_BEGIN_METADIRECTIVE: + return ST_OMP_END_METADIRECTIVE; + default: + break; + } + } + + return ST_NONE; +} /* Parse the statements of OpenMP do/parallel do. */ @@ -5174,94 +5374,16 @@ parse_omp_do (gfc_statement omp_st) pop_state (); st = next_statement (); - gfc_statement omp_end_st = ST_OMP_END_DO; - switch (omp_st) - { - case ST_OMP_DISTRIBUTE: omp_end_st = ST_OMP_END_DISTRIBUTE; break; - case ST_OMP_DISTRIBUTE_PARALLEL_DO: - omp_end_st = ST_OMP_END_DISTRIBUTE_PARALLEL_DO; - break; - case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: - omp_end_st = ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD; - break; - case ST_OMP_DISTRIBUTE_SIMD: - omp_end_st = ST_OMP_END_DISTRIBUTE_SIMD; - break; - case ST_OMP_DO: omp_end_st = ST_OMP_END_DO; break; - case ST_OMP_DO_SIMD: omp_end_st = ST_OMP_END_DO_SIMD; break; - case ST_OMP_LOOP: omp_end_st = ST_OMP_END_LOOP; break; - case ST_OMP_PARALLEL_DO: omp_end_st = ST_OMP_END_PARALLEL_DO; break; - case ST_OMP_PARALLEL_DO_SIMD: - omp_end_st = ST_OMP_END_PARALLEL_DO_SIMD; - break; - case ST_OMP_PARALLEL_LOOP: - omp_end_st = ST_OMP_END_PARALLEL_LOOP; - break; - case ST_OMP_SIMD: omp_end_st = ST_OMP_END_SIMD; break; - case ST_OMP_TARGET_PARALLEL_DO: - omp_end_st = ST_OMP_END_TARGET_PARALLEL_DO; - break; - case ST_OMP_TARGET_PARALLEL_DO_SIMD: - omp_end_st = ST_OMP_END_TARGET_PARALLEL_DO_SIMD; - break; - case ST_OMP_TARGET_PARALLEL_LOOP: - omp_end_st = ST_OMP_END_TARGET_PARALLEL_LOOP; - break; - case ST_OMP_TARGET_SIMD: omp_end_st = ST_OMP_END_TARGET_SIMD; break; - case ST_OMP_TARGET_TEAMS_DISTRIBUTE: - omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE; - break; - case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: - omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO; - break; - case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: - omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD; - break; - case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: - omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD; - break; - case ST_OMP_TARGET_TEAMS_LOOP: - omp_end_st = ST_OMP_END_TARGET_TEAMS_LOOP; - break; - case ST_OMP_TASKLOOP: omp_end_st = ST_OMP_END_TASKLOOP; break; - case ST_OMP_TASKLOOP_SIMD: omp_end_st = ST_OMP_END_TASKLOOP_SIMD; break; - case ST_OMP_MASKED_TASKLOOP: omp_end_st = ST_OMP_END_MASKED_TASKLOOP; break; - case ST_OMP_MASKED_TASKLOOP_SIMD: - omp_end_st = ST_OMP_END_MASKED_TASKLOOP_SIMD; - break; - case ST_OMP_MASTER_TASKLOOP: omp_end_st = ST_OMP_END_MASTER_TASKLOOP; break; - case ST_OMP_MASTER_TASKLOOP_SIMD: - omp_end_st = ST_OMP_END_MASTER_TASKLOOP_SIMD; - break; - case ST_OMP_PARALLEL_MASKED_TASKLOOP: - omp_end_st = ST_OMP_END_PARALLEL_MASKED_TASKLOOP; - break; - case ST_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: - omp_end_st = ST_OMP_END_PARALLEL_MASKED_TASKLOOP_SIMD; - break; - case ST_OMP_PARALLEL_MASTER_TASKLOOP: - omp_end_st = ST_OMP_END_PARALLEL_MASTER_TASKLOOP; - break; - case ST_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: - omp_end_st = ST_OMP_END_PARALLEL_MASTER_TASKLOOP_SIMD; - break; - case ST_OMP_TEAMS_DISTRIBUTE: - omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE; - break; - case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: - omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO; - break; - case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: - omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD; - break; - case ST_OMP_TEAMS_DISTRIBUTE_SIMD: - omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE_SIMD; - break; - case ST_OMP_TEAMS_LOOP: - omp_end_st = ST_OMP_END_TEAMS_LOOP; - break; - default: gcc_unreachable (); - } + gfc_statement omp_end_st = gfc_omp_end_stmt (omp_st, true, false); + if (omp_st == ST_NONE) + gcc_unreachable (); + + /* If handling a metadirective variant, treat 'omp end metadirective' + as the expected end statement for the current construct. */ + if (st == ST_OMP_END_METADIRECTIVE + && gfc_state_stack->state == COMP_OMP_BEGIN_METADIRECTIVE) + st = omp_end_st; + if (st == omp_end_st) { if (new_st.op == EXEC_OMP_END_NOWAIT) @@ -5496,77 +5618,9 @@ parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only) np->op = cp->op; np->block = NULL; - switch (omp_st) - { - case ST_OMP_PARALLEL: - omp_end_st = ST_OMP_END_PARALLEL; - break; - case ST_OMP_PARALLEL_MASKED: - omp_end_st = ST_OMP_END_PARALLEL_MASKED; - break; - case ST_OMP_PARALLEL_MASTER: - omp_end_st = ST_OMP_END_PARALLEL_MASTER; - break; - case ST_OMP_PARALLEL_SECTIONS: - omp_end_st = ST_OMP_END_PARALLEL_SECTIONS; - break; - case ST_OMP_SCOPE: - omp_end_st = ST_OMP_END_SCOPE; - break; - case ST_OMP_SECTIONS: - omp_end_st = ST_OMP_END_SECTIONS; - break; - case ST_OMP_ORDERED: - omp_end_st = ST_OMP_END_ORDERED; - break; - case ST_OMP_CRITICAL: - omp_end_st = ST_OMP_END_CRITICAL; - break; - case ST_OMP_MASKED: - omp_end_st = ST_OMP_END_MASKED; - break; - case ST_OMP_MASTER: - omp_end_st = ST_OMP_END_MASTER; - break; - case ST_OMP_SINGLE: - omp_end_st = ST_OMP_END_SINGLE; - break; - case ST_OMP_TARGET: - omp_end_st = ST_OMP_END_TARGET; - break; - case ST_OMP_TARGET_DATA: - omp_end_st = ST_OMP_END_TARGET_DATA; - break; - case ST_OMP_TARGET_PARALLEL: - omp_end_st = ST_OMP_END_TARGET_PARALLEL; - break; - case ST_OMP_TARGET_TEAMS: - omp_end_st = ST_OMP_END_TARGET_TEAMS; - break; - case ST_OMP_TASK: - omp_end_st = ST_OMP_END_TASK; - break; - case ST_OMP_TASKGROUP: - omp_end_st = ST_OMP_END_TASKGROUP; - break; - case ST_OMP_TEAMS: - omp_end_st = ST_OMP_END_TEAMS; - break; - case ST_OMP_TEAMS_DISTRIBUTE: - omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE; - break; - case ST_OMP_DISTRIBUTE: - omp_end_st = ST_OMP_END_DISTRIBUTE; - break; - case ST_OMP_WORKSHARE: - omp_end_st = ST_OMP_END_WORKSHARE; - break; - case ST_OMP_PARALLEL_WORKSHARE: - omp_end_st = ST_OMP_END_PARALLEL_WORKSHARE; - break; - default: - gcc_unreachable (); - } + omp_end_st = gfc_omp_end_stmt (omp_st, false, true); + if (omp_st == ST_NONE) + gcc_unreachable (); bool block_construct = false; gfc_namespace *my_ns = NULL; @@ -5665,6 +5719,14 @@ parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only) } else st = parse_executable (st); + + /* If handling a metadirective variant, treat 'omp end metadirective' + as the expected end statement for the current construct. */ + if (st == ST_OMP_END_METADIRECTIVE + && gfc_state_stack->previous != NULL + && gfc_state_stack->previous->state == COMP_OMP_BEGIN_METADIRECTIVE) + st = omp_end_st; + if (st == ST_NONE) unexpected_eof (); else if (st == ST_OMP_SECTION @@ -5734,6 +5796,70 @@ parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only) return st; } +static gfc_statement +parse_omp_metadirective_body (gfc_statement omp_st) +{ + gfc_omp_metadirective_clause *clause = new_st.ext.omp_metadirective_clauses; + locus body_locus = gfc_current_locus; + + accept_statement (omp_st); + + gfc_statement next_st = ST_NONE; + + while (clause) + { + gfc_current_locus = body_locus; + gfc_state_data s; + bool workshare_p = clause->stmt == ST_OMP_WORKSHARE + || clause->stmt == ST_OMP_PARALLEL_WORKSHARE; + enum gfc_compile_state new_state = + (omp_st == ST_OMP_METADIRECTIVE) + ? COMP_OMP_METADIRECTIVE : COMP_OMP_BEGIN_METADIRECTIVE; + + new_st = *clause->code; + push_state (&s, new_state, NULL); + + gfc_statement st; + bool old_in_metadirective_body = gfc_in_metadirective_body; + gfc_in_metadirective_body = true; + + gfc_omp_region_count++; + switch (clause->stmt) + { + case_omp_structured_block: + st = parse_omp_structured_block (clause->stmt, workshare_p); + break; + case_omp_do: + st = parse_omp_do (clause->stmt); + /* TODO: Does st == ST_IMPLIED_ENDDO need special handling? */ + break; + default: + accept_statement (clause->stmt); + st = parse_executable (next_statement ()); + break; + } + + gfc_in_metadirective_body = old_in_metadirective_body; + + *clause->code = *gfc_state_stack->head; + pop_state (); + + gfc_commit_symbols (); + gfc_warning_check (); + if (clause->next) + gfc_clear_new_st (); + + /* Sanity-check that each clause finishes parsing at the same place. */ + if (next_st == ST_NONE) + next_st = st; + else + gcc_assert (st == next_st); + + clause = clause->next; + } + + return next_st; +} /* Accept a series of executable statements. We return the first statement that doesn't fit to the caller. Any block statements are @@ -5744,12 +5870,19 @@ static gfc_statement parse_executable (gfc_statement st) { int close_flag; + bool one_stmt_p = false; if (st == ST_NONE) st = next_statement (); for (;;) { + /* Only parse one statement for the form of metadirective without + an explicit begin..end. */ + if (gfc_state_stack->state == COMP_OMP_METADIRECTIVE && one_stmt_p) + return st; + one_stmt_p = true; + close_flag = check_do_closure (); if (close_flag) switch (st) @@ -5854,67 +5987,13 @@ parse_executable (gfc_statement st) parse_oacc_structured_block (st); break; - case ST_OMP_PARALLEL: - case ST_OMP_PARALLEL_MASKED: - case ST_OMP_PARALLEL_MASTER: - case ST_OMP_PARALLEL_SECTIONS: - case ST_OMP_ORDERED: - case ST_OMP_CRITICAL: - case ST_OMP_MASKED: - case ST_OMP_MASTER: - case ST_OMP_SCOPE: - case ST_OMP_SECTIONS: - case ST_OMP_SINGLE: - case ST_OMP_TARGET: - case ST_OMP_TARGET_DATA: - case ST_OMP_TARGET_PARALLEL: - case ST_OMP_TARGET_TEAMS: - case ST_OMP_TEAMS: - case ST_OMP_TASK: - case ST_OMP_TASKGROUP: - st = parse_omp_structured_block (st, false); - continue; - - case ST_OMP_WORKSHARE: - case ST_OMP_PARALLEL_WORKSHARE: - st = parse_omp_structured_block (st, true); + case_omp_structured_block: + st = parse_omp_structured_block (st, + st == ST_OMP_WORKSHARE + || st == ST_OMP_PARALLEL_WORKSHARE); continue; - case ST_OMP_DISTRIBUTE: - case ST_OMP_DISTRIBUTE_PARALLEL_DO: - case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: - case ST_OMP_DISTRIBUTE_SIMD: - case ST_OMP_DO: - case ST_OMP_DO_SIMD: - case ST_OMP_LOOP: - case ST_OMP_PARALLEL_DO: - case ST_OMP_PARALLEL_DO_SIMD: - case ST_OMP_PARALLEL_LOOP: - case ST_OMP_PARALLEL_MASKED_TASKLOOP: - case ST_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: - case ST_OMP_PARALLEL_MASTER_TASKLOOP: - case ST_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: - case ST_OMP_MASKED_TASKLOOP: - case ST_OMP_MASKED_TASKLOOP_SIMD: - case ST_OMP_MASTER_TASKLOOP: - case ST_OMP_MASTER_TASKLOOP_SIMD: - case ST_OMP_SIMD: - case ST_OMP_TARGET_PARALLEL_DO: - case ST_OMP_TARGET_PARALLEL_DO_SIMD: - case ST_OMP_TARGET_PARALLEL_LOOP: - case ST_OMP_TARGET_SIMD: - case ST_OMP_TARGET_TEAMS_DISTRIBUTE: - case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: - case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: - case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: - case ST_OMP_TARGET_TEAMS_LOOP: - case ST_OMP_TASKLOOP: - case ST_OMP_TASKLOOP_SIMD: - case ST_OMP_TEAMS_DISTRIBUTE: - case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: - case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: - case ST_OMP_TEAMS_DISTRIBUTE_SIMD: - case ST_OMP_TEAMS_LOOP: + case_omp_do: st = parse_omp_do (st); if (st == ST_IMPLIED_ENDDO) return st; @@ -5928,6 +6007,19 @@ parse_executable (gfc_statement st) st = parse_omp_oacc_atomic (true); continue; + case ST_OMP_METADIRECTIVE: + case ST_OMP_BEGIN_METADIRECTIVE: + st = parse_omp_metadirective_body (st); + continue; + + case ST_OMP_END_METADIRECTIVE: + if (gfc_state_stack->state == COMP_OMP_BEGIN_METADIRECTIVE) + { + st = next_statement (); + return st; + } + /* FALLTHRU */ + default: return st; } @@ -6700,6 +6792,10 @@ gfc_parse_file (void) gfc_statement_label = NULL; + gfc_omp_region_count = 0; + gfc_in_metadirective_body = false; + gfc_matching_omp_context_selector = false; + if (setjmp (eof_buf)) return false; /* Come here on unexpected EOF */ diff --git a/gcc/fortran/parse.h b/gcc/fortran/parse.h index 66b275de89b..43bdd91aa14 100644 --- a/gcc/fortran/parse.h +++ b/gcc/fortran/parse.h @@ -31,7 +31,8 @@ enum gfc_compile_state COMP_STRUCTURE, COMP_UNION, COMP_MAP, COMP_DO, COMP_SELECT, COMP_FORALL, COMP_WHERE, COMP_CONTAINS, COMP_ENUM, COMP_SELECT_TYPE, COMP_SELECT_RANK, COMP_OMP_STRUCTURED_BLOCK, COMP_CRITICAL, - COMP_DO_CONCURRENT, COMP_OMP_STRICTLY_STRUCTURED_BLOCK + COMP_DO_CONCURRENT, COMP_OMP_STRICTLY_STRUCTURED_BLOCK, + COMP_OMP_METADIRECTIVE, COMP_OMP_BEGIN_METADIRECTIVE }; /* Stack element for the current compilation state. These structures @@ -67,10 +68,15 @@ int gfc_check_do_variable (gfc_symtree *); bool gfc_find_state (gfc_compile_state); gfc_state_data *gfc_enclosing_unit (gfc_compile_state *); const char *gfc_ascii_statement (gfc_statement); +gfc_statement gfc_omp_end_stmt (gfc_statement, bool = true, bool = true); match gfc_match_enum (void); match gfc_match_enumerator_def (void); void gfc_free_enum_history (void); extern bool gfc_matching_function; +extern bool gfc_matching_omp_context_selector; +extern bool gfc_in_metadirective_body; +extern int gfc_omp_region_count; + match gfc_match_prefix (gfc_typespec *); bool is_oacc (gfc_state_data *); #endif /* GFC_PARSE_H */ diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 0ed31970f8b..1a07aef6771 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -11834,6 +11834,17 @@ gfc_resolve_code (gfc_code *code, gfc_namespace *ns) gfc_resolve_forall (code, ns, forall_save); forall_flag = 2; } + else if (code->op == EXEC_OMP_METADIRECTIVE) + { + gfc_omp_metadirective_clause *clause + = code->ext.omp_metadirective_clauses; + + while (clause) + { + gfc_resolve_code (clause->code, ns); + clause = clause->next; + } + } else if (code->block) { omp_workshare_save = -1; @@ -12322,6 +12333,7 @@ start: case EXEC_OMP_MASKED: case EXEC_OMP_MASKED_TASKLOOP: case EXEC_OMP_MASKED_TASKLOOP_SIMD: + case EXEC_OMP_METADIRECTIVE: case EXEC_OMP_ORDERED: case EXEC_OMP_SCAN: case EXEC_OMP_SCOPE: diff --git a/gcc/fortran/st.c b/gcc/fortran/st.c index 6bf730c9062..b15a0885e2e 100644 --- a/gcc/fortran/st.c +++ b/gcc/fortran/st.c @@ -296,6 +296,10 @@ gfc_free_statement (gfc_code *p) case EXEC_OMP_TASKYIELD: break; + case EXEC_OMP_METADIRECTIVE: + gfc_free_omp_metadirective_clauses (p->ext.omp_metadirective_clauses); + break; + default: gfc_internal_error ("gfc_free_statement(): Bad statement"); } diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index ebd99846610..8a56ee31b33 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -2624,10 +2624,13 @@ free_components (gfc_component *p) static int compare_st_labels (void *a1, void *b1) { - int a = ((gfc_st_label *) a1)->value; - int b = ((gfc_st_label *) b1)->value; + gfc_st_label *a = (gfc_st_label *) a1; + gfc_st_label *b = (gfc_st_label *) b1; - return (b - a); + int a_value = a->value + 10000 * a->omp_region; + int b_value = b->value + 10000 * b->omp_region; + + return (b_value - a_value); } @@ -2677,6 +2680,7 @@ gfc_get_st_label (int labelno) { gfc_st_label *lp; gfc_namespace *ns; + int omp_region = gfc_in_metadirective_body ? gfc_omp_region_count : 0; if (gfc_current_state () == COMP_DERIVED) ns = gfc_current_block ()->f2k_derived; @@ -2693,10 +2697,13 @@ gfc_get_st_label (int labelno) lp = ns->st_labels; while (lp) { - if (lp->value == labelno) + int a = lp->value + 10000 * lp->omp_region; + int b = labelno + 10000 * omp_region; + + if (a == b) return lp; - if (lp->value < labelno) + if (a < b) lp = lp->left; else lp = lp->right; @@ -2708,6 +2715,7 @@ gfc_get_st_label (int labelno) lp->defined = ST_LABEL_UNKNOWN; lp->referenced = ST_LABEL_UNKNOWN; lp->ns = ns; + lp->omp_region = omp_region; gfc_insert_bbt (&ns->st_labels, lp, compare_st_labels); diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index cb7f684d52c..69ea7f02871 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -326,7 +326,10 @@ gfc_get_label_decl (gfc_st_label * lp) gcc_assert (lp != NULL && lp->value <= MAX_LABEL_VALUE); /* Build a mangled name for the label. */ - sprintf (label_name, "__label_%.6d", lp->value); + if (lp->omp_region) + sprintf (label_name, "__label_%d_%.6d", lp->omp_region, lp->value); + else + sprintf (label_name, "__label_%.6d", lp->value); /* Build the LABEL_DECL node. */ label_decl = gfc_build_label_decl (get_identifier (label_name)); diff --git a/gcc/fortran/trans-openmp.c b/gcc/fortran/trans-openmp.c index d8229a5ac30..3be453a513a 100644 --- a/gcc/fortran/trans-openmp.c +++ b/gcc/fortran/trans-openmp.c @@ -7207,6 +7207,8 @@ gfc_trans_omp_directive (gfc_code *code) case EXEC_OMP_MASTER_TASKLOOP: case EXEC_OMP_MASTER_TASKLOOP_SIMD: return gfc_trans_omp_master_masked_taskloop (code, code->op); + case EXEC_OMP_METADIRECTIVE: + return gfc_trans_omp_metadirective (code); case EXEC_OMP_ORDERED: return gfc_trans_omp_ordered (code); case EXEC_OMP_PARALLEL: @@ -7298,6 +7300,87 @@ gfc_trans_omp_declare_simd (gfc_namespace *ns) } } +static tree +gfc_trans_omp_set_selector (gfc_omp_set_selector *gfc_selectors, locus where) +{ + tree set_selectors = NULL_TREE; + gfc_omp_set_selector *oss; + + for (oss = gfc_selectors; oss; oss = oss->next) + { + tree selectors = NULL_TREE; + gfc_omp_selector *os; + for (os = oss->trait_selectors; os; os = os->next) + { + tree properties = NULL_TREE; + gfc_omp_trait_property *otp; + + for (otp = os->properties; otp; otp = otp->next) + { + switch (otp->property_kind) + { + case CTX_PROPERTY_USER: + case CTX_PROPERTY_EXPR: + { + gfc_se se; + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, otp->expr); + properties = tree_cons (NULL_TREE, se.expr, + properties); + } + break; + case CTX_PROPERTY_ID: + properties = tree_cons (get_identifier (otp->name), + NULL_TREE, properties); + break; + case CTX_PROPERTY_NAME_LIST: + { + tree prop = NULL_TREE, value = NULL_TREE; + if (otp->is_name) + prop = get_identifier (otp->name); + else + { + value = gfc_conv_constant_to_tree (otp->expr); + + /* The string length is expected to include the null + terminator in context selectors. This is safe as + build_string always null-terminates strings. */ + ++TREE_STRING_LENGTH (value); + } + + properties = tree_cons (prop, value, properties); + } + break; + case CTX_PROPERTY_SIMD: + properties = gfc_trans_omp_clauses (NULL, otp->clauses, + where, true); + break; + default: + gcc_unreachable (); + } + } + + if (os->score) + { + gfc_se se; + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, os->score); + properties = tree_cons (get_identifier (" score"), + se.expr, properties); + } + + selectors = tree_cons (get_identifier (os->trait_selector_name), + properties, selectors); + } + + set_selectors + = tree_cons (get_identifier (oss->trait_set_selector_name), + selectors, set_selectors); + } + + return set_selectors; +} + void gfc_trans_omp_declare_variant (gfc_namespace *ns) { @@ -7373,73 +7456,8 @@ gfc_trans_omp_declare_variant (gfc_namespace *ns) && strcmp (odv->base_proc_symtree->name, ns->proc_name->name))) continue; - tree set_selectors = NULL_TREE; - gfc_omp_set_selector *oss; - - for (oss = odv->set_selectors; oss; oss = oss->next) - { - tree selectors = NULL_TREE; - gfc_omp_selector *os; - for (os = oss->trait_selectors; os; os = os->next) - { - tree properties = NULL_TREE; - gfc_omp_trait_property *otp; - - for (otp = os->properties; otp; otp = otp->next) - { - switch (otp->property_kind) - { - case CTX_PROPERTY_USER: - case CTX_PROPERTY_EXPR: - { - gfc_se se; - gfc_init_se (&se, NULL); - gfc_conv_expr (&se, otp->expr); - properties = tree_cons (NULL_TREE, se.expr, - properties); - } - break; - case CTX_PROPERTY_ID: - properties = tree_cons (get_identifier (otp->name), - NULL_TREE, properties); - break; - case CTX_PROPERTY_NAME_LIST: - { - tree prop = NULL_TREE, value = NULL_TREE; - if (otp->is_name) - prop = get_identifier (otp->name); - else - value = gfc_conv_constant_to_tree (otp->expr); - - properties = tree_cons (prop, value, properties); - } - break; - case CTX_PROPERTY_SIMD: - properties = gfc_trans_omp_clauses (NULL, otp->clauses, - odv->where, true); - break; - default: - gcc_unreachable (); - } - } - - if (os->score) - { - gfc_se se; - gfc_init_se (&se, NULL); - gfc_conv_expr (&se, os->score); - properties = tree_cons (get_identifier (" score"), - se.expr, properties); - } - - selectors = tree_cons (get_identifier (os->trait_selector_name), - properties, selectors); - } - - set_selectors - = tree_cons (get_identifier (oss->trait_set_selector_name), - selectors, set_selectors); - } + tree set_selectors = gfc_trans_omp_set_selector (odv->set_selectors, + odv->where); const char *variant_proc_name = odv->variant_proc_symtree->name; gfc_symbol *variant_proc_sym = odv->variant_proc_symtree->n.sym; @@ -7501,3 +7519,41 @@ gfc_trans_omp_declare_variant (gfc_namespace *ns) } } } + +tree +gfc_trans_omp_metadirective (gfc_code *code) +{ + gfc_omp_metadirective_clause *clause = code->ext.omp_metadirective_clauses; + + tree metadirective_tree = make_node (OMP_METADIRECTIVE); + SET_EXPR_LOCATION (metadirective_tree, gfc_get_location (&code->loc)); + TREE_TYPE (metadirective_tree) = void_type_node; + OMP_METADIRECTIVE_CLAUSES (metadirective_tree) = NULL_TREE; + + tree tree_body = NULL_TREE; + + while (clause) + { + tree selectors = gfc_trans_omp_set_selector (clause->selectors, + clause->where); + gfc_code *next_code = clause->code->next; + if (next_code && tree_body == NULL_TREE) + tree_body = gfc_trans_code (next_code); + + if (next_code) + clause->code->next = NULL; + tree directive = gfc_trans_code (clause->code); + if (next_code) + clause->code->next = next_code; + + tree body = next_code ? tree_body : NULL_TREE; + tree variant = build_tree_list (selectors, build_tree_list (directive, body)); + OMP_METADIRECTIVE_CLAUSES (metadirective_tree) + = chainon (OMP_METADIRECTIVE_CLAUSES (metadirective_tree), variant); + clause = clause->next; + } + + /* TODO: Resolve the metadirective here if possible. */ + + return metadirective_tree; +} diff --git a/gcc/fortran/trans-stmt.h b/gcc/fortran/trans-stmt.h index e824caf4d08..08355e582c8 100644 --- a/gcc/fortran/trans-stmt.h +++ b/gcc/fortran/trans-stmt.h @@ -71,6 +71,7 @@ tree gfc_trans_deallocate (gfc_code *); tree gfc_trans_omp_directive (gfc_code *); void gfc_trans_omp_declare_simd (gfc_namespace *); void gfc_trans_omp_declare_variant (gfc_namespace *); +tree gfc_trans_omp_metadirective (gfc_code *code); tree gfc_trans_oacc_directive (gfc_code *); tree gfc_trans_oacc_declare (gfc_namespace *); diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c index a377d0eeb24..007ee65a169 100644 --- a/gcc/fortran/trans.c +++ b/gcc/fortran/trans.c @@ -2161,6 +2161,7 @@ trans_code (gfc_code * code, tree cond) case EXEC_OMP_MASTER: case EXEC_OMP_MASTER_TASKLOOP: case EXEC_OMP_MASTER_TASKLOOP_SIMD: + case EXEC_OMP_METADIRECTIVE: case EXEC_OMP_ORDERED: case EXEC_OMP_PARALLEL: case EXEC_OMP_PARALLEL_DO: diff --git a/gcc/omp-general.c b/gcc/omp-general.c index 6340d1600a6..5a8a34573c8 100644 --- a/gcc/omp-general.c +++ b/gcc/omp-general.c @@ -1198,7 +1198,7 @@ omp_check_context_selector (location_t loc, tree ctx) const char *str = TREE_STRING_POINTER (TREE_VALUE (t2)); if (!strcmp (str, props[i].props[j]) && ((size_t) TREE_STRING_LENGTH (TREE_VALUE (t2)) - == strlen (str) + (lang_GNU_Fortran () ? 0 : 1))) + == strlen (str) + 1)) break; } else if (!strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t2)), @@ -1247,8 +1247,7 @@ omp_context_name_list_prop (tree prop) else { const char *ret = TREE_STRING_POINTER (TREE_VALUE (prop)); - if ((size_t) TREE_STRING_LENGTH (TREE_VALUE (prop)) - == strlen (ret) + (lang_GNU_Fortran () ? 0 : 1)) + if ((size_t) TREE_STRING_LENGTH (TREE_VALUE (prop)) == strlen (ret) + 1) return ret; return NULL; } From patchwork Fri Dec 10 17:40:36 2021 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Kwok Cheung Yeung X-Patchwork-Id: 48799 Return-Path: X-Original-To: patchwork@sourceware.org Delivered-To: patchwork@sourceware.org Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 217D03857C7A for ; Fri, 10 Dec 2021 17:41:35 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from esa3.mentor.iphmx.com (esa3.mentor.iphmx.com [68.232.137.180]) by sourceware.org (Postfix) with ESMTPS id 7A04C3857C4C for ; Fri, 10 Dec 2021 17:41:08 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.1 sourceware.org 7A04C3857C4C Authentication-Results: sourceware.org; dmarc=none (p=none dis=none) header.from=codesourcery.com Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=mentor.com IronPort-SDR: OkB1Fr5h6ORB/P1Su+w/3vVXuLIbiVzYYupZ4PSSSKS2sZaEieHqGmps2PVeu81BhGm7tvGeya M5k32YNkIq048JYMpraD6EULHA7/52LQGfaZiGWfxolCP5Vq76o1UBpnTGq9IgIGPE3Ic24MMJ iYBVDeWkkJicJutSGoOZDAD6QjI095fd05vxX7/4tfRrc4siYbPerOGrUIUE3b+RC5B1y2GT5n aUnCxzmgMXhpwLWMx9rruFY8Aqc0Y7ReitHur4mSzqH4cRsoXKz+Wg5duTQXa4XF/YwcGMixci bpjvge3YTkMxXnieBXiql4Y9 X-IronPort-AV: E=Sophos;i="5.88,196,1635235200"; d="scan'208,223";a="69403716" Received: from orw-gwy-02-in.mentorg.com ([192.94.38.167]) by esa3.mentor.iphmx.com with ESMTP; 10 Dec 2021 09:41:07 -0800 IronPort-SDR: LkxSkm1dyvwr9idECvBhWfgypiMtxNhrOq3b4lRfZul7dYbVajthmUsjaCQ5L45DqDwDUZQLMT SdcrdOdW5CddwRH5u7EitNDGPAsk6EjPf8g8ZW1uFNk9GGOb0UYVx/zHzQltKJ6WbG9rwSNJf7 d1TN1ywvxMLucWvv8xNEl4k3f03YQHvh23aPdiR3akBf8hgSopFqNZP6f/qjRtUfOEiL48NKkH ytyWCTeGTU6faq9NWwWZw8C3w0OcvrZM2y4fVZemHKZqdRDA4RqvjhC3kBKjlOeLnQfWmwF3Ww NjI= Message-ID: Date: Fri, 10 Dec 2021 17:40:36 +0000 MIME-Version: 1.0 User-Agent: Mozilla/5.0 (Windows NT 10.0; Win64; x64; rv:91.0) Gecko/20100101 Thunderbird/91.4.0 To: gcc-patches , Jakub Jelinek References: Subject: [PATCH 7/7] openmp: Add testcases for metadirectives From: Kwok Cheung Yeung In-Reply-To: X-Originating-IP: [137.202.0.90] X-ClientProxiedBy: SVR-IES-MBX-04.mgc.mentorg.com (139.181.222.4) To SVR-IES-MBX-04.mgc.mentorg.com (139.181.222.4) X-Spam-Status: No, score=-12.0 required=5.0 tests=BAYES_00, GIT_PATCH_0, HEADER_FROM_DIFFERENT_DOMAINS, KAM_DMARC_STATUS, SPF_HELO_PASS, SPF_PASS, TXREP autolearn=ham autolearn_force=no version=3.4.4 X-Spam-Checker-Version: SpamAssassin 3.4.4 (2020-01-24) on server2.sourceware.org X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: gcc-patches-bounces+patchwork=sourceware.org@gcc.gnu.org Sender: "Gcc-patches" This adds testcases for metadirectives. Kwok From d3f80b603298fb2f3501a28b888acfdbc02a64e7 Mon Sep 17 00:00:00 2001 From: Kwok Cheung Yeung Date: Tue, 7 Dec 2021 11:25:33 +0000 Subject: [PATCH 7/7] openmp: Add testcases for metadirectives 2021-12-10 Kwok Cheung Yeung gcc/testsuite/ * c-c++-common/gomp/metadirective-1.c: New. * c-c++-common/gomp/metadirective-2.c: New. * c-c++-common/gomp/metadirective-3.c: New. * c-c++-common/gomp/metadirective-4.c: New. * c-c++-common/gomp/metadirective-5.c: New. * c-c++-common/gomp/metadirective-6.c: New. * gcc.dg/gomp/metadirective-1.c: New. * gfortran.dg/gomp/metadirective-1.f90: New. * gfortran.dg/gomp/metadirective-2.f90: New. * gfortran.dg/gomp/metadirective-3.f90: New. * gfortran.dg/gomp/metadirective-4.f90: New. * gfortran.dg/gomp/metadirective-5.f90: New. * gfortran.dg/gomp/metadirective-6.f90: New. libgomp/ * testsuite/libgomp.c-c++-common/metadirective-1.c: New. * testsuite/libgomp.c-c++-common/metadirective-2.c: New. * testsuite/libgomp.c-c++-common/metadirective-3.c: New. * testsuite/libgomp.c-c++-common/metadirective-4.c: New. * testsuite/libgomp.fortran/metadirective-1.f90: New. * testsuite/libgomp.fortran/metadirective-2.f90: New. * testsuite/libgomp.fortran/metadirective-3.f90: New. * testsuite/libgomp.fortran/metadirective-4.f90: New. --- .../c-c++-common/gomp/metadirective-1.c | 29 ++++++++ .../c-c++-common/gomp/metadirective-2.c | 74 +++++++++++++++++++ .../c-c++-common/gomp/metadirective-3.c | 31 ++++++++ .../c-c++-common/gomp/metadirective-4.c | 40 ++++++++++ .../c-c++-common/gomp/metadirective-5.c | 24 ++++++ .../c-c++-common/gomp/metadirective-6.c | 31 ++++++++ gcc/testsuite/gcc.dg/gomp/metadirective-1.c | 15 ++++ .../gfortran.dg/gomp/metadirective-1.f90 | 41 ++++++++++ .../gfortran.dg/gomp/metadirective-2.f90 | 59 +++++++++++++++ .../gfortran.dg/gomp/metadirective-3.f90 | 34 +++++++++ .../gfortran.dg/gomp/metadirective-4.f90 | 39 ++++++++++ .../gfortran.dg/gomp/metadirective-5.f90 | 30 ++++++++ .../gfortran.dg/gomp/metadirective-6.f90 | 31 ++++++++ .../libgomp.c-c++-common/metadirective-1.c | 35 +++++++++ .../libgomp.c-c++-common/metadirective-2.c | 41 ++++++++++ .../libgomp.c-c++-common/metadirective-3.c | 34 +++++++++ .../libgomp.c-c++-common/metadirective-4.c | 52 +++++++++++++ .../libgomp.fortran/metadirective-1.f90 | 33 +++++++++ .../libgomp.fortran/metadirective-2.f90 | 40 ++++++++++ .../libgomp.fortran/metadirective-3.f90 | 29 ++++++++ .../libgomp.fortran/metadirective-4.f90 | 46 ++++++++++++ 21 files changed, 788 insertions(+) create mode 100644 gcc/testsuite/c-c++-common/gomp/metadirective-1.c create mode 100644 gcc/testsuite/c-c++-common/gomp/metadirective-2.c create mode 100644 gcc/testsuite/c-c++-common/gomp/metadirective-3.c create mode 100644 gcc/testsuite/c-c++-common/gomp/metadirective-4.c create mode 100644 gcc/testsuite/c-c++-common/gomp/metadirective-5.c create mode 100644 gcc/testsuite/c-c++-common/gomp/metadirective-6.c create mode 100644 gcc/testsuite/gcc.dg/gomp/metadirective-1.c create mode 100644 gcc/testsuite/gfortran.dg/gomp/metadirective-1.f90 create mode 100644 gcc/testsuite/gfortran.dg/gomp/metadirective-2.f90 create mode 100644 gcc/testsuite/gfortran.dg/gomp/metadirective-3.f90 create mode 100644 gcc/testsuite/gfortran.dg/gomp/metadirective-4.f90 create mode 100644 gcc/testsuite/gfortran.dg/gomp/metadirective-5.f90 create mode 100644 gcc/testsuite/gfortran.dg/gomp/metadirective-6.f90 create mode 100644 libgomp/testsuite/libgomp.c-c++-common/metadirective-1.c create mode 100644 libgomp/testsuite/libgomp.c-c++-common/metadirective-2.c create mode 100644 libgomp/testsuite/libgomp.c-c++-common/metadirective-3.c create mode 100644 libgomp/testsuite/libgomp.c-c++-common/metadirective-4.c create mode 100644 libgomp/testsuite/libgomp.fortran/metadirective-1.f90 create mode 100644 libgomp/testsuite/libgomp.fortran/metadirective-2.f90 create mode 100644 libgomp/testsuite/libgomp.fortran/metadirective-3.f90 create mode 100644 libgomp/testsuite/libgomp.fortran/metadirective-4.f90 diff --git a/gcc/testsuite/c-c++-common/gomp/metadirective-1.c b/gcc/testsuite/c-c++-common/gomp/metadirective-1.c new file mode 100644 index 00000000000..72cf0abbbd7 --- /dev/null +++ b/gcc/testsuite/c-c++-common/gomp/metadirective-1.c @@ -0,0 +1,29 @@ +/* { dg-do compile } */ + +#define N 100 + +void f (int a[], int b[], int c[]) +{ + #pragma omp metadirective \ + default (teams loop) \ + default (parallel loop) /* { dg-error "there can only be one default clause in a metadirective before '\\(' token" } */ + for (i = 0; i < N; i++) c[i] = a[i] * b[i]; + + #pragma omp metadirective \ + default (bad_directive) /* { dg-error "unknown directive name before '\\)' token" } */ + for (i = 0; i < N; i++) c[i] = a[i] * b[i]; + + #pragma omp metadirective \ + default (teams loop) \ + where (device={arch("nvptx")}: parallel loop) /* { dg-error "expected 'when' or 'default' before '\\(' token" } */ + for (i = 0; i < N; i++) c[i] = a[i] * b[i]; + + #pragma omp metadirective \ + default (teams loop) \ + when (device={arch("nvptx")} parallel loop) /* { dg-error "expected colon before 'parallel'" } */ + for (i = 0; i < N; i++) c[i] = a[i] * b[i]; + + #pragma omp metadirective \ + default (metadirective default (flush)) /* { dg-error "metadirectives cannot be used as directive variants before 'default'" } */ + for (i = 0; i < N; i++) c[i] = a[i] * b[i]; +} diff --git a/gcc/testsuite/c-c++-common/gomp/metadirective-2.c b/gcc/testsuite/c-c++-common/gomp/metadirective-2.c new file mode 100644 index 00000000000..ea6904c9c12 --- /dev/null +++ b/gcc/testsuite/c-c++-common/gomp/metadirective-2.c @@ -0,0 +1,74 @@ +/* { dg-do compile } */ + +#define N 100 + +int main (void) +{ + int x = 0; + int y = 0; + + /* Test implicit default (nothing). */ + #pragma omp metadirective \ + when (device={arch("nvptx")}: barrier) + x = 1; + + /* Test with multiple standalone directives. */ + #pragma omp metadirective \ + when (device={arch("nvptx")}: barrier) \ + default (flush) + x = 1; + + /* Test combining a standalone directive with one that takes a statement + body. */ + #pragma omp metadirective \ + when (device={arch("nvptx")}: parallel) \ + default (barrier) + x = 1; + + /* Test combining a standalone directive with one that takes a for loop. */ + #pragma omp metadirective \ + when (device={arch("nvptx")}: parallel for) \ + default (barrier) + for (int i = 0; i < N; i++) + x += i; + + /* Test combining a directive that takes a for loop with one that takes + a regular statement body. */ + #pragma omp metadirective \ + when (device={arch("nvptx")}: parallel for) \ + default (parallel) + for (int i = 0; i < N; i++) + x += i; + + /* Test labels inside statement body. */ + #pragma omp metadirective \ + when (device={arch("nvptx")}: teams num_teams(512)) \ + when (device={arch("gcn")}: teams num_teams(256)) \ + default (teams num_teams(4)) + { + if (x) + goto l1; + else + goto l2; + l1: ; + l2: ; + } + + /* Test local labels inside statement body. */ + #pragma omp metadirective \ + when (device={arch("nvptx")}: teams num_teams(512)) \ + when (device={arch("gcn")}: teams num_teams(256)) \ + default (teams num_teams(4)) + { + //__label__ l1, l2; + + if (x) + goto l1; + else + goto l2; + l1: ; + l2: ; + } + + return 0; +} diff --git a/gcc/testsuite/c-c++-common/gomp/metadirective-3.c b/gcc/testsuite/c-c++-common/gomp/metadirective-3.c new file mode 100644 index 00000000000..80c93b1521d --- /dev/null +++ b/gcc/testsuite/c-c++-common/gomp/metadirective-3.c @@ -0,0 +1,31 @@ +/* { dg-do compile } */ +/* { dg-additional-options "-fdump-tree-original" } */ +/* { dg-additional-options "-fdump-tree-gimple" } */ +/* { dg-additional-options "-fdump-tree-optimized" } */ + +#define N 100 + +void f (int x[], int y[], int z[]) +{ + int i; + + #pragma omp target map(to: x, y) map(from: z) + #pragma omp metadirective \ + when (device={arch("nvptx")}: teams loop) \ + default (parallel loop) + for (i = 0; i < N; i++) + z[i] = x[i] * y[i]; +} + +/* The metadirective should be resolved after Gimplification. */ + +/* { dg-final { scan-tree-dump-times "#pragma omp metadirective" 1 "original" } } */ +/* { dg-final { scan-tree-dump-times "when \\(device arch .nvptx.\\):" 1 "original" } } */ +/* { dg-final { scan-tree-dump-times "#pragma omp teams" 1 "original" } } */ +/* { dg-final { scan-tree-dump-times "default:" 1 "original" } } */ +/* { dg-final { scan-tree-dump-times "#pragma omp parallel" 1 "original" } } */ +/* { dg-final { scan-tree-dump-times "#pragma omp loop" 2 "original" } } */ + +/* { dg-final { scan-tree-dump-times "#pragma omp metadirective" 1 "gimple" } } */ + +/* { dg-final { scan-tree-dump-not "#pragma omp metadirective" "optimized" } } */ diff --git a/gcc/testsuite/c-c++-common/gomp/metadirective-4.c b/gcc/testsuite/c-c++-common/gomp/metadirective-4.c new file mode 100644 index 00000000000..c4b109295db --- /dev/null +++ b/gcc/testsuite/c-c++-common/gomp/metadirective-4.c @@ -0,0 +1,40 @@ +/* { dg-do compile } */ +/* { dg-additional-options "-fdump-tree-original" } */ +/* { dg-additional-options "-fdump-tree-gimple" } */ + +#define N 100 + +#pragma omp declare target +void f(double a[], double x) { + int i; + + #pragma omp metadirective \ + when (construct={target}: distribute parallel for) \ + default (parallel for simd) + for (i = 0; i < N; i++) + a[i] = x * i; +} +#pragma omp end declare target + + int main() +{ + double a[N]; + + #pragma omp target teams map(from: a[0:N]) + f (a, 3.14159); + + /* TODO: This does not execute a version of f with the default clause + active as might be expected. */ + f (a, 2.71828); + + return 0; + } + + /* The metadirective should be resolved during Gimplification. */ + +/* { dg-final { scan-tree-dump-times "#pragma omp metadirective" 1 "original" } } */ +/* { dg-final { scan-tree-dump-times "when \\(construct target.*\\):" 1 "original" } } */ +/* { dg-final { scan-tree-dump-times "default:" 1 "original" } } */ +/* { dg-final { scan-tree-dump-times "#pragma omp parallel" 2 "original" } } */ + +/* { dg-final { scan-tree-dump-not "#pragma omp metadirective" "gimple" } } */ diff --git a/gcc/testsuite/c-c++-common/gomp/metadirective-5.c b/gcc/testsuite/c-c++-common/gomp/metadirective-5.c new file mode 100644 index 00000000000..4a9f1aa85a6 --- /dev/null +++ b/gcc/testsuite/c-c++-common/gomp/metadirective-5.c @@ -0,0 +1,24 @@ +/* { dg-do compile } */ +/* { dg-additional-options "-fdump-tree-original" } */ + +#define N 100 + +void f (int a[], int flag) +{ + int i; + #pragma omp metadirective \ + when (user={condition(flag)}: \ + target teams distribute parallel for map(from: a[0:N])) \ + default (parallel for) + for (i = 0; i < N; i++) + a[i] = i; +} + +/* The metadirective should be resolved at parse time. */ + +/* { dg-final { scan-tree-dump-not "#pragma omp metadirective" "original" } } */ +/* { dg-final { scan-tree-dump-times "#pragma omp target" 1 "original" } } */ +/* { dg-final { scan-tree-dump-times "#pragma omp teams" 1 "original" } } */ +/* { dg-final { scan-tree-dump-times "#pragma omp distribute" 1 "original" } } */ +/* { dg-final { scan-tree-dump-times "#pragma omp parallel" 2 "original" } } */ +/* { dg-final { scan-tree-dump-times "#pragma omp for" 2 "original" } } */ diff --git a/gcc/testsuite/c-c++-common/gomp/metadirective-6.c b/gcc/testsuite/c-c++-common/gomp/metadirective-6.c new file mode 100644 index 00000000000..c77c0065e17 --- /dev/null +++ b/gcc/testsuite/c-c++-common/gomp/metadirective-6.c @@ -0,0 +1,31 @@ +/* { dg-do compile } */ +/* { dg-additional-options "-fdump-tree-original" } */ +/* { dg-additional-options "-fdump-tree-gimple" } */ + +#define N 100 + +void bar (int a[], int run_parallel, int run_guided) +{ + #pragma omp metadirective \ + when (user={condition(run_parallel)}: parallel) + { + int i; + #pragma omp metadirective \ + when (construct={parallel}, user={condition(run_guided)}: \ + for schedule(guided)) \ + when (construct={parallel}: for schedule(static)) + for (i = 0; i < N; i++) + a[i] = i; + } + } + +/* The outer metadirective should be resolved at parse time. */ +/* The inner metadirective should be resolved during Gimplificiation. */ + +/* { dg-final { scan-tree-dump-times "#pragma omp metadirective" 2 "original" } } */ +/* { dg-final { scan-tree-dump-times "#pragma omp parallel" 1 "original" } } */ +/* { dg-final { scan-tree-dump-times "#pragma omp for" 4 "original" } } */ +/* { dg-final { scan-tree-dump-times "when \\(construct parallel" 4 "original" } } */ +/* { dg-final { scan-tree-dump-times "default:" 2 "original" } } */ + +/* { dg-final { scan-tree-dump-not "#pragma omp metadirective" "gimple" } } */ diff --git a/gcc/testsuite/gcc.dg/gomp/metadirective-1.c b/gcc/testsuite/gcc.dg/gomp/metadirective-1.c new file mode 100644 index 00000000000..2ac81bfde75 --- /dev/null +++ b/gcc/testsuite/gcc.dg/gomp/metadirective-1.c @@ -0,0 +1,15 @@ +int main (void) +{ + int x, y; + + /* Test nested functions inside statement body. */ + #pragma omp metadirective \ + when (device={arch("nvptx")}: teams num_teams(512)) \ + when (device={arch("gcn")}: teams num_teams(256)) \ + default (teams num_teams(4)) + { + int f (int x) { return x * 3; } + + y = f (x); + } +} diff --git a/gcc/testsuite/gfortran.dg/gomp/metadirective-1.f90 b/gcc/testsuite/gfortran.dg/gomp/metadirective-1.f90 new file mode 100644 index 00000000000..aa439fc855e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/metadirective-1.f90 @@ -0,0 +1,41 @@ +! { dg-do compile } + +program main + integer, parameter :: N = 10 + integer, dimension(N) :: a + integer, dimension(N) :: b + integer, dimension(N) :: c + integer :: i + + do i = 1, N + a(i) = i * 2 + b(i) = i * 3 + end do + + !$omp metadirective & + !$omp& default (teams loop) & + !$omp& default (parallel loop) ! { dg-error "there can only be one default clause in a metadirective at .1." } + do i = 1, N + c(i) = a(i) * b(i) + end do + + !$omp metadirective default (xyz) ! { dg-error "Unclassifiable OpenMP directive at .1." } + do i = 1, N + c(i) = a(i) * b(i) + end do + + !$omp metadirective & + !$omp& default (teams loop) & ! { dg-error "expected 'default' or 'when' at .1." } + !$omp& where (device={arch("nvptx")}: parallel loop) + do i = 1, N + c(i) = a(i) * b(i) + end do + + !$omp begin metadirective & + !$omp& when (device={arch("nvptx")}: parallel do) & + !$omp& default (barrier) ! { dg-error "variant directive used in OMP BEGIN METADIRECTIVE at .1. must have a corresponding end directive" } + do i = 1, N + c(i) = a(i) * b(i) + end do + !$omp end metadirective ! { dg-error "Unexpected !OMP END METADIRECTIVE statement at .1." } +end program diff --git a/gcc/testsuite/gfortran.dg/gomp/metadirective-2.f90 b/gcc/testsuite/gfortran.dg/gomp/metadirective-2.f90 new file mode 100644 index 00000000000..06c324589d0 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/metadirective-2.f90 @@ -0,0 +1,59 @@ +! { dg-do compile } + +program main + integer, parameter :: N = 100 + integer :: x = 0 + integer :: y = 0 + integer :: i + + ! Test implicit default directive + !$omp metadirective & + !$omp& when (device={arch("nvptx")}: barrier) + x = 1 + + ! Test implicit default directive combined with a directive that takes a + ! do loop. + !$omp metadirective & + !$omp& when (device={arch("nvptx")}: parallel do) + do i = 1, N + x = x + i + end do + + ! Test with multiple standalone directives. + !$omp metadirective & + !$omp& when (device={arch("nvptx")}: barrier) & + !$omp& default (flush) + x = 1 + + ! Test combining a standalone directive with one that takes a do loop. + !$omp metadirective & + !$omp& when (device={arch("nvptx")}: parallel do) & + !$omp& default (barrier) + do i = 1, N + x = x + i + end do + + ! Test combining a directive that takes a do loop with one that takes + ! a statement body. + !$omp begin metadirective & + !$omp& when (device={arch("nvptx")}: parallel do) & + !$omp& default (parallel) + do i = 1, N + x = x + i + end do + !$omp end metadirective + + ! Test labels in the body + !$omp begin metadirective & + !$omp& when (device={arch("nvptx")}: parallel do) & + !$omp& when (device={arch("gcn")}: parallel) + do i = 1, N + x = x + i + if (x .gt. N/2) goto 10 +10 x = x + 1 + goto 20 + x = x + 2 +20 continue + end do + !$omp end metadirective +end program diff --git a/gcc/testsuite/gfortran.dg/gomp/metadirective-3.f90 b/gcc/testsuite/gfortran.dg/gomp/metadirective-3.f90 new file mode 100644 index 00000000000..c36a462bf51 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/metadirective-3.f90 @@ -0,0 +1,34 @@ +! { dg-do compile } +! { dg-additional-options "-fdump-tree-original" } +! { dg-additional-options "-fdump-tree-gimple" } +! { dg-additional-options "-fdump-tree-optimized" } + +module test + integer, parameter :: N = 100 +contains + subroutine f (x, y, z) + integer :: x(N), y(N), z(N) + + !$omp target map (to: v1, v2) map(from: v3) + !$omp metadirective & + !$omp& when(device={arch("nvptx")}: teams loop) & + !$omp& default(parallel loop) + do i = 1, N + z(i) = x(i) * y(i) + enddo + !$omp end target + end subroutine +end module + +! The metadirective should be resolved after Gimplification. + +! { dg-final { scan-tree-dump-times "#pragma omp metadirective" 1 "original" } } +! { dg-final { scan-tree-dump-times "when \\(device arch .nvptx.\\):" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp teams" 1 "original" } } +! { dg-final { scan-tree-dump-times "default:" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp parallel" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp loop" 2 "original" } } + +! { dg-final { scan-tree-dump-times "#pragma omp metadirective" 1 "gimple" } } + +! { dg-final { scan-tree-dump-not "#pragma omp metadirective" "optimized" } } diff --git a/gcc/testsuite/gfortran.dg/gomp/metadirective-4.f90 b/gcc/testsuite/gfortran.dg/gomp/metadirective-4.f90 new file mode 100644 index 00000000000..b82c9ea96d9 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/metadirective-4.f90 @@ -0,0 +1,39 @@ +! { dg-do compile } +! { dg-additional-options "-fdump-tree-original" } +! { dg-additional-options "-fdump-tree-gimple" } + +program test + implicit none + integer, parameter :: N = 100 + real :: a(N) + + !$omp target map(from: a) + call f (a, 3.14159) + !$omp end target + + ! TODO: This does not execute a version of f with the default clause + ! active as might be expected. + call f (a, 2.71828) +contains + subroutine f (a, x) + integer :: i + real :: a(N), x + !$omp declare target + + !$omp metadirective & + !$omp& when (construct={target}: distribute parallel do ) & + !$omp& default(parallel do simd) + do i = 1, N + a(i) = x * i + end do + end subroutine +end program + +! The metadirective should be resolved during Gimplification. + +! { dg-final { scan-tree-dump-times "#pragma omp metadirective" 1 "original" } } +! { dg-final { scan-tree-dump-times "when \\(construct target.*\\):" 1 "original" } } +! { dg-final { scan-tree-dump-times "default:" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp parallel" 2 "original" } } + +! { dg-final { scan-tree-dump-not "#pragma omp metadirective" "gimple" } } diff --git a/gcc/testsuite/gfortran.dg/gomp/metadirective-5.f90 b/gcc/testsuite/gfortran.dg/gomp/metadirective-5.f90 new file mode 100644 index 00000000000..03970393eb4 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/metadirective-5.f90 @@ -0,0 +1,30 @@ +! { dg-do compile } +! { dg-additional-options "-fdump-tree-gimple" } + +module test + integer, parameter :: N = 100 +contains + subroutine f (a, flag) + integer :: a(N) + logical :: flag + integer :: i + + !$omp metadirective & + !$omp& when (user={condition(flag)}: & + !$omp& target teams distribute parallel do map(from: a(1:N))) & + !$omp& default(parallel do) + do i = 1, N + a(i) = i + end do + end subroutine +end module + +! The metadirective should be resolved at parse time, but is currently +! resolved during Gimplification + +! { dg-final { scan-tree-dump-not "#pragma omp metadirective" "gimple" } } +! { dg-final { scan-tree-dump-times "#pragma omp target" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "#pragma omp teams" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "#pragma omp distribute" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "#pragma omp parallel" 2 "gimple" } } +! { dg-final { scan-tree-dump-times "#pragma omp for" 2 "gimple" } } diff --git a/gcc/testsuite/gfortran.dg/gomp/metadirective-6.f90 b/gcc/testsuite/gfortran.dg/gomp/metadirective-6.f90 new file mode 100644 index 00000000000..9b6c371296f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/metadirective-6.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! { dg-additional-options "-fdump-tree-gimple" } + +module test + integer, parameter :: N = 100 +contains + subroutine f (a, run_parallel, run_guided) + integer :: a(N) + logical :: run_parallel, run_guided + integer :: i + + !$omp begin metadirective when(user={condition(run_parallel)}: parallel) + !$omp metadirective & + !$omp& when(construct={parallel}, user={condition(run_guided)}: & + !$omp& do schedule(guided)) & + !$omp& when(construct={parallel}: do schedule(static)) + do i = 1, N + a(i) = i + end do + !$omp end metadirective + end subroutine +end module + +! The outer metadirective should be resolved at parse time, but is +! currently resolved during Gimplification. + +! The inner metadirective should be resolved during Gimplificiation. + +! { dg-final { scan-tree-dump-not "#pragma omp metadirective" "gimple" } } +! { dg-final { scan-tree-dump-times "#pragma omp parallel" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "#pragma omp for" 2 "gimple" } } diff --git a/libgomp/testsuite/libgomp.c-c++-common/metadirective-1.c b/libgomp/testsuite/libgomp.c-c++-common/metadirective-1.c new file mode 100644 index 00000000000..0de59cbe3d3 --- /dev/null +++ b/libgomp/testsuite/libgomp.c-c++-common/metadirective-1.c @@ -0,0 +1,35 @@ +/* { dg-do run } */ + +#define N 100 + +void f (int x[], int y[], int z[]) +{ + int i; + + #pragma omp target map(to: x[0:N], y[0:N]) map(from: z[0:N]) + #pragma omp metadirective \ + when (device={arch("nvptx")}: teams loop) \ + default (parallel loop) + for (i = 0; i < N; i++) + z[i] = x[i] * y[i]; +} + +int main (void) +{ + int x[N], y[N], z[N]; + int i; + + for (i = 0; i < N; i++) + { + x[i] = i; + y[i] = -i; + } + + f (x, y, z); + + for (i = 0; i < N; i++) + if (z[i] != x[i] * y[i]) + return 1; + + return 0; +} diff --git a/libgomp/testsuite/libgomp.c-c++-common/metadirective-2.c b/libgomp/testsuite/libgomp.c-c++-common/metadirective-2.c new file mode 100644 index 00000000000..cd5c6c5e21a --- /dev/null +++ b/libgomp/testsuite/libgomp.c-c++-common/metadirective-2.c @@ -0,0 +1,41 @@ +/* { dg-do run } */ + +#include + +#define N 100 +#define EPSILON 0.001 + +#pragma omp declare target +void f(double a[], double x) { + int i; + + #pragma omp metadirective \ + when (construct={target}: distribute parallel for) \ + default (parallel for simd) + for (i = 0; i < N; i++) + a[i] = x * i; +} +#pragma omp end declare target + + int main() +{ + double a[N]; + int i; + + #pragma omp target teams map(from: a[0:N]) + f (a, M_PI); + + for (i = 0; i < N; i++) + if (fabs (a[i] - (M_PI * i)) > EPSILON) + return 1; + + /* TODO: This does not execute a version of f with the default clause + active as might be expected. */ + f (a, M_E); + + for (i = 0; i < N; i++) + if (fabs (a[i] - (M_E * i)) > EPSILON) + return 1; + + return 0; + } diff --git a/libgomp/testsuite/libgomp.c-c++-common/metadirective-3.c b/libgomp/testsuite/libgomp.c-c++-common/metadirective-3.c new file mode 100644 index 00000000000..e31daf2cb64 --- /dev/null +++ b/libgomp/testsuite/libgomp.c-c++-common/metadirective-3.c @@ -0,0 +1,34 @@ +/* { dg-do run } */ + +#define N 100 + +int f (int a[], int flag) +{ + int i; + int res = 0; + + #pragma omp metadirective \ + when (user={condition(!flag)}: \ + target teams distribute parallel for \ + map(from: a[0:N]) private(res)) \ + default (parallel for) + for (i = 0; i < N; i++) + { + a[i] = i; + res = 1; + } + + return res; +} + +int main (void) +{ + int a[N]; + + if (f (a, 0)) + return 1; + if (!f (a, 1)) + return 1; + + return 0; +} diff --git a/libgomp/testsuite/libgomp.c-c++-common/metadirective-4.c b/libgomp/testsuite/libgomp.c-c++-common/metadirective-4.c new file mode 100644 index 00000000000..7fc601eaba6 --- /dev/null +++ b/libgomp/testsuite/libgomp.c-c++-common/metadirective-4.c @@ -0,0 +1,52 @@ +/* { dg-do run } */ + +#include + +#define N 100 + +int f (int a[], int run_parallel, int run_static) +{ + int is_parallel = 0; + int is_static = 0; + + #pragma omp metadirective \ + when (user={condition(run_parallel)}: parallel) + { + int i; + + if (omp_in_parallel ()) + is_parallel = 1; + + #pragma omp metadirective \ + when (construct={parallel}, user={condition(!run_static)}: \ + for schedule(guided) private(is_static)) \ + when (construct={parallel}: for schedule(static)) + for (i = 0; i < N; i++) + { + a[i] = i; + is_static = 1; + } + } + + return (is_parallel << 1) | is_static; +} + +int main (void) +{ + int a[N]; + + /* is_static is always set if run_parallel is false. */ + if (f (a, 0, 0) != 1) + return 1; + + if (f (a, 0, 1) != 1) + return 1; + + if (f (a, 1, 0) != 2) + return 1; + + if (f (a, 1, 1) != 3) + return 1; + + return 0; +} diff --git a/libgomp/testsuite/libgomp.fortran/metadirective-1.f90 b/libgomp/testsuite/libgomp.fortran/metadirective-1.f90 new file mode 100644 index 00000000000..9f6a07459e0 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/metadirective-1.f90 @@ -0,0 +1,33 @@ +! { dg-do run } + +program test + implicit none + + integer, parameter :: N = 100 + integer :: x(N), y(N), z(N) + integer :: i + + do i = 1, N + x(i) = i; + y(i) = -i; + end do + + call f (x, y, z) + + do i = 1, N + if (z(i) .ne. x(i) * y(i)) stop 1 + end do +contains + subroutine f (x, y, z) + integer :: x(N), y(N), z(N) + + !$omp target map (to: x, y) map(from: z) + !$omp metadirective & + !$omp& when(device={arch("nvptx")}: teams loop) & + !$omp& default(parallel loop) + do i = 1, N + z(i) = x(i) * y(i) + enddo + !$omp end target + end subroutine +end program diff --git a/libgomp/testsuite/libgomp.fortran/metadirective-2.f90 b/libgomp/testsuite/libgomp.fortran/metadirective-2.f90 new file mode 100644 index 00000000000..32017a00077 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/metadirective-2.f90 @@ -0,0 +1,40 @@ +! { dg-do run } + +program test + implicit none + integer, parameter :: N = 100 + real, parameter :: PI_CONST = 3.14159 + real, parameter :: E_CONST = 2.71828 + real, parameter :: EPSILON = 0.001 + integer :: i + real :: a(N) + + !$omp target map(from: a) + call f (a, PI_CONST) + !$omp end target + + do i = 1, N + if (abs (a(i) - (PI_CONST * i)) .gt. EPSILON) stop 1 + end do + + ! TODO: This does not execute a version of f with the default clause + ! active as might be expected. + call f (a, E_CONST) + + do i = 1, N + if (abs (a(i) - (E_CONST * i)) .gt. EPSILON) stop 2 + end do +contains + subroutine f (a, x) + integer :: i + real :: a(N), x + !$omp declare target + + !$omp metadirective & + !$omp& when (construct={target}: distribute parallel do ) & + !$omp& default(parallel do simd) + do i = 1, N + a(i) = x * i + end do + end subroutine +end program diff --git a/libgomp/testsuite/libgomp.fortran/metadirective-3.f90 b/libgomp/testsuite/libgomp.fortran/metadirective-3.f90 new file mode 100644 index 00000000000..693c40bca5a --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/metadirective-3.f90 @@ -0,0 +1,29 @@ +! { dg-do run } + +program test + implicit none + + integer, parameter :: N = 100 + integer :: a(N) + integer :: res + + if (f (a, .false.)) stop 1 + if (.not. f (a, .true.)) stop 2 +contains + logical function f (a, flag) + integer :: a(N) + logical :: flag + logical :: res = .false. + integer :: i + f = .false. + !$omp metadirective & + !$omp& when (user={condition(.not. flag)}: & + !$omp& target teams distribute parallel do & + !$omp& map(from: a(1:N)) private(res)) & + !$omp& default(parallel do) + do i = 1, N + a(i) = i + f = .true. + end do + end function +end program diff --git a/libgomp/testsuite/libgomp.fortran/metadirective-4.f90 b/libgomp/testsuite/libgomp.fortran/metadirective-4.f90 new file mode 100644 index 00000000000..04fdf61489c --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/metadirective-4.f90 @@ -0,0 +1,46 @@ +! { dg-do run } + +program test + use omp_lib + + implicit none + integer, parameter :: N = 100 + integer :: a(N) + logical :: is_parallel, is_static + + ! is_static is always set if run_parallel is false. + call f (a, .false., .false., is_parallel, is_static) + if (is_parallel .or. .not. is_static) stop 1 + + call f (a, .false., .true., is_parallel, is_static) + if (is_parallel .or. .not. is_static) stop 2 + + call f (a, .true., .false., is_parallel, is_static) + if (.not. is_parallel .or. is_static) stop 3 + + call f (a, .true., .true., is_parallel, is_static) + if (.not. is_parallel .or. .not. is_static) stop 4 +contains + subroutine f (a, run_parallel, run_static, is_parallel, is_static) + integer :: a(N) + logical, intent(in) :: run_parallel, run_static + logical, intent(out) :: is_parallel, is_static + integer :: i + + is_parallel = .false. + is_static = .false. + + !$omp begin metadirective when(user={condition(run_parallel)}: parallel) + if (omp_in_parallel ()) is_parallel = .true. + + !$omp metadirective & + !$omp& when(construct={parallel}, user={condition(.not. run_static)}: & + !$omp& do schedule(guided) private(is_static)) & + !$omp& when(construct={parallel}: do schedule(static)) + do i = 1, N + a(i) = i + is_static = .true. + end do + !$omp end metadirective + end subroutine +end program