From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: (qmail 78024 invoked by alias); 5 May 2015 08:59:00 -0000 Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Received: (qmail 78002 invoked by uid 89); 5 May 2015 08:58:59 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=-0.9 required=5.0 tests=AWL,BAYES_50,RCVD_IN_DNSWL_LOW,SPF_PASS,T_FROM_12LTRDOM autolearn=ham version=3.3.2 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; Tue, 05 May 2015 08:58:53 +0000 Received: from nat-ies.mentorg.com ([192.94.31.2] helo=SVR-IES-FEM-01.mgc.mentorg.com) by relay1.mentorg.com with esmtp id 1YpYgj-0004ht-6C from Thomas_Schwinge@mentor.com ; Tue, 05 May 2015 01:58:50 -0700 Received: from feldtkeller.schwinge.homeip.net (137.202.0.76) by SVR-IES-FEM-01.mgc.mentorg.com (137.202.0.104) with Microsoft SMTP Server id 14.3.224.2; Tue, 5 May 2015 09:58:46 +0100 From: Thomas Schwinge To: , Jakub Jelinek , CC: Bernd Schmidt , Cesar Philippidis , Chung-Lin Tang , James Norris , Joseph Myers , Julian Brown , Tom de Vries Subject: Next set of OpenACC changes: Fortran In-Reply-To: <87sibbpfpx.fsf@schwinge.name> References: <87sibbpfpx.fsf@schwinge.name> User-Agent: Notmuch/0.9-101-g81dad07 (http://notmuchmail.org) Emacs/24.3.1 (x86_64-pc-linux-gnu) Date: Tue, 05 May 2015 08:59:00 -0000 Message-ID: <87h9rrpfi5.fsf@schwinge.name> MIME-Version: 1.0 Content-Type: multipart/signed; boundary="=-=-="; micalg=pgp-sha1; protocol="application/pgp-signature" X-SW-Source: 2015-05/txt/msg00290.txt.bz2 --=-=-= Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: quoted-printable Content-length: 53194 Hi! On Tue, 05 May 2015 10:54:02 +0200, I wrote: > In follow-up messages, I'll be posting the separated parts (for easier > review) of a next set of OpenACC changes that we'd like to commit. > ChangeLog updates not yet written; will do that before commit, obviously. gcc/fortran/dump-parse-tree.c | 12 +- gcc/fortran/gfortran.h | 50 +- gcc/fortran/match.h | 1 + gcc/fortran/openmp.c | 581 +++++-- gcc/fortran/parse.c | 65 +- gcc/fortran/parse.h | 2 +- gcc/fortran/resolve.c | 5 + gcc/fortran/st.c | 7 + gcc/fortran/trans-decl.c | 62 +- gcc/fortran/trans-openmp.c | 66 +- gcc/fortran/trans-stmt.c | 7 +- gcc/fortran/trans-stmt.h | 2 +- gcc/fortran/trans.c | 2 + diff --git gcc/fortran/dump-parse-tree.c gcc/fortran/dump-parse-tree.c index 83ecbaa..48476af 100644 --- gcc/fortran/dump-parse-tree.c +++ gcc/fortran/dump-parse-tree.c @@ -2570,12 +2570,16 @@ show_namespace (gfc_namespace *ns) for (eq =3D ns->equiv; eq; eq =3D eq->next) show_equiv (eq); =20 - if (ns->oacc_declare_clauses) + if (ns->oacc_declare) { + struct gfc_oacc_declare *decl; /* Dump !$ACC DECLARE clauses. */ - show_indent (); - fprintf (dumpfile, "!$ACC DECLARE"); - show_omp_clauses (ns->oacc_declare_clauses); + for (decl =3D ns->oacc_declare; decl; decl =3D decl->next) + { + show_indent (); + fprintf (dumpfile, "!$ACC DECLARE"); + show_omp_clauses (decl->clauses); + } } =20 fputc ('\n', dumpfile); diff --git gcc/fortran/gfortran.h gcc/fortran/gfortran.h index 832a6ce..9258786 100644 --- gcc/fortran/gfortran.h +++ gcc/fortran/gfortran.h @@ -222,6 +222,7 @@ typedef enum ST_OACC_END_LOOP, ST_OACC_DECLARE, ST_OACC_UPDATE, ST_OACC_WAIT, ST_OACC_CACHE, ST_OACC_KERNELS_LOOP, ST_OACC_END_KERNELS_LOOP, ST_OACC_ENTER_DATA, ST_OACC_EXIT_DATA, ST_OACC_ROUTINE, + ST_OACC_ATOMIC, ST_OACC_END_ATOMIC, ST_OMP_ATOMIC, ST_OMP_BARRIER, ST_OMP_CRITICAL, ST_OMP_END_ATOMIC, ST_OMP_END_CRITICAL, ST_OMP_END_DO, ST_OMP_END_MASTER, ST_OMP_END_ORDERE= D, ST_OMP_END_PARALLEL, ST_OMP_END_PARALLEL_DO, ST_OMP_END_PARALLEL_SECTION= S, @@ -1242,10 +1243,14 @@ typedef struct gfc_omp_clauses struct gfc_expr *num_gangs_expr; struct gfc_expr *num_workers_expr; struct gfc_expr *vector_length_expr; + struct gfc_symbol *routine_bind; + int dtype; + struct gfc_omp_clauses *dtype_clauses; gfc_expr_list *wait_list; gfc_expr_list *tile_list; unsigned async:1, gang:1, worker:1, vector:1, seq:1, independent:1; - unsigned wait:1, par_auto:1, gang_static:1; + unsigned wait:1, par_auto:1, gang_static:1, nohost:1, acc_collapse:1, bi= nd:1; + unsigned num_gangs:1, num_workers:1, vector_length:1, tile:1; locus loc; =20 } @@ -1253,6 +1258,17 @@ gfc_omp_clauses; =20 #define gfc_get_omp_clauses() XCNEW (gfc_omp_clauses) =20 +/* Node in the linked list used for storing !$oacc declare constructs. */ + +typedef struct gfc_oacc_declare +{ + struct gfc_oacc_declare *next; + locus where; + gfc_omp_clauses *clauses; +} +gfc_oacc_declare; +#define gfc_get_oacc_declare() XCNEW (gfc_oacc_declare) + =20 /* Node in the linked list used for storing !$omp declare simd constructs.= */ =20 @@ -1592,6 +1608,16 @@ gfc_dt_list; /* A list of all derived types. */ extern gfc_dt_list *gfc_derived_types; =20 +typedef struct gfc_oacc_routine_name +{ + struct gfc_symbol *sym; + struct gfc_omp_clauses *clauses; + struct gfc_oacc_routine_name *next; +} +gfc_oacc_routine_name; + +#define gfc_get_oacc_routine_name() XCNEW (gfc_oacc_routine_name) + /* A namespace describes the contents of procedure, module, interface block or BLOCK construct. */ /* ??? Anything else use these? */ @@ -1656,7 +1682,13 @@ typedef struct gfc_namespace struct gfc_data *data, *old_data; =20 /* !$ACC DECLARE clauses. */ - gfc_omp_clauses *oacc_declare_clauses; + struct gfc_oacc_declare *oacc_declare; + + /* !$ACC ROUTINE clauses. */ + gfc_omp_clauses *oacc_routine_clauses; + + /* !$ACC ROUTINE names. */ + gfc_oacc_routine_name *oacc_routine_names; =20 gfc_charlen *cl_list, *old_cl_list; =20 @@ -1703,6 +1735,9 @@ typedef struct gfc_namespace =20 /* Set to 1 for !$OMP DECLARE REDUCTION namespaces. */ unsigned omp_udr_ns:1; + + /* Set to 1 for !$ACC ROUTINE namespaces. */ + unsigned oacc_routine:1; } gfc_namespace; =20 @@ -2331,10 +2366,11 @@ typedef enum EXEC_READ, EXEC_WRITE, EXEC_IOLENGTH, EXEC_TRANSFER, EXEC_DT_END, EXEC_BACKSPACE, EXEC_ENDFILE, EXEC_INQUIRE, EXEC_REWIND, EXEC_FLUSH, EXEC_LOCK, EXEC_UNLOCK, - EXEC_OACC_KERNELS_LOOP, EXEC_OACC_PARALLEL_LOOP, + EXEC_OACC_KERNELS_LOOP, EXEC_OACC_PARALLEL_LOOP, EXEC_OACC_ROUTINE, EXEC_OACC_PARALLEL, EXEC_OACC_KERNELS, EXEC_OACC_DATA, EXEC_OACC_HOST_DA= TA, EXEC_OACC_LOOP, EXEC_OACC_UPDATE, EXEC_OACC_WAIT, EXEC_OACC_CACHE, - EXEC_OACC_ENTER_DATA, EXEC_OACC_EXIT_DATA, + EXEC_OACC_ENTER_DATA, EXEC_OACC_EXIT_DATA, EXEC_OACC_ATOMIC, + EXEC_OACC_DECLARE, EXEC_OMP_CRITICAL, EXEC_OMP_DO, EXEC_OMP_FLUSH, EXEC_OMP_MASTER, EXEC_OMP_ORDERED, EXEC_OMP_PARALLEL, EXEC_OMP_PARALLEL_DO, EXEC_OMP_PARALLEL_SECTIONS, EXEC_OMP_PARALLEL_WORKSHARE, @@ -2416,6 +2452,7 @@ typedef struct gfc_code int stop_code; gfc_entry_list *entry; gfc_omp_clauses *omp_clauses; + gfc_oacc_declare *oacc_declare; const char *omp_name; gfc_omp_namelist *omp_namelist; bool omp_bool; @@ -2923,6 +2960,7 @@ gfc_expr *gfc_get_parentheses (gfc_expr *); /* openmp.c */ struct gfc_omp_saved_state { void *ptrs[2]; int ints[1]; }; void gfc_free_omp_clauses (gfc_omp_clauses *); +void gfc_free_oacc_declares (struct gfc_oacc_declare *); void gfc_free_omp_declare_simd (gfc_omp_declare_simd *); void gfc_free_omp_declare_simd_list (gfc_omp_declare_simd *); void gfc_free_omp_udr (gfc_omp_udr *); @@ -3231,4 +3269,8 @@ int gfc_code_walker (gfc_code **, walk_code_fn_t, wal= k_expr_fn_t, void *); =20 void gfc_convert_mpz_to_signed (mpz_t, int); =20 +/* trans-decl.c */ + +void insert_oacc_declare (gfc_namespace *); + #endif /* GCC_GFORTRAN_H */ diff --git gcc/fortran/match.h gcc/fortran/match.h index 96d3ec1..202e175 100644 --- gcc/fortran/match.h +++ gcc/fortran/match.h @@ -123,6 +123,7 @@ gfc_common_head *gfc_get_common (const char *, int); /* openmp.c. */ =20 /* OpenACC directive matchers. */ +match gfc_match_oacc_atomic (void); match gfc_match_oacc_cache (void); match gfc_match_oacc_wait (void); match gfc_match_oacc_update (void); diff --git gcc/fortran/openmp.c gcc/fortran/openmp.c index 21de607..883676e 100644 --- gcc/fortran/openmp.c +++ gcc/fortran/openmp.c @@ -92,6 +92,25 @@ gfc_free_omp_clauses (gfc_omp_clauses *c) free (c); } =20 +/* Free oacc_declare structures. */ + +void +gfc_free_oacc_declares (struct gfc_oacc_declare *oc) +{ + struct gfc_oacc_declare *decl =3D oc; + + do + { + struct gfc_oacc_declare *next; + + next =3D decl->next; + gfc_free_omp_clauses (decl->clauses); + free (decl); + decl =3D next; + } + while (decl); +} + /* Free expression list. */ void gfc_free_expr_list (gfc_expr_list *list) @@ -447,21 +466,26 @@ match_oacc_clause_gang (gfc_omp_clauses *cp) #define OMP_CLAUSE_INDEPENDENT ((uint64_t) 1 << 49) #define OMP_CLAUSE_USE_DEVICE ((uint64_t) 1 << 50) #define OMP_CLAUSE_DEVICE_RESIDENT ((uint64_t) 1 << 51) -#define OMP_CLAUSE_HOST_SELF ((uint64_t) 1 << 52) +#define OMP_CLAUSE_HOST ((uint64_t) 1 << 52) #define OMP_CLAUSE_OACC_DEVICE ((uint64_t) 1 << 53) #define OMP_CLAUSE_WAIT ((uint64_t) 1 << 54) #define OMP_CLAUSE_DELETE ((uint64_t) 1 << 55) #define OMP_CLAUSE_AUTO ((uint64_t) 1 << 56) #define OMP_CLAUSE_TILE ((uint64_t) 1 << 57) +#define OMP_CLAUSE_BIND ((uint64_t) 1 << 58) +#define OMP_CLAUSE_NOHOST ((uint64_t) 1 << 59) +#define OMP_CLAUSE_DEVICE_TYPE ((uint64_t) 1 << 60) =20 /* Helper function for OpenACC and OpenMP clauses involving memory mapping. */ =20 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_sections =3D true) { gfc_omp_namelist **head =3D NULL; - if (gfc_match_omp_variable_list ("", list, false, NULL, &head, true) + if (gfc_match_omp_variable_list ("", list, false, NULL, &head, + allow_sections) =3D=3D MATCH_YES) { gfc_omp_namelist *n; @@ -478,11 +502,14 @@ gfc_match_omp_map_clause (gfc_omp_namelist **list, gf= c_omp_map_op map_op) =20 static match gfc_match_omp_clauses (gfc_omp_clauses **cp, uint64_t mask, - bool first =3D true, bool needs_space =3D true, - bool openacc =3D false) + uint64_t dtype_mask, bool first =3D true, + bool needs_space =3D true, bool openacc =3D false) { - gfc_omp_clauses *c =3D gfc_get_omp_clauses (); + gfc_omp_clauses *base_clauses, *c =3D gfc_get_omp_clauses (); locus old_loc; + bool scan_dtype =3D false; + + base_clauses =3D c; =20 *cp =3D NULL; while (1) @@ -531,7 +558,10 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, uint64_t = mask, if ((mask & OMP_CLAUSE_VECTOR_LENGTH) && c->vector_length_expr =3D= =3D NULL && gfc_match ("vector_length ( %e )", &c->vector_length_expr) =3D=3D MATCH_YES) - continue; + { + c->vector_length =3D 1; + continue; + } if ((mask & OMP_CLAUSE_VECTOR) && !c->vector) if (gfc_match ("vector") =3D=3D MATCH_YES) { @@ -596,11 +626,17 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, uint64_t= mask, } if ((mask & OMP_CLAUSE_NUM_GANGS) && c->num_gangs_expr =3D=3D NULL && gfc_match ("num_gangs ( %e )", &c->num_gangs_expr) =3D=3D MATCH_YES) - continue; + { + c->num_gangs =3D 1; + continue; + } if ((mask & OMP_CLAUSE_NUM_WORKERS) && c->num_workers_expr =3D=3D NU= LL && gfc_match ("num_workers ( %e )", &c->num_workers_expr) =3D=3D MATCH_YES) - continue; + { + c->num_workers =3D 1; + continue; + } if ((mask & OMP_CLAUSE_COPY) && gfc_match ("copy ( ") =3D=3D MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], @@ -680,6 +716,18 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, uint64_t = mask, continue; } } + if ((mask & OMP_CLAUSE_BIND) && c->routine_bind =3D=3D NULL + && gfc_match ("bind ( %s )", &c->routine_bind) =3D=3D MATCH_YES) + { + c->bind =3D 1; + continue; + } + if ((mask & OMP_CLAUSE_NOHOST) && !c->nohost + && gfc_match ("nohost") =3D=3D MATCH_YES) + { + c->nohost =3D true; + continue; + } if ((mask & OMP_CLAUSE_USE_DEVICE) && gfc_match_omp_variable_list ("use_device (", &c->lists[OMP_LIST_USE_DEVICE], true) @@ -696,15 +744,20 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, uint64_t= mask, && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], OMP_MAP_FORCE_TO)) continue; - if ((mask & OMP_CLAUSE_HOST_SELF) + if ((mask & OMP_CLAUSE_HOST) && (gfc_match ("host ( ") =3D=3D MATCH_YES - || gfc_match ("self ( ") =3D=3D MATCH_YES) + || gfc_match ("self ( ") =3D=3D MATCH_YES) /* "self" is a synonym f= or + "host". */ && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], OMP_MAP_FORCE_FROM)) continue; if ((mask & OMP_CLAUSE_TILE) + && !c->tile_list && match_oacc_expr_list ("tile (", &c->tile_list, true) =3D=3D MATCH_YE= S) - continue; + { + c->tile =3D 1; + continue; + } if ((mask & OMP_CLAUSE_SEQ) && !c->seq && gfc_match ("seq") =3D=3D MATCH_YES) { @@ -856,13 +909,14 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, uint64_t= mask, if ((mask & OMP_CLAUSE_DEFAULT) && c->default_sharing =3D=3D OMP_DEFAULT_UNKNOWN) { - if (gfc_match ("default ( shared )") =3D=3D MATCH_YES) + if (!openacc && gfc_match ("default ( shared )") =3D=3D MATCH_YES) c->default_sharing =3D OMP_DEFAULT_SHARED; - else if (gfc_match ("default ( private )") =3D=3D MATCH_YES) + else if (!openacc && gfc_match ("default ( private )") =3D=3D MATCH_YES) c->default_sharing =3D OMP_DEFAULT_PRIVATE; else if (gfc_match ("default ( none )") =3D=3D MATCH_YES) c->default_sharing =3D OMP_DEFAULT_NONE; - else if (gfc_match ("default ( firstprivate )") =3D=3D MATCH_YES) + else if (!openacc + && gfc_match ("default ( firstprivate )") =3D=3D MATCH_YES) c->default_sharing =3D OMP_DEFAULT_FIRSTPRIVATE; if (c->default_sharing !=3D OMP_DEFAULT_UNKNOWN) continue; @@ -938,6 +992,7 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, uint64_t m= ask, } c->collapse =3D collapse; gfc_free_expr (cexpr); + c->acc_collapse =3D 1; continue; } } @@ -1083,6 +1138,47 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, uint64_= t mask, if ((mask & OMP_CLAUSE_DEVICE) && c->device =3D=3D NULL && gfc_match ("device ( %e )", &c->device) =3D=3D MATCH_YES) continue; + if (((mask & OMP_CLAUSE_DEVICE_TYPE) || scan_dtype) + && (gfc_match ("device_type ( ") =3D=3D MATCH_YES + || gfc_match ("dtype ( ") =3D=3D MATCH_YES)) + { + int device =3D GOMP_DEVICE_NONE; + gfc_omp_clauses *t =3D gfc_get_omp_clauses (); + + c->dtype_clauses =3D t; + c =3D t; + + if (gfc_match (" * ") =3D=3D MATCH_YES) + device =3D GOMP_DEVICE_DEFAULT; + else + { + char n[GFC_MAX_SYMBOL_LEN + 1]; + + while (gfc_match (" %n ", n) =3D=3D MATCH_YES) + { + if (!strcasecmp ("nvidia", n)) + device =3D GOMP_DEVICE_NVIDIA_PTX; + else + { + /* The OpenACC technical committee advises compilers + to silently ignore unknown devices. */ + } + gfc_match (" , "); + } + } + + /* Consume the trailing ')'. */ + if (gfc_match (" ) ") !=3D MATCH_YES) + { + gfc_error ("expected %<)%>"); + continue; + } + + c->dtype =3D device; + mask =3D dtype_mask; + scan_dtype =3D true; + continue; + } if ((mask & OMP_CLAUSE_THREAD_LIMIT) && c->thread_limit =3D=3D NULL && gfc_match ("thread_limit ( %e )", &c->thread_limit) =3D=3D MATCH_YES) continue; @@ -1129,11 +1225,82 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, uint64= _t mask, =20 if (gfc_match_omp_eos () !=3D MATCH_YES) { - gfc_free_omp_clauses (c); + gfc_omp_clauses *t; + c =3D base_clauses->dtype_clauses; + while (c) + { + t =3D c->dtype_clauses; + gfc_free_omp_clauses (c); + c =3D t; + } + gfc_free_omp_clauses (base_clauses); return MATCH_ERROR; } =20 - *cp =3D c; + /* Filter out the device_type clauses. */ + if (base_clauses->dtype_clauses) + { + gfc_omp_clauses *t; + gfc_omp_clauses *seen_default =3D NULL; + gfc_omp_clauses *seen_nvidia =3D NULL; + + /* Scan for device_type clauses. */ + c =3D base_clauses->dtype_clauses; + while (c) + { + if (c->dtype =3D=3D GOMP_DEVICE_DEFAULT) + { + if (seen_default) + gfc_error ("duplicate device_type (*)"); + else + seen_default =3D c; + } + else if (c->dtype =3D=3D GOMP_DEVICE_NVIDIA_PTX) + { + if (seen_nvidia) + gfc_error ("duplicate device_type (nvidia)"); + else + seen_nvidia =3D c; + } + c =3D c->dtype_clauses; + } + + /* Update the clauses in the original set of clauses. */ + c =3D seen_nvidia ? seen_nvidia : seen_default; + if (c) + { +#define acc_clause0(mask) do if (c->mask) { base_clauses->mask =3D 1; } wh= ile (0) +#define acc_clause1(mask, expr, type) do if (c->mask) { type t; \ + base_clauses->mask =3D 1; t =3D base_clauses->expr; \ + base_clauses->expr =3D c->expr; c->expr =3D t; } while (0) + + acc_clause1 (acc_collapse, collapse, int); + acc_clause1 (gang, gang_expr, gfc_expr *); + acc_clause1 (worker, worker_expr, gfc_expr *); + acc_clause1 (vector, vector_expr, gfc_expr *); + acc_clause0 (par_auto); + acc_clause0 (independent); + acc_clause0 (seq); + acc_clause1 (tile, tile_list, gfc_expr_list *); + acc_clause1 (async, async_expr, gfc_expr *); + acc_clause1 (wait, wait_list, gfc_expr_list *); + acc_clause1 (num_gangs, num_gangs_expr, gfc_expr *); + acc_clause1 (num_workers, num_workers_expr, gfc_expr *); + acc_clause1 (vector_length, vector_length_expr, gfc_expr *); + acc_clause1 (bind, routine_bind, gfc_symbol *); + } + + /* Remove the device_type clauses. */ + c =3D base_clauses->dtype_clauses; + while (c) + { + t =3D c->dtype_clauses; + gfc_free_omp_clauses (c); + c =3D t; + }=20=20=20=20=20=20 + } + + *cp =3D base_clauses; return MATCH_YES; } =20 @@ -1145,13 +1312,15 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, uint64= _t mask, | OMP_CLAUSE_CREATE | OMP_CLAUSE_PRESENT | OMP_CLAUSE_PRESENT_OR_COPY = \ | OMP_CLAUSE_PRESENT_OR_COPYIN | OMP_CLAUSE_PRESENT_OR_COPYOUT = \ | OMP_CLAUSE_PRESENT_OR_CREATE | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_PRIV= ATE \ - | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT) + | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT \ + | OMP_CLAUSE_DEVICE_TYPE) #define OACC_KERNELS_CLAUSES \ (OMP_CLAUSE_IF | OMP_CLAUSE_ASYNC | OMP_CLAUSE_DEVICEPTR = \ | OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT = \ | OMP_CLAUSE_CREATE | OMP_CLAUSE_PRESENT | OMP_CLAUSE_PRESENT_OR_COPY = \ | OMP_CLAUSE_PRESENT_OR_COPYIN | OMP_CLAUSE_PRESENT_OR_COPYOUT = \ - | OMP_CLAUSE_PRESENT_OR_CREATE | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT) + | OMP_CLAUSE_PRESENT_OR_CREATE | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT = \ + | OMP_CLAUSE_DEVICE_TYPE) #define OACC_DATA_CLAUSES \ (OMP_CLAUSE_IF | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_COPY = \ | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT | OMP_CLAUSE_CREATE = \ @@ -1162,7 +1331,7 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, uint64_t= mask, (OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_GANG | OMP_CLAUSE_WORKER \ | OMP_CLAUSE_VECTOR | OMP_CLAUSE_SEQ | OMP_CLAUSE_INDEPENDENT \ | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_AUTO \ - | OMP_CLAUSE_TILE) + | OMP_CLAUSE_TILE | OMP_CLAUSE_DEVICE_TYPE) #define OACC_PARALLEL_LOOP_CLAUSES \ (OACC_LOOP_CLAUSES | OACC_PARALLEL_CLAUSES) #define OACC_KERNELS_LOOP_CLAUSES \ @@ -1175,8 +1344,8 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, uint64_t= mask, | OMP_CLAUSE_PRESENT_OR_COPYIN | OMP_CLAUSE_PRESENT_OR_COPYOUT = \ | OMP_CLAUSE_PRESENT_OR_CREATE) #define OACC_UPDATE_CLAUSES \ - (OMP_CLAUSE_IF | OMP_CLAUSE_ASYNC | OMP_CLAUSE_HOST_SELF \ - | OMP_CLAUSE_OACC_DEVICE | OMP_CLAUSE_WAIT) + (OMP_CLAUSE_IF | OMP_CLAUSE_ASYNC | OMP_CLAUSE_HOST \ + | OMP_CLAUSE_OACC_DEVICE | OMP_CLAUSE_WAIT | OMP_CLAUSE_DEVICE_TYPE) #define OACC_ENTER_DATA_CLAUSES \ (OMP_CLAUSE_IF | OMP_CLAUSE_ASYNC | OMP_CLAUSE_WAIT | OMP_CLAUSE_COPYIN = \ | OMP_CLAUSE_CREATE | OMP_CLAUSE_PRESENT_OR_COPYIN = \ @@ -1186,14 +1355,35 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, uint64= _t mask, | OMP_CLAUSE_DELETE) #define OACC_WAIT_CLAUSES \ (OMP_CLAUSE_ASYNC) +#define OACC_ROUTINE_CLAUSES \ + (OMP_CLAUSE_GANG | OMP_CLAUSE_WORKER | OMP_CLAUSE_VECTOR | OMP_CLAUSE_SE= Q \ + | OMP_CLAUSE_BIND | OMP_CLAUSE_OACC_DEVICE | OMP_CLAUSE_NOHOST = \ + | OMP_CLAUSE_DEVICE_TYPE) + +#define OACC_LOOP_CLAUSE_DEVICE_TYPE_MASK \ + (OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_GANG | OMP_CLAUSE_WORKER \ + | OMP_CLAUSE_VECTOR | OMP_CLAUSE_AUTO | OMP_CLAUSE_INDEPENDENT \ + | OMP_CLAUSE_SEQ | OMP_CLAUSE_TILE) +#define OACC_KERNELS_CLAUSE_DEVICE_TYPE_MASK \ + (OMP_CLAUSE_ASYNC | OMP_CLAUSE_WAIT) +#define OACC_PARALLEL_CLAUSE_DEVICE_TYPE_MASK \ + (OMP_CLAUSE_ASYNC | OMP_CLAUSE_NUM_GANGS | OMP_CLAUSE_NUM_WORKERS \ + | OMP_CLAUSE_VECTOR_LENGTH | OMP_CLAUSE_WAIT) +#define OACC_ROUTINE_CLAUSE_DEVICE_TYPE_MASK \ + (OMP_CLAUSE_GANG | OMP_CLAUSE_WORKER | OMP_CLAUSE_VECTOR \ + | OMP_CLAUSE_SEQ | OMP_CLAUSE_BIND) +#define OACC_UPDATE_CLAUSE_DEVICE_TYPE_MASK \ + (OMP_CLAUSE_ASYNC | OMP_CLAUSE_WAIT) =20 =20 match gfc_match_oacc_parallel_loop (void) { gfc_omp_clauses *c; - if (gfc_match_omp_clauses (&c, OACC_PARALLEL_LOOP_CLAUSES, false, false, - true) !=3D MATCH_YES) + if (gfc_match_omp_clauses (&c, OACC_PARALLEL_LOOP_CLAUSES, + OACC_PARALLEL_CLAUSE_DEVICE_TYPE_MASK + | OACC_LOOP_CLAUSE_DEVICE_TYPE_MASK, false, + false, true) !=3D MATCH_YES) return MATCH_ERROR; =20 new_st.op =3D EXEC_OACC_PARALLEL_LOOP; @@ -1206,7 +1396,9 @@ match gfc_match_oacc_parallel (void) { gfc_omp_clauses *c; - if (gfc_match_omp_clauses (&c, OACC_PARALLEL_CLAUSES, false, false, true) + if (gfc_match_omp_clauses (&c, OACC_PARALLEL_CLAUSES, + OACC_PARALLEL_CLAUSE_DEVICE_TYPE_MASK, false, + false, true) !=3D MATCH_YES) return MATCH_ERROR; =20 @@ -1220,8 +1412,10 @@ match gfc_match_oacc_kernels_loop (void) { gfc_omp_clauses *c; - if (gfc_match_omp_clauses (&c, OACC_KERNELS_LOOP_CLAUSES, false, false, - true) !=3D MATCH_YES) + if (gfc_match_omp_clauses (&c, OACC_KERNELS_LOOP_CLAUSES, + OACC_KERNELS_CLAUSE_DEVICE_TYPE_MASK + | OACC_LOOP_CLAUSE_DEVICE_TYPE_MASK, false, + false, true) !=3D MATCH_YES) return MATCH_ERROR; =20 new_st.op =3D EXEC_OACC_KERNELS_LOOP; @@ -1234,7 +1428,9 @@ match gfc_match_oacc_kernels (void) { gfc_omp_clauses *c; - if (gfc_match_omp_clauses (&c, OACC_KERNELS_CLAUSES, false, false, true) + if (gfc_match_omp_clauses (&c, OACC_KERNELS_CLAUSES, + OACC_KERNELS_CLAUSE_DEVICE_TYPE_MASK, false, + false, true) !=3D MATCH_YES) return MATCH_ERROR; =20 @@ -1248,7 +1444,7 @@ match gfc_match_oacc_data (void) { gfc_omp_clauses *c; - if (gfc_match_omp_clauses (&c, OACC_DATA_CLAUSES, false, false, true) + if (gfc_match_omp_clauses (&c, OACC_DATA_CLAUSES, 0, false, false, true) !=3D MATCH_YES) return MATCH_ERROR; =20 @@ -1262,7 +1458,7 @@ match gfc_match_oacc_host_data (void) { gfc_omp_clauses *c; - if (gfc_match_omp_clauses (&c, OACC_HOST_DATA_CLAUSES, false, false, tru= e) + if (gfc_match_omp_clauses (&c, OACC_HOST_DATA_CLAUSES, 0, false, false, = true) !=3D MATCH_YES) return MATCH_ERROR; =20 @@ -1276,7 +1472,9 @@ match gfc_match_oacc_loop (void) { gfc_omp_clauses *c; - if (gfc_match_omp_clauses (&c, OACC_LOOP_CLAUSES, false, false, true) + if (gfc_match_omp_clauses (&c, OACC_LOOP_CLAUSES, + OACC_LOOP_CLAUSE_DEVICE_TYPE_MASK, false, false, + true) !=3D MATCH_YES) return MATCH_ERROR; =20 @@ -1290,12 +1488,90 @@ match gfc_match_oacc_declare (void) { gfc_omp_clauses *c; - if (gfc_match_omp_clauses (&c, OACC_DECLARE_CLAUSES, false, false, true) + gfc_omp_namelist *n; + gfc_namespace *ns =3D gfc_current_ns; + gfc_oacc_declare *new_oc, *oc; + locus where =3D gfc_current_locus; + + if (gfc_match_omp_clauses (&c, OACC_DECLARE_CLAUSES, 0, false, false, tr= ue) !=3D MATCH_YES) return MATCH_ERROR; =20 - new_st.ext.omp_clauses =3D c; - new_st.ext.omp_clauses->loc =3D gfc_current_locus; + for (n =3D c->lists[OMP_LIST_MAP]; n !=3D NULL; n =3D n->next) + { + gfc_symbol *s =3D n->sym; + + if (s->ns->proc_name && s->ns->proc_name->attr.proc =3D=3D PROC_MODU= LE) + { + if (n->u.map_op !=3D OMP_MAP_FORCE_ALLOC + && n->u.map_op !=3D OMP_MAP_FORCE_TO) + { + gfc_error ("Invalid clause in module with " + "$!ACC DECLARE at %C"); + return MATCH_ERROR; + } + } + + if (s->attr.in_common) + { + gfc_error ("Unsupported: variable in a common block with " + "$!ACC DECLARE at %C"); + return MATCH_ERROR; + } + + if (s->attr.use_assoc) + { + gfc_error ("Unsupported: variable is USE-associated with " + "$!ACC DECLARE at %C"); + return MATCH_ERROR; + } + + if ((s->attr.dimension || s->attr.codimension) + && s->attr.dummy && s->as->type !=3D AS_EXPLICIT) + { + gfc_error ("Unsupported: assumed-size dummy array with " + "$!ACC DECLARE at %C"); + return MATCH_ERROR; + } + } + + new_oc =3D gfc_get_oacc_declare (); + new_oc->next =3D ns->oacc_declare; + new_oc->where =3D where; + new_oc->clauses =3D c; + + for (oc =3D new_oc; oc; oc =3D oc->next) + { + c =3D oc->clauses; + for (n =3D c->lists[OMP_LIST_MAP]; n !=3D NULL; n =3D n->next) + n->sym->mark =3D 0; + } + + for (oc =3D new_oc; oc; oc =3D oc->next) + { + c =3D oc->clauses; + for (n =3D c->lists[OMP_LIST_MAP]; n !=3D NULL; n =3D n->next) + { + if (n->sym->mark) + { + gfc_error ("Symbol %qs present on multiple clauses at %C", + n->sym->name); + return MATCH_ERROR; + } + else + n->sym->mark =3D 1; + } + } + + for (oc =3D new_oc; oc; oc =3D oc->next) + { + c =3D oc->clauses; + for (n =3D c->lists[OMP_LIST_MAP]; n !=3D NULL; n =3D n->next) + n->sym->mark =3D 1; + } + + ns->oacc_declare =3D new_oc; + return MATCH_YES; } =20 @@ -1304,10 +1580,21 @@ match gfc_match_oacc_update (void) { gfc_omp_clauses *c; - if (gfc_match_omp_clauses (&c, OACC_UPDATE_CLAUSES, false, false, true) + locus here =3D gfc_current_locus; + + if (gfc_match_omp_clauses (&c, OACC_UPDATE_CLAUSES, + OACC_UPDATE_CLAUSE_DEVICE_TYPE_MASK, false, + false, true) !=3D MATCH_YES) return MATCH_ERROR; =20 + if (!c->lists[OMP_LIST_MAP]) + { + gfc_error ("% must contain at least one " + "% or % clause at %L", &here); + return MATCH_ERROR; + } + new_st.op =3D EXEC_OACC_UPDATE; new_st.ext.omp_clauses =3D c; return MATCH_YES; @@ -1318,7 +1605,7 @@ match gfc_match_oacc_enter_data (void) { gfc_omp_clauses *c; - if (gfc_match_omp_clauses (&c, OACC_ENTER_DATA_CLAUSES, false, false, tr= ue) + if (gfc_match_omp_clauses (&c, OACC_ENTER_DATA_CLAUSES, 0, false, false,= true) !=3D MATCH_YES) return MATCH_ERROR; =20 @@ -1332,7 +1619,7 @@ match gfc_match_oacc_exit_data (void) { gfc_omp_clauses *c; - if (gfc_match_omp_clauses (&c, OACC_EXIT_DATA_CLAUSES, false, false, tru= e) + if (gfc_match_omp_clauses (&c, OACC_EXIT_DATA_CLAUSES, 0, false, false, = true) !=3D MATCH_YES) return MATCH_ERROR; =20 @@ -1349,7 +1636,7 @@ gfc_match_oacc_wait (void) gfc_expr_list *wait_list =3D NULL, *el; =20 match_oacc_expr_list (" (", &wait_list, true); - gfc_match_omp_clauses (&c, OACC_WAIT_CLAUSES, false, false, true); + gfc_match_omp_clauses (&c, OACC_WAIT_CLAUSES, 0, false, false, true); =20 if (gfc_match_omp_eos () !=3D MATCH_YES) { @@ -1389,7 +1676,8 @@ gfc_match_oacc_cache (void) { gfc_omp_clauses *c =3D gfc_get_omp_clauses (); match m =3D gfc_match_omp_variable_list (" (", - &c->lists[OMP_LIST_CACHE], true); + &c->lists[OMP_LIST_CACHE], true, + NULL, NULL, true); if (m !=3D MATCH_YES) { gfc_free_omp_clauses(c); @@ -1414,8 +1702,10 @@ match gfc_match_oacc_routine (void) { locus old_loc; - gfc_symbol *sym; + gfc_symbol *sym =3D NULL; match m; + gfc_omp_clauses *c =3D NULL; + gfc_oacc_routine_name *n =3D NULL; =20 old_loc =3D gfc_current_locus; =20 @@ -1430,52 +1720,73 @@ gfc_match_oacc_routine (void) goto cleanup; } =20 - if (m =3D=3D MATCH_NO - && gfc_current_ns->proc_name - && gfc_match_omp_eos () =3D=3D MATCH_YES) + if (m =3D=3D MATCH_YES) + { + /* Scan for a function name/string. */ + m =3D gfc_match_symbol (&sym, 0); + + if (m =3D=3D MATCH_NO) + { + gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C"); + gfc_current_locus =3D old_loc; + return MATCH_ERROR; + } + + if (!sym->attr.external && !sym->attr.function && !sym->attr.subrout= ine) + { + gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C, invalid" + " function name %qs", sym->name); + gfc_current_locus =3D old_loc; + return MATCH_ERROR; + } + + if (gfc_match_char (')') !=3D MATCH_YES) + { + gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C, expecting" + " ')' after NAME"); + gfc_current_locus =3D old_loc; + return MATCH_ERROR; + } + } + + if (sym !=3D NULL) + { + n =3D gfc_get_oacc_routine_name (); + n->sym =3D sym; + n->clauses =3D NULL; + n->next =3D NULL; + if (gfc_current_ns->oacc_routine_names !=3D NULL) + n->next =3D gfc_current_ns->oacc_routine_names; + + gfc_current_ns->oacc_routine_names =3D n; + } + else if (gfc_current_ns->proc_name) { if (!gfc_add_omp_declare_target (&gfc_current_ns->proc_name->attr, gfc_current_ns->proc_name->name, &old_loc)) goto cleanup; - return MATCH_YES; } + else + gcc_unreachable (); =20 - if (m !=3D MATCH_YES) - return m; + if (gfc_match_omp_eos () =3D=3D MATCH_YES) + return MATCH_YES; =20 - /* Scan for a function name. */ - m =3D gfc_match_symbol (&sym, 0); + if (gfc_match_omp_clauses (&c, OACC_ROUTINE_CLAUSES, + OACC_ROUTINE_CLAUSE_DEVICE_TYPE_MASK, false, + false, true) + !=3D MATCH_YES) + return MATCH_ERROR; =20 - if (m !=3D MATCH_YES) - { - gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C"); - gfc_current_locus =3D old_loc; - return MATCH_ERROR; - } - - if (!sym->attr.external && !sym->attr.function && !sym->attr.subroutine) - { - gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C, invalid" - " function name %qs", sym->name); - gfc_current_locus =3D old_loc; - return MATCH_ERROR; - } + if (n) + n->clauses =3D c; + else if (gfc_current_ns->oacc_routine) + gfc_current_ns->oacc_routine_clauses =3D c; =20 - if (gfc_match_char (')') !=3D MATCH_YES) - { - gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C, expecting" - " ')' after NAME"); - gfc_current_locus =3D old_loc; - return MATCH_ERROR; - } - - if (gfc_match_omp_eos () !=3D MATCH_YES) - { - gfc_error ("Unexpected junk after !$ACC ROUTINE at %C"); - goto cleanup; - } - return MATCH_YES; + new_st.op =3D EXEC_OACC_ROUTINE; + new_st.ext.omp_clauses =3D c; + return MATCH_YES;=20=20 =20 cleanup: gfc_current_locus =3D old_loc; @@ -1524,7 +1835,7 @@ static match match_omp (gfc_exec_op op, unsigned int mask) { gfc_omp_clauses *c; - if (gfc_match_omp_clauses (&c, mask) !=3D MATCH_YES) + if (gfc_match_omp_clauses (&c, mask, 0) !=3D MATCH_YES) return MATCH_ERROR; new_st.op =3D op; new_st.ext.omp_clauses =3D c; @@ -1627,7 +1938,7 @@ gfc_match_omp_declare_simd (void) if (gfc_match (" ( %s ) ", &proc_name) !=3D MATCH_YES) return MATCH_ERROR; =20 - if (gfc_match_omp_clauses (&c, OMP_DECLARE_SIMD_CLAUSES, true, + if (gfc_match_omp_clauses (&c, OMP_DECLARE_SIMD_CLAUSES, 0, true, false) !=3D MATCH_YES) return MATCH_ERROR; =20 @@ -2450,9 +2761,8 @@ gfc_match_omp_ordered (void) return MATCH_YES; } =20 - -match -gfc_match_omp_atomic (void) +static match +gfc_match_omp_oacc_atomic (bool omp_p) { gfc_omp_atomic_op op =3D GFC_OMP_ATOMIC_UPDATE; int seq_cst =3D 0; @@ -2490,13 +2800,24 @@ gfc_match_omp_atomic (void) gfc_error ("Unexpected junk after $OMP ATOMIC statement at %C"); return MATCH_ERROR; } - new_st.op =3D EXEC_OMP_ATOMIC; + new_st.op =3D (omp_p ? EXEC_OMP_ATOMIC : EXEC_OACC_ATOMIC); if (seq_cst) op =3D (gfc_omp_atomic_op) (op | GFC_OMP_ATOMIC_SEQ_CST); new_st.ext.omp_atomic =3D op; return MATCH_YES; } =20 +match +gfc_match_oacc_atomic (void) +{ + return gfc_match_omp_oacc_atomic (false); +} + +match +gfc_match_omp_atomic (void) +{ + return gfc_match_omp_oacc_atomic (true); +} =20 match gfc_match_omp_barrier (void) @@ -2549,7 +2870,7 @@ gfc_match_omp_cancel (void) enum gfc_omp_cancel_kind kind =3D gfc_match_omp_cancel_kind (); if (kind =3D=3D OMP_CANCEL_UNKNOWN) return MATCH_ERROR; - if (gfc_match_omp_clauses (&c, OMP_CLAUSE_IF, false) !=3D MATCH_YES) + if (gfc_match_omp_clauses (&c, OMP_CLAUSE_IF, 0, false) !=3D MATCH_YES) return MATCH_ERROR; c->cancel =3D kind; new_st.op =3D EXEC_OMP_CANCEL; @@ -2606,7 +2927,7 @@ gfc_match_omp_end_single (void) new_st.ext.omp_bool =3D true; return MATCH_YES; } - if (gfc_match_omp_clauses (&c, OMP_CLAUSE_COPYPRIVATE) !=3D MATCH_YES) + if (gfc_match_omp_clauses (&c, OMP_CLAUSE_COPYPRIVATE, 0) !=3D MATCH_YES) return MATCH_ERROR; new_st.op =3D EXEC_OMP_END_SINGLE; new_st.ext.omp_clauses =3D c; @@ -2686,10 +3007,6 @@ check_array_not_assumed (gfc_symbol *sym, locus loc,= const char *name) if (sym->as && sym->as->type =3D=3D AS_ASSUMED_RANK) gfc_error ("Assumed rank array %qs in %s clause at %L", sym->name, name, &loc); - if (sym->as && sym->as->type =3D=3D AS_DEFERRED && sym->attr.pointer - && !sym->attr.contiguous) - gfc_error ("Noncontiguous deferred shape array %qs in %s clause at %L", - sym->name, name, &loc); } =20 static void @@ -4302,6 +4619,8 @@ oacc_code_to_statement (gfc_code *code) { switch (code->op) { + case EXEC_OACC_ATOMIC: + return ST_OACC_ATOMIC; case EXEC_OACC_PARALLEL: return ST_OACC_PARALLEL; case EXEC_OACC_KERNELS: @@ -4514,22 +4833,8 @@ resolve_oacc_loop_blocks (gfc_code *code) if (code->ext.omp_clauses->vector) gfc_error ("Clause AUTO conflicts with VECTOR at %L", &code->loc); } - if (!code->ext.omp_clauses->tile_list) - { - if (code->ext.omp_clauses->gang) - { - if (code->ext.omp_clauses->worker) - gfc_error ("Clause GANG conflicts with WORKER at %L", &code->loc); - if (code->ext.omp_clauses->vector) - gfc_error ("Clause GANG conflicts with VECTOR at %L", &code->loc); - } - if (code->ext.omp_clauses->worker) - if (code->ext.omp_clauses->vector) - gfc_error ("Clause WORKER conflicts with VECTOR at %L", &code->loc); - } - else if (code->ext.omp_clauses->gang - && code->ext.omp_clauses->worker - && code->ext.omp_clauses->vector) + if (code->ext.omp_clauses->tile_list && code->ext.omp_clauses->gang + && code->ext.omp_clauses->worker && code->ext.omp_clauses->vector) gfc_error ("Tiled loop cannot be parallelized across gangs, workers an= d " "vectors at the same time at %L", &code->loc); =20 @@ -4599,48 +4904,52 @@ resolve_oacc_loop (gfc_code *code) } =20 =20 -static void -resolve_oacc_cache (gfc_code *code ATTRIBUTE_UNUSED) -{ - sorry ("Sorry, !$ACC cache unimplemented yet"); -} - - void gfc_resolve_oacc_declare (gfc_namespace *ns) { int list; gfc_omp_namelist *n; locus loc; + gfc_oacc_declare *oc; =20 - if (ns->oacc_declare_clauses =3D=3D NULL) + if (ns->oacc_declare =3D=3D NULL) return; =20 - loc =3D ns->oacc_declare_clauses->loc; + for (oc =3D ns->oacc_declare; oc; oc =3D oc->next) + { + loc =3D oc->where; =20 - for (list =3D OMP_LIST_DEVICE_RESIDENT; - list <=3D OMP_LIST_DEVICE_RESIDENT; list++) - for (n =3D ns->oacc_declare_clauses->lists[list]; n; n =3D n->next) - { - n->sym->mark =3D 0; - if (n->sym->attr.flavor =3D=3D FL_PARAMETER) - gfc_error ("PARAMETER object %qs is not allowed at %L", n->sym->name, &= loc); - } + for (list =3D OMP_LIST_DEVICE_RESIDENT; + list <=3D OMP_LIST_DEVICE_RESIDENT; list++) + for (n =3D oc->clauses->lists[list]; n; n =3D n->next) + { + n->sym->mark =3D 0; + if (n->sym->attr.flavor =3D=3D FL_PARAMETER) + gfc_error ("PARAMETER object %qs is not allowed at %L", + n->sym->name, &loc); + } =20 - for (list =3D OMP_LIST_DEVICE_RESIDENT; - list <=3D OMP_LIST_DEVICE_RESIDENT; list++) - for (n =3D ns->oacc_declare_clauses->lists[list]; n; n =3D n->next) - { - if (n->sym->mark) - gfc_error ("Symbol %qs present on multiple clauses at %L", - n->sym->name, &loc); - else - n->sym->mark =3D 1; - } + for (list =3D OMP_LIST_DEVICE_RESIDENT; + list <=3D OMP_LIST_DEVICE_RESIDENT; list++) + for (n =3D oc->clauses->lists[list]; n; n =3D n->next) + { + if (n->sym->mark) + gfc_error ("Symbol %qs present on multiple clauses at %L", + n->sym->name, &loc); + else + n->sym->mark =3D 1; + } =20 - for (n =3D ns->oacc_declare_clauses->lists[OMP_LIST_DEVICE_RESIDENT]; n; - n =3D n->next) - check_array_not_assumed (n->sym, loc, "DEVICE_RESIDENT"); + for (n =3D oc->clauses->lists[OMP_LIST_DEVICE_RESIDENT]; n; n =3D n-= >next) + check_array_not_assumed (n->sym, loc, "DEVICE_RESIDENT"); + + for (n =3D oc->clauses->lists[OMP_LIST_MAP]; n; n =3D n->next) + { + if (n->expr && n->expr->ref->type =3D=3D REF_ARRAY) + gfc_error ("Subarray: %qs not allowed in $!ACC DECLARE at %L", + n->sym->name, &loc); + } + } } =20 =20 @@ -4667,8 +4976,8 @@ gfc_resolve_oacc_directive (gfc_code *code, gfc_names= pace *ns ATTRIBUTE_UNUSED) case EXEC_OACC_LOOP: resolve_oacc_loop (code); break; - case EXEC_OACC_CACHE: - resolve_oacc_cache (code); + case EXEC_OACC_ATOMIC: + resolve_omp_atomic (code); break; default: break; diff --git gcc/fortran/parse.c gcc/fortran/parse.c index 2c7c554..69217c0 100644 --- gcc/fortran/parse.c +++ gcc/fortran/parse.c @@ -615,6 +615,9 @@ decode_oacc_directive (void) =20 switch (c) { + case 'a': + match ("atomic", gfc_match_oacc_atomic, ST_OACC_ATOMIC); + break; case 'c': match ("cache", gfc_match_oacc_cache, ST_OACC_CACHE); break; @@ -623,6 +626,7 @@ decode_oacc_directive (void) match ("declare", gfc_match_oacc_declare, ST_OACC_DECLARE); break; case 'e': + match ("end atomic", gfc_match_omp_eos, ST_OACC_END_ATOMIC); match ("end data", gfc_match_omp_eos, ST_OACC_END_DATA); match ("end host_data", gfc_match_omp_eos, ST_OACC_END_HOST_DATA); match ("end kernels loop", gfc_match_omp_eos, ST_OACC_END_KERNELS_LO= OP); @@ -1351,7 +1355,8 @@ next_statement (void) case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: \ case ST_CRITICAL: \ case ST_OACC_PARALLEL_LOOP: case ST_OACC_PARALLEL: case ST_OACC_KERNELS:= \ - case ST_OACC_DATA: case ST_OACC_HOST_DATA: case ST_OACC_LOOP: case ST_OA= CC_KERNELS_LOOP + case ST_OACC_DATA: case ST_OACC_HOST_DATA: case ST_OACC_LOOP: \ + case ST_OACC_KERNELS_LOOP: case ST_OACC_ATOMIC =20 /* Declaration statements */ =20 @@ -1359,7 +1364,7 @@ next_statement (void) case ST_EQUIVALENCE: case ST_NAMELIST: case ST_STATEMENT_FUNCTION: \ case ST_TYPE: case ST_INTERFACE: case ST_OMP_THREADPRIVATE: \ case ST_PROCEDURE: case ST_OMP_DECLARE_SIMD: case ST_OMP_DECLARE_REDUCTI= ON: \ - case ST_OMP_DECLARE_TARGET: case ST_OACC_ROUTINE + case ST_OMP_DECLARE_TARGET: case ST_OACC_ROUTINE: case ST_OACC_DECLARE =20 /* Block end statements. Errors associated with interchanging these are detected in gfc_match_end(). */ @@ -1380,7 +1385,7 @@ push_state (gfc_state_data *p, gfc_compile_state new_= state, gfc_symbol *sym) p->head =3D p->tail =3D NULL; p->do_variable =3D NULL; if (p->state !=3D COMP_DO && p->state !=3D COMP_DO_CONCURRENT) - p->ext.oacc_declare_clauses =3D NULL; + p->ext.oacc_declare =3D NULL; =20 /* If this the state of a construct like BLOCK, DO or IF, the correspond= ing construct statement was accepted right before pushing the state. Thu= s, @@ -1909,6 +1914,12 @@ gfc_ascii_statement (gfc_statement st) case ST_OACC_ROUTINE: p =3D "!$ACC ROUTINE"; break; + case ST_OACC_ATOMIC: + p =3D "!ACC ATOMIC"; + break; + case ST_OACC_END_ATOMIC: + p =3D "!ACC END ATOMIC"; + break; case ST_OMP_ATOMIC: p =3D "!$OMP ATOMIC"; break; @@ -2410,7 +2421,6 @@ verify_st_order (st_state *p, gfc_statement st, bool = silent) case ST_PUBLIC: case ST_PRIVATE: case ST_DERIVED_DECL: - case ST_OACC_DECLARE: case_decl: if (p->state >=3D ORDER_EXEC) goto order; @@ -3312,19 +3322,6 @@ declSt: st =3D next_statement (); goto loop; =20 - case ST_OACC_DECLARE: - if (!verify_st_order(&ss, st, false)) - { - reject_statement (); - st =3D next_statement (); - goto loop; - } - if (gfc_state_stack->ext.oacc_declare_clauses =3D=3D NULL) - gfc_state_stack->ext.oacc_declare_clauses =3D new_st.ext.omp_clauses; - accept_statement (st); - st =3D next_statement (); - goto loop; - default: break; } @@ -4190,14 +4187,24 @@ parse_omp_do (gfc_statement omp_st) /* Parse the statements of OpenMP atomic directive. */ =20 static gfc_statement -parse_omp_atomic (void) +parse_omp_oacc_atomic (bool omp_p) { - gfc_statement st; + gfc_statement st, st_atomic, st_end_atomic; gfc_code *cp, *np; gfc_state_data s; int count; =20 - accept_statement (ST_OMP_ATOMIC); + if (omp_p) + { + st_atomic =3D ST_OMP_ATOMIC; + st_end_atomic =3D ST_OMP_END_ATOMIC; + } + else + { + st_atomic =3D ST_OACC_ATOMIC; + st_end_atomic =3D ST_OACC_END_ATOMIC; + } + accept_statement (st_atomic); =20 cp =3D gfc_state_stack->tail; push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL); @@ -4224,7 +4231,7 @@ parse_omp_atomic (void) pop_state (); =20 st =3D next_statement (); - if (st =3D=3D ST_OMP_END_ATOMIC) + if (st =3D=3D st_end_atomic) { gfc_clear_new_st (); gfc_commit_symbols (); @@ -4518,7 +4525,7 @@ parse_omp_structured_block (gfc_statement omp_st, boo= l workshare_stmts_only) continue; =20 case ST_OMP_ATOMIC: - st =3D parse_omp_atomic (); + st =3D parse_omp_oacc_atomic (true); continue; =20 default: @@ -4737,8 +4744,12 @@ parse_executable (gfc_statement st) return st; continue; =20 + case ST_OACC_ATOMIC: + st =3D parse_omp_oacc_atomic (false); + continue; + case ST_OMP_ATOMIC: - st =3D parse_omp_atomic (); + st =3D parse_omp_oacc_atomic (true); continue; =20 default: @@ -5024,13 +5035,6 @@ contains: =20 done: gfc_current_ns->code =3D gfc_state_stack->head; - if (gfc_state_stack->state =3D=3D COMP_PROGRAM - || gfc_state_stack->state =3D=3D COMP_MODULE=20 - || gfc_state_stack->state =3D=3D COMP_SUBROUTINE=20 - || gfc_state_stack->state =3D=3D COMP_FUNCTION - || gfc_state_stack->state =3D=3D COMP_BLOCK) - gfc_current_ns->oacc_declare_clauses=20 - =3D gfc_state_stack->ext.oacc_declare_clauses; } =20 =20 @@ -5568,6 +5572,7 @@ is_oacc (gfc_state_data *sd) case EXEC_OACC_CACHE: case EXEC_OACC_ENTER_DATA: case EXEC_OACC_EXIT_DATA: + case EXEC_OACC_ROUTINE: return true; =20 default: diff --git gcc/fortran/parse.h gcc/fortran/parse.h index 8a1613f..11f1e20 100644 --- gcc/fortran/parse.h +++ gcc/fortran/parse.h @@ -49,7 +49,7 @@ typedef struct gfc_state_data union { gfc_st_label *end_do_label; - gfc_omp_clauses *oacc_declare_clauses; + struct gfc_oacc_declare *oacc_declare; } ext; } diff --git gcc/fortran/resolve.c gcc/fortran/resolve.c index 316b413..bfcb6be 100644 --- gcc/fortran/resolve.c +++ gcc/fortran/resolve.c @@ -9209,6 +9209,9 @@ gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns) case EXEC_OACC_CACHE: case EXEC_OACC_ENTER_DATA: case EXEC_OACC_EXIT_DATA: + case EXEC_OACC_ATOMIC: + case EXEC_OACC_ROUTINE: + case EXEC_OACC_DECLARE: case EXEC_OMP_ATOMIC: case EXEC_OMP_CRITICAL: case EXEC_OMP_DISTRIBUTE: @@ -10385,6 +10388,7 @@ gfc_resolve_code (gfc_code *code, gfc_namespace *ns) "expression", &code->expr1->where); break; =20 + case EXEC_OACC_ATOMIC: case EXEC_OACC_PARALLEL_LOOP: case EXEC_OACC_PARALLEL: case EXEC_OACC_KERNELS_LOOP: @@ -10397,6 +10401,7 @@ gfc_resolve_code (gfc_code *code, gfc_namespace *ns) case EXEC_OACC_CACHE: case EXEC_OACC_ENTER_DATA: case EXEC_OACC_EXIT_DATA: + case EXEC_OACC_DECLARE: gfc_resolve_oacc_directive (code, ns); break; =20 diff --git gcc/fortran/st.c gcc/fortran/st.c index 116af15..78099b8 100644 --- gcc/fortran/st.c +++ gcc/fortran/st.c @@ -185,6 +185,11 @@ gfc_free_statement (gfc_code *p) gfc_free_forall_iterator (p->ext.forall_iterator); break; =20 + case EXEC_OACC_DECLARE: + if (p->ext.oacc_declare) + gfc_free_oacc_declares (p->ext.oacc_declare); + break; + case EXEC_OACC_PARALLEL_LOOP: case EXEC_OACC_PARALLEL: case EXEC_OACC_KERNELS_LOOP: @@ -197,6 +202,7 @@ gfc_free_statement (gfc_code *p) case EXEC_OACC_CACHE: case EXEC_OACC_ENTER_DATA: case EXEC_OACC_EXIT_DATA: + case EXEC_OACC_ROUTINE: case EXEC_OMP_CANCEL: case EXEC_OMP_CANCELLATION_POINT: case EXEC_OMP_DISTRIBUTE: @@ -240,6 +246,7 @@ gfc_free_statement (gfc_code *p) gfc_free_omp_namelist (p->ext.omp_namelist); break; =20 + case EXEC_OACC_ATOMIC: case EXEC_OMP_ATOMIC: case EXEC_OMP_BARRIER: case EXEC_OMP_MASTER: diff --git gcc/fortran/trans-decl.c gcc/fortran/trans-decl.c index 4c18920..3dbf128 100644 --- gcc/fortran/trans-decl.c +++ gcc/fortran/trans-decl.c @@ -5750,6 +5750,61 @@ is_ieee_module_used (gfc_namespace *ns) } =20 =20 +static gfc_code * +find_end (gfc_code *code) +{ + gcc_assert (code); + + if (code->op =3D=3D EXEC_END_PROCEDURE) + return code; + + if (code->next) + { + if (code->next->op =3D=3D EXEC_END_PROCEDURE) + return code; + else + return find_end (code->next); + } + + return NULL; +} + + +void +insert_oacc_declare (gfc_namespace *ns) +{ + gfc_code *code; + + code =3D XCNEW (gfc_code); + code->op =3D EXEC_OACC_DECLARE; + code->loc =3D ns->oacc_declare->where; + + code->ext.oacc_declare =3D ns->oacc_declare; + + code->block =3D XCNEW (gfc_code); + code->block->op =3D EXEC_OACC_DECLARE; + code->block->loc =3D ns->oacc_declare->where; + + if (ns->code) + { + gfc_code *c; + + c =3D find_end (ns->code); + if (c) + { + code->next =3D c->next; + c->next =3D NULL; + } + + code->block->next =3D ns->code; + code->block->ext.oacc_declare =3D NULL; + } + + ns->code =3D code; + ns->oacc_declare =3D NULL; +} + + /* Generate code for a function. */ =20 void @@ -5887,11 +5942,8 @@ gfc_generate_function_code (gfc_namespace * ns) add_argument_checking (&body, sym); =20 /* Generate !$ACC DECLARE directive. */ - if (ns->oacc_declare_clauses) - { - tree tmp =3D gfc_trans_oacc_declare (&body, ns); - gfc_add_expr_to_block (&body, tmp); - } + if (ns->oacc_declare) + insert_oacc_declare (ns); =20 tmp =3D gfc_trans_code (ns->code); gfc_add_expr_to_block (&body, tmp); diff --git gcc/fortran/trans-openmp.c gcc/fortran/trans-openmp.c index 9642a7d..60e06d2 100644 --- gcc/fortran/trans-openmp.c +++ gcc/fortran/trans-openmp.c @@ -563,7 +563,8 @@ gfc_omp_clause_copy_ctor (tree clause, tree dest, tree = src) stmtblock_t block, cond_block; =20 gcc_assert (OMP_CLAUSE_CODE (clause) =3D=3D OMP_CLAUSE_FIRSTPRIVATE - || OMP_CLAUSE_CODE (clause) =3D=3D OMP_CLAUSE_LINEAR); + || OMP_CLAUSE_CODE (clause) =3D=3D OMP_CLAUSE_LINEAR + || OMP_CLAUSE_CODE (clause) =3D=3D OMP_CLAUSE_REDUCTION); =20 if ((! GFC_DESCRIPTOR_TYPE_P (type) || GFC_TYPE_ARRAY_AKIND (type) !=3D GFC_ARRAY_ALLOCATABLE) @@ -1725,7 +1726,7 @@ gfc_convert_expr_to_tree (stmtblock_t *block, gfc_exp= r *expr) gfc_se se; tree result; =20 - gfc_init_se (&se, NULL ); + gfc_init_se (&se, NULL); gfc_conv_expr (&se, expr); gfc_add_block_to_block (block, &se.pre); result =3D gfc_evaluate_now (se.expr, block); @@ -2528,7 +2529,12 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_c= lauses *clauses, } if (clauses->seq) { - c =3D build_omp_clause (where.lb->location, OMP_CLAUSE_ORDERED); + c =3D build_omp_clause (where.lb->location, OMP_CLAUSE_SEQ); + omp_clauses =3D gfc_trans_add_clause (c, omp_clauses); + } + if (clauses->par_auto) + { + c =3D build_omp_clause (where.lb->location, OMP_CLAUSE_AUTO); omp_clauses =3D gfc_trans_add_clause (c, omp_clauses); } if (clauses->independent) @@ -2572,6 +2578,21 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_c= lauses *clauses, OMP_CLAUSE_VECTOR_LENGTH_EXPR (c) =3D vector_length_var; omp_clauses =3D gfc_trans_add_clause (c, omp_clauses); } + if (clauses->tile_list) + { + vec *tvec; + gfc_expr_list *el; + + vec_alloc (tvec, 4); + + for (el =3D clauses->tile_list; el; el =3D el->next) + vec_safe_push (tvec, gfc_convert_expr_to_tree (block, el->expr)); + + c =3D build_omp_clause (where.lb->location, OMP_CLAUSE_TILE); + OMP_CLAUSE_TILE_LIST (c) =3D build_tree_list_vec (tvec); + omp_clauses =3D gfc_trans_add_clause (c, omp_clauses); + tvec->truncate (0); + } if (clauses->vector) { if (clauses->vector_expr) @@ -2714,7 +2735,7 @@ gfc_trans_oacc_executable_directive (gfc_code *code) gfc_start_block (&block); oacc_clauses =3D gfc_trans_omp_clauses (&block, code->ext.omp_clauses, code->loc); - stmt =3D build1_loc (input_location, construct_code, void_type_node,=20 + stmt =3D build1_loc (input_location, construct_code, void_type_node, oacc_clauses); gfc_add_expr_to_block (&block, stmt); return gfc_finish_block (&block); @@ -3465,10 +3486,6 @@ gfc_trans_oacc_combined_directive (gfc_code *code) poplevel (0, 0); stmt =3D build2_loc (input_location, construct_code, void_type_node, stm= t, oacc_clauses); - if (code->op =3D=3D EXEC_OACC_KERNELS_LOOP) - OACC_KERNELS_COMBINED (stmt) =3D 1; - else - OACC_PARALLEL_COMBINED (stmt) =3D 1; gfc_add_expr_to_block (&block, stmt); return gfc_finish_block (&block); } @@ -4363,13 +4380,30 @@ gfc_trans_omp_workshare (gfc_code *code, gfc_omp_cl= auses *clauses) } =20 tree -gfc_trans_oacc_declare (stmtblock_t *block, gfc_namespace *ns) +gfc_trans_oacc_declare (gfc_code *code) { - tree oacc_clauses; - oacc_clauses =3D gfc_trans_omp_clauses (block, ns->oacc_declare_clauses, - ns->oacc_declare_clauses->loc); - return build1_loc (ns->oacc_declare_clauses->loc.lb->location, - OACC_DECLARE, void_type_node, oacc_clauses); + stmtblock_t block; + struct gfc_oacc_declare *d; + tree stmt, clauses =3D NULL_TREE; + + gfc_start_block (&block); + + for (d =3D code->ext.oacc_declare; d; d =3D d->next) + { + tree t; + + t =3D gfc_trans_omp_clauses (&block, d->clauses, d->clauses->loc); + + if (clauses) + OMP_CLAUSE_CHAIN (clauses) =3D t; + else + clauses =3D t; + } + + stmt =3D gfc_trans_omp_code (code->block->next, true); + stmt =3D build2_loc (input_location, OACC_DATA, void_type_node, stmt, cl= auses); + gfc_add_expr_to_block (&block, stmt); + return gfc_finish_block (&block); } =20 tree @@ -4395,6 +4429,10 @@ gfc_trans_oacc_directive (gfc_code *code) return gfc_trans_oacc_executable_directive (code); case EXEC_OACC_WAIT: return gfc_trans_oacc_wait_directive (code); + case EXEC_OACC_ATOMIC: + return gfc_trans_omp_atomic (code); + case EXEC_OACC_DECLARE: + return gfc_trans_oacc_declare (code); default: gcc_unreachable (); } diff --git gcc/fortran/trans-stmt.c gcc/fortran/trans-stmt.c index 53e9bcc..2b988d0 100644 --- gcc/fortran/trans-stmt.c +++ gcc/fortran/trans-stmt.c @@ -1588,11 +1588,8 @@ gfc_trans_block_construct (gfc_code* code) code->exit_label =3D exit_label; =20 /* Generate !$ACC DECLARE directive. */ - if (ns->oacc_declare_clauses) - { - tree tmp =3D gfc_trans_oacc_declare (&body, ns); - gfc_add_expr_to_block (&body, tmp); - } + if (ns->oacc_declare) + insert_oacc_declare (ns); =20 gfc_add_expr_to_block (&body, gfc_trans_code (ns->code)); gfc_add_expr_to_block (&body, build1_v (LABEL_EXPR, exit_label)); diff --git gcc/fortran/trans-stmt.h gcc/fortran/trans-stmt.h index 2f2a0b3..0ff93c4 100644 --- gcc/fortran/trans-stmt.h +++ gcc/fortran/trans-stmt.h @@ -67,7 +67,7 @@ void gfc_trans_omp_declare_simd (gfc_namespace *); =20 /* trans-openacc.c */ tree gfc_trans_oacc_directive (gfc_code *); -tree gfc_trans_oacc_declare (stmtblock_t *block, gfc_namespace *); +tree gfc_trans_oacc_declare (gfc_namespace *); =20 /* trans-io.c */ tree gfc_trans_open (gfc_code *); diff --git gcc/fortran/trans.c gcc/fortran/trans.c index 2dabf08..b20ec37 100644 --- gcc/fortran/trans.c +++ gcc/fortran/trans.c @@ -1932,6 +1932,7 @@ trans_code (gfc_code * code, tree cond) res =3D gfc_trans_omp_directive (code); break; =20 + case EXEC_OACC_ATOMIC: case EXEC_OACC_CACHE: case EXEC_OACC_WAIT: case EXEC_OACC_UPDATE: @@ -1944,6 +1945,7 @@ trans_code (gfc_code * code, tree cond) case EXEC_OACC_PARALLEL_LOOP: case EXEC_OACC_ENTER_DATA: case EXEC_OACC_EXIT_DATA: + case EXEC_OACC_DECLARE: res =3D gfc_trans_oacc_directive (code); break; =20 Gr=C3=BC=C3=9Fe, Thomas --=-=-= Content-Type: application/pgp-signature Content-length: 472 -----BEGIN PGP SIGNATURE----- Version: GnuPG v1 iQEcBAEBAgAGBQJVSIZCAAoJEPoxNhtoi6COaeQH+we5eLB1V3rzXQshj0VWmZ8Y UWKxn5nflnYlNHVOuLwBNUrzlLqX9mePvUEymbyqpm9Vmj+/8q5P4eJGkcrfe2Dp JJdhm8Ux+ck2nCkrmnQWlq83D5HDP/WIKjS/RxfspeaGjHe67ZNTf1dBUDNZG+Wq nfma42vFCAo6CRsQ4549jc5avvJXvQ1r9S91F+Xmjmt3ZdAs2ymMKc9jIVzU7hgr tqFLeXjof6Dg/9MM5lhL4vFA6ve4bxe1eHGb5VwN04jLKfBfSEPkeM4iWBQrE+fr BOrihk7DBuRPqsRJD+AUDEJdMlJ1Zmcn0/GBKc3EM4YwxuyIk52iLMExM2d3yDA= =tYrX -----END PGP SIGNATURE----- --=-=-=--