?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
PR rtl-optimization/43520
[official-gcc.git] / gcc / fortran / openmp.c
blobc00e1b41e28c092f80c4454414cadce74350a1b8
1 /* OpenMP directive matching and resolving.
2 Copyright (C) 2005, 2006, 2007, 2008, 2010
3 Free Software Foundation, Inc.
4 Contributed by Jakub Jelinek
5
6 This file is part of GCC.
7
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
11 version.
12
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
16 for more details.
17
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
21
22 #include "config.h"
23 #include "system.h"
24 #include "flags.h"
25 #include "gfortran.h"
26 #include "match.h"
27 #include "parse.h"
28 #include "pointer-set.h"
29 #include "target.h"
30 #include "toplev.h"
31
32 /* Match an end of OpenMP directive. End of OpenMP directive is optional
33 whitespace, followed by '\n' or comment '!'. */
34
35 match
36 gfc_match_omp_eos (void)
37 {
38 locus old_loc;
39 char c;
40
41 old_loc = gfc_current_locus;
42 gfc_gobble_whitespace ();
43
44 c = gfc_next_ascii_char ();
45 switch (c)
46 {
47 case '!':
48 do
49 c = gfc_next_ascii_char ();
50 while (c != '\n');
51 /* Fall through */
52
53 case '\n':
54 return MATCH_YES;
55 }
56
57 gfc_current_locus = old_loc;
58 return MATCH_NO;
59 }
60
61 /* Free an omp_clauses structure. */
62
63 void
64 gfc_free_omp_clauses (gfc_omp_clauses *c)
65 {
66 int i;
67 if (c == NULL)
68 return;
69
70 gfc_free_expr (c->if_expr);
71 gfc_free_expr (c->num_threads);
72 gfc_free_expr (c->chunk_size);
73 for (i = 0; i < OMP_LIST_NUM; i++)
74 gfc_free_namelist (c->lists[i]);
75 gfc_free (c);
76 }
77
78 /* Match a variable/common block list and construct a namelist from it. */
79
80 static match
81 gfc_match_omp_variable_list (const char *str, gfc_namelist **list,
82 bool allow_common)
83 {
84 gfc_namelist *head, *tail, *p;
85 locus old_loc;
86 char n[GFC_MAX_SYMBOL_LEN+1];
87 gfc_symbol *sym;
88 match m;
89 gfc_symtree *st;
90
91 head = tail = NULL;
92
93 old_loc = gfc_current_locus;
94
95 m = gfc_match (str);
96 if (m != MATCH_YES)
97 return m;
98
99 for (;;)
100 {
101 m = gfc_match_symbol (&sym, 1);
102 switch (m)
103 {
104 case MATCH_YES:
105 gfc_set_sym_referenced (sym);
106 p = gfc_get_namelist ();
107 if (head == NULL)
108 head = tail = p;
109 else
110 {
111 tail->next = p;
112 tail = tail->next;
113 }
114 tail->sym = sym;
115 goto next_item;
116 case MATCH_NO:
117 break;
118 case MATCH_ERROR:
119 goto cleanup;
120 }
121
122 if (!allow_common)
123 goto syntax;
124
125 m = gfc_match (" / %n /", n);
126 if (m == MATCH_ERROR)
127 goto cleanup;
128 if (m == MATCH_NO)
129 goto syntax;
130
131 st = gfc_find_symtree (gfc_current_ns->common_root, n);
132 if (st == NULL)
133 {
134 gfc_error ("COMMON block /%s/ not found at %C", n);
135 goto cleanup;
136 }
137 for (sym = st->n.common->head; sym; sym = sym->common_next)
138 {
139 gfc_set_sym_referenced (sym);
140 p = gfc_get_namelist ();
141 if (head == NULL)
142 head = tail = p;
143 else
144 {
145 tail->next = p;
146 tail = tail->next;
147 }
148 tail->sym = sym;
149 }
150
151 next_item:
152 if (gfc_match_char (')') == MATCH_YES)
153 break;
154 if (gfc_match_char (',') != MATCH_YES)
155 goto syntax;
156 }
157
158 while (*list)
159 list = &(*list)->next;
160
161 *list = head;
162 return MATCH_YES;
163
164 syntax:
165 gfc_error ("Syntax error in OpenMP variable list at %C");
166
167 cleanup:
168 gfc_free_namelist (head);
169 gfc_current_locus = old_loc;
170 return MATCH_ERROR;
171 }
172
173 #define OMP_CLAUSE_PRIVATE (1 << 0)
174 #define OMP_CLAUSE_FIRSTPRIVATE (1 << 1)
175 #define OMP_CLAUSE_LASTPRIVATE (1 << 2)
176 #define OMP_CLAUSE_COPYPRIVATE (1 << 3)
177 #define OMP_CLAUSE_SHARED (1 << 4)
178 #define OMP_CLAUSE_COPYIN (1 << 5)
179 #define OMP_CLAUSE_REDUCTION (1 << 6)
180 #define OMP_CLAUSE_IF (1 << 7)
181 #define OMP_CLAUSE_NUM_THREADS (1 << 8)
182 #define OMP_CLAUSE_SCHEDULE (1 << 9)
183 #define OMP_CLAUSE_DEFAULT (1 << 10)
184 #define OMP_CLAUSE_ORDERED (1 << 11)
185 #define OMP_CLAUSE_COLLAPSE (1 << 12)
186 #define OMP_CLAUSE_UNTIED (1 << 13)
187
188 /* Match OpenMP directive clauses. MASK is a bitmask of
189 clauses that are allowed for a particular directive. */
190
191 static match
192 gfc_match_omp_clauses (gfc_omp_clauses **cp, int mask)
193 {
194 gfc_omp_clauses *c = gfc_get_omp_clauses ();
195 locus old_loc;
196 bool needs_space = true, first = true;
197
198 *cp = NULL;
199 while (1)
200 {
201 if ((first || gfc_match_char (',') != MATCH_YES)
202 && (needs_space && gfc_match_space () != MATCH_YES))
203 break;
204 needs_space = false;
205 first = false;
206 gfc_gobble_whitespace ();
207 if ((mask & OMP_CLAUSE_IF) && c->if_expr == NULL
208 && gfc_match ("if ( %e )", &c->if_expr) == MATCH_YES)
209 continue;
210 if ((mask & OMP_CLAUSE_NUM_THREADS) && c->num_threads == NULL
211 && gfc_match ("num_threads ( %e )", &c->num_threads) == MATCH_YES)
212 continue;
213 if ((mask & OMP_CLAUSE_PRIVATE)
214 && gfc_match_omp_variable_list ("private (",
215 &c->lists[OMP_LIST_PRIVATE], true)
216 == MATCH_YES)
217 continue;
218 if ((mask & OMP_CLAUSE_FIRSTPRIVATE)
219 && gfc_match_omp_variable_list ("firstprivate (",
220 &c->lists[OMP_LIST_FIRSTPRIVATE],
221 true)
222 == MATCH_YES)
223 continue;
224 if ((mask & OMP_CLAUSE_LASTPRIVATE)
225 && gfc_match_omp_variable_list ("lastprivate (",
226 &c->lists[OMP_LIST_LASTPRIVATE],
227 true)
228 == MATCH_YES)
229 continue;
230 if ((mask & OMP_CLAUSE_COPYPRIVATE)
231 && gfc_match_omp_variable_list ("copyprivate (",
232 &c->lists[OMP_LIST_COPYPRIVATE],
233 true)
234 == MATCH_YES)
235 continue;
236 if ((mask & OMP_CLAUSE_SHARED)
237 && gfc_match_omp_variable_list ("shared (",
238 &c->lists[OMP_LIST_SHARED], true)
239 == MATCH_YES)
240 continue;
241 if ((mask & OMP_CLAUSE_COPYIN)
242 && gfc_match_omp_variable_list ("copyin (",
243 &c->lists[OMP_LIST_COPYIN], true)
244 == MATCH_YES)
245 continue;
246 old_loc = gfc_current_locus;
247 if ((mask & OMP_CLAUSE_REDUCTION)
248 && gfc_match ("reduction ( ") == MATCH_YES)
249 {
250 int reduction = OMP_LIST_NUM;
251 char buffer[GFC_MAX_SYMBOL_LEN + 1];
252 if (gfc_match_char ('+') == MATCH_YES)
253 reduction = OMP_LIST_PLUS;
254 else if (gfc_match_char ('*') == MATCH_YES)
255 reduction = OMP_LIST_MULT;
256 else if (gfc_match_char ('-') == MATCH_YES)
257 reduction = OMP_LIST_SUB;
258 else if (gfc_match (".and.") == MATCH_YES)
259 reduction = OMP_LIST_AND;
260 else if (gfc_match (".or.") == MATCH_YES)
261 reduction = OMP_LIST_OR;
262 else if (gfc_match (".eqv.") == MATCH_YES)
263 reduction = OMP_LIST_EQV;
264 else if (gfc_match (".neqv.") == MATCH_YES)
265 reduction = OMP_LIST_NEQV;
266 else if (gfc_match_name (buffer) == MATCH_YES)
267 {
268 gfc_symbol *sym;
269 const char *n = buffer;
270
271 gfc_find_symbol (buffer, NULL, 1, &sym);
272 if (sym != NULL)
273 {
274 if (sym->attr.intrinsic)
275 n = sym->name;
276 else if ((sym->attr.flavor != FL_UNKNOWN
277 && sym->attr.flavor != FL_PROCEDURE)
278 || sym->attr.external
279 || sym->attr.generic
280 || sym->attr.entry
281 || sym->attr.result
282 || sym->attr.dummy
283 || sym->attr.subroutine
284 || sym->attr.pointer
285 || sym->attr.target
286 || sym->attr.cray_pointer
287 || sym->attr.cray_pointee
288 || (sym->attr.proc != PROC_UNKNOWN
289 && sym->attr.proc != PROC_INTRINSIC)
290 || sym->attr.if_source != IFSRC_UNKNOWN
291 || sym == sym->ns->proc_name)
292 {
293 gfc_error_now ("%s is not INTRINSIC procedure name "
294 "at %C", buffer);
295 sym = NULL;
296 }
297 else
298 n = sym->name;
299 }
300 if (strcmp (n, "max") == 0)
301 reduction = OMP_LIST_MAX;
302 else if (strcmp (n, "min") == 0)
303 reduction = OMP_LIST_MIN;
304 else if (strcmp (n, "iand") == 0)
305 reduction = OMP_LIST_IAND;
306 else if (strcmp (n, "ior") == 0)
307 reduction = OMP_LIST_IOR;
308 else if (strcmp (n, "ieor") == 0)
309 reduction = OMP_LIST_IEOR;
310 if (reduction != OMP_LIST_NUM
311 && sym != NULL
312 && ! sym->attr.intrinsic
313 && ! sym->attr.use_assoc
314 && ((sym->attr.flavor == FL_UNKNOWN
315 && gfc_add_flavor (&sym->attr, FL_PROCEDURE,
316 sym->name, NULL) == FAILURE)
317 || gfc_add_intrinsic (&sym->attr, NULL) == FAILURE))
318 {
319 gfc_free_omp_clauses (c);
320 return MATCH_ERROR;
321 }
322 }
323 if (reduction != OMP_LIST_NUM
324 && gfc_match_omp_variable_list (" :", &c->lists[reduction],
325 false)
326 == MATCH_YES)
327 continue;
328 else
329 gfc_current_locus = old_loc;
330 }
331 if ((mask & OMP_CLAUSE_DEFAULT)
332 && c->default_sharing == OMP_DEFAULT_UNKNOWN)
333 {
334 if (gfc_match ("default ( shared )") == MATCH_YES)
335 c->default_sharing = OMP_DEFAULT_SHARED;
336 else if (gfc_match ("default ( private )") == MATCH_YES)
337 c->default_sharing = OMP_DEFAULT_PRIVATE;
338 else if (gfc_match ("default ( none )") == MATCH_YES)
339 c->default_sharing = OMP_DEFAULT_NONE;
340 else if (gfc_match ("default ( firstprivate )") == MATCH_YES)
341 c->default_sharing = OMP_DEFAULT_FIRSTPRIVATE;
342 if (c->default_sharing != OMP_DEFAULT_UNKNOWN)
343 continue;
344 }
345 old_loc = gfc_current_locus;
346 if ((mask & OMP_CLAUSE_SCHEDULE)
347 && c->sched_kind == OMP_SCHED_NONE
348 && gfc_match ("schedule ( ") == MATCH_YES)
349 {
350 if (gfc_match ("static") == MATCH_YES)
351 c->sched_kind = OMP_SCHED_STATIC;
352 else if (gfc_match ("dynamic") == MATCH_YES)
353 c->sched_kind = OMP_SCHED_DYNAMIC;
354 else if (gfc_match ("guided") == MATCH_YES)
355 c->sched_kind = OMP_SCHED_GUIDED;
356 else if (gfc_match ("runtime") == MATCH_YES)
357 c->sched_kind = OMP_SCHED_RUNTIME;
358 else if (gfc_match ("auto") == MATCH_YES)
359 c->sched_kind = OMP_SCHED_AUTO;
360 if (c->sched_kind != OMP_SCHED_NONE)
361 {
362 match m = MATCH_NO;
363 if (c->sched_kind != OMP_SCHED_RUNTIME
364 && c->sched_kind != OMP_SCHED_AUTO)
365 m = gfc_match (" , %e )", &c->chunk_size);
366 if (m != MATCH_YES)
367 m = gfc_match_char (')');
368 if (m != MATCH_YES)
369 c->sched_kind = OMP_SCHED_NONE;
370 }
371 if (c->sched_kind != OMP_SCHED_NONE)
372 continue;
373 else
374 gfc_current_locus = old_loc;
375 }
376 if ((mask & OMP_CLAUSE_ORDERED) && !c->ordered
377 && gfc_match ("ordered") == MATCH_YES)
378 {
379 c->ordered = needs_space = true;
380 continue;
381 }
382 if ((mask & OMP_CLAUSE_UNTIED) && !c->untied
383 && gfc_match ("untied") == MATCH_YES)
384 {
385 c->untied = needs_space = true;
386 continue;
387 }
388 if ((mask & OMP_CLAUSE_COLLAPSE) && !c->collapse)
389 {
390 gfc_expr *cexpr = NULL;
391 match m = gfc_match ("collapse ( %e )", &cexpr);
392
393 if (m == MATCH_YES)
394 {
395 int collapse;
396 const char *p = gfc_extract_int (cexpr, &collapse);
397 if (p)
398 {
399 gfc_error_now (p);
400 collapse = 1;
401 }
402 else if (collapse <= 0)
403 {
404 gfc_error_now ("COLLAPSE clause argument not"
405 " constant positive integer at %C");
406 collapse = 1;
407 }
408 c->collapse = collapse;
409 gfc_free_expr (cexpr);
410 continue;
411 }
412 }
413
414 break;
415 }
416
417 if (gfc_match_omp_eos () != MATCH_YES)
418 {
419 gfc_free_omp_clauses (c);
420 return MATCH_ERROR;
421 }
422
423 *cp = c;
424 return MATCH_YES;
425 }
426
427 #define OMP_PARALLEL_CLAUSES \
428 (OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_SHARED \
429 | OMP_CLAUSE_COPYIN | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_IF \
430 | OMP_CLAUSE_NUM_THREADS | OMP_CLAUSE_DEFAULT)
431 #define OMP_DO_CLAUSES \
432 (OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
433 | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION \
434 | OMP_CLAUSE_SCHEDULE | OMP_CLAUSE_ORDERED | OMP_CLAUSE_COLLAPSE)
435 #define OMP_SECTIONS_CLAUSES \
436 (OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
437 | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION)
438 #define OMP_TASK_CLAUSES \
439 (OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_SHARED \
440 | OMP_CLAUSE_IF | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_UNTIED)
441
442 match
443 gfc_match_omp_parallel (void)
444 {
445 gfc_omp_clauses *c;
446 if (gfc_match_omp_clauses (&c, OMP_PARALLEL_CLAUSES) != MATCH_YES)
447 return MATCH_ERROR;
448 new_st.op = EXEC_OMP_PARALLEL;
449 new_st.ext.omp_clauses = c;
450 return MATCH_YES;
451 }
452
453
454 match
455 gfc_match_omp_task (void)
456 {
457 gfc_omp_clauses *c;
458 if (gfc_match_omp_clauses (&c, OMP_TASK_CLAUSES) != MATCH_YES)
459 return MATCH_ERROR;
460 new_st.op = EXEC_OMP_TASK;
461 new_st.ext.omp_clauses = c;
462 return MATCH_YES;
463 }
464
465
466 match
467 gfc_match_omp_taskwait (void)
468 {
469 if (gfc_match_omp_eos () != MATCH_YES)
470 return MATCH_ERROR;
471 new_st.op = EXEC_OMP_TASKWAIT;
472 new_st.ext.omp_clauses = NULL;
473 return MATCH_YES;
474 }
475
476
477 match
478 gfc_match_omp_critical (void)
479 {
480 char n[GFC_MAX_SYMBOL_LEN+1];
481
482 if (gfc_match (" ( %n )", n) != MATCH_YES)
483 n[0] = '\0';
484 if (gfc_match_omp_eos () != MATCH_YES)
485 return MATCH_ERROR;
486 new_st.op = EXEC_OMP_CRITICAL;
487 new_st.ext.omp_name = n[0] ? xstrdup (n) : NULL;
488 return MATCH_YES;
489 }
490
491
492 match
493 gfc_match_omp_do (void)
494 {
495 gfc_omp_clauses *c;
496 if (gfc_match_omp_clauses (&c, OMP_DO_CLAUSES) != MATCH_YES)
497 return MATCH_ERROR;
498 new_st.op = EXEC_OMP_DO;
499 new_st.ext.omp_clauses = c;
500 return MATCH_YES;
501 }
502
503
504 match
505 gfc_match_omp_flush (void)
506 {
507 gfc_namelist *list = NULL;
508 gfc_match_omp_variable_list (" (", &list, true);
509 if (gfc_match_omp_eos () != MATCH_YES)
510 {
511 gfc_free_namelist (list);
512 return MATCH_ERROR;
513 }
514 new_st.op = EXEC_OMP_FLUSH;
515 new_st.ext.omp_namelist = list;
516 return MATCH_YES;
517 }
518
519
520 match
521 gfc_match_omp_threadprivate (void)
522 {
523 locus old_loc;
524 char n[GFC_MAX_SYMBOL_LEN+1];
525 gfc_symbol *sym;
526 match m;
527 gfc_symtree *st;
528
529 old_loc = gfc_current_locus;
530
531 m = gfc_match (" (");
532 if (m != MATCH_YES)
533 return m;
534
535 for (;;)
536 {
537 m = gfc_match_symbol (&sym, 0);
538 switch (m)
539 {
540 case MATCH_YES:
541 if (sym->attr.in_common)
542 gfc_error_now ("Threadprivate variable at %C is an element of "
543 "a COMMON block");
544 else if (gfc_add_threadprivate (&sym->attr, sym->name,
545 &sym->declared_at) == FAILURE)
546 goto cleanup;
547 goto next_item;
548 case MATCH_NO:
549 break;
550 case MATCH_ERROR:
551 goto cleanup;
552 }
553
554 m = gfc_match (" / %n /", n);
555 if (m == MATCH_ERROR)
556 goto cleanup;
557 if (m == MATCH_NO || n[0] == '\0')
558 goto syntax;
559
560 st = gfc_find_symtree (gfc_current_ns->common_root, n);
561 if (st == NULL)
562 {
563 gfc_error ("COMMON block /%s/ not found at %C", n);
564 goto cleanup;
565 }
566 st->n.common->threadprivate = 1;
567 for (sym = st->n.common->head; sym; sym = sym->common_next)
568 if (gfc_add_threadprivate (&sym->attr, sym->name,
569 &sym->declared_at) == FAILURE)
570 goto cleanup;
571
572 next_item:
573 if (gfc_match_char (')') == MATCH_YES)
574 break;
575 if (gfc_match_char (',') != MATCH_YES)
576 goto syntax;
577 }
578
579 return MATCH_YES;
580
581 syntax:
582 gfc_error ("Syntax error in !$OMP THREADPRIVATE list at %C");
583
584 cleanup:
585 gfc_current_locus = old_loc;
586 return MATCH_ERROR;
587 }
588
589
590 match
591 gfc_match_omp_parallel_do (void)
592 {
593 gfc_omp_clauses *c;
594 if (gfc_match_omp_clauses (&c, OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES)
595 != MATCH_YES)
596 return MATCH_ERROR;
597 new_st.op = EXEC_OMP_PARALLEL_DO;
598 new_st.ext.omp_clauses = c;
599 return MATCH_YES;
600 }
601
602
603 match
604 gfc_match_omp_parallel_sections (void)
605 {
606 gfc_omp_clauses *c;
607 if (gfc_match_omp_clauses (&c, OMP_PARALLEL_CLAUSES | OMP_SECTIONS_CLAUSES)
608 != MATCH_YES)
609 return MATCH_ERROR;
610 new_st.op = EXEC_OMP_PARALLEL_SECTIONS;
611 new_st.ext.omp_clauses = c;
612 return MATCH_YES;
613 }
614
615
616 match
617 gfc_match_omp_parallel_workshare (void)
618 {
619 gfc_omp_clauses *c;
620 if (gfc_match_omp_clauses (&c, OMP_PARALLEL_CLAUSES) != MATCH_YES)
621 return MATCH_ERROR;
622 new_st.op = EXEC_OMP_PARALLEL_WORKSHARE;
623 new_st.ext.omp_clauses = c;
624 return MATCH_YES;
625 }
626
627
628 match
629 gfc_match_omp_sections (void)
630 {
631 gfc_omp_clauses *c;
632 if (gfc_match_omp_clauses (&c, OMP_SECTIONS_CLAUSES) != MATCH_YES)
633 return MATCH_ERROR;
634 new_st.op = EXEC_OMP_SECTIONS;
635 new_st.ext.omp_clauses = c;
636 return MATCH_YES;
637 }
638
639
640 match
641 gfc_match_omp_single (void)
642 {
643 gfc_omp_clauses *c;
644 if (gfc_match_omp_clauses (&c, OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE)
645 != MATCH_YES)
646 return MATCH_ERROR;
647 new_st.op = EXEC_OMP_SINGLE;
648 new_st.ext.omp_clauses = c;
649 return MATCH_YES;
650 }
651
652
653 match
654 gfc_match_omp_workshare (void)
655 {
656 if (gfc_match_omp_eos () != MATCH_YES)
657 return MATCH_ERROR;
658 new_st.op = EXEC_OMP_WORKSHARE;
659 new_st.ext.omp_clauses = gfc_get_omp_clauses ();
660 return MATCH_YES;
661 }
662
663
664 match
665 gfc_match_omp_master (void)
666 {
667 if (gfc_match_omp_eos () != MATCH_YES)
668 return MATCH_ERROR;
669 new_st.op = EXEC_OMP_MASTER;
670 new_st.ext.omp_clauses = NULL;
671 return MATCH_YES;
672 }
673
674
675 match
676 gfc_match_omp_ordered (void)
677 {
678 if (gfc_match_omp_eos () != MATCH_YES)
679 return MATCH_ERROR;
680 new_st.op = EXEC_OMP_ORDERED;
681 new_st.ext.omp_clauses = NULL;
682 return MATCH_YES;
683 }
684
685
686 match
687 gfc_match_omp_atomic (void)
688 {
689 if (gfc_match_omp_eos () != MATCH_YES)
690 return MATCH_ERROR;
691 new_st.op = EXEC_OMP_ATOMIC;
692 new_st.ext.omp_clauses = NULL;
693 return MATCH_YES;
694 }
695
696
697 match
698 gfc_match_omp_barrier (void)
699 {
700 if (gfc_match_omp_eos () != MATCH_YES)
701 return MATCH_ERROR;
702 new_st.op = EXEC_OMP_BARRIER;
703 new_st.ext.omp_clauses = NULL;
704 return MATCH_YES;
705 }
706
707
708 match
709 gfc_match_omp_end_nowait (void)
710 {
711 bool nowait = false;
712 if (gfc_match ("% nowait") == MATCH_YES)
713 nowait = true;
714 if (gfc_match_omp_eos () != MATCH_YES)
715 return MATCH_ERROR;
716 new_st.op = EXEC_OMP_END_NOWAIT;
717 new_st.ext.omp_bool = nowait;
718 return MATCH_YES;
719 }
720
721
722 match
723 gfc_match_omp_end_single (void)
724 {
725 gfc_omp_clauses *c;
726 if (gfc_match ("% nowait") == MATCH_YES)
727 {
728 new_st.op = EXEC_OMP_END_NOWAIT;
729 new_st.ext.omp_bool = true;
730 return MATCH_YES;
731 }
732 if (gfc_match_omp_clauses (&c, OMP_CLAUSE_COPYPRIVATE) != MATCH_YES)
733 return MATCH_ERROR;
734 new_st.op = EXEC_OMP_END_SINGLE;
735 new_st.ext.omp_clauses = c;
736 return MATCH_YES;
737 }
738
739
740 /* OpenMP directive resolving routines. */
741
742 static void
743 resolve_omp_clauses (gfc_code *code)
744 {
745 gfc_omp_clauses *omp_clauses = code->ext.omp_clauses;
746 gfc_namelist *n;
747 int list;
748 static const char *clause_names[]
749 = { "PRIVATE", "FIRSTPRIVATE", "LASTPRIVATE", "COPYPRIVATE", "SHARED",
750 "COPYIN", "REDUCTION" };
751
752 if (omp_clauses == NULL)
753 return;
754
755 if (omp_clauses->if_expr)
756 {
757 gfc_expr *expr = omp_clauses->if_expr;
758 if (gfc_resolve_expr (expr) == FAILURE
759 || expr->ts.type != BT_LOGICAL || expr->rank != 0)
760 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
761 &expr->where);
762 }
763 if (omp_clauses->num_threads)
764 {
765 gfc_expr *expr = omp_clauses->num_threads;
766 if (gfc_resolve_expr (expr) == FAILURE
767 || expr->ts.type != BT_INTEGER || expr->rank != 0)
768 gfc_error ("NUM_THREADS clause at %L requires a scalar "
769 "INTEGER expression", &expr->where);
770 }
771 if (omp_clauses->chunk_size)
772 {
773 gfc_expr *expr = omp_clauses->chunk_size;
774 if (gfc_resolve_expr (expr) == FAILURE
775 || expr->ts.type != BT_INTEGER || expr->rank != 0)
776 gfc_error ("SCHEDULE clause's chunk_size at %L requires "
777 "a scalar INTEGER expression", &expr->where);
778 }
779
780 /* Check that no symbol appears on multiple clauses, except that
781 a symbol can appear on both firstprivate and lastprivate. */
782 for (list = 0; list < OMP_LIST_NUM; list++)
783 for (n = omp_clauses->lists[list]; n; n = n->next)
784 {
785 n->sym->mark = 0;
786 if (n->sym->attr.flavor == FL_VARIABLE)
787 continue;
788 if (n->sym->attr.flavor == FL_PROCEDURE
789 && n->sym->result == n->sym
790 && n->sym->attr.function)
791 {
792 if (gfc_current_ns->proc_name == n->sym
793 || (gfc_current_ns->parent
794 && gfc_current_ns->parent->proc_name == n->sym))
795 continue;
796 if (gfc_current_ns->proc_name->attr.entry_master)
797 {
798 gfc_entry_list *el = gfc_current_ns->entries;
799 for (; el; el = el->next)
800 if (el->sym == n->sym)
801 break;
802 if (el)
803 continue;
804 }
805 if (gfc_current_ns->parent
806 && gfc_current_ns->parent->proc_name->attr.entry_master)
807 {
808 gfc_entry_list *el = gfc_current_ns->parent->entries;
809 for (; el; el = el->next)
810 if (el->sym == n->sym)
811 break;
812 if (el)
813 continue;
814 }
815 }
816 gfc_error ("Object '%s' is not a variable at %L", n->sym->name,
817 &code->loc);
818 }
819
820 for (list = 0; list < OMP_LIST_NUM; list++)
821 if (list != OMP_LIST_FIRSTPRIVATE && list != OMP_LIST_LASTPRIVATE)
822 for (n = omp_clauses->lists[list]; n; n = n->next)
823 if (n->sym->mark)
824 gfc_error ("Symbol '%s' present on multiple clauses at %L",
825 n->sym->name, &code->loc);
826 else
827 n->sym->mark = 1;
828
829 gcc_assert (OMP_LIST_LASTPRIVATE == OMP_LIST_FIRSTPRIVATE + 1);
830 for (list = OMP_LIST_FIRSTPRIVATE; list <= OMP_LIST_LASTPRIVATE; list++)
831 for (n = omp_clauses->lists[list]; n; n = n->next)
832 if (n->sym->mark)
833 {
834 gfc_error ("Symbol '%s' present on multiple clauses at %L",
835 n->sym->name, &code->loc);
836 n->sym->mark = 0;
837 }
838
839 for (n = omp_clauses->lists[OMP_LIST_FIRSTPRIVATE]; n; n = n->next)
840 if (n->sym->mark)
841 gfc_error ("Symbol '%s' present on multiple clauses at %L",
842 n->sym->name, &code->loc);
843 else
844 n->sym->mark = 1;
845
846 for (n = omp_clauses->lists[OMP_LIST_LASTPRIVATE]; n; n = n->next)
847 n->sym->mark = 0;
848
849 for (n = omp_clauses->lists[OMP_LIST_LASTPRIVATE]; n; n = n->next)
850 if (n->sym->mark)
851 gfc_error ("Symbol '%s' present on multiple clauses at %L",
852 n->sym->name, &code->loc);
853 else
854 n->sym->mark = 1;
855
856 for (list = 0; list < OMP_LIST_NUM; list++)
857 if ((n = omp_clauses->lists[list]) != NULL)
858 {
859 const char *name;
860
861 if (list < OMP_LIST_REDUCTION_FIRST)
862 name = clause_names[list];
863 else if (list <= OMP_LIST_REDUCTION_LAST)
864 name = clause_names[OMP_LIST_REDUCTION_FIRST];
865 else
866 gcc_unreachable ();
867
868 switch (list)
869 {
870 case OMP_LIST_COPYIN:
871 for (; n != NULL; n = n->next)
872 {
873 if (!n->sym->attr.threadprivate)
874 gfc_error ("Non-THREADPRIVATE object '%s' in COPYIN clause"
875 " at %L", n->sym->name, &code->loc);
876 if (n->sym->ts.type == BT_DERIVED && n->sym->ts.u.derived->attr.alloc_comp)
877 gfc_error ("COPYIN clause object '%s' at %L has ALLOCATABLE components",
878 n->sym->name, &code->loc);
879 }
880 break;
881 case OMP_LIST_COPYPRIVATE:
882 for (; n != NULL; n = n->next)
883 {
884 if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
885 gfc_error ("Assumed size array '%s' in COPYPRIVATE clause "
886 "at %L", n->sym->name, &code->loc);
887 if (n->sym->ts.type == BT_DERIVED && n->sym->ts.u.derived->attr.alloc_comp)
888 gfc_error ("COPYPRIVATE clause object '%s' at %L has ALLOCATABLE components",
889 n->sym->name, &code->loc);
890 }
891 break;
892 case OMP_LIST_SHARED:
893 for (; n != NULL; n = n->next)
894 {
895 if (n->sym->attr.threadprivate)
896 gfc_error ("THREADPRIVATE object '%s' in SHARED clause at "
897 "%L", n->sym->name, &code->loc);
898 if (n->sym->attr.cray_pointee)
899 gfc_error ("Cray pointee '%s' in SHARED clause at %L",
900 n->sym->name, &code->loc);
901 }
902 break;
903 default:
904 for (; n != NULL; n = n->next)
905 {
906 if (n->sym->attr.threadprivate)
907 gfc_error ("THREADPRIVATE object '%s' in %s clause at %L",
908 n->sym->name, name, &code->loc);
909 if (n->sym->attr.cray_pointee)
910 gfc_error ("Cray pointee '%s' in %s clause at %L",
911 n->sym->name, name, &code->loc);
912 if (list != OMP_LIST_PRIVATE)
913 {
914 if (n->sym->attr.pointer)
915 gfc_error ("POINTER object '%s' in %s clause at %L",
916 n->sym->name, name, &code->loc);
917 /* Variables in REDUCTION-clauses must be of intrinsic type (flagged below). */
918 if ((list < OMP_LIST_REDUCTION_FIRST || list > OMP_LIST_REDUCTION_LAST) &&
919 n->sym->ts.type == BT_DERIVED && n->sym->ts.u.derived->attr.alloc_comp)
920 gfc_error ("%s clause object '%s' has ALLOCATABLE components at %L",
921 name, n->sym->name, &code->loc);
922 if (n->sym->attr.cray_pointer)
923 gfc_error ("Cray pointer '%s' in %s clause at %L",
924 n->sym->name, name, &code->loc);
925 }
926 if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
927 gfc_error ("Assumed size array '%s' in %s clause at %L",
928 n->sym->name, name, &code->loc);
929 if (n->sym->attr.in_namelist
930 && (list < OMP_LIST_REDUCTION_FIRST
931 || list > OMP_LIST_REDUCTION_LAST))
932 gfc_error ("Variable '%s' in %s clause is used in "
933 "NAMELIST statement at %L",
934 n->sym->name, name, &code->loc);
935 switch (list)
936 {
937 case OMP_LIST_PLUS:
938 case OMP_LIST_MULT:
939 case OMP_LIST_SUB:
940 if (!gfc_numeric_ts (&n->sym->ts))
941 gfc_error ("%c REDUCTION variable '%s' at %L must be of numeric type, got %s",
942 list == OMP_LIST_PLUS ? '+'
943 : list == OMP_LIST_MULT ? '*' : '-',
944 n->sym->name, &code->loc,
945 gfc_typename (&n->sym->ts));
946 break;
947 case OMP_LIST_AND:
948 case OMP_LIST_OR:
949 case OMP_LIST_EQV:
950 case OMP_LIST_NEQV:
951 if (n->sym->ts.type != BT_LOGICAL)
952 gfc_error ("%s REDUCTION variable '%s' must be LOGICAL "
953 "at %L",
954 list == OMP_LIST_AND ? ".AND."
955 : list == OMP_LIST_OR ? ".OR."
956 : list == OMP_LIST_EQV ? ".EQV." : ".NEQV.",
957 n->sym->name, &code->loc);
958 break;
959 case OMP_LIST_MAX:
960 case OMP_LIST_MIN:
961 if (n->sym->ts.type != BT_INTEGER
962 && n->sym->ts.type != BT_REAL)
963 gfc_error ("%s REDUCTION variable '%s' must be "
964 "INTEGER or REAL at %L",
965 list == OMP_LIST_MAX ? "MAX" : "MIN",
966 n->sym->name, &code->loc);
967 break;
968 case OMP_LIST_IAND:
969 case OMP_LIST_IOR:
970 case OMP_LIST_IEOR:
971 if (n->sym->ts.type != BT_INTEGER)
972 gfc_error ("%s REDUCTION variable '%s' must be INTEGER "
973 "at %L",
974 list == OMP_LIST_IAND ? "IAND"
975 : list == OMP_LIST_MULT ? "IOR" : "IEOR",
976 n->sym->name, &code->loc);
977 break;
978 /* Workaround for PR middle-end/26316, nothing really needs
979 to be done here for OMP_LIST_PRIVATE. */
980 case OMP_LIST_PRIVATE:
981 gcc_assert (code->op != EXEC_NOP);
982 default:
983 break;
984 }
985 }
986 break;
987 }
988 }
989 }
990
991
992 /* Return true if SYM is ever referenced in EXPR except in the SE node. */
993
994 static bool
995 expr_references_sym (gfc_expr *e, gfc_symbol *s, gfc_expr *se)
996 {
997 gfc_actual_arglist *arg;
998 if (e == NULL || e == se)
999 return false;
1000 switch (e->expr_type)
1001 {
1002 case EXPR_CONSTANT:
1003 case EXPR_NULL:
1004 case EXPR_VARIABLE:
1005 case EXPR_STRUCTURE:
1006 case EXPR_ARRAY:
1007 if (e->symtree != NULL
1008 && e->symtree->n.sym == s)
1009 return true;
1010 return false;
1011 case EXPR_SUBSTRING:
1012 if (e->ref != NULL
1013 && (expr_references_sym (e->ref->u.ss.start, s, se)
1014 || expr_references_sym (e->ref->u.ss.end, s, se)))
1015 return true;
1016 return false;
1017 case EXPR_OP:
1018 if (expr_references_sym (e->value.op.op2, s, se))
1019 return true;
1020 return expr_references_sym (e->value.op.op1, s, se);
1021 case EXPR_FUNCTION:
1022 for (arg = e->value.function.actual; arg; arg = arg->next)
1023 if (expr_references_sym (arg->expr, s, se))
1024 return true;
1025 return false;
1026 default:
1027 gcc_unreachable ();
1028 }
1029 }
1030
1031
1032 /* If EXPR is a conversion function that widens the type
1033 if WIDENING is true or narrows the type if WIDENING is false,
1034 return the inner expression, otherwise return NULL. */
1035
1036 static gfc_expr *
1037 is_conversion (gfc_expr *expr, bool widening)
1038 {
1039 gfc_typespec *ts1, *ts2;
1040
1041 if (expr->expr_type != EXPR_FUNCTION
1042 || expr->value.function.isym == NULL
1043 || expr->value.function.esym != NULL
1044 || expr->value.function.isym->id != GFC_ISYM_CONVERSION)
1045 return NULL;
1046
1047 if (widening)
1048 {
1049 ts1 = &expr->ts;
1050 ts2 = &expr->value.function.actual->expr->ts;
1051 }
1052 else
1053 {
1054 ts1 = &expr->value.function.actual->expr->ts;
1055 ts2 = &expr->ts;
1056 }
1057
1058 if (ts1->type > ts2->type
1059 || (ts1->type == ts2->type && ts1->kind > ts2->kind))
1060 return expr->value.function.actual->expr;
1061
1062 return NULL;
1063 }
1064
1065
1066 static void
1067 resolve_omp_atomic (gfc_code *code)
1068 {
1069 gfc_symbol *var;
1070 gfc_expr *expr2;
1071
1072 code = code->block->next;
1073 gcc_assert (code->op == EXEC_ASSIGN);
1074 gcc_assert (code->next == NULL);
1075
1076 if (code->expr1->expr_type != EXPR_VARIABLE
1077 || code->expr1->symtree == NULL
1078 || code->expr1->rank != 0
1079 || (code->expr1->ts.type != BT_INTEGER
1080 && code->expr1->ts.type != BT_REAL
1081 && code->expr1->ts.type != BT_COMPLEX
1082 && code->expr1->ts.type != BT_LOGICAL))
1083 {
1084 gfc_error ("!$OMP ATOMIC statement must set a scalar variable of "
1085 "intrinsic type at %L", &code->loc);
1086 return;
1087 }
1088
1089 var = code->expr1->symtree->n.sym;
1090 expr2 = is_conversion (code->expr2, false);
1091 if (expr2 == NULL)
1092 expr2 = code->expr2;
1093
1094 if (expr2->expr_type == EXPR_OP)
1095 {
1096 gfc_expr *v = NULL, *e, *c;
1097 gfc_intrinsic_op op = expr2->value.op.op;
1098 gfc_intrinsic_op alt_op = INTRINSIC_NONE;
1099
1100 switch (op)
1101 {
1102 case INTRINSIC_PLUS:
1103 alt_op = INTRINSIC_MINUS;
1104 break;
1105 case INTRINSIC_TIMES:
1106 alt_op = INTRINSIC_DIVIDE;
1107 break;
1108 case INTRINSIC_MINUS:
1109 alt_op = INTRINSIC_PLUS;
1110 break;
1111 case INTRINSIC_DIVIDE:
1112 alt_op = INTRINSIC_TIMES;
1113 break;
1114 case INTRINSIC_AND:
1115 case INTRINSIC_OR:
1116 break;
1117 case INTRINSIC_EQV:
1118 alt_op = INTRINSIC_NEQV;
1119 break;
1120 case INTRINSIC_NEQV:
1121 alt_op = INTRINSIC_EQV;
1122 break;
1123 default:
1124 gfc_error ("!$OMP ATOMIC assignment operator must be "
1125 "+, *, -, /, .AND., .OR., .EQV. or .NEQV. at %L",
1126 &expr2->where);
1127 return;
1128 }
1129
1130 /* Check for var = var op expr resp. var = expr op var where
1131 expr doesn't reference var and var op expr is mathematically
1132 equivalent to var op (expr) resp. expr op var equivalent to
1133 (expr) op var. We rely here on the fact that the matcher
1134 for x op1 y op2 z where op1 and op2 have equal precedence
1135 returns (x op1 y) op2 z. */
1136 e = expr2->value.op.op2;
1137 if (e->expr_type == EXPR_VARIABLE
1138 && e->symtree != NULL
1139 && e->symtree->n.sym == var)
1140 v = e;
1141 else if ((c = is_conversion (e, true)) != NULL
1142 && c->expr_type == EXPR_VARIABLE
1143 && c->symtree != NULL
1144 && c->symtree->n.sym == var)
1145 v = c;
1146 else
1147 {
1148 gfc_expr **p = NULL, **q;
1149 for (q = &expr2->value.op.op1; (e = *q) != NULL; )
1150 if (e->expr_type == EXPR_VARIABLE
1151 && e->symtree != NULL
1152 && e->symtree->n.sym == var)
1153 {
1154 v = e;
1155 break;
1156 }
1157 else if ((c = is_conversion (e, true)) != NULL)
1158 q = &e->value.function.actual->expr;
1159 else if (e->expr_type != EXPR_OP
1160 || (e->value.op.op != op
1161 && e->value.op.op != alt_op)
1162 || e->rank != 0)
1163 break;
1164 else
1165 {
1166 p = q;
1167 q = &e->value.op.op1;
1168 }
1169
1170 if (v == NULL)
1171 {
1172 gfc_error ("!$OMP ATOMIC assignment must be var = var op expr "
1173 "or var = expr op var at %L", &expr2->where);
1174 return;
1175 }
1176
1177 if (p != NULL)
1178 {
1179 e = *p;
1180 switch (e->value.op.op)
1181 {
1182 case INTRINSIC_MINUS:
1183 case INTRINSIC_DIVIDE:
1184 case INTRINSIC_EQV:
1185 case INTRINSIC_NEQV:
1186 gfc_error ("!$OMP ATOMIC var = var op expr not "
1187 "mathematically equivalent to var = var op "
1188 "(expr) at %L", &expr2->where);
1189 break;
1190 default:
1191 break;
1192 }
1193
1194 /* Canonicalize into var = var op (expr). */
1195 *p = e->value.op.op2;
1196 e->value.op.op2 = expr2;
1197 e->ts = expr2->ts;
1198 if (code->expr2 == expr2)
1199 code->expr2 = expr2 = e;
1200 else
1201 code->expr2->value.function.actual->expr = expr2 = e;
1202
1203 if (!gfc_compare_types (&expr2->value.op.op1->ts, &expr2->ts))
1204 {
1205 for (p = &expr2->value.op.op1; *p != v;
1206 p = &(*p)->value.function.actual->expr)
1207 ;
1208 *p = NULL;
1209 gfc_free_expr (expr2->value.op.op1);
1210 expr2->value.op.op1 = v;
1211 gfc_convert_type (v, &expr2->ts, 2);
1212 }
1213 }
1214 }
1215
1216 if (e->rank != 0 || expr_references_sym (code->expr2, var, v))
1217 {
1218 gfc_error ("expr in !$OMP ATOMIC assignment var = var op expr "
1219 "must be scalar and cannot reference var at %L",
1220 &expr2->where);
1221 return;
1222 }
1223 }
1224 else if (expr2->expr_type == EXPR_FUNCTION
1225 && expr2->value.function.isym != NULL
1226 && expr2->value.function.esym == NULL
1227 && expr2->value.function.actual != NULL
1228 && expr2->value.function.actual->next != NULL)
1229 {
1230 gfc_actual_arglist *arg, *var_arg;
1231
1232 switch (expr2->value.function.isym->id)
1233 {
1234 case GFC_ISYM_MIN:
1235 case GFC_ISYM_MAX:
1236 break;
1237 case GFC_ISYM_IAND:
1238 case GFC_ISYM_IOR:
1239 case GFC_ISYM_IEOR:
1240 if (expr2->value.function.actual->next->next != NULL)
1241 {
1242 gfc_error ("!$OMP ATOMIC assignment intrinsic IAND, IOR "
1243 "or IEOR must have two arguments at %L",
1244 &expr2->where);
1245 return;
1246 }
1247 break;
1248 default:
1249 gfc_error ("!$OMP ATOMIC assignment intrinsic must be "
1250 "MIN, MAX, IAND, IOR or IEOR at %L",
1251 &expr2->where);
1252 return;
1253 }
1254
1255 var_arg = NULL;
1256 for (arg = expr2->value.function.actual; arg; arg = arg->next)
1257 {
1258 if ((arg == expr2->value.function.actual
1259 || (var_arg == NULL && arg->next == NULL))
1260 && arg->expr->expr_type == EXPR_VARIABLE
1261 && arg->expr->symtree != NULL
1262 && arg->expr->symtree->n.sym == var)
1263 var_arg = arg;
1264 else if (expr_references_sym (arg->expr, var, NULL))
1265 gfc_error ("!$OMP ATOMIC intrinsic arguments except one must not "
1266 "reference '%s' at %L", var->name, &arg->expr->where);
1267 if (arg->expr->rank != 0)
1268 gfc_error ("!$OMP ATOMIC intrinsic arguments must be scalar "
1269 "at %L", &arg->expr->where);
1270 }
1271
1272 if (var_arg == NULL)
1273 {
1274 gfc_error ("First or last !$OMP ATOMIC intrinsic argument must "
1275 "be '%s' at %L", var->name, &expr2->where);
1276 return;
1277 }
1278
1279 if (var_arg != expr2->value.function.actual)
1280 {
1281 /* Canonicalize, so that var comes first. */
1282 gcc_assert (var_arg->next == NULL);
1283 for (arg = expr2->value.function.actual;
1284 arg->next != var_arg; arg = arg->next)
1285 ;
1286 var_arg->next = expr2->value.function.actual;
1287 expr2->value.function.actual = var_arg;
1288 arg->next = NULL;
1289 }
1290 }
1291 else
1292 gfc_error ("!$OMP ATOMIC assignment must have an operator or intrinsic "
1293 "on right hand side at %L", &expr2->where);
1294 }
1295
1296
1297 struct omp_context
1298 {
1299 gfc_code *code;
1300 struct pointer_set_t *sharing_clauses;
1301 struct pointer_set_t *private_iterators;
1302 struct omp_context *previous;
1303 } *omp_current_ctx;
1304 static gfc_code *omp_current_do_code;
1305 static int omp_current_do_collapse;
1306
1307 void
1308 gfc_resolve_omp_do_blocks (gfc_code *code, gfc_namespace *ns)
1309 {
1310 if (code->block->next && code->block->next->op == EXEC_DO)
1311 {
1312 int i;
1313 gfc_code *c;
1314
1315 omp_current_do_code = code->block->next;
1316 omp_current_do_collapse = code->ext.omp_clauses->collapse;
1317 for (i = 1, c = omp_current_do_code; i < omp_current_do_collapse; i++)
1318 {
1319 c = c->block;
1320 if (c->op != EXEC_DO || c->next == NULL)
1321 break;
1322 c = c->next;
1323 if (c->op != EXEC_DO)
1324 break;
1325 }
1326 if (i < omp_current_do_collapse || omp_current_do_collapse <= 0)
1327 omp_current_do_collapse = 1;
1328 }
1329 gfc_resolve_blocks (code->block, ns);
1330 omp_current_do_collapse = 0;
1331 omp_current_do_code = NULL;
1332 }
1333
1334
1335 void
1336 gfc_resolve_omp_parallel_blocks (gfc_code *code, gfc_namespace *ns)
1337 {
1338 struct omp_context ctx;
1339 gfc_omp_clauses *omp_clauses = code->ext.omp_clauses;
1340 gfc_namelist *n;
1341 int list;
1342
1343 ctx.code = code;
1344 ctx.sharing_clauses = pointer_set_create ();
1345 ctx.private_iterators = pointer_set_create ();
1346 ctx.previous = omp_current_ctx;
1347 omp_current_ctx = &ctx;
1348
1349 for (list = 0; list < OMP_LIST_NUM; list++)
1350 for (n = omp_clauses->lists[list]; n; n = n->next)
1351 pointer_set_insert (ctx.sharing_clauses, n->sym);
1352
1353 if (code->op == EXEC_OMP_PARALLEL_DO)
1354 gfc_resolve_omp_do_blocks (code, ns);
1355 else
1356 gfc_resolve_blocks (code->block, ns);
1357
1358 omp_current_ctx = ctx.previous;
1359 pointer_set_destroy (ctx.sharing_clauses);
1360 pointer_set_destroy (ctx.private_iterators);
1361 }
1362
1363
1364 /* Note a DO iterator variable. This is special in !$omp parallel
1365 construct, where they are predetermined private. */
1366
1367 void
1368 gfc_resolve_do_iterator (gfc_code *code, gfc_symbol *sym)
1369 {
1370 int i = omp_current_do_collapse;
1371 gfc_code *c = omp_current_do_code;
1372
1373 if (sym->attr.threadprivate)
1374 return;
1375
1376 /* !$omp do and !$omp parallel do iteration variable is predetermined
1377 private just in the !$omp do resp. !$omp parallel do construct,
1378 with no implications for the outer parallel constructs. */
1379
1380 while (i-- >= 1)
1381 {
1382 if (code == c)
1383 return;
1384
1385 c = c->block->next;
1386 }
1387
1388 if (omp_current_ctx == NULL)
1389 return;
1390
1391 if (pointer_set_contains (omp_current_ctx->sharing_clauses, sym))
1392 return;
1393
1394 if (! pointer_set_insert (omp_current_ctx->private_iterators, sym))
1395 {
1396 gfc_omp_clauses *omp_clauses = omp_current_ctx->code->ext.omp_clauses;
1397 gfc_namelist *p;
1398
1399 p = gfc_get_namelist ();
1400 p->sym = sym;
1401 p->next = omp_clauses->lists[OMP_LIST_PRIVATE];
1402 omp_clauses->lists[OMP_LIST_PRIVATE] = p;
1403 }
1404 }
1405
1406
1407 static void
1408 resolve_omp_do (gfc_code *code)
1409 {
1410 gfc_code *do_code, *c;
1411 int list, i, collapse;
1412 gfc_namelist *n;
1413 gfc_symbol *dovar;
1414
1415 if (code->ext.omp_clauses)
1416 resolve_omp_clauses (code);
1417
1418 do_code = code->block->next;
1419 collapse = code->ext.omp_clauses->collapse;
1420 if (collapse <= 0)
1421 collapse = 1;
1422 for (i = 1; i <= collapse; i++)
1423 {
1424 if (do_code->op == EXEC_DO_WHILE)
1425 {
1426 gfc_error ("!$OMP DO cannot be a DO WHILE or DO without loop control "
1427 "at %L", &do_code->loc);
1428 break;
1429 }
1430 gcc_assert (do_code->op == EXEC_DO);
1431 if (do_code->ext.iterator->var->ts.type != BT_INTEGER)
1432 gfc_error ("!$OMP DO iteration variable must be of type integer at %L",
1433 &do_code->loc);
1434 dovar = do_code->ext.iterator->var->symtree->n.sym;
1435 if (dovar->attr.threadprivate)
1436 gfc_error ("!$OMP DO iteration variable must not be THREADPRIVATE "
1437 "at %L", &do_code->loc);
1438 if (code->ext.omp_clauses)
1439 for (list = 0; list < OMP_LIST_NUM; list++)
1440 if (list != OMP_LIST_PRIVATE && list != OMP_LIST_LASTPRIVATE)
1441 for (n = code->ext.omp_clauses->lists[list]; n; n = n->next)
1442 if (dovar == n->sym)
1443 {
1444 gfc_error ("!$OMP DO iteration variable present on clause "
1445 "other than PRIVATE or LASTPRIVATE at %L",
1446 &do_code->loc);
1447 break;
1448 }
1449 if (i > 1)
1450 {
1451 gfc_code *do_code2 = code->block->next;
1452 int j;
1453
1454 for (j = 1; j < i; j++)
1455 {
1456 gfc_symbol *ivar = do_code2->ext.iterator->var->symtree->n.sym;
1457 if (dovar == ivar
1458 || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->start)
1459 || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->end)
1460 || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->step))
1461 {
1462 gfc_error ("!$OMP DO collapsed loops don't form rectangular iteration space at %L",
1463 &do_code->loc);
1464 break;
1465 }
1466 if (j < i)
1467 break;
1468 do_code2 = do_code2->block->next;
1469 }
1470 }
1471 if (i == collapse)
1472 break;
1473 for (c = do_code->next; c; c = c->next)
1474 if (c->op != EXEC_NOP && c->op != EXEC_CONTINUE)
1475 {
1476 gfc_error ("collapsed !$OMP DO loops not perfectly nested at %L",
1477 &c->loc);
1478 break;
1479 }
1480 if (c)
1481 break;
1482 do_code = do_code->block;
1483 if (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE)
1484 {
1485 gfc_error ("not enough DO loops for collapsed !$OMP DO at %L",
1486 &code->loc);
1487 break;
1488 }
1489 do_code = do_code->next;
1490 if (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE)
1491 {
1492 gfc_error ("not enough DO loops for collapsed !$OMP DO at %L",
1493 &code->loc);
1494 break;
1495 }
1496 }
1497 }
1498
1499
1500 /* Resolve OpenMP directive clauses and check various requirements
1501 of each directive. */
1502
1503 void
1504 gfc_resolve_omp_directive (gfc_code *code, gfc_namespace *ns ATTRIBUTE_UNUSED)
1505 {
1506 if (code->op != EXEC_OMP_ATOMIC)
1507 gfc_maybe_initialize_eh ();
1508
1509 switch (code->op)
1510 {
1511 case EXEC_OMP_DO:
1512 case EXEC_OMP_PARALLEL_DO:
1513 resolve_omp_do (code);
1514 break;
1515 case EXEC_OMP_WORKSHARE:
1516 case EXEC_OMP_PARALLEL_WORKSHARE:
1517 case EXEC_OMP_PARALLEL:
1518 case EXEC_OMP_PARALLEL_SECTIONS:
1519 case EXEC_OMP_SECTIONS:
1520 case EXEC_OMP_SINGLE:
1521 if (code->ext.omp_clauses)
1522 resolve_omp_clauses (code);
1523 break;
1524 case EXEC_OMP_ATOMIC:
1525 resolve_omp_atomic (code);
1526 break;
1527 default:
1528 break;
1529 }
1530 }
Mirror of the offical gcc git repository hosted at gcc.gnu.org