1 | /* OpenMP directive matching and resolving. |
2 | Copyright (C) 2005-2023 Free Software Foundation, Inc. |
3 | Contributed by Jakub Jelinek |
4 | |
5 | This file is part of GCC. |
6 | |
7 | GCC is free software; you can redistribute it and/or modify it under |
8 | the terms of the GNU General Public License as published by the Free |
9 | Software Foundation; either version 3, or (at your option) any later |
10 | version. |
11 | |
12 | GCC is distributed in the hope that it will be useful, but WITHOUT ANY |
13 | WARRANTY; without even the implied warranty of MERCHANTABILITY or |
14 | FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License |
15 | for more details. |
16 | |
17 | You should have received a copy of the GNU General Public License |
18 | along with GCC; see the file COPYING3. If not see |
19 | <http://www.gnu.org/licenses/>. */ |
20 | |
21 | #include "config.h" |
22 | #include "system.h" |
23 | #include "coretypes.h" |
24 | #include "gfortran.h" |
25 | #include "arith.h" |
26 | #include "match.h" |
27 | #include "parse.h" |
28 | #include "constructor.h" |
29 | #include "diagnostic.h" |
30 | #include "gomp-constants.h" |
31 | #include "target-memory.h" /* For gfc_encode_character. */ |
32 | #include "bitmap.h" |
33 | #include "omp-api.h" /* For omp_runtime_api_procname. */ |
34 | |
35 | |
36 | static gfc_statement omp_code_to_statement (gfc_code *); |
37 | |
38 | enum gfc_omp_directive_kind { |
39 | GFC_OMP_DIR_DECLARATIVE, |
40 | GFC_OMP_DIR_EXECUTABLE, |
41 | GFC_OMP_DIR_INFORMATIONAL, |
42 | GFC_OMP_DIR_META, |
43 | GFC_OMP_DIR_SUBSIDIARY, |
44 | GFC_OMP_DIR_UTILITY |
45 | }; |
46 | |
47 | struct gfc_omp_directive { |
48 | const char *name; |
49 | enum gfc_omp_directive_kind kind; |
50 | gfc_statement st; |
51 | }; |
52 | |
53 | /* Alphabetically sorted OpenMP clauses, except that longer strings are before |
54 | substrings; excludes combined/composite directives. See note for "ordered" |
55 | and "nothing". */ |
56 | |
57 | static const struct gfc_omp_directive gfc_omp_directives[] = { |
58 | {.name: "allocate" , .kind: GFC_OMP_DIR_DECLARATIVE, .st: ST_OMP_ALLOCATE}, |
59 | {.name: "allocators" , .kind: GFC_OMP_DIR_EXECUTABLE, .st: ST_OMP_ALLOCATORS}, |
60 | {.name: "assumes" , .kind: GFC_OMP_DIR_INFORMATIONAL, .st: ST_OMP_ASSUMES}, |
61 | {.name: "assume" , .kind: GFC_OMP_DIR_INFORMATIONAL, .st: ST_OMP_ASSUME}, |
62 | {.name: "atomic" , .kind: GFC_OMP_DIR_EXECUTABLE, .st: ST_OMP_ATOMIC}, |
63 | {.name: "barrier" , .kind: GFC_OMP_DIR_EXECUTABLE, .st: ST_OMP_BARRIER}, |
64 | {.name: "cancellation point" , .kind: GFC_OMP_DIR_EXECUTABLE, .st: ST_OMP_CANCELLATION_POINT}, |
65 | {.name: "cancel" , .kind: GFC_OMP_DIR_EXECUTABLE, .st: ST_OMP_CANCEL}, |
66 | {.name: "critical" , .kind: GFC_OMP_DIR_EXECUTABLE, .st: ST_OMP_CRITICAL}, |
67 | /* {"declare mapper", GFC_OMP_DIR_DECLARATIVE, ST_OMP_DECLARE_MAPPER}, */ |
68 | {.name: "declare reduction" , .kind: GFC_OMP_DIR_DECLARATIVE, .st: ST_OMP_DECLARE_REDUCTION}, |
69 | {.name: "declare simd" , .kind: GFC_OMP_DIR_DECLARATIVE, .st: ST_OMP_DECLARE_SIMD}, |
70 | {.name: "declare target" , .kind: GFC_OMP_DIR_DECLARATIVE, .st: ST_OMP_DECLARE_TARGET}, |
71 | {.name: "declare variant" , .kind: GFC_OMP_DIR_DECLARATIVE, .st: ST_OMP_DECLARE_VARIANT}, |
72 | {.name: "depobj" , .kind: GFC_OMP_DIR_EXECUTABLE, .st: ST_OMP_DEPOBJ}, |
73 | /* {"dispatch", GFC_OMP_DIR_EXECUTABLE, ST_OMP_DISPATCH}, */ |
74 | {.name: "distribute" , .kind: GFC_OMP_DIR_EXECUTABLE, .st: ST_OMP_DISTRIBUTE}, |
75 | {.name: "do" , .kind: GFC_OMP_DIR_EXECUTABLE, .st: ST_OMP_DO}, |
76 | /* "error" becomes GFC_OMP_DIR_EXECUTABLE with at(execution) */ |
77 | {.name: "error" , .kind: GFC_OMP_DIR_UTILITY, .st: ST_OMP_ERROR}, |
78 | {.name: "flush" , .kind: GFC_OMP_DIR_EXECUTABLE, .st: ST_OMP_FLUSH}, |
79 | /* {"interop", GFC_OMP_DIR_EXECUTABLE, ST_OMP_INTEROP}, */ |
80 | {.name: "loop" , .kind: GFC_OMP_DIR_EXECUTABLE, .st: ST_OMP_LOOP}, |
81 | {.name: "masked" , .kind: GFC_OMP_DIR_EXECUTABLE, .st: ST_OMP_MASKED}, |
82 | /* {"metadirective", GFC_OMP_DIR_META, ST_OMP_METADIRECTIVE}, */ |
83 | /* Note: gfc_match_omp_nothing returns ST_NONE. */ |
84 | {.name: "nothing" , .kind: GFC_OMP_DIR_UTILITY, .st: ST_OMP_NOTHING}, |
85 | /* Special case; for now map to the first one. |
86 | ordered-blockassoc = ST_OMP_ORDERED |
87 | ordered-standalone = ST_OMP_ORDERED_DEPEND + depend/doacross. */ |
88 | {.name: "ordered" , .kind: GFC_OMP_DIR_EXECUTABLE, .st: ST_OMP_ORDERED}, |
89 | {.name: "parallel" , .kind: GFC_OMP_DIR_EXECUTABLE, .st: ST_OMP_PARALLEL}, |
90 | {.name: "requires" , .kind: GFC_OMP_DIR_INFORMATIONAL, .st: ST_OMP_REQUIRES}, |
91 | {.name: "scan" , .kind: GFC_OMP_DIR_SUBSIDIARY, .st: ST_OMP_SCAN}, |
92 | {.name: "scope" , .kind: GFC_OMP_DIR_EXECUTABLE, .st: ST_OMP_SCOPE}, |
93 | {.name: "sections" , .kind: GFC_OMP_DIR_EXECUTABLE, .st: ST_OMP_SECTIONS}, |
94 | {.name: "section" , .kind: GFC_OMP_DIR_SUBSIDIARY, .st: ST_OMP_SECTION}, |
95 | {.name: "simd" , .kind: GFC_OMP_DIR_EXECUTABLE, .st: ST_OMP_SIMD}, |
96 | {.name: "single" , .kind: GFC_OMP_DIR_EXECUTABLE, .st: ST_OMP_SINGLE}, |
97 | {.name: "target data" , .kind: GFC_OMP_DIR_EXECUTABLE, .st: ST_OMP_TARGET_DATA}, |
98 | {.name: "target enter data" , .kind: GFC_OMP_DIR_EXECUTABLE, .st: ST_OMP_TARGET_ENTER_DATA}, |
99 | {.name: "target exit data" , .kind: GFC_OMP_DIR_EXECUTABLE, .st: ST_OMP_TARGET_EXIT_DATA}, |
100 | {.name: "target update" , .kind: GFC_OMP_DIR_EXECUTABLE, .st: ST_OMP_TARGET_UPDATE}, |
101 | {.name: "target" , .kind: GFC_OMP_DIR_EXECUTABLE, .st: ST_OMP_TARGET}, |
102 | {.name: "taskloop" , .kind: GFC_OMP_DIR_EXECUTABLE, .st: ST_OMP_TASKLOOP}, |
103 | {.name: "taskwait" , .kind: GFC_OMP_DIR_EXECUTABLE, .st: ST_OMP_TASKWAIT}, |
104 | {.name: "taskyield" , .kind: GFC_OMP_DIR_EXECUTABLE, .st: ST_OMP_TASKYIELD}, |
105 | {.name: "task" , .kind: GFC_OMP_DIR_EXECUTABLE, .st: ST_OMP_TASK}, |
106 | {.name: "teams" , .kind: GFC_OMP_DIR_EXECUTABLE, .st: ST_OMP_TEAMS}, |
107 | {.name: "threadprivate" , .kind: GFC_OMP_DIR_DECLARATIVE, .st: ST_OMP_THREADPRIVATE}, |
108 | /* {"tile", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TILE}, */ |
109 | /* {"unroll", GFC_OMP_DIR_EXECUTABLE, ST_OMP_UNROLL}, */ |
110 | {.name: "workshare" , .kind: GFC_OMP_DIR_EXECUTABLE, .st: ST_OMP_WORKSHARE}, |
111 | }; |
112 | |
113 | |
114 | /* Match an end of OpenMP directive. End of OpenMP directive is optional |
115 | whitespace, followed by '\n' or comment '!'. */ |
116 | |
117 | static match |
118 | gfc_match_omp_eos (void) |
119 | { |
120 | locus old_loc; |
121 | char c; |
122 | |
123 | old_loc = gfc_current_locus; |
124 | gfc_gobble_whitespace (); |
125 | |
126 | c = gfc_next_ascii_char (); |
127 | switch (c) |
128 | { |
129 | case '!': |
130 | do |
131 | c = gfc_next_ascii_char (); |
132 | while (c != '\n'); |
133 | /* Fall through */ |
134 | |
135 | case '\n': |
136 | return MATCH_YES; |
137 | } |
138 | |
139 | gfc_current_locus = old_loc; |
140 | return MATCH_NO; |
141 | } |
142 | |
143 | match |
144 | gfc_match_omp_eos_error (void) |
145 | { |
146 | if (gfc_match_omp_eos() == MATCH_YES) |
147 | return MATCH_YES; |
148 | |
149 | gfc_error ("Unexpected junk at %C" ); |
150 | return MATCH_ERROR; |
151 | } |
152 | |
153 | |
154 | /* Free an omp_clauses structure. */ |
155 | |
156 | void |
157 | gfc_free_omp_clauses (gfc_omp_clauses *c) |
158 | { |
159 | int i; |
160 | if (c == NULL) |
161 | return; |
162 | |
163 | gfc_free_expr (c->if_expr); |
164 | for (i = 0; i < OMP_IF_LAST; i++) |
165 | gfc_free_expr (c->if_exprs[i]); |
166 | gfc_free_expr (c->final_expr); |
167 | gfc_free_expr (c->num_threads); |
168 | gfc_free_expr (c->chunk_size); |
169 | gfc_free_expr (c->safelen_expr); |
170 | gfc_free_expr (c->simdlen_expr); |
171 | gfc_free_expr (c->num_teams_lower); |
172 | gfc_free_expr (c->num_teams_upper); |
173 | gfc_free_expr (c->device); |
174 | gfc_free_expr (c->thread_limit); |
175 | gfc_free_expr (c->dist_chunk_size); |
176 | gfc_free_expr (c->grainsize); |
177 | gfc_free_expr (c->hint); |
178 | gfc_free_expr (c->num_tasks); |
179 | gfc_free_expr (c->priority); |
180 | gfc_free_expr (c->detach); |
181 | gfc_free_expr (c->async_expr); |
182 | gfc_free_expr (c->gang_num_expr); |
183 | gfc_free_expr (c->gang_static_expr); |
184 | gfc_free_expr (c->worker_expr); |
185 | gfc_free_expr (c->vector_expr); |
186 | gfc_free_expr (c->num_gangs_expr); |
187 | gfc_free_expr (c->num_workers_expr); |
188 | gfc_free_expr (c->vector_length_expr); |
189 | for (i = 0; i < OMP_LIST_NUM; i++) |
190 | gfc_free_omp_namelist (c->lists[i], |
191 | i == OMP_LIST_AFFINITY || i == OMP_LIST_DEPEND, |
192 | i == OMP_LIST_ALLOCATE, |
193 | i == OMP_LIST_USES_ALLOCATORS); |
194 | gfc_free_expr_list (c->wait_list); |
195 | gfc_free_expr_list (c->tile_list); |
196 | free (CONST_CAST (char *, c->critical_name)); |
197 | if (c->assume) |
198 | { |
199 | free (ptr: c->assume->absent); |
200 | free (ptr: c->assume->contains); |
201 | gfc_free_expr_list (c->assume->holds); |
202 | free (ptr: c->assume); |
203 | } |
204 | free (ptr: c); |
205 | } |
206 | |
207 | /* Free oacc_declare structures. */ |
208 | |
209 | void |
210 | gfc_free_oacc_declare_clauses (struct gfc_oacc_declare *oc) |
211 | { |
212 | struct gfc_oacc_declare *decl = oc; |
213 | |
214 | do |
215 | { |
216 | struct gfc_oacc_declare *next; |
217 | |
218 | next = decl->next; |
219 | gfc_free_omp_clauses (c: decl->clauses); |
220 | free (ptr: decl); |
221 | decl = next; |
222 | } |
223 | while (decl); |
224 | } |
225 | |
226 | /* Free expression list. */ |
227 | void |
228 | gfc_free_expr_list (gfc_expr_list *list) |
229 | { |
230 | gfc_expr_list *n; |
231 | |
232 | for (; list; list = n) |
233 | { |
234 | n = list->next; |
235 | free (ptr: list); |
236 | } |
237 | } |
238 | |
239 | /* Free an !$omp declare simd construct list. */ |
240 | |
241 | void |
242 | gfc_free_omp_declare_simd (gfc_omp_declare_simd *ods) |
243 | { |
244 | if (ods) |
245 | { |
246 | gfc_free_omp_clauses (c: ods->clauses); |
247 | free (ptr: ods); |
248 | } |
249 | } |
250 | |
251 | void |
252 | gfc_free_omp_declare_simd_list (gfc_omp_declare_simd *list) |
253 | { |
254 | while (list) |
255 | { |
256 | gfc_omp_declare_simd *current = list; |
257 | list = list->next; |
258 | gfc_free_omp_declare_simd (ods: current); |
259 | } |
260 | } |
261 | |
262 | static void |
263 | gfc_free_omp_trait_property_list (gfc_omp_trait_property *list) |
264 | { |
265 | while (list) |
266 | { |
267 | gfc_omp_trait_property *current = list; |
268 | list = list->next; |
269 | switch (current->property_kind) |
270 | { |
271 | case CTX_PROPERTY_ID: |
272 | free (ptr: current->name); |
273 | break; |
274 | case CTX_PROPERTY_NAME_LIST: |
275 | if (current->is_name) |
276 | free (ptr: current->name); |
277 | break; |
278 | case CTX_PROPERTY_SIMD: |
279 | gfc_free_omp_clauses (c: current->clauses); |
280 | break; |
281 | default: |
282 | break; |
283 | } |
284 | free (ptr: current); |
285 | } |
286 | } |
287 | |
288 | static void |
289 | gfc_free_omp_selector_list (gfc_omp_selector *list) |
290 | { |
291 | while (list) |
292 | { |
293 | gfc_omp_selector *current = list; |
294 | list = list->next; |
295 | gfc_free_omp_trait_property_list (list: current->properties); |
296 | free (ptr: current); |
297 | } |
298 | } |
299 | |
300 | static void |
301 | gfc_free_omp_set_selector_list (gfc_omp_set_selector *list) |
302 | { |
303 | while (list) |
304 | { |
305 | gfc_omp_set_selector *current = list; |
306 | list = list->next; |
307 | gfc_free_omp_selector_list (list: current->trait_selectors); |
308 | free (ptr: current); |
309 | } |
310 | } |
311 | |
312 | /* Free an !$omp declare variant construct list. */ |
313 | |
314 | void |
315 | gfc_free_omp_declare_variant_list (gfc_omp_declare_variant *list) |
316 | { |
317 | while (list) |
318 | { |
319 | gfc_omp_declare_variant *current = list; |
320 | list = list->next; |
321 | gfc_free_omp_set_selector_list (list: current->set_selectors); |
322 | free (ptr: current); |
323 | } |
324 | } |
325 | |
326 | /* Free an !$omp declare reduction. */ |
327 | |
328 | void |
329 | gfc_free_omp_udr (gfc_omp_udr *omp_udr) |
330 | { |
331 | if (omp_udr) |
332 | { |
333 | gfc_free_omp_udr (omp_udr: omp_udr->next); |
334 | gfc_free_namespace (omp_udr->combiner_ns); |
335 | if (omp_udr->initializer_ns) |
336 | gfc_free_namespace (omp_udr->initializer_ns); |
337 | free (ptr: omp_udr); |
338 | } |
339 | } |
340 | |
341 | |
342 | static gfc_omp_udr * |
343 | gfc_find_omp_udr (gfc_namespace *ns, const char *name, gfc_typespec *ts) |
344 | { |
345 | gfc_symtree *st; |
346 | |
347 | if (ns == NULL) |
348 | ns = gfc_current_ns; |
349 | do |
350 | { |
351 | gfc_omp_udr *omp_udr; |
352 | |
353 | st = gfc_find_symtree (ns->omp_udr_root, name); |
354 | if (st != NULL) |
355 | { |
356 | for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next) |
357 | if (ts == NULL) |
358 | return omp_udr; |
359 | else if (gfc_compare_types (&omp_udr->ts, ts)) |
360 | { |
361 | if (ts->type == BT_CHARACTER) |
362 | { |
363 | if (omp_udr->ts.u.cl->length == NULL) |
364 | return omp_udr; |
365 | if (ts->u.cl->length == NULL) |
366 | continue; |
367 | if (gfc_compare_expr (omp_udr->ts.u.cl->length, |
368 | ts->u.cl->length, |
369 | INTRINSIC_EQ) != 0) |
370 | continue; |
371 | } |
372 | return omp_udr; |
373 | } |
374 | } |
375 | |
376 | /* Don't escape an interface block. */ |
377 | if (ns && !ns->has_import_set |
378 | && ns->proc_name && ns->proc_name->attr.if_source == IFSRC_IFBODY) |
379 | break; |
380 | |
381 | ns = ns->parent; |
382 | } |
383 | while (ns != NULL); |
384 | |
385 | return NULL; |
386 | } |
387 | |
388 | |
389 | /* Match a variable/common block list and construct a namelist from it; |
390 | if has_all_memory != NULL, *has_all_memory is set and omp_all_memory |
391 | yields a list->sym NULL entry. */ |
392 | |
393 | static match |
394 | gfc_match_omp_variable_list (const char *str, gfc_omp_namelist **list, |
395 | bool allow_common, bool *end_colon = NULL, |
396 | gfc_omp_namelist ***headp = NULL, |
397 | bool allow_sections = false, |
398 | bool allow_derived = false, |
399 | bool *has_all_memory = NULL, |
400 | bool reject_common_vars = false) |
401 | { |
402 | gfc_omp_namelist *head, *tail, *p; |
403 | locus old_loc, cur_loc; |
404 | char n[GFC_MAX_SYMBOL_LEN+1]; |
405 | gfc_symbol *sym; |
406 | match m; |
407 | gfc_symtree *st; |
408 | |
409 | head = tail = NULL; |
410 | |
411 | old_loc = gfc_current_locus; |
412 | if (has_all_memory) |
413 | *has_all_memory = false; |
414 | m = gfc_match (str); |
415 | if (m != MATCH_YES) |
416 | return m; |
417 | |
418 | for (;;) |
419 | { |
420 | cur_loc = gfc_current_locus; |
421 | |
422 | m = gfc_match_name (n); |
423 | if (m == MATCH_YES && strcmp (s1: n, s2: "omp_all_memory" ) == 0) |
424 | { |
425 | if (!has_all_memory) |
426 | { |
427 | gfc_error ("%<omp_all_memory%> at %C not permitted in this " |
428 | "clause" ); |
429 | goto cleanup; |
430 | } |
431 | *has_all_memory = true; |
432 | p = gfc_get_omp_namelist (); |
433 | if (head == NULL) |
434 | head = tail = p; |
435 | else |
436 | { |
437 | tail->next = p; |
438 | tail = tail->next; |
439 | } |
440 | tail->where = cur_loc; |
441 | goto next_item; |
442 | } |
443 | if (m == MATCH_YES) |
444 | { |
445 | gfc_symtree *st; |
446 | if ((m = gfc_get_ha_sym_tree (n, &st) ? MATCH_ERROR : MATCH_YES) |
447 | == MATCH_YES) |
448 | sym = st->n.sym; |
449 | } |
450 | switch (m) |
451 | { |
452 | case MATCH_YES: |
453 | gfc_expr *expr; |
454 | expr = NULL; |
455 | gfc_gobble_whitespace (); |
456 | if ((allow_sections && gfc_peek_ascii_char () == '(') |
457 | || (allow_derived && gfc_peek_ascii_char () == '%')) |
458 | { |
459 | gfc_current_locus = cur_loc; |
460 | m = gfc_match_variable (&expr, 0); |
461 | switch (m) |
462 | { |
463 | case MATCH_ERROR: |
464 | goto cleanup; |
465 | case MATCH_NO: |
466 | goto syntax; |
467 | default: |
468 | break; |
469 | } |
470 | if (gfc_is_coindexed (expr)) |
471 | { |
472 | gfc_error ("List item shall not be coindexed at %C" ); |
473 | goto cleanup; |
474 | } |
475 | } |
476 | gfc_set_sym_referenced (sym); |
477 | p = gfc_get_omp_namelist (); |
478 | if (head == NULL) |
479 | head = tail = p; |
480 | else |
481 | { |
482 | tail->next = p; |
483 | tail = tail->next; |
484 | } |
485 | tail->sym = sym; |
486 | tail->expr = expr; |
487 | tail->where = cur_loc; |
488 | if (reject_common_vars && sym->attr.in_common) |
489 | { |
490 | gcc_assert (allow_common); |
491 | gfc_error ("%qs at %L is part of the common block %</%s/%> and " |
492 | "may only be specificed implicitly via the named " |
493 | "common block" , sym->name, &cur_loc, |
494 | sym->common_head->name); |
495 | goto cleanup; |
496 | } |
497 | goto next_item; |
498 | case MATCH_NO: |
499 | break; |
500 | case MATCH_ERROR: |
501 | goto cleanup; |
502 | } |
503 | |
504 | if (!allow_common) |
505 | goto syntax; |
506 | |
507 | m = gfc_match (" / %n /" , n); |
508 | if (m == MATCH_ERROR) |
509 | goto cleanup; |
510 | if (m == MATCH_NO) |
511 | goto syntax; |
512 | |
513 | st = gfc_find_symtree (gfc_current_ns->common_root, n); |
514 | if (st == NULL) |
515 | { |
516 | gfc_error ("COMMON block /%s/ not found at %C" , n); |
517 | goto cleanup; |
518 | } |
519 | for (sym = st->n.common->head; sym; sym = sym->common_next) |
520 | { |
521 | gfc_set_sym_referenced (sym); |
522 | p = gfc_get_omp_namelist (); |
523 | if (head == NULL) |
524 | head = tail = p; |
525 | else |
526 | { |
527 | tail->next = p; |
528 | tail = tail->next; |
529 | } |
530 | tail->sym = sym; |
531 | tail->where = cur_loc; |
532 | } |
533 | |
534 | next_item: |
535 | if (end_colon && gfc_match_char (':') == MATCH_YES) |
536 | { |
537 | *end_colon = true; |
538 | break; |
539 | } |
540 | if (gfc_match_char (')') == MATCH_YES) |
541 | break; |
542 | if (gfc_match_char (',') != MATCH_YES) |
543 | goto syntax; |
544 | } |
545 | |
546 | while (*list) |
547 | list = &(*list)->next; |
548 | |
549 | *list = head; |
550 | if (headp) |
551 | *headp = list; |
552 | return MATCH_YES; |
553 | |
554 | syntax: |
555 | gfc_error ("Syntax error in OpenMP variable list at %C" ); |
556 | |
557 | cleanup: |
558 | gfc_free_omp_namelist (head, false, false, false); |
559 | gfc_current_locus = old_loc; |
560 | return MATCH_ERROR; |
561 | } |
562 | |
563 | /* Match a variable/procedure/common block list and construct a namelist |
564 | from it. */ |
565 | |
566 | static match |
567 | gfc_match_omp_to_link (const char *str, gfc_omp_namelist **list) |
568 | { |
569 | gfc_omp_namelist *head, *tail, *p; |
570 | locus old_loc, cur_loc; |
571 | char n[GFC_MAX_SYMBOL_LEN+1]; |
572 | gfc_symbol *sym; |
573 | match m; |
574 | gfc_symtree *st; |
575 | |
576 | head = tail = NULL; |
577 | |
578 | old_loc = gfc_current_locus; |
579 | |
580 | m = gfc_match (str); |
581 | if (m != MATCH_YES) |
582 | return m; |
583 | |
584 | for (;;) |
585 | { |
586 | cur_loc = gfc_current_locus; |
587 | m = gfc_match_symbol (&sym, 1); |
588 | switch (m) |
589 | { |
590 | case MATCH_YES: |
591 | p = gfc_get_omp_namelist (); |
592 | if (head == NULL) |
593 | head = tail = p; |
594 | else |
595 | { |
596 | tail->next = p; |
597 | tail = tail->next; |
598 | } |
599 | tail->sym = sym; |
600 | tail->where = cur_loc; |
601 | goto next_item; |
602 | case MATCH_NO: |
603 | break; |
604 | case MATCH_ERROR: |
605 | goto cleanup; |
606 | } |
607 | |
608 | m = gfc_match (" / %n /" , n); |
609 | if (m == MATCH_ERROR) |
610 | goto cleanup; |
611 | if (m == MATCH_NO) |
612 | goto syntax; |
613 | |
614 | st = gfc_find_symtree (gfc_current_ns->common_root, n); |
615 | if (st == NULL) |
616 | { |
617 | gfc_error ("COMMON block /%s/ not found at %C" , n); |
618 | goto cleanup; |
619 | } |
620 | p = gfc_get_omp_namelist (); |
621 | if (head == NULL) |
622 | head = tail = p; |
623 | else |
624 | { |
625 | tail->next = p; |
626 | tail = tail->next; |
627 | } |
628 | tail->u.common = st->n.common; |
629 | tail->where = cur_loc; |
630 | |
631 | next_item: |
632 | if (gfc_match_char (')') == MATCH_YES) |
633 | break; |
634 | if (gfc_match_char (',') != MATCH_YES) |
635 | goto syntax; |
636 | } |
637 | |
638 | while (*list) |
639 | list = &(*list)->next; |
640 | |
641 | *list = head; |
642 | return MATCH_YES; |
643 | |
644 | syntax: |
645 | gfc_error ("Syntax error in OpenMP variable list at %C" ); |
646 | |
647 | cleanup: |
648 | gfc_free_omp_namelist (head, false, false, false); |
649 | gfc_current_locus = old_loc; |
650 | return MATCH_ERROR; |
651 | } |
652 | |
653 | /* Match detach(event-handle). */ |
654 | |
655 | static match |
656 | gfc_match_omp_detach (gfc_expr **expr) |
657 | { |
658 | locus old_loc = gfc_current_locus; |
659 | |
660 | if (gfc_match ("detach ( " ) != MATCH_YES) |
661 | goto syntax_error; |
662 | |
663 | if (gfc_match_variable (expr, 0) != MATCH_YES) |
664 | goto syntax_error; |
665 | |
666 | if (gfc_match_char (')') != MATCH_YES) |
667 | goto syntax_error; |
668 | |
669 | return MATCH_YES; |
670 | |
671 | syntax_error: |
672 | gfc_error ("Syntax error in OpenMP detach clause at %C" ); |
673 | gfc_current_locus = old_loc; |
674 | return MATCH_ERROR; |
675 | |
676 | } |
677 | |
678 | /* Match doacross(sink : ...) construct a namelist from it; |
679 | if depend is true, match legacy 'depend(sink : ...)'. */ |
680 | |
681 | static match |
682 | gfc_match_omp_doacross_sink (gfc_omp_namelist **list, bool depend) |
683 | { |
684 | char n[GFC_MAX_SYMBOL_LEN+1]; |
685 | gfc_omp_namelist *head, *tail, *p; |
686 | locus old_loc, cur_loc; |
687 | gfc_symbol *sym; |
688 | |
689 | head = tail = NULL; |
690 | |
691 | old_loc = gfc_current_locus; |
692 | |
693 | for (;;) |
694 | { |
695 | cur_loc = gfc_current_locus; |
696 | |
697 | if (gfc_match_name (n) != MATCH_YES) |
698 | goto syntax; |
699 | if (UNLIKELY (strcmp (n, "omp_all_memory" ) == 0)) |
700 | { |
701 | gfc_error ("%<omp_all_memory%> used with dependence-type " |
702 | "other than OUT or INOUT at %C" ); |
703 | goto cleanup; |
704 | } |
705 | sym = NULL; |
706 | if (!(strcmp (s1: n, s2: "omp_cur_iteration" ) == 0)) |
707 | { |
708 | gfc_symtree *st; |
709 | if (gfc_get_ha_sym_tree (n, &st)) |
710 | goto syntax; |
711 | sym = st->n.sym; |
712 | gfc_set_sym_referenced (sym); |
713 | } |
714 | p = gfc_get_omp_namelist (); |
715 | if (head == NULL) |
716 | { |
717 | head = tail = p; |
718 | head->u.depend_doacross_op = (depend ? OMP_DEPEND_SINK_FIRST |
719 | : OMP_DOACROSS_SINK_FIRST); |
720 | } |
721 | else |
722 | { |
723 | tail->next = p; |
724 | tail = tail->next; |
725 | tail->u.depend_doacross_op = OMP_DOACROSS_SINK; |
726 | } |
727 | tail->sym = sym; |
728 | tail->expr = NULL; |
729 | tail->where = cur_loc; |
730 | if (gfc_match_char ('+') == MATCH_YES) |
731 | { |
732 | if (gfc_match_literal_constant (&tail->expr, 0) != MATCH_YES) |
733 | goto syntax; |
734 | } |
735 | else if (gfc_match_char ('-') == MATCH_YES) |
736 | { |
737 | if (gfc_match_literal_constant (&tail->expr, 0) != MATCH_YES) |
738 | goto syntax; |
739 | tail->expr = gfc_uminus (op: tail->expr); |
740 | } |
741 | if (gfc_match_char (')') == MATCH_YES) |
742 | break; |
743 | if (gfc_match_char (',') != MATCH_YES) |
744 | goto syntax; |
745 | } |
746 | |
747 | while (*list) |
748 | list = &(*list)->next; |
749 | |
750 | *list = head; |
751 | return MATCH_YES; |
752 | |
753 | syntax: |
754 | gfc_error ("Syntax error in OpenMP SINK dependence-type list at %C" ); |
755 | |
756 | cleanup: |
757 | gfc_free_omp_namelist (head, false, false, false); |
758 | gfc_current_locus = old_loc; |
759 | return MATCH_ERROR; |
760 | } |
761 | |
762 | static match |
763 | match_oacc_expr_list (const char *str, gfc_expr_list **list, |
764 | bool allow_asterisk) |
765 | { |
766 | gfc_expr_list *head, *tail, *p; |
767 | locus old_loc; |
768 | gfc_expr *expr; |
769 | match m; |
770 | |
771 | head = tail = NULL; |
772 | |
773 | old_loc = gfc_current_locus; |
774 | |
775 | m = gfc_match (str); |
776 | if (m != MATCH_YES) |
777 | return m; |
778 | |
779 | for (;;) |
780 | { |
781 | m = gfc_match_expr (&expr); |
782 | if (m == MATCH_YES || allow_asterisk) |
783 | { |
784 | p = gfc_get_expr_list (); |
785 | if (head == NULL) |
786 | head = tail = p; |
787 | else |
788 | { |
789 | tail->next = p; |
790 | tail = tail->next; |
791 | } |
792 | if (m == MATCH_YES) |
793 | tail->expr = expr; |
794 | else if (gfc_match (" *" ) != MATCH_YES) |
795 | goto syntax; |
796 | goto next_item; |
797 | } |
798 | if (m == MATCH_ERROR) |
799 | goto cleanup; |
800 | goto syntax; |
801 | |
802 | next_item: |
803 | if (gfc_match_char (')') == MATCH_YES) |
804 | break; |
805 | if (gfc_match_char (',') != MATCH_YES) |
806 | goto syntax; |
807 | } |
808 | |
809 | while (*list) |
810 | list = &(*list)->next; |
811 | |
812 | *list = head; |
813 | return MATCH_YES; |
814 | |
815 | syntax: |
816 | gfc_error ("Syntax error in OpenACC expression list at %C" ); |
817 | |
818 | cleanup: |
819 | gfc_free_expr_list (list: head); |
820 | gfc_current_locus = old_loc; |
821 | return MATCH_ERROR; |
822 | } |
823 | |
824 | static match |
825 | match_oacc_clause_gwv (gfc_omp_clauses *cp, unsigned gwv) |
826 | { |
827 | match ret = MATCH_YES; |
828 | |
829 | if (gfc_match (" ( " ) != MATCH_YES) |
830 | return MATCH_NO; |
831 | |
832 | if (gwv == GOMP_DIM_GANG) |
833 | { |
834 | /* The gang clause accepts two optional arguments, num and static. |
835 | The num argument may either be explicit (num: <val>) or |
836 | implicit without (<val> without num:). */ |
837 | |
838 | while (ret == MATCH_YES) |
839 | { |
840 | if (gfc_match (" static :" ) == MATCH_YES) |
841 | { |
842 | if (cp->gang_static) |
843 | return MATCH_ERROR; |
844 | else |
845 | cp->gang_static = true; |
846 | if (gfc_match_char ('*') == MATCH_YES) |
847 | cp->gang_static_expr = NULL; |
848 | else if (gfc_match (" %e " , &cp->gang_static_expr) != MATCH_YES) |
849 | return MATCH_ERROR; |
850 | } |
851 | else |
852 | { |
853 | if (cp->gang_num_expr) |
854 | return MATCH_ERROR; |
855 | |
856 | /* The 'num' argument is optional. */ |
857 | gfc_match (" num :" ); |
858 | |
859 | if (gfc_match (" %e " , &cp->gang_num_expr) != MATCH_YES) |
860 | return MATCH_ERROR; |
861 | } |
862 | |
863 | ret = gfc_match (" , " ); |
864 | } |
865 | } |
866 | else if (gwv == GOMP_DIM_WORKER) |
867 | { |
868 | /* The 'num' argument is optional. */ |
869 | gfc_match (" num :" ); |
870 | |
871 | if (gfc_match (" %e " , &cp->worker_expr) != MATCH_YES) |
872 | return MATCH_ERROR; |
873 | } |
874 | else if (gwv == GOMP_DIM_VECTOR) |
875 | { |
876 | /* The 'length' argument is optional. */ |
877 | gfc_match (" length :" ); |
878 | |
879 | if (gfc_match (" %e " , &cp->vector_expr) != MATCH_YES) |
880 | return MATCH_ERROR; |
881 | } |
882 | else |
883 | gfc_fatal_error ("Unexpected OpenACC parallelism." ); |
884 | |
885 | return gfc_match (" )" ); |
886 | } |
887 | |
888 | static match |
889 | gfc_match_oacc_clause_link (const char *str, gfc_omp_namelist **list) |
890 | { |
891 | gfc_omp_namelist *head = NULL; |
892 | gfc_omp_namelist *tail, *p; |
893 | locus old_loc; |
894 | char n[GFC_MAX_SYMBOL_LEN+1]; |
895 | gfc_symbol *sym; |
896 | match m; |
897 | gfc_symtree *st; |
898 | |
899 | old_loc = gfc_current_locus; |
900 | |
901 | m = gfc_match (str); |
902 | if (m != MATCH_YES) |
903 | return m; |
904 | |
905 | m = gfc_match (" (" ); |
906 | |
907 | for (;;) |
908 | { |
909 | m = gfc_match_symbol (&sym, 0); |
910 | switch (m) |
911 | { |
912 | case MATCH_YES: |
913 | if (sym->attr.in_common) |
914 | { |
915 | gfc_error_now ("Variable at %C is an element of a COMMON block" ); |
916 | goto cleanup; |
917 | } |
918 | gfc_set_sym_referenced (sym); |
919 | p = gfc_get_omp_namelist (); |
920 | if (head == NULL) |
921 | head = tail = p; |
922 | else |
923 | { |
924 | tail->next = p; |
925 | tail = tail->next; |
926 | } |
927 | tail->sym = sym; |
928 | tail->expr = NULL; |
929 | tail->where = gfc_current_locus; |
930 | goto next_item; |
931 | case MATCH_NO: |
932 | break; |
933 | |
934 | case MATCH_ERROR: |
935 | goto cleanup; |
936 | } |
937 | |
938 | m = gfc_match (" / %n /" , n); |
939 | if (m == MATCH_ERROR) |
940 | goto cleanup; |
941 | if (m == MATCH_NO || n[0] == '\0') |
942 | goto syntax; |
943 | |
944 | st = gfc_find_symtree (gfc_current_ns->common_root, n); |
945 | if (st == NULL) |
946 | { |
947 | gfc_error ("COMMON block /%s/ not found at %C" , n); |
948 | goto cleanup; |
949 | } |
950 | |
951 | for (sym = st->n.common->head; sym; sym = sym->common_next) |
952 | { |
953 | gfc_set_sym_referenced (sym); |
954 | p = gfc_get_omp_namelist (); |
955 | if (head == NULL) |
956 | head = tail = p; |
957 | else |
958 | { |
959 | tail->next = p; |
960 | tail = tail->next; |
961 | } |
962 | tail->sym = sym; |
963 | tail->where = gfc_current_locus; |
964 | } |
965 | |
966 | next_item: |
967 | if (gfc_match_char (')') == MATCH_YES) |
968 | break; |
969 | if (gfc_match_char (',') != MATCH_YES) |
970 | goto syntax; |
971 | } |
972 | |
973 | if (gfc_match_omp_eos () != MATCH_YES) |
974 | { |
975 | gfc_error ("Unexpected junk after !$ACC DECLARE at %C" ); |
976 | goto cleanup; |
977 | } |
978 | |
979 | while (*list) |
980 | list = &(*list)->next; |
981 | *list = head; |
982 | return MATCH_YES; |
983 | |
984 | syntax: |
985 | gfc_error ("Syntax error in !$ACC DECLARE list at %C" ); |
986 | |
987 | cleanup: |
988 | gfc_current_locus = old_loc; |
989 | return MATCH_ERROR; |
990 | } |
991 | |
992 | /* OpenMP clauses. */ |
993 | enum omp_mask1 |
994 | { |
995 | OMP_CLAUSE_PRIVATE, |
996 | OMP_CLAUSE_FIRSTPRIVATE, |
997 | OMP_CLAUSE_LASTPRIVATE, |
998 | OMP_CLAUSE_COPYPRIVATE, |
999 | OMP_CLAUSE_SHARED, |
1000 | OMP_CLAUSE_COPYIN, |
1001 | OMP_CLAUSE_REDUCTION, |
1002 | OMP_CLAUSE_IN_REDUCTION, |
1003 | OMP_CLAUSE_TASK_REDUCTION, |
1004 | OMP_CLAUSE_IF, |
1005 | OMP_CLAUSE_NUM_THREADS, |
1006 | OMP_CLAUSE_SCHEDULE, |
1007 | OMP_CLAUSE_DEFAULT, |
1008 | OMP_CLAUSE_ORDER, |
1009 | OMP_CLAUSE_ORDERED, |
1010 | OMP_CLAUSE_COLLAPSE, |
1011 | OMP_CLAUSE_UNTIED, |
1012 | OMP_CLAUSE_FINAL, |
1013 | OMP_CLAUSE_MERGEABLE, |
1014 | OMP_CLAUSE_ALIGNED, |
1015 | OMP_CLAUSE_DEPEND, |
1016 | OMP_CLAUSE_INBRANCH, |
1017 | OMP_CLAUSE_LINEAR, |
1018 | OMP_CLAUSE_NOTINBRANCH, |
1019 | OMP_CLAUSE_PROC_BIND, |
1020 | OMP_CLAUSE_SAFELEN, |
1021 | OMP_CLAUSE_SIMDLEN, |
1022 | OMP_CLAUSE_UNIFORM, |
1023 | OMP_CLAUSE_DEVICE, |
1024 | OMP_CLAUSE_MAP, |
1025 | OMP_CLAUSE_TO, |
1026 | OMP_CLAUSE_FROM, |
1027 | OMP_CLAUSE_NUM_TEAMS, |
1028 | OMP_CLAUSE_THREAD_LIMIT, |
1029 | OMP_CLAUSE_DIST_SCHEDULE, |
1030 | OMP_CLAUSE_DEFAULTMAP, |
1031 | OMP_CLAUSE_GRAINSIZE, |
1032 | OMP_CLAUSE_HINT, |
1033 | OMP_CLAUSE_IS_DEVICE_PTR, |
1034 | OMP_CLAUSE_LINK, |
1035 | OMP_CLAUSE_NOGROUP, |
1036 | OMP_CLAUSE_NOTEMPORAL, |
1037 | OMP_CLAUSE_NUM_TASKS, |
1038 | OMP_CLAUSE_PRIORITY, |
1039 | OMP_CLAUSE_SIMD, |
1040 | OMP_CLAUSE_THREADS, |
1041 | OMP_CLAUSE_USE_DEVICE_PTR, |
1042 | OMP_CLAUSE_USE_DEVICE_ADDR, /* OpenMP 5.0. */ |
1043 | OMP_CLAUSE_DEVICE_TYPE, /* OpenMP 5.0. */ |
1044 | OMP_CLAUSE_ATOMIC, /* OpenMP 5.0. */ |
1045 | OMP_CLAUSE_CAPTURE, /* OpenMP 5.0. */ |
1046 | OMP_CLAUSE_MEMORDER, /* OpenMP 5.0. */ |
1047 | OMP_CLAUSE_DETACH, /* OpenMP 5.0. */ |
1048 | OMP_CLAUSE_AFFINITY, /* OpenMP 5.0. */ |
1049 | OMP_CLAUSE_ALLOCATE, /* OpenMP 5.0. */ |
1050 | OMP_CLAUSE_BIND, /* OpenMP 5.0. */ |
1051 | OMP_CLAUSE_FILTER, /* OpenMP 5.1. */ |
1052 | OMP_CLAUSE_AT, /* OpenMP 5.1. */ |
1053 | OMP_CLAUSE_MESSAGE, /* OpenMP 5.1. */ |
1054 | OMP_CLAUSE_SEVERITY, /* OpenMP 5.1. */ |
1055 | OMP_CLAUSE_COMPARE, /* OpenMP 5.1. */ |
1056 | OMP_CLAUSE_FAIL, /* OpenMP 5.1. */ |
1057 | OMP_CLAUSE_WEAK, /* OpenMP 5.1. */ |
1058 | OMP_CLAUSE_NOWAIT, |
1059 | /* This must come last. */ |
1060 | OMP_MASK1_LAST |
1061 | }; |
1062 | |
1063 | /* More OpenMP clauses and OpenACC 2.0+ specific clauses. */ |
1064 | enum omp_mask2 |
1065 | { |
1066 | OMP_CLAUSE_ASYNC, |
1067 | OMP_CLAUSE_NUM_GANGS, |
1068 | OMP_CLAUSE_NUM_WORKERS, |
1069 | OMP_CLAUSE_VECTOR_LENGTH, |
1070 | OMP_CLAUSE_COPY, |
1071 | OMP_CLAUSE_COPYOUT, |
1072 | OMP_CLAUSE_CREATE, |
1073 | OMP_CLAUSE_NO_CREATE, |
1074 | OMP_CLAUSE_PRESENT, |
1075 | OMP_CLAUSE_DEVICEPTR, |
1076 | OMP_CLAUSE_GANG, |
1077 | OMP_CLAUSE_WORKER, |
1078 | OMP_CLAUSE_VECTOR, |
1079 | OMP_CLAUSE_SEQ, |
1080 | OMP_CLAUSE_INDEPENDENT, |
1081 | OMP_CLAUSE_USE_DEVICE, |
1082 | OMP_CLAUSE_DEVICE_RESIDENT, |
1083 | OMP_CLAUSE_SELF, |
1084 | OMP_CLAUSE_HOST, |
1085 | OMP_CLAUSE_WAIT, |
1086 | OMP_CLAUSE_DELETE, |
1087 | OMP_CLAUSE_AUTO, |
1088 | OMP_CLAUSE_TILE, |
1089 | OMP_CLAUSE_IF_PRESENT, |
1090 | OMP_CLAUSE_FINALIZE, |
1091 | OMP_CLAUSE_ATTACH, |
1092 | OMP_CLAUSE_NOHOST, |
1093 | OMP_CLAUSE_HAS_DEVICE_ADDR, /* OpenMP 5.1 */ |
1094 | OMP_CLAUSE_ENTER, /* OpenMP 5.2 */ |
1095 | OMP_CLAUSE_DOACROSS, /* OpenMP 5.2 */ |
1096 | OMP_CLAUSE_ASSUMPTIONS, /* OpenMP 5.1. */ |
1097 | OMP_CLAUSE_USES_ALLOCATORS, /* OpenMP 5.0 */ |
1098 | /* This must come last. */ |
1099 | OMP_MASK2_LAST |
1100 | }; |
1101 | |
1102 | struct omp_inv_mask; |
1103 | |
1104 | /* Customized bitset for up to 128-bits. |
1105 | The two enums above provide bit numbers to use, and which of the |
1106 | two enums it is determines which of the two mask fields is used. |
1107 | Supported operations are defining a mask, like: |
1108 | #define XXX_CLAUSES \ |
1109 | (omp_mask (OMP_CLAUSE_XXX) | OMP_CLAUSE_YYY | OMP_CLAUSE_ZZZ) |
1110 | oring such bitsets together or removing selected bits: |
1111 | (XXX_CLAUSES | YYY_CLAUSES) & ~(omp_mask (OMP_CLAUSE_VVV)) |
1112 | and testing individual bits: |
1113 | if (mask & OMP_CLAUSE_UUU) */ |
1114 | |
1115 | struct omp_mask { |
1116 | const uint64_t mask1; |
1117 | const uint64_t mask2; |
1118 | inline omp_mask (); |
1119 | inline omp_mask (omp_mask1); |
1120 | inline omp_mask (omp_mask2); |
1121 | inline omp_mask (uint64_t, uint64_t); |
1122 | inline omp_mask operator| (omp_mask1) const; |
1123 | inline omp_mask operator| (omp_mask2) const; |
1124 | inline omp_mask operator| (omp_mask) const; |
1125 | inline omp_mask operator& (const omp_inv_mask &) const; |
1126 | inline bool operator& (omp_mask1) const; |
1127 | inline bool operator& (omp_mask2) const; |
1128 | inline omp_inv_mask operator~ () const; |
1129 | }; |
1130 | |
1131 | struct omp_inv_mask : public omp_mask { |
1132 | inline omp_inv_mask (const omp_mask &); |
1133 | }; |
1134 | |
1135 | omp_mask::omp_mask () : mask1 (0), mask2 (0) |
1136 | { |
1137 | } |
1138 | |
1139 | omp_mask::omp_mask (omp_mask1 m) : mask1 (((uint64_t) 1) << m), mask2 (0) |
1140 | { |
1141 | } |
1142 | |
1143 | omp_mask::omp_mask (omp_mask2 m) : mask1 (0), mask2 (((uint64_t) 1) << m) |
1144 | { |
1145 | } |
1146 | |
1147 | omp_mask::omp_mask (uint64_t m1, uint64_t m2) : mask1 (m1), mask2 (m2) |
1148 | { |
1149 | } |
1150 | |
1151 | omp_mask |
1152 | omp_mask::operator| (omp_mask1 m) const |
1153 | { |
1154 | return omp_mask (mask1 | (((uint64_t) 1) << m), mask2); |
1155 | } |
1156 | |
1157 | omp_mask |
1158 | omp_mask::operator| (omp_mask2 m) const |
1159 | { |
1160 | return omp_mask (mask1, mask2 | (((uint64_t) 1) << m)); |
1161 | } |
1162 | |
1163 | omp_mask |
1164 | omp_mask::operator| (omp_mask m) const |
1165 | { |
1166 | return omp_mask (mask1 | m.mask1, mask2 | m.mask2); |
1167 | } |
1168 | |
1169 | omp_mask |
1170 | omp_mask::operator& (const omp_inv_mask &m) const |
1171 | { |
1172 | return omp_mask (mask1 & ~m.mask1, mask2 & ~m.mask2); |
1173 | } |
1174 | |
1175 | bool |
1176 | omp_mask::operator& (omp_mask1 m) const |
1177 | { |
1178 | return (mask1 & (((uint64_t) 1) << m)) != 0; |
1179 | } |
1180 | |
1181 | bool |
1182 | omp_mask::operator& (omp_mask2 m) const |
1183 | { |
1184 | return (mask2 & (((uint64_t) 1) << m)) != 0; |
1185 | } |
1186 | |
1187 | omp_inv_mask |
1188 | omp_mask::operator~ () const |
1189 | { |
1190 | return omp_inv_mask (*this); |
1191 | } |
1192 | |
1193 | omp_inv_mask::omp_inv_mask (const omp_mask &m) : omp_mask (m) |
1194 | { |
1195 | } |
1196 | |
1197 | /* Helper function for OpenACC and OpenMP clauses involving memory |
1198 | mapping. */ |
1199 | |
1200 | static bool |
1201 | gfc_match_omp_map_clause (gfc_omp_namelist **list, gfc_omp_map_op map_op, |
1202 | bool allow_common, bool allow_derived) |
1203 | { |
1204 | gfc_omp_namelist **head = NULL; |
1205 | if (gfc_match_omp_variable_list (str: "" , list, allow_common, NULL, headp: &head, allow_sections: true, |
1206 | allow_derived) |
1207 | == MATCH_YES) |
1208 | { |
1209 | gfc_omp_namelist *n; |
1210 | for (n = *head; n; n = n->next) |
1211 | n->u.map_op = map_op; |
1212 | return true; |
1213 | } |
1214 | |
1215 | return false; |
1216 | } |
1217 | |
1218 | static match |
1219 | gfc_match_iterator (gfc_namespace **ns, bool permit_var) |
1220 | { |
1221 | locus old_loc = gfc_current_locus; |
1222 | |
1223 | if (gfc_match ("iterator ( " ) != MATCH_YES) |
1224 | return MATCH_NO; |
1225 | |
1226 | gfc_typespec ts; |
1227 | gfc_symbol *last = NULL; |
1228 | gfc_expr *begin, *end, *step; |
1229 | *ns = gfc_build_block_ns (gfc_current_ns); |
1230 | char name[GFC_MAX_SYMBOL_LEN + 1]; |
1231 | while (true) |
1232 | { |
1233 | locus prev_loc = gfc_current_locus; |
1234 | if (gfc_match_type_spec (&ts) == MATCH_YES |
1235 | && gfc_match (" :: " ) == MATCH_YES) |
1236 | { |
1237 | if (ts.type != BT_INTEGER) |
1238 | { |
1239 | gfc_error ("Expected INTEGER type at %L" , &prev_loc); |
1240 | return MATCH_ERROR; |
1241 | } |
1242 | permit_var = false; |
1243 | } |
1244 | else |
1245 | { |
1246 | ts.type = BT_INTEGER; |
1247 | ts.kind = gfc_default_integer_kind; |
1248 | gfc_current_locus = prev_loc; |
1249 | } |
1250 | prev_loc = gfc_current_locus; |
1251 | if (gfc_match_name (name) != MATCH_YES) |
1252 | { |
1253 | gfc_error ("Expected identifier at %C" ); |
1254 | goto failed; |
1255 | } |
1256 | if (gfc_find_symtree ((*ns)->sym_root, name)) |
1257 | { |
1258 | gfc_error ("Same identifier %qs specified again at %C" , name); |
1259 | goto failed; |
1260 | } |
1261 | |
1262 | gfc_symbol *sym = gfc_new_symbol (name, *ns); |
1263 | if (last) |
1264 | last->tlink = sym; |
1265 | else |
1266 | (*ns)->omp_affinity_iterators = sym; |
1267 | last = sym; |
1268 | sym->declared_at = prev_loc; |
1269 | sym->ts = ts; |
1270 | sym->attr.flavor = FL_VARIABLE; |
1271 | sym->attr.artificial = 1; |
1272 | sym->attr.referenced = 1; |
1273 | sym->refs++; |
1274 | gfc_symtree *st = gfc_new_symtree (&(*ns)->sym_root, name); |
1275 | st->n.sym = sym; |
1276 | |
1277 | prev_loc = gfc_current_locus; |
1278 | if (gfc_match (" = " ) != MATCH_YES) |
1279 | goto failed; |
1280 | permit_var = false; |
1281 | begin = end = step = NULL; |
1282 | if (gfc_match ("%e : " , &begin) != MATCH_YES |
1283 | || gfc_match ("%e " , &end) != MATCH_YES) |
1284 | { |
1285 | gfc_error ("Expected range-specification at %C" ); |
1286 | gfc_free_expr (begin); |
1287 | gfc_free_expr (end); |
1288 | return MATCH_ERROR; |
1289 | } |
1290 | if (':' == gfc_peek_ascii_char ()) |
1291 | { |
1292 | if (gfc_match (": %e " , &step) != MATCH_YES) |
1293 | { |
1294 | gfc_free_expr (begin); |
1295 | gfc_free_expr (end); |
1296 | gfc_free_expr (step); |
1297 | goto failed; |
1298 | } |
1299 | } |
1300 | |
1301 | gfc_expr *e = gfc_get_expr (); |
1302 | e->where = prev_loc; |
1303 | e->expr_type = EXPR_ARRAY; |
1304 | e->ts = ts; |
1305 | e->rank = 1; |
1306 | e->shape = gfc_get_shape (1); |
1307 | mpz_init_set_ui (e->shape[0], step ? 3 : 2); |
1308 | gfc_constructor_append_expr (base: &e->value.constructor, e: begin, where: &begin->where); |
1309 | gfc_constructor_append_expr (base: &e->value.constructor, e: end, where: &end->where); |
1310 | if (step) |
1311 | gfc_constructor_append_expr (base: &e->value.constructor, e: step, where: &step->where); |
1312 | sym->value = e; |
1313 | |
1314 | if (gfc_match (") " ) == MATCH_YES) |
1315 | break; |
1316 | if (gfc_match (", " ) != MATCH_YES) |
1317 | goto failed; |
1318 | } |
1319 | return MATCH_YES; |
1320 | |
1321 | failed: |
1322 | gfc_namespace *prev_ns = NULL; |
1323 | for (gfc_namespace *it = gfc_current_ns->contained; it; it = it->sibling) |
1324 | { |
1325 | if (it == *ns) |
1326 | { |
1327 | if (prev_ns) |
1328 | prev_ns->sibling = it->sibling; |
1329 | else |
1330 | gfc_current_ns->contained = it->sibling; |
1331 | gfc_free_namespace (it); |
1332 | break; |
1333 | } |
1334 | prev_ns = it; |
1335 | } |
1336 | *ns = NULL; |
1337 | if (!permit_var) |
1338 | return MATCH_ERROR; |
1339 | gfc_current_locus = old_loc; |
1340 | return MATCH_NO; |
1341 | } |
1342 | |
1343 | /* Match target update's to/from( [present:] var-list). */ |
1344 | |
1345 | static match |
1346 | gfc_match_motion_var_list (const char *str, gfc_omp_namelist **list, |
1347 | gfc_omp_namelist ***headp) |
1348 | { |
1349 | match m = gfc_match (str); |
1350 | if (m != MATCH_YES) |
1351 | return m; |
1352 | |
1353 | match m_present = gfc_match (" present : " ); |
1354 | |
1355 | m = gfc_match_omp_variable_list (str: "" , list, allow_common: false, NULL, headp, allow_sections: true, allow_derived: true); |
1356 | if (m != MATCH_YES) |
1357 | return m; |
1358 | if (m_present == MATCH_YES) |
1359 | { |
1360 | gfc_omp_namelist *n; |
1361 | for (n = **headp; n; n = n->next) |
1362 | n->u.present_modifier = true; |
1363 | } |
1364 | return MATCH_YES; |
1365 | } |
1366 | |
1367 | /* reduction ( reduction-modifier, reduction-operator : variable-list ) |
1368 | in_reduction ( reduction-operator : variable-list ) |
1369 | task_reduction ( reduction-operator : variable-list ) */ |
1370 | |
1371 | static match |
1372 | gfc_match_omp_clause_reduction (char pc, gfc_omp_clauses *c, bool openacc, |
1373 | bool allow_derived, bool openmp_target = false) |
1374 | { |
1375 | if (pc == 'r' && gfc_match ("reduction ( " ) != MATCH_YES) |
1376 | return MATCH_NO; |
1377 | else if (pc == 'i' && gfc_match ("in_reduction ( " ) != MATCH_YES) |
1378 | return MATCH_NO; |
1379 | else if (pc == 't' && gfc_match ("task_reduction ( " ) != MATCH_YES) |
1380 | return MATCH_NO; |
1381 | |
1382 | locus old_loc = gfc_current_locus; |
1383 | int list_idx = 0; |
1384 | |
1385 | if (pc == 'r' && !openacc) |
1386 | { |
1387 | if (gfc_match ("inscan" ) == MATCH_YES) |
1388 | list_idx = OMP_LIST_REDUCTION_INSCAN; |
1389 | else if (gfc_match ("task" ) == MATCH_YES) |
1390 | list_idx = OMP_LIST_REDUCTION_TASK; |
1391 | else if (gfc_match ("default" ) == MATCH_YES) |
1392 | list_idx = OMP_LIST_REDUCTION; |
1393 | if (list_idx != 0 && gfc_match (", " ) != MATCH_YES) |
1394 | { |
1395 | gfc_error ("Comma expected at %C" ); |
1396 | gfc_current_locus = old_loc; |
1397 | return MATCH_NO; |
1398 | } |
1399 | if (list_idx == 0) |
1400 | list_idx = OMP_LIST_REDUCTION; |
1401 | } |
1402 | else if (pc == 'i') |
1403 | list_idx = OMP_LIST_IN_REDUCTION; |
1404 | else if (pc == 't') |
1405 | list_idx = OMP_LIST_TASK_REDUCTION; |
1406 | else |
1407 | list_idx = OMP_LIST_REDUCTION; |
1408 | |
1409 | gfc_omp_reduction_op rop = OMP_REDUCTION_NONE; |
1410 | char buffer[GFC_MAX_SYMBOL_LEN + 3]; |
1411 | if (gfc_match_char ('+') == MATCH_YES) |
1412 | rop = OMP_REDUCTION_PLUS; |
1413 | else if (gfc_match_char ('*') == MATCH_YES) |
1414 | rop = OMP_REDUCTION_TIMES; |
1415 | else if (gfc_match_char ('-') == MATCH_YES) |
1416 | rop = OMP_REDUCTION_MINUS; |
1417 | else if (gfc_match (".and." ) == MATCH_YES) |
1418 | rop = OMP_REDUCTION_AND; |
1419 | else if (gfc_match (".or." ) == MATCH_YES) |
1420 | rop = OMP_REDUCTION_OR; |
1421 | else if (gfc_match (".eqv." ) == MATCH_YES) |
1422 | rop = OMP_REDUCTION_EQV; |
1423 | else if (gfc_match (".neqv." ) == MATCH_YES) |
1424 | rop = OMP_REDUCTION_NEQV; |
1425 | if (rop != OMP_REDUCTION_NONE) |
1426 | snprintf (s: buffer, maxlen: sizeof buffer, format: "operator %s" , |
1427 | gfc_op2string ((gfc_intrinsic_op) rop)); |
1428 | else if (gfc_match_defined_op_name (buffer + 1, 1) == MATCH_YES) |
1429 | { |
1430 | buffer[0] = '.'; |
1431 | strcat (dest: buffer, src: "." ); |
1432 | } |
1433 | else if (gfc_match_name (buffer) == MATCH_YES) |
1434 | { |
1435 | gfc_symbol *sym; |
1436 | const char *n = buffer; |
1437 | |
1438 | gfc_find_symbol (buffer, NULL, 1, &sym); |
1439 | if (sym != NULL) |
1440 | { |
1441 | if (sym->attr.intrinsic) |
1442 | n = sym->name; |
1443 | else if ((sym->attr.flavor != FL_UNKNOWN |
1444 | && sym->attr.flavor != FL_PROCEDURE) |
1445 | || sym->attr.external |
1446 | || sym->attr.generic |
1447 | || sym->attr.entry |
1448 | || sym->attr.result |
1449 | || sym->attr.dummy |
1450 | || sym->attr.subroutine |
1451 | || sym->attr.pointer |
1452 | || sym->attr.target |
1453 | || sym->attr.cray_pointer |
1454 | || sym->attr.cray_pointee |
1455 | || (sym->attr.proc != PROC_UNKNOWN |
1456 | && sym->attr.proc != PROC_INTRINSIC) |
1457 | || sym->attr.if_source != IFSRC_UNKNOWN |
1458 | || sym == sym->ns->proc_name) |
1459 | { |
1460 | sym = NULL; |
1461 | n = NULL; |
1462 | } |
1463 | else |
1464 | n = sym->name; |
1465 | } |
1466 | if (n == NULL) |
1467 | rop = OMP_REDUCTION_NONE; |
1468 | else if (strcmp (s1: n, s2: "max" ) == 0) |
1469 | rop = OMP_REDUCTION_MAX; |
1470 | else if (strcmp (s1: n, s2: "min" ) == 0) |
1471 | rop = OMP_REDUCTION_MIN; |
1472 | else if (strcmp (s1: n, s2: "iand" ) == 0) |
1473 | rop = OMP_REDUCTION_IAND; |
1474 | else if (strcmp (s1: n, s2: "ior" ) == 0) |
1475 | rop = OMP_REDUCTION_IOR; |
1476 | else if (strcmp (s1: n, s2: "ieor" ) == 0) |
1477 | rop = OMP_REDUCTION_IEOR; |
1478 | if (rop != OMP_REDUCTION_NONE |
1479 | && sym != NULL |
1480 | && ! sym->attr.intrinsic |
1481 | && ! sym->attr.use_assoc |
1482 | && ((sym->attr.flavor == FL_UNKNOWN |
1483 | && !gfc_add_flavor (&sym->attr, FL_PROCEDURE, |
1484 | sym->name, NULL)) |
1485 | || !gfc_add_intrinsic (&sym->attr, NULL))) |
1486 | rop = OMP_REDUCTION_NONE; |
1487 | } |
1488 | else |
1489 | buffer[0] = '\0'; |
1490 | gfc_omp_udr *udr = (buffer[0] ? gfc_find_omp_udr (ns: gfc_current_ns, name: buffer, NULL) |
1491 | : NULL); |
1492 | gfc_omp_namelist **head = NULL; |
1493 | if (rop == OMP_REDUCTION_NONE && udr) |
1494 | rop = OMP_REDUCTION_USER; |
1495 | |
1496 | if (gfc_match_omp_variable_list (str: " :" , list: &c->lists[list_idx], allow_common: false, NULL, |
1497 | headp: &head, allow_sections: openacc, allow_derived) != MATCH_YES) |
1498 | { |
1499 | gfc_current_locus = old_loc; |
1500 | return MATCH_NO; |
1501 | } |
1502 | gfc_omp_namelist *n; |
1503 | if (rop == OMP_REDUCTION_NONE) |
1504 | { |
1505 | n = *head; |
1506 | *head = NULL; |
1507 | gfc_error_now ("!$OMP DECLARE REDUCTION %s not found at %L" , |
1508 | buffer, &old_loc); |
1509 | gfc_free_omp_namelist (n, false, false, false); |
1510 | } |
1511 | else |
1512 | for (n = *head; n; n = n->next) |
1513 | { |
1514 | n->u.reduction_op = rop; |
1515 | if (udr) |
1516 | { |
1517 | n->u2.udr = gfc_get_omp_namelist_udr (); |
1518 | n->u2.udr->udr = udr; |
1519 | } |
1520 | if (openmp_target && list_idx == OMP_LIST_IN_REDUCTION) |
1521 | { |
1522 | gfc_omp_namelist *p = gfc_get_omp_namelist (), **tl; |
1523 | p->sym = n->sym; |
1524 | p->where = p->where; |
1525 | p->u.map_op = OMP_MAP_ALWAYS_TOFROM; |
1526 | |
1527 | tl = &c->lists[OMP_LIST_MAP]; |
1528 | while (*tl) |
1529 | tl = &((*tl)->next); |
1530 | *tl = p; |
1531 | p->next = NULL; |
1532 | } |
1533 | } |
1534 | return MATCH_YES; |
1535 | } |
1536 | |
1537 | static match |
1538 | gfc_omp_absent_contains_clause (gfc_omp_assumptions **assume, bool is_absent) |
1539 | { |
1540 | if (*assume == NULL) |
1541 | *assume = gfc_get_omp_assumptions (); |
1542 | do |
1543 | { |
1544 | gfc_statement st = ST_NONE; |
1545 | gfc_gobble_whitespace (); |
1546 | locus old_loc = gfc_current_locus; |
1547 | char c = gfc_peek_ascii_char (); |
1548 | enum gfc_omp_directive_kind kind |
1549 | = GFC_OMP_DIR_DECLARATIVE; /* Silence warning. */ |
1550 | for (size_t i = 0; i < ARRAY_SIZE (gfc_omp_directives); i++) |
1551 | { |
1552 | if (gfc_omp_directives[i].name[0] > c) |
1553 | break; |
1554 | if (gfc_omp_directives[i].name[0] != c) |
1555 | continue; |
1556 | if (gfc_match (gfc_omp_directives[i].name) == MATCH_YES) |
1557 | { |
1558 | st = gfc_omp_directives[i].st; |
1559 | kind = gfc_omp_directives[i].kind; |
1560 | } |
1561 | } |
1562 | gfc_gobble_whitespace (); |
1563 | c = gfc_peek_ascii_char (); |
1564 | if (st == ST_NONE || (c != ',' && c != ')')) |
1565 | { |
1566 | if (st == ST_NONE) |
1567 | gfc_error ("Unknown directive at %L" , &old_loc); |
1568 | else |
1569 | gfc_error ("Invalid combined or composite directive at %L" , |
1570 | &old_loc); |
1571 | return MATCH_ERROR; |
1572 | } |
1573 | if (kind == GFC_OMP_DIR_DECLARATIVE |
1574 | || kind == GFC_OMP_DIR_INFORMATIONAL |
1575 | || kind == GFC_OMP_DIR_META) |
1576 | { |
1577 | gfc_error ("Invalid %qs directive at %L in %s clause: declarative, " |
1578 | "informational and meta directives not permitted" , |
1579 | gfc_ascii_statement (st, strip_sentinel: true), &old_loc, |
1580 | is_absent ? "ABSENT" : "CONTAINS" ); |
1581 | return MATCH_ERROR; |
1582 | } |
1583 | if (is_absent) |
1584 | { |
1585 | /* Use exponential allocation; equivalent to pow2p(x). */ |
1586 | int i = (*assume)->n_absent; |
1587 | int size = ((i == 0) ? 4 |
1588 | : pow2p_hwi (x: i) == 1 ? i*2 : 0); |
1589 | if (size != 0) |
1590 | (*assume)->absent = XRESIZEVEC (gfc_statement, |
1591 | (*assume)->absent, size); |
1592 | (*assume)->absent[(*assume)->n_absent++] = st; |
1593 | } |
1594 | else |
1595 | { |
1596 | int i = (*assume)->n_contains; |
1597 | int size = ((i == 0) ? 4 |
1598 | : pow2p_hwi (x: i) == 1 ? i*2 : 0); |
1599 | if (size != 0) |
1600 | (*assume)->contains = XRESIZEVEC (gfc_statement, |
1601 | (*assume)->contains, size); |
1602 | (*assume)->contains[(*assume)->n_contains++] = st; |
1603 | } |
1604 | gfc_gobble_whitespace (); |
1605 | if (gfc_match("," ) == MATCH_YES) |
1606 | continue; |
1607 | if (gfc_match(")" ) == MATCH_YES) |
1608 | break; |
1609 | gfc_error ("Expected %<,%> or %<)%> at %C" ); |
1610 | return MATCH_ERROR; |
1611 | } |
1612 | while (true); |
1613 | |
1614 | return MATCH_YES; |
1615 | } |
1616 | |
1617 | /* Check 'check' argument for duplicated statements in absent and/or contains |
1618 | clauses. If 'merge', merge them from check to 'merge'. */ |
1619 | |
1620 | static match |
1621 | omp_verify_merge_absent_contains (gfc_statement st, gfc_omp_assumptions *check, |
1622 | gfc_omp_assumptions *merge, locus *loc) |
1623 | { |
1624 | if (check == NULL) |
1625 | return MATCH_YES; |
1626 | bitmap_head absent_head, contains_head; |
1627 | bitmap_obstack_initialize (NULL); |
1628 | bitmap_initialize (head: &absent_head, obstack: &bitmap_default_obstack); |
1629 | bitmap_initialize (head: &contains_head, obstack: &bitmap_default_obstack); |
1630 | |
1631 | match m = MATCH_YES; |
1632 | for (int i = 0; i < check->n_absent; i++) |
1633 | if (!bitmap_set_bit (&absent_head, check->absent[i])) |
1634 | { |
1635 | gfc_error ("%qs directive mentioned multiple times in %s clause in %s " |
1636 | "directive at %L" , |
1637 | gfc_ascii_statement (check->absent[i], strip_sentinel: true), |
1638 | "ABSENT" , gfc_ascii_statement (st), loc); |
1639 | m = MATCH_ERROR; |
1640 | } |
1641 | for (int i = 0; i < check->n_contains; i++) |
1642 | { |
1643 | if (!bitmap_set_bit (&contains_head, check->contains[i])) |
1644 | { |
1645 | gfc_error ("%qs directive mentioned multiple times in %s clause in %s " |
1646 | "directive at %L" , |
1647 | gfc_ascii_statement (check->contains[i], strip_sentinel: true), |
1648 | "CONTAINS" , gfc_ascii_statement (st), loc); |
1649 | m = MATCH_ERROR; |
1650 | } |
1651 | if (bitmap_bit_p (&absent_head, check->contains[i])) |
1652 | { |
1653 | gfc_error ("%qs directive mentioned both times in ABSENT and CONTAINS " |
1654 | "clauses in %s directive at %L" , |
1655 | gfc_ascii_statement (check->absent[i], strip_sentinel: true), |
1656 | gfc_ascii_statement (st), loc); |
1657 | m = MATCH_ERROR; |
1658 | } |
1659 | } |
1660 | |
1661 | if (m == MATCH_ERROR) |
1662 | return MATCH_ERROR; |
1663 | if (merge == NULL) |
1664 | return MATCH_YES; |
1665 | if (merge->absent == NULL && check->absent) |
1666 | { |
1667 | merge->n_absent = check->n_absent; |
1668 | merge->absent = check->absent; |
1669 | check->absent = NULL; |
1670 | } |
1671 | else if (merge->absent && check->absent) |
1672 | { |
1673 | check->absent = XRESIZEVEC (gfc_statement, check->absent, |
1674 | merge->n_absent + check->n_absent); |
1675 | for (int i = 0; i < merge->n_absent; i++) |
1676 | if (!bitmap_bit_p (&absent_head, merge->absent[i])) |
1677 | check->absent[check->n_absent++] = merge->absent[i]; |
1678 | free (ptr: merge->absent); |
1679 | merge->absent = check->absent; |
1680 | merge->n_absent = check->n_absent; |
1681 | check->absent = NULL; |
1682 | } |
1683 | if (merge->contains == NULL && check->contains) |
1684 | { |
1685 | merge->n_contains = check->n_contains; |
1686 | merge->contains = check->contains; |
1687 | check->contains = NULL; |
1688 | } |
1689 | else if (merge->contains && check->contains) |
1690 | { |
1691 | check->contains = XRESIZEVEC (gfc_statement, check->contains, |
1692 | merge->n_contains + check->n_contains); |
1693 | for (int i = 0; i < merge->n_contains; i++) |
1694 | if (!bitmap_bit_p (&contains_head, merge->contains[i])) |
1695 | check->contains[check->n_contains++] = merge->contains[i]; |
1696 | free (ptr: merge->contains); |
1697 | merge->contains = check->contains; |
1698 | merge->n_contains = check->n_contains; |
1699 | check->contains = NULL; |
1700 | } |
1701 | return MATCH_YES; |
1702 | } |
1703 | |
1704 | /* OpenMP 5.0 |
1705 | uses_allocators ( allocator-list ) |
1706 | |
1707 | allocator: |
1708 | predefined-allocator |
1709 | variable ( traits-array ) |
1710 | |
1711 | OpenMP 5.2: |
1712 | uses_allocators ( [modifier-list :] allocator-list ) |
1713 | |
1714 | allocator: |
1715 | variable or predefined-allocator |
1716 | modifier: |
1717 | traits ( traits-array ) |
1718 | memspace ( mem-space-handle ) */ |
1719 | |
1720 | static match |
1721 | gfc_match_omp_clause_uses_allocators (gfc_omp_clauses *c) |
1722 | { |
1723 | gfc_symbol *memspace_sym = NULL; |
1724 | gfc_symbol *traits_sym = NULL; |
1725 | gfc_omp_namelist *head = NULL; |
1726 | gfc_omp_namelist *p, *tail, **list; |
1727 | int ntraits, nmemspace; |
1728 | bool has_modifiers; |
1729 | locus old_loc, cur_loc; |
1730 | |
1731 | gfc_gobble_whitespace (); |
1732 | old_loc = gfc_current_locus; |
1733 | ntraits = nmemspace = 0; |
1734 | do |
1735 | { |
1736 | cur_loc = gfc_current_locus; |
1737 | if (gfc_match ("traits ( %S ) " , &traits_sym) == MATCH_YES) |
1738 | ntraits++; |
1739 | else if (gfc_match ("memspace ( %S ) " , &memspace_sym) == MATCH_YES) |
1740 | nmemspace++; |
1741 | if (ntraits > 1 || nmemspace > 1) |
1742 | { |
1743 | gfc_error ("Duplicate %s modifier at %L in USES_ALLOCATORS clause" , |
1744 | ntraits > 1 ? "TRAITS" : "MEMSPACE" , &cur_loc); |
1745 | return MATCH_ERROR; |
1746 | } |
1747 | if (gfc_match (", " ) == MATCH_YES) |
1748 | continue; |
1749 | if (gfc_match (": " ) != MATCH_YES) |
1750 | { |
1751 | /* Assume no modifier. */ |
1752 | memspace_sym = traits_sym = NULL; |
1753 | gfc_current_locus = old_loc; |
1754 | break; |
1755 | } |
1756 | break; |
1757 | } while (true); |
1758 | |
1759 | has_modifiers = traits_sym != NULL || memspace_sym != NULL; |
1760 | do |
1761 | { |
1762 | p = gfc_get_omp_namelist (); |
1763 | p->where = gfc_current_locus; |
1764 | if (head == NULL) |
1765 | head = tail = p; |
1766 | else |
1767 | { |
1768 | tail->next = p; |
1769 | tail = tail->next; |
1770 | } |
1771 | if (gfc_match ("%S " , &p->sym) != MATCH_YES) |
1772 | goto error; |
1773 | if (!has_modifiers) |
1774 | gfc_match ("( %S ) " , &p->u2.traits_sym); |
1775 | else if (gfc_peek_ascii_char () == '(') |
1776 | { |
1777 | gfc_error ("Unexpected %<(%> at %C" ); |
1778 | goto error; |
1779 | } |
1780 | else |
1781 | { |
1782 | p->u.memspace_sym = memspace_sym; |
1783 | p->u2.traits_sym = traits_sym; |
1784 | } |
1785 | if (gfc_match (", " ) == MATCH_YES) |
1786 | continue; |
1787 | if (gfc_match (") " ) == MATCH_YES) |
1788 | break; |
1789 | goto error; |
1790 | } while (true); |
1791 | |
1792 | list = &c->lists[OMP_LIST_USES_ALLOCATORS]; |
1793 | while (*list) |
1794 | list = &(*list)->next; |
1795 | *list = head; |
1796 | |
1797 | return MATCH_YES; |
1798 | |
1799 | error: |
1800 | gfc_free_omp_namelist (head, false, false, true); |
1801 | return MATCH_ERROR; |
1802 | } |
1803 | |
1804 | |
1805 | /* Match with duplicate check. Matches 'name'. If expr != NULL, it |
1806 | then matches '(expr)', otherwise, if open_parens is true, |
1807 | it matches a ' ( ' after 'name'. |
1808 | dupl_message requires '%qs %L' - and is used by |
1809 | gfc_match_dupl_memorder and gfc_match_dupl_atomic. */ |
1810 | |
1811 | static match |
1812 | gfc_match_dupl_check (bool not_dupl, const char *name, bool open_parens = false, |
1813 | gfc_expr **expr = NULL, const char *dupl_msg = NULL) |
1814 | { |
1815 | match m; |
1816 | locus old_loc = gfc_current_locus; |
1817 | if ((m = gfc_match (name)) != MATCH_YES) |
1818 | return m; |
1819 | if (!not_dupl) |
1820 | { |
1821 | if (dupl_msg) |
1822 | gfc_error (dupl_msg, name, &old_loc); |
1823 | else |
1824 | gfc_error ("Duplicated %qs clause at %L" , name, &old_loc); |
1825 | return MATCH_ERROR; |
1826 | } |
1827 | if (open_parens || expr) |
1828 | { |
1829 | if (gfc_match (" ( " ) != MATCH_YES) |
1830 | { |
1831 | gfc_error ("Expected %<(%> after %qs at %C" , name); |
1832 | return MATCH_ERROR; |
1833 | } |
1834 | if (expr) |
1835 | { |
1836 | if (gfc_match ("%e )" , expr) != MATCH_YES) |
1837 | { |
1838 | gfc_error ("Invalid expression after %<%s(%> at %C" , name); |
1839 | return MATCH_ERROR; |
1840 | } |
1841 | } |
1842 | } |
1843 | return MATCH_YES; |
1844 | } |
1845 | |
1846 | static match |
1847 | gfc_match_dupl_memorder (bool not_dupl, const char *name) |
1848 | { |
1849 | return gfc_match_dupl_check (not_dupl, name, open_parens: false, NULL, |
1850 | dupl_msg: "Duplicated memory-order clause: unexpected %s " |
1851 | "clause at %L" ); |
1852 | } |
1853 | |
1854 | static match |
1855 | gfc_match_dupl_atomic (bool not_dupl, const char *name) |
1856 | { |
1857 | return gfc_match_dupl_check (not_dupl, name, open_parens: false, NULL, |
1858 | dupl_msg: "Duplicated atomic clause: unexpected %s " |
1859 | "clause at %L" ); |
1860 | } |
1861 | |
1862 | /* Match OpenMP and OpenACC directive clauses. MASK is a bitmask of |
1863 | clauses that are allowed for a particular directive. */ |
1864 | |
1865 | static match |
1866 | gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, |
1867 | bool first = true, bool needs_space = true, |
1868 | bool openacc = false, bool context_selector = false, |
1869 | bool openmp_target = false) |
1870 | { |
1871 | bool error = false; |
1872 | gfc_omp_clauses *c = gfc_get_omp_clauses (); |
1873 | locus old_loc; |
1874 | /* Determine whether we're dealing with an OpenACC directive that permits |
1875 | derived type member accesses. This in particular disallows |
1876 | "!$acc declare" from using such accesses, because it's not clear if/how |
1877 | that should work. */ |
1878 | bool allow_derived = (openacc |
1879 | && ((mask & OMP_CLAUSE_ATTACH) |
1880 | || (mask & OMP_CLAUSE_DETACH))); |
1881 | |
1882 | gcc_checking_assert (OMP_MASK1_LAST <= 64 && OMP_MASK2_LAST <= 64); |
1883 | *cp = NULL; |
1884 | while (1) |
1885 | { |
1886 | match m = MATCH_NO; |
1887 | if ((first || (m = gfc_match_char (',')) != MATCH_YES) |
1888 | && (needs_space && gfc_match_space () != MATCH_YES)) |
1889 | break; |
1890 | needs_space = false; |
1891 | first = false; |
1892 | gfc_gobble_whitespace (); |
1893 | bool end_colon; |
1894 | gfc_omp_namelist **head; |
1895 | old_loc = gfc_current_locus; |
1896 | char pc = gfc_peek_ascii_char (); |
1897 | if (pc == '\n' && m == MATCH_YES) |
1898 | { |
1899 | gfc_error ("Clause expected at %C after trailing comma" ); |
1900 | goto error; |
1901 | } |
1902 | switch (pc) |
1903 | { |
1904 | case 'a': |
1905 | end_colon = false; |
1906 | head = NULL; |
1907 | if ((mask & OMP_CLAUSE_ASSUMPTIONS) |
1908 | && gfc_match ("absent ( " ) == MATCH_YES) |
1909 | { |
1910 | if (gfc_omp_absent_contains_clause (assume: &c->assume, is_absent: true) |
1911 | != MATCH_YES) |
1912 | goto error; |
1913 | continue; |
1914 | } |
1915 | if ((mask & OMP_CLAUSE_ALIGNED) |
1916 | && gfc_match_omp_variable_list (str: "aligned (" , |
1917 | list: &c->lists[OMP_LIST_ALIGNED], |
1918 | allow_common: false, end_colon: &end_colon, |
1919 | headp: &head) == MATCH_YES) |
1920 | { |
1921 | gfc_expr *alignment = NULL; |
1922 | gfc_omp_namelist *n; |
1923 | |
1924 | if (end_colon && gfc_match (" %e )" , &alignment) != MATCH_YES) |
1925 | { |
1926 | gfc_free_omp_namelist (*head, false, false, false); |
1927 | gfc_current_locus = old_loc; |
1928 | *head = NULL; |
1929 | break; |
1930 | } |
1931 | for (n = *head; n; n = n->next) |
1932 | if (n->next && alignment) |
1933 | n->expr = gfc_copy_expr (alignment); |
1934 | else |
1935 | n->expr = alignment; |
1936 | continue; |
1937 | } |
1938 | if ((mask & OMP_CLAUSE_MEMORDER) |
1939 | && (m = gfc_match_dupl_memorder (not_dupl: (c->memorder |
1940 | == OMP_MEMORDER_UNSET), |
1941 | name: "acq_rel" )) != MATCH_NO) |
1942 | { |
1943 | if (m == MATCH_ERROR) |
1944 | goto error; |
1945 | c->memorder = OMP_MEMORDER_ACQ_REL; |
1946 | needs_space = true; |
1947 | continue; |
1948 | } |
1949 | if ((mask & OMP_CLAUSE_MEMORDER) |
1950 | && (m = gfc_match_dupl_memorder (not_dupl: (c->memorder |
1951 | == OMP_MEMORDER_UNSET), |
1952 | name: "acquire" )) != MATCH_NO) |
1953 | { |
1954 | if (m == MATCH_ERROR) |
1955 | goto error; |
1956 | c->memorder = OMP_MEMORDER_ACQUIRE; |
1957 | needs_space = true; |
1958 | continue; |
1959 | } |
1960 | if ((mask & OMP_CLAUSE_AFFINITY) |
1961 | && gfc_match ("affinity ( " ) == MATCH_YES) |
1962 | { |
1963 | gfc_namespace *ns_iter = NULL, *ns_curr = gfc_current_ns; |
1964 | m = gfc_match_iterator (ns: &ns_iter, permit_var: true); |
1965 | if (m == MATCH_ERROR) |
1966 | break; |
1967 | if (m == MATCH_YES && gfc_match (" : " ) != MATCH_YES) |
1968 | { |
1969 | gfc_error ("Expected %<:%> at %C" ); |
1970 | break; |
1971 | } |
1972 | if (ns_iter) |
1973 | gfc_current_ns = ns_iter; |
1974 | head = NULL; |
1975 | m = gfc_match_omp_variable_list (str: "" , list: &c->lists[OMP_LIST_AFFINITY], |
1976 | allow_common: false, NULL, headp: &head, allow_sections: true); |
1977 | gfc_current_ns = ns_curr; |
1978 | if (m == MATCH_ERROR) |
1979 | break; |
1980 | if (ns_iter) |
1981 | { |
1982 | for (gfc_omp_namelist *n = *head; n; n = n->next) |
1983 | { |
1984 | n->u2.ns = ns_iter; |
1985 | ns_iter->refs++; |
1986 | } |
1987 | } |
1988 | continue; |
1989 | } |
1990 | if ((mask & OMP_CLAUSE_ALLOCATE) |
1991 | && gfc_match ("allocate ( " ) == MATCH_YES) |
1992 | { |
1993 | gfc_expr *allocator = NULL; |
1994 | gfc_expr *align = NULL; |
1995 | old_loc = gfc_current_locus; |
1996 | if ((m = gfc_match ("allocator ( %e )" , &allocator)) == MATCH_YES) |
1997 | gfc_match (" , align ( %e )" , &align); |
1998 | else if ((m = gfc_match ("align ( %e )" , &align)) == MATCH_YES) |
1999 | gfc_match (" , allocator ( %e )" , &allocator); |
2000 | |
2001 | if (m == MATCH_YES) |
2002 | { |
2003 | if (gfc_match (" : " ) != MATCH_YES) |
2004 | { |
2005 | gfc_error ("Expected %<:%> at %C" ); |
2006 | goto error; |
2007 | } |
2008 | } |
2009 | else |
2010 | { |
2011 | m = gfc_match_expr (&allocator); |
2012 | if (m == MATCH_YES && gfc_match (" : " ) != MATCH_YES) |
2013 | { |
2014 | /* If no ":" then there is no allocator, we backtrack |
2015 | and read the variable list. */ |
2016 | gfc_free_expr (allocator); |
2017 | allocator = NULL; |
2018 | gfc_current_locus = old_loc; |
2019 | } |
2020 | } |
2021 | gfc_omp_namelist **head = NULL; |
2022 | m = gfc_match_omp_variable_list (str: "" , list: &c->lists[OMP_LIST_ALLOCATE], |
2023 | allow_common: true, NULL, headp: &head); |
2024 | |
2025 | if (m != MATCH_YES) |
2026 | { |
2027 | gfc_free_expr (allocator); |
2028 | gfc_free_expr (align); |
2029 | gfc_error ("Expected variable list at %C" ); |
2030 | goto error; |
2031 | } |
2032 | |
2033 | for (gfc_omp_namelist *n = *head; n; n = n->next) |
2034 | { |
2035 | n->u2.allocator = allocator; |
2036 | n->u.align = (align) ? gfc_copy_expr (align) : NULL; |
2037 | } |
2038 | gfc_free_expr (align); |
2039 | continue; |
2040 | } |
2041 | if ((mask & OMP_CLAUSE_AT) |
2042 | && (m = gfc_match_dupl_check (not_dupl: c->at == OMP_AT_UNSET, name: "at" , open_parens: true)) |
2043 | != MATCH_NO) |
2044 | { |
2045 | if (m == MATCH_ERROR) |
2046 | goto error; |
2047 | if (gfc_match ("compilation )" ) == MATCH_YES) |
2048 | c->at = OMP_AT_COMPILATION; |
2049 | else if (gfc_match ("execution )" ) == MATCH_YES) |
2050 | c->at = OMP_AT_EXECUTION; |
2051 | else |
2052 | { |
2053 | gfc_error ("Expected COMPILATION or EXECUTION in AT clause " |
2054 | "at %C" ); |
2055 | goto error; |
2056 | } |
2057 | continue; |
2058 | } |
2059 | if ((mask & OMP_CLAUSE_ASYNC) |
2060 | && (m = gfc_match_dupl_check (not_dupl: !c->async, name: "async" )) != MATCH_NO) |
2061 | { |
2062 | if (m == MATCH_ERROR) |
2063 | goto error; |
2064 | c->async = true; |
2065 | m = gfc_match (" ( %e )" , &c->async_expr); |
2066 | if (m == MATCH_ERROR) |
2067 | { |
2068 | gfc_current_locus = old_loc; |
2069 | break; |
2070 | } |
2071 | else if (m == MATCH_NO) |
2072 | { |
2073 | c->async_expr |
2074 | = gfc_get_constant_expr (BT_INTEGER, |
2075 | gfc_default_integer_kind, |
2076 | &gfc_current_locus); |
2077 | mpz_set_si (c->async_expr->value.integer, GOMP_ASYNC_NOVAL); |
2078 | needs_space = true; |
2079 | } |
2080 | continue; |
2081 | } |
2082 | if ((mask & OMP_CLAUSE_AUTO) |
2083 | && (m = gfc_match_dupl_check (not_dupl: !c->par_auto, name: "auto" )) |
2084 | != MATCH_NO) |
2085 | { |
2086 | if (m == MATCH_ERROR) |
2087 | goto error; |
2088 | c->par_auto = true; |
2089 | needs_space = true; |
2090 | continue; |
2091 | } |
2092 | if ((mask & OMP_CLAUSE_ATTACH) |
2093 | && gfc_match ("attach ( " ) == MATCH_YES |
2094 | && gfc_match_omp_map_clause (list: &c->lists[OMP_LIST_MAP], |
2095 | map_op: OMP_MAP_ATTACH, allow_common: false, |
2096 | allow_derived)) |
2097 | continue; |
2098 | break; |
2099 | case 'b': |
2100 | if ((mask & OMP_CLAUSE_BIND) |
2101 | && (m = gfc_match_dupl_check (not_dupl: c->bind == OMP_BIND_UNSET, name: "bind" , |
2102 | open_parens: true)) != MATCH_NO) |
2103 | { |
2104 | if (m == MATCH_ERROR) |
2105 | goto error; |
2106 | if (gfc_match ("teams )" ) == MATCH_YES) |
2107 | c->bind = OMP_BIND_TEAMS; |
2108 | else if (gfc_match ("parallel )" ) == MATCH_YES) |
2109 | c->bind = OMP_BIND_PARALLEL; |
2110 | else if (gfc_match ("thread )" ) == MATCH_YES) |
2111 | c->bind = OMP_BIND_THREAD; |
2112 | else |
2113 | { |
2114 | gfc_error ("Expected TEAMS, PARALLEL or THREAD as binding in " |
2115 | "BIND at %C" ); |
2116 | break; |
2117 | } |
2118 | continue; |
2119 | } |
2120 | break; |
2121 | case 'c': |
2122 | if ((mask & OMP_CLAUSE_CAPTURE) |
2123 | && (m = gfc_match_dupl_check (not_dupl: !c->capture, name: "capture" )) |
2124 | != MATCH_NO) |
2125 | { |
2126 | if (m == MATCH_ERROR) |
2127 | goto error; |
2128 | c->capture = true; |
2129 | needs_space = true; |
2130 | continue; |
2131 | } |
2132 | if (mask & OMP_CLAUSE_COLLAPSE) |
2133 | { |
2134 | gfc_expr *cexpr = NULL; |
2135 | if ((m = gfc_match_dupl_check (not_dupl: !c->collapse, name: "collapse" , open_parens: true, |
2136 | expr: &cexpr)) != MATCH_NO) |
2137 | { |
2138 | int collapse; |
2139 | if (m == MATCH_ERROR) |
2140 | goto error; |
2141 | if (gfc_extract_int (cexpr, &collapse, -1)) |
2142 | collapse = 1; |
2143 | else if (collapse <= 0) |
2144 | { |
2145 | gfc_error_now ("COLLAPSE clause argument not constant " |
2146 | "positive integer at %C" ); |
2147 | collapse = 1; |
2148 | } |
2149 | gfc_free_expr (cexpr); |
2150 | c->collapse = collapse; |
2151 | continue; |
2152 | } |
2153 | } |
2154 | if ((mask & OMP_CLAUSE_COMPARE) |
2155 | && (m = gfc_match_dupl_check (not_dupl: !c->compare, name: "compare" )) |
2156 | != MATCH_NO) |
2157 | { |
2158 | if (m == MATCH_ERROR) |
2159 | goto error; |
2160 | c->compare = true; |
2161 | needs_space = true; |
2162 | continue; |
2163 | } |
2164 | if ((mask & OMP_CLAUSE_ASSUMPTIONS) |
2165 | && gfc_match ("contains ( " ) == MATCH_YES) |
2166 | { |
2167 | if (gfc_omp_absent_contains_clause (assume: &c->assume, is_absent: false) |
2168 | != MATCH_YES) |
2169 | goto error; |
2170 | continue; |
2171 | } |
2172 | if ((mask & OMP_CLAUSE_COPY) |
2173 | && gfc_match ("copy ( " ) == MATCH_YES |
2174 | && gfc_match_omp_map_clause (list: &c->lists[OMP_LIST_MAP], |
2175 | map_op: OMP_MAP_TOFROM, allow_common: true, |
2176 | allow_derived)) |
2177 | continue; |
2178 | if (mask & OMP_CLAUSE_COPYIN) |
2179 | { |
2180 | if (openacc) |
2181 | { |
2182 | if (gfc_match ("copyin ( " ) == MATCH_YES |
2183 | && gfc_match_omp_map_clause (list: &c->lists[OMP_LIST_MAP], |
2184 | map_op: OMP_MAP_TO, allow_common: true, |
2185 | allow_derived)) |
2186 | continue; |
2187 | } |
2188 | else if (gfc_match_omp_variable_list (str: "copyin (" , |
2189 | list: &c->lists[OMP_LIST_COPYIN], |
2190 | allow_common: true) == MATCH_YES) |
2191 | continue; |
2192 | } |
2193 | if ((mask & OMP_CLAUSE_COPYOUT) |
2194 | && gfc_match ("copyout ( " ) == MATCH_YES |
2195 | && gfc_match_omp_map_clause (list: &c->lists[OMP_LIST_MAP], |
2196 | map_op: OMP_MAP_FROM, allow_common: true, allow_derived)) |
2197 | continue; |
2198 | if ((mask & OMP_CLAUSE_COPYPRIVATE) |
2199 | && gfc_match_omp_variable_list (str: "copyprivate (" , |
2200 | list: &c->lists[OMP_LIST_COPYPRIVATE], |
2201 | allow_common: true) == MATCH_YES) |
2202 | continue; |
2203 | if ((mask & OMP_CLAUSE_CREATE) |
2204 | && gfc_match ("create ( " ) == MATCH_YES |
2205 | && gfc_match_omp_map_clause (list: &c->lists[OMP_LIST_MAP], |
2206 | map_op: OMP_MAP_ALLOC, allow_common: true, allow_derived)) |
2207 | continue; |
2208 | break; |
2209 | case 'd': |
2210 | if ((mask & OMP_CLAUSE_DEFAULTMAP) |
2211 | && gfc_match ("defaultmap ( " ) == MATCH_YES) |
2212 | { |
2213 | enum gfc_omp_defaultmap behavior; |
2214 | gfc_omp_defaultmap_category category |
2215 | = OMP_DEFAULTMAP_CAT_UNCATEGORIZED; |
2216 | if (gfc_match ("alloc " ) == MATCH_YES) |
2217 | behavior = OMP_DEFAULTMAP_ALLOC; |
2218 | else if (gfc_match ("tofrom " ) == MATCH_YES) |
2219 | behavior = OMP_DEFAULTMAP_TOFROM; |
2220 | else if (gfc_match ("to " ) == MATCH_YES) |
2221 | behavior = OMP_DEFAULTMAP_TO; |
2222 | else if (gfc_match ("from " ) == MATCH_YES) |
2223 | behavior = OMP_DEFAULTMAP_FROM; |
2224 | else if (gfc_match ("firstprivate " ) == MATCH_YES) |
2225 | behavior = OMP_DEFAULTMAP_FIRSTPRIVATE; |
2226 | else if (gfc_match ("present " ) == MATCH_YES) |
2227 | behavior = OMP_DEFAULTMAP_PRESENT; |
2228 | else if (gfc_match ("none " ) == MATCH_YES) |
2229 | behavior = OMP_DEFAULTMAP_NONE; |
2230 | else if (gfc_match ("default " ) == MATCH_YES) |
2231 | behavior = OMP_DEFAULTMAP_DEFAULT; |
2232 | else |
2233 | { |
2234 | gfc_error ("Expected ALLOC, TO, FROM, TOFROM, FIRSTPRIVATE, " |
2235 | "PRESENT, NONE or DEFAULT at %C" ); |
2236 | break; |
2237 | } |
2238 | if (')' == gfc_peek_ascii_char ()) |
2239 | ; |
2240 | else if (gfc_match (": " ) != MATCH_YES) |
2241 | break; |
2242 | else |
2243 | { |
2244 | if (gfc_match ("scalar " ) == MATCH_YES) |
2245 | category = OMP_DEFAULTMAP_CAT_SCALAR; |
2246 | else if (gfc_match ("aggregate " ) == MATCH_YES) |
2247 | category = OMP_DEFAULTMAP_CAT_AGGREGATE; |
2248 | else if (gfc_match ("allocatable " ) == MATCH_YES) |
2249 | category = OMP_DEFAULTMAP_CAT_ALLOCATABLE; |
2250 | else if (gfc_match ("pointer " ) == MATCH_YES) |
2251 | category = OMP_DEFAULTMAP_CAT_POINTER; |
2252 | else if (gfc_match ("all " ) == MATCH_YES) |
2253 | category = OMP_DEFAULTMAP_CAT_ALL; |
2254 | else |
2255 | { |
2256 | gfc_error ("Expected SCALAR, AGGREGATE, ALLOCATABLE, " |
2257 | "POINTER or ALL at %C" ); |
2258 | break; |
2259 | } |
2260 | } |
2261 | for (int i = 0; i < OMP_DEFAULTMAP_CAT_NUM; ++i) |
2262 | { |
2263 | if (i != category |
2264 | && category != OMP_DEFAULTMAP_CAT_UNCATEGORIZED |
2265 | && category != OMP_DEFAULTMAP_CAT_ALL |
2266 | && i != OMP_DEFAULTMAP_CAT_UNCATEGORIZED |
2267 | && i != OMP_DEFAULTMAP_CAT_ALL) |
2268 | continue; |
2269 | if (c->defaultmap[i] != OMP_DEFAULTMAP_UNSET) |
2270 | { |
2271 | const char *pcategory = NULL; |
2272 | switch (i) |
2273 | { |
2274 | case OMP_DEFAULTMAP_CAT_UNCATEGORIZED: break; |
2275 | case OMP_DEFAULTMAP_CAT_ALL: pcategory = "ALL" ; break; |
2276 | case OMP_DEFAULTMAP_CAT_SCALAR: pcategory = "SCALAR" ; break; |
2277 | case OMP_DEFAULTMAP_CAT_AGGREGATE: |
2278 | pcategory = "AGGREGATE" ; |
2279 | break; |
2280 | case OMP_DEFAULTMAP_CAT_ALLOCATABLE: |
2281 | pcategory = "ALLOCATABLE" ; |
2282 | break; |
2283 | case OMP_DEFAULTMAP_CAT_POINTER: |
2284 | pcategory = "POINTER" ; |
2285 | break; |
2286 | default: gcc_unreachable (); |
2287 | } |
2288 | if (i == OMP_DEFAULTMAP_CAT_UNCATEGORIZED) |
2289 | gfc_error ("DEFAULTMAP at %C but prior DEFAULTMAP with " |
2290 | "unspecified category" ); |
2291 | else |
2292 | gfc_error ("DEFAULTMAP at %C but prior DEFAULTMAP for " |
2293 | "category %s" , pcategory); |
2294 | goto error; |
2295 | } |
2296 | } |
2297 | c->defaultmap[category] = behavior; |
2298 | if (gfc_match (")" ) != MATCH_YES) |
2299 | break; |
2300 | continue; |
2301 | } |
2302 | if ((mask & OMP_CLAUSE_DEFAULT) |
2303 | && (m = gfc_match_dupl_check (not_dupl: c->default_sharing |
2304 | == OMP_DEFAULT_UNKNOWN, name: "default" , |
2305 | open_parens: true)) != MATCH_NO) |
2306 | { |
2307 | if (m == MATCH_ERROR) |
2308 | goto error; |
2309 | if (gfc_match ("none" ) == MATCH_YES) |
2310 | c->default_sharing = OMP_DEFAULT_NONE; |
2311 | else if (openacc) |
2312 | { |
2313 | if (gfc_match ("present" ) == MATCH_YES) |
2314 | c->default_sharing = OMP_DEFAULT_PRESENT; |
2315 | } |
2316 | else |
2317 | { |
2318 | if (gfc_match ("firstprivate" ) == MATCH_YES) |
2319 | c->default_sharing = OMP_DEFAULT_FIRSTPRIVATE; |
2320 | else if (gfc_match ("private" ) == MATCH_YES) |
2321 | c->default_sharing = OMP_DEFAULT_PRIVATE; |
2322 | else if (gfc_match ("shared" ) == MATCH_YES) |
2323 | c->default_sharing = OMP_DEFAULT_SHARED; |
2324 | } |
2325 | if (c->default_sharing == OMP_DEFAULT_UNKNOWN) |
2326 | { |
2327 | if (openacc) |
2328 | gfc_error ("Expected NONE or PRESENT in DEFAULT clause " |
2329 | "at %C" ); |
2330 | else |
2331 | gfc_error ("Expected NONE, FIRSTPRIVATE, PRIVATE or SHARED " |
2332 | "in DEFAULT clause at %C" ); |
2333 | goto error; |
2334 | } |
2335 | if (gfc_match (" )" ) != MATCH_YES) |
2336 | goto error; |
2337 | continue; |
2338 | } |
2339 | if ((mask & OMP_CLAUSE_DELETE) |
2340 | && gfc_match ("delete ( " ) == MATCH_YES |
2341 | && gfc_match_omp_map_clause (list: &c->lists[OMP_LIST_MAP], |
2342 | map_op: OMP_MAP_RELEASE, allow_common: true, |
2343 | allow_derived)) |
2344 | continue; |
2345 | /* DOACROSS: match 'doacross' and 'depend' with sink/source. |
2346 | DEPEND: match 'depend' but not sink/source. */ |
2347 | m = MATCH_NO; |
2348 | if (((mask & OMP_CLAUSE_DOACROSS) |
2349 | && gfc_match ("doacross ( " ) == MATCH_YES) |
2350 | || (((mask & OMP_CLAUSE_DEPEND) || (mask & OMP_CLAUSE_DOACROSS)) |
2351 | && (m = gfc_match ("depend ( " )) == MATCH_YES)) |
2352 | { |
2353 | bool has_omp_all_memory; |
2354 | bool is_depend = m == MATCH_YES; |
2355 | gfc_namespace *ns_iter = NULL, *ns_curr = gfc_current_ns; |
2356 | match m_it = MATCH_NO; |
2357 | if (is_depend) |
2358 | m_it = gfc_match_iterator (ns: &ns_iter, permit_var: false); |
2359 | if (m_it == MATCH_ERROR) |
2360 | break; |
2361 | if (m_it == MATCH_YES && gfc_match (" , " ) != MATCH_YES) |
2362 | break; |
2363 | m = MATCH_YES; |
2364 | gfc_omp_depend_doacross_op depend_op = OMP_DEPEND_OUT; |
2365 | if (gfc_match ("inoutset" ) == MATCH_YES) |
2366 | depend_op = OMP_DEPEND_INOUTSET; |
2367 | else if (gfc_match ("inout" ) == MATCH_YES) |
2368 | depend_op = OMP_DEPEND_INOUT; |
2369 | else if (gfc_match ("in" ) == MATCH_YES) |
2370 | depend_op = OMP_DEPEND_IN; |
2371 | else if (gfc_match ("out" ) == MATCH_YES) |
2372 | depend_op = OMP_DEPEND_OUT; |
2373 | else if (gfc_match ("mutexinoutset" ) == MATCH_YES) |
2374 | depend_op = OMP_DEPEND_MUTEXINOUTSET; |
2375 | else if (gfc_match ("depobj" ) == MATCH_YES) |
2376 | depend_op = OMP_DEPEND_DEPOBJ; |
2377 | else if (gfc_match ("source" ) == MATCH_YES) |
2378 | { |
2379 | if (m_it == MATCH_YES) |
2380 | { |
2381 | gfc_error ("ITERATOR may not be combined with SOURCE " |
2382 | "at %C" ); |
2383 | goto error; |
2384 | } |
2385 | if (!(mask & OMP_CLAUSE_DOACROSS)) |
2386 | { |
2387 | gfc_error ("SOURCE at %C not permitted as dependence-type" |
2388 | " for this directive" ); |
2389 | goto error; |
2390 | } |
2391 | if (c->doacross_source) |
2392 | { |
2393 | gfc_error ("Duplicated clause with SOURCE dependence-type" |
2394 | " at %C" ); |
2395 | goto error; |
2396 | } |
2397 | gfc_gobble_whitespace (); |
2398 | m = gfc_match (": " ); |
2399 | if (m != MATCH_YES && !is_depend) |
2400 | { |
2401 | gfc_error ("Expected %<:%> at %C" ); |
2402 | goto error; |
2403 | } |
2404 | if (gfc_match (")" ) != MATCH_YES |
2405 | && !(m == MATCH_YES |
2406 | && gfc_match ("omp_cur_iteration )" ) == MATCH_YES)) |
2407 | { |
2408 | gfc_error ("Expected %<)%> or %<omp_cur_iteration)%> " |
2409 | "at %C" ); |
2410 | goto error; |
2411 | } |
2412 | c->doacross_source = true; |
2413 | c->depend_source = is_depend; |
2414 | continue; |
2415 | } |
2416 | else if (gfc_match ("sink " ) == MATCH_YES) |
2417 | { |
2418 | if (!(mask & OMP_CLAUSE_DOACROSS)) |
2419 | { |
2420 | gfc_error ("SINK at %C not permitted as dependence-type " |
2421 | "for this directive" ); |
2422 | goto error; |
2423 | } |
2424 | if (gfc_match (": " ) != MATCH_YES) |
2425 | { |
2426 | gfc_error ("Expected %<:%> at %C" ); |
2427 | goto error; |
2428 | } |
2429 | if (m_it == MATCH_YES) |
2430 | { |
2431 | gfc_error ("ITERATOR may not be combined with SINK " |
2432 | "at %C" ); |
2433 | goto error; |
2434 | } |
2435 | m = gfc_match_omp_doacross_sink (list: &c->lists[OMP_LIST_DEPEND], |
2436 | depend: is_depend); |
2437 | if (m == MATCH_YES) |
2438 | continue; |
2439 | goto error; |
2440 | } |
2441 | else |
2442 | m = MATCH_NO; |
2443 | if (!(mask & OMP_CLAUSE_DEPEND)) |
2444 | { |
2445 | gfc_error ("Expected dependence-type SINK or SOURCE at %C" ); |
2446 | goto error; |
2447 | } |
2448 | head = NULL; |
2449 | if (ns_iter) |
2450 | gfc_current_ns = ns_iter; |
2451 | if (m == MATCH_YES) |
2452 | m = gfc_match_omp_variable_list (str: " : " , |
2453 | list: &c->lists[OMP_LIST_DEPEND], |
2454 | allow_common: false, NULL, headp: &head, allow_sections: true, |
2455 | allow_derived: false, has_all_memory: &has_omp_all_memory); |
2456 | if (m != MATCH_YES) |
2457 | goto error; |
2458 | gfc_current_ns = ns_curr; |
2459 | if (has_omp_all_memory && depend_op != OMP_DEPEND_INOUT |
2460 | && depend_op != OMP_DEPEND_OUT) |
2461 | { |
2462 | gfc_error ("%<omp_all_memory%> used with DEPEND kind " |
2463 | "other than OUT or INOUT at %C" ); |
2464 | goto error; |
2465 | } |
2466 | gfc_omp_namelist *n; |
2467 | for (n = *head; n; n = n->next) |
2468 | { |
2469 | n->u.depend_doacross_op = depend_op; |
2470 | n->u2.ns = ns_iter; |
2471 | if (ns_iter) |
2472 | ns_iter->refs++; |
2473 | } |
2474 | continue; |
2475 | } |
2476 | if ((mask & OMP_CLAUSE_DETACH) |
2477 | && !openacc |
2478 | && !c->detach |
2479 | && gfc_match_omp_detach (expr: &c->detach) == MATCH_YES) |
2480 | continue; |
2481 | if ((mask & OMP_CLAUSE_DETACH) |
2482 | && openacc |
2483 | && gfc_match ("detach ( " ) == MATCH_YES |
2484 | && gfc_match_omp_map_clause (list: &c->lists[OMP_LIST_MAP], |
2485 | map_op: OMP_MAP_DETACH, allow_common: false, |
2486 | allow_derived)) |
2487 | continue; |
2488 | if ((mask & OMP_CLAUSE_DEVICE) |
2489 | && !openacc |
2490 | && ((m = gfc_match_dupl_check (not_dupl: !c->device, name: "device" , open_parens: true)) |
2491 | != MATCH_NO)) |
2492 | { |
2493 | if (m == MATCH_ERROR) |
2494 | goto error; |
2495 | c->ancestor = false; |
2496 | if (gfc_match ("device_num : " ) == MATCH_YES) |
2497 | { |
2498 | if (gfc_match ("%e )" , &c->device) != MATCH_YES) |
2499 | { |
2500 | gfc_error ("Expected integer expression at %C" ); |
2501 | break; |
2502 | } |
2503 | } |
2504 | else if (gfc_match ("ancestor : " ) == MATCH_YES) |
2505 | { |
2506 | bool has_requires = false; |
2507 | c->ancestor = true; |
2508 | for (gfc_namespace *ns = gfc_current_ns; ns; ns = ns->parent) |
2509 | if (ns->omp_requires & OMP_REQ_REVERSE_OFFLOAD) |
2510 | { |
2511 | has_requires = true; |
2512 | break; |
2513 | } |
2514 | if (!has_requires) |
2515 | { |
2516 | gfc_error ("%<ancestor%> device modifier not " |
2517 | "preceded by %<requires%> directive " |
2518 | "with %<reverse_offload%> clause at %C" ); |
2519 | break; |
2520 | } |
2521 | locus old_loc2 = gfc_current_locus; |
2522 | if (gfc_match ("%e )" , &c->device) == MATCH_YES) |
2523 | { |
2524 | int device = 0; |
2525 | if (!gfc_extract_int (c->device, &device) && device != 1) |
2526 | { |
2527 | gfc_current_locus = old_loc2; |
2528 | gfc_error ("the %<device%> clause expression must " |
2529 | "evaluate to %<1%> at %C" ); |
2530 | break; |
2531 | } |
2532 | } |
2533 | else |
2534 | { |
2535 | gfc_error ("Expected integer expression at %C" ); |
2536 | break; |
2537 | } |
2538 | } |
2539 | else if (gfc_match ("%e )" , &c->device) != MATCH_YES) |
2540 | { |
2541 | gfc_error ("Expected integer expression or a single device-" |
2542 | "modifier %<device_num%> or %<ancestor%> at %C" ); |
2543 | break; |
2544 | } |
2545 | continue; |
2546 | } |
2547 | if ((mask & OMP_CLAUSE_DEVICE) |
2548 | && openacc |
2549 | && gfc_match ("device ( " ) == MATCH_YES |
2550 | && gfc_match_omp_map_clause (list: &c->lists[OMP_LIST_MAP], |
2551 | map_op: OMP_MAP_FORCE_TO, allow_common: true, |
2552 | /* allow_derived = */ true)) |
2553 | continue; |
2554 | if ((mask & OMP_CLAUSE_DEVICEPTR) |
2555 | && gfc_match ("deviceptr ( " ) == MATCH_YES |
2556 | && gfc_match_omp_map_clause (list: &c->lists[OMP_LIST_MAP], |
2557 | map_op: OMP_MAP_FORCE_DEVICEPTR, allow_common: false, |
2558 | allow_derived)) |
2559 | continue; |
2560 | if ((mask & OMP_CLAUSE_DEVICE_TYPE) |
2561 | && gfc_match ("device_type ( " ) == MATCH_YES) |
2562 | { |
2563 | if (gfc_match ("host" ) == MATCH_YES) |
2564 | c->device_type = OMP_DEVICE_TYPE_HOST; |
2565 | else if (gfc_match ("nohost" ) == MATCH_YES) |
2566 | c->device_type = OMP_DEVICE_TYPE_NOHOST; |
2567 | else if (gfc_match ("any" ) == MATCH_YES) |
2568 | c->device_type = OMP_DEVICE_TYPE_ANY; |
2569 | else |
2570 | { |
2571 | gfc_error ("Expected HOST, NOHOST or ANY at %C" ); |
2572 | break; |
2573 | } |
2574 | if (gfc_match (" )" ) != MATCH_YES) |
2575 | break; |
2576 | continue; |
2577 | } |
2578 | if ((mask & OMP_CLAUSE_DEVICE_RESIDENT) |
2579 | && gfc_match_omp_variable_list |
2580 | (str: "device_resident (" , |
2581 | list: &c->lists[OMP_LIST_DEVICE_RESIDENT], allow_common: true) == MATCH_YES) |
2582 | continue; |
2583 | if ((mask & OMP_CLAUSE_DIST_SCHEDULE) |
2584 | && c->dist_sched_kind == OMP_SCHED_NONE |
2585 | && gfc_match ("dist_schedule ( static" ) == MATCH_YES) |
2586 | { |
2587 | m = MATCH_NO; |
2588 | c->dist_sched_kind = OMP_SCHED_STATIC; |
2589 | m = gfc_match (" , %e )" , &c->dist_chunk_size); |
2590 | if (m != MATCH_YES) |
2591 | m = gfc_match_char (')'); |
2592 | if (m != MATCH_YES) |
2593 | { |
2594 | c->dist_sched_kind = OMP_SCHED_NONE; |
2595 | gfc_current_locus = old_loc; |
2596 | } |
2597 | else |
2598 | continue; |
2599 | } |
2600 | break; |
2601 | case 'e': |
2602 | if ((mask & OMP_CLAUSE_ENTER)) |
2603 | { |
2604 | m = gfc_match_omp_to_link (str: "enter (" , list: &c->lists[OMP_LIST_ENTER]); |
2605 | if (m == MATCH_ERROR) |
2606 | goto error; |
2607 | if (m == MATCH_YES) |
2608 | continue; |
2609 | } |
2610 | break; |
2611 | case 'f': |
2612 | if ((mask & OMP_CLAUSE_FAIL) |
2613 | && (m = gfc_match_dupl_check (not_dupl: c->fail == OMP_MEMORDER_UNSET, |
2614 | name: "fail" , open_parens: true)) != MATCH_NO) |
2615 | { |
2616 | if (m == MATCH_ERROR) |
2617 | goto error; |
2618 | if (gfc_match ("seq_cst" ) == MATCH_YES) |
2619 | c->fail = OMP_MEMORDER_SEQ_CST; |
2620 | else if (gfc_match ("acquire" ) == MATCH_YES) |
2621 | c->fail = OMP_MEMORDER_ACQUIRE; |
2622 | else if (gfc_match ("relaxed" ) == MATCH_YES) |
2623 | c->fail = OMP_MEMORDER_RELAXED; |
2624 | else |
2625 | { |
2626 | gfc_error ("Expected SEQ_CST, ACQUIRE or RELAXED at %C" ); |
2627 | break; |
2628 | } |
2629 | if (gfc_match (" )" ) != MATCH_YES) |
2630 | goto error; |
2631 | continue; |
2632 | } |
2633 | if ((mask & OMP_CLAUSE_FILTER) |
2634 | && (m = gfc_match_dupl_check (not_dupl: !c->filter, name: "filter" , open_parens: true, |
2635 | expr: &c->filter)) != MATCH_NO) |
2636 | { |
2637 | if (m == MATCH_ERROR) |
2638 | goto error; |
2639 | continue; |
2640 | } |
2641 | if ((mask & OMP_CLAUSE_FINAL) |
2642 | && (m = gfc_match_dupl_check (not_dupl: !c->final_expr, name: "final" , open_parens: true, |
2643 | expr: &c->final_expr)) != MATCH_NO) |
2644 | { |
2645 | if (m == MATCH_ERROR) |
2646 | goto error; |
2647 | continue; |
2648 | } |
2649 | if ((mask & OMP_CLAUSE_FINALIZE) |
2650 | && (m = gfc_match_dupl_check (not_dupl: !c->finalize, name: "finalize" )) |
2651 | != MATCH_NO) |
2652 | { |
2653 | if (m == MATCH_ERROR) |
2654 | goto error; |
2655 | c->finalize = true; |
2656 | needs_space = true; |
2657 | continue; |
2658 | } |
2659 | if ((mask & OMP_CLAUSE_FIRSTPRIVATE) |
2660 | && gfc_match_omp_variable_list (str: "firstprivate (" , |
2661 | list: &c->lists[OMP_LIST_FIRSTPRIVATE], |
2662 | allow_common: true) == MATCH_YES) |
2663 | continue; |
2664 | if ((mask & OMP_CLAUSE_FROM) |
2665 | && gfc_match_motion_var_list (str: "from (" , list: &c->lists[OMP_LIST_FROM], |
2666 | headp: &head) == MATCH_YES) |
2667 | continue; |
2668 | break; |
2669 | case 'g': |
2670 | if ((mask & OMP_CLAUSE_GANG) |
2671 | && (m = gfc_match_dupl_check (not_dupl: !c->gang, name: "gang" )) != MATCH_NO) |
2672 | { |
2673 | if (m == MATCH_ERROR) |
2674 | goto error; |
2675 | c->gang = true; |
2676 | m = match_oacc_clause_gwv (cp: c, GOMP_DIM_GANG); |
2677 | if (m == MATCH_ERROR) |
2678 | { |
2679 | gfc_current_locus = old_loc; |
2680 | break; |
2681 | } |
2682 | else if (m == MATCH_NO) |
2683 | needs_space = true; |
2684 | continue; |
2685 | } |
2686 | if ((mask & OMP_CLAUSE_GRAINSIZE) |
2687 | && (m = gfc_match_dupl_check (not_dupl: !c->grainsize, name: "grainsize" , open_parens: true)) |
2688 | != MATCH_NO) |
2689 | { |
2690 | if (m == MATCH_ERROR) |
2691 | goto error; |
2692 | if (gfc_match ("strict : " ) == MATCH_YES) |
2693 | c->grainsize_strict = true; |
2694 | if (gfc_match (" %e )" , &c->grainsize) != MATCH_YES) |
2695 | goto error; |
2696 | continue; |
2697 | } |
2698 | break; |
2699 | case 'h': |
2700 | if ((mask & OMP_CLAUSE_HAS_DEVICE_ADDR) |
2701 | && gfc_match_omp_variable_list |
2702 | (str: "has_device_addr (" , list: &c->lists[OMP_LIST_HAS_DEVICE_ADDR], |
2703 | allow_common: false, NULL, NULL, allow_sections: true) == MATCH_YES) |
2704 | continue; |
2705 | if ((mask & OMP_CLAUSE_HINT) |
2706 | && (m = gfc_match_dupl_check (not_dupl: !c->hint, name: "hint" , open_parens: true, expr: &c->hint)) |
2707 | != MATCH_NO) |
2708 | { |
2709 | if (m == MATCH_ERROR) |
2710 | goto error; |
2711 | continue; |
2712 | } |
2713 | if ((mask & OMP_CLAUSE_ASSUMPTIONS) |
2714 | && gfc_match ("holds ( " ) == MATCH_YES) |
2715 | { |
2716 | gfc_expr *e; |
2717 | if (gfc_match ("%e )" , &e) != MATCH_YES) |
2718 | goto error; |
2719 | if (c->assume == NULL) |
2720 | c->assume = gfc_get_omp_assumptions (); |
2721 | gfc_expr_list *el = XCNEW (gfc_expr_list); |
2722 | el->expr = e; |
2723 | el->next = c->assume->holds; |
2724 | c->assume->holds = el; |
2725 | continue; |
2726 | } |
2727 | if ((mask & OMP_CLAUSE_HOST) |
2728 | && gfc_match ("host ( " ) == MATCH_YES |
2729 | && gfc_match_omp_map_clause (list: &c->lists[OMP_LIST_MAP], |
2730 | map_op: OMP_MAP_FORCE_FROM, allow_common: true, |
2731 | /* allow_derived = */ true)) |
2732 | continue; |
2733 | break; |
2734 | case 'i': |
2735 | if ((mask & OMP_CLAUSE_IF_PRESENT) |
2736 | && (m = gfc_match_dupl_check (not_dupl: !c->if_present, name: "if_present" )) |
2737 | != MATCH_NO) |
2738 | { |
2739 | if (m == MATCH_ERROR) |
2740 | goto error; |
2741 | c->if_present = true; |
2742 | needs_space = true; |
2743 | continue; |
2744 | } |
2745 | if ((mask & OMP_CLAUSE_IF) |
2746 | && (m = gfc_match_dupl_check (not_dupl: !c->if_expr, name: "if" , open_parens: true)) |
2747 | != MATCH_NO) |
2748 | { |
2749 | if (m == MATCH_ERROR) |
2750 | goto error; |
2751 | if (!openacc) |
2752 | { |
2753 | /* This should match the enum gfc_omp_if_kind order. */ |
2754 | static const char *ifs[OMP_IF_LAST] = { |
2755 | "cancel : %e )" , |
2756 | "parallel : %e )" , |
2757 | "simd : %e )" , |
2758 | "task : %e )" , |
2759 | "taskloop : %e )" , |
2760 | "target : %e )" , |
2761 | "target data : %e )" , |
2762 | "target update : %e )" , |
2763 | "target enter data : %e )" , |
2764 | "target exit data : %e )" }; |
2765 | int i; |
2766 | for (i = 0; i < OMP_IF_LAST; i++) |
2767 | if (c->if_exprs[i] == NULL |
2768 | && gfc_match (ifs[i], &c->if_exprs[i]) == MATCH_YES) |
2769 | break; |
2770 | if (i < OMP_IF_LAST) |
2771 | continue; |
2772 | } |
2773 | if (gfc_match (" %e )" , &c->if_expr) == MATCH_YES) |
2774 | continue; |
2775 | goto error; |
2776 | } |
2777 | if ((mask & OMP_CLAUSE_IN_REDUCTION) |
2778 | && gfc_match_omp_clause_reduction (pc, c, openacc, allow_derived, |
2779 | openmp_target) == MATCH_YES) |
2780 | continue; |
2781 | if ((mask & OMP_CLAUSE_INBRANCH) |
2782 | && (m = gfc_match_dupl_check (not_dupl: !c->inbranch && !c->notinbranch, |
2783 | name: "inbranch" )) != MATCH_NO) |
2784 | { |
2785 | if (m == MATCH_ERROR) |
2786 | goto error; |
2787 | c->inbranch = needs_space = true; |
2788 | continue; |
2789 | } |
2790 | if ((mask & OMP_CLAUSE_INDEPENDENT) |
2791 | && (m = gfc_match_dupl_check (not_dupl: !c->independent, name: "independent" )) |
2792 | != MATCH_NO) |
2793 | { |
2794 | if (m == MATCH_ERROR) |
2795 | goto error; |
2796 | c->independent = true; |
2797 | needs_space = true; |
2798 | continue; |
2799 | } |
2800 | if ((mask & OMP_CLAUSE_IS_DEVICE_PTR) |
2801 | && gfc_match_omp_variable_list |
2802 | (str: "is_device_ptr (" , |
2803 | list: &c->lists[OMP_LIST_IS_DEVICE_PTR], allow_common: false) == MATCH_YES) |
2804 | continue; |
2805 | break; |
2806 | case 'l': |
2807 | if ((mask & OMP_CLAUSE_LASTPRIVATE) |
2808 | && gfc_match ("lastprivate ( " ) == MATCH_YES) |
2809 | { |
2810 | bool conditional = gfc_match ("conditional : " ) == MATCH_YES; |
2811 | head = NULL; |
2812 | if (gfc_match_omp_variable_list (str: "" , |
2813 | list: &c->lists[OMP_LIST_LASTPRIVATE], |
2814 | allow_common: false, NULL, headp: &head) == MATCH_YES) |
2815 | { |
2816 | gfc_omp_namelist *n; |
2817 | for (n = *head; n; n = n->next) |
2818 | n->u.lastprivate_conditional = conditional; |
2819 | continue; |
2820 | } |
2821 | gfc_current_locus = old_loc; |
2822 | break; |
2823 | } |
2824 | end_colon = false; |
2825 | head = NULL; |
2826 | if ((mask & OMP_CLAUSE_LINEAR) |
2827 | && gfc_match ("linear (" ) == MATCH_YES) |
2828 | { |
2829 | bool old_linear_modifier = false; |
2830 | gfc_omp_linear_op linear_op = OMP_LINEAR_DEFAULT; |
2831 | gfc_expr *step = NULL; |
2832 | |
2833 | if (gfc_match_omp_variable_list (str: " ref (" , |
2834 | list: &c->lists[OMP_LIST_LINEAR], |
2835 | allow_common: false, NULL, headp: &head) |
2836 | == MATCH_YES) |
2837 | { |
2838 | linear_op = OMP_LINEAR_REF; |
2839 | old_linear_modifier = true; |
2840 | } |
2841 | else if (gfc_match_omp_variable_list (str: " val (" , |
2842 | list: &c->lists[OMP_LIST_LINEAR], |
2843 | allow_common: false, NULL, headp: &head) |
2844 | == MATCH_YES) |
2845 | { |
2846 | linear_op = OMP_LINEAR_VAL; |
2847 | old_linear_modifier = true; |
2848 | } |
2849 | else if (gfc_match_omp_variable_list (str: " uval (" , |
2850 | list: &c->lists[OMP_LIST_LINEAR], |
2851 | allow_common: false, NULL, headp: &head) |
2852 | == MATCH_YES) |
2853 | { |
2854 | linear_op = OMP_LINEAR_UVAL; |
2855 | old_linear_modifier = true; |
2856 | } |
2857 | else if (gfc_match_omp_variable_list (str: "" , |
2858 | list: &c->lists[OMP_LIST_LINEAR], |
2859 | allow_common: false, end_colon: &end_colon, headp: &head) |
2860 | == MATCH_YES) |
2861 | linear_op = OMP_LINEAR_DEFAULT; |
2862 | else |
2863 | { |
2864 | gfc_current_locus = old_loc; |
2865 | break; |
2866 | } |
2867 | if (linear_op != OMP_LINEAR_DEFAULT) |
2868 | { |
2869 | if (gfc_match (" :" ) == MATCH_YES) |
2870 | end_colon = true; |
2871 | else if (gfc_match (" )" ) != MATCH_YES) |
2872 | { |
2873 | gfc_free_omp_namelist (*head, false, false, false); |
2874 | gfc_current_locus = old_loc; |
2875 | *head = NULL; |
2876 | break; |
2877 | } |
2878 | } |
2879 | gfc_gobble_whitespace (); |
2880 | if (old_linear_modifier && end_colon) |
2881 | { |
2882 | if (gfc_match (" %e )" , &step) != MATCH_YES) |
2883 | { |
2884 | gfc_free_omp_namelist (*head, false, false, false); |
2885 | gfc_current_locus = old_loc; |
2886 | *head = NULL; |
2887 | goto error; |
2888 | } |
2889 | } |
2890 | else if (end_colon) |
2891 | { |
2892 | bool has_error = false; |
2893 | bool has_modifiers = false; |
2894 | bool has_step = false; |
2895 | bool duplicate_step = false; |
2896 | bool duplicate_mod = false; |
2897 | while (true) |
2898 | { |
2899 | old_loc = gfc_current_locus; |
2900 | bool close_paren = gfc_match ("val )" ) == MATCH_YES; |
2901 | if (close_paren || gfc_match ("val , " ) == MATCH_YES) |
2902 | { |
2903 | if (linear_op != OMP_LINEAR_DEFAULT) |
2904 | { |
2905 | duplicate_mod = true; |
2906 | break; |
2907 | } |
2908 | linear_op = OMP_LINEAR_VAL; |
2909 | has_modifiers = true; |
2910 | if (close_paren) |
2911 | break; |
2912 | continue; |
2913 | } |
2914 | close_paren = gfc_match ("uval )" ) == MATCH_YES; |
2915 | if (close_paren || gfc_match ("uval , " ) == MATCH_YES) |
2916 | { |
2917 | if (linear_op != OMP_LINEAR_DEFAULT) |
2918 | { |
2919 | duplicate_mod = true; |
2920 | break; |
2921 | } |
2922 | linear_op = OMP_LINEAR_UVAL; |
2923 | has_modifiers = true; |
2924 | if (close_paren) |
2925 | break; |
2926 | continue; |
2927 | } |
2928 | close_paren = gfc_match ("ref )" ) == MATCH_YES; |
2929 | if (close_paren || gfc_match ("ref , " ) == MATCH_YES) |
2930 | { |
2931 | if (linear_op != OMP_LINEAR_DEFAULT) |
2932 | { |
2933 | duplicate_mod = true; |
2934 | break; |
2935 | } |
2936 | linear_op = OMP_LINEAR_REF; |
2937 | has_modifiers = true; |
2938 | if (close_paren) |
2939 | break; |
2940 | continue; |
2941 | } |
2942 | close_paren = (gfc_match ("step ( %e ) )" , &step) |
2943 | == MATCH_YES); |
2944 | if (close_paren |
2945 | || gfc_match ("step ( %e ) , " , &step) == MATCH_YES) |
2946 | { |
2947 | if (has_step) |
2948 | { |
2949 | duplicate_step = true; |
2950 | break; |
2951 | } |
2952 | has_modifiers = has_step = true; |
2953 | if (close_paren) |
2954 | break; |
2955 | continue; |
2956 | } |
2957 | if (!has_modifiers |
2958 | && gfc_match ("%e )" , &step) == MATCH_YES) |
2959 | { |
2960 | if ((step->expr_type == EXPR_FUNCTION |
2961 | || step->expr_type == EXPR_VARIABLE) |
2962 | && strcmp (s1: step->symtree->name, s2: "step" ) == 0) |
2963 | { |
2964 | gfc_current_locus = old_loc; |
2965 | gfc_match ("step (" ); |
2966 | has_error = true; |
2967 | } |
2968 | break; |
2969 | } |
2970 | has_error = true; |
2971 | break; |
2972 | } |
2973 | if (duplicate_mod || duplicate_step) |
2974 | { |
2975 | gfc_error ("Multiple %qs modifiers specified at %C" , |
2976 | duplicate_mod ? "linear" : "step" ); |
2977 | has_error = true; |
2978 | } |
2979 | if (has_error) |
2980 | { |
2981 | gfc_free_omp_namelist (*head, false, false, false); |
2982 | *head = NULL; |
2983 | goto error; |
2984 | } |
2985 | } |
2986 | if (step == NULL) |
2987 | { |
2988 | step = gfc_get_constant_expr (BT_INTEGER, |
2989 | gfc_default_integer_kind, |
2990 | &old_loc); |
2991 | mpz_set_si (step->value.integer, 1); |
2992 | } |
2993 | (*head)->expr = step; |
2994 | if (linear_op != OMP_LINEAR_DEFAULT || old_linear_modifier) |
2995 | for (gfc_omp_namelist *n = *head; n; n = n->next) |
2996 | { |
2997 | n->u.linear.op = linear_op; |
2998 | n->u.linear.old_modifier = old_linear_modifier; |
2999 | } |
3000 | continue; |
3001 | } |
3002 | if ((mask & OMP_CLAUSE_LINK) |
3003 | && openacc |
3004 | && (gfc_match_oacc_clause_link (str: "link (" , |
3005 | list: &c->lists[OMP_LIST_LINK]) |
3006 | == MATCH_YES)) |
3007 | continue; |
3008 | else if ((mask & OMP_CLAUSE_LINK) |
3009 | && !openacc |
3010 | && (gfc_match_omp_to_link (str: "link (" , |
3011 | list: &c->lists[OMP_LIST_LINK]) |
3012 | == MATCH_YES)) |
3013 | continue; |
3014 | break; |
3015 | case 'm': |
3016 | if ((mask & OMP_CLAUSE_MAP) |
3017 | && gfc_match ("map ( " ) == MATCH_YES) |
3018 | { |
3019 | locus old_loc2 = gfc_current_locus; |
3020 | int always_modifier = 0; |
3021 | int close_modifier = 0; |
3022 | int present_modifier = 0; |
3023 | locus second_always_locus = old_loc2; |
3024 | locus second_close_locus = old_loc2; |
3025 | locus second_present_locus = old_loc2; |
3026 | |
3027 | for (;;) |
3028 | { |
3029 | locus current_locus = gfc_current_locus; |
3030 | if (gfc_match ("always " ) == MATCH_YES) |
3031 | { |
3032 | if (always_modifier++ == 1) |
3033 | second_always_locus = current_locus; |
3034 | } |
3035 | else if (gfc_match ("close " ) == MATCH_YES) |
3036 | { |
3037 | if (close_modifier++ == 1) |
3038 | second_close_locus = current_locus; |
3039 | } |
3040 | else if (gfc_match ("present " ) == MATCH_YES) |
3041 | { |
3042 | if (present_modifier++ == 1) |
3043 | second_present_locus = current_locus; |
3044 | } |
3045 | else |
3046 | break; |
3047 | gfc_match (", " ); |
3048 | } |
3049 | |
3050 | gfc_omp_map_op map_op = OMP_MAP_TOFROM; |
3051 | int always_present_modifier |
3052 | = always_modifier && present_modifier; |
3053 | |
3054 | if (gfc_match ("alloc : " ) == MATCH_YES) |
3055 | map_op = (present_modifier ? OMP_MAP_PRESENT_ALLOC |
3056 | : OMP_MAP_ALLOC); |
3057 | else if (gfc_match ("tofrom : " ) == MATCH_YES) |
3058 | map_op = (always_present_modifier ? OMP_MAP_ALWAYS_PRESENT_TOFROM |
3059 | : present_modifier ? OMP_MAP_PRESENT_TOFROM |
3060 | : always_modifier ? OMP_MAP_ALWAYS_TOFROM |
3061 | : OMP_MAP_TOFROM); |
3062 | else if (gfc_match ("to : " ) == MATCH_YES) |
3063 | map_op = (always_present_modifier ? OMP_MAP_ALWAYS_PRESENT_TO |
3064 | : present_modifier ? OMP_MAP_PRESENT_TO |
3065 | : always_modifier ? OMP_MAP_ALWAYS_TO |
3066 | : OMP_MAP_TO); |
3067 | else if (gfc_match ("from : " ) == MATCH_YES) |
3068 | map_op = (always_present_modifier ? OMP_MAP_ALWAYS_PRESENT_FROM |
3069 | : present_modifier ? OMP_MAP_PRESENT_FROM |
3070 | : always_modifier ? OMP_MAP_ALWAYS_FROM |
3071 | : OMP_MAP_FROM); |
3072 | else if (gfc_match ("release : " ) == MATCH_YES) |
3073 | map_op = OMP_MAP_RELEASE; |
3074 | else if (gfc_match ("delete : " ) == MATCH_YES) |
3075 | map_op = OMP_MAP_DELETE; |
3076 | else |
3077 | { |
3078 | gfc_current_locus = old_loc2; |
3079 | always_modifier = 0; |
3080 | close_modifier = 0; |
3081 | } |
3082 | |
3083 | if (always_modifier > 1) |
3084 | { |
3085 | gfc_error ("too many %<always%> modifiers at %L" , |
3086 | &second_always_locus); |
3087 | break; |
3088 | } |
3089 | if (close_modifier > 1) |
3090 | { |
3091 | gfc_error ("too many %<close%> modifiers at %L" , |
3092 | &second_close_locus); |
3093 | break; |
3094 | } |
3095 | if (present_modifier > 1) |
3096 | { |
3097 | gfc_error ("too many %<present%> modifiers at %L" , |
3098 | &second_present_locus); |
3099 | break; |
3100 | } |
3101 | |
3102 | head = NULL; |
3103 | if (gfc_match_omp_variable_list (str: "" , list: &c->lists[OMP_LIST_MAP], |
3104 | allow_common: false, NULL, headp: &head, |
3105 | allow_sections: true, allow_derived: true) == MATCH_YES) |
3106 | { |
3107 | gfc_omp_namelist *n; |
3108 | for (n = *head; n; n = n->next) |
3109 | n->u.map_op = map_op; |
3110 | continue; |
3111 | } |
3112 | gfc_current_locus = old_loc; |
3113 | break; |
3114 | } |
3115 | if ((mask & OMP_CLAUSE_MERGEABLE) |
3116 | && (m = gfc_match_dupl_check (not_dupl: !c->mergeable, name: "mergeable" )) |
3117 | != MATCH_NO) |
3118 | { |
3119 | if (m == MATCH_ERROR) |
3120 | goto error; |
3121 | c->mergeable = needs_space = true; |
3122 | continue; |
3123 | } |
3124 | if ((mask & OMP_CLAUSE_MESSAGE) |
3125 | && (m = gfc_match_dupl_check (not_dupl: !c->message, name: "message" , open_parens: true, |
3126 | expr: &c->message)) != MATCH_NO) |
3127 | { |
3128 | if (m == MATCH_ERROR) |
3129 | goto error; |
3130 | continue; |
3131 | } |
3132 | break; |
3133 | case 'n': |
3134 | if ((mask & OMP_CLAUSE_NO_CREATE) |
3135 | && gfc_match ("no_create ( " ) == MATCH_YES |
3136 | && gfc_match_omp_map_clause (list: &c->lists[OMP_LIST_MAP], |
3137 | map_op: OMP_MAP_IF_PRESENT, allow_common: true, |
3138 | allow_derived)) |
3139 | continue; |
3140 | if ((mask & OMP_CLAUSE_ASSUMPTIONS) |
3141 | && (m = gfc_match_dupl_check (not_dupl: !c->assume |
3142 | || !c->assume->no_openmp_routines, |
3143 | name: "no_openmp_routines" )) == MATCH_YES) |
3144 | { |
3145 | if (m == MATCH_ERROR) |
3146 | goto error; |
3147 | if (c->assume == NULL) |
3148 | c->assume = gfc_get_omp_assumptions (); |
3149 | c->assume->no_openmp_routines = needs_space = true; |
3150 | continue; |
3151 | } |
3152 | if ((mask & OMP_CLAUSE_ASSUMPTIONS) |
3153 | && (m = gfc_match_dupl_check (not_dupl: !c->assume || !c->assume->no_openmp, |
3154 | name: "no_openmp" )) == MATCH_YES) |
3155 | { |
3156 | if (m == MATCH_ERROR) |
3157 | goto error; |
3158 | if (c->assume == NULL) |
3159 | c->assume = gfc_get_omp_assumptions (); |
3160 | c->assume->no_openmp = needs_space = true; |
3161 | continue; |
3162 | } |
3163 | if ((mask & OMP_CLAUSE_ASSUMPTIONS) |
3164 | && (m = gfc_match_dupl_check (not_dupl: !c->assume |
3165 | || !c->assume->no_parallelism, |
3166 | name: "no_parallelism" )) == MATCH_YES) |
3167 | { |
3168 | if (m == MATCH_ERROR) |
3169 | goto error; |
3170 | if (c->assume == NULL) |
3171 | c->assume = gfc_get_omp_assumptions (); |
3172 | c->assume->no_parallelism = needs_space = true; |
3173 | continue; |
3174 | } |
3175 | if ((mask & OMP_CLAUSE_NOGROUP) |
3176 | && (m = gfc_match_dupl_check (not_dupl: !c->nogroup, name: "nogroup" )) |
3177 | != MATCH_NO) |
3178 | { |
3179 | if (m == MATCH_ERROR) |
3180 | goto error; |
3181 | c->nogroup = needs_space = true; |
3182 | continue; |
3183 | } |
3184 | if ((mask & OMP_CLAUSE_NOHOST) |
3185 | && (m = gfc_match_dupl_check (not_dupl: !c->nohost, name: "nohost" )) != MATCH_NO) |
3186 | { |
3187 | if (m == MATCH_ERROR) |
3188 | goto error; |
3189 | c->nohost = needs_space = true; |
3190 | continue; |
3191 | } |
3192 | if ((mask & OMP_CLAUSE_NOTEMPORAL) |
3193 | && gfc_match_omp_variable_list (str: "nontemporal (" , |
3194 | list: &c->lists[OMP_LIST_NONTEMPORAL], |
3195 | allow_common: true) == MATCH_YES) |
3196 | continue; |
3197 | if ((mask & OMP_CLAUSE_NOTINBRANCH) |
3198 | && (m = gfc_match_dupl_check (not_dupl: !c->notinbranch && !c->inbranch, |
3199 | name: "notinbranch" )) != MATCH_NO) |
3200 | { |
3201 | if (m == MATCH_ERROR) |
3202 | goto error; |
3203 | c->notinbranch = needs_space = true; |
3204 | continue; |
3205 | } |
3206 | if ((mask & OMP_CLAUSE_NOWAIT) |
3207 | && (m = gfc_match_dupl_check (not_dupl: !c->nowait, name: "nowait" )) != MATCH_NO) |
3208 | { |
3209 | if (m == MATCH_ERROR) |
3210 | goto error; |
3211 | c->nowait = needs_space = true; |
3212 | continue; |
3213 | } |
3214 | if ((mask & OMP_CLAUSE_NUM_GANGS) |
3215 | && (m = gfc_match_dupl_check (not_dupl: !c->num_gangs_expr, name: "num_gangs" , |
3216 | open_parens: true)) != MATCH_NO) |
3217 | { |
3218 | if (m == MATCH_ERROR) |
3219 | goto error; |
3220 | if (gfc_match (" %e )" , &c->num_gangs_expr) != MATCH_YES) |
3221 | goto error; |
3222 | continue; |
3223 | } |
3224 | if ((mask & OMP_CLAUSE_NUM_TASKS) |
3225 | && (m = gfc_match_dupl_check (not_dupl: !c->num_tasks, name: "num_tasks" , open_parens: true)) |
3226 | != MATCH_NO) |
3227 | { |
3228 | if (m == MATCH_ERROR) |
3229 | goto error; |
3230 | if (gfc_match ("strict : " ) == MATCH_YES) |
3231 | c->num_tasks_strict = true; |
3232 | if (gfc_match (" %e )" , &c->num_tasks) != MATCH_YES) |
3233 | goto error; |
3234 | continue; |
3235 | } |
3236 | if ((mask & OMP_CLAUSE_NUM_TEAMS) |
3237 | && (m = gfc_match_dupl_check (not_dupl: !c->num_teams_upper, name: "num_teams" , |
3238 | open_parens: true)) != MATCH_NO) |
3239 | { |
3240 | if (m == MATCH_ERROR) |
3241 | goto error; |
3242 | if (gfc_match ("%e " , &c->num_teams_upper) != MATCH_YES) |
3243 | goto error; |
3244 | if (gfc_peek_ascii_char () == ':') |
3245 | { |
3246 | c->num_teams_lower = c->num_teams_upper; |
3247 | c->num_teams_upper = NULL; |
3248 | if (gfc_match (": %e " , &c->num_teams_upper) != MATCH_YES) |
3249 | goto error; |
3250 | } |
3251 | if (gfc_match (") " ) != MATCH_YES) |
3252 | goto error; |
3253 | continue; |
3254 | } |
3255 | if ((mask & OMP_CLAUSE_NUM_THREADS) |
3256 | && (m = gfc_match_dupl_check (not_dupl: !c->num_threads, name: "num_threads" , open_parens: true, |
3257 | expr: &c->num_threads)) != MATCH_NO) |
3258 | { |
3259 | if (m == MATCH_ERROR) |
3260 | goto error; |
3261 | continue; |
3262 | } |
3263 | if ((mask & OMP_CLAUSE_NUM_WORKERS) |
3264 | && (m = gfc_match_dupl_check (not_dupl: !c->num_workers_expr, name: "num_workers" , |
3265 | open_parens: true, expr: &c->num_workers_expr)) |
3266 | != MATCH_NO) |
3267 | { |
3268 | if (m == MATCH_ERROR) |
3269 | goto error; |
3270 | continue; |
3271 | } |
3272 | break; |
3273 | case 'o': |
3274 | if ((mask & OMP_CLAUSE_ORDER) |
3275 | && (m = gfc_match_dupl_check (not_dupl: !c->order_concurrent, name: "order (" )) |
3276 | != MATCH_NO) |
3277 | { |
3278 | if (m == MATCH_ERROR) |
3279 | goto error; |
3280 | if (gfc_match (" reproducible : concurrent )" ) == MATCH_YES) |
3281 | c->order_reproducible = true; |
3282 | else if (gfc_match (" concurrent )" ) == MATCH_YES) |
3283 | ; |
3284 | else if (gfc_match (" unconstrained : concurrent )" ) == MATCH_YES) |
3285 | c->order_unconstrained = true; |
3286 | else |
3287 | { |
3288 | gfc_error ("Expected ORDER(CONCURRENT) at %C " |
3289 | "with optional %<reproducible%> or " |
3290 | "%<unconstrained%> modifier" ); |
3291 | goto error; |
3292 | } |
3293 | c->order_concurrent = true; |
3294 | continue; |
3295 | } |
3296 | if ((mask & OMP_CLAUSE_ORDERED) |
3297 | && (m = gfc_match_dupl_check (not_dupl: !c->ordered, name: "ordered" )) |
3298 | != MATCH_NO) |
3299 | { |
3300 | if (m == MATCH_ERROR) |
3301 | goto error; |
3302 | gfc_expr *cexpr = NULL; |
3303 | m = gfc_match (" ( %e )" , &cexpr); |
3304 | |
3305 | c->ordered = true; |
3306 | if (m == MATCH_YES) |
3307 | { |
3308 | int ordered = 0; |
3309 | if (gfc_extract_int (cexpr, &ordered, -1)) |
3310 | ordered = 0; |
3311 | else if (ordered <= 0) |
3312 | { |
3313 | gfc_error_now ("ORDERED clause argument not" |
3314 | " constant positive integer at %C" ); |
3315 | ordered = 0; |
3316 | } |
3317 | c->orderedc = ordered; |
3318 | gfc_free_expr (cexpr); |
3319 | continue; |
3320 | } |
3321 | |
3322 | needs_space = true; |
3323 | continue; |
3324 | } |
3325 | break; |
3326 | case 'p': |
3327 | if ((mask & OMP_CLAUSE_COPY) |
3328 | && gfc_match ("pcopy ( " ) == MATCH_YES |
3329 | && gfc_match_omp_map_clause (list: &c->lists[OMP_LIST_MAP], |
3330 | map_op: OMP_MAP_TOFROM, allow_common: true, allow_derived)) |
3331 | continue; |
3332 | if ((mask & OMP_CLAUSE_COPYIN) |
3333 | && gfc_match ("pcopyin ( " ) == MATCH_YES |
3334 | && gfc_match_omp_map_clause (list: &c->lists[OMP_LIST_MAP], |
3335 | map_op: OMP_MAP_TO, allow_common: true, allow_derived)) |
3336 | continue; |
3337 | if ((mask & OMP_CLAUSE_COPYOUT) |
3338 | && gfc_match ("pcopyout ( " ) == MATCH_YES |
3339 | && gfc_match_omp_map_clause (list: &c->lists[OMP_LIST_MAP], |
3340 | map_op: OMP_MAP_FROM, allow_common: true, allow_derived)) |
3341 | continue; |
3342 | if ((mask & OMP_CLAUSE_CREATE) |
3343 | && gfc_match ("pcreate ( " ) == MATCH_YES |
3344 | && gfc_match_omp_map_clause (list: &c->lists[OMP_LIST_MAP], |
3345 | map_op: OMP_MAP_ALLOC, allow_common: true, allow_derived)) |
3346 | continue; |
3347 | if ((mask & OMP_CLAUSE_PRESENT) |
3348 | && gfc_match ("present ( " ) == MATCH_YES |
3349 | && gfc_match_omp_map_clause (list: &c->lists[OMP_LIST_MAP], |
3350 | map_op: OMP_MAP_FORCE_PRESENT, allow_common: false, |
3351 | allow_derived)) |
3352 | continue; |
3353 | if ((mask & OMP_CLAUSE_COPY) |
3354 | && gfc_match ("present_or_copy ( " ) == MATCH_YES |
3355 | && gfc_match_omp_map_clause (list: &c->lists[OMP_LIST_MAP], |
3356 | map_op: OMP_MAP_TOFROM, allow_common: true, |
3357 | allow_derived)) |
3358 | continue; |
3359 | if ((mask & OMP_CLAUSE_COPYIN) |
3360 | && gfc_match ("present_or_copyin ( " ) == MATCH_YES |
3361 | && gfc_match_omp_map_clause (list: &c->lists[OMP_LIST_MAP], |
3362 | map_op: OMP_MAP_TO, allow_common: true, allow_derived)) |
3363 | continue; |
3364 | if ((mask & OMP_CLAUSE_COPYOUT) |
3365 | && gfc_match ("present_or_copyout ( " ) == MATCH_YES |
3366 | && gfc_match_omp_map_clause (list: &c->lists[OMP_LIST_MAP], |
3367 | map_op: OMP_MAP_FROM, allow_common: true, allow_derived)) |
3368 | continue; |
3369 | if ((mask & OMP_CLAUSE_CREATE) |
3370 | && gfc_match ("present_or_create ( " ) == MATCH_YES |
3371 | && gfc_match_omp_map_clause (list: &c->lists[OMP_LIST_MAP], |
3372 | map_op: OMP_MAP_ALLOC, allow_common: true, allow_derived)) |
3373 | continue; |
3374 | if ((mask & OMP_CLAUSE_PRIORITY) |
3375 | && (m = gfc_match_dupl_check (not_dupl: !c->priority, name: "priority" , open_parens: true, |
3376 | expr: &c->priority)) != MATCH_NO) |
3377 | { |
3378 | if (m == MATCH_ERROR) |
3379 | goto error; |
3380 | continue; |
3381 | } |
3382 | if ((mask & OMP_CLAUSE_PRIVATE) |
3383 | && gfc_match_omp_variable_list (str: "private (" , |
3384 | list: &c->lists[OMP_LIST_PRIVATE], |
3385 | allow_common: true) == MATCH_YES) |
3386 | continue; |
3387 | if ((mask & OMP_CLAUSE_PROC_BIND) |
3388 | && (m = gfc_match_dupl_check (not_dupl: (c->proc_bind |
3389 | == OMP_PROC_BIND_UNKNOWN), |
3390 | name: "proc_bind" , open_parens: true)) != MATCH_NO) |
3391 | { |
3392 | if (m == MATCH_ERROR) |
3393 | goto error; |
3394 | if (gfc_match ("primary )" ) == MATCH_YES) |
3395 | c->proc_bind = OMP_PROC_BIND_PRIMARY; |
3396 | else if (gfc_match ("master )" ) == MATCH_YES) |
3397 | c->proc_bind = OMP_PROC_BIND_MASTER; |
3398 | else if (gfc_match ("spread )" ) == MATCH_YES) |
3399 | c->proc_bind = OMP_PROC_BIND_SPREAD; |
3400 | else if (gfc_match ("close )" ) == MATCH_YES) |
3401 | c->proc_bind = OMP_PROC_BIND_CLOSE; |
3402 | else |
3403 | goto error; |
3404 | continue; |
3405 | } |
3406 | break; |
3407 | case 'r': |
3408 | if ((mask & OMP_CLAUSE_ATOMIC) |
3409 | && (m = gfc_match_dupl_atomic (not_dupl: (c->atomic_op |
3410 | == GFC_OMP_ATOMIC_UNSET), |
3411 | name: "read" )) != MATCH_NO) |
3412 | { |
3413 | if (m == MATCH_ERROR) |
3414 | goto error; |
3415 | c->atomic_op = GFC_OMP_ATOMIC_READ; |
3416 | needs_space = true; |
3417 | continue; |
3418 | } |
3419 | if ((mask & OMP_CLAUSE_REDUCTION) |
3420 | && gfc_match_omp_clause_reduction (pc, c, openacc, |
3421 | allow_derived) == MATCH_YES) |
3422 | continue; |
3423 | if ((mask & OMP_CLAUSE_MEMORDER) |
3424 | && (m = gfc_match_dupl_memorder (not_dupl: (c->memorder |
3425 | == OMP_MEMORDER_UNSET), |
3426 | name: "relaxed" )) != MATCH_NO) |
3427 | { |
3428 | if (m == MATCH_ERROR) |
3429 | goto error; |
3430 | c->memorder = OMP_MEMORDER_RELAXED; |
3431 | needs_space = true; |
3432 | continue; |
3433 | } |
3434 | if ((mask & OMP_CLAUSE_MEMORDER) |
3435 | && (m = gfc_match_dupl_memorder (not_dupl: (c->memorder |
3436 | == OMP_MEMORDER_UNSET), |
3437 | name: "release" )) != MATCH_NO) |
3438 | { |
3439 | if (m == MATCH_ERROR) |
3440 | goto error; |
3441 | c->memorder = OMP_MEMORDER_RELEASE; |
3442 | needs_space = true; |
3443 | continue; |
3444 | } |
3445 | break; |
3446 | case 's': |
3447 | if ((mask & OMP_CLAUSE_SAFELEN) |
3448 | && (m = gfc_match_dupl_check (not_dupl: !c->safelen_expr, name: "safelen" , |
3449 | open_parens: true, expr: &c->safelen_expr)) |
3450 | != MATCH_NO) |
3451 | { |
3452 | if (m == MATCH_ERROR) |
3453 | goto error; |
3454 | continue; |
3455 | } |
3456 | if ((mask & OMP_CLAUSE_SCHEDULE) |
3457 | && (m = gfc_match_dupl_check (not_dupl: c->sched_kind == OMP_SCHED_NONE, |
3458 | name: "schedule" , open_parens: true)) != MATCH_NO) |
3459 | { |
3460 | if (m == MATCH_ERROR) |
3461 | goto error; |
3462 | int nmodifiers = 0; |
3463 | locus old_loc2 = gfc_current_locus; |
3464 | do |
3465 | { |
3466 | if (gfc_match ("simd" ) == MATCH_YES) |
3467 | { |
3468 | c->sched_simd = true; |
3469 | nmodifiers++; |
3470 | } |
3471 | else if (gfc_match ("monotonic" ) == MATCH_YES) |
3472 | { |
3473 | c->sched_monotonic = true; |
3474 | nmodifiers++; |
3475 | } |
3476 | else if (gfc_match ("nonmonotonic" ) == MATCH_YES) |
3477 | { |
3478 | c->sched_nonmonotonic = true; |
3479 | nmodifiers++; |
3480 | } |
3481 | else |
3482 | { |
3483 | if (nmodifiers) |
3484 | gfc_current_locus = old_loc2; |
3485 | break; |
3486 | } |
3487 | if (nmodifiers == 1 |
3488 | && gfc_match (" , " ) == MATCH_YES) |
3489 | continue; |
3490 | else if (gfc_match (" : " ) == MATCH_YES) |
3491 | break; |
3492 | gfc_current_locus = old_loc2; |
3493 | break; |
3494 | } |
3495 | while (1); |
3496 | if (gfc_match ("static" ) == MATCH_YES) |
3497 | c->sched_kind = OMP_SCHED_STATIC; |
3498 | else if (gfc_match ("dynamic" ) == MATCH_YES) |
3499 | c->sched_kind = OMP_SCHED_DYNAMIC; |
3500 | else if (gfc_match ("guided" ) == MATCH_YES) |
3501 | c->sched_kind = OMP_SCHED_GUIDED; |
3502 | else if (gfc_match ("runtime" ) == MATCH_YES) |
3503 | c->sched_kind = OMP_SCHED_RUNTIME; |
3504 | else if (gfc_match ("auto" ) == MATCH_YES) |
3505 | c->sched_kind = OMP_SCHED_AUTO; |
3506 | if (c->sched_kind != OMP_SCHED_NONE) |
3507 | { |
3508 | m = MATCH_NO; |
3509 | if (c->sched_kind != OMP_SCHED_RUNTIME |
3510 | && c->sched_kind != OMP_SCHED_AUTO) |
3511 | m = gfc_match (" , %e )" , &c->chunk_size); |
3512 | if (m != MATCH_YES) |
3513 | m = gfc_match_char (')'); |
3514 | if (m != MATCH_YES) |
3515 | c->sched_kind = OMP_SCHED_NONE; |
3516 | } |
3517 | if (c->sched_kind != OMP_SCHED_NONE) |
3518 | continue; |
3519 | else |
3520 | gfc_current_locus = old_loc; |
3521 | } |
3522 | if ((mask & OMP_CLAUSE_SELF) |
3523 | && !(mask & OMP_CLAUSE_HOST) /* OpenACC compute construct */ |
3524 | && (m = gfc_match_dupl_check (not_dupl: !c->self_expr, name: "self" )) |
3525 | != MATCH_NO) |
3526 | { |
3527 | if (m == MATCH_ERROR) |
3528 | goto error; |
3529 | m = gfc_match (" ( %e )" , &c->self_expr); |
3530 | if (m == MATCH_ERROR) |
3531 | { |
3532 | gfc_current_locus = old_loc; |
3533 | break; |
3534 | } |
3535 | else if (m == MATCH_NO) |
3536 | { |
3537 | c->self_expr = gfc_get_logical_expr (gfc_default_logical_kind, |
3538 | NULL, true); |
3539 | needs_space = true; |
3540 | } |
3541 | continue; |
3542 | } |
3543 | if ((mask & OMP_CLAUSE_SELF) |
3544 | && (mask & OMP_CLAUSE_HOST) /* OpenACC 'update' directive */ |
3545 | && gfc_match ("self ( " ) == MATCH_YES |
3546 | && gfc_match_omp_map_clause (list: &c->lists[OMP_LIST_MAP], |
3547 | map_op: OMP_MAP_FORCE_FROM, allow_common: true, |
3548 | /* allow_derived = */ true)) |
3549 | continue; |
3550 | if ((mask & OMP_CLAUSE_SEQ) |
3551 | && (m = gfc_match_dupl_check (not_dupl: !c->seq, name: "seq" )) != MATCH_NO) |
3552 | { |
3553 | if (m == MATCH_ERROR) |
3554 | goto error; |
3555 | c->seq = true; |
3556 | needs_space = true; |
3557 | continue; |
3558 | } |
3559 | if ((mask & OMP_CLAUSE_MEMORDER) |
3560 | && (m = gfc_match_dupl_memorder (not_dupl: (c->memorder |
3561 | == OMP_MEMORDER_UNSET), |
3562 | name: "seq_cst" )) != MATCH_NO) |
3563 | { |
3564 | if (m == MATCH_ERROR) |
3565 | goto error; |
3566 | c->memorder = OMP_MEMORDER_SEQ_CST; |
3567 | needs_space = true; |
3568 | continue; |
3569 | } |
3570 | if ((mask & OMP_CLAUSE_SHARED) |
3571 | && gfc_match_omp_variable_list (str: "shared (" , |
3572 | list: &c->lists[OMP_LIST_SHARED], |
3573 | allow_common: true) == MATCH_YES) |
3574 | continue; |
3575 | if ((mask & OMP_CLAUSE_SIMDLEN) |
3576 | && (m = gfc_match_dupl_check (not_dupl: !c->simdlen_expr, name: "simdlen" , open_parens: true, |
3577 | expr: &c->simdlen_expr)) != MATCH_NO) |
3578 | { |
3579 | if (m == MATCH_ERROR) |
3580 | goto error; |
3581 | continue; |
3582 | } |
3583 | if ((mask & OMP_CLAUSE_SIMD) |
3584 | && (m = gfc_match_dupl_check (not_dupl: !c->simd, name: "simd" )) != MATCH_NO) |
3585 | { |
3586 | if (m == MATCH_ERROR) |
3587 | goto error; |
3588 | c->simd = needs_space = true; |
3589 | continue; |
3590 | } |
3591 | if ((mask & OMP_CLAUSE_SEVERITY) |
3592 | && (m = gfc_match_dupl_check (not_dupl: !c->severity, name: "severity" , open_parens: true)) |
3593 | != MATCH_NO) |
3594 | { |
3595 | if (m == MATCH_ERROR) |
3596 | goto error; |
3597 | if (gfc_match ("fatal )" ) == MATCH_YES) |
3598 | c->severity = OMP_SEVERITY_FATAL; |
3599 | else if (gfc_match ("warning )" ) == MATCH_YES) |
3600 | c->severity = OMP_SEVERITY_WARNING; |
3601 | else |
3602 | { |
3603 | gfc_error ("Expected FATAL or WARNING in SEVERITY clause " |
3604 | "at %C" ); |
3605 | goto error; |
3606 | } |
3607 | continue; |
3608 | } |
3609 | break; |
3610 | case 't': |
3611 | if ((mask & OMP_CLAUSE_TASK_REDUCTION) |
3612 | && gfc_match_omp_clause_reduction (pc, c, openacc, |
3613 | allow_derived) == MATCH_YES) |
3614 | continue; |
3615 | if ((mask & OMP_CLAUSE_THREAD_LIMIT) |
3616 | && (m = gfc_match_dupl_check (not_dupl: !c->thread_limit, name: "thread_limit" , |
3617 | open_parens: true, expr: &c->thread_limit)) |
3618 | != MATCH_NO) |
3619 | { |
3620 | if (m == MATCH_ERROR) |
3621 | goto error; |
3622 | continue; |
3623 | } |
3624 | if ((mask & OMP_CLAUSE_THREADS) |
3625 | && (m = gfc_match_dupl_check (not_dupl: !c->threads, name: "threads" )) |
3626 | != MATCH_NO) |
3627 | { |
3628 | if (m == MATCH_ERROR) |
3629 | goto error; |
3630 | c->threads = needs_space = true; |
3631 | continue; |
3632 | } |
3633 | if ((mask & OMP_CLAUSE_TILE) |
3634 | && !c->tile_list |
3635 | && match_oacc_expr_list (str: "tile (" , list: &c->tile_list, |
3636 | allow_asterisk: true) == MATCH_YES) |
3637 | continue; |
3638 | if ((mask & OMP_CLAUSE_TO) && (mask & OMP_CLAUSE_LINK)) |
3639 | { |
3640 | /* Declare target: 'to' is an alias for 'enter'; |
3641 | 'to' is deprecated since 5.2. */ |
3642 | m = gfc_match_omp_to_link (str: "to (" , list: &c->lists[OMP_LIST_TO]); |
3643 | if (m == MATCH_ERROR) |
3644 | goto error; |
3645 | if (m == MATCH_YES) |
3646 | continue; |
3647 | } |
3648 | else if ((mask & OMP_CLAUSE_TO) |
3649 | && gfc_match_motion_var_list (str: "to (" , list: &c->lists[OMP_LIST_TO], |
3650 | headp: &head) == MATCH_YES) |
3651 | continue; |
3652 | break; |
3653 | case 'u': |
3654 | if ((mask & OMP_CLAUSE_UNIFORM) |
3655 | && gfc_match_omp_variable_list (str: "uniform (" , |
3656 | list: &c->lists[OMP_LIST_UNIFORM], |
3657 | allow_common: false) == MATCH_YES) |
3658 | continue; |
3659 | if ((mask & OMP_CLAUSE_UNTIED) |
3660 | && (m = gfc_match_dupl_check (not_dupl: !c->untied, name: "untied" )) != MATCH_NO) |
3661 | { |
3662 | if (m == MATCH_ERROR) |
3663 | goto error; |
3664 | c->untied = needs_space = true; |
3665 | continue; |
3666 | } |
3667 | if ((mask & OMP_CLAUSE_ATOMIC) |
3668 | && (m = gfc_match_dupl_atomic (not_dupl: (c->atomic_op |
3669 | == GFC_OMP_ATOMIC_UNSET), |
3670 | name: "update" )) != MATCH_NO) |
3671 | { |
3672 | if (m == MATCH_ERROR) |
3673 | goto error; |
3674 | c->atomic_op = GFC_OMP_ATOMIC_UPDATE; |
3675 | needs_space = true; |
3676 | continue; |
3677 | } |
3678 | if ((mask & OMP_CLAUSE_USE_DEVICE) |
3679 | && gfc_match_omp_variable_list (str: "use_device (" , |
3680 | list: &c->lists[OMP_LIST_USE_DEVICE], |
3681 | allow_common: true) == MATCH_YES) |
3682 | continue; |
3683 | if ((mask & OMP_CLAUSE_USE_DEVICE_PTR) |
3684 | && gfc_match_omp_variable_list |
3685 | (str: "use_device_ptr (" , |
3686 | list: &c->lists[OMP_LIST_USE_DEVICE_PTR], allow_common: false) == MATCH_YES) |
3687 | continue; |
3688 | if ((mask & OMP_CLAUSE_USE_DEVICE_ADDR) |
3689 | && gfc_match_omp_variable_list |
3690 | (str: "use_device_addr (" , list: &c->lists[OMP_LIST_USE_DEVICE_ADDR], |
3691 | allow_common: false, NULL, NULL, allow_sections: true) == MATCH_YES) |
3692 | continue; |
3693 | if ((mask & OMP_CLAUSE_USES_ALLOCATORS) |
3694 | && (gfc_match ("uses_allocators ( " ) == MATCH_YES)) |
3695 | { |
3696 | if (gfc_match_omp_clause_uses_allocators (c) != MATCH_YES) |
3697 | goto error; |
3698 | continue; |
3699 | } |
3700 | break; |
3701 | case 'v': |
3702 | /* VECTOR_LENGTH must be matched before VECTOR, because the latter |
3703 | doesn't unconditionally match '('. */ |
3704 | if ((mask & OMP_CLAUSE_VECTOR_LENGTH) |
3705 | && (m = gfc_match_dupl_check (not_dupl: !c->vector_length_expr, |
3706 | name: "vector_length" , open_parens: true, |
3707 | expr: &c->vector_length_expr)) |
3708 | != MATCH_NO) |
3709 | { |
3710 | if (m == MATCH_ERROR) |
3711 | goto error; |
3712 | continue; |
3713 | } |
3714 | if ((mask & OMP_CLAUSE_VECTOR) |
3715 | && (m = gfc_match_dupl_check (not_dupl: !c->vector, name: "vector" )) != MATCH_NO) |
3716 | { |
3717 | if (m == MATCH_ERROR) |
3718 | goto error; |
3719 | c->vector = true; |
3720 | m = match_oacc_clause_gwv (cp: c, GOMP_DIM_VECTOR); |
3721 | if (m == MATCH_ERROR) |
3722 | goto error; |
3723 | if (m == MATCH_NO) |
3724 | needs_space = true; |
3725 | continue; |
3726 | } |
3727 | break; |
3728 | case 'w': |
3729 | if ((mask & OMP_CLAUSE_WAIT) |
3730 | && gfc_match ("wait" ) == MATCH_YES) |
3731 | { |
3732 | m = match_oacc_expr_list (str: " (" , list: &c->wait_list, allow_asterisk: false); |
3733 | if (m == MATCH_ERROR) |
3734 | goto error; |
3735 | else if (m == MATCH_NO) |
3736 | { |
3737 | gfc_expr *expr |
3738 | = gfc_get_constant_expr (BT_INTEGER, |
3739 | gfc_default_integer_kind, |
3740 | &gfc_current_locus); |
3741 | mpz_set_si (expr->value.integer, GOMP_ASYNC_NOVAL); |
3742 | gfc_expr_list **expr_list = &c->wait_list; |
3743 | while (*expr_list) |
3744 | expr_list = &(*expr_list)->next; |
3745 | *expr_list = gfc_get_expr_list (); |
3746 | (*expr_list)->expr = expr; |
3747 | needs_space = true; |
3748 | } |
3749 | continue; |
3750 | } |
3751 | if ((mask & OMP_CLAUSE_WEAK) |
3752 | && (m = gfc_match_dupl_check (not_dupl: !c->weak, name: "weak" )) |
3753 | != MATCH_NO) |
3754 | { |
3755 | if (m == MATCH_ERROR) |
3756 | goto error; |
3757 | c->weak = true; |
3758 | needs_space = true; |
3759 | continue; |
3760 | } |
3761 | if ((mask & OMP_CLAUSE_WORKER) |
3762 | && (m = gfc_match_dupl_check (not_dupl: !c->worker, name: "worker" )) != MATCH_NO) |
3763 | { |
3764 | if (m == MATCH_ERROR) |
3765 | goto error; |
3766 | c->worker = true; |
3767 | m = match_oacc_clause_gwv (cp: c, GOMP_DIM_WORKER); |
3768 | if (m == MATCH_ERROR) |
3769 | goto error; |
3770 | else if (m == MATCH_NO) |
3771 | needs_space = true; |
3772 | continue; |
3773 | } |
3774 | if ((mask & OMP_CLAUSE_ATOMIC) |
3775 | && (m = gfc_match_dupl_atomic (not_dupl: (c->atomic_op |
3776 | == GFC_OMP_ATOMIC_UNSET), |
3777 | name: "write" )) != MATCH_NO) |
3778 | { |
3779 | if (m == MATCH_ERROR) |
3780 | goto error; |
3781 | c->atomic_op = GFC_OMP_ATOMIC_WRITE; |
3782 | needs_space = true; |
3783 | continue; |
3784 | } |
3785 | break; |
3786 | } |
3787 | break; |
3788 | } |
3789 | |
3790 | end: |
3791 | if (error |
3792 | || (context_selector && gfc_peek_ascii_char () != ')') |
3793 | || (!context_selector && gfc_match_omp_eos () != MATCH_YES)) |
3794 | { |
3795 | if (!gfc_error_flag_test ()) |
3796 | gfc_error ("Failed to match clause at %C" ); |
3797 | gfc_free_omp_clauses (c); |
3798 | return MATCH_ERROR; |
3799 | } |
3800 | |
3801 | *cp = c; |
3802 | return MATCH_YES; |
3803 | |
3804 | error: |
3805 | error = true; |
3806 | goto end; |
3807 | } |
3808 | |
3809 | |
3810 | #define OACC_PARALLEL_CLAUSES \ |
3811 | (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_NUM_GANGS \ |
3812 | | OMP_CLAUSE_NUM_WORKERS | OMP_CLAUSE_VECTOR_LENGTH | OMP_CLAUSE_REDUCTION \ |
3813 | | OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \ |
3814 | | OMP_CLAUSE_CREATE | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT \ |
3815 | | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \ |
3816 | | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT | OMP_CLAUSE_ATTACH \ |
3817 | | OMP_CLAUSE_SELF) |
3818 | #define OACC_KERNELS_CLAUSES \ |
3819 | (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_NUM_GANGS \ |
3820 | | OMP_CLAUSE_NUM_WORKERS | OMP_CLAUSE_VECTOR_LENGTH | OMP_CLAUSE_DEVICEPTR \ |
3821 | | OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \ |
3822 | | OMP_CLAUSE_CREATE | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT \ |
3823 | | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT | OMP_CLAUSE_ATTACH \ |
3824 | | OMP_CLAUSE_SELF) |
3825 | #define OACC_SERIAL_CLAUSES \ |
3826 | (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_REDUCTION \ |
3827 | | OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \ |
3828 | | OMP_CLAUSE_CREATE | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT \ |
3829 | | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \ |
3830 | | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT | OMP_CLAUSE_ATTACH \ |
3831 | | OMP_CLAUSE_SELF) |
3832 | #define OACC_DATA_CLAUSES \ |
3833 | (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_COPY \ |
3834 | | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT | OMP_CLAUSE_CREATE \ |
3835 | | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT | OMP_CLAUSE_ATTACH \ |
3836 | | OMP_CLAUSE_DEFAULT) |
3837 | #define OACC_LOOP_CLAUSES \ |
3838 | (omp_mask (OMP_CLAUSE_COLLAPSE) | OMP_CLAUSE_GANG | OMP_CLAUSE_WORKER \ |
3839 | | OMP_CLAUSE_VECTOR | OMP_CLAUSE_SEQ | OMP_CLAUSE_INDEPENDENT \ |
3840 | | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_AUTO \ |
3841 | | OMP_CLAUSE_TILE) |
3842 | #define OACC_PARALLEL_LOOP_CLAUSES \ |
3843 | (OACC_LOOP_CLAUSES | OACC_PARALLEL_CLAUSES) |
3844 | #define OACC_KERNELS_LOOP_CLAUSES \ |
3845 | (OACC_LOOP_CLAUSES | OACC_KERNELS_CLAUSES) |
3846 | #define OACC_SERIAL_LOOP_CLAUSES \ |
3847 | (OACC_LOOP_CLAUSES | OACC_SERIAL_CLAUSES) |
3848 | #define OACC_HOST_DATA_CLAUSES \ |
3849 | (omp_mask (OMP_CLAUSE_USE_DEVICE) \ |
3850 | | OMP_CLAUSE_IF \ |
3851 | | OMP_CLAUSE_IF_PRESENT) |
3852 | #define OACC_DECLARE_CLAUSES \ |
3853 | (omp_mask (OMP_CLAUSE_COPY) | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \ |
3854 | | OMP_CLAUSE_CREATE | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_DEVICE_RESIDENT \ |
3855 | | OMP_CLAUSE_PRESENT \ |
3856 | | OMP_CLAUSE_LINK) |
3857 | #define OACC_UPDATE_CLAUSES \ |
3858 | (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_HOST \ |
3859 | | OMP_CLAUSE_DEVICE | OMP_CLAUSE_WAIT | OMP_CLAUSE_IF_PRESENT \ |
3860 | | OMP_CLAUSE_SELF) |
3861 | #define OACC_ENTER_DATA_CLAUSES \ |
3862 | (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_WAIT \ |
3863 | | OMP_CLAUSE_COPYIN | OMP_CLAUSE_CREATE | OMP_CLAUSE_ATTACH) |
3864 | #define OACC_EXIT_DATA_CLAUSES \ |
3865 | (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_WAIT \ |
3866 | | OMP_CLAUSE_COPYOUT | OMP_CLAUSE_DELETE | OMP_CLAUSE_FINALIZE \ |
3867 | | OMP_CLAUSE_DETACH) |
3868 | #define OACC_WAIT_CLAUSES \ |
3869 | omp_mask (OMP_CLAUSE_ASYNC) |
3870 | #define OACC_ROUTINE_CLAUSES \ |
3871 | (omp_mask (OMP_CLAUSE_GANG) | OMP_CLAUSE_WORKER | OMP_CLAUSE_VECTOR \ |
3872 | | OMP_CLAUSE_SEQ \ |
3873 | | OMP_CLAUSE_NOHOST) |
3874 | |
3875 | |
3876 | static match |
3877 | match_acc (gfc_exec_op op, const omp_mask mask) |
3878 | { |
3879 | gfc_omp_clauses *c; |
3880 | if (gfc_match_omp_clauses (cp: &c, mask, first: false, needs_space: false, openacc: true) != MATCH_YES) |
3881 | return MATCH_ERROR; |
3882 | new_st.op = op; |
3883 | new_st.ext.omp_clauses = c; |
3884 | return MATCH_YES; |
3885 | } |
3886 | |
3887 | match |
3888 | gfc_match_oacc_parallel_loop (void) |
3889 | { |
3890 | return match_acc (op: EXEC_OACC_PARALLEL_LOOP, OACC_PARALLEL_LOOP_CLAUSES); |
3891 | } |
3892 | |
3893 | |
3894 | match |
3895 | gfc_match_oacc_parallel (void) |
3896 | { |
3897 | return match_acc (op: EXEC_OACC_PARALLEL, OACC_PARALLEL_CLAUSES); |
3898 | } |
3899 | |
3900 | |
3901 | match |
3902 | gfc_match_oacc_kernels_loop (void) |
3903 | { |
3904 | return match_acc (op: EXEC_OACC_KERNELS_LOOP, OACC_KERNELS_LOOP_CLAUSES); |
3905 | } |
3906 | |
3907 | |
3908 | match |
3909 | gfc_match_oacc_kernels (void) |
3910 | { |
3911 | return match_acc (op: EXEC_OACC_KERNELS, OACC_KERNELS_CLAUSES); |
3912 | } |
3913 | |
3914 | |
3915 | match |
3916 | gfc_match_oacc_serial_loop (void) |
3917 | { |
3918 | return match_acc (op: EXEC_OACC_SERIAL_LOOP, OACC_SERIAL_LOOP_CLAUSES); |
3919 | } |
3920 | |
3921 | |
3922 | match |
3923 | gfc_match_oacc_serial (void) |
3924 | { |
3925 | return match_acc (op: EXEC_OACC_SERIAL, OACC_SERIAL_CLAUSES); |
3926 | } |
3927 | |
3928 | |
3929 | match |
3930 | gfc_match_oacc_data (void) |
3931 | { |
3932 | return match_acc (op: EXEC_OACC_DATA, OACC_DATA_CLAUSES); |
3933 | } |
3934 | |
3935 | |
3936 | match |
3937 | gfc_match_oacc_host_data (void) |
3938 | { |
3939 | return match_acc (op: EXEC_OACC_HOST_DATA, OACC_HOST_DATA_CLAUSES); |
3940 | } |
3941 | |
3942 | |
3943 | match |
3944 | gfc_match_oacc_loop (void) |
3945 | { |
3946 | return match_acc (op: EXEC_OACC_LOOP, OACC_LOOP_CLAUSES); |
3947 | } |
3948 | |
3949 | |
3950 | match |
3951 | gfc_match_oacc_declare (void) |
3952 | { |
3953 | gfc_omp_clauses *c; |
3954 | gfc_omp_namelist *n; |
3955 | gfc_namespace *ns = gfc_current_ns; |
3956 | gfc_oacc_declare *new_oc; |
3957 | bool module_var = false; |
3958 | locus where = gfc_current_locus; |
3959 | |
3960 | if (gfc_match_omp_clauses (cp: &c, OACC_DECLARE_CLAUSES, first: false, needs_space: false, openacc: true) |
3961 | != MATCH_YES) |
3962 | return MATCH_ERROR; |
3963 | |
3964 | for (n = c->lists[OMP_LIST_DEVICE_RESIDENT]; n != NULL; n = n->next) |
3965 | n->sym->attr.oacc_declare_device_resident = 1; |
3966 | |
3967 | for (n = c->lists[OMP_LIST_LINK]; n != NULL; n = n->next) |
3968 | n->sym->attr.oacc_declare_link = 1; |
3969 | |
3970 | for (n = c->lists[OMP_LIST_MAP]; n != NULL; n = n->next) |
3971 | { |
3972 | gfc_symbol *s = n->sym; |
3973 | |
3974 | if (gfc_current_ns->proc_name |
3975 | && gfc_current_ns->proc_name->attr.flavor == FL_MODULE) |
3976 | { |
3977 | if (n->u.map_op != OMP_MAP_ALLOC && n->u.map_op != OMP_MAP_TO) |
3978 | { |
3979 | gfc_error ("Invalid clause in module with !$ACC DECLARE at %L" , |
3980 | &where); |
3981 | return MATCH_ERROR; |
3982 | } |
3983 | |
3984 | module_var = true; |
3985 | } |
3986 | |
3987 | if (s->attr.use_assoc) |
3988 | { |
3989 | gfc_error ("Variable is USE-associated with !$ACC DECLARE at %L" , |
3990 | &where); |
3991 | return MATCH_ERROR; |
3992 | } |
3993 | |
3994 | if ((s->result == s && s->ns->contained != gfc_current_ns) |
3995 | || ((s->attr.flavor == FL_UNKNOWN || s->attr.flavor == FL_VARIABLE) |
3996 | && s->ns != gfc_current_ns)) |
3997 | { |
3998 | gfc_error ("Variable %qs shall be declared in the same scoping unit " |
3999 | "as !$ACC DECLARE at %L" , s->name, &where); |
4000 | return MATCH_ERROR; |
4001 | } |
4002 | |
4003 | if ((s->attr.dimension || s->attr.codimension) |
4004 | && s->attr.dummy && s->as->type != AS_EXPLICIT) |
4005 | { |
4006 | gfc_error ("Assumed-size dummy array with !$ACC DECLARE at %L" , |
4007 | &where); |
4008 | return MATCH_ERROR; |
4009 | } |
4010 | |
4011 | switch (n->u.map_op) |
4012 | { |
4013 | case OMP_MAP_FORCE_ALLOC: |
4014 | case OMP_MAP_ALLOC: |
4015 | s->attr.oacc_declare_create = 1; |
4016 | break; |
4017 | |
4018 | case OMP_MAP_FORCE_TO: |
4019 | case OMP_MAP_TO: |
4020 | s->attr.oacc_declare_copyin = 1; |
4021 | break; |
4022 | |
4023 | case OMP_MAP_FORCE_DEVICEPTR: |
4024 | s->attr.oacc_declare_deviceptr = 1; |
4025 | break; |
4026 | |
4027 | default: |
4028 | break; |
4029 | } |
4030 | } |
4031 | |
4032 | new_oc = gfc_get_oacc_declare (); |
4033 | new_oc->next = ns->oacc_declare; |
4034 | new_oc->module_var = module_var; |
4035 | new_oc->clauses = c; |
4036 | new_oc->loc = gfc_current_locus; |
4037 | ns->oacc_declare = new_oc; |
4038 | |
4039 | return MATCH_YES; |
4040 | } |
4041 | |
4042 | |
4043 | match |
4044 | gfc_match_oacc_update (void) |
4045 | { |
4046 | gfc_omp_clauses *c; |
4047 | locus here = gfc_current_locus; |
4048 | |
4049 | if (gfc_match_omp_clauses (cp: &c, OACC_UPDATE_CLAUSES, first: false, needs_space: false, openacc: true) |
4050 | != MATCH_YES) |
4051 | return MATCH_ERROR; |
4052 | |
4053 | if (!c->lists[OMP_LIST_MAP]) |
4054 | { |
4055 | gfc_error ("%<acc update%> must contain at least one " |
4056 | "%<device%> or %<host%> or %<self%> clause at %L" , &here); |
4057 | return MATCH_ERROR; |
4058 | } |
4059 | |
4060 | new_st.op = EXEC_OACC_UPDATE; |
4061 | new_st.ext.omp_clauses = c; |
4062 | return MATCH_YES; |
4063 | } |
4064 | |
4065 | |
4066 | match |
4067 | gfc_match_oacc_enter_data (void) |
4068 | { |
4069 | return match_acc (op: EXEC_OACC_ENTER_DATA, OACC_ENTER_DATA_CLAUSES); |
4070 | } |
4071 | |
4072 | |
4073 | match |
4074 | gfc_match_oacc_exit_data (void) |
4075 | { |
4076 | return match_acc (op: EXEC_OACC_EXIT_DATA, OACC_EXIT_DATA_CLAUSES); |
4077 | } |
4078 | |
4079 | |
4080 | match |
4081 | gfc_match_oacc_wait (void) |
4082 | { |
4083 | gfc_omp_clauses *c = gfc_get_omp_clauses (); |
4084 | gfc_expr_list *wait_list = NULL, *el; |
4085 | bool space = true; |
4086 | match m; |
4087 | |
4088 | m = match_oacc_expr_list (str: " (" , list: &wait_list, allow_asterisk: true); |
4089 | if (m == MATCH_ERROR) |
4090 | return m; |
4091 | else if (m == MATCH_YES) |
4092 | space = false; |
4093 | |
4094 | if (gfc_match_omp_clauses (cp: &c, OACC_WAIT_CLAUSES, first: space, needs_space: space, openacc: true) |
4095 | == MATCH_ERROR) |
4096 | return MATCH_ERROR; |
4097 | |
4098 | if (wait_list) |
4099 | for (el = wait_list; el; el = el->next) |
4100 | { |
4101 | if (el->expr == NULL) |
4102 | { |
4103 | gfc_error ("Invalid argument to !$ACC WAIT at %C" ); |
4104 | return MATCH_ERROR; |
4105 | } |
4106 | |
4107 | if (!gfc_resolve_expr (el->expr) |
4108 | || el->expr->ts.type != BT_INTEGER || el->expr->rank != 0) |
4109 | { |
4110 | gfc_error ("WAIT clause at %L requires a scalar INTEGER expression" , |
4111 | &el->expr->where); |
4112 | |
4113 | return MATCH_ERROR; |
4114 | } |
4115 | } |
4116 | c->wait_list = wait_list; |
4117 | new_st.op = EXEC_OACC_WAIT; |
4118 | new_st.ext.omp_clauses = c; |
4119 | return MATCH_YES; |
4120 | } |
4121 | |
4122 | |
4123 | match |
4124 | gfc_match_oacc_cache (void) |
4125 | { |
4126 | gfc_omp_clauses *c = gfc_get_omp_clauses (); |
4127 | /* The OpenACC cache directive explicitly only allows "array elements or |
4128 | subarrays", which we're currently not checking here. Either check this |
4129 | after the call of gfc_match_omp_variable_list, or add something like a |
4130 | only_sections variant next to its allow_sections parameter. */ |
4131 | match m = gfc_match_omp_variable_list (str: " (" , |
4132 | list: &c->lists[OMP_LIST_CACHE], allow_common: true, |
4133 | NULL, NULL, allow_sections: true); |
4134 | if (m != MATCH_YES) |
4135 | { |
4136 | gfc_free_omp_clauses(c); |
4137 | return m; |
4138 | } |
4139 | |
4140 | if (gfc_current_state() != COMP_DO |
4141 | && gfc_current_state() != COMP_DO_CONCURRENT) |
4142 | { |
4143 | gfc_error ("ACC CACHE directive must be inside of loop %C" ); |
4144 | gfc_free_omp_clauses(c); |
4145 | return MATCH_ERROR; |
4146 | } |
4147 | |
4148 | new_st.op = EXEC_OACC_CACHE; |
4149 | new_st.ext.omp_clauses = c; |
4150 | return MATCH_YES; |
4151 | } |
4152 | |
4153 | /* Determine the OpenACC 'routine' directive's level of parallelism. */ |
4154 | |
4155 | static oacc_routine_lop |
4156 | gfc_oacc_routine_lop (gfc_omp_clauses *clauses) |
4157 | { |
4158 | oacc_routine_lop ret = OACC_ROUTINE_LOP_SEQ; |
4159 | |
4160 | if (clauses) |
4161 | { |
4162 | unsigned n_lop_clauses = 0; |
4163 | |
4164 | if (clauses->gang) |
4165 | { |
4166 | ++n_lop_clauses; |
4167 | ret = OACC_ROUTINE_LOP_GANG; |
4168 | } |
4169 | if (clauses->worker) |
4170 | { |
4171 | ++n_lop_clauses; |
4172 | ret = OACC_ROUTINE_LOP_WORKER; |
4173 | } |
4174 | if (clauses->vector) |
4175 | { |
4176 | ++n_lop_clauses; |
4177 | ret = OACC_ROUTINE_LOP_VECTOR; |
4178 | } |
4179 | if (clauses->seq) |
4180 | { |
4181 | ++n_lop_clauses; |
4182 | ret = OACC_ROUTINE_LOP_SEQ; |
4183 | } |
4184 | |
4185 | if (n_lop_clauses > 1) |
4186 | ret = OACC_ROUTINE_LOP_ERROR; |
4187 | } |
4188 | |
4189 | return ret; |
4190 | } |
4191 | |
4192 | match |
4193 | gfc_match_oacc_routine (void) |
4194 | { |
4195 | locus old_loc; |
4196 | match m; |
4197 | gfc_intrinsic_sym *isym = NULL; |
4198 | gfc_symbol *sym = NULL; |
4199 | gfc_omp_clauses *c = NULL; |
4200 | gfc_oacc_routine_name *n = NULL; |
4201 | oacc_routine_lop lop = OACC_ROUTINE_LOP_NONE; |
4202 | bool nohost; |
4203 | |
4204 | old_loc = gfc_current_locus; |
4205 | |
4206 | m = gfc_match (" (" ); |
4207 | |
4208 | if (gfc_current_ns->proc_name |
4209 | && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY |
4210 | && m == MATCH_YES) |
4211 | { |
4212 | gfc_error ("Only the !$ACC ROUTINE form without " |
4213 | "list is allowed in interface block at %C" ); |
4214 | goto cleanup; |
4215 | } |
4216 | |
4217 | if (m == MATCH_YES) |
4218 | { |
4219 | char buffer[GFC_MAX_SYMBOL_LEN + 1]; |
4220 | |
4221 | m = gfc_match_name (buffer); |
4222 | if (m == MATCH_YES) |
4223 | { |
4224 | gfc_symtree *st = NULL; |
4225 | |
4226 | /* First look for an intrinsic symbol. */ |
4227 | isym = gfc_find_function (buffer); |
4228 | if (!isym) |
4229 | isym = gfc_find_subroutine (buffer); |
4230 | /* If no intrinsic symbol found, search the current namespace. */ |
4231 | if (!isym) |
4232 | st = gfc_find_symtree (gfc_current_ns->sym_root, buffer); |
4233 | if (st) |
4234 | { |
4235 | sym = st->n.sym; |
4236 | /* If the name in a 'routine' directive refers to the containing |
4237 | subroutine or function, then make sure that we'll later handle |
4238 | this accordingly. */ |
4239 | if (gfc_current_ns->proc_name != NULL |
4240 | && strcmp (s1: sym->name, s2: gfc_current_ns->proc_name->name) == 0) |
4241 | sym = NULL; |
4242 | } |
4243 | |
4244 | if (isym == NULL && st == NULL) |
4245 | { |
4246 | gfc_error ("Invalid NAME %qs in !$ACC ROUTINE ( NAME ) at %C" , |
4247 | buffer); |
4248 | gfc_current_locus = old_loc; |
4249 | return MATCH_ERROR; |
4250 | } |
4251 | } |
4252 | else |
4253 | { |
4254 | gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C" ); |
4255 | gfc_current_locus = old_loc; |
4256 | return MATCH_ERROR; |
4257 | } |
4258 | |
4259 | if (gfc_match_char (')') != MATCH_YES) |
4260 | { |
4261 | gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C, expecting" |
4262 | " %<)%> after NAME" ); |
4263 | gfc_current_locus = old_loc; |
4264 | return MATCH_ERROR; |
4265 | } |
4266 | } |
4267 | |
4268 | if (gfc_match_omp_eos () != MATCH_YES |
4269 | && (gfc_match_omp_clauses (cp: &c, OACC_ROUTINE_CLAUSES, first: false, needs_space: false, openacc: true) |
4270 | != MATCH_YES)) |
4271 | return MATCH_ERROR; |
4272 | |
4273 | lop = gfc_oacc_routine_lop (clauses: c); |
4274 | if (lop == OACC_ROUTINE_LOP_ERROR) |
4275 | { |
4276 | gfc_error ("Multiple loop axes specified for routine at %C" ); |
4277 | goto cleanup; |
4278 | } |
4279 | nohost = c ? c->nohost : false; |
4280 | |
4281 | if (isym != NULL) |
4282 | { |
4283 | /* Diagnose any OpenACC 'routine' directive that doesn't match the |
4284 | (implicit) one with a 'seq' clause. */ |
4285 | if (c && (c->gang || c->worker || c->vector)) |
4286 | { |
4287 | gfc_error ("Intrinsic symbol specified in !$ACC ROUTINE ( NAME )" |
4288 | " at %C marked with incompatible GANG, WORKER, or VECTOR" |
4289 | " clause" ); |
4290 | goto cleanup; |
4291 | } |
4292 | /* ..., and no 'nohost' clause. */ |
4293 | if (nohost) |
4294 | { |
4295 | gfc_error ("Intrinsic symbol specified in !$ACC ROUTINE ( NAME )" |
4296 | " at %C marked with incompatible NOHOST clause" ); |
4297 | goto cleanup; |
4298 | } |
4299 | } |
4300 | else if (sym != NULL) |
4301 | { |
4302 | bool add = true; |
4303 | |
4304 | /* For a repeated OpenACC 'routine' directive, diagnose if it doesn't |
4305 | match the first one. */ |
4306 | for (gfc_oacc_routine_name *n_p = gfc_current_ns->oacc_routine_names; |
4307 | n_p; |
4308 | n_p = n_p->next) |
4309 | if (n_p->sym == sym) |
4310 | { |
4311 | add = false; |
4312 | bool nohost_p = n_p->clauses ? n_p->clauses->nohost : false; |
4313 | if (lop != gfc_oacc_routine_lop (clauses: n_p->clauses) |
4314 | || nohost != nohost_p) |
4315 | { |
4316 | gfc_error ("!$ACC ROUTINE already applied at %C" ); |
4317 | goto cleanup; |
4318 | } |
4319 | } |
4320 | |
4321 | if (add) |
4322 | { |
4323 | sym->attr.oacc_routine_lop = lop; |
4324 | sym->attr.oacc_routine_nohost = nohost; |
4325 | |
4326 | n = gfc_get_oacc_routine_name (); |
4327 | n->sym = sym; |
4328 | n->clauses = c; |
4329 | n->next = gfc_current_ns->oacc_routine_names; |
4330 | n->loc = old_loc; |
4331 | gfc_current_ns->oacc_routine_names = n; |
4332 | } |
4333 | } |
4334 | else if (gfc_current_ns->proc_name) |
4335 | { |
4336 | /* For a repeated OpenACC 'routine' directive, diagnose if it doesn't |
4337 | match the first one. */ |
4338 | oacc_routine_lop lop_p = gfc_current_ns->proc_name->attr.oacc_routine_lop; |
4339 | bool nohost_p = gfc_current_ns->proc_name->attr.oacc_routine_nohost; |
4340 | if (lop_p != OACC_ROUTINE_LOP_NONE |
4341 | && (lop != lop_p |
4342 | || nohost != nohost_p)) |
4343 | { |
4344 | gfc_error ("!$ACC ROUTINE already applied at %C" ); |
4345 | goto cleanup; |
4346 | } |
4347 | |
4348 | if (!gfc_add_omp_declare_target (&gfc_current_ns->proc_name->attr, |
4349 | gfc_current_ns->proc_name->name, |
4350 | &old_loc)) |
4351 | goto cleanup; |
4352 | gfc_current_ns->proc_name->attr.oacc_routine_lop = lop; |
4353 | gfc_current_ns->proc_name->attr.oacc_routine_nohost = nohost; |
4354 | } |
4355 | else |
4356 | /* Something has gone wrong, possibly a syntax error. */ |
4357 | goto cleanup; |
4358 | |
4359 | if (gfc_pure (NULL) && c && (c->gang || c->worker || c->vector)) |
4360 | { |
4361 | gfc_error ("!$ACC ROUTINE with GANG, WORKER, or VECTOR clause is not " |
4362 | "permitted in PURE procedure at %C" ); |
4363 | goto cleanup; |
4364 | } |
4365 | |
4366 | |
4367 | if (n) |
4368 | n->clauses = c; |
4369 | else if (gfc_current_ns->oacc_routine) |
4370 | gfc_current_ns->oacc_routine_clauses = c; |
4371 | |
4372 | new_st.op = EXEC_OACC_ROUTINE; |
4373 | new_st.ext.omp_clauses = c; |
4374 | return MATCH_YES; |
4375 | |
4376 | cleanup: |
4377 | gfc_current_locus = old_loc; |
4378 | return MATCH_ERROR; |
4379 | } |
4380 | |
4381 | |
4382 | #define OMP_PARALLEL_CLAUSES \ |
4383 | (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \ |
4384 | | OMP_CLAUSE_SHARED | OMP_CLAUSE_COPYIN | OMP_CLAUSE_REDUCTION \ |
4385 | | OMP_CLAUSE_IF | OMP_CLAUSE_NUM_THREADS | OMP_CLAUSE_DEFAULT \ |
4386 | | OMP_CLAUSE_PROC_BIND | OMP_CLAUSE_ALLOCATE) |
4387 | #define OMP_DECLARE_SIMD_CLAUSES \ |
4388 | (omp_mask (OMP_CLAUSE_SIMDLEN) | OMP_CLAUSE_LINEAR \ |
4389 | | OMP_CLAUSE_UNIFORM | OMP_CLAUSE_ALIGNED | OMP_CLAUSE_INBRANCH \ |
4390 | | OMP_CLAUSE_NOTINBRANCH) |
4391 | #define OMP_DO_CLAUSES \ |
4392 | (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \ |
4393 | | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION \ |
4394 | | OMP_CLAUSE_SCHEDULE | OMP_CLAUSE_ORDERED | OMP_CLAUSE_COLLAPSE \ |
4395 | | OMP_CLAUSE_LINEAR | OMP_CLAUSE_ORDER | OMP_CLAUSE_ALLOCATE \ |
4396 | | OMP_CLAUSE_NOWAIT) |
4397 | #define OMP_LOOP_CLAUSES \ |
4398 | (omp_mask (OMP_CLAUSE_BIND) | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_ORDER \ |
4399 | | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION) |
4400 | |
4401 | #define OMP_SCOPE_CLAUSES \ |
4402 | (omp_mask (OMP_CLAUSE_PRIVATE) |OMP_CLAUSE_FIRSTPRIVATE \ |
4403 | | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_ALLOCATE | OMP_CLAUSE_NOWAIT) |
4404 | #define OMP_SECTIONS_CLAUSES \ |
4405 | (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \ |
4406 | | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION \ |
4407 | | OMP_CLAUSE_ALLOCATE | OMP_CLAUSE_NOWAIT) |
4408 | #define OMP_SIMD_CLAUSES \ |
4409 | (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_LASTPRIVATE \ |
4410 | | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_SAFELEN \ |
4411 | | OMP_CLAUSE_LINEAR | OMP_CLAUSE_ALIGNED | OMP_CLAUSE_SIMDLEN \ |
4412 | | OMP_CLAUSE_IF | OMP_CLAUSE_ORDER | OMP_CLAUSE_NOTEMPORAL) |
4413 | #define OMP_TASK_CLAUSES \ |
4414 | (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \ |
4415 | | OMP_CLAUSE_SHARED | OMP_CLAUSE_IF | OMP_CLAUSE_DEFAULT \ |
4416 | | OMP_CLAUSE_UNTIED | OMP_CLAUSE_FINAL | OMP_CLAUSE_MERGEABLE \ |
4417 | | OMP_CLAUSE_DEPEND | OMP_CLAUSE_PRIORITY | OMP_CLAUSE_IN_REDUCTION \ |
4418 | | OMP_CLAUSE_DETACH | OMP_CLAUSE_AFFINITY | OMP_CLAUSE_ALLOCATE) |
4419 | #define OMP_TASKLOOP_CLAUSES \ |
4420 | (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \ |
4421 | | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_SHARED | OMP_CLAUSE_IF \ |
4422 | | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_UNTIED | OMP_CLAUSE_FINAL \ |
4423 | | OMP_CLAUSE_MERGEABLE | OMP_CLAUSE_PRIORITY | OMP_CLAUSE_GRAINSIZE \ |
4424 | | OMP_CLAUSE_NUM_TASKS | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_NOGROUP \ |
4425 | | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_IN_REDUCTION | OMP_CLAUSE_ALLOCATE) |
4426 | #define OMP_TASKGROUP_CLAUSES \ |
4427 | (omp_mask (OMP_CLAUSE_TASK_REDUCTION) | OMP_CLAUSE_ALLOCATE) |
4428 | #define OMP_TARGET_CLAUSES \ |
4429 | (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \ |
4430 | | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT | OMP_CLAUSE_PRIVATE \ |
4431 | | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_DEFAULTMAP \ |
4432 | | OMP_CLAUSE_IS_DEVICE_PTR | OMP_CLAUSE_IN_REDUCTION \ |
4433 | | OMP_CLAUSE_THREAD_LIMIT | OMP_CLAUSE_ALLOCATE \ |
4434 | | OMP_CLAUSE_HAS_DEVICE_ADDR | OMP_CLAUSE_USES_ALLOCATORS) |
4435 | #define OMP_TARGET_DATA_CLAUSES \ |
4436 | (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \ |
4437 | | OMP_CLAUSE_USE_DEVICE_PTR | OMP_CLAUSE_USE_DEVICE_ADDR) |
4438 | #define OMP_TARGET_ENTER_DATA_CLAUSES \ |
4439 | (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \ |
4440 | | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT) |
4441 | #define OMP_TARGET_EXIT_DATA_CLAUSES \ |
4442 | (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \ |
4443 | | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT) |
4444 | #define OMP_TARGET_UPDATE_CLAUSES \ |
4445 | (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_IF | OMP_CLAUSE_TO \ |
4446 | | OMP_CLAUSE_FROM | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT) |
4447 | #define OMP_TEAMS_CLAUSES \ |
4448 | (omp_mask (OMP_CLAUSE_NUM_TEAMS) | OMP_CLAUSE_THREAD_LIMIT \ |
4449 | | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \ |
4450 | | OMP_CLAUSE_SHARED | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_ALLOCATE) |
4451 | #define OMP_DISTRIBUTE_CLAUSES \ |
4452 | (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \ |
4453 | | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_DIST_SCHEDULE \ |
4454 | | OMP_CLAUSE_ORDER | OMP_CLAUSE_ALLOCATE) |
4455 | #define OMP_SINGLE_CLAUSES \ |
4456 | (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \ |
4457 | | OMP_CLAUSE_ALLOCATE | OMP_CLAUSE_NOWAIT | OMP_CLAUSE_COPYPRIVATE) |
4458 | #define OMP_ORDERED_CLAUSES \ |
4459 | (omp_mask (OMP_CLAUSE_THREADS) | OMP_CLAUSE_SIMD) |
4460 | #define OMP_DECLARE_TARGET_CLAUSES \ |
4461 | (omp_mask (OMP_CLAUSE_ENTER) | OMP_CLAUSE_LINK | OMP_CLAUSE_DEVICE_TYPE \ |
4462 | | OMP_CLAUSE_TO) |
4463 | #define OMP_ATOMIC_CLAUSES \ |
4464 | (omp_mask (OMP_CLAUSE_ATOMIC) | OMP_CLAUSE_CAPTURE | OMP_CLAUSE_HINT \ |
4465 | | OMP_CLAUSE_MEMORDER | OMP_CLAUSE_COMPARE | OMP_CLAUSE_FAIL \ |
4466 | | OMP_CLAUSE_WEAK) |
4467 | #define OMP_MASKED_CLAUSES \ |
4468 | (omp_mask (OMP_CLAUSE_FILTER)) |
4469 | #define OMP_ERROR_CLAUSES \ |
4470 | (omp_mask (OMP_CLAUSE_AT) | OMP_CLAUSE_MESSAGE | OMP_CLAUSE_SEVERITY) |
4471 | #define OMP_WORKSHARE_CLAUSES \ |
4472 | omp_mask (OMP_CLAUSE_NOWAIT) |
4473 | #define OMP_ALLOCATORS_CLAUSES \ |
4474 | omp_mask (OMP_CLAUSE_ALLOCATE) |
4475 | |
4476 | |
4477 | static match |
4478 | match_omp (gfc_exec_op op, const omp_mask mask) |
4479 | { |
4480 | gfc_omp_clauses *c; |
4481 | if (gfc_match_omp_clauses (cp: &c, mask, first: true, needs_space: true, openacc: false, context_selector: false, |
4482 | openmp_target: op == EXEC_OMP_TARGET) != MATCH_YES) |
4483 | return MATCH_ERROR; |
4484 | new_st.op = op; |
4485 | new_st.ext.omp_clauses = c; |
4486 | return MATCH_YES; |
4487 | } |
4488 | |
4489 | /* Handles both declarative and (deprecated) executable ALLOCATE directive; |
4490 | accepts optional list (for executable) and common blocks. |
4491 | If no variables have been provided, the single omp namelist has sym == NULL. |
4492 | |
4493 | Note that the executable ALLOCATE directive permits structure elements only |
4494 | in OpenMP 5.0 and 5.1 but not longer in 5.2. See also the comment on the |
4495 | 'omp allocators' directive below. The accidental change was reverted for |
4496 | OpenMP TR12, permitting them again. See also gfc_match_omp_allocators. |
4497 | |
4498 | Hence, structure elements are rejected for now, also to make resolving |
4499 | OMP_LIST_ALLOCATE simpler (check for duplicates, same symbol in |
4500 | Fortran allocate stmt). TODO: Permit structure elements. */ |
4501 | |
4502 | match |
4503 | gfc_match_omp_allocate (void) |
4504 | { |
4505 | match m; |
4506 | bool first = true; |
4507 | gfc_omp_namelist *vars = NULL; |
4508 | gfc_expr *align = NULL; |
4509 | gfc_expr *allocator = NULL; |
4510 | locus loc = gfc_current_locus; |
4511 | |
4512 | m = gfc_match_omp_variable_list (str: " (" , list: &vars, allow_common: true, NULL, NULL, allow_sections: true, allow_derived: true, |
4513 | NULL, reject_common_vars: true); |
4514 | |
4515 | if (m == MATCH_ERROR) |
4516 | return m; |
4517 | |
4518 | while (true) |
4519 | { |
4520 | gfc_gobble_whitespace (); |
4521 | if (gfc_match_omp_eos () == MATCH_YES) |
4522 | break; |
4523 | if (!first) |
4524 | gfc_match (", " ); |
4525 | first = false; |
4526 | if ((m = gfc_match_dupl_check (not_dupl: !align, name: "align" , open_parens: true, expr: &align)) |
4527 | != MATCH_NO) |
4528 | { |
4529 | if (m == MATCH_ERROR) |
4530 | goto error; |
4531 | continue; |
4532 | } |
4533 | if ((m = gfc_match_dupl_check (not_dupl: !allocator, name: "allocator" , |
4534 | open_parens: true, expr: &allocator)) != MATCH_NO) |
4535 | { |
4536 | if (m == MATCH_ERROR) |
4537 | goto error; |
4538 | continue; |
4539 | } |
4540 | gfc_error ("Expected ALIGN or ALLOCATOR clause at %C" ); |
4541 | return MATCH_ERROR; |
4542 | } |
4543 | for (gfc_omp_namelist *n = vars; n; n = n->next) |
4544 | if (n->expr) |
4545 | { |
4546 | if ((n->expr->ref && n->expr->ref->type == REF_COMPONENT) |
4547 | || (n->expr->ref->next && n->expr->ref->type == REF_COMPONENT)) |
4548 | gfc_error ("Sorry, structure-element list item at %L in ALLOCATE " |
4549 | "directive is not yet supported" , &n->expr->where); |
4550 | else |
4551 | gfc_error ("Unexpected expression as list item at %L in ALLOCATE " |
4552 | "directive" , &n->expr->where); |
4553 | |
4554 | gfc_free_omp_namelist (vars, false, true, false); |
4555 | goto error; |
4556 | } |
4557 | |
4558 | new_st.op = EXEC_OMP_ALLOCATE; |
4559 | new_st.ext.omp_clauses = gfc_get_omp_clauses (); |
4560 | if (vars == NULL) |
4561 | { |
4562 | vars = gfc_get_omp_namelist (); |
4563 | vars->where = loc; |
4564 | vars->u.align = align; |
4565 | vars->u2.allocator = allocator; |
4566 | new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE] = vars; |
4567 | } |
4568 | else |
4569 | { |
4570 | new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE] = vars; |
4571 | for (; vars; vars = vars->next) |
4572 | { |
4573 | vars->u.align = (align) ? gfc_copy_expr (align) : NULL; |
4574 | vars->u2.allocator = allocator; |
4575 | } |
4576 | gfc_free_expr (align); |
4577 | } |
4578 | return MATCH_YES; |
4579 | |
4580 | error: |
4581 | gfc_free_expr (align); |
4582 | gfc_free_expr (allocator); |
4583 | return MATCH_ERROR; |
4584 | } |
4585 | |
4586 | /* In line with OpenMP 5.2 derived-type components are rejected. |
4587 | See also comment before gfc_match_omp_allocate. */ |
4588 | |
4589 | match |
4590 | gfc_match_omp_allocators (void) |
4591 | { |
4592 | return match_omp (op: EXEC_OMP_ALLOCATORS, OMP_ALLOCATORS_CLAUSES); |
4593 | } |
4594 | |
4595 | |
4596 | match |
4597 | gfc_match_omp_assume (void) |
4598 | { |
4599 | gfc_omp_clauses *c; |
4600 | locus loc = gfc_current_locus; |
4601 | if ((gfc_match_omp_clauses (cp: &c, mask: omp_mask (OMP_CLAUSE_ASSUMPTIONS)) |
4602 | != MATCH_YES) |
4603 | || (omp_verify_merge_absent_contains (st: ST_OMP_ASSUME, check: c->assume, NULL, |
4604 | loc: &loc) != MATCH_YES)) |
4605 | return MATCH_ERROR; |
4606 | new_st.op = EXEC_OMP_ASSUME; |
4607 | new_st.ext.omp_clauses = c; |
4608 | return MATCH_YES; |
4609 | } |
4610 | |
4611 | |
4612 | match |
4613 | gfc_match_omp_assumes (void) |
4614 | { |
4615 | gfc_omp_clauses *c; |
4616 | locus loc = gfc_current_locus; |
4617 | if (!gfc_current_ns->proc_name |
4618 | || (gfc_current_ns->proc_name->attr.flavor != FL_MODULE |
4619 | && !gfc_current_ns->proc_name->attr.subroutine |
4620 | && !gfc_current_ns->proc_name->attr.function)) |
4621 | { |
4622 | gfc_error ("!$OMP ASSUMES at %C must be in the specification part of a " |
4623 | "subprogram or module" ); |
4624 | return MATCH_ERROR; |
4625 | } |
4626 | if ((gfc_match_omp_clauses (cp: &c, mask: omp_mask (OMP_CLAUSE_ASSUMPTIONS)) |
4627 | != MATCH_YES) |
4628 | || (omp_verify_merge_absent_contains (st: ST_OMP_ASSUMES, check: c->assume, |
4629 | merge: gfc_current_ns->omp_assumes, loc: &loc) |
4630 | != MATCH_YES)) |
4631 | return MATCH_ERROR; |
4632 | if (gfc_current_ns->omp_assumes == NULL) |
4633 | { |
4634 | gfc_current_ns->omp_assumes = c->assume; |
4635 | c->assume = NULL; |
4636 | } |
4637 | else if (gfc_current_ns->omp_assumes && c->assume) |
4638 | { |
4639 | gfc_current_ns->omp_assumes->no_openmp |= c->assume->no_openmp; |
4640 | gfc_current_ns->omp_assumes->no_openmp_routines |
4641 | |= c->assume->no_openmp_routines; |
4642 | gfc_current_ns->omp_assumes->no_parallelism |= c->assume->no_parallelism; |
4643 | if (gfc_current_ns->omp_assumes->holds && c->assume->holds) |
4644 | { |
4645 | gfc_expr_list *el = gfc_current_ns->omp_assumes->holds; |
4646 | for ( ; el->next ; el = el->next) |
4647 | ; |
4648 | el->next = c->assume->holds; |
4649 | } |
4650 | else if (c->assume->holds) |
4651 | gfc_current_ns->omp_assumes->holds = c->assume->holds; |
4652 | c->assume->holds = NULL; |
4653 | } |
4654 | gfc_free_omp_clauses (c); |
4655 | return MATCH_YES; |
4656 | } |
4657 | |
4658 | |
4659 | match |
4660 | gfc_match_omp_critical (void) |
4661 | { |
4662 | char n[GFC_MAX_SYMBOL_LEN+1]; |
4663 | gfc_omp_clauses *c = NULL; |
4664 | |
4665 | if (gfc_match (" ( %n )" , n) != MATCH_YES) |
4666 | n[0] = '\0'; |
4667 | |
4668 | if (gfc_match_omp_clauses (cp: &c, mask: omp_mask (OMP_CLAUSE_HINT), |
4669 | /* first = */ n[0] == '\0') != MATCH_YES) |
4670 | return MATCH_ERROR; |
4671 | |
4672 | new_st.op = EXEC_OMP_CRITICAL; |
4673 | new_st.ext.omp_clauses = c; |
4674 | if (n[0]) |
4675 | c->critical_name = xstrdup (n); |
4676 | return MATCH_YES; |
4677 | } |
4678 | |
4679 | |
4680 | match |
4681 | gfc_match_omp_end_critical (void) |
4682 | { |
4683 | char n[GFC_MAX_SYMBOL_LEN+1]; |
4684 | |
4685 | if (gfc_match (" ( %n )" , n) != MATCH_YES) |
4686 | n[0] = '\0'; |
4687 | if (gfc_match_omp_eos () != MATCH_YES) |
4688 | { |
4689 | gfc_error ("Unexpected junk after $OMP CRITICAL statement at %C" ); |
4690 | return MATCH_ERROR; |
4691 | } |
4692 | |
4693 | new_st.op = EXEC_OMP_END_CRITICAL; |
4694 | new_st.ext.omp_name = n[0] ? xstrdup (n) : NULL; |
4695 | return MATCH_YES; |
4696 | } |
4697 | |
4698 | /* depobj(depobj) depend(dep-type:loc)|destroy|update(dep-type) |
4699 | dep-type = in/out/inout/mutexinoutset/depobj/source/sink |
4700 | depend: !source, !sink |
4701 | update: !source, !sink, !depobj |
4702 | locator = exactly one list item .*/ |
4703 | match |
4704 | gfc_match_omp_depobj (void) |
4705 | { |
4706 | gfc_omp_clauses *c = NULL; |
4707 | gfc_expr *depobj; |
4708 | |
4709 | if (gfc_match (" ( %v ) " , &depobj) != MATCH_YES) |
4710 | { |
4711 | gfc_error ("Expected %<( depobj )%> at %C" ); |
4712 | return MATCH_ERROR; |
4713 | } |
4714 | if (gfc_match ("update ( " ) == MATCH_YES) |
4715 | { |
4716 | c = gfc_get_omp_clauses (); |
4717 | if (gfc_match ("inoutset )" ) == MATCH_YES) |
4718 | c->depobj_update = OMP_DEPEND_INOUTSET; |
4719 | else if (gfc_match ("inout )" ) == MATCH_YES) |
4720 | c->depobj_update = OMP_DEPEND_INOUT; |
4721 | else if (gfc_match ("in )" ) == MATCH_YES) |
4722 | c->depobj_update = OMP_DEPEND_IN; |
4723 | else if (gfc_match ("out )" ) == MATCH_YES) |
4724 | c->depobj_update = OMP_DEPEND_OUT; |
4725 | else if (gfc_match ("mutexinoutset )" ) == MATCH_YES) |
4726 | c->depobj_update = OMP_DEPEND_MUTEXINOUTSET; |
4727 | else |
4728 | { |
4729 | gfc_error ("Expected IN, OUT, INOUT, INOUTSET or MUTEXINOUTSET " |
4730 | "followed by %<)%> at %C" ); |
4731 | goto error; |
4732 | } |
4733 | } |
4734 | else if (gfc_match ("destroy" ) == MATCH_YES) |
4735 | { |
4736 | c = gfc_get_omp_clauses (); |
4737 | c->destroy = true; |
4738 | } |
4739 | else if (gfc_match_omp_clauses (cp: &c, mask: omp_mask (OMP_CLAUSE_DEPEND), first: true, needs_space: false) |
4740 | != MATCH_YES) |
4741 | goto error; |
4742 | |
4743 | if (c->depobj_update == OMP_DEPEND_UNSET && !c->destroy) |
4744 | { |
4745 | if (!c->doacross_source && !c->lists[OMP_LIST_DEPEND]) |
4746 | { |
4747 | gfc_error ("Expected DEPEND, UPDATE, or DESTROY clause at %C" ); |
4748 | goto error; |
4749 | } |
4750 | if (c->lists[OMP_LIST_DEPEND]->u.depend_doacross_op == OMP_DEPEND_DEPOBJ) |
4751 | { |
4752 | gfc_error ("DEPEND clause at %L of OMP DEPOBJ construct shall not " |
4753 | "have dependence-type DEPOBJ" , |
4754 | c->lists[OMP_LIST_DEPEND] |
4755 | ? &c->lists[OMP_LIST_DEPEND]->where : &gfc_current_locus); |
4756 | goto error; |
4757 | } |
4758 | if (c->lists[OMP_LIST_DEPEND]->next) |
4759 | { |
4760 | gfc_error ("DEPEND clause at %L of OMP DEPOBJ construct shall have " |
4761 | "only a single locator" , |
4762 | &c->lists[OMP_LIST_DEPEND]->next->where); |
4763 | goto error; |
4764 | } |
4765 | } |
4766 | |
4767 | c->depobj = depobj; |
4768 | new_st.op = EXEC_OMP_DEPOBJ; |
4769 | new_st.ext.omp_clauses = c; |
4770 | return MATCH_YES; |
4771 | |
4772 | error: |
4773 | gfc_free_expr (depobj); |
4774 | gfc_free_omp_clauses (c); |
4775 | return MATCH_ERROR; |
4776 | } |
4777 | |
4778 | match |
4779 | gfc_match_omp_distribute (void) |
4780 | { |
4781 | return match_omp (op: EXEC_OMP_DISTRIBUTE, OMP_DISTRIBUTE_CLAUSES); |
4782 | } |
4783 | |
4784 | |
4785 | match |
4786 | gfc_match_omp_distribute_parallel_do (void) |
4787 | { |
4788 | return match_omp (op: EXEC_OMP_DISTRIBUTE_PARALLEL_DO, |
4789 | mask: (OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES |
4790 | | OMP_DO_CLAUSES) |
4791 | & ~(omp_mask (OMP_CLAUSE_ORDERED) |
4792 | | OMP_CLAUSE_LINEAR | OMP_CLAUSE_NOWAIT)); |
4793 | } |
4794 | |
4795 | |
4796 | match |
4797 | gfc_match_omp_distribute_parallel_do_simd (void) |
4798 | { |
4799 | return match_omp (op: EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD, |
4800 | mask: (OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES |
4801 | | OMP_DO_CLAUSES | OMP_SIMD_CLAUSES) |
4802 | & ~(omp_mask (OMP_CLAUSE_ORDERED) | OMP_CLAUSE_NOWAIT)); |
4803 | } |
4804 | |
4805 | |
4806 | match |
4807 | gfc_match_omp_distribute_simd (void) |
4808 | { |
4809 | return match_omp (op: EXEC_OMP_DISTRIBUTE_SIMD, |
4810 | OMP_DISTRIBUTE_CLAUSES | OMP_SIMD_CLAUSES); |
4811 | } |
4812 | |
4813 | |
4814 | match |
4815 | gfc_match_omp_do (void) |
4816 | { |
4817 | return match_omp (op: EXEC_OMP_DO, OMP_DO_CLAUSES); |
4818 | } |
4819 | |
4820 | |
4821 | match |
4822 | gfc_match_omp_do_simd (void) |
4823 | { |
4824 | return match_omp (op: EXEC_OMP_DO_SIMD, OMP_DO_CLAUSES | OMP_SIMD_CLAUSES); |
4825 | } |
4826 | |
4827 | |
4828 | match |
4829 | gfc_match_omp_loop (void) |
4830 | { |
4831 | return match_omp (op: EXEC_OMP_LOOP, OMP_LOOP_CLAUSES); |
4832 | } |
4833 | |
4834 | |
4835 | match |
4836 | gfc_match_omp_teams_loop (void) |
4837 | { |
4838 | return match_omp (op: EXEC_OMP_TEAMS_LOOP, OMP_TEAMS_CLAUSES | OMP_LOOP_CLAUSES); |
4839 | } |
4840 | |
4841 | |
4842 | match |
4843 | gfc_match_omp_target_teams_loop (void) |
4844 | { |
4845 | return match_omp (op: EXEC_OMP_TARGET_TEAMS_LOOP, |
4846 | OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES | OMP_LOOP_CLAUSES); |
4847 | } |
4848 | |
4849 | |
4850 | match |
4851 | gfc_match_omp_parallel_loop (void) |
4852 | { |
4853 | return match_omp (op: EXEC_OMP_PARALLEL_LOOP, |
4854 | OMP_PARALLEL_CLAUSES | OMP_LOOP_CLAUSES); |
4855 | } |
4856 | |
4857 | |
4858 | match |
4859 | gfc_match_omp_target_parallel_loop (void) |
4860 | { |
4861 | return match_omp (op: EXEC_OMP_TARGET_PARALLEL_LOOP, |
4862 | mask: (OMP_TARGET_CLAUSES | OMP_PARALLEL_CLAUSES |
4863 | | OMP_LOOP_CLAUSES)); |
4864 | } |
4865 | |
4866 | |
4867 | match |
4868 | gfc_match_omp_error (void) |
4869 | { |
4870 | locus loc = gfc_current_locus; |
4871 | match m = match_omp (op: EXEC_OMP_ERROR, OMP_ERROR_CLAUSES); |
4872 | if (m != MATCH_YES) |
4873 | return m; |
4874 | |
4875 | gfc_omp_clauses *c = new_st.ext.omp_clauses; |
4876 | if (c->severity == OMP_SEVERITY_UNSET) |
4877 | c->severity = OMP_SEVERITY_FATAL; |
4878 | if (new_st.ext.omp_clauses->at == OMP_AT_EXECUTION) |
4879 | return MATCH_YES; |
4880 | if (c->message |
4881 | && (!gfc_resolve_expr (c->message) |
4882 | || c->message->ts.type != BT_CHARACTER |
4883 | || c->message->ts.kind != gfc_default_character_kind |
4884 | || c->message->rank != 0)) |
4885 | { |
4886 | gfc_error ("MESSAGE clause at %L requires a scalar default-kind " |
4887 | "CHARACTER expression" , |
4888 | &new_st.ext.omp_clauses->message->where); |
4889 | return MATCH_ERROR; |
4890 | } |
4891 | if (c->message && !gfc_is_constant_expr (c->message)) |
4892 | { |
4893 | gfc_error ("Constant character expression required in MESSAGE clause " |
4894 | "at %L" , &new_st.ext.omp_clauses->message->where); |
4895 | return MATCH_ERROR; |
4896 | } |
4897 | if (c->message) |
4898 | { |
4899 | const char *msg = G_("$OMP ERROR encountered at %L: %s" ); |
4900 | gcc_assert (c->message->expr_type == EXPR_CONSTANT); |
4901 | gfc_charlen_t slen = c->message->value.character.length; |
4902 | int i = gfc_validate_kind (BT_CHARACTER, gfc_default_character_kind, |
4903 | false); |
4904 | size_t size = slen * gfc_character_kinds[i].bit_size / 8; |
4905 | unsigned char *s = XCNEWVAR (unsigned char, size + 1); |
4906 | gfc_encode_character (gfc_default_character_kind, slen, |
4907 | c->message->value.character.string, |
4908 | (unsigned char *) s, size); |
4909 | s[size] = '\0'; |
4910 | if (c->severity == OMP_SEVERITY_WARNING) |
4911 | gfc_warning_now (opt: 0, msg, &loc, s); |
4912 | else |
4913 | gfc_error_now (msg, &loc, s); |
4914 | free (ptr: s); |
4915 | } |
4916 | else |
4917 | { |
4918 | const char *msg = G_("$OMP ERROR encountered at %L" ); |
4919 | if (c->severity == OMP_SEVERITY_WARNING) |
4920 | gfc_warning_now (opt: 0, msg, &loc); |
4921 | else |
4922 | gfc_error_now (msg, &loc); |
4923 | } |
4924 | return MATCH_YES; |
4925 | } |
4926 | |
4927 | match |
4928 | gfc_match_omp_flush (void) |
4929 | { |
4930 | gfc_omp_namelist *list = NULL; |
4931 | gfc_omp_clauses *c = NULL; |
4932 | gfc_gobble_whitespace (); |
4933 | enum gfc_omp_memorder mo = OMP_MEMORDER_UNSET; |
4934 | if (gfc_match_omp_eos () == MATCH_NO && gfc_peek_ascii_char () != '(') |
4935 | { |
4936 | if (gfc_match ("seq_cst" ) == MATCH_YES) |
4937 | mo = OMP_MEMORDER_SEQ_CST; |
4938 | else if (gfc_match ("acq_rel" ) == MATCH_YES) |
4939 | mo = OMP_MEMORDER_ACQ_REL; |
4940 | else if (gfc_match ("release" ) == MATCH_YES) |
4941 | mo = OMP_MEMORDER_RELEASE; |
4942 | else if (gfc_match ("acquire" ) == MATCH_YES) |
4943 | mo = OMP_MEMORDER_ACQUIRE; |
4944 | else |
4945 | { |
4946 | gfc_error ("Expected SEQ_CST, AQC_REL, RELEASE, or ACQUIRE at %C" ); |
4947 | return MATCH_ERROR; |
4948 | } |
4949 | c = gfc_get_omp_clauses (); |
4950 | c->memorder = mo; |
4951 | } |
4952 | gfc_match_omp_variable_list (str: " (" , list: &list, allow_common: true); |
4953 | if (list && mo != OMP_MEMORDER_UNSET) |
4954 | { |
4955 | gfc_error ("List specified together with memory order clause in FLUSH " |
4956 | "directive at %C" ); |
4957 | gfc_free_omp_namelist (list, false, false, false); |
4958 | gfc_free_omp_clauses (c); |
4959 | return MATCH_ERROR; |
4960 | } |
4961 | if (gfc_match_omp_eos () != MATCH_YES) |
4962 | { |
4963 | gfc_error ("Unexpected junk after $OMP FLUSH statement at %C" ); |
4964 | gfc_free_omp_namelist (list, false, false, false); |
4965 | gfc_free_omp_clauses (c); |
4966 | return MATCH_ERROR; |
4967 | } |
4968 | new_st.op = EXEC_OMP_FLUSH; |
4969 | new_st.ext.omp_namelist = list; |
4970 | new_st.ext.omp_clauses = c; |
4971 | return MATCH_YES; |
4972 | } |
4973 | |
4974 | |
4975 | match |
4976 | gfc_match_omp_declare_simd (void) |
4977 | { |
4978 | locus where = gfc_current_locus; |
4979 | gfc_symbol *proc_name; |
4980 | gfc_omp_clauses *c; |
4981 | gfc_omp_declare_simd *ods; |
4982 | bool needs_space = false; |
4983 | |
4984 | switch (gfc_match (" ( " )) |
4985 | { |
4986 | case MATCH_YES: |
4987 | if (gfc_match_symbol (&proc_name, /* host assoc = */ true) != MATCH_YES |
4988 | || gfc_match (" ) " ) != MATCH_YES) |
4989 | return MATCH_ERROR; |
4990 | break; |
4991 | case MATCH_NO: proc_name = NULL; needs_space = true; break; |
4992 | case MATCH_ERROR: return MATCH_ERROR; |
4993 | } |
4994 | |
4995 | if (gfc_match_omp_clauses (cp: &c, OMP_DECLARE_SIMD_CLAUSES, first: true, |
4996 | needs_space) != MATCH_YES) |
4997 | return MATCH_ERROR; |
4998 | |
4999 | if (gfc_current_ns->is_block_data) |
5000 | { |
5001 | gfc_free_omp_clauses (c); |
5002 | return MATCH_YES; |
5003 | } |
5004 | |
5005 | ods = gfc_get_omp_declare_simd (); |
5006 | ods->where = where; |
5007 | ods->proc_name = proc_name; |
5008 | ods->clauses = c; |
5009 | ods->next = gfc_current_ns->omp_declare_simd; |
5010 | gfc_current_ns->omp_declare_simd = ods; |
5011 | return MATCH_YES; |
5012 | } |
5013 | |
5014 | |
5015 | static bool |
5016 | match_udr_expr (gfc_symtree *omp_sym1, gfc_symtree *omp_sym2) |
5017 | { |
5018 | match m; |
5019 | locus old_loc = gfc_current_locus; |
5020 | char sname[GFC_MAX_SYMBOL_LEN + 1]; |
5021 | gfc_symbol *sym; |
5022 | gfc_namespace *ns = gfc_current_ns; |
5023 | gfc_expr *lvalue = NULL, *rvalue = NULL; |
5024 | gfc_symtree *st; |
5025 | gfc_actual_arglist *arglist; |
5026 | |
5027 | m = gfc_match (" %v =" , &lvalue); |
5028 | if (m != MATCH_YES) |
5029 | gfc_current_locus = old_loc; |
5030 | else |
5031 | { |
5032 | m = gfc_match (" %e )" , &rvalue); |
5033 | if (m == MATCH_YES) |
5034 | { |
5035 | ns->code = gfc_get_code (EXEC_ASSIGN); |
5036 | ns->code->expr1 = lvalue; |
5037 | ns->code->expr2 = rvalue; |
5038 | ns->code->loc = old_loc; |
5039 | return true; |
5040 | } |
5041 | |
5042 | gfc_current_locus = old_loc; |
5043 | gfc_free_expr (lvalue); |
5044 | } |
5045 | |
5046 | m = gfc_match (" %n" , sname); |
5047 | if (m != MATCH_YES) |
5048 | return false; |
5049 | |
5050 | if (strcmp (s1: sname, s2: omp_sym1->name) == 0 |
5051 | || strcmp (s1: sname, s2: omp_sym2->name) == 0) |
5052 | return false; |
5053 | |
5054 | gfc_current_ns = ns->parent; |
5055 | if (gfc_get_ha_sym_tree (sname, &st)) |
5056 | return false; |
5057 | |
5058 | sym = st->n.sym; |
5059 | if (sym->attr.flavor != FL_PROCEDURE |
5060 | && sym->attr.flavor != FL_UNKNOWN) |
5061 | return false; |
5062 | |
5063 | if (!sym->attr.generic |
5064 | && !sym->attr.subroutine |
5065 | && !sym->attr.function) |
5066 | { |
5067 | if (!(sym->attr.external && !sym->attr.referenced)) |
5068 | { |
5069 | /* ...create a symbol in this scope... */ |
5070 | if (sym->ns != gfc_current_ns |
5071 | && gfc_get_sym_tree (sname, NULL, &st, false) == 1) |
5072 | return false; |
5073 | |
5074 | if (sym != st->n.sym) |
5075 | sym = st->n.sym; |
5076 | } |
5077 | |
5078 | /* ...and then to try to make the symbol into a subroutine. */ |
5079 | if (!gfc_add_subroutine (&sym->attr, sym->name, NULL)) |
5080 | return false; |
5081 | } |
5082 | |
5083 | gfc_set_sym_referenced (sym); |
5084 | gfc_gobble_whitespace (); |
5085 | if (gfc_peek_ascii_char () != '(') |
5086 | return false; |
5087 | |
5088 | gfc_current_ns = ns; |
5089 | m = gfc_match_actual_arglist (1, &arglist); |
5090 | if (m != MATCH_YES) |
5091 | return false; |
5092 | |
5093 | if (gfc_match_char (')') != MATCH_YES) |
5094 | return false; |
5095 | |
5096 | ns->code = gfc_get_code (EXEC_CALL); |
5097 | ns->code->symtree = st; |
5098 | ns->code->ext.actual = arglist; |
5099 | ns->code->loc = old_loc; |
5100 | return true; |
5101 | } |
5102 | |
5103 | static bool |
5104 | gfc_omp_udr_predef (gfc_omp_reduction_op rop, const char *name, |
5105 | gfc_typespec *ts, const char **n) |
5106 | { |
5107 | if (!gfc_numeric_ts (ts) && ts->type != BT_LOGICAL) |
5108 | return false; |
5109 | |
5110 | switch (rop) |
5111 | { |
5112 | case OMP_REDUCTION_PLUS: |
5113 | case OMP_REDUCTION_MINUS: |
5114 | case OMP_REDUCTION_TIMES: |
5115 | return ts->type != BT_LOGICAL; |
5116 | case OMP_REDUCTION_AND: |
5117 | case OMP_REDUCTION_OR: |
5118 | case OMP_REDUCTION_EQV: |
5119 | case OMP_REDUCTION_NEQV: |
5120 | return ts->type == BT_LOGICAL; |
5121 | case OMP_REDUCTION_USER: |
5122 | if (name[0] != '.' && (ts->type == BT_INTEGER || ts->type == BT_REAL)) |
5123 | { |
5124 | gfc_symbol *sym; |
5125 | |
5126 | gfc_find_symbol (name, NULL, 1, &sym); |
5127 | if (sym != NULL) |
5128 | { |
5129 | if (sym->attr.intrinsic) |
5130 | *n = sym->name; |
5131 | else if ((sym->attr.flavor != FL_UNKNOWN |
5132 | && sym->attr.flavor != FL_PROCEDURE) |
5133 | || sym->attr.external |
5134 | || sym->attr.generic |
5135 | || sym->attr.entry |
5136 | || sym->attr.result |
5137 | || sym->attr.dummy |
5138 | || sym->attr.subroutine |
5139 | || sym->attr.pointer |
5140 | || sym->attr.target |
5141 | || sym->attr.cray_pointer |
5142 | || sym->attr.cray_pointee |
5143 | || (sym->attr.proc != PROC_UNKNOWN |
5144 | && sym->attr.proc != PROC_INTRINSIC) |
5145 | || sym->attr.if_source != IFSRC_UNKNOWN |
5146 | || sym == sym->ns->proc_name) |
5147 | *n = NULL; |
5148 | else |
5149 | *n = sym->name; |
5150 | } |
5151 | else |
5152 | *n = name; |
5153 | if (*n |
5154 | && (strcmp (s1: *n, s2: "max" ) == 0 || strcmp (s1: *n, s2: "min" ) == 0)) |
5155 | return true; |
5156 | else if (*n |
5157 | && ts->type == BT_INTEGER |
5158 | && (strcmp (s1: *n, s2: "iand" ) == 0 |
5159 | || strcmp (s1: *n, s2: "ior" ) == 0 |
5160 | || strcmp (s1: *n, s2: "ieor" ) == 0)) |
5161 | return true; |
5162 | } |
5163 | break; |
5164 | default: |
5165 | break; |
5166 | } |
5167 | return false; |
5168 | } |
5169 | |
5170 | gfc_omp_udr * |
5171 | gfc_omp_udr_find (gfc_symtree *st, gfc_typespec *ts) |
5172 | { |
5173 | gfc_omp_udr *omp_udr; |
5174 | |
5175 | if (st == NULL) |
5176 | return NULL; |
5177 | |
5178 | for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next) |
5179 | if (omp_udr->ts.type == ts->type |
5180 | || ((omp_udr->ts.type == BT_DERIVED || omp_udr->ts.type == BT_CLASS) |
5181 | && (ts->type == BT_DERIVED || ts->type == BT_CLASS))) |
5182 | { |
5183 | if (omp_udr->ts.type == BT_DERIVED || omp_udr->ts.type == BT_CLASS) |
5184 | { |
5185 | if (strcmp (s1: omp_udr->ts.u.derived->name, s2: ts->u.derived->name) == 0) |
5186 | return omp_udr; |
5187 | } |
5188 | else if (omp_udr->ts.kind == ts->kind) |
5189 | { |
5190 | if (omp_udr->ts.type == BT_CHARACTER) |
5191 | { |
5192 | if (omp_udr->ts.u.cl->length == NULL |
5193 | || ts->u.cl->length == NULL) |
5194 | return omp_udr; |
5195 | if (omp_udr->ts.u.cl->length->expr_type != EXPR_CONSTANT) |
5196 | return omp_udr; |
5197 | if (ts->u.cl->length->expr_type != EXPR_CONSTANT) |
5198 | return omp_udr; |
5199 | if (omp_udr->ts.u.cl->length->ts.type != BT_INTEGER) |
5200 | return omp_udr; |
5201 | if (ts->u.cl->length->ts.type != BT_INTEGER) |
5202 | return omp_udr; |
5203 | if (gfc_compare_expr (omp_udr->ts.u.cl->length, |
5204 | ts->u.cl->length, INTRINSIC_EQ) != 0) |
5205 | continue; |
5206 | } |
5207 | return omp_udr; |
5208 | } |
5209 | } |
5210 | return NULL; |
5211 | } |
5212 | |
5213 | match |
5214 | gfc_match_omp_declare_reduction (void) |
5215 | { |
5216 | match m; |
5217 | gfc_intrinsic_op op; |
5218 | char name[GFC_MAX_SYMBOL_LEN + 3]; |
5219 | auto_vec<gfc_typespec, 5> tss; |
5220 | gfc_typespec ts; |
5221 | unsigned int i; |
5222 | gfc_symtree *st; |
5223 | locus where = gfc_current_locus; |
5224 | locus end_loc = gfc_current_locus; |
5225 | bool end_loc_set = false; |
5226 | gfc_omp_reduction_op rop = OMP_REDUCTION_NONE; |
5227 | |
5228 | if (gfc_match_char ('(') != MATCH_YES) |
5229 | return MATCH_ERROR; |
5230 | |
5231 | m = gfc_match (" %o : " , &op); |
5232 | if (m == MATCH_ERROR) |
5233 | return MATCH_ERROR; |
5234 | if (m == MATCH_YES) |
5235 | { |
5236 | snprintf (s: name, maxlen: sizeof name, format: "operator %s" , gfc_op2string (op)); |
5237 | rop = (gfc_omp_reduction_op) op; |
5238 | } |
5239 | else |
5240 | { |
5241 | m = gfc_match_defined_op_name (name + 1, 1); |
5242 | if (m == MATCH_ERROR) |
5243 | return MATCH_ERROR; |
5244 | if (m == MATCH_YES) |
5245 | { |
5246 | name[0] = '.'; |
5247 | strcat (dest: name, src: "." ); |
5248 | if (gfc_match (" : " ) != MATCH_YES) |
5249 | return MATCH_ERROR; |
5250 | } |
5251 | else |
5252 | { |
5253 | if (gfc_match (" %n : " , name) != MATCH_YES) |
5254 | return MATCH_ERROR; |
5255 | } |
5256 | rop = OMP_REDUCTION_USER; |
5257 | } |
5258 | |
5259 | m = gfc_match_type_spec (&ts); |
5260 | if (m != MATCH_YES) |
5261 | return MATCH_ERROR; |
5262 | /* Treat len=: the same as len=*. */ |
5263 | if (ts.type == BT_CHARACTER) |
5264 | ts.deferred = false; |
5265 | tss.safe_push (obj: ts); |
5266 | |
5267 | while (gfc_match_char (',') == MATCH_YES) |
5268 | { |
5269 | m = gfc_match_type_spec (&ts); |
5270 | if (m != MATCH_YES) |
5271 | return MATCH_ERROR; |
5272 | tss.safe_push (obj: ts); |
5273 | } |
5274 | if (gfc_match_char (':') != MATCH_YES) |
5275 | return MATCH_ERROR; |
5276 | |
5277 | st = gfc_find_symtree (gfc_current_ns->omp_udr_root, name); |
5278 | for (i = 0; i < tss.length (); i++) |
5279 | { |
5280 | gfc_symtree *omp_out, *omp_in; |
5281 | gfc_symtree *omp_priv = NULL, *omp_orig = NULL; |
5282 | gfc_namespace *combiner_ns, *initializer_ns = NULL; |
5283 | gfc_omp_udr *prev_udr, *omp_udr; |
5284 | const char *predef_name = NULL; |
5285 | |
5286 | omp_udr = gfc_get_omp_udr (); |
5287 | omp_udr->name = gfc_get_string ("%s" , name); |
5288 | omp_udr->rop = rop; |
5289 | omp_udr->ts = tss[i]; |
5290 | omp_udr->where = where; |
5291 | |
5292 | gfc_current_ns = combiner_ns = gfc_get_namespace (gfc_current_ns, 1); |
5293 | combiner_ns->proc_name = combiner_ns->parent->proc_name; |
5294 | |
5295 | gfc_get_sym_tree ("omp_out" , combiner_ns, &omp_out, false); |
5296 | gfc_get_sym_tree ("omp_in" , combiner_ns, &omp_in, false); |
5297 | combiner_ns->omp_udr_ns = 1; |
5298 | omp_out->n.sym->ts = tss[i]; |
5299 | omp_in->n.sym->ts = tss[i]; |
5300 | omp_out->n.sym->attr.omp_udr_artificial_var = 1; |
5301 | omp_in->n.sym->attr.omp_udr_artificial_var = 1; |
5302 | omp_out->n.sym->attr.flavor = FL_VARIABLE; |
5303 | omp_in->n.sym->attr.flavor = FL_VARIABLE; |
5304 | gfc_commit_symbols (); |
5305 | omp_udr->combiner_ns = combiner_ns; |
5306 | omp_udr->omp_out = omp_out->n.sym; |
5307 | omp_udr->omp_in = omp_in->n.sym; |
5308 | |
5309 | locus old_loc = gfc_current_locus; |
5310 | |
5311 | if (!match_udr_expr (omp_sym1: omp_out, omp_sym2: omp_in)) |
5312 | { |
5313 | syntax: |
5314 | gfc_current_locus = old_loc; |
5315 | gfc_current_ns = combiner_ns->parent; |
5316 | gfc_undo_symbols (); |
5317 | gfc_free_omp_udr (omp_udr); |
5318 | return MATCH_ERROR; |
5319 | } |
5320 | |
5321 | if (gfc_match (" initializer ( " ) == MATCH_YES) |
5322 | { |
5323 | gfc_current_ns = combiner_ns->parent; |
5324 | initializer_ns = gfc_get_namespace (gfc_current_ns, 1); |
5325 | gfc_current_ns = initializer_ns; |
5326 | initializer_ns->proc_name = initializer_ns->parent->proc_name; |
5327 | |
5328 | gfc_get_sym_tree ("omp_priv" , initializer_ns, &omp_priv, false); |
5329 | gfc_get_sym_tree ("omp_orig" , initializer_ns, &omp_orig, false); |
5330 | initializer_ns->omp_udr_ns = 1; |
5331 | omp_priv->n.sym->ts = tss[i]; |
5332 | omp_orig->n.sym->ts = tss[i]; |
5333 | omp_priv->n.sym->attr.omp_udr_artificial_var = 1; |
5334 | omp_orig->n.sym->attr.omp_udr_artificial_var = 1; |
5335 | omp_priv->n.sym->attr.flavor = FL_VARIABLE; |
5336 | omp_orig->n.sym->attr.flavor = FL_VARIABLE; |
5337 | gfc_commit_symbols (); |
5338 | omp_udr->initializer_ns = initializer_ns; |
5339 | omp_udr->omp_priv = omp_priv->n.sym; |
5340 | omp_udr->omp_orig = omp_orig->n.sym; |
5341 | |
5342 | if (!match_udr_expr (omp_sym1: omp_priv, omp_sym2: omp_orig)) |
5343 | goto syntax; |
5344 | } |
5345 | |
5346 | gfc_current_ns = combiner_ns->parent; |
5347 | if (!end_loc_set) |
5348 | { |
5349 | end_loc_set = true; |
5350 | end_loc = gfc_current_locus; |
5351 | } |
5352 | gfc_current_locus = old_loc; |
5353 | |
5354 | prev_udr = gfc_omp_udr_find (st, ts: &tss[i]); |
5355 | if (gfc_omp_udr_predef (rop, name, ts: &tss[i], n: &predef_name) |
5356 | /* Don't error on !$omp declare reduction (min : integer : ...) |
5357 | just yet, there could be integer :: min afterwards, |
5358 | making it valid. When the UDR is resolved, we'll get |
5359 | to it again. */ |
5360 | && (rop != OMP_REDUCTION_USER || name[0] == '.')) |
5361 | { |
5362 | if (predef_name) |
5363 | gfc_error_now ("Redefinition of predefined %s " |
5364 | "!$OMP DECLARE REDUCTION at %L" , |
5365 | predef_name, &where); |
5366 | else |
5367 | gfc_error_now ("Redefinition of predefined " |
5368 | "!$OMP DECLARE REDUCTION at %L" , &where); |
5369 | } |
5370 | else if (prev_udr) |
5371 | { |
5372 | gfc_error_now ("Redefinition of !$OMP DECLARE REDUCTION at %L" , |
5373 | &where); |
5374 | gfc_error_now ("Previous !$OMP DECLARE REDUCTION at %L" , |
5375 | &prev_udr->where); |
5376 | } |
5377 | else if (st) |
5378 | { |
5379 | omp_udr->next = st->n.omp_udr; |
5380 | st->n.omp_udr = omp_udr; |
5381 | } |
5382 | else |
5383 | { |
5384 | st = gfc_new_symtree (&gfc_current_ns->omp_udr_root, name); |
5385 | st->n.omp_udr = omp_udr; |
5386 | } |
5387 | } |
5388 | |
5389 | if (end_loc_set) |
5390 | { |
5391 | gfc_current_locus = end_loc; |
5392 | if (gfc_match_omp_eos () != MATCH_YES) |
5393 | { |
5394 | gfc_error ("Unexpected junk after !$OMP DECLARE REDUCTION at %C" ); |
5395 | gfc_current_locus = where; |
5396 | return MATCH_ERROR; |
5397 | } |
5398 | |
5399 | return MATCH_YES; |
5400 | } |
5401 | gfc_clear_error (); |
5402 | return MATCH_ERROR; |
5403 | } |
5404 | |
5405 | |
5406 | match |
5407 | gfc_match_omp_declare_target (void) |
5408 | { |
5409 | locus old_loc; |
5410 | match m; |
5411 | gfc_omp_clauses *c = NULL; |
5412 | int list; |
5413 | gfc_omp_namelist *n; |
5414 | gfc_symbol *s; |
5415 | |
5416 | old_loc = gfc_current_locus; |
5417 | |
5418 | if (gfc_current_ns->proc_name |
5419 | && gfc_match_omp_eos () == MATCH_YES) |
5420 | { |
5421 | if (!gfc_add_omp_declare_target (&gfc_current_ns->proc_name->attr, |
5422 | gfc_current_ns->proc_name->name, |
5423 | &old_loc)) |
5424 | goto cleanup; |
5425 | return MATCH_YES; |
5426 | } |
5427 | |
5428 | if (gfc_current_ns->proc_name |
5429 | && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY) |
5430 | { |
5431 | gfc_error ("Only the !$OMP DECLARE TARGET form without " |
5432 | "clauses is allowed in interface block at %C" ); |
5433 | goto cleanup; |
5434 | } |
5435 | |
5436 | m = gfc_match (" (" ); |
5437 | if (m == MATCH_YES) |
5438 | { |
5439 | c = gfc_get_omp_clauses (); |
5440 | gfc_current_locus = old_loc; |
5441 | m = gfc_match_omp_to_link (str: " (" , list: &c->lists[OMP_LIST_ENTER]); |
5442 | if (m != MATCH_YES) |
5443 | goto syntax; |
5444 | if (gfc_match_omp_eos () != MATCH_YES) |
5445 | { |
5446 | gfc_error ("Unexpected junk after !$OMP DECLARE TARGET at %C" ); |
5447 | goto cleanup; |
5448 | } |
5449 | } |
5450 | else if (gfc_match_omp_clauses (cp: &c, OMP_DECLARE_TARGET_CLAUSES) != MATCH_YES) |
5451 | return MATCH_ERROR; |
5452 | |
5453 | gfc_buffer_error (false); |
5454 | |
5455 | static const int to_enter_link_lists[] |
5456 | = { OMP_LIST_TO, OMP_LIST_ENTER, OMP_LIST_LINK }; |
5457 | for (size_t listn = 0; listn < ARRAY_SIZE (to_enter_link_lists) |
5458 | && (list = to_enter_link_lists[listn], true); ++listn) |
5459 | for (n = c->lists[list]; n; n = n->next) |
5460 | if (n->sym) |
5461 | n->sym->mark = 0; |
5462 | else if (n->u.common->head) |
5463 | n->u.common->head->mark = 0; |
5464 | |
5465 | for (size_t listn = 0; listn < ARRAY_SIZE (to_enter_link_lists) |
5466 | && (list = to_enter_link_lists[listn], true); ++listn) |
5467 | for (n = c->lists[list]; n; n = n->next) |
5468 | if (n->sym) |
5469 | { |
5470 | if (n->sym->attr.in_common) |
5471 | gfc_error_now ("OMP DECLARE TARGET variable at %L is an " |
5472 | "element of a COMMON block" , &n->where); |
5473 | else if (n->sym->mark) |
5474 | gfc_error_now ("Variable at %L mentioned multiple times in " |
5475 | "clauses of the same OMP DECLARE TARGET directive" , |
5476 | &n->where); |
5477 | else if (n->sym->attr.omp_declare_target |
5478 | && n->sym->attr.omp_declare_target_link |
5479 | && list != OMP_LIST_LINK) |
5480 | gfc_error_now ("OMP DECLARE TARGET variable at %L previously " |
5481 | "mentioned in LINK clause and later in %s clause" , |
5482 | &n->where, list == OMP_LIST_TO ? "TO" : "ENTER" ); |
5483 | else if (n->sym->attr.omp_declare_target |
5484 | && !n->sym->attr.omp_declare_target_link |
5485 | && list == OMP_LIST_LINK) |
5486 | gfc_error_now ("OMP DECLARE TARGET variable at %L previously " |
5487 | "mentioned in TO or ENTER clause and later in " |
5488 | "LINK clause" , &n->where); |
5489 | else if (gfc_add_omp_declare_target (&n->sym->attr, n->sym->name, |
5490 | &n->sym->declared_at)) |
5491 | { |
5492 | if (list == OMP_LIST_LINK) |
5493 | gfc_add_omp_declare_target_link (&n->sym->attr, n->sym->name, |
5494 | &n->sym->declared_at); |
5495 | } |
5496 | if (c->device_type != OMP_DEVICE_TYPE_UNSET) |
5497 | { |
5498 | if (n->sym->attr.omp_device_type != OMP_DEVICE_TYPE_UNSET |
5499 | && n->sym->attr.omp_device_type != c->device_type) |
5500 | gfc_error_now ("List item %qs at %L set in previous OMP DECLARE " |
5501 | "TARGET directive to a different DEVICE_TYPE" , |
5502 | n->sym->name, &n->where); |
5503 | n->sym->attr.omp_device_type = c->device_type; |
5504 | } |
5505 | n->sym->mark = 1; |
5506 | } |
5507 | else if (n->u.common->omp_declare_target |
5508 | && n->u.common->omp_declare_target_link |
5509 | && list != OMP_LIST_LINK) |
5510 | gfc_error_now ("OMP DECLARE TARGET COMMON at %L previously " |
5511 | "mentioned in LINK clause and later in %s clause" , |
5512 | &n->where, list == OMP_LIST_TO ? "TO" : "ENTER" ); |
5513 | else if (n->u.common->omp_declare_target |
5514 | && !n->u.common->omp_declare_target_link |
5515 | && list == OMP_LIST_LINK) |
5516 | gfc_error_now ("OMP DECLARE TARGET COMMON at %L previously " |
5517 | "mentioned in TO or ENTER clause and later in " |
5518 | "LINK clause" , &n->where); |
5519 | else if (n->u.common->head && n->u.common->head->mark) |
5520 | gfc_error_now ("COMMON at %L mentioned multiple times in " |
5521 | "clauses of the same OMP DECLARE TARGET directive" , |
5522 | &n->where); |
5523 | else |
5524 | { |
5525 | n->u.common->omp_declare_target = 1; |
5526 | n->u.common->omp_declare_target_link = (list == OMP_LIST_LINK); |
5527 | if (n->u.common->omp_device_type != OMP_DEVICE_TYPE_UNSET |
5528 | && n->u.common->omp_device_type != c->device_type) |
5529 | gfc_error_now ("COMMON at %L set in previous OMP DECLARE " |
5530 | "TARGET directive to a different DEVICE_TYPE" , |
5531 | &n->where); |
5532 | n->u.common->omp_device_type = c->device_type; |
5533 | |
5534 | for (s = n->u.common->head; s; s = s->common_next) |
5535 | { |
5536 | s->mark = 1; |
5537 | if (gfc_add_omp_declare_target (&s->attr, s->name, |
5538 | &s->declared_at)) |
5539 | { |
5540 | if (list == OMP_LIST_LINK) |
5541 | gfc_add_omp_declare_target_link (&s->attr, s->name, |
5542 | &s->declared_at); |
5543 | } |
5544 | if (s->attr.omp_device_type != OMP_DEVICE_TYPE_UNSET |
5545 | && s->attr.omp_device_type != c->device_type) |
5546 | gfc_error_now ("List item %qs at %L set in previous OMP DECLARE" |
5547 | " TARGET directive to a different DEVICE_TYPE" , |
5548 | s->name, &n->where); |
5549 | s->attr.omp_device_type = c->device_type; |
5550 | } |
5551 | } |
5552 | if (c->device_type |
5553 | && !c->lists[OMP_LIST_ENTER] |
5554 | && !c->lists[OMP_LIST_TO] |
5555 | && !c->lists[OMP_LIST_LINK]) |
5556 | gfc_warning_now (opt: 0, "OMP DECLARE TARGET directive at %L with only " |
5557 | "DEVICE_TYPE clause is ignored" , &old_loc); |
5558 | |
5559 | gfc_buffer_error (true); |
5560 | |
5561 | if (c) |
5562 | gfc_free_omp_clauses (c); |
5563 | return MATCH_YES; |
5564 | |
5565 | syntax: |
5566 | gfc_error ("Syntax error in !$OMP DECLARE TARGET list at %C" ); |
5567 | |
5568 | cleanup: |
5569 | gfc_current_locus = old_loc; |
5570 | if (c) |
5571 | gfc_free_omp_clauses (c); |
5572 | return MATCH_ERROR; |
5573 | } |
5574 | |
5575 | |
5576 | static const char *const omp_construct_selectors[] = { |
5577 | "simd" , "target" , "teams" , "parallel" , "do" , NULL }; |
5578 | static const char *const omp_device_selectors[] = { |
5579 | "kind" , "isa" , "arch" , NULL }; |
5580 | static const char *const omp_implementation_selectors[] = { |
5581 | "vendor" , "extension" , "atomic_default_mem_order" , "unified_address" , |
5582 | "unified_shared_memory" , "dynamic_allocators" , "reverse_offload" , NULL }; |
5583 | static const char *const omp_user_selectors[] = { |
5584 | "condition" , NULL }; |
5585 | |
5586 | |
5587 | /* OpenMP 5.0: |
5588 | |
5589 | trait-selector: |
5590 | trait-selector-name[([trait-score:]trait-property[,trait-property[,...]])] |
5591 | |
5592 | trait-score: |
5593 | score(score-expression) */ |
5594 | |
5595 | match |
5596 | gfc_match_omp_context_selector (gfc_omp_set_selector *oss) |
5597 | { |
5598 | do |
5599 | { |
5600 | char selector[GFC_MAX_SYMBOL_LEN + 1]; |
5601 | |
5602 | if (gfc_match_name (selector) != MATCH_YES) |
5603 | { |
5604 | gfc_error ("expected trait selector name at %C" ); |
5605 | return MATCH_ERROR; |
5606 | } |
5607 | |
5608 | gfc_omp_selector *os = gfc_get_omp_selector (); |
5609 | os->trait_selector_name = XNEWVEC (char, strlen (selector) + 1); |
5610 | strcpy (dest: os->trait_selector_name, src: selector); |
5611 | os->next = oss->trait_selectors; |
5612 | oss->trait_selectors = os; |
5613 | |
5614 | const char *const *selectors = NULL; |
5615 | bool allow_score = true; |
5616 | bool allow_user = false; |
5617 | int property_limit = 0; |
5618 | enum gfc_omp_trait_property_kind property_kind = CTX_PROPERTY_NONE; |
5619 | switch (oss->trait_set_selector_name[0]) |
5620 | { |
5621 | case 'c': /* construct */ |
5622 | selectors = omp_construct_selectors; |
5623 | allow_score = false; |
5624 | property_limit = 1; |
5625 | property_kind = CTX_PROPERTY_SIMD; |
5626 | break; |
5627 | case 'd': /* device */ |
5628 | selectors = omp_device_selectors; |
5629 | allow_score = false; |
5630 | allow_user = true; |
5631 | property_limit = 3; |
5632 | property_kind = CTX_PROPERTY_NAME_LIST; |
5633 | break; |
5634 | case 'i': /* implementation */ |
5635 | selectors = omp_implementation_selectors; |
5636 | allow_user = true; |
5637 | property_limit = 3; |
5638 | property_kind = CTX_PROPERTY_NAME_LIST; |
5639 | break; |
5640 | case 'u': /* user */ |
5641 | selectors = omp_user_selectors; |
5642 | property_limit = 1; |
5643 | property_kind = CTX_PROPERTY_EXPR; |
5644 | break; |
5645 | default: |
5646 | gcc_unreachable (); |
5647 | } |
5648 | for (int i = 0; ; i++) |
5649 | { |
5650 | if (selectors[i] == NULL) |
5651 | { |
5652 | if (allow_user) |
5653 | { |
5654 | property_kind = CTX_PROPERTY_USER; |
5655 | break; |
5656 | } |
5657 | else |
5658 | { |
5659 | gfc_error ("selector %qs not allowed for context selector " |
5660 | "set %qs at %C" , |
5661 | selector, oss->trait_set_selector_name); |
5662 | return MATCH_ERROR; |
5663 | } |
5664 | } |
5665 | if (i == property_limit) |
5666 | property_kind = CTX_PROPERTY_NONE; |
5667 | if (strcmp (s1: selectors[i], s2: selector) == 0) |
5668 | break; |
5669 | } |
5670 | if (property_kind == CTX_PROPERTY_NAME_LIST |
5671 | && oss->trait_set_selector_name[0] == 'i' |
5672 | && strcmp (s1: selector, s2: "atomic_default_mem_order" ) == 0) |
5673 | property_kind = CTX_PROPERTY_ID; |
5674 | |
5675 | if (gfc_match (" (" ) == MATCH_YES) |
5676 | { |
5677 | if (property_kind == CTX_PROPERTY_NONE) |
5678 | { |
5679 | gfc_error ("selector %qs does not accept any properties at %C" , |
5680 | selector); |
5681 | return MATCH_ERROR; |
5682 | } |
5683 | |
5684 | if (allow_score && gfc_match (" score" ) == MATCH_YES) |
5685 | { |
5686 | if (gfc_match (" (" ) != MATCH_YES) |
5687 | { |
5688 | gfc_error ("expected %<(%> at %C" ); |
5689 | return MATCH_ERROR; |
5690 | } |
5691 | if (gfc_match_expr (&os->score) != MATCH_YES |
5692 | || !gfc_resolve_expr (os->score) |
5693 | || os->score->ts.type != BT_INTEGER |
5694 | || os->score->rank != 0) |
5695 | { |
5696 | gfc_error ("score argument must be constant integer " |
5697 | "expression at %C" ); |
5698 | return MATCH_ERROR; |
5699 | } |
5700 | |
5701 | if (os->score->expr_type == EXPR_CONSTANT |
5702 | && mpz_sgn (os->score->value.integer) < 0) |
5703 | { |
5704 | gfc_error ("score argument must be non-negative at %C" ); |
5705 | return MATCH_ERROR; |
5706 | } |
5707 | |
5708 | if (gfc_match (" )" ) != MATCH_YES) |
5709 | { |
5710 | gfc_error ("expected %<)%> at %C" ); |
5711 | return MATCH_ERROR; |
5712 | } |
5713 | |
5714 | if (gfc_match (" :" ) != MATCH_YES) |
5715 | { |
5716 | gfc_error ("expected : at %C" ); |
5717 | return MATCH_ERROR; |
5718 | } |
5719 | } |
5720 | |
5721 | gfc_omp_trait_property *otp = gfc_get_omp_trait_property (); |
5722 | otp->property_kind = property_kind; |
5723 | otp->next = os->properties; |
5724 | os->properties = otp; |
5725 | |
5726 | switch (property_kind) |
5727 | { |
5728 | case CTX_PROPERTY_USER: |
5729 | do |
5730 | { |
5731 | if (gfc_match_expr (&otp->expr) != MATCH_YES) |
5732 | { |
5733 | gfc_error ("property must be constant integer " |
5734 | "expression or string literal at %C" ); |
5735 | return MATCH_ERROR; |
5736 | } |
5737 | |
5738 | if (gfc_match (" ," ) != MATCH_YES) |
5739 | break; |
5740 | } |
5741 | while (1); |
5742 | break; |
5743 | case CTX_PROPERTY_ID: |
5744 | { |
5745 | char buf[GFC_MAX_SYMBOL_LEN + 1]; |
5746 | if (gfc_match_name (buf) == MATCH_YES) |
5747 | { |
5748 | otp->name = XNEWVEC (char, strlen (buf) + 1); |
5749 | strcpy (dest: otp->name, src: buf); |
5750 | } |
5751 | else |
5752 | { |
5753 | gfc_error ("expected identifier at %C" ); |
5754 | return MATCH_ERROR; |
5755 | } |
5756 | } |
5757 | break; |
5758 | case CTX_PROPERTY_NAME_LIST: |
5759 | do |
5760 | { |
5761 | char buf[GFC_MAX_SYMBOL_LEN + 1]; |
5762 | if (gfc_match_name (buf) == MATCH_YES) |
5763 | { |
5764 | otp->name = XNEWVEC (char, strlen (buf) + 1); |
5765 | strcpy (dest: otp->name, src: buf); |
5766 | otp->is_name = true; |
5767 | } |
5768 | else if (gfc_match_literal_constant (&otp->expr, 0) |
5769 | != MATCH_YES |
5770 | || otp->expr->ts.type != BT_CHARACTER) |
5771 | { |
5772 | gfc_error ("expected identifier or string literal " |
5773 | "at %C" ); |
5774 | return MATCH_ERROR; |
5775 | } |
5776 | |
5777 | if (gfc_match (" ," ) == MATCH_YES) |
5778 | { |
5779 | otp = gfc_get_omp_trait_property (); |
5780 | otp->property_kind = property_kind; |
5781 | otp->next = os->properties; |
5782 | os->properties = otp; |
5783 | } |
5784 | else |
5785 | break; |
5786 | } |
5787 | while (1); |
5788 | break; |
5789 | case CTX_PROPERTY_EXPR: |
5790 | if (gfc_match_expr (&otp->expr) != MATCH_YES) |
5791 | { |
5792 | gfc_error ("expected expression at %C" ); |
5793 | return MATCH_ERROR; |
5794 | } |
5795 | if (!gfc_resolve_expr (otp->expr) |
5796 | || (otp->expr->ts.type != BT_LOGICAL |
5797 | && otp->expr->ts.type != BT_INTEGER) |
5798 | || otp->expr->rank != 0) |
5799 | { |
5800 | gfc_error ("property must be constant integer or logical " |
5801 | "expression at %C" ); |
5802 | return MATCH_ERROR; |
5803 | } |
5804 | break; |
5805 | case CTX_PROPERTY_SIMD: |
5806 | { |
5807 | if (gfc_match_omp_clauses (cp: &otp->clauses, |
5808 | OMP_DECLARE_SIMD_CLAUSES, |
5809 | first: true, needs_space: false, openacc: false, context_selector: true) |
5810 | != MATCH_YES) |
5811 | { |
5812 | gfc_error ("expected simd clause at %C" ); |
5813 | return MATCH_ERROR; |
5814 | } |
5815 | break; |
5816 | } |
5817 | default: |
5818 | gcc_unreachable (); |
5819 | } |
5820 | |
5821 | if (gfc_match (" )" ) != MATCH_YES) |
5822 | { |
5823 | gfc_error ("expected %<)%> at %C" ); |
5824 | return MATCH_ERROR; |
5825 | } |
5826 | } |
5827 | else if (property_kind == CTX_PROPERTY_NAME_LIST |
5828 | || property_kind == CTX_PROPERTY_ID |
5829 | || property_kind == CTX_PROPERTY_EXPR) |
5830 | { |
5831 | if (gfc_match (" (" ) != MATCH_YES) |
5832 | { |
5833 | gfc_error ("expected %<(%> at %C" ); |
5834 | return MATCH_ERROR; |
5835 | } |
5836 | } |
5837 | |
5838 | if (gfc_match (" ," ) != MATCH_YES) |
5839 | break; |
5840 | } |
5841 | while (1); |
5842 | |
5843 | return MATCH_YES; |
5844 | } |
5845 | |
5846 | /* OpenMP 5.0: |
5847 | |
5848 | trait-set-selector[,trait-set-selector[,...]] |
5849 | |
5850 | trait-set-selector: |
5851 | trait-set-selector-name = { trait-selector[, trait-selector[, ...]] } |
5852 | |
5853 | trait-set-selector-name: |
5854 | constructor |
5855 | device |
5856 | implementation |
5857 | user */ |
5858 | |
5859 | match |
5860 | gfc_match_omp_context_selector_specification (gfc_omp_declare_variant *odv) |
5861 | { |
5862 | do |
5863 | { |
5864 | match m; |
5865 | const char *selector_sets[] = { "construct" , "device" , |
5866 | "implementation" , "user" }; |
5867 | const int selector_set_count = ARRAY_SIZE (selector_sets); |
5868 | int i; |
5869 | char buf[GFC_MAX_SYMBOL_LEN + 1]; |
5870 | |
5871 | m = gfc_match_name (buf); |
5872 | if (m == MATCH_YES) |
5873 | for (i = 0; i < selector_set_count; i++) |
5874 | if (strcmp (s1: buf, s2: selector_sets[i]) == 0) |
5875 | break; |
5876 | |
5877 | if (m != MATCH_YES || i == selector_set_count) |
5878 | { |
5879 | gfc_error ("expected %<construct%>, %<device%>, %<implementation%> " |
5880 | "or %<user%> at %C" ); |
5881 | return MATCH_ERROR; |
5882 | } |
5883 | |
5884 | m = gfc_match (" =" ); |
5885 | if (m != MATCH_YES) |
5886 | { |
5887 | gfc_error ("expected %<=%> at %C" ); |
5888 | return MATCH_ERROR; |
5889 | } |
5890 | |
5891 | m = gfc_match (" {" ); |
5892 | if (m != MATCH_YES) |
5893 | { |
5894 | gfc_error ("expected %<{%> at %C" ); |
5895 | return MATCH_ERROR; |
5896 | } |
5897 | |
5898 | gfc_omp_set_selector *oss = gfc_get_omp_set_selector (); |
5899 | oss->next = odv->set_selectors; |
5900 | oss->trait_set_selector_name = selector_sets[i]; |
5901 | odv->set_selectors = oss; |
5902 | |
5903 | if (gfc_match_omp_context_selector (oss) != MATCH_YES) |
5904 | return MATCH_ERROR; |
5905 | |
5906 | m = gfc_match (" }" ); |
5907 | if (m != MATCH_YES) |
5908 | { |
5909 | gfc_error ("expected %<}%> at %C" ); |
5910 | return MATCH_ERROR; |
5911 | } |
5912 | |
5913 | m = gfc_match (" ," ); |
5914 | if (m != MATCH_YES) |
5915 | break; |
5916 | } |
5917 | while (1); |
5918 | |
5919 | return MATCH_YES; |
5920 | } |
5921 | |
5922 | |
5923 | match |
5924 | gfc_match_omp_declare_variant (void) |
5925 | { |
5926 | bool first_p = true; |
5927 | char buf[GFC_MAX_SYMBOL_LEN + 1]; |
5928 | |
5929 | if (gfc_match (" (" ) != MATCH_YES) |
5930 | { |
5931 | gfc_error ("expected %<(%> at %C" ); |
5932 | return MATCH_ERROR; |
5933 | } |
5934 | |
5935 | gfc_symtree *base_proc_st, *variant_proc_st; |
5936 | if (gfc_match_name (buf) != MATCH_YES) |
5937 | { |
5938 | gfc_error ("expected name at %C" ); |
5939 | return MATCH_ERROR; |
5940 | } |
5941 | |
5942 | if (gfc_get_ha_sym_tree (buf, &base_proc_st)) |
5943 | return MATCH_ERROR; |
5944 | |
5945 | if (gfc_match (" :" ) == MATCH_YES) |
5946 | { |
5947 | if (gfc_match_name (buf) != MATCH_YES) |
5948 | { |
5949 | gfc_error ("expected variant name at %C" ); |
5950 | return MATCH_ERROR; |
5951 | } |
5952 | |
5953 | if (gfc_get_ha_sym_tree (buf, &variant_proc_st)) |
5954 | return MATCH_ERROR; |
5955 | } |
5956 | else |
5957 | { |
5958 | /* Base procedure not specified. */ |
5959 | variant_proc_st = base_proc_st; |
5960 | base_proc_st = NULL; |
5961 | } |
5962 | |
5963 | gfc_omp_declare_variant *odv; |
5964 | odv = gfc_get_omp_declare_variant (); |
5965 | odv->where = gfc_current_locus; |
5966 | odv->variant_proc_symtree = variant_proc_st; |
5967 | odv->base_proc_symtree = base_proc_st; |
5968 | odv->next = NULL; |
5969 | odv->error_p = false; |
5970 | |
5971 | /* Add the new declare variant to the end of the list. */ |
5972 | gfc_omp_declare_variant **prev_next = &gfc_current_ns->omp_declare_variant; |
5973 | while (*prev_next) |
5974 | prev_next = &((*prev_next)->next); |
5975 | *prev_next = odv; |
5976 | |
5977 | if (gfc_match (" )" ) != MATCH_YES) |
5978 | { |
5979 | gfc_error ("expected %<)%> at %C" ); |
5980 | return MATCH_ERROR; |
5981 | } |
5982 | |
5983 | for (;;) |
5984 | { |
5985 | if (gfc_match (" match" ) != MATCH_YES) |
5986 | { |
5987 | if (first_p) |
5988 | { |
5989 | gfc_error ("expected %<match%> at %C" ); |
5990 | return MATCH_ERROR; |
5991 | } |
5992 | else |
5993 | break; |
5994 | } |
5995 | |
5996 | if (gfc_match (" (" ) != MATCH_YES) |
5997 | { |
5998 | gfc_error ("expected %<(%> at %C" ); |
5999 | return MATCH_ERROR; |
6000 | } |
6001 | |
6002 | if (gfc_match_omp_context_selector_specification (odv) != MATCH_YES) |
6003 | return MATCH_ERROR; |
6004 | |
6005 | if (gfc_match (" )" ) != MATCH_YES) |
6006 | { |
6007 | gfc_error ("expected %<)%> at %C" ); |
6008 | return MATCH_ERROR; |
6009 | } |
6010 | |
6011 | first_p = false; |
6012 | } |
6013 | |
6014 | return MATCH_YES; |
6015 | } |
6016 | |
6017 | |
6018 | match |
6019 | gfc_match_omp_threadprivate (void) |
6020 | { |
6021 | locus old_loc; |
6022 | char n[GFC_MAX_SYMBOL_LEN+1]; |
6023 | gfc_symbol *sym; |
6024 | match m; |
6025 | gfc_symtree *st; |
6026 | |
6027 | old_loc = gfc_current_locus; |
6028 | |
6029 | m = gfc_match (" (" ); |
6030 | if (m != MATCH_YES) |
6031 | return m; |
6032 | |
6033 | for (;;) |
6034 | { |
6035 | m = gfc_match_symbol (&sym, 0); |
6036 | switch (m) |
6037 | { |
6038 | case MATCH_YES: |
6039 | if (sym->attr.in_common) |
6040 | gfc_error_now ("Threadprivate variable at %C is an element of " |
6041 | "a COMMON block" ); |
6042 | else if (!gfc_add_threadprivate (&sym->attr, sym->name, &sym->declared_at)) |
6043 | goto cleanup; |
6044 | goto next_item; |
6045 | case MATCH_NO: |
6046 | break; |
6047 | case MATCH_ERROR: |
6048 | goto cleanup; |
6049 | } |
6050 | |
6051 | m = gfc_match (" / %n /" , n); |
6052 | if (m == MATCH_ERROR) |
6053 | goto cleanup; |
6054 | if (m == MATCH_NO || n[0] == '\0') |
6055 | goto syntax; |
6056 | |
6057 | st = gfc_find_symtree (gfc_current_ns->common_root, n); |
6058 | if (st == NULL) |
6059 | { |
6060 | gfc_error ("COMMON block /%s/ not found at %C" , n); |
6061 | goto cleanup; |
6062 | } |
6063 | st->n.common->threadprivate = 1; |
6064 | for (sym = st->n.common->head; sym; sym = sym->common_next) |
6065 | if (!gfc_add_threadprivate (&sym->attr, sym->name, &sym->declared_at)) |
6066 | goto cleanup; |
6067 | |
6068 | next_item: |
6069 | if (gfc_match_char (')') == MATCH_YES) |
6070 | break; |
6071 | if (gfc_match_char (',') != MATCH_YES) |
6072 | goto syntax; |
6073 | } |
6074 | |
6075 | if (gfc_match_omp_eos () != MATCH_YES) |
6076 | { |
6077 | gfc_error ("Unexpected junk after OMP THREADPRIVATE at %C" ); |
6078 | goto cleanup; |
6079 | } |
6080 | |
6081 | return MATCH_YES; |
6082 | |
6083 | syntax: |
6084 | gfc_error ("Syntax error in !$OMP THREADPRIVATE list at %C" ); |
6085 | |
6086 | cleanup: |
6087 | gfc_current_locus = old_loc; |
6088 | return MATCH_ERROR; |
6089 | } |
6090 | |
6091 | |
6092 | match |
6093 | gfc_match_omp_parallel (void) |
6094 | { |
6095 | return match_omp (op: EXEC_OMP_PARALLEL, OMP_PARALLEL_CLAUSES); |
6096 | } |
6097 | |
6098 | |
6099 | match |
6100 | gfc_match_omp_parallel_do (void) |
6101 | { |
6102 | return match_omp (op: EXEC_OMP_PARALLEL_DO, |
6103 | mask: (OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES) |
6104 | & ~(omp_mask (OMP_CLAUSE_NOWAIT))); |
6105 | } |
6106 | |
6107 | |
6108 | match |
6109 | gfc_match_omp_parallel_do_simd (void) |
6110 | { |
6111 | return match_omp (op: EXEC_OMP_PARALLEL_DO_SIMD, |
6112 | mask: (OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES | OMP_SIMD_CLAUSES) |
6113 | & ~(omp_mask (OMP_CLAUSE_NOWAIT))); |
6114 | } |
6115 | |
6116 | |
6117 | match |
6118 | gfc_match_omp_parallel_masked (void) |
6119 | { |
6120 | return match_omp (op: EXEC_OMP_PARALLEL_MASKED, |
6121 | OMP_PARALLEL_CLAUSES | OMP_MASKED_CLAUSES); |
6122 | } |
6123 | |
6124 | match |
6125 | gfc_match_omp_parallel_masked_taskloop (void) |
6126 | { |
6127 | return match_omp (op: EXEC_OMP_PARALLEL_MASKED_TASKLOOP, |
6128 | mask: (OMP_PARALLEL_CLAUSES | OMP_MASKED_CLAUSES |
6129 | | OMP_TASKLOOP_CLAUSES) |
6130 | & ~(omp_mask (OMP_CLAUSE_IN_REDUCTION))); |
6131 | } |
6132 | |
6133 | match |
6134 | gfc_match_omp_parallel_masked_taskloop_simd (void) |
6135 | { |
6136 | return match_omp (op: EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD, |
6137 | mask: (OMP_PARALLEL_CLAUSES | OMP_MASKED_CLAUSES |
6138 | | OMP_TASKLOOP_CLAUSES | OMP_SIMD_CLAUSES) |
6139 | & ~(omp_mask (OMP_CLAUSE_IN_REDUCTION))); |
6140 | } |
6141 | |
6142 | match |
6143 | gfc_match_omp_parallel_master (void) |
6144 | { |
6145 | return match_omp (op: EXEC_OMP_PARALLEL_MASTER, OMP_PARALLEL_CLAUSES); |
6146 | } |
6147 | |
6148 | match |
6149 | gfc_match_omp_parallel_master_taskloop (void) |
6150 | { |
6151 | return match_omp (op: EXEC_OMP_PARALLEL_MASTER_TASKLOOP, |
6152 | mask: (OMP_PARALLEL_CLAUSES | OMP_TASKLOOP_CLAUSES) |
6153 | & ~(omp_mask (OMP_CLAUSE_IN_REDUCTION))); |
6154 | } |
6155 | |
6156 | match |
6157 | gfc_match_omp_parallel_master_taskloop_simd (void) |
6158 | { |
6159 | return match_omp (op: EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD, |
6160 | mask: (OMP_PARALLEL_CLAUSES | OMP_TASKLOOP_CLAUSES |
6161 | | OMP_SIMD_CLAUSES) |
6162 | & ~(omp_mask (OMP_CLAUSE_IN_REDUCTION))); |
6163 | } |
6164 | |
6165 | match |
6166 | gfc_match_omp_parallel_sections (void) |
6167 | { |
6168 | return match_omp (op: EXEC_OMP_PARALLEL_SECTIONS, |
6169 | mask: (OMP_PARALLEL_CLAUSES | OMP_SECTIONS_CLAUSES) |
6170 | & ~(omp_mask (OMP_CLAUSE_NOWAIT))); |
6171 | } |
6172 | |
6173 | |
6174 | match |
6175 | gfc_match_omp_parallel_workshare (void) |
6176 | { |
6177 | return match_omp (op: EXEC_OMP_PARALLEL_WORKSHARE, OMP_PARALLEL_CLAUSES); |
6178 | } |
6179 | |
6180 | void |
6181 | gfc_check_omp_requires (gfc_namespace *ns, int ref_omp_requires) |
6182 | { |
6183 | if (ns->omp_target_seen |
6184 | && (ns->omp_requires & OMP_REQ_TARGET_MASK) |
6185 | != (ref_omp_requires & OMP_REQ_TARGET_MASK)) |
6186 | { |
6187 | gcc_assert (ns->proc_name); |
6188 | if ((ref_omp_requires & OMP_REQ_REVERSE_OFFLOAD) |
6189 | && !(ns->omp_requires & OMP_REQ_REVERSE_OFFLOAD)) |
6190 | gfc_error ("Program unit at %L has OpenMP device constructs/routines " |
6191 | "but does not set !$OMP REQUIRES REVERSE_OFFLOAD but other " |
6192 | "program units do" , &ns->proc_name->declared_at); |
6193 | if ((ref_omp_requires & OMP_REQ_UNIFIED_ADDRESS) |
6194 | && !(ns->omp_requires & OMP_REQ_UNIFIED_ADDRESS)) |
6195 | gfc_error ("Program unit at %L has OpenMP device constructs/routines " |
6196 | "but does not set !$OMP REQUIRES UNIFIED_ADDRESS but other " |
6197 | "program units do" , &ns->proc_name->declared_at); |
6198 | if ((ref_omp_requires & OMP_REQ_UNIFIED_SHARED_MEMORY) |
6199 | && !(ns->omp_requires & OMP_REQ_UNIFIED_SHARED_MEMORY)) |
6200 | gfc_error ("Program unit at %L has OpenMP device constructs/routines " |
6201 | "but does not set !$OMP REQUIRES UNIFIED_SHARED_MEMORY but " |
6202 | "other program units do" , &ns->proc_name->declared_at); |
6203 | } |
6204 | } |
6205 | |
6206 | bool |
6207 | gfc_omp_requires_add_clause (gfc_omp_requires_kind clause, |
6208 | const char *clause_name, locus *loc, |
6209 | const char *module_name) |
6210 | { |
6211 | gfc_namespace *prog_unit = gfc_current_ns; |
6212 | while (prog_unit->parent) |
6213 | { |
6214 | if (gfc_state_stack->previous |
6215 | && gfc_state_stack->previous->state == COMP_INTERFACE) |
6216 | break; |
6217 | prog_unit = prog_unit->parent; |
6218 | } |
6219 | |
6220 | /* Requires added after use. */ |
6221 | if (prog_unit->omp_target_seen |
6222 | && (clause & OMP_REQ_TARGET_MASK) |
6223 | && !(prog_unit->omp_requires & clause)) |
6224 | { |
6225 | if (module_name) |
6226 | gfc_error ("!$OMP REQUIRES clause %qs specified via module %qs use " |
6227 | "at %L comes after using a device construct/routine" , |
6228 | clause_name, module_name, loc); |
6229 | else |
6230 | gfc_error ("!$OMP REQUIRES clause %qs specified at %L comes after " |
6231 | "using a device construct/routine" , clause_name, loc); |
6232 | return false; |
6233 | } |
6234 | |
6235 | /* Overriding atomic_default_mem_order clause value. */ |
6236 | if ((clause & OMP_REQ_ATOMIC_MEM_ORDER_MASK) |
6237 | && (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK) |
6238 | && (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK) |
6239 | != (int) clause) |
6240 | { |
6241 | const char *other; |
6242 | if (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST) |
6243 | other = "seq_cst" ; |
6244 | else if (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL) |
6245 | other = "acq_rel" ; |
6246 | else if (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_RELAXED) |
6247 | other = "relaxed" ; |
6248 | else |
6249 | gcc_unreachable (); |
6250 | |
6251 | if (module_name) |
6252 | gfc_error ("!$OMP REQUIRES clause %<atomic_default_mem_order(%s)%> " |
6253 | "specified via module %qs use at %L overrides a previous " |
6254 | "%<atomic_default_mem_order(%s)%> (which might be through " |
6255 | "using a module)" , clause_name, module_name, loc, other); |
6256 | else |
6257 | gfc_error ("!$OMP REQUIRES clause %<atomic_default_mem_order(%s)%> " |
6258 | "specified at %L overrides a previous " |
6259 | "%<atomic_default_mem_order(%s)%> (which might be through " |
6260 | "using a module)" , clause_name, loc, other); |
6261 | return false; |
6262 | } |
6263 | |
6264 | /* Requires via module not at program-unit level and not repeating clause. */ |
6265 | if (prog_unit != gfc_current_ns && !(prog_unit->omp_requires & clause)) |
6266 | { |
6267 | if (clause & OMP_REQ_ATOMIC_MEM_ORDER_MASK) |
6268 | gfc_error ("!$OMP REQUIRES clause %<atomic_default_mem_order(%s)%> " |
6269 | "specified via module %qs use at %L but same clause is " |
6270 | "not specified for the program unit" , clause_name, |
6271 | module_name, loc); |
6272 | else |
6273 | gfc_error ("!$OMP REQUIRES clause %qs specified via module %qs use at " |
6274 | "%L but same clause is not specified for the program unit" , |
6275 | clause_name, module_name, loc); |
6276 | return false; |
6277 | } |
6278 | |
6279 | if (!gfc_state_stack->previous |
6280 | || gfc_state_stack->previous->state != COMP_INTERFACE) |
6281 | prog_unit->omp_requires |= clause; |
6282 | return true; |
6283 | } |
6284 | |
6285 | match |
6286 | gfc_match_omp_requires (void) |
6287 | { |
6288 | static const char *clauses[] = {"reverse_offload" , |
6289 | "unified_address" , |
6290 | "unified_shared_memory" , |
6291 | "dynamic_allocators" , |
6292 | "atomic_default" }; |
6293 | const char *clause = NULL; |
6294 | int requires_clauses = 0; |
6295 | bool first = true; |
6296 | locus old_loc; |
6297 | |
6298 | if (gfc_current_ns->parent |
6299 | && (!gfc_state_stack->previous |
6300 | || gfc_state_stack->previous->state != COMP_INTERFACE)) |
6301 | { |
6302 | gfc_error ("!$OMP REQUIRES at %C must appear in the specification part " |
6303 | "of a program unit" ); |
6304 | return MATCH_ERROR; |
6305 | } |
6306 | |
6307 | while (true) |
6308 | { |
6309 | old_loc = gfc_current_locus; |
6310 | gfc_omp_requires_kind requires_clause; |
6311 | if ((first || gfc_match_char (',') != MATCH_YES) |
6312 | && (first && gfc_match_space () != MATCH_YES)) |
6313 | goto error; |
6314 | first = false; |
6315 | gfc_gobble_whitespace (); |
6316 | old_loc = gfc_current_locus; |
6317 | |
6318 | if (gfc_match_omp_eos () != MATCH_NO) |
6319 | break; |
6320 | if (gfc_match (clauses[0]) == MATCH_YES) |
6321 | { |
6322 | clause = clauses[0]; |
6323 | requires_clause = OMP_REQ_REVERSE_OFFLOAD; |
6324 | if (requires_clauses & OMP_REQ_REVERSE_OFFLOAD) |
6325 | goto duplicate_clause; |
6326 | } |
6327 | else if (gfc_match (clauses[1]) == MATCH_YES) |
6328 | { |
6329 | clause = clauses[1]; |
6330 | requires_clause = OMP_REQ_UNIFIED_ADDRESS; |
6331 | if (requires_clauses & OMP_REQ_UNIFIED_ADDRESS) |
6332 | goto duplicate_clause; |
6333 | } |
6334 | else if (gfc_match (clauses[2]) == MATCH_YES) |
6335 | { |
6336 | clause = clauses[2]; |
6337 | requires_clause = OMP_REQ_UNIFIED_SHARED_MEMORY; |
6338 | if (requires_clauses & OMP_REQ_UNIFIED_SHARED_MEMORY) |
6339 | goto duplicate_clause; |
6340 | } |
6341 | else if (gfc_match (clauses[3]) == MATCH_YES) |
6342 | { |
6343 | clause = clauses[3]; |
6344 | requires_clause = OMP_REQ_DYNAMIC_ALLOCATORS; |
6345 | if (requires_clauses & OMP_REQ_DYNAMIC_ALLOCATORS) |
6346 | goto duplicate_clause; |
6347 | } |
6348 | else if (gfc_match ("atomic_default_mem_order (" ) == MATCH_YES) |
6349 | { |
6350 | clause = clauses[4]; |
6351 | if (requires_clauses & OMP_REQ_ATOMIC_MEM_ORDER_MASK) |
6352 | goto duplicate_clause; |
6353 | if (gfc_match (" seq_cst )" ) == MATCH_YES) |
6354 | { |
6355 | clause = "seq_cst" ; |
6356 | requires_clause = OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST; |
6357 | } |
6358 | else if (gfc_match (" acq_rel )" ) == MATCH_YES) |
6359 | { |
6360 | clause = "acq_rel" ; |
6361 | requires_clause = OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL; |
6362 | } |
6363 | else if (gfc_match (" relaxed )" ) == MATCH_YES) |
6364 | { |
6365 | clause = "relaxed" ; |
6366 | requires_clause = OMP_REQ_ATOMIC_MEM_ORDER_RELAXED; |
6367 | } |
6368 | else |
6369 | { |
6370 | gfc_error ("Expected SEQ_CST, ACQ_REL or RELAXED for " |
6371 | "ATOMIC_DEFAULT_MEM_ORDER clause at %C" ); |
6372 | goto error; |
6373 | } |
6374 | } |
6375 | else |
6376 | goto error; |
6377 | |
6378 | if (!gfc_omp_requires_add_clause (clause: requires_clause, clause_name: clause, loc: &old_loc, NULL)) |
6379 | goto error; |
6380 | requires_clauses |= requires_clause; |
6381 | } |
6382 | |
6383 | if (requires_clauses == 0) |
6384 | { |
6385 | if (!gfc_error_flag_test ()) |
6386 | gfc_error ("Clause expected at %C" ); |
6387 | goto error; |
6388 | } |
6389 | return MATCH_YES; |
6390 | |
6391 | duplicate_clause: |
6392 | gfc_error ("%qs clause at %L specified more than once" , clause, &old_loc); |
6393 | error: |
6394 | if (!gfc_error_flag_test ()) |
6395 | gfc_error ("Expected UNIFIED_ADDRESS, UNIFIED_SHARED_MEMORY, " |
6396 | "DYNAMIC_ALLOCATORS, REVERSE_OFFLOAD, or " |
6397 | "ATOMIC_DEFAULT_MEM_ORDER clause at %L" , &old_loc); |
6398 | return MATCH_ERROR; |
6399 | } |
6400 | |
6401 | |
6402 | match |
6403 | gfc_match_omp_scan (void) |
6404 | { |
6405 | bool incl; |
6406 | gfc_omp_clauses *c = gfc_get_omp_clauses (); |
6407 | gfc_gobble_whitespace (); |
6408 | if ((incl = (gfc_match ("inclusive" ) == MATCH_YES)) |
6409 | || gfc_match ("exclusive" ) == MATCH_YES) |
6410 | { |
6411 | if (gfc_match_omp_variable_list (str: " (" , list: &c->lists[incl ? OMP_LIST_SCAN_IN |
6412 | : OMP_LIST_SCAN_EX], |
6413 | allow_common: false) != MATCH_YES) |
6414 | { |
6415 | gfc_free_omp_clauses (c); |
6416 | return MATCH_ERROR; |
6417 | } |
6418 | } |
6419 | else |
6420 | { |
6421 | gfc_error ("Expected INCLUSIVE or EXCLUSIVE clause at %C" ); |
6422 | gfc_free_omp_clauses (c); |
6423 | return MATCH_ERROR; |
6424 | } |
6425 | if (gfc_match_omp_eos () != MATCH_YES) |
6426 | { |
6427 | gfc_error ("Unexpected junk after !$OMP SCAN at %C" ); |
6428 | gfc_free_omp_clauses (c); |
6429 | return MATCH_ERROR; |
6430 | } |
6431 | |
6432 | new_st.op = EXEC_OMP_SCAN; |
6433 | new_st.ext.omp_clauses = c; |
6434 | return MATCH_YES; |
6435 | } |
6436 | |
6437 | |
6438 | match |
6439 | gfc_match_omp_scope (void) |
6440 | { |
6441 | return match_omp (op: EXEC_OMP_SCOPE, OMP_SCOPE_CLAUSES); |
6442 | } |
6443 | |
6444 | |
6445 | match |
6446 | gfc_match_omp_sections (void) |
6447 | { |
6448 | return match_omp (op: EXEC_OMP_SECTIONS, OMP_SECTIONS_CLAUSES); |
6449 | } |
6450 | |
6451 | |
6452 | match |
6453 | gfc_match_omp_simd (void) |
6454 | { |
6455 | return match_omp (op: EXEC_OMP_SIMD, OMP_SIMD_CLAUSES); |
6456 | } |
6457 | |
6458 | |
6459 | match |
6460 | gfc_match_omp_single (void) |
6461 | { |
6462 | return match_omp (op: EXEC_OMP_SINGLE, OMP_SINGLE_CLAUSES); |
6463 | } |
6464 | |
6465 | |
6466 | match |
6467 | gfc_match_omp_target (void) |
6468 | { |
6469 | return match_omp (op: EXEC_OMP_TARGET, OMP_TARGET_CLAUSES); |
6470 | } |
6471 | |
6472 | |
6473 | match |
6474 | gfc_match_omp_target_data (void) |
6475 | { |
6476 | return match_omp (op: EXEC_OMP_TARGET_DATA, OMP_TARGET_DATA_CLAUSES); |
6477 | } |
6478 | |
6479 | |
6480 | match |
6481 | gfc_match_omp_target_enter_data (void) |
6482 | { |
6483 | return match_omp (op: EXEC_OMP_TARGET_ENTER_DATA, OMP_TARGET_ENTER_DATA_CLAUSES); |
6484 | } |
6485 | |
6486 | |
6487 | match |
6488 | gfc_match_omp_target_exit_data (void) |
6489 | { |
6490 | return match_omp (op: EXEC_OMP_TARGET_EXIT_DATA, OMP_TARGET_EXIT_DATA_CLAUSES); |
6491 | } |
6492 | |
6493 | |
6494 | match |
6495 | gfc_match_omp_target_parallel (void) |
6496 | { |
6497 | return match_omp (op: EXEC_OMP_TARGET_PARALLEL, |
6498 | mask: (OMP_TARGET_CLAUSES | OMP_PARALLEL_CLAUSES) |
6499 | & ~(omp_mask (OMP_CLAUSE_COPYIN))); |
6500 | } |
6501 | |
6502 | |
6503 | match |
6504 | gfc_match_omp_target_parallel_do (void) |
6505 | { |
6506 | return match_omp (op: EXEC_OMP_TARGET_PARALLEL_DO, |
6507 | mask: (OMP_TARGET_CLAUSES | OMP_PARALLEL_CLAUSES |
6508 | | OMP_DO_CLAUSES) & ~(omp_mask (OMP_CLAUSE_COPYIN))); |
6509 | } |
6510 | |
6511 | |
6512 | match |
6513 | gfc_match_omp_target_parallel_do_simd (void) |
6514 | { |
6515 | return match_omp (op: EXEC_OMP_TARGET_PARALLEL_DO_SIMD, |
6516 | mask: (OMP_TARGET_CLAUSES | OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES |
6517 | | OMP_SIMD_CLAUSES) & ~(omp_mask (OMP_CLAUSE_COPYIN))); |
6518 | } |
6519 | |
6520 | |
6521 | match |
6522 | gfc_match_omp_target_simd (void) |
6523 | { |
6524 | return match_omp (op: EXEC_OMP_TARGET_SIMD, |
6525 | OMP_TARGET_CLAUSES | OMP_SIMD_CLAUSES); |
6526 | } |
6527 | |
6528 | |
6529 | match |
6530 | gfc_match_omp_target_teams (void) |
6531 | { |
6532 | return match_omp (op: EXEC_OMP_TARGET_TEAMS, |
6533 | OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES); |
6534 | } |
6535 | |
6536 | |
6537 | match |
6538 | gfc_match_omp_target_teams_distribute (void) |
6539 | { |
6540 | return match_omp (op: EXEC_OMP_TARGET_TEAMS_DISTRIBUTE, |
6541 | OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES |
6542 | | OMP_DISTRIBUTE_CLAUSES); |
6543 | } |
6544 | |
6545 | |
6546 | match |
6547 | gfc_match_omp_target_teams_distribute_parallel_do (void) |
6548 | { |
6549 | return match_omp (op: EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO, |
6550 | mask: (OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES |
6551 | | OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES |
6552 | | OMP_DO_CLAUSES) |
6553 | & ~(omp_mask (OMP_CLAUSE_ORDERED)) |
6554 | & ~(omp_mask (OMP_CLAUSE_LINEAR))); |
6555 | } |
6556 | |
6557 | |
6558 | match |
6559 | gfc_match_omp_target_teams_distribute_parallel_do_simd (void) |
6560 | { |
6561 | return match_omp (op: EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD, |
6562 | mask: (OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES |
6563 | | OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES |
6564 | | OMP_DO_CLAUSES | OMP_SIMD_CLAUSES) |
6565 | & ~(omp_mask (OMP_CLAUSE_ORDERED))); |
6566 | } |
6567 | |
6568 | |
6569 | match |
6570 | gfc_match_omp_target_teams_distribute_simd (void) |
6571 | { |
6572 | return match_omp (op: EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD, |
6573 | OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES |
6574 | | OMP_DISTRIBUTE_CLAUSES | OMP_SIMD_CLAUSES); |
6575 | } |
6576 | |
6577 | |
6578 | match |
6579 | gfc_match_omp_target_update (void) |
6580 | { |
6581 | return match_omp (op: EXEC_OMP_TARGET_UPDATE, OMP_TARGET_UPDATE_CLAUSES); |
6582 | } |
6583 | |
6584 | |
6585 | match |
6586 | gfc_match_omp_task (void) |
6587 | { |
6588 | return match_omp (op: EXEC_OMP_TASK, OMP_TASK_CLAUSES); |
6589 | } |
6590 | |
6591 | |
6592 | match |
6593 | gfc_match_omp_taskloop (void) |
6594 | { |
6595 | return match_omp (op: EXEC_OMP_TASKLOOP, OMP_TASKLOOP_CLAUSES); |
6596 | } |
6597 | |
6598 | |
6599 | match |
6600 | gfc_match_omp_taskloop_simd (void) |
6601 | { |
6602 | return match_omp (op: EXEC_OMP_TASKLOOP_SIMD, |
6603 | OMP_TASKLOOP_CLAUSES | OMP_SIMD_CLAUSES); |
6604 | } |
6605 | |
6606 | |
6607 | match |
6608 | gfc_match_omp_taskwait (void) |
6609 | { |
6610 | if (gfc_match_omp_eos () == MATCH_YES) |
6611 | { |
6612 | new_st.op = EXEC_OMP_TASKWAIT; |
6613 | new_st.ext.omp_clauses = NULL; |
6614 | return MATCH_YES; |
6615 | } |
6616 | return match_omp (op: EXEC_OMP_TASKWAIT, |
6617 | mask: omp_mask (OMP_CLAUSE_DEPEND) | OMP_CLAUSE_NOWAIT); |
6618 | } |
6619 | |
6620 | |
6621 | match |
6622 | gfc_match_omp_taskyield (void) |
6623 | { |
6624 | if (gfc_match_omp_eos () != MATCH_YES) |
6625 | { |
6626 | gfc_error ("Unexpected junk after TASKYIELD clause at %C" ); |
6627 | return MATCH_ERROR; |
6628 | } |
6629 | new_st.op = EXEC_OMP_TASKYIELD; |
6630 | new_st.ext.omp_clauses = NULL; |
6631 | return MATCH_YES; |
6632 | } |
6633 | |
6634 | |
6635 | match |
6636 | gfc_match_omp_teams (void) |
6637 | { |
6638 | return match_omp (op: EXEC_OMP_TEAMS, OMP_TEAMS_CLAUSES); |
6639 | } |
6640 | |
6641 | |
6642 | match |
6643 | gfc_match_omp_teams_distribute (void) |
6644 | { |
6645 | return match_omp (op: EXEC_OMP_TEAMS_DISTRIBUTE, |
6646 | OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES); |
6647 | } |
6648 | |
6649 | |
6650 | match |
6651 | gfc_match_omp_teams_distribute_parallel_do (void) |
6652 | { |
6653 | return match_omp (op: EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO, |
6654 | mask: (OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES |
6655 | | OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES) |
6656 | & ~(omp_mask (OMP_CLAUSE_ORDERED) |
6657 | | OMP_CLAUSE_LINEAR | OMP_CLAUSE_NOWAIT)); |
6658 | } |
6659 | |
6660 | |
6661 | match |
6662 | gfc_match_omp_teams_distribute_parallel_do_simd (void) |
6663 | { |
6664 | return match_omp (op: EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD, |
6665 | mask: (OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES |
6666 | | OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES |
6667 | | OMP_SIMD_CLAUSES) |
6668 | & ~(omp_mask (OMP_CLAUSE_ORDERED) | OMP_CLAUSE_NOWAIT)); |
6669 | } |
6670 | |
6671 | |
6672 | match |
6673 | gfc_match_omp_teams_distribute_simd (void) |
6674 | { |
6675 | return match_omp (op: EXEC_OMP_TEAMS_DISTRIBUTE_SIMD, |
6676 | OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES |
6677 | | OMP_SIMD_CLAUSES); |
6678 | } |
6679 | |
6680 | |
6681 | match |
6682 | gfc_match_omp_workshare (void) |
6683 | { |
6684 | return match_omp (op: EXEC_OMP_WORKSHARE, OMP_WORKSHARE_CLAUSES); |
6685 | } |
6686 | |
6687 | |
6688 | match |
6689 | gfc_match_omp_masked (void) |
6690 | { |
6691 | return match_omp (op: EXEC_OMP_MASKED, OMP_MASKED_CLAUSES); |
6692 | } |
6693 | |
6694 | match |
6695 | gfc_match_omp_masked_taskloop (void) |
6696 | { |
6697 | return match_omp (op: EXEC_OMP_MASKED_TASKLOOP, |
6698 | OMP_MASKED_CLAUSES | OMP_TASKLOOP_CLAUSES); |
6699 | } |
6700 | |
6701 | match |
6702 | gfc_match_omp_masked_taskloop_simd (void) |
6703 | { |
6704 | return match_omp (op: EXEC_OMP_MASKED_TASKLOOP_SIMD, |
6705 | mask: (OMP_MASKED_CLAUSES | OMP_TASKLOOP_CLAUSES |
6706 | | OMP_SIMD_CLAUSES)); |
6707 | } |
6708 | |
6709 | match |
6710 | gfc_match_omp_master (void) |
6711 | { |
6712 | if (gfc_match_omp_eos () != MATCH_YES) |
6713 | { |
6714 | gfc_error ("Unexpected junk after $OMP MASTER statement at %C" ); |
6715 | return MATCH_ERROR; |
6716 | } |
6717 | new_st.op = EXEC_OMP_MASTER; |
6718 | new_st.ext.omp_clauses = NULL; |
6719 | return MATCH_YES; |
6720 | } |
6721 | |
6722 | match |
6723 | gfc_match_omp_master_taskloop (void) |
6724 | { |
6725 | return match_omp (op: EXEC_OMP_MASTER_TASKLOOP, OMP_TASKLOOP_CLAUSES); |
6726 | } |
6727 | |
6728 | match |
6729 | gfc_match_omp_master_taskloop_simd (void) |
6730 | { |
6731 | return match_omp (op: EXEC_OMP_MASTER_TASKLOOP_SIMD, |
6732 | OMP_TASKLOOP_CLAUSES | OMP_SIMD_CLAUSES); |
6733 | } |
6734 | |
6735 | match |
6736 | gfc_match_omp_ordered (void) |
6737 | { |
6738 | return match_omp (op: EXEC_OMP_ORDERED, OMP_ORDERED_CLAUSES); |
6739 | } |
6740 | |
6741 | match |
6742 | gfc_match_omp_nothing (void) |
6743 | { |
6744 | if (gfc_match_omp_eos () != MATCH_YES) |
6745 | { |
6746 | gfc_error ("Unexpected junk after $OMP NOTHING statement at %C" ); |
6747 | return MATCH_ERROR; |
6748 | } |
6749 | /* Will use ST_NONE; therefore, no EXEC_OMP_ is needed. */ |
6750 | return MATCH_YES; |
6751 | } |
6752 | |
6753 | match |
6754 | gfc_match_omp_ordered_depend (void) |
6755 | { |
6756 | return match_omp (op: EXEC_OMP_ORDERED, mask: omp_mask (OMP_CLAUSE_DOACROSS)); |
6757 | } |
6758 | |
6759 | |
6760 | /* omp atomic [clause-list] |
6761 | - atomic-clause: read | write | update |
6762 | - capture |
6763 | - memory-order-clause: seq_cst | acq_rel | release | acquire | relaxed |
6764 | - hint(hint-expr) |
6765 | - OpenMP 5.1: compare | fail (seq_cst | acquire | relaxed ) | weak |
6766 | */ |
6767 | |
6768 | match |
6769 | gfc_match_omp_atomic (void) |
6770 | { |
6771 | gfc_omp_clauses *c; |
6772 | locus loc = gfc_current_locus; |
6773 | |
6774 | if (gfc_match_omp_clauses (cp: &c, OMP_ATOMIC_CLAUSES, first: true, needs_space: true) != MATCH_YES) |
6775 | return MATCH_ERROR; |
6776 | |
6777 | if (c->atomic_op == GFC_OMP_ATOMIC_UNSET) |
6778 | c->atomic_op = GFC_OMP_ATOMIC_UPDATE; |
6779 | |
6780 | if (c->capture && c->atomic_op != GFC_OMP_ATOMIC_UPDATE) |
6781 | gfc_error ("!$OMP ATOMIC at %L with %s clause is incompatible with " |
6782 | "READ or WRITE" , &loc, "CAPTURE" ); |
6783 | if (c->compare && c->atomic_op != GFC_OMP_ATOMIC_UPDATE) |
6784 | gfc_error ("!$OMP ATOMIC at %L with %s clause is incompatible with " |
6785 | "READ or WRITE" , &loc, "COMPARE" ); |
6786 | if (c->fail != OMP_MEMORDER_UNSET && c->atomic_op != GFC_OMP_ATOMIC_UPDATE) |
6787 | gfc_error ("!$OMP ATOMIC at %L with %s clause is incompatible with " |
6788 | "READ or WRITE" , &loc, "FAIL" ); |
6789 | if (c->weak && !c->compare) |
6790 | { |
6791 | gfc_error ("!$OMP ATOMIC at %L with %s clause requires %s clause" , &loc, |
6792 | "WEAK" , "COMPARE" ); |
6793 | c->weak = false; |
6794 | } |
6795 | |
6796 | if (c->memorder == OMP_MEMORDER_UNSET) |
6797 | { |
6798 | gfc_namespace *prog_unit = gfc_current_ns; |
6799 | while (prog_unit->parent) |
6800 | prog_unit = prog_unit->parent; |
6801 | switch (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK) |
6802 | { |
6803 | case 0: |
6804 | case OMP_REQ_ATOMIC_MEM_ORDER_RELAXED: |
6805 | c->memorder = OMP_MEMORDER_RELAXED; |
6806 | break; |
6807 | case OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST: |
6808 | c->memorder = OMP_MEMORDER_SEQ_CST; |
6809 | break; |
6810 | case OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL: |
6811 | if (c->capture) |
6812 | c->memorder = OMP_MEMORDER_ACQ_REL; |
6813 | else if (c->atomic_op == GFC_OMP_ATOMIC_READ) |
6814 | c->memorder = OMP_MEMORDER_ACQUIRE; |
6815 | else |
6816 | c->memorder = OMP_MEMORDER_RELEASE; |
6817 | break; |
6818 | default: |
6819 | gcc_unreachable (); |
6820 | } |
6821 | } |
6822 | else |
6823 | switch (c->atomic_op) |
6824 | { |
6825 | case GFC_OMP_ATOMIC_READ: |
6826 | if (c->memorder == OMP_MEMORDER_RELEASE) |
6827 | { |
6828 | gfc_error ("!$OMP ATOMIC READ at %L incompatible with " |
6829 | "RELEASE clause" , &loc); |
6830 | c->memorder = OMP_MEMORDER_SEQ_CST; |
6831 | } |
6832 | else if (c->memorder == OMP_MEMORDER_ACQ_REL) |
6833 | c->memorder = OMP_MEMORDER_ACQUIRE; |
6834 | break; |
6835 | case GFC_OMP_ATOMIC_WRITE: |
6836 | if (c->memorder == OMP_MEMORDER_ACQUIRE) |
6837 | { |
6838 | gfc_error ("!$OMP ATOMIC WRITE at %L incompatible with " |
6839 | "ACQUIRE clause" , &loc); |
6840 | c->memorder = OMP_MEMORDER_SEQ_CST; |
6841 | } |
6842 | else if (c->memorder == OMP_MEMORDER_ACQ_REL) |
6843 | c->memorder = OMP_MEMORDER_RELEASE; |
6844 | break; |
6845 | default: |
6846 | break; |
6847 | } |
6848 | gfc_error_check (); |
6849 | new_st.ext.omp_clauses = c; |
6850 | new_st.op = EXEC_OMP_ATOMIC; |
6851 | return MATCH_YES; |
6852 | } |
6853 | |
6854 | |
6855 | /* acc atomic [ read | write | update | capture] */ |
6856 | |
6857 | match |
6858 | gfc_match_oacc_atomic (void) |
6859 | { |
6860 | gfc_omp_clauses *c = gfc_get_omp_clauses (); |
6861 | c->atomic_op = GFC_OMP_ATOMIC_UPDATE; |
6862 | c->memorder = OMP_MEMORDER_RELAXED; |
6863 | gfc_gobble_whitespace (); |
6864 | if (gfc_match ("update" ) == MATCH_YES) |
6865 | ; |
6866 | else if (gfc_match ("read" ) == MATCH_YES) |
6867 | c->atomic_op = GFC_OMP_ATOMIC_READ; |
6868 | else if (gfc_match ("write" ) == MATCH_YES) |
6869 | c->atomic_op = GFC_OMP_ATOMIC_WRITE; |
6870 | else if (gfc_match ("capture" ) == MATCH_YES) |
6871 | c->capture = true; |
6872 | gfc_gobble_whitespace (); |
6873 | if (gfc_match_omp_eos () != MATCH_YES) |
6874 | { |
6875 | gfc_error ("Unexpected junk after !$ACC ATOMIC statement at %C" ); |
6876 | gfc_free_omp_clauses (c); |
6877 | return MATCH_ERROR; |
6878 | } |
6879 | new_st.ext.omp_clauses = c; |
6880 | new_st.op = EXEC_OACC_ATOMIC; |
6881 | return MATCH_YES; |
6882 | } |
6883 | |
6884 | |
6885 | match |
6886 | gfc_match_omp_barrier (void) |
6887 | { |
6888 | if (gfc_match_omp_eos () != MATCH_YES) |
6889 | { |
6890 | gfc_error ("Unexpected junk after $OMP BARRIER statement at %C" ); |
6891 | return MATCH_ERROR; |
6892 | } |
6893 | new_st.op = EXEC_OMP_BARRIER; |
6894 | new_st.ext.omp_clauses = NULL; |
6895 | return MATCH_YES; |
6896 | } |
6897 | |
6898 | |
6899 | match |
6900 | gfc_match_omp_taskgroup (void) |
6901 | { |
6902 | return match_omp (op: EXEC_OMP_TASKGROUP, OMP_TASKGROUP_CLAUSES); |
6903 | } |
6904 | |
6905 | |
6906 | static enum gfc_omp_cancel_kind |
6907 | gfc_match_omp_cancel_kind (void) |
6908 | { |
6909 | if (gfc_match_space () != MATCH_YES) |
6910 | return OMP_CANCEL_UNKNOWN; |
6911 | if (gfc_match ("parallel" ) == MATCH_YES) |
6912 | return OMP_CANCEL_PARALLEL; |
6913 | if (gfc_match ("sections" ) == MATCH_YES) |
6914 | return OMP_CANCEL_SECTIONS; |
6915 | if (gfc_match ("do" ) == MATCH_YES) |
6916 | return OMP_CANCEL_DO; |
6917 | if (gfc_match ("taskgroup" ) == MATCH_YES) |
6918 | return OMP_CANCEL_TASKGROUP; |
6919 | return OMP_CANCEL_UNKNOWN; |
6920 | } |
6921 | |
6922 | |
6923 | match |
6924 | gfc_match_omp_cancel (void) |
6925 | { |
6926 | gfc_omp_clauses *c; |
6927 | enum gfc_omp_cancel_kind kind = gfc_match_omp_cancel_kind (); |
6928 | if (kind == OMP_CANCEL_UNKNOWN) |
6929 | return MATCH_ERROR; |
6930 | if (gfc_match_omp_clauses (cp: &c, mask: omp_mask (OMP_CLAUSE_IF), first: false) != MATCH_YES) |
6931 | return MATCH_ERROR; |
6932 | c->cancel = kind; |
6933 | new_st.op = EXEC_OMP_CANCEL; |
6934 | new_st.ext.omp_clauses = c; |
6935 | return MATCH_YES; |
6936 | } |
6937 | |
6938 | |
6939 | match |
6940 | gfc_match_omp_cancellation_point (void) |
6941 | { |
6942 | gfc_omp_clauses *c; |
6943 | enum gfc_omp_cancel_kind kind = gfc_match_omp_cancel_kind (); |
6944 | if (kind == OMP_CANCEL_UNKNOWN) |
6945 | { |
6946 | gfc_error ("Expected construct-type PARALLEL, SECTIONS, DO or TASKGROUP " |
6947 | "in $OMP CANCELLATION POINT statement at %C" ); |
6948 | return MATCH_ERROR; |
6949 | } |
6950 | if (gfc_match_omp_eos () != MATCH_YES) |
6951 | { |
6952 | gfc_error ("Unexpected junk after $OMP CANCELLATION POINT statement " |
6953 | "at %C" ); |
6954 | return MATCH_ERROR; |
6955 | } |
6956 | c = gfc_get_omp_clauses (); |
6957 | c->cancel = kind; |
6958 | new_st.op = EXEC_OMP_CANCELLATION_POINT; |
6959 | new_st.ext.omp_clauses = c; |
6960 | return MATCH_YES; |
6961 | } |
6962 | |
6963 | |
6964 | match |
6965 | gfc_match_omp_end_nowait (void) |
6966 | { |
6967 | bool nowait = false; |
6968 | if (gfc_match ("% nowait" ) == MATCH_YES) |
6969 | nowait = true; |
6970 | if (gfc_match_omp_eos () != MATCH_YES) |
6971 | { |
6972 | if (nowait) |
6973 | gfc_error ("Unexpected junk after NOWAIT clause at %C" ); |
6974 | else |
6975 | gfc_error ("Unexpected junk at %C" ); |
6976 | return MATCH_ERROR; |
6977 | } |
6978 | new_st.op = EXEC_OMP_END_NOWAIT; |
6979 | new_st.ext.omp_bool = nowait; |
6980 | return MATCH_YES; |
6981 | } |
6982 | |
6983 | |
6984 | match |
6985 | gfc_match_omp_end_single (void) |
6986 | { |
6987 | gfc_omp_clauses *c; |
6988 | if (gfc_match_omp_clauses (cp: &c, mask: omp_mask (OMP_CLAUSE_COPYPRIVATE) |
6989 | | OMP_CLAUSE_NOWAIT) != MATCH_YES) |
6990 | return MATCH_ERROR; |
6991 | new_st.op = EXEC_OMP_END_SINGLE; |
6992 | new_st.ext.omp_clauses = c; |
6993 | return MATCH_YES; |
6994 | } |
6995 | |
6996 | |
6997 | static bool |
6998 | oacc_is_loop (gfc_code *code) |
6999 | { |
7000 | return code->op == EXEC_OACC_PARALLEL_LOOP |
7001 | || code->op == EXEC_OACC_KERNELS_LOOP |
7002 | || code->op == EXEC_OACC_SERIAL_LOOP |
7003 | || code->op == EXEC_OACC_LOOP; |
7004 | } |
7005 | |
7006 | static void |
7007 | resolve_scalar_int_expr (gfc_expr *expr, const char *clause) |
7008 | { |
7009 | if (!gfc_resolve_expr (expr) |
7010 | || expr->ts.type != BT_INTEGER |
7011 | || expr->rank != 0) |
7012 | gfc_error ("%s clause at %L requires a scalar INTEGER expression" , |
7013 | clause, &expr->where); |
7014 | } |
7015 | |
7016 | static void |
7017 | resolve_positive_int_expr (gfc_expr *expr, const char *clause) |
7018 | { |
7019 | resolve_scalar_int_expr (expr, clause); |
7020 | if (expr->expr_type == EXPR_CONSTANT |
7021 | && expr->ts.type == BT_INTEGER |
7022 | && mpz_sgn (expr->value.integer) <= 0) |
7023 | gfc_warning (opt: 0, "INTEGER expression of %s clause at %L must be positive" , |
7024 | clause, &expr->where); |
7025 | } |
7026 | |
7027 | static void |
7028 | resolve_nonnegative_int_expr (gfc_expr *expr, const char *clause) |
7029 | { |
7030 | resolve_scalar_int_expr (expr, clause); |
7031 | if (expr->expr_type == EXPR_CONSTANT |
7032 | && expr->ts.type == BT_INTEGER |
7033 | && mpz_sgn (expr->value.integer) < 0) |
7034 | gfc_warning (opt: 0, "INTEGER expression of %s clause at %L must be " |
7035 | "non-negative" , clause, &expr->where); |
7036 | } |
7037 | |
7038 | /* Emits error when symbol is pointer, cray pointer or cray pointee |
7039 | of derived of polymorphic type. */ |
7040 | |
7041 | static void |
7042 | check_symbol_not_pointer (gfc_symbol *sym, locus loc, const char *name) |
7043 | { |
7044 | if (sym->ts.type == BT_DERIVED && sym->attr.cray_pointer) |
7045 | gfc_error ("Cray pointer object %qs of derived type in %s clause at %L" , |
7046 | sym->name, name, &loc); |
7047 | if (sym->ts.type == BT_DERIVED && sym->attr.cray_pointee) |
7048 | gfc_error ("Cray pointee object %qs of derived type in %s clause at %L" , |
7049 | sym->name, name, &loc); |
7050 | |
7051 | if ((sym->ts.type == BT_ASSUMED && sym->attr.pointer) |
7052 | || (sym->ts.type == BT_CLASS && CLASS_DATA (sym) |
7053 | && CLASS_DATA (sym)->attr.pointer)) |
7054 | gfc_error ("POINTER object %qs of polymorphic type in %s clause at %L" , |
7055 | sym->name, name, &loc); |
7056 | if ((sym->ts.type == BT_ASSUMED && sym->attr.cray_pointer) |
7057 | || (sym->ts.type == BT_CLASS && CLASS_DATA (sym) |
7058 | && CLASS_DATA (sym)->attr.cray_pointer)) |
7059 | gfc_error ("Cray pointer object %qs of polymorphic type in %s clause at %L" , |
7060 | sym->name, name, &loc); |
7061 | if ((sym->ts.type == BT_ASSUMED && sym->attr.cray_pointee) |
7062 | || (sym->ts.type == BT_CLASS && CLASS_DATA (sym) |
7063 | && CLASS_DATA (sym)->attr.cray_pointee)) |
7064 | gfc_error ("Cray pointee object %qs of polymorphic type in %s clause at %L" , |
7065 | sym->name, name, &loc); |
7066 | } |
7067 | |
7068 | /* Emits error when symbol represents assumed size/rank array. */ |
7069 | |
7070 | static void |
7071 | check_array_not_assumed (gfc_symbol *sym, locus loc, const char *name) |
7072 | { |
7073 | if (sym->as && sym->as->type == AS_ASSUMED_SIZE) |
7074 | gfc_error ("Assumed size array %qs in %s clause at %L" , |
7075 | sym->name, name, &loc); |
7076 | if (sym->as && sym->as->type == AS_ASSUMED_RANK) |
7077 | gfc_error ("Assumed rank array %qs in %s clause at %L" , |
7078 | sym->name, name, &loc); |
7079 | } |
7080 | |
7081 | static void |
7082 | resolve_oacc_data_clauses (gfc_symbol *sym, locus loc, const char *name) |
7083 | { |
7084 | check_array_not_assumed (sym, loc, name); |
7085 | } |
7086 | |
7087 | static void |
7088 | resolve_oacc_deviceptr_clause (gfc_symbol *sym, locus loc, const char *name) |
7089 | { |
7090 | if (sym->attr.pointer |
7091 | || (sym->ts.type == BT_CLASS && CLASS_DATA (sym) |
7092 | && CLASS_DATA (sym)->attr.class_pointer)) |
7093 | gfc_error ("POINTER object %qs in %s clause at %L" , |
7094 | sym->name, name, &loc); |
7095 | if (sym->attr.cray_pointer |
7096 | || (sym->ts.type == BT_CLASS && CLASS_DATA (sym) |
7097 | && CLASS_DATA (sym)->attr.cray_pointer)) |
7098 | gfc_error ("Cray pointer object %qs in %s clause at %L" , |
7099 | sym->name, name, &loc); |
7100 | if (sym->attr.cray_pointee |
7101 | || (sym->ts.type == BT_CLASS && CLASS_DATA (sym) |
7102 | && CLASS_DATA (sym)->attr.cray_pointee)) |
7103 | gfc_error ("Cray pointee object %qs in %s clause at %L" , |
7104 | sym->name, name, &loc); |
7105 | if (sym->attr.allocatable |
7106 | || (sym->ts.type == BT_CLASS && CLASS_DATA (sym) |
7107 | && CLASS_DATA (sym)->attr.allocatable)) |
7108 | gfc_error ("ALLOCATABLE object %qs in %s clause at %L" , |
7109 | sym->name, name, &loc); |
7110 | if (sym->attr.value) |
7111 | gfc_error ("VALUE object %qs in %s clause at %L" , |
7112 | sym->name, name, &loc); |
7113 | check_array_not_assumed (sym, loc, name); |
7114 | } |
7115 | |
7116 | |
7117 | struct resolve_omp_udr_callback_data |
7118 | { |
7119 | gfc_symbol *sym1, *sym2; |
7120 | }; |
7121 | |
7122 | |
7123 | static int |
7124 | resolve_omp_udr_callback (gfc_expr **e, int *, void *data) |
7125 | { |
7126 | struct resolve_omp_udr_callback_data *rcd |
7127 | = (struct resolve_omp_udr_callback_data *) data; |
7128 | if ((*e)->expr_type == EXPR_VARIABLE |
7129 | && ((*e)->symtree->n.sym == rcd->sym1 |
7130 | || (*e)->symtree->n.sym == rcd->sym2)) |
7131 | { |
7132 | gfc_ref *ref = gfc_get_ref (); |
7133 | ref->type = REF_ARRAY; |
7134 | ref->u.ar.where = (*e)->where; |
7135 | ref->u.ar.as = (*e)->symtree->n.sym->as; |
7136 | ref->u.ar.type = AR_FULL; |
7137 | ref->u.ar.dimen = 0; |
7138 | ref->next = (*e)->ref; |
7139 | (*e)->ref = ref; |
7140 | } |
7141 | return 0; |
7142 | } |
7143 | |
7144 | |
7145 | static int |
7146 | resolve_omp_udr_callback2 (gfc_expr **e, int *, void *) |
7147 | { |
7148 | if ((*e)->expr_type == EXPR_FUNCTION |
7149 | && (*e)->value.function.isym == NULL) |
7150 | { |
7151 | gfc_symbol *sym = (*e)->symtree->n.sym; |
7152 | if (!sym->attr.intrinsic |
7153 | && sym->attr.if_source == IFSRC_UNKNOWN) |
7154 | gfc_error ("Implicitly declared function %s used in " |
7155 | "!$OMP DECLARE REDUCTION at %L" , sym->name, &(*e)->where); |
7156 | } |
7157 | return 0; |
7158 | } |
7159 | |
7160 | |
7161 | static gfc_code * |
7162 | resolve_omp_udr_clause (gfc_omp_namelist *n, gfc_namespace *ns, |
7163 | gfc_symbol *sym1, gfc_symbol *sym2) |
7164 | { |
7165 | gfc_code *copy; |
7166 | gfc_symbol sym1_copy, sym2_copy; |
7167 | |
7168 | if (ns->code->op == EXEC_ASSIGN) |
7169 | { |
7170 | copy = gfc_get_code (EXEC_ASSIGN); |
7171 | copy->expr1 = gfc_copy_expr (ns->code->expr1); |
7172 | copy->expr2 = gfc_copy_expr (ns->code->expr2); |
7173 | } |
7174 | else |
7175 | { |
7176 | copy = gfc_get_code (EXEC_CALL); |
7177 | copy->symtree = ns->code->symtree; |
7178 | copy->ext.actual = gfc_copy_actual_arglist (ns->code->ext.actual); |
7179 | } |
7180 | copy->loc = ns->code->loc; |
7181 | sym1_copy = *sym1; |
7182 | sym2_copy = *sym2; |
7183 | *sym1 = *n->sym; |
7184 | *sym2 = *n->sym; |
7185 | sym1->name = sym1_copy.name; |
7186 | sym2->name = sym2_copy.name; |
7187 | ns->proc_name = ns->parent->proc_name; |
7188 | if (n->sym->attr.dimension) |
7189 | { |
7190 | struct resolve_omp_udr_callback_data rcd; |
7191 | rcd.sym1 = sym1; |
7192 | rcd.sym2 = sym2; |
7193 | gfc_code_walker (©, gfc_dummy_code_callback, |
7194 | resolve_omp_udr_callback, &rcd); |
7195 | } |
7196 | gfc_resolve_code (copy, gfc_current_ns); |
7197 | if (copy->op == EXEC_CALL && copy->resolved_isym == NULL) |
7198 | { |
7199 | gfc_symbol *sym = copy->resolved_sym; |
7200 | if (sym |
7201 | && !sym->attr.intrinsic |
7202 | && sym->attr.if_source == IFSRC_UNKNOWN) |
7203 | gfc_error ("Implicitly declared subroutine %s used in " |
7204 | "!$OMP DECLARE REDUCTION at %L" , sym->name, |
7205 | ©->loc); |
7206 | } |
7207 | gfc_code_walker (©, gfc_dummy_code_callback, |
7208 | resolve_omp_udr_callback2, NULL); |
7209 | *sym1 = sym1_copy; |
7210 | *sym2 = sym2_copy; |
7211 | return copy; |
7212 | } |
7213 | |
7214 | /* Assume that a constant expression in the range 1 (omp_default_mem_alloc) |
7215 | to 8 (omp_thread_mem_alloc) range is fine. The original symbol name is |
7216 | already lost during matching via gfc_match_expr. */ |
7217 | static bool |
7218 | is_predefined_allocator (gfc_expr *expr) |
7219 | { |
7220 | return (gfc_resolve_expr (expr) |
7221 | && expr->rank == 0 |
7222 | && expr->ts.type == BT_INTEGER |
7223 | && expr->ts.kind == gfc_c_intptr_kind |
7224 | && expr->expr_type == EXPR_CONSTANT |
7225 | && mpz_sgn (expr->value.integer) > 0 |
7226 | && mpz_cmp_si (expr->value.integer, 8) <= 0); |
7227 | } |
7228 | |
7229 | /* Resolve declarative ALLOCATE statement. Note: Common block vars only appear |
7230 | as /block/ not individual, which is ensured during parsing. */ |
7231 | |
7232 | void |
7233 | gfc_resolve_omp_allocate (gfc_namespace *ns, gfc_omp_namelist *list) |
7234 | { |
7235 | for (gfc_omp_namelist *n = list; n; n = n->next) |
7236 | { |
7237 | if (n->sym->attr.result || n->sym->result == n->sym) |
7238 | { |
7239 | gfc_error ("Unexpected function-result variable %qs at %L in " |
7240 | "declarative !$OMP ALLOCATE" , n->sym->name, &n->where); |
7241 | continue; |
7242 | } |
7243 | if (ns->omp_allocate->sym->attr.proc_pointer) |
7244 | { |
7245 | gfc_error ("Procedure pointer %qs not supported with !$OMP " |
7246 | "ALLOCATE at %L" , n->sym->name, &n->where); |
7247 | continue; |
7248 | } |
7249 | if (n->sym->attr.flavor != FL_VARIABLE) |
7250 | { |
7251 | gfc_error ("Argument %qs at %L to declarative !$OMP ALLOCATE " |
7252 | "directive must be a variable" , n->sym->name, |
7253 | &n->where); |
7254 | continue; |
7255 | } |
7256 | if (ns != n->sym->ns || n->sym->attr.use_assoc || n->sym->attr.imported) |
7257 | { |
7258 | gfc_error ("Argument %qs at %L to declarative !$OMP ALLOCATE shall be" |
7259 | " in the same scope as the variable declaration" , |
7260 | n->sym->name, &n->where); |
7261 | continue; |
7262 | } |
7263 | if (n->sym->attr.dummy) |
7264 | { |
7265 | gfc_error ("Unexpected dummy argument %qs as argument at %L to " |
7266 | "declarative !$OMP ALLOCATE" , n->sym->name, &n->where); |
7267 | continue; |
7268 | } |
7269 | if (n->sym->attr.codimension) |
7270 | { |
7271 | gfc_error ("Unexpected coarray argument %qs as argument at %L to " |
7272 | "declarative !$OMP ALLOCATE" , n->sym->name, &n->where); |
7273 | continue; |
7274 | } |
7275 | if (n->sym->attr.omp_allocate) |
7276 | { |
7277 | if (n->sym->attr.in_common) |
7278 | { |
7279 | gfc_error ("Duplicated common block %</%s/%> in !$OMP ALLOCATE " |
7280 | "at %L" , n->sym->common_head->name, &n->where); |
7281 | while (n->next && n->next->sym |
7282 | && n->sym->common_head == n->next->sym->common_head) |
7283 | n = n->next; |
7284 | } |
7285 | else |
7286 | gfc_error ("Duplicated variable %qs in !$OMP ALLOCATE at %L" , |
7287 | n->sym->name, &n->where); |
7288 | continue; |
7289 | } |
7290 | /* For 'equivalence(a,b)', a 'union_type {<type> a,b} equiv.0' is created |
7291 | with a value expression for 'a' as 'equiv.0.a' (likewise for b); while |
7292 | this can be handled, EQUIVALENCE is marked as obsolescent since Fortran |
7293 | 2018 and also not widely used. However, it could be supported, |
7294 | if needed. */ |
7295 | if (n->sym->attr.in_equivalence) |
7296 | { |
7297 | gfc_error ("Sorry, EQUIVALENCE object %qs not supported with !$OMP " |
7298 | "ALLOCATE at %L" , n->sym->name, &n->where); |
7299 | continue; |
7300 | } |
7301 | /* Similar for Cray pointer/pointee - they could be implemented but as |
7302 | common vendor extension but nowadays rarely used and requiring |
7303 | -fcray-pointer, there is no need to support them. */ |
7304 | if (n->sym->attr.cray_pointer || n->sym->attr.cray_pointee) |
7305 | { |
7306 | gfc_error ("Sorry, Cray pointers and pointees such as %qs are not " |
7307 | "supported with !$OMP ALLOCATE at %L" , |
7308 | n->sym->name, &n->where); |
7309 | continue; |
7310 | } |
7311 | n->sym->attr.omp_allocate = 1; |
7312 | if ((n->sym->ts.type == BT_CLASS && n->sym->attr.class_ok |
7313 | && CLASS_DATA (n->sym)->attr.allocatable) |
7314 | || (n->sym->ts.type != BT_CLASS && n->sym->attr.allocatable)) |
7315 | gfc_error ("Unexpected allocatable variable %qs at %L in declarative " |
7316 | "!$OMP ALLOCATE directive" , n->sym->name, &n->where); |
7317 | else if ((n->sym->ts.type == BT_CLASS && n->sym->attr.class_ok |
7318 | && CLASS_DATA (n->sym)->attr.class_pointer) |
7319 | || (n->sym->ts.type != BT_CLASS && n->sym->attr.pointer)) |
7320 | gfc_error ("Unexpected pointer variable %qs at %L in declarative " |
7321 | "!$OMP ALLOCATE directive" , n->sym->name, &n->where); |
7322 | HOST_WIDE_INT alignment = 0; |
7323 | if (n->u.align |
7324 | && (!gfc_resolve_expr (n->u.align) |
7325 | || n->u.align->ts.type != BT_INTEGER |
7326 | || n->u.align->rank != 0 |
7327 | || n->u.align->expr_type != EXPR_CONSTANT |
7328 | || gfc_extract_hwi (n->u.align, &alignment) |
7329 | || !pow2p_hwi (x: alignment))) |
7330 | { |
7331 | gfc_error ("ALIGN requires a scalar positive constant integer " |
7332 | "alignment expression at %L that is a power of two" , |
7333 | &n->u.align->where); |
7334 | while (n->sym->attr.in_common && n->next && n->next->sym |
7335 | && n->sym->common_head == n->next->sym->common_head) |
7336 | n = n->next; |
7337 | continue; |
7338 | } |
7339 | if (n->sym->attr.in_common || n->sym->attr.save || n->sym->ns->save_all |
7340 | || (n->sym->ns->proc_name |
7341 | && (n->sym->ns->proc_name->attr.flavor == FL_PROGRAM |
7342 | || n->sym->ns->proc_name->attr.flavor == FL_MODULE))) |
7343 | { |
7344 | bool com = n->sym->attr.in_common; |
7345 | if (!n->u2.allocator) |
7346 | gfc_error ("An ALLOCATOR clause is required as the list item " |
7347 | "%<%s%s%s%> at %L has the SAVE attribute" , com ? "/" : "" , |
7348 | com ? n->sym->common_head->name : n->sym->name, |
7349 | com ? "/" : "" , &n->where); |
7350 | else if (!is_predefined_allocator (expr: n->u2.allocator)) |
7351 | gfc_error ("Predefined allocator required in ALLOCATOR clause at %L" |
7352 | " as the list item %<%s%s%s%> at %L has the SAVE attribute" , |
7353 | &n->u2.allocator->where, com ? "/" : "" , |
7354 | com ? n->sym->common_head->name : n->sym->name, |
7355 | com ? "/" : "" , &n->where); |
7356 | while (n->sym->attr.in_common && n->next && n->next->sym |
7357 | && n->sym->common_head == n->next->sym->common_head) |
7358 | n = n->next; |
7359 | } |
7360 | else if (n->u2.allocator |
7361 | && (!gfc_resolve_expr (n->u2.allocator) |
7362 | || n->u2.allocator->ts.type != BT_INTEGER |
7363 | || n->u2.allocator->rank != 0 |
7364 | || n->u2.allocator->ts.kind != gfc_c_intptr_kind)) |
7365 | gfc_error ("Expected integer expression of the " |
7366 | "%<omp_allocator_handle_kind%> kind at %L" , |
7367 | &n->u2.allocator->where); |
7368 | } |
7369 | } |
7370 | |
7371 | /* Resolve ASSUME's and ASSUMES' assumption clauses. Note that absent/contains |
7372 | is handled during parse time in omp_verify_merge_absent_contains. */ |
7373 | |
7374 | void |
7375 | gfc_resolve_omp_assumptions (gfc_omp_assumptions *assume) |
7376 | { |
7377 | for (gfc_expr_list *el = assume->holds; el; el = el->next) |
7378 | if (!gfc_resolve_expr (el->expr) |
7379 | || el->expr->ts.type != BT_LOGICAL |
7380 | || el->expr->rank != 0) |
7381 | gfc_error ("HOLDS expression at %L must be a scalar logical expression" , |
7382 | &el->expr->where); |
7383 | } |
7384 | |
7385 | |
7386 | /* OpenMP directive resolving routines. */ |
7387 | |
7388 | static void |
7389 | resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, |
7390 | gfc_namespace *ns, bool openacc = false) |
7391 | { |
7392 | gfc_omp_namelist *n, *last; |
7393 | gfc_expr_list *el; |
7394 | int list; |
7395 | int ifc; |
7396 | bool if_without_mod = false; |
7397 | gfc_omp_linear_op linear_op = OMP_LINEAR_DEFAULT; |
7398 | static const char *clause_names[] |
7399 | = { "PRIVATE" , "FIRSTPRIVATE" , "LASTPRIVATE" , "COPYPRIVATE" , "SHARED" , |
7400 | "COPYIN" , "UNIFORM" , "AFFINITY" , "ALIGNED" , "LINEAR" , "DEPEND" , "MAP" , |
7401 | "TO" , "FROM" , "INCLUSIVE" , "EXCLUSIVE" , |
7402 | "REDUCTION" , "REDUCTION" /*inscan*/, "REDUCTION" /*task*/, |
7403 | "IN_REDUCTION" , "TASK_REDUCTION" , |
7404 | "DEVICE_RESIDENT" , "LINK" , "USE_DEVICE" , |
7405 | "CACHE" , "IS_DEVICE_PTR" , "USE_DEVICE_PTR" , "USE_DEVICE_ADDR" , |
7406 | "NONTEMPORAL" , "ALLOCATE" , "HAS_DEVICE_ADDR" , "ENTER" , |
7407 | "USES_ALLOCATORS" }; |
7408 | STATIC_ASSERT (ARRAY_SIZE (clause_names) == OMP_LIST_NUM); |
7409 | |
7410 | if (omp_clauses == NULL) |
7411 | return; |
7412 | |
7413 | if (omp_clauses->orderedc && omp_clauses->orderedc < omp_clauses->collapse) |
7414 | gfc_error ("ORDERED clause parameter is less than COLLAPSE at %L" , |
7415 | &code->loc); |
7416 | if (omp_clauses->order_concurrent && omp_clauses->ordered) |
7417 | gfc_error ("ORDER clause must not be used together ORDERED at %L" , |
7418 | &code->loc); |
7419 | if (omp_clauses->if_expr) |
7420 | { |
7421 | gfc_expr *expr = omp_clauses->if_expr; |
7422 | if (!gfc_resolve_expr (expr) |
7423 | || expr->ts.type != BT_LOGICAL || expr->rank != 0) |
7424 | gfc_error ("IF clause at %L requires a scalar LOGICAL expression" , |
7425 | &expr->where); |
7426 | if_without_mod = true; |
7427 | } |
7428 | for (ifc = 0; ifc < OMP_IF_LAST; ifc++) |
7429 | if (omp_clauses->if_exprs[ifc]) |
7430 | { |
7431 | gfc_expr *expr = omp_clauses->if_exprs[ifc]; |
7432 | bool ok = true; |
7433 | if (!gfc_resolve_expr (expr) |
7434 | || expr->ts.type != BT_LOGICAL || expr->rank != 0) |
7435 | gfc_error ("IF clause at %L requires a scalar LOGICAL expression" , |
7436 | &expr->where); |
7437 | else if (if_without_mod) |
7438 | { |
7439 | gfc_error ("IF clause without modifier at %L used together with " |
7440 | "IF clauses with modifiers" , |
7441 | &omp_clauses->if_expr->where); |
7442 | if_without_mod = false; |
7443 | } |
7444 | else |
7445 | switch (code->op) |
7446 | { |
7447 | case EXEC_OMP_CANCEL: |
7448 | ok = ifc == OMP_IF_CANCEL; |
7449 | break; |
7450 | |
7451 | case EXEC_OMP_PARALLEL: |
7452 | case EXEC_OMP_PARALLEL_DO: |
7453 | case EXEC_OMP_PARALLEL_LOOP: |
7454 | case EXEC_OMP_PARALLEL_MASKED: |
7455 | case EXEC_OMP_PARALLEL_MASTER: |
7456 | case EXEC_OMP_PARALLEL_SECTIONS: |
7457 | case EXEC_OMP_PARALLEL_WORKSHARE: |
7458 | case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: |
7459 | case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: |
7460 | ok = ifc == OMP_IF_PARALLEL; |
7461 | break; |
7462 | |
7463 | case EXEC_OMP_PARALLEL_DO_SIMD: |
7464 | case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: |
7465 | case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: |
7466 | ok = ifc == OMP_IF_PARALLEL || ifc == OMP_IF_SIMD; |
7467 | break; |
7468 | |
7469 | case EXEC_OMP_PARALLEL_MASKED_TASKLOOP: |
7470 | case EXEC_OMP_PARALLEL_MASTER_TASKLOOP: |
7471 | ok = ifc == OMP_IF_PARALLEL || ifc == OMP_IF_TASKLOOP; |
7472 | break; |
7473 | |
7474 | case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: |
7475 | case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: |
7476 | ok = (ifc == OMP_IF_PARALLEL |
7477 | || ifc == OMP_IF_TASKLOOP |
7478 | || ifc == OMP_IF_SIMD); |
7479 | break; |
7480 | |
7481 | case EXEC_OMP_SIMD: |
7482 | case EXEC_OMP_DO_SIMD: |
7483 | case EXEC_OMP_DISTRIBUTE_SIMD: |
7484 | case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: |
7485 | ok = ifc == OMP_IF_SIMD; |
7486 | break; |
7487 | |
7488 | case EXEC_OMP_TASK: |
7489 | ok = ifc == OMP_IF_TASK; |
7490 | break; |
7491 | |
7492 | case EXEC_OMP_TASKLOOP: |
7493 | case EXEC_OMP_MASKED_TASKLOOP: |
7494 | case EXEC_OMP_MASTER_TASKLOOP: |
7495 | ok = ifc == OMP_IF_TASKLOOP; |
7496 | break; |
7497 | |
7498 | case EXEC_OMP_TASKLOOP_SIMD: |
7499 | case EXEC_OMP_MASKED_TASKLOOP_SIMD: |
7500 | case EXEC_OMP_MASTER_TASKLOOP_SIMD: |
7501 | ok = ifc == OMP_IF_TASKLOOP || ifc == OMP_IF_SIMD; |
7502 | break; |
7503 | |
7504 | case EXEC_OMP_TARGET: |
7505 | case EXEC_OMP_TARGET_TEAMS: |
7506 | case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: |
7507 | case EXEC_OMP_TARGET_TEAMS_LOOP: |
7508 | ok = ifc == OMP_IF_TARGET; |
7509 | break; |
7510 | |
7511 | case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: |
7512 | case EXEC_OMP_TARGET_SIMD: |
7513 | ok = ifc == OMP_IF_TARGET || ifc == OMP_IF_SIMD; |
7514 | break; |
7515 | |
7516 | case EXEC_OMP_TARGET_DATA: |
7517 | ok = ifc == OMP_IF_TARGET_DATA; |
7518 | break; |
7519 | |
7520 | case EXEC_OMP_TARGET_UPDATE: |
7521 | ok = ifc == OMP_IF_TARGET_UPDATE; |
7522 | break; |
7523 | |
7524 | case EXEC_OMP_TARGET_ENTER_DATA: |
7525 | ok = ifc == OMP_IF_TARGET_ENTER_DATA; |
7526 | break; |
7527 | |
7528 | case EXEC_OMP_TARGET_EXIT_DATA: |
7529 | ok = ifc == OMP_IF_TARGET_EXIT_DATA; |
7530 | break; |
7531 | |
7532 | case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: |
7533 | case EXEC_OMP_TARGET_PARALLEL: |
7534 | case EXEC_OMP_TARGET_PARALLEL_DO: |
7535 | case EXEC_OMP_TARGET_PARALLEL_LOOP: |
7536 | ok = ifc == OMP_IF_TARGET || ifc == OMP_IF_PARALLEL; |
7537 | break; |
7538 | |
7539 | case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: |
7540 | case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: |
7541 | ok = (ifc == OMP_IF_TARGET |
7542 | || ifc == OMP_IF_PARALLEL |
7543 | || ifc == OMP_IF_SIMD); |
7544 | break; |
7545 | |
7546 | default: |
7547 | ok = false; |
7548 | break; |
7549 | } |
7550 | if (!ok) |
7551 | { |
7552 | static const char *ifs[] = { |
7553 | "CANCEL" , |
7554 | "PARALLEL" , |
7555 | "SIMD" , |
7556 | "TASK" , |
7557 | "TASKLOOP" , |
7558 | "TARGET" , |
7559 | "TARGET DATA" , |
7560 | "TARGET UPDATE" , |
7561 | "TARGET ENTER DATA" , |
7562 | "TARGET EXIT DATA" |
7563 | }; |
7564 | gfc_error ("IF clause modifier %s at %L not appropriate for " |
7565 | "the current OpenMP construct" , ifs[ifc], &expr->where); |
7566 | } |
7567 | } |
7568 | |
7569 | if (omp_clauses->self_expr) |
7570 | { |
7571 | gfc_expr *expr = omp_clauses->self_expr; |
7572 | if (!gfc_resolve_expr (expr) |
7573 | || expr->ts.type != BT_LOGICAL || expr->rank != 0) |
7574 | gfc_error ("SELF clause at %L requires a scalar LOGICAL expression" , |
7575 | &expr->where); |
7576 | } |
7577 | |
7578 | if (omp_clauses->final_expr) |
7579 | { |
7580 | gfc_expr *expr = omp_clauses->final_expr; |
7581 | if (!gfc_resolve_expr (expr) |
7582 | || expr->ts.type != BT_LOGICAL || expr->rank != 0) |
7583 | gfc_error ("FINAL clause at %L requires a scalar LOGICAL expression" , |
7584 | &expr->where); |
7585 | } |
7586 | if (omp_clauses->num_threads) |
7587 | resolve_positive_int_expr (expr: omp_clauses->num_threads, clause: "NUM_THREADS" ); |
7588 | if (omp_clauses->chunk_size) |
7589 | { |
7590 | gfc_expr *expr = omp_clauses->chunk_size; |
7591 | if (!gfc_resolve_expr (expr) |
7592 | || expr->ts.type != BT_INTEGER || expr->rank != 0) |
7593 | gfc_error ("SCHEDULE clause's chunk_size at %L requires " |
7594 | "a scalar INTEGER expression" , &expr->where); |
7595 | else if (expr->expr_type == EXPR_CONSTANT |
7596 | && expr->ts.type == BT_INTEGER |
7597 | && mpz_sgn (expr->value.integer) <= 0) |
7598 | gfc_warning (opt: 0, "INTEGER expression of SCHEDULE clause's chunk_size " |
7599 | "at %L must be positive" , &expr->where); |
7600 | } |
7601 | if (omp_clauses->sched_kind != OMP_SCHED_NONE |
7602 | && omp_clauses->sched_nonmonotonic) |
7603 | { |
7604 | if (omp_clauses->sched_monotonic) |
7605 | gfc_error ("Both MONOTONIC and NONMONOTONIC schedule modifiers " |
7606 | "specified at %L" , &code->loc); |
7607 | else if (omp_clauses->ordered) |
7608 | gfc_error ("NONMONOTONIC schedule modifier specified with ORDERED " |
7609 | "clause at %L" , &code->loc); |
7610 | } |
7611 | |
7612 | if (omp_clauses->depobj |
7613 | && (!gfc_resolve_expr (omp_clauses->depobj) |
7614 | || omp_clauses->depobj->ts.type != BT_INTEGER |
7615 | || omp_clauses->depobj->ts.kind != 2 * gfc_index_integer_kind |
7616 | || omp_clauses->depobj->rank != 0)) |
7617 | gfc_error ("DEPOBJ in DEPOBJ construct at %L shall be a scalar integer " |
7618 | "of OMP_DEPEND_KIND kind" , &omp_clauses->depobj->where); |
7619 | |
7620 | /* Check that no symbol appears on multiple clauses, except that |
7621 | a symbol can appear on both firstprivate and lastprivate. */ |
7622 | for (list = 0; list < OMP_LIST_NUM; list++) |
7623 | for (n = omp_clauses->lists[list]; n; n = n->next) |
7624 | { |
7625 | if (!n->sym) /* omp_all_memory. */ |
7626 | continue; |
7627 | n->sym->mark = 0; |
7628 | n->sym->comp_mark = 0; |
7629 | n->sym->data_mark = 0; |
7630 | n->sym->dev_mark = 0; |
7631 | n->sym->gen_mark = 0; |
7632 | n->sym->reduc_mark = 0; |
7633 | if (n->sym->attr.flavor == FL_VARIABLE |
7634 | || n->sym->attr.proc_pointer |
7635 | || (!code && (!n->sym->attr.dummy || n->sym->ns != ns))) |
7636 | { |
7637 | if (!code && (!n->sym->attr.dummy || n->sym->ns != ns)) |
7638 | gfc_error ("Variable %qs is not a dummy argument at %L" , |
7639 | n->sym->name, &n->where); |
7640 | continue; |
7641 | } |
7642 | if (n->sym->attr.flavor == FL_PROCEDURE |
7643 | && n->sym->result == n->sym |
7644 | && n->sym->attr.function) |
7645 | { |
7646 | if (gfc_current_ns->proc_name == n->sym |
7647 | || (gfc_current_ns->parent |
7648 | && gfc_current_ns->parent->proc_name == n->sym)) |
7649 | continue; |
7650 | if (gfc_current_ns->proc_name->attr.entry_master) |
7651 | { |
7652 | gfc_entry_list *el = gfc_current_ns->entries; |
7653 | for (; el; el = el->next) |
7654 | if (el->sym == n->sym) |
7655 | break; |
7656 | if (el) |
7657 | continue; |
7658 | } |
7659 | if (gfc_current_ns->parent |
7660 | && gfc_current_ns->parent->proc_name->attr.entry_master) |
7661 | { |
7662 | gfc_entry_list *el = gfc_current_ns->parent->entries; |
7663 | for (; el; el = el->next) |
7664 | if (el->sym == n->sym) |
7665 | break; |
7666 | if (el) |
7667 | continue; |
7668 | } |
7669 | } |
7670 | if (list == OMP_LIST_MAP |
7671 | && n->sym->attr.flavor == FL_PARAMETER) |
7672 | { |
7673 | if (openacc) |
7674 | gfc_error ("Object %qs is not a variable at %L; parameters" |
7675 | " cannot be and need not be copied" , n->sym->name, |
7676 | &n->where); |
7677 | else |
7678 | gfc_error ("Object %qs is not a variable at %L; parameters" |
7679 | " cannot be and need not be mapped" , n->sym->name, |
7680 | &n->where); |
7681 | } |
7682 | else if (list != OMP_LIST_USES_ALLOCATORS) |
7683 | gfc_error ("Object %qs is not a variable at %L" , n->sym->name, |
7684 | &n->where); |
7685 | } |
7686 | if (omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN]) |
7687 | { |
7688 | locus *loc = &omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN]->where; |
7689 | if (code->op != EXEC_OMP_DO |
7690 | && code->op != EXEC_OMP_SIMD |
7691 | && code->op != EXEC_OMP_DO_SIMD |
7692 | && code->op != EXEC_OMP_PARALLEL_DO |
7693 | && code->op != EXEC_OMP_PARALLEL_DO_SIMD) |
7694 | gfc_error ("%<inscan%> REDUCTION clause on construct other than DO, " |
7695 | "SIMD, DO SIMD, PARALLEL DO, PARALLEL DO SIMD at %L" , |
7696 | loc); |
7697 | if (omp_clauses->ordered) |
7698 | gfc_error ("ORDERED clause specified together with %<inscan%> " |
7699 | "REDUCTION clause at %L" , loc); |
7700 | if (omp_clauses->sched_kind != OMP_SCHED_NONE) |
7701 | gfc_error ("SCHEDULE clause specified together with %<inscan%> " |
7702 | "REDUCTION clause at %L" , loc); |
7703 | } |
7704 | |
7705 | for (list = 0; list < OMP_LIST_NUM; list++) |
7706 | if (list != OMP_LIST_FIRSTPRIVATE |
7707 | && list != OMP_LIST_LASTPRIVATE |
7708 | && list != OMP_LIST_ALIGNED |
7709 | && list != OMP_LIST_DEPEND |
7710 | && list != OMP_LIST_FROM |
7711 | && list != OMP_LIST_TO |
7712 | && (list != OMP_LIST_REDUCTION || !openacc) |
7713 | && list != OMP_LIST_ALLOCATE) |
7714 | for (n = omp_clauses->lists[list]; n; n = n->next) |
7715 | { |
7716 | bool component_ref_p = false; |
7717 | |
7718 | /* Allow multiple components of the same (e.g. derived-type) |
7719 | variable here. Duplicate components are detected elsewhere. */ |
7720 | if (n->expr && n->expr->expr_type == EXPR_VARIABLE) |
7721 | for (gfc_ref *ref = n->expr->ref; ref; ref = ref->next) |
7722 | if (ref->type == REF_COMPONENT) |
7723 | component_ref_p = true; |
7724 | if ((list == OMP_LIST_IS_DEVICE_PTR |
7725 | || list == OMP_LIST_HAS_DEVICE_ADDR) |
7726 | && !component_ref_p) |
7727 | { |
7728 | if (n->sym->gen_mark |
7729 | || n->sym->dev_mark |
7730 | || n->sym->reduc_mark |
7731 | || n->sym->mark) |
7732 | gfc_error ("Symbol %qs present on multiple clauses at %L" , |
7733 | n->sym->name, &n->where); |
7734 | else |
7735 | n->sym->dev_mark = 1; |
7736 | } |
7737 | else if ((list == OMP_LIST_USE_DEVICE_PTR |
7738 | || list == OMP_LIST_USE_DEVICE_ADDR |
7739 | || list == OMP_LIST_PRIVATE |
7740 | || list == OMP_LIST_SHARED) |
7741 | && !component_ref_p) |
7742 | { |
7743 | if (n->sym->gen_mark || n->sym->dev_mark || n->sym->reduc_mark) |
7744 | gfc_error ("Symbol %qs present on multiple clauses at %L" , |
7745 | n->sym->name, &n->where); |
7746 | else |
7747 | { |
7748 | n->sym->gen_mark = 1; |
7749 | /* Set both generic and device bits if we have |
7750 | use_device_*(x) or shared(x). This allows us to diagnose |
7751 | "map(x) private(x)" below. */ |
7752 | if (list != OMP_LIST_PRIVATE) |
7753 | n->sym->dev_mark = 1; |
7754 | } |
7755 | } |
7756 | else if ((list == OMP_LIST_REDUCTION |
7757 | || list == OMP_LIST_REDUCTION_TASK |
7758 | || list == OMP_LIST_REDUCTION_INSCAN |
7759 | || list == OMP_LIST_IN_REDUCTION |
7760 | || list == OMP_LIST_TASK_REDUCTION) |
7761 | && !component_ref_p) |
7762 | { |
7763 | /* Attempts to mix reduction types are diagnosed below. */ |
7764 | if (n->sym->gen_mark || n->sym->dev_mark) |
7765 | gfc_error ("Symbol %qs present on multiple clauses at %L" , |
7766 | n->sym->name, &n->where); |
7767 | n->sym->reduc_mark = 1; |
7768 | } |
7769 | else if ((!component_ref_p && n->sym->comp_mark) |
7770 | || (component_ref_p && n->sym->mark)) |
7771 | { |
7772 | if (openacc) |
7773 | gfc_error ("Symbol %qs has mixed component and non-component " |
7774 | "accesses at %L" , n->sym->name, &n->where); |
7775 | } |
7776 | else if (n->sym->mark) |
7777 | gfc_error ("Symbol %qs present on multiple clauses at %L" , |
7778 | n->sym->name, &n->where); |
7779 | else |
7780 | { |
7781 | if (component_ref_p) |
7782 | n->sym->comp_mark = 1; |
7783 | else |
7784 | n->sym->mark = 1; |
7785 | } |
7786 | } |
7787 | |
7788 | /* Detect specifically the case where we have "map(x) private(x)" and raise |
7789 | an error. If we have "...simd" combined directives though, the "private" |
7790 | applies to the simd part, so this is permitted though. */ |
7791 | for (n = omp_clauses->lists[OMP_LIST_PRIVATE]; n; n = n->next) |
7792 | if (n->sym->mark |
7793 | && n->sym->gen_mark |
7794 | && !n->sym->dev_mark |
7795 | && !n->sym->reduc_mark |
7796 | && code->op != EXEC_OMP_TARGET_SIMD |
7797 | && code->op != EXEC_OMP_TARGET_PARALLEL_DO_SIMD |
7798 | && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD |
7799 | && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD) |
7800 | gfc_error ("Symbol %qs present on multiple clauses at %L" , |
7801 | n->sym->name, &n->where); |
7802 | |
7803 | gcc_assert (OMP_LIST_LASTPRIVATE == OMP_LIST_FIRSTPRIVATE + 1); |
7804 | for (list = OMP_LIST_FIRSTPRIVATE; list <= OMP_LIST_LASTPRIVATE; list++) |
7805 | for (n = omp_clauses->lists[list]; n; n = n->next) |
7806 | if (n->sym->data_mark || n->sym->gen_mark || n->sym->dev_mark) |
7807 | { |
7808 | gfc_error ("Symbol %qs present on multiple clauses at %L" , |
7809 | n->sym->name, &n->where); |
7810 | n->sym->data_mark = n->sym->gen_mark = n->sym->dev_mark = 0; |
7811 | } |
7812 | else if (n->sym->mark |
7813 | && code->op != EXEC_OMP_TARGET_TEAMS |
7814 | && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE |
7815 | && code->op != EXEC_OMP_TARGET_TEAMS_LOOP |
7816 | && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD |
7817 | && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO |
7818 | && code->op != EXEC_OMP_TARGET_PARALLEL |
7819 | && code->op != EXEC_OMP_TARGET_PARALLEL_DO |
7820 | && code->op != EXEC_OMP_TARGET_PARALLEL_LOOP |
7821 | && code->op != EXEC_OMP_TARGET_PARALLEL_DO_SIMD |
7822 | && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD) |
7823 | gfc_error ("Symbol %qs present on both data and map clauses " |
7824 | "at %L" , n->sym->name, &n->where); |
7825 | |
7826 | for (n = omp_clauses->lists[OMP_LIST_FIRSTPRIVATE]; n; n = n->next) |
7827 | { |
7828 | if (n->sym->data_mark || n->sym->gen_mark || n->sym->dev_mark) |
7829 | gfc_error ("Symbol %qs present on multiple clauses at %L" , |
7830 | n->sym->name, &n->where); |
7831 | else |
7832 | n->sym->data_mark = 1; |
7833 | } |
7834 | for (n = omp_clauses->lists[OMP_LIST_LASTPRIVATE]; n; n = n->next) |
7835 | n->sym->data_mark = 0; |
7836 | |
7837 | for (n = omp_clauses->lists[OMP_LIST_LASTPRIVATE]; n; n = n->next) |
7838 | { |
7839 | if (n->sym->data_mark || n->sym->gen_mark || n->sym->dev_mark) |
7840 | gfc_error ("Symbol %qs present on multiple clauses at %L" , |
7841 | n->sym->name, &n->where); |
7842 | else |
7843 | n->sym->data_mark = 1; |
7844 | } |
7845 | |
7846 | for (n = omp_clauses->lists[OMP_LIST_ALIGNED]; n; n = n->next) |
7847 | n->sym->mark = 0; |
7848 | |
7849 | for (n = omp_clauses->lists[OMP_LIST_ALIGNED]; n; n = n->next) |
7850 | { |
7851 | if (n->sym->mark) |
7852 | gfc_error ("Symbol %qs present on multiple clauses at %L" , |
7853 | n->sym->name, &n->where); |
7854 | else |
7855 | n->sym->mark = 1; |
7856 | } |
7857 | |
7858 | if (omp_clauses->lists[OMP_LIST_ALLOCATE]) |
7859 | { |
7860 | for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next) |
7861 | { |
7862 | if (n->u2.allocator |
7863 | && (!gfc_resolve_expr (n->u2.allocator) |
7864 | || n->u2.allocator->ts.type != BT_INTEGER |
7865 | || n->u2.allocator->rank != 0 |
7866 | || n->u2.allocator->ts.kind != gfc_c_intptr_kind)) |
7867 | { |
7868 | gfc_error ("Expected integer expression of the " |
7869 | "%<omp_allocator_handle_kind%> kind at %L" , |
7870 | &n->u2.allocator->where); |
7871 | break; |
7872 | } |
7873 | if (!n->u.align) |
7874 | continue; |
7875 | HOST_WIDE_INT alignment = 0; |
7876 | if (!gfc_resolve_expr (n->u.align) |
7877 | || n->u.align->ts.type != BT_INTEGER |
7878 | || n->u.align->rank != 0 |
7879 | || n->u.align->expr_type != EXPR_CONSTANT |
7880 | || gfc_extract_hwi (n->u.align, &alignment) |
7881 | || alignment <= 0 |
7882 | || !pow2p_hwi (x: alignment)) |
7883 | { |
7884 | gfc_error ("ALIGN requires a scalar positive constant integer " |
7885 | "alignment expression at %L that is a power of two" , |
7886 | &n->u.align->where); |
7887 | break; |
7888 | } |
7889 | } |
7890 | |
7891 | /* Check for 2 things here. |
7892 | 1. There is no duplication of variable in allocate clause. |
7893 | 2. Variable in allocate clause are also present in some |
7894 | privatization clase (non-composite case). */ |
7895 | for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next) |
7896 | if (n->sym) |
7897 | n->sym->mark = 0; |
7898 | |
7899 | gfc_omp_namelist *prev = NULL; |
7900 | for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; ) |
7901 | { |
7902 | if (n->sym == NULL) |
7903 | { |
7904 | n = n->next; |
7905 | continue; |
7906 | } |
7907 | if (n->sym->mark == 1) |
7908 | { |
7909 | gfc_warning (opt: 0, "%qs appears more than once in %<allocate%> " |
7910 | "at %L" , n->sym->name, &n->where); |
7911 | /* We have already seen this variable so it is a duplicate. |
7912 | Remove it. */ |
7913 | if (prev != NULL && prev->next == n) |
7914 | { |
7915 | prev->next = n->next; |
7916 | n->next = NULL; |
7917 | gfc_free_omp_namelist (n, false, true, false); |
7918 | n = prev->next; |
7919 | } |
7920 | continue; |
7921 | } |
7922 | n->sym->mark = 1; |
7923 | prev = n; |
7924 | n = n->next; |
7925 | } |
7926 | |
7927 | /* Non-composite constructs. */ |
7928 | if (code && code->op < EXEC_OMP_DO_SIMD) |
7929 | { |
7930 | for (list = 0; list < OMP_LIST_NUM; list++) |
7931 | switch (list) |
7932 | { |
7933 | case OMP_LIST_PRIVATE: |
7934 | case OMP_LIST_FIRSTPRIVATE: |
7935 | case OMP_LIST_LASTPRIVATE: |
7936 | case OMP_LIST_REDUCTION: |
7937 | case OMP_LIST_REDUCTION_INSCAN: |
7938 | case OMP_LIST_REDUCTION_TASK: |
7939 | case OMP_LIST_IN_REDUCTION: |
7940 | case OMP_LIST_TASK_REDUCTION: |
7941 | case OMP_LIST_LINEAR: |
7942 | for (n = omp_clauses->lists[list]; n; n = n->next) |
7943 | n->sym->mark = 0; |
7944 | break; |
7945 | default: |
7946 | break; |
7947 | } |
7948 | |
7949 | for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next) |
7950 | if (n->sym->mark == 1) |
7951 | gfc_error ("%qs specified in %<allocate%> clause at %L but not " |
7952 | "in an explicit privatization clause" , |
7953 | n->sym->name, &n->where); |
7954 | } |
7955 | if (code |
7956 | && (code->op == EXEC_OMP_ALLOCATORS || code->op == EXEC_OMP_ALLOCATE) |
7957 | && code->block |
7958 | && code->block->next |
7959 | && code->block->next->op == EXEC_ALLOCATE) |
7960 | { |
7961 | gfc_alloc *a; |
7962 | for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next) |
7963 | { |
7964 | if (n->sym == NULL) |
7965 | continue; |
7966 | if (n->sym->attr.codimension) |
7967 | gfc_error ("Unexpected coarray %qs in %<allocate%> at %L" , |
7968 | n->sym->name, &n->where); |
7969 | for (a = code->block->next->ext.alloc.list; a; a = a->next) |
7970 | if (a->expr->expr_type == EXPR_VARIABLE |
7971 | && a->expr->symtree->n.sym == n->sym) |
7972 | break; |
7973 | if (a == NULL) |
7974 | gfc_error ("%qs specified in %<allocate%> at %L but not " |
7975 | "in the associated ALLOCATE statement" , |
7976 | n->sym->name, &n->where); |
7977 | } |
7978 | } |
7979 | |
7980 | } |
7981 | |
7982 | /* OpenACC reductions. */ |
7983 | if (openacc) |
7984 | { |
7985 | for (n = omp_clauses->lists[OMP_LIST_REDUCTION]; n; n = n->next) |
7986 | n->sym->mark = 0; |
7987 | |
7988 | for (n = omp_clauses->lists[OMP_LIST_REDUCTION]; n; n = n->next) |
7989 | { |
7990 | if (n->sym->mark) |
7991 | gfc_error ("Symbol %qs present on multiple clauses at %L" , |
7992 | n->sym->name, &n->where); |
7993 | else |
7994 | n->sym->mark = 1; |
7995 | |
7996 | /* OpenACC does not support reductions on arrays. */ |
7997 | if (n->sym->as) |
7998 | gfc_error ("Array %qs is not permitted in reduction at %L" , |
7999 | n->sym->name, &n->where); |
8000 | } |
8001 | } |
8002 | |
8003 | for (n = omp_clauses->lists[OMP_LIST_TO]; n; n = n->next) |
8004 | n->sym->mark = 0; |
8005 | for (n = omp_clauses->lists[OMP_LIST_FROM]; n; n = n->next) |
8006 | if (n->expr == NULL) |
8007 | n->sym->mark = 1; |
8008 | for (n = omp_clauses->lists[OMP_LIST_TO]; n; n = n->next) |
8009 | { |
8010 | if (n->expr == NULL && n->sym->mark) |
8011 | gfc_error ("Symbol %qs present on both FROM and TO clauses at %L" , |
8012 | n->sym->name, &n->where); |
8013 | else |
8014 | n->sym->mark = 1; |
8015 | } |
8016 | |
8017 | bool has_inscan = false, has_notinscan = false; |
8018 | for (list = 0; list < OMP_LIST_NUM; list++) |
8019 | if ((n = omp_clauses->lists[list]) != NULL) |
8020 | { |
8021 | const char *name = clause_names[list]; |
8022 | |
8023 | switch (list) |
8024 | { |
8025 | case OMP_LIST_COPYIN: |
8026 | for (; n != NULL; n = n->next) |
8027 | { |
8028 | if (!n->sym->attr.threadprivate) |
8029 | gfc_error ("Non-THREADPRIVATE object %qs in COPYIN clause" |
8030 | " at %L" , n->sym->name, &n->where); |
8031 | } |
8032 | break; |
8033 | case OMP_LIST_COPYPRIVATE: |
8034 | if (omp_clauses->nowait) |
8035 | gfc_error ("NOWAIT clause must not be used with COPYPRIVATE " |
8036 | "clause at %L" , &n->where); |
8037 | for (; n != NULL; n = n->next) |
8038 | { |
8039 | if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE) |
8040 | gfc_error ("Assumed size array %qs in COPYPRIVATE clause " |
8041 | "at %L" , n->sym->name, &n->where); |
8042 | if (n->sym->attr.pointer && n->sym->attr.intent == INTENT_IN) |
8043 | gfc_error ("INTENT(IN) POINTER %qs in COPYPRIVATE clause " |
8044 | "at %L" , n->sym->name, &n->where); |
8045 | } |
8046 | break; |
8047 | case OMP_LIST_SHARED: |
8048 | for (; n != NULL; n = n->next) |
8049 | { |
8050 | if (n->sym->attr.threadprivate) |
8051 | gfc_error ("THREADPRIVATE object %qs in SHARED clause at " |
8052 | "%L" , n->sym->name, &n->where); |
8053 | if (n->sym->attr.cray_pointee) |
8054 | gfc_error ("Cray pointee %qs in SHARED clause at %L" , |
8055 | n->sym->name, &n->where); |
8056 | if (n->sym->attr.associate_var) |
8057 | gfc_error ("Associate name %qs in SHARED clause at %L" , |
8058 | n->sym->attr.select_type_temporary |
8059 | ? n->sym->assoc->target->symtree->n.sym->name |
8060 | : n->sym->name, &n->where); |
8061 | if (omp_clauses->detach |
8062 | && n->sym == omp_clauses->detach->symtree->n.sym) |
8063 | gfc_error ("DETACH event handle %qs in SHARED clause at %L" , |
8064 | n->sym->name, &n->where); |
8065 | } |
8066 | break; |
8067 | case OMP_LIST_ALIGNED: |
8068 | for (; n != NULL; n = n->next) |
8069 | { |
8070 | if (!n->sym->attr.pointer |
8071 | && !n->sym->attr.allocatable |
8072 | && !n->sym->attr.cray_pointer |
8073 | && (n->sym->ts.type != BT_DERIVED |
8074 | || (n->sym->ts.u.derived->from_intmod |
8075 | != INTMOD_ISO_C_BINDING) |
8076 | || (n->sym->ts.u.derived->intmod_sym_id |
8077 | != ISOCBINDING_PTR))) |
8078 | gfc_error ("%qs in ALIGNED clause must be POINTER, " |
8079 | "ALLOCATABLE, Cray pointer or C_PTR at %L" , |
8080 | n->sym->name, &n->where); |
8081 | else if (n->expr) |
8082 | { |
8083 | if (!gfc_resolve_expr (n->expr) |
8084 | || n->expr->ts.type != BT_INTEGER |
8085 | || n->expr->rank != 0 |
8086 | || n->expr->expr_type != EXPR_CONSTANT |
8087 | || mpz_sgn (n->expr->value.integer) <= 0) |
8088 | gfc_error ("%qs in ALIGNED clause at %L requires a scalar" |
8089 | " positive constant integer alignment " |
8090 | "expression" , n->sym->name, &n->where); |
8091 | } |
8092 | } |
8093 | break; |
8094 | case OMP_LIST_AFFINITY: |
8095 | case OMP_LIST_DEPEND: |
8096 | case OMP_LIST_MAP: |
8097 | case OMP_LIST_TO: |
8098 | case OMP_LIST_FROM: |
8099 | case OMP_LIST_CACHE: |
8100 | for (; n != NULL; n = n->next) |
8101 | { |
8102 | if ((list == OMP_LIST_DEPEND || list == OMP_LIST_AFFINITY) |
8103 | && n->u2.ns && !n->u2.ns->resolved) |
8104 | { |
8105 | n->u2.ns->resolved = 1; |
8106 | for (gfc_symbol *sym = n->u2.ns->omp_affinity_iterators; |
8107 | sym; sym = sym->tlink) |
8108 | { |
8109 | gfc_constructor *c; |
8110 | c = gfc_constructor_first (base: sym->value->value.constructor); |
8111 | if (!gfc_resolve_expr (c->expr) |
8112 | || c->expr->ts.type != BT_INTEGER |
8113 | || c->expr->rank != 0) |
8114 | gfc_error ("Scalar integer expression for range begin" |
8115 | " expected at %L" , &c->expr->where); |
8116 | c = gfc_constructor_next (ctor: c); |
8117 | if (!gfc_resolve_expr (c->expr) |
8118 | || c->expr->ts.type != BT_INTEGER |
8119 | || c->expr->rank != 0) |
8120 | gfc_error ("Scalar integer expression for range end " |
8121 | "expected at %L" , &c->expr->where); |
8122 | c = gfc_constructor_next (ctor: c); |
8123 | if (c && (!gfc_resolve_expr (c->expr) |
8124 | || c->expr->ts.type != BT_INTEGER |
8125 | || c->expr->rank != 0)) |
8126 | gfc_error ("Scalar integer expression for range step " |
8127 | "expected at %L" , &c->expr->where); |
8128 | else if (c |
8129 | && c->expr->expr_type == EXPR_CONSTANT |
8130 | && mpz_cmp_si (c->expr->value.integer, 0) == 0) |
8131 | gfc_error ("Nonzero range step expected at %L" , |
8132 | &c->expr->where); |
8133 | } |
8134 | } |
8135 | |
8136 | if (list == OMP_LIST_DEPEND) |
8137 | { |
8138 | if (n->u.depend_doacross_op == OMP_DEPEND_SINK_FIRST |
8139 | || n->u.depend_doacross_op == OMP_DOACROSS_SINK_FIRST |
8140 | || n->u.depend_doacross_op == OMP_DOACROSS_SINK) |
8141 | { |
8142 | if (omp_clauses->doacross_source) |
8143 | { |
8144 | gfc_error ("Dependence-type SINK used together with" |
8145 | " SOURCE on the same construct at %L" , |
8146 | &n->where); |
8147 | omp_clauses->doacross_source = false; |
8148 | } |
8149 | else if (n->expr) |
8150 | { |
8151 | if (!gfc_resolve_expr (n->expr) |
8152 | || n->expr->ts.type != BT_INTEGER |
8153 | || n->expr->rank != 0) |
8154 | gfc_error ("SINK addend not a constant integer " |
8155 | "at %L" , &n->where); |
8156 | } |
8157 | if (n->sym == NULL |
8158 | && (n->expr == NULL |
8159 | || mpz_cmp_si (n->expr->value.integer, -1) != 0)) |
8160 | gfc_error ("omp_cur_iteration at %L requires %<-1%> " |
8161 | "as logical offset" , &n->where); |
8162 | continue; |
8163 | } |
8164 | else if (n->u.depend_doacross_op == OMP_DEPEND_DEPOBJ |
8165 | && !n->expr |
8166 | && (n->sym->ts.type != BT_INTEGER |
8167 | || n->sym->ts.kind |
8168 | != 2 * gfc_index_integer_kind |
8169 | || n->sym->attr.dimension)) |
8170 | gfc_error ("Locator %qs at %L in DEPEND clause of depobj " |
8171 | "type shall be a scalar integer of " |
8172 | "OMP_DEPEND_KIND kind" , n->sym->name, |
8173 | &n->where); |
8174 | else if (n->u.depend_doacross_op == OMP_DEPEND_DEPOBJ |
8175 | && n->expr |
8176 | && (!gfc_resolve_expr (n->expr) |
8177 | || n->expr->ts.type != BT_INTEGER |
8178 | || n->expr->ts.kind |
8179 | != 2 * gfc_index_integer_kind |
8180 | || n->expr->rank != 0)) |
8181 | gfc_error ("Locator at %L in DEPEND clause of depobj " |
8182 | "type shall be a scalar integer of " |
8183 | "OMP_DEPEND_KIND kind" , &n->expr->where); |
8184 | } |
8185 | gfc_ref *lastref = NULL, *lastslice = NULL; |
8186 | bool resolved = false; |
8187 | if (n->expr) |
8188 | { |
8189 | lastref = n->expr->ref; |
8190 | resolved = gfc_resolve_expr (n->expr); |
8191 | |
8192 | /* Look through component refs to find last array |
8193 | reference. */ |
8194 | if (resolved) |
8195 | { |
8196 | for (gfc_ref *ref = n->expr->ref; ref; ref = ref->next) |
8197 | if (ref->type == REF_COMPONENT |
8198 | || ref->type == REF_SUBSTRING |
8199 | || ref->type == REF_INQUIRY) |
8200 | lastref = ref; |
8201 | else if (ref->type == REF_ARRAY) |
8202 | { |
8203 | for (int i = 0; i < ref->u.ar.dimen; i++) |
8204 | if (ref->u.ar.dimen_type[i] == DIMEN_RANGE) |
8205 | lastslice = ref; |
8206 | |
8207 | lastref = ref; |
8208 | } |
8209 | |
8210 | /* The "!$acc cache" directive allows rectangular |
8211 | subarrays to be specified, with some restrictions |
8212 | on the form of bounds (not implemented). |
8213 | Only raise an error here if we're really sure the |
8214 | array isn't contiguous. An expression such as |
8215 | arr(-n:n,-n:n) could be contiguous even if it looks |
8216 | like it may not be. */ |
8217 | if (code->op != EXEC_OACC_UPDATE |
8218 | && list != OMP_LIST_CACHE |
8219 | && list != OMP_LIST_DEPEND |
8220 | && !gfc_is_simply_contiguous (n->expr, false, true) |
8221 | && gfc_is_not_contiguous (n->expr) |
8222 | && !(lastslice |
8223 | && (lastslice->next |
8224 | || lastslice->type != REF_ARRAY))) |
8225 | gfc_error ("Array is not contiguous at %L" , |
8226 | &n->where); |
8227 | } |
8228 | } |
8229 | if (openacc |
8230 | && list == OMP_LIST_MAP |
8231 | && (n->u.map_op == OMP_MAP_ATTACH |
8232 | || n->u.map_op == OMP_MAP_DETACH)) |
8233 | { |
8234 | symbol_attribute attr; |
8235 | if (n->expr) |
8236 | attr = gfc_expr_attr (n->expr); |
8237 | else |
8238 | attr = n->sym->attr; |
8239 | if (!attr.pointer && !attr.allocatable) |
8240 | gfc_error ("%qs clause argument must be ALLOCATABLE or " |
8241 | "a POINTER at %L" , |
8242 | (n->u.map_op == OMP_MAP_ATTACH) ? "attach" |
8243 | : "detach" , &n->where); |
8244 | } |
8245 | if (lastref |
8246 | || (n->expr |
8247 | && (!resolved || n->expr->expr_type != EXPR_VARIABLE))) |
8248 | { |
8249 | if (!lastslice |
8250 | && lastref |
8251 | && lastref->type == REF_SUBSTRING) |
8252 | gfc_error ("Unexpected substring reference in %s clause " |
8253 | "at %L" , name, &n->where); |
8254 | else if (!lastslice |
8255 | && lastref |
8256 | && lastref->type == REF_INQUIRY) |
8257 | { |
8258 | gcc_assert (lastref->u.i == INQUIRY_RE |
8259 | || lastref->u.i == INQUIRY_IM); |
8260 | gfc_error ("Unexpected complex-parts designator " |
8261 | "reference in %s clause at %L" , |
8262 | name, &n->where); |
8263 | } |
8264 | else if (!resolved |
8265 | || n->expr->expr_type != EXPR_VARIABLE |
8266 | || (lastslice |
8267 | && (lastslice->next |
8268 | || lastslice->type != REF_ARRAY))) |
8269 | gfc_error ("%qs in %s clause at %L is not a proper " |
8270 | "array section" , n->sym->name, name, |
8271 | &n->where); |
8272 | else if (lastslice) |
8273 | { |
8274 | int i; |
8275 | gfc_array_ref *ar = &lastslice->u.ar; |
8276 | for (i = 0; i < ar->dimen; i++) |
8277 | if (ar->stride[i] && code->op != EXEC_OACC_UPDATE) |
8278 | { |
8279 | gfc_error ("Stride should not be specified for " |
8280 | "array section in %s clause at %L" , |
8281 | name, &n->where); |
8282 | break; |
8283 | } |
8284 | else if (ar->dimen_type[i] != DIMEN_ELEMENT |
8285 | && ar->dimen_type[i] != DIMEN_RANGE) |
8286 | { |
8287 | gfc_error ("%qs in %s clause at %L is not a " |
8288 | "proper array section" , |
8289 | n->sym->name, name, &n->where); |
8290 | break; |
8291 | } |
8292 | else if ((list == OMP_LIST_DEPEND |
8293 | || list == OMP_LIST_AFFINITY) |
8294 | && ar->start[i] |
8295 | && ar->start[i]->expr_type == EXPR_CONSTANT |
8296 | && ar->end[i] |
8297 | && ar->end[i]->expr_type == EXPR_CONSTANT |
8298 | && mpz_cmp (ar->start[i]->value.integer, |
8299 | ar->end[i]->value.integer) > 0) |
8300 | { |
8301 | gfc_error ("%qs in %s clause at %L is a " |
8302 | "zero size array section" , |
8303 | n->sym->name, |
8304 | list == OMP_LIST_DEPEND |
8305 | ? "DEPEND" : "AFFINITY" , &n->where); |
8306 | break; |
8307 | } |
8308 | } |
8309 | } |
8310 | else if (openacc) |
8311 | { |
8312 | if (list == OMP_LIST_MAP |
8313 | && n->u.map_op == OMP_MAP_FORCE_DEVICEPTR) |
8314 | resolve_oacc_deviceptr_clause (sym: n->sym, loc: n->where, name); |
8315 | else |
8316 | resolve_oacc_data_clauses (sym: n->sym, loc: n->where, name); |
8317 | } |
8318 | else if (list != OMP_LIST_DEPEND |
8319 | && n->sym->as |
8320 | && n->sym->as->type == AS_ASSUMED_SIZE) |
8321 | gfc_error ("Assumed size array %qs in %s clause at %L" , |
8322 | n->sym->name, name, &n->where); |
8323 | if (!openacc |
8324 | && list == OMP_LIST_MAP |
8325 | && n->sym->ts.type == BT_DERIVED |
8326 | && n->sym->ts.u.derived->attr.alloc_comp) |
8327 | gfc_error ("List item %qs with allocatable components is not " |
8328 | "permitted in map clause at %L" , n->sym->name, |
8329 | &n->where); |
8330 | if (list == OMP_LIST_MAP && !openacc) |
8331 | switch (code->op) |
8332 | { |
8333 | case EXEC_OMP_TARGET: |
8334 | case EXEC_OMP_TARGET_DATA: |
8335 | switch (n->u.map_op) |
8336 | { |
8337 | case OMP_MAP_TO: |
8338 | case OMP_MAP_ALWAYS_TO: |
8339 | case OMP_MAP_PRESENT_TO: |
8340 | case OMP_MAP_ALWAYS_PRESENT_TO: |
8341 | case OMP_MAP_FROM: |
8342 | case OMP_MAP_ALWAYS_FROM: |
8343 | case OMP_MAP_PRESENT_FROM: |
8344 | case OMP_MAP_ALWAYS_PRESENT_FROM: |
8345 | case OMP_MAP_TOFROM: |
8346 | case OMP_MAP_ALWAYS_TOFROM: |
8347 | case OMP_MAP_PRESENT_TOFROM: |
8348 | case OMP_MAP_ALWAYS_PRESENT_TOFROM: |
8349 | case OMP_MAP_ALLOC: |
8350 | case OMP_MAP_PRESENT_ALLOC: |
8351 | break; |
8352 | default: |
8353 | gfc_error ("TARGET%s with map-type other than TO, " |
8354 | "FROM, TOFROM, or ALLOC on MAP clause " |
8355 | "at %L" , |
8356 | code->op == EXEC_OMP_TARGET |
8357 | ? "" : " DATA" , &n->where); |
8358 | break; |
8359 | } |
8360 | break; |
8361 | case EXEC_OMP_TARGET_ENTER_DATA: |
8362 | switch (n->u.map_op) |
8363 | { |
8364 | case OMP_MAP_TO: |
8365 | case OMP_MAP_ALWAYS_TO: |
8366 | case OMP_MAP_PRESENT_TO: |
8367 | case OMP_MAP_ALWAYS_PRESENT_TO: |
8368 | case OMP_MAP_ALLOC: |
8369 | case OMP_MAP_PRESENT_ALLOC: |
8370 | break; |
8371 | case OMP_MAP_TOFROM: |
8372 | n->u.map_op = OMP_MAP_TO; |
8373 | break; |
8374 | case OMP_MAP_ALWAYS_TOFROM: |
8375 | n->u.map_op = OMP_MAP_ALWAYS_TO; |
8376 | break; |
8377 | case OMP_MAP_PRESENT_TOFROM: |
8378 | n->u.map_op = OMP_MAP_PRESENT_TO; |
8379 | break; |
8380 | case OMP_MAP_ALWAYS_PRESENT_TOFROM: |
8381 | n->u.map_op = OMP_MAP_ALWAYS_PRESENT_TO; |
8382 | break; |
8383 | default: |
8384 | gfc_error ("TARGET ENTER DATA with map-type other " |
8385 | "than TO, TOFROM or ALLOC on MAP clause " |
8386 | "at %L" , &n->where); |
8387 | break; |
8388 | } |
8389 | break; |
8390 | case EXEC_OMP_TARGET_EXIT_DATA: |
8391 | switch (n->u.map_op) |
8392 | { |
8393 | case OMP_MAP_FROM: |
8394 | case OMP_MAP_ALWAYS_FROM: |
8395 | case OMP_MAP_PRESENT_FROM: |
8396 | case OMP_MAP_ALWAYS_PRESENT_FROM: |
8397 | case OMP_MAP_RELEASE: |
8398 | case OMP_MAP_DELETE: |
8399 | break; |
8400 | case OMP_MAP_TOFROM: |
8401 | n->u.map_op = OMP_MAP_FROM; |
8402 | break; |
8403 | case OMP_MAP_ALWAYS_TOFROM: |
8404 | n->u.map_op = OMP_MAP_ALWAYS_FROM; |
8405 | break; |
8406 | case OMP_MAP_PRESENT_TOFROM: |
8407 | n->u.map_op = OMP_MAP_PRESENT_FROM; |
8408 | break; |
8409 | case OMP_MAP_ALWAYS_PRESENT_TOFROM: |
8410 | n->u.map_op = OMP_MAP_ALWAYS_PRESENT_FROM; |
8411 | break; |
8412 | default: |
8413 | gfc_error ("TARGET EXIT DATA with map-type other " |
8414 | "than FROM, TOFROM, RELEASE, or DELETE on " |
8415 | "MAP clause at %L" , &n->where); |
8416 | break; |
8417 | } |
8418 | break; |
8419 | default: |
8420 | break; |
8421 | } |
8422 | } |
8423 | |
8424 | if (list != OMP_LIST_DEPEND) |
8425 | for (n = omp_clauses->lists[list]; n != NULL; n = n->next) |
8426 | { |
8427 | n->sym->attr.referenced = 1; |
8428 | if (n->sym->attr.threadprivate) |
8429 | gfc_error ("THREADPRIVATE object %qs in %s clause at %L" , |
8430 | n->sym->name, name, &n->where); |
8431 | if (n->sym->attr.cray_pointee) |
8432 | gfc_error ("Cray pointee %qs in %s clause at %L" , |
8433 | n->sym->name, name, &n->where); |
8434 | } |
8435 | break; |
8436 | case OMP_LIST_IS_DEVICE_PTR: |
8437 | last = NULL; |
8438 | for (n = omp_clauses->lists[list]; n != NULL; ) |
8439 | { |
8440 | if (n->sym->ts.type == BT_DERIVED |
8441 | && n->sym->ts.u.derived->ts.is_iso_c |
8442 | && code->op != EXEC_OMP_TARGET) |
8443 | /* Non-TARGET (i.e. DISPATCH) requires a C_PTR. */ |
8444 | gfc_error ("List item %qs in %s clause at %L must be of " |
8445 | "TYPE(C_PTR)" , n->sym->name, name, &n->where); |
8446 | else if (n->sym->ts.type != BT_DERIVED |
8447 | || !n->sym->ts.u.derived->ts.is_iso_c) |
8448 | { |
8449 | /* For TARGET, non-C_PTR are deprecated and handled as |
8450 | has_device_addr. */ |
8451 | gfc_omp_namelist *n2 = n; |
8452 | n = n->next; |
8453 | if (last) |
8454 | last->next = n; |
8455 | else |
8456 | omp_clauses->lists[list] = n; |
8457 | n2->next = omp_clauses->lists[OMP_LIST_HAS_DEVICE_ADDR]; |
8458 | omp_clauses->lists[OMP_LIST_HAS_DEVICE_ADDR] = n2; |
8459 | continue; |
8460 | } |
8461 | last = n; |
8462 | n = n->next; |
8463 | } |
8464 | break; |
8465 | case OMP_LIST_HAS_DEVICE_ADDR: |
8466 | case OMP_LIST_USE_DEVICE_ADDR: |
8467 | break; |
8468 | case OMP_LIST_USE_DEVICE_PTR: |
8469 | /* Non-C_PTR are deprecated and handled as use_device_ADDR. */ |
8470 | last = NULL; |
8471 | for (n = omp_clauses->lists[list]; n != NULL; ) |
8472 | { |
8473 | gfc_omp_namelist *n2 = n; |
8474 | if (n->sym->ts.type != BT_DERIVED |
8475 | || !n->sym->ts.u.derived->ts.is_iso_c) |
8476 | { |
8477 | n = n->next; |
8478 | if (last) |
8479 | last->next = n; |
8480 | else |
8481 | omp_clauses->lists[list] = n; |
8482 | n2->next = omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR]; |
8483 | omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR] = n2; |
8484 | continue; |
8485 | } |
8486 | last = n; |
8487 | n = n->next; |
8488 | } |
8489 | break; |
8490 | case OMP_LIST_USES_ALLOCATORS: |
8491 | { |
8492 | if (n != NULL |
8493 | && n->u.memspace_sym |
8494 | && (n->u.memspace_sym->attr.flavor != FL_PARAMETER |
8495 | || n->u.memspace_sym->ts.type != BT_INTEGER |
8496 | || n->u.memspace_sym->ts.kind != gfc_c_intptr_kind |
8497 | || n->u.memspace_sym->attr.dimension |
8498 | || (!startswith (str: n->u.memspace_sym->name, prefix: "omp_" ) |
8499 | && !startswith (str: n->u.memspace_sym->name, prefix: "ompx_" )) |
8500 | || !endswith (str: n->u.memspace_sym->name, suffix: "_mem_space" ))) |
8501 | gfc_error ("Memspace %qs at %L in USES_ALLOCATORS must be " |
8502 | "a predefined memory space" , |
8503 | n->u.memspace_sym->name, &n->where); |
8504 | for (; n != NULL; n = n->next) |
8505 | { |
8506 | if (n->sym->ts.type != BT_INTEGER |
8507 | || n->sym->ts.kind != gfc_c_intptr_kind |
8508 | || n->sym->attr.dimension) |
8509 | gfc_error ("Allocator %qs at %L in USES_ALLOCATORS must " |
8510 | "be a scalar integer of kind " |
8511 | "%<omp_allocator_handle_kind%>" , n->sym->name, |
8512 | &n->where); |
8513 | else if (n->sym->attr.flavor != FL_VARIABLE |
8514 | && ((!startswith (str: n->sym->name, prefix: "omp_" ) |
8515 | && !startswith (str: n->sym->name, prefix: "ompx_" )) |
8516 | || !endswith (str: n->sym->name, suffix: "_mem_alloc" ))) |
8517 | gfc_error ("Allocator %qs at %L in USES_ALLOCATORS must " |
8518 | "either a variable or a predefined allocator" , |
8519 | n->sym->name, &n->where); |
8520 | else if ((n->u.memspace_sym || n->u2.traits_sym) |
8521 | && n->sym->attr.flavor != FL_VARIABLE) |
8522 | gfc_error ("A memory space or traits array may not be " |
8523 | "specified for predefined allocator %qs at %L" , |
8524 | n->sym->name, &n->where); |
8525 | if (n->u2.traits_sym |
8526 | && (n->u2.traits_sym->attr.flavor != FL_PARAMETER |
8527 | || !n->u2.traits_sym->attr.dimension |
8528 | || n->u2.traits_sym->as->rank != 1 |
8529 | || n->u2.traits_sym->ts.type != BT_DERIVED |
8530 | || strcmp (s1: n->u2.traits_sym->ts.u.derived->name, |
8531 | s2: "omp_alloctrait" ) != 0)) |
8532 | { |
8533 | gfc_error ("Traits array %qs in USES_ALLOCATORS %L must " |
8534 | "be a one-dimensional named constant array of " |
8535 | "type %<omp_alloctrait%>" , |
8536 | n->u2.traits_sym->name, &n->where); |
8537 | break; |
8538 | } |
8539 | } |
8540 | break; |
8541 | } |
8542 | default: |
8543 | for (; n != NULL; n = n->next) |
8544 | { |
8545 | if (n->sym == NULL) |
8546 | { |
8547 | gcc_assert (code->op == EXEC_OMP_ALLOCATORS |
8548 | || code->op == EXEC_OMP_ALLOCATE); |
8549 | continue; |
8550 | } |
8551 | bool bad = false; |
8552 | bool is_reduction = (list == OMP_LIST_REDUCTION |
8553 | || list == OMP_LIST_REDUCTION_INSCAN |
8554 | || list == OMP_LIST_REDUCTION_TASK |
8555 | || list == OMP_LIST_IN_REDUCTION |
8556 | || list == OMP_LIST_TASK_REDUCTION); |
8557 | if (list == OMP_LIST_REDUCTION_INSCAN) |
8558 | has_inscan = true; |
8559 | else if (is_reduction) |
8560 | has_notinscan = true; |
8561 | if (has_inscan && has_notinscan && is_reduction) |
8562 | { |
8563 | gfc_error ("%<inscan%> and non-%<inscan%> %<reduction%> " |
8564 | "clauses on the same construct at %L" , |
8565 | &n->where); |
8566 | break; |
8567 | } |
8568 | if (n->sym->attr.threadprivate) |
8569 | gfc_error ("THREADPRIVATE object %qs in %s clause at %L" , |
8570 | n->sym->name, name, &n->where); |
8571 | if (n->sym->attr.cray_pointee) |
8572 | gfc_error ("Cray pointee %qs in %s clause at %L" , |
8573 | n->sym->name, name, &n->where); |
8574 | if (n->sym->attr.associate_var) |
8575 | gfc_error ("Associate name %qs in %s clause at %L" , |
8576 | n->sym->attr.select_type_temporary |
8577 | ? n->sym->assoc->target->symtree->n.sym->name |
8578 | : n->sym->name, name, &n->where); |
8579 | if (list != OMP_LIST_PRIVATE && is_reduction) |
8580 | { |
8581 | if (n->sym->attr.proc_pointer) |
8582 | gfc_error ("Procedure pointer %qs in %s clause at %L" , |
8583 | n->sym->name, name, &n->where); |
8584 | if (n->sym->attr.pointer) |
8585 | gfc_error ("POINTER object %qs in %s clause at %L" , |
8586 | n->sym->name, name, &n->where); |
8587 | if (n->sym->attr.cray_pointer) |
8588 | gfc_error ("Cray pointer %qs in %s clause at %L" , |
8589 | n->sym->name, name, &n->where); |
8590 | } |
8591 | if (code |
8592 | && (oacc_is_loop (code) |
8593 | || code->op == EXEC_OACC_PARALLEL |
8594 | || code->op == EXEC_OACC_SERIAL)) |
8595 | check_array_not_assumed (sym: n->sym, loc: n->where, name); |
8596 | else if (list != OMP_LIST_UNIFORM |
8597 | && n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE) |
8598 | gfc_error ("Assumed size array %qs in %s clause at %L" , |
8599 | n->sym->name, name, &n->where); |
8600 | if (n->sym->attr.in_namelist && !is_reduction) |
8601 | gfc_error ("Variable %qs in %s clause is used in " |
8602 | "NAMELIST statement at %L" , |
8603 | n->sym->name, name, &n->where); |
8604 | if (n->sym->attr.pointer && n->sym->attr.intent == INTENT_IN) |
8605 | switch (list) |
8606 | { |
8607 | case OMP_LIST_PRIVATE: |
8608 | case OMP_LIST_LASTPRIVATE: |
8609 | case OMP_LIST_LINEAR: |
8610 | /* case OMP_LIST_REDUCTION: */ |
8611 | gfc_error ("INTENT(IN) POINTER %qs in %s clause at %L" , |
8612 | n->sym->name, name, &n->where); |
8613 | break; |
8614 | default: |
8615 | break; |
8616 | } |
8617 | if (omp_clauses->detach |
8618 | && (list == OMP_LIST_PRIVATE |
8619 | || list == OMP_LIST_FIRSTPRIVATE |
8620 | || list == OMP_LIST_LASTPRIVATE) |
8621 | && n->sym == omp_clauses->detach->symtree->n.sym) |
8622 | gfc_error ("DETACH event handle %qs in %s clause at %L" , |
8623 | n->sym->name, name, &n->where); |
8624 | switch (list) |
8625 | { |
8626 | case OMP_LIST_REDUCTION_TASK: |
8627 | if (code |
8628 | && (code->op == EXEC_OMP_LOOP |
8629 | || code->op == EXEC_OMP_TASKLOOP |
8630 | || code->op == EXEC_OMP_TASKLOOP_SIMD |
8631 | || code->op == EXEC_OMP_MASKED_TASKLOOP |
8632 | || code->op == EXEC_OMP_MASKED_TASKLOOP_SIMD |
8633 | || code->op == EXEC_OMP_MASTER_TASKLOOP |
8634 | || code->op == EXEC_OMP_MASTER_TASKLOOP_SIMD |
8635 | || code->op == EXEC_OMP_PARALLEL_LOOP |
8636 | || code->op == EXEC_OMP_PARALLEL_MASKED_TASKLOOP |
8637 | || code->op == EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD |
8638 | || code->op == EXEC_OMP_PARALLEL_MASTER_TASKLOOP |
8639 | || code->op == EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD |
8640 | || code->op == EXEC_OMP_TARGET_PARALLEL_LOOP |
8641 | || code->op == EXEC_OMP_TARGET_TEAMS_LOOP |
8642 | || code->op == EXEC_OMP_TEAMS |
8643 | || code->op == EXEC_OMP_TEAMS_DISTRIBUTE |
8644 | || code->op == EXEC_OMP_TEAMS_LOOP)) |
8645 | { |
8646 | gfc_error ("Only DEFAULT permitted as reduction-" |
8647 | "modifier in REDUCTION clause at %L" , |
8648 | &n->where); |
8649 | break; |
8650 | } |
8651 | gcc_fallthrough (); |
8652 | case OMP_LIST_REDUCTION: |
8653 | case OMP_LIST_IN_REDUCTION: |
8654 | case OMP_LIST_TASK_REDUCTION: |
8655 | case OMP_LIST_REDUCTION_INSCAN: |
8656 | switch (n->u.reduction_op) |
8657 | { |
8658 | case OMP_REDUCTION_PLUS: |
8659 | case OMP_REDUCTION_TIMES: |
8660 | case OMP_REDUCTION_MINUS: |
8661 | if (!gfc_numeric_ts (&n->sym->ts)) |
8662 | bad = true; |
8663 | break; |
8664 | case OMP_REDUCTION_AND: |
8665 | case OMP_REDUCTION_OR: |
8666 | case OMP_REDUCTION_EQV: |
8667 | case OMP_REDUCTION_NEQV: |
8668 | if (n->sym->ts.type != BT_LOGICAL) |
8669 | bad = true; |
8670 | break; |
8671 | case OMP_REDUCTION_MAX: |
8672 | case OMP_REDUCTION_MIN: |
8673 | if (n->sym->ts.type != BT_INTEGER |
8674 | && n->sym->ts.type != BT_REAL) |
8675 | bad = true; |
8676 | break; |
8677 | case OMP_REDUCTION_IAND: |
8678 | case OMP_REDUCTION_IOR: |
8679 | case OMP_REDUCTION_IEOR: |
8680 | if (n->sym->ts.type != BT_INTEGER) |
8681 | bad = true; |
8682 | break; |
8683 | case OMP_REDUCTION_USER: |
8684 | bad = true; |
8685 | break; |
8686 | default: |
8687 | break; |
8688 | } |
8689 | if (!bad) |
8690 | n->u2.udr = NULL; |
8691 | else |
8692 | { |
8693 | const char *udr_name = NULL; |
8694 | if (n->u2.udr) |
8695 | { |
8696 | udr_name = n->u2.udr->udr->name; |
8697 | n->u2.udr->udr |
8698 | = gfc_find_omp_udr (NULL, name: udr_name, |
8699 | ts: &n->sym->ts); |
8700 | if (n->u2.udr->udr == NULL) |
8701 | { |
8702 | free (ptr: n->u2.udr); |
8703 | n->u2.udr = NULL; |
8704 | } |
8705 | } |
8706 | if (n->u2.udr == NULL) |
8707 | { |
8708 | if (udr_name == NULL) |
8709 | switch (n->u.reduction_op) |
8710 | { |
8711 | case OMP_REDUCTION_PLUS: |
8712 | case OMP_REDUCTION_TIMES: |
8713 | case OMP_REDUCTION_MINUS: |
8714 | case OMP_REDUCTION_AND: |
8715 | case OMP_REDUCTION_OR: |
8716 | case OMP_REDUCTION_EQV: |
8717 | case OMP_REDUCTION_NEQV: |
8718 | udr_name = gfc_op2string ((gfc_intrinsic_op) |
8719 | n->u.reduction_op); |
8720 | break; |
8721 | case OMP_REDUCTION_MAX: |
8722 | udr_name = "max" ; |
8723 | break; |
8724 | case OMP_REDUCTION_MIN: |
8725 | udr_name = "min" ; |
8726 | break; |
8727 | case OMP_REDUCTION_IAND: |
8728 | udr_name = "iand" ; |
8729 | break; |
8730 | case OMP_REDUCTION_IOR: |
8731 | udr_name = "ior" ; |
8732 | break; |
8733 | case OMP_REDUCTION_IEOR: |
8734 | udr_name = "ieor" ; |
8735 | break; |
8736 | default: |
8737 | gcc_unreachable (); |
8738 | } |
8739 | gfc_error ("!$OMP DECLARE REDUCTION %s not found " |
8740 | "for type %s at %L" , udr_name, |
8741 | gfc_typename (&n->sym->ts), &n->where); |
8742 | } |
8743 | else |
8744 | { |
8745 | gfc_omp_udr *udr = n->u2.udr->udr; |
8746 | n->u.reduction_op = OMP_REDUCTION_USER; |
8747 | n->u2.udr->combiner |
8748 | = resolve_omp_udr_clause (n, ns: udr->combiner_ns, |
8749 | sym1: udr->omp_out, |
8750 | sym2: udr->omp_in); |
8751 | if (udr->initializer_ns) |
8752 | n->u2.udr->initializer |
8753 | = resolve_omp_udr_clause (n, |
8754 | ns: udr->initializer_ns, |
8755 | sym1: udr->omp_priv, |
8756 | sym2: udr->omp_orig); |
8757 | } |
8758 | } |
8759 | break; |
8760 | case OMP_LIST_LINEAR: |
8761 | if (code |
8762 | && n->u.linear.op != OMP_LINEAR_DEFAULT |
8763 | && n->u.linear.op != linear_op) |
8764 | { |
8765 | if (n->u.linear.old_modifier) |
8766 | { |
8767 | gfc_error ("LINEAR clause modifier used on DO or " |
8768 | "SIMD construct at %L" , &n->where); |
8769 | linear_op = n->u.linear.op; |
8770 | } |
8771 | else if (n->u.linear.op != OMP_LINEAR_VAL) |
8772 | { |
8773 | gfc_error ("LINEAR clause modifier other than VAL " |
8774 | "used on DO or SIMD construct at %L" , |
8775 | &n->where); |
8776 | linear_op = n->u.linear.op; |
8777 | } |
8778 | } |
8779 | else if (n->u.linear.op != OMP_LINEAR_REF |
8780 | && n->sym->ts.type != BT_INTEGER) |
8781 | gfc_error ("LINEAR variable %qs must be INTEGER " |
8782 | "at %L" , n->sym->name, &n->where); |
8783 | else if ((n->u.linear.op == OMP_LINEAR_REF |
8784 | || n->u.linear.op == OMP_LINEAR_UVAL) |
8785 | && n->sym->attr.value) |
8786 | gfc_error ("LINEAR dummy argument %qs with VALUE " |
8787 | "attribute with %s modifier at %L" , |
8788 | n->sym->name, |
8789 | n->u.linear.op == OMP_LINEAR_REF |
8790 | ? "REF" : "UVAL" , &n->where); |
8791 | else if (n->expr) |
8792 | { |
8793 | gfc_expr *expr = n->expr; |
8794 | if (!gfc_resolve_expr (expr) |
8795 | || expr->ts.type != BT_INTEGER |
8796 | || expr->rank != 0) |
8797 | gfc_error ("%qs in LINEAR clause at %L requires " |
8798 | "a scalar integer linear-step expression" , |
8799 | n->sym->name, &n->where); |
8800 | else if (!code && expr->expr_type != EXPR_CONSTANT) |
8801 | { |
8802 | if (expr->expr_type == EXPR_VARIABLE |
8803 | && expr->symtree->n.sym->attr.dummy |
8804 | && expr->symtree->n.sym->ns == ns) |
8805 | { |
8806 | gfc_omp_namelist *n2; |
8807 | for (n2 = omp_clauses->lists[OMP_LIST_UNIFORM]; |
8808 | n2; n2 = n2->next) |
8809 | if (n2->sym == expr->symtree->n.sym) |
8810 | break; |
8811 | if (n2) |
8812 | break; |
8813 | } |
8814 | gfc_error ("%qs in LINEAR clause at %L requires " |
8815 | "a constant integer linear-step " |
8816 | "expression or dummy argument " |
8817 | "specified in UNIFORM clause" , |
8818 | n->sym->name, &n->where); |
8819 | } |
8820 | } |
8821 | break; |
8822 | /* Workaround for PR middle-end/26316, nothing really needs |
8823 | to be done here for OMP_LIST_PRIVATE. */ |
8824 | case OMP_LIST_PRIVATE: |
8825 | gcc_assert (code && code->op != EXEC_NOP); |
8826 | break; |
8827 | case OMP_LIST_USE_DEVICE: |
8828 | if (n->sym->attr.allocatable |
8829 | || (n->sym->ts.type == BT_CLASS && CLASS_DATA (n->sym) |
8830 | && CLASS_DATA (n->sym)->attr.allocatable)) |
8831 | gfc_error ("ALLOCATABLE object %qs in %s clause at %L" , |
8832 | n->sym->name, name, &n->where); |
8833 | if (n->sym->ts.type == BT_CLASS |
8834 | && CLASS_DATA (n->sym) |
8835 | && CLASS_DATA (n->sym)->attr.class_pointer) |
8836 | gfc_error ("POINTER object %qs of polymorphic type in " |
8837 | "%s clause at %L" , n->sym->name, name, |
8838 | &n->where); |
8839 | if (n->sym->attr.cray_pointer) |
8840 | gfc_error ("Cray pointer object %qs in %s clause at %L" , |
8841 | n->sym->name, name, &n->where); |
8842 | else if (n->sym->attr.cray_pointee) |
8843 | gfc_error ("Cray pointee object %qs in %s clause at %L" , |
8844 | n->sym->name, name, &n->where); |
8845 | else if (n->sym->attr.flavor == FL_VARIABLE |
8846 | && !n->sym->as |
8847 | && !n->sym->attr.pointer) |
8848 | gfc_error ("%s clause variable %qs at %L is neither " |
8849 | "a POINTER nor an array" , name, |
8850 | n->sym->name, &n->where); |
8851 | /* FALLTHRU */ |
8852 | case OMP_LIST_DEVICE_RESIDENT: |
8853 | check_symbol_not_pointer (sym: n->sym, loc: n->where, name); |
8854 | check_array_not_assumed (sym: n->sym, loc: n->where, name); |
8855 | break; |
8856 | default: |
8857 | break; |
8858 | } |
8859 | } |
8860 | break; |
8861 | } |
8862 | } |
8863 | /* OpenMP 5.1: use_device_ptr acts like use_device_addr, except for |
8864 | type(c_ptr). */ |
8865 | if (omp_clauses->lists[OMP_LIST_USE_DEVICE_PTR]) |
8866 | { |
8867 | gfc_omp_namelist *n_prev, *n_next, *n_addr; |
8868 | n_addr = omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR]; |
8869 | for (; n_addr && n_addr->next; n_addr = n_addr->next) |
8870 | ; |
8871 | n_prev = NULL; |
8872 | n = omp_clauses->lists[OMP_LIST_USE_DEVICE_PTR]; |
8873 | while (n) |
8874 | { |
8875 | n_next = n->next; |
8876 | if (n->sym->ts.type != BT_DERIVED |
8877 | || n->sym->ts.u.derived->ts.f90_type != BT_VOID) |
8878 | { |
8879 | n->next = NULL; |
8880 | if (n_addr) |
8881 | n_addr->next = n; |
8882 | else |
8883 | omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR] = n; |
8884 | n_addr = n; |
8885 | if (n_prev) |
8886 | n_prev->next = n_next; |
8887 | else |
8888 | omp_clauses->lists[OMP_LIST_USE_DEVICE_PTR] = n_next; |
8889 | } |
8890 | else |
8891 | n_prev = n; |
8892 | n = n_next; |
8893 | } |
8894 | } |
8895 | if (omp_clauses->safelen_expr) |
8896 | resolve_positive_int_expr (expr: omp_clauses->safelen_expr, clause: "SAFELEN" ); |
8897 | if (omp_clauses->simdlen_expr) |
8898 | resolve_positive_int_expr (expr: omp_clauses->simdlen_expr, clause: "SIMDLEN" ); |
8899 | if (omp_clauses->num_teams_lower) |
8900 | resolve_positive_int_expr (expr: omp_clauses->num_teams_lower, clause: "NUM_TEAMS" ); |
8901 | if (omp_clauses->num_teams_upper) |
8902 | resolve_positive_int_expr (expr: omp_clauses->num_teams_upper, clause: "NUM_TEAMS" ); |
8903 | if (omp_clauses->num_teams_lower |
8904 | && omp_clauses->num_teams_lower->expr_type == EXPR_CONSTANT |
8905 | && omp_clauses->num_teams_upper->expr_type == EXPR_CONSTANT |
8906 | && mpz_cmp (omp_clauses->num_teams_lower->value.integer, |
8907 | omp_clauses->num_teams_upper->value.integer) > 0) |
8908 | gfc_warning (opt: 0, "NUM_TEAMS lower bound at %L larger than upper bound at %L" , |
8909 | &omp_clauses->num_teams_lower->where, |
8910 | &omp_clauses->num_teams_upper->where); |
8911 | if (omp_clauses->device) |
8912 | resolve_scalar_int_expr (expr: omp_clauses->device, clause: "DEVICE" ); |
8913 | if (omp_clauses->filter) |
8914 | resolve_nonnegative_int_expr (expr: omp_clauses->filter, clause: "FILTER" ); |
8915 | if (omp_clauses->hint) |
8916 | { |
8917 | resolve_scalar_int_expr (expr: omp_clauses->hint, clause: "HINT" ); |
8918 | if (omp_clauses->hint->ts.type != BT_INTEGER |
8919 | || omp_clauses->hint->expr_type != EXPR_CONSTANT |
8920 | || mpz_sgn (omp_clauses->hint->value.integer) < 0) |
8921 | gfc_error ("Value of HINT clause at %L shall be a valid " |
8922 | "constant hint expression" , &omp_clauses->hint->where); |
8923 | } |
8924 | if (omp_clauses->priority) |
8925 | resolve_nonnegative_int_expr (expr: omp_clauses->priority, clause: "PRIORITY" ); |
8926 | if (omp_clauses->dist_chunk_size) |
8927 | { |
8928 | gfc_expr *expr = omp_clauses->dist_chunk_size; |
8929 | if (!gfc_resolve_expr (expr) |
8930 | || expr->ts.type != BT_INTEGER || expr->rank != 0) |
8931 | gfc_error ("DIST_SCHEDULE clause's chunk_size at %L requires " |
8932 | "a scalar INTEGER expression" , &expr->where); |
8933 | } |
8934 | if (omp_clauses->thread_limit) |
8935 | resolve_positive_int_expr (expr: omp_clauses->thread_limit, clause: "THREAD_LIMIT" ); |
8936 | if (omp_clauses->grainsize) |
8937 | resolve_positive_int_expr (expr: omp_clauses->grainsize, clause: "GRAINSIZE" ); |
8938 | if (omp_clauses->num_tasks) |
8939 | resolve_positive_int_expr (expr: omp_clauses->num_tasks, clause: "NUM_TASKS" ); |
8940 | if (omp_clauses->async) |
8941 | if (omp_clauses->async_expr) |
8942 | resolve_scalar_int_expr (expr: omp_clauses->async_expr, clause: "ASYNC" ); |
8943 | if (omp_clauses->num_gangs_expr) |
8944 | resolve_positive_int_expr (expr: omp_clauses->num_gangs_expr, clause: "NUM_GANGS" ); |
8945 | if (omp_clauses->num_workers_expr) |
8946 | resolve_positive_int_expr (expr: omp_clauses->num_workers_expr, clause: "NUM_WORKERS" ); |
8947 | if (omp_clauses->vector_length_expr) |
8948 | resolve_positive_int_expr (expr: omp_clauses->vector_length_expr, |
8949 | clause: "VECTOR_LENGTH" ); |
8950 | if (omp_clauses->gang_num_expr) |
8951 | resolve_positive_int_expr (expr: omp_clauses->gang_num_expr, clause: "GANG" ); |
8952 | if (omp_clauses->gang_static_expr) |
8953 | resolve_positive_int_expr (expr: omp_clauses->gang_static_expr, clause: "GANG" ); |
8954 | if (omp_clauses->worker_expr) |
8955 | resolve_positive_int_expr (expr: omp_clauses->worker_expr, clause: "WORKER" ); |
8956 | if (omp_clauses->vector_expr) |
8957 | resolve_positive_int_expr (expr: omp_clauses->vector_expr, clause: "VECTOR" ); |
8958 | for (el = omp_clauses->wait_list; el; el = el->next) |
8959 | resolve_scalar_int_expr (expr: el->expr, clause: "WAIT" ); |
8960 | if (omp_clauses->collapse && omp_clauses->tile_list) |
8961 | gfc_error ("Incompatible use of TILE and COLLAPSE at %L" , &code->loc); |
8962 | if (omp_clauses->message) |
8963 | { |
8964 | gfc_expr *expr = omp_clauses->message; |
8965 | if (!gfc_resolve_expr (expr) |
8966 | || expr->ts.kind != gfc_default_character_kind |
8967 | || expr->ts.type != BT_CHARACTER || expr->rank != 0) |
8968 | gfc_error ("MESSAGE clause at %L requires a scalar default-kind " |
8969 | "CHARACTER expression" , &expr->where); |
8970 | } |
8971 | if (!openacc |
8972 | && code |
8973 | && omp_clauses->lists[OMP_LIST_MAP] == NULL |
8974 | && omp_clauses->lists[OMP_LIST_USE_DEVICE_PTR] == NULL |
8975 | && omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR] == NULL) |
8976 | { |
8977 | const char *p = NULL; |
8978 | switch (code->op) |
8979 | { |
8980 | case EXEC_OMP_TARGET_ENTER_DATA: p = "TARGET ENTER DATA" ; break; |
8981 | case EXEC_OMP_TARGET_EXIT_DATA: p = "TARGET EXIT DATA" ; break; |
8982 | default: break; |
8983 | } |
8984 | if (code->op == EXEC_OMP_TARGET_DATA) |
8985 | gfc_error ("TARGET DATA must contain at least one MAP, USE_DEVICE_PTR, " |
8986 | "or USE_DEVICE_ADDR clause at %L" , &code->loc); |
8987 | else if (p) |
8988 | gfc_error ("%s must contain at least one MAP clause at %L" , |
8989 | p, &code->loc); |
8990 | } |
8991 | |
8992 | if (!openacc && omp_clauses->detach) |
8993 | { |
8994 | if (!gfc_resolve_expr (omp_clauses->detach) |
8995 | || omp_clauses->detach->ts.type != BT_INTEGER |
8996 | || omp_clauses->detach->ts.kind != gfc_c_intptr_kind |
8997 | || omp_clauses->detach->rank != 0) |
8998 | gfc_error ("%qs at %L should be a scalar of type " |
8999 | "integer(kind=omp_event_handle_kind)" , |
9000 | omp_clauses->detach->symtree->n.sym->name, |
9001 | &omp_clauses->detach->where); |
9002 | else if (omp_clauses->detach->symtree->n.sym->attr.dimension > 0) |
9003 | gfc_error ("The event handle at %L must not be an array element" , |
9004 | &omp_clauses->detach->where); |
9005 | else if (omp_clauses->detach->symtree->n.sym->ts.type == BT_DERIVED |
9006 | || omp_clauses->detach->symtree->n.sym->ts.type == BT_CLASS) |
9007 | gfc_error ("The event handle at %L must not be part of " |
9008 | "a derived type or class" , &omp_clauses->detach->where); |
9009 | |
9010 | if (omp_clauses->mergeable) |
9011 | gfc_error ("%<DETACH%> clause at %L must not be used together with " |
9012 | "%<MERGEABLE%> clause" , &omp_clauses->detach->where); |
9013 | } |
9014 | |
9015 | if (openacc |
9016 | && code->op == EXEC_OACC_HOST_DATA |
9017 | && omp_clauses->lists[OMP_LIST_USE_DEVICE] == NULL) |
9018 | gfc_error ("%<host_data%> construct at %L requires %<use_device%> clause" , |
9019 | &code->loc); |
9020 | |
9021 | if (omp_clauses->assume) |
9022 | gfc_resolve_omp_assumptions (assume: omp_clauses->assume); |
9023 | } |
9024 | |
9025 | |
9026 | /* Return true if SYM is ever referenced in EXPR except in the SE node. */ |
9027 | |
9028 | static bool |
9029 | expr_references_sym (gfc_expr *e, gfc_symbol *s, gfc_expr *se) |
9030 | { |
9031 | gfc_actual_arglist *arg; |
9032 | if (e == NULL || e == se) |
9033 | return false; |
9034 | switch (e->expr_type) |
9035 | { |
9036 | case EXPR_CONSTANT: |
9037 | case EXPR_NULL: |
9038 | case EXPR_VARIABLE: |
9039 | case EXPR_STRUCTURE: |
9040 | case EXPR_ARRAY: |
9041 | if (e->symtree != NULL |
9042 | && e->symtree->n.sym == s) |
9043 | return true; |
9044 | return false; |
9045 | case EXPR_SUBSTRING: |
9046 | if (e->ref != NULL |
9047 | && (expr_references_sym (e: e->ref->u.ss.start, s, se) |
9048 | || expr_references_sym (e: e->ref->u.ss.end, s, se))) |
9049 | return true; |
9050 | return false; |
9051 | case EXPR_OP: |
9052 | if (expr_references_sym (e: e->value.op.op2, s, se)) |
9053 | return true; |
9054 | return expr_references_sym (e: e->value.op.op1, s, se); |
9055 | case EXPR_FUNCTION: |
9056 | for (arg = e->value.function.actual; arg; arg = arg->next) |
9057 | if (expr_references_sym (e: arg->expr, s, se)) |
9058 | return true; |
9059 | return false; |
9060 | default: |
9061 | gcc_unreachable (); |
9062 | } |
9063 | } |
9064 | |
9065 | |
9066 | /* If EXPR is a conversion function that widens the type |
9067 | if WIDENING is true or narrows the type if NARROW is true, |
9068 | return the inner expression, otherwise return NULL. */ |
9069 | |
9070 | static gfc_expr * |
9071 | is_conversion (gfc_expr *expr, bool narrowing, bool widening) |
9072 | { |
9073 | gfc_typespec *ts1, *ts2; |
9074 | |
9075 | if (expr->expr_type != EXPR_FUNCTION |
9076 | || expr->value.function.isym == NULL |
9077 | || expr->value.function.esym != NULL |
9078 | || expr->value.function.isym->id != GFC_ISYM_CONVERSION |
9079 | || (!narrowing && !widening)) |
9080 | return NULL; |
9081 | |
9082 | if (narrowing && widening) |
9083 | return expr->value.function.actual->expr; |
9084 | |
9085 | if (widening) |
9086 | { |
9087 | ts1 = &expr->ts; |
9088 | ts2 = &expr->value.function.actual->expr->ts; |
9089 | } |
9090 | else |
9091 | { |
9092 | ts1 = &expr->value.function.actual->expr->ts; |
9093 | ts2 = &expr->ts; |
9094 | } |
9095 | |
9096 | if (ts1->type > ts2->type |
9097 | || (ts1->type == ts2->type && ts1->kind > ts2->kind)) |
9098 | return expr->value.function.actual->expr; |
9099 | |
9100 | return NULL; |
9101 | } |
9102 | |
9103 | static bool |
9104 | is_scalar_intrinsic_expr (gfc_expr *expr, bool must_be_var, bool conv_ok) |
9105 | { |
9106 | if (must_be_var |
9107 | && (expr->expr_type != EXPR_VARIABLE || !expr->symtree)) |
9108 | { |
9109 | if (!conv_ok) |
9110 | return false; |
9111 | gfc_expr *conv = is_conversion (expr, narrowing: true, widening: true); |
9112 | if (!conv) |
9113 | return false; |
9114 | if (conv->expr_type != EXPR_VARIABLE || !conv->symtree) |
9115 | return false; |
9116 | } |
9117 | return (expr->rank == 0 |
9118 | && !gfc_is_coindexed (expr) |
9119 | && (expr->ts.type == BT_INTEGER |
9120 | || expr->ts.type == BT_REAL |
9121 | || expr->ts.type == BT_COMPLEX |
9122 | || expr->ts.type == BT_LOGICAL)); |
9123 | } |
9124 | |
9125 | static void |
9126 | resolve_omp_atomic (gfc_code *code) |
9127 | { |
9128 | gfc_code *atomic_code = code->block; |
9129 | gfc_symbol *var; |
9130 | gfc_expr *stmt_expr2, *capt_expr2; |
9131 | gfc_omp_atomic_op aop |
9132 | = (gfc_omp_atomic_op) (atomic_code->ext.omp_clauses->atomic_op |
9133 | & GFC_OMP_ATOMIC_MASK); |
9134 | gfc_code *stmt = NULL, *capture_stmt = NULL, *tailing_stmt = NULL; |
9135 | gfc_expr *comp_cond = NULL; |
9136 | locus *loc = NULL; |
9137 | |
9138 | code = code->block->next; |
9139 | /* resolve_blocks asserts this is initially EXEC_ASSIGN or EXEC_IF |
9140 | If it changed to EXEC_NOP, assume an error has been emitted already. */ |
9141 | if (code->op == EXEC_NOP) |
9142 | return; |
9143 | |
9144 | if (atomic_code->ext.omp_clauses->compare |
9145 | && atomic_code->ext.omp_clauses->capture) |
9146 | { |
9147 | /* Must be either "if (x == e) then; x = d; else; v = x; end if" |
9148 | or "v = expr" followed/preceded by |
9149 | "if (x == e) then; x = d; end if" or "if (x == e) x = d". */ |
9150 | gfc_code *next = code; |
9151 | if (code->op == EXEC_ASSIGN) |
9152 | { |
9153 | capture_stmt = code; |
9154 | next = code->next; |
9155 | } |
9156 | if (next->op == EXEC_IF |
9157 | && next->block |
9158 | && next->block->op == EXEC_IF |
9159 | && next->block->next |
9160 | && next->block->next->op == EXEC_ASSIGN) |
9161 | { |
9162 | comp_cond = next->block->expr1; |
9163 | stmt = next->block->next; |
9164 | if (stmt->next) |
9165 | { |
9166 | loc = &stmt->loc; |
9167 | goto unexpected; |
9168 | } |
9169 | } |
9170 | else if (capture_stmt) |
9171 | { |
9172 | gfc_error ("Expected IF at %L in atomic compare capture" , |
9173 | &next->loc); |
9174 | return; |
9175 | } |
9176 | if (stmt && !capture_stmt && next->block->block) |
9177 | { |
9178 | if (next->block->block->expr1) |
9179 | { |
9180 | gfc_error ("Expected ELSE at %L in atomic compare capture" , |
9181 | &next->block->block->expr1->where); |
9182 | return; |
9183 | } |
9184 | if (!code->block->block->next |
9185 | || code->block->block->next->op != EXEC_ASSIGN) |
9186 | { |
9187 | loc = (code->block->block->next ? &code->block->block->next->loc |
9188 | : &code->block->block->loc); |
9189 | goto unexpected; |
9190 | } |
9191 | capture_stmt = code->block->block->next; |
9192 | if (capture_stmt->next) |
9193 | { |
9194 | loc = &capture_stmt->next->loc; |
9195 | goto unexpected; |
9196 | } |
9197 | } |
9198 | if (stmt && !capture_stmt && next->next->op == EXEC_ASSIGN) |
9199 | capture_stmt = next->next; |
9200 | else if (!capture_stmt) |
9201 | { |
9202 | loc = &code->loc; |
9203 | goto unexpected; |
9204 | } |
9205 | } |
9206 | else if (atomic_code->ext.omp_clauses->compare) |
9207 | { |
9208 | /* Must be: "if (x == e) then; x = d; end if" or "if (x == e) x = d". */ |
9209 | if (code->op == EXEC_IF |
9210 | && code->block |
9211 | && code->block->op == EXEC_IF |
9212 | && code->block->next |
9213 | && code->block->next->op == EXEC_ASSIGN) |
9214 | { |
9215 | comp_cond = code->block->expr1; |
9216 | stmt = code->block->next; |
9217 | if (stmt->next || code->block->block) |
9218 | { |
9219 | loc = stmt->next ? &stmt->next->loc : &code->block->block->loc; |
9220 | goto unexpected; |
9221 | } |
9222 | } |
9223 | else |
9224 | { |
9225 | loc = &code->loc; |
9226 | goto unexpected; |
9227 | } |
9228 | } |
9229 | else if (atomic_code->ext.omp_clauses->capture) |
9230 | { |
9231 | /* Must be: "v = x" followed/preceded by "x = ...". */ |
9232 | if (code->op != EXEC_ASSIGN) |
9233 | goto unexpected; |
9234 | if (code->next->op != EXEC_ASSIGN) |
9235 | { |
9236 | loc = &code->next->loc; |
9237 | goto unexpected; |
9238 | } |
9239 | gfc_expr *expr2, *expr2_next; |
9240 | expr2 = is_conversion (expr: code->expr2, narrowing: true, widening: true); |
9241 | if (expr2 == NULL) |
9242 | expr2 = code->expr2; |
9243 | expr2_next = is_conversion (expr: code->next->expr2, narrowing: true, widening: true); |
9244 | if (expr2_next == NULL) |
9245 | expr2_next = code->next->expr2; |
9246 | if (code->expr1->expr_type == EXPR_VARIABLE |
9247 | && code->next->expr1->expr_type == EXPR_VARIABLE |
9248 | && expr2->expr_type == EXPR_VARIABLE |
9249 | && expr2_next->expr_type == EXPR_VARIABLE) |
9250 | { |
9251 | if (code->expr1->symtree->n.sym == expr2_next->symtree->n.sym) |
9252 | { |
9253 | stmt = code; |
9254 | capture_stmt = code->next; |
9255 | } |
9256 | else |
9257 | { |
9258 | capture_stmt = code; |
9259 | stmt = code->next; |
9260 | } |
9261 | } |
9262 | else if (expr2->expr_type == EXPR_VARIABLE) |
9263 | { |
9264 | capture_stmt = code; |
9265 | stmt = code->next; |
9266 | } |
9267 | else |
9268 | { |
9269 | stmt = code; |
9270 | capture_stmt = code->next; |
9271 | } |
9272 | /* Shall be NULL but can happen for invalid code. */ |
9273 | tailing_stmt = code->next->next; |
9274 | } |
9275 | else |
9276 | { |
9277 | /* x = ... */ |
9278 | stmt = code; |
9279 | if (!atomic_code->ext.omp_clauses->compare && stmt->op != EXEC_ASSIGN) |
9280 | goto unexpected; |
9281 | /* Shall be NULL but can happen for invalid code. */ |
9282 | tailing_stmt = code->next; |
9283 | } |
9284 | |
9285 | if (comp_cond) |
9286 | { |
9287 | if (comp_cond->expr_type != EXPR_OP |
9288 | || (comp_cond->value.op.op != INTRINSIC_EQ |
9289 | && comp_cond->value.op.op != INTRINSIC_EQ_OS |
9290 | && comp_cond->value.op.op != INTRINSIC_EQV)) |
9291 | { |
9292 | gfc_error ("Expected %<==%>, %<.EQ.%> or %<.EQV.%> atomic comparison " |
9293 | "expression at %L" , &comp_cond->where); |
9294 | return; |
9295 | } |
9296 | if (!is_scalar_intrinsic_expr (expr: comp_cond->value.op.op1, must_be_var: true, conv_ok: true)) |
9297 | { |
9298 | gfc_error ("Expected scalar intrinsic variable at %L in atomic " |
9299 | "comparison" , &comp_cond->value.op.op1->where); |
9300 | return; |
9301 | } |
9302 | if (!gfc_resolve_expr (comp_cond->value.op.op2)) |
9303 | return; |
9304 | if (!is_scalar_intrinsic_expr (expr: comp_cond->value.op.op2, must_be_var: false, conv_ok: false)) |
9305 | { |
9306 | gfc_error ("Expected scalar intrinsic expression at %L in atomic " |
9307 | "comparison" , &comp_cond->value.op.op1->where); |
9308 | return; |
9309 | } |
9310 | } |
9311 | |
9312 | if (!is_scalar_intrinsic_expr (expr: stmt->expr1, must_be_var: true, conv_ok: false)) |
9313 | { |
9314 | gfc_error ("!$OMP ATOMIC statement must set a scalar variable of " |
9315 | "intrinsic type at %L" , &stmt->expr1->where); |
9316 | return; |
9317 | } |
9318 | |
9319 | if (!gfc_resolve_expr (stmt->expr2)) |
9320 | return; |
9321 | if (!is_scalar_intrinsic_expr (expr: stmt->expr2, must_be_var: false, conv_ok: false)) |
9322 | { |
9323 | gfc_error ("!$OMP ATOMIC statement must assign an expression of " |
9324 | "intrinsic type at %L" , &stmt->expr2->where); |
9325 | return; |
9326 | } |
9327 | |
9328 | if (gfc_expr_attr (stmt->expr1).allocatable) |
9329 | { |
9330 | gfc_error ("!$OMP ATOMIC with ALLOCATABLE variable at %L" , |
9331 | &stmt->expr1->where); |
9332 | return; |
9333 | } |
9334 | |
9335 | /* Should be diagnosed above already. */ |
9336 | gcc_assert (tailing_stmt == NULL); |
9337 | |
9338 | var = stmt->expr1->symtree->n.sym; |
9339 | stmt_expr2 = is_conversion (expr: stmt->expr2, narrowing: true, widening: true); |
9340 | if (stmt_expr2 == NULL) |
9341 | stmt_expr2 = stmt->expr2; |
9342 | |
9343 | switch (aop) |
9344 | { |
9345 | case GFC_OMP_ATOMIC_READ: |
9346 | if (stmt_expr2->expr_type != EXPR_VARIABLE) |
9347 | gfc_error ("!$OMP ATOMIC READ statement must read from a scalar " |
9348 | "variable of intrinsic type at %L" , &stmt_expr2->where); |
9349 | return; |
9350 | case GFC_OMP_ATOMIC_WRITE: |
9351 | if (expr_references_sym (e: stmt_expr2, s: var, NULL)) |
9352 | gfc_error ("expr in !$OMP ATOMIC WRITE assignment var = expr " |
9353 | "must be scalar and cannot reference var at %L" , |
9354 | &stmt_expr2->where); |
9355 | return; |
9356 | default: |
9357 | break; |
9358 | } |
9359 | |
9360 | if (atomic_code->ext.omp_clauses->capture) |
9361 | { |
9362 | if (!is_scalar_intrinsic_expr (expr: capture_stmt->expr1, must_be_var: true, conv_ok: false)) |
9363 | { |
9364 | gfc_error ("!$OMP ATOMIC capture-statement must set a scalar " |
9365 | "variable of intrinsic type at %L" , |
9366 | &capture_stmt->expr1->where); |
9367 | return; |
9368 | } |
9369 | |
9370 | if (!is_scalar_intrinsic_expr (expr: capture_stmt->expr2, must_be_var: true, conv_ok: true)) |
9371 | { |
9372 | gfc_error ("!$OMP ATOMIC capture-statement requires a scalar variable" |
9373 | " of intrinsic type at %L" , &capture_stmt->expr2->where); |
9374 | return; |
9375 | } |
9376 | capt_expr2 = is_conversion (expr: capture_stmt->expr2, narrowing: true, widening: true); |
9377 | if (capt_expr2 == NULL) |
9378 | capt_expr2 = capture_stmt->expr2; |
9379 | |
9380 | if (capt_expr2->symtree->n.sym != var) |
9381 | { |
9382 | gfc_error ("!$OMP ATOMIC CAPTURE capture statement reads from " |
9383 | "different variable than update statement writes " |
9384 | "into at %L" , &capture_stmt->expr2->where); |
9385 | return; |
9386 | } |
9387 | } |
9388 | |
9389 | if (atomic_code->ext.omp_clauses->compare) |
9390 | { |
9391 | gfc_expr *var_expr; |
9392 | if (comp_cond->value.op.op1->expr_type == EXPR_VARIABLE) |
9393 | var_expr = comp_cond->value.op.op1; |
9394 | else |
9395 | var_expr = comp_cond->value.op.op1->value.function.actual->expr; |
9396 | if (var_expr->symtree->n.sym != var) |
9397 | { |
9398 | gfc_error ("For !$OMP ATOMIC COMPARE, the first operand in comparison" |
9399 | " at %L must be the variable %qs that the update statement" |
9400 | " writes into at %L" , &var_expr->where, var->name, |
9401 | &stmt->expr1->where); |
9402 | return; |
9403 | } |
9404 | if (stmt_expr2->rank != 0 || expr_references_sym (e: stmt_expr2, s: var, NULL)) |
9405 | { |
9406 | gfc_error ("expr in !$OMP ATOMIC COMPARE assignment var = expr " |
9407 | "must be scalar and cannot reference var at %L" , |
9408 | &stmt_expr2->where); |
9409 | return; |
9410 | } |
9411 | } |
9412 | else if (atomic_code->ext.omp_clauses->capture |
9413 | && !expr_references_sym (e: stmt_expr2, s: var, NULL)) |
9414 | atomic_code->ext.omp_clauses->atomic_op |
9415 | = (gfc_omp_atomic_op) (atomic_code->ext.omp_clauses->atomic_op |
9416 | | GFC_OMP_ATOMIC_SWAP); |
9417 | else if (stmt_expr2->expr_type == EXPR_OP) |
9418 | { |
9419 | gfc_expr *v = NULL, *e, *c; |
9420 | gfc_intrinsic_op op = stmt_expr2->value.op.op; |
9421 | gfc_intrinsic_op alt_op = INTRINSIC_NONE; |
9422 | |
9423 | if (atomic_code->ext.omp_clauses->fail != OMP_MEMORDER_UNSET) |
9424 | gfc_error ("!$OMP ATOMIC UPDATE at %L with FAIL clause requiries either" |
9425 | " the COMPARE clause or using the intrinsic MIN/MAX " |
9426 | "procedure" , &atomic_code->loc); |
9427 | switch (op) |
9428 | { |
9429 | case INTRINSIC_PLUS: |
9430 | alt_op = INTRINSIC_MINUS; |
9431 | break; |
9432 | case INTRINSIC_TIMES: |
9433 | alt_op = INTRINSIC_DIVIDE; |
9434 | break; |
9435 | case INTRINSIC_MINUS: |
9436 | alt_op = INTRINSIC_PLUS; |
9437 | break; |
9438 | case INTRINSIC_DIVIDE: |
9439 | alt_op = INTRINSIC_TIMES; |
9440 | break; |
9441 | case INTRINSIC_AND: |
9442 | case INTRINSIC_OR: |
9443 | break; |
9444 | case INTRINSIC_EQV: |
9445 | alt_op = INTRINSIC_NEQV; |
9446 | break; |
9447 | case INTRINSIC_NEQV: |
9448 | alt_op = INTRINSIC_EQV; |
9449 | break; |
9450 | default: |
9451 | gfc_error ("!$OMP ATOMIC assignment operator must be binary " |
9452 | "+, *, -, /, .AND., .OR., .EQV. or .NEQV. at %L" , |
9453 | &stmt_expr2->where); |
9454 | return; |
9455 | } |
9456 | |
9457 | /* Check for var = var op expr resp. var = expr op var where |
9458 | expr doesn't reference var and var op expr is mathematically |
9459 | equivalent to var op (expr) resp. expr op var equivalent to |
9460 | (expr) op var. We rely here on the fact that the matcher |
9461 | for x op1 y op2 z where op1 and op2 have equal precedence |
9462 | returns (x op1 y) op2 z. */ |
9463 | e = stmt_expr2->value.op.op2; |
9464 | if (e->expr_type == EXPR_VARIABLE |
9465 | && e->symtree != NULL |
9466 | && e->symtree->n.sym == var) |
9467 | v = e; |
9468 | else if ((c = is_conversion (expr: e, narrowing: false, widening: true)) != NULL |
9469 | && c->expr_type == EXPR_VARIABLE |
9470 | && c->symtree != NULL |
9471 | && c->symtree->n.sym == var) |
9472 | v = c; |
9473 | else |
9474 | { |
9475 | gfc_expr **p = NULL, **q; |
9476 | for (q = &stmt_expr2->value.op.op1; (e = *q) != NULL; ) |
9477 | if (e->expr_type == EXPR_VARIABLE |
9478 | && e->symtree != NULL |
9479 | && e->symtree->n.sym == var) |
9480 | { |
9481 | v = e; |
9482 | break; |
9483 | } |
9484 | else if ((c = is_conversion (expr: e, narrowing: false, widening: true)) != NULL) |
9485 | q = &e->value.function.actual->expr; |
9486 | else if (e->expr_type != EXPR_OP |
9487 | || (e->value.op.op != op |
9488 | && e->value.op.op != alt_op) |
9489 | || e->rank != 0) |
9490 | break; |
9491 | else |
9492 | { |
9493 | p = q; |
9494 | q = &e->value.op.op1; |
9495 | } |
9496 | |
9497 | if (v == NULL) |
9498 | { |
9499 | gfc_error ("!$OMP ATOMIC assignment must be var = var op expr " |
9500 | "or var = expr op var at %L" , &stmt_expr2->where); |
9501 | return; |
9502 | } |
9503 | |
9504 | if (p != NULL) |
9505 | { |
9506 | e = *p; |
9507 | switch (e->value.op.op) |
9508 | { |
9509 | case INTRINSIC_MINUS: |
9510 | case INTRINSIC_DIVIDE: |
9511 | case INTRINSIC_EQV: |
9512 | case INTRINSIC_NEQV: |
9513 | gfc_error ("!$OMP ATOMIC var = var op expr not " |
9514 | "mathematically equivalent to var = var op " |
9515 | "(expr) at %L" , &stmt_expr2->where); |
9516 | break; |
9517 | default: |
9518 | break; |
9519 | } |
9520 | |
9521 | /* Canonicalize into var = var op (expr). */ |
9522 | *p = e->value.op.op2; |
9523 | e->value.op.op2 = stmt_expr2; |
9524 | e->ts = stmt_expr2->ts; |
9525 | if (stmt->expr2 == stmt_expr2) |
9526 | stmt->expr2 = stmt_expr2 = e; |
9527 | else |
9528 | stmt->expr2->value.function.actual->expr = stmt_expr2 = e; |
9529 | |
9530 | if (!gfc_compare_types (&stmt_expr2->value.op.op1->ts, |
9531 | &stmt_expr2->ts)) |
9532 | { |
9533 | for (p = &stmt_expr2->value.op.op1; *p != v; |
9534 | p = &(*p)->value.function.actual->expr) |
9535 | ; |
9536 | *p = NULL; |
9537 | gfc_free_expr (stmt_expr2->value.op.op1); |
9538 | stmt_expr2->value.op.op1 = v; |
9539 | gfc_convert_type (v, &stmt_expr2->ts, 2); |
9540 | } |
9541 | } |
9542 | } |
9543 | |
9544 | if (e->rank != 0 || expr_references_sym (e: stmt->expr2, s: var, se: v)) |
9545 | { |
9546 | gfc_error ("expr in !$OMP ATOMIC assignment var = var op expr " |
9547 | "must be scalar and cannot reference var at %L" , |
9548 | &stmt_expr2->where); |
9549 | return; |
9550 | } |
9551 | } |
9552 | else if (stmt_expr2->expr_type == EXPR_FUNCTION |
9553 | && stmt_expr2->value.function.isym != NULL |
9554 | && stmt_expr2->value.function.esym == NULL |
9555 | && stmt_expr2->value.function.actual != NULL |
9556 | && stmt_expr2->value.function.actual->next != NULL) |
9557 | { |
9558 | gfc_actual_arglist *arg, *var_arg; |
9559 | |
9560 | switch (stmt_expr2->value.function.isym->id) |
9561 | { |
9562 | case GFC_ISYM_MIN: |
9563 | case GFC_ISYM_MAX: |
9564 | break; |
9565 | case GFC_ISYM_IAND: |
9566 | case GFC_ISYM_IOR: |
9567 | case GFC_ISYM_IEOR: |
9568 | if (stmt_expr2->value.function.actual->next->next != NULL) |
9569 | { |
9570 | gfc_error ("!$OMP ATOMIC assignment intrinsic IAND, IOR " |
9571 | "or IEOR must have two arguments at %L" , |
9572 | &stmt_expr2->where); |
9573 | return; |
9574 | } |
9575 | break; |
9576 | default: |
9577 | gfc_error ("!$OMP ATOMIC assignment intrinsic must be " |
9578 | "MIN, MAX, IAND, IOR or IEOR at %L" , |
9579 | &stmt_expr2->where); |
9580 | return; |
9581 | } |
9582 | |
9583 | var_arg = NULL; |
9584 | for (arg = stmt_expr2->value.function.actual; arg; arg = arg->next) |
9585 | { |
9586 | gfc_expr *e = NULL; |
9587 | if (arg == stmt_expr2->value.function.actual |
9588 | || (var_arg == NULL && arg->next == NULL)) |
9589 | { |
9590 | e = is_conversion (expr: arg->expr, narrowing: false, widening: true); |
9591 | if (!e) |
9592 | e = arg->expr; |
9593 | if (e->expr_type == EXPR_VARIABLE |
9594 | && e->symtree != NULL |
9595 | && e->symtree->n.sym == var) |
9596 | var_arg = arg; |
9597 | } |
9598 | if ((!var_arg || !e) && expr_references_sym (e: arg->expr, s: var, NULL)) |
9599 | { |
9600 | gfc_error ("!$OMP ATOMIC intrinsic arguments except one must " |
9601 | "not reference %qs at %L" , |
9602 | var->name, &arg->expr->where); |
9603 | return; |
9604 | } |
9605 | if (arg->expr->rank != 0) |
9606 | { |
9607 | gfc_error ("!$OMP ATOMIC intrinsic arguments must be scalar " |
9608 | "at %L" , &arg->expr->where); |
9609 | return; |
9610 | } |
9611 | } |
9612 | |
9613 | if (var_arg == NULL) |
9614 | { |
9615 | gfc_error ("First or last !$OMP ATOMIC intrinsic argument must " |
9616 | "be %qs at %L" , var->name, &stmt_expr2->where); |
9617 | return; |
9618 | } |
9619 | |
9620 | if (var_arg != stmt_expr2->value.function.actual) |
9621 | { |
9622 | /* Canonicalize, so that var comes first. */ |
9623 | gcc_assert (var_arg->next == NULL); |
9624 | for (arg = stmt_expr2->value.function.actual; |
9625 | arg->next != var_arg; arg = arg->next) |
9626 | ; |
9627 | var_arg->next = stmt_expr2->value.function.actual; |
9628 | stmt_expr2->value.function.actual = var_arg; |
9629 | arg->next = NULL; |
9630 | } |
9631 | } |
9632 | else |
9633 | gfc_error ("!$OMP ATOMIC assignment must have an operator or " |
9634 | "intrinsic on right hand side at %L" , &stmt_expr2->where); |
9635 | return; |
9636 | |
9637 | unexpected: |
9638 | gfc_error ("unexpected !$OMP ATOMIC expression at %L" , |
9639 | loc ? loc : &code->loc); |
9640 | return; |
9641 | } |
9642 | |
9643 | |
9644 | static struct fortran_omp_context |
9645 | { |
9646 | gfc_code *code; |
9647 | hash_set<gfc_symbol *> *sharing_clauses; |
9648 | hash_set<gfc_symbol *> *private_iterators; |
9649 | struct fortran_omp_context *previous; |
9650 | bool is_openmp; |
9651 | } *omp_current_ctx; |
9652 | static gfc_code *omp_current_do_code; |
9653 | static int omp_current_do_collapse; |
9654 | |
9655 | /* Forward declaration for mutually recursive functions. */ |
9656 | static gfc_code * |
9657 | find_nested_loop_in_block (gfc_code *block); |
9658 | |
9659 | /* Return the first nested DO loop in CHAIN, or NULL if there |
9660 | isn't one. Does no error checking on intervening code. */ |
9661 | |
9662 | static gfc_code * |
9663 | find_nested_loop_in_chain (gfc_code *chain) |
9664 | { |
9665 | gfc_code *code; |
9666 | |
9667 | if (!chain) |
9668 | return NULL; |
9669 | |
9670 | for (code = chain; code; code = code->next) |
9671 | { |
9672 | if (code->op == EXEC_DO) |
9673 | return code; |
9674 | else if (code->op == EXEC_BLOCK) |
9675 | { |
9676 | gfc_code *c = find_nested_loop_in_block (block: code); |
9677 | if (c) |
9678 | return c; |
9679 | } |
9680 | } |
9681 | return NULL; |
9682 | } |
9683 | |
9684 | /* Return the first nested DO loop in BLOCK, or NULL if there |
9685 | isn't one. Does no error checking on intervening code. */ |
9686 | static gfc_code * |
9687 | find_nested_loop_in_block (gfc_code *block) |
9688 | { |
9689 | gfc_namespace *ns; |
9690 | gcc_assert (block->op == EXEC_BLOCK); |
9691 | ns = block->ext.block.ns; |
9692 | gcc_assert (ns); |
9693 | return find_nested_loop_in_chain (chain: ns->code); |
9694 | } |
9695 | |
9696 | void |
9697 | gfc_resolve_omp_do_blocks (gfc_code *code, gfc_namespace *ns) |
9698 | { |
9699 | if (code->block->next && code->block->next->op == EXEC_DO) |
9700 | { |
9701 | int i; |
9702 | |
9703 | omp_current_do_code = code->block->next; |
9704 | if (code->ext.omp_clauses->orderedc) |
9705 | omp_current_do_collapse = code->ext.omp_clauses->orderedc; |
9706 | else if (code->ext.omp_clauses->collapse) |
9707 | omp_current_do_collapse = code->ext.omp_clauses->collapse; |
9708 | else |
9709 | omp_current_do_collapse = 1; |
9710 | if (code->ext.omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN]) |
9711 | { |
9712 | /* Checking that there is a matching EXEC_OMP_SCAN in the |
9713 | innermost body cannot be deferred to resolve_omp_do because |
9714 | we process directives nested in the loop before we get |
9715 | there. */ |
9716 | locus *loc |
9717 | = &code->ext.omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN]->where; |
9718 | gfc_code *c; |
9719 | |
9720 | for (i = 1, c = omp_current_do_code; |
9721 | i < omp_current_do_collapse; i++) |
9722 | { |
9723 | c = find_nested_loop_in_chain (chain: c->block->next); |
9724 | if (!c || c->op != EXEC_DO || c->block == NULL) |
9725 | break; |
9726 | } |
9727 | |
9728 | /* Skip this if we don't have enough nested loops. That |
9729 | problem will be diagnosed elsewhere. */ |
9730 | if (c && c->op == EXEC_DO) |
9731 | { |
9732 | gfc_code *block = c->block ? c->block->next : NULL; |
9733 | if (block && block->op != EXEC_OMP_SCAN) |
9734 | while (block && block->next |
9735 | && block->next->op != EXEC_OMP_SCAN) |
9736 | block = block->next; |
9737 | if (!block |
9738 | || (block->op != EXEC_OMP_SCAN |
9739 | && (!block->next || block->next->op != EXEC_OMP_SCAN))) |
9740 | gfc_error ("With INSCAN at %L, expected loop body with " |
9741 | "!$OMP SCAN between two " |
9742 | "structured block sequences" , loc); |
9743 | else |
9744 | { |
9745 | if (block->op == EXEC_OMP_SCAN) |
9746 | gfc_warning (opt: 0, "!$OMP SCAN at %L with zero executable " |
9747 | "statements in preceding structured block " |
9748 | "sequence" , &block->loc); |
9749 | if ((block->op == EXEC_OMP_SCAN && !block->next) |
9750 | || (block->next && block->next->op == EXEC_OMP_SCAN |
9751 | && !block->next->next)) |
9752 | gfc_warning (opt: 0, "!$OMP SCAN at %L with zero executable " |
9753 | "statements in succeeding structured block " |
9754 | "sequence" , block->op == EXEC_OMP_SCAN |
9755 | ? &block->loc : &block->next->loc); |
9756 | } |
9757 | if (block && block->op != EXEC_OMP_SCAN) |
9758 | block = block->next; |
9759 | if (block && block->op == EXEC_OMP_SCAN) |
9760 | /* Mark 'omp scan' as checked; flag will be unset later. */ |
9761 | block->ext.omp_clauses->if_present = true; |
9762 | } |
9763 | } |
9764 | } |
9765 | gfc_resolve_blocks (code->block, ns); |
9766 | omp_current_do_collapse = 0; |
9767 | omp_current_do_code = NULL; |
9768 | } |
9769 | |
9770 | |
9771 | void |
9772 | gfc_resolve_omp_parallel_blocks (gfc_code *code, gfc_namespace *ns) |
9773 | { |
9774 | struct fortran_omp_context ctx; |
9775 | gfc_omp_clauses *omp_clauses = code->ext.omp_clauses; |
9776 | gfc_omp_namelist *n; |
9777 | int list; |
9778 | |
9779 | ctx.code = code; |
9780 | ctx.sharing_clauses = new hash_set<gfc_symbol *>; |
9781 | ctx.private_iterators = new hash_set<gfc_symbol *>; |
9782 | ctx.previous = omp_current_ctx; |
9783 | ctx.is_openmp = true; |
9784 | omp_current_ctx = &ctx; |
9785 | |
9786 | for (list = 0; list < OMP_LIST_NUM; list++) |
9787 | switch (list) |
9788 | { |
9789 | case OMP_LIST_SHARED: |
9790 | case OMP_LIST_PRIVATE: |
9791 | case OMP_LIST_FIRSTPRIVATE: |
9792 | case OMP_LIST_LASTPRIVATE: |
9793 | case OMP_LIST_REDUCTION: |
9794 | case OMP_LIST_REDUCTION_INSCAN: |
9795 | case OMP_LIST_REDUCTION_TASK: |
9796 | case OMP_LIST_IN_REDUCTION: |
9797 | case OMP_LIST_TASK_REDUCTION: |
9798 | case OMP_LIST_LINEAR: |
9799 | for (n = omp_clauses->lists[list]; n; n = n->next) |
9800 | ctx.sharing_clauses->add (k: n->sym); |
9801 | break; |
9802 | default: |
9803 | break; |
9804 | } |
9805 | |
9806 | switch (code->op) |
9807 | { |
9808 | case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: |
9809 | case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: |
9810 | case EXEC_OMP_MASKED_TASKLOOP: |
9811 | case EXEC_OMP_MASKED_TASKLOOP_SIMD: |
9812 | case EXEC_OMP_MASTER_TASKLOOP: |
9813 | case EXEC_OMP_MASTER_TASKLOOP_SIMD: |
9814 | case EXEC_OMP_PARALLEL_DO: |
9815 | case EXEC_OMP_PARALLEL_DO_SIMD: |
9816 | case EXEC_OMP_PARALLEL_LOOP: |
9817 | case EXEC_OMP_PARALLEL_MASKED_TASKLOOP: |
9818 | case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: |
9819 | case EXEC_OMP_PARALLEL_MASTER_TASKLOOP: |
9820 | case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: |
9821 | case EXEC_OMP_TARGET_PARALLEL_DO: |
9822 | case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: |
9823 | case EXEC_OMP_TARGET_PARALLEL_LOOP: |
9824 | case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: |
9825 | case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: |
9826 | case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: |
9827 | case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: |
9828 | case EXEC_OMP_TARGET_TEAMS_LOOP: |
9829 | case EXEC_OMP_TASKLOOP: |
9830 | case EXEC_OMP_TASKLOOP_SIMD: |
9831 | case EXEC_OMP_TEAMS_DISTRIBUTE: |
9832 | case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: |
9833 | case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: |
9834 | case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: |
9835 | case EXEC_OMP_TEAMS_LOOP: |
9836 | gfc_resolve_omp_do_blocks (code, ns); |
9837 | break; |
9838 | default: |
9839 | gfc_resolve_blocks (code->block, ns); |
9840 | } |
9841 | |
9842 | omp_current_ctx = ctx.previous; |
9843 | delete ctx.sharing_clauses; |
9844 | delete ctx.private_iterators; |
9845 | } |
9846 | |
9847 | |
9848 | /* Save and clear openmp.cc private state. */ |
9849 | |
9850 | void |
9851 | gfc_omp_save_and_clear_state (struct gfc_omp_saved_state *state) |
9852 | { |
9853 | state->ptrs[0] = omp_current_ctx; |
9854 | state->ptrs[1] = omp_current_do_code; |
9855 | state->ints[0] = omp_current_do_collapse; |
9856 | omp_current_ctx = NULL; |
9857 | omp_current_do_code = NULL; |
9858 | omp_current_do_collapse = 0; |
9859 | } |
9860 | |
9861 | |
9862 | /* Restore openmp.cc private state from the saved state. */ |
9863 | |
9864 | void |
9865 | gfc_omp_restore_state (struct gfc_omp_saved_state *state) |
9866 | { |
9867 | omp_current_ctx = (struct fortran_omp_context *) state->ptrs[0]; |
9868 | omp_current_do_code = (gfc_code *) state->ptrs[1]; |
9869 | omp_current_do_collapse = state->ints[0]; |
9870 | } |
9871 | |
9872 | |
9873 | /* Note a DO iterator variable. This is special in !$omp parallel |
9874 | construct, where they are predetermined private. */ |
9875 | |
9876 | void |
9877 | gfc_resolve_do_iterator (gfc_code *code, gfc_symbol *sym, bool add_clause) |
9878 | { |
9879 | if (omp_current_ctx == NULL) |
9880 | return; |
9881 | |
9882 | int i = omp_current_do_collapse; |
9883 | gfc_code *c = omp_current_do_code; |
9884 | |
9885 | if (sym->attr.threadprivate) |
9886 | return; |
9887 | |
9888 | /* !$omp do and !$omp parallel do iteration variable is predetermined |
9889 | private just in the !$omp do resp. !$omp parallel do construct, |
9890 | with no implications for the outer parallel constructs. */ |
9891 | |
9892 | while (i-- >= 1 && c) |
9893 | { |
9894 | if (code == c) |
9895 | return; |
9896 | c = find_nested_loop_in_chain (chain: c->block->next); |
9897 | } |
9898 | |
9899 | /* An openacc context may represent a data clause. Abort if so. */ |
9900 | if (!omp_current_ctx->is_openmp && !oacc_is_loop (code: omp_current_ctx->code)) |
9901 | return; |
9902 | |
9903 | if (omp_current_ctx->sharing_clauses->contains (k: sym)) |
9904 | return; |
9905 | |
9906 | if (! omp_current_ctx->private_iterators->add (k: sym) && add_clause) |
9907 | { |
9908 | gfc_omp_clauses *omp_clauses = omp_current_ctx->code->ext.omp_clauses; |
9909 | gfc_omp_namelist *p; |
9910 | |
9911 | p = gfc_get_omp_namelist (); |
9912 | p->sym = sym; |
9913 | p->where = omp_current_ctx->code->loc; |
9914 | p->next = omp_clauses->lists[OMP_LIST_PRIVATE]; |
9915 | omp_clauses->lists[OMP_LIST_PRIVATE] = p; |
9916 | } |
9917 | } |
9918 | |
9919 | static void |
9920 | handle_local_var (gfc_symbol *sym) |
9921 | { |
9922 | if (sym->attr.flavor != FL_VARIABLE |
9923 | || sym->as != NULL |
9924 | || (sym->ts.type != BT_INTEGER && sym->ts.type != BT_REAL)) |
9925 | return; |
9926 | gfc_resolve_do_iterator (code: sym->ns->code, sym, add_clause: false); |
9927 | } |
9928 | |
9929 | void |
9930 | gfc_resolve_omp_local_vars (gfc_namespace *ns) |
9931 | { |
9932 | if (omp_current_ctx) |
9933 | gfc_traverse_ns (ns, handle_local_var); |
9934 | } |
9935 | |
9936 | |
9937 | /* Error checking on intervening code uses a code walker. */ |
9938 | |
9939 | struct icode_error_state |
9940 | { |
9941 | const char *name; |
9942 | bool errorp; |
9943 | gfc_code *nested; |
9944 | gfc_code *next; |
9945 | }; |
9946 | |
9947 | static int |
9948 | icode_code_error_callback (gfc_code **codep, |
9949 | int *walk_subtrees ATTRIBUTE_UNUSED, void *opaque) |
9950 | { |
9951 | gfc_code *code = *codep; |
9952 | icode_error_state *state = (icode_error_state *)opaque; |
9953 | |
9954 | /* gfc_code_walker walks down CODE's next chain as well as |
9955 | walking things that are actually nested in CODE. We need to |
9956 | special-case traversal of outer blocks, so stop immediately if we |
9957 | are heading down such a next chain. */ |
9958 | if (code == state->next) |
9959 | return 1; |
9960 | |
9961 | switch (code->op) |
9962 | { |
9963 | case EXEC_DO: |
9964 | case EXEC_DO_WHILE: |
9965 | case EXEC_DO_CONCURRENT: |
9966 | gfc_error ("%s cannot contain loop in intervening code at %L" , |
9967 | state->name, &code->loc); |
9968 | state->errorp = true; |
9969 | break; |
9970 | case EXEC_CYCLE: |
9971 | case EXEC_EXIT: |
9972 | /* Errors have already been diagnosed in match_exit_cycle. */ |
9973 | state->errorp = true; |
9974 | break; |
9975 | case EXEC_OMP_CRITICAL: |
9976 | case EXEC_OMP_DO: |
9977 | case EXEC_OMP_FLUSH: |
9978 | case EXEC_OMP_MASTER: |
9979 | case EXEC_OMP_ORDERED: |
9980 | case EXEC_OMP_PARALLEL: |
9981 | case EXEC_OMP_PARALLEL_DO: |
9982 | case EXEC_OMP_PARALLEL_SECTIONS: |
9983 | case EXEC_OMP_PARALLEL_WORKSHARE: |
9984 | case EXEC_OMP_SECTIONS: |
9985 | case EXEC_OMP_SINGLE: |
9986 | case EXEC_OMP_WORKSHARE: |
9987 | case EXEC_OMP_ATOMIC: |
9988 | case EXEC_OMP_BARRIER: |
9989 | case EXEC_OMP_END_NOWAIT: |
9990 | case EXEC_OMP_END_SINGLE: |
9991 | case EXEC_OMP_TASK: |
9992 | case EXEC_OMP_TASKWAIT: |
9993 | case EXEC_OMP_TASKYIELD: |
9994 | case EXEC_OMP_CANCEL: |
9995 | case EXEC_OMP_CANCELLATION_POINT: |
9996 | case EXEC_OMP_TASKGROUP: |
9997 | case EXEC_OMP_SIMD: |
9998 | case EXEC_OMP_DO_SIMD: |
9999 | case EXEC_OMP_PARALLEL_DO_SIMD: |
10000 | case EXEC_OMP_TARGET: |
10001 | case EXEC_OMP_TARGET_DATA: |
10002 | case EXEC_OMP_TEAMS: |
10003 | case EXEC_OMP_DISTRIBUTE: |
10004 | case EXEC_OMP_DISTRIBUTE_SIMD: |
10005 | case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: |
10006 | case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: |
10007 | case EXEC_OMP_TARGET_TEAMS: |
10008 | case EXEC_OMP_TEAMS_DISTRIBUTE: |
10009 | case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: |
10010 | case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: |
10011 | case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: |
10012 | case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: |
10013 | case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: |
10014 | case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: |
10015 | case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: |
10016 | case EXEC_OMP_TARGET_UPDATE: |
10017 | case EXEC_OMP_END_CRITICAL: |
10018 | case EXEC_OMP_TARGET_ENTER_DATA: |
10019 | case EXEC_OMP_TARGET_EXIT_DATA: |
10020 | case EXEC_OMP_TARGET_PARALLEL: |
10021 | case EXEC_OMP_TARGET_PARALLEL_DO: |
10022 | case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: |
10023 | case EXEC_OMP_TARGET_SIMD: |
10024 | case EXEC_OMP_TASKLOOP: |
10025 | case EXEC_OMP_TASKLOOP_SIMD: |
10026 | case EXEC_OMP_SCAN: |
10027 | case EXEC_OMP_DEPOBJ: |
10028 | case EXEC_OMP_PARALLEL_MASTER: |
10029 | case EXEC_OMP_PARALLEL_MASTER_TASKLOOP: |
10030 | case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: |
10031 | case EXEC_OMP_MASTER_TASKLOOP: |
10032 | case EXEC_OMP_MASTER_TASKLOOP_SIMD: |
10033 | case EXEC_OMP_LOOP: |
10034 | case EXEC_OMP_PARALLEL_LOOP: |
10035 | case EXEC_OMP_TEAMS_LOOP: |
10036 | case EXEC_OMP_TARGET_PARALLEL_LOOP: |
10037 | case EXEC_OMP_TARGET_TEAMS_LOOP: |
10038 | case EXEC_OMP_MASKED: |
10039 | case EXEC_OMP_PARALLEL_MASKED: |
10040 | case EXEC_OMP_PARALLEL_MASKED_TASKLOOP: |
10041 | case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: |
10042 | case EXEC_OMP_MASKED_TASKLOOP: |
10043 | case EXEC_OMP_MASKED_TASKLOOP_SIMD: |
10044 | case EXEC_OMP_SCOPE: |
10045 | case EXEC_OMP_ERROR: |
10046 | gfc_error ("%s cannot contain OpenMP directive in intervening code " |
10047 | "at %L" , |
10048 | state->name, &code->loc); |
10049 | state->errorp = true; |
10050 | break; |
10051 | case EXEC_CALL: |
10052 | /* Per OpenMP 5.2, the "omp_" prefix is reserved, so we don't have to |
10053 | consider the possibility that some locally-bound definition |
10054 | overrides the runtime routine. */ |
10055 | if (code->resolved_sym |
10056 | && omp_runtime_api_procname (name: code->resolved_sym->name)) |
10057 | { |
10058 | gfc_error ("%s cannot contain OpenMP API call in intervening code " |
10059 | "at %L" , |
10060 | state->name, &code->loc); |
10061 | state->errorp = true; |
10062 | } |
10063 | break; |
10064 | default: |
10065 | break; |
10066 | } |
10067 | return 0; |
10068 | } |
10069 | |
10070 | static int |
10071 | icode_expr_error_callback (gfc_expr **expr, |
10072 | int *walk_subtrees ATTRIBUTE_UNUSED, void *opaque) |
10073 | { |
10074 | icode_error_state *state = (icode_error_state *)opaque; |
10075 | |
10076 | switch ((*expr)->expr_type) |
10077 | { |
10078 | /* As for EXPR_CALL with "omp_"-prefixed symbols. */ |
10079 | case EXPR_FUNCTION: |
10080 | { |
10081 | gfc_symbol *sym = (*expr)->value.function.esym; |
10082 | if (sym && omp_runtime_api_procname (name: sym->name)) |
10083 | { |
10084 | gfc_error ("%s cannot contain OpenMP API call in intervening code " |
10085 | "at %L" , |
10086 | state->name, &((*expr)->where)); |
10087 | state->errorp = true; |
10088 | } |
10089 | } |
10090 | |
10091 | break; |
10092 | default: |
10093 | break; |
10094 | } |
10095 | |
10096 | /* FIXME: The description of canonical loop form in the OpenMP standard |
10097 | also says "array expressions" are not permitted in intervening code. |
10098 | That term is not defined in either the OpenMP spec or the Fortran |
10099 | standard, although the latter uses it informally to refer to any |
10100 | expression that is not scalar-valued. It is also apparently not the |
10101 | thing GCC internally calls EXPR_ARRAY. It seems the intent of the |
10102 | OpenMP restriction is to disallow elemental operations/intrinsics |
10103 | (including things that are not expressions, like assignment |
10104 | statements) that generate implicit loops over array operands |
10105 | (even if the result is a scalar), but even if the spec said |
10106 | that there is no list of all the cases that would be forbidden. |
10107 | This is OpenMP issue 3326. */ |
10108 | |
10109 | return 0; |
10110 | } |
10111 | |
10112 | static void |
10113 | diagnose_intervening_code_errors_1 (gfc_code *chain, |
10114 | struct icode_error_state *state) |
10115 | { |
10116 | gfc_code *code; |
10117 | for (code = chain; code; code = code->next) |
10118 | { |
10119 | if (code == state->nested) |
10120 | /* Do not walk the nested loop or its body, we are only |
10121 | interested in intervening code. */ |
10122 | ; |
10123 | else if (code->op == EXEC_BLOCK |
10124 | && find_nested_loop_in_block (block: code) == state->nested) |
10125 | /* This block contains the nested loop, recurse on its |
10126 | statements. */ |
10127 | { |
10128 | gfc_namespace* ns = code->ext.block.ns; |
10129 | diagnose_intervening_code_errors_1 (chain: ns->code, state); |
10130 | } |
10131 | else |
10132 | /* Treat the whole statement as a unit. */ |
10133 | { |
10134 | gfc_code *temp = state->next; |
10135 | state->next = code->next; |
10136 | gfc_code_walker (&code, icode_code_error_callback, |
10137 | icode_expr_error_callback, state); |
10138 | state->next = temp; |
10139 | } |
10140 | } |
10141 | } |
10142 | |
10143 | /* Diagnose intervening code errors in BLOCK with nested loop NESTED. |
10144 | NAME is the user-friendly name of the OMP directive, used for error |
10145 | messages. Returns true if any error was found. */ |
10146 | static bool |
10147 | diagnose_intervening_code_errors (gfc_code *chain, const char *name, |
10148 | gfc_code *nested) |
10149 | { |
10150 | struct icode_error_state state; |
10151 | state.name = name; |
10152 | state.errorp = false; |
10153 | state.nested = nested; |
10154 | state.next = NULL; |
10155 | diagnose_intervening_code_errors_1 (chain, state: &state); |
10156 | return state.errorp; |
10157 | } |
10158 | |
10159 | /* Helper function for restructure_intervening_code: wrap CHAIN in |
10160 | a marker to indicate that it is a structured block sequence. That |
10161 | information will be used later on (in omp-low.cc) for error checking. */ |
10162 | static gfc_code * |
10163 | make_structured_block (gfc_code *chain) |
10164 | { |
10165 | gcc_assert (chain); |
10166 | gfc_namespace *ns = gfc_build_block_ns (gfc_current_ns); |
10167 | gfc_code *result = gfc_get_code (EXEC_BLOCK); |
10168 | result->op = EXEC_BLOCK; |
10169 | result->ext.block.ns = ns; |
10170 | result->ext.block.assoc = NULL; |
10171 | result->loc = chain->loc; |
10172 | ns->omp_structured_block = 1; |
10173 | ns->code = chain; |
10174 | return result; |
10175 | } |
10176 | |
10177 | /* Push intervening code surrounding a loop, including nested scopes, |
10178 | into the body of the loop. CHAINP is the pointer to the head of |
10179 | the next-chain to scan, OUTER_LOOP is the EXEC_DO for the next outer |
10180 | loop level, and COLLAPSE is the number of nested loops we need to |
10181 | process. |
10182 | Note that CHAINP may point at outer_loop->block->next when we |
10183 | are scanning the body of a loop, but if there is an intervening block |
10184 | CHAINP points into the block's chain rather than its enclosing outer |
10185 | loop. This is why OUTER_LOOP is passed separately. */ |
10186 | static gfc_code * |
10187 | restructure_intervening_code (gfc_code **chainp, gfc_code *outer_loop, |
10188 | int count) |
10189 | { |
10190 | gfc_code *code; |
10191 | gfc_code *head = *chainp; |
10192 | gfc_code *tail = NULL; |
10193 | gfc_code *innermost_loop = NULL; |
10194 | |
10195 | for (code = *chainp; code; code = code->next, chainp = &((*chainp)->next)) |
10196 | { |
10197 | if (code->op == EXEC_DO) |
10198 | { |
10199 | /* Cut CODE free from its chain, leaving the ends dangling. */ |
10200 | *chainp = NULL; |
10201 | tail = code->next; |
10202 | code->next = NULL; |
10203 | |
10204 | if (count == 1) |
10205 | innermost_loop = code; |
10206 | else |
10207 | innermost_loop |
10208 | = restructure_intervening_code (chainp: &(code->block->next), |
10209 | outer_loop: code, count: count - 1); |
10210 | break; |
10211 | } |
10212 | else if (code->op == EXEC_BLOCK |
10213 | && find_nested_loop_in_block (block: code)) |
10214 | { |
10215 | gfc_namespace *ns = code->ext.block.ns; |
10216 | |
10217 | /* Cut CODE free from its chain, leaving the ends dangling. */ |
10218 | *chainp = NULL; |
10219 | tail = code->next; |
10220 | code->next = NULL; |
10221 | |
10222 | innermost_loop |
10223 | = restructure_intervening_code (chainp: &(ns->code), outer_loop, |
10224 | count); |
10225 | |
10226 | /* At this point we have already pulled out the nested loop and |
10227 | pointed outer_loop at it, and moved the intervening code that |
10228 | was previously in the block into the body of innermost_loop. |
10229 | Now we want to move the BLOCK itself so it wraps the entire |
10230 | current body of innermost_loop. */ |
10231 | ns->code = innermost_loop->block->next; |
10232 | innermost_loop->block->next = code; |
10233 | break; |
10234 | } |
10235 | } |
10236 | |
10237 | gcc_assert (innermost_loop); |
10238 | |
10239 | /* Now we have split the intervening code into two parts: |
10240 | head is the start of the part before the loop/block, terminating |
10241 | at *chainp, and tail is the part after it. Mark each part as |
10242 | a structured block sequence, and splice the two parts around the |
10243 | existing body of the innermost loop. */ |
10244 | if (head != code) |
10245 | { |
10246 | gfc_code *block = make_structured_block (chain: head); |
10247 | if (innermost_loop->block->next) |
10248 | gfc_append_code (block, innermost_loop->block->next); |
10249 | innermost_loop->block->next = block; |
10250 | } |
10251 | if (tail) |
10252 | { |
10253 | gfc_code *block = make_structured_block (chain: tail); |
10254 | if (innermost_loop->block->next) |
10255 | gfc_append_code (innermost_loop->block->next, block); |
10256 | else |
10257 | innermost_loop->block->next = block; |
10258 | } |
10259 | |
10260 | /* For loops, finally splice CODE into OUTER_LOOP. We already handled |
10261 | relinking EXEC_BLOCK above. */ |
10262 | if (code->op == EXEC_DO && outer_loop) |
10263 | outer_loop->block->next = code; |
10264 | |
10265 | return innermost_loop; |
10266 | } |
10267 | |
10268 | /* CODE is an OMP loop construct. Return true if VAR matches an iteration |
10269 | variable outer to level DEPTH. */ |
10270 | static bool |
10271 | is_outer_iteration_variable (gfc_code *code, int depth, gfc_symbol *var) |
10272 | { |
10273 | int i; |
10274 | gfc_code *do_code = code; |
10275 | |
10276 | for (i = 1; i < depth; i++) |
10277 | { |
10278 | do_code = find_nested_loop_in_chain (chain: do_code->block->next); |
10279 | gcc_assert (do_code); |
10280 | gfc_symbol *ivar = do_code->ext.iterator->var->symtree->n.sym; |
10281 | if (var == ivar) |
10282 | return true; |
10283 | } |
10284 | return false; |
10285 | } |
10286 | |
10287 | /* Forward declaration for recursive functions. */ |
10288 | static gfc_code * |
10289 | check_nested_loop_in_block (gfc_code *block, gfc_expr *expr, gfc_symbol *sym, |
10290 | bool *bad); |
10291 | |
10292 | /* Like find_nested_loop_in_chain, but additionally check that EXPR |
10293 | does not reference any variables bound in intervening EXEC_BLOCKs |
10294 | and that SYM is not bound in such intervening blocks. Either EXPR or SYM |
10295 | may be null. Sets *BAD to true if either test fails. */ |
10296 | static gfc_code * |
10297 | check_nested_loop_in_chain (gfc_code *chain, gfc_expr *expr, gfc_symbol *sym, |
10298 | bool *bad) |
10299 | { |
10300 | for (gfc_code *code = chain; code; code = code->next) |
10301 | { |
10302 | if (code->op == EXEC_DO) |
10303 | return code; |
10304 | else if (code->op == EXEC_BLOCK) |
10305 | { |
10306 | gfc_code *c = check_nested_loop_in_block (block: code, expr, sym, bad); |
10307 | if (c) |
10308 | return c; |
10309 | } |
10310 | } |
10311 | return NULL; |
10312 | } |
10313 | |
10314 | /* Code walker for block symtrees. It doesn't take any kind of state |
10315 | argument, so use a static variable. */ |
10316 | static struct check_nested_loop_in_block_state_t { |
10317 | gfc_expr *expr; |
10318 | gfc_symbol *sym; |
10319 | bool *bad; |
10320 | } check_nested_loop_in_block_state; |
10321 | |
10322 | static void |
10323 | check_nested_loop_in_block_symbol (gfc_symbol *sym) |
10324 | { |
10325 | if (sym == check_nested_loop_in_block_state.sym |
10326 | || (check_nested_loop_in_block_state.expr |
10327 | && gfc_find_sym_in_expr (sym, |
10328 | check_nested_loop_in_block_state.expr))) |
10329 | *check_nested_loop_in_block_state.bad = true; |
10330 | } |
10331 | |
10332 | /* Return the first nested DO loop in BLOCK, or NULL if there |
10333 | isn't one. Set *BAD to true if EXPR references any variables in BLOCK, or |
10334 | SYM is bound in BLOCK. Either EXPR or SYM may be null. */ |
10335 | static gfc_code * |
10336 | check_nested_loop_in_block (gfc_code *block, gfc_expr *expr, |
10337 | gfc_symbol *sym, bool *bad) |
10338 | { |
10339 | gfc_namespace *ns; |
10340 | gcc_assert (block->op == EXEC_BLOCK); |
10341 | ns = block->ext.block.ns; |
10342 | gcc_assert (ns); |
10343 | |
10344 | /* Skip the check if this block doesn't contain the nested loop, or |
10345 | if we already know it's bad. */ |
10346 | gfc_code *result = check_nested_loop_in_chain (chain: ns->code, expr, sym, bad); |
10347 | if (result && !*bad) |
10348 | { |
10349 | check_nested_loop_in_block_state.expr = expr; |
10350 | check_nested_loop_in_block_state.sym = sym; |
10351 | check_nested_loop_in_block_state.bad = bad; |
10352 | gfc_traverse_ns (ns, check_nested_loop_in_block_symbol); |
10353 | check_nested_loop_in_block_state.expr = NULL; |
10354 | check_nested_loop_in_block_state.sym = NULL; |
10355 | check_nested_loop_in_block_state.bad = NULL; |
10356 | } |
10357 | return result; |
10358 | } |
10359 | |
10360 | /* CODE is an OMP loop construct. Return true if EXPR references |
10361 | any variables bound in intervening code, to level DEPTH. */ |
10362 | static bool |
10363 | expr_uses_intervening_var (gfc_code *code, int depth, gfc_expr *expr) |
10364 | { |
10365 | int i; |
10366 | gfc_code *do_code = code; |
10367 | |
10368 | for (i = 0; i < depth; i++) |
10369 | { |
10370 | bool bad = false; |
10371 | do_code = check_nested_loop_in_chain (chain: do_code->block->next, |
10372 | expr, NULL, bad: &bad); |
10373 | if (bad) |
10374 | return true; |
10375 | } |
10376 | return false; |
10377 | } |
10378 | |
10379 | /* CODE is an OMP loop construct. Return true if SYM is bound in |
10380 | intervening code, to level DEPTH. */ |
10381 | static bool |
10382 | is_intervening_var (gfc_code *code, int depth, gfc_symbol *sym) |
10383 | { |
10384 | int i; |
10385 | gfc_code *do_code = code; |
10386 | |
10387 | for (i = 0; i < depth; i++) |
10388 | { |
10389 | bool bad = false; |
10390 | do_code = check_nested_loop_in_chain (chain: do_code->block->next, |
10391 | NULL, sym, bad: &bad); |
10392 | if (bad) |
10393 | return true; |
10394 | } |
10395 | return false; |
10396 | } |
10397 | |
10398 | /* CODE is an OMP loop construct. Return true if EXPR does not reference |
10399 | any iteration variables outer to level DEPTH. */ |
10400 | static bool |
10401 | expr_is_invariant (gfc_code *code, int depth, gfc_expr *expr) |
10402 | { |
10403 | int i; |
10404 | gfc_code *do_code = code; |
10405 | |
10406 | for (i = 1; i < depth; i++) |
10407 | { |
10408 | do_code = find_nested_loop_in_chain (chain: do_code->block->next); |
10409 | gcc_assert (do_code); |
10410 | gfc_symbol *ivar = do_code->ext.iterator->var->symtree->n.sym; |
10411 | if (gfc_find_sym_in_expr (ivar, expr)) |
10412 | return false; |
10413 | } |
10414 | return true; |
10415 | } |
10416 | |
10417 | /* CODE is an OMP loop construct. Return true if EXPR matches one of the |
10418 | canonical forms for a bound expression. It may include references to |
10419 | an iteration variable outer to level DEPTH; set OUTER_VARP if so. */ |
10420 | static bool |
10421 | bound_expr_is_canonical (gfc_code *code, int depth, gfc_expr *expr, |
10422 | gfc_symbol **outer_varp) |
10423 | { |
10424 | gfc_expr *expr2 = NULL; |
10425 | |
10426 | /* Rectangular case. */ |
10427 | if (depth == 0 || expr_is_invariant (code, depth, expr)) |
10428 | return true; |
10429 | |
10430 | /* Any simple variable that didn't pass expr_is_invariant must be |
10431 | an outer_var. */ |
10432 | if (expr->expr_type == EXPR_VARIABLE && expr->rank == 0) |
10433 | { |
10434 | *outer_varp = expr->symtree->n.sym; |
10435 | return true; |
10436 | } |
10437 | |
10438 | /* All other permitted forms are binary operators. */ |
10439 | if (expr->expr_type != EXPR_OP) |
10440 | return false; |
10441 | |
10442 | /* Check for plus/minus a loop invariant expr. */ |
10443 | if (expr->value.op.op == INTRINSIC_PLUS |
10444 | || expr->value.op.op == INTRINSIC_MINUS) |
10445 | { |
10446 | if (expr_is_invariant (code, depth, expr: expr->value.op.op1)) |
10447 | expr2 = expr->value.op.op2; |
10448 | else if (expr_is_invariant (code, depth, expr: expr->value.op.op2)) |
10449 | expr2 = expr->value.op.op1; |
10450 | else |
10451 | return false; |
10452 | } |
10453 | else |
10454 | expr2 = expr; |
10455 | |
10456 | /* Check for a product with a loop-invariant expr. */ |
10457 | if (expr2->expr_type == EXPR_OP |
10458 | && expr2->value.op.op == INTRINSIC_TIMES) |
10459 | { |
10460 | if (expr_is_invariant (code, depth, expr: expr2->value.op.op1)) |
10461 | expr2 = expr2->value.op.op2; |
10462 | else if (expr_is_invariant (code, depth, expr: expr2->value.op.op2)) |
10463 | expr2 = expr2->value.op.op1; |
10464 | else |
10465 | return false; |
10466 | } |
10467 | |
10468 | /* What's left must be a reference to an outer loop variable. */ |
10469 | if (expr2->expr_type == EXPR_VARIABLE |
10470 | && expr2->rank == 0 |
10471 | && is_outer_iteration_variable (code, depth, var: expr2->symtree->n.sym)) |
10472 | { |
10473 | *outer_varp = expr2->symtree->n.sym; |
10474 | return true; |
10475 | } |
10476 | |
10477 | return false; |
10478 | } |
10479 | |
10480 | static void |
10481 | resolve_omp_do (gfc_code *code) |
10482 | { |
10483 | gfc_code *do_code, *next; |
10484 | int list, i, count; |
10485 | gfc_omp_namelist *n; |
10486 | gfc_symbol *dovar; |
10487 | const char *name; |
10488 | bool is_simd = false; |
10489 | bool errorp = false; |
10490 | bool perfect_nesting_errorp = false; |
10491 | |
10492 | switch (code->op) |
10493 | { |
10494 | case EXEC_OMP_DISTRIBUTE: name = "!$OMP DISTRIBUTE" ; break; |
10495 | case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: |
10496 | name = "!$OMP DISTRIBUTE PARALLEL DO" ; |
10497 | break; |
10498 | case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: |
10499 | name = "!$OMP DISTRIBUTE PARALLEL DO SIMD" ; |
10500 | is_simd = true; |
10501 | break; |
10502 | case EXEC_OMP_DISTRIBUTE_SIMD: |
10503 | name = "!$OMP DISTRIBUTE SIMD" ; |
10504 | is_simd = true; |
10505 | break; |
10506 | case EXEC_OMP_DO: name = "!$OMP DO" ; break; |
10507 | case EXEC_OMP_DO_SIMD: name = "!$OMP DO SIMD" ; is_simd = true; break; |
10508 | case EXEC_OMP_LOOP: name = "!$OMP LOOP" ; break; |
10509 | case EXEC_OMP_PARALLEL_DO: name = "!$OMP PARALLEL DO" ; break; |
10510 | case EXEC_OMP_PARALLEL_DO_SIMD: |
10511 | name = "!$OMP PARALLEL DO SIMD" ; |
10512 | is_simd = true; |
10513 | break; |
10514 | case EXEC_OMP_PARALLEL_LOOP: name = "!$OMP PARALLEL LOOP" ; break; |
10515 | case EXEC_OMP_PARALLEL_MASKED_TASKLOOP: |
10516 | name = "!$OMP PARALLEL MASKED TASKLOOP" ; |
10517 | break; |
10518 | case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: |
10519 | name = "!$OMP PARALLEL MASKED TASKLOOP SIMD" ; |
10520 | is_simd = true; |
10521 | break; |
10522 | case EXEC_OMP_PARALLEL_MASTER_TASKLOOP: |
10523 | name = "!$OMP PARALLEL MASTER TASKLOOP" ; |
10524 | break; |
10525 | case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: |
10526 | name = "!$OMP PARALLEL MASTER TASKLOOP SIMD" ; |
10527 | is_simd = true; |
10528 | break; |
10529 | case EXEC_OMP_MASKED_TASKLOOP: name = "!$OMP MASKED TASKLOOP" ; break; |
10530 | case EXEC_OMP_MASKED_TASKLOOP_SIMD: |
10531 | name = "!$OMP MASKED TASKLOOP SIMD" ; |
10532 | is_simd = true; |
10533 | break; |
10534 | case EXEC_OMP_MASTER_TASKLOOP: name = "!$OMP MASTER TASKLOOP" ; break; |
10535 | case EXEC_OMP_MASTER_TASKLOOP_SIMD: |
10536 | name = "!$OMP MASTER TASKLOOP SIMD" ; |
10537 | is_simd = true; |
10538 | break; |
10539 | case EXEC_OMP_SIMD: name = "!$OMP SIMD" ; is_simd = true; break; |
10540 | case EXEC_OMP_TARGET_PARALLEL_DO: name = "!$OMP TARGET PARALLEL DO" ; break; |
10541 | case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: |
10542 | name = "!$OMP TARGET PARALLEL DO SIMD" ; |
10543 | is_simd = true; |
10544 | break; |
10545 | case EXEC_OMP_TARGET_PARALLEL_LOOP: |
10546 | name = "!$OMP TARGET PARALLEL LOOP" ; |
10547 | break; |
10548 | case EXEC_OMP_TARGET_SIMD: |
10549 | name = "!$OMP TARGET SIMD" ; |
10550 | is_simd = true; |
10551 | break; |
10552 | case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: |
10553 | name = "!$OMP TARGET TEAMS DISTRIBUTE" ; |
10554 | break; |
10555 | case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: |
10556 | name = "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO" ; |
10557 | break; |
10558 | case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: |
10559 | name = "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD" ; |
10560 | is_simd = true; |
10561 | break; |
10562 | case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: |
10563 | name = "!$OMP TARGET TEAMS DISTRIBUTE SIMD" ; |
10564 | is_simd = true; |
10565 | break; |
10566 | case EXEC_OMP_TARGET_TEAMS_LOOP: name = "!$OMP TARGET TEAMS LOOP" ; break; |
10567 | case EXEC_OMP_TASKLOOP: name = "!$OMP TASKLOOP" ; break; |
10568 | case EXEC_OMP_TASKLOOP_SIMD: |
10569 | name = "!$OMP TASKLOOP SIMD" ; |
10570 | is_simd = true; |
10571 | break; |
10572 | case EXEC_OMP_TEAMS_DISTRIBUTE: name = "!$OMP TEAMS DISTRIBUTE" ; break; |
10573 | case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: |
10574 | name = "!$OMP TEAMS DISTRIBUTE PARALLEL DO" ; |
10575 | break; |
10576 | case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: |
10577 | name = "!$OMP TEAMS DISTRIBUTE PARALLEL DO SIMD" ; |
10578 | is_simd = true; |
10579 | break; |
10580 | case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: |
10581 | name = "!$OMP TEAMS DISTRIBUTE SIMD" ; |
10582 | is_simd = true; |
10583 | break; |
10584 | case EXEC_OMP_TEAMS_LOOP: name = "!$OMP TEAMS LOOP" ; break; |
10585 | default: gcc_unreachable (); |
10586 | } |
10587 | |
10588 | if (code->ext.omp_clauses) |
10589 | resolve_omp_clauses (code, omp_clauses: code->ext.omp_clauses, NULL); |
10590 | |
10591 | do_code = code->block->next; |
10592 | if (code->ext.omp_clauses->orderedc) |
10593 | count = code->ext.omp_clauses->orderedc; |
10594 | else |
10595 | { |
10596 | count = code->ext.omp_clauses->collapse; |
10597 | if (count <= 0) |
10598 | count = 1; |
10599 | } |
10600 | |
10601 | /* While the spec defines the loop nest depth independently of the COLLAPSE |
10602 | clause, in practice the middle end only pays attention to the COLLAPSE |
10603 | depth and treats any further inner loops as the final-loop-body. So |
10604 | here we also check canonical loop nest form only for the number of |
10605 | outer loops specified by the COLLAPSE clause too. */ |
10606 | for (i = 1; i <= count; i++) |
10607 | { |
10608 | gfc_symbol *start_var = NULL, *end_var = NULL; |
10609 | /* Parse errors are not recoverable. */ |
10610 | if (do_code->op == EXEC_DO_WHILE) |
10611 | { |
10612 | gfc_error ("%s cannot be a DO WHILE or DO without loop control " |
10613 | "at %L" , name, &do_code->loc); |
10614 | return; |
10615 | } |
10616 | if (do_code->op == EXEC_DO_CONCURRENT) |
10617 | { |
10618 | gfc_error ("%s cannot be a DO CONCURRENT loop at %L" , name, |
10619 | &do_code->loc); |
10620 | return; |
10621 | } |
10622 | gcc_assert (do_code->op == EXEC_DO); |
10623 | if (do_code->ext.iterator->var->ts.type != BT_INTEGER) |
10624 | { |
10625 | gfc_error ("%s iteration variable must be of type integer at %L" , |
10626 | name, &do_code->loc); |
10627 | errorp = true; |
10628 | } |
10629 | dovar = do_code->ext.iterator->var->symtree->n.sym; |
10630 | if (dovar->attr.threadprivate) |
10631 | { |
10632 | gfc_error ("%s iteration variable must not be THREADPRIVATE " |
10633 | "at %L" , name, &do_code->loc); |
10634 | errorp = true; |
10635 | } |
10636 | if (code->ext.omp_clauses) |
10637 | for (list = 0; list < OMP_LIST_NUM; list++) |
10638 | if (!is_simd || code->ext.omp_clauses->collapse > 1 |
10639 | ? (list != OMP_LIST_PRIVATE && list != OMP_LIST_LASTPRIVATE |
10640 | && list != OMP_LIST_ALLOCATE) |
10641 | : (list != OMP_LIST_PRIVATE && list != OMP_LIST_LASTPRIVATE |
10642 | && list != OMP_LIST_ALLOCATE && list != OMP_LIST_LINEAR)) |
10643 | for (n = code->ext.omp_clauses->lists[list]; n; n = n->next) |
10644 | if (dovar == n->sym) |
10645 | { |
10646 | if (!is_simd || code->ext.omp_clauses->collapse > 1) |
10647 | gfc_error ("%s iteration variable present on clause " |
10648 | "other than PRIVATE, LASTPRIVATE or " |
10649 | "ALLOCATE at %L" , name, &do_code->loc); |
10650 | else |
10651 | gfc_error ("%s iteration variable present on clause " |
10652 | "other than PRIVATE, LASTPRIVATE, ALLOCATE or " |
10653 | "LINEAR at %L" , name, &do_code->loc); |
10654 | errorp = true; |
10655 | } |
10656 | if (is_outer_iteration_variable (code, depth: i, var: dovar)) |
10657 | { |
10658 | gfc_error ("%s iteration variable used in more than one loop at %L" , |
10659 | name, &do_code->loc); |
10660 | errorp = true; |
10661 | } |
10662 | else if (is_intervening_var (code, depth: i, sym: dovar)) |
10663 | { |
10664 | gfc_error ("%s iteration variable at %L is bound in " |
10665 | "intervening code" , |
10666 | name, &do_code->loc); |
10667 | errorp = true; |
10668 | } |
10669 | else if (!bound_expr_is_canonical (code, depth: i, |
10670 | expr: do_code->ext.iterator->start, |
10671 | outer_varp: &start_var)) |
10672 | { |
10673 | gfc_error ("%s loop start expression not in canonical form at %L" , |
10674 | name, &do_code->loc); |
10675 | errorp = true; |
10676 | } |
10677 | else if (expr_uses_intervening_var (code, depth: i, |
10678 | expr: do_code->ext.iterator->start)) |
10679 | { |
10680 | gfc_error ("%s loop start expression at %L uses variable bound in " |
10681 | "intervening code" , |
10682 | name, &do_code->loc); |
10683 | errorp = true; |
10684 | } |
10685 | else if (!bound_expr_is_canonical (code, depth: i, |
10686 | expr: do_code->ext.iterator->end, |
10687 | outer_varp: &end_var)) |
10688 | { |
10689 | gfc_error ("%s loop end expression not in canonical form at %L" , |
10690 | name, &do_code->loc); |
10691 | errorp = true; |
10692 | } |
10693 | else if (expr_uses_intervening_var (code, depth: i, |
10694 | expr: do_code->ext.iterator->end)) |
10695 | { |
10696 | gfc_error ("%s loop end expression at %L uses variable bound in " |
10697 | "intervening code" , |
10698 | name, &do_code->loc); |
10699 | errorp = true; |
10700 | } |
10701 | else if (start_var && end_var && start_var != end_var) |
10702 | { |
10703 | gfc_error ("%s loop bounds reference different " |
10704 | "iteration variables at %L" , name, &do_code->loc); |
10705 | errorp = true; |
10706 | } |
10707 | else if (!expr_is_invariant (code, depth: i, expr: do_code->ext.iterator->step)) |
10708 | { |
10709 | gfc_error ("%s loop increment not in canonical form at %L" , |
10710 | name, &do_code->loc); |
10711 | errorp = true; |
10712 | } |
10713 | else if (expr_uses_intervening_var (code, depth: i, |
10714 | expr: do_code->ext.iterator->step)) |
10715 | { |
10716 | gfc_error ("%s loop increment expression at %L uses variable " |
10717 | "bound in intervening code" , |
10718 | name, &do_code->loc); |
10719 | errorp = true; |
10720 | } |
10721 | if (start_var || end_var) |
10722 | code->ext.omp_clauses->non_rectangular = 1; |
10723 | |
10724 | /* Only parse loop body into nested loop and intervening code if |
10725 | there are supposed to be more loops in the nest to collapse. */ |
10726 | if (i == count) |
10727 | break; |
10728 | |
10729 | next = find_nested_loop_in_chain (chain: do_code->block->next); |
10730 | |
10731 | if (!next) |
10732 | { |
10733 | /* Parse error, can't recover from this. */ |
10734 | gfc_error ("not enough DO loops for collapsed %s (level %d) at %L" , |
10735 | name, i, &code->loc); |
10736 | return; |
10737 | } |
10738 | else if (next != do_code->block->next || next->next) |
10739 | /* Imperfectly nested loop found. */ |
10740 | { |
10741 | /* Only diagnose violation of imperfect nesting constraints once. */ |
10742 | if (!perfect_nesting_errorp) |
10743 | { |
10744 | if (code->ext.omp_clauses->orderedc) |
10745 | { |
10746 | gfc_error ("%s inner loops must be perfectly nested with " |
10747 | "ORDERED clause at %L" , |
10748 | name, &code->loc); |
10749 | perfect_nesting_errorp = true; |
10750 | } |
10751 | else if (code->ext.omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN]) |
10752 | { |
10753 | gfc_error ("%s inner loops must be perfectly nested with " |
10754 | "REDUCTION INSCAN clause at %L" , |
10755 | name, &code->loc); |
10756 | perfect_nesting_errorp = true; |
10757 | } |
10758 | /* FIXME: Also diagnose for TILE directives. */ |
10759 | if (perfect_nesting_errorp) |
10760 | errorp = true; |
10761 | } |
10762 | if (diagnose_intervening_code_errors (chain: do_code->block->next, |
10763 | name, nested: next)) |
10764 | errorp = true; |
10765 | } |
10766 | do_code = next; |
10767 | } |
10768 | |
10769 | /* Give up now if we found any constraint violations. */ |
10770 | if (errorp) |
10771 | return; |
10772 | |
10773 | restructure_intervening_code (chainp: &(code->block->next), outer_loop: code, count); |
10774 | } |
10775 | |
10776 | |
10777 | static gfc_statement |
10778 | omp_code_to_statement (gfc_code *code) |
10779 | { |
10780 | switch (code->op) |
10781 | { |
10782 | case EXEC_OMP_PARALLEL: |
10783 | return ST_OMP_PARALLEL; |
10784 | case EXEC_OMP_PARALLEL_MASKED: |
10785 | return ST_OMP_PARALLEL_MASKED; |
10786 | case EXEC_OMP_PARALLEL_MASKED_TASKLOOP: |
10787 | return ST_OMP_PARALLEL_MASKED_TASKLOOP; |
10788 | case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: |
10789 | return ST_OMP_PARALLEL_MASKED_TASKLOOP_SIMD; |
10790 | case EXEC_OMP_PARALLEL_MASTER: |
10791 | return ST_OMP_PARALLEL_MASTER; |
10792 | case EXEC_OMP_PARALLEL_MASTER_TASKLOOP: |
10793 | return ST_OMP_PARALLEL_MASTER_TASKLOOP; |
10794 | case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: |
10795 | return ST_OMP_PARALLEL_MASTER_TASKLOOP_SIMD; |
10796 | case EXEC_OMP_PARALLEL_SECTIONS: |
10797 | return ST_OMP_PARALLEL_SECTIONS; |
10798 | case EXEC_OMP_SECTIONS: |
10799 | return ST_OMP_SECTIONS; |
10800 | case EXEC_OMP_ORDERED: |
10801 | return ST_OMP_ORDERED; |
10802 | case EXEC_OMP_CRITICAL: |
10803 | return ST_OMP_CRITICAL; |
10804 | case EXEC_OMP_MASKED: |
10805 | return ST_OMP_MASKED; |
10806 | case EXEC_OMP_MASKED_TASKLOOP: |
10807 | return ST_OMP_MASKED_TASKLOOP; |
10808 | case EXEC_OMP_MASKED_TASKLOOP_SIMD: |
10809 | return ST_OMP_MASKED_TASKLOOP_SIMD; |
10810 | case EXEC_OMP_MASTER: |
10811 | return ST_OMP_MASTER; |
10812 | case EXEC_OMP_MASTER_TASKLOOP: |
10813 | return ST_OMP_MASTER_TASKLOOP; |
10814 | case EXEC_OMP_MASTER_TASKLOOP_SIMD: |
10815 | return ST_OMP_MASTER_TASKLOOP_SIMD; |
10816 | case EXEC_OMP_SINGLE: |
10817 | return ST_OMP_SINGLE; |
10818 | case EXEC_OMP_TASK: |
10819 | return ST_OMP_TASK; |
10820 | case EXEC_OMP_WORKSHARE: |
10821 | return ST_OMP_WORKSHARE; |
10822 | case EXEC_OMP_PARALLEL_WORKSHARE: |
10823 | return ST_OMP_PARALLEL_WORKSHARE; |
10824 | case EXEC_OMP_DO: |
10825 | return ST_OMP_DO; |
10826 | case EXEC_OMP_LOOP: |
10827 | return ST_OMP_LOOP; |
10828 | case EXEC_OMP_ALLOCATE: |
10829 | return ST_OMP_ALLOCATE_EXEC; |
10830 | case EXEC_OMP_ALLOCATORS: |
10831 | return ST_OMP_ALLOCATORS; |
10832 | case EXEC_OMP_ASSUME: |
10833 | return ST_OMP_ASSUME; |
10834 | case EXEC_OMP_ATOMIC: |
10835 | return ST_OMP_ATOMIC; |
10836 | case EXEC_OMP_BARRIER: |
10837 | return ST_OMP_BARRIER; |
10838 | case EXEC_OMP_CANCEL: |
10839 | return ST_OMP_CANCEL; |
10840 | case EXEC_OMP_CANCELLATION_POINT: |
10841 | return ST_OMP_CANCELLATION_POINT; |
10842 | case EXEC_OMP_ERROR: |
10843 | return ST_OMP_ERROR; |
10844 | case EXEC_OMP_FLUSH: |
10845 | return ST_OMP_FLUSH; |
10846 | case EXEC_OMP_DISTRIBUTE: |
10847 | return ST_OMP_DISTRIBUTE; |
10848 | case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: |
10849 | return ST_OMP_DISTRIBUTE_PARALLEL_DO; |
10850 | case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: |
10851 | return ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD; |
10852 | case EXEC_OMP_DISTRIBUTE_SIMD: |
10853 | return ST_OMP_DISTRIBUTE_SIMD; |
10854 | case EXEC_OMP_DO_SIMD: |
10855 | return ST_OMP_DO_SIMD; |
10856 | case EXEC_OMP_SCAN: |
10857 | return ST_OMP_SCAN; |
10858 | case EXEC_OMP_SCOPE: |
10859 | return ST_OMP_SCOPE; |
10860 | case EXEC_OMP_SIMD: |
10861 | return ST_OMP_SIMD; |
10862 | case EXEC_OMP_TARGET: |
10863 | return ST_OMP_TARGET; |
10864 | case EXEC_OMP_TARGET_DATA: |
10865 | return ST_OMP_TARGET_DATA; |
10866 | case EXEC_OMP_TARGET_ENTER_DATA: |
10867 | return ST_OMP_TARGET_ENTER_DATA; |
10868 | case EXEC_OMP_TARGET_EXIT_DATA: |
10869 | return ST_OMP_TARGET_EXIT_DATA; |
10870 | case EXEC_OMP_TARGET_PARALLEL: |
10871 | return ST_OMP_TARGET_PARALLEL; |
10872 | case EXEC_OMP_TARGET_PARALLEL_DO: |
10873 | return ST_OMP_TARGET_PARALLEL_DO; |
10874 | case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: |
10875 | return ST_OMP_TARGET_PARALLEL_DO_SIMD; |
10876 | case EXEC_OMP_TARGET_PARALLEL_LOOP: |
10877 | return ST_OMP_TARGET_PARALLEL_LOOP; |
10878 | case EXEC_OMP_TARGET_SIMD: |
10879 | return ST_OMP_TARGET_SIMD; |
10880 | case EXEC_OMP_TARGET_TEAMS: |
10881 | return ST_OMP_TARGET_TEAMS; |
10882 | case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: |
10883 | return ST_OMP_TARGET_TEAMS_DISTRIBUTE; |
10884 | case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: |
10885 | return ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO; |
10886 | case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: |
10887 | return ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD; |
10888 | case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: |
10889 | return ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD; |
10890 | case EXEC_OMP_TARGET_TEAMS_LOOP: |
10891 | return ST_OMP_TARGET_TEAMS_LOOP; |
10892 | case EXEC_OMP_TARGET_UPDATE: |
10893 | return ST_OMP_TARGET_UPDATE; |
10894 | case EXEC_OMP_TASKGROUP: |
10895 | return ST_OMP_TASKGROUP; |
10896 | case EXEC_OMP_TASKLOOP: |
10897 | return ST_OMP_TASKLOOP; |
10898 | case EXEC_OMP_TASKLOOP_SIMD: |
10899 | return ST_OMP_TASKLOOP_SIMD; |
10900 | case EXEC_OMP_TASKWAIT: |
10901 | return ST_OMP_TASKWAIT; |
10902 | case EXEC_OMP_TASKYIELD: |
10903 | return ST_OMP_TASKYIELD; |
10904 | case EXEC_OMP_TEAMS: |
10905 | return ST_OMP_TEAMS; |
10906 | case EXEC_OMP_TEAMS_DISTRIBUTE: |
10907 | return ST_OMP_TEAMS_DISTRIBUTE; |
10908 | case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: |
10909 | return ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO; |
10910 | case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: |
10911 | return ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD; |
10912 | case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: |
10913 | return ST_OMP_TEAMS_DISTRIBUTE_SIMD; |
10914 | case EXEC_OMP_TEAMS_LOOP: |
10915 | return ST_OMP_TEAMS_LOOP; |
10916 | case EXEC_OMP_PARALLEL_DO: |
10917 | return ST_OMP_PARALLEL_DO; |
10918 | case EXEC_OMP_PARALLEL_DO_SIMD: |
10919 | return ST_OMP_PARALLEL_DO_SIMD; |
10920 | case EXEC_OMP_PARALLEL_LOOP: |
10921 | return ST_OMP_PARALLEL_LOOP; |
10922 | case EXEC_OMP_DEPOBJ: |
10923 | return ST_OMP_DEPOBJ; |
10924 | default: |
10925 | gcc_unreachable (); |
10926 | } |
10927 | } |
10928 | |
10929 | static gfc_statement |
10930 | oacc_code_to_statement (gfc_code *code) |
10931 | { |
10932 | switch (code->op) |
10933 | { |
10934 | case EXEC_OACC_PARALLEL: |
10935 | return ST_OACC_PARALLEL; |
10936 | case EXEC_OACC_KERNELS: |
10937 | return ST_OACC_KERNELS; |
10938 | case EXEC_OACC_SERIAL: |
10939 | return ST_OACC_SERIAL; |
10940 | case EXEC_OACC_DATA: |
10941 | return ST_OACC_DATA; |
10942 | case EXEC_OACC_HOST_DATA: |
10943 | return ST_OACC_HOST_DATA; |
10944 | case EXEC_OACC_PARALLEL_LOOP: |
10945 | return ST_OACC_PARALLEL_LOOP; |
10946 | case EXEC_OACC_KERNELS_LOOP: |
10947 | return ST_OACC_KERNELS_LOOP; |
10948 | case EXEC_OACC_SERIAL_LOOP: |
10949 | return ST_OACC_SERIAL_LOOP; |
10950 | case EXEC_OACC_LOOP: |
10951 | return ST_OACC_LOOP; |
10952 | case EXEC_OACC_ATOMIC: |
10953 | return ST_OACC_ATOMIC; |
10954 | case EXEC_OACC_ROUTINE: |
10955 | return ST_OACC_ROUTINE; |
10956 | case EXEC_OACC_UPDATE: |
10957 | return ST_OACC_UPDATE; |
10958 | case EXEC_OACC_WAIT: |
10959 | return ST_OACC_WAIT; |
10960 | case EXEC_OACC_CACHE: |
10961 | return ST_OACC_CACHE; |
10962 | case EXEC_OACC_ENTER_DATA: |
10963 | return ST_OACC_ENTER_DATA; |
10964 | case EXEC_OACC_EXIT_DATA: |
10965 | return ST_OACC_EXIT_DATA; |
10966 | case EXEC_OACC_DECLARE: |
10967 | return ST_OACC_DECLARE; |
10968 | default: |
10969 | gcc_unreachable (); |
10970 | } |
10971 | } |
10972 | |
10973 | static void |
10974 | resolve_oacc_directive_inside_omp_region (gfc_code *code) |
10975 | { |
10976 | if (omp_current_ctx != NULL && omp_current_ctx->is_openmp) |
10977 | { |
10978 | gfc_statement st = omp_code_to_statement (code: omp_current_ctx->code); |
10979 | gfc_statement oacc_st = oacc_code_to_statement (code); |
10980 | gfc_error ("The %s directive cannot be specified within " |
10981 | "a %s region at %L" , gfc_ascii_statement (oacc_st), |
10982 | gfc_ascii_statement (st), &code->loc); |
10983 | } |
10984 | } |
10985 | |
10986 | static void |
10987 | resolve_omp_directive_inside_oacc_region (gfc_code *code) |
10988 | { |
10989 | if (omp_current_ctx != NULL && !omp_current_ctx->is_openmp) |
10990 | { |
10991 | gfc_statement st = oacc_code_to_statement (code: omp_current_ctx->code); |
10992 | gfc_statement omp_st = omp_code_to_statement (code); |
10993 | gfc_error ("The %s directive cannot be specified within " |
10994 | "a %s region at %L" , gfc_ascii_statement (omp_st), |
10995 | gfc_ascii_statement (st), &code->loc); |
10996 | } |
10997 | } |
10998 | |
10999 | |
11000 | static void |
11001 | resolve_oacc_nested_loops (gfc_code *code, gfc_code* do_code, int collapse, |
11002 | const char *clause) |
11003 | { |
11004 | gfc_symbol *dovar; |
11005 | gfc_code *c; |
11006 | int i; |
11007 | |
11008 | for (i = 1; i <= collapse; i++) |
11009 | { |
11010 | if (do_code->op == EXEC_DO_WHILE) |
11011 | { |
11012 | gfc_error ("!$ACC LOOP cannot be a DO WHILE or DO without loop control " |
11013 | "at %L" , &do_code->loc); |
11014 | break; |
11015 | } |
11016 | if (do_code->op == EXEC_DO_CONCURRENT) |
11017 | { |
11018 | gfc_error ("!$ACC LOOP cannot be a DO CONCURRENT loop at %L" , |
11019 | &do_code->loc); |
11020 | break; |
11021 | } |
11022 | gcc_assert (do_code->op == EXEC_DO); |
11023 | if (do_code->ext.iterator->var->ts.type != BT_INTEGER) |
11024 | gfc_error ("!$ACC LOOP iteration variable must be of type integer at %L" , |
11025 | &do_code->loc); |
11026 | dovar = do_code->ext.iterator->var->symtree->n.sym; |
11027 | if (i > 1) |
11028 | { |
11029 | gfc_code *do_code2 = code->block->next; |
11030 | int j; |
11031 | |
11032 | for (j = 1; j < i; j++) |
11033 | { |
11034 | gfc_symbol *ivar = do_code2->ext.iterator->var->symtree->n.sym; |
11035 | if (dovar == ivar |
11036 | || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->start) |
11037 | || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->end) |
11038 | || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->step)) |
11039 | { |
11040 | gfc_error ("!$ACC LOOP %s loops don't form rectangular " |
11041 | "iteration space at %L" , clause, &do_code->loc); |
11042 | break; |
11043 | } |
11044 | do_code2 = do_code2->block->next; |
11045 | } |
11046 | } |
11047 | if (i == collapse) |
11048 | break; |
11049 | for (c = do_code->next; c; c = c->next) |
11050 | if (c->op != EXEC_NOP && c->op != EXEC_CONTINUE) |
11051 | { |
11052 | gfc_error ("%s !$ACC LOOP loops not perfectly nested at %L" , |
11053 | clause, &c->loc); |
11054 | break; |
11055 | } |
11056 | if (c) |
11057 | break; |
11058 | do_code = do_code->block; |
11059 | if (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE |
11060 | && do_code->op != EXEC_DO_CONCURRENT) |
11061 | { |
11062 | gfc_error ("not enough DO loops for %s !$ACC LOOP at %L" , |
11063 | clause, &code->loc); |
11064 | break; |
11065 | } |
11066 | do_code = do_code->next; |
11067 | if (do_code == NULL |
11068 | || (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE |
11069 | && do_code->op != EXEC_DO_CONCURRENT)) |
11070 | { |
11071 | gfc_error ("not enough DO loops for %s !$ACC LOOP at %L" , |
11072 | clause, &code->loc); |
11073 | break; |
11074 | } |
11075 | } |
11076 | } |
11077 | |
11078 | |
11079 | static void |
11080 | resolve_oacc_loop_blocks (gfc_code *code) |
11081 | { |
11082 | if (!oacc_is_loop (code)) |
11083 | return; |
11084 | |
11085 | if (code->ext.omp_clauses->tile_list && code->ext.omp_clauses->gang |
11086 | && code->ext.omp_clauses->worker && code->ext.omp_clauses->vector) |
11087 | gfc_error ("Tiled loop cannot be parallelized across gangs, workers and " |
11088 | "vectors at the same time at %L" , &code->loc); |
11089 | |
11090 | if (code->ext.omp_clauses->tile_list) |
11091 | { |
11092 | gfc_expr_list *el; |
11093 | for (el = code->ext.omp_clauses->tile_list; el; el = el->next) |
11094 | { |
11095 | if (el->expr == NULL) |
11096 | { |
11097 | /* NULL expressions are used to represent '*' arguments. |
11098 | Convert those to a 0 expressions. */ |
11099 | el->expr = gfc_get_constant_expr (BT_INTEGER, |
11100 | gfc_default_integer_kind, |
11101 | &code->loc); |
11102 | mpz_set_si (el->expr->value.integer, 0); |
11103 | } |
11104 | else |
11105 | { |
11106 | resolve_positive_int_expr (expr: el->expr, clause: "TILE" ); |
11107 | if (el->expr->expr_type != EXPR_CONSTANT) |
11108 | gfc_error ("TILE requires constant expression at %L" , |
11109 | &code->loc); |
11110 | } |
11111 | } |
11112 | } |
11113 | } |
11114 | |
11115 | |
11116 | void |
11117 | gfc_resolve_oacc_blocks (gfc_code *code, gfc_namespace *ns) |
11118 | { |
11119 | fortran_omp_context ctx; |
11120 | gfc_omp_clauses *omp_clauses = code->ext.omp_clauses; |
11121 | gfc_omp_namelist *n; |
11122 | int list; |
11123 | |
11124 | resolve_oacc_loop_blocks (code); |
11125 | |
11126 | ctx.code = code; |
11127 | ctx.sharing_clauses = new hash_set<gfc_symbol *>; |
11128 | ctx.private_iterators = new hash_set<gfc_symbol *>; |
11129 | ctx.previous = omp_current_ctx; |
11130 | ctx.is_openmp = false; |
11131 | omp_current_ctx = &ctx; |
11132 | |
11133 | for (list = 0; list < OMP_LIST_NUM; list++) |
11134 | switch (list) |
11135 | { |
11136 | case OMP_LIST_PRIVATE: |
11137 | for (n = omp_clauses->lists[list]; n; n = n->next) |
11138 | ctx.sharing_clauses->add (k: n->sym); |
11139 | break; |
11140 | default: |
11141 | break; |
11142 | } |
11143 | |
11144 | gfc_resolve_blocks (code->block, ns); |
11145 | |
11146 | omp_current_ctx = ctx.previous; |
11147 | delete ctx.sharing_clauses; |
11148 | delete ctx.private_iterators; |
11149 | } |
11150 | |
11151 | |
11152 | static void |
11153 | resolve_oacc_loop (gfc_code *code) |
11154 | { |
11155 | gfc_code *do_code; |
11156 | int collapse; |
11157 | |
11158 | if (code->ext.omp_clauses) |
11159 | resolve_omp_clauses (code, omp_clauses: code->ext.omp_clauses, NULL, openacc: true); |
11160 | |
11161 | do_code = code->block->next; |
11162 | collapse = code->ext.omp_clauses->collapse; |
11163 | |
11164 | /* Both collapsed and tiled loops are lowered the same way, but are not |
11165 | compatible. In gfc_trans_omp_do, the tile is prioritized. */ |
11166 | if (code->ext.omp_clauses->tile_list) |
11167 | { |
11168 | int num = 0; |
11169 | gfc_expr_list *el; |
11170 | for (el = code->ext.omp_clauses->tile_list; el; el = el->next) |
11171 | ++num; |
11172 | resolve_oacc_nested_loops (code, do_code: code->block->next, collapse: num, clause: "tiled" ); |
11173 | return; |
11174 | } |
11175 | |
11176 | if (collapse <= 0) |
11177 | collapse = 1; |
11178 | resolve_oacc_nested_loops (code, do_code, collapse, clause: "collapsed" ); |
11179 | } |
11180 | |
11181 | void |
11182 | gfc_resolve_oacc_declare (gfc_namespace *ns) |
11183 | { |
11184 | int list; |
11185 | gfc_omp_namelist *n; |
11186 | gfc_oacc_declare *oc; |
11187 | |
11188 | if (ns->oacc_declare == NULL) |
11189 | return; |
11190 | |
11191 | for (oc = ns->oacc_declare; oc; oc = oc->next) |
11192 | { |
11193 | for (list = 0; list < OMP_LIST_NUM; list++) |
11194 | for (n = oc->clauses->lists[list]; n; n = n->next) |
11195 | { |
11196 | n->sym->mark = 0; |
11197 | if (n->sym->attr.flavor != FL_VARIABLE |
11198 | && (n->sym->attr.flavor != FL_PROCEDURE |
11199 | || n->sym->result != n->sym)) |
11200 | { |
11201 | gfc_error ("Object %qs is not a variable at %L" , |
11202 | n->sym->name, &oc->loc); |
11203 | continue; |
11204 | } |
11205 | |
11206 | if (n->expr && n->expr->ref->type == REF_ARRAY) |
11207 | { |
11208 | gfc_error ("Array sections: %qs not allowed in" |
11209 | " !$ACC DECLARE at %L" , n->sym->name, &oc->loc); |
11210 | continue; |
11211 | } |
11212 | } |
11213 | |
11214 | for (n = oc->clauses->lists[OMP_LIST_DEVICE_RESIDENT]; n; n = n->next) |
11215 | check_array_not_assumed (sym: n->sym, loc: oc->loc, name: "DEVICE_RESIDENT" ); |
11216 | } |
11217 | |
11218 | for (oc = ns->oacc_declare; oc; oc = oc->next) |
11219 | { |
11220 | for (list = 0; list < OMP_LIST_NUM; list++) |
11221 | for (n = oc->clauses->lists[list]; n; n = n->next) |
11222 | { |
11223 | if (n->sym->mark) |
11224 | { |
11225 | gfc_error ("Symbol %qs present on multiple clauses at %L" , |
11226 | n->sym->name, &oc->loc); |
11227 | continue; |
11228 | } |
11229 | else |
11230 | n->sym->mark = 1; |
11231 | } |
11232 | } |
11233 | |
11234 | for (oc = ns->oacc_declare; oc; oc = oc->next) |
11235 | { |
11236 | for (list = 0; list < OMP_LIST_NUM; list++) |
11237 | for (n = oc->clauses->lists[list]; n; n = n->next) |
11238 | n->sym->mark = 0; |
11239 | } |
11240 | } |
11241 | |
11242 | |
11243 | void |
11244 | gfc_resolve_oacc_routines (gfc_namespace *ns) |
11245 | { |
11246 | for (gfc_oacc_routine_name *orn = ns->oacc_routine_names; |
11247 | orn; |
11248 | orn = orn->next) |
11249 | { |
11250 | gfc_symbol *sym = orn->sym; |
11251 | if (!sym->attr.external |
11252 | && !sym->attr.function |
11253 | && !sym->attr.subroutine) |
11254 | { |
11255 | gfc_error ("NAME %qs does not refer to a subroutine or function" |
11256 | " in !$ACC ROUTINE ( NAME ) at %L" , sym->name, &orn->loc); |
11257 | continue; |
11258 | } |
11259 | if (!gfc_add_omp_declare_target (&sym->attr, sym->name, &orn->loc)) |
11260 | { |
11261 | gfc_error ("NAME %qs invalid" |
11262 | " in !$ACC ROUTINE ( NAME ) at %L" , sym->name, &orn->loc); |
11263 | continue; |
11264 | } |
11265 | } |
11266 | } |
11267 | |
11268 | |
11269 | void |
11270 | gfc_resolve_oacc_directive (gfc_code *code, gfc_namespace *ns ATTRIBUTE_UNUSED) |
11271 | { |
11272 | resolve_oacc_directive_inside_omp_region (code); |
11273 | |
11274 | switch (code->op) |
11275 | { |
11276 | case EXEC_OACC_PARALLEL: |
11277 | case EXEC_OACC_KERNELS: |
11278 | case EXEC_OACC_SERIAL: |
11279 | case EXEC_OACC_DATA: |
11280 | case EXEC_OACC_HOST_DATA: |
11281 | case EXEC_OACC_UPDATE: |
11282 | case EXEC_OACC_ENTER_DATA: |
11283 | case EXEC_OACC_EXIT_DATA: |
11284 | case EXEC_OACC_WAIT: |
11285 | case EXEC_OACC_CACHE: |
11286 | resolve_omp_clauses (code, omp_clauses: code->ext.omp_clauses, NULL, openacc: true); |
11287 | break; |
11288 | case EXEC_OACC_PARALLEL_LOOP: |
11289 | case EXEC_OACC_KERNELS_LOOP: |
11290 | case EXEC_OACC_SERIAL_LOOP: |
11291 | case EXEC_OACC_LOOP: |
11292 | resolve_oacc_loop (code); |
11293 | break; |
11294 | case EXEC_OACC_ATOMIC: |
11295 | resolve_omp_atomic (code); |
11296 | break; |
11297 | default: |
11298 | break; |
11299 | } |
11300 | } |
11301 | |
11302 | |
11303 | static void |
11304 | resolve_omp_target (gfc_code *code) |
11305 | { |
11306 | #define GFC_IS_TEAMS_CONSTRUCT(op) \ |
11307 | (op == EXEC_OMP_TEAMS \ |
11308 | || op == EXEC_OMP_TEAMS_DISTRIBUTE \ |
11309 | || op == EXEC_OMP_TEAMS_DISTRIBUTE_SIMD \ |
11310 | || op == EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO \ |
11311 | || op == EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD \ |
11312 | || op == EXEC_OMP_TEAMS_LOOP) |
11313 | |
11314 | if (!code->ext.omp_clauses->contains_teams_construct) |
11315 | return; |
11316 | gfc_code *c = code->block->next; |
11317 | if (c->op == EXEC_BLOCK) |
11318 | c = c->ext.block.ns->code; |
11319 | if (code->ext.omp_clauses->target_first_st_is_teams |
11320 | && ((GFC_IS_TEAMS_CONSTRUCT (c->op) && c->next == NULL) |
11321 | || (c->op == EXEC_BLOCK |
11322 | && c->next |
11323 | && GFC_IS_TEAMS_CONSTRUCT (c->next->op) |
11324 | && c->next->next == NULL))) |
11325 | return; |
11326 | while (c && !GFC_IS_TEAMS_CONSTRUCT (c->op)) |
11327 | c = c->next; |
11328 | if (c) |
11329 | gfc_error ("!$OMP TARGET region at %L with a nested TEAMS at %L may not " |
11330 | "contain any other statement, declaration or directive outside " |
11331 | "of the single TEAMS construct" , &c->loc, &code->loc); |
11332 | else |
11333 | gfc_error ("!$OMP TARGET region at %L with a nested TEAMS may not " |
11334 | "contain any other statement, declaration or directive outside " |
11335 | "of the single TEAMS construct" , &code->loc); |
11336 | #undef GFC_IS_TEAMS_CONSTRUCT |
11337 | } |
11338 | |
11339 | |
11340 | /* Resolve OpenMP directive clauses and check various requirements |
11341 | of each directive. */ |
11342 | |
11343 | void |
11344 | gfc_resolve_omp_directive (gfc_code *code, gfc_namespace *ns) |
11345 | { |
11346 | resolve_omp_directive_inside_oacc_region (code); |
11347 | |
11348 | if (code->op != EXEC_OMP_ATOMIC) |
11349 | gfc_maybe_initialize_eh (); |
11350 | |
11351 | switch (code->op) |
11352 | { |
11353 | case EXEC_OMP_DISTRIBUTE: |
11354 | case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: |
11355 | case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: |
11356 | case EXEC_OMP_DISTRIBUTE_SIMD: |
11357 | case EXEC_OMP_DO: |
11358 | case EXEC_OMP_DO_SIMD: |
11359 | case EXEC_OMP_LOOP: |
11360 | case EXEC_OMP_PARALLEL_DO: |
11361 | case EXEC_OMP_PARALLEL_DO_SIMD: |
11362 | case EXEC_OMP_PARALLEL_LOOP: |
11363 | case EXEC_OMP_PARALLEL_MASKED_TASKLOOP: |
11364 | case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: |
11365 | case EXEC_OMP_PARALLEL_MASTER_TASKLOOP: |
11366 | case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: |
11367 | case EXEC_OMP_MASKED_TASKLOOP: |
11368 | case EXEC_OMP_MASKED_TASKLOOP_SIMD: |
11369 | case EXEC_OMP_MASTER_TASKLOOP: |
11370 | case EXEC_OMP_MASTER_TASKLOOP_SIMD: |
11371 | case EXEC_OMP_SIMD: |
11372 | case EXEC_OMP_TARGET_PARALLEL_DO: |
11373 | case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: |
11374 | case EXEC_OMP_TARGET_PARALLEL_LOOP: |
11375 | case EXEC_OMP_TARGET_SIMD: |
11376 | case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: |
11377 | case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: |
11378 | case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: |
11379 | case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: |
11380 | case EXEC_OMP_TARGET_TEAMS_LOOP: |
11381 | case EXEC_OMP_TASKLOOP: |
11382 | case EXEC_OMP_TASKLOOP_SIMD: |
11383 | case EXEC_OMP_TEAMS_DISTRIBUTE: |
11384 | case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: |
11385 | case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: |
11386 | case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: |
11387 | case EXEC_OMP_TEAMS_LOOP: |
11388 | resolve_omp_do (code); |
11389 | break; |
11390 | case EXEC_OMP_TARGET: |
11391 | resolve_omp_target (code); |
11392 | gcc_fallthrough (); |
11393 | case EXEC_OMP_ALLOCATE: |
11394 | case EXEC_OMP_ALLOCATORS: |
11395 | case EXEC_OMP_ASSUME: |
11396 | case EXEC_OMP_CANCEL: |
11397 | case EXEC_OMP_ERROR: |
11398 | case EXEC_OMP_MASKED: |
11399 | case EXEC_OMP_ORDERED: |
11400 | case EXEC_OMP_PARALLEL_WORKSHARE: |
11401 | case EXEC_OMP_PARALLEL: |
11402 | case EXEC_OMP_PARALLEL_MASKED: |
11403 | case EXEC_OMP_PARALLEL_MASTER: |
11404 | case EXEC_OMP_PARALLEL_SECTIONS: |
11405 | case EXEC_OMP_SCOPE: |
11406 | case EXEC_OMP_SECTIONS: |
11407 | case EXEC_OMP_SINGLE: |
11408 | case EXEC_OMP_TARGET_DATA: |
11409 | case EXEC_OMP_TARGET_ENTER_DATA: |
11410 | case EXEC_OMP_TARGET_EXIT_DATA: |
11411 | case EXEC_OMP_TARGET_PARALLEL: |
11412 | case EXEC_OMP_TARGET_TEAMS: |
11413 | case EXEC_OMP_TASK: |
11414 | case EXEC_OMP_TASKWAIT: |
11415 | case EXEC_OMP_TEAMS: |
11416 | case EXEC_OMP_WORKSHARE: |
11417 | case EXEC_OMP_DEPOBJ: |
11418 | if (code->ext.omp_clauses) |
11419 | resolve_omp_clauses (code, omp_clauses: code->ext.omp_clauses, NULL); |
11420 | break; |
11421 | case EXEC_OMP_TARGET_UPDATE: |
11422 | if (code->ext.omp_clauses) |
11423 | resolve_omp_clauses (code, omp_clauses: code->ext.omp_clauses, NULL); |
11424 | if (code->ext.omp_clauses == NULL |
11425 | || (code->ext.omp_clauses->lists[OMP_LIST_TO] == NULL |
11426 | && code->ext.omp_clauses->lists[OMP_LIST_FROM] == NULL)) |
11427 | gfc_error ("OMP TARGET UPDATE at %L requires at least one TO or " |
11428 | "FROM clause" , &code->loc); |
11429 | break; |
11430 | case EXEC_OMP_ATOMIC: |
11431 | resolve_omp_clauses (code, omp_clauses: code->block->ext.omp_clauses, NULL); |
11432 | resolve_omp_atomic (code); |
11433 | break; |
11434 | case EXEC_OMP_CRITICAL: |
11435 | resolve_omp_clauses (code, omp_clauses: code->ext.omp_clauses, NULL); |
11436 | if (!code->ext.omp_clauses->critical_name |
11437 | && code->ext.omp_clauses->hint |
11438 | && code->ext.omp_clauses->hint->ts.type == BT_INTEGER |
11439 | && code->ext.omp_clauses->hint->expr_type == EXPR_CONSTANT |
11440 | && mpz_sgn (code->ext.omp_clauses->hint->value.integer) != 0) |
11441 | gfc_error ("OMP CRITICAL at %L with HINT clause requires a NAME, " |
11442 | "except when omp_sync_hint_none is used" , &code->loc); |
11443 | break; |
11444 | case EXEC_OMP_SCAN: |
11445 | /* Flag is only used to checking, hence, it is unset afterwards. */ |
11446 | if (!code->ext.omp_clauses->if_present) |
11447 | gfc_error ("Unexpected !$OMP SCAN at %L outside loop construct with " |
11448 | "%<inscan%> REDUCTION clause" , &code->loc); |
11449 | code->ext.omp_clauses->if_present = false; |
11450 | resolve_omp_clauses (code, omp_clauses: code->ext.omp_clauses, ns); |
11451 | break; |
11452 | default: |
11453 | break; |
11454 | } |
11455 | } |
11456 | |
11457 | /* Resolve !$omp declare simd constructs in NS. */ |
11458 | |
11459 | void |
11460 | gfc_resolve_omp_declare_simd (gfc_namespace *ns) |
11461 | { |
11462 | gfc_omp_declare_simd *ods; |
11463 | |
11464 | for (ods = ns->omp_declare_simd; ods; ods = ods->next) |
11465 | { |
11466 | if (ods->proc_name != NULL |
11467 | && ods->proc_name != ns->proc_name) |
11468 | gfc_error ("!$OMP DECLARE SIMD should refer to containing procedure " |
11469 | "%qs at %L" , ns->proc_name->name, &ods->where); |
11470 | if (ods->clauses) |
11471 | resolve_omp_clauses (NULL, omp_clauses: ods->clauses, ns); |
11472 | } |
11473 | } |
11474 | |
11475 | struct omp_udr_callback_data |
11476 | { |
11477 | gfc_omp_udr *omp_udr; |
11478 | bool is_initializer; |
11479 | }; |
11480 | |
11481 | static int |
11482 | omp_udr_callback (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, |
11483 | void *data) |
11484 | { |
11485 | struct omp_udr_callback_data *cd = (struct omp_udr_callback_data *) data; |
11486 | if ((*e)->expr_type == EXPR_VARIABLE) |
11487 | { |
11488 | if (cd->is_initializer) |
11489 | { |
11490 | if ((*e)->symtree->n.sym != cd->omp_udr->omp_priv |
11491 | && (*e)->symtree->n.sym != cd->omp_udr->omp_orig) |
11492 | gfc_error ("Variable other than OMP_PRIV or OMP_ORIG used in " |
11493 | "INITIALIZER clause of !$OMP DECLARE REDUCTION at %L" , |
11494 | &(*e)->where); |
11495 | } |
11496 | else |
11497 | { |
11498 | if ((*e)->symtree->n.sym != cd->omp_udr->omp_out |
11499 | && (*e)->symtree->n.sym != cd->omp_udr->omp_in) |
11500 | gfc_error ("Variable other than OMP_OUT or OMP_IN used in " |
11501 | "combiner of !$OMP DECLARE REDUCTION at %L" , |
11502 | &(*e)->where); |
11503 | } |
11504 | } |
11505 | return 0; |
11506 | } |
11507 | |
11508 | /* Resolve !$omp declare reduction constructs. */ |
11509 | |
11510 | static void |
11511 | gfc_resolve_omp_udr (gfc_omp_udr *omp_udr) |
11512 | { |
11513 | gfc_actual_arglist *a; |
11514 | const char *predef_name = NULL; |
11515 | |
11516 | switch (omp_udr->rop) |
11517 | { |
11518 | case OMP_REDUCTION_PLUS: |
11519 | case OMP_REDUCTION_TIMES: |
11520 | case OMP_REDUCTION_MINUS: |
11521 | case OMP_REDUCTION_AND: |
11522 | case OMP_REDUCTION_OR: |
11523 | case OMP_REDUCTION_EQV: |
11524 | case OMP_REDUCTION_NEQV: |
11525 | case OMP_REDUCTION_MAX: |
11526 | case OMP_REDUCTION_USER: |
11527 | break; |
11528 | default: |
11529 | gfc_error ("Invalid operator for !$OMP DECLARE REDUCTION %s at %L" , |
11530 | omp_udr->name, &omp_udr->where); |
11531 | return; |
11532 | } |
11533 | |
11534 | if (gfc_omp_udr_predef (rop: omp_udr->rop, name: omp_udr->name, |
11535 | ts: &omp_udr->ts, n: &predef_name)) |
11536 | { |
11537 | if (predef_name) |
11538 | gfc_error_now ("Redefinition of predefined %s " |
11539 | "!$OMP DECLARE REDUCTION at %L" , |
11540 | predef_name, &omp_udr->where); |
11541 | else |
11542 | gfc_error_now ("Redefinition of predefined " |
11543 | "!$OMP DECLARE REDUCTION at %L" , &omp_udr->where); |
11544 | return; |
11545 | } |
11546 | |
11547 | if (omp_udr->ts.type == BT_CHARACTER |
11548 | && omp_udr->ts.u.cl->length |
11549 | && omp_udr->ts.u.cl->length->expr_type != EXPR_CONSTANT) |
11550 | { |
11551 | gfc_error ("CHARACTER length in !$OMP DECLARE REDUCTION %s not " |
11552 | "constant at %L" , omp_udr->name, &omp_udr->where); |
11553 | return; |
11554 | } |
11555 | |
11556 | struct omp_udr_callback_data cd; |
11557 | cd.omp_udr = omp_udr; |
11558 | cd.is_initializer = false; |
11559 | gfc_code_walker (&omp_udr->combiner_ns->code, gfc_dummy_code_callback, |
11560 | omp_udr_callback, &cd); |
11561 | if (omp_udr->combiner_ns->code->op == EXEC_CALL) |
11562 | { |
11563 | for (a = omp_udr->combiner_ns->code->ext.actual; a; a = a->next) |
11564 | if (a->expr == NULL) |
11565 | break; |
11566 | if (a) |
11567 | gfc_error ("Subroutine call with alternate returns in combiner " |
11568 | "of !$OMP DECLARE REDUCTION at %L" , |
11569 | &omp_udr->combiner_ns->code->loc); |
11570 | } |
11571 | if (omp_udr->initializer_ns) |
11572 | { |
11573 | cd.is_initializer = true; |
11574 | gfc_code_walker (&omp_udr->initializer_ns->code, gfc_dummy_code_callback, |
11575 | omp_udr_callback, &cd); |
11576 | if (omp_udr->initializer_ns->code->op == EXEC_CALL) |
11577 | { |
11578 | for (a = omp_udr->initializer_ns->code->ext.actual; a; a = a->next) |
11579 | if (a->expr == NULL) |
11580 | break; |
11581 | if (a) |
11582 | gfc_error ("Subroutine call with alternate returns in " |
11583 | "INITIALIZER clause of !$OMP DECLARE REDUCTION " |
11584 | "at %L" , &omp_udr->initializer_ns->code->loc); |
11585 | for (a = omp_udr->initializer_ns->code->ext.actual; a; a = a->next) |
11586 | if (a->expr |
11587 | && a->expr->expr_type == EXPR_VARIABLE |
11588 | && a->expr->symtree->n.sym == omp_udr->omp_priv |
11589 | && a->expr->ref == NULL) |
11590 | break; |
11591 | if (a == NULL) |
11592 | gfc_error ("One of actual subroutine arguments in INITIALIZER " |
11593 | "clause of !$OMP DECLARE REDUCTION must be OMP_PRIV " |
11594 | "at %L" , &omp_udr->initializer_ns->code->loc); |
11595 | } |
11596 | } |
11597 | else if (omp_udr->ts.type == BT_DERIVED |
11598 | && !gfc_has_default_initializer (omp_udr->ts.u.derived)) |
11599 | { |
11600 | gfc_error ("Missing INITIALIZER clause for !$OMP DECLARE REDUCTION " |
11601 | "of derived type without default initializer at %L" , |
11602 | &omp_udr->where); |
11603 | return; |
11604 | } |
11605 | } |
11606 | |
11607 | void |
11608 | gfc_resolve_omp_udrs (gfc_symtree *st) |
11609 | { |
11610 | gfc_omp_udr *omp_udr; |
11611 | |
11612 | if (st == NULL) |
11613 | return; |
11614 | gfc_resolve_omp_udrs (st: st->left); |
11615 | gfc_resolve_omp_udrs (st: st->right); |
11616 | for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next) |
11617 | gfc_resolve_omp_udr (omp_udr); |
11618 | } |
11619 | |