From patchwork Thu Nov 10 17:38:33 2016 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Cesar Philippidis X-Patchwork-Id: 81720 Delivered-To: patch@linaro.org Received: by 10.140.97.165 with SMTP id m34csp849389qge; Thu, 10 Nov 2016 09:39:20 -0800 (PST) X-Received: by 10.98.206.207 with SMTP id y198mr12089598pfg.70.1478799560105; Thu, 10 Nov 2016 09:39:20 -0800 (PST) Return-Path: Received: from sourceware.org (server1.sourceware.org. [209.132.180.131]) by mx.google.com with ESMTPS id p73si6055471pfl.79.2016.11.10.09.39.19 for (version=TLS1_2 cipher=ECDHE-RSA-AES128-GCM-SHA256 bits=128/128); Thu, 10 Nov 2016 09:39:20 -0800 (PST) Received-SPF: pass (google.com: domain of gcc-patches-return-441002-patch=linaro.org@gcc.gnu.org designates 209.132.180.131 as permitted sender) client-ip=209.132.180.131; Authentication-Results: mx.google.com; dkim=pass header.i=@gcc.gnu.org; spf=pass (google.com: domain of gcc-patches-return-441002-patch=linaro.org@gcc.gnu.org designates 209.132.180.131 as permitted sender) smtp.mailfrom=gcc-patches-return-441002-patch=linaro.org@gcc.gnu.org DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:from :subject:to:message-id:date:mime-version:content-type; q=dns; s= default; b=BdDBnyLTZnwuc1cHd8/QEulIIbhuKzfRFxEryIZOeHPmOtol/5eJD J9TIK/iQ3xGa6BjGNkutkVM7Lttx/fziodcBUOPff1HqF+J1LICrqV8a35NtyXmb UtsebIsSwa8cFhnPosTwr3g4T1ioGshokvIYm0AfKCjL+U6HtpyACg= 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:from :subject:to:message-id:date:mime-version:content-type; s= default; bh=hRVWVwiBtn8y8OChK72ROiRu8j8=; b=XyLoiFuH1PvGE9/xsHaq KHVLvKIxoZUina9uDpmwb1RldJS6TTV+qMvzD1rGmGgN3brNv+px12Z7uGMUARs2 IvJ8bufqGiYOB1vqVEkj7xIBO3qNSjihEP/yxxDVx3mmYp9NPSBUzm0YivtTI1lI JA1n45ftXxwjKPpFoQkkt3g= Received: (qmail 84961 invoked by alias); 10 Nov 2016 17:38:50 -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 84825 invoked by uid 89); 10 Nov 2016 17:38:49 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=-1.9 required=5.0 tests=AWL, BAYES_00, RCVD_IN_DNSWL_NONE, SPF_PASS, URIBL_RED autolearn=ham version=3.3.2 spammy=acc, goacc, 20a, !$acc X-Spam-User: qpsmtpd, 2 recipients 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; Thu, 10 Nov 2016 17:38:38 +0000 Received: from svr-orw-mbx-01.mgc.mentorg.com ([147.34.90.201]) by relay1.mentorg.com with esmtp id 1c4tJ7-0007We-BG from Cesar_Philippidis@mentor.com ; Thu, 10 Nov 2016 09:38:37 -0800 Received: from [127.0.0.1] (147.34.91.1) by svr-orw-mbx-01.mgc.mentorg.com (147.34.90.201) with Microsoft SMTP Server (TLS) id 15.0.1210.3; Thu, 10 Nov 2016 09:38:34 -0800 From: Cesar Philippidis Subject: [gomp4] add support for derived types in ACC UPDATE To: "gcc-patches@gcc.gnu.org" , Fortran List Message-ID: <4b5d0f5c-f6a5-225e-595c-4a029cc46ff6@codesourcery.com> Date: Thu, 10 Nov 2016 09:38:33 -0800 User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:45.0) Gecko/20100101 Thunderbird/45.3.0 MIME-Version: 1.0 X-ClientProxiedBy: svr-orw-mbx-01.mgc.mentorg.com (147.34.90.201) To svr-orw-mbx-01.mgc.mentorg.com (147.34.90.201) OpenACC 2.0a has limited support for fortran derived types. Basically, derived type variables are only supported in ACC UPDATE. Rather than adding generalized support for derived times in the gimplifier, this patch has the fortran FE pass both subarrays and arrays as void pointers with an appropriate OMP_CLAUSE_SIZE. ACC UPDATE is an executable directive, and the gimplifier would just end up pruning out all of the unnecessary supporting data clauses otherwise. As of right now, GCC still lacks support for non-contiguous subarray arguments to ACC UPDATE. I'm not sure why it was decided to let ACC UPDATE support non-contiguous subarrays, but it already is an oddball with its lone support for derived types. This patch has been committed to gomp-4_0-branch. Cesar 2016-11-10 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. diff --git a/gcc/fortran/openmp.c b/gcc/fortran/openmp.c index 95885bc..0a9d137 100644 --- a/gcc/fortran/openmp.c +++ b/gcc/fortran/openmp.c @@ -216,7 +216,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; @@ -242,7 +243,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); @@ -634,10 +636,11 @@ cleanup: static bool gfc_match_omp_map_clause (gfc_omp_namelist **list, gfc_omp_map_op map_op, - bool common_blocks) + bool common_blocks, bool allow_derived) { gfc_omp_namelist **head = NULL; - if (gfc_match_omp_variable_list ("", list, common_blocks, NULL, &head, true) + if (gfc_match_omp_variable_list ("", list, common_blocks, NULL, &head, true, + allow_derived) == MATCH_YES) { gfc_omp_namelist *n; @@ -655,7 +658,8 @@ 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, uint64_t mask, uint64_t dtype_mask, bool first = true, - bool needs_space = true, bool openacc = false) + bool needs_space = true, bool openacc = false, + bool allow_derived = false) { gfc_omp_clauses *base_clauses, *c = gfc_get_omp_clauses (); locus old_loc; @@ -773,7 +777,8 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, uint64_t mask, if ((mask & OMP_CLAUSE_COPY) && gfc_match ("copy ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_FORCE_TOFROM, openacc)) + OMP_MAP_FORCE_TOFROM, openacc, + allow_derived)) continue; if (mask & OMP_CLAUSE_COPYIN) { @@ -781,7 +786,8 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, uint64_t mask, { if (gfc_match ("copyin ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_FORCE_TO, true)) + OMP_MAP_FORCE_TO, true, + allow_derived)) continue; } else if (gfc_match_omp_variable_list ("copyin (", @@ -792,7 +798,8 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, uint64_t mask, if ((mask & OMP_CLAUSE_COPYOUT) && gfc_match ("copyout ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_FORCE_FROM, true)) + OMP_MAP_FORCE_FROM, true, + allow_derived)) continue; if ((mask & OMP_CLAUSE_COPYPRIVATE) && gfc_match_omp_variable_list ("copyprivate (", @@ -802,14 +809,15 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, uint64_t mask, if ((mask & OMP_CLAUSE_CREATE) && gfc_match ("create ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_FORCE_ALLOC, true)) + OMP_MAP_FORCE_ALLOC, true, + allow_derived)) continue; break; case 'd': if ((mask & OMP_CLAUSE_DELETE) && gfc_match ("delete ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_DELETE, true)) + OMP_MAP_DELETE, true, allow_derived)) continue; if ((mask & OMP_CLAUSE_DEFAULT) && c->default_sharing == OMP_DEFAULT_UNKNOWN) @@ -862,12 +870,14 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, uint64_t mask, if ((mask & OMP_CLAUSE_OACC_DEVICE) && gfc_match ("device ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_FORCE_TO, false)) + OMP_MAP_FORCE_TO, false, + 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, false)) + OMP_MAP_FORCE_DEVICEPTR, false, + allow_derived)) continue; if ((mask & OMP_CLAUSE_DEVICE_RESIDENT) && gfc_match_omp_variable_list @@ -991,7 +1001,8 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, uint64_t mask, && gfc_match ("host ( ") == MATCH_YES /* "self" is a synonym for "host". */ && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_FORCE_FROM, true)) + OMP_MAP_FORCE_FROM, true, + allow_derived)) continue; break; case 'i': @@ -1136,47 +1147,48 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, uint64_t mask, if ((mask & OMP_CLAUSE_PRESENT_OR_COPY) && gfc_match ("pcopy ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_TOFROM, true)) + OMP_MAP_TOFROM, true, allow_derived)) continue; if ((mask & OMP_CLAUSE_PRESENT_OR_COPYIN) && gfc_match ("pcopyin ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_TO, true)) + OMP_MAP_TO, true, allow_derived)) continue; if ((mask & OMP_CLAUSE_PRESENT_OR_COPYOUT) && gfc_match ("pcopyout ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_FROM, true)) + OMP_MAP_FROM, true, allow_derived)) continue; if ((mask & OMP_CLAUSE_PRESENT_OR_CREATE) && gfc_match ("pcreate ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_ALLOC, true)) + OMP_MAP_ALLOC, true, 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, false)) + OMP_MAP_FORCE_PRESENT, false, + allow_derived)) continue; if ((mask & OMP_CLAUSE_PRESENT_OR_COPY) && gfc_match ("present_or_copy ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_TOFROM, true)) + OMP_MAP_TOFROM, true, allow_derived)) continue; if ((mask & OMP_CLAUSE_PRESENT_OR_COPYIN) && gfc_match ("present_or_copyin ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_TO, true)) + OMP_MAP_TO, true, allow_derived)) continue; if ((mask & OMP_CLAUSE_PRESENT_OR_COPYOUT) && gfc_match ("present_or_copyout ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_FROM, true)) + OMP_MAP_FROM, true, allow_derived)) continue; if ((mask & OMP_CLAUSE_PRESENT_OR_CREATE) && gfc_match ("present_or_create ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_ALLOC, true)) + OMP_MAP_ALLOC, true, allow_derived)) continue; if ((mask & OMP_CLAUSE_PRIVATE) && gfc_match_omp_variable_list ("private (", @@ -1356,7 +1368,8 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, uint64_t mask, if ((mask & OMP_CLAUSE_HOST) && gfc_match ("self ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_FORCE_FROM, true)) + OMP_MAP_FORCE_FROM, true, + allow_derived)) continue; if ((mask & OMP_CLAUSE_SEQ) && !c->seq @@ -1758,7 +1771,7 @@ gfc_match_oacc_update (void) if (gfc_match_omp_clauses (&c, OACC_UPDATE_CLAUSES, OACC_UPDATE_CLAUSE_DEVICE_TYPE_MASK, false, - false, true) + false, true, true) != MATCH_YES) return MATCH_ERROR; @@ -3739,9 +3752,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 f374451..9924872 100644 --- a/gcc/fortran/trans-openmp.c +++ b/gcc/fortran/trans-openmp.c @@ -1938,7 +1938,66 @@ gfc_trans_omp_clauses_1 (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))) + { + gfc_ref *ref = n->expr->ref; + tree orig_decl = decl; + 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 (build_pointer_type (void_type_node), + NULL); + gfc_add_modify (block, ptr, build_fold_addr_expr (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) @@ -2038,13 +2097,26 @@ gfc_trans_omp_clauses_1 (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); + 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 { @@ -2065,6 +2137,8 @@ gfc_trans_omp_clauses_1 (stmtblock_t *block, gfc_omp_clauses *clauses, gfc_add_block_to_block (block, &se.post); 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)))) { @@ -2108,6 +2182,7 @@ gfc_trans_omp_clauses_1 (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 2c25a2e..36c128b 100644 --- a/gcc/gimplify.c +++ b/gcc/gimplify.c @@ -7049,7 +7049,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..7f1a821 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/goacc/derived-types.f90 @@ -0,0 +1,78 @@ +! Test ACC UPDATE with derived types. The DEVICE clause depends on an +! accelerator being present. + +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/update-2.f90 b/libgomp/testsuite/libgomp.oacc-fortran/update-2.f90 new file mode 100644 index 0000000..769ef6b --- /dev/null +++ b/libgomp/testsuite/libgomp.oacc-fortran/update-2.f90 @@ -0,0 +1,285 @@ +! Test ACC UPDATE with derived types. The DEVICE clause depends on an +! accelerator being present. + +! { dg-do run { target openacc_nvidia_accel_selected } } + +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