From patchwork Thu Sep 5 08:59:09 2024 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: Tobias Burnus X-Patchwork-Id: 97139 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 D4873384DEC2 for ; Thu, 5 Sep 2024 08:59:53 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-wm1-x330.google.com (mail-wm1-x330.google.com [IPv6:2a00:1450:4864:20::330]) by sourceware.org (Postfix) with ESMTPS id 0579D386549A for ; Thu, 5 Sep 2024 08:59:12 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 0579D386549A 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 0579D386549A Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=2a00:1450:4864:20::330 ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1725526758; cv=none; b=WNod+zErsfDRY+l/znemAkJIXkigLGcP1rVO4nx1IL13aUVI/FfHu3kZrFnp42ySCcNxgK727FiT1dr9B7+DUlfHOcGIBIb/6gTJBZSjPlzJ2ECP3iQTUx9QgltjaMEHfj26Hub+9ZllOvX20L5HEWMj77kPBuShzxpCEtbaXW4= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1725526758; c=relaxed/simple; bh=vcaFOIdSbRcbxirXMecNbLLFLmpbZiVHmVEjjAkDBOk=; h=DKIM-Signature:Message-ID:Date:MIME-Version:Subject:From:To; b=Bmt8puNKpj+6409SGbVAW2dELP+byDiinF3cEb4RbryEOw1qVMMBWVWsLxg3J3W378P6J6MGeEOxXwpTCIqwvebBleVc4kseA1jjPEUpQxrLrgCWSab44zb8yvkS94JfNdPA3AN82lWvTuGG+czirF12UHmKQciemlQTiOWaA20= ARC-Authentication-Results: i=1; server2.sourceware.org Received: by mail-wm1-x330.google.com with SMTP id 5b1f17b1804b1-42bac9469e8so3645085e9.3 for ; Thu, 05 Sep 2024 01:59:11 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=baylibre-com.20230601.gappssmtp.com; s=20230601; t=1725526751; x=1726131551; darn=gcc.gnu.org; h=in-reply-to:content-language:references:to:from:subject:user-agent :mime-version:date:message-id:from:to:cc:subject:date:message-id :reply-to; bh=M+dj8GhlsEdBATBnH+pSI/16j1HXxKSO5RLhGYMQmYc=; b=fmwjMta8SldM5RRnH0rtgquEy/ijXZlcW+5Hjhk3xeW4kVihVnAn28L2pEcgHMMJxC O8pSrAF9s7jWIlP9rnBI+uL7iqZ2DDq3BcyBzM47bxtWZABFLlMRAPaDMn1VZO9A+5WF EyqNQjmYbHWDxADZk5Lux2eMhMhOWYyn/O1Y+VJ6+oL1WmklCkFFXerEbuhH+Tem3gnr TpSm7rHG6aiazoThfDl9fjAGJumFbyPZ+ZtLxoxdvpy4qMSVHJHbtVeE2qpWE9ycxPaF 7qOfUOiSI06AmaINoJHzmsoiYbNBwbcbyOrAiavMZj6CwPZnc/jstP3KeC9d5sNRXhBw Xxkg== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1725526751; x=1726131551; h=in-reply-to:content-language:references:to:from:subject:user-agent :mime-version:date:message-id:x-gm-message-state:from:to:cc:subject :date:message-id:reply-to; bh=M+dj8GhlsEdBATBnH+pSI/16j1HXxKSO5RLhGYMQmYc=; b=fHX5jxpDo4zxmQfBzxwUaBOrUkXB6O9BbtiHphvAyMpS8V3g5rVlf0jIG2/CHTiLcs WfJA6U4ol1osDV1OUR6labGXgzSLLHXGwBQpTi62179TjtOpGbXJzdo+leX5tvLh/cEw GSup/aj2j7RlpxU/dhRj65rZJ3pi0C/mm0LT6k6zZ39EliqVSQamhEXDe9wl4fBp+FtW Yne3lETezdOfKQpLAU5GHiPcsgjk0xf88EfVucKmUixuD92M6XvtZebIf+z+zsW0oQnL JVislxl8B6fD+Z5p4NosNNrZDu5qP+G6gPTtLSrcc6sCHdOWtLxVYnqXz9K6rslDY2Xm /Pgw== X-Gm-Message-State: AOJu0YwEoHCdRGriJDKNPoRF5NxZRmkoUMsel+zFDfyC5FOAolANeGcK m3diE9Agth8zNawymj0+VSvoItGrNOGFUAn4oFjSyXd/WD9iD+NZTE7EErZ/g5rYOyXCbOaFGeR h X-Google-Smtp-Source: AGHT+IFff7wOoZQW9ACo85j9x0LEhszxaITLDAq34liC4Q3kyAIwVk7Mm+/meTJwgth4cUzs5Yg+sg== X-Received: by 2002:a5d:62c3:0:b0:374:b35e:ea6c with SMTP id ffacd0b85a97d-37770c70515mr3456088f8f.40.1725526750414; Thu, 05 Sep 2024 01:59:10 -0700 (PDT) Received: from ?IPV6:2001:16b8:3d1a:600:d68e:ddaa:801:4709? ([2001:16b8:3d1a:600:d68e:ddaa:801:4709]) by smtp.gmail.com with ESMTPSA id ffacd0b85a97d-374c4059811sm12690446f8f.4.2024.09.05.01.59.09 (version=TLS1_3 cipher=TLS_AES_128_GCM_SHA256 bits=128/128); Thu, 05 Sep 2024 01:59:09 -0700 (PDT) Message-ID: <5503a5ef-9e3d-4c2a-a182-0a17eae52b8a@baylibre.com> Date: Thu, 5 Sep 2024 10:59:09 +0200 MIME-Version: 1.0 User-Agent: Mozilla Thunderbird Subject: [patch][v2] Fortran: Add OpenMP 'interop' directive parsing support From: Tobias Burnus To: gcc-patches , Jakub Jelinek , "fortran@gcc.gnu.org" References: <446d61f2-1ab5-406e-88b6-2d5d9a2957b4@baylibre.com> Content-Language: en-US In-Reply-To: <446d61f2-1ab5-406e-88b6-2d5d9a2957b4@baylibre.com> X-Spam-Status: No, score=-13.3 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, GIT_PATCH_0, KAM_SHORT, RCVD_IN_DNSWL_NONE, SPF_HELO_NONE, SPF_PASS, TXREP, T_SCC_BODY_TEXT_LINE 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~patchwork=sourceware.org@gcc.gnu.org Now also supports the following (note the variable name): 'init(targetsync, target)' – and I fixed an ICE when the variable parsing failed. Comments before I commit it? Tobias Tobias Burnus wrote: > This patch adds Fortran parsing support for OpenMP's 'interop' > directive (which stops with a 'sorry' in trans-openmp.cc as the middle > end support is still missing). > > Tested on x86-64-gnu-linux. > > Comments, suggestions, remarks? > > * * * > > Background: > > 'interop' makes it easier to call, e.g., a CUDA-BLAS function directly > as it permits to map an OpenMP device number (→ "target" modifier > required) to the "foreign runtime" device number or to get directly a > stream object (→ if "targetsync" modifier specified) with dependency > tracking. > > Just calling '!$omp interop init(obj)' works but that leaves the > decision which type of object should be returned to the run time. > > Using 'prefer_type', the user can ask for a specific type. Permits is > a string such as "hip" or an integer constant such as > omp_ifr_cuda_driver – and the old-style syntax is 'prefer_type( integer expr|literal string> [ , ...])'.  [Note > thatn a constant integer expression is permitted.] > > The new syntax permits additional attributes like for 'sycl' > requesting an 'in-order' queue (instead of the default 'out-of-order' > queue when obtaining a stream. The new syntax is 'prefer_type( {...} > [, {...} ... } ) where '{ ... }' is a list of either > 'attr("ompx_...")' (i.e. 'attr(...)' with literal string arg that > starts with ompx_ and does not contain a ',') or > 'fr()' where the identifier is an integer > constant. 'fr' can be present or not, but only once per {...} while > multiple 'attr' may be used. [Note that as non-string only an > identifier is permitted (i.e. a integer parameter).] > > I decided for the used way to encode the string – but I am open to > other representations as well. In my WIP/RFC patch is is used as shown > in plugin-*.c in the patch > https://gcc.gnu.org/pipermail/gcc-patches/2024-August/661207.html > > The available foreign runtimes and values that can be returned values > are hidden in that patch and more readable in the documentation patch > at https://gcc.gnu.org/pipermail/gcc-patches/2024-August/661365.html > > If someone wants to delve into the details of the 'interop' feature: > Have a look at OpenMP 5.1 (5.2) *and* TR13 and the additional > definition document at https://www.openmp.org/specifications/ ('hsa': > publishing pending). > > * * * > > Tobias > > PS: In the dump, I am a bit lazy and add spurious tailing ','. As it > is only a dump, I decided adding a bunch of checks to ensure that a > ',' only gets printed if needed is not really required. If you think > otherwise, I can surely add a bunch of 'if' an only print it > conditionally. > > PPS: In order to to use 'interop', mainly the part in middle is > missing, i.e. some middle-end gimplification with a call into libgomp > – and the libgomp function. A stub version of the latter and some > (loosely) tested plugin handling does exist as WIP/RFC patch, see > patch link above. - Besides gimplify and the libgomp function, a bunch > of tests and, obviously, the C and C++ FE counterpart to this patch > have to be implemented. Fortran: Add OpenMP 'interop' directive parsing support Parse OpenMP's 'interop' directive but stop with a 'sorry, unimplemented' after resolving. Additionally, it moves some clause dumping away from the end directive as that lead to 'nowait' not being printed when it should as some cases were missed. gcc/fortran/ChangeLog: * dump-parse-tree.cc (show_omp_namelist): Handle OMP_LIST_INIT. (show_omp_clauses): Handle OMP_LIST_{INIT,USE,DESTORY}; move 'nowait' from end-directive to the directive dump. (show_omp_node, show_code_node): Handle EXEC_OMP_INTEROP. * gfortran.h (enum gfc_statement): Add ST_OMP_INTEROP. (OMP_LIST_INIT, OMP_LIST_USE, OMP_LIST_DESTROY): Add. (enum gfc_exec_op): Add EXEC_OMP_INTEROP. (struct gfc_omp_namelist): Add interop items to union. (gfc_free_omp_namelist): Add boolean arg. * match.cc (gfc_free_omp_namelist): Update to free interop union members. * match.h (gfc_match_omp_interop): New. * openmp.cc (gfc_omp_directives): Uncomment 'interop' entry. (gfc_free_omp_clauses, gfc_match_omp_allocate, gfc_match_omp_flush, gfc_match_omp_clause_reduction): Update call. (enum omp_mask2): Add OMP_CLAUSE_{INIT,USE,DESTROY}. (OMP_INTEROP_CLAUSES): Use it. (gfc_match_omp_clauses): Match those clauses. (gfc_match_omp_prefer_type, gfc_match_omp_init, gfc_match_omp_interop): New. (resolve_omp_clauses): Handle interop clauses. (omp_code_to_statement): Add ST_OMP_INTEROP. (gfc_resolve_omp_directive): Add EXEC_OMP_INTEROP. * parse.cc (decode_omp_directive): Parse 'interop' directive. (next_statement, gfc_ascii_statement): Handle ST_OMP_INTEROP. * st.cc (gfc_free_statement): Likewise * resolve.cc (gfc_resolve_code): Handle EXEC_OMP_INTEROP. * trans.cc (trans_code): Likewise. * trans-openmp.cc (gfc_trans_omp_directive): Print 'sorry' for EXEC_OMP_INTEROP. gcc/testsuite/ChangeLog: * gfortran.dg/gomp/interop-1.f90: New test. * gfortran.dg/gomp/interop-2.f90: New test. * gfortran.dg/gomp/interop-3.f90: New test. gcc/fortran/dump-parse-tree.cc | 61 +++- gcc/fortran/gfortran.h | 17 +- gcc/fortran/match.cc | 13 +- gcc/fortran/match.h | 1 + gcc/fortran/openmp.cc | 412 +++++++++++++++++++++++++-- gcc/fortran/parse.cc | 7 + gcc/fortran/resolve.cc | 1 + gcc/fortran/st.cc | 3 +- gcc/fortran/trans-openmp.cc | 3 + gcc/fortran/trans.cc | 3 +- gcc/testsuite/gfortran.dg/gomp/interop-1.f90 | 62 ++++ gcc/testsuite/gfortran.dg/gomp/interop-2.f90 | 46 +++ gcc/testsuite/gfortran.dg/gomp/interop-3.f90 | 59 ++++ 13 files changed, 651 insertions(+), 37 deletions(-) diff --git a/gcc/fortran/dump-parse-tree.cc b/gcc/fortran/dump-parse-tree.cc index 80aa8ef84e7..0971e6cfee7 100644 --- a/gcc/fortran/dump-parse-tree.cc +++ b/gcc/fortran/dump-parse-tree.cc @@ -1374,6 +1374,8 @@ show_omp_namelist (int list_type, gfc_omp_namelist *n) } ns_iter = n->u2.ns; } + else if (list_type == OMP_LIST_INIT && n != n2) + fputs (") INIT(", dumpfile); if (list_type == OMP_LIST_ALLOCATE) { if (n->u2.allocator) @@ -1525,6 +1527,39 @@ show_omp_namelist (int list_type, gfc_omp_namelist *n) fputs (", ", dumpfile); continue; } + 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->u.init.len) + fputc (')', dumpfile); + fputc (':', dumpfile); + } fprintf (dumpfile, "%s", n->sym ? n->sym->name : "omp_all_memory"); if (list_type == OMP_LIST_LINEAR && n->u.linear.op != OMP_LINEAR_DEFAULT) fputc (')', dumpfile); @@ -1806,11 +1841,12 @@ show_omp_clauses (gfc_omp_clauses *omp_clauses) fputs (" UNTIED", dumpfile); if (omp_clauses->mergeable) fputs (" MERGEABLE", dumpfile); + if (omp_clauses->nowait) + fputs (" NOWAIT", dumpfile); if (omp_clauses->collapse) fprintf (dumpfile, " COLLAPSE(%d)", omp_clauses->collapse); for (list_type = 0; list_type < OMP_LIST_NUM; list_type++) - if (omp_clauses->lists[list_type] != NULL - && list_type != OMP_LIST_COPYPRIVATE) + if (omp_clauses->lists[list_type] != NULL) { const char *type = NULL; switch (list_type) @@ -1855,6 +1891,9 @@ show_omp_clauses (gfc_omp_clauses *omp_clauses) case OMP_LIST_SCAN_IN: type = "INCLUSIVE"; break; case OMP_LIST_SCAN_EX: type = "EXCLUSIVE"; break; case OMP_LIST_USES_ALLOCATORS: type = "USES_ALLOCATORS"; break; + case OMP_LIST_INIT: type = "INIT"; break; + case OMP_LIST_USE: type = "USE"; break; + case OMP_LIST_DESTROY: type = "DESTROY"; break; default: gcc_unreachable (); } @@ -2186,6 +2225,7 @@ show_omp_node (int level, gfc_code *c) case EXEC_OMP_DO_SIMD: name = "DO SIMD"; break; case EXEC_OMP_ERROR: name = "ERROR"; break; case EXEC_OMP_FLUSH: name = "FLUSH"; break; + case EXEC_OMP_INTEROP: name = "INTEROP"; break; case EXEC_OMP_LOOP: name = "LOOP"; break; case EXEC_OMP_MASKED: name = "MASKED"; break; case EXEC_OMP_MASKED_TASKLOOP: name = "MASKED TASKLOOP"; break; @@ -2286,6 +2326,7 @@ show_omp_node (int level, gfc_code *c) case EXEC_OMP_DO: case EXEC_OMP_DO_SIMD: case EXEC_OMP_ERROR: + case EXEC_OMP_INTEROP: case EXEC_OMP_LOOP: case EXEC_OMP_ORDERED: case EXEC_OMP_MASKED: @@ -2379,6 +2420,7 @@ show_omp_node (int level, gfc_code *c) || c->op == EXEC_OMP_TARGET_UPDATE || c->op == EXEC_OMP_TARGET_ENTER_DATA || c->op == EXEC_OMP_TARGET_EXIT_DATA || c->op == EXEC_OMP_SCAN || c->op == EXEC_OMP_DEPOBJ || c->op == EXEC_OMP_ERROR + || c->op == EXEC_OMP_INTEROP || (c->op == EXEC_OMP_ORDERED && c->block == NULL)) return; if (c->op == EXEC_OMP_SECTIONS || c->op == EXEC_OMP_PARALLEL_SECTIONS) @@ -2401,19 +2443,7 @@ show_omp_node (int level, gfc_code *c) fputc ('\n', dumpfile); code_indent (level, 0); fprintf (dumpfile, "!$%s END %s", is_oacc ? "ACC" : "OMP", name); - if (omp_clauses != NULL) - { - if (omp_clauses->lists[OMP_LIST_COPYPRIVATE]) - { - fputs (" COPYPRIVATE(", dumpfile); - show_omp_namelist (OMP_LIST_COPYPRIVATE, - omp_clauses->lists[OMP_LIST_COPYPRIVATE]); - fputc (')', dumpfile); - } - else if (omp_clauses->nowait) - fputs (" NOWAIT", dumpfile); - } - else if (c->op == EXEC_OMP_CRITICAL && c->ext.omp_clauses) + if (c->op == EXEC_OMP_CRITICAL && c->ext.omp_clauses) fprintf (dumpfile, " (%s)", c->ext.omp_clauses->critical_name); } @@ -3529,6 +3559,7 @@ show_code_node (int level, gfc_code *c) case EXEC_OMP_DO: case EXEC_OMP_DO_SIMD: case EXEC_OMP_ERROR: + case EXEC_OMP_INTEROP: case EXEC_OMP_FLUSH: case EXEC_OMP_LOOP: case EXEC_OMP_MASKED: diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 729d811d945..49fb7e9a3e3 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -323,7 +323,7 @@ enum gfc_statement /* Note: gfc_match_omp_nothing returns ST_NONE. */ ST_OMP_NOTHING, ST_NONE, ST_OMP_UNROLL, ST_OMP_END_UNROLL, - ST_OMP_TILE, ST_OMP_END_TILE + ST_OMP_TILE, ST_OMP_END_TILE, ST_OMP_INTEROP }; /* Types of interfaces that we can have. Assignment interfaces are @@ -1381,6 +1381,13 @@ typedef struct gfc_omp_namelist struct gfc_symbol *memspace_sym; bool lastprivate_conditional; bool present_modifier; + struct + { + char *str; + int len; + bool target; + bool targetsync; + } init; } u; union { @@ -1389,6 +1396,7 @@ typedef struct gfc_omp_namelist gfc_expr *allocator; struct gfc_symbol *traits_sym; struct gfc_omp_namelist *duplicate_of; + int *interop_int; } u2; struct gfc_omp_namelist *next; locus where; @@ -1433,6 +1441,9 @@ enum OMP_LIST_HAS_DEVICE_ADDR, OMP_LIST_ENTER, OMP_LIST_USES_ALLOCATORS, + OMP_LIST_INIT, + OMP_LIST_USE, + OMP_LIST_DESTROY, OMP_LIST_NUM /* Must be the last. */ }; @@ -3044,7 +3055,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_UNROLL, EXEC_OMP_TILE, + EXEC_OMP_UNROLL, EXEC_OMP_TILE, EXEC_OMP_INTEROP, EXEC_OMP_ERROR, EXEC_OMP_ALLOCATE, EXEC_OMP_ALLOCATORS }; @@ -3683,7 +3694,7 @@ void gfc_free_iterator (gfc_iterator *, int); void gfc_free_forall_iterator (gfc_forall_iterator *); void gfc_free_alloc_list (gfc_alloc *); void gfc_free_namelist (gfc_namelist *); -void gfc_free_omp_namelist (gfc_omp_namelist *, bool, bool, bool); +void gfc_free_omp_namelist (gfc_omp_namelist *, bool, bool, bool, bool); void gfc_free_equiv (gfc_equiv *); void gfc_free_equiv_until (gfc_equiv *, gfc_equiv *); void gfc_free_data (gfc_data *); diff --git a/gcc/fortran/match.cc b/gcc/fortran/match.cc index 53c54c1c489..423ff859c6a 100644 --- a/gcc/fortran/match.cc +++ b/gcc/fortran/match.cc @@ -5540,10 +5540,11 @@ gfc_free_namelist (gfc_namelist *name) void gfc_free_omp_namelist (gfc_omp_namelist *name, bool free_ns, bool free_align_allocator, - bool free_mem_traits_space) + bool free_mem_traits_space, bool free_init) { gfc_omp_namelist *n; gfc_expr *last_allocator = NULL; + char *last_init_str = NULL; for (; name; name = n) { @@ -5552,6 +5553,7 @@ gfc_free_omp_namelist (gfc_omp_namelist *name, bool free_ns, gfc_free_expr (name->u.align); else if (free_mem_traits_space) { } /* name->u.memspace_sym: shall not call gfc_free_symbol here. */ + if (free_ns) gfc_free_namespace (name->u2.ns); else if (free_align_allocator) @@ -5564,6 +5566,15 @@ gfc_free_omp_namelist (gfc_omp_namelist *name, bool free_ns, } else if (free_mem_traits_space) { } /* name->u2.traits_sym: shall not call gfc_free_symbol here. */ + else if (free_init) + { + if (name->u.init.str != last_init_str) + { + last_init_str = name->u.init.str; + free (name->u.init.str); + free (name->u2.interop_int); + } + } else if (name->u2.udr) { if (name->u2.udr->combiner) diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h index c2b7d69c37c..84d84b81825 100644 --- a/gcc/fortran/match.h +++ b/gcc/fortran/match.h @@ -172,6 +172,7 @@ match gfc_match_omp_do_simd (void); match gfc_match_omp_loop (void); match gfc_match_omp_error (void); match gfc_match_omp_flush (void); +match gfc_match_omp_interop (void); match gfc_match_omp_masked (void); match gfc_match_omp_masked_taskloop (void); match gfc_match_omp_masked_taskloop_simd (void); diff --git a/gcc/fortran/openmp.cc b/gcc/fortran/openmp.cc index 333f0c7fe7f..c04d8b0f528 100644 --- a/gcc/fortran/openmp.cc +++ b/gcc/fortran/openmp.cc @@ -18,6 +18,8 @@ You should have received a copy of the GNU General Public License along with GCC; see the file COPYING3. If not see . */ +#define INCLUDE_VECTOR +#define INCLUDE_STRING #include "config.h" #include "system.h" #include "coretypes.h" @@ -78,7 +80,7 @@ static const struct gfc_omp_directive gfc_omp_directives[] = { /* "error" becomes GFC_OMP_DIR_EXECUTABLE with at(execution) */ {"error", GFC_OMP_DIR_UTILITY, ST_OMP_ERROR}, {"flush", GFC_OMP_DIR_EXECUTABLE, ST_OMP_FLUSH}, - /* {"interop", GFC_OMP_DIR_EXECUTABLE, ST_OMP_INTEROP}, */ + {"interop", GFC_OMP_DIR_EXECUTABLE, ST_OMP_INTEROP}, {"loop", GFC_OMP_DIR_EXECUTABLE, ST_OMP_LOOP}, {"masked", GFC_OMP_DIR_EXECUTABLE, ST_OMP_MASKED}, /* {"metadirective", GFC_OMP_DIR_META, ST_OMP_METADIRECTIVE}, */ @@ -193,7 +195,8 @@ gfc_free_omp_clauses (gfc_omp_clauses *c) gfc_free_omp_namelist (c->lists[i], i == OMP_LIST_AFFINITY || i == OMP_LIST_DEPEND, i == OMP_LIST_ALLOCATE, - i == OMP_LIST_USES_ALLOCATORS); + i == OMP_LIST_USES_ALLOCATORS, + i == OMP_LIST_INIT); gfc_free_expr_list (c->wait_list); gfc_free_expr_list (c->tile_list); gfc_free_expr_list (c->sizes_list); @@ -559,7 +562,7 @@ syntax: gfc_error ("Syntax error in OpenMP variable list at %C"); cleanup: - gfc_free_omp_namelist (head, false, false, false); + gfc_free_omp_namelist (head, false, false, false, false); gfc_current_locus = old_loc; return MATCH_ERROR; } @@ -649,7 +652,7 @@ syntax: gfc_error ("Syntax error in OpenMP variable list at %C"); cleanup: - gfc_free_omp_namelist (head, false, false, false); + gfc_free_omp_namelist (head, false, false, false, false); gfc_current_locus = old_loc; return MATCH_ERROR; } @@ -758,7 +761,7 @@ syntax: gfc_error ("Syntax error in OpenMP SINK dependence-type list at %C"); cleanup: - gfc_free_omp_namelist (head, false, false, false); + gfc_free_omp_namelist (head, false, false, false, false); gfc_current_locus = old_loc; return MATCH_ERROR; } @@ -1106,6 +1109,9 @@ enum omp_mask2 OMP_CLAUSE_FULL, /* OpenMP 5.1. */ OMP_CLAUSE_PARTIAL, /* OpenMP 5.1. */ OMP_CLAUSE_SIZES, /* OpenMP 5.1. */ + OMP_CLAUSE_INIT, /* OpenMP 5.1. */ + OMP_CLAUSE_DESTROY, /* OpenMP 5.1. */ + OMP_CLAUSE_USE, /* OpenMP 5.1. */ /* This must come last. */ OMP_MASK2_LAST }; @@ -1517,7 +1523,7 @@ gfc_match_omp_clause_reduction (char pc, gfc_omp_clauses *c, bool openacc, *head = NULL; gfc_error_now ("!$OMP DECLARE REDUCTION %s not found at %L", buffer, &old_loc); - gfc_free_omp_namelist (n, false, false, false); + gfc_free_omp_namelist (n, false, false, false, false); } else for (n = *head; n; n = n->next) @@ -1808,11 +1814,330 @@ gfc_match_omp_clause_uses_allocators (gfc_omp_clauses *c) return MATCH_YES; error: - gfc_free_omp_namelist (head, false, false, true); + gfc_free_omp_namelist (head, false, false, true, false); return MATCH_ERROR; } +/* Match the 'prefer_type' modifier of the interop 'init' clause: + with either OpenMP 5.1's + prefer_type ( [, ...] + or + prefer_type ( '{' , ...] '}' [, '{' ... '}' ] ) + where 'fr' takes an integer named constant or a string literal + and 'attr takes a string literal, starting with 'ompx_') + +Document string + int format +*/ + +static match +gfc_match_omp_prefer_type (char **pref_str, int *pref_str_len, int **pref_int_array) +{ + gfc_expr *e; + size_t cnt = 0; + std::vector int_list; + std::string pref_string; + /* New syntax. */ + if (gfc_peek_ascii_char () == '{') + do + { + if (gfc_match ("{ ") != MATCH_YES) + { + gfc_error ("Expected %<{%> at %C"); + return MATCH_ERROR; + } + std::string attr; + bool fr_found = false; + do + { + if (gfc_match ("fr ( ") == MATCH_YES) + { + if (fr_found) + { + gfc_error ("Duplicated % preference-selector-name " + "at %C"); + return MATCH_ERROR; + } + fr_found = true; + gfc_symbol *sym = NULL; + locus loc = gfc_current_locus; + if (gfc_match_symbol (&sym, 0) != MATCH_YES + || gfc_match (" _") == MATCH_YES) + { + gfc_current_locus = loc; + if (gfc_match_expr (&e) == MATCH_ERROR) + 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", + &e->where); + gfc_free_expr (e); + 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'; + } + } + 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) + { + gfc_error ("Unexpected null or %<,%> character in " + "character literal at %L", &e->where); + return MATCH_ERROR; + } + attr += str; + attr += '\0'; + } + 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) + break; + gfc_error ("Expected %<,%> or %<}%> at %C"); + return MATCH_ERROR; + } + while (true); + if (!fr_found) + { + pref_string += ' '; + pref_string += '\0'; + } + pref_string += attr; + pref_string += '\0'; + + if (gfc_match (", ") == MATCH_YES) + continue; + if (gfc_match (") ") == MATCH_YES) + break; + gfc_error ("Expected %<,%> or %<)%> at %C"); + return MATCH_ERROR; + } + while (true); + else + do + { + if (gfc_match_expr (&e) != MATCH_YES) + return MATCH_ERROR; + if (!gfc_resolve_expr (e) + || e->expr_type != EXPR_CONSTANT + || (e->ts.type != BT_INTEGER && e->ts.type != BT_CHARACTER) + || (e->ts.type == BT_INTEGER + && !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 constant integer expression or non-empty " + "default-kind character literal at %L", &e->where); + gfc_free_expr (e); + return MATCH_ERROR; + } + 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 += ' '; + } + 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; + } + pref_string += str; + } + pref_string += '\0'; + pref_string += '\0'; + ++cnt; + gfc_free_expr (e); + if (gfc_match (", ") == MATCH_YES) + continue; + if (gfc_match (") ") == MATCH_YES) + break; + gfc_error ("Expected %<,%> or %<)%> at %C"); + 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'; + + *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 ()) + { + *pref_int_array = XNEWVEC (int, cnt); + memcpy (*pref_int_array, int_list.data (), sizeof (int) * cnt); + } + return MATCH_YES; +} + + +/* Match OpenMP 5.1's 'init' clause for 'interop' objects: + init([prefer_type(...)][,][, ...] :] interop-obj-list) */ + +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; + match m; + locus old_loc = gfc_current_locus; + do { + if (gfc_match ("prefer_type ( ") == MATCH_YES) + { + if (pref_str) + { + gfc_error ("Duplicate % modifier at %C"); + return MATCH_ERROR; + } + m = gfc_match_omp_prefer_type (&pref_str, &pref_str_len, + &pref_int_array); + if (m != MATCH_YES) + return m; + if (gfc_match (", ") == MATCH_YES) + continue; + if (gfc_match (": ") == MATCH_YES) + break; + gfc_error ("Expected %<,%> or %<:%> at %C"); + return MATCH_ERROR; + } + if (gfc_match ("targetsync ") == MATCH_YES) + { + targetsync = true; + if (gfc_match (", ") == MATCH_YES) + continue; + if (gfc_match (": ") == MATCH_YES) + break; + gfc_char_t c = gfc_peek_char (); + if (!pref_str + && (c == ')' + || (gfc_current_form != FORM_FREE + && (c == '_' || ISALPHA (c))))) + { + gfc_current_locus = old_loc; + break; + } + gfc_error ("Expected %<,%> or %<:%> at %C"); + return MATCH_ERROR; + } + if (gfc_match ("target ") == MATCH_YES) + { + target = true; + if (gfc_match (", ") == MATCH_YES) + continue; + if (gfc_match (": ") == MATCH_YES) + break; + gfc_char_t c = gfc_peek_char (); + if (!pref_str + && (c == ')' + || (gfc_current_form != FORM_FREE + && (c == '_' || ISALPHA (c))))) + { + gfc_current_locus = old_loc; + break; + } + gfc_error ("Expected %<,%> or %<:%> at %C"); + return MATCH_ERROR; + } + if (pref_str) + { + gfc_error ("Expected % or % at %C"); + return MATCH_ERROR; + } + gfc_current_locus = old_loc; + break; + } + while (true); + + gfc_omp_namelist **head = NULL; + if (gfc_match_omp_variable_list ("", list, false, NULL, &head) != MATCH_YES) + return MATCH_ERROR; + for (gfc_omp_namelist *n = *head; n; n = n->next) + { + 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; + } + return MATCH_YES; +} + + /* Match with duplicate check. Matches 'name'. If expr != NULL, it then matches '(expr)', otherwise, if open_parens is true, it matches a ' ( ' after 'name'. @@ -1934,7 +2259,7 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, if (end_colon && gfc_match (" %e )", &alignment) != MATCH_YES) { - gfc_free_omp_namelist (*head, false, false, false); + gfc_free_omp_namelist (*head, false, false, false, false); gfc_current_locus = old_loc; *head = NULL; break; @@ -2498,6 +2823,11 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, } continue; } + if ((mask & OMP_CLAUSE_DESTROY) + && gfc_match_omp_variable_list ("destroy (", + &c->lists[OMP_LIST_DESTROY], + true) == MATCH_YES) + continue; if ((mask & OMP_CLAUSE_DETACH) && !openacc && !c->detach @@ -2856,6 +3186,14 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, c->indirect = 1; continue; } + if ((mask & OMP_CLAUSE_INIT) + && gfc_match ("init ( ") == MATCH_YES) + { + m = gfc_match_omp_init (&c->lists[OMP_LIST_INIT]); + if (m == MATCH_YES) + continue; + goto error; + } if ((mask & OMP_CLAUSE_IS_DEVICE_PTR) && gfc_match_omp_variable_list ("is_device_ptr (", @@ -2929,7 +3267,7 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, end_colon = true; else if (gfc_match (" )") != MATCH_YES) { - gfc_free_omp_namelist (*head, false, false, false); + gfc_free_omp_namelist (*head, false, false, false, false); gfc_current_locus = old_loc; *head = NULL; break; @@ -2940,7 +3278,7 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, { if (gfc_match (" %e )", &step) != MATCH_YES) { - gfc_free_omp_namelist (*head, false, false, false); + gfc_free_omp_namelist (*head, false, false, false, false); gfc_current_locus = old_loc; *head = NULL; goto error; @@ -3037,7 +3375,7 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, } if (has_error) { - gfc_free_omp_namelist (*head, false, false, false); + gfc_free_omp_namelist (*head, false, false, false, false); *head = NULL; goto error; } @@ -3774,6 +4112,11 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, needs_space = true; continue; } + if ((mask & OMP_CLAUSE_USE) + && gfc_match_omp_variable_list ("use (", + &c->lists[OMP_LIST_USE], + true) == MATCH_YES) + continue; if ((mask & OMP_CLAUSE_USE_DEVICE) && gfc_match_omp_variable_list ("use_device (", &c->lists[OMP_LIST_USE_DEVICE], @@ -4590,6 +4933,9 @@ cleanup: (omp_mask (OMP_CLAUSE_SIZES)) #define OMP_ALLOCATORS_CLAUSES \ omp_mask (OMP_CLAUSE_ALLOCATE) +#define OMP_INTEROP_CLAUSES \ + (omp_mask (OMP_CLAUSE_DEPEND) | OMP_CLAUSE_NOWAIT | OMP_CLAUSE_DEVICE \ + | OMP_CLAUSE_INIT | OMP_CLAUSE_DESTROY | OMP_CLAUSE_USE) static match @@ -4669,7 +5015,7 @@ gfc_match_omp_allocate (void) gfc_error ("Unexpected expression as list item at %L in ALLOCATE " "directive", &n->expr->where); - gfc_free_omp_namelist (vars, false, true, false); + gfc_free_omp_namelist (vars, false, true, false, false); goto error; } @@ -5082,14 +5428,14 @@ gfc_match_omp_flush (void) { gfc_error ("List specified together with memory order clause in FLUSH " "directive at %C"); - gfc_free_omp_namelist (list, false, false, false); + gfc_free_omp_namelist (list, false, false, false, false); gfc_free_omp_clauses (c); return MATCH_ERROR; } if (gfc_match_omp_eos () != MATCH_YES) { gfc_error ("Unexpected junk after $OMP FLUSH statement at %C"); - gfc_free_omp_namelist (list, false, false, false); + gfc_free_omp_namelist (list, false, false, false, false); gfc_free_omp_clauses (c); return MATCH_ERROR; } @@ -5768,6 +6114,14 @@ gfc_ignore_trait_property_extension_list (void) } } + +match +gfc_match_omp_interop (void) +{ + return match_omp (EXEC_OMP_INTEROP, OMP_INTEROP_CLAUSES); +} + + /* OpenMP 5.0: trait-selector: @@ -7618,7 +7972,7 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, "DEVICE_RESIDENT", "LINK", "USE_DEVICE", "CACHE", "IS_DEVICE_PTR", "USE_DEVICE_PTR", "USE_DEVICE_ADDR", "NONTEMPORAL", "ALLOCATE", "HAS_DEVICE_ADDR", "ENTER", - "USES_ALLOCATORS" }; + "USES_ALLOCATORS", "INIT", "USE", "DESTROY" }; STATIC_ASSERT (ARRAY_SIZE (clause_names) == OMP_LIST_NUM); if (omp_clauses == NULL) @@ -8001,6 +8355,29 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, } } + if (code + && code->op == EXEC_OMP_INTEROP + && omp_clauses->lists[OMP_LIST_DEPEND]) + { + if (!omp_clauses->lists[OMP_LIST_INIT] + && !omp_clauses->lists[OMP_LIST_USE] + && !omp_clauses->lists[OMP_LIST_DESTROY]) + { + gfc_error ("DEPEND clause at %L requires action clause with " + "% interop-type", + &omp_clauses->lists[OMP_LIST_DEPEND]->where); + } + for (n = omp_clauses->lists[OMP_LIST_INIT]; n; n = n->next) + if (!n->u.init.targetsync) + { + gfc_error ("DEPEND clause at %L requires % " + "interop-type, lacking it for %qs at %L", + &omp_clauses->lists[OMP_LIST_DEPEND]->where, + n->sym->name, &n->where); + break; + } + } + /* Detect specifically the case where we have "map(x) private(x)" and raise an error. If we have "...simd" combined directives though, the "private" applies to the simd part, so this is permitted though. */ @@ -8130,7 +8507,7 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, { prev->next = n->next; n->next = NULL; - gfc_free_omp_namelist (n, false, true, false); + gfc_free_omp_namelist (n, false, true, false, false); n = prev->next; } continue; @@ -11283,6 +11660,8 @@ omp_code_to_statement (gfc_code *code) return ST_OMP_ERROR; case EXEC_OMP_FLUSH: return ST_OMP_FLUSH; + case EXEC_OMP_INTEROP: + return ST_OMP_INTEROP; case EXEC_OMP_DISTRIBUTE: return ST_OMP_DISTRIBUTE; case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: @@ -11841,6 +12220,7 @@ gfc_resolve_omp_directive (gfc_code *code, gfc_namespace *ns) case EXEC_OMP_ASSUME: case EXEC_OMP_CANCEL: case EXEC_OMP_ERROR: + case EXEC_OMP_INTEROP: case EXEC_OMP_MASKED: case EXEC_OMP_ORDERED: case EXEC_OMP_PARALLEL_WORKSHARE: diff --git a/gcc/fortran/parse.cc b/gcc/fortran/parse.cc index a814b7910d3..c506e18233e 100644 --- a/gcc/fortran/parse.cc +++ b/gcc/fortran/parse.cc @@ -1165,6 +1165,9 @@ decode_omp_directive (void) case 'f': matcho ("flush", gfc_match_omp_flush, ST_OMP_FLUSH); break; + case 'i': + matcho ("interop", gfc_match_omp_interop, ST_OMP_INTEROP); + break; case 'm': matcho ("masked taskloop simd", gfc_match_omp_masked_taskloop_simd, ST_OMP_MASKED_TASKLOOP_SIMD); @@ -1881,6 +1884,7 @@ next_statement (void) case ST_OMP_CANCEL: case ST_OMP_CANCELLATION_POINT: case ST_OMP_DEPOBJ: \ case ST_OMP_TARGET_UPDATE: case ST_OMP_TARGET_ENTER_DATA: \ case ST_OMP_TARGET_EXIT_DATA: case ST_OMP_ORDERED_DEPEND: case ST_OMP_ERROR: \ + case ST_OMP_INTEROP: \ case ST_ERROR_STOP: case ST_OMP_SCAN: case ST_SYNC_ALL: \ case ST_SYNC_IMAGES: case ST_SYNC_MEMORY: case ST_LOCK: case ST_UNLOCK: \ case ST_FORM_TEAM: case ST_CHANGE_TEAM: \ @@ -2810,6 +2814,9 @@ gfc_ascii_statement (gfc_statement st, bool strip_sentinel) case ST_OMP_FLUSH: p = "!$OMP FLUSH"; break; + case ST_OMP_INTEROP: + p = "!$OMP INTEROP"; + break; case ST_OMP_LOOP: p = "!$OMP LOOP"; break; diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc index a78e9b7daf7..2a841313db9 100644 --- a/gcc/fortran/resolve.cc +++ b/gcc/fortran/resolve.cc @@ -13237,6 +13237,7 @@ start: case EXEC_OMP_DO: case EXEC_OMP_DO_SIMD: case EXEC_OMP_ERROR: + case EXEC_OMP_INTEROP: case EXEC_OMP_LOOP: case EXEC_OMP_MASTER: case EXEC_OMP_MASTER_TASKLOOP: diff --git a/gcc/fortran/st.cc b/gcc/fortran/st.cc index 0218d290782..904b0008070 100644 --- a/gcc/fortran/st.cc +++ b/gcc/fortran/st.cc @@ -229,6 +229,7 @@ gfc_free_statement (gfc_code *p) case EXEC_OMP_DO: case EXEC_OMP_DO_SIMD: case EXEC_OMP_ERROR: + case EXEC_OMP_INTEROP: case EXEC_OMP_LOOP: case EXEC_OMP_END_SINGLE: case EXEC_OMP_MASKED_TASKLOOP: @@ -290,7 +291,7 @@ gfc_free_statement (gfc_code *p) break; case EXEC_OMP_FLUSH: - gfc_free_omp_namelist (p->ext.omp_namelist, false, false, false); + gfc_free_omp_namelist (p->ext.omp_namelist, false, false, false, false); break; case EXEC_OMP_BARRIER: diff --git a/gcc/fortran/trans-openmp.cc b/gcc/fortran/trans-openmp.cc index df1bf144e23..3a335ade0f7 100644 --- a/gcc/fortran/trans-openmp.cc +++ b/gcc/fortran/trans-openmp.cc @@ -8358,6 +8358,9 @@ gfc_trans_omp_directive (gfc_code *code) return gfc_trans_omp_teams (code, NULL, NULL_TREE); case EXEC_OMP_WORKSHARE: return gfc_trans_omp_workshare (code, code->ext.omp_clauses); + case EXEC_OMP_INTEROP: + sorry ("%"); + return build_empty_stmt (input_location); default: gcc_unreachable (); } diff --git a/gcc/fortran/trans.cc b/gcc/fortran/trans.cc index ce4618562b7..da6c2543612 100644 --- a/gcc/fortran/trans.cc +++ b/gcc/fortran/trans.cc @@ -2606,9 +2606,10 @@ trans_code (gfc_code * code, tree cond) case EXEC_OMP_DISTRIBUTE_SIMD: case EXEC_OMP_DO: case EXEC_OMP_DO_SIMD: - case EXEC_OMP_LOOP: case EXEC_OMP_ERROR: case EXEC_OMP_FLUSH: + case EXEC_OMP_INTEROP: + case EXEC_OMP_LOOP: case EXEC_OMP_MASKED: case EXEC_OMP_MASKED_TASKLOOP: case EXEC_OMP_MASKED_TASKLOOP_SIMD: diff --git a/gcc/testsuite/gfortran.dg/gomp/interop-1.f90 b/gcc/testsuite/gfortran.dg/gomp/interop-1.f90 new file mode 100644 index 00000000000..bbb1dea1be6 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/interop-1.f90 @@ -0,0 +1,62 @@ +module m + use iso_c_binding + implicit none + + ! The following definitions are in omp_lib, which cannot be included + ! in gcc/testsuite/ + integer, parameter :: omp_interop_kind = c_intptr_t + integer, parameter :: omp_interop_fr_kind = c_int + + integer (omp_interop_kind), parameter :: omp_interop_none = 0_omp_interop_kind + integer (omp_interop_fr_kind), parameter :: omp_ifr_cuda = 1 + integer (omp_interop_fr_kind), parameter :: omp_ifr_cuda_driver = 2 + integer (omp_interop_fr_kind), parameter :: omp_ifr_opencl = 3 + integer (omp_interop_fr_kind), parameter :: omp_ifr_sycl = 4 + integer (omp_interop_fr_kind), parameter :: omp_ifr_hip = 5 + integer (omp_interop_fr_kind), parameter :: omp_ifr_level_zero = 6 + integer (omp_interop_fr_kind), parameter :: omp_ifr_hsa = 7 +end module m + +subroutine sub1 + !$omp interop + integer :: y ! { dg-error "Unexpected data declaration statement" } +end subroutine sub1 + +program main +use m +implicit none + +!$omp requires reverse_offload + +integer(omp_interop_kind) :: obj1, obj2, obj3, obj4, obj5 +integer :: x + +!$omp interop init(obj1) init(target,targetsync,target,targetsync : obj2, obj3) nowait + +!$omp interop init(prefer_type("cu"//"da", omp_ifr_opencl, omp_ifr_level_zero, "hsa"), targetsync : obj1) & +!$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 end assume + +!$omp interop init(prefer_type("cu"//char(0)//"da") : obj3) ! { dg-error "Unexpected null character in character literal" } + +!$omp interop depend(inout: x) , use(obj2), destroy(obj3) ! OK, use or destory might have 'targetsync' + +!$omp interop depend(inout: x) use(obj2), destroy(obj3) ! Likewise + +!$omp interop depend(inout: x) init(targetsync : obj5) use(obj2), destroy(obj3) init(prefer_type("cuda"), targetsync : obj4) ! OK + +!$omp interop init ( target , prefer_type( { fr("hsa") }, "hip") : obj1) ! { dg-error "Expected '\{' at .1." } + +!$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( {fr(c_char_"cuda") }) : obj1) ! OK +!$omp interop init ( prefer_type( {fr(1_"cuda") }) : obj1) ! OK + +end diff --git a/gcc/testsuite/gfortran.dg/gomp/interop-2.f90 b/gcc/testsuite/gfortran.dg/gomp/interop-2.f90 new file mode 100644 index 00000000000..c7673a662d0 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/interop-2.f90 @@ -0,0 +1,46 @@ +module m + use iso_c_binding + implicit none + + ! The following definitions are in omp_lib, which cannot be included + ! in gcc/testsuite/ + integer, parameter :: omp_interop_kind = c_intptr_t + integer, parameter :: omp_interop_fr_kind = c_int + + integer (omp_interop_kind), parameter :: omp_interop_none = 0_omp_interop_kind + integer (omp_interop_fr_kind), parameter :: omp_ifr_cuda = 1 + integer (omp_interop_fr_kind), parameter :: omp_ifr_cuda_driver = 2 + integer (omp_interop_fr_kind), parameter :: omp_ifr_opencl = 3 + integer (omp_interop_fr_kind), parameter :: omp_ifr_sycl = 4 + integer (omp_interop_fr_kind), parameter :: omp_ifr_hip = 5 + integer (omp_interop_fr_kind), parameter :: omp_ifr_level_zero = 6 + integer (omp_interop_fr_kind), parameter :: omp_ifr_hsa = 7 +end module m + +program main +use m +implicit none + +!$omp requires reverse_offload + +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_"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_'" } +!$omp interop init ( prefer_type( {fr(1_"hip") , attr("ompx_option") , attr("ompx_") } ) : obj1) +!$omp interop init ( prefer_type( {fr(1_"hip") , attr("ompx_option") }, { attr("ompx_") } ) : obj1) +!$omp interop init ( prefer_type( {fr(1_"hip") , attr("ompx_option") } { attr("ompx_") } ) : obj1) ! { dg-error "Expected ',' or '\\)'" } +!$omp interop init ( prefer_type( {fr(1_"hip") , attr("ompx_option") ) : obj1) ! { dg-error "Expected ',' or '\}'" } + +!$omp interop init ( prefer_type( {fr(1_"hip") attr("ompx_option") ) : obj1) ! { dg-error "Expected ',' or '\}'" } +!$omp interop init ( prefer_type( {fr(1_"hip")}), prefer_type("cuda") : obj1) ! { dg-error "Duplicate 'prefer_type' modifier" } + +!$omp interop init ( prefer_type( {attr("ompx_option1,ompx_option2") ) : obj1) ! { dg-error "Unexpected null or ',' character in character literal" } + +!$omp interop init ( targetsync other ) : obj1) ! { dg-error "Expected ',' or ':'" } +!$omp interop init ( prefer_type( {fr(1_"cuda") } ), other : obj1) ! { dg-error "Expected 'target' or 'targetsync'" } +!$omp interop init ( prefer_type( {fr(1_"cuda") } ), obj1) ! { dg-error "Expected 'target' or 'targetsync'" } +end diff --git a/gcc/testsuite/gfortran.dg/gomp/interop-3.f90 b/gcc/testsuite/gfortran.dg/gomp/interop-3.f90 new file mode 100644 index 00000000000..a6d2cc460fb --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/interop-3.f90 @@ -0,0 +1,59 @@ +module m + use iso_c_binding + implicit none + + ! The following definitions are in omp_lib, which cannot be included + ! in gcc/testsuite/ + integer, parameter :: omp_interop_kind = c_intptr_t + integer, parameter :: omp_interop_fr_kind = c_int + + integer (omp_interop_kind), parameter :: omp_interop_none = 0_omp_interop_kind + integer (omp_interop_fr_kind), parameter :: omp_ifr_cuda = 1 + integer (omp_interop_fr_kind), parameter :: omp_ifr_cuda_driver = 2 + integer (omp_interop_fr_kind), parameter :: omp_ifr_opencl = 3 + integer (omp_interop_fr_kind), parameter :: omp_ifr_sycl = 4 + integer (omp_interop_fr_kind), parameter :: omp_ifr_hip = 5 + integer (omp_interop_fr_kind), parameter :: omp_ifr_level_zero = 6 + integer (omp_interop_fr_kind), parameter :: omp_ifr_hsa = 7 +end module m + +program main +use m +implicit none + +!$omp requires reverse_offload + +integer(omp_interop_kind) :: obj1, obj2, obj3, obj4, obj5 +integer(omp_interop_kind) :: target, targetsync,prefer_type +integer :: x + +!$omp interop init(obj1) init(target,targetsync,target,targetsync : obj2, obj3) nowait + +!$omp interop init(prefer_type("cu"//"da", omp_ifr_opencl, omp_ifr_level_zero, "hsa"), targetsync : obj1) & +!$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 end assume + +!$omp interop init(obj1, obj2, obj1), use(obj4) destroy(obj4) +! { dg-error "Symbol 'obj1' present on multiple clauses" "" { target *-*-* } .-1 } +! { dg-error "Symbol 'obj4' present on multiple clauses" "" { target *-*-* } .-2 } + +!$omp interop depend(inout: x) ! { dg-error "DEPEND clause at .1. requires action clause with 'targetsync' interop-type" } + +!$omp interop depend(inout: x) , use(obj2), destroy(obj3) ! OK, use or destory might have 'targetsync' + +!$omp interop depend(inout: x) use(obj2), destroy(obj3) ! Likewise + +!$omp interop depend(inout: x) use(obj2), destroy(obj3) init(obj4) ! { dg-error "DEPEND clause at .1. requires 'targetsync' interop-type, lacking it for 'obj4' at .2." } + +!$omp interop depend(inout: x) init(targetsync : obj5) use(obj2), destroy(obj3) init(obj4) ! { dg-error "DEPEND clause at .1. requires 'targetsync' interop-type, lacking it for 'obj4' at .2." } +!$omp interop depend(inout: x) init(targetsync : obj5) use(obj2), destroy(obj3) init(prefer_type("cuda"), targetsync : obj4) ! OK + +!$omp interop init(target, targetsync, prefer_type, obj1) +!$omp interop init(prefer_type, obj1, target, targetsync) +!$omp interop init(target, targetsync,target) ! { dg-error "Symbol 'target' present on multiple clauses" } + +!$omp interop init(, targetsync, prefer_type, obj1, target) ! { dg-error "Syntax error in OpenMP variable list" } +end