From patchwork Fri Dec 23 12:13:04 2022 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Julian Brown X-Patchwork-Id: 62358 Return-Path: X-Original-To: patchwork@sourceware.org Delivered-To: patchwork@sourceware.org Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 7639B38A90B9 for ; Fri, 23 Dec 2022 12:16:26 +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 124733844B3E; Fri, 23 Dec 2022 12:14:58 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.1 sourceware.org 124733844B3E 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="5.96,268,1665475200"; d="scan'208";a="90736110" Received: from orw-gwy-01-in.mentorg.com ([192.94.38.165]) by esa4.mentor.iphmx.com with ESMTP; 23 Dec 2022 04:14:57 -0800 IronPort-SDR: 0MP9st3AbCsbYAZQy05GG9kdQdrj5Ogaby2f+GIvaVTBqOmwYwgmley1PSzNOQP6PBheWuM+zN SPCNOHDCmHpTBZgTsfi7wpRlLjmT7RFsxdYjLIMyDl6A7EzXLXeMjFYqM4bRS0gKrQyICj2DWI LvRs3cF/UNwest5oHcr/4OaUIDpAP1CZB3rBSrF72TLI5+p5oDipRocDg33OCfPKO1rCCzDeKi YC1nsLk+mKqS/5AMGCL4PUHnbkqaOyg2WBTzMvK/2ekg8SSHZAIQiyi9KVHeymHfX3NgsH0hzI JLg= From: Julian Brown To: CC: , Tobias Burnus , "Jakub Jelinek" , Thomas Schwinge Subject: [PATCH v6 11/11] OpenMP: Fortran "!$omp declare mapper" support Date: Fri, 23 Dec 2022 04:13:04 -0800 Message-ID: <1bea970230e817bfc32957980b854fac1fe0a05c.1671796516.git.julian@codesourcery.com> X-Mailer: git-send-email 2.29.2 In-Reply-To: References: MIME-Version: 1.0 X-Originating-IP: [137.202.0.90] X-ClientProxiedBy: svr-ies-mbx-11.mgc.mentorg.com (139.181.222.11) To svr-ies-mbx-11.mgc.mentorg.com (139.181.222.11) X-Spam-Status: No, score=-11.8 required=5.0 tests=BAYES_00, GIT_PATCH_0, HEADER_FROM_DIFFERENT_DOMAINS, KAM_DMARC_STATUS, SPF_HELO_PASS, SPF_PASS, TXREP autolearn=ham autolearn_force=no version=3.4.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+patchwork=sourceware.org@gcc.gnu.org Sender: "Gcc-patches" This patch implements "omp declare mapper" functionality for Fortran, following the equivalent support for C and C++. Fortran differs quite substantially from C and C++ in that "map" clauses are naturally represented in the gfortran front-end's own representation rather than as trees. Those are turned into one -- or several -- OMP_CLAUSE_MAP nodes in gfc_trans_omp_clauses. The "several nodes" case is problematic for mappers, for a few different reasons: - Firstly, if we're invoking a nested mapper, we need some way of keeping those nodes together so they can be replaced "as one" by the clauses listed in that mapper. (For C and C++, a single OMP_CLAUSE_MAP node is used to represent a map clause early in compilation, which is then expanded in c_finish_omp_clauses for C, and similar for C++. We process mappers before that function is called.) - Secondly, the process of translating FE representation of clauses into "tree" mapping nodes can generate preamble code, and we need to either defer that generation or else put the preamble code somewhere if we're defining a mapper. - Thirdly, gfc_trans_omp_clauses needs to examine both the FE representation and partially-translated tree codes. In the case where we're instantiating mappers implicitly from the middle end, the FE representation is long gone. The scheme used is as follows. For the first problem, we introduce a GOMP_MAP_MAPPING_GROUP mapping kind. This is used to keep several mapping nodes together in mapper definitions until instantiation time. If the group triggers a nested mapper, the required information can be extracted from it and then it can be deleted/replaced as a whole. For the second and third problems, we emit preamble code into a function wrapping the "omp declare mapper" node. This extends the scheme currently under review for C++, and performs inlining of a modified version of the function whenever a mapper is invoked from the middle-end. New copies of variables (e.g. temporary array descriptors or other metadata) are introduced to copy needed values out of the inlined function to where they're needed in the mapper instantiation. For Fortran, we also need to add special-case handling for mapping derived-type variables that are (a) pointers and (b) trigger a mapper, in both the explicit mapping and implicit mapping cases. If we have a type and a mapper like this: type T integer, dimension(10) :: iarr end type T type(T), pointer :: tptr !$omp declare mapper (T :: t) map(t%iarr) !$omp target map(tptr) [...] !$omp end target Here "map(tptr)" maps the pointer itself, and implicitly maps the pointed-to object as well. So, when invoking the mapper, rather than rewriting this as just: !$omp target map(tptr%iarr) we must introduce a new node to map the pointer also, i.e.: !$omp target map(alloc:tptr) map(tptr%iarr) ...before the mapping nodes go off to gimplify for processing. We also need to handle module writing and reading for "declare mappers". This requires an ABI bump that I noticed one of Tobias's patches also does, so we'll probably need to synchronize on that somehow. This version of the patch is rebased wrt. current-ish mainline and refactorings that are now done higher up this patch series. 2022-12-23 Julian Brown gcc/fortran/ * dump-parse-tree.cc (show_attr): Show omp_udm_artificial_var flag. (show_omp_namelist): Support OMP_MAP_UNSET. * f95-lang.cc (LANG_HOOKS_OMP_FINISH_MAPPER_CLAUSES, LANG_HOOKS_OMP_EXTRACT_MAPPER_DIRECTIVE, LANG_HOOKS_OMP_MAP_ARRAY_SECTION): Define language hooks. * gfortran.h (gfc_statement): Add ST_OMP_DECLARE_MAPPER. (symbol_attribute): Add omp_udm_artificial_var attribute. (gfc_omp_map_op): Add OMP_MAP_UNSET. (gfc_omp_namelist): Add udm pointer to u2 union. (gfc_omp_udm): New struct. (gfc_omp_namelist_udm): New struct. (gfc_symtree): Add omp_udm pointer. (gfc_namespace): Add omp_udm_root symtree. Add omp_udm_ns flag. (gfc_free_omp_namelist): Update prototype. (gfc_free_omp_udm, gfc_omp_udm_find, gfc_find_omp_udm, gfc_resolve_omp_udms): Add prototypes. * match.cc (gfc_free_omp_namelist): Change FREE_NS and FREE_ALIGN parameters to LIST number, to handle freeing user-defined mapper namelists safely. * match.h (gfc_match_omp_declare_mapper): Add prototype. * module.cc (MOD_VERSION): Bump to 16. (ab_attribute): Add AB_OMP_DECLARE_MAPPER_VAR. (attr_bits): Add OMP_DECLARE_MAPPER_VAR. (mio_symbol_attribute): Read/write AB_OMP_DECLARE_MAPPER_VAR attribute. Set referenced attr on read. (omp_map_clause_ops, omp_map_cardinality): New arrays. (load_omp_udms, check_omp_declare_mappers): New functions. (read_module): Load and check OMP declare mappers. (write_omp_udm, write_omp_udms): New functions. (write_module): Write OMP declare mappers. * openmp.cc (gfc_free_omp_clauses, gfc_match_omp_variable_list, gfc_match_omp_to_link, gfc_match_omp_depend_sink, gfc_match_omp_clause_reduction): Update calls to gfc_free_omp_namelist. (gfc_free_omp_udm, gfc_find_omp_udm, gfc_omp_udm_find, gfc_match_omp_declare_mapper): New functions. (gfc_match_omp_clauses): Add DEFAULT_MAP_OP parameter. Update calls to gfc_free_omp_namelist. Add declare mapper support. (resolve_omp_clauses): Add declare mapper support. Update calls to gfc_free_omp_namelist. (gfc_resolve_omp_udm, gfc_resolve_omp_udms): New functions. * parse.cc (decode_omp_directive): Add declare mapper support. (case_omp_decl): Add ST_OMP_DECLARE_MAPPER case. (gfc_ascii_statement): Add ST_OMP_DECLARE_MAPPER case. * resolve.cc (resolve_types): Call gfc_resolve_omp_udms. * st.cc (gfc_free_statement): Update call to gfc_free_omp_namelist. * symbol.cc (free_omp_udm_tree): New function. (gfc_free_namespace): Call above. * trans-decl.cc (omp_declare_mapper_ns): New global. (gfc_finish_var_decl, gfc_generate_function_code): Support declare mappers. * trans-openmp.cc (tree-iterator.h): Include. (gfc_omp_finish_mapper_clauses, gfc_omp_extract_mapper_directive, gfc_omp_map_array_section): New functions. (omp_clause_directive): New enum. (gfc_trans_omp_clauses): Remove DECLARE_SIMD and OPENACC parameters. Replace with omp_clause_directive CD, defaulting to OMP_CD_OPENMP. Add declare mapper support. (gfc_trans_omp_construct, gfc_trans_oacc_executable_directive, gfc_trans_oacc_combined_directive): Update calls to gfc_trans_omp_clauses. (gfc_subst_replace, gfc_subst_prepend_ref): New variables. (gfc_subst_in_expr_1, gfc_subst_in_expr, gfc_subst_mapper_var, gfc_trans_omp_instantiate_mapper, gfc_trans_omp_instantiate_mappers, gfc_record_mapper_bindings_code_fn, gfc_record_mapper_bindings_expr_fn, gfc_find_nested_mappers, gfc_record_mapper_bindings): New functions. (gfc_typespec * hash traits): New template. (omp_declare_mapper_ns): Extern declaration. (gfc_trans_omp_target): Call gfc_trans_omp_instantiate_mappers and gfc_record_mapper_bindings. Update calls to gfc_trans_omp_clauses. (gfc_trans_omp_declare_simd, gfc_trans_omp_declare_variant): Update calls to gfc_trans_omp_clauses. (gfc_trans_omp_mapper_name, gfc_trans_omp_declare_mapper, gfc_trans_omp_declare_mappers): New functions. * trans-stmt.h (gfc_trans_omp_declare_mappers): Add prototype. * trans.h (gfc_omp_finish_mapper_clauses, gfc_omp_extract_mapper_directive, gfc_omp_map_array_section): Add prototypes. gcc/ * gimplify.cc (omp_mapping_group_data, omp_mapping_group_ptr): New functions. (omp_instantiate_mapper): Handle inlining of "declare mapper" function bodies containing setup code (e.g. for Fortran). Handle pointers to derived types. Handle GOMP_MAP_MAPPING_GROUPs. * tree-pretty-print.cc (dump_omp_clause): Handle GOMP_MAP_MAPPING_GROUP. include/ * gomp-constants.h (gomp_map_kind): Add GOMP_MAP_MAPPING_GROUP. gcc/testsuite/ * gfortran.dg/gomp/declare-mapper-1.f90: New test. * gfortran.dg/gomp/declare-mapper-5.f90: New test. * gfortran.dg/gomp/declare-mapper-14.f90: New test. * gfortran.dg/gomp/declare-mapper-16.f90: New test. libgomp/ * testsuite/libgomp.fortran/declare-mapper-2.f90: New test. * testsuite/libgomp.fortran/declare-mapper-3.f90: New test. * testsuite/libgomp.fortran/declare-mapper-4.f90: New test. * testsuite/libgomp.fortran/declare-mapper-6.f90: New test. * testsuite/libgomp.fortran/declare-mapper-7.f90: New test. * testsuite/libgomp.fortran/declare-mapper-8.f90: New test. * testsuite/libgomp.fortran/declare-mapper-9.f90: New test. * testsuite/libgomp.fortran/declare-mapper-10.f90: New test. * testsuite/libgomp.fortran/declare-mapper-11.f90: New test. * testsuite/libgomp.fortran/declare-mapper-12.f90: New test. * testsuite/libgomp.fortran/declare-mapper-13.f90: New test. * testsuite/libgomp.fortran/declare-mapper-15.f90: New test. * testsuite/libgomp.fortran/declare-mapper-17.f90: New test. * testsuite/libgomp.fortran/declare-mapper-18.f90: New test. * testsuite/libgomp.fortran/declare-mapper-19.f90: New test. * testsuite/libgomp.fortran/declare-mapper-20.f90: New test. --- gcc/fortran/dump-parse-tree.cc | 3 + gcc/fortran/f95-lang.cc | 7 + gcc/fortran/gfortran.h | 55 +- gcc/fortran/match.cc | 9 +- gcc/fortran/match.h | 1 + gcc/fortran/module.cc | 252 ++++++- gcc/fortran/openmp.cc | 299 +++++++- gcc/fortran/parse.cc | 12 +- gcc/fortran/resolve.cc | 2 + gcc/fortran/st.cc | 2 +- gcc/fortran/symbol.cc | 16 + gcc/fortran/trans-decl.cc | 30 +- gcc/fortran/trans-openmp.cc | 668 +++++++++++++++++- gcc/fortran/trans-stmt.h | 1 + gcc/fortran/trans.h | 3 + gcc/gimplify.cc | 238 ++++++- .../gfortran.dg/gomp/declare-mapper-1.f90 | 71 ++ .../gfortran.dg/gomp/declare-mapper-14.f90 | 26 + .../gfortran.dg/gomp/declare-mapper-16.f90 | 22 + .../gfortran.dg/gomp/declare-mapper-5.f90 | 45 ++ gcc/tree-pretty-print.cc | 3 + include/gomp-constants.h | 5 +- .../libgomp.fortran/declare-mapper-10.f90 | 40 ++ .../libgomp.fortran/declare-mapper-11.f90 | 38 + .../libgomp.fortran/declare-mapper-12.f90 | 33 + .../libgomp.fortran/declare-mapper-13.f90 | 49 ++ .../libgomp.fortran/declare-mapper-15.f90 | 24 + .../libgomp.fortran/declare-mapper-17.f90 | 92 +++ .../libgomp.fortran/declare-mapper-18.f90 | 46 ++ .../libgomp.fortran/declare-mapper-19.f90 | 29 + .../libgomp.fortran/declare-mapper-2.f90 | 32 + .../libgomp.fortran/declare-mapper-20.f90 | 29 + .../libgomp.fortran/declare-mapper-3.f90 | 33 + .../libgomp.fortran/declare-mapper-4.f90 | 36 + .../libgomp.fortran/declare-mapper-6.f90 | 28 + .../libgomp.fortran/declare-mapper-7.f90 | 29 + .../libgomp.fortran/declare-mapper-8.f90 | 115 +++ .../libgomp.fortran/declare-mapper-9.f90 | 27 + 38 files changed, 2391 insertions(+), 59 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/gomp/declare-mapper-1.f90 create mode 100644 gcc/testsuite/gfortran.dg/gomp/declare-mapper-14.f90 create mode 100644 gcc/testsuite/gfortran.dg/gomp/declare-mapper-16.f90 create mode 100644 gcc/testsuite/gfortran.dg/gomp/declare-mapper-5.f90 create mode 100644 libgomp/testsuite/libgomp.fortran/declare-mapper-10.f90 create mode 100644 libgomp/testsuite/libgomp.fortran/declare-mapper-11.f90 create mode 100644 libgomp/testsuite/libgomp.fortran/declare-mapper-12.f90 create mode 100644 libgomp/testsuite/libgomp.fortran/declare-mapper-13.f90 create mode 100644 libgomp/testsuite/libgomp.fortran/declare-mapper-15.f90 create mode 100644 libgomp/testsuite/libgomp.fortran/declare-mapper-17.f90 create mode 100644 libgomp/testsuite/libgomp.fortran/declare-mapper-18.f90 create mode 100644 libgomp/testsuite/libgomp.fortran/declare-mapper-19.f90 create mode 100644 libgomp/testsuite/libgomp.fortran/declare-mapper-2.f90 create mode 100644 libgomp/testsuite/libgomp.fortran/declare-mapper-20.f90 create mode 100644 libgomp/testsuite/libgomp.fortran/declare-mapper-3.f90 create mode 100644 libgomp/testsuite/libgomp.fortran/declare-mapper-4.f90 create mode 100644 libgomp/testsuite/libgomp.fortran/declare-mapper-6.f90 create mode 100644 libgomp/testsuite/libgomp.fortran/declare-mapper-7.f90 create mode 100644 libgomp/testsuite/libgomp.fortran/declare-mapper-8.f90 create mode 100644 libgomp/testsuite/libgomp.fortran/declare-mapper-9.f90 diff --git a/gcc/fortran/dump-parse-tree.cc b/gcc/fortran/dump-parse-tree.cc index ae8ca6fb5000..f39f51f525e8 100644 --- a/gcc/fortran/dump-parse-tree.cc +++ b/gcc/fortran/dump-parse-tree.cc @@ -895,6 +895,8 @@ show_attr (symbol_attribute *attr, const char * module) fputs (" PDT-STRING", dumpfile); if (attr->omp_udr_artificial_var) fputs (" OMP-UDR-ARTIFICIAL-VAR", dumpfile); + if (attr->omp_udm_artificial_var) + fputs (" OMP-UDM-ARTIFICIAL-VAR", dumpfile); if (attr->omp_declare_target) fputs (" OMP-DECLARE-TARGET", dumpfile); if (attr->omp_declare_target_link) @@ -1458,6 +1460,7 @@ show_omp_namelist (int list_type, gfc_omp_namelist *n) case OMP_MAP_ALWAYS_TOFROM: fputs ("always,tofrom:", dumpfile); break; case OMP_MAP_DELETE: fputs ("delete:", dumpfile); break; case OMP_MAP_RELEASE: fputs ("release:", dumpfile); break; + case OMP_MAP_UNSET: fputs ("unset:", dumpfile); break; default: break; } else if (list_type == OMP_LIST_LINEAR && n->u.linear.old_modifier) diff --git a/gcc/fortran/f95-lang.cc b/gcc/fortran/f95-lang.cc index 0d83f3f8b690..fab85e53f98d 100644 --- a/gcc/fortran/f95-lang.cc +++ b/gcc/fortran/f95-lang.cc @@ -136,6 +136,9 @@ gfc_get_sarif_source_language (const char *) #undef LANG_HOOKS_OMP_CLAUSE_LINEAR_CTOR #undef LANG_HOOKS_OMP_CLAUSE_DTOR #undef LANG_HOOKS_OMP_FINISH_CLAUSE +#undef LANG_HOOKS_OMP_FINISH_MAPPER_CLAUSES +#undef LANG_HOOKS_OMP_EXTRACT_MAPPER_DIRECTIVE +#undef LANG_HOOKS_OMP_MAP_ARRAY_SECTION #undef LANG_HOOKS_OMP_ALLOCATABLE_P #undef LANG_HOOKS_OMP_SCALAR_TARGET_P #undef LANG_HOOKS_OMP_SCALAR_P @@ -176,6 +179,10 @@ gfc_get_sarif_source_language (const char *) #define LANG_HOOKS_OMP_CLAUSE_LINEAR_CTOR gfc_omp_clause_linear_ctor #define LANG_HOOKS_OMP_CLAUSE_DTOR gfc_omp_clause_dtor #define LANG_HOOKS_OMP_FINISH_CLAUSE gfc_omp_finish_clause +#define LANG_HOOKS_OMP_FINISH_MAPPER_CLAUSES gfc_omp_finish_mapper_clauses +#define LANG_HOOKS_OMP_EXTRACT_MAPPER_DIRECTIVE \ + gfc_omp_extract_mapper_directive +#define LANG_HOOKS_OMP_MAP_ARRAY_SECTION gfc_omp_map_array_section #define LANG_HOOKS_OMP_ALLOCATABLE_P gfc_omp_allocatable_p #define LANG_HOOKS_OMP_SCALAR_P gfc_omp_scalar_p #define LANG_HOOKS_OMP_SCALAR_TARGET_P gfc_omp_scalar_target_p diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 3bf87cd26ed4..0abd2068b6a0 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -272,8 +272,9 @@ enum gfc_statement ST_OMP_TASKWAIT, ST_OMP_TASKYIELD, ST_OMP_CANCEL, ST_OMP_CANCELLATION_POINT, ST_OMP_TASKGROUP, ST_OMP_END_TASKGROUP, ST_OMP_SIMD, ST_OMP_END_SIMD, ST_OMP_DO_SIMD, ST_OMP_END_DO_SIMD, ST_OMP_PARALLEL_DO_SIMD, - ST_OMP_END_PARALLEL_DO_SIMD, ST_OMP_DECLARE_SIMD, ST_OMP_DECLARE_REDUCTION, - ST_OMP_TARGET, ST_OMP_END_TARGET, ST_OMP_TARGET_DATA, ST_OMP_END_TARGET_DATA, + ST_OMP_END_PARALLEL_DO_SIMD, ST_OMP_DECLARE_SIMD, ST_OMP_DECLARE_MAPPER, + ST_OMP_DECLARE_REDUCTION, ST_OMP_TARGET, ST_OMP_END_TARGET, + ST_OMP_TARGET_DATA, ST_OMP_END_TARGET_DATA, ST_OMP_TARGET_UPDATE, ST_OMP_DECLARE_TARGET, ST_OMP_DECLARE_VARIANT, ST_OMP_TEAMS, ST_OMP_END_TEAMS, ST_OMP_DISTRIBUTE, ST_OMP_END_DISTRIBUTE, ST_OMP_DISTRIBUTE_SIMD, ST_OMP_END_DISTRIBUTE_SIMD, @@ -991,6 +992,10 @@ typedef struct !$OMP DECLARE REDUCTION. */ unsigned omp_udr_artificial_var:1; + /* This is a placeholder variable used in an !$OMP DECLARE MAPPER + directive. */ + unsigned omp_udm_artificial_var:1; + /* Mentioned in OMP DECLARE TARGET. */ unsigned omp_declare_target:1; unsigned omp_declare_target_link:1; @@ -1303,7 +1308,8 @@ enum gfc_omp_map_op OMP_MAP_RELEASE, OMP_MAP_ALWAYS_TO, OMP_MAP_ALWAYS_FROM, - OMP_MAP_ALWAYS_TOFROM + OMP_MAP_ALWAYS_TOFROM, + OMP_MAP_UNSET }; enum gfc_omp_defaultmap @@ -1361,6 +1367,7 @@ typedef struct gfc_omp_namelist union { struct gfc_omp_namelist_udr *udr; + struct gfc_omp_namelist_udm *udm; gfc_namespace *ns; struct gfc_omp_namelist *duplicate_of; } u2; @@ -1717,6 +1724,35 @@ typedef struct gfc_omp_namelist_udr gfc_omp_namelist_udr; #define gfc_get_omp_namelist_udr() XCNEW (gfc_omp_namelist_udr) + +typedef struct gfc_omp_udm +{ + struct gfc_omp_udm *next; + locus where; /* Where the !$omp declare mapper construct occurred. */ + + const char *mapper_id; + gfc_typespec ts; + + struct gfc_symbol *var_sym; + struct gfc_namespace *mapper_ns; + + /* We probably don't need a whole gfc_omp_clauses here. We only use the + OMP_LIST_MAP clause list. */ + gfc_omp_clauses *clauses; + + tree backend_decl; +} +gfc_omp_udm; +#define gfc_get_omp_udm() XCNEW (gfc_omp_udm) + +typedef struct gfc_omp_namelist_udm +{ + bool multiple_elems_p; + struct gfc_omp_udm *udm; +} +gfc_omp_namelist_udm; +#define gfc_get_omp_namelist_udm() XCNEW (gfc_omp_namelist_udm) + /* The gfc_st_label structure is a BBT attached to a namespace that records the usage of statement labels within that space. */ @@ -2048,6 +2084,7 @@ typedef struct gfc_symtree gfc_common_head *common; gfc_typebound_proc *tb; gfc_omp_udr *omp_udr; + gfc_omp_udm *omp_udm; } n; } @@ -2091,6 +2128,8 @@ typedef struct gfc_namespace gfc_symtree *common_root; /* Tree containing all the OpenMP user defined reductions. */ gfc_symtree *omp_udr_root; + /* Tree containing all the OpenMP user defined mappers. */ + gfc_symtree *omp_udm_root; /* Tree containing type-bound procedures. */ gfc_symtree *tb_sym_root; @@ -2209,6 +2248,9 @@ typedef struct gfc_namespace /* Set to 1 for !$OMP DECLARE REDUCTION namespaces. */ unsigned omp_udr_ns:1; + /* Set to 1 for !$OMP DECLARE MAPPER namespaces. */ + unsigned omp_udm_ns:1; + /* Set to 1 for !$ACC ROUTINE namespaces. */ unsigned oacc_routine:1; @@ -3586,7 +3628,7 @@ void gfc_free_iterator (gfc_iterator *, int); void gfc_free_forall_iterator (gfc_forall_iterator *); void gfc_free_alloc_list (gfc_alloc *); void gfc_free_namelist (gfc_namelist *); -void gfc_free_omp_namelist (gfc_omp_namelist *, bool, bool); +void gfc_free_omp_namelist (gfc_omp_namelist *, int = OMP_LIST_NUM); void gfc_free_equiv (gfc_equiv *); void gfc_free_equiv_until (gfc_equiv *, gfc_equiv *); void gfc_free_data (gfc_data *); @@ -3607,8 +3649,12 @@ void gfc_free_omp_declare_variant_list (gfc_omp_declare_variant *list); void gfc_free_omp_declare_simd (gfc_omp_declare_simd *); void gfc_free_omp_declare_simd_list (gfc_omp_declare_simd *); void gfc_free_omp_udr (gfc_omp_udr *); +void gfc_free_omp_udm (gfc_omp_udm *); gfc_omp_udr *gfc_omp_udr_find (gfc_symtree *, gfc_typespec *); void gfc_resolve_omp_assumptions (gfc_omp_assumptions *); +gfc_omp_udm *gfc_omp_udm_find (gfc_symtree *, gfc_typespec *); +gfc_omp_udm *gfc_find_omp_udm (gfc_namespace *ns, const char *mapper_id, + gfc_typespec *ts); void gfc_resolve_omp_directive (gfc_code *, gfc_namespace *); void gfc_resolve_do_iterator (gfc_code *, gfc_symbol *, bool); void gfc_resolve_omp_local_vars (gfc_namespace *); @@ -3616,6 +3662,7 @@ void gfc_resolve_omp_parallel_blocks (gfc_code *, gfc_namespace *); void gfc_resolve_omp_do_blocks (gfc_code *, gfc_namespace *); void gfc_resolve_omp_declare_simd (gfc_namespace *); void gfc_resolve_omp_udrs (gfc_symtree *); +void gfc_resolve_omp_udms (gfc_symtree *); void gfc_omp_save_and_clear_state (struct gfc_omp_saved_state *); void gfc_omp_restore_state (struct gfc_omp_saved_state *); void gfc_free_expr_list (gfc_expr_list *); diff --git a/gcc/fortran/match.cc b/gcc/fortran/match.cc index 89fb115c0f61..6dc6440e32c0 100644 --- a/gcc/fortran/match.cc +++ b/gcc/fortran/match.cc @@ -5524,8 +5524,11 @@ gfc_free_namelist (gfc_namelist *name) /* Free an OpenMP namelist structure. */ void -gfc_free_omp_namelist (gfc_omp_namelist *name, bool free_ns, bool free_align) +gfc_free_omp_namelist (gfc_omp_namelist *name, int list) { + bool free_ns = (list == OMP_LIST_AFFINITY || list == OMP_LIST_DEPEND); + bool free_mapper = (list == OMP_LIST_MAP); + bool free_align = (list == OMP_LIST_ALLOCATE); gfc_omp_namelist *n; for (; name; name = n) @@ -5535,7 +5538,9 @@ gfc_free_omp_namelist (gfc_omp_namelist *name, bool free_ns, bool free_align) gfc_free_expr (name->u.align); if (free_ns) gfc_free_namespace (name->u2.ns); - else if (name->u2.udr) + else if (free_mapper && name->u2.udm) + free (name->u2.udm); + else if (!free_mapper && name->u2.udr) { if (name->u2.udr->combiner) gfc_free_statement (name->u2.udr->combiner); diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h index 2a805815d9ca..31d990498eaf 100644 --- a/gcc/fortran/match.h +++ b/gcc/fortran/match.h @@ -156,6 +156,7 @@ match gfc_match_omp_barrier (void); match gfc_match_omp_cancel (void); match gfc_match_omp_cancellation_point (void); match gfc_match_omp_critical (void); +match gfc_match_omp_declare_mapper (void); match gfc_match_omp_declare_reduction (void); match gfc_match_omp_declare_simd (void); match gfc_match_omp_declare_target (void); diff --git a/gcc/fortran/module.cc b/gcc/fortran/module.cc index 5ddabdcff4d7..b3a902de1801 100644 --- a/gcc/fortran/module.cc +++ b/gcc/fortran/module.cc @@ -84,7 +84,7 @@ along with GCC; see the file COPYING3. If not see /* Don't put any single quote (') in MOD_VERSION, if you want it to be recognized. */ -#define MOD_VERSION "15" +#define MOD_VERSION "16" /* Structure that describes a position within a module file. */ @@ -2081,7 +2081,8 @@ enum ab_attribute AB_IS_BIND_C, AB_IS_C_INTEROP, AB_IS_ISO_C, AB_ABSTRACT, AB_ZERO_COMP, AB_IS_CLASS, AB_PROCEDURE, AB_PROC_POINTER, AB_ASYNCHRONOUS, AB_CODIMENSION, AB_COARRAY_COMP, AB_VTYPE, AB_VTAB, AB_CONTIGUOUS, AB_CLASS_POINTER, - AB_IMPLICIT_PURE, AB_ARTIFICIAL, AB_UNLIMITED_POLY, AB_OMP_DECLARE_TARGET, + AB_IMPLICIT_PURE, AB_ARTIFICIAL, AB_UNLIMITED_POLY, + AB_OMP_DECLARE_MAPPER_VAR, AB_OMP_DECLARE_TARGET, AB_ARRAY_OUTER_DEPENDENCY, AB_MODULE_PROCEDURE, AB_OACC_DECLARE_CREATE, AB_OACC_DECLARE_COPYIN, AB_OACC_DECLARE_DEVICEPTR, AB_OACC_DECLARE_DEVICE_RESIDENT, AB_OACC_DECLARE_LINK, @@ -2149,6 +2150,7 @@ static const mstring attr_bits[] = minit ("CLASS_POINTER", AB_CLASS_POINTER), minit ("IMPLICIT_PURE", AB_IMPLICIT_PURE), minit ("UNLIMITED_POLY", AB_UNLIMITED_POLY), + minit ("OMP_DECLARE_MAPPER_VAR", AB_OMP_DECLARE_MAPPER_VAR), minit ("OMP_DECLARE_TARGET", AB_OMP_DECLARE_TARGET), minit ("ARRAY_OUTER_DEPENDENCY", AB_ARRAY_OUTER_DEPENDENCY), minit ("MODULE_PROCEDURE", AB_MODULE_PROCEDURE), @@ -2369,6 +2371,8 @@ mio_symbol_attribute (symbol_attribute *attr) MIO_NAME (ab_attribute) (AB_VTYPE, attr_bits); if (attr->vtab) MIO_NAME (ab_attribute) (AB_VTAB, attr_bits); + if (attr->omp_udm_artificial_var) + MIO_NAME (ab_attribute) (AB_OMP_DECLARE_MAPPER_VAR, attr_bits); if (attr->omp_declare_target) MIO_NAME (ab_attribute) (AB_OMP_DECLARE_TARGET, attr_bits); if (attr->array_outer_dependency) @@ -2626,6 +2630,17 @@ mio_symbol_attribute (symbol_attribute *attr) case AB_VTAB: attr->vtab = 1; break; + case AB_OMP_DECLARE_MAPPER_VAR: + attr->omp_udm_artificial_var = 1; + /* For the placeholder variable used in an !$OMP DECLARE MAPPER, + we don't know if the final clauses will reference used + variables or not, yet. Make sure the clause list doesn't get + skipped in trans-openmp.cc by forcing the variable referenced + attribute true here (else on reading the module, the symbol is + created with "referenced" false, and nothing else sets it to + true). */ + attr->referenced = 1; + break; case AB_OMP_DECLARE_TARGET: attr->omp_declare_target = 1; break; @@ -5134,6 +5149,129 @@ load_omp_udrs (void) } +/* We only need some of the enumeration values of gfc_omp_map_op for mapping + ops in the "!$omp declare mapper" clause list. */ + +static const mstring omp_map_clause_ops[] = +{ + minit ("ALLOC", OMP_MAP_ALLOC), + minit ("TO", OMP_MAP_TO), + minit ("FROM", OMP_MAP_FROM), + minit ("TOFROM", OMP_MAP_TOFROM), + minit ("ALWAYS_TO", OMP_MAP_ALWAYS_TO), + minit ("ALWAYS_FROM", OMP_MAP_ALWAYS_FROM), + minit ("ALWAYS_TOFROM", OMP_MAP_ALWAYS_TOFROM), + minit ("UNSET", OMP_MAP_UNSET), + minit (NULL, -1) +}; + + +/* Whether a namelist in an "!$omp declare mapper" maps a single element or + multiple elements. */ + +static const mstring omp_map_cardinality[] = +{ + minit ("SINGLE", 0), + minit ("MULTIPLE", 1), + minit (NULL, -1) +}; + +/* This function loads OpenMP user-defined mappers. */ + +static void +load_omp_udms (void) +{ + mio_lparen (); + while (peek_atom () != ATOM_RPAREN) + { + const char *mapper_id = NULL; + gfc_symtree *st; + + mio_lparen (); + gfc_omp_udm *udm = gfc_get_omp_udm (); + + require_atom (ATOM_INTEGER); + pointer_info *udmpi = get_integer (atom_int); + associate_integer_pointer (udmpi, udm); + + mio_pool_string (&mapper_id); + + /* Note: for a derived-type typespec, we might not have loaded the + "u.derived" symbol yet. Defer checking duplicates until + check_omp_declare_mappers is called after loading all symbols. */ + mio_typespec (&udm->ts); + + if (mapper_id == NULL) + mapper_id = gfc_get_string ("%s", ""); + + st = gfc_find_symtree (gfc_current_ns->omp_udm_root, mapper_id); + + pointer_info *p = mio_symbol_ref (&udm->var_sym); + pointer_info *q = get_integer (p->u.rsym.ns); + + udm->where = gfc_current_locus; + udm->mapper_id = mapper_id; + udm->mapper_ns = gfc_get_namespace (gfc_current_ns, 1); + udm->mapper_ns->proc_name = gfc_current_ns->proc_name; + udm->mapper_ns->omp_udm_ns = 1; + + associate_integer_pointer (q, udm->mapper_ns); + + gfc_omp_namelist *clauses = NULL; + gfc_omp_namelist **clausep = &clauses; + + mio_lparen (); + while (peek_atom () != ATOM_RPAREN) + { + /* Read each map clause. */ + gfc_omp_namelist *n = gfc_get_omp_namelist (); + + mio_lparen (); + + n->u.map_op = (gfc_omp_map_op) mio_name (0, omp_map_clause_ops); + mio_symbol_ref (&n->sym); + mio_expr (&n->expr); + + mio_lparen (); + + if (peek_atom () != ATOM_RPAREN) + { + n->u2.udm = gfc_get_omp_namelist_udm (); + n->u2.udm->multiple_elems_p = mio_name (0, omp_map_cardinality); + mio_pointer_ref (&n->u2.udm->udm); + } + + mio_rparen (); + + n->where = gfc_current_locus; + + mio_rparen (); + + *clausep = n; + clausep = &n->next; + } + mio_rparen (); + + udm->clauses = gfc_get_omp_clauses (); + udm->clauses->lists[OMP_LIST_MAP] = clauses; + + if (st) + { + udm->next = st->n.omp_udm; + st->n.omp_udm = udm; + } + else + { + st = gfc_new_symtree (&gfc_current_ns->omp_udm_root, mapper_id); + st->n.omp_udm = udm; + } + + mio_rparen (); + } + mio_rparen (); +} + + /* Recursive function to traverse the pointer_info tree and load a needed symbol. We return nonzero if we load a symbol and stop the traversal, because the act of loading can alter the tree. */ @@ -5324,12 +5462,44 @@ check_for_ambiguous (gfc_symtree *st, pointer_info *info) } +static void +check_omp_declare_mappers (gfc_symtree *st) +{ + if (!st) + return; + + check_omp_declare_mappers (st->left); + check_omp_declare_mappers (st->right); + + gfc_omp_udm **udmp = &st->n.omp_udm; + gfc_symtree tmp_st; + + while (*udmp) + { + gfc_omp_udm *udm = *udmp; + tmp_st.n.omp_udm = udm->next; + gfc_omp_udm *prev_udm = gfc_omp_udm_find (&tmp_st, &udm->ts); + if (prev_udm) + { + gfc_error ("Ambiguous !$OMP DECLARE MAPPER from module %s at %L", + udm->ts.u.derived->module, &udm->where); + gfc_error ("Previous !$OMP DECLARE MAPPER from module %s at %L", + prev_udm->ts.u.derived->module, &prev_udm->where); + /* Delete the duplicate. */ + *udmp = (*udmp)->next; + } + else + udmp = &(*udmp)->next; + } +} + + /* Read a module file. */ static void read_module (void) { - module_locus operator_interfaces, user_operators, omp_udrs; + module_locus operator_interfaces, user_operators, omp_udrs, omp_udms; const char *p; char name[GFC_MAX_SYMBOL_LEN + 1]; int i; @@ -5356,6 +5526,10 @@ read_module (void) get_module_locus (&omp_udrs); skip_list (); + /* Skip OpenMP UDMs. */ + get_module_locus (&omp_udms); + skip_list (); + mio_lparen (); /* Create the fixup nodes for all the symbols. */ @@ -5690,6 +5864,10 @@ read_module (void) set_module_locus (&omp_udrs); load_omp_udrs (); + /* Load OpenMP user defined mappers. */ + set_module_locus (&omp_udms); + load_omp_udms (); + /* At this point, we read those symbols that are needed but haven't been loaded yet. If one symbol requires another, the other gets marked as NEEDED if its previous state was UNUSED. */ @@ -5722,6 +5900,9 @@ read_module (void) module_name); } + /* Check "omp declare mappers" for duplicates from different modules. */ + check_omp_declare_mappers (gfc_current_ns->omp_udm_root); + /* Clean up symbol nodes that were never loaded, create references to hidden symbols. */ @@ -6100,6 +6281,65 @@ write_omp_udrs (gfc_symtree *st) } +static void +write_omp_udm (gfc_omp_udm *udm) +{ + /* If "!$omp declare mapper" type is private, don't write it. */ + if (!gfc_check_symbol_access (udm->ts.u.derived)) + return; + + mio_lparen (); + /* We need this pointer ref to identify this mapper so that other mappers + can refer to it. */ + mio_pointer_ref (&udm); + mio_pool_string (&udm->mapper_id); + mio_typespec (&udm->ts); + + if (udm->var_sym->module == NULL) + udm->var_sym->module = module_name; + + mio_symbol_ref (&udm->var_sym); + mio_lparen (); + gfc_omp_namelist *n; + for (n = udm->clauses->lists[OMP_LIST_MAP]; n; n = n->next) + { + mio_lparen (); + + mio_name (n->u.map_op, omp_map_clause_ops); + mio_symbol_ref (&n->sym); + mio_expr (&n->expr); + + mio_lparen (); + + if (n->u2.udm) + { + mio_name (n->u2.udm->multiple_elems_p, omp_map_cardinality); + mio_pointer_ref (&n->u2.udm->udm); + } + + mio_rparen (); + + mio_rparen (); + } + mio_rparen (); + mio_rparen (); +} + + +static void +write_omp_udms (gfc_symtree *st) +{ + if (st == NULL) + return; + + write_omp_udms (st->left); + gfc_omp_udm *udm; + for (udm = st->n.omp_udm; udm; udm = udm->next) + write_omp_udm (udm); + write_omp_udms (st->right); +} + + /* Type for the temporary tree used when writing secondary symbols. */ struct sorted_pointer_info @@ -6361,6 +6601,12 @@ write_module (void) write_char ('\n'); write_char ('\n'); + mio_lparen (); + write_omp_udms (gfc_current_ns->omp_udm_root); + mio_rparen (); + write_char ('\n'); + write_char ('\n'); + /* Write symbol information. First we traverse all symbols in the primary namespace, writing those that need to be written. Sometimes writing one symbol will cause another to need to be diff --git a/gcc/fortran/openmp.cc b/gcc/fortran/openmp.cc index b71ee467c01c..8657fef323b4 100644 --- a/gcc/fortran/openmp.cc +++ b/gcc/fortran/openmp.cc @@ -186,9 +186,7 @@ gfc_free_omp_clauses (gfc_omp_clauses *c) gfc_free_expr (c->num_workers_expr); gfc_free_expr (c->vector_length_expr); for (i = 0; i < OMP_LIST_NUM; i++) - gfc_free_omp_namelist (c->lists[i], - i == OMP_LIST_AFFINITY || i == OMP_LIST_DEPEND, - i == OMP_LIST_ALLOCATE); + gfc_free_omp_namelist (c->lists[i], i); gfc_free_expr_list (c->wait_list); gfc_free_expr_list (c->tile_list); free (CONST_CAST (char *, c->critical_name)); @@ -336,6 +334,19 @@ gfc_free_omp_udr (gfc_omp_udr *omp_udr) } } +/* Free an !$omp declare mapper. */ + +void +gfc_free_omp_udm (gfc_omp_udm *omp_udm) +{ + if (omp_udm) + { + gfc_free_omp_udm (omp_udm->next); + gfc_free_namespace (omp_udm->mapper_ns); + free (omp_udm); + } +} + static gfc_omp_udr * gfc_find_omp_udr (gfc_namespace *ns, const char *name, gfc_typespec *ts) @@ -543,7 +554,7 @@ syntax: gfc_error ("Syntax error in OpenMP variable list at %C"); cleanup: - gfc_free_omp_namelist (head, false, false); + gfc_free_omp_namelist (head); gfc_current_locus = old_loc; return MATCH_ERROR; } @@ -633,7 +644,7 @@ syntax: gfc_error ("Syntax error in OpenMP variable list at %C"); cleanup: - gfc_free_omp_namelist (head, false, false); + gfc_free_omp_namelist (head); gfc_current_locus = old_loc; return MATCH_ERROR; } @@ -742,7 +753,7 @@ syntax: gfc_error ("Syntax error in OpenMP SINK dependence-type list at %C"); cleanup: - gfc_free_omp_namelist (head, false, false); + gfc_free_omp_namelist (head); gfc_current_locus = old_loc; return MATCH_ERROR; } @@ -1468,7 +1479,7 @@ gfc_match_omp_clause_reduction (char pc, gfc_omp_clauses *c, bool openacc, *head = NULL; gfc_error_now ("!$OMP DECLARE REDUCTION %s not found at %L", buffer, &old_loc); - gfc_free_omp_namelist (n, false, false); + gfc_free_omp_namelist (n, list_idx); } else for (n = *head; n; n = n->next) @@ -1721,6 +1732,44 @@ gfc_match_dupl_atomic (bool not_dupl, const char *name) "clause at %L"); } + +/* Search upwards though namespace NS and its parents to find an + !$omp declare mapper named MAPPER_ID, for typespec TS. */ + +gfc_omp_udm * +gfc_find_omp_udm (gfc_namespace *ns, const char *mapper_id, gfc_typespec *ts) +{ + gfc_symtree *st; + + if (ns == NULL) + ns = gfc_current_ns; + + do + { + gfc_omp_udm *omp_udm; + + st = gfc_find_symtree (ns->omp_udm_root, mapper_id); + + if (st != NULL) + { + for (omp_udm = st->n.omp_udm; omp_udm; omp_udm = omp_udm->next) + if (gfc_compare_types (&omp_udm->ts, ts)) + return omp_udm; + } + + /* Don't escape an interface block. */ + if (ns && !ns->has_import_set + && ns->proc_name && ns->proc_name->attr.if_source == IFSRC_IFBODY) + break; + + ns = ns->parent; + } + while (ns != NULL); + + return NULL; +} + + /* Match OpenMP and OpenACC directive clauses. MASK is a bitmask of clauses that are allowed for a particular directive. */ @@ -1728,7 +1777,8 @@ static match gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, bool first = true, bool needs_space = true, bool openacc = false, bool context_selector = false, - bool openmp_target = false) + bool openmp_target = false, + gfc_omp_map_op default_map_op = OMP_MAP_TOFROM) { bool error = false; gfc_omp_clauses *c = gfc_get_omp_clauses (); @@ -1786,7 +1836,7 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, if (end_colon && gfc_match (" %e )", &alignment) != MATCH_YES) { - gfc_free_omp_namelist (*head, false, false); + gfc_free_omp_namelist (*head); gfc_current_locus = old_loc; *head = NULL; break; @@ -2728,7 +2778,7 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, end_colon = true; else if (gfc_match (" )") != MATCH_YES) { - gfc_free_omp_namelist (*head, false, false); + gfc_free_omp_namelist (*head); gfc_current_locus = old_loc; *head = NULL; break; @@ -2739,7 +2789,7 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, { if (gfc_match (" %e )", &step) != MATCH_YES) { - gfc_free_omp_namelist (*head, false, false); + gfc_free_omp_namelist (*head); gfc_current_locus = old_loc; *head = NULL; goto error; @@ -2836,7 +2886,7 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, } if (has_error) { - gfc_free_omp_namelist (*head, false, false); + gfc_free_omp_namelist (*head); *head = NULL; goto error; } @@ -2877,8 +2927,11 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, locus old_loc2 = gfc_current_locus; int always_modifier = 0; int close_modifier = 0; + int mapper_modifier = 0; locus second_always_locus = old_loc2; locus second_close_locus = old_loc2; + locus second_mapper_locus = old_loc2; + char mapper_id[GFC_MAX_SYMBOL_LEN + 1] = { '\0' }; for (;;) { @@ -2893,12 +2946,20 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, if (close_modifier++ == 1) second_close_locus = current_locus; } + else if (gfc_match ("mapper ( ") == MATCH_YES) + { + if (mapper_modifier++ == 1) + second_mapper_locus = current_locus; + m = gfc_match (" %n ) ", mapper_id); + if (m != MATCH_YES) + goto error; + } else break; gfc_match (", "); } - gfc_omp_map_op map_op = OMP_MAP_TOFROM; + gfc_omp_map_op map_op = default_map_op; if (gfc_match ("alloc : ") == MATCH_YES) map_op = OMP_MAP_ALLOC; else if (gfc_match ("tofrom : ") == MATCH_YES) @@ -2916,6 +2977,7 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, gfc_current_locus = old_loc2; always_modifier = 0; close_modifier = 0; + mapper_modifier = 0; } if (always_modifier > 1) @@ -2930,6 +2992,12 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, &second_close_locus); break; } + if (mapper_modifier > 1) + { + gfc_error ("too many % modifiers at %L", + &second_mapper_locus); + break; + } head = NULL; if (gfc_match_omp_variable_list ("", &c->lists[OMP_LIST_MAP], @@ -2938,7 +3006,23 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, { gfc_omp_namelist *n; for (n = *head; n; n = n->next) - n->u.map_op = map_op; + { + n->u.map_op = map_op; + + gfc_typespec *ts; + if (n->expr) + ts = &n->expr->ts; + else + ts = &n->sym->ts; + + gfc_omp_udm *udm + = gfc_find_omp_udm (gfc_current_ns, mapper_id, ts); + if (udm) + { + n->u2.udm = gfc_get_omp_namelist_udm (); + n->u2.udm->udm = udm; + } + } continue; } gfc_current_locus = old_loc; @@ -4646,14 +4730,14 @@ gfc_match_omp_flush (void) { gfc_error ("List specified together with memory order clause in FLUSH " "directive at %C"); - gfc_free_omp_namelist (list, false, false); + gfc_free_omp_namelist (list); gfc_free_omp_clauses (c); return MATCH_ERROR; } if (gfc_match_omp_eos () != MATCH_YES) { gfc_error ("Unexpected junk after $OMP FLUSH statement at %C"); - gfc_free_omp_namelist (list, false, false); + gfc_free_omp_namelist (list); gfc_free_omp_clauses (c); return MATCH_ERROR; } @@ -4704,6 +4788,153 @@ gfc_match_omp_declare_simd (void) } +/* Find a matching "!$omp declare mapper" for typespec TS in symtree ST. */ + +gfc_omp_udm * +gfc_omp_udm_find (gfc_symtree *st, gfc_typespec *ts) +{ + gfc_omp_udm *omp_udm; + + if (st == NULL) + return NULL; + + for (omp_udm = st->n.omp_udm; omp_udm; omp_udm = omp_udm->next) + if ((omp_udm->ts.type == BT_DERIVED || omp_udm->ts.type == BT_CLASS) + && (ts->type == BT_DERIVED || ts->type == BT_CLASS) + && strcmp (omp_udm->ts.u.derived->name, ts->u.derived->name) == 0) + return omp_udm; + + return NULL; +} + + +match +gfc_match_omp_declare_mapper (void) +{ + match m; + gfc_typespec ts; + char mapper_id[GFC_MAX_SYMBOL_LEN + 1]; + char var[GFC_MAX_SYMBOL_LEN + 1]; + gfc_namespace *mapper_ns = NULL; + gfc_symtree *var_st; + gfc_symtree *st; + gfc_omp_udm *omp_udm = NULL, *prev_udm = NULL; + locus where = gfc_current_locus; + + if (gfc_match_char ('(') != MATCH_YES) + return MATCH_ERROR; + + locus old_locus = gfc_current_locus; + + m = gfc_match (" %n : ", mapper_id); + + if (m == MATCH_ERROR) + return MATCH_ERROR; + + /* As a special case, a mapper named "default" and an unnamed mapper are + both the default mapper for a given type. */ + if (strcmp (mapper_id, "default") == 0) + mapper_id[0] = '\0'; + + if (gfc_peek_ascii_char () == ':') + { + /* If we see '::', the user did not name the mapper, and instead we just + saw the type. So backtrack and try parsing as a type instead. */ + mapper_id[0] = '\0'; + gfc_current_locus = old_locus; + } + + /* This accepts 't' but not e.g. 'type(t)'. Is that correct? */ + m = gfc_match_type_spec (&ts); + if (m != MATCH_YES) + return MATCH_ERROR; + + if (ts.type != BT_DERIVED) + { + gfc_error_now ("!$OMP DECLARE MAPPER with non-derived type at %C"); + return MATCH_ERROR; + } + + if (gfc_match (" :: ") != MATCH_YES) + return MATCH_ERROR; + + if (gfc_match_name (var) != MATCH_YES) + return MATCH_ERROR; + + if (gfc_match_char (')') != MATCH_YES) + return MATCH_ERROR; + + st = gfc_find_symtree (gfc_current_ns->omp_udm_root, mapper_id); + + /* Now we need to set up a new namespace, and create a new sym_tree for our + dummy variable so we can use it in the following list of mapping + clauses. */ + + gfc_current_ns = mapper_ns = gfc_get_namespace (gfc_current_ns, 1); + mapper_ns->proc_name = mapper_ns->parent->proc_name; + mapper_ns->omp_udm_ns = 1; + + gfc_get_sym_tree (var, mapper_ns, &var_st, false); + var_st->n.sym->ts = ts; + var_st->n.sym->attr.omp_udm_artificial_var = 1; + var_st->n.sym->attr.flavor = FL_VARIABLE; + gfc_commit_symbols (); + + gfc_omp_clauses *clauses = NULL; + + m = gfc_match_omp_clauses (&clauses, omp_mask (OMP_CLAUSE_MAP), true, true, + false, false, false, OMP_MAP_UNSET); + if (m != MATCH_YES) + goto failure; + + omp_udm = gfc_get_omp_udm (); + omp_udm->next = NULL; + omp_udm->where = where; + omp_udm->mapper_id = gfc_get_string ("%s", mapper_id); + omp_udm->ts = ts; + omp_udm->var_sym = var_st->n.sym; + omp_udm->mapper_ns = mapper_ns; + omp_udm->clauses = clauses; + + gfc_current_ns = mapper_ns->parent; + + prev_udm = gfc_omp_udm_find (st, &ts); + if (prev_udm) + { + gfc_error_now ("Redefinition of !$OMP DECLARE MAPPER at %L", &where); + gfc_error_now ("Previous !$OMP DECLARE MAPPER at %L", &prev_udm->where); + } + else if (st) + { + omp_udm->next = st->n.omp_udm; + st->n.omp_udm = omp_udm; + } + else + { + st = gfc_new_symtree (&gfc_current_ns->omp_udm_root, mapper_id); + st->n.omp_udm = omp_udm; + } + + if (gfc_match_omp_eos () != MATCH_YES) + { + gfc_error ("Unexpected junk after !$OMP DECLARE MAPPER at %C"); + gfc_current_locus = where; + return MATCH_ERROR; + } + + return MATCH_YES; + +failure: + if (mapper_ns) + gfc_current_ns = mapper_ns->parent; + gfc_free_omp_udm (omp_udm); + + gfc_clear_error (); + + return MATCH_ERROR; +} + + static bool match_udr_expr (gfc_symtree *omp_sym1, gfc_symtree *omp_sym2) { @@ -7156,9 +7387,13 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, n->sym->reduc_mark = 0; if (n->sym->attr.flavor == FL_VARIABLE || n->sym->attr.proc_pointer - || (!code && (!n->sym->attr.dummy || n->sym->ns != ns))) + || (!code + && !ns->omp_udm_ns + && (!n->sym->attr.dummy || n->sym->ns != ns))) { - if (!code && (!n->sym->attr.dummy || n->sym->ns != ns)) + if (!code + && !ns->omp_udm_ns + && (!n->sym->attr.dummy || n->sym->ns != ns)) gfc_error ("Variable %qs is not a dummy argument at %L", n->sym->name, &n->where); continue; @@ -7419,7 +7654,7 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, { prev->next = n->next; n->next = NULL; - gfc_free_omp_namelist (n, false, true); + gfc_free_omp_namelist (n, OMP_LIST_ALLOCATE); n = prev->next; } continue; @@ -7696,7 +7931,8 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, array isn't contiguous. An expression such as arr(-n:n,-n:n) could be contiguous even if it looks like it may not be. */ - if (code->op != EXEC_OACC_UPDATE + if (code + && code->op != EXEC_OACC_UPDATE && list != OMP_LIST_CACHE && list != OMP_LIST_DEPEND && !gfc_is_simply_contiguous (n->expr, false, true) @@ -7793,7 +8029,7 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, gfc_error ("List item %qs with allocatable components is not " "permitted in map clause at %L", n->sym->name, &n->where); - if (list == OMP_LIST_MAP && !openacc) + if (code && list == OMP_LIST_MAP && !openacc) switch (code->op) { case EXEC_OMP_TARGET: @@ -10372,3 +10608,24 @@ gfc_resolve_omp_udrs (gfc_symtree *st) for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next) gfc_resolve_omp_udr (omp_udr); } + +/* Resolve !$omp declare mapper constructs. */ + +static void +gfc_resolve_omp_udm (gfc_omp_udm *omp_udm) +{ + resolve_omp_clauses (NULL, omp_udm->clauses, omp_udm->mapper_ns); +} + +void +gfc_resolve_omp_udms (gfc_symtree *st) +{ + gfc_omp_udm *omp_udm; + + if (st == NULL) + return; + gfc_resolve_omp_udms (st->left); + gfc_resolve_omp_udms (st->right); + for (omp_udm = st->n.omp_udm; omp_udm; omp_udm = omp_udm->next) + gfc_resolve_omp_udm (omp_udm); +} diff --git a/gcc/fortran/parse.cc b/gcc/fortran/parse.cc index c1015078d17f..591f63e98b4e 100644 --- a/gcc/fortran/parse.cc +++ b/gcc/fortran/parse.cc @@ -902,6 +902,8 @@ decode_omp_directive (void) matcho ("critical", gfc_match_omp_critical, ST_OMP_CRITICAL); break; case 'd': + matchds ("declare mapper", gfc_match_omp_declare_mapper, + ST_OMP_DECLARE_MAPPER); matchds ("declare reduction", gfc_match_omp_declare_reduction, ST_OMP_DECLARE_REDUCTION); matcho ("depobj", gfc_match_omp_depobj, ST_OMP_DEPOBJ); @@ -1740,9 +1742,10 @@ next_statement (void) the specification part. */ #define case_omp_decl case ST_OMP_THREADPRIVATE: case ST_OMP_DECLARE_SIMD: \ - case ST_OMP_DECLARE_TARGET: case ST_OMP_DECLARE_REDUCTION: \ - case ST_OMP_DECLARE_VARIANT: case ST_OMP_ASSUMES: \ - case ST_OMP_REQUIRES: case ST_OACC_ROUTINE: case ST_OACC_DECLARE + case ST_OMP_DECLARE_TARGET: case ST_OMP_DECLARE_MAPPER: \ + case ST_OMP_DECLARE_REDUCTION: case ST_OMP_DECLARE_VARIANT: \ + case ST_OMP_ASSUMES: case ST_OMP_REQUIRES: case ST_OACC_ROUTINE: \ + case ST_OACC_DECLARE /* Block end statements. Errors associated with interchanging these are detected in gfc_match_end(). */ @@ -2383,6 +2386,9 @@ gfc_ascii_statement (gfc_statement st, bool strip_sentinel) case ST_OMP_CRITICAL: p = "!$OMP CRITICAL"; break; + case ST_OMP_DECLARE_MAPPER: + p = "!$OMP DECLARE MAPPER"; + break; case ST_OMP_DECLARE_REDUCTION: p = "!$OMP DECLARE REDUCTION"; break; diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc index 0f5f1d277e48..dcec7f0c410f 100644 --- a/gcc/fortran/resolve.cc +++ b/gcc/fortran/resolve.cc @@ -17591,6 +17591,8 @@ resolve_types (gfc_namespace *ns) gfc_resolve_omp_udrs (ns->omp_udr_root); + gfc_resolve_omp_udms (ns->omp_udm_root); + ns->types_resolved = 1; gfc_current_ns = old_ns; diff --git a/gcc/fortran/st.cc b/gcc/fortran/st.cc index 8b4ca5ec2ea0..7ebb70d2f392 100644 --- a/gcc/fortran/st.cc +++ b/gcc/fortran/st.cc @@ -286,7 +286,7 @@ gfc_free_statement (gfc_code *p) break; case EXEC_OMP_FLUSH: - gfc_free_omp_namelist (p->ext.omp_namelist, false, false); + gfc_free_omp_namelist (p->ext.omp_namelist); break; case EXEC_OMP_BARRIER: diff --git a/gcc/fortran/symbol.cc b/gcc/fortran/symbol.cc index e704e7ac2bd6..b62000602528 100644 --- a/gcc/fortran/symbol.cc +++ b/gcc/fortran/symbol.cc @@ -3876,6 +3876,21 @@ free_omp_udr_tree (gfc_symtree * omp_udr_tree) free (omp_udr_tree); } +/* Similar, for !$omp declare mappers. */ + +static void +free_omp_udm_tree (gfc_symtree *omp_udm_tree) +{ + if (omp_udm_tree == NULL) + return; + + free_omp_udm_tree (omp_udm_tree->left); + free_omp_udm_tree (omp_udm_tree->right); + + gfc_free_omp_udm (omp_udm_tree->n.omp_udm); + free (omp_udm_tree); +} + /* Recursive function that deletes an entire tree and all the user operator nodes that it contains. */ @@ -4050,6 +4065,7 @@ gfc_free_namespace (gfc_namespace *&ns) free_uop_tree (ns->uop_root); free_common_tree (ns->common_root); free_omp_udr_tree (ns->omp_udr_root); + free_omp_udm_tree (ns->omp_udm_root); free_tb_tree (ns->tb_sym_root); free_tb_tree (ns->tb_uop_root); gfc_free_finalizer_list (ns->finalizers); diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc index 217de6b8da04..d1f8e02a20a7 100644 --- a/gcc/fortran/trans-decl.cc +++ b/gcc/fortran/trans-decl.cc @@ -88,6 +88,11 @@ static stmtblock_t caf_init_block; tree gfc_static_ctors; +/* The namespace in which to look up "declare mapper" mappers (in + trans-openmp.cc:gfc_trans_omp_target). This is somewhat grubby. */ + +gfc_namespace *omp_declare_mapper_ns; + /* Whether we've seen a symbol from an IEEE module in the namespace. */ static int seen_ieee_symbol; @@ -639,9 +644,12 @@ gfc_finish_var_decl (tree decl, gfc_symbol * sym) function scope. */ if (current_function_decl != NULL_TREE) { - if (sym->ns->proc_name - && (sym->ns->proc_name->backend_decl == current_function_decl - || sym->result == sym)) + if (sym->ns->omp_udm_ns) + /* ...except for in omp declare mappers, which are special. */ + pushdecl (decl); + else if (sym->ns->proc_name + && (sym->ns->proc_name->backend_decl == current_function_decl + || sym->result == sym)) gfc_add_decl_to_function (decl); else if (sym->ns->proc_name && sym->ns->proc_name->attr.flavor == FL_LABEL) @@ -7603,6 +7611,16 @@ gfc_generate_function_code (gfc_namespace * ns) gfc_conv_cfi_to_gfc (&init, &cleanup, tmp, desc, fsym); } + { + tree dm_saved_parent_function_decls = saved_parent_function_decls; + saved_parent_function_decls = saved_function_decls; + /* NOTE: Decls referenced in a mapper (other than the placeholder variable) + may be added to "saved_parent_function_decls". */ + gfc_trans_omp_declare_mappers (ns->omp_udm_root); + saved_function_decls = saved_parent_function_decls; + saved_parent_function_decls = dm_saved_parent_function_decls; + } + gfc_generate_contained_functions (ns); has_coarray_vars = false; @@ -7671,9 +7689,15 @@ gfc_generate_function_code (gfc_namespace * ns) finish_oacc_declare (ns, sym, false); + /* Record the namespace for looking up OpenMP declare mappers in. */ + omp_declare_mapper_ns = ns; + tmp = gfc_trans_code (ns->code); gfc_add_expr_to_block (&body, tmp); + /* Unset this to avoid accidentally using a stale pointer. */ + omp_declare_mapper_ns = NULL; + if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node || (sym->result && sym->result != sym && sym->result->ts.type == BT_DERIVED diff --git a/gcc/fortran/trans-openmp.cc b/gcc/fortran/trans-openmp.cc index 5b5bce26ad36..de638c487c5a 100644 --- a/gcc/fortran/trans-openmp.cc +++ b/gcc/fortran/trans-openmp.cc @@ -49,6 +49,7 @@ along with GCC; see the file COPYING3. If not see #define GCC_DIAG_STYLE __gcc_gfc__ #include "attribs.h" #include "function.h" +#include "tree-iterator.h" int ompws_flags; @@ -2522,6 +2523,107 @@ gfc_trans_omp_array_section (stmtblock_t *block, gfc_omp_namelist *n, ptr, ptr2); } +/* CLAUSES is a list of clauses resulting from an "omp declare mapper" + instantiation in gimplify.cc. In some cases we don't know if we need to + create any extra mapping nodes as a result of mapper expansion until after + substitution has taken place, so do that now. */ + +tree +gfc_omp_finish_mapper_clauses (tree clauses) +{ + tree *clausep = &clauses; + + while (*clausep) + { + tree n = *clausep; + + if (OMP_CLAUSE_CODE (n) != OMP_CLAUSE_MAP) + { + clausep = &OMP_CLAUSE_CHAIN (*clausep); + continue; + } + + tree decl = OMP_CLAUSE_DECL (n); + + switch (OMP_CLAUSE_MAP_KIND (n)) + { + case GOMP_MAP_ALLOC: + case GOMP_MAP_TO: + case GOMP_MAP_FROM: + case GOMP_MAP_TOFROM: + case GOMP_MAP_ALWAYS_TO: + case GOMP_MAP_ALWAYS_FROM: + case GOMP_MAP_ALWAYS_TOFROM: + { + if ((TREE_CODE (decl) == INDIRECT_REF + || (TREE_CODE (decl) == MEM_REF + && integer_zerop (TREE_OPERAND (decl, 1)))) + && DECL_P (TREE_OPERAND (decl, 0))) + { + tree ptr = TREE_OPERAND (decl, 0); + /* A DECL_P pointer arising from a mapper expansion needs a + GOMP_MAP_POINTER after it. */ + tree pnode = build_omp_clause (OMP_CLAUSE_LOCATION (n), + OMP_CLAUSE_MAP); + /* Should this ever be FIRSTPRIVATE_POINTER or + FIRSTPRIVATE_REFERENCE? */ + OMP_CLAUSE_SET_MAP_KIND (pnode, GOMP_MAP_POINTER); + OMP_CLAUSE_DECL (pnode) = ptr; + OMP_CLAUSE_SIZE (pnode) = size_zero_node; + OMP_CLAUSE_CHAIN (pnode) = OMP_CLAUSE_CHAIN (n); + OMP_CLAUSE_CHAIN (n) = pnode; + clausep = &OMP_CLAUSE_CHAIN (pnode); + continue; + } + } + break; + + default: + ; + } + + clausep = &OMP_CLAUSE_CHAIN (*clausep); + } + + return clauses; +} + +tree +gfc_omp_extract_mapper_directive (tree fndecl) +{ + tree body = DECL_SAVED_TREE (fndecl); + + if (TREE_CODE (body) == BIND_EXPR) + body = BIND_EXPR_BODY (body); + + if (TREE_CODE (body) == OMP_DECLARE_MAPPER) + return body; + + if (TREE_CODE (body) != STATEMENT_LIST) + return error_mark_node; + + tree_stmt_iterator tsi; + for (tsi = tsi_start (body); !tsi_end_p (tsi); tsi_next (&tsi)) + { + tree stmt = tsi_stmt (tsi); + if (TREE_CODE (stmt) == OMP_DECLARE_MAPPER) + { + gcc_assert (tsi_one_before_end_p (tsi)); + return stmt; + } + } + + return error_mark_node; +} + +tree +gfc_omp_map_array_section (location_t, tree section) +{ + /* For Fortran, detection of attempts to use array sections or full arrays + whose elements are mapped with a mapper happens elsewhere. */ + return section; +} + static tree handle_iterator (gfc_namespace *ns, stmtblock_t *iter_block, tree block) { @@ -2581,6 +2683,14 @@ handle_iterator (gfc_namespace *ns, stmtblock_t *iter_block, tree block) return list; } +enum omp_clause_directive +{ + OMP_CD_OPENMP, + OMP_CD_OPENMP_DECLARE_SIMD, + OMP_CD_OPENMP_DECLARE_MAPPER, + OMP_CD_OPENACC +}; + /* To alleviate quadratic behaviour in checking each entry of a gfc_omp_namelist against every other entry, we build a hashtable indexed by gfc_symbol pointer, which we can use in the usual case that a map @@ -2650,9 +2760,11 @@ get_symbol_rooted_namelist (hash_mapu2.udm && n->u2.udm->multiple_elems_p) + { + gfc_error ("cannot map non-unit size array " + "with mapper at %C"); + node2 = NULL_TREE; + goto finalize_map_clause; + } } node3 = build_omp_clause (input_location, OMP_CLAUSE_MAP); @@ -3748,13 +3871,73 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, finalize_map_clause: - omp_clauses = gfc_trans_add_clause (node, omp_clauses); - if (node2) - omp_clauses = gfc_trans_add_clause (node2, omp_clauses); - if (node3) - omp_clauses = gfc_trans_add_clause (node3, omp_clauses); - if (node4) - omp_clauses = gfc_trans_add_clause (node4, omp_clauses); + /* If we're processing an "omp declare mapper" directive, group + together multiple nodes used for some given map clause using + GOMP_MAP_MAPPING_GROUP. These are then either flattened or + appropriately transformed if they cause a nested mapper to be + invoked. */ + + if (declare_mapper) + { + tree cl, container; + + if (node2 || node3 || node4) + cl = tree_cons (node, NULL_TREE, NULL_TREE); + else + cl = node; + + if (node2) + cl = tree_cons (node2, NULL_TREE, cl); + if (node3) + cl = tree_cons (node3, NULL_TREE, cl); + if (node4) + cl = tree_cons (node4, NULL_TREE, cl); + + if (node != cl) + { + cl = nreverse (cl); + + container = build_omp_clause (input_location, + OMP_CLAUSE_MAP); + OMP_CLAUSE_SET_MAP_KIND (container, + GOMP_MAP_MAPPING_GROUP); + OMP_CLAUSE_DECL (container) = cl; + } + else + container = cl; + + if (n->u2.udm + && n->u2.udm->udm->mapper_id + && n->u2.udm->udm->mapper_id[0] != '\0') + { + tree push = build_omp_clause (input_location, + OMP_CLAUSE_MAP); + OMP_CLAUSE_SET_MAP_KIND (push, GOMP_MAP_PUSH_MAPPER_NAME); + OMP_CLAUSE_DECL (push) + = get_identifier (n->u2.udm->udm->mapper_id); + tree pop = build_omp_clause (input_location, + OMP_CLAUSE_MAP); + OMP_CLAUSE_SET_MAP_KIND (pop, GOMP_MAP_POP_MAPPER_NAME); + OMP_CLAUSE_DECL (pop) = null_pointer_node; + omp_clauses = gfc_trans_add_clause (push, omp_clauses); + omp_clauses = gfc_trans_add_clause (container, + omp_clauses); + omp_clauses = gfc_trans_add_clause (pop, omp_clauses); + } + else + omp_clauses = gfc_trans_add_clause (container, omp_clauses); + } + else + { + omp_clauses = gfc_trans_add_clause (node, omp_clauses); + + if (node2) + omp_clauses = gfc_trans_add_clause (node2, omp_clauses); + if (node3) + omp_clauses = gfc_trans_add_clause (node3, omp_clauses); + if (node4) + omp_clauses = gfc_trans_add_clause (node4, omp_clauses); + } } break; case OMP_LIST_TO: @@ -4658,7 +4841,7 @@ gfc_trans_oacc_construct (gfc_code *code) gfc_start_block (&block); oacc_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses, - code->loc, false, true); + code->loc, OMP_CD_OPENACC); pushlevel (); stmt = gfc_trans_omp_code (code->block->next, true); stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); @@ -4696,7 +4879,7 @@ gfc_trans_oacc_executable_directive (gfc_code *code) gfc_start_block (&block); oacc_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses, - code->loc, false, true); + code->loc, OMP_CD_OPENACC); stmt = build1_loc (input_location, construct_code, void_type_node, oacc_clauses); gfc_add_expr_to_block (&block, stmt); @@ -5745,7 +5928,7 @@ gfc_trans_oacc_combined_directive (gfc_code *code) if (construct_code == OACC_KERNELS) construct_clauses.lists[OMP_LIST_REDUCTION] = NULL; oacc_clauses = gfc_trans_omp_clauses (&block, &construct_clauses, - code->loc, false, true); + code->loc, OMP_CD_OPENACC); } if (!loop_clauses.seq) pblock = █ @@ -7166,6 +7349,336 @@ gfc_trans_omp_teams (gfc_code *code, gfc_omp_clauses *clausesa, return gfc_finish_block (&block); } +static gfc_symtree *gfc_subst_replace; +static gfc_ref *gfc_subst_prepend_ref; + +static bool +gfc_subst_in_expr_1 (gfc_expr *expr, gfc_symbol *search, int *) +{ + /* The base-object for component accesses may be stored in expr->symtree. + If it's the symbol for our "declare mapper" placeholder variable, + substitute it. */ + if (expr->symtree && expr->symtree->n.sym == search) + { + gfc_ref **lastptr = NULL; + expr->symtree = gfc_subst_replace; + + if (!gfc_subst_prepend_ref) + return false; + + gfc_ref *prepend_ref = gfc_copy_ref (gfc_subst_prepend_ref); + + for (gfc_ref *walk = prepend_ref; walk; walk = walk->next) + lastptr = &walk->next; + + *lastptr = expr->ref; + expr->ref = prepend_ref; + } + + return false; +} + +static void +gfc_subst_in_expr (gfc_expr *expr, gfc_symbol *search, gfc_symtree *replace, + gfc_ref *prepend_ref) +{ + gfc_subst_replace = replace; + gfc_subst_prepend_ref = prepend_ref; + gfc_traverse_expr (expr, search, gfc_subst_in_expr_1, 0); +} + +static void +gfc_subst_mapper_var (gfc_symbol **out_sym, gfc_expr **out_expr, + gfc_symbol *orig_sym, gfc_expr *orig_expr, + gfc_symbol *dummy_var, + gfc_symbol *templ_sym, gfc_expr *templ_expr) +{ + gfc_ref *orig_ref = orig_expr ? orig_expr->ref : NULL; + gfc_symtree *orig_st = gfc_find_symtree (orig_sym->ns->sym_root, + orig_sym->name); + + if (dummy_var == templ_sym) + *out_sym = orig_sym; + else + *out_sym = templ_sym; + + if (templ_expr) + { + *out_expr = gfc_copy_expr (templ_expr); + gfc_subst_in_expr (*out_expr, dummy_var, orig_st, orig_ref); + } + else if (orig_expr) + *out_expr = gfc_copy_expr (orig_expr); + else + *out_expr = NULL; +} + +static gfc_omp_namelist ** +gfc_trans_omp_instantiate_mapper (gfc_omp_namelist **outlistp, + gfc_omp_namelist *clause, gfc_omp_udm *udm) +{ + /* Here "sym" and "expr" describe the clause as written, to be substituted + for the dummy variable in the mapper definition. */ + struct gfc_symbol *sym = clause->sym; + struct gfc_expr *expr = clause->expr; + gfc_omp_namelist *mapper_clause = udm->clauses->lists[OMP_LIST_MAP]; + gfc_omp_map_op outer_map_op = clause->u.map_op; + bool pointer_needed_p = false; + + if (expr) + { + gfc_ref *lastref = expr->ref; + + while (lastref->next) + lastref = lastref->next; + + if (lastref && lastref->type == REF_ARRAY) + { + mpz_t elems; + bool multiple_elems_p = false; + + if (gfc_array_size (expr, &elems)) + { + HOST_WIDE_INT nelems = gfc_mpz_get_hwi (elems); + if (nelems > 1) + multiple_elems_p = true; + } + else + multiple_elems_p = true; + + if (multiple_elems_p) + { + gcc_assert (clause->u2.udm); + clause->u2.udm->multiple_elems_p = true; + *outlistp = clause; + return &(*outlistp)->next; + } + } + + if (lastref + && lastref->type == REF_COMPONENT + && (lastref->u.c.component->attr.pointer + || lastref->u.c.component->attr.allocatable)) + pointer_needed_p = true; + } + + if (pointer_needed_p) + { + /* If we're instantiating a mapper via a pointer, we need to map that + pointer as well as mapping the entities explicitly listed in the + mapper definition. Create a node for that. */ + gfc_omp_namelist *new_clause = gfc_get_omp_namelist (); + new_clause->sym = sym; + new_clause->expr = gfc_copy_expr (expr); + new_clause->u.map_op = OMP_MAP_ALLOC; + *outlistp = new_clause; + outlistp = &new_clause->next; + } + + for (; mapper_clause; mapper_clause = mapper_clause->next) + { + gfc_omp_namelist *new_clause = gfc_get_omp_namelist (); + + gfc_subst_mapper_var (&new_clause->sym, &new_clause->expr, + sym, expr, udm->var_sym, mapper_clause->sym, + mapper_clause->expr); + + if (mapper_clause->u.map_op == OMP_MAP_UNSET) + new_clause->u.map_op = outer_map_op; + else + new_clause->u.map_op = mapper_clause->u.map_op; + + new_clause->where = clause->where; + + if (mapper_clause->u2.udm + && mapper_clause->u2.udm->udm != udm) + { + gfc_omp_udm *inner_udm = mapper_clause->u2.udm->udm; + outlistp = gfc_trans_omp_instantiate_mapper (outlistp, new_clause, + inner_udm); + } + else + { + *outlistp = new_clause; + outlistp = &new_clause->next; + } + } + + return outlistp; +} + +static void +gfc_trans_omp_instantiate_mappers (gfc_omp_clauses *clauses) +{ + gfc_omp_namelist *clause = clauses->lists[OMP_LIST_MAP]; + gfc_omp_namelist **clausep = &clauses->lists[OMP_LIST_MAP]; + + for (; clause; clause = *clausep) + { + if (clause->u2.udm) + { + clausep = gfc_trans_omp_instantiate_mapper (clausep, + clause, + clause->u2.udm->udm); + *clausep = clause->next; + } + else + clausep = &clause->next; + } +} + +/* Code callback for gfc_code_walker. */ + +static int +gfc_record_mapper_bindings_code_fn (gfc_code **, int *, void *) +{ + return 0; +} + +template <> +struct default_hash_traits > + : typed_noop_remove > +{ + GTY((skip)) typedef omp_name_type value_type; + GTY((skip)) typedef omp_name_type compare_type; + + static hashval_t + hash (omp_name_type p) + { + tree typenode = gfc_typenode_for_spec (p.type); + return p.name ? iterative_hash_expr (p.name, TYPE_UID (typenode)) + : TYPE_UID (typenode); + } + + static const bool empty_zero_p = true; + + static bool + is_empty (omp_name_type p) + { + return p.type == NULL; + } + + static bool + is_deleted (omp_name_type) + { + return false; + } + + static bool + equal (const omp_name_type &a, + const omp_name_type &b) + { + if (a.name == NULL_TREE && b.name == NULL_TREE) + return a.type == b.type; + else if (a.name == NULL_TREE || b.name == NULL_TREE) + return false; + else + return a.name == b.name && gfc_compare_types (a.type, b.type); + } + + static void + mark_empty (omp_name_type &e) + { + e.type = NULL; + } +}; + + +extern gfc_namespace *omp_declare_mapper_ns; + +/* Conceptually similar to c-omp.cc:c_omp_find_nested_mappers, but using + Fortran typespec to idenfify mappers. */ + +static void +gfc_find_nested_mappers (omp_mapper_list *mlist, + gfc_omp_udm *udm) +{ + gfc_omp_namelist *ns = udm->clauses->lists[OMP_LIST_MAP]; + + for (; ns; ns = ns->next) + { + if (ns->u2.udm && ns->u2.udm->udm != udm) + { + gfc_omp_udm *nested_udm = ns->u2.udm->udm; + tree mapper_id + = (nested_udm->mapper_id ? get_identifier (nested_udm->mapper_id) + : NULL_TREE); + mlist->add_mapper (mapper_id, &nested_udm->ts, + nested_udm->backend_decl); + gfc_find_nested_mappers (mlist, nested_udm); + } + } +} + +/* Expr callback for gfc_code_walker. */ + +static int +gfc_record_mapper_bindings_expr_fn (gfc_expr **exprp, int *, void *data) +{ + gfc_typespec *ts = NULL; + omp_mapper_list *mlist + = (omp_mapper_list *) data; + + if ((*exprp)->symtree) + { + gfc_symbol *sym = (*exprp)->symtree->n.sym; + if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS) + ts = &sym->ts; + } + else if ((*exprp)->base_expr) + { + gfc_expr *base_expr = (*exprp)->base_expr; + if (base_expr->ts.type == BT_DERIVED || base_expr->ts.type == BT_CLASS) + ts = &base_expr->ts; + } + + if (!ts) + return 0; + + gfc_omp_udm *udm = gfc_find_omp_udm (omp_declare_mapper_ns, "", ts); + + if (udm) + { + mlist->add_mapper (NULL_TREE, &udm->ts, udm->backend_decl); + gfc_find_nested_mappers (mlist, udm); + } + + return 0; +} + +static void +gfc_record_mapper_bindings (tree *clauses, gfc_code *code) +{ + hash_set> seen_types; + auto_vec mappers; + omp_mapper_list mlist (&seen_types, &mappers); + + gfc_code_walker (&code, gfc_record_mapper_bindings_code_fn, + gfc_record_mapper_bindings_expr_fn, (void *) &mlist); + + unsigned int i; + tree mapperfn; + FOR_EACH_VEC_ELT (mappers, i, mapperfn) + { + tree mapper = gfc_omp_extract_mapper_directive (mapperfn); + if (mapper == error_mark_node) + continue; + tree mapper_name = OMP_DECLARE_MAPPER_ID (mapper); + tree decl = OMP_DECLARE_MAPPER_DECL (mapper); + + if (mapper_name && IDENTIFIER_POINTER (mapper_name)[0] == '\0') + mapper_name = NULL_TREE; + + tree c = build_omp_clause (input_location, OMP_CLAUSE__MAPPER_BINDING_); + OMP_CLAUSE__MAPPER_BINDING__ID (c) = mapper_name; + OMP_CLAUSE__MAPPER_BINDING__DECL (c) = decl; + OMP_CLAUSE__MAPPER_BINDING__MAPPER (c) = mapperfn; + + OMP_CLAUSE_CHAIN (c) = *clauses; + *clauses = c; + } +} + static tree gfc_trans_omp_target (gfc_code *code) { @@ -7176,14 +7689,18 @@ gfc_trans_omp_target (gfc_code *code) gfc_start_block (&block); gfc_split_omp_clauses (code, clausesa); if (flag_openmp) - omp_clauses - = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_TARGET], - code->loc); + { + gfc_omp_clauses *target_clauses = &clausesa[GFC_OMP_SPLIT_TARGET]; + gfc_trans_omp_instantiate_mappers (target_clauses); + omp_clauses = gfc_trans_omp_clauses (&block, target_clauses, + code->loc); + } switch (code->op) { case EXEC_OMP_TARGET: pushlevel (); stmt = gfc_trans_omp_code (code->block->next, true); + gfc_record_mapper_bindings (&omp_clauses, code->block->next); stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); break; case EXEC_OMP_TARGET_PARALLEL: @@ -7196,6 +7713,7 @@ gfc_trans_omp_target (gfc_code *code) = gfc_trans_omp_clauses (&iblock, &clausesa[GFC_OMP_SPLIT_PARALLEL], code->loc); stmt = gfc_trans_omp_code (code->block->next, true); + gfc_record_mapper_bindings (&omp_clauses, code->block->next); stmt = build2_loc (input_location, OMP_PARALLEL, void_type_node, stmt, inner_clauses); gfc_add_expr_to_block (&iblock, stmt); @@ -7684,7 +8202,7 @@ gfc_trans_oacc_declare (gfc_code *code) gfc_start_block (&block); oacc_clauses = gfc_trans_omp_clauses (&block, code->ext.oacc_declare->clauses, - code->loc, false, true); + code->loc, OMP_CD_OPENACC); stmt = gfc_trans_omp_code (code->block->next, true); stmt = build2_loc (input_location, construct_code, void_type_node, stmt, oacc_clauses); @@ -7853,7 +8371,8 @@ gfc_trans_omp_declare_simd (gfc_namespace *ns) gfc_omp_declare_simd *ods; for (ods = ns->omp_declare_simd; ods; ods = ods->next) { - tree c = gfc_trans_omp_clauses (NULL, ods->clauses, ods->where, true); + tree c = gfc_trans_omp_clauses (NULL, ods->clauses, ods->where, + OMP_CD_OPENMP_DECLARE_SIMD); tree fndecl = ns->proc_name->backend_decl; if (c != NULL_TREE) c = tree_cons (NULL_TREE, c, NULL_TREE); @@ -7980,8 +8499,10 @@ gfc_trans_omp_declare_variant (gfc_namespace *ns) } break; case CTX_PROPERTY_SIMD: - properties = gfc_trans_omp_clauses (NULL, otp->clauses, - odv->where, true); + properties + = gfc_trans_omp_clauses (NULL, otp->clauses, + odv->where, + OMP_CD_OPENMP_DECLARE_SIMD); break; default: gcc_unreachable (); @@ -8066,3 +8587,112 @@ gfc_trans_omp_declare_variant (gfc_namespace *ns) } } } + +static tree +gfc_trans_omp_mapper_name (const char *mapper_id, gfc_typespec *ts) +{ + /* Enough space for ":CLASS()" + '\0'. */ + char buffer[2 * GFC_MAX_SYMBOL_LEN + 9]; + const char *type_name = gfc_typename (ts); + if (!mapper_id) + mapper_id = "default"; + snprintf (buffer, sizeof (buffer), "omp declare mapper %s:%s", mapper_id, + type_name); + return get_identifier (buffer); +} + +/* Here we need to translate the internal representation of an OpenMP + "declare mapper" into a form that can be consumed by the middle-end. */ + +static void +gfc_trans_omp_declare_mapper (gfc_omp_udm *udm) +{ + tree mapper_name = gfc_trans_omp_mapper_name (udm->mapper_id, &udm->ts); + tree fn; + tree saved_fn_decl = current_function_decl; + tree decl, decls; + + if (saved_fn_decl) + push_function_context (); + + tree tmp = build_function_type_list (void_type_node, NULL_TREE); + fn = build_decl (input_location, FUNCTION_DECL, mapper_name, tmp); + + DECL_ARTIFICIAL (fn) = 1; + DECL_EXTERNAL (fn) = 1; + DECL_DECLARED_INLINE_P (fn) = 1; + DECL_IGNORED_P (fn) = 1; + SET_DECL_ASSEMBLER_NAME (fn, get_identifier ("")); + DECL_ATTRIBUTES (fn) + = tree_cons (get_identifier ("gnu_inline"), NULL_TREE, + DECL_ATTRIBUTES (fn)); + + decl = build_decl (input_location, RESULT_DECL, NULL_TREE, void_type_node); + DECL_ARTIFICIAL (decl) = 1; + DECL_IGNORED_P (decl) = 1; + DECL_CONTEXT (decl) = fn; + DECL_RESULT (fn) = decl; + + pushdecl (fn); + current_function_decl = fn; + + allocate_struct_function (fn, false); + + pushlevel (); + + stmtblock_t block; + gfc_init_block (&block); + + tree mapper_id = udm->mapper_id ? get_identifier (udm->mapper_id) : NULL_TREE; + tree type = gfc_typenode_for_spec (&udm->ts); + tree var = gfc_get_symbol_decl (udm->var_sym); + + DECL_CONTEXT (var) = fn; + /* Normally a "use"-related variable will get the DECL_EXTERN flag set, but + we don't want that here because it interferes with rewriting the decl. */ + DECL_EXTERNAL (var) = 0; + + tree maplist = gfc_trans_omp_clauses (&block, udm->clauses, udm->where, + OMP_CD_OPENMP_DECLARE_MAPPER); + + tree stmt = make_node (OMP_DECLARE_MAPPER); + TREE_TYPE (stmt) = type; + OMP_DECLARE_MAPPER_ID (stmt) = mapper_id; + OMP_DECLARE_MAPPER_DECL (stmt) = var; + OMP_DECLARE_MAPPER_CLAUSES (stmt) = maplist; + + gfc_add_expr_to_block (&block, stmt); + DECL_SAVED_TREE (fn) = gfc_finish_block (&block); + decls = getdecls (); + poplevel (1, 1); + BLOCK_SUPERCONTEXT (DECL_INITIAL (fn)) = fn; + + DECL_SAVED_TREE (fn) = fold_build3_loc (input_location, BIND_EXPR, + void_type_node, decls, + DECL_SAVED_TREE (fn), + DECL_INITIAL (fn)); + dump_function (TDI_original, fn); + + udm->backend_decl = fn; + + set_cfun (NULL); + + if (saved_fn_decl) + { + pop_function_context (); + current_function_decl = saved_fn_decl; + } +} + +void +gfc_trans_omp_declare_mappers (gfc_symtree *omp_udm_root) +{ + if (!omp_udm_root) + return; + + gfc_trans_omp_declare_mappers (omp_udm_root->left); + gfc_trans_omp_declare_mappers (omp_udm_root->right); + + for (gfc_omp_udm *udm = omp_udm_root->n.omp_udm; udm; udm = udm->next) + gfc_trans_omp_declare_mapper (udm); +} diff --git a/gcc/fortran/trans-stmt.h b/gcc/fortran/trans-stmt.h index 477add43f6cf..7a2737df6dd3 100644 --- a/gcc/fortran/trans-stmt.h +++ b/gcc/fortran/trans-stmt.h @@ -71,6 +71,7 @@ tree gfc_trans_deallocate (gfc_code *); tree gfc_trans_omp_directive (gfc_code *); void gfc_trans_omp_declare_simd (gfc_namespace *); void gfc_trans_omp_declare_variant (gfc_namespace *); +void gfc_trans_omp_declare_mappers (gfc_symtree *); tree gfc_trans_oacc_directive (gfc_code *); tree gfc_trans_oacc_declare (gfc_namespace *); diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index bc9035c1717e..3c1ef27886ce 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -818,6 +818,9 @@ tree gfc_omp_clause_assign_op (tree, tree, tree); tree gfc_omp_clause_linear_ctor (tree, tree, tree, tree); tree gfc_omp_clause_dtor (tree, tree); void gfc_omp_finish_clause (tree, gimple_seq *, bool); +tree gfc_omp_finish_mapper_clauses (tree); +tree gfc_omp_extract_mapper_directive (tree); +tree gfc_omp_map_array_section (location_t, tree); bool gfc_omp_allocatable_p (tree); bool gfc_omp_scalar_p (tree, bool); bool gfc_omp_scalar_target_p (tree); diff --git a/gcc/gimplify.cc b/gcc/gimplify.cc index 050282ce0587..29c303dd53e3 100644 --- a/gcc/gimplify.cc +++ b/gcc/gimplify.cc @@ -11584,6 +11584,36 @@ omp_mapper_copy_decl (tree var, copy_body_data *cb) return var; } +/* If we have a TREE_LIST representing an unprocessed mapping group (e.g. from + a "declare mapper" definition emitted by the Fortran FE), return the node + for the data being mapped. */ + +static tree +omp_mapping_group_data (tree group) +{ + gcc_assert (TREE_CODE (group) == TREE_LIST); + /* Use the first member of the group for substitution. */ + return TREE_PURPOSE (group); +} + +static tree +omp_mapping_group_ptr (tree group) +{ + gcc_assert (TREE_CODE (group) == TREE_LIST); + + while (TREE_CHAIN (group)) + group = TREE_CHAIN (group); + + tree node = TREE_PURPOSE (group); + + gcc_assert (OMP_CLAUSE_CODE (node) == OMP_CLAUSE_MAP); + + if (OMP_CLAUSE_MAP_KIND (node) == GOMP_MAP_ATTACH_DETACH) + return node; + + return NULL_TREE; +} + static tree * omp_instantiate_mapper (gimple_seq *pre_p, hash_map, tree> *implicit_mappers, @@ -11603,8 +11633,138 @@ omp_instantiate_mapper (gimple_seq *pre_p, "bind" expression in the pre_p sequence). */ hash_map extraction_map; - extraction_map.put (dummy_var, expr); - extraction_map.put (expr, expr); + if (TREE_CODE (mapperfn) == FUNCTION_DECL + && TREE_CODE (DECL_SAVED_TREE (mapperfn)) == BIND_EXPR) + { + tree body = NULL_TREE, bind = DECL_SAVED_TREE (mapperfn); + copy_body_data id; + hash_map decl_map; + + /* The "decl map" maps declarations in the definition of the mapper + function into new declarations in the current function. These are + local to the bind in which they are expanded, so we copy them out to + temporaries in the enclosing function scope, and use those temporaries + in the mapper expansion (see "extraction_map" above). (This also + allows a mapper to be invoked for multiple variables). */ + + memset (&id, 0, sizeof (id)); + /* The source function isn't always mapperfn: e.g. for C++ mappers + defined within functions, the mapper decl is created in a scope + within that function, rather than in mapperfn. So, that containing + function is the one we need to copy from. */ + id.src_fn = DECL_CONTEXT (dummy_var); + id.dst_fn = current_function_decl; + id.src_cfun = DECL_STRUCT_FUNCTION (mapperfn); + id.decl_map = &decl_map; + id.copy_decl = copy_decl_no_change; + id.transform_call_graph_edges = CB_CGE_DUPLICATE; + id.transform_new_cfg = true; + + walk_tree (&bind, copy_tree_body_r, &id, NULL); + + body = BIND_EXPR_BODY (bind); + + extraction_map.put (dummy_var, expr); + extraction_map.put (expr, expr); + + if (DECL_P (expr)) + mark_addressable (expr); + + tree dummy_var_remapped, *remapped_var_p = decl_map.get (dummy_var); + if (remapped_var_p) + dummy_var_remapped = *remapped_var_p; + else + internal_error ("failed to remap mapper variable"); + + hash_map mapper_map; + mapper_map.put (dummy_var_remapped, expr); + + /* Now we need to make two adjustments to the inlined bind: we have to + substitute the dummy variable for the expression in the clause + triggering this mapper instantiation, and we need to remove the + (remapped) decl from the bind's decl list. */ + + if (TREE_CODE (body) == STATEMENT_LIST) + { + copy_body_data id2; + memset (&id2, 0, sizeof (id2)); + id2.src_fn = current_function_decl; + id2.dst_fn = current_function_decl; + id2.src_cfun = cfun; + id2.decl_map = &mapper_map; + id2.copy_decl = omp_mapper_copy_decl; + id2.transform_call_graph_edges = CB_CGE_DUPLICATE; + id2.transform_new_cfg = true; + + tree_stmt_iterator tsi; + for (tsi = tsi_start (body); !tsi_end_p (tsi); tsi_next (&tsi)) + { + tree* stmtp = tsi_stmt_ptr (tsi); + if (TREE_CODE (*stmtp) == OMP_DECLARE_MAPPER) + *stmtp = NULL_TREE; + else if (TREE_CODE (*stmtp) == DECL_EXPR + && DECL_EXPR_DECL (*stmtp) == dummy_var_remapped) + *stmtp = NULL_TREE; + else + walk_tree (stmtp, remap_mapper_decl_1, &id2, NULL); + } + + tsi = tsi_last (body); + + for (hash_map::iterator ti = decl_map.begin (); + ti != decl_map.end (); + ++ti) + { + tree tmp, var = (*ti).first, inlined = (*ti).second; + + if (var == dummy_var || var == inlined || !DECL_P (var)) + continue; + + if (!is_gimple_reg (var)) + { + const char *decl_name + = IDENTIFIER_POINTER (DECL_NAME (var)); + tmp = create_tmp_var (TREE_TYPE (var), decl_name); + } + else + tmp = create_tmp_var (TREE_TYPE (var)); + + /* We have three versions of the decl here. VAR is the version + as represented in the function defining the "declare mapper", + and in the clause list attached to the OMP_DECLARE_MAPPER + directive within that function. INLINED is the variable that + has been localised to a bind within the function where the + mapper is being instantiated (i.e. current_function_decl). + TMP is the variable that we copy the values created in that + block to. */ + + extraction_map.put (var, tmp); + extraction_map.put (tmp, tmp); + + tree asgn = build2 (MODIFY_EXPR, TREE_TYPE (tmp), tmp, inlined); + tsi_link_after (&tsi, asgn, TSI_CONTINUE_LINKING); + } + } + + /* We've replaced the "dummy variable" of the declare mapper definition + with a localised version in a bind expr in the current function. We + have just rewritten all references to that, so remove the decl. */ + + for (tree *decl = &BIND_EXPR_VARS (bind); *decl;) + { + if (*decl == dummy_var_remapped) + *decl = DECL_CHAIN (*decl); + else + decl = &DECL_CHAIN (*decl); + } + + gimplify_bind_expr (&bind, pre_p); + } + else + { + extraction_map.put (dummy_var, expr); + extraction_map.put (expr, expr); + } /* This copy_body_data is only used to remap the decls in the OMP_DECLARE_MAPPER tree node expansion itself. All relevant decls should @@ -11636,6 +11796,80 @@ omp_instantiate_mapper (gimple_seq *pre_p, } tree decl = OMP_CLAUSE_DECL (clause); + + if (map_kind == GOMP_MAP_MAPPING_GROUP) + { + tree data = omp_mapping_group_data (decl); + tree group_type = TREE_TYPE (OMP_CLAUSE_DECL (data)); + + group_type = TYPE_MAIN_VARIANT (group_type); + + nested_mapper_p = implicit_mappers->get ({ mapper_name, group_type }); + + if (nested_mapper_p && *nested_mapper_p != mapperfn) + { + tree unshared = unshare_expr (data); + map_kind = OMP_CLAUSE_MAP_KIND (data); + walk_tree (&unshared, remap_mapper_decl_1, &id, NULL); + tree ptr = omp_mapping_group_ptr (decl); + + /* !!! When ptr is NULL, we're discarding the other nodes in the + mapping group. Is that always OK? */ + + if (ptr) + { + /* This behaviour is Fortran-specific. That's fine for now + because only Fortran is using GOMP_MAP_MAPPING_GROUP, but + may need revisiting if that ever changes. */ + gcc_assert (lang_GNU_Fortran ()); + + /* We're invoking a (nested) mapper from CLAUSE, which was a + pointer to a derived type. The elements of the derived + type are handled by the mapper, but we need to map the + actual pointer as well. Create an ALLOC node to do + that. */ + + tree ptr_unshared = unshare_expr (ptr); + walk_tree (&ptr_unshared, remap_mapper_decl_1, &id, NULL); + + tree node = build_omp_clause (OMP_CLAUSE_LOCATION (clause), + OMP_CLAUSE_MAP); + OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ALLOC); + OMP_CLAUSE_DECL (node) = OMP_CLAUSE_DECL (ptr_unshared); + OMP_CLAUSE_SIZE (node) + = TYPE_SIZE_UNIT (TREE_TYPE (OMP_CLAUSE_DECL (node))); + + *mapper_clauses_p = node; + mapper_clauses_p = &OMP_CLAUSE_CHAIN (node); + } + + if (map_kind == GOMP_MAP_UNSET) + map_kind = outer_kind; + + mapper_clauses_p + = omp_instantiate_mapper (pre_p, implicit_mappers, + *nested_mapper_p, + OMP_CLAUSE_DECL (unshared), map_kind, + mapper_clauses_p); + } + else + /* No nested mapper, so process each element of the mapping + group. */ + for (tree cp = OMP_CLAUSE_DECL (clause); cp; cp = TREE_CHAIN (cp)) + { + tree node = unshare_expr (TREE_PURPOSE (cp)); + walk_tree (&node, remap_mapper_decl_1, &id, NULL); + + if (OMP_CLAUSE_MAP_KIND (node) == GOMP_MAP_UNSET) + OMP_CLAUSE_SET_MAP_KIND (node, outer_kind); + + *mapper_clauses_p = node; + mapper_clauses_p = &OMP_CLAUSE_CHAIN (node); + } + + continue; + } + tree unshared, type; bool nonunit_array_with_mapper = false; diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-mapper-1.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-mapper-1.f90 new file mode 100644 index 000000000000..7bf30df9cdbd --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/declare-mapper-1.f90 @@ -0,0 +1,71 @@ +! { dg-do compile } + +! Basic "!$omp declare mapper" parsing tests. + +module mymod +type s + integer :: c + integer :: d(99) + integer, dimension(100,100) :: e +end type s + +!$omp declare mapper (s :: x) map(tofrom: x%c, x%d) +!$omp declare mapper (withaname : s :: x) map(from: x%d(2:30)) +!$omp declare mapper (withaname2 : s :: x) map(from: x%d(5)) +!$omp declare mapper (named: s :: x) map(tofrom: x%e(:,3)) +!$omp declare mapper (named2: s :: x) map(tofrom: x%e(5,:)) + +end module mymod + +program myprog +use mymod, only: s +type t + integer :: a + integer :: b +end type t + +type u + integer :: q +end type u + +type deriv + integer :: arr(100) + integer :: len +end type deriv + +type(t) :: y +type(s) :: z +type(u) :: p +type(deriv) :: d +integer, dimension(100,100) :: i2d + +!$omp declare mapper (t :: x) map(tofrom: x%a) map(y%b) +!$omp declare mapper (named: t :: x) map(tofrom: x%a) map(y%b) +!$omp declare mapper (integer :: x) ! { dg-error "\\\!\\\$OMP DECLARE MAPPER with non-derived type" } + +!$omp declare mapper (deriv :: x) map(tofrom: x%len) & +!$omp & map(tofrom: x%arr(:)) + +!$omp target map(tofrom: z%e(:,5)) +!$omp end target + +!$omp target map(mapper(named), tofrom: y) +!$omp end target + +!$omp target +y%a = y%b +!$omp end target + +d%len = 10 + +!$omp target +d%arr(5) = 13 +!$omp end target + +!$omp target map(tofrom: z) +!$omp end target + +!$omp target map(mapper(withaname), from: z) map(tofrom:p%q) +!$omp end target + +end program myprog diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-mapper-14.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-mapper-14.f90 new file mode 100644 index 000000000000..8ae73935a2d5 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/declare-mapper-14.f90 @@ -0,0 +1,26 @@ +program myprog +type T +integer :: arr1(10) +integer :: arr2(10) +end type T + +type U +integer :: arr1(10) +end type U + +type V +integer :: arr1(10) +end type V + +!$omp declare mapper (default: T :: x) map(to:x%arr1) map(from:x%arr2) ! { dg-error "Previous \\\!\\\$OMP DECLARE MAPPER" } +!$omp declare mapper (T :: x) map(to:x%arr1) ! { dg-error "Redefinition of \\\!\\\$OMP DECLARE MAPPER" } + +! Check what happens if we're SHOUTING too. +!$omp declare mapper (default: U :: x) map(to:x%arr1) ! { dg-error "Previous \\\!\\\$OMP DECLARE MAPPER" } +!$omp declare mapper (DEFAULT: U :: x) map(to:x%arr1) ! { dg-error "Redefinition of \\\!\\\$OMP DECLARE MAPPER" } + +! Or if we're using a keyword (which should be fine). +!$omp declare mapper (V :: x) map(alloc:x%arr1) +!$omp declare mapper (integer : V :: x) map(tofrom:x%arr1(:)) + +end program myprog diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-mapper-16.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-mapper-16.f90 new file mode 100644 index 000000000000..d4b9e5b4cca1 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/declare-mapper-16.f90 @@ -0,0 +1,22 @@ +program myprog + +type A +character(len=20) :: string1 +character(len=:), allocatable :: string2 +end type A + +!$omp declare mapper (A :: x) map(to:x%string1) map(from:x%string2) ! { dg-error "List item 'x' with allocatable components is not permitted in map clause" } + +type(A) :: var + +allocate(character(len=20) :: var%string2) + +var%string1 = "hello world" + +!$omp target +var%string2 = var%string1 +!$omp end target + +if (var%string2.ne."hello world") stop 1 + +end program myprog diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-mapper-5.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-mapper-5.f90 new file mode 100644 index 000000000000..0790fcd35088 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/declare-mapper-5.f90 @@ -0,0 +1,45 @@ +! { dg-do compile } + +! Check duplicate mapper detection in module reader. + +module mod1 +type S +integer, dimension(:), pointer :: arr +end type S +!$omp declare mapper (S :: v) map(to: v%arr) map(tofrom:v%arr(1)) +end module mod1 + +module mod2 +type S +character :: c +integer, dimension(:), pointer :: arr +end type S +!$omp declare mapper (S :: v) map(to: v%arr) map(tofrom:v%arr(:)) + +type(S) :: svar + +contains + +subroutine setup +allocate(svar%arr(10)) +end subroutine setup + +subroutine teardown +deallocate(svar%arr) +end subroutine teardown + +end module mod2 + +program myprog +use mod1 ! { dg-error "Previous \\\!\\\$OMP DECLARE MAPPER from module mod1" } +use mod2 ! { dg-error "Ambiguous \\\!\\\$OMP DECLARE MAPPER from module mod2" } + +call setup + +!$omp target +svar%arr(1) = svar%arr(1) + 1 +!$omp end target + +call teardown + +end program myprog diff --git a/gcc/tree-pretty-print.cc b/gcc/tree-pretty-print.cc index 2818cecaa8f7..8056c17c1397 100644 --- a/gcc/tree-pretty-print.cc +++ b/gcc/tree-pretty-print.cc @@ -1003,6 +1003,9 @@ dump_omp_clause (pretty_printer *pp, tree clause, int spc, dump_flags_t flags) case GOMP_MAP_POP_MAPPER_NAME: pp_string (pp, "pop_mapper"); break; + case GOMP_MAP_MAPPING_GROUP: + pp_string (pp, "mapping_group"); + break; default: gcc_unreachable (); } diff --git a/include/gomp-constants.h b/include/gomp-constants.h index 4e913cb2ebba..dd6bfdeffc4e 100644 --- a/include/gomp-constants.h +++ b/include/gomp-constants.h @@ -194,7 +194,10 @@ enum gomp_map_kind GOMP_MAP_UNSET = (GOMP_MAP_LAST | 4), /* Used to record the name of a named mapper. */ GOMP_MAP_PUSH_MAPPER_NAME = (GOMP_MAP_LAST | 5), - GOMP_MAP_POP_MAPPER_NAME = (GOMP_MAP_LAST | 6) + GOMP_MAP_POP_MAPPER_NAME = (GOMP_MAP_LAST | 6), + /* Used to hold a TREE_LIST of grouped nodes in an 'omp declare mapper' + definition (only for Fortran at present). */ + GOMP_MAP_MAPPING_GROUP = (GOMP_MAP_LAST | 7) }; #define GOMP_MAP_COPY_TO_P(X) \ diff --git a/libgomp/testsuite/libgomp.fortran/declare-mapper-10.f90 b/libgomp/testsuite/libgomp.fortran/declare-mapper-10.f90 new file mode 100644 index 000000000000..801becc7d7dc --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/declare-mapper-10.f90 @@ -0,0 +1,40 @@ +! { dg-do run } + +program myprog +type t + integer, dimension (8) :: arr1 +end type t +type u + type(t), dimension (:), pointer :: tarr +end type u + +type(u) :: myu +type(t), dimension (12), target :: myarray + +!$omp declare mapper (t :: x) map(x%arr1(1:4)) +!$omp declare mapper (u :: x) map(to: x%tarr) map(x%tarr(1)) + +myu%tarr => myarray + +myu%tarr(1)%arr1(1) = 1 + +! We can't do this: we have a mapper for "t" elements, and this implicitly maps +! the whole array. +!!$omp target map(tofrom:myu%tarr) +!myu%tarr(1)%arr1(1) = myu%tarr(1)%arr1(1) + 1 +!!$omp end target + +! ...but we can do this, because we're just mapping an element of the "t" +! array. We still need to map the actual "myu%tarr" descriptor. +!$omp target map(to:myu%tarr) map(myu%tarr(1)%arr1(1:4)) +myu%tarr(1)%arr1(1) = myu%tarr(1)%arr1(1) + 1 +!$omp end target + +!$omp target +myu%tarr(1)%arr1(1) = myu%tarr(1)%arr1(1) + 1 +!$omp end target + +if (myu%tarr(1)%arr1(1).ne.3) stop 1 + +end program myprog + diff --git a/libgomp/testsuite/libgomp.fortran/declare-mapper-11.f90 b/libgomp/testsuite/libgomp.fortran/declare-mapper-11.f90 new file mode 100644 index 000000000000..0fc424a7ba48 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/declare-mapper-11.f90 @@ -0,0 +1,38 @@ +! { dg-do run } + +program myprog +type t + integer, dimension (8) :: arr1 +end type t +type u + type(t) :: t_elem +end type u + +type(u) :: myu + +!$omp declare mapper (t :: x) map(x%arr1(5:8)) +!$omp declare mapper (tmapper: t :: x) map(x%arr1(1:4)) +!$omp declare mapper (u :: x) map(mapper(tmapper), tofrom: x%t_elem) + +myu%t_elem%arr1(1) = 1 +myu%t_elem%arr1(5) = 1 + +! Different ways of invoking nested mappers, named vs. unnamed + +!$omp target map(tofrom:myu%t_elem) +myu%t_elem%arr1(5) = myu%t_elem%arr1(5) + 1 +!$omp end target + +!$omp target map(tofrom:myu) +myu%t_elem%arr1(1) = myu%t_elem%arr1(1) + 1 +!$omp end target + +!$omp target +myu%t_elem%arr1(1) = myu%t_elem%arr1(1) + 1 +!$omp end target + +if (myu%t_elem%arr1(1).ne.3) stop 1 +if (myu%t_elem%arr1(5).ne.2) stop 2 + +end program myprog + diff --git a/libgomp/testsuite/libgomp.fortran/declare-mapper-12.f90 b/libgomp/testsuite/libgomp.fortran/declare-mapper-12.f90 new file mode 100644 index 000000000000..a475501d014f --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/declare-mapper-12.f90 @@ -0,0 +1,33 @@ +! { dg-do run } + +program myprog +type t + integer, dimension (8) :: arr1 +end type t +type u + type(t) :: t_elem +end type u + +type(u) :: myu + +!$omp declare mapper (tmapper: t :: x) map(x%arr1(1:4)) +!$omp declare mapper (u :: x) map(mapper(tmapper), tofrom: x%t_elem) + +myu%t_elem%arr1(1) = 1 + +!$omp target map(tofrom:myu%t_elem) +myu%t_elem%arr1(1) = myu%t_elem%arr1(1) + 1 +!$omp end target + +!$omp target map(tofrom:myu) +myu%t_elem%arr1(1) = myu%t_elem%arr1(1) + 1 +!$omp end target + +!$omp target +myu%t_elem%arr1(1) = myu%t_elem%arr1(1) + 1 +!$omp end target + +if (myu%t_elem%arr1(1).ne.4) stop 1 + +end program myprog + diff --git a/libgomp/testsuite/libgomp.fortran/declare-mapper-13.f90 b/libgomp/testsuite/libgomp.fortran/declare-mapper-13.f90 new file mode 100644 index 000000000000..3cae0fe7c265 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/declare-mapper-13.f90 @@ -0,0 +1,49 @@ +! { dg-do run } + +module mymod +type S +integer :: a +integer :: b +integer :: c +end type S + +!$omp declare mapper (S :: x) map(x%c) +end module mymod + +program myprog +use mymod +type T +integer :: a +integer :: b +integer :: c +end type T + +type(S) :: mys +type(T) :: myt + +!$omp declare mapper (T :: x) map(x%b) + +myt%a = 0 +myt%b = 0 +myt%c = 0 +mys%a = 0 +mys%b = 0 +mys%c = 0 + +!$omp target +myt%b = myt%b + 1 +!$omp end target + +!$omp target +mys%c = mys%c + 1 +!$omp end target + +!$omp target +myt%b = myt%b + 2 +mys%c = mys%c + 3 +!$omp end target + +if (myt%b.ne.3) stop 1 +if (mys%c.ne.4) stop 2 + +end program myprog diff --git a/libgomp/testsuite/libgomp.fortran/declare-mapper-15.f90 b/libgomp/testsuite/libgomp.fortran/declare-mapper-15.f90 new file mode 100644 index 000000000000..eb0dd5f1027f --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/declare-mapper-15.f90 @@ -0,0 +1,24 @@ +! { dg-do run } + +program myprog + +type A +character(len=20) :: string1 +character(len=:), pointer :: string2 +end type A + +!$omp declare mapper (A :: x) map(to:x%string1) map(from:x%string2) + +type(A) :: var + +allocate(character(len=20) :: var%string2) + +var%string1 = "hello world" + +!$omp target map(to:var%string1) map(from:var%string2) +var%string2 = var%string1 +!$omp end target + +if (var%string2.ne."hello world") stop 1 + +end program myprog diff --git a/libgomp/testsuite/libgomp.fortran/declare-mapper-17.f90 b/libgomp/testsuite/libgomp.fortran/declare-mapper-17.f90 new file mode 100644 index 000000000000..c21597145dd1 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/declare-mapper-17.f90 @@ -0,0 +1,92 @@ +! { dg-do run } + +program myprog + +type A +integer :: x +integer :: y(20) +integer, dimension(:), pointer :: z +end type A + +integer, target :: arr1(20), arr2(20) +type(A) :: p, q + +p%y = 0 +q%y = 0 + +p%z => arr1 +q%z => arr2 + +call mysub (p, q) + +if (p%z(1).ne.1) stop 1 +if (q%z(1).ne.1) stop 2 + +p%y = 0 +q%y = 0 +p%z = 0 +q%z = 0 + +call mysub2 (p, q) + +if (p%z(1).ne.1) stop 3 +if (q%z(1).ne.1) stop 4 + +p%y = 0 +q%y = 0 +p%z = 0 +q%z = 0 + +call mysub3 (p, q) + +if (p%z(1).ne.1) stop 5 +if (q%z(1).ne.1) stop 6 + +contains + +subroutine mysub(arg1, arg2) +implicit none +type(A), intent(inout) :: arg1 +type(A), intent(inout) :: arg2 + +!$omp declare mapper (A :: x) map(always, to:x) map(tofrom:x%z(:)) + +!$omp target +arg1%y(1) = arg1%y(1) + 1 +arg1%z = arg1%y +arg2%y(1) = arg2%y(1) + 1 +arg2%z = arg2%y +!$omp end target +end subroutine mysub + +subroutine mysub2(arg1, arg2) +implicit none +type(A), intent(inout) :: arg1 +type(A), intent(inout) :: arg2 + +!$omp declare mapper (A :: x) map(to:x) map(from:x%z(:)) + +!$omp target +arg1%y(1) = arg1%y(1) + 1 +arg1%z = arg1%y +arg2%y(1) = arg2%y(1) + 1 +arg2%z = arg2%y +!$omp end target +end subroutine mysub2 + +subroutine mysub3(arg1, arg2) +implicit none +type(A), intent(inout) :: arg1 +type(A), intent(inout) :: arg2 + +!$omp declare mapper (A :: x) map(to:x) map(from:x%z(:)) + +!$omp target map(arg1, arg2) +arg1%y(1) = arg1%y(1) + 1 +arg1%z = arg1%y +arg2%y(1) = arg2%y(1) + 1 +arg2%z = arg2%y +!$omp end target +end subroutine mysub3 + +end program myprog diff --git a/libgomp/testsuite/libgomp.fortran/declare-mapper-18.f90 b/libgomp/testsuite/libgomp.fortran/declare-mapper-18.f90 new file mode 100644 index 000000000000..a333b6844f1f --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/declare-mapper-18.f90 @@ -0,0 +1,46 @@ +! { dg-do run } + +module mymod +type F +integer :: a, b, c +integer, dimension(10) :: d +end type F + +type G +integer :: x, y +type(F), pointer :: myf +integer :: z +end type G + +! Check that nested mappers work inside modules. + +!$omp declare mapper (F :: f) map(to: f%b) map(f%d) +!$omp declare mapper (G :: g) map(tofrom: g%myf) + +end module mymod + +program myprog +use mymod + +type(F), target :: ftmp +type(G) :: gvar + +gvar%myf => ftmp + +gvar%myf%d = 0 + +!$omp target map(gvar%myf) +gvar%myf%d(1) = gvar%myf%d(1) + 1 +!$omp end target + +!$omp target map(gvar) +gvar%myf%d(1) = gvar%myf%d(1) + 1 +!$omp end target + +!$omp target +gvar%myf%d(1) = gvar%myf%d(1) + 1 +!$omp end target + +if (gvar%myf%d(1).ne.3) stop 1 + +end program myprog diff --git a/libgomp/testsuite/libgomp.fortran/declare-mapper-19.f90 b/libgomp/testsuite/libgomp.fortran/declare-mapper-19.f90 new file mode 100644 index 000000000000..d86497524f93 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/declare-mapper-19.f90 @@ -0,0 +1,29 @@ +! { dg-do run } + +program myprog +type F +integer :: a, b, c +integer, dimension(10) :: d +end type F + +type(F), pointer :: myf + +!$omp declare mapper (F :: f) map(f%d) + +allocate(myf) + +myf%d = 0 + +!$omp target map(myf) +myf%d(1) = myf%d(1) + 1 +!$omp end target + +!$omp target +myf%d(1) = myf%d(1) + 1 +!$omp end target + +if (myf%d(1).ne.2) stop 1 + +deallocate(myf) + +end program myprog diff --git a/libgomp/testsuite/libgomp.fortran/declare-mapper-2.f90 b/libgomp/testsuite/libgomp.fortran/declare-mapper-2.f90 new file mode 100644 index 000000000000..ec1c0ec2a15a --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/declare-mapper-2.f90 @@ -0,0 +1,32 @@ +! { dg-do run } + +program myprog +type s + integer :: c + integer :: d(99) +end type s + +type t + type(s) :: mys +end type t + +type u + type(t) :: myt +end type u + +type(u) :: myu + +!$omp declare mapper (t :: x) map(tofrom: x%mys%c) map(x%mys%d(1:x%mys%c)) + +myu%myt%mys%c = 1 +myu%myt%mys%d = 0 + +!$omp target map(tofrom: myu%myt) +myu%myt%mys%d(1) = myu%myt%mys%d(1) + 1 +myu%myt%mys%c = myu%myt%mys%c + 2 +!$omp end target + +if (myu%myt%mys%d(1).ne.1) stop 1 +if (myu%myt%mys%c.ne.3) stop 2 + +end program myprog diff --git a/libgomp/testsuite/libgomp.fortran/declare-mapper-20.f90 b/libgomp/testsuite/libgomp.fortran/declare-mapper-20.f90 new file mode 100644 index 000000000000..20688289ecfb --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/declare-mapper-20.f90 @@ -0,0 +1,29 @@ +! { dg-do run } + +program myprog +type F +integer :: a, b, c +integer, dimension(10) :: d +end type F + +type(F), allocatable :: myf + +!$omp declare mapper (F :: f) map(f) + +allocate(myf) + +myf%d = 0 + +!$omp target map(myf) +myf%d(1) = myf%d(1) + 1 +!$omp end target + +!$omp target +myf%d(1) = myf%d(1) + 1 +!$omp end target + +if (myf%d(1).ne.2) stop 1 + +deallocate(myf) + +end program myprog diff --git a/libgomp/testsuite/libgomp.fortran/declare-mapper-3.f90 b/libgomp/testsuite/libgomp.fortran/declare-mapper-3.f90 new file mode 100644 index 000000000000..517096db51c7 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/declare-mapper-3.f90 @@ -0,0 +1,33 @@ +program myprog +type s + integer :: c + integer :: d(99) +end type s + +type t + type(s) :: mys +end type t + +type u + type(t) :: myt +end type u + +type(u) :: myu + +!$omp declare mapper (s :: x) map(tofrom: x%c, x%d(1:x%c)) +!$omp declare mapper (t :: x) map(tofrom: x%mys) +!$omp declare mapper (u :: x) map(tofrom: x%myt) + +myu%myt%mys%c = 1 +myu%myt%mys%d = 0 + +! Nested mappers. + +!$omp target map(tofrom: myu) +myu%myt%mys%d(1) = myu%myt%mys%d(1) + 1 +!$omp end target + +if (myu%myt%mys%c.ne.1) stop 1 +if (myu%myt%mys%d(1).ne.1) stop 2 + +end program myprog diff --git a/libgomp/testsuite/libgomp.fortran/declare-mapper-4.f90 b/libgomp/testsuite/libgomp.fortran/declare-mapper-4.f90 new file mode 100644 index 000000000000..e95dbbd6f966 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/declare-mapper-4.f90 @@ -0,0 +1,36 @@ +! { dg-do run } + +program myprog +type s + integer :: c + integer :: d(99) +end type s + +type t + type(s) :: mys +end type t + +type u + type(t) :: myt +end type u + +type(u) :: myu + +! Here, the mappers are declared out of order, so later ones are not 'seen' by +! earlier ones. Is that right? +!$omp declare mapper (u :: x) map(tofrom: x%myt) +!$omp declare mapper (t :: x) map(tofrom: x%mys) +!$omp declare mapper (s :: x) map(tofrom: x%c, x%d(1:x%c)) + +myu%myt%mys%c = 1 +myu%myt%mys%d = 0 + +!$omp target map(tofrom: myu) +myu%myt%mys%d(5) = myu%myt%mys%d(5) + 1 +!$omp end target + +! Note: we used the default mapper, not the 's' mapper, so we mapped the +! whole array 'd'. +if (myu%myt%mys%d(5).ne.1) stop 1 + +end program myprog diff --git a/libgomp/testsuite/libgomp.fortran/declare-mapper-6.f90 b/libgomp/testsuite/libgomp.fortran/declare-mapper-6.f90 new file mode 100644 index 000000000000..9ebf8da6d8be --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/declare-mapper-6.f90 @@ -0,0 +1,28 @@ +! { dg-do run } + +program myprog +type bounds + integer :: lo + integer :: hi +end type bounds + +integer, allocatable :: myarr(:) +type(bounds) :: b + +! Use the placeholder variable, but not at the top level. +!$omp declare mapper (bounds :: x) map(tofrom: myarr(x%lo:x%hi)) + +allocate (myarr(1:100)) + +b%lo = 4 +b%hi = 6 + +myarr = 0 + +!$omp target map(tofrom: b) +myarr(5) = myarr(5) + 1 +!$omp end target + +if (myarr(5).ne.1) stop 1 + +end program myprog diff --git a/libgomp/testsuite/libgomp.fortran/declare-mapper-7.f90 b/libgomp/testsuite/libgomp.fortran/declare-mapper-7.f90 new file mode 100644 index 000000000000..6297c8e99cb1 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/declare-mapper-7.f90 @@ -0,0 +1,29 @@ +! { dg-do run } + +program myprog +type s + integer :: a + integer :: b +end type s + +type t + type(s) :: mys +end type t + +type(t) :: myt + +! Identity mapper + +!$omp declare mapper (s :: x) map(tofrom: x) +!$omp declare mapper (t :: x) map(tofrom: x%mys) + +myt%mys%a = 0 +myt%mys%b = 0 + +!$omp target map(tofrom: myt) +myt%mys%a = myt%mys%a + 1 +!$omp end target + +if (myt%mys%a.ne.1) stop 1 + +end program myprog diff --git a/libgomp/testsuite/libgomp.fortran/declare-mapper-8.f90 b/libgomp/testsuite/libgomp.fortran/declare-mapper-8.f90 new file mode 100644 index 000000000000..254486b58805 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/declare-mapper-8.f90 @@ -0,0 +1,115 @@ +! { dg-do run } + +program myprog +type t + integer, dimension (8) :: arr1 +end type t +type u + integer, dimension (9) :: arr1 +end type u +type v + integer, dimension (10) :: arr1 +end type v +type w + integer, dimension (11) :: arr1 +end type w +type y + integer, dimension(:), pointer :: ptr1 +end type y +type z + integer, dimension(:), pointer :: ptr1 +end type z + +!$omp declare mapper (t::x) map(tofrom:x%arr1) +!$omp declare mapper (u::x) map(tofrom:x%arr1(:)) +!$omp declare mapper (v::x) map(always,tofrom:x%arr1(1:3)) +!$omp declare mapper (w::x) map(tofrom:x%arr1(1)) +!$omp declare mapper (y::x) map(tofrom:x%ptr1) +!$omp declare mapper (z::x) map(to:x%ptr1) map(tofrom:x%ptr1(1:3)) + +type(t) :: myt +type(u) :: myu +type(v) :: myv +type(w) :: myw +type(y) :: myy +integer, target, dimension(8) :: arrtgt +type(z) :: myz +integer, target, dimension(8) :: arrtgt2 + +myy%ptr1 => arrtgt +myz%ptr1 => arrtgt2 + +myt%arr1 = 0 + +!$omp target map(myt) +myt%arr1(1) = myt%arr1(1) + 1 +!$omp end target + +!$omp target +myt%arr1(1) = myt%arr1(1) + 1 +!$omp end target + +if (myt%arr1(1).ne.2) stop 1 + +myu%arr1 = 0 + +!$omp target map(tofrom:myu%arr1(:)) +myu%arr1(1) = myu%arr1(1) + 1 +!$omp end target + +!$omp target +myu%arr1(1) = myu%arr1(1) + 1 +!$omp end target + +if (myu%arr1(1).ne.2) stop 2 + +myv%arr1 = 0 + +!$omp target map(always,tofrom:myv%arr1(1:3)) +myv%arr1(1) = myv%arr1(1) + 1 +!$omp end target + +!$omp target +myv%arr1(1) = myv%arr1(1) + 1 +!$omp end target + +if (myv%arr1(1).ne.2) stop 3 + +myw%arr1 = 0 + +!$omp target map(tofrom:myw%arr1(1)) +myw%arr1(1) = myw%arr1(1) + 1 +!$omp end target + +!$omp target +myw%arr1(1) = myw%arr1(1) + 1 +!$omp end target + +if (myw%arr1(1).ne.2) stop 4 + +myy%ptr1 = 0 + +!$omp target map(tofrom:myy%ptr1) +myy%ptr1(1) = myy%ptr1(1) + 1 +!$omp end target + +!$omp target map(to:myy%ptr1) map(tofrom:myy%ptr1(1:2)) +myy%ptr1(1) = myy%ptr1(1) + 1 +!$omp end target + +!$omp target +myy%ptr1(1) = myy%ptr1(1) + 1 +!$omp end target + +if (myy%ptr1(1).ne.3) stop 5 + +myz%ptr1(1) = 0 + +!$omp target +myz%ptr1(1) = myz%ptr1(1) + 1 +!$omp end target + +if (myz%ptr1(1).ne.1) stop 6 + +end program myprog + diff --git a/libgomp/testsuite/libgomp.fortran/declare-mapper-9.f90 b/libgomp/testsuite/libgomp.fortran/declare-mapper-9.f90 new file mode 100644 index 000000000000..deaf30b9575e --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/declare-mapper-9.f90 @@ -0,0 +1,27 @@ +! { dg-do run } + +type t + integer, dimension (8) :: arr1 +end type t +type u + type(t), dimension (:), pointer :: tarr +end type u + +type(u) :: myu +type(t), dimension (1), target :: myarray + +!$omp declare mapper (named: t :: x) map(x%arr1(1:4)) +!$omp declare mapper (u :: x) map(to: x%tarr) map(mapper(named), tofrom: x%tarr(1)) + +myu%tarr => myarray +myu%tarr(1)%arr1 = 0 + +! Unnamed mapper invoking named mapper + +!$omp target +myu%tarr(1)%arr1(1) = myu%tarr(1)%arr1(1) + 1 +!$omp end target + +if (myu%tarr(1)%arr1(1).ne.1) stop 1 + +end