From patchwork Wed Jul 10 00:49:43 2019 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Julian Brown X-Patchwork-Id: 1130086 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Authentication-Results: ozlabs.org; spf=pass (mailfrom) smtp.mailfrom=gcc.gnu.org (client-ip=209.132.180.131; helo=sourceware.org; envelope-from=gcc-patches-return-504785-incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=) Authentication-Results: ozlabs.org; dmarc=none (p=none dis=none) header.from=codesourcery.com Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.b="ROgMQvpO"; dkim-atps=neutral Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id 45k0wH4Rfbz9sN6 for ; Wed, 10 Jul 2019 10:50:14 +1000 (AEST) DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:date :from:to:subject:message-id:mime-version:content-type; q=dns; s= default; b=IN5g4KsCK4283gxRy+4lFVWCNOWKla+WpIV4TVg0JU8vwWiu09xGR BYBxkissuy5YIxBBK9LJ5lLFF/jSQhS9gFrn4RqB5SppRxGyYiifHocNUcifQc5E X0ESep00azxkCAior9UggRr5EBxdJQNi1VKXLVGu2vnFZhC0qfgxls= DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:date :from:to:subject:message-id:mime-version:content-type; s= default; bh=YLaj7VTVUedUDUFOU5F7z14czKQ=; b=ROgMQvpOSz6CbAPIXmX6 2kFNkYM/62iPL2zHo5ugQziSEUEY1oYf4vl7r+2Iv1Km7XppWGys/12JCzsJrLLz yvEZrdlteP+j7raQUEnoVKr5JtNIVVRGab1tSsfntP59i2W+tTsI4QWNtaekwIME D350ElP4glZ/su8Tw8y8C7o= Received: (qmail 21533 invoked by alias); 10 Jul 2019 00:50:03 -0000 Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org Received: (qmail 21514 invoked by uid 89); 10 Jul 2019 00:50:03 -0000 Authentication-Results: sourceware.org; auth=none X-Spam-SWARE-Status: No, score=-15.5 required=5.0 tests=AWL, BAYES_00, GIT_PATCH_0, GIT_PATCH_1, GIT_PATCH_2, GIT_PATCH_3, RCVD_IN_DNSWL_NONE autolearn=ham version=3.3.1 spammy=spc, 2019-07-10, 20190710, rank X-HELO: relay1.mentorg.com Received: from relay1.mentorg.com (HELO relay1.mentorg.com) (192.94.38.131) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP; Wed, 10 Jul 2019 00:49:56 +0000 Received: from nat-ies.mentorg.com ([192.94.31.2] helo=SVR-IES-MBX-04.mgc.mentorg.com) by relay1.mentorg.com with esmtps (TLSv1.2:ECDHE-RSA-AES256-SHA384:256) id 1hl0nv-0004VE-TG from Julian_Brown@mentor.com for gcc-patches@gcc.gnu.org; Tue, 09 Jul 2019 17:49:52 -0700 Received: from squid.athome (137.202.0.90) by SVR-IES-MBX-04.mgc.mentorg.com (139.181.222.4) with Microsoft SMTP Server (TLS) id 15.0.1320.4; Wed, 10 Jul 2019 01:49:47 +0100 Date: Wed, 10 Jul 2019 01:49:43 +0100 From: Julian Brown To: Subject: [og9] Support Fortran 2003 class pointers in OpenACC Message-ID: <20190710014943.371fdcd4@squid.athome> MIME-Version: 1.0 X-IsSubscribed: yes This patch provides initial support for Fortran 2003 polymorphic class pointers in OpenACC. This necessitated some rewriting of the lowering code in gfc_trans_omp_clauses, partly reverting some of the changes made by the earlier manual deep copy support. In the new code, I've tried to reuse existing lowering code in the Fortran front-end where appropriate. The main changes can be summarised thus: 1. Polymorphic class pointers can be used in OpenACC data-mapping clauses. Class descriptors (comprising a _data pointer and a _vptr virtual-table pointer) are mapped using GOMP_MAP_TO_PSET, in a similar way to the existing support for array descriptors. 2. For OpenACC, a new internal-only gomp_map_kind has been introduced when mapping derived-type pointer components, GOMP_MAP_ATTACH_DETACH, instead of hijacking GOMP_MAP_ALWAYS_POINTER for attach/detach operations then rewriting it in gimplify.c. This cleans up some code paths and hopefully self-documents better. 3. OpenACC "enter data" and "exit data" now have GOMP_MAP_POINTER and GOMP_MAP_PSET mappings removed during gimplification. In some circumstances, passing an array to a function/subroutine and then doing an "enter data" on it could leave dangling references to the function's stack, although the actual array data is defined outside the function. In any case, the pointer/pointer-set mappings don't seem to be necessary for OpenACC "enter data". Tested with offloading to nvptx. I will apply shortly (to the openacc-gcc-9-branch). Thanks, Julian ChangeLog gcc/ * gimplify.c (insert_struct_comp_map): Handle GOMP_MAP_ATTACH_DETACH. (gimplify_scan_omp_clauses): Separate out handling of OACC_ENTER_DATA and OACC_EXIT_DATA. Remove GOMP_MAP_POINTER and GOMP_MAP_TO_PSET mappings, apart from those following GOMP_MAP_DECLARE_{,DE}ALLOCATE. Handle GOMP_MAP_ATTACH_DETACH. * tree-pretty-print.c (dump_omp_clause): Support GOMP_MAP_ATTACH_DETACH. Print "bias" not "len" for attach/detach clause types. include/ * gomp-constants.h (gomp_map_kind): Add GOMP_MAP_ATTACH_DETACH. gcc/c/ * c-typeck.c (handle_omp_array_sections): Use GOMP_MAP_ATTACH_DETACH for OpenACC attach/detach operations. gcc/cp/ * semantics.c (handle_omp_array_sections): Likewise. (finish_omp_clauses): Handle GOMP_MAP_ATTACH_DETACH. gcc/fortran/ * openmp.c (resolve_oacc_data_clauses): Allow polymorphic allocatable variables. * trans-expr.c (gfc_conv_component_ref, conv_parent_component_reference): Make global. (gfc_auto_dereference_var): New function, broken out of... (gfc_conv_variable): ...here. Call outlined function instead. * trans-openmp.c (gfc_trans_omp_array_section): New function, broken out of... (gfc_trans_omp_clauses): ...here. Separate out OpenACC derived type/polymorphic class pointer handling. Call above outlined function. * trans.h (gfc_conv_component_ref, conv_parent_component_references, gfc_auto_dereference_var): Add prototypes. gcc/testsuite/ * c-c++-common/goacc/mdc-1.c: Update clause matching patterns. libgomp/ * oacc-parallel.c (GOACC_enter_exit_data): Fix optional arguments for changes to clause stripping in enter data/exit data directives. * testsuite/libgomp.oacc-fortran/class-ptr-param.f95: New test. * testsuite/libgomp.oacc-fortran/classtypes-1.f95: New test. * testsuite/libgomp.oacc-fortran/classtypes-2.f95: New test. * testsuite/libgomp.oacc-fortran/derivedtype-1.f95: New test. * testsuite/libgomp.oacc-fortran/derivedtype-2.f95: New test. * testsuite/libgomp.oacc-fortran/multidim-slice.f95: New test. From 3c260613f2e74d6639c4dbd43b018b6640ae8454 Mon Sep 17 00:00:00 2001 From: Julian Brown Date: Wed, 20 Feb 2019 05:21:15 -0800 Subject: [PATCH 1/3] Support Fortran 2003 class pointers in OpenACC gcc/ * gimplify.c (insert_struct_comp_map): Handle GOMP_MAP_ATTACH_DETACH. (gimplify_scan_omp_clauses): Separate out handling of OACC_ENTER_DATA and OACC_EXIT_DATA. Remove GOMP_MAP_POINTER and GOMP_MAP_TO_PSET mappings, apart from those following GOMP_MAP_DECLARE_{,DE}ALLOCATE. Handle GOMP_MAP_ATTACH_DETACH. * tree-pretty-print.c (dump_omp_clause): Support GOMP_MAP_ATTACH_DETACH. Print "bias" not "len" for attach/detach clause types. include/ * gomp-constants.h (gomp_map_kind): Add GOMP_MAP_ATTACH_DETACH. gcc/c/ * c-typeck.c (handle_omp_array_sections): Use GOMP_MAP_ATTACH_DETACH for OpenACC attach/detach operations. gcc/cp/ * semantics.c (handle_omp_array_sections): Likewise. (finish_omp_clauses): Handle GOMP_MAP_ATTACH_DETACH. gcc/fortran/ * openmp.c (resolve_oacc_data_clauses): Allow polymorphic allocatable variables. * trans-expr.c (gfc_conv_component_ref, conv_parent_component_reference): Make global. (gfc_auto_dereference_var): New function, broken out of... (gfc_conv_variable): ...here. Call outlined function instead. * trans-openmp.c (gfc_trans_omp_array_section): New function, broken out of... (gfc_trans_omp_clauses): ...here. Separate out OpenACC derived type/polymorphic class pointer handling. Call above outlined function. * trans.h (gfc_conv_component_ref, conv_parent_component_references, gfc_auto_dereference_var): Add prototypes. gcc/testsuite/ * c-c++-common/goacc/mdc-1.c: Update clause matching patterns. libgomp/ * oacc-parallel.c (GOACC_enter_exit_data): Fix optional arguments for changes to clause stripping in enter data/exit data directives. * testsuite/libgomp.oacc-fortran/class-ptr-param.f95: New test. * testsuite/libgomp.oacc-fortran/classtypes-1.f95: New test. * testsuite/libgomp.oacc-fortran/classtypes-2.f95: New test. * testsuite/libgomp.oacc-fortran/derivedtype-1.f95: New test. * testsuite/libgomp.oacc-fortran/derivedtype-2.f95: New test. * testsuite/libgomp.oacc-fortran/multidim-slice.f95: New test. --- gcc/ChangeLog.openacc | 10 + gcc/c/ChangeLog.openacc | 5 + gcc/c/c-typeck.c | 6 +- gcc/cp/ChangeLog.openacc | 5 + gcc/cp/semantics.c | 20 +- gcc/fortran/ChangeLog.openacc | 15 + gcc/fortran/openmp.c | 6 - gcc/fortran/trans-expr.c | 184 ++++----- gcc/fortran/trans-openmp.c | 382 +++++++++++++----- gcc/fortran/trans.h | 9 + gcc/gimplify.c | 67 ++- gcc/testsuite/ChangeLog.openacc | 4 + gcc/testsuite/c-c++-common/goacc/mdc-1.c | 16 +- gcc/tree-pretty-print.c | 9 + include/ChangeLog.openacc | 4 + include/gomp-constants.h | 6 +- libgomp/ChangeLog.openacc | 11 + libgomp/oacc-parallel.c | 3 +- .../libgomp.oacc-fortran/class-ptr-param.f95 | 34 ++ .../libgomp.oacc-fortran/classtypes-1.f95 | 48 +++ .../libgomp.oacc-fortran/classtypes-2.f95 | 106 +++++ .../libgomp.oacc-fortran/derivedtype-1.f95 | 30 ++ .../libgomp.oacc-fortran/derivedtype-2.f95 | 41 ++ .../libgomp.oacc-fortran/multidim-slice.f95 | 50 +++ 24 files changed, 836 insertions(+), 235 deletions(-) create mode 100644 libgomp/testsuite/libgomp.oacc-fortran/class-ptr-param.f95 create mode 100644 libgomp/testsuite/libgomp.oacc-fortran/classtypes-1.f95 create mode 100644 libgomp/testsuite/libgomp.oacc-fortran/classtypes-2.f95 create mode 100644 libgomp/testsuite/libgomp.oacc-fortran/derivedtype-1.f95 create mode 100644 libgomp/testsuite/libgomp.oacc-fortran/derivedtype-2.f95 create mode 100644 libgomp/testsuite/libgomp.oacc-fortran/multidim-slice.f95 diff --git a/gcc/ChangeLog.openacc b/gcc/ChangeLog.openacc index 15c9c084413..455f67f5eae 100644 --- a/gcc/ChangeLog.openacc +++ b/gcc/ChangeLog.openacc @@ -1,3 +1,13 @@ +2019-07-10 Julian Brown + + * gimplify.c (insert_struct_comp_map): Handle GOMP_MAP_ATTACH_DETACH. + (gimplify_scan_omp_clauses): Separate out handling of OACC_ENTER_DATA + and OACC_EXIT_DATA. Remove GOMP_MAP_POINTER and GOMP_MAP_TO_PSET + mappings, apart from those following GOMP_MAP_DECLARE_{,DE}ALLOCATE. + Handle GOMP_MAP_ATTACH_DETACH. + * tree-pretty-print.c (dump_omp_clause): Support GOMP_MAP_ATTACH_DETACH. + Print "bias" not "len" for attach/detach clause types. + 2019-05-28 Julian Brown * omp-low.c (mark_oacc_gangprivate): Add CTX parameter. Use to look up diff --git a/gcc/c/ChangeLog.openacc b/gcc/c/ChangeLog.openacc index c9341355d1a..e5ac8c4be69 100644 --- a/gcc/c/ChangeLog.openacc +++ b/gcc/c/ChangeLog.openacc @@ -1,3 +1,8 @@ +2019-07-10 Julian Brown + + * c-typeck.c (handle_omp_array_sections): Use GOMP_MAP_ATTACH_DETACH + for OpenACC attach/detach operations. + 2018-12-19 Julian Brown Maciej W. Rozycki diff --git a/gcc/c/c-typeck.c b/gcc/c/c-typeck.c index 2acd12d849f..8a56478f7cb 100644 --- a/gcc/c/c-typeck.c +++ b/gcc/c/c-typeck.c @@ -13451,7 +13451,11 @@ handle_omp_array_sections (tree c, enum c_omp_region_type ort) if (ort != C_ORT_OMP && ort != C_ORT_ACC) OMP_CLAUSE_SET_MAP_KIND (c2, GOMP_MAP_POINTER); else if (TREE_CODE (t) == COMPONENT_REF) - OMP_CLAUSE_SET_MAP_KIND (c2, GOMP_MAP_ALWAYS_POINTER); + { + gomp_map_kind k = (ort == C_ORT_ACC) ? GOMP_MAP_ATTACH_DETACH + : GOMP_MAP_ALWAYS_POINTER; + OMP_CLAUSE_SET_MAP_KIND (c2, k); + } else OMP_CLAUSE_SET_MAP_KIND (c2, GOMP_MAP_FIRSTPRIVATE_POINTER); if (OMP_CLAUSE_MAP_KIND (c2) != GOMP_MAP_FIRSTPRIVATE_POINTER diff --git a/gcc/cp/ChangeLog.openacc b/gcc/cp/ChangeLog.openacc index 8306bd04bc3..00ee6b4e469 100644 --- a/gcc/cp/ChangeLog.openacc +++ b/gcc/cp/ChangeLog.openacc @@ -1,3 +1,8 @@ +2019-07-10 Julian Brown + + * semantics.c (handle_omp_array_sections): Likewise. + (finish_omp_clauses): Handle GOMP_MAP_ATTACH_DETACH. + 2019-07-09 Andrew Stubbs Backport from mainline: diff --git a/gcc/cp/semantics.c b/gcc/cp/semantics.c index b8fa0c795be..d5b256df8ff 100644 --- a/gcc/cp/semantics.c +++ b/gcc/cp/semantics.c @@ -5261,12 +5261,18 @@ handle_omp_array_sections (tree c, enum c_omp_region_type ort) if ((ort & C_ORT_OMP_DECLARE_SIMD) != C_ORT_OMP && ort != C_ORT_ACC) OMP_CLAUSE_SET_MAP_KIND (c2, GOMP_MAP_POINTER); else if (TREE_CODE (t) == COMPONENT_REF) - OMP_CLAUSE_SET_MAP_KIND (c2, GOMP_MAP_ALWAYS_POINTER); + { + gomp_map_kind k = (ort == C_ORT_ACC) ? GOMP_MAP_ATTACH_DETACH + : GOMP_MAP_ALWAYS_POINTER; + OMP_CLAUSE_SET_MAP_KIND (c2, k); + } else if (REFERENCE_REF_P (t) && TREE_CODE (TREE_OPERAND (t, 0)) == COMPONENT_REF) { t = TREE_OPERAND (t, 0); - OMP_CLAUSE_SET_MAP_KIND (c2, GOMP_MAP_ALWAYS_POINTER); + gomp_map_kind k = (ort == C_ORT_ACC) ? GOMP_MAP_ATTACH_DETACH + : GOMP_MAP_ALWAYS_POINTER; + OMP_CLAUSE_SET_MAP_KIND (c2, k); } else OMP_CLAUSE_SET_MAP_KIND (c2, GOMP_MAP_FIRSTPRIVATE_POINTER); @@ -7300,7 +7306,8 @@ finish_omp_clauses (tree clauses, enum c_omp_region_type ort) break; if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_MAP && (OMP_CLAUSE_MAP_KIND (c) == GOMP_MAP_POINTER - || OMP_CLAUSE_MAP_KIND (c) == GOMP_MAP_ALWAYS_POINTER)) + || OMP_CLAUSE_MAP_KIND (c) == GOMP_MAP_ALWAYS_POINTER + || OMP_CLAUSE_MAP_KIND (c) == GOMP_MAP_ATTACH_DETACH)) break; if (DECL_P (t)) error_at (OMP_CLAUSE_LOCATION (c), @@ -7439,7 +7446,12 @@ finish_omp_clauses (tree clauses, enum c_omp_region_type ort) tree c2 = build_omp_clause (OMP_CLAUSE_LOCATION (c), OMP_CLAUSE_MAP); if (TREE_CODE (t) == COMPONENT_REF) - OMP_CLAUSE_SET_MAP_KIND (c2, GOMP_MAP_ALWAYS_POINTER); + { + gomp_map_kind k + = (ort == C_ORT_ACC) ? GOMP_MAP_ATTACH_DETACH + : GOMP_MAP_ALWAYS_POINTER; + OMP_CLAUSE_SET_MAP_KIND (c2, k); + } else OMP_CLAUSE_SET_MAP_KIND (c2, GOMP_MAP_FIRSTPRIVATE_REFERENCE); diff --git a/gcc/fortran/ChangeLog.openacc b/gcc/fortran/ChangeLog.openacc index 02349239674..c44a5ebdb3b 100644 --- a/gcc/fortran/ChangeLog.openacc +++ b/gcc/fortran/ChangeLog.openacc @@ -1,3 +1,18 @@ +2019-07-10 Julian Brown + + * openmp.c (resolve_oacc_data_clauses): Allow polymorphic allocatable + variables. + * trans-expr.c (gfc_conv_component_ref, + conv_parent_component_reference): Make global. + (gfc_auto_dereference_var): New function, broken out of... + (gfc_conv_variable): ...here. Call outlined function instead. + * trans-openmp.c (gfc_trans_omp_array_section): New function, broken out + of... + (gfc_trans_omp_clauses): ...here. Separate out OpenACC derived + type/polymorphic class pointer handling. Call above outlined function. + * trans.h (gfc_conv_component_ref, conv_parent_component_references, + gfc_auto_dereference_var): Add prototypes. + 2019-05-19 Julian Brown * trans-openmp.c (gfc_omp_finish_clause): Guard addition of clauses for diff --git a/gcc/fortran/openmp.c b/gcc/fortran/openmp.c index 679f99714b0..adf8d4240f7 100644 --- a/gcc/fortran/openmp.c +++ b/gcc/fortran/openmp.c @@ -3931,12 +3931,6 @@ check_array_not_assumed (gfc_symbol *sym, locus loc, const char *name) static void resolve_oacc_data_clauses (gfc_symbol *sym, locus loc, const char *name) { - if ((sym->ts.type == BT_ASSUMED && sym->attr.allocatable) - || (sym->ts.type == BT_CLASS && CLASS_DATA (sym) - && CLASS_DATA (sym)->attr.allocatable)) - gfc_error ("ALLOCATABLE object %qs of polymorphic type " - "in %s clause at %L", sym->name, name, &loc); - check_symbol_not_pointer (sym, loc, name); check_array_not_assumed (sym, loc, name); } diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 21535acb989..7dc5ada9b6b 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -2403,7 +2403,7 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind, /* Convert a derived type component reference. */ -static void +void gfc_conv_component_ref (gfc_se * se, gfc_ref * ref) { gfc_component *c; @@ -2493,7 +2493,7 @@ gfc_conv_component_ref (gfc_se * se, gfc_ref * ref) /* This function deals with component references to components of the parent type for derived type extensions. */ -static void +void conv_parent_component_references (gfc_se * se, gfc_ref * ref) { gfc_component *c; @@ -2559,6 +2559,95 @@ conv_inquiry (gfc_se * se, gfc_ref * ref, gfc_expr *expr, gfc_typespec *ts) se->expr = res; } +/* Transparently dereference VAR if it is a pointer, reference, etc. + according to Fortran semantics. */ + +tree +gfc_auto_dereference_var (location_t loc, gfc_symbol *sym, tree var, + bool descriptor_only_p, bool is_classarray) +{ + /* Characters are entirely different from other types, they are treated + separately. */ + if (sym->ts.type == BT_CHARACTER) + { + /* Dereference character pointer dummy arguments + or results. */ + if ((sym->attr.pointer || sym->attr.allocatable) + && (sym->attr.dummy + || sym->attr.function + || sym->attr.result)) + var = build_fold_indirect_ref_loc (input_location, var); + } + else if (!sym->attr.value) + { + /* Dereference temporaries for class array dummy arguments. */ + if (sym->attr.dummy && is_classarray + && GFC_ARRAY_TYPE_P (TREE_TYPE (var))) + { + if (!descriptor_only_p) + var = GFC_DECL_SAVED_DESCRIPTOR (var); + + var = build_fold_indirect_ref_loc (input_location, var); + } + + /* Dereference non-character scalar dummy arguments. */ + if (sym->attr.dummy && !sym->attr.dimension + && !(sym->attr.codimension && sym->attr.allocatable) + && (sym->ts.type != BT_CLASS + || (!CLASS_DATA (sym)->attr.dimension + && !(CLASS_DATA (sym)->attr.codimension + && CLASS_DATA (sym)->attr.allocatable)))) + var = build_fold_indirect_ref_loc (input_location, var); + + /* Dereference scalar hidden result. */ + if (flag_f2c && sym->ts.type == BT_COMPLEX + && (sym->attr.function || sym->attr.result) + && !sym->attr.dimension && !sym->attr.pointer + && !sym->attr.always_explicit) + var = build_fold_indirect_ref_loc (input_location, var); + + /* Dereference non-character, non-class pointer variables. + These must be dummies, results, or scalars. */ + if (!is_classarray + && (sym->attr.pointer || sym->attr.allocatable + || gfc_is_associate_pointer (sym) + || (sym->as && sym->as->type == AS_ASSUMED_RANK)) + && (sym->attr.dummy + || sym->attr.function + || sym->attr.result + || (!sym->attr.dimension + && (!sym->attr.codimension || !sym->attr.allocatable)))) + var = build_fold_indirect_ref_loc (input_location, var); + /* Now treat the class array pointer variables accordingly. */ + else if (sym->ts.type == BT_CLASS + && sym->attr.dummy + && (CLASS_DATA (sym)->attr.dimension + || CLASS_DATA (sym)->attr.codimension) + && ((CLASS_DATA (sym)->as + && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK) + || CLASS_DATA (sym)->attr.allocatable + || CLASS_DATA (sym)->attr.class_pointer)) + var = build_fold_indirect_ref_loc (input_location, var); + /* And the case where a non-dummy, non-result, non-function, + non-allotable and non-pointer classarray is present. This case was + previously covered by the first if, but with introducing the + condition !is_classarray there, that case has to be covered + explicitly. */ + else if (sym->ts.type == BT_CLASS + && !sym->attr.dummy + && !sym->attr.function + && !sym->attr.result + && (CLASS_DATA (sym)->attr.dimension + || CLASS_DATA (sym)->attr.codimension) + && (sym->assoc + || !CLASS_DATA (sym)->attr.allocatable) + && !CLASS_DATA (sym)->attr.class_pointer) + var = build_fold_indirect_ref_loc (input_location, var); + } + + return var; +} + /* Return the contents of a variable. Also handles reference/pointer variables (all Fortran pointer references are implicit). */ @@ -2665,94 +2754,9 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) return; } - - /* Dereference the expression, where needed. Since characters - are entirely different from other types, they are treated - separately. */ - if (sym->ts.type == BT_CHARACTER) - { - /* Dereference character pointer dummy arguments - or results. */ - if ((sym->attr.pointer || sym->attr.allocatable) - && (sym->attr.dummy - || sym->attr.function - || sym->attr.result)) - se->expr = build_fold_indirect_ref_loc (input_location, - se->expr); - - } - else if (!sym->attr.value) - { - /* Dereference temporaries for class array dummy arguments. */ - if (sym->attr.dummy && is_classarray - && GFC_ARRAY_TYPE_P (TREE_TYPE (se->expr))) - { - if (!se->descriptor_only) - se->expr = GFC_DECL_SAVED_DESCRIPTOR (se->expr); - - se->expr = build_fold_indirect_ref_loc (input_location, - se->expr); - } - - /* Dereference non-character scalar dummy arguments. */ - if (sym->attr.dummy && !sym->attr.dimension - && !(sym->attr.codimension && sym->attr.allocatable) - && (sym->ts.type != BT_CLASS - || (!CLASS_DATA (sym)->attr.dimension - && !(CLASS_DATA (sym)->attr.codimension - && CLASS_DATA (sym)->attr.allocatable)))) - se->expr = build_fold_indirect_ref_loc (input_location, - se->expr); - - /* Dereference scalar hidden result. */ - if (flag_f2c && sym->ts.type == BT_COMPLEX - && (sym->attr.function || sym->attr.result) - && !sym->attr.dimension && !sym->attr.pointer - && !sym->attr.always_explicit) - se->expr = build_fold_indirect_ref_loc (input_location, - se->expr); - - /* Dereference non-character, non-class pointer variables. - These must be dummies, results, or scalars. */ - if (!is_classarray - && (sym->attr.pointer || sym->attr.allocatable - || gfc_is_associate_pointer (sym) - || (sym->as && sym->as->type == AS_ASSUMED_RANK)) - && (sym->attr.dummy - || sym->attr.function - || sym->attr.result - || (!sym->attr.dimension - && (!sym->attr.codimension || !sym->attr.allocatable)))) - se->expr = build_fold_indirect_ref_loc (input_location, - se->expr); - /* Now treat the class array pointer variables accordingly. */ - else if (sym->ts.type == BT_CLASS - && sym->attr.dummy - && (CLASS_DATA (sym)->attr.dimension - || CLASS_DATA (sym)->attr.codimension) - && ((CLASS_DATA (sym)->as - && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK) - || CLASS_DATA (sym)->attr.allocatable - || CLASS_DATA (sym)->attr.class_pointer)) - se->expr = build_fold_indirect_ref_loc (input_location, - se->expr); - /* And the case where a non-dummy, non-result, non-function, - non-allotable and non-pointer classarray is present. This case was - previously covered by the first if, but with introducing the - condition !is_classarray there, that case has to be covered - explicitly. */ - else if (sym->ts.type == BT_CLASS - && !sym->attr.dummy - && !sym->attr.function - && !sym->attr.result - && (CLASS_DATA (sym)->attr.dimension - || CLASS_DATA (sym)->attr.codimension) - && (sym->assoc - || !CLASS_DATA (sym)->attr.allocatable) - && !CLASS_DATA (sym)->attr.class_pointer) - se->expr = build_fold_indirect_ref_loc (input_location, - se->expr); - } + /* Dereference the expression, where needed. */ + se->expr = gfc_auto_dereference_var (input_location, sym, se->expr, + se->descriptor_only, is_classarray); ref = expr->ref; } diff --git a/gcc/fortran/trans-openmp.c b/gcc/fortran/trans-openmp.c index b0dc2d799fe..d5ae0b717df 100644 --- a/gcc/fortran/trans-openmp.c +++ b/gcc/fortran/trans-openmp.c @@ -1937,6 +1937,92 @@ gfc_convert_expr_to_tree (stmtblock_t *block, gfc_expr *expr) static vec *doacross_steps; + +/* Translate an array section or array element. */ + +static void +gfc_trans_omp_array_section (stmtblock_t *block, gfc_omp_namelist *n, + tree decl, bool element, gomp_map_kind ptr_kind, + tree node, tree &node2, tree &node3, tree &node4) +{ + gfc_se se; + tree ptr, ptr2; + + gfc_init_se (&se, NULL); + + if (element) + { + gfc_conv_expr_reference (&se, n->expr); + gfc_add_block_to_block (block, &se.pre); + ptr = se.expr; + OMP_CLAUSE_SIZE (node) + = TYPE_SIZE_UNIT (TREE_TYPE (ptr)); + } + else + { + gfc_conv_expr_descriptor (&se, n->expr); + ptr = gfc_conv_array_data (se.expr); + tree type = TREE_TYPE (se.expr); + gfc_add_block_to_block (block, &se.pre); + OMP_CLAUSE_SIZE (node) = gfc_full_array_size (block, se.expr, + GFC_TYPE_ARRAY_RANK (type)); + tree elemsz = TYPE_SIZE_UNIT (gfc_get_element_type (type)); + elemsz = fold_convert (gfc_array_index_type, elemsz); + OMP_CLAUSE_SIZE (node) = fold_build2 (MULT_EXPR, gfc_array_index_type, + OMP_CLAUSE_SIZE (node), elemsz); + } + gfc_add_block_to_block (block, &se.post); + ptr = fold_convert (build_pointer_type (char_type_node), ptr); + OMP_CLAUSE_DECL (node) = build_fold_indirect_ref (ptr); + + if (POINTER_TYPE_P (TREE_TYPE (decl)) + && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (decl))) + && ptr_kind == GOMP_MAP_POINTER) + { + node4 = build_omp_clause (input_location, + OMP_CLAUSE_MAP); + OMP_CLAUSE_SET_MAP_KIND (node4, GOMP_MAP_POINTER); + OMP_CLAUSE_DECL (node4) = decl; + OMP_CLAUSE_SIZE (node4) = size_int (0); + decl = build_fold_indirect_ref (decl); + } + ptr = fold_convert (sizetype, ptr); + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))) + { + tree type = TREE_TYPE (decl); + ptr2 = gfc_conv_descriptor_data_get (decl); + node2 = build_omp_clause (input_location, + OMP_CLAUSE_MAP); + OMP_CLAUSE_SET_MAP_KIND (node2, GOMP_MAP_TO_PSET); + OMP_CLAUSE_DECL (node2) = decl; + OMP_CLAUSE_SIZE (node2) = TYPE_SIZE_UNIT (type); + node3 = build_omp_clause (input_location, + OMP_CLAUSE_MAP); + OMP_CLAUSE_SET_MAP_KIND (node3, ptr_kind); + OMP_CLAUSE_DECL (node3) + = gfc_conv_descriptor_data_get (decl); + if (ptr_kind == GOMP_MAP_ATTACH_DETACH) + STRIP_NOPS (OMP_CLAUSE_DECL (node3)); + } + else + { + if (TREE_CODE (TREE_TYPE (decl)) == ARRAY_TYPE) + ptr2 = build_fold_addr_expr (decl); + else + { + gcc_assert (POINTER_TYPE_P (TREE_TYPE (decl))); + ptr2 = decl; + } + node3 = build_omp_clause (input_location, + OMP_CLAUSE_MAP); + OMP_CLAUSE_SET_MAP_KIND (node3, ptr_kind); + OMP_CLAUSE_DECL (node3) = decl; + } + ptr2 = fold_convert (sizetype, ptr2); + OMP_CLAUSE_SIZE (node3) + = fold_build2 (MINUS_EXPR, sizetype, ptr, ptr2); +} + static tree gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, locus where, bool declare_simd = false) @@ -2255,51 +2341,54 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, if (DECL_P (decl)) TREE_ADDRESSABLE (decl) = 1; - gfc_ref *ref = n->expr ? n->expr->ref : NULL; - symbol_attribute *sym_attr = &n->sym->attr; - gomp_map_kind ptr_map_kind = GOMP_MAP_POINTER; - - if (ref && n->sym->ts.type == BT_DERIVED) - { - if (gfc_omp_privatize_by_reference (decl)) - decl = build_fold_indirect_ref (decl); - - for (; ref && ref->type == REF_COMPONENT; ref = ref->next) - { - tree field = ref->u.c.component->backend_decl; - gcc_assert (field && TREE_CODE (field) == FIELD_DECL); - decl = fold_build3 (COMPONENT_REF, TREE_TYPE (field), - decl, field, NULL_TREE); - sym_attr = &ref->u.c.component->attr; - } - - ptr_map_kind = GOMP_MAP_ALWAYS_POINTER; - } - - if (ref == NULL || ref->u.ar.type == AR_FULL) + if (n->expr == NULL || n->expr->ref->u.ar.type == AR_FULL) { - tree field = decl; - - while (TREE_CODE (field) == COMPONENT_REF) - field = TREE_OPERAND (field, 1); - if (POINTER_TYPE_P (TREE_TYPE (decl)) && n->u.map_op == OMP_MAP_FORCE_DEVICEPTR) { OMP_CLAUSE_DECL (node) = decl; goto finalize_map_clause; } + else if (n->sym->ts.type == BT_CLASS) + { + tree type = TREE_TYPE (decl); + if (n->sym->attr.optional) + sorry ("optional class parameter"); + if (POINTER_TYPE_P (type)) + { + node4 = build_omp_clause (input_location, + OMP_CLAUSE_MAP); + OMP_CLAUSE_SET_MAP_KIND (node4, GOMP_MAP_POINTER); + OMP_CLAUSE_DECL (node4) = decl; + OMP_CLAUSE_SIZE (node4) = size_int (0); + decl = build_fold_indirect_ref (decl); + } + tree ptr = gfc_class_data_get (decl); + ptr = build_fold_indirect_ref (ptr); + OMP_CLAUSE_DECL (node) = ptr; + OMP_CLAUSE_SIZE (node) = gfc_class_vtab_size_get (decl); + node2 = build_omp_clause (input_location, OMP_CLAUSE_MAP); + OMP_CLAUSE_SET_MAP_KIND (node2, GOMP_MAP_TO_PSET); + OMP_CLAUSE_DECL (node2) = decl; + OMP_CLAUSE_SIZE (node2) = TYPE_SIZE_UNIT (type); + node3 = build_omp_clause (input_location, OMP_CLAUSE_MAP); + OMP_CLAUSE_SET_MAP_KIND (node3, GOMP_MAP_ATTACH_DETACH); + OMP_CLAUSE_DECL (node3) = gfc_class_data_get (decl); + OMP_CLAUSE_SIZE (node3) = size_int (0); + goto finalize_map_clause; + } else if (POINTER_TYPE_P (TREE_TYPE (decl)) - && (gfc_omp_privatize_by_reference (decl) - || GFC_DECL_GET_SCALAR_POINTER (field) - || GFC_DECL_GET_SCALAR_ALLOCATABLE (field) - || GFC_DECL_CRAY_POINTEE (field) - || GFC_DESCRIPTOR_TYPE_P - (TREE_TYPE (TREE_TYPE (field))))) + && (gfc_omp_privatize_by_reference (decl) + || GFC_DECL_GET_SCALAR_POINTER (decl) + || GFC_DECL_GET_SCALAR_ALLOCATABLE (decl) + || GFC_DECL_CRAY_POINTEE (decl) + || GFC_DESCRIPTOR_TYPE_P + (TREE_TYPE (TREE_TYPE (decl))) + || n->sym->ts.type == BT_DERIVED)) { tree orig_decl = decl; enum gomp_map_kind gmk = GOMP_MAP_POINTER; - if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field) + if (GFC_DECL_GET_SCALAR_ALLOCATABLE (decl) && n->sym->attr.oacc_declare_create) { if (clauses->update_allocatable) @@ -2319,7 +2408,7 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, { node3 = build_omp_clause (input_location, OMP_CLAUSE_MAP); - OMP_CLAUSE_SET_MAP_KIND (node3, ptr_map_kind); + OMP_CLAUSE_SET_MAP_KIND (node3, GOMP_MAP_POINTER); OMP_CLAUSE_DECL (node3) = decl; OMP_CLAUSE_SIZE (node3) = size_int (0); decl = build_fold_indirect_ref (decl); @@ -2332,7 +2421,7 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, tree type = TREE_TYPE (decl); tree ptr; - if (sym_attr->optional) + if (n->sym->attr.optional) ptr = gfc_build_conditional_assign_expr ( block, TREE_OPERAND (decl, 0), @@ -2352,22 +2441,20 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, OMP_CLAUSE_SIZE (node2) = TYPE_SIZE_UNIT (type); node3 = build_omp_clause (input_location, OMP_CLAUSE_MAP); - OMP_CLAUSE_SET_MAP_KIND (node3, ptr_map_kind); + OMP_CLAUSE_SET_MAP_KIND (node3, GOMP_MAP_POINTER); OMP_CLAUSE_DECL (node3) = gfc_conv_descriptor_data_get (decl); - if (ptr_map_kind == GOMP_MAP_ALWAYS_POINTER) - STRIP_NOPS (OMP_CLAUSE_DECL (node3)); OMP_CLAUSE_SIZE (node3) = size_int (0); /* We have to check for n->sym->attr.dimension because of scalar coarrays. */ - if ((sym_attr->pointer || sym_attr->optional) - && sym_attr->dimension) + if ((n->sym->attr.pointer || n->sym->attr.optional) + && n->sym->attr.dimension) { stmtblock_t cond_block; tree size = gfc_create_var (gfc_array_index_type, NULL); - tree cond = sym_attr->optional + tree cond = n->sym->attr.optional ? TREE_OPERAND (decl, 0) : gfc_conv_descriptor_data_get (decl); @@ -2387,11 +2474,11 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, OMP_CLAUSE_SIZE (node) = size; } - else if (sym_attr->dimension) + else if (n->sym->attr.dimension) OMP_CLAUSE_SIZE (node) = gfc_full_array_size (block, decl, GFC_TYPE_ARRAY_RANK (type)); - if (sym_attr->dimension) + if (n->sym->attr.dimension) { tree elemsz = TYPE_SIZE_UNIT (gfc_get_element_type (type)); @@ -2404,88 +2491,161 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, else OMP_CLAUSE_DECL (node) = decl; } - else if (ref) + else if (n->expr + && n->expr->expr_type == EXPR_VARIABLE + && n->expr->ref->type == REF_COMPONENT) { - tree ptr, ptr2; - gfc_init_se (&se, NULL); - if (ref->u.ar.type == AR_ELEMENT) - { - gfc_conv_expr_reference (&se, n->expr); - gfc_add_block_to_block (block, &se.pre); - ptr = se.expr; - OMP_CLAUSE_SIZE (node) - = TYPE_SIZE_UNIT (TREE_TYPE (ptr)); - } + gfc_ref *lastcomp; + + for (gfc_ref *ref = n->expr->ref; ref; ref = ref->next) + if (ref->type == REF_COMPONENT) + lastcomp = ref; + + symbol_attribute sym_attr; + + if (lastcomp->u.c.component->ts.type == BT_CLASS) + sym_attr = CLASS_DATA (lastcomp->u.c.component)->attr; else + sym_attr = lastcomp->u.c.component->attr; + + gfc_init_se (&se, NULL); + + if (!sym_attr.dimension + && lastcomp->u.c.component->ts.type != BT_CLASS + && lastcomp->u.c.component->ts.type != BT_DERIVED) { - gfc_conv_expr_descriptor (&se, n->expr); - ptr = gfc_conv_array_data (se.expr); - tree type = TREE_TYPE (se.expr); + /* Last component is a scalar. */ + gfc_conv_expr (&se, n->expr); gfc_add_block_to_block (block, &se.pre); - OMP_CLAUSE_SIZE (node) - = gfc_full_array_size (block, se.expr, - GFC_TYPE_ARRAY_RANK (type)); - tree elemsz - = TYPE_SIZE_UNIT (gfc_get_element_type (type)); - elemsz = fold_convert (gfc_array_index_type, elemsz); - OMP_CLAUSE_SIZE (node) - = fold_build2 (MULT_EXPR, gfc_array_index_type, - OMP_CLAUSE_SIZE (node), elemsz); + OMP_CLAUSE_DECL (node) = se.expr; + gfc_add_block_to_block (block, &se.post); + goto finalize_map_clause; } - gfc_add_block_to_block (block, &se.post); - ptr = fold_convert (build_pointer_type (char_type_node), - ptr); - OMP_CLAUSE_DECL (node) = build_fold_indirect_ref (ptr); - if (POINTER_TYPE_P (TREE_TYPE (decl)) - && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (decl)))) + se.expr + = gfc_auto_dereference_var (input_location, n->sym, + decl); + + for (gfc_ref *ref = n->expr->ref; + ref && ref != lastcomp->next; + ref = ref->next) { - node4 = build_omp_clause (input_location, - OMP_CLAUSE_MAP); - OMP_CLAUSE_SET_MAP_KIND (node4, ptr_map_kind); - OMP_CLAUSE_DECL (node4) = decl; - OMP_CLAUSE_SIZE (node4) = size_int (0); - decl = build_fold_indirect_ref (decl); + if (ref->type == REF_COMPONENT) + { + if (ref->u.c.sym->attr.extension) + conv_parent_component_references (&se, ref); + + gfc_conv_component_ref (&se, ref); + } + else + sorry ("unhandled derived-type component"); } - ptr = fold_convert (sizetype, ptr); - if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))) + + tree inner = se.expr; + + /* Last component is a derived type or class pointer. */ + if (lastcomp->u.c.component->ts.type == BT_DERIVED + || lastcomp->u.c.component->ts.type == BT_CLASS) { - tree type = TREE_TYPE (decl); - ptr2 = gfc_conv_descriptor_data_get (decl); - node2 = build_omp_clause (input_location, - OMP_CLAUSE_MAP); - OMP_CLAUSE_SET_MAP_KIND (node2, GOMP_MAP_TO_PSET); - OMP_CLAUSE_DECL (node2) = decl; - OMP_CLAUSE_SIZE (node2) = TYPE_SIZE_UNIT (type); - node3 = build_omp_clause (input_location, - OMP_CLAUSE_MAP); - OMP_CLAUSE_SET_MAP_KIND (node3, ptr_map_kind); - OMP_CLAUSE_DECL (node3) - = gfc_conv_descriptor_data_get (decl); - if (ptr_map_kind == GOMP_MAP_ALWAYS_POINTER) - STRIP_NOPS (OMP_CLAUSE_DECL (node3)); + if (sym_attr.allocatable || sym_attr.pointer) + { + tree data, size; + + if (lastcomp->u.c.component->ts.type == BT_CLASS) + { + data = gfc_class_data_get (inner); + size = gfc_class_vtab_size_get (inner); + } + else /* BT_DERIVED. */ + { + data = inner; + size = TYPE_SIZE_UNIT (TREE_TYPE (inner)); + } + + OMP_CLAUSE_DECL (node) + = build_fold_indirect_ref (data); + OMP_CLAUSE_SIZE (node) = size; + node2 = build_omp_clause (input_location, + OMP_CLAUSE_MAP); + OMP_CLAUSE_SET_MAP_KIND (node2, + GOMP_MAP_ATTACH_DETACH); + OMP_CLAUSE_DECL (node2) = data; + OMP_CLAUSE_SIZE (node2) = size_int (0); + } + else + { + OMP_CLAUSE_DECL (node) = decl; + OMP_CLAUSE_SIZE (node) + = TYPE_SIZE_UNIT (TREE_TYPE (decl)); + } } - else + else if (lastcomp->next + && lastcomp->next->type == REF_ARRAY + && lastcomp->next->u.ar.type == AR_FULL) { - if (TREE_CODE (TREE_TYPE (decl)) == ARRAY_TYPE) - ptr2 = build_fold_addr_expr (decl); - else + /* Just pass the (auto-dereferenced) decl through for + bare attach and detach clauses. */ + if (n->u.map_op == OMP_MAP_ATTACH + || n->u.map_op == OMP_MAP_DETACH) { - gcc_assert (POINTER_TYPE_P (TREE_TYPE (decl))); - ptr2 = decl; + OMP_CLAUSE_DECL (node) = inner; + OMP_CLAUSE_SIZE (node) = size_zero_node; + goto finalize_map_clause; } - node3 = build_omp_clause (input_location, - OMP_CLAUSE_MAP); - OMP_CLAUSE_SET_MAP_KIND (node3, ptr_map_kind); - OMP_CLAUSE_DECL (node3) = decl; + + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (inner))) + { + tree type = TREE_TYPE (inner); + tree ptr = gfc_conv_descriptor_data_get (inner); + ptr = build_fold_indirect_ref (ptr); + OMP_CLAUSE_DECL (node) = ptr; + node2 = build_omp_clause (input_location, + OMP_CLAUSE_MAP); + OMP_CLAUSE_SET_MAP_KIND (node2, GOMP_MAP_TO_PSET); + OMP_CLAUSE_DECL (node2) = inner; + OMP_CLAUSE_SIZE (node2) = TYPE_SIZE_UNIT (type); + node3 = build_omp_clause (input_location, + OMP_CLAUSE_MAP); + OMP_CLAUSE_SET_MAP_KIND (node3, + GOMP_MAP_ATTACH_DETACH); + OMP_CLAUSE_DECL (node3) + = gfc_conv_descriptor_data_get (inner); + STRIP_NOPS (OMP_CLAUSE_DECL (node3)); + OMP_CLAUSE_SIZE (node3) = size_int (0); + int rank = GFC_TYPE_ARRAY_RANK (type); + OMP_CLAUSE_SIZE (node) + = gfc_full_array_size (block, inner, rank); + tree elemsz + = TYPE_SIZE_UNIT (gfc_get_element_type (type)); + elemsz = fold_convert (gfc_array_index_type, elemsz); + OMP_CLAUSE_SIZE (node) + = fold_build2 (MULT_EXPR, gfc_array_index_type, + OMP_CLAUSE_SIZE (node), elemsz); + } + else + OMP_CLAUSE_DECL (node) = inner; + } + else /* An array element or section. */ + { + bool element + = (lastcomp->next + && lastcomp->next->type == REF_ARRAY + && lastcomp->next->u.ar.type == AR_ELEMENT); + + gfc_trans_omp_array_section (block, n, inner, element, + GOMP_MAP_ATTACH_DETACH, + node, node2, node3, node4); } - ptr2 = fold_convert (sizetype, ptr2); - OMP_CLAUSE_SIZE (node3) - = fold_build2 (MINUS_EXPR, sizetype, ptr, ptr2); - finalize_map_clause:; } - else - gcc_unreachable (); + else /* An array element or array section. */ + { + bool element = n->expr->ref->u.ar.type == AR_ELEMENT; + gfc_trans_omp_array_section (block, n, decl, element, + GOMP_MAP_POINTER, node, node2, + node3, node4); + } + + finalize_map_clause: switch (n->u.map_op) { case OMP_MAP_ALLOC: diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index cb8c1af3799..794600a1e61 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -546,6 +546,15 @@ tree gfc_conv_expr_present (gfc_symbol *); /* Convert a missing, dummy argument into a null or zero. */ void gfc_conv_missing_dummy (gfc_se *, gfc_expr *, gfc_typespec, int); +/* Lowering of component references. */ +void gfc_conv_component_ref (gfc_se * se, gfc_ref * ref); +void conv_parent_component_references (gfc_se * se, gfc_ref * ref); + +/* Automatically dereference var. */ +tree gfc_auto_dereference_var (location_t, gfc_symbol *, tree, + bool desc_only = false, + bool is_classarray = false); + /* Generate code to allocate a string temporary. */ tree gfc_conv_string_tmp (gfc_se *, tree, tree); /* Get the string length variable belonging to an expression. */ diff --git a/gcc/gimplify.c b/gcc/gimplify.c index 56d707d735d..60e04ff8353 100644 --- a/gcc/gimplify.c +++ b/gcc/gimplify.c @@ -8126,8 +8126,10 @@ insert_struct_comp_map (enum tree_code code, tree c, tree struct_node, GOMP_MAP_ALWAYS_POINTER though, i.e. a GOMP_MAP_TO_PSET. */ if (OMP_CLAUSE_CHAIN (prev_node) != c && OMP_CLAUSE_CODE (OMP_CLAUSE_CHAIN (prev_node)) == OMP_CLAUSE_MAP - && (OMP_CLAUSE_MAP_KIND (OMP_CLAUSE_CHAIN (prev_node)) - == GOMP_MAP_ALWAYS_POINTER)) + && ((OMP_CLAUSE_MAP_KIND (OMP_CLAUSE_CHAIN (prev_node)) + == GOMP_MAP_ALWAYS_POINTER) + || (OMP_CLAUSE_MAP_KIND (OMP_CLAUSE_CHAIN (prev_node)) + == GOMP_MAP_ATTACH_DETACH))) { tree c4 = OMP_CLAUSE_CHAIN (prev_node); tree c3 = build_omp_clause (OMP_CLAUSE_LOCATION (c), OMP_CLAUSE_MAP); @@ -8673,8 +8675,6 @@ gimplify_scan_omp_clauses (tree *list_p, gimple_seq *pre_p, case OMP_TARGET_DATA: case OMP_TARGET_ENTER_DATA: case OMP_TARGET_EXIT_DATA: - case OACC_ENTER_DATA: - case OACC_EXIT_DATA: case OACC_HOST_DATA: if (OMP_CLAUSE_MAP_KIND (c) == GOMP_MAP_FIRSTPRIVATE_POINTER || (OMP_CLAUSE_MAP_KIND (c) @@ -8683,6 +8683,21 @@ gimplify_scan_omp_clauses (tree *list_p, gimple_seq *pre_p, mapped, but not the pointer to it. */ remove = true; break; + case OACC_ENTER_DATA: + case OACC_EXIT_DATA: + if ((OMP_CLAUSE_MAP_KIND (c) == GOMP_MAP_POINTER + || OMP_CLAUSE_MAP_KIND (c) == GOMP_MAP_TO_PSET + || OMP_CLAUSE_MAP_KIND (c) == GOMP_MAP_FIRSTPRIVATE_POINTER + || (OMP_CLAUSE_MAP_KIND (c) + == GOMP_MAP_FIRSTPRIVATE_REFERENCE)) + && !(prev_list_p + && OMP_CLAUSE_CODE (*prev_list_p) == OMP_CLAUSE_MAP + && ((OMP_CLAUSE_MAP_KIND (*prev_list_p) + == GOMP_MAP_DECLARE_ALLOCATE) + || (OMP_CLAUSE_MAP_KIND (*prev_list_p) + == GOMP_MAP_DECLARE_DEALLOCATE)))) + remove = true; + break; default: break; } @@ -8770,7 +8785,7 @@ gimplify_scan_omp_clauses (tree *list_p, gimple_seq *pre_p, tree decl_ref = NULL_TREE; if ((region_type & ORT_ACC) != 0 && TREE_CODE (*pd) == COMPONENT_REF - && OMP_CLAUSE_MAP_KIND (c) == GOMP_MAP_ALWAYS_POINTER + && OMP_CLAUSE_MAP_KIND (c) == GOMP_MAP_ATTACH_DETACH && code != OACC_UPDATE) { while (TREE_CODE (decl) == COMPONENT_REF) @@ -8812,7 +8827,14 @@ gimplify_scan_omp_clauses (tree *list_p, gimple_seq *pre_p, mapped as a FIRSTPRIVATE_POINTER. */ OMP_CLAUSE_SET_MAP_KIND (c, k); flags = GOVD_MAP | GOVD_SEEN | GOVD_EXPLICIT; + tree next_clause = OMP_CLAUSE_CHAIN (c); if (k == GOMP_MAP_ATTACH + && code != OACC_ENTER_DATA + && (!next_clause + || (OMP_CLAUSE_CODE (next_clause) != OMP_CLAUSE_MAP) + || (OMP_CLAUSE_MAP_KIND (next_clause) + != GOMP_MAP_POINTER) + || OMP_CLAUSE_DECL (next_clause) != decl) && (!struct_deref_set || !struct_deref_set->contains (decl))) { @@ -8848,6 +8870,13 @@ gimplify_scan_omp_clauses (tree *list_p, gimple_seq *pre_p, } goto do_add_decl; } + /* An "attach/detach" operation on an update directive should + behave as a GOMP_MAP_ALWAYS_POINTER. Beware that + unlike attach or detach map kinds, GOMP_MAP_ALWAYS_POINTER + depends on the previous mapping. */ + if (code == OACC_UPDATE + && OMP_CLAUSE_MAP_KIND (c) == GOMP_MAP_ATTACH_DETACH) + OMP_CLAUSE_SET_MAP_KIND (c, GOMP_MAP_ALWAYS_POINTER); if (gimplify_expr (pd, pre_p, NULL, is_gimple_lvalue, fb_lvalue) == GS_ERROR) { @@ -8856,6 +8885,8 @@ gimplify_scan_omp_clauses (tree *list_p, gimple_seq *pre_p, } if (DECL_P (decl) && OMP_CLAUSE_MAP_KIND (c) != GOMP_MAP_TO_PSET + && OMP_CLAUSE_MAP_KIND (c) != GOMP_MAP_ATTACH + && OMP_CLAUSE_MAP_KIND (c) != GOMP_MAP_DETACH && code != OACC_UPDATE) { if (error_operand_p (decl)) @@ -8877,7 +8908,8 @@ gimplify_scan_omp_clauses (tree *list_p, gimple_seq *pre_p, break; } - if (OMP_CLAUSE_MAP_KIND (c) == GOMP_MAP_ALWAYS_POINTER) + if (OMP_CLAUSE_MAP_KIND (c) == GOMP_MAP_ALWAYS_POINTER + || OMP_CLAUSE_MAP_KIND (c) == GOMP_MAP_ATTACH_DETACH) { /* Error recovery. */ if (prev_list_p == NULL) @@ -8909,12 +8941,14 @@ gimplify_scan_omp_clauses (tree *list_p, gimple_seq *pre_p, = splay_tree_lookup (ctx->variables, (splay_tree_key)decl); bool ptr = (OMP_CLAUSE_MAP_KIND (c) == GOMP_MAP_ALWAYS_POINTER); + bool attach_detach = (OMP_CLAUSE_MAP_KIND (c) + == GOMP_MAP_ATTACH_DETACH); bool attach = OMP_CLAUSE_MAP_KIND (c) == GOMP_MAP_ATTACH || OMP_CLAUSE_MAP_KIND (c) == GOMP_MAP_DETACH; bool has_attachments = false; /* For OpenACC, pointers in structs should trigger an attach action. */ - if (ptr && (region_type & ORT_ACC) != 0) + if (attach_detach && (region_type & ORT_ACC) != 0) { /* Turning a GOMP_MAP_ALWAYS_POINTER clause into a GOMP_MAP_ATTACH clause after we have detected a case @@ -8946,7 +8980,7 @@ gimplify_scan_omp_clauses (tree *list_p, gimple_seq *pre_p, if (struct_map_to_clause == NULL) struct_map_to_clause = new hash_map; struct_map_to_clause->put (decl, l); - if (ptr) + if (ptr || attach_detach) { insert_struct_comp_map (code, c, l, *prev_list_p, NULL); @@ -8972,7 +9006,9 @@ gimplify_scan_omp_clauses (tree *list_p, gimple_seq *pre_p, OMP_CLAUSE_CHAIN (l) = c2; } flags = GOVD_MAP | GOVD_EXPLICIT; - if (GOMP_MAP_ALWAYS_P (OMP_CLAUSE_MAP_KIND (c)) || ptr) + if (GOMP_MAP_ALWAYS_P (OMP_CLAUSE_MAP_KIND (c)) + || ptr + || attach_detach) flags |= GOVD_SEEN; if (has_attachments) flags |= GOVD_MAP_HAS_ATTACHMENTS; @@ -8982,7 +9018,9 @@ gimplify_scan_omp_clauses (tree *list_p, gimple_seq *pre_p, { tree *osc = struct_map_to_clause->get (decl); tree *sc = NULL, *scp = NULL; - if (GOMP_MAP_ALWAYS_P (OMP_CLAUSE_MAP_KIND (c)) || ptr) + if (GOMP_MAP_ALWAYS_P (OMP_CLAUSE_MAP_KIND (c)) + || ptr + || attach_detach) n->value |= GOVD_SEEN; sc = &OMP_CLAUSE_CHAIN (*osc); if (*sc != c @@ -8992,7 +9030,7 @@ gimplify_scan_omp_clauses (tree *list_p, gimple_seq *pre_p, /* Here "prev_list_p" is the end of the inserted alloc/release nodes after the struct node, OSC. */ for (; *sc != c; sc = &OMP_CLAUSE_CHAIN (*sc)) - if (ptr && sc == prev_list_p) + if ((ptr || attach_detach) && sc == prev_list_p) break; else if (TREE_CODE (OMP_CLAUSE_DECL (*sc)) != COMPONENT_REF @@ -9041,7 +9079,7 @@ gimplify_scan_omp_clauses (tree *list_p, gimple_seq *pre_p, } if (same_decl_offset_lt) { - if (ptr) + if (ptr || attach_detach) scp = sc; else break; @@ -9053,7 +9091,7 @@ gimplify_scan_omp_clauses (tree *list_p, gimple_seq *pre_p, OMP_CLAUSE_SIZE (*osc) = size_binop (PLUS_EXPR, OMP_CLAUSE_SIZE (*osc), size_one_node); - if (ptr) + if (ptr || attach_detach) { tree cl = insert_struct_comp_map (code, c, NULL, *prev_list_p, scp); @@ -9083,11 +9121,14 @@ gimplify_scan_omp_clauses (tree *list_p, gimple_seq *pre_p, } if (!remove && OMP_CLAUSE_MAP_KIND (c) != GOMP_MAP_ALWAYS_POINTER + && OMP_CLAUSE_MAP_KIND (c) != GOMP_MAP_ATTACH_DETACH && OMP_CLAUSE_MAP_KIND (c) != GOMP_MAP_TO_PSET && OMP_CLAUSE_CHAIN (c) && OMP_CLAUSE_CODE (OMP_CLAUSE_CHAIN (c)) == OMP_CLAUSE_MAP && ((OMP_CLAUSE_MAP_KIND (OMP_CLAUSE_CHAIN (c)) == GOMP_MAP_ALWAYS_POINTER) + || (OMP_CLAUSE_MAP_KIND (OMP_CLAUSE_CHAIN (c)) + == GOMP_MAP_ATTACH_DETACH) || (OMP_CLAUSE_MAP_KIND (OMP_CLAUSE_CHAIN (c)) == GOMP_MAP_TO_PSET))) prev_list_p = list_p; diff --git a/gcc/testsuite/ChangeLog.openacc b/gcc/testsuite/ChangeLog.openacc index deddcc50ce1..8295fe61ba7 100644 --- a/gcc/testsuite/ChangeLog.openacc +++ b/gcc/testsuite/ChangeLog.openacc @@ -1,3 +1,7 @@ +2019-07-10 Julian Brown + + * c-c++-common/goacc/mdc-1.c: Update clause matching patterns. + 2019-07-09 Andrew Stubbs Backport from mainline: diff --git a/gcc/testsuite/c-c++-common/goacc/mdc-1.c b/gcc/testsuite/c-c++-common/goacc/mdc-1.c index b8d03a088ec..6c6a81ea73a 100644 --- a/gcc/testsuite/c-c++-common/goacc/mdc-1.c +++ b/gcc/testsuite/c-c++-common/goacc/mdc-1.c @@ -43,13 +43,13 @@ t1 () } /* { dg-final { scan-tree-dump-times "pragma omp target oacc_enter_exit_data map.to:s .len: 32.." 1 "omplower" } } */ -/* { dg-final { scan-tree-dump-times "pragma omp target oacc_data map.tofrom:.z .len: 40.. map.struct:s .len: 1.. map.alloc:s.a .len: 8.. map.tofrom:._1 .len: 40.. map.attach:s.a .len: 0.." 1 "omplower" } } */ -/* { dg-final { scan-tree-dump-times "pragma omp target oacc_parallel map.force_present:s .len: 32.. map.attach:s.e .len: 8.." 1 "omplower" } } */ -/* { dg-final { scan-tree-dump-times "pragma omp target oacc_enter_exit_data map.attach:a .len: 8.." 1 "omplower" } } */ -/* { dg-final { scan-tree-dump-times "pragma omp target oacc_enter_exit_data map.detach:a .len: 8.." 1 "omplower" } } */ +/* { dg-final { scan-tree-dump-times "pragma omp target oacc_data map.tofrom:.z .len: 40.. map.struct:s .len: 1.. map.alloc:s.a .len: 8.. map.tofrom:._1 .len: 40.. map.attach:s.a .bias: 0.." 1 "omplower" } } */ +/* { dg-final { scan-tree-dump-times "pragma omp target oacc_parallel map.attach:s.e .bias: 8.. map.tofrom:s .len: 32" 1 "omplower" } } */ +/* { dg-final { scan-tree-dump-times "pragma omp target oacc_enter_exit_data map.attach:a .bias: 8.." 1 "omplower" } } */ +/* { dg-final { scan-tree-dump-times "pragma omp target oacc_enter_exit_data map.detach:a .bias: 8.." 1 "omplower" } } */ /* { dg-final { scan-tree-dump-times "pragma omp target oacc_enter_exit_data map.to:a .len: 8.." 1 "omplower" } } */ -/* { dg-final { scan-tree-dump-times "pragma omp target oacc_enter_exit_data map.force_present:s .len: 32.. map.detach:s.e .len: 8.." 1 "omplower" } } */ -/* { dg-final { scan-tree-dump-times "pragma omp target oacc_data map.force_present:s .len: 32.. map.attach:s.e .len: 8.." 1 "omplower" } } */ +/* { dg-final { scan-tree-dump-times "pragma omp target oacc_enter_exit_data map.detach:s.e .bias: 8.." 1 "omplower" } } */ +/* { dg-final { scan-tree-dump-times "pragma omp target oacc_data map.attach:s.e .bias: 8.." 1 "omplower" } } */ /* { dg-final { scan-tree-dump-times "pragma omp target oacc_enter_exit_data map.release:a .len: 8.." 1 "omplower" } } */ -/* { dg-final { scan-tree-dump-times "pragma omp target oacc_enter_exit_data finalize map.force_detach:a .len: 8.." 1 "omplower" } } */ -/* { dg-final { scan-tree-dump-times "pragma omp target oacc_enter_exit_data finalize map.force_present:s .len: 32.. map.force_detach:s.a .len: 8.." 1 "omplower" } } */ +/* { dg-final { scan-tree-dump-times "pragma omp target oacc_enter_exit_data finalize map.force_detach:a .bias: 8.." 1 "omplower" } } */ +/* { dg-final { scan-tree-dump-times "pragma omp target oacc_enter_exit_data finalize map.force_detach:s.a .bias: 8.." 1 "omplower" } } */ diff --git a/gcc/tree-pretty-print.c b/gcc/tree-pretty-print.c index d6171f09f0e..3a170794688 100644 --- a/gcc/tree-pretty-print.c +++ b/gcc/tree-pretty-print.c @@ -871,6 +871,9 @@ dump_omp_clause (pretty_printer *pp, tree clause, int spc, dump_flags_t flags) case GOMP_MAP_FORCE_DETACH: pp_string (pp, "force_detach"); break; + case GOMP_MAP_ATTACH_DETACH: + pp_string (pp, "attach_detach"); + break; default: gcc_unreachable (); } @@ -896,6 +899,12 @@ dump_omp_clause (pretty_printer *pp, tree clause, int spc, dump_flags_t flags) gcc_assert (TREE_CODE (OMP_CLAUSE_SIZE (clause)) == TREE_LIST); pp_string (pp, " [dimensions: "); break; + case GOMP_MAP_ATTACH: + case GOMP_MAP_DETACH: + case GOMP_MAP_FORCE_DETACH: + case GOMP_MAP_ATTACH_DETACH: + pp_string (pp, " [bias: "); + break; default: pp_string (pp, " [len: "); break; diff --git a/include/ChangeLog.openacc b/include/ChangeLog.openacc index 2cbb9919f60..e0584385f43 100644 --- a/include/ChangeLog.openacc +++ b/include/ChangeLog.openacc @@ -1,3 +1,7 @@ +2019-07-10 Julian Brown + + * gomp-constants.h (gomp_map_kind): Add GOMP_MAP_ATTACH_DETACH. + 2018-12-20 Maciej W. Rozycki * gomp-constants.h (GOMP_DEVICE_CURRENT): New macro. diff --git a/include/gomp-constants.h b/include/gomp-constants.h index 5634babd840..22f9520524d 100644 --- a/include/gomp-constants.h +++ b/include/gomp-constants.h @@ -171,7 +171,11 @@ enum gomp_map_kind /* Do not map, but pointer assign a pointer instead. */ GOMP_MAP_FIRSTPRIVATE_POINTER = (GOMP_MAP_LAST | 1), /* Do not map, but pointer assign a reference instead. */ - GOMP_MAP_FIRSTPRIVATE_REFERENCE = (GOMP_MAP_LAST | 2) + GOMP_MAP_FIRSTPRIVATE_REFERENCE = (GOMP_MAP_LAST | 2), + /* An attach or detach operation. Rewritten to the appropriate type during + gimplification, depending on directive (i.e. "enter data" or + parallel/kernels region vs. "exit data"). */ + GOMP_MAP_ATTACH_DETACH = (GOMP_MAP_LAST | 3) }; #define GOMP_MAP_COPY_TO_P(X) \ diff --git a/libgomp/ChangeLog.openacc b/libgomp/ChangeLog.openacc index b3bcb3113f1..1d88bd54cd2 100644 --- a/libgomp/ChangeLog.openacc +++ b/libgomp/ChangeLog.openacc @@ -1,3 +1,14 @@ +2019-07-10 Julian Brown + + * oacc-parallel.c (GOACC_enter_exit_data): Fix optional arguments for + changes to clause stripping in enter data/exit data directives. + * testsuite/libgomp.oacc-fortran/class-ptr-param.f95: New test. + * testsuite/libgomp.oacc-fortran/classtypes-1.f95: New test. + * testsuite/libgomp.oacc-fortran/classtypes-2.f95: New test. + * testsuite/libgomp.oacc-fortran/derivedtype-1.f95: New test. + * testsuite/libgomp.oacc-fortran/derivedtype-2.f95: New test. + * testsuite/libgomp.oacc-fortran/multidim-slice.f95: New test. + 2019-05-28 Julian Brown * testsuite/libgomp.oacc-fortran/gangprivate-attrib-2.f90: New test. diff --git a/libgomp/oacc-parallel.c b/libgomp/oacc-parallel.c index b949599a8d0..86063417bff 100644 --- a/libgomp/oacc-parallel.c +++ b/libgomp/oacc-parallel.c @@ -550,7 +550,8 @@ GOACC_enter_exit_data (int flags_m, size_t mapnum, break; case GOMP_MAP_TO: case GOMP_MAP_FORCE_TO: - acc_copyin_async (hostaddrs[i], sizes[i], async); + if (hostaddrs[i]) + acc_copyin_async (hostaddrs[i], sizes[i], async); break; case GOMP_MAP_STRUCT: { diff --git a/libgomp/testsuite/libgomp.oacc-fortran/class-ptr-param.f95 b/libgomp/testsuite/libgomp.oacc-fortran/class-ptr-param.f95 new file mode 100644 index 00000000000..80147337c9d --- /dev/null +++ b/libgomp/testsuite/libgomp.oacc-fortran/class-ptr-param.f95 @@ -0,0 +1,34 @@ +! { dg-do run } + +module typemod + +type mytype + integer :: a +end type mytype + +contains + +subroutine mysub(c) + implicit none + + class(mytype), allocatable :: c + +!$acc parallel copy(c) + c%a = 5 +!$acc end parallel +end subroutine mysub + +end module typemod + +program main + use typemod + implicit none + + class(mytype), allocatable :: myvar + allocate(mytype :: myvar) + + myvar%a = 0 + call mysub(myvar) + + if (myvar%a .ne. 5) stop 1 +end program main diff --git a/libgomp/testsuite/libgomp.oacc-fortran/classtypes-1.f95 b/libgomp/testsuite/libgomp.oacc-fortran/classtypes-1.f95 new file mode 100644 index 00000000000..f16f42fc3af --- /dev/null +++ b/libgomp/testsuite/libgomp.oacc-fortran/classtypes-1.f95 @@ -0,0 +1,48 @@ +! { dg-do run } + +module typemod + +type :: typeimpl + real, pointer :: p(:) => null() +end type typeimpl + +type :: basictype + class(typeimpl), pointer :: p => null() +end type basictype + +type, extends(basictype) :: regulartype + character :: void +end type regulartype + +end module typemod + +program main + use typemod + implicit none + type(regulartype), pointer :: myvar + integer :: i + real :: j, k + + allocate(myvar) + allocate(myvar%p) + allocate(myvar%p%p(1:100)) + + do i=1,100 + myvar%p%p(i) = -1.0 + end do + +!$acc enter data copyin(myvar, myvar%p) create(myvar%p%p) + +!$acc parallel loop present(myvar%p%p) + do i=1,100 + myvar%p%p(i) = i * 2 + end do +!$acc end parallel loop + +!$acc exit data copyout(myvar%p%p) delete(myvar, myvar%p) + + do i=1,100 + if (myvar%p%p(i) .ne. i * 2) stop 1 + end do + +end program main diff --git a/libgomp/testsuite/libgomp.oacc-fortran/classtypes-2.f95 b/libgomp/testsuite/libgomp.oacc-fortran/classtypes-2.f95 new file mode 100644 index 00000000000..ad80ec2a0ef --- /dev/null +++ b/libgomp/testsuite/libgomp.oacc-fortran/classtypes-2.f95 @@ -0,0 +1,106 @@ +! { dg-do run } + +module wrapper_mod + +type compute + integer, allocatable :: block(:,:) +contains + procedure :: initialize +end type compute + +type, extends(compute) :: cpu_compute + integer :: blocksize +contains + procedure :: setblocksize +end type cpu_compute + +type, extends(compute) :: gpu_compute + integer :: numgangs + integer :: numworkers + integer :: vectorsize + integer, allocatable :: gpu_block(:,:) +contains + procedure :: setdims +end type gpu_compute + +contains + +subroutine initialize(c, length, width) + implicit none + class(compute) :: c + integer :: length + integer :: width + integer :: i + integer :: j + + allocate (c%block(length, width)) + + do i=1,length + do j=1, width + c%block(i,j) = i + j + end do + end do +end subroutine initialize + +subroutine setdims(c, g, w, v) + implicit none + class(gpu_compute) :: c + integer :: g + integer :: w + integer :: v + c%numgangs = g + c%numworkers = w + c%vectorsize = v +end subroutine setdims + +subroutine setblocksize(c, bs) + implicit none + class(cpu_compute) :: c + integer :: bs + c%blocksize = bs +end subroutine setblocksize + +end module wrapper_mod + +program main + use wrapper_mod + implicit none + class(compute), allocatable, target :: mycomp + integer :: i, j + + allocate(gpu_compute::mycomp) + + call mycomp%initialize(1024,1024) + + !$acc enter data copyin(mycomp) + + select type (mycomp) + type is (cpu_compute) + call mycomp%setblocksize(32) + type is (gpu_compute) + call mycomp%setdims(32,32,32) + allocate(mycomp%gpu_block(1024,1024)) + !$acc update device(mycomp) + !$acc parallel copyin(mycomp%block) copyout(mycomp%gpu_block) + !$acc loop gang worker vector collapse(2) + do i=1,1024 + do j=1,1024 + mycomp%gpu_block(i,j) = mycomp%block(i,j) + 1 + end do + end do + !$acc end parallel + end select + + !$acc exit data copyout(mycomp) + + select type (g => mycomp) + type is (gpu_compute) + do i = 1, 1024 + do j = 1, 1024 + if (g%gpu_block(i,j) .ne. i + j + 1) stop 1 + end do + end do + end select + + deallocate(mycomp) +end program main diff --git a/libgomp/testsuite/libgomp.oacc-fortran/derivedtype-1.f95 b/libgomp/testsuite/libgomp.oacc-fortran/derivedtype-1.f95 new file mode 100644 index 00000000000..75ce48ddca2 --- /dev/null +++ b/libgomp/testsuite/libgomp.oacc-fortran/derivedtype-1.f95 @@ -0,0 +1,30 @@ +! { dg-do run } + +program main + implicit none + + type mytype + integer :: a, b, c + end type mytype + + type(mytype) :: myvar + integer :: i + + myvar%a = 0 + myvar%b = 0 + myvar%c = 0 + +!$acc enter data copyin(myvar) + +!$acc parallel present(myvar) + myvar%a = 1 + myvar%b = 2 + myvar%c = 3 +!$acc end parallel + +!$acc exit data copyout(myvar) + + if (myvar%a .ne. 1) stop 1 + if (myvar%b .ne. 2) stop 2 + if (myvar%c .ne. 3) stop 3 +end program main diff --git a/libgomp/testsuite/libgomp.oacc-fortran/derivedtype-2.f95 b/libgomp/testsuite/libgomp.oacc-fortran/derivedtype-2.f95 new file mode 100644 index 00000000000..3088b832957 --- /dev/null +++ b/libgomp/testsuite/libgomp.oacc-fortran/derivedtype-2.f95 @@ -0,0 +1,41 @@ +! { dg-do run } + +program main + implicit none + + type tnest + integer :: ia, ib, ic + end type tnest + + type mytype + type(tnest) :: nest + integer :: a, b, c + end type mytype + + type(mytype) :: myvar + integer :: i + + myvar%a = 0 + myvar%b = 0 + myvar%c = 0 + myvar%nest%ia = 0 + myvar%nest%ib = 0 + myvar%nest%ic = 0 + +!$acc enter data copyin(myvar%nest) + +!$acc parallel present(myvar%nest) + myvar%nest%ia = 4 + myvar%nest%ib = 5 + myvar%nest%ic = 6 +!$acc end parallel + +!$acc exit data copyout(myvar%nest) + + if (myvar%a .ne. 0) stop 1 + if (myvar%b .ne. 0) stop 2 + if (myvar%c .ne. 0) stop 3 + if (myvar%nest%ia .ne. 4) stop 4 + if (myvar%nest%ib .ne. 5) stop 5 + if (myvar%nest%ic .ne. 6) stop 6 +end program main diff --git a/libgomp/testsuite/libgomp.oacc-fortran/multidim-slice.f95 b/libgomp/testsuite/libgomp.oacc-fortran/multidim-slice.f95 new file mode 100644 index 00000000000..a9b40eeab4c --- /dev/null +++ b/libgomp/testsuite/libgomp.oacc-fortran/multidim-slice.f95 @@ -0,0 +1,50 @@ +! { dg-do run } + +program main + implicit none + real, allocatable :: myarr(:,:,:,:,:) + integer i, j, k, l, m + + allocate(myarr(1:10,1:10,1:10,1:10,1:10)) + + do i=1,10 + do j=1,10 + do k=1,10 + do l=1,10 + do m=1,10 + myarr(m,l,k,j,i) = i+j+k+l+m + end do + end do + end do + end do + end do + + do i=1,10 + !$acc data copy(myarr(:,:,:,:,i)) + !$acc parallel loop collapse(4) present(myarr(:,:,:,:,i)) + do j=1,10 + do k=1,10 + do l=1,10 + do m=1,10 + myarr(m,l,k,j,i) = myarr(m,l,k,j,i) + 1 + end do + end do + end do + end do + !$acc end parallel loop + !$acc end data + end do + + do i=1,10 + do j=1,10 + do k=1,10 + do l=1,10 + do m=1,10 + if (myarr(m,l,k,j,i) .ne. i+j+k+l+m+1) stop 1 + end do + end do + end do + end do + end do + +end program main -- 2.22.0