From patchwork Thu Sep 12 17:00:12 2024 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: Tobias Burnus X-Patchwork-Id: 1984775 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@legolas.ozlabs.org Authentication-Results: legolas.ozlabs.org; dkim=pass (2048-bit key; unprotected) header.d=baylibre-com.20230601.gappssmtp.com header.i=@baylibre-com.20230601.gappssmtp.com header.a=rsa-sha256 header.s=20230601 header.b=opOS+IvQ; dkim-atps=neutral Authentication-Results: legolas.ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=2620:52:3:1:0:246e:9693:128c; helo=server2.sourceware.org; envelope-from=gcc-patches-bounces~incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=patchwork.ozlabs.org) Received: from server2.sourceware.org (server2.sourceware.org [IPv6:2620:52:3:1:0:246e:9693:128c]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits) key-exchange X25519 server-signature ECDSA (secp384r1) server-digest SHA384) (No client certificate requested) by legolas.ozlabs.org (Postfix) with ESMTPS id 4X4NxH3Hmjz1y1y for ; Fri, 13 Sep 2024 03:00:49 +1000 (AEST) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 2C5FD385DDD4 for ; Thu, 12 Sep 2024 17:00:47 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-wm1-x332.google.com (mail-wm1-x332.google.com [IPv6:2a00:1450:4864:20::332]) by sourceware.org (Postfix) with ESMTPS id CA1E83858D28 for ; Thu, 12 Sep 2024 17:00:15 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org CA1E83858D28 Authentication-Results: sourceware.org; dmarc=none (p=none dis=none) header.from=baylibre.com Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=baylibre.com ARC-Filter: OpenARC Filter v1.0.0 sourceware.org CA1E83858D28 Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=2a00:1450:4864:20::332 ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1726160421; cv=none; b=jFyCxUMd/xVOEt1O1CfN1TaXAnScIVvBsktOx+9nLPIjOhR7ejoxZm21W3xavfb947DmxJwkLnwc28zXzpgQPJczru1nVEkbo2PD/eyWG14775smr+j2jOg+chCuWp0UdL2UxfIHL/o7jHbpAsUuhA+G0KI7jdpaK6PCoiigOuo= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1726160421; c=relaxed/simple; bh=8DgdzIBIfVJvArWwTKAMbAt5dLPC9TMIqf9o6vRtg7Q=; h=DKIM-Signature:Message-ID:Date:MIME-Version:To:From:Subject; b=bjpHnS5cQnYvRHKpbh6tbGyzFvPA1BWwYV/Hm59h0H9D/+dIYoq4yDcNe2wExR6bHfJ5NxVV2BIEHVUdgfQeBL+MQwkjFwZit5RQ+KaE5h4jPgHmSTUPe0D7e55b5SyQa9NwE177xYeq3Utw2s4m/cGl++Cfqj8LG1yfjNrLbjM= ARC-Authentication-Results: i=1; server2.sourceware.org Received: by mail-wm1-x332.google.com with SMTP id 5b1f17b1804b1-42bbffe38e6so10014485e9.0 for ; Thu, 12 Sep 2024 10:00:15 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=baylibre-com.20230601.gappssmtp.com; s=20230601; t=1726160414; x=1726765214; darn=gcc.gnu.org; h=subject:from:to:content-language:user-agent:mime-version:date :message-id:from:to:cc:subject:date:message-id:reply-to; bh=SQiyQnMQNAWFnGG749cenF7LfJHN8UIYnotQ1/+3ZUE=; b=opOS+IvQw3W5BBH6KBqPYBMQvejv9Bx2cT8d/4Qww1VPDKZ+8q+V2RQpl5i6wmdpir JoLHOFvnHSH3+Ss/4Vl+PxbwJkWbKOhbpuiTY6xrNxd/sqZJ79h8OrpsFpqxtSzohvNq TnyzNYdhAd2XvJfbadqMc7JiA4qWHSxuA59ntHw/aCZYLcbUgpxdV+XaqHb2rHKpe38D 4p9mmUPdIoNuEMYeao5AxXfT57ItunwX5yyyrAp6mwxWAv5zEUISEVFDZqnWxSgmq0Qg udpiwTV7UKKLKuKfnKSZiKBfXIhfXUUhR3n/DzDOnL4Lq3RvMy1gJ2O5QzdAsd18ThFh i9Dg== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1726160414; x=1726765214; h=subject:from:to:content-language:user-agent:mime-version:date :message-id:x-gm-message-state:from:to:cc:subject:date:message-id :reply-to; bh=SQiyQnMQNAWFnGG749cenF7LfJHN8UIYnotQ1/+3ZUE=; b=gV6jXzaGGgP1mmjJJZH3CjmIvQ9y5oRHqvVUHYwq0Xy1NRvItJD0SP5SJCvr3XYgo3 a3AW1mA6rSiv6hYQ3NH9bRTaMhZJMWGVDO3rJ1oJ94BNnu2DCj7kC60jl7iKYK56f9xo wyn+GPKK/1j2P6CHa2hQjLJcAIz0oYp+7cYqi9vbr0w4EL2MYsdzBNG8TyP2x+5sXfiH jKWbnsKSxQpsqO7zZx0ULjF3crb1p3MmsK0j4UpMn8MXRMUrxInXV5edWwGxpsYvkA/0 k5giWc++SPlvulGNiTqoPPkomf2eieFYj162YkHqtxkBSy8BaC0AkL90Wn+lD+R3oW63 BHng== X-Gm-Message-State: AOJu0Yy52HJYqlEEPDmbi+rqtOcdMea+hVOtLnrSWHBZ4bhABuDGki3p z5OJ1LdsFrnzPVZJON42cGhEuxdLhITEvrRWe0jSfHCf6x+kNkxuMvV8NKBPuDUPrYB6Vw/B55H M X-Google-Smtp-Source: AGHT+IEyi8v6t0tBzC4ROvP9ox44/tZnBbq+qh1bCc8GcJZA+ZXJyyoMRGEE5++dOr1h84WSLSiKwg== X-Received: by 2002:a05:600c:3595:b0:425:7884:6b29 with SMTP id 5b1f17b1804b1-42cdb53f541mr24485135e9.19.1726160413730; Thu, 12 Sep 2024 10:00:13 -0700 (PDT) Received: from ?IPV6:2001:16b8:3d0b:9500:21d:a7e8:9dc7:d6b5? ([2001:16b8:3d0b:9500:21d:a7e8:9dc7:d6b5]) by smtp.gmail.com with ESMTPSA id 5b1f17b1804b1-42caeb4444asm179140215e9.22.2024.09.12.10.00.12 (version=TLS1_3 cipher=TLS_AES_128_GCM_SHA256 bits=128/128); Thu, 12 Sep 2024 10:00:13 -0700 (PDT) Message-ID: Date: Thu, 12 Sep 2024 19:00:12 +0200 MIME-Version: 1.0 User-Agent: Mozilla Thunderbird Content-Language: en-US To: gcc-patches , Jakub Jelinek , "fortran@gcc.gnu.org" From: Tobias Burnus Subject: [Patch] Fortran: Fixes to OpenMP 'interop' directive parsing support X-Spam-Status: No, score=-12.1 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, GIT_PATCH_0, RCVD_IN_DNSWL_NONE, SPF_HELO_NONE, SPF_PASS, TXREP autolearn=ham autolearn_force=no version=3.4.6 X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on server2.sourceware.org X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.30 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: gcc-patches-bounces~incoming=patchwork.ozlabs.org@gcc.gnu.org This patch fixes a couple of issues, like a missing white-space gobbling after matching an expression. It also reorganizes some code to handle 'identifier_"string"' vs. 'identifier' better as there were some diagnostic issues. (OpenMP requires for 'fr' that the argument is either an identifier (that is a scalar integer parameter) or a string; while for the older syntax, it can be any constant integer expression.) However, the two main changes are: * 'fr' and 'attr' actually support a list of arguments. While I believe 'attr("x", "y") and "attr("x"),attr("y")' are semantically identically, supporting more than one (or zero) values for 'fr' required a different encoding. * Jakub additionally suggested that for 'fr', which supports constant integers and string literals, we could pass on integer values – and do some checking. That's what this patch does: Known string values are converted to their associated integer values, others to 0. And if the integer/string value is unknown, a warning is printed [-Wopenmp]. Known values are those in the "OpenMP API Additional Definitions" document, https://www.openmp.org/specifications/ – with the addition of hsa / 7, which has been voted at spec level (no idea about ARB level) but not yet published. Note that that's the warning is based on what is defined there, i.e. 'level_zero' there is no warning, even though GCC does not support it. Obviously, if will add another value next year, GCC 15 will not support it and warn, even if the code is perfectly valid. — But I guess we can live with a warning in that case. Comments, remarks, suggestions? — Especially regarding the internal representation? Tobias PS: Next step will be to get the C/C++ parsing working, which also implies encoding this representation into 'tree'. (Then doing the tree conversion for Fortran.) Once satisfied with that, the middle end + libgomp part that links those bits will come next. And the question whether there should be one call per 'interop' directive or might be multiple (e.g. one per interop object in 'init'/'use'/'destroy'). Fortran: Fixes to OpenMP 'interop' directive parsing support Handle lists as argument to 'fr' and 'attr'; fix parsing corner cases. Additionally, 'fr' values are now internally stored as integer, permitting the diagnoses (warning) for values not defined in the OpenMP additional definitions document. PR fortran/116661 gcc/fortran/ChangeLog: * gfortran.h (gfc_omp_namelist): Rename 'init' members for clarity. * match.cc (gfc_free_omp_namelist): Handle renaming. * dump-parse-tree.cc (show_omp_namelist): Update for new format and features. * openmp.cc (gfc_match_omp_prefer_type): Parse list to 'fr' and 'attr'; store 'fr' values as integer. (gfc_match_omp_init): Rename variable names. gcc/ChangeLog: * omp-api.h (omp_get_fr_id_from_name, omp_get_name_from_fr_id): New prototypes. * omp-general.cc (omp_get_fr_id_from_name, omp_get_name_from_fr_id): New. include/ChangeLog: * gomp-constants.h (GOMP_INTEROP_IFR_LAST, GOMP_INTEROP_IFR_SEPARATOR, GOMP_INTEROP_IFR_NONE): New. gcc/testsuite/ChangeLog: * gfortran.dg/gomp/interop-1.f90: Extend, update dg-*. * gfortran.dg/gomp/interop-2.f90: Update dg-error. * gfortran.dg/gomp/interop-3.f90: Add dg-warning. gcc/fortran/dump-parse-tree.cc | 84 +++++--- gcc/fortran/gfortran.h | 4 +- gcc/fortran/match.cc | 10 +- gcc/fortran/openmp.cc | 305 ++++++++++++++++----------- gcc/omp-api.h | 3 + gcc/omp-general.cc | 29 +++ gcc/testsuite/gfortran.dg/gomp/interop-1.f90 | 32 ++- gcc/testsuite/gfortran.dg/gomp/interop-2.f90 | 2 +- gcc/testsuite/gfortran.dg/gomp/interop-3.f90 | 2 +- include/gomp-constants.h | 5 + 10 files changed, 314 insertions(+), 162 deletions(-) diff --git a/gcc/fortran/dump-parse-tree.cc b/gcc/fortran/dump-parse-tree.cc index 8fc6141611c..3547d7f8aca 100644 --- a/gcc/fortran/dump-parse-tree.cc +++ b/gcc/fortran/dump-parse-tree.cc @@ -37,6 +37,8 @@ along with GCC; see the file COPYING3. If not see #include "constructor.h" #include "version.h" #include "parse.h" /* For gfc_ascii_statement. */ +#include "omp-api.h" /* For omp_get_name_from_fr_id. */ +#include "gomp-constants.h" /* For GOMP_INTEROP_IFR_SEPARATOR. */ /* Keep track of indentation for symbol tree dumps. */ static int show_level = 0; @@ -1537,35 +1539,69 @@ show_omp_namelist (int list_type, gfc_omp_namelist *n) } else if (list_type == OMP_LIST_INIT) { - int i = 0; if (n->u.init.target) fputs ("target,", dumpfile); if (n->u.init.targetsync) fputs ("targetsync,", dumpfile); - char *prefer_type = n->u.init.str; - if (n->u.init.len) - fputs ("prefer_type(", dumpfile); - if (n->u.init.len) - while (*prefer_type) - { - fputc ('{', dumpfile); - if (n->u2.interop_int && n->u2.interop_int[i] != 0) - fprintf (dumpfile, "fr(%d),", n->u2.interop_int[i]); - else if (prefer_type[0] != ' ' || prefer_type[1] != '\0') - fprintf (dumpfile, "fr(\"%s\"),", prefer_type); - prefer_type += 1 + strlen (prefer_type); - - while (*prefer_type) - { - fprintf (dumpfile, "attr(\"%s\"),", prefer_type); - prefer_type += 1 + strlen (prefer_type); - } - fputc ('}', dumpfile); - ++prefer_type; - ++i; + if (n->u2.init_interop_fr) + { + char *attr_str = n->u.init.attr; + int idx = 0; + int fr_id; + fputs ("prefer_type(", dumpfile); + do + { + fr_id = n->u2.init_interop_fr[idx]; + fputc ('{', dumpfile); + if (fr_id != GOMP_INTEROP_IFR_NONE) + { + fputs ("fr(", dumpfile); + do + { + const char *fr_str = omp_get_name_from_fr_id (fr_id); + if (fr_str) + fprintf (dumpfile, "\"%s\"", fr_str); + else + fprintf (dumpfile, "%d", fr_id); + fr_id = n->u2.init_interop_fr[++idx]; + if (fr_id != GOMP_INTEROP_IFR_SEPARATOR) + fputc (',', dumpfile); + } + while (fr_id != GOMP_INTEROP_IFR_SEPARATOR); + fputc (')', dumpfile); + if (attr_str && (attr_str[0] != ' ' || attr_str[1] != '\0')) + fputc (',', dumpfile); + } + else + fr_id = n->u2.init_interop_fr[++idx]; + if (attr_str && attr_str[0] == ' ' && attr_str[1] == '\0') + attr_str += 2; + else if (attr_str) + { + fputs ("attr(\"", dumpfile); + do + { + fputs ((char *) attr_str, dumpfile); + fputc ('"', dumpfile); + attr_str += strlen (attr_str) + 1; + if (attr_str[0] == '\0') + break; + fputs (",\"", dumpfile); + } + while (true); + fputc (')', dumpfile); + } + fputc ('}', dumpfile); + fr_id = n->u2.init_interop_fr[++idx]; + if (fr_id == GOMP_INTEROP_IFR_SEPARATOR) + break; + fputc (',', dumpfile); + if (attr_str) + ++attr_str; + } + while (true); + fputc (')', dumpfile); } - if (n->u.init.len) - fputc (')', dumpfile); fputc (':', dumpfile); } fprintf (dumpfile, "%s", n->sym ? n->sym->name : "omp_all_memory"); diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 797d4ed07f5..37c28691f41 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -1389,7 +1389,7 @@ typedef struct gfc_omp_namelist bool present_modifier; struct { - char *str; + char *attr; int len; bool target; bool targetsync; @@ -1402,7 +1402,7 @@ typedef struct gfc_omp_namelist gfc_expr *allocator; struct gfc_symbol *traits_sym; struct gfc_omp_namelist *duplicate_of; - int *interop_int; + char *init_interop_fr; } u2; struct gfc_omp_namelist *next; locus where; diff --git a/gcc/fortran/match.cc b/gcc/fortran/match.cc index f3767c928a7..0cd78a57a2f 100644 --- a/gcc/fortran/match.cc +++ b/gcc/fortran/match.cc @@ -5551,7 +5551,7 @@ gfc_free_omp_namelist (gfc_omp_namelist *name, bool free_ns, { gfc_omp_namelist *n; gfc_expr *last_allocator = NULL; - char *last_init_str = NULL; + char *last_init_attr = NULL; for (; name; name = n) { @@ -5575,11 +5575,11 @@ gfc_free_omp_namelist (gfc_omp_namelist *name, bool free_ns, { } /* name->u2.traits_sym: shall not call gfc_free_symbol here. */ else if (free_init) { - if (name->u.init.str != last_init_str) + if (name->u.init.attr != last_init_attr) { - last_init_str = name->u.init.str; - free (name->u.init.str); - free (name->u2.interop_int); + last_init_attr = name->u.init.attr; + free (name->u.init.attr); + free (name->u2.init_interop_fr); } } else if (name->u2.udr) diff --git a/gcc/fortran/openmp.cc b/gcc/fortran/openmp.cc index 1145e2ff890..050409e00a0 100644 --- a/gcc/fortran/openmp.cc +++ b/gcc/fortran/openmp.cc @@ -1827,16 +1827,31 @@ error: where 'fr' takes an integer named constant or a string literal and 'attr takes a string literal, starting with 'ompx_') -Document string + int format -*/ + For the foreign runtime identifiers, string values are converted to + their integer value; unknown string or integer values are set to 0. + + For the simple syntax, pref_int_array contains alternatingly the + fr_id integer value and GOMP_INTEROP_IFR_SEPARATOR followed by a + GOMP_INTEROP_IFR_SEPARATOR as last item. + For the complex syntax, it contains the values associated with a + 'fr(...)' followed by GOMP_INTEROP_IFR_SEPARATOR. If there is no + 'fr' in a curly-brace block, it is GOMP_INTEROP_IFR_NONE followed + by GOMP_INTEROP_IFR_SEPARATOR. An additional GOMP_INTEROP_IFR_SEPARATOR + at the end terminates the array. + + For attributes, if the simply syntax is used, it is NULL - likewise if no + 'attr' appears. For the complex syntax it is: For reach curly-brace block, + it is \0\0 is no attr appears and otherwise a concatenation (including + the \0) of all 'attr' strings followed by a tailing '\0'. At the end, + another '\0' follows. */ static match -gfc_match_omp_prefer_type (char **pref_str, int *pref_str_len, int **pref_int_array) +gfc_match_omp_prefer_type (char **fr_int_array, char **attr_str, int *attr_str_len) { gfc_expr *e; - size_t cnt = 0; - std::vector int_list; - std::string pref_string; + int cnt_brace_grp = 0; + std::vector int_list; + std::string attr_string; /* New syntax. */ if (gfc_peek_ascii_char () == '{') do @@ -1846,8 +1861,8 @@ gfc_match_omp_prefer_type (char **pref_str, int *pref_str_len, int **pref_int_ar gfc_error ("Expected %<{%> at %C"); return MATCH_ERROR; } - std::string attr; bool fr_found = false; + bool attr_found = false; do { if (gfc_match ("fr ( ") == MATCH_YES) @@ -1859,99 +1874,129 @@ gfc_match_omp_prefer_type (char **pref_str, int *pref_str_len, int **pref_int_ar return MATCH_ERROR; } fr_found = true; - gfc_symbol *sym = NULL; - e = NULL; - locus loc = gfc_current_locus; - if (gfc_match_symbol (&sym, 0) != MATCH_YES - || gfc_match (" _") == MATCH_YES) + do { - gfc_current_locus = loc; - if (gfc_match_expr (&e) == MATCH_ERROR) + if (gfc_match_expr (&e) != MATCH_YES) return MATCH_ERROR; - } - if ((!sym && !e) - || (e && (!gfc_resolve_expr (e) - || e->expr_type != EXPR_CONSTANT - || e->ts.type != BT_CHARACTER - || e->ts.kind != gfc_default_character_kind - || e->value.character.length == 0)) - || (sym && (sym->attr.flavor != FL_PARAMETER - || sym->ts.type != BT_INTEGER - || !mpz_fits_sint_p (sym->value->value.integer) - || sym->attr.dimension))) - { - gfc_error ("Expected constant integer identifier or " - "non-empty default-kind character literal at %L", - &loc); - gfc_free_expr (e); + if (e->expr_type != EXPR_CONSTANT + || e->ref != NULL + || !gfc_resolve_expr (e) + || (e->ts.type != BT_INTEGER + && e->ts.type != BT_CHARACTER) + || (e->ts.type == BT_INTEGER + && (!e->symtree + || e->symtree->n.sym->attr.flavor != FL_PARAMETER + || !mpz_fits_sint_p (e->value.integer))) + || (e->ts.type == BT_CHARACTER + && (e->ts.kind != gfc_default_character_kind + || e->value.character.length == 0))) + { + gfc_error ("Expected scalar integer parameter or " + "non-empty default-kind character literal " + "at %L", &e->where); + gfc_free_expr (e); + return MATCH_ERROR; + } + gfc_gobble_whitespace (); + int val; + if (e->ts.type == BT_INTEGER) + { + val = mpz_get_si (e->value.integer); + if (val < 1 || val > GOMP_INTEROP_IFR_LAST) + { + gfc_warning (OPT_Wopenmp, + "Unknown foreign runtime identifier " + "%qd at %L", val, &e->where); + val = 0; + } + } + else + { + char *str = XALLOCAVEC (char, + e->value.character.length+1); + for (int i = 0; i < e->value.character.length + 1; i++) + str[i] = e->value.character.string[i]; + if (memchr (str, '\0', e->value.character.length) != 0) + { + gfc_error ("Unexpected null character in character " + "literal at %L", &e->where); + return MATCH_ERROR; + } + val = omp_get_fr_id_from_name (str); + if (val == 0) + gfc_warning (OPT_Wopenmp, + "Unknown foreign runtime identifier %qs " + "at %L", str, &e->where); + } + int_list.push_back (val); + if (gfc_match (", ") == MATCH_YES) + continue; + if (gfc_match (") ") == MATCH_YES) + break; + gfc_error ("Expected %<,%> or %<)%> at %C"); return MATCH_ERROR; } - if (sym) - { - for (size_t i = int_list.size(); i < cnt; ++i) - int_list.push_back (0); - int_list.push_back (mpz_get_si (sym->value->value.integer)); - pref_string += ' '; - pref_string += '\0'; - } - else - { - char *str = XALLOCAVEC (char, e->value.character.length+1); - for (int i = 0; i < e->value.character.length + 1; i++) - str[i] = e->value.character.string[i]; - if (memchr (str, '\0', e->value.character.length) != 0) - { - gfc_error ("Unexpected null character in character " - "literal at %L", &loc); - return MATCH_ERROR; - } - pref_string += str; - pref_string += '\0'; - } + while (true); } else if (gfc_match ("attr ( ") == MATCH_YES) { - locus loc = gfc_current_locus; - if (gfc_match_expr (&e) != MATCH_YES - || e->expr_type != EXPR_CONSTANT - || e->ts.type != BT_CHARACTER) - { - gfc_error ("Expected default-kind character literal at %L", - &loc); - gfc_free_expr (e); - return MATCH_ERROR; - } - char *str = XALLOCAVEC (char, e->value.character.length+1); - for (int i = 0; i < e->value.character.length + 1; i++) - str[i] = e->value.character.string[i]; - if (!startswith (str, "ompx_")) - { - gfc_error ("Character literal at %L must start with " - "%", &e->where); - gfc_free_expr (e); - return MATCH_ERROR; - } - if (memchr (str, '\0', e->value.character.length) != 0 - || memchr (str, ',', e->value.character.length) != 0) + attr_found = true; + if (attr_string.empty ()) + for (int i = 0; i < cnt_brace_grp; ++i) + { + /* Add dummy elements for previous curly-brace blocks. */ + attr_string += ' '; + attr_string += '\0'; + attr_string += '\0'; + } + do { - gfc_error ("Unexpected null or %<,%> character in " - "character literal at %L", &e->where); + if (gfc_match_expr (&e) != MATCH_YES) + return MATCH_ERROR; + if (e->expr_type != EXPR_CONSTANT + || e->rank != 0 + || e->ts.type != BT_CHARACTER + || e->ts.kind != gfc_default_character_kind) + { + gfc_error ("Expected default-kind character literal " + "at %L", &e->where); + gfc_free_expr (e); + return MATCH_ERROR; + } + gfc_gobble_whitespace (); + char *str = XALLOCAVEC (char, e->value.character.length+1); + for (int i = 0; i < e->value.character.length + 1; i++) + str[i] = e->value.character.string[i]; + if (!startswith (str, "ompx_")) + { + gfc_error ("Character literal at %L must start with " + "%", &e->where); + gfc_free_expr (e); + return MATCH_ERROR; + } + if (memchr (str, '\0', e->value.character.length) != 0 + || memchr (str, ',', e->value.character.length) != 0) + { + gfc_error ("Unexpected null or %<,%> character in " + "character literal at %L", &e->where); + return MATCH_ERROR; + } + attr_string += str; + attr_string += '\0'; + if (gfc_match (", ") == MATCH_YES) + continue; + if (gfc_match (") ") == MATCH_YES) + break; + gfc_error ("Expected %<,%> or %<)%> at %C"); return MATCH_ERROR; } - attr += str; - attr += '\0'; + while (true); } else { gfc_error ("Expected % or % at %C"); return MATCH_ERROR; } - ++cnt; - if (gfc_match (") ") != MATCH_YES) - { - gfc_error ("Expected %<)%> at %C"); - return MATCH_ERROR; - } if (gfc_match (", ") == MATCH_YES) continue; if (gfc_match ("} ") == MATCH_YES) @@ -1960,13 +2005,20 @@ gfc_match_omp_prefer_type (char **pref_str, int *pref_str_len, int **pref_int_ar return MATCH_ERROR; } while (true); + ++cnt_brace_grp; if (!fr_found) + int_list.push_back (GOMP_INTEROP_IFR_NONE); + int_list.push_back (GOMP_INTEROP_IFR_SEPARATOR); + if (!attr_string.empty ()) { - pref_string += ' '; - pref_string += '\0'; + if (!attr_found) + { + /* Dummy entry. */ + attr_string += ' '; + attr_string += '\0'; + } + attr_string += '\0'; } - pref_string += attr; - pref_string += '\0'; if (gfc_match (", ") == MATCH_YES) continue; @@ -1982,6 +2034,7 @@ gfc_match_omp_prefer_type (char **pref_str, int *pref_str_len, int **pref_int_ar if (gfc_match_expr (&e) != MATCH_YES) return MATCH_ERROR; if (!gfc_resolve_expr (e) + || e->rank != 0 || e->expr_type != EXPR_CONSTANT || (e->ts.type != BT_INTEGER && e->ts.type != BT_CHARACTER) || (e->ts.type == BT_INTEGER @@ -1990,17 +2043,23 @@ gfc_match_omp_prefer_type (char **pref_str, int *pref_str_len, int **pref_int_ar && (e->ts.kind != gfc_default_character_kind || e->value.character.length == 0))) { - gfc_error ("Expected constant integer expression or non-empty " - "default-kind character literal at %L", &e->where); + gfc_error ("Expected constant scalar integer expression or " + "non-empty default-kind character literal at %L", &e->where); gfc_free_expr (e); return MATCH_ERROR; } + gfc_gobble_whitespace (); + int val; if (e->ts.type == BT_INTEGER) { - for (size_t i = int_list.size(); i < cnt; ++i) - int_list.push_back (0); - int_list.push_back (mpz_get_si (e->value.integer)); - pref_string += ' '; + val = mpz_get_si (e->value.integer); + if (val < 1 || val > GOMP_INTEROP_IFR_LAST) + { + gfc_warning (OPT_Wopenmp, + "Unknown foreign runtime identifier %qd at %L", + val, &e->where); + val = 0; + } } else { @@ -2009,15 +2068,18 @@ gfc_match_omp_prefer_type (char **pref_str, int *pref_str_len, int **pref_int_ar str[i] = e->value.character.string[i]; if (memchr (str, '\0', e->value.character.length) != 0) { - gfc_error ("Unexpected null character in character literal " - "at %L", &e->where); + gfc_error ("Unexpected null character in character " + "literal at %L", &e->where); return MATCH_ERROR; } - pref_string += str; + val = omp_get_fr_id_from_name (str); + if (val == 0) + gfc_warning (OPT_Wopenmp, + "Unknown foreign runtime identifier %qs at %L", + str, &e->where); } - pref_string += '\0'; - pref_string += '\0'; - ++cnt; + int_list.push_back (val); + int_list.push_back (GOMP_INTEROP_IFR_SEPARATOR); gfc_free_expr (e); if (gfc_match (", ") == MATCH_YES) continue; @@ -2027,19 +2089,16 @@ gfc_match_omp_prefer_type (char **pref_str, int *pref_str_len, int **pref_int_ar return MATCH_ERROR; } while (true); - if (!int_list.empty()) - for (size_t i = int_list.size(); i < cnt; ++i) - int_list.push_back (0); - - pref_string += '\0'; + int_list.push_back (GOMP_INTEROP_IFR_SEPARATOR); + *fr_int_array = XNEWVEC (char, int_list.size ()); + memcpy (*fr_int_array, int_list.data (), sizeof (char) * int_list.size ()); - *pref_str_len = pref_string.length(); - *pref_str = XNEWVEC (char, pref_string.length ()); - memcpy (*pref_str, pref_string.data (), pref_string.length ()); - if (!int_list.empty ()) + if (!attr_string.empty ()) { - *pref_int_array = XNEWVEC (int, cnt); - memcpy (*pref_int_array, int_list.data (), sizeof (int) * cnt); + attr_string += '\0'; + *attr_str_len = attr_string.length(); + *attr_str = XNEWVEC (char, attr_string.length ()); + memcpy (*attr_str, attr_string.data (), attr_string.length ()); } return MATCH_YES; } @@ -2052,21 +2111,21 @@ static match gfc_match_omp_init (gfc_omp_namelist **list) { bool target = false, targetsync = false; - char *pref_str = NULL; - int pref_str_len = 0; - int *pref_int_array = NULL; + char *fr_int_array = NULL; + char *attr_str = NULL; + int attr_str_len = 0; match m; locus old_loc = gfc_current_locus; do { if (gfc_match ("prefer_type ( ") == MATCH_YES) { - if (pref_str) + if (fr_int_array) { gfc_error ("Duplicate % modifier at %C"); return MATCH_ERROR; } - m = gfc_match_omp_prefer_type (&pref_str, &pref_str_len, - &pref_int_array); + m = gfc_match_omp_prefer_type (&fr_int_array, &attr_str, + &attr_str_len); if (m != MATCH_YES) return m; if (gfc_match (", ") == MATCH_YES) @@ -2084,7 +2143,7 @@ gfc_match_omp_init (gfc_omp_namelist **list) if (gfc_match (": ") == MATCH_YES) break; gfc_char_t c = gfc_peek_char (); - if (!pref_str + if (!fr_int_array && (c == ')' || (gfc_current_form != FORM_FREE && (c == '_' || ISALPHA (c))))) @@ -2103,7 +2162,7 @@ gfc_match_omp_init (gfc_omp_namelist **list) if (gfc_match (": ") == MATCH_YES) break; gfc_char_t c = gfc_peek_char (); - if (!pref_str + if (!fr_int_array && (c == ')' || (gfc_current_form != FORM_FREE && (c == '_' || ISALPHA (c))))) @@ -2114,7 +2173,7 @@ gfc_match_omp_init (gfc_omp_namelist **list) gfc_error ("Expected %<,%> or %<:%> at %C"); return MATCH_ERROR; } - if (pref_str) + if (fr_int_array) { gfc_error ("Expected % or % at %C"); return MATCH_ERROR; @@ -2131,9 +2190,9 @@ gfc_match_omp_init (gfc_omp_namelist **list) { n->u.init.target = target; n->u.init.targetsync = targetsync; - n->u.init.str = pref_str; - n->u.init.len = pref_str_len; - n->u2.interop_int = pref_int_array; + n->u.init.attr = attr_str; + n->u.init.len = attr_str_len; + n->u2.init_interop_fr = fr_int_array; } return MATCH_YES; } diff --git a/gcc/omp-api.h b/gcc/omp-api.h index 0884e51c61c..1b877f257f0 100644 --- a/gcc/omp-api.h +++ b/gcc/omp-api.h @@ -29,4 +29,7 @@ along with GCC; see the file COPYING3. If not see extern bool omp_runtime_api_procname (const char *name); extern bool omp_runtime_api_call (const_tree fndecl); +extern int omp_get_fr_id_from_name (const char *); +extern const char *omp_get_name_from_fr_id (int); + #endif diff --git a/gcc/omp-general.cc b/gcc/omp-general.cc index aaa179afe13..de91ba8a4a7 100644 --- a/gcc/omp-general.cc +++ b/gcc/omp-general.cc @@ -3385,6 +3385,35 @@ omp_runtime_api_call (const_tree fndecl) return omp_runtime_api_procname (IDENTIFIER_POINTER (declname)); } +/* See "Additional Definitions for the OpenMP API Specification" document; + associated IDs are 1, 2, ... */ +static const char* omp_interop_fr_str[] = {"cuda", "cuda_driver", "opencl", + "sycl", "hip", "level_zero", "hsa"}; + +/* Returns the foreign-runtime ID if found or 0 otherwise. */ + +int +omp_get_fr_id_from_name (const char *str) +{ + static_assert (GOMP_INTEROP_IFR_LAST == ARRAY_SIZE (omp_interop_fr_str), ""); + + for (unsigned i = 0; i < ARRAY_SIZE (omp_interop_fr_str); ++i) + if (!strcmp (str, omp_interop_fr_str[i])) + return i + 1; + return 0; +} + +/* Returns the string value to a foreign-runtime integer value or NULL if value + is not known. */ + +const char * +omp_get_name_from_fr_id (int fr_id) +{ + if (fr_id < 1 || fr_id > (int) ARRAY_SIZE (omp_interop_fr_str)) + return NULL; + return omp_interop_fr_str[fr_id-1]; +} + namespace omp_addr_tokenizer { /* We scan an expression by recursive descent, and build a vector of diff --git a/gcc/testsuite/gfortran.dg/gomp/interop-1.f90 b/gcc/testsuite/gfortran.dg/gomp/interop-1.f90 index bbb1dea1be6..8c99fc97f88 100644 --- a/gcc/testsuite/gfortran.dg/gomp/interop-1.f90 +++ b/gcc/testsuite/gfortran.dg/gomp/interop-1.f90 @@ -28,6 +28,8 @@ implicit none !$omp requires reverse_offload +integer(omp_interop_fr_kind), parameter :: ifr_array(2) = [omp_ifr_cuda, omp_ifr_hip] + integer(omp_interop_kind) :: obj1, obj2, obj3, obj4, obj5 integer :: x @@ -37,7 +39,7 @@ integer :: x !$omp& destroy(obj2, obj3) depend(inout: x) use(obj4, obj5) device(device_num: 0) !$omp assume contains(interop) - !$omp interop init(prefer_type("cu"//char(1)//"da") : obj3) + !$omp interop init(prefer_type("cu"//char(1)//"da") : obj3) ! { dg-warning "Unknown foreign runtime identifier 'cu\\\\x01da'" } !$omp end assume !$omp interop init(prefer_type("cu"//char(0)//"da") : obj3) ! { dg-error "Unexpected null character in character literal" } @@ -52,11 +54,29 @@ integer :: x !$omp interop init ( target , prefer_type( { fr("hsa"), attr("ompx_nothing") , fr("hsa" ) }) :obj1) ! { dg-error "Duplicated 'fr' preference-selector-name" } -!$omp interop init ( prefer_type( 4, omp_ifr_hip*4) : obj1) -!$omp interop init ( prefer_type( sin(3.3) : obj1) ! { dg-error "Expected constant integer expression or non-empty default-kind character literal" } -!$omp interop init ( prefer_type( {fr(4) }) : obj1) ! { dg-error "Expected constant integer identifier or non-empty default-kind character literal" } -!$omp interop init ( prefer_type( {fr(4_"cuda") }) : obj1) ! { dg-error "Expected constant integer identifier or non-empty default-kind character literal" } +!$omp interop init ( prefer_type( 4, omp_ifr_hip*4) : obj1) ! { dg-warning "Unknown foreign runtime identifier '20'" } +!$omp interop init ( prefer_type( sin(3.3) : obj1) ! { dg-error "Expected constant scalar integer expression or non-empty default-kind character literal" } +!$omp interop init ( prefer_type( {fr(4 ) }) : obj1) ! { dg-error "Expected scalar integer parameter or non-empty default-kind character literal" } +!$omp interop init ( prefer_type( {fr(4_"cuda" ) }) : obj1) ! { dg-error "Expected scalar integer parameter or non-empty default-kind character literal" } !$omp interop init ( prefer_type( {fr(c_char_"cuda") }) : obj1) ! OK -!$omp interop init ( prefer_type( {fr(1_"cuda") }) : obj1) ! OK +!$omp interop init ( prefer_type( {fr(1_"cuda" ) }) : obj1) ! OK +!$omp interop init ( prefer_type( {fr(omp_ifr_level_zero ) }, {fr(omp_ifr_hip)}) : obj1) ! OK +!$omp interop init ( prefer_type( {fr(omp_ifr_level_zero + 1) }) : obj1) ! { dg-error "Expected scalar integer parameter or non-empty default-kind character literal" } +!$omp interop init ( prefer_type( {fr(x) }) : obj1) ! { dg-error "Expected scalar integer parameter or non-empty default-kind character literal" } +!$omp interop init ( prefer_type( {fr(ifr_array ) }) : obj1) ! { dg-error "Expected scalar integer parameter or non-empty default-kind character literal" } +!$omp interop init ( prefer_type( {fr(ifr_array(1) ) }) : obj1) ! { dg-error "Expected scalar integer parameter or non-empty default-kind character literal" } + +!$omp interop init ( prefer_type( omp_ifr_level_zero, omp_ifr_hip ) : obj1) ! OK +!$omp interop init ( prefer_type( omp_ifr_level_zero +1 ) : obj1) ! OK +!$omp interop init ( prefer_type( x ) : obj1) ! { dg-error "Expected constant scalar integer expression or non-empty default-kind character literal" } +!$omp interop init ( prefer_type( ifr_array ) : obj1) ! { dg-error "Expected constant scalar integer expression or non-empty default-kind character literal" } +!$omp interop init ( prefer_type( ifr_array(2) ) : obj1) ! OK + +!$omp interop init ( prefer_type( 4, omp_ifr_hip*4) : obj1) ! { dg-warning "Unknown foreign runtime identifier '20'" } +!$omp interop init ( prefer_type( 4, 1, 3) : obj1) + +!$omp interop init ( prefer_type( {fr("cuda","sycl") }, {fr(omp_ifr_hsa,omp_ifr_level_zero)} , {attr("ompx_a") } , {fr(omp_ifr_hip) }) : obj1) +!$omp interop init ( prefer_type( {fr("cuda","sycl"), attr("ompx_1", "ompx_2"), attr("ompx_3") }, {attr("ompx_4", "ompx_5"),fr(omp_ifr_hsa,omp_ifr_level_zero)} ) : obj1) +!$omp interop init ( prefer_type( { fr("cuda","sycl"), attr("ompx_1") }, {fr(omp_ifr_hsa,omp_ifr_level_zero)} , {attr("ompx_a") } ) : obj1) end diff --git a/gcc/testsuite/gfortran.dg/gomp/interop-2.f90 b/gcc/testsuite/gfortran.dg/gomp/interop-2.f90 index c7673a662d0..f3391bf88f0 100644 --- a/gcc/testsuite/gfortran.dg/gomp/interop-2.f90 +++ b/gcc/testsuite/gfortran.dg/gomp/interop-2.f90 @@ -26,7 +26,7 @@ implicit none integer(omp_interop_kind) :: obj1, obj2, obj3, obj4, obj5 integer :: x -!$omp interop init ( prefer_type( {fr(1_"") }) : obj1) ! { dg-error "Expected constant integer identifier or non-empty default-kind character literal" } +!$omp interop init ( prefer_type( {fr(1_"") }) : obj1) ! { dg-error "Expected scalar integer parameter or non-empty default-kind character literal" } !$omp interop init ( prefer_type( {fr(1_"hip") , attr(omp_ifr_cuda) }) : obj1) ! { dg-error "Expected default-kind character literal" } !$omp interop init ( prefer_type( {fr(1_"hip") , attr("myooption") }) : obj1) ! { dg-error "Character literal at .1. must start with 'ompx_'" } diff --git a/gcc/testsuite/gfortran.dg/gomp/interop-3.f90 b/gcc/testsuite/gfortran.dg/gomp/interop-3.f90 index a6d2cc460fb..462ed4f2e4b 100644 --- a/gcc/testsuite/gfortran.dg/gomp/interop-3.f90 +++ b/gcc/testsuite/gfortran.dg/gomp/interop-3.f90 @@ -33,7 +33,7 @@ integer :: x !$omp& destroy(obj2, obj3) depend(inout: x) use(obj4, obj5) device(device_num: 0) !$omp assume contains(interop) - !$omp interop init(prefer_type("cu"//char(1)//"da") : obj3) + !$omp interop init(prefer_type("cu"//char(1)//"da") : obj3) ! { dg-warning "Unknown foreign runtime identifier 'cu\\\\x01da'" } !$omp end assume !$omp interop init(obj1, obj2, obj1), use(obj4) destroy(obj4) diff --git a/include/gomp-constants.h b/include/gomp-constants.h index 775fc4e8f64..0fae337f9d6 100644 --- a/include/gomp-constants.h +++ b/include/gomp-constants.h @@ -388,6 +388,11 @@ enum gomp_map_kind #define GOMP_REQUIRES_REVERSE_OFFLOAD 0x80 #define GOMP_REQUIRES_TARGET_USED 0x200 +/* Interop foreign-runtime data. */ +#define GOMP_INTEROP_IFR_LAST 7 +#define GOMP_INTEROP_IFR_SEPARATOR -1 +#define GOMP_INTEROP_IFR_NONE -2 + /* HSA specific data structures. */ /* Identifiers of device-specific target arguments. */