1 /* OpenMP directive matching and resolving.
2 Copyright (C) 2005, 2006, 2007, 2008
3 Free Software Foundation, Inc.
4 Contributed by Jakub Jelinek
6 This file is part of GCC.
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
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
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/>. */
28 #include "pointer-set.h"
32 /* Match an end of OpenMP directive. End of OpenMP directive is optional
33 whitespace, followed by '\n' or comment '!'. */
36 gfc_match_omp_eos (void)
41 old_loc
= gfc_current_locus
;
42 gfc_gobble_whitespace ();
44 c
= gfc_next_ascii_char ();
49 c
= gfc_next_ascii_char ();
57 gfc_current_locus
= old_loc
;
61 /* Free an omp_clauses structure. */
64 gfc_free_omp_clauses (gfc_omp_clauses
*c
)
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
]);
78 /* Match a variable/common block list and construct a namelist from it. */
81 gfc_match_omp_variable_list (const char *str
, gfc_namelist
**list
,
84 gfc_namelist
*head
, *tail
, *p
;
86 char n
[GFC_MAX_SYMBOL_LEN
+1];
93 old_loc
= gfc_current_locus
;
101 m
= gfc_match_symbol (&sym
, 1);
105 gfc_set_sym_referenced (sym
);
106 p
= gfc_get_namelist ();
125 m
= gfc_match (" / %n /", n
);
126 if (m
== MATCH_ERROR
)
131 st
= gfc_find_symtree (gfc_current_ns
->common_root
, n
);
134 gfc_error ("COMMON block /%s/ not found at %C", n
);
137 for (sym
= st
->n
.common
->head
; sym
; sym
= sym
->common_next
)
139 gfc_set_sym_referenced (sym
);
140 p
= gfc_get_namelist ();
152 if (gfc_match_char (')') == MATCH_YES
)
154 if (gfc_match_char (',') != MATCH_YES
)
159 list
= &(*list
)->next
;
165 gfc_error ("Syntax error in OpenMP variable list at %C");
168 gfc_free_namelist (head
);
169 gfc_current_locus
= old_loc
;
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)
188 /* Match OpenMP directive clauses. MASK is a bitmask of
189 clauses that are allowed for a particular directive. */
192 gfc_match_omp_clauses (gfc_omp_clauses
**cp
, int mask
)
194 gfc_omp_clauses
*c
= gfc_get_omp_clauses ();
196 bool needs_space
= true, first
= true;
201 if ((first
|| gfc_match_char (',') != MATCH_YES
)
202 && (needs_space
&& gfc_match_space () != MATCH_YES
))
206 gfc_gobble_whitespace ();
207 if ((mask
& OMP_CLAUSE_IF
) && c
->if_expr
== NULL
208 && gfc_match ("if ( %e )", &c
->if_expr
) == MATCH_YES
)
210 if ((mask
& OMP_CLAUSE_NUM_THREADS
) && c
->num_threads
== NULL
211 && gfc_match ("num_threads ( %e )", &c
->num_threads
) == MATCH_YES
)
213 if ((mask
& OMP_CLAUSE_PRIVATE
)
214 && gfc_match_omp_variable_list ("private (",
215 &c
->lists
[OMP_LIST_PRIVATE
], true)
218 if ((mask
& OMP_CLAUSE_FIRSTPRIVATE
)
219 && gfc_match_omp_variable_list ("firstprivate (",
220 &c
->lists
[OMP_LIST_FIRSTPRIVATE
],
224 if ((mask
& OMP_CLAUSE_LASTPRIVATE
)
225 && gfc_match_omp_variable_list ("lastprivate (",
226 &c
->lists
[OMP_LIST_LASTPRIVATE
],
230 if ((mask
& OMP_CLAUSE_COPYPRIVATE
)
231 && gfc_match_omp_variable_list ("copyprivate (",
232 &c
->lists
[OMP_LIST_COPYPRIVATE
],
236 if ((mask
& OMP_CLAUSE_SHARED
)
237 && gfc_match_omp_variable_list ("shared (",
238 &c
->lists
[OMP_LIST_SHARED
], true)
241 if ((mask
& OMP_CLAUSE_COPYIN
)
242 && gfc_match_omp_variable_list ("copyin (",
243 &c
->lists
[OMP_LIST_COPYIN
], true)
246 old_loc
= gfc_current_locus
;
247 if ((mask
& OMP_CLAUSE_REDUCTION
)
248 && gfc_match ("reduction ( ") == MATCH_YES
)
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
)
269 const char *n
= buffer
;
271 gfc_find_symbol (buffer
, NULL
, 1, &sym
);
274 if (sym
->attr
.intrinsic
)
276 else if ((sym
->attr
.flavor
!= FL_UNKNOWN
277 && sym
->attr
.flavor
!= FL_PROCEDURE
)
278 || sym
->attr
.external
283 || sym
->attr
.subroutine
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
)
293 gfc_error_now ("%s is not INTRINSIC procedure name "
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
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
))
319 gfc_free_omp_clauses (c
);
323 if (reduction
!= OMP_LIST_NUM
324 && gfc_match_omp_variable_list (" :", &c
->lists
[reduction
],
329 gfc_current_locus
= old_loc
;
331 if ((mask
& OMP_CLAUSE_DEFAULT
)
332 && c
->default_sharing
== OMP_DEFAULT_UNKNOWN
)
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
)
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
)
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
)
363 if (c
->sched_kind
!= OMP_SCHED_RUNTIME
364 && c
->sched_kind
!= OMP_SCHED_AUTO
)
365 m
= gfc_match (" , %e )", &c
->chunk_size
);
367 m
= gfc_match_char (')');
369 c
->sched_kind
= OMP_SCHED_NONE
;
371 if (c
->sched_kind
!= OMP_SCHED_NONE
)
374 gfc_current_locus
= old_loc
;
376 if ((mask
& OMP_CLAUSE_ORDERED
) && !c
->ordered
377 && gfc_match ("ordered") == MATCH_YES
)
379 c
->ordered
= needs_space
= true;
382 if ((mask
& OMP_CLAUSE_UNTIED
) && !c
->untied
383 && gfc_match ("untied") == MATCH_YES
)
385 c
->untied
= needs_space
= true;
388 if ((mask
& OMP_CLAUSE_COLLAPSE
) && !c
->collapse
)
390 gfc_expr
*cexpr
= NULL
;
391 match m
= gfc_match ("collapse ( %e )", &cexpr
);
396 const char *p
= gfc_extract_int (cexpr
, &collapse
);
402 else if (collapse
<= 0)
404 gfc_error ("COLLAPSE clause argument not constant positive integer at %C");
407 c
->collapse
= collapse
;
408 gfc_free_expr (cexpr
);
416 if (gfc_match_omp_eos () != MATCH_YES
)
418 gfc_free_omp_clauses (c
);
426 #define OMP_PARALLEL_CLAUSES \
427 (OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_SHARED \
428 | OMP_CLAUSE_COPYIN | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_IF \
429 | OMP_CLAUSE_NUM_THREADS | OMP_CLAUSE_DEFAULT)
430 #define OMP_DO_CLAUSES \
431 (OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
432 | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION \
433 | OMP_CLAUSE_SCHEDULE | OMP_CLAUSE_ORDERED | OMP_CLAUSE_COLLAPSE)
434 #define OMP_SECTIONS_CLAUSES \
435 (OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
436 | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION)
437 #define OMP_TASK_CLAUSES \
438 (OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_SHARED \
439 | OMP_CLAUSE_IF | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_UNTIED)
442 gfc_match_omp_parallel (void)
445 if (gfc_match_omp_clauses (&c
, OMP_PARALLEL_CLAUSES
) != MATCH_YES
)
447 new_st
.op
= EXEC_OMP_PARALLEL
;
448 new_st
.ext
.omp_clauses
= c
;
454 gfc_match_omp_task (void)
457 if (gfc_match_omp_clauses (&c
, OMP_TASK_CLAUSES
) != MATCH_YES
)
459 new_st
.op
= EXEC_OMP_TASK
;
460 new_st
.ext
.omp_clauses
= c
;
466 gfc_match_omp_taskwait (void)
468 if (gfc_match_omp_eos () != MATCH_YES
)
470 new_st
.op
= EXEC_OMP_TASKWAIT
;
471 new_st
.ext
.omp_clauses
= NULL
;
477 gfc_match_omp_critical (void)
479 char n
[GFC_MAX_SYMBOL_LEN
+1];
481 if (gfc_match (" ( %n )", n
) != MATCH_YES
)
483 if (gfc_match_omp_eos () != MATCH_YES
)
485 new_st
.op
= EXEC_OMP_CRITICAL
;
486 new_st
.ext
.omp_name
= n
[0] ? xstrdup (n
) : NULL
;
492 gfc_match_omp_do (void)
495 if (gfc_match_omp_clauses (&c
, OMP_DO_CLAUSES
) != MATCH_YES
)
497 new_st
.op
= EXEC_OMP_DO
;
498 new_st
.ext
.omp_clauses
= c
;
504 gfc_match_omp_flush (void)
506 gfc_namelist
*list
= NULL
;
507 gfc_match_omp_variable_list (" (", &list
, true);
508 if (gfc_match_omp_eos () != MATCH_YES
)
510 gfc_free_namelist (list
);
513 new_st
.op
= EXEC_OMP_FLUSH
;
514 new_st
.ext
.omp_namelist
= list
;
520 gfc_match_omp_threadprivate (void)
523 char n
[GFC_MAX_SYMBOL_LEN
+1];
528 old_loc
= gfc_current_locus
;
530 m
= gfc_match (" (");
536 m
= gfc_match_symbol (&sym
, 0);
540 if (sym
->attr
.in_common
)
541 gfc_error_now ("Threadprivate variable at %C is an element of "
543 else if (gfc_add_threadprivate (&sym
->attr
, sym
->name
,
544 &sym
->declared_at
) == FAILURE
)
553 m
= gfc_match (" / %n /", n
);
554 if (m
== MATCH_ERROR
)
556 if (m
== MATCH_NO
|| n
[0] == '\0')
559 st
= gfc_find_symtree (gfc_current_ns
->common_root
, n
);
562 gfc_error ("COMMON block /%s/ not found at %C", n
);
565 st
->n
.common
->threadprivate
= 1;
566 for (sym
= st
->n
.common
->head
; sym
; sym
= sym
->common_next
)
567 if (gfc_add_threadprivate (&sym
->attr
, sym
->name
,
568 &sym
->declared_at
) == FAILURE
)
572 if (gfc_match_char (')') == MATCH_YES
)
574 if (gfc_match_char (',') != MATCH_YES
)
581 gfc_error ("Syntax error in !$OMP THREADPRIVATE list at %C");
584 gfc_current_locus
= old_loc
;
590 gfc_match_omp_parallel_do (void)
593 if (gfc_match_omp_clauses (&c
, OMP_PARALLEL_CLAUSES
| OMP_DO_CLAUSES
)
596 new_st
.op
= EXEC_OMP_PARALLEL_DO
;
597 new_st
.ext
.omp_clauses
= c
;
603 gfc_match_omp_parallel_sections (void)
606 if (gfc_match_omp_clauses (&c
, OMP_PARALLEL_CLAUSES
| OMP_SECTIONS_CLAUSES
)
609 new_st
.op
= EXEC_OMP_PARALLEL_SECTIONS
;
610 new_st
.ext
.omp_clauses
= c
;
616 gfc_match_omp_parallel_workshare (void)
619 if (gfc_match_omp_clauses (&c
, OMP_PARALLEL_CLAUSES
) != MATCH_YES
)
621 new_st
.op
= EXEC_OMP_PARALLEL_WORKSHARE
;
622 new_st
.ext
.omp_clauses
= c
;
628 gfc_match_omp_sections (void)
631 if (gfc_match_omp_clauses (&c
, OMP_SECTIONS_CLAUSES
) != MATCH_YES
)
633 new_st
.op
= EXEC_OMP_SECTIONS
;
634 new_st
.ext
.omp_clauses
= c
;
640 gfc_match_omp_single (void)
643 if (gfc_match_omp_clauses (&c
, OMP_CLAUSE_PRIVATE
| OMP_CLAUSE_FIRSTPRIVATE
)
646 new_st
.op
= EXEC_OMP_SINGLE
;
647 new_st
.ext
.omp_clauses
= c
;
653 gfc_match_omp_workshare (void)
655 if (gfc_match_omp_eos () != MATCH_YES
)
657 new_st
.op
= EXEC_OMP_WORKSHARE
;
658 new_st
.ext
.omp_clauses
= gfc_get_omp_clauses ();
664 gfc_match_omp_master (void)
666 if (gfc_match_omp_eos () != MATCH_YES
)
668 new_st
.op
= EXEC_OMP_MASTER
;
669 new_st
.ext
.omp_clauses
= NULL
;
675 gfc_match_omp_ordered (void)
677 if (gfc_match_omp_eos () != MATCH_YES
)
679 new_st
.op
= EXEC_OMP_ORDERED
;
680 new_st
.ext
.omp_clauses
= NULL
;
686 gfc_match_omp_atomic (void)
688 if (gfc_match_omp_eos () != MATCH_YES
)
690 new_st
.op
= EXEC_OMP_ATOMIC
;
691 new_st
.ext
.omp_clauses
= NULL
;
697 gfc_match_omp_barrier (void)
699 if (gfc_match_omp_eos () != MATCH_YES
)
701 new_st
.op
= EXEC_OMP_BARRIER
;
702 new_st
.ext
.omp_clauses
= NULL
;
708 gfc_match_omp_end_nowait (void)
711 if (gfc_match ("% nowait") == MATCH_YES
)
713 if (gfc_match_omp_eos () != MATCH_YES
)
715 new_st
.op
= EXEC_OMP_END_NOWAIT
;
716 new_st
.ext
.omp_bool
= nowait
;
722 gfc_match_omp_end_single (void)
725 if (gfc_match ("% nowait") == MATCH_YES
)
727 new_st
.op
= EXEC_OMP_END_NOWAIT
;
728 new_st
.ext
.omp_bool
= true;
731 if (gfc_match_omp_clauses (&c
, OMP_CLAUSE_COPYPRIVATE
) != MATCH_YES
)
733 new_st
.op
= EXEC_OMP_END_SINGLE
;
734 new_st
.ext
.omp_clauses
= c
;
739 /* OpenMP directive resolving routines. */
742 resolve_omp_clauses (gfc_code
*code
)
744 gfc_omp_clauses
*omp_clauses
= code
->ext
.omp_clauses
;
747 static const char *clause_names
[]
748 = { "PRIVATE", "FIRSTPRIVATE", "LASTPRIVATE", "COPYPRIVATE", "SHARED",
749 "COPYIN", "REDUCTION" };
751 if (omp_clauses
== NULL
)
754 if (omp_clauses
->if_expr
)
756 gfc_expr
*expr
= omp_clauses
->if_expr
;
757 if (gfc_resolve_expr (expr
) == FAILURE
758 || expr
->ts
.type
!= BT_LOGICAL
|| expr
->rank
!= 0)
759 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
762 if (omp_clauses
->num_threads
)
764 gfc_expr
*expr
= omp_clauses
->num_threads
;
765 if (gfc_resolve_expr (expr
) == FAILURE
766 || expr
->ts
.type
!= BT_INTEGER
|| expr
->rank
!= 0)
767 gfc_error ("NUM_THREADS clause at %L requires a scalar "
768 "INTEGER expression", &expr
->where
);
770 if (omp_clauses
->chunk_size
)
772 gfc_expr
*expr
= omp_clauses
->chunk_size
;
773 if (gfc_resolve_expr (expr
) == FAILURE
774 || expr
->ts
.type
!= BT_INTEGER
|| expr
->rank
!= 0)
775 gfc_error ("SCHEDULE clause's chunk_size at %L requires "
776 "a scalar INTEGER expression", &expr
->where
);
779 /* Check that no symbol appears on multiple clauses, except that
780 a symbol can appear on both firstprivate and lastprivate. */
781 for (list
= 0; list
< OMP_LIST_NUM
; list
++)
782 for (n
= omp_clauses
->lists
[list
]; n
; n
= n
->next
)
785 if (n
->sym
->attr
.flavor
== FL_VARIABLE
)
787 if (n
->sym
->attr
.flavor
== FL_PROCEDURE
788 && n
->sym
->result
== n
->sym
789 && n
->sym
->attr
.function
)
791 if (gfc_current_ns
->proc_name
== n
->sym
792 || (gfc_current_ns
->parent
793 && gfc_current_ns
->parent
->proc_name
== n
->sym
))
795 if (gfc_current_ns
->proc_name
->attr
.entry_master
)
797 gfc_entry_list
*el
= gfc_current_ns
->entries
;
798 for (; el
; el
= el
->next
)
799 if (el
->sym
== n
->sym
)
804 if (gfc_current_ns
->parent
805 && gfc_current_ns
->parent
->proc_name
->attr
.entry_master
)
807 gfc_entry_list
*el
= gfc_current_ns
->parent
->entries
;
808 for (; el
; el
= el
->next
)
809 if (el
->sym
== n
->sym
)
815 gfc_error ("Object '%s' is not a variable at %L", n
->sym
->name
,
819 for (list
= 0; list
< OMP_LIST_NUM
; list
++)
820 if (list
!= OMP_LIST_FIRSTPRIVATE
&& list
!= OMP_LIST_LASTPRIVATE
)
821 for (n
= omp_clauses
->lists
[list
]; n
; n
= n
->next
)
823 gfc_error ("Symbol '%s' present on multiple clauses at %L",
824 n
->sym
->name
, &code
->loc
);
828 gcc_assert (OMP_LIST_LASTPRIVATE
== OMP_LIST_FIRSTPRIVATE
+ 1);
829 for (list
= OMP_LIST_FIRSTPRIVATE
; list
<= OMP_LIST_LASTPRIVATE
; list
++)
830 for (n
= omp_clauses
->lists
[list
]; n
; n
= n
->next
)
833 gfc_error ("Symbol '%s' present on multiple clauses at %L",
834 n
->sym
->name
, &code
->loc
);
838 for (n
= omp_clauses
->lists
[OMP_LIST_FIRSTPRIVATE
]; n
; n
= n
->next
)
840 gfc_error ("Symbol '%s' present on multiple clauses at %L",
841 n
->sym
->name
, &code
->loc
);
845 for (n
= omp_clauses
->lists
[OMP_LIST_LASTPRIVATE
]; n
; n
= n
->next
)
848 for (n
= omp_clauses
->lists
[OMP_LIST_LASTPRIVATE
]; n
; n
= n
->next
)
850 gfc_error ("Symbol '%s' present on multiple clauses at %L",
851 n
->sym
->name
, &code
->loc
);
855 for (list
= 0; list
< OMP_LIST_NUM
; list
++)
856 if ((n
= omp_clauses
->lists
[list
]) != NULL
)
860 if (list
< OMP_LIST_REDUCTION_FIRST
)
861 name
= clause_names
[list
];
862 else if (list
<= OMP_LIST_REDUCTION_LAST
)
863 name
= clause_names
[OMP_LIST_REDUCTION_FIRST
];
869 case OMP_LIST_COPYIN
:
870 for (; n
!= NULL
; n
= n
->next
)
872 if (!n
->sym
->attr
.threadprivate
)
873 gfc_error ("Non-THREADPRIVATE object '%s' in COPYIN clause"
874 " at %L", n
->sym
->name
, &code
->loc
);
875 if (n
->sym
->ts
.type
== BT_DERIVED
&& n
->sym
->ts
.derived
->attr
.alloc_comp
)
876 gfc_error ("COPYIN clause object '%s' at %L has ALLOCATABLE components",
877 n
->sym
->name
, &code
->loc
);
880 case OMP_LIST_COPYPRIVATE
:
881 for (; n
!= NULL
; n
= n
->next
)
883 if (n
->sym
->as
&& n
->sym
->as
->type
== AS_ASSUMED_SIZE
)
884 gfc_error ("Assumed size array '%s' in COPYPRIVATE clause "
885 "at %L", n
->sym
->name
, &code
->loc
);
886 if (n
->sym
->ts
.type
== BT_DERIVED
&& n
->sym
->ts
.derived
->attr
.alloc_comp
)
887 gfc_error ("COPYPRIVATE clause object '%s' at %L has ALLOCATABLE components",
888 n
->sym
->name
, &code
->loc
);
891 case OMP_LIST_SHARED
:
892 for (; n
!= NULL
; n
= n
->next
)
894 if (n
->sym
->attr
.threadprivate
)
895 gfc_error ("THREADPRIVATE object '%s' in SHARED clause at "
896 "%L", n
->sym
->name
, &code
->loc
);
897 if (n
->sym
->attr
.cray_pointee
)
898 gfc_error ("Cray pointee '%s' in SHARED clause at %L",
899 n
->sym
->name
, &code
->loc
);
903 for (; n
!= NULL
; n
= n
->next
)
905 if (n
->sym
->attr
.threadprivate
)
906 gfc_error ("THREADPRIVATE object '%s' in %s clause at %L",
907 n
->sym
->name
, name
, &code
->loc
);
908 if (n
->sym
->attr
.cray_pointee
)
909 gfc_error ("Cray pointee '%s' in %s clause at %L",
910 n
->sym
->name
, name
, &code
->loc
);
911 if (list
!= OMP_LIST_PRIVATE
)
913 if (n
->sym
->attr
.pointer
)
914 gfc_error ("POINTER object '%s' in %s clause at %L",
915 n
->sym
->name
, name
, &code
->loc
);
916 /* Variables in REDUCTION-clauses must be of intrinsic type (flagged below). */
917 if ((list
< OMP_LIST_REDUCTION_FIRST
|| list
> OMP_LIST_REDUCTION_LAST
) &&
918 n
->sym
->ts
.type
== BT_DERIVED
&& n
->sym
->ts
.derived
->attr
.alloc_comp
)
919 gfc_error ("%s clause object '%s' has ALLOCATABLE components at %L",
920 name
, n
->sym
->name
, &code
->loc
);
921 if (n
->sym
->attr
.cray_pointer
)
922 gfc_error ("Cray pointer '%s' in %s clause at %L",
923 n
->sym
->name
, name
, &code
->loc
);
925 if (n
->sym
->as
&& n
->sym
->as
->type
== AS_ASSUMED_SIZE
)
926 gfc_error ("Assumed size array '%s' in %s clause at %L",
927 n
->sym
->name
, name
, &code
->loc
);
928 if (n
->sym
->attr
.in_namelist
929 && (list
< OMP_LIST_REDUCTION_FIRST
930 || list
> OMP_LIST_REDUCTION_LAST
))
931 gfc_error ("Variable '%s' in %s clause is used in "
932 "NAMELIST statement at %L",
933 n
->sym
->name
, name
, &code
->loc
);
939 if (!gfc_numeric_ts (&n
->sym
->ts
))
940 gfc_error ("%c REDUCTION variable '%s' at %L must be of numeric type, got %s",
941 list
== OMP_LIST_PLUS
? '+'
942 : list
== OMP_LIST_MULT
? '*' : '-',
943 n
->sym
->name
, &code
->loc
,
944 gfc_typename (&n
->sym
->ts
));
950 if (n
->sym
->ts
.type
!= BT_LOGICAL
)
951 gfc_error ("%s REDUCTION variable '%s' must be LOGICAL "
953 list
== OMP_LIST_AND
? ".AND."
954 : list
== OMP_LIST_OR
? ".OR."
955 : list
== OMP_LIST_EQV
? ".EQV." : ".NEQV.",
956 n
->sym
->name
, &code
->loc
);
960 if (n
->sym
->ts
.type
!= BT_INTEGER
961 && n
->sym
->ts
.type
!= BT_REAL
)
962 gfc_error ("%s REDUCTION variable '%s' must be "
963 "INTEGER or REAL at %L",
964 list
== OMP_LIST_MAX
? "MAX" : "MIN",
965 n
->sym
->name
, &code
->loc
);
970 if (n
->sym
->ts
.type
!= BT_INTEGER
)
971 gfc_error ("%s REDUCTION variable '%s' must be INTEGER "
973 list
== OMP_LIST_IAND
? "IAND"
974 : list
== OMP_LIST_MULT
? "IOR" : "IEOR",
975 n
->sym
->name
, &code
->loc
);
977 /* Workaround for PR middle-end/26316, nothing really needs
978 to be done here for OMP_LIST_PRIVATE. */
979 case OMP_LIST_PRIVATE
:
980 gcc_assert (code
->op
!= EXEC_NOP
);
991 /* Return true if SYM is ever referenced in EXPR except in the SE node. */
994 expr_references_sym (gfc_expr
*e
, gfc_symbol
*s
, gfc_expr
*se
)
996 gfc_actual_arglist
*arg
;
997 if (e
== NULL
|| e
== se
)
999 switch (e
->expr_type
)
1004 case EXPR_STRUCTURE
:
1006 if (e
->symtree
!= NULL
1007 && e
->symtree
->n
.sym
== s
)
1010 case EXPR_SUBSTRING
:
1012 && (expr_references_sym (e
->ref
->u
.ss
.start
, s
, se
)
1013 || expr_references_sym (e
->ref
->u
.ss
.end
, s
, se
)))
1017 if (expr_references_sym (e
->value
.op
.op2
, s
, se
))
1019 return expr_references_sym (e
->value
.op
.op1
, s
, se
);
1021 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
1022 if (expr_references_sym (arg
->expr
, s
, se
))
1031 /* If EXPR is a conversion function that widens the type
1032 if WIDENING is true or narrows the type if WIDENING is false,
1033 return the inner expression, otherwise return NULL. */
1036 is_conversion (gfc_expr
*expr
, bool widening
)
1038 gfc_typespec
*ts1
, *ts2
;
1040 if (expr
->expr_type
!= EXPR_FUNCTION
1041 || expr
->value
.function
.isym
== NULL
1042 || expr
->value
.function
.esym
!= NULL
1043 || expr
->value
.function
.isym
->id
!= GFC_ISYM_CONVERSION
)
1049 ts2
= &expr
->value
.function
.actual
->expr
->ts
;
1053 ts1
= &expr
->value
.function
.actual
->expr
->ts
;
1057 if (ts1
->type
> ts2
->type
1058 || (ts1
->type
== ts2
->type
&& ts1
->kind
> ts2
->kind
))
1059 return expr
->value
.function
.actual
->expr
;
1066 resolve_omp_atomic (gfc_code
*code
)
1071 code
= code
->block
->next
;
1072 gcc_assert (code
->op
== EXEC_ASSIGN
);
1073 gcc_assert (code
->next
== NULL
);
1075 if (code
->expr
->expr_type
!= EXPR_VARIABLE
1076 || code
->expr
->symtree
== NULL
1077 || code
->expr
->rank
!= 0
1078 || (code
->expr
->ts
.type
!= BT_INTEGER
1079 && code
->expr
->ts
.type
!= BT_REAL
1080 && code
->expr
->ts
.type
!= BT_COMPLEX
1081 && code
->expr
->ts
.type
!= BT_LOGICAL
))
1083 gfc_error ("!$OMP ATOMIC statement must set a scalar variable of "
1084 "intrinsic type at %L", &code
->loc
);
1088 var
= code
->expr
->symtree
->n
.sym
;
1089 expr2
= is_conversion (code
->expr2
, false);
1091 expr2
= code
->expr2
;
1093 if (expr2
->expr_type
== EXPR_OP
)
1095 gfc_expr
*v
= NULL
, *e
, *c
;
1096 gfc_intrinsic_op op
= expr2
->value
.op
.operator;
1097 gfc_intrinsic_op alt_op
= INTRINSIC_NONE
;
1101 case INTRINSIC_PLUS
:
1102 alt_op
= INTRINSIC_MINUS
;
1104 case INTRINSIC_TIMES
:
1105 alt_op
= INTRINSIC_DIVIDE
;
1107 case INTRINSIC_MINUS
:
1108 alt_op
= INTRINSIC_PLUS
;
1110 case INTRINSIC_DIVIDE
:
1111 alt_op
= INTRINSIC_TIMES
;
1117 alt_op
= INTRINSIC_NEQV
;
1119 case INTRINSIC_NEQV
:
1120 alt_op
= INTRINSIC_EQV
;
1123 gfc_error ("!$OMP ATOMIC assignment operator must be "
1124 "+, *, -, /, .AND., .OR., .EQV. or .NEQV. at %L",
1129 /* Check for var = var op expr resp. var = expr op var where
1130 expr doesn't reference var and var op expr is mathematically
1131 equivalent to var op (expr) resp. expr op var equivalent to
1132 (expr) op var. We rely here on the fact that the matcher
1133 for x op1 y op2 z where op1 and op2 have equal precedence
1134 returns (x op1 y) op2 z. */
1135 e
= expr2
->value
.op
.op2
;
1136 if (e
->expr_type
== EXPR_VARIABLE
1137 && e
->symtree
!= NULL
1138 && e
->symtree
->n
.sym
== var
)
1140 else if ((c
= is_conversion (e
, true)) != NULL
1141 && c
->expr_type
== EXPR_VARIABLE
1142 && c
->symtree
!= NULL
1143 && c
->symtree
->n
.sym
== var
)
1147 gfc_expr
**p
= NULL
, **q
;
1148 for (q
= &expr2
->value
.op
.op1
; (e
= *q
) != NULL
; )
1149 if (e
->expr_type
== EXPR_VARIABLE
1150 && e
->symtree
!= NULL
1151 && e
->symtree
->n
.sym
== var
)
1156 else if ((c
= is_conversion (e
, true)) != NULL
)
1157 q
= &e
->value
.function
.actual
->expr
;
1158 else if (e
->expr_type
!= EXPR_OP
1159 || (e
->value
.op
.operator != op
1160 && e
->value
.op
.operator != alt_op
)
1166 q
= &e
->value
.op
.op1
;
1171 gfc_error ("!$OMP ATOMIC assignment must be var = var op expr "
1172 "or var = expr op var at %L", &expr2
->where
);
1179 switch (e
->value
.op
.operator)
1181 case INTRINSIC_MINUS
:
1182 case INTRINSIC_DIVIDE
:
1184 case INTRINSIC_NEQV
:
1185 gfc_error ("!$OMP ATOMIC var = var op expr not "
1186 "mathematically equivalent to var = var op "
1187 "(expr) at %L", &expr2
->where
);
1193 /* Canonicalize into var = var op (expr). */
1194 *p
= e
->value
.op
.op2
;
1195 e
->value
.op
.op2
= expr2
;
1197 if (code
->expr2
== expr2
)
1198 code
->expr2
= expr2
= e
;
1200 code
->expr2
->value
.function
.actual
->expr
= expr2
= e
;
1202 if (!gfc_compare_types (&expr2
->value
.op
.op1
->ts
, &expr2
->ts
))
1204 for (p
= &expr2
->value
.op
.op1
; *p
!= v
;
1205 p
= &(*p
)->value
.function
.actual
->expr
)
1208 gfc_free_expr (expr2
->value
.op
.op1
);
1209 expr2
->value
.op
.op1
= v
;
1210 gfc_convert_type (v
, &expr2
->ts
, 2);
1215 if (e
->rank
!= 0 || expr_references_sym (code
->expr2
, var
, v
))
1217 gfc_error ("expr in !$OMP ATOMIC assignment var = var op expr "
1218 "must be scalar and cannot reference var at %L",
1223 else if (expr2
->expr_type
== EXPR_FUNCTION
1224 && expr2
->value
.function
.isym
!= NULL
1225 && expr2
->value
.function
.esym
== NULL
1226 && expr2
->value
.function
.actual
!= NULL
1227 && expr2
->value
.function
.actual
->next
!= NULL
)
1229 gfc_actual_arglist
*arg
, *var_arg
;
1231 switch (expr2
->value
.function
.isym
->id
)
1239 if (expr2
->value
.function
.actual
->next
->next
!= NULL
)
1241 gfc_error ("!$OMP ATOMIC assignment intrinsic IAND, IOR "
1242 "or IEOR must have two arguments at %L",
1248 gfc_error ("!$OMP ATOMIC assignment intrinsic must be "
1249 "MIN, MAX, IAND, IOR or IEOR at %L",
1255 for (arg
= expr2
->value
.function
.actual
; arg
; arg
= arg
->next
)
1257 if ((arg
== expr2
->value
.function
.actual
1258 || (var_arg
== NULL
&& arg
->next
== NULL
))
1259 && arg
->expr
->expr_type
== EXPR_VARIABLE
1260 && arg
->expr
->symtree
!= NULL
1261 && arg
->expr
->symtree
->n
.sym
== var
)
1263 else if (expr_references_sym (arg
->expr
, var
, NULL
))
1264 gfc_error ("!$OMP ATOMIC intrinsic arguments except one must not "
1265 "reference '%s' at %L", var
->name
, &arg
->expr
->where
);
1266 if (arg
->expr
->rank
!= 0)
1267 gfc_error ("!$OMP ATOMIC intrinsic arguments must be scalar "
1268 "at %L", &arg
->expr
->where
);
1271 if (var_arg
== NULL
)
1273 gfc_error ("First or last !$OMP ATOMIC intrinsic argument must "
1274 "be '%s' at %L", var
->name
, &expr2
->where
);
1278 if (var_arg
!= expr2
->value
.function
.actual
)
1280 /* Canonicalize, so that var comes first. */
1281 gcc_assert (var_arg
->next
== NULL
);
1282 for (arg
= expr2
->value
.function
.actual
;
1283 arg
->next
!= var_arg
; arg
= arg
->next
)
1285 var_arg
->next
= expr2
->value
.function
.actual
;
1286 expr2
->value
.function
.actual
= var_arg
;
1291 gfc_error ("!$OMP ATOMIC assignment must have an operator or intrinsic "
1292 "on right hand side at %L", &expr2
->where
);
1299 struct pointer_set_t
*sharing_clauses
;
1300 struct pointer_set_t
*private_iterators
;
1301 struct omp_context
*previous
;
1303 static gfc_code
*omp_current_do_code
;
1304 static int omp_current_do_collapse
;
1307 gfc_resolve_omp_do_blocks (gfc_code
*code
, gfc_namespace
*ns
)
1309 if (code
->block
->next
&& code
->block
->next
->op
== EXEC_DO
)
1314 omp_current_do_code
= code
->block
->next
;
1315 omp_current_do_collapse
= code
->ext
.omp_clauses
->collapse
;
1316 for (i
= 1, c
= omp_current_do_code
; i
< omp_current_do_collapse
; i
++)
1319 if (c
->op
!= EXEC_DO
|| c
->next
== NULL
)
1322 if (c
->op
!= EXEC_DO
)
1325 if (i
< omp_current_do_collapse
|| omp_current_do_collapse
<= 0)
1326 omp_current_do_collapse
= 1;
1328 gfc_resolve_blocks (code
->block
, ns
);
1329 omp_current_do_collapse
= 0;
1330 omp_current_do_code
= NULL
;
1335 gfc_resolve_omp_parallel_blocks (gfc_code
*code
, gfc_namespace
*ns
)
1337 struct omp_context ctx
;
1338 gfc_omp_clauses
*omp_clauses
= code
->ext
.omp_clauses
;
1343 ctx
.sharing_clauses
= pointer_set_create ();
1344 ctx
.private_iterators
= pointer_set_create ();
1345 ctx
.previous
= omp_current_ctx
;
1346 omp_current_ctx
= &ctx
;
1348 for (list
= 0; list
< OMP_LIST_NUM
; list
++)
1349 for (n
= omp_clauses
->lists
[list
]; n
; n
= n
->next
)
1350 pointer_set_insert (ctx
.sharing_clauses
, n
->sym
);
1352 if (code
->op
== EXEC_OMP_PARALLEL_DO
)
1353 gfc_resolve_omp_do_blocks (code
, ns
);
1355 gfc_resolve_blocks (code
->block
, ns
);
1357 omp_current_ctx
= ctx
.previous
;
1358 pointer_set_destroy (ctx
.sharing_clauses
);
1359 pointer_set_destroy (ctx
.private_iterators
);
1363 /* Note a DO iterator variable. This is special in !$omp parallel
1364 construct, where they are predetermined private. */
1367 gfc_resolve_do_iterator (gfc_code
*code
, gfc_symbol
*sym
)
1369 struct omp_context
*ctx
;
1370 int i
= omp_current_do_collapse
;
1371 gfc_code
*c
= omp_current_do_code
;
1373 if (sym
->attr
.threadprivate
)
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. */
1388 for (ctx
= omp_current_ctx
; ctx
; ctx
= ctx
->previous
)
1390 if (pointer_set_contains (ctx
->sharing_clauses
, sym
))
1393 if (! pointer_set_insert (ctx
->private_iterators
, sym
))
1395 gfc_omp_clauses
*omp_clauses
= ctx
->code
->ext
.omp_clauses
;
1398 p
= gfc_get_namelist ();
1400 p
->next
= omp_clauses
->lists
[OMP_LIST_PRIVATE
];
1401 omp_clauses
->lists
[OMP_LIST_PRIVATE
] = p
;
1408 resolve_omp_do (gfc_code
*code
)
1410 gfc_code
*do_code
, *c
;
1411 int list
, i
, collapse
;
1415 if (code
->ext
.omp_clauses
)
1416 resolve_omp_clauses (code
);
1418 do_code
= code
->block
->next
;
1419 collapse
= code
->ext
.omp_clauses
->collapse
;
1422 for (i
= 1; i
<= collapse
; i
++)
1424 if (do_code
->op
== EXEC_DO_WHILE
)
1426 gfc_error ("!$OMP DO cannot be a DO WHILE or DO without loop control "
1427 "at %L", &do_code
->loc
);
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",
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
)
1444 gfc_error ("!$OMP DO iteration variable present on clause "
1445 "other than PRIVATE or LASTPRIVATE at %L",
1451 gfc_code
*do_code2
= code
->block
->next
;
1454 for (j
= 1; j
< i
; j
++)
1456 gfc_symbol
*ivar
= do_code2
->ext
.iterator
->var
->symtree
->n
.sym
;
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
))
1462 gfc_error ("!$OMP DO collapsed loops don't form rectangular iteration space at %L",
1468 do_code2
= do_code2
->block
->next
;
1473 for (c
= do_code
->next
; c
; c
= c
->next
)
1474 if (c
->op
!= EXEC_NOP
&& c
->op
!= EXEC_CONTINUE
)
1476 gfc_error ("collapsed !$OMP DO loops not perfectly nested at %L",
1482 do_code
= do_code
->block
;
1483 if (do_code
->op
!= EXEC_DO
&& do_code
->op
!= EXEC_DO_WHILE
)
1485 gfc_error ("not enough DO loops for collapsed !$OMP DO at %L",
1489 do_code
= do_code
->next
;
1490 if (do_code
->op
!= EXEC_DO
&& do_code
->op
!= EXEC_DO_WHILE
)
1492 gfc_error ("not enough DO loops for collapsed !$OMP DO at %L",
1500 /* Resolve OpenMP directive clauses and check various requirements
1501 of each directive. */
1504 gfc_resolve_omp_directive (gfc_code
*code
, gfc_namespace
*ns ATTRIBUTE_UNUSED
)
1509 case EXEC_OMP_PARALLEL_DO
:
1510 resolve_omp_do (code
);
1512 case EXEC_OMP_WORKSHARE
:
1513 case EXEC_OMP_PARALLEL_WORKSHARE
:
1514 case EXEC_OMP_PARALLEL
:
1515 case EXEC_OMP_PARALLEL_SECTIONS
:
1516 case EXEC_OMP_SECTIONS
:
1517 case EXEC_OMP_SINGLE
:
1518 if (code
->ext
.omp_clauses
)
1519 resolve_omp_clauses (code
);
1521 case EXEC_OMP_ATOMIC
:
1522 resolve_omp_atomic (code
);