From patchwork Sun Jul 23 22:15:21 2023 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Sandra Loosemore X-Patchwork-Id: 124556 Return-Path: Delivered-To: ouuuleilei@gmail.com Received: by 2002:a59:9010:0:b0:3e4:2afc:c1 with SMTP id l16csp1451764vqg; Sun, 23 Jul 2023 15:19:47 -0700 (PDT) X-Google-Smtp-Source: APBJJlEPJDfCfrcJkwd+D5zVgAl9SXE3j5Z6Qy8n2oW6aEg3ZDn2T2ByO9LvO7Fq0l44OYDeS6vf X-Received: by 2002:aa7:d145:0:b0:51e:5ec8:d2f7 with SMTP id r5-20020aa7d145000000b0051e5ec8d2f7mr7210201edo.30.1690150787399; Sun, 23 Jul 2023 15:19:47 -0700 (PDT) ARC-Seal: i=1; a=rsa-sha256; t=1690150787; cv=none; d=google.com; s=arc-20160816; b=Y4UoNezkp6uJz60f0b875PcHXoTzZ4dLruOKnyqsfXaCCgzJOEtk1jUSK49+2h+b0t 4MEXDUuVwYVsjaWqyfrM0QdM520jM+LGEOfDylW72fxlu8xxxniQHxugm+CgG9mVIOci GxunyfwR4PADoTHpb03MzDuHyfSykcbMNu+BDUzyVGr2EKGGa7rTzLbo1O6ROTtTTo/3 F+vfTGa7HNvyc+55fduedNS2WMEx9nJ0NkyAmaj0kB68kb+UHEvMVU0+Z06rUU66kGJE zjCw5GxiVO/XnWWQJpvXvkzq48XDFCKCt3y7B3MIn7+E//0Y2R8KOj4Gw9vYwHXdgSMp 9K0g== ARC-Message-Signature: i=1; a=rsa-sha256; c=relaxed/relaxed; d=google.com; s=arc-20160816; h=sender:errors-to:list-subscribe:list-help:list-post:list-archive :list-unsubscribe:list-id:precedence:content-transfer-encoding :mime-version:references:in-reply-to:message-id:date:subject:cc:to :from:ironport-sdr:dmarc-filter:delivered-to; bh=+RoPS8/l2fr99HdCK2IO53EIwPNTRb9feDYFt1+GJYA=; fh=x2if1ZpAyqzzvFTN8g3whRDYBVJRV+wEkJNjaYGbcaY=; b=JaeCV0muaeHQLdMCOCmoi2FW1nqYLsGoINxd8brQmoyFQHyhO0tFLTh4yoZgygBzde 0rf56GC2jkI60CzqT3JB2ZyfeulwFCAsUw17WmZQyjKn0gAlfxHMr7iKKzvFlkf7CMiw LbQz1z2mLiUf3jyM7csKkTNcNzvEPQDE7TMkcQ0Z5pEKM2Igtl21AC/+kfxN9kpiv87m +4HFPIGGPlfqWljynmQjRTDp3QqzFb73n58q4w/7Zh2MaUkikBqRMzHqwbEfl7+TcK3p 9T6WO1FaMz/MafnDfHdMCdI5T0wMJnRLWZNYR1wjYL9V0GclodT8DUL1twiFcIVpg3Xy TERw== ARC-Authentication-Results: i=1; mx.google.com; spf=pass (google.com: domain of gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org designates 8.43.85.97 as permitted sender) smtp.mailfrom="gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org" Received: from server2.sourceware.org (ip-8-43-85-97.sourceware.org. [8.43.85.97]) by mx.google.com with ESMTPS id n10-20020aa7db4a000000b005222065005asi1751217edt.13.2023.07.23.15.19.46 for (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Sun, 23 Jul 2023 15:19:47 -0700 (PDT) Received-SPF: pass (google.com: domain of gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org designates 8.43.85.97 as permitted sender) client-ip=8.43.85.97; Authentication-Results: mx.google.com; spf=pass (google.com: domain of gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org designates 8.43.85.97 as permitted sender) smtp.mailfrom="gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org" Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 7B3883882003 for ; Sun, 23 Jul 2023 22:17:48 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from esa4.mentor.iphmx.com (esa4.mentor.iphmx.com [68.232.137.252]) by sourceware.org (Postfix) with ESMTPS id 507C43870C0E for ; Sun, 23 Jul 2023 22:16:28 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 507C43870C0E Authentication-Results: sourceware.org; dmarc=none (p=none dis=none) header.from=codesourcery.com Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=mentor.com X-IronPort-AV: E=Sophos;i="6.01,228,1684828800"; d="scan'208";a="12541452" Received: from orw-gwy-02-in.mentorg.com ([192.94.38.167]) by esa4.mentor.iphmx.com with ESMTP; 23 Jul 2023 14:16:27 -0800 IronPort-SDR: 7BqY//8P4ENHl61H8Ref5CgT1Gb7Un5C57fJ2WXP7pPK70NZUcEJZRfZs/gt8bWRA3KG/zScfR ODDO77aNTeK5aFLEgiNSunkVmJBX0Q84gdCyyCI2m+aziuiLH46nZd2zg4gMAexGVnlhyXNm/I ih3RYXuinLbtqT/dhRi9W9k8QHb30YoNK7KCcr0KFA2fFNLguvIySGY4v5r/38KrsembA8bgw4 460Vbe8i+xCcDtCjnYQVNbfnsrs+jNVVGOx94HiyFH+fASUZ2sHxB6+wOgbFO9X13yRWGeq/l1 JiI= From: Sandra Loosemore To: CC: Subject: [PATCH V2 5/5] OpenMP: Fortran support for imperfectly-nested loops Date: Sun, 23 Jul 2023 16:15:21 -0600 Message-ID: <20230723221521.3739463-6-sandra@codesourcery.com> X-Mailer: git-send-email 2.34.1 In-Reply-To: <20230723221521.3739463-1-sandra@codesourcery.com> References: <20230723221521.3739463-1-sandra@codesourcery.com> MIME-Version: 1.0 X-ClientProxiedBy: svr-orw-mbx-11.mgc.mentorg.com (147.34.90.211) To svr-orw-mbx-13.mgc.mentorg.com (147.34.90.213) X-Spam-Status: No, score=-9.4 required=5.0 tests=BAYES_00, GIT_PATCH_0, HEADER_FROM_DIFFERENT_DOMAINS, KAM_DMARC_STATUS, SCC_5_SHORT_WORD_LINES, SPF_HELO_PASS, SPF_PASS, TXREP, T_FILL_THIS_FORM_SHORT, 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.29 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org Sender: "Gcc-patches" X-getmail-retrieved-from-mailbox: INBOX X-GMAIL-THRID: 1772251551898580343 X-GMAIL-MSGID: 1772251551898580343 OpenMP 5.0 removed the restriction that multiple collapsed loops must be perfectly nested, allowing "intervening code" (including nested BLOCKs) before or after each nested loop. In GCC this code is moved into the inner loop body by the respective front ends. In the Fortran front end, most of the semantic processing happens during the translation phase, so the parse phase just collects the intervening statements, checks them for errors, and splices them around the loop body. gcc/fortran/ChangeLog * gfortran.h (struct gfc_namespace): Add omp_structured_block bit. * openmp.cc: Include omp-api.h. (resolve_omp_clauses): Consolidate inscan reduction clause conflict checking here. (find_nested_loop_in_chain): New. (find_nested_loop_in_block): New. (gfc_resolve_omp_do_blocks): Set omp_current_do_collapse properly. Handle imperfectly-nested loops when looking for nested omp scan. Refactor to move inscan reduction clause conflict checking to resolve_omp_clauses. (gfc_resolve_do_iterator): Handle imperfectly-nested loops. (struct icode_error_state): New. (icode_code_error_callback): New. (icode_expr_error_callback): New. (diagnose_intervening_code_errors_1): New. (diagnose_intervening_code_errors): New. (make_structured_block): New. (restructure_intervening_code): New. (is_outer_iteration_variable): Do not assume loops are perfectly nested. (check_nested_loop_in_chain): New. (check_nested_loop_in_block_state): New. (check_nested_loop_in_block_symbol): New. (check_nested_loop_in_block): New. (expr_uses_intervening_var): New. (is_intervening_var): New. (expr_is_invariant): Do not assume loops are perfectly nested. (resolve_omp_do): Handle imperfectly-nested loops. * trans-stmt.cc (gfc_trans_block_construct): Generate OMP_STRUCTURED_BLOCK if magic bit is set on block namespace. gcc/testsuite/ChangeLog * gfortran.dg/gomp/collapse1.f90: Adjust expected errors. * gfortran.dg/gomp/collapse2.f90: Likewise. * gfortran.dg/gomp/imperfect-gotos.f90: New. * gfortran.dg/gomp/imperfect-invalid-scope.f90: New. * gfortran.dg/gomp/imperfect1.f90: New. * gfortran.dg/gomp/imperfect2.f90: New. * gfortran.dg/gomp/imperfect3.f90: New. * gfortran.dg/gomp/imperfect4.f90: New. * gfortran.dg/gomp/imperfect5.f90: New. libgomp/ChangeLog * testsuite/libgomp.fortran/imperfect-destructor.f90: New. * testsuite/libgomp.fortran/imperfect1.f90: New. * testsuite/libgomp.fortran/imperfect2.f90: New. * testsuite/libgomp.fortran/imperfect3.f90: New. * testsuite/libgomp.fortran/imperfect4.f90: New. * testsuite/libgomp.fortran/target-imperfect1.f90: New. * testsuite/libgomp.fortran/target-imperfect2.f90: New. * testsuite/libgomp.fortran/target-imperfect3.f90: New. * testsuite/libgomp.fortran/target-imperfect4.f90: New. --- gcc/fortran/gfortran.h | 3 + gcc/fortran/openmp.cc | 765 +++++++++++++++--- gcc/fortran/trans-stmt.cc | 7 +- gcc/testsuite/gfortran.dg/gomp/collapse1.f90 | 6 +- gcc/testsuite/gfortran.dg/gomp/collapse2.f90 | 10 +- .../gfortran.dg/gomp/imperfect-gotos.f90 | 69 ++ .../gomp/imperfect-invalid-scope.f90 | 81 ++ gcc/testsuite/gfortran.dg/gomp/imperfect1.f90 | 39 + gcc/testsuite/gfortran.dg/gomp/imperfect2.f90 | 56 ++ gcc/testsuite/gfortran.dg/gomp/imperfect3.f90 | 29 + gcc/testsuite/gfortran.dg/gomp/imperfect4.f90 | 36 + gcc/testsuite/gfortran.dg/gomp/imperfect5.f90 | 67 ++ .../libgomp.fortran/imperfect-destructor.f90 | 142 ++++ .../testsuite/libgomp.fortran/imperfect1.f90 | 67 ++ .../testsuite/libgomp.fortran/imperfect2.f90 | 102 +++ .../testsuite/libgomp.fortran/imperfect3.f90 | 110 +++ .../testsuite/libgomp.fortran/imperfect4.f90 | 121 +++ .../libgomp.fortran/target-imperfect1.f90 | 72 ++ .../libgomp.fortran/target-imperfect2.f90 | 110 +++ .../libgomp.fortran/target-imperfect3.f90 | 116 +++ .../libgomp.fortran/target-imperfect4.f90 | 126 +++ 21 files changed, 2025 insertions(+), 109 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/gomp/imperfect-gotos.f90 create mode 100644 gcc/testsuite/gfortran.dg/gomp/imperfect-invalid-scope.f90 create mode 100644 gcc/testsuite/gfortran.dg/gomp/imperfect1.f90 create mode 100644 gcc/testsuite/gfortran.dg/gomp/imperfect2.f90 create mode 100644 gcc/testsuite/gfortran.dg/gomp/imperfect3.f90 create mode 100644 gcc/testsuite/gfortran.dg/gomp/imperfect4.f90 create mode 100644 gcc/testsuite/gfortran.dg/gomp/imperfect5.f90 create mode 100644 libgomp/testsuite/libgomp.fortran/imperfect-destructor.f90 create mode 100644 libgomp/testsuite/libgomp.fortran/imperfect1.f90 create mode 100644 libgomp/testsuite/libgomp.fortran/imperfect2.f90 create mode 100644 libgomp/testsuite/libgomp.fortran/imperfect3.f90 create mode 100644 libgomp/testsuite/libgomp.fortran/imperfect4.f90 create mode 100644 libgomp/testsuite/libgomp.fortran/target-imperfect1.f90 create mode 100644 libgomp/testsuite/libgomp.fortran/target-imperfect2.f90 create mode 100644 libgomp/testsuite/libgomp.fortran/target-imperfect3.f90 create mode 100644 libgomp/testsuite/libgomp.fortran/target-imperfect4.f90 diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 30631abd788..b7429e39a5b 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -2232,6 +2232,9 @@ typedef struct gfc_namespace /* OpenMP requires. */ unsigned omp_requires:6; unsigned omp_target_seen:1; + + /* Set to 1 if this is an implicit OMP structured block. */ + unsigned omp_structured_block:1; } gfc_namespace; diff --git a/gcc/fortran/openmp.cc b/gcc/fortran/openmp.cc index 8efc4b3ecfa..e0d88dca41b 100644 --- a/gcc/fortran/openmp.cc +++ b/gcc/fortran/openmp.cc @@ -30,6 +30,7 @@ along with GCC; see the file COPYING3. If not see #include "gomp-constants.h" #include "target-memory.h" /* For gfc_encode_character. */ #include "bitmap.h" +#include "omp-api.h" /* For omp_runtime_api_procname. */ static gfc_statement omp_code_to_statement (gfc_code *); @@ -7499,15 +7500,24 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, gfc_error ("Object %qs is not a variable at %L", n->sym->name, &n->where); } - if (omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN] - && code->op != EXEC_OMP_DO - && code->op != EXEC_OMP_SIMD - && code->op != EXEC_OMP_DO_SIMD - && code->op != EXEC_OMP_PARALLEL_DO - && code->op != EXEC_OMP_PARALLEL_DO_SIMD) - gfc_error ("% REDUCTION clause on construct other than DO, SIMD, " - "DO SIMD, PARALLEL DO, PARALLEL DO SIMD at %L", - &omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN]->where); + if (omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN]) + { + locus *loc = &omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN]->where; + if (code->op != EXEC_OMP_DO + && code->op != EXEC_OMP_SIMD + && code->op != EXEC_OMP_DO_SIMD + && code->op != EXEC_OMP_PARALLEL_DO + && code->op != EXEC_OMP_PARALLEL_DO_SIMD) + gfc_error ("% REDUCTION clause on construct other than DO, " + "SIMD, DO SIMD, PARALLEL DO, PARALLEL DO SIMD at %L", + loc); + if (omp_clauses->ordered) + gfc_error ("ORDERED clause specified together with % " + "REDUCTION clause at %L", loc); + if (omp_clauses->sched_kind != OMP_SCHED_NONE) + gfc_error ("SCHEDULE clause specified together with % " + "REDUCTION clause at %L", loc); + } for (list = 0; list < OMP_LIST_NUM; list++) if (list != OMP_LIST_FIRSTPRIVATE @@ -9398,68 +9408,114 @@ static struct fortran_omp_context static gfc_code *omp_current_do_code; static int omp_current_do_collapse; +/* Forward declaration for mutually recursive functions. */ +static gfc_code * +find_nested_loop_in_block (gfc_code *block); + +/* Return the first nested DO loop in CHAIN, or NULL if there + isn't one. Does no error checking on intervening code. */ + +static gfc_code * +find_nested_loop_in_chain (gfc_code *chain) +{ + gfc_code *code; + + if (!chain) + return NULL; + + for (code = chain; code; code = code->next) + { + if (code->op == EXEC_DO) + return code; + else if (code->op == EXEC_BLOCK) + { + gfc_code *c = find_nested_loop_in_block (code); + if (c) + return c; + } + } + return NULL; +} + +/* Return the first nested DO loop in BLOCK, or NULL if there + isn't one. Does no error checking on intervening code. */ +static gfc_code * +find_nested_loop_in_block (gfc_code *block) +{ + gfc_namespace *ns; + gcc_assert (block->op == EXEC_BLOCK); + ns = block->ext.block.ns; + gcc_assert (ns); + return find_nested_loop_in_chain (ns->code); +} + void gfc_resolve_omp_do_blocks (gfc_code *code, gfc_namespace *ns) { if (code->block->next && code->block->next->op == EXEC_DO) { int i; - gfc_code *c; omp_current_do_code = code->block->next; if (code->ext.omp_clauses->orderedc) omp_current_do_collapse = code->ext.omp_clauses->orderedc; - else + else if (code->ext.omp_clauses->collapse) omp_current_do_collapse = code->ext.omp_clauses->collapse; - for (i = 1, c = omp_current_do_code; i < omp_current_do_collapse; i++) - { - c = c->block; - if (c->op != EXEC_DO || c->next == NULL) - break; - c = c->next; - if (c->op != EXEC_DO) - break; - } - if (i < omp_current_do_collapse || omp_current_do_collapse <= 0) + else omp_current_do_collapse = 1; if (code->ext.omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN]) { + /* Checking that there is a matching EXEC_OMP_SCAN in the + innermost body cannot be deferred to resolve_omp_do because + we process directives nested in the loop before we get + there. */ locus *loc = &code->ext.omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN]->where; - if (code->ext.omp_clauses->ordered) - gfc_error ("ORDERED clause specified together with % " - "REDUCTION clause at %L", loc); - if (code->ext.omp_clauses->sched_kind != OMP_SCHED_NONE) - gfc_error ("SCHEDULE clause specified together with % " - "REDUCTION clause at %L", loc); - gfc_code *block = c->block ? c->block->next : NULL; - if (block && block->op != EXEC_OMP_SCAN) - while (block && block->next && block->next->op != EXEC_OMP_SCAN) - block = block->next; - if (!block - || (block->op != EXEC_OMP_SCAN - && (!block->next || block->next->op != EXEC_OMP_SCAN))) - gfc_error ("With INSCAN at %L, expected loop body with !$OMP SCAN " - "between two structured block sequences", loc); - else + gfc_code *c; + + for (i = 1, c = omp_current_do_code; + i < omp_current_do_collapse; i++) { - if (block->op == EXEC_OMP_SCAN) - gfc_warning (0, "!$OMP SCAN at %L with zero executable " - "statements in preceding structured block " - "sequence", &block->loc); - if ((block->op == EXEC_OMP_SCAN && !block->next) - || (block->next && block->next->op == EXEC_OMP_SCAN - && !block->next->next)) - gfc_warning (0, "!$OMP SCAN at %L with zero executable " - "statements in succeeding structured block " - "sequence", block->op == EXEC_OMP_SCAN - ? &block->loc : &block->next->loc); - } - if (block && block->op != EXEC_OMP_SCAN) - block = block->next; - if (block && block->op == EXEC_OMP_SCAN) - /* Mark 'omp scan' as checked; flag will be unset later. */ - block->ext.omp_clauses->if_present = true; + c = find_nested_loop_in_chain (c->block->next); + if (!c || c->op != EXEC_DO || c->block == NULL) + break; + } + + /* Skip this if we don't have enough nested loops. That + problem will be diagnosed elsewhere. */ + if (c && c->op == EXEC_DO) + { + gfc_code *block = c->block ? c->block->next : NULL; + if (block && block->op != EXEC_OMP_SCAN) + while (block && block->next + && block->next->op != EXEC_OMP_SCAN) + block = block->next; + if (!block + || (block->op != EXEC_OMP_SCAN + && (!block->next || block->next->op != EXEC_OMP_SCAN))) + gfc_error ("With INSCAN at %L, expected loop body with " + "!$OMP SCAN between two " + "structured block sequences", loc); + else + { + if (block->op == EXEC_OMP_SCAN) + gfc_warning (0, "!$OMP SCAN at %L with zero executable " + "statements in preceding structured block " + "sequence", &block->loc); + if ((block->op == EXEC_OMP_SCAN && !block->next) + || (block->next && block->next->op == EXEC_OMP_SCAN + && !block->next->next)) + gfc_warning (0, "!$OMP SCAN at %L with zero executable " + "statements in succeeding structured block " + "sequence", block->op == EXEC_OMP_SCAN + ? &block->loc : &block->next->loc); + } + if (block && block->op != EXEC_OMP_SCAN) + block = block->next; + if (block && block->op == EXEC_OMP_SCAN) + /* Mark 'omp scan' as checked; flag will be unset later. */ + block->ext.omp_clauses->if_present = true; + } } } gfc_resolve_blocks (code->block, ns); @@ -9589,13 +9645,12 @@ gfc_resolve_do_iterator (gfc_code *code, gfc_symbol *sym, bool add_clause) private just in the !$omp do resp. !$omp parallel do construct, with no implications for the outer parallel constructs. */ - while (i-- >= 1) + while (i-- >= 1 && c) { if (code == c) return; - - c = c->block->next; - } + c = find_nested_loop_in_chain (c->block->next); + } /* An openacc context may represent a data clause. Abort if so. */ if (!omp_current_ctx->is_openmp && !oacc_is_loop (omp_current_ctx->code)) @@ -9634,20 +9689,464 @@ gfc_resolve_omp_local_vars (gfc_namespace *ns) gfc_traverse_ns (ns, handle_local_var); } + +/* Error checking on intervening code uses a code walker. */ + +struct icode_error_state +{ + const char *name; + bool errorp; + gfc_code *nested; + gfc_code *next; +}; + +static int +icode_code_error_callback (gfc_code **codep, + int *walk_subtrees ATTRIBUTE_UNUSED, void *opaque) +{ + gfc_code *code = *codep; + icode_error_state *state = (icode_error_state *)opaque; + + /* gfc_code_walker walks down CODE's next chain as well as + walking things that are actually nested in CODE. We need to + special-case traversal of outer blocks, so stop immediately if we + are heading down such a next chain. */ + if (code == state->next) + return 1; + + switch (code->op) + { + case EXEC_DO: + case EXEC_DO_WHILE: + case EXEC_DO_CONCURRENT: + gfc_error ("%s cannot contain loop in intervening code at %L", + state->name, &code->loc); + state->errorp = true; + break; + case EXEC_CYCLE: + case EXEC_EXIT: + /* Errors have already been diagnosed in match_exit_cycle. */ + state->errorp = true; + break; + case EXEC_OMP_CRITICAL: + case EXEC_OMP_DO: + case EXEC_OMP_FLUSH: + case EXEC_OMP_MASTER: + case EXEC_OMP_ORDERED: + case EXEC_OMP_PARALLEL: + case EXEC_OMP_PARALLEL_DO: + case EXEC_OMP_PARALLEL_SECTIONS: + case EXEC_OMP_PARALLEL_WORKSHARE: + case EXEC_OMP_SECTIONS: + case EXEC_OMP_SINGLE: + case EXEC_OMP_WORKSHARE: + case EXEC_OMP_ATOMIC: + case EXEC_OMP_BARRIER: + case EXEC_OMP_END_NOWAIT: + case EXEC_OMP_END_SINGLE: + case EXEC_OMP_TASK: + case EXEC_OMP_TASKWAIT: + case EXEC_OMP_TASKYIELD: + case EXEC_OMP_CANCEL: + case EXEC_OMP_CANCELLATION_POINT: + case EXEC_OMP_TASKGROUP: + case EXEC_OMP_SIMD: + case EXEC_OMP_DO_SIMD: + case EXEC_OMP_PARALLEL_DO_SIMD: + case EXEC_OMP_TARGET: + case EXEC_OMP_TARGET_DATA: + case EXEC_OMP_TEAMS: + case EXEC_OMP_DISTRIBUTE: + case EXEC_OMP_DISTRIBUTE_SIMD: + case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: + case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: + case EXEC_OMP_TARGET_TEAMS: + case EXEC_OMP_TEAMS_DISTRIBUTE: + case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: + case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: + case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: + case EXEC_OMP_TARGET_UPDATE: + case EXEC_OMP_END_CRITICAL: + case EXEC_OMP_TARGET_ENTER_DATA: + case EXEC_OMP_TARGET_EXIT_DATA: + case EXEC_OMP_TARGET_PARALLEL: + case EXEC_OMP_TARGET_PARALLEL_DO: + case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: + case EXEC_OMP_TARGET_SIMD: + case EXEC_OMP_TASKLOOP: + case EXEC_OMP_TASKLOOP_SIMD: + case EXEC_OMP_SCAN: + case EXEC_OMP_DEPOBJ: + case EXEC_OMP_PARALLEL_MASTER: + case EXEC_OMP_PARALLEL_MASTER_TASKLOOP: + case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: + case EXEC_OMP_MASTER_TASKLOOP: + case EXEC_OMP_MASTER_TASKLOOP_SIMD: + case EXEC_OMP_LOOP: + case EXEC_OMP_PARALLEL_LOOP: + case EXEC_OMP_TEAMS_LOOP: + case EXEC_OMP_TARGET_PARALLEL_LOOP: + case EXEC_OMP_TARGET_TEAMS_LOOP: + case EXEC_OMP_MASKED: + case EXEC_OMP_PARALLEL_MASKED: + case EXEC_OMP_PARALLEL_MASKED_TASKLOOP: + case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: + case EXEC_OMP_MASKED_TASKLOOP: + case EXEC_OMP_MASKED_TASKLOOP_SIMD: + case EXEC_OMP_SCOPE: + case EXEC_OMP_ERROR: + gfc_error ("%s cannot contain OpenMP directive in intervening code " + "at %L", + state->name, &code->loc); + state->errorp = true; + break; + case EXEC_CALL: + /* Per OpenMP 5.2, the "omp_" prefix is reserved, so we don't have to + consider the possibility that some locally-bound definition + overrides the runtime routine. */ + if (code->resolved_sym + && omp_runtime_api_procname (code->resolved_sym->name)) + { + gfc_error ("%s cannot contain OpenMP API call in intervening code " + "at %L", + state->name, &code->loc); + state->errorp = true; + } + break; + default: + break; + } + return 0; +} + +static int +icode_expr_error_callback (gfc_expr **expr, + int *walk_subtrees ATTRIBUTE_UNUSED, void *opaque) +{ + icode_error_state *state = (icode_error_state *)opaque; + + switch ((*expr)->expr_type) + { + /* As for EXPR_CALL with "omp_"-prefixed symbols. */ + case EXPR_FUNCTION: + { + gfc_symbol *sym = (*expr)->value.function.esym; + if (sym && omp_runtime_api_procname (sym->name)) + { + gfc_error ("%s cannot contain OpenMP API call in intervening code " + "at %L", + state->name, &((*expr)->where)); + state->errorp = true; + } + } + + break; + default: + break; + } + + /* FIXME: The description of canonical loop form in the OpenMP standard + also says "array expressions" are not permitted in intervening code. + That term is not defined in either the OpenMP spec or the Fortran + standard, although the latter uses it informally to refer to any + expression that is not scalar-valued. It is also apparently not the + thing GCC internally calls EXPR_ARRAY. It seems the intent of the + OpenMP restriction is to disallow elemental operations/intrinsics + (including things that are not expressions, like assignment + statements) that generate implicit loops over array operands + (even if the result is a scalar), but even if the spec said + that there is no list of all the cases that would be forbidden. + This is OpenMP issue 3326. */ + + return 0; +} + +static void +diagnose_intervening_code_errors_1 (gfc_code *chain, + struct icode_error_state *state) +{ + gfc_code *code; + for (code = chain; code; code = code->next) + { + if (code == state->nested) + /* Do not walk the nested loop or its body, we are only + interested in intervening code. */ + ; + else if (code->op == EXEC_BLOCK + && find_nested_loop_in_block (code) == state->nested) + /* This block contains the nested loop, recurse on its + statements. */ + { + gfc_namespace* ns = code->ext.block.ns; + diagnose_intervening_code_errors_1 (ns->code, state); + } + else + /* Treat the whole statement as a unit. */ + { + gfc_code *temp = state->next; + state->next = code->next; + gfc_code_walker (&code, icode_code_error_callback, + icode_expr_error_callback, state); + state->next = temp; + } + } +} + +/* Diagnose intervening code errors in BLOCK with nested loop NESTED. + NAME is the user-friendly name of the OMP directive, used for error + messages. Returns true if any error was found. */ +static bool +diagnose_intervening_code_errors (gfc_code *chain, const char *name, + gfc_code *nested) +{ + struct icode_error_state state; + state.name = name; + state.errorp = false; + state.nested = nested; + state.next = NULL; + diagnose_intervening_code_errors_1 (chain, &state); + return state.errorp; +} + +/* Helper function for restructure_intervening_code: wrap CHAIN in + a marker to indicate that it is a structured block sequence. That + information will be used later on (in omp-low.cc) for error checking. */ +static gfc_code * +make_structured_block (gfc_code *chain) +{ + gcc_assert (chain); + gfc_namespace *ns = gfc_build_block_ns (gfc_current_ns); + gfc_code *result = gfc_get_code (EXEC_BLOCK); + result->op = EXEC_BLOCK; + result->ext.block.ns = ns; + result->ext.block.assoc = NULL; + result->loc = chain->loc; + ns->omp_structured_block = 1; + ns->code = chain; + return result; +} + +/* Push intervening code surrounding a loop, including nested scopes, + into the body of the loop. CHAINP is the pointer to the head of + the next-chain to scan, OUTER_LOOP is the EXEC_DO for the next outer + loop level, and COLLAPSE is the number of nested loops we need to + process. + Note that CHAINP may point at outer_loop->block->next when we + are scanning the body of a loop, but if there is an intervening block + CHAINP points into the block's chain rather than its enclosing outer + loop. This is why OUTER_LOOP is passed separately. */ +static gfc_code * +restructure_intervening_code (gfc_code **chainp, gfc_code *outer_loop, + int count) +{ + gfc_code *code; + gfc_code *head = *chainp; + gfc_code *tail = NULL; + gfc_code *innermost_loop = NULL; + + for (code = *chainp; code; code = code->next, chainp = &((*chainp)->next)) + { + if (code->op == EXEC_DO) + { + /* Cut CODE free from its chain, leaving the ends dangling. */ + *chainp = NULL; + tail = code->next; + code->next = NULL; + + if (count == 1) + innermost_loop = code; + else + innermost_loop + = restructure_intervening_code (&(code->block->next), + code, count - 1); + break; + } + else if (code->op == EXEC_BLOCK + && find_nested_loop_in_block (code)) + { + gfc_namespace *ns = code->ext.block.ns; + + /* Cut CODE free from its chain, leaving the ends dangling. */ + *chainp = NULL; + tail = code->next; + code->next = NULL; + + innermost_loop + = restructure_intervening_code (&(ns->code), outer_loop, + count); + + /* At this point we have already pulled out the nested loop and + pointed outer_loop at it, and moved the intervening code that + was previously in the block into the body of innermost_loop. + Now we want to move the BLOCK itself so it wraps the entire + current body of innermost_loop. */ + ns->code = innermost_loop->block->next; + innermost_loop->block->next = code; + break; + } + } + + gcc_assert (innermost_loop); + + /* Now we have split the intervening code into two parts: + head is the start of the part before the loop/block, terminating + at *chainp, and tail is the part after it. Mark each part as + a structured block sequence, and splice the two parts around the + existing body of the innermost loop. */ + if (head != code) + { + gfc_code *block = make_structured_block (head); + if (innermost_loop->block->next) + gfc_append_code (block, innermost_loop->block->next); + innermost_loop->block->next = block; + } + if (tail) + { + gfc_code *block = make_structured_block (tail); + if (innermost_loop->block->next) + gfc_append_code (innermost_loop->block->next, block); + else + innermost_loop->block->next = block; + } + + /* For loops, finally splice CODE into OUTER_LOOP. We already handled + relinking EXEC_BLOCK above. */ + if (code->op == EXEC_DO && outer_loop) + outer_loop->block->next = code; + + return innermost_loop; +} + /* CODE is an OMP loop construct. Return true if VAR matches an iteration variable outer to level DEPTH. */ static bool is_outer_iteration_variable (gfc_code *code, int depth, gfc_symbol *var) { int i; - gfc_code *do_code = code->block->next; + gfc_code *do_code = code; for (i = 1; i < depth; i++) { + do_code = find_nested_loop_in_chain (do_code->block->next); + gcc_assert (do_code); gfc_symbol *ivar = do_code->ext.iterator->var->symtree->n.sym; if (var == ivar) return true; - do_code = do_code->block->next; + } + return false; +} + +/* Forward declaration for recursive functions. */ +static gfc_code * +check_nested_loop_in_block (gfc_code *block, gfc_expr *expr, gfc_symbol *sym, + bool *bad); + +/* Like find_nested_loop_in_chain, but additionally check that EXPR + does not reference any variables bound in intervening EXEC_BLOCKs + and that SYM is not bound in such intervening blocks. Either EXPR or SYM + may be null. Sets *BAD to true if either test fails. */ +static gfc_code * +check_nested_loop_in_chain (gfc_code *chain, gfc_expr *expr, gfc_symbol *sym, + bool *bad) +{ + for (gfc_code *code = chain; code; code = code->next) + { + if (code->op == EXEC_DO) + return code; + else if (code->op == EXEC_BLOCK) + { + gfc_code *c = check_nested_loop_in_block (code, expr, sym, bad); + if (c) + return c; + } + } + return NULL; +} + +/* Code walker for block symtrees. It doesn't take any kind of state + argument, so use a static variable. */ +static struct check_nested_loop_in_block_state_t { + gfc_expr *expr; + gfc_symbol *sym; + bool *bad; +} check_nested_loop_in_block_state; + +static void +check_nested_loop_in_block_symbol (gfc_symbol *sym) +{ + if (sym == check_nested_loop_in_block_state.sym + || (check_nested_loop_in_block_state.expr + && gfc_find_sym_in_expr (sym, + check_nested_loop_in_block_state.expr))) + *check_nested_loop_in_block_state.bad = true; +} + +/* Return the first nested DO loop in BLOCK, or NULL if there + isn't one. Set *BAD to true if EXPR references any variables in BLOCK, or + SYM is bound in BLOCK. Either EXPR or SYM may be null. */ +static gfc_code * +check_nested_loop_in_block (gfc_code *block, gfc_expr *expr, + gfc_symbol *sym, bool *bad) +{ + gfc_namespace *ns; + gcc_assert (block->op == EXEC_BLOCK); + ns = block->ext.block.ns; + gcc_assert (ns); + + /* Skip the check if this block doesn't contain the nested loop, or + if we already know it's bad. */ + gfc_code *result = check_nested_loop_in_chain (ns->code, expr, sym, bad); + if (result && !*bad) + { + check_nested_loop_in_block_state.expr = expr; + check_nested_loop_in_block_state.sym = sym; + check_nested_loop_in_block_state.bad = bad; + gfc_traverse_ns (ns, check_nested_loop_in_block_symbol); + check_nested_loop_in_block_state.expr = NULL; + check_nested_loop_in_block_state.sym = NULL; + check_nested_loop_in_block_state.bad = NULL; + } + return result; +} + +/* CODE is an OMP loop construct. Return true if EXPR references + any variables bound in intervening code, to level DEPTH. */ +static bool +expr_uses_intervening_var (gfc_code *code, int depth, gfc_expr *expr) +{ + int i; + gfc_code *do_code = code; + + for (i = 0; i < depth; i++) + { + bool bad = false; + do_code = check_nested_loop_in_chain (do_code->block->next, + expr, NULL, &bad); + if (bad) + return true; + } + return false; +} + +/* CODE is an OMP loop construct. Return true if SYM is bound in + intervening code, to level DEPTH. */ +static bool +is_intervening_var (gfc_code *code, int depth, gfc_symbol *sym) +{ + int i; + gfc_code *do_code = code; + + for (i = 0; i < depth; i++) + { + bool bad = false; + do_code = check_nested_loop_in_chain (do_code->block->next, + NULL, sym, &bad); + if (bad) + return true; } return false; } @@ -9658,14 +10157,15 @@ static bool expr_is_invariant (gfc_code *code, int depth, gfc_expr *expr) { int i; - gfc_code *do_code = code->block->next; + gfc_code *do_code = code; for (i = 1; i < depth; i++) { + do_code = find_nested_loop_in_chain (do_code->block->next); + gcc_assert (do_code); gfc_symbol *ivar = do_code->ext.iterator->var->symtree->n.sym; if (gfc_find_sym_in_expr (ivar, expr)) return false; - do_code = do_code->block->next; } return true; } @@ -9736,12 +10236,14 @@ bound_expr_is_canonical (gfc_code *code, int depth, gfc_expr *expr, static void resolve_omp_do (gfc_code *code) { - gfc_code *do_code, *c; - int list, i, collapse; + gfc_code *do_code, *next; + int list, i, count; gfc_omp_namelist *n; gfc_symbol *dovar; const char *name; bool is_simd = false; + bool errorp = false; + bool perfect_nesting_errorp = false; switch (code->op) { @@ -9844,12 +10346,12 @@ resolve_omp_do (gfc_code *code) do_code = code->block->next; if (code->ext.omp_clauses->orderedc) - collapse = code->ext.omp_clauses->orderedc; + count = code->ext.omp_clauses->orderedc; else { - collapse = code->ext.omp_clauses->collapse; - if (collapse <= 0) - collapse = 1; + count = code->ext.omp_clauses->collapse; + if (count <= 0) + count = 1; } /* While the spec defines the loop nest depth independently of the COLLAPSE @@ -9857,29 +10359,36 @@ resolve_omp_do (gfc_code *code) depth and treats any further inner loops as the final-loop-body. So here we also check canonical loop nest form only for the number of outer loops specified by the COLLAPSE clause too. */ - for (i = 1; i <= collapse; i++) + for (i = 1; i <= count; i++) { gfc_symbol *start_var = NULL, *end_var = NULL; + /* Parse errors are not recoverable. */ if (do_code->op == EXEC_DO_WHILE) { gfc_error ("%s cannot be a DO WHILE or DO without loop control " "at %L", name, &do_code->loc); - break; + return; } if (do_code->op == EXEC_DO_CONCURRENT) { gfc_error ("%s cannot be a DO CONCURRENT loop at %L", name, &do_code->loc); - break; + return; } gcc_assert (do_code->op == EXEC_DO); if (do_code->ext.iterator->var->ts.type != BT_INTEGER) - gfc_error ("%s iteration variable must be of type integer at %L", - name, &do_code->loc); + { + gfc_error ("%s iteration variable must be of type integer at %L", + name, &do_code->loc); + errorp = true; + } dovar = do_code->ext.iterator->var->symtree->n.sym; if (dovar->attr.threadprivate) - gfc_error ("%s iteration variable must not be THREADPRIVATE " - "at %L", name, &do_code->loc); + { + gfc_error ("%s iteration variable must not be THREADPRIVATE " + "at %L", name, &do_code->loc); + errorp = true; + } if (code->ext.omp_clauses) for (list = 0; list < OMP_LIST_NUM; list++) if (!is_simd || code->ext.omp_clauses->collapse > 1 @@ -9898,13 +10407,20 @@ resolve_omp_do (gfc_code *code) gfc_error ("%s iteration variable present on clause " "other than PRIVATE, LASTPRIVATE, ALLOCATE or " "LINEAR at %L", name, &do_code->loc); - break; + errorp = true; } if (is_outer_iteration_variable (code, i, dovar)) { gfc_error ("%s iteration variable used in more than one loop at %L", name, &do_code->loc); - break; + errorp = true; + } + else if (is_intervening_var (code, i, dovar)) + { + gfc_error ("%s iteration variable at %L is bound in " + "intervening code", + name, &do_code->loc); + errorp = true; } else if (!bound_expr_is_canonical (code, i, do_code->ext.iterator->start, @@ -9912,7 +10428,15 @@ resolve_omp_do (gfc_code *code) { gfc_error ("%s loop start expression not in canonical form at %L", name, &do_code->loc); - break; + errorp = true; + } + else if (expr_uses_intervening_var (code, i, + do_code->ext.iterator->start)) + { + gfc_error ("%s loop start expression at %L uses variable bound in " + "intervening code", + name, &do_code->loc); + errorp = true; } else if (!bound_expr_is_canonical (code, i, do_code->ext.iterator->end, @@ -9920,48 +10444,89 @@ resolve_omp_do (gfc_code *code) { gfc_error ("%s loop end expression not in canonical form at %L", name, &do_code->loc); - break; + errorp = true; + } + else if (expr_uses_intervening_var (code, i, + do_code->ext.iterator->end)) + { + gfc_error ("%s loop end expression at %L uses variable bound in " + "intervening code", + name, &do_code->loc); + errorp = true; } else if (start_var && end_var && start_var != end_var) { gfc_error ("%s loop bounds reference different " "iteration variables at %L", name, &do_code->loc); - break; + errorp = true; } else if (!expr_is_invariant (code, i, do_code->ext.iterator->step)) { gfc_error ("%s loop increment not in canonical form at %L", name, &do_code->loc); - break; + errorp = true; + } + else if (expr_uses_intervening_var (code, i, + do_code->ext.iterator->step)) + { + gfc_error ("%s loop increment expression at %L uses variable " + "bound in intervening code", + name, &do_code->loc); + errorp = true; } if (start_var || end_var) code->ext.omp_clauses->non_rectangular = 1; - for (c = do_code->next; c; c = c->next) - if (c->op != EXEC_NOP && c->op != EXEC_CONTINUE) - { - gfc_error ("collapsed %s loops not perfectly nested at %L", - name, &c->loc); - break; - } - if (i == collapse || c) + /* Only parse loop body into nested loop and intervening code if + there are supposed to be more loops in the nest to collapse. */ + if (i == count) break; - do_code = do_code->block; - if (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE) + + next = find_nested_loop_in_chain (do_code->block->next); + + if (!next) { - gfc_error ("not enough DO loops for collapsed %s at %L", - name, &code->loc); - break; + /* Parse error, can't recover from this. */ + gfc_error ("not enough DO loops for collapsed %s (level %d) at %L", + name, i, &code->loc); + return; } - do_code = do_code->next; - if (do_code == NULL - || (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE)) + else if (next != do_code->block->next || next->next) + /* Imperfectly nested loop found. */ { - gfc_error ("not enough DO loops for collapsed %s at %L", - name, &code->loc); - break; + /* Only diagnose violation of imperfect nesting constraints once. */ + if (!perfect_nesting_errorp) + { + if (code->ext.omp_clauses->orderedc) + { + gfc_error ("%s inner loops must be perfectly nested with " + "ORDERED clause at %L", + name, &code->loc); + perfect_nesting_errorp = true; + } + else if (code->ext.omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN]) + { + gfc_error ("%s inner loops must be perfectly nested with " + "REDUCTION INSCAN clause at %L", + name, &code->loc); + perfect_nesting_errorp = true; + } + /* FIXME: Also diagnose for TILE directives. */ + if (perfect_nesting_errorp) + errorp = true; + } + if (diagnose_intervening_code_errors (do_code->block->next, + name, next)) + errorp = true; } + do_code = next; } + + /* Give up now if we found any constraint violations. */ + if (errorp) + return; + + restructure_intervening_code (&(code->block->next), code, count); } diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc index 7e768343a57..4b508003e32 100644 --- a/gcc/fortran/trans-stmt.cc +++ b/gcc/fortran/trans-stmt.cc @@ -2334,6 +2334,7 @@ gfc_trans_block_construct (gfc_code* code) tree exit_label; stmtblock_t body; gfc_association_list *ass; + tree translated_body; ns = code->ext.block.ns; gcc_assert (ns); @@ -2352,7 +2353,11 @@ gfc_trans_block_construct (gfc_code* code) finish_oacc_declare (ns, sym, true); - gfc_add_expr_to_block (&body, gfc_trans_code (ns->code)); + translated_body = gfc_trans_code (ns->code); + if (ns->omp_structured_block) + translated_body = build1 (OMP_STRUCTURED_BLOCK, void_type_node, + translated_body); + gfc_add_expr_to_block (&body, translated_body); gfc_add_expr_to_block (&body, build1_v (LABEL_EXPR, exit_label)); /* Finish everything. */ diff --git a/gcc/testsuite/gfortran.dg/gomp/collapse1.f90 b/gcc/testsuite/gfortran.dg/gomp/collapse1.f90 index 77b2bdd7fcb..613f06f6ea9 100644 --- a/gcc/testsuite/gfortran.dg/gomp/collapse1.f90 +++ b/gcc/testsuite/gfortran.dg/gomp/collapse1.f90 @@ -31,11 +31,11 @@ subroutine collapse1 do i = 1, 3 do j = 4, 6 end do - k = 4 ! { dg-error "loops not perfectly nested" } + k = 4 end do - !$omp parallel do collapse(2) + !$omp parallel do collapse(2) ! { dg-error "not enough DO loops" } do i = 1, 3 - do ! { dg-error "cannot be a DO WHILE or DO without loop control" } + do end do end do !$omp parallel do collapse(2) diff --git a/gcc/testsuite/gfortran.dg/gomp/collapse2.f90 b/gcc/testsuite/gfortran.dg/gomp/collapse2.f90 index 1ab934e3d0d..9af3b656829 100644 --- a/gcc/testsuite/gfortran.dg/gomp/collapse2.f90 +++ b/gcc/testsuite/gfortran.dg/gomp/collapse2.f90 @@ -6,24 +6,24 @@ program p do j = 1, 8 do k = 1, 8 end do - x = 5 ! { dg-error "loops not perfectly nested" } + x = 5 end do end do - !$omp parallel do ordered(3) + !$omp parallel do ordered(3) ! { dg-error "inner loops must be perfectly nested" } do i = 1, 8 do j = 1, 8 do k = 1, 8 end do end do - x = 5 ! { dg-error "loops not perfectly nested" } + x = 5 end do - !$omp parallel do collapse(2) ! { dg-error "not enough DO loops for collapsed" } + !$omp parallel do collapse(2) do i = 1, 8 x = 5 do j = 1, 8 end do end do - !$omp parallel do ordered(2) ! { dg-error "not enough DO loops for collapsed" } + !$omp parallel do ordered(2) ! { dg-error "inner loops must be perfectly nested" } do i = 1, 8 x = 5 do j = 1, 8 diff --git a/gcc/testsuite/gfortran.dg/gomp/imperfect-gotos.f90 b/gcc/testsuite/gfortran.dg/gomp/imperfect-gotos.f90 new file mode 100644 index 00000000000..e184ffe631e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/imperfect-gotos.f90 @@ -0,0 +1,69 @@ +! This test case is expected to fail due to errors. + +! These jumps are all OK since they are to/from the same structured block. +subroutine f1 () + integer :: i, j + !$omp do collapse(2) + do i = 1, 64 + go to 10 +10 continue + do j = 1, 64 + go to 11 +11 continue + end do + go to 12 +12 continue + end do +end subroutine + +! Jump around loop body to/from different structured blocks of intervening +! code. +subroutine f2 () + integer :: i, j + !$omp do collapse(2) + do i = 1, 64 + go to 20 +20 continue + if (i > 16) go to 22 ! { dg-error "invalid branch to/from OpenMP structured block" } + do j = 1, 64 + go to 21 +21 continue + end do + go to 22 +22 continue + end do +end subroutine + +! Jump into loop body from intervening code. +subroutine f3 () + integer :: i, j + !$omp do collapse(2) + do i = 1, 64 + go to 30 +30 continue + if (i > 16) go to 31 ! { dg-error "invalid branch to/from OpenMP structured block" } + ! { dg-warning "Legacy Extension:" "" { target *-*-* } .-1 } + do j = 1, 64 + go to 31 +31 continue ! { dg-warning "Legacy Extension:" } + end do + go to 32 +32 continue + end do +end subroutine + +! Jump out of loop body to intervening code. +subroutine f4 () + integer :: i, j + !$omp do collapse(2) + do i = 1, 64 + go to 40 +40 continue + do j = 1, 64 + if (i > 16) go to 41 ! { dg-error "invalid branch to/from OpenMP structured block" } + end do +41 continue + go to 42 +42 continue + end do +end subroutine diff --git a/gcc/testsuite/gfortran.dg/gomp/imperfect-invalid-scope.f90 b/gcc/testsuite/gfortran.dg/gomp/imperfect-invalid-scope.f90 new file mode 100644 index 00000000000..7cc60944131 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/imperfect-invalid-scope.f90 @@ -0,0 +1,81 @@ +! Test that various errors involving references to variables bound +! in intervening code in the DO loop control expressions are diagnosed. + +subroutine foo (x, y) + integer :: x, y +end subroutine + +subroutine f1 () + integer :: i, j + + !$omp do collapse (2) + do i = 1, 64 + block + integer :: v + v = (i + 4) * 2 + do j = v, 64 ! { dg-error "loop start expression at .1. uses variable bound in intervening code" } + call foo (i, j) + end do + end block + end do +end subroutine + +subroutine f2 () + integer :: i, j + + !$omp do collapse (2) + do i = 1, 64 + block + integer :: v + v = (i + 4) * 2 + do j = 1, v ! { dg-error "loop end expression at .1. uses variable bound in intervening code" } + call foo (i, j) + end do + end block + end do +end subroutine + +subroutine f3 () + integer :: i, j + + !$omp do collapse (2) + do i = 1, 64 + block + integer :: v + v = (i + 4) * 2 + do j = 1, 64, v ! { dg-error "loop increment expression at .1. uses variable bound in intervening code" } + call foo (i, j) + end do + end block + end do +end subroutine + +subroutine f4 () + integer :: i + + !$omp do collapse (2) + do i = 1, 64 + block + integer :: j + do j = 1, 64 ! { dg-error "iteration variable at .1. is bound in intervening code" } + call foo (i, j) + end do + end block + end do +end subroutine + +subroutine f5 () + integer :: i + + !$omp do collapse (2) + do i = 1, 64 + block + integer :: j + integer :: v + v = (i + 4) * 2 + do j = v, 64 ! { dg-error "iteration variable at .1. is bound in intervening code" } + call foo (i, j) + end do + end block + end do +end subroutine diff --git a/gcc/testsuite/gfortran.dg/gomp/imperfect1.f90 b/gcc/testsuite/gfortran.dg/gomp/imperfect1.f90 new file mode 100644 index 00000000000..4e750d9ad05 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/imperfect1.f90 @@ -0,0 +1,39 @@ +! This test case is expected to fail due to errors. + +subroutine f1 (depth, iter) + integer :: depth, iter +end subroutine + +subroutine f2 (depth, iter) + integer :: depth, iter +end subroutine + +subroutine s1 (a1, a2, a3) + integer :: a1, a2, a3 + integer :: i, j, k + + !$omp do collapse(3) + do i = 1, a1 + call f1 (1, i) + do j = 1, a2 + call f1 (2, j) + if (i == 3) then + cycle ! { dg-error "CYCLE statement" } + else + exit ! { dg-error "EXIT statement" } + endif +!$omp barrier ! { dg-error "OpenMP directive in intervening code" } + do k = 1, a3 + call f1 (3, k) + call f2 (3, k) + end do + call f2 (2, j) + end do + do k = 1, a3 ! { dg-error "loop in intervening code" } + call f1 (3, k) + call f2 (3, k) + end do + call f2 (1, i) + end do + +end subroutine diff --git a/gcc/testsuite/gfortran.dg/gomp/imperfect2.f90 b/gcc/testsuite/gfortran.dg/gomp/imperfect2.f90 new file mode 100644 index 00000000000..d02191050d9 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/imperfect2.f90 @@ -0,0 +1,56 @@ +! This test case is expected to fail due to errors. + +! Note that the calls to these functions in the test case don't make +! any sense in terms of behavior, they're just there to test the error +! behavior. + +module omp_lib + use iso_c_binding + interface + integer function omp_get_thread_num () + end + subroutine omp_set_max_levels (i) + integer :: i + end + end interface +end module + +program junk + use omp_lib + implicit none + +contains + +subroutine f1 (depth, iter) + integer :: depth, iter +end subroutine + +subroutine f2 (depth, iter) + integer :: depth, iter +end subroutine + +subroutine s1 (a1, a2, a3) + integer :: a1, a2, a3 + integer :: i, j, k + + integer :: m + + !$omp do collapse(3) + do i = 1, a1 + call f1 (1, i) + m = omp_get_thread_num () ! { dg-error "OpenMP API call in intervening code" } + do j = 1, a2 + omp_get_thread_num () ! This is OK + call f1 (2, j) + do k = 1, a3 + call f1 (m, k) + call omp_set_max_active_levels (k) ! This is OK too + call f2 (m, k) + end do + call f2 (2, j) + call omp_set_max_active_levels (i) ! { dg-error "OpenMP API call in intervening code" } + end do + call f2 (1, i) + end do +end subroutine + +end program diff --git a/gcc/testsuite/gfortran.dg/gomp/imperfect3.f90 b/gcc/testsuite/gfortran.dg/gomp/imperfect3.f90 new file mode 100644 index 00000000000..2eccdfc8b58 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/imperfect3.f90 @@ -0,0 +1,29 @@ +! This test case is expected to fail due to errors. + +subroutine f1 (depth, iter) + integer :: depth, iter +end subroutine + +subroutine f2 (depth, iter) + integer :: depth, iter +end subroutine + +subroutine s1 (a1, a2, a3) + integer :: a1, a2, a3 + integer :: i, j, k + + !$omp do ordered(3) ! { dg-error "inner loops must be perfectly nested" } + do i = 1, a1 + call f1 (1, i) + do j = 1, a2 + call f1 (2, j) + do k = 1, a3 + call f1 (3, k) + call f2 (3, k) + end do + call f2 (2, j) + end do + call f2 (1, i) + end do + +end subroutine diff --git a/gcc/testsuite/gfortran.dg/gomp/imperfect4.f90 b/gcc/testsuite/gfortran.dg/gomp/imperfect4.f90 new file mode 100644 index 00000000000..b7ccd8b6c53 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/imperfect4.f90 @@ -0,0 +1,36 @@ +! This test case is expected to fail due to errors. + +subroutine f1 (depth, iter) + integer :: depth, iter +end subroutine + +subroutine f2 (depth, iter) + integer :: depth, iter +end subroutine + +! Unlike the C/C++ front ends, the Fortran front end already has the whole +! parse tree for the OMP DO construct before doing error checking on it. +! It gives up immediately if there are not enough nested loops for the +! specified COLLAPSE depth, without error-checking intervening code. + +subroutine s1 (a1, a2, a3) + integer :: a1, a2, a3 + integer :: i, j, k + + !$omp do collapse(4) ! { dg-error "not enough DO loops" } + do i = 1, a1 + call f1 (1, i) + do j = 1, a2 + call f1 (2, j) + do k = 1, a3 +! This is not valid intervening code, but the above error takes precedence. +!$omp barrier + call f1 (3, k) + call f2 (3, k) + end do + call f2 (2, j) + end do + call f2 (1, i) + end do + +end subroutine diff --git a/gcc/testsuite/gfortran.dg/gomp/imperfect5.f90 b/gcc/testsuite/gfortran.dg/gomp/imperfect5.f90 new file mode 100644 index 00000000000..95cc7f144a2 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/imperfect5.f90 @@ -0,0 +1,67 @@ +! This test case is expected to fail due to errors. + +subroutine f1 (depth, iter) + integer :: depth, iter +end subroutine + +subroutine f2 (depth, iter) + integer :: depth, iter +end subroutine + +function ijk (x, y, z) + integer :: ijk + integer :: x, y, z +end function + +subroutine f3 (sum) + integer :: sum +end subroutine + +! This function isn't particularly meaningful, but it should compile without +! error. +function s1 (a1, a2, a3) + integer :: s1 + integer :: a1, a2, a3 + integer :: i, j, k + integer :: r + + r = 0 + !$omp simd collapse(3) reduction (inscan, +:r) + do i = 1, a1 + do j = 1, a2 + do k = 1, a3 + r = r + ijk (i, j, k) +!$omp scan exclusive (r) + call f3 (r) + end do + end do + end do + + s1 = r +end function + +! Adding intervening code should trigger an error. +function s2 (a1, a2, a3) + integer :: s2 + integer :: a1, a2, a3 + integer :: i, j, k + integer :: r + + r = 0 + !$omp simd collapse(3) reduction (inscan, +:r) ! { dg-error "inner loops must be perfectly nested" } + do i = 1, a1 + call f1 (1, i) + do j = 1, a2 + call f1 (2, j) + do k = 1, a3 + r = r + ijk (i, j, k) +!$omp scan exclusive (r) + call f3 (r) + end do + call f2 (2, j) + end do + call f2 (1, i) + end do + + s2 = r +end function diff --git a/libgomp/testsuite/libgomp.fortran/imperfect-destructor.f90 b/libgomp/testsuite/libgomp.fortran/imperfect-destructor.f90 new file mode 100644 index 00000000000..664d27fe968 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/imperfect-destructor.f90 @@ -0,0 +1,142 @@ +! { dg-do run } + +! Like imperfect2.f90, but adds bindings to the blocks. + +module m + implicit none + type t + integer :: i + contains + final :: fini + end type t + + integer :: ccount(3), dcount(3) + + contains + + subroutine init(x, n) + type(t) :: x + integer :: n + x%i = n + ccount(x%i) = ccount(x%i) + 1 + end subroutine init + + subroutine fini(x) + type(t) :: x + dcount(x%i) = dcount(x%i) + 1 + end subroutine fini +end module m + +program foo + use m + + integer :: f1count(3), f2count(3), g1count(3), g2count(3) + + f1count(1) = 0 + f1count(2) = 0 + f1count(3) = 0 + f2count(1) = 0 + f2count(2) = 0 + f2count(3) = 0 + + g1count(1) = 0 + g1count(2) = 0 + g1count(3) = 0 + g2count(1) = 0 + g2count(2) = 0 + g2count(3) = 0 + + call s1 (3, 4, 5) + + ! All intervening code at the same depth must be executed the same + ! number of times. + if (f1count(1) /= f2count(1)) error stop 101 + if (f1count(2) /= f2count(2)) error stop 102 + if (f1count(3) /= f2count(3)) error stop 103 + if (g1count(1) /= f1count(1)) error stop 104 + if (g2count(1) /= f1count(1)) error stop 105 + if (g1count(2) /= f1count(2)) error stop 106 + if (g2count(2) /= f1count(2)) error stop 107 + if (g1count(3) /= f1count(3)) error stop 108 + if (g2count(3) /= f1count(3)) error stop 109 + + ! Intervening code must be executed at least as many times as the loop + ! that encloses it. + if (f1count(1) < 3) error stop 111 + if (f1count(2) < 3 * 4) error stop 112 + + ! Intervening code must not be executed more times than the number + ! of logical iterations. + if (f1count(1) > 3 * 4 * 5) error stop 121 + if (f1count(2) > 3 * 4 * 5) error stop 122 + + ! Check that the innermost loop body is executed exactly the number + ! of logical iterations expected. + if (f1count(3) /= 3 * 4 * 5) error stop 131 + + ! Check that constructors and destructors are called equal number of times. + if (ccount(1) /= dcount(1)) error stop 141 + if (ccount(2) /= dcount(2)) error stop 142 + if (ccount(3) /= dcount(3)) error stop 143 + +contains + +subroutine f1 (depth, iter) + integer :: depth, iter + f1count(depth) = f1count(depth) + 1 +end subroutine + +subroutine f2 (depth, iter) + integer :: depth, iter + f2count(depth) = f2count(depth) + 1 +end subroutine + +subroutine g1 (depth, iter) + integer :: depth, iter + g1count(depth) = g1count(depth) + 1 +end subroutine + +subroutine g2 (depth, iter) + integer :: depth, iter + g2count(depth) = g2count(depth) + 1 +end subroutine + +subroutine s1 (a1, a2, a3) + integer :: a1, a2, a3 + integer :: i, j, k + + !$omp do collapse(3) + do i = 1, a1 + call f1 (1, i) + block + type (t) :: local1 + call init (local1, 1) + call g1 (local1%i, i) + do j = 1, a2 + call f1 (2, j) + block + type (t) :: local2 + call init (local2, 2) + call g1 (local2%i, j) + do k = 1, a3 + call f1 (3, k) + block + type (t) :: local3 + call init (local3, 3) + call g1 (local3%i, k) + call g2 (local3%i, k) + end block + call f2 (3, k) + end do + call g2 (local2%i, j) + end block + call f2 (2, j) + end do + call g2 (local1%i, i) + end block + call f2 (1, i) + end do + +end subroutine + +end program diff --git a/libgomp/testsuite/libgomp.fortran/imperfect1.f90 b/libgomp/testsuite/libgomp.fortran/imperfect1.f90 new file mode 100644 index 00000000000..8c483c2a4e5 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/imperfect1.f90 @@ -0,0 +1,67 @@ +! { dg-do run } + +program foo + integer, save :: f1count(3), f2count(3) + + f1count(1) = 0 + f1count(2) = 0 + f1count(3) = 0 + f2count(1) = 0 + f2count(2) = 0 + f2count(3) = 0 + + call s1 (3, 4, 5) + + ! All intervening code at the same depth must be executed the same + ! number of times. + if (f1count(1) /= f2count(1)) error stop 101 + if (f1count(2) /= f2count(2)) error stop 102 + if (f1count(3) /= f2count(3)) error stop 103 + + ! Intervening code must be executed at least as many times as the loop + ! that encloses it. + if (f1count(1) < 3) error stop 111 + if (f1count(2) < 3 * 4) error stop 112 + + ! Intervening code must not be executed more times than the number + ! of logical iterations. + if (f1count(1) > 3 * 4 * 5) error stop 121 + if (f1count(2) > 3 * 4 * 5) error stop 122 + + ! Check that the innermost loop body is executed exactly the number + ! of logical iterations expected. + if (f1count(3) /= 3 * 4 * 5) error stop 131 + +contains + +subroutine f1 (depth, iter) + integer :: depth, iter + f1count(depth) = f1count(depth) + 1 +end subroutine + +subroutine f2 (depth, iter) + integer :: depth, iter + f2count(depth) = f2count(depth) + 1 +end subroutine + +subroutine s1 (a1, a2, a3) + integer :: a1, a2, a3 + integer :: i, j, k + + !$omp do collapse(3) + do i = 1, a1 + call f1 (1, i) + do j = 1, a2 + call f1 (2, j) + do k = 1, a3 + call f1 (3, k) + call f2 (3, k) + end do + call f2 (2, j) + end do + call f2 (1, i) + end do + +end subroutine + +end program diff --git a/libgomp/testsuite/libgomp.fortran/imperfect2.f90 b/libgomp/testsuite/libgomp.fortran/imperfect2.f90 new file mode 100644 index 00000000000..e42cb08031b --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/imperfect2.f90 @@ -0,0 +1,102 @@ +! { dg-do run } + +program foo + integer, save :: f1count(3), f2count(3), g1count(3), g2count(3) + + f1count(1) = 0 + f1count(2) = 0 + f1count(3) = 0 + f2count(1) = 0 + f2count(2) = 0 + f2count(3) = 0 + + g1count(1) = 0 + g1count(2) = 0 + g1count(3) = 0 + g2count(1) = 0 + g2count(2) = 0 + g2count(3) = 0 + + call s1 (3, 4, 5) + + ! All intervening code at the same depth must be executed the same + ! number of times. + if (f1count(1) /= f2count(1)) error stop 101 + if (f1count(2) /= f2count(2)) error stop 102 + if (f1count(3) /= f2count(3)) error stop 103 + if (g1count(1) /= f1count(1)) error stop 104 + if (g2count(1) /= f1count(1)) error stop 105 + if (g1count(2) /= f1count(2)) error stop 106 + if (g2count(2) /= f1count(2)) error stop 107 + if (g1count(3) /= f1count(3)) error stop 108 + if (g2count(3) /= f1count(3)) error stop 109 + + ! Intervening code must be executed at least as many times as the loop + ! that encloses it. + if (f1count(1) < 3) error stop 111 + if (f1count(2) < 3 * 4) error stop 112 + + ! Intervening code must not be executed more times than the number + ! of logical iterations. + if (f1count(1) > 3 * 4 * 5) error stop 121 + if (f1count(2) > 3 * 4 * 5) error stop 122 + + ! Check that the innermost loop body is executed exactly the number + ! of logical iterations expected. + if (f1count(3) /= 3 * 4 * 5) error stop 131 + +contains + +subroutine f1 (depth, iter) + integer :: depth, iter + f1count(depth) = f1count(depth) + 1 +end subroutine + +subroutine f2 (depth, iter) + integer :: depth, iter + f2count(depth) = f2count(depth) + 1 +end subroutine + +subroutine g1 (depth, iter) + integer :: depth, iter + g1count(depth) = g1count(depth) + 1 +end subroutine + +subroutine g2 (depth, iter) + integer :: depth, iter + g2count(depth) = g2count(depth) + 1 +end subroutine + +subroutine s1 (a1, a2, a3) + integer :: a1, a2, a3 + integer :: i, j, k + + !$omp do collapse(3) + do i = 1, a1 + call f1 (1, i) + block + call g1 (1, i) + do j = 1, a2 + call f1 (2, j) + block + call g1 (2, j) + do k = 1, a3 + call f1 (3, k) + block + call g1 (3, k) + call g2 (3, k) + end block + call f2 (3, k) + end do + call g2 (2, j) + end block + call f2 (2, j) + end do + call g2 (1, i) + end block + call f2 (1, i) + end do + +end subroutine + +end program diff --git a/libgomp/testsuite/libgomp.fortran/imperfect3.f90 b/libgomp/testsuite/libgomp.fortran/imperfect3.f90 new file mode 100644 index 00000000000..da094612332 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/imperfect3.f90 @@ -0,0 +1,110 @@ +! { dg-do run } + +! Like imperfect2.f90, but adds bindings to the blocks. + +program foo + integer, save :: f1count(3), f2count(3), g1count(3), g2count(3) + + f1count(1) = 0 + f1count(2) = 0 + f1count(3) = 0 + f2count(1) = 0 + f2count(2) = 0 + f2count(3) = 0 + + g1count(1) = 0 + g1count(2) = 0 + g1count(3) = 0 + g2count(1) = 0 + g2count(2) = 0 + g2count(3) = 0 + + call s1 (3, 4, 5) + + ! All intervening code at the same depth must be executed the same + ! number of times. + if (f1count(1) /= f2count(1)) error stop 101 + if (f1count(2) /= f2count(2)) error stop 102 + if (f1count(3) /= f2count(3)) error stop 103 + if (g1count(1) /= f1count(1)) error stop 104 + if (g2count(1) /= f1count(1)) error stop 105 + if (g1count(2) /= f1count(2)) error stop 106 + if (g2count(2) /= f1count(2)) error stop 107 + if (g1count(3) /= f1count(3)) error stop 108 + if (g2count(3) /= f1count(3)) error stop 109 + + ! Intervening code must be executed at least as many times as the loop + ! that encloses it. + if (f1count(1) < 3) error stop 111 + if (f1count(2) < 3 * 4) error stop 112 + + ! Intervening code must not be executed more times than the number + ! of logical iterations. + if (f1count(1) > 3 * 4 * 5) error stop 121 + if (f1count(2) > 3 * 4 * 5) error stop 122 + + ! Check that the innermost loop body is executed exactly the number + ! of logical iterations expected. + if (f1count(3) /= 3 * 4 * 5) error stop 131 + +contains + +subroutine f1 (depth, iter) + integer :: depth, iter + f1count(depth) = f1count(depth) + 1 +end subroutine + +subroutine f2 (depth, iter) + integer :: depth, iter + f2count(depth) = f2count(depth) + 1 +end subroutine + +subroutine g1 (depth, iter) + integer :: depth, iter + g1count(depth) = g1count(depth) + 1 +end subroutine + +subroutine g2 (depth, iter) + integer :: depth, iter + g2count(depth) = g2count(depth) + 1 +end subroutine + +subroutine s1 (a1, a2, a3) + integer :: a1, a2, a3 + integer :: i, j, k + + !$omp do collapse(3) + do i = 1, a1 + call f1 (1, i) + block + integer :: local1 + local1 = 1 + call g1 (local1, i) + do j = 1, a2 + call f1 (2, j) + block + integer :: local2 + local2 = 2 + call g1 (local2, j) + do k = 1, a3 + call f1 (3, k) + block + integer :: local3 + local3 = 3 + call g1 (local3, k) + call g2 (local3, k) + end block + call f2 (3, k) + end do + call g2 (local2, j) + end block + call f2 (2, j) + end do + call g2 (local1, i) + end block + call f2 (1, i) + end do + +end subroutine + +end program diff --git a/libgomp/testsuite/libgomp.fortran/imperfect4.f90 b/libgomp/testsuite/libgomp.fortran/imperfect4.f90 new file mode 100644 index 00000000000..1679c8c5b92 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/imperfect4.f90 @@ -0,0 +1,121 @@ +! { dg-do run } + +! Like imperfect2.f90, but includes blocks that are themselves wholly +! intervening code and not containers for nested loops. + +program foo + integer, save :: f1count(3), f2count(3), g1count(3), g2count(3) + + f1count(1) = 0 + f1count(2) = 0 + f1count(3) = 0 + f2count(1) = 0 + f2count(2) = 0 + f2count(3) = 0 + + g1count(1) = 0 + g1count(2) = 0 + g1count(3) = 0 + g2count(1) = 0 + g2count(2) = 0 + g2count(3) = 0 + + call s1 (3, 4, 5) + + ! All intervening code at the same depth must be executed the same + ! number of times. + if (f1count(1) /= f2count(1)) error stop 101 + if (f1count(2) /= f2count(2)) error stop 102 + if (f1count(3) /= f2count(3)) error stop 103 + if (g1count(1) /= f1count(1)) error stop 104 + if (g2count(1) /= f1count(1)) error stop 105 + if (g1count(2) /= f1count(2)) error stop 106 + if (g2count(2) /= f1count(2)) error stop 107 + if (g1count(3) /= f1count(3)) error stop 108 + if (g2count(3) /= f1count(3)) error stop 109 + + ! Intervening code must be executed at least as many times as the loop + ! that encloses it. + if (f1count(1) < 3) error stop 111 + if (f1count(2) < 3 * 4) error stop 112 + + ! Intervening code must not be executed more times than the number + ! of logical iterations. + if (f1count(1) > 3 * 4 * 5) error stop 121 + if (f1count(2) > 3 * 4 * 5) error stop 122 + + ! Check that the innermost loop body is executed exactly the number + ! of logical iterations expected. + if (f1count(3) /= 3 * 4 * 5) error stop 131 + +contains + +subroutine f1 (depth, iter) + integer :: depth, iter + f1count(depth) = f1count(depth) + 1 +end subroutine + +subroutine f2 (depth, iter) + integer :: depth, iter + f2count(depth) = f2count(depth) + 1 +end subroutine + +subroutine g1 (depth, iter) + integer :: depth, iter + g1count(depth) = g1count(depth) + 1 +end subroutine + +subroutine g2 (depth, iter) + integer :: depth, iter + g2count(depth) = g2count(depth) + 1 +end subroutine + +subroutine s1 (a1, a2, a3) + integer :: a1, a2, a3 + integer :: i, j, k + + !$omp do collapse(3) + do i = 1, a1 + block + call f1 (1, i) + end block + block + block + call g1 (1, i) + end block + do j = 1, a2 + block + call f1 (2, j) + end block + block + block + call g1 (2, j) + end block + do k = 1, a3 + call f1 (3, k) + block + call g1 (3, k) + call g2 (3, k) + end block + call f2 (3, k) + end do + block + call g2 (2, j) + end block + end block + block + call f2 (2, j) + end block + end do + block + call g2 (1, i) + end block + end block + block + call f2 (1, i) + end block + end do + +end subroutine + +end program diff --git a/libgomp/testsuite/libgomp.fortran/target-imperfect1.f90 b/libgomp/testsuite/libgomp.fortran/target-imperfect1.f90 new file mode 100644 index 00000000000..608eee7e424 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/target-imperfect1.f90 @@ -0,0 +1,72 @@ +! { dg-do run } + +! Like imperfect1.f90, but enables offloading. + +program foo + integer, save :: f1count(3), f2count(3) + !$omp declare target enter (f1count, f2count) + + f1count(1) = 0 + f1count(2) = 0 + f1count(3) = 0 + f2count(1) = 0 + f2count(2) = 0 + f2count(3) = 0 + + call s1 (3, 4, 5) + + ! All intervening code at the same depth must be executed the same + ! number of times. + if (f1count(1) /= f2count(1)) error stop 101 + if (f1count(2) /= f2count(2)) error stop 102 + if (f1count(3) /= f2count(3)) error stop 103 + + ! Intervening code must be executed at least as many times as the loop + ! that encloses it. + if (f1count(1) < 3) error stop 111 + if (f1count(2) < 3 * 4) error stop 112 + + ! Intervening code must not be executed more times than the number + ! of logical iterations. + if (f1count(1) > 3 * 4 * 5) error stop 121 + if (f1count(2) > 3 * 4 * 5) error stop 122 + + ! Check that the innermost loop body is executed exactly the number + ! of logical iterations expected. + if (f1count(3) /= 3 * 4 * 5) error stop 131 + +contains + +subroutine f1 (depth, iter) + integer :: depth, iter + !$omp atomic + f1count(depth) = f1count(depth) + 1 +end subroutine + +subroutine f2 (depth, iter) + integer :: depth, iter + !$omp atomic + f2count(depth) = f2count(depth) + 1 +end subroutine + +subroutine s1 (a1, a2, a3) + integer :: a1, a2, a3 + integer :: i, j, k + + !$omp target parallel do collapse(3) map(always, tofrom:f1count, f2count) + do i = 1, a1 + call f1 (1, i) + do j = 1, a2 + call f1 (2, j) + do k = 1, a3 + call f1 (3, k) + call f2 (3, k) + end do + call f2 (2, j) + end do + call f2 (1, i) + end do + +end subroutine + +end program diff --git a/libgomp/testsuite/libgomp.fortran/target-imperfect2.f90 b/libgomp/testsuite/libgomp.fortran/target-imperfect2.f90 new file mode 100644 index 00000000000..982661c278a --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/target-imperfect2.f90 @@ -0,0 +1,110 @@ +! { dg-do run } + +! Like imperfect2.f90, but enables offloading. + +program foo + integer, save :: f1count(3), f2count(3), g1count(3), g2count(3) + !$omp declare target enter (f1count, f2count) + !$omp declare target enter (g1count, g2count) + + f1count(1) = 0 + f1count(2) = 0 + f1count(3) = 0 + f2count(1) = 0 + f2count(2) = 0 + f2count(3) = 0 + + g1count(1) = 0 + g1count(2) = 0 + g1count(3) = 0 + g2count(1) = 0 + g2count(2) = 0 + g2count(3) = 0 + + call s1 (3, 4, 5) + + ! All intervening code at the same depth must be executed the same + ! number of times. + if (f1count(1) /= f2count(1)) error stop 101 + if (f1count(2) /= f2count(2)) error stop 102 + if (f1count(3) /= f2count(3)) error stop 103 + if (g1count(1) /= f1count(1)) error stop 104 + if (g2count(1) /= f1count(1)) error stop 105 + if (g1count(2) /= f1count(2)) error stop 106 + if (g2count(2) /= f1count(2)) error stop 107 + if (g1count(3) /= f1count(3)) error stop 108 + if (g2count(3) /= f1count(3)) error stop 109 + + ! Intervening code must be executed at least as many times as the loop + ! that encloses it. + if (f1count(1) < 3) error stop 111 + if (f1count(2) < 3 * 4) error stop 112 + + ! Intervening code must not be executed more times than the number + ! of logical iterations. + if (f1count(1) > 3 * 4 * 5) error stop 121 + if (f1count(2) > 3 * 4 * 5) error stop 122 + + ! Check that the innermost loop body is executed exactly the number + ! of logical iterations expected. + if (f1count(3) /= 3 * 4 * 5) error stop 131 + +contains + +subroutine f1 (depth, iter) + integer :: depth, iter + !$omp atomic + f1count(depth) = f1count(depth) + 1 +end subroutine + +subroutine f2 (depth, iter) + integer :: depth, iter + !$omp atomic + f2count(depth) = f2count(depth) + 1 +end subroutine + +subroutine g1 (depth, iter) + integer :: depth, iter + !$omp atomic + g1count(depth) = g1count(depth) + 1 +end subroutine + +subroutine g2 (depth, iter) + integer :: depth, iter + !$omp atomic + g2count(depth) = g2count(depth) + 1 +end subroutine + +subroutine s1 (a1, a2, a3) + integer :: a1, a2, a3 + integer :: i, j, k + + !$omp target parallel do collapse(3) map(always, tofrom:f1count, f2count, g1count, g2count) + do i = 1, a1 + call f1 (1, i) + block + call g1 (1, i) + do j = 1, a2 + call f1 (2, j) + block + call g1 (2, j) + do k = 1, a3 + call f1 (3, k) + block + call g1 (3, k) + call g2 (3, k) + end block + call f2 (3, k) + end do + call g2 (2, j) + end block + call f2 (2, j) + end do + call g2 (1, i) + end block + call f2 (1, i) + end do + +end subroutine + +end program diff --git a/libgomp/testsuite/libgomp.fortran/target-imperfect3.f90 b/libgomp/testsuite/libgomp.fortran/target-imperfect3.f90 new file mode 100644 index 00000000000..6f4f92d6f3f --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/target-imperfect3.f90 @@ -0,0 +1,116 @@ +! { dg-do run } + +! Like imperfect3.f90, but enables offloading. + +program foo + integer, save :: f1count(3), f2count(3), g1count(3), g2count(3) + !$omp declare target enter (f1count, f2count) + !$omp declare target enter (g1count, g2count) + + f1count(1) = 0 + f1count(2) = 0 + f1count(3) = 0 + f2count(1) = 0 + f2count(2) = 0 + f2count(3) = 0 + + g1count(1) = 0 + g1count(2) = 0 + g1count(3) = 0 + g2count(1) = 0 + g2count(2) = 0 + g2count(3) = 0 + + call s1 (3, 4, 5) + + ! All intervening code at the same depth must be executed the same + ! number of times. + if (f1count(1) /= f2count(1)) error stop 101 + if (f1count(2) /= f2count(2)) error stop 102 + if (f1count(3) /= f2count(3)) error stop 103 + if (g1count(1) /= f1count(1)) error stop 104 + if (g2count(1) /= f1count(1)) error stop 105 + if (g1count(2) /= f1count(2)) error stop 106 + if (g2count(2) /= f1count(2)) error stop 107 + if (g1count(3) /= f1count(3)) error stop 108 + if (g2count(3) /= f1count(3)) error stop 109 + + ! Intervening code must be executed at least as many times as the loop + ! that encloses it. + if (f1count(1) < 3) error stop 111 + if (f1count(2) < 3 * 4) error stop 112 + + ! Intervening code must not be executed more times than the number + ! of logical iterations. + if (f1count(1) > 3 * 4 * 5) error stop 121 + if (f1count(2) > 3 * 4 * 5) error stop 122 + + ! Check that the innermost loop body is executed exactly the number + ! of logical iterations expected. + if (f1count(3) /= 3 * 4 * 5) error stop 131 + +contains + +subroutine f1 (depth, iter) + integer :: depth, iter + !$omp atomic + f1count(depth) = f1count(depth) + 1 +end subroutine + +subroutine f2 (depth, iter) + integer :: depth, iter + !$omp atomic + f2count(depth) = f2count(depth) + 1 +end subroutine + +subroutine g1 (depth, iter) + integer :: depth, iter + !$omp atomic + g1count(depth) = g1count(depth) + 1 +end subroutine + +subroutine g2 (depth, iter) + integer :: depth, iter + !$omp atomic + g2count(depth) = g2count(depth) + 1 +end subroutine + +subroutine s1 (a1, a2, a3) + integer :: a1, a2, a3 + integer :: i, j, k + + !$omp target parallel do collapse(3) map(always, tofrom:f1count, f2count, g1count, g2count) + do i = 1, a1 + call f1 (1, i) + block + integer :: local1 + local1 = 1 + call g1 (local1, i) + do j = 1, a2 + call f1 (2, j) + block + integer :: local2 + local2 = 2 + call g1 (local2, j) + do k = 1, a3 + call f1 (3, k) + block + integer :: local3 + local3 = 3 + call g1 (local3, k) + call g2 (local3, k) + end block + call f2 (3, k) + end do + call g2 (local2, j) + end block + call f2 (2, j) + end do + call g2 (local1, i) + end block + call f2 (1, i) + end do + +end subroutine + +end program diff --git a/libgomp/testsuite/libgomp.fortran/target-imperfect4.f90 b/libgomp/testsuite/libgomp.fortran/target-imperfect4.f90 new file mode 100644 index 00000000000..59ec0e92b05 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/target-imperfect4.f90 @@ -0,0 +1,126 @@ +! { dg-do run } + +! Like imperfect4.f90, but enables offloading. + +program foo + integer, save :: f1count(3), f2count(3), g1count(3), g2count(3) + !$omp declare target enter (f1count, f2count) + !$omp declare target enter (g1count, g2count) + + f1count(1) = 0 + f1count(2) = 0 + f1count(3) = 0 + f2count(1) = 0 + f2count(2) = 0 + f2count(3) = 0 + + g1count(1) = 0 + g1count(2) = 0 + g1count(3) = 0 + g2count(1) = 0 + g2count(2) = 0 + g2count(3) = 0 + + call s1 (3, 4, 5) + + ! All intervening code at the same depth must be executed the same + ! number of times. + if (f1count(1) /= f2count(1)) error stop 101 + if (f1count(2) /= f2count(2)) error stop 102 + if (f1count(3) /= f2count(3)) error stop 103 + if (g1count(1) /= f1count(1)) error stop 104 + if (g2count(1) /= f1count(1)) error stop 105 + if (g1count(2) /= f1count(2)) error stop 106 + if (g2count(2) /= f1count(2)) error stop 107 + if (g1count(3) /= f1count(3)) error stop 108 + if (g2count(3) /= f1count(3)) error stop 109 + + ! Intervening code must be executed at least as many times as the loop + ! that encloses it. + if (f1count(1) < 3) error stop 111 + if (f1count(2) < 3 * 4) error stop 112 + + ! Intervening code must not be executed more times than the number + ! of logical iterations. + if (f1count(1) > 3 * 4 * 5) error stop 121 + if (f1count(2) > 3 * 4 * 5) error stop 122 + + ! Check that the innermost loop body is executed exactly the number + ! of logical iterations expected. + if (f1count(3) /= 3 * 4 * 5) error stop 131 + +contains + +subroutine f1 (depth, iter) + integer :: depth, iter + !$omp atomic + f1count(depth) = f1count(depth) + 1 +end subroutine + +subroutine f2 (depth, iter) + integer :: depth, iter + !$omp atomic + f2count(depth) = f2count(depth) + 1 +end subroutine + +subroutine g1 (depth, iter) + integer :: depth, iter + !$omp atomic + g1count(depth) = g1count(depth) + 1 +end subroutine + +subroutine g2 (depth, iter) + integer :: depth, iter + !$omp atomic + g2count(depth) = g2count(depth) + 1 +end subroutine + +subroutine s1 (a1, a2, a3) + integer :: a1, a2, a3 + integer :: i, j, k + + !$omp target parallel do collapse(3) map(always, tofrom:f1count, f2count, g1count, g2count) + do i = 1, a1 + block + call f1 (1, i) + end block + block + block + call g1 (1, i) + end block + do j = 1, a2 + block + call f1 (2, j) + end block + block + block + call g1 (2, j) + end block + do k = 1, a3 + call f1 (3, k) + block + call g1 (3, k) + call g2 (3, k) + end block + call f2 (3, k) + end do + block + call g2 (2, j) + end block + end block + block + call f2 (2, j) + end block + end do + block + call g2 (1, i) + end block + end block + block + call f2 (1, i) + end block + end do + +end subroutine + +end program