From patchwork Wed Oct 2 16:55:37 2024 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Paul-Antoine Arras X-Patchwork-Id: 1992104 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=b12jeXRF; 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 4XJgwY0NHJz1xtY for ; Thu, 3 Oct 2024 02:57:49 +1000 (AEST) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id D92AD384BC07 for ; Wed, 2 Oct 2024 16:57:46 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-wr1-x42b.google.com (mail-wr1-x42b.google.com [IPv6:2a00:1450:4864:20::42b]) by sourceware.org (Postfix) with ESMTPS id EB7F73858427 for ; Wed, 2 Oct 2024 16:56:02 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org EB7F73858427 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 EB7F73858427 Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=2a00:1450:4864:20::42b ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1727888174; cv=none; b=PJTrsNpSHTDaF5V/uYHI9hWFZxMi37t1XgwytX9eyQIizeH2feLIzIM8gjN/Gh28uuZlMLnA+zXQfH0EPXtpi6shsaaUDNuARlqxT9RNxKPUPekR0JA9OGfA/fYgBqi1EF6bQQTfVpfOmFXSEJJkAcYbhHmXJfhFSDByKBAkJIk= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1727888174; c=relaxed/simple; bh=NbTvfFL+66EWlNcUoq4ZwDgSsEN7gysg7oPqhcPtRwE=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=PccehDMdgbHjzNnQTL7wGglTueQQw2muvQGxemJdeJCDh5a2VQ2meGpKskmDsP/XBU2CRfYdROJ4nRKTu98Ajy5ulzByFJB/Ah7DEEoV44BUu6PHwCxmm1O+TuTrCiWPJAahI6AVOdiDCXJ39Ve3uVO5jvarlpKFcFI6aDE5xj8= ARC-Authentication-Results: i=1; server2.sourceware.org Received: by mail-wr1-x42b.google.com with SMTP id ffacd0b85a97d-37cd831ab06so34382f8f.0 for ; Wed, 02 Oct 2024 09:56:02 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=baylibre-com.20230601.gappssmtp.com; s=20230601; t=1727888161; x=1728492961; darn=gcc.gnu.org; h=content-transfer-encoding:mime-version:references:in-reply-to :message-id:date:subject:cc:to:from:from:to:cc:subject:date :message-id:reply-to; bh=uF85pIc7yYFlZo+WaETKtRa5odwPXkfCqSnfdszsWII=; b=b12jeXRFCsOkTVjId5u0e5oPbSC6E7QEnIZoLZ8u1WtMU8we3xP6S4rWX0RUhGAUxe JBy77fV4qSjgAOxU2fVbDCBBVxz60dJBimAypZdKgoTigs/o0FGqxTCzXVlwvIt2rMmI H2rqleybkTePibzTi5W/jHu8dmyx6eoWNSCWNTAav46r/pzPumLxWHE51ili8bTevK5o Dc+hsDb6dXJtTlYhMbZLMka8hQoowanvivtP7Q2EDsOn54HF40UsHs2dxeFW08u3QVTq UTsBRndKTBrvxmqtqAAUoc7mvWzfKU//WeVENUgERrGbUSvVj0X6yMg7S2AWxKz+ongm Z3ww== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1727888161; x=1728492961; h=content-transfer-encoding:mime-version:references:in-reply-to :message-id:date:subject:cc:to:from:x-gm-message-state:from:to:cc :subject:date:message-id:reply-to; bh=uF85pIc7yYFlZo+WaETKtRa5odwPXkfCqSnfdszsWII=; b=rbse2F9W9j8hXBzZC3UkwNqGxRDcCGLpn/F8sSQ6FCSaRW98XcPFV3B+2Zhs6TWnF9 seDQdCqYxlSdKRrlW9Dzxu8JPAXmkLKL+IAXLUlgVB9SpRHQDRNd4ZGTzSTW70+jszgS p4/VB06ftbDPyJDP/V1rV669RLKivEh0je3Xu3/jSiDFIbrseE920hynXV6oRNXi0Mmw 1+1u3blWQT/UIEhMxrukj6vzLP/ydcLeiONbGvkb/K87M52RgMVmvZuz951ZGpdPzP9H F+3aXAJN0b9WRdFyH1qIkh7gzz/hBB4EwpvGbOUrWJQz71lPA7ip3UmVobR/3CAo7boQ 25rQ== X-Gm-Message-State: AOJu0YzW2JXUinsa7NRiZxVgCRSjkv56Z6X+/HVSA3OgC1xewT3Toq1u BSy5PYWGfzTe3LqvZYGZt7XNtOP/kruQH0muEEWsMhh9P8r7aKaQ84TH/H0mg4ok0mGFIQ7nwFc A X-Google-Smtp-Source: AGHT+IEnKSpBAKagdHClcWvlSKTBOhg+tlF9dwjo3HE/bHqXL6G0DUrEiUTxVlIlHNaR8Hz3xBcHRg== X-Received: by 2002:adf:f785:0:b0:374:bb32:656c with SMTP id ffacd0b85a97d-37cfb9f9df6mr2324535f8f.39.1727888160445; Wed, 02 Oct 2024 09:56:00 -0700 (PDT) Received: from localhost.localdomain (2a01cb0018c22f0003fd7af961426ad9.ipv6.abo.wanadoo.fr. [2a01:cb00:18c2:2f00:3fd:7af9:6142:6ad9]) by smtp.gmail.com with ESMTPSA id ffacd0b85a97d-37cd575de73sm14244859f8f.115.2024.10.02.09.55.59 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Wed, 02 Oct 2024 09:56:00 -0700 (PDT) From: Paul-Antoine Arras To: gcc-patches@gcc.gnu.org Cc: Paul-Antoine Arras Subject: [PATCH v4 6/7] OpenMP: Fortran front-end support for dispatch + adjust_args Date: Wed, 2 Oct 2024 18:55:37 +0200 Message-ID: <20241002165538.3237107-7-parras@baylibre.com> X-Mailer: git-send-email 2.45.2 In-Reply-To: <20241002165538.3237107-1-parras@baylibre.com> References: <20241002165538.3237107-1-parras@baylibre.com> MIME-Version: 1.0 X-Spam-Status: No, score=-13.0 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 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 adds support for the `dispatch` construct and the `adjust_args` clause to the Fortran front-end. Handling of `adjust_args` across translation units is missing due to PR115271. gcc/fortran/ChangeLog: * dump-parse-tree.cc (show_omp_clauses): Handle novariants and nocontext clauses. (show_omp_node): Handle EXEC_OMP_DISPATCH. (show_code_node): Likewise. * frontend-passes.cc (gfc_code_walker): Handle novariants and nocontext. * gfortran.h (enum gfc_statement): Add ST_OMP_DISPATCH. (symbol_attribute): Add omp_declare_variant_need_device_ptr. (gfc_omp_clauses): Add novariants and nocontext. (gfc_omp_declare_variant): Add need_device_ptr_arg_list. (enum gfc_exec_op): Add EXEC_OMP_DISPATCH. * match.h (gfc_match_omp_dispatch): Declare. * openmp.cc (gfc_free_omp_clauses): Free novariants and nocontext clauses. (gfc_free_omp_declare_variant_list): Free need_device_ptr_arg_list namelist. (enum omp_mask2): Add OMP_CLAUSE_NOVARIANTS and OMP_CLAUSE_NOCONTEXT. (gfc_match_omp_clauses): Handle OMP_CLAUSE_NOVARIANTS and OMP_CLAUSE_NOCONTEXT. (OMP_DISPATCH_CLAUSES): Define. (gfc_match_omp_dispatch): New function. (gfc_match_omp_declare_variant): Parse adjust_args. (resolve_omp_clauses): Handle adjust_args, novariants and nocontext. Adjust handling of OMP_LIST_IS_DEVICE_PTR. (icode_code_error_callback): Handle EXEC_OMP_DISPATCH. (omp_code_to_statement): Likewise. (resolve_omp_dispatch): New function. (gfc_resolve_omp_directive): Handle EXEC_OMP_DISPATCH. * parse.cc (decode_omp_directive): Match dispatch. (next_statement): Handle ST_OMP_DISPATCH. (gfc_ascii_statement): Likewise. (parse_omp_dispatch): New function. (parse_executable): Handle ST_OMP_DISPATCH. * resolve.cc (gfc_resolve_blocks): Handle EXEC_OMP_DISPATCH. * st.cc (gfc_free_statement): Likewise. * trans-decl.cc (create_function_arglist): Declare. (gfc_get_extern_function_decl): Call it. * trans-openmp.cc (gfc_trans_omp_clauses): Handle novariants and nocontext. (replace_omp_dispatch_call): New function. (gfc_trans_omp_dispatch): New function. (gfc_trans_omp_directive): Handle EXEC_OMP_DISPATCH. (gfc_trans_omp_declare_variant): Handle adjust_args. * trans.cc (trans_code): Handle EXEC_OMP_DISPATCH:. gcc/testsuite/ChangeLog: * gfortran.dg/gomp/declare-variant-2.f90: Update dg-error. * gfortran.dg/gomp/declare-variant-21.f90: New test (xfail). * gfortran.dg/gomp/declare-variant-21-aux.f90: New test. * gfortran.dg/gomp/adjust-args-1.f90: New test. * gfortran.dg/gomp/adjust-args-2.f90: New test. * gfortran.dg/gomp/adjust-args-3.f90: New test. * gfortran.dg/gomp/adjust-args-4.f90: New test. * gfortran.dg/gomp/adjust-args-5.f90: New test. * gfortran.dg/gomp/dispatch-1.f90: New test. * gfortran.dg/gomp/dispatch-2.f90: New test. * gfortran.dg/gomp/dispatch-3.f90: New test. * gfortran.dg/gomp/dispatch-4.f90: New test. * gfortran.dg/gomp/dispatch-5.f90: New test. * gfortran.dg/gomp/dispatch-6.f90: New test. * gfortran.dg/gomp/dispatch-7.f90: New test. * gfortran.dg/gomp/dispatch-8.f90: New test. * gfortran.dg/gomp/dispatch-9.f90: New test. * gfortran.dg/gomp/dispatch-10.f90: New test. --- gcc/fortran/dump-parse-tree.cc | 17 ++ gcc/fortran/frontend-passes.cc | 2 + gcc/fortran/gfortran.h | 12 +- gcc/fortran/match.h | 1 + gcc/fortran/openmp.cc | 195 +++++++++++++++-- gcc/fortran/parse.cc | 51 ++++- gcc/fortran/resolve.cc | 2 + gcc/fortran/st.cc | 1 + gcc/fortran/trans-decl.cc | 9 +- gcc/fortran/trans-openmp.cc | 197 ++++++++++++++++++ gcc/fortran/trans.cc | 1 + .../gfortran.dg/gomp/adjust-args-1.f90 | 58 ++++++ .../gfortran.dg/gomp/adjust-args-2.f90 | 18 ++ .../gfortran.dg/gomp/adjust-args-3.f90 | 27 +++ .../gfortran.dg/gomp/adjust-args-4.f90 | 58 ++++++ .../gfortran.dg/gomp/adjust-args-5.f90 | 58 ++++++ .../gfortran.dg/gomp/declare-variant-2.f90 | 6 +- .../gomp/declare-variant-21-aux.f90 | 25 +++ .../gfortran.dg/gomp/declare-variant-21.f90 | 22 ++ gcc/testsuite/gfortran.dg/gomp/dispatch-1.f90 | 77 +++++++ .../gfortran.dg/gomp/dispatch-10.f90 | 21 ++ gcc/testsuite/gfortran.dg/gomp/dispatch-2.f90 | 79 +++++++ gcc/testsuite/gfortran.dg/gomp/dispatch-3.f90 | 39 ++++ gcc/testsuite/gfortran.dg/gomp/dispatch-4.f90 | 19 ++ gcc/testsuite/gfortran.dg/gomp/dispatch-5.f90 | 25 +++ gcc/testsuite/gfortran.dg/gomp/dispatch-6.f90 | 39 ++++ gcc/testsuite/gfortran.dg/gomp/dispatch-7.f90 | 26 +++ gcc/testsuite/gfortran.dg/gomp/dispatch-8.f90 | 33 +++ gcc/testsuite/gfortran.dg/gomp/dispatch-9.f90 | 24 +++ 29 files changed, 1121 insertions(+), 21 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/gomp/adjust-args-1.f90 create mode 100644 gcc/testsuite/gfortran.dg/gomp/adjust-args-2.f90 create mode 100644 gcc/testsuite/gfortran.dg/gomp/adjust-args-3.f90 create mode 100644 gcc/testsuite/gfortran.dg/gomp/adjust-args-4.f90 create mode 100644 gcc/testsuite/gfortran.dg/gomp/adjust-args-5.f90 create mode 100644 gcc/testsuite/gfortran.dg/gomp/declare-variant-21-aux.f90 create mode 100644 gcc/testsuite/gfortran.dg/gomp/declare-variant-21.f90 create mode 100644 gcc/testsuite/gfortran.dg/gomp/dispatch-1.f90 create mode 100644 gcc/testsuite/gfortran.dg/gomp/dispatch-10.f90 create mode 100644 gcc/testsuite/gfortran.dg/gomp/dispatch-2.f90 create mode 100644 gcc/testsuite/gfortran.dg/gomp/dispatch-3.f90 create mode 100644 gcc/testsuite/gfortran.dg/gomp/dispatch-4.f90 create mode 100644 gcc/testsuite/gfortran.dg/gomp/dispatch-5.f90 create mode 100644 gcc/testsuite/gfortran.dg/gomp/dispatch-6.f90 create mode 100644 gcc/testsuite/gfortran.dg/gomp/dispatch-7.f90 create mode 100644 gcc/testsuite/gfortran.dg/gomp/dispatch-8.f90 create mode 100644 gcc/testsuite/gfortran.dg/gomp/dispatch-9.f90 diff --git a/gcc/fortran/dump-parse-tree.cc b/gcc/fortran/dump-parse-tree.cc index 3547d7f8aca..23586c09808 100644 --- a/gcc/fortran/dump-parse-tree.cc +++ b/gcc/fortran/dump-parse-tree.cc @@ -2222,6 +2222,18 @@ show_omp_clauses (gfc_omp_clauses *omp_clauses) } fputc (')', dumpfile); } + if (omp_clauses->novariants) + { + fputs (" NOVARIANTS(", dumpfile); + show_expr (omp_clauses->novariants); + fputc (')', dumpfile); + } + if (omp_clauses->nocontext) + { + fputs (" NOCONTEXT(", dumpfile); + show_expr (omp_clauses->nocontext); + fputc (')', dumpfile); + } } /* Show a single OpenMP or OpenACC directive node and everything underneath it @@ -2259,6 +2271,9 @@ show_omp_node (int level, gfc_code *c) case EXEC_OMP_CANCEL: name = "CANCEL"; break; case EXEC_OMP_CANCELLATION_POINT: name = "CANCELLATION POINT"; break; case EXEC_OMP_CRITICAL: name = "CRITICAL"; break; + case EXEC_OMP_DISPATCH: + name = "DISPATCH"; + break; case EXEC_OMP_DISTRIBUTE: name = "DISTRIBUTE"; break; case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: name = "DISTRIBUTE PARALLEL DO"; break; @@ -2363,6 +2378,7 @@ show_omp_node (int level, gfc_code *c) case EXEC_OMP_ASSUME: case EXEC_OMP_CANCEL: case EXEC_OMP_CANCELLATION_POINT: + case EXEC_OMP_DISPATCH: case EXEC_OMP_DISTRIBUTE: case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: @@ -3596,6 +3612,7 @@ show_code_node (int level, gfc_code *c) case EXEC_OMP_BARRIER: case EXEC_OMP_CRITICAL: case EXEC_OMP_DEPOBJ: + case EXEC_OMP_DISPATCH: case EXEC_OMP_DISTRIBUTE: case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: diff --git a/gcc/fortran/frontend-passes.cc b/gcc/fortran/frontend-passes.cc index c7cb9d2a389..337c244cc17 100644 --- a/gcc/fortran/frontend-passes.cc +++ b/gcc/fortran/frontend-passes.cc @@ -5617,6 +5617,8 @@ gfc_code_walker (gfc_code **c, walk_code_fn_t codefn, walk_expr_fn_t exprfn, WALK_SUBEXPR (co->ext.omp_clauses->num_tasks); WALK_SUBEXPR (co->ext.omp_clauses->priority); WALK_SUBEXPR (co->ext.omp_clauses->detach); + WALK_SUBEXPR (co->ext.omp_clauses->novariants); + WALK_SUBEXPR (co->ext.omp_clauses->nocontext); for (idx = 0; idx < ARRAY_SIZE (list_types); idx++) for (n = co->ext.omp_clauses->lists[list_types[idx]]; n; n = n->next) diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 917866a7ef0..51d87f90746 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -324,7 +324,8 @@ 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_INTEROP + ST_OMP_TILE, ST_OMP_END_TILE, ST_OMP_INTEROP, ST_OMP_DISPATCH, + ST_OMP_END_DISPATCH }; /* Types of interfaces that we can have. Assignment interfaces are @@ -1012,6 +1013,9 @@ typedef struct ENUM_BITFIELD (gfc_omp_device_type) omp_device_type:2; unsigned omp_allocate:1; + /* Mentioned in OMP DECLARE VARIANT. */ + // unsigned omp_declare_variant_need_device_ptr : 1; + /* Mentioned in OACC DECLARE. */ unsigned oacc_declare_create:1; unsigned oacc_declare_copyin:1; @@ -1450,6 +1454,7 @@ enum OMP_LIST_INIT, OMP_LIST_USE, OMP_LIST_DESTROY, + OMP_LIST_ADJUST_ARGS, OMP_LIST_NUM /* Must be the last. */ }; @@ -1597,6 +1602,8 @@ typedef struct gfc_omp_clauses struct gfc_expr *depobj; struct gfc_expr *dist_chunk_size; struct gfc_expr *message; + struct gfc_expr *novariants; + struct gfc_expr *nocontext; struct gfc_omp_assumptions *assume; struct gfc_expr_list *sizes_list; const char *critical_name; @@ -1726,6 +1733,7 @@ typedef struct gfc_omp_declare_variant struct gfc_symtree *variant_proc_symtree; gfc_omp_set_selector *set_selectors; + gfc_omp_namelist *need_device_ptr_arg_list; bool checked_p : 1; /* Set if previously checked for errors. */ bool error_p : 1; /* Set if error found in directive. */ @@ -3083,7 +3091,7 @@ enum gfc_exec_op 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_INTEROP, - EXEC_OMP_ERROR, EXEC_OMP_ALLOCATE, EXEC_OMP_ALLOCATORS + EXEC_OMP_ERROR, EXEC_OMP_ALLOCATE, EXEC_OMP_ALLOCATORS, EXEC_OMP_DISPATCH }; typedef struct gfc_code diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h index 84d84b81825..2bf5cccc816 100644 --- a/gcc/fortran/match.h +++ b/gcc/fortran/match.h @@ -163,6 +163,7 @@ match gfc_match_omp_declare_simd (void); match gfc_match_omp_declare_target (void); match gfc_match_omp_declare_variant (void); match gfc_match_omp_depobj (void); +match gfc_match_omp_dispatch (void); match gfc_match_omp_distribute (void); match gfc_match_omp_distribute_parallel_do (void); match gfc_match_omp_distribute_parallel_do_simd (void); diff --git a/gcc/fortran/openmp.cc b/gcc/fortran/openmp.cc index 2d5c4305d2a..88ac6c2f159 100644 --- a/gcc/fortran/openmp.cc +++ b/gcc/fortran/openmp.cc @@ -74,7 +74,7 @@ static const struct gfc_omp_directive gfc_omp_directives[] = { {"declare target", GFC_OMP_DIR_DECLARATIVE, ST_OMP_DECLARE_TARGET}, {"declare variant", GFC_OMP_DIR_DECLARATIVE, ST_OMP_DECLARE_VARIANT}, {"depobj", GFC_OMP_DIR_EXECUTABLE, ST_OMP_DEPOBJ}, - /* {"dispatch", GFC_OMP_DIR_EXECUTABLE, ST_OMP_DISPATCH}, */ + {"dispatch", GFC_OMP_DIR_EXECUTABLE, ST_OMP_DISPATCH}, {"distribute", GFC_OMP_DIR_EXECUTABLE, ST_OMP_DISTRIBUTE}, {"do", GFC_OMP_DIR_EXECUTABLE, ST_OMP_DO}, /* "error" becomes GFC_OMP_DIR_EXECUTABLE with at(execution) */ @@ -183,6 +183,8 @@ gfc_free_omp_clauses (gfc_omp_clauses *c) gfc_free_expr (c->num_tasks); gfc_free_expr (c->priority); gfc_free_expr (c->detach); + gfc_free_expr (c->novariants); + gfc_free_expr (c->nocontext); gfc_free_expr (c->async_expr); gfc_free_expr (c->gang_num_expr); gfc_free_expr (c->gang_static_expr); @@ -326,6 +328,8 @@ gfc_free_omp_declare_variant_list (gfc_omp_declare_variant *list) gfc_omp_declare_variant *current = list; list = list->next; gfc_free_omp_set_selector_list (current->set_selectors); + gfc_free_omp_namelist (current->need_device_ptr_arg_list, false, false, + false, false); free (current); } } @@ -1112,6 +1116,8 @@ enum omp_mask2 OMP_CLAUSE_INIT, /* OpenMP 5.1. */ OMP_CLAUSE_DESTROY, /* OpenMP 5.1. */ OMP_CLAUSE_USE, /* OpenMP 5.1. */ + OMP_CLAUSE_NOVARIANTS, /* OpenMP 5.1 */ + OMP_CLAUSE_NOCONTEXT, /* OpenMP 5.1 */ /* This must come last. */ OMP_MASK2_LAST }; @@ -3629,6 +3635,25 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, c->assume->no_parallelism = needs_space = true; continue; } + + if ((mask & OMP_CLAUSE_NOVARIANTS) + && (m = gfc_match_dupl_check (!c->novariants, "novariants", true, + &c->novariants)) + != MATCH_NO) + { + if (m == MATCH_ERROR) + goto error; + continue; + } + if ((mask & OMP_CLAUSE_NOCONTEXT) + && (m = gfc_match_dupl_check (!c->nocontext, "nocontext", true, + &c->nocontext)) + != MATCH_NO) + { + if (m == MATCH_ERROR) + goto error; + continue; + } if ((mask & OMP_CLAUSE_NOGROUP) && (m = gfc_match_dupl_check (!c->nogroup, "nogroup")) != MATCH_NO) @@ -4996,6 +5021,9 @@ cleanup: #define OMP_INTEROP_CLAUSES \ (omp_mask (OMP_CLAUSE_DEPEND) | OMP_CLAUSE_NOWAIT | OMP_CLAUSE_DEVICE \ | OMP_CLAUSE_INIT | OMP_CLAUSE_DESTROY | OMP_CLAUSE_USE) +#define OMP_DISPATCH_CLAUSES \ + (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOVARIANTS \ + | OMP_CLAUSE_NOCONTEXT | OMP_CLAUSE_IS_DEVICE_PTR | OMP_CLAUSE_NOWAIT) static match @@ -5309,6 +5337,12 @@ error: return MATCH_ERROR; } +match +gfc_match_omp_dispatch (void) +{ + return match_omp (EXEC_OMP_DISPATCH, OMP_DISPATCH_CLAUSES); +} + match gfc_match_omp_distribute (void) { @@ -6543,6 +6577,7 @@ gfc_match_omp_declare_variant (void) odv = gfc_get_omp_declare_variant (); odv->where = gfc_current_locus; odv->variant_proc_symtree = variant_proc_st; + odv->need_device_ptr_arg_list = NULL; odv->base_proc_symtree = base_proc_st; odv->next = NULL; odv->error_p = false; @@ -6559,13 +6594,29 @@ gfc_match_omp_declare_variant (void) return MATCH_ERROR; } + bool has_match = false, has_adjust_args = false; + locus adjust_args_loc; + for (;;) { - if (gfc_match (" match") != MATCH_YES) + enum clause + { + match, + adjust_args + } ccode; + + if (gfc_match (" match") == MATCH_YES) + ccode = match; + else if (gfc_match (" adjust_args") == MATCH_YES) + { + ccode = adjust_args; + adjust_args_loc = gfc_current_locus; + } + else { if (first_p) { - gfc_error ("expected % at %C"); + gfc_error ("expected % or % at %C"); return MATCH_ERROR; } else @@ -6578,18 +6629,80 @@ gfc_match_omp_declare_variant (void) return MATCH_ERROR; } - if (gfc_match_omp_context_selector_specification (odv) != MATCH_YES) - return MATCH_ERROR; - - if (gfc_match (" )") != MATCH_YES) + if (ccode == match) { - gfc_error ("expected %<)%> at %C"); - return MATCH_ERROR; + has_match = true; + if (gfc_match_omp_context_selector_specification (odv) + != MATCH_YES) + return MATCH_ERROR; + if (gfc_match (" )") != MATCH_YES) + { + gfc_error ("expected %<)%> at %C"); + return MATCH_ERROR; + } + } + else if (ccode == adjust_args) + { + has_adjust_args = true; + bool need_device_ptr_p; + if (gfc_match (" nothing") == MATCH_YES) + need_device_ptr_p = false; + else if (gfc_match (" need_device_ptr") == MATCH_YES) + need_device_ptr_p = true; + else + { + gfc_error ("expected % or % at %C"); + return MATCH_ERROR; + } + if (need_device_ptr_p) + { + if (gfc_match_omp_variable_list (" :", + &odv->need_device_ptr_arg_list, + false) + != MATCH_YES) + { + gfc_error ("expected argument list at %C"); + return MATCH_ERROR; + } + for (gfc_omp_namelist *n = odv->need_device_ptr_arg_list; + n != NULL; n = n->next) + if (n->sym->ts.type != BT_DERIVED + || !n->sym->ts.u.derived->ts.is_iso_c + || (n->sym->ts.u.derived->intmod_sym_id != ISOCBINDING_PTR)) + { + gfc_error ("argument list item %qs in " + "% at %L must be of " + "TYPE(C_PTR)", + n->sym->name, &n->where); + return MATCH_ERROR; + } + } + else + { + gfc_omp_namelist *nothing_arg_list = NULL; + if (gfc_match_omp_variable_list (" :", ¬hing_arg_list, false) + != MATCH_YES) + { + gfc_error ("expected argument list at %C"); + return MATCH_ERROR; + } + gfc_free_omp_namelist (nothing_arg_list, false, false, false, + false); + } } first_p = false; } + if (has_adjust_args && !has_match) + { + gfc_error ("an % clause at %L can only be specified if the " + "% selector of the construct selector set appears " + "in the % clause", + &adjust_args_loc); + return MATCH_ERROR; + } + return MATCH_YES; } @@ -8040,7 +8153,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", "INIT", "USE", "DESTROY" }; + "USES_ALLOCATORS", "INIT", "USE", "DESTROY", "ADJUST_ARGS" }; STATIC_ASSERT (ARRAY_SIZE (clause_names) == OMP_LIST_NUM); if (omp_clauses == NULL) @@ -8222,6 +8335,26 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, gfc_error ("FINAL clause at %L requires a scalar LOGICAL expression", &expr->where); } + if (omp_clauses->novariants) + { + gfc_expr *expr = omp_clauses->novariants; + if (!gfc_resolve_expr (expr) || expr->ts.type != BT_LOGICAL + || expr->rank != 0) + gfc_error ( + "NOVARIANTS clause at %L requires a scalar LOGICAL expression", + &expr->where); + if_without_mod = true; + } + if (omp_clauses->nocontext) + { + gfc_expr *expr = omp_clauses->nocontext; + if (!gfc_resolve_expr (expr) || expr->ts.type != BT_LOGICAL + || expr->rank != 0) + gfc_error ( + "NOCONTEXT clause at %L requires a scalar LOGICAL expression", + &expr->where); + if_without_mod = true; + } if (omp_clauses->num_threads) resolve_positive_int_expr (omp_clauses->num_threads, "NUM_THREADS"); if (omp_clauses->chunk_size) @@ -9194,14 +9327,18 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, last = NULL; for (n = omp_clauses->lists[list]; n != NULL; ) { - if (n->sym->ts.type == BT_DERIVED - && n->sym->ts.u.derived->ts.is_iso_c - && code->op != EXEC_OMP_TARGET) + if ((n->sym->ts.type != BT_DERIVED + || !n->sym->ts.u.derived->ts.is_iso_c + || (n->sym->ts.u.derived->intmod_sym_id + != ISOCBINDING_PTR)) + && code->op == EXEC_OMP_DISPATCH) /* Non-TARGET (i.e. DISPATCH) requires a C_PTR. */ gfc_error ("List item %qs in %s clause at %L must be of " "TYPE(C_PTR)", n->sym->name, name, &n->where); else if (n->sym->ts.type != BT_DERIVED - || !n->sym->ts.u.derived->ts.is_iso_c) + || !n->sym->ts.u.derived->ts.is_iso_c + || (n->sym->ts.u.derived->intmod_sym_id + != ISOCBINDING_PTR)) { /* For TARGET, non-C_PTR are deprecated and handled as has_device_addr. */ @@ -10836,6 +10973,7 @@ icode_code_error_callback (gfc_code **codep, case EXEC_OMP_MASKED_TASKLOOP_SIMD: case EXEC_OMP_SCOPE: case EXEC_OMP_ERROR: + case EXEC_OMP_DISPATCH: gfc_error ("%s cannot contain OpenMP directive in intervening code " "at %L", state->name, &code->loc); @@ -11812,6 +11950,8 @@ omp_code_to_statement (gfc_code *code) return ST_OMP_TILE; case EXEC_OMP_UNROLL: return ST_OMP_UNROLL; + case EXEC_OMP_DISPATCH: + return ST_OMP_DISPATCH; default: gcc_unreachable (); } @@ -12227,6 +12367,28 @@ resolve_omp_target (gfc_code *code) #undef GFC_IS_TEAMS_CONSTRUCT } +static void +resolve_omp_dispatch (gfc_code *code) +{ + gfc_code *next = code->block->next; + if (next == NULL) + return; + + gfc_exec_op op = next->op; + gcc_assert (op == EXEC_CALL || op == EXEC_ASSIGN); + if (op != EXEC_CALL + && (op != EXEC_ASSIGN || next->expr2->expr_type != EXPR_FUNCTION)) + gfc_error ( + "% directive at %L must be followed by a procedure " + "call with optional assignment", + &code->loc); + + if ((op == EXEC_CALL && next->resolved_sym->attr.proc_pointer) + || (op == EXEC_ASSIGN && gfc_expr_attr (next->expr2).proc_pointer)) + gfc_error ("% directive at %L cannot be followed by a " + "procedure pointer", + &code->loc); +} /* Resolve OpenMP directive clauses and check various requirements of each directive. */ @@ -12343,6 +12505,11 @@ 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_DISPATCH: + if (code->ext.omp_clauses) + resolve_omp_clauses (code, code->ext.omp_clauses, ns); + resolve_omp_dispatch (code); + break; default: break; } diff --git a/gcc/fortran/parse.cc b/gcc/fortran/parse.cc index 9e06dbf0911..9d128962ba2 100644 --- a/gcc/fortran/parse.cc +++ b/gcc/fortran/parse.cc @@ -1058,6 +1058,7 @@ decode_omp_directive (void) break; case 'd': matcho ("depobj", gfc_match_omp_depobj, ST_OMP_DEPOBJ); + matcho ("dispatch", gfc_match_omp_dispatch, ST_OMP_DISPATCH); matchs ("distribute parallel do simd", gfc_match_omp_distribute_parallel_do_simd, ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD); @@ -1073,6 +1074,7 @@ decode_omp_directive (void) matcho ("end allocators", gfc_match_omp_eos_error, ST_OMP_END_ALLOCATORS); matcho ("end atomic", gfc_match_omp_eos_error, ST_OMP_END_ATOMIC); matcho ("end critical", gfc_match_omp_end_critical, ST_OMP_END_CRITICAL); + matcho ("end dispatch", gfc_match_omp_end_nowait, ST_OMP_END_DISPATCH); matchs ("end distribute parallel do simd", gfc_match_omp_eos_error, ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD); matcho ("end distribute parallel do", gfc_match_omp_eos_error, @@ -1932,7 +1934,7 @@ next_statement (void) case ST_OMP_LOOP: case ST_OMP_PARALLEL_LOOP: case ST_OMP_TEAMS_LOOP: \ case ST_OMP_TARGET_PARALLEL_LOOP: case ST_OMP_TARGET_TEAMS_LOOP: \ case ST_OMP_ALLOCATE_EXEC: case ST_OMP_ALLOCATORS: case ST_OMP_ASSUME: \ - case ST_OMP_TILE: case ST_OMP_UNROLL: \ + case ST_OMP_TILE: case ST_OMP_UNROLL: case ST_OMP_DISPATCH: \ case ST_CRITICAL: \ case ST_OACC_PARALLEL_LOOP: case ST_OACC_PARALLEL: case ST_OACC_KERNELS: \ case ST_OACC_DATA: case ST_OACC_HOST_DATA: case ST_OACC_LOOP: \ @@ -2614,6 +2616,9 @@ gfc_ascii_statement (gfc_statement st, bool strip_sentinel) case ST_OMP_DEPOBJ: p = "!$OMP DEPOBJ"; break; + case ST_OMP_DISPATCH: + p = "!$OMP DISPATCH"; + break; case ST_OMP_DISTRIBUTE: p = "!$OMP DISTRIBUTE"; break; @@ -2644,6 +2649,9 @@ gfc_ascii_statement (gfc_statement st, bool strip_sentinel) case ST_OMP_END_CRITICAL: p = "!$OMP END CRITICAL"; break; + case ST_OMP_END_DISPATCH: + p = "!$OMP END DISPATCH"; + break; case ST_OMP_END_DISTRIBUTE: p = "!$OMP END DISTRIBUTE"; break; @@ -6238,6 +6246,43 @@ parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only) } +static gfc_statement +parse_omp_dispatch (void) +{ + gfc_statement st; + gfc_code *cp, *np; + gfc_state_data s; + + accept_statement (ST_OMP_DISPATCH); + + cp = gfc_state_stack->tail; + push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL); + np = new_level (cp); + np->op = cp->op; + np->block = NULL; + + st = next_statement (); + if (st == ST_CALL || st == ST_ASSIGNMENT) + accept_statement (st); + else + { + gfc_error ("% directive must be followed by a procedure " + "call with optional assignment at %C"); + reject_statement (); + } + pop_state (); + st = next_statement (); + if (st == ST_OMP_END_DISPATCH) + { + if (cp->ext.omp_clauses->nowait && new_st.ext.omp_bool) + gfc_error_now ("Duplicated NOWAIT clause on !$OMP DISPATCH and !$OMP " + "END DISPATCH at %C"); + accept_statement (st); + st = next_statement (); + } + return st; +} + /* Accept a series of executable statements. We return the first statement that doesn't fit to the caller. Any block statements are passed on to the correct handler, which usually passes the buck @@ -6440,6 +6485,10 @@ parse_executable (gfc_statement st) st = parse_omp_oacc_atomic (true); continue; + case ST_OMP_DISPATCH: + st = parse_omp_dispatch (); + continue; + default: return st; } diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc index ebe449e7119..ba289c18ddc 100644 --- a/gcc/fortran/resolve.cc +++ b/gcc/fortran/resolve.cc @@ -11572,6 +11572,7 @@ gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns) case EXEC_OMP_ALLOCATORS: case EXEC_OMP_ASSUME: case EXEC_OMP_CRITICAL: + case EXEC_OMP_DISPATCH: case EXEC_OMP_DISTRIBUTE: case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: @@ -13280,6 +13281,7 @@ start: case EXEC_OMP_CRITICAL: case EXEC_OMP_FLUSH: case EXEC_OMP_DEPOBJ: + case EXEC_OMP_DISPATCH: case EXEC_OMP_DISTRIBUTE: case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: diff --git a/gcc/fortran/st.cc b/gcc/fortran/st.cc index 904b0008070..aa7e3183636 100644 --- a/gcc/fortran/st.cc +++ b/gcc/fortran/st.cc @@ -222,6 +222,7 @@ gfc_free_statement (gfc_code *p) case EXEC_OMP_CANCELLATION_POINT: case EXEC_OMP_CRITICAL: case EXEC_OMP_DEPOBJ: + case EXEC_OMP_DISPATCH: case EXEC_OMP_DISTRIBUTE: case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc index 8231bd255d6..7a8300511d9 100644 --- a/gcc/fortran/trans-decl.cc +++ b/gcc/fortran/trans-decl.cc @@ -2189,6 +2189,8 @@ get_proc_pointer_decl (gfc_symbol *sym) return decl; } +static void +create_function_arglist (gfc_symbol *sym); /* Get a basic decl for an external function. */ @@ -2449,7 +2451,12 @@ module_sym: if (sym->formal_ns->omp_declare_simd) gfc_trans_omp_declare_simd (sym->formal_ns); if (flag_openmp) - gfc_trans_omp_declare_variant (sym->formal_ns); + { + // We need DECL_ARGUMENTS to put attributes on, in case some arguments + // need adjustment + create_function_arglist (sym->formal_ns->proc_name); + gfc_trans_omp_declare_variant (sym->formal_ns); + } } return fndecl; diff --git a/gcc/fortran/trans-openmp.cc b/gcc/fortran/trans-openmp.cc index 3a335ade0f7..10aed171e9b 100644 --- a/gcc/fortran/trans-openmp.cc +++ b/gcc/fortran/trans-openmp.cc @@ -4233,6 +4233,36 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, omp_clauses = gfc_trans_add_clause (c, omp_clauses); } + if (clauses->novariants) + { + tree novariants_var; + + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, clauses->novariants); + gfc_add_block_to_block (block, &se.pre); + novariants_var = gfc_evaluate_now (se.expr, block); + gfc_add_block_to_block (block, &se.post); + + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NOVARIANTS); + OMP_CLAUSE_NOVARIANTS_EXPR (c) = novariants_var; + omp_clauses = gfc_trans_add_clause (c, omp_clauses); + } + + if (clauses->nocontext) + { + tree nocontext_var; + + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, clauses->nocontext); + gfc_add_block_to_block (block, &se.pre); + nocontext_var = gfc_evaluate_now (se.expr, block); + gfc_add_block_to_block (block, &se.post); + + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NOCONTEXT); + OMP_CLAUSE_NOCONTEXT_EXPR (c) = nocontext_var; + omp_clauses = gfc_trans_add_clause (c, omp_clauses); + } + if (clauses->num_threads) { tree num_threads; @@ -6360,6 +6390,114 @@ gfc_trans_omp_depobj (gfc_code *code) return gfc_finish_block (&block); } +/* Callback for walk_tree to find an OMP dispatch call and wrap it into an + * IFN_GOMP_DISPATCH. */ + +static tree +replace_omp_dispatch_call (tree *tp, int *, void *decls_p) +{ + tree t = *tp; + tree decls = (tree) decls_p; + tree orig_fn_decl = TREE_PURPOSE (decls); + tree dup_fn_decl = TREE_VALUE (decls); + if (TREE_CODE (t) == CALL_EXPR) + { + if (CALL_EXPR_FN (t) == dup_fn_decl) + CALL_EXPR_FN (t) = orig_fn_decl; + else if (TREE_CODE (CALL_EXPR_FN (t)) == ADDR_EXPR + && TREE_OPERAND (CALL_EXPR_FN (t), 0) == dup_fn_decl) + TREE_OPERAND (CALL_EXPR_FN (t), 0) = dup_fn_decl; + else + return NULL_TREE; + *tp = build_call_expr_internal_loc (input_location, IFN_GOMP_DISPATCH, + TREE_TYPE (TREE_TYPE (orig_fn_decl)), + 1, t); + return *tp; + } + + return NULL_TREE; +} + +static tree +gfc_trans_omp_dispatch (gfc_code *code) +{ + stmtblock_t block; + gfc_code *next = code->block->next; + // assume ill-formed "function dispatch structured + // block" have already been rejected by resolve_omp_dispatch + gcc_assert (next->op == EXEC_CALL || next->op == EXEC_ASSIGN); + + // Make duplicate decl for dispatch function call to make it easy to spot + // after translation + gfc_symbol *orig_fn_sym; + gfc_expr *call_expr = next->op == EXEC_CALL ? next->expr1 : next->expr2; + if (call_expr != NULL) // function + { + if (call_expr->value.function.isym != NULL) // dig into convert intrinsics + call_expr = call_expr->value.function.actual->expr; + gcc_assert (call_expr->expr_type == EXPR_FUNCTION); + orig_fn_sym = call_expr->value.function.esym + ? call_expr->value.function.esym + : call_expr->symtree->n.sym; + } + else // subroutine + { + orig_fn_sym = next->resolved_sym; + } + if (!orig_fn_sym->backend_decl) + gfc_get_symbol_decl (orig_fn_sym); + gfc_symbol dup_fn_sym = *orig_fn_sym; + dup_fn_sym.backend_decl = copy_node (orig_fn_sym->backend_decl); + if (call_expr != NULL) + call_expr->value.function.esym = &dup_fn_sym; + else + next->resolved_sym = &dup_fn_sym; + + tree body = gfc_trans_code (next); + + // Walk the tree to find the duplicate decl, wrap IFN call and replace + // dup decl with original + tree fn_decls + = build_tree_list (orig_fn_sym->backend_decl, dup_fn_sym.backend_decl); + tree dispatch_call + = walk_tree (&body, replace_omp_dispatch_call, fn_decls, NULL); + gcc_assert (dispatch_call != NULL_TREE); + + gfc_start_block (&block); + tree omp_clauses + = gfc_trans_omp_clauses (&block, code->ext.omp_clauses, code->loc); + + // Extract depend clauses and create taskwait + tree depend_clauses = NULL_TREE; + tree *depend_clauses_ptr = &depend_clauses; + for (tree c = omp_clauses; c; c = OMP_CLAUSE_CHAIN (c)) + { + if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_DEPEND) + { + *depend_clauses_ptr = c; + depend_clauses_ptr = &OMP_CLAUSE_CHAIN (c); + } + } + if (depend_clauses != NULL_TREE) + { + tree stmt = make_node (OMP_TASK); + TREE_TYPE (stmt) = void_node; + OMP_TASK_CLAUSES (stmt) = depend_clauses; + OMP_TASK_BODY (stmt) = NULL_TREE; + SET_EXPR_LOCATION (stmt, gfc_get_location (&code->loc)); + gfc_add_expr_to_block (&block, stmt); + } + + tree stmt = make_node (OMP_DISPATCH); + SET_EXPR_LOCATION (stmt, gfc_get_location (&code->loc)); + TREE_TYPE (stmt) = void_type_node; + OMP_DISPATCH_BODY (stmt) = body; + OMP_DISPATCH_CLAUSES (stmt) = omp_clauses; + + gfc_add_expr_to_block (&block, stmt); + return gfc_finish_block (&block); +} + static tree gfc_trans_omp_error (gfc_code *code) { @@ -8272,6 +8410,8 @@ gfc_trans_omp_directive (gfc_code *code) case EXEC_OMP_UNROLL: return gfc_trans_omp_do (code, code->op, NULL, code->ext.omp_clauses, NULL); + case EXEC_OMP_DISPATCH: + return gfc_trans_omp_dispatch (code); case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: case EXEC_OMP_DISTRIBUTE_SIMD: @@ -8586,6 +8726,19 @@ gfc_trans_omp_declare_variant (gfc_namespace *ns) variant_proc_sym = NULL; } } + if (odv->need_device_ptr_arg_list != NULL + && omp_get_context_selector (set_selectors, OMP_TRAIT_SET_CONSTRUCT, + OMP_TRAIT_CONSTRUCT_DISPATCH) + == NULL_TREE) + { + gfc_error ("an % clause can only be " + "specified if the " + "% selector of the construct " + "selector set appears " + "in the % clause at %L", + &odv->where); + variant_proc_sym = NULL; + } if (variant_proc_sym != NULL) { gfc_set_sym_referenced (variant_proc_sym); @@ -8602,6 +8755,50 @@ gfc_trans_omp_declare_variant (gfc_namespace *ns) DECL_ATTRIBUTES (base_fn_decl) = tree_cons (id, build_tree_list (variant, set_selectors), DECL_ATTRIBUTES (base_fn_decl)); + + // Handle adjust_args + tree need_device_ptr_list = make_node (TREE_LIST); + vec adjust_args_list = vNULL; + for (gfc_omp_namelist *arg_list + = odv->need_device_ptr_arg_list; + arg_list != NULL; arg_list = arg_list->next) + { + if (!arg_list->sym->attr.dummy) + { + gfc_error ( + "list item %qs at %L is not a dummy argument", + arg_list->sym->name, &arg_list->where); + continue; + } + if (adjust_args_list.contains (arg_list->sym)) + { + gfc_error ("%qs at %L is specified more than once", + arg_list->sym->name, &arg_list->where); + continue; + } + adjust_args_list.safe_push (arg_list->sym); + int idx; + gfc_formal_arglist *arg; + for (arg = ns->proc_name->formal, idx = 0; arg != NULL; + arg = arg->next, idx++) + if (arg->sym == arg_list->sym) + break; + gcc_assert (arg != NULL); + need_device_ptr_list + = chainon (need_device_ptr_list, + build_tree_list ( + NULL_TREE, + build_int_cst ( + integer_type_node, + idx))); // Store 0-based argument index, + // as in gimplify_call_expr + } + + DECL_ATTRIBUTES (variant) = tree_cons ( + get_identifier ("omp declare variant variant adjust_args"), + build_tree_list (need_device_ptr_list, + NULL_TREE /*need_device_addr */), + DECL_ATTRIBUTES (variant)); } } } diff --git a/gcc/fortran/trans.cc b/gcc/fortran/trans.cc index da6c2543612..8acbd2446a1 100644 --- a/gcc/fortran/trans.cc +++ b/gcc/fortran/trans.cc @@ -2600,6 +2600,7 @@ trans_code (gfc_code * code, tree cond) case EXEC_OMP_CANCELLATION_POINT: case EXEC_OMP_CRITICAL: case EXEC_OMP_DEPOBJ: + case EXEC_OMP_DISPATCH: case EXEC_OMP_DISTRIBUTE: case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: diff --git a/gcc/testsuite/gfortran.dg/gomp/adjust-args-1.f90 b/gcc/testsuite/gfortran.dg/gomp/adjust-args-1.f90 new file mode 100644 index 00000000000..ae8c3afa73d --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/adjust-args-1.f90 @@ -0,0 +1,58 @@ +! Test parsing of OMP clause adjust_args +! { dg-do compile } + +module main + use iso_c_binding, only: c_ptr, c_funptr + implicit none + integer :: b + interface + integer function f0 (a) + import c_ptr + type(c_ptr), intent(inout) :: a + end function + integer function g (a) + import c_ptr + type(c_ptr), intent(inout) :: a + end function + integer function h (a) + import c_funptr + type(c_funptr), intent(inout) :: a + end function + integer function f1 (i) + integer, intent(in) :: i + end function + + integer function f3 (a) + import c_ptr + type(c_ptr), intent(inout) :: a + !$omp declare variant (f1) match (construct={dispatch}) adjust_args (other: a) ! { dg-error "expected 'nothing' or 'need_device_ptr' at .1." } + end function + integer function f4 (a) + import c_ptr + type(c_ptr), intent(inout) :: a + !$omp declare variant (f0) adjust_args (nothing: a) ! { dg-error "an 'adjust_args' clause at .1. can only be specified if the 'dispatch' selector of the construct selector set appears in the 'match' clause" } + end function + integer function f5 (i) + integer, intent(inout) :: i + !$omp declare variant (f1) match (construct={dispatch}) adjust_args () ! { dg-error "expected 'nothing' or 'need_device_ptr' at .1." } + end function + integer function f6 (i) + integer, intent(inout) :: i + !$omp declare variant (f1) match (construct={dispatch}) adjust_args (nothing) ! { dg-error "expected argument list at .1." } + end function + integer function f7 (i) + integer, intent(inout) :: i + !$omp declare variant (f1) match (construct={dispatch}) adjust_args (nothing:) ! { dg-error "expected argument list at .1." } + end function + integer function f9 (i) + integer, intent(inout) :: i + !$omp declare variant (f1) match (construct={dispatch}) adjust_args (need_device_ptr: i) ! { dg-error "argument list item 'i' in 'need_device_ptr' at .1. must be of TYPE.C_PTR." } + end function + integer function f13 (a) + import c_funptr + type(c_funptr), intent(inout) :: a + !$omp declare variant (h) match (construct={dispatch}) adjust_args (need_device_ptr: a) ! { dg-error "argument list item 'a' in 'need_device_ptr' at .1. must be of TYPE.C_PTR." } + end function + + end interface +end module diff --git a/gcc/testsuite/gfortran.dg/gomp/adjust-args-2.f90 b/gcc/testsuite/gfortran.dg/gomp/adjust-args-2.f90 new file mode 100644 index 00000000000..c65a4839ca5 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/adjust-args-2.f90 @@ -0,0 +1,18 @@ +! Test resolution of OMP clause adjust_args +! { dg-do compile } + +module main + implicit none +interface +subroutine f1 (i) + integer, intent(inout) :: i +end subroutine +end interface +contains + + subroutine f3 (i) + integer, intent(inout) :: i + !$omp declare variant (f1) match (construct={dispatch}) adjust_args (nothing: z) ! { dg-error "Symbol 'z' at .1. has no IMPLICIT type" } + end subroutine + +end module diff --git a/gcc/testsuite/gfortran.dg/gomp/adjust-args-3.f90 b/gcc/testsuite/gfortran.dg/gomp/adjust-args-3.f90 new file mode 100644 index 00000000000..291bb47aaa2 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/adjust-args-3.f90 @@ -0,0 +1,27 @@ +! Test translation of OMP clause adjust_args +! { dg-do compile } + +module main + use iso_c_binding, only: c_ptr + implicit none + type(c_ptr) :: b + +contains + subroutine base2 (a) + type(c_ptr), intent(inout) :: a + !$omp declare variant (variant2) match (construct={parallel}) adjust_args (need_device_ptr: a) ! { dg-error "an 'adjust_args' clause can only be specified if the 'dispatch' selector of the construct selector set appears in the 'match' clause at .1." } + end subroutine + subroutine base3 (a) + type(c_ptr), intent(inout) :: a + !$omp declare variant (variant2) match (construct={dispatch}) adjust_args (need_device_ptr: a) adjust_args (need_device_ptr: a) ! { dg-error "'a' at .1. is specified more than once" } + end subroutine + subroutine base4 (a) + type(c_ptr), intent(inout) :: a + !$omp declare variant (variant2) match (construct={dispatch}) adjust_args (need_device_ptr: b) ! { dg-error "list item 'b' at .1. is not a dummy argument" } + end subroutine + + subroutine variant2 (a) + type(c_ptr), intent(inout) :: a + end subroutine + +end module diff --git a/gcc/testsuite/gfortran.dg/gomp/adjust-args-4.f90 b/gcc/testsuite/gfortran.dg/gomp/adjust-args-4.f90 new file mode 100644 index 00000000000..75e884044b2 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/adjust-args-4.f90 @@ -0,0 +1,58 @@ +! { dg-do compile } +! { dg-additional-options "-fdump-tree-gimple" } + +module main + use iso_c_binding, only: c_ptr + implicit none + + type :: struct + integer :: a + real :: b + end type + + interface + integer function f(a, b, c) + import c_ptr + integer, intent(in) :: a + type(c_ptr), intent(inout) :: b + type(c_ptr), intent(out) :: c(:) + end function + integer function f0(a, b, c) + import c_ptr + integer, intent(in) :: a + type(c_ptr), intent(inout) :: b + type(c_ptr), intent(out) :: c(:) + !$omp declare variant (f) match (construct={dispatch}) & + !$omp& adjust_args (nothing: a) adjust_args (need_device_ptr: b, c) + end function + integer function f1(a, b, c) + import c_ptr + integer, intent(in) :: a + type(c_ptr), intent(inout) :: b + type(c_ptr), intent(out) :: c(:) + !$omp declare variant (f) match (construct={dispatch}) & + !$omp& adjust_args (nothing: a) adjust_args (need_device_ptr: b) adjust_args (need_device_ptr: c) + end function + end interface + +contains +subroutine test + integer :: a + type(c_ptr) :: b + type(c_ptr) :: c(2) + type(struct) :: s + + s%a = f0 (a, b, c) + !$omp dispatch + s%a = f0 (a, b, c) + + s%b = f1 (a, b, c) + !$omp dispatch + s%b = f1 (a, b, c) + +end subroutine +end module + +! { dg-final { scan-tree-dump-times "__builtin_omp_get_default_device \\(\\);" 2 "gimple" } } +! { dg-final { scan-tree-dump-times "D\.\[0-9]+ = __builtin_omp_get_mapped_ptr \\(&parm\.\[0-9]+, D\.\[0-9]+\\);" 2 "gimple" } } +! { dg-final { scan-tree-dump-times "D\.\[0-9]+ = __builtin_omp_get_mapped_ptr \\(&b, D\.\[0-9]+\\);" 2 "gimple" } } diff --git a/gcc/testsuite/gfortran.dg/gomp/adjust-args-5.f90 b/gcc/testsuite/gfortran.dg/gomp/adjust-args-5.f90 new file mode 100644 index 00000000000..75e884044b2 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/adjust-args-5.f90 @@ -0,0 +1,58 @@ +! { dg-do compile } +! { dg-additional-options "-fdump-tree-gimple" } + +module main + use iso_c_binding, only: c_ptr + implicit none + + type :: struct + integer :: a + real :: b + end type + + interface + integer function f(a, b, c) + import c_ptr + integer, intent(in) :: a + type(c_ptr), intent(inout) :: b + type(c_ptr), intent(out) :: c(:) + end function + integer function f0(a, b, c) + import c_ptr + integer, intent(in) :: a + type(c_ptr), intent(inout) :: b + type(c_ptr), intent(out) :: c(:) + !$omp declare variant (f) match (construct={dispatch}) & + !$omp& adjust_args (nothing: a) adjust_args (need_device_ptr: b, c) + end function + integer function f1(a, b, c) + import c_ptr + integer, intent(in) :: a + type(c_ptr), intent(inout) :: b + type(c_ptr), intent(out) :: c(:) + !$omp declare variant (f) match (construct={dispatch}) & + !$omp& adjust_args (nothing: a) adjust_args (need_device_ptr: b) adjust_args (need_device_ptr: c) + end function + end interface + +contains +subroutine test + integer :: a + type(c_ptr) :: b + type(c_ptr) :: c(2) + type(struct) :: s + + s%a = f0 (a, b, c) + !$omp dispatch + s%a = f0 (a, b, c) + + s%b = f1 (a, b, c) + !$omp dispatch + s%b = f1 (a, b, c) + +end subroutine +end module + +! { dg-final { scan-tree-dump-times "__builtin_omp_get_default_device \\(\\);" 2 "gimple" } } +! { dg-final { scan-tree-dump-times "D\.\[0-9]+ = __builtin_omp_get_mapped_ptr \\(&parm\.\[0-9]+, D\.\[0-9]+\\);" 2 "gimple" } } +! { dg-final { scan-tree-dump-times "D\.\[0-9]+ = __builtin_omp_get_mapped_ptr \\(&b, D\.\[0-9]+\\);" 2 "gimple" } } diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-variant-2.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-variant-2.f90 index 7fc5071feff..62d2cb96fac 100644 --- a/gcc/testsuite/gfortran.dg/gomp/declare-variant-2.f90 +++ b/gcc/testsuite/gfortran.dg/gomp/declare-variant-2.f90 @@ -18,10 +18,10 @@ contains !$omp declare variant match(user={condition(.false.)}) ! { dg-error "expected '\\(' at .1." } end subroutine subroutine f6 () - !$omp declare variant (f1) ! { dg-error "expected 'match' at .1." } + !$omp declare variant (f1) ! { dg-error "expected 'match' or 'adjust_args' at .1." } end subroutine subroutine f7 () - !$omp declare variant (f1) simd ! { dg-error "expected 'match' at .1." } + !$omp declare variant (f1) simd ! { dg-error "expected 'match' or 'adjust_args' at .1." } end subroutine subroutine f8 () !$omp declare variant (f1) match ! { dg-error "expected '\\(' at .1." } @@ -183,7 +183,7 @@ contains !$omp declare variant (f1) match(construct={requires}) ! { dg-warning "unknown selector 'requires' for context selector set 'construct' at .1." } end subroutine subroutine f75 () - !$omp declare variant (f1),match(construct={parallel}) ! { dg-error "expected 'match' at .1." } + !$omp declare variant (f1),match(construct={parallel}) ! { dg-error "expected 'match' or 'adjust_args' at .1." } end subroutine subroutine f76 () !$omp declare variant (f1) match(implementation={atomic_default_mem_order("relaxed")}) ! { dg-error "expected identifier at .1." } diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-variant-21-aux.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-variant-21-aux.f90 new file mode 100644 index 00000000000..59b55e0bb85 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/declare-variant-21-aux.f90 @@ -0,0 +1,25 @@ +! { dg-do compile { target skip-all-targets } } + +! Test XFAILed due to https://gcc.gnu.org/PR115271 + + +subroutine base_proc (a) + use iso_c_binding, only: c_ptr + type(c_ptr), intent(inout) :: a +end subroutine + +program main + use iso_c_binding, only: c_ptr + use my_mod + implicit none + + type(c_ptr) :: a + + + call base_proc(a) + !call variant_proc(a) + + !$omp dispatch + call base_proc(a) + +end program main diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-variant-21.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-variant-21.f90 new file mode 100644 index 00000000000..0a89c8ff231 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/declare-variant-21.f90 @@ -0,0 +1,22 @@ +! { dg-do run } +! { dg-additional-sources declare-variant-21-aux.f90 } +! { dg-additional-options "-fdump-tree-gimple" } + +module my_mod + use iso_c_binding, only: c_ptr + implicit none + interface + subroutine base_proc (a) + use iso_c_binding, only: c_ptr + type(c_ptr), intent(inout) :: a + end subroutine + end interface + +contains + subroutine variant_proc (a) + type(c_ptr), intent(inout) :: a + !$omp declare variant (base_proc) match (construct={dispatch}) adjust_args(need_device_ptr: a) + end subroutine +end module + +! { dg-final { scan-tree-dump "variant_proc \\(&a\\)" "gimple" { xfail *-*-* } } } diff --git a/gcc/testsuite/gfortran.dg/gomp/dispatch-1.f90 b/gcc/testsuite/gfortran.dg/gomp/dispatch-1.f90 new file mode 100644 index 00000000000..12c30904131 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/dispatch-1.f90 @@ -0,0 +1,77 @@ +module main + use iso_c_binding, only: c_ptr + implicit none + contains + + subroutine f1 () + integer :: a, b, arr(10) + real :: x + complex :: c + character :: ch + logical :: bool + type :: struct + integer :: a + real :: b + end type + type(struct) :: s + type(c_ptr) :: p + + interface + subroutine f0 (a, c, bool, s) + import :: struct + integer, intent(in) :: a + complex, intent(out) :: c + logical, intent(inout) :: bool + type(struct) :: s + end subroutine + integer function f2 (arr, x, ch, b) + integer, intent(inout) :: arr(:) + real, intent(in) :: x + character, intent(out) :: ch + real :: b + end function + subroutine f3 (p) + import :: c_ptr + type(c_ptr) :: p + end subroutine + integer function f4 () + end function + end interface + + !$omp dispatch + b = f2(arr, x, ch, s%b) + !$omp dispatch + c = f2(arr(:5), x * 2.4, ch, s%b) + !$omp dispatch + arr(1) = f2(arr, x, ch, s%b) + !$omp dispatch + s%a = f2(arr, x, ch, s%b) + !$omp dispatch + x = f2(arr, x, ch, s%b) + !$omp dispatch + call f0(a, c, bool, s) + !$omp dispatch + call f0(f4(), c, bool, s) + + !$omp dispatch nocontext(.TRUE.) + call f0(a, c, bool, s) + !$omp dispatch nocontext(arr(2) < 10) + call f0(a, c, bool, s) + !$omp dispatch novariants(.FALSE.) + call f0(a, c, bool, s) + !$omp dispatch novariants(bool) + call f0(a, c, bool, s) + !$omp dispatch nowait + call f0(a, c, bool, s) + !$omp dispatch device(arr(9)) + call f0(a, c, bool, s) + !$omp dispatch device(a + a) + call f0(a, c, bool, s) + !$omp dispatch device(-25373654) + call f0(a, c, bool, s) + !$omp dispatch is_device_ptr(p) + call f3(p) + !$omp dispatch depend(in: a, c, bool) depend(inout: s, arr(:3)) + call f0(a, c, bool, s) + end subroutine +end module diff --git a/gcc/testsuite/gfortran.dg/gomp/dispatch-10.f90 b/gcc/testsuite/gfortran.dg/gomp/dispatch-10.f90 new file mode 100644 index 00000000000..391879c7c24 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/dispatch-10.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! { dg-additional-options "-fdump-tree-original -fdump-tree-gimple" } + +! Check that the right call to f is wrapped in a GOMP_DISPATCH internal function +! before translation and that it is stripped during gimplification. + +subroutine g(x,f) + interface + integer function f(y) + allocatable :: f + integer :: y + end + end interface + integer, allocatable :: X(:) + + !$omp dispatch + x(f(3)) = f(f(2)) +end + +! { dg-final { scan-tree-dump-times "D\.\[0-9]+ = \.GOMP_DISPATCH \\(f \\(&D\.\[0-9]+\\)\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "D\.\[0-9]+ = f \\(&D\.\[0-9]+\\);" 1 "gimple" } } diff --git a/gcc/testsuite/gfortran.dg/gomp/dispatch-2.f90 b/gcc/testsuite/gfortran.dg/gomp/dispatch-2.f90 new file mode 100644 index 00000000000..d2d555b5932 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/dispatch-2.f90 @@ -0,0 +1,79 @@ +module main + use iso_c_binding, only: c_funptr + implicit none + contains + + subroutine f1 () + integer :: a, b, arr(10) + real :: x + complex :: c + character :: ch + logical :: bool + type :: struct + integer :: a + real :: b + end type + type(struct) :: s + type(c_funptr) :: p + + interface + subroutine f0 (a, c, bool, s) + import :: struct + integer, intent(in) :: a + complex, intent(out) :: c + logical, intent(inout) :: bool + type(struct) :: s + end subroutine + integer function f2 (arr, x, ch, b) + integer, intent(inout) :: arr(:) + real, intent(in) :: x + character, intent(out) :: ch + real :: b + end function + end interface + procedure(f0), pointer:: fp => NULL() + + !$omp dispatch !{ dg-error "'OMP DISPATCH' directive at .1. must be followed by a procedure call with optional assignment" } +50 b = f2(arr, x, ch, s%b) + a + !$omp dispatch !{ dg-error "'OMP DISPATCH' directive at .1. must be followed by a procedure call with optional assignment" } + a = b + !$omp dispatch !{ dg-error "'OMP DISPATCH' directive at .1. must be followed by a procedure call with optional assignment" } + b = Not (2) + !$omp dispatch + !$omp threadprivate(a) !{ dg-error "'OMP DISPATCH' directive must be followed by a procedure call with optional assignment at .1." } + a = f2(arr, x, ch, s%b) + !$omp dispatch + print *, 'This is not allowed here.' !{ dg-error "'OMP DISPATCH' directive must be followed by a procedure call with optional assignment at .1." } + !$omp dispatch + goto 50 !{ dg-error "'OMP DISPATCH' directive must be followed by a procedure call with optional assignment at .1." } + !$omp dispatch !{ dg-error "'OMP DISPATCH' directive at .1. cannot be followed by a procedure pointer" } + call fp(a, c, bool, s) + + !$omp dispatch nocontext(s) !{ dg-error "NOCONTEXT clause at .1. requires a scalar LOGICAL expression" } + call f0(a, c, bool, s) + !$omp dispatch nocontext(a, b) !{ dg-error "Invalid expression after 'nocontext.' at .1." } + call f0(a, c, bool, s) + !$omp dispatch nocontext(a) nocontext(b) !{ dg-error "Duplicated 'nocontext' clause at .1." } + call f0(a, c, bool, s) + !$omp dispatch novariants(s) !{ dg-error "NOVARIANTS clause at .1. requires a scalar LOGICAL expression" } + call f0(a, c, bool, s) + !$omp dispatch novariants(a, b) !{ dg-error "Invalid expression after 'novariants.' at .1." } + call f0(a, c, bool, s) + !$omp dispatch novariants(a) novariants(b) !{ dg-error "Duplicated 'novariants' clause at .1." } + call f0(a, c, bool, s) + !$omp dispatch nowait nowait !{ dg-error "Duplicated 'nowait' clause at .1." } + call f0(a, c, bool, s) + !$omp dispatch device(x) !{ dg-error "DEVICE clause at .1. requires a scalar INTEGER expression" } + call f0(a, c, bool, s) + !$omp dispatch device(arr) !{ dg-error "DEVICE clause at .1. requires a scalar INTEGER expression" } + call f0(a, c, bool, s) + !$omp dispatch is_device_ptr(x) !{ dg-error "List item 'x' in IS_DEVICE_PTR clause at .1. must be of TYPE.C_PTR." } + call f0(a, c, bool, s) + !$omp dispatch is_device_ptr(arr) !{ dg-error "List item 'arr' in IS_DEVICE_PTR clause at .1. must be of TYPE.C_PTR." } + call f0(a, c, bool, s) + !$omp dispatch is_device_ptr(p) !{ dg-error "List item 'p' in IS_DEVICE_PTR clause at .1. must be of TYPE.C_PTR." } + call f0(a, c, bool, s) + !$omp dispatch depend(inout: f0) !{ dg-error "Object 'f0' is not a variable at .1." } + call f0(a, c, bool, s) + end subroutine +end module diff --git a/gcc/testsuite/gfortran.dg/gomp/dispatch-3.f90 b/gcc/testsuite/gfortran.dg/gomp/dispatch-3.f90 new file mode 100644 index 00000000000..84590fd883a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/dispatch-3.f90 @@ -0,0 +1,39 @@ +! { dg-do compile } +! { dg-additional-options "-fdump-tree-gimple" } + +module main + implicit none + interface + integer function f0 () + end function + + integer function f1 () + end function + + integer function f2 () + !$omp declare variant (f0) match (construct={dispatch}) + !$omp declare variant (f1) match (implementation={vendor(gnu)}) + end function + end interface + contains + + integer function test () + integer :: a + + !$omp dispatch + a = f2 () + !$omp dispatch novariants(.TRUE.) + a = f2 () + !$omp dispatch novariants(.FALSE.) + a = f2 () + !$omp dispatch nocontext(.TRUE.) + a = f2 () + !$omp dispatch nocontext(.FALSE.) + a = f2 () + end function +end module + + +! { dg-final { scan-tree-dump-times "a = f0 \\\(\\\);" 3 "gimple" } } +! { dg-final { scan-tree-dump-times "a = f1 \\\(\\\);" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "a = f2 \\\(\\\);" 1 "gimple" } } diff --git a/gcc/testsuite/gfortran.dg/gomp/dispatch-4.f90 b/gcc/testsuite/gfortran.dg/gomp/dispatch-4.f90 new file mode 100644 index 00000000000..edcd799a718 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/dispatch-4.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! { dg-additional-options "-fdump-tree-gimple" } + +module main + implicit none + interface + subroutine f2 () + end subroutine + end interface + contains + + subroutine test () + !$omp dispatch ! { dg-final { scan-tree-dump-not "#pragma omp task" "gimple" } } + call f2 () + !$omp dispatch nowait ! { dg-final { scan-tree-dump-not "nowait" "gimple" } } + call f2 () + end subroutine +end module + diff --git a/gcc/testsuite/gfortran.dg/gomp/dispatch-5.f90 b/gcc/testsuite/gfortran.dg/gomp/dispatch-5.f90 new file mode 100644 index 00000000000..f6fead0dae2 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/dispatch-5.f90 @@ -0,0 +1,25 @@ +! { dg-do compile } +! { dg-additional-options "-fdump-tree-gimple" } + +module main + implicit none + interface + subroutine f2 (a) + integer, intent(in) :: a + end subroutine + end interface + contains + + subroutine test () + integer :: a + + !$omp dispatch device(-25373654) + ! { dg-final { scan-tree-dump-times "__builtin_omp_set_default_device \\(-25373654\\);" 1 "gimple" } } + call f2 (a) + !$omp dispatch device(a + a) + ! { dg-final { scan-tree-dump-times "(D\.\[0-9]+) = a.\[0-9_]+ \\* 2;.*#pragma omp dispatch.*__builtin_omp_set_default_device \\(\\1\\);.*f2 \\(&a\\)" 2 "gimple" } } + call f2 (a) + end subroutine +end module + +! { dg-final { scan-tree-dump-times "(D\.\[0-9]+) = __builtin_omp_get_default_device \\(\\);.*__builtin_omp_set_default_device \\(\\1\\);" 4 "gimple" } } diff --git a/gcc/testsuite/gfortran.dg/gomp/dispatch-6.f90 b/gcc/testsuite/gfortran.dg/gomp/dispatch-6.f90 new file mode 100644 index 00000000000..c08aec45206 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/dispatch-6.f90 @@ -0,0 +1,39 @@ +! { dg-do compile } +! { dg-additional-options "-fdump-tree-gimple" } + +module main + use iso_c_binding, only: c_ptr + implicit none + interface + subroutine f1 (p, p2) + import :: c_ptr + type(c_ptr), intent(out) :: p + type(c_ptr), intent(in) :: p2 + end subroutine + subroutine f2 (p, p2) + import :: c_ptr + type(c_ptr), intent(out) :: p + type(c_ptr), intent(in) :: p2 + !$omp declare variant (f1) match (construct={dispatch}) adjust_args (need_device_ptr: p, p2) + end subroutine + end interface + contains + + subroutine test () + type(c_ptr) :: p, p2 + + !$omp dispatch + ! { dg-final { scan-tree-dump-times "#pragma omp dispatch\[ \t\n\r\{]*integer\\(kind=4\\) (D\.\[0-9]+);\[ \t\n\r]*void \\* (D\.\[0-9]+);\[ \t\n\r]*void \\* (D\.\[0-9]+);\[ \t\n\r]*p = {CLOBBER};\[ \t\n\r]*\\1 = __builtin_omp_get_default_device \\(\\);\[ \t\n\r]*\\2 = __builtin_omp_get_mapped_ptr \\(&p2, \\1\\);\[ \t\n\r]*\\3 = __builtin_omp_get_mapped_ptr \\(&p, \\1\\);\[ \t\n\r]*f1 \\(\\3, \\2\\);" 4 "gimple" } } + call f2 (p, p2) + !$omp dispatch is_device_ptr(p) + ! { dg-final { scan-tree-dump-times "#pragma omp dispatch is_device_ptr\\(p\\)\[ \t\n\r\{]*integer\\(kind=4\\) (D\.\[0-9]+);\[ \t\n\r]*void \\* (D\.\[0-9]+);\[ \t\n\r]*p = {CLOBBER};\[ \t\n\r]*\\1 = __builtin_omp_get_default_device \\(\\);\[ \t\n\r]*\\2 = __builtin_omp_get_mapped_ptr \\(&p2, \\1\\);\[ \t\n\r]*f1 \\(&p, \\2\\);" 3 "gimple" } } + call f2 (p, p2) + !$omp dispatch is_device_ptr(p2) + ! { dg-final { scan-tree-dump-times "#pragma omp dispatch is_device_ptr\\(p2\\)\[ \t\n\r\{]*integer\\(kind=4\\) (D\.\[0-9]+);\[ \t\n\r]*void \\* (D\.\[0-9]+);\[ \t\n\r]*p = {CLOBBER};\[ \t\n\r]*\\1 = __builtin_omp_get_default_device \\(\\);\[ \t\n\r]*\\2 = __builtin_omp_get_mapped_ptr \\(&p, \\1\\);\[ \t\n\r]*f1 \\(\\2, &p2\\);" 3 "gimple" } } + call f2 (p, p2) + !$omp dispatch is_device_ptr(p, p2) + ! { dg-final { scan-tree-dump-times "#pragma omp dispatch is_device_ptr\\(p\\) is_device_ptr\\(p2\\)\[ \t\n\r\{]*p = {CLOBBER};\[ \t\n\r]*f1 \\(&p, &p2\\);" 1 "gimple" } } + call f2 (p, p2) + end subroutine +end module + diff --git a/gcc/testsuite/gfortran.dg/gomp/dispatch-7.f90 b/gcc/testsuite/gfortran.dg/gomp/dispatch-7.f90 new file mode 100644 index 00000000000..6b40af6f315 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/dispatch-7.f90 @@ -0,0 +1,26 @@ +! { dg-do compile } +! { dg-additional-options "-fdump-tree-ompexp" } + +module main + use iso_c_binding, only: c_ptr + implicit none + interface + subroutine f2 (p) + import :: c_ptr + type(c_ptr), intent(out) :: p + end subroutine + end interface + contains + + subroutine test () + type(c_ptr) :: p + + !$omp dispatch + ! { dg-final { scan-tree-dump-not "__builtin_GOMP_task " "ompexp" } } + call f2 (p) + !$omp dispatch depend(inout: p) + ! { dg-final { scan-tree-dump-times "(D\.\[0-9]+)\\\[2] = &p;\[ \n]*__builtin_GOMP_taskwait_depend \\(&\\1\\);" 2 "ompexp" } } + call f2 (p) + end subroutine +end module + diff --git a/gcc/testsuite/gfortran.dg/gomp/dispatch-8.f90 b/gcc/testsuite/gfortran.dg/gomp/dispatch-8.f90 new file mode 100644 index 00000000000..acfd410987a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/dispatch-8.f90 @@ -0,0 +1,33 @@ +! { dg-do compile } +! { dg-additional-options "-fdump-tree-gimple" } + +module main + use iso_c_binding, only: c_ptr + implicit none + interface + integer function f0 () + end function + integer function f1 () + end function + integer function f2 () + !$omp declare variant (f0) match (construct={dispatch}) + !$omp declare variant (f1) match (implementation={vendor(gnu)}) + end function + end interface + contains + + subroutine test () + integer :: a, n + + !$omp dispatch novariants(n < 1024) nocontext(n > 1024) + a = f2 () + end subroutine +end module + +! { dg-final { scan-tree-dump-times "D\.\[0-9]+ = n <= 1023;" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "D\.\[0-9]+ = n > 1024;" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "#pragma omp dispatch novariants\\(0\\) nocontext\\(0\\)" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "a = f2 \\\(\\\);" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "a = f1 \\\(\\\);" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "a = f0 \\\(\\\);" 1 "gimple" } } + diff --git a/gcc/testsuite/gfortran.dg/gomp/dispatch-9.f90 b/gcc/testsuite/gfortran.dg/gomp/dispatch-9.f90 new file mode 100644 index 00000000000..bd421e7239a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/dispatch-9.f90 @@ -0,0 +1,24 @@ +module m +contains +subroutine f1 (ar) + integer :: arr(10) +end +subroutine f0 (ar) + integer :: arr(10) + !$omp declare variant (f1) match (construct={dispatch}) +end +end module + +subroutine call_it(ctx, arr) + logical :: ctx + integer :: arr(:) + !$omp dispatch nocontext(ctx) + call f0(arr) + !$omp end dispatch ! valid since 5.2 + !$omp dispatch nocontext(ctx) + call f0(arr) + !$omp end dispatch nowait ! likewise valid (unless there is a 'nowait' at '!$omp dispatch') + !$omp dispatch nowait + call f0(arr) + !$omp end dispatch nowait !{ dg-error "Duplicated NOWAIT clause on !.OMP DISPATCH and !.OMP END DISPATCH at .1." } +end