From patchwork Tue Sep 4 00:46:54 2018 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Julian Brown X-Patchwork-Id: 965646 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-485050-incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=) Authentication-Results: ozlabs.org; dmarc=none (p=none dis=none) header.from=codesourcery.com 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 4247Tg5Jfmz9ryn for ; Tue, 4 Sep 2018 10:47:25 +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=rpUjRwSsCjF7u9UQyLZHlPQEyq53MyyLUIl1wTBjiaSNSpb/nztt5 6DCPxvJDW6g5+VBwXrOUVGNUJUbfM1R2I9Pl1mcqwDwzUgA5cO0pkt2xRUXrAseq zQcU3YEpWjYVuUsBDn9eeOsFCkJHwTJbQQHabF7XtPyghaLbfKvB5g= 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=qsWHBKEWr9vZZfpkFYCUqVRzakE=; b=C+vfDLjCIP0kRAFTPwrN LghPXL8be6sq6VZveG8ah9O7l1cPMFHGELm/GImcuhTxfKuRJbpx44kqnALWj80O G/F/nD5fodPWSf7kq8J4DxVPyJql491PiS72O71oL030rf91jFxA5wZQCpUWXiHI b8nt8OP/kaeY7N6dKeEC2F0= Received: (qmail 118148 invoked by alias); 4 Sep 2018 00:47:17 -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 118134 invoked by uid 89); 4 Sep 2018 00:47:17 -0000 Authentication-Results: sourceware.org; auth=none X-Spam-SWARE-Status: No, score=-24.5 required=5.0 tests=AWL, BAYES_00, GIT_PATCH_0, GIT_PATCH_1, GIT_PATCH_2, GIT_PATCH_3, RCVD_IN_DNSWL_NONE, SPF_PASS autolearn=ham version=3.3.2 spammy=permit, rank, UPDATE, i1 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; Tue, 04 Sep 2018 00:47:13 +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 1fwzUt-0000vb-FF from Julian_Brown@mentor.com ; Mon, 03 Sep 2018 17:47:11 -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; Tue, 4 Sep 2018 01:47:06 +0100 Date: Mon, 3 Sep 2018 20:46:54 -0400 From: Julian Brown To: "gcc-patches@gcc.gnu.org" , Cesar Philippidis , Jakub Jelinek Subject: [PATCH, OpenACC] Support Fortran derived type members in "acc update" directives Message-ID: <20180903204654.5056f591@squid.athome> MIME-Version: 1.0 X-IsSubscribed: yes Hi, This patch (by Cesar) adds support for Fortran derived type members in "acc update" directives (as specified in OpenACC 2.5 2.14.4., Update Directive). Seemingly only "update" directives may specify derived type members in this way as of OpenACC 2.5. Tested with offloading to NVPTX and bootstrapped. OK to apply? Thanks, Julian 2018-09-03 Cesar Philippidis gcc/fortran/ * openmp.c (gfc_match_omp_variable_list): New allow_derived argument. (gfc_match_omp_map_clause): Update call to gfc_match_omp_variable_list. (gfc_match_omp_clauses): Update calls to gfc_match_omp_map_clause. (gfc_match_oacc_update): Update call to gfc_match_omp_clauses. (resolve_omp_clauses): Permit derived type variables in ACC UPDATE clauses. * trans-openmp.c (gfc_trans_omp_clauses_1): Lower derived type members. gcc/ * gimplify.c (gimplify_scan_omp_clauses): Update handling of ACC UPDATE variables. gcc/testsuite/ * gfortran.dg/goacc/derived-types.f90: New test. libgomp/ * testsuite/libgomp.oacc-fortran/update-2.f90: New test. * testsuite/libgomp.oacc-fortran/derived-type-1.f90: New test. commit a7e1f0958d38bfda7474fbaf6bb31951351ab66d Author: Julian Brown Date: Thu Aug 30 17:00:58 2018 -0700 Derived types for acc update. 2018-09-03 Cesar Philippidis gcc/fortran/ * openmp.c (gfc_match_omp_variable_list): New allow_derived argument. (gfc_match_omp_map_clause): Update call to gfc_match_omp_variable_list. (gfc_match_omp_clauses): Update calls to gfc_match_omp_map_clause. (gfc_match_oacc_update): Update call to gfc_match_omp_clauses. (resolve_omp_clauses): Permit derived type variables in ACC UPDATE clauses. * trans-openmp.c (gfc_trans_omp_clauses_1): Lower derived type members. gcc/ * gimplify.c (gimplify_scan_omp_clauses): Update handling of ACC UPDATE variables. gcc/testsuite/ * gfortran.dg/goacc/derived-types.f90: New test. libgomp/ * testsuite/libgomp.oacc-fortran/update-2.f90: New test. * testsuite/libgomp.oacc-fortran/derived-type-1.f90: New test. diff --git a/gcc/fortran/openmp.c b/gcc/fortran/openmp.c index 94a7f7e..80a4c05 100644 --- a/gcc/fortran/openmp.c +++ b/gcc/fortran/openmp.c @@ -222,7 +222,8 @@ static match gfc_match_omp_variable_list (const char *str, gfc_omp_namelist **list, bool allow_common, bool *end_colon = NULL, gfc_omp_namelist ***headp = NULL, - bool allow_sections = false) + bool allow_sections = false, + bool allow_derived = false) { gfc_omp_namelist *head, *tail, *p; locus old_loc, cur_loc; @@ -248,7 +249,8 @@ gfc_match_omp_variable_list (const char *str, gfc_omp_namelist **list, case MATCH_YES: gfc_expr *expr; expr = NULL; - if (allow_sections && gfc_peek_ascii_char () == '(') + if ((allow_sections && gfc_peek_ascii_char () == '(') + || (allow_derived && gfc_peek_ascii_char () == '%')) { gfc_current_locus = cur_loc; m = gfc_match_variable (&expr, 0); @@ -914,10 +916,12 @@ omp_inv_mask::omp_inv_mask (const omp_mask &m) : omp_mask (m) mapping. */ static bool -gfc_match_omp_map_clause (gfc_omp_namelist **list, gfc_omp_map_op map_op) +gfc_match_omp_map_clause (gfc_omp_namelist **list, gfc_omp_map_op map_op, + bool allow_derived) { gfc_omp_namelist **head = NULL; - if (gfc_match_omp_variable_list ("", list, false, NULL, &head, true) + if (gfc_match_omp_variable_list ("", list, false, NULL, &head, true, + allow_derived) == MATCH_YES) { gfc_omp_namelist *n; @@ -935,7 +939,7 @@ gfc_match_omp_map_clause (gfc_omp_namelist **list, gfc_omp_map_op map_op) 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 openacc = false, bool allow_derived = false) { gfc_omp_clauses *c = gfc_get_omp_clauses (); locus old_loc; @@ -1039,7 +1043,7 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, if ((mask & OMP_CLAUSE_COPY) && gfc_match ("copy ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_TOFROM)) + OMP_MAP_TOFROM, allow_derived)) continue; if (mask & OMP_CLAUSE_COPYIN) { @@ -1047,7 +1051,7 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, { if (gfc_match ("copyin ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_TO)) + OMP_MAP_TO, allow_derived)) continue; } else if (gfc_match_omp_variable_list ("copyin (", @@ -1058,7 +1062,7 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, if ((mask & OMP_CLAUSE_COPYOUT) && gfc_match ("copyout ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_FROM)) + OMP_MAP_FROM, allow_derived)) continue; if ((mask & OMP_CLAUSE_COPYPRIVATE) && gfc_match_omp_variable_list ("copyprivate (", @@ -1068,7 +1072,7 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, if ((mask & OMP_CLAUSE_CREATE) && gfc_match ("create ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_ALLOC)) + OMP_MAP_ALLOC, allow_derived)) continue; break; case 'd': @@ -1104,7 +1108,7 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, if ((mask & OMP_CLAUSE_DELETE) && gfc_match ("delete ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_RELEASE)) + OMP_MAP_RELEASE, allow_derived)) continue; if ((mask & OMP_CLAUSE_DEPEND) && gfc_match ("depend ( ") == MATCH_YES) @@ -1156,12 +1160,13 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, && openacc && gfc_match ("device ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_FORCE_TO)) + OMP_MAP_FORCE_TO, allow_derived)) continue; if ((mask & OMP_CLAUSE_DEVICEPTR) && gfc_match ("deviceptr ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_FORCE_DEVICEPTR)) + OMP_MAP_FORCE_DEVICEPTR, + allow_derived)) continue; if ((mask & OMP_CLAUSE_DEVICE_RESIDENT) && gfc_match_omp_variable_list @@ -1239,7 +1244,7 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, if ((mask & OMP_CLAUSE_HOST_SELF) && gfc_match ("host ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_FORCE_FROM)) + OMP_MAP_FORCE_FROM, allow_derived)) continue; break; case 'i': @@ -1511,47 +1516,48 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, if ((mask & OMP_CLAUSE_COPY) && gfc_match ("pcopy ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_TOFROM)) + OMP_MAP_TOFROM, allow_derived)) continue; if ((mask & OMP_CLAUSE_COPYIN) && gfc_match ("pcopyin ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_TO)) + OMP_MAP_TO, allow_derived)) continue; if ((mask & OMP_CLAUSE_COPYOUT) && gfc_match ("pcopyout ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_FROM)) + OMP_MAP_FROM, allow_derived)) continue; if ((mask & OMP_CLAUSE_CREATE) && gfc_match ("pcreate ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_ALLOC)) + OMP_MAP_ALLOC, allow_derived)) continue; if ((mask & OMP_CLAUSE_PRESENT) && gfc_match ("present ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_FORCE_PRESENT)) + OMP_MAP_FORCE_PRESENT, + allow_derived)) continue; if ((mask & OMP_CLAUSE_COPY) && gfc_match ("present_or_copy ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_TOFROM)) + OMP_MAP_TOFROM, allow_derived)) continue; if ((mask & OMP_CLAUSE_COPYIN) && gfc_match ("present_or_copyin ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_TO)) + OMP_MAP_TO, allow_derived)) continue; if ((mask & OMP_CLAUSE_COPYOUT) && gfc_match ("present_or_copyout ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_FROM)) + OMP_MAP_FROM, allow_derived)) continue; if ((mask & OMP_CLAUSE_CREATE) && gfc_match ("present_or_create ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_ALLOC)) + OMP_MAP_ALLOC, allow_derived)) continue; if ((mask & OMP_CLAUSE_PRIORITY) && c->priority == NULL @@ -1774,7 +1780,7 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, if ((mask & OMP_CLAUSE_HOST_SELF) && gfc_match ("self ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_FORCE_FROM)) + OMP_MAP_FORCE_FROM, allow_derived)) continue; if ((mask & OMP_CLAUSE_SEQ) && !c->seq @@ -2130,7 +2136,7 @@ gfc_match_oacc_update (void) gfc_omp_clauses *c; locus here = gfc_current_locus; - if (gfc_match_omp_clauses (&c, OACC_UPDATE_CLAUSES, false, false, true) + if (gfc_match_omp_clauses (&c, OACC_UPDATE_CLAUSES, false, false, true, true) != MATCH_YES) return MATCH_ERROR; @@ -4336,9 +4342,12 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, || n->expr->ref == NULL || n->expr->ref->next || n->expr->ref->type != REF_ARRAY) - gfc_error ("%qs in %s clause at %L is not a proper " - "array section", n->sym->name, name, - &n->where); + { + if (n->sym->ts.type != BT_DERIVED) + gfc_error ("%qs in %s clause at %L is not a proper " + "array section", n->sym->name, name, + &n->where); + } else if (n->expr->ref->u.ar.codimen) gfc_error ("Coarrays not supported in %s clause at %L", name, &n->where); diff --git a/gcc/fortran/trans-openmp.c b/gcc/fortran/trans-openmp.c index f038f4c..95b15e5 100644 --- a/gcc/fortran/trans-openmp.c +++ b/gcc/fortran/trans-openmp.c @@ -2108,7 +2108,68 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, tree decl = gfc_get_symbol_decl (n->sym); if (DECL_P (decl)) TREE_ADDRESSABLE (decl) = 1; - if (n->expr == NULL || n->expr->ref->u.ar.type == AR_FULL) + /* Handle derived-typed members for OpenACC Update. */ + if (n->sym->ts.type == BT_DERIVED + && n->expr != NULL && n->expr->ref != NULL + && (n->expr->ref->next == NULL + || (n->expr->ref->next != NULL + && n->expr->ref->next->type == REF_ARRAY + && n->expr->ref->next->u.ar.type == AR_FULL)) + && (n->expr->ref->type == REF_ARRAY + && n->expr->ref->u.ar.type != AR_SECTION)) + { + gfc_ref *ref = n->expr->ref; + gfc_component *c = ref->u.c.component; + tree field; + tree context; + tree ptr; + tree type; + tree scratch; + + if (c->backend_decl == NULL_TREE + && ref->u.c.sym != NULL) + gfc_get_derived_type (ref->u.c.sym); + + field = c->backend_decl; + gcc_assert (field && TREE_CODE (field) == FIELD_DECL); + context = DECL_FIELD_CONTEXT (field); + + type = TREE_TYPE (decl); + if (POINTER_TYPE_P (type)) + type = TREE_TYPE (type); + + if (context != type) + { + tree f2 = c->norestrict_decl; + if (!f2 || DECL_FIELD_CONTEXT (f2) != type) + for (f2 = TYPE_FIELDS (TREE_TYPE (decl)); f2; + f2 = DECL_CHAIN (f2)) + if (TREE_CODE (f2) == FIELD_DECL + && DECL_NAME (f2) == DECL_NAME (field)) + break; + gcc_assert (f2); + c->norestrict_decl = f2; + field = f2; + } + + if (POINTER_TYPE_P (TREE_TYPE (decl))) + decl = build_fold_indirect_ref_loc (input_location, + decl); + + scratch = fold_build3_loc (input_location, COMPONENT_REF, + TREE_TYPE (field), decl, field, + NULL_TREE); + type = TREE_TYPE (scratch); + ptr = gfc_create_var (pvoid_type_node, NULL); + scratch = fold_convert (pvoid_type_node, + build_fold_addr_expr (scratch)); + gfc_add_modify (block, ptr, scratch); + OMP_CLAUSE_SIZE (node) = TYPE_SIZE_UNIT (type); + OMP_CLAUSE_DECL (node) = build_fold_indirect_ref (ptr); + } + else if ((n->sym->ts.type == BT_DERIVED && n->expr == NULL) + || (n->expr == NULL + || n->expr->ref->u.ar.type == AR_FULL)) { if (POINTER_TYPE_P (TREE_TYPE (decl)) && (gfc_omp_privatize_by_reference (decl) @@ -2210,13 +2271,27 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, { tree ptr, ptr2; gfc_init_se (&se, NULL); - if (n->expr->ref->u.ar.type == AR_ELEMENT) + if ((n->sym->ts.type == BT_DERIVED + && n->expr->rank == 0) + || (n->sym->ts.type != BT_DERIVED + && n->expr->ref->u.ar.type == AR_ELEMENT)) { gfc_conv_expr_reference (&se, n->expr); gfc_add_block_to_block (block, &se.pre); ptr = se.expr; + tree type = TREE_TYPE (ptr); + if (n->sym->ts.type == BT_DERIVED) + { + tree t = gfc_create_var (build_pointer_type + (void_type_node), + NULL); + ptr = fold_convert (pvoid_type_node, ptr); + gfc_add_modify (block, t, ptr); + ptr = t; + type = TREE_TYPE (type); + } OMP_CLAUSE_SIZE (node) - = TYPE_SIZE_UNIT (TREE_TYPE (ptr)); + = TYPE_SIZE_UNIT (type); } else { @@ -2239,6 +2314,8 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, ptr); OMP_CLAUSE_DECL (node) = build_fold_indirect_ref (ptr); + if (n->sym->ts.type == BT_DERIVED) + goto finalize_map_clause; if (POINTER_TYPE_P (TREE_TYPE (decl)) && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (decl)))) { @@ -2282,6 +2359,7 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, ptr2 = fold_convert (sizetype, ptr2); OMP_CLAUSE_SIZE (node3) = fold_build2 (MINUS_EXPR, sizetype, ptr, ptr2); + finalize_map_clause:; } switch (n->u.map_op) { diff --git a/gcc/gimplify.c b/gcc/gimplify.c index dbd0f0e..f7f7f52 100644 --- a/gcc/gimplify.c +++ b/gcc/gimplify.c @@ -7955,7 +7955,8 @@ 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); - if (n == NULL || (n->value & GOVD_MAP) == 0) + if ((n == NULL || (n->value & GOVD_MAP) == 0) + && code != OACC_UPDATE) { tree l = build_omp_clause (OMP_CLAUSE_LOCATION (c), OMP_CLAUSE_MAP); diff --git a/gcc/testsuite/gfortran.dg/goacc/derived-types.f90 b/gcc/testsuite/gfortran.dg/goacc/derived-types.f90 new file mode 100644 index 0000000..44a3814 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/goacc/derived-types.f90 @@ -0,0 +1,77 @@ +! Test ACC UPDATE with derived types. + +module dt + integer, parameter :: n = 10 + type inner + integer :: d(n) + end type inner + type dtype + integer(8) :: a, b, c(n) + type(inner) :: in + end type dtype +end module dt + +program derived_acc + use dt + + implicit none + type(dtype):: var + integer i + !$acc declare create(var) + !$acc declare pcopy(var%a) ! { dg-error "Syntax error in OpenMP" } + + !$acc update host(var) + !$acc update host(var%a) + !$acc update device(var) + !$acc update device(var%a) + !$acc update self(var) + !$acc update self(var%a) + + !$acc enter data copyin(var) + !$acc enter data copyin(var%a) ! { dg-error "Syntax error in OpenMP" } + + !$acc exit data copyout(var) + !$acc exit data copyout(var%a) ! { dg-error "Syntax error in OpenMP" } + + !$acc data copy(var) + !$acc end data + + !$acc data copyout(var%a) ! { dg-error "Syntax error in OpenMP" } + !$acc end data ! { dg-error "Unexpected ..ACC END" } + + !$acc parallel loop pcopyout(var) + do i = 1, 10 + end do + !$acc end parallel loop + + !$acc parallel loop copyout(var%a) ! { dg-error "Syntax error in OpenMP" } + do i = 1, 10 + end do + !$acc end parallel loop ! { dg-error "Unexpected ..ACC END" } + + !$acc parallel pcopy(var) + !$acc end parallel + + !$acc parallel pcopy(var%a) ! { dg-error "Syntax error in OpenMP" } + do i = 1, 10 + end do + !$acc end parallel ! { dg-error "Unexpected ..ACC END" } + + !$acc kernels pcopyin(var) + !$acc end kernels + + !$acc kernels pcopy(var%a) ! { dg-error "Syntax error in OpenMP" } + do i = 1, 10 + end do + !$acc end kernels ! { dg-error "Unexpected ..ACC END" } + + !$acc kernels loop pcopyin(var) + do i = 1, 10 + end do + !$acc end kernels loop + + !$acc kernels loop pcopy(var%a) ! { dg-error "Syntax error in OpenMP" } + do i = 1, 10 + end do + !$acc end kernels loop ! { dg-error "Unexpected ..ACC END" } +end program derived_acc diff --git a/libgomp/testsuite/libgomp.oacc-fortran/derived-type-1.f90 b/libgomp/testsuite/libgomp.oacc-fortran/derived-type-1.f90 new file mode 100644 index 0000000..1ec4784 --- /dev/null +++ b/libgomp/testsuite/libgomp.oacc-fortran/derived-type-1.f90 @@ -0,0 +1,28 @@ +! Test derived types with subarrays + +! { dg-do run } + + implicit none + type dtype + integer :: a, b, c + end type dtype + integer, parameter :: n = 100 + integer i + type (dtype), dimension(n) :: d + + !$acc data copy(d(1:n)) + !$acc parallel loop + do i = 1, n + d(i)%a = i + d(i)%b = i-1 + d(i)%c = i+1 + end do + !$acc end data + + do i = 1, n + if (d(i)%a /= i) call abort + if (d(i)%b /= i-1) call abort + if (d(i)%c /= i+1) call abort + end do +end program + diff --git a/libgomp/testsuite/libgomp.oacc-fortran/update-2.f90 b/libgomp/testsuite/libgomp.oacc-fortran/update-2.f90 new file mode 100644 index 0000000..a37d526 --- /dev/null +++ b/libgomp/testsuite/libgomp.oacc-fortran/update-2.f90 @@ -0,0 +1,284 @@ +! Test ACC UPDATE with derived types. + +! { dg-do run } + +module dt + integer, parameter :: n = 10 + type inner + integer :: d(n) + end type inner + type mytype + integer(8) :: a, b, c(n) + type(inner) :: in + end type mytype +end module dt + +program derived_acc + use dt + + implicit none + integer i, res + type(mytype) :: var + + var%a = 0 + var%b = 1 + var%c(:) = 10 + var%in%d(:) = 100 + + var%c(:) = 10 + + !$acc enter data copyin(var) + + !$acc parallel loop present(var) + do i = 1, 1 + var%a = var%b + end do + !$acc end parallel loop + + !$acc update host(var%a) + + if (var%a /= var%b) call abort + + var%b = 100 + + !$acc update device(var%b) + + !$acc parallel loop present(var) + do i = 1, 1 + var%a = var%b + end do + !$acc end parallel loop + + !$acc update host(var%a) + + if (var%a /= var%b) call abort + + !$acc parallel loop present (var) + do i = 1, n + var%c(i) = i + end do + !$acc end parallel loop + + !$acc update host(var%c) + + var%a = -1 + + do i = 1, n + if (var%c(i) /= i) call abort + var%c(i) = var%a + end do + + !$acc update device(var%a) + !$acc update device(var%c) + + res = 0 + + !$acc parallel loop present(var) reduction(+:res) + do i = 1, n + if (var%c(i) /= var%a) res = res + 1 + end do + + if (res /= 0) call abort + + var%c(:) = 0 + + !$acc update device(var%c) + + !$acc parallel loop present(var) + do i = 5, 5 + var%c(i) = 1 + end do + !$acc end parallel loop + + !$acc update host(var%c(5)) + + do i = 1, n + if (i /= 5 .and. var%c(i) /= 0) call abort + if (i == 5 .and. var%c(i) /= 1) call abort + end do + + !$acc parallel loop present(var) + do i = 1, n + var%in%d = var%a + end do + !$acc end parallel loop + + !$acc update host(var%in%d) + + do i = 1, n + if (var%in%d(i) /= var%a) call abort + end do + + var%c(:) = 0 + + !$acc update device(var%c) + + var%c(:) = -1 + + !$acc parallel loop present(var) + do i = n/2, n + var%c(i) = i + end do + !$acc end parallel loop + + !$acc update host(var%c(n/2:n)) + + do i = 1,n + if (i < n/2 .and. var%c(i) /= -1) call abort + if (i >= n/2 .and. var%c(i) /= i) call abort + end do + + var%in%d(:) = 0 + !$acc update device(var%in%d) + + !$acc parallel loop present(var) + do i = 5, 5 + var%in%d(i) = 1 + end do + !$acc end parallel loop + + !$acc update host(var%in%d(5)) + + do i = 1, n + if (i /= 5 .and. var%in%d(i) /= 0) call abort + if (i == 5 .and. var%in%d(i) /= 1) call abort + end do + + !$acc exit data delete(var) + + call derived_acc_subroutine(var) +end program derived_acc + +subroutine derived_acc_subroutine(var) + use dt + + implicit none + integer i, res + type(mytype) :: var + + var%a = 0 + var%b = 1 + var%c(:) = 10 + var%in%d(:) = 100 + + var%c(:) = 10 + + !$acc enter data copyin(var) + + !$acc parallel loop present(var) + do i = 1, 1 + var%a = var%b + end do + !$acc end parallel loop + + !$acc update host(var%a) + + if (var%a /= var%b) call abort + + var%b = 100 + + !$acc update device(var%b) + + !$acc parallel loop present(var) + do i = 1, 1 + var%a = var%b + end do + !$acc end parallel loop + + !$acc update host(var%a) + + if (var%a /= var%b) call abort + + !$acc parallel loop present (var) + do i = 1, n + var%c(i) = i + end do + !$acc end parallel loop + + !$acc update host(var%c) + + var%a = -1 + + do i = 1, n + if (var%c(i) /= i) call abort + var%c(i) = var%a + end do + + !$acc update device(var%a) + !$acc update device(var%c) + + res = 0 + + !$acc parallel loop present(var) reduction(+:res) + do i = 1, n + if (var%c(i) /= var%a) res = res + 1 + end do + + if (res /= 0) call abort + + var%c(:) = 0 + + !$acc update device(var%c) + + !$acc parallel loop present(var) + do i = 5, 5 + var%c(i) = 1 + end do + !$acc end parallel loop + + !$acc update host(var%c(5)) + + do i = 1, n + if (i /= 5 .and. var%c(i) /= 0) call abort + if (i == 5 .and. var%c(i) /= 1) call abort + end do + + !$acc parallel loop present(var) + do i = 1, n + var%in%d = var%a + end do + !$acc end parallel loop + + !$acc update host(var%in%d) + + do i = 1, n + if (var%in%d(i) /= var%a) call abort + end do + + var%c(:) = 0 + + !$acc update device(var%c) + + var%c(:) = -1 + + !$acc parallel loop present(var) + do i = n/2, n + var%c(i) = i + end do + !$acc end parallel loop + + !$acc update host(var%c(n/2:n)) + + do i = 1,n + if (i < n/2 .and. var%c(i) /= -1) call abort + if (i >= n/2 .and. var%c(i) /= i) call abort + end do + + var%in%d(:) = 0 + !$acc update device(var%in%d) + + !$acc parallel loop present(var) + do i = 5, 5 + var%in%d(i) = 1 + end do + !$acc end parallel loop + + !$acc update host(var%in%d(5)) + + do i = 1, n + if (i /= 5 .and. var%in%d(i) /= 0) call abort + if (i == 5 .and. var%in%d(i) /= 1) call abort + end do + + !$acc exit data delete(var) +end subroutine derived_acc_subroutine