Branch data Line data Source code
1 : : /* OpenMP directive translation -- generate GCC trees from gfc_code.
2 : : Copyright (C) 2005-2024 Free Software Foundation, Inc.
3 : : Contributed by Jakub Jelinek <jakub@redhat.com>
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 : :
22 : : #include "config.h"
23 : : #include "system.h"
24 : : #include "coretypes.h"
25 : : #include "options.h"
26 : : #include "tree.h"
27 : : #include "gfortran.h"
28 : : #include "gimple-expr.h"
29 : : #include "trans.h"
30 : : #include "stringpool.h"
31 : : #include "fold-const.h"
32 : : #include "gimplify.h" /* For create_tmp_var_raw. */
33 : : #include "trans-stmt.h"
34 : : #include "trans-types.h"
35 : : #include "trans-array.h"
36 : : #include "trans-const.h"
37 : : #include "arith.h"
38 : : #include "constructor.h"
39 : : #include "gomp-constants.h"
40 : : #include "omp-general.h"
41 : : #include "omp-low.h"
42 : : #include "memmodel.h" /* For MEMMODEL_ enums. */
43 : : #include "dependency.h"
44 : :
45 : : #undef GCC_DIAG_STYLE
46 : : #define GCC_DIAG_STYLE __gcc_tdiag__
47 : : #include "diagnostic-core.h"
48 : : #undef GCC_DIAG_STYLE
49 : : #define GCC_DIAG_STYLE __gcc_gfc__
50 : : #include "attribs.h"
51 : : #include "function.h"
52 : :
53 : : int ompws_flags;
54 : :
55 : : /* True if OpenMP should regard this DECL as being a scalar which has Fortran's
56 : : allocatable or pointer attribute. */
57 : :
58 : : bool
59 : 5911 : gfc_omp_is_allocatable_or_ptr (const_tree decl)
60 : : {
61 : 5911 : return (DECL_P (decl)
62 : 5911 : && (GFC_DECL_GET_SCALAR_POINTER (decl)
63 : 4180 : || GFC_DECL_GET_SCALAR_ALLOCATABLE (decl)));
64 : : }
65 : :
66 : : /* True if the argument is an optional argument; except that false is also
67 : : returned for arguments with the value attribute (nonpointers) and for
68 : : assumed-shape variables (decl is a local variable containing arg->data).
69 : : Note that for 'procedure(), optional' the value false is used as that's
70 : : always a pointer and no additional indirection is used.
71 : : Note that pvoid_type_node is for 'type(c_ptr), value' (and c_funloc). */
72 : :
73 : : static bool
74 : 45166 : gfc_omp_is_optional_argument (const_tree decl)
75 : : {
76 : : /* Note: VAR_DECL can occur with BIND(C) and array descriptors. */
77 : 29817 : return ((TREE_CODE (decl) == PARM_DECL || VAR_P (decl))
78 : 45166 : && DECL_LANG_SPECIFIC (decl)
79 : 20542 : && TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE
80 : 20360 : && !VOID_TYPE_P (TREE_TYPE (TREE_TYPE (decl)))
81 : 20129 : && TREE_CODE (TREE_TYPE (TREE_TYPE (decl))) != FUNCTION_TYPE
82 : 65271 : && GFC_DECL_OPTIONAL_ARGUMENT (decl));
83 : : }
84 : :
85 : : /* Check whether this DECL belongs to a Fortran optional argument.
86 : : With 'for_present_check' set to false, decls which are optional parameters
87 : : themselves are returned as tree - or a NULL_TREE otherwise. Those decls are
88 : : always pointers. With 'for_present_check' set to true, the decl for checking
89 : : whether an argument is present is returned; for arguments with value
90 : : attribute this is the hidden argument and of BOOLEAN_TYPE. If the decl is
91 : : unrelated to optional arguments, NULL_TREE is returned. */
92 : :
93 : : tree
94 : 20967 : gfc_omp_check_optional_argument (tree decl, bool for_present_check)
95 : : {
96 : 20967 : if (!for_present_check)
97 : 2104 : return gfc_omp_is_optional_argument (decl) ? decl : NULL_TREE;
98 : :
99 : 18863 : if (!DECL_LANG_SPECIFIC (decl))
100 : : return NULL_TREE;
101 : :
102 : 5012 : tree orig_decl = decl;
103 : :
104 : : /* For assumed-shape arrays, a local decl with arg->data is used. */
105 : 5012 : if (TREE_CODE (decl) != PARM_DECL
106 : 5012 : && (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
107 : 1648 : || GFC_ARRAY_TYPE_P (TREE_TYPE (decl))))
108 : 722 : decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
109 : :
110 : : /* Note: With BIND(C), array descriptors are converted to a VAR_DECL. */
111 : 5012 : if (decl == NULL_TREE
112 : 4893 : || (TREE_CODE (decl) != PARM_DECL && TREE_CODE (decl) != VAR_DECL)
113 : 4893 : || !DECL_LANG_SPECIFIC (decl)
114 : 9503 : || !GFC_DECL_OPTIONAL_ARGUMENT (decl))
115 : : return NULL_TREE;
116 : :
117 : : /* Scalars with VALUE attribute which are passed by value use a hidden
118 : : argument to denote the present status. They are passed as nonpointer type
119 : : with one exception: 'type(c_ptr), value' as 'void*'. */
120 : : /* Cf. trans-expr.cc's gfc_conv_expr_present. */
121 : 2810 : if (TREE_CODE (TREE_TYPE (decl)) != POINTER_TYPE
122 : 2810 : || VOID_TYPE_P (TREE_TYPE (TREE_TYPE (decl))))
123 : : {
124 : 205 : char name[GFC_MAX_SYMBOL_LEN + 2];
125 : 205 : tree tree_name;
126 : :
127 : 205 : name[0] = '.';
128 : 205 : strcpy (&name[1], IDENTIFIER_POINTER (DECL_NAME (decl)));
129 : 205 : tree_name = get_identifier (name);
130 : :
131 : : /* Walk function argument list to find the hidden arg. */
132 : 205 : decl = DECL_ARGUMENTS (DECL_CONTEXT (decl));
133 : 1437 : for ( ; decl != NULL_TREE; decl = TREE_CHAIN (decl))
134 : 1437 : if (DECL_NAME (decl) == tree_name
135 : 1437 : && DECL_ARTIFICIAL (decl))
136 : : break;
137 : :
138 : 205 : gcc_assert (decl);
139 : 205 : return decl;
140 : : }
141 : :
142 : 2605 : return fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
143 : 2605 : orig_decl, null_pointer_node);
144 : : }
145 : :
146 : :
147 : : /* Returns tree with NULL if it is not an array descriptor and with the tree to
148 : : access the 'data' component otherwise. With type_only = true, it returns the
149 : : TREE_TYPE without creating a new tree. */
150 : :
151 : : tree
152 : 18257 : gfc_omp_array_data (tree decl, bool type_only)
153 : : {
154 : 18257 : tree type = TREE_TYPE (decl);
155 : :
156 : 18257 : if (POINTER_TYPE_P (type))
157 : 9997 : type = TREE_TYPE (type);
158 : :
159 : 18257 : if (!GFC_DESCRIPTOR_TYPE_P (type))
160 : : return NULL_TREE;
161 : :
162 : 4540 : if (type_only)
163 : 3322 : return GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
164 : :
165 : 1218 : if (POINTER_TYPE_P (TREE_TYPE (decl)))
166 : 414 : decl = build_fold_indirect_ref (decl);
167 : :
168 : 1218 : decl = gfc_conv_descriptor_data_get (decl);
169 : 1218 : STRIP_NOPS (decl);
170 : 1218 : return decl;
171 : : }
172 : :
173 : : /* Return the byte-size of the passed array descriptor. */
174 : :
175 : : tree
176 : 18 : gfc_omp_array_size (tree decl, gimple_seq *pre_p)
177 : : {
178 : 18 : stmtblock_t block;
179 : 18 : if (POINTER_TYPE_P (TREE_TYPE (decl)))
180 : 18 : decl = build_fold_indirect_ref (decl);
181 : 18 : tree type = TREE_TYPE (decl);
182 : 18 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
183 : 18 : bool allocatable = (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE
184 : 2 : || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER
185 : 18 : || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT);
186 : 18 : gfc_init_block (&block);
187 : 54 : tree size = gfc_full_array_size (&block, decl,
188 : 18 : GFC_TYPE_ARRAY_RANK (TREE_TYPE (decl)));
189 : 18 : size = fold_convert (size_type_node, size);
190 : 18 : tree elemsz = gfc_get_element_type (TREE_TYPE (decl));
191 : 18 : if (TREE_CODE (elemsz) == ARRAY_TYPE && TYPE_STRING_FLAG (elemsz))
192 : 6 : elemsz = gfc_conv_descriptor_elem_len (decl);
193 : : else
194 : 12 : elemsz = TYPE_SIZE_UNIT (elemsz);
195 : 18 : size = fold_build2 (MULT_EXPR, size_type_node, size, elemsz);
196 : 18 : if (!allocatable)
197 : 0 : gimplify_and_add (gfc_finish_block (&block), pre_p);
198 : : else
199 : : {
200 : 18 : tree var = create_tmp_var (size_type_node);
201 : 18 : gfc_add_expr_to_block (&block, build2 (MODIFY_EXPR, sizetype, var, size));
202 : 18 : tree tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
203 : : gfc_conv_descriptor_data_get (decl),
204 : : null_pointer_node);
205 : 18 : tmp = build3_loc (input_location, COND_EXPR, void_type_node, tmp,
206 : : gfc_finish_block (&block),
207 : : build2 (MODIFY_EXPR, sizetype, var, size_zero_node));
208 : 18 : gimplify_and_add (tmp, pre_p);
209 : 18 : size = var;
210 : : }
211 : 18 : return size;
212 : : }
213 : :
214 : :
215 : : /* True if OpenMP should privatize what this DECL points to rather
216 : : than the DECL itself. */
217 : :
218 : : bool
219 : 450346 : gfc_omp_privatize_by_reference (const_tree decl)
220 : : {
221 : 450346 : tree type = TREE_TYPE (decl);
222 : :
223 : 450346 : if (TREE_CODE (type) == REFERENCE_TYPE
224 : 450346 : && (!DECL_ARTIFICIAL (decl) || TREE_CODE (decl) == PARM_DECL))
225 : : return true;
226 : :
227 : 427518 : if (TREE_CODE (type) == POINTER_TYPE
228 : 427518 : && gfc_omp_is_optional_argument (decl))
229 : : return true;
230 : :
231 : 418470 : if (TREE_CODE (type) == POINTER_TYPE)
232 : : {
233 : 31981 : while (TREE_CODE (decl) == COMPONENT_REF)
234 : 0 : decl = TREE_OPERAND (decl, 1);
235 : :
236 : : /* Array POINTER/ALLOCATABLE have aggregate types, all user variables
237 : : that have POINTER_TYPE type and aren't scalar pointers, scalar
238 : : allocatables, Cray pointees or C pointers are supposed to be
239 : : privatized by reference. */
240 : 31981 : if (GFC_DECL_GET_SCALAR_POINTER (decl)
241 : 30483 : || GFC_DECL_GET_SCALAR_ALLOCATABLE (decl)
242 : 28246 : || GFC_DECL_CRAY_POINTEE (decl)
243 : 28240 : || GFC_DECL_ASSOCIATE_VAR_P (decl)
244 : 37474 : || VOID_TYPE_P (TREE_TYPE (TREE_TYPE (decl))))
245 : : return false;
246 : :
247 : 20479 : if (!DECL_ARTIFICIAL (decl)
248 : 20479 : && TREE_CODE (TREE_TYPE (type)) != FUNCTION_TYPE)
249 : : return true;
250 : :
251 : : /* Some arrays are expanded as DECL_ARTIFICIAL pointers
252 : : by the frontend. */
253 : 13359 : if (DECL_LANG_SPECIFIC (decl)
254 : 13359 : && GFC_DECL_SAVED_DESCRIPTOR (decl))
255 : : return true;
256 : : }
257 : :
258 : : return false;
259 : : }
260 : :
261 : : /* OMP_CLAUSE_DEFAULT_UNSPECIFIED unless OpenMP sharing attribute
262 : : of DECL is predetermined. */
263 : :
264 : : enum omp_clause_default_kind
265 : 7925 : gfc_omp_predetermined_sharing (tree decl)
266 : : {
267 : : /* Associate names preserve the association established during ASSOCIATE.
268 : : As they are implemented either as pointers to the selector or array
269 : : descriptor and shouldn't really change in the ASSOCIATE region,
270 : : this decl can be either shared or firstprivate. If it is a pointer,
271 : : use firstprivate, as it is cheaper that way, otherwise make it shared. */
272 : 7925 : if (GFC_DECL_ASSOCIATE_VAR_P (decl))
273 : : {
274 : 45 : if (TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE)
275 : : return OMP_CLAUSE_DEFAULT_FIRSTPRIVATE;
276 : : else
277 : 18 : return OMP_CLAUSE_DEFAULT_SHARED;
278 : : }
279 : :
280 : 7880 : if (DECL_ARTIFICIAL (decl)
281 : 1536 : && ! GFC_DECL_RESULT (decl)
282 : 9416 : && ! (DECL_LANG_SPECIFIC (decl)
283 : 348 : && GFC_DECL_SAVED_DESCRIPTOR (decl)))
284 : : return OMP_CLAUSE_DEFAULT_SHARED;
285 : :
286 : : /* Cray pointees shouldn't be listed in any clauses and should be
287 : : gimplified to dereference of the corresponding Cray pointer.
288 : : Make them all private, so that they are emitted in the debug
289 : : information. */
290 : 6668 : if (GFC_DECL_CRAY_POINTEE (decl))
291 : : return OMP_CLAUSE_DEFAULT_PRIVATE;
292 : :
293 : : /* Assumed-size arrays are predetermined shared. */
294 : 6632 : if (TREE_CODE (decl) == PARM_DECL
295 : 1716 : && GFC_ARRAY_TYPE_P (TREE_TYPE (decl))
296 : 603 : && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (decl)) == GFC_ARRAY_UNKNOWN
297 : 7235 : && GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (decl),
298 : : GFC_TYPE_ARRAY_RANK (TREE_TYPE (decl)) - 1)
299 : : == NULL)
300 : : return OMP_CLAUSE_DEFAULT_SHARED;
301 : :
302 : : /* Dummy procedures aren't considered variables by OpenMP, thus are
303 : : disallowed in OpenMP clauses. They are represented as PARM_DECLs
304 : : in the middle-end, so return OMP_CLAUSE_DEFAULT_FIRSTPRIVATE here
305 : : to avoid complaining about their uses with default(none). */
306 : 6564 : if (TREE_CODE (decl) == PARM_DECL
307 : 1648 : && TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE
308 : 7193 : && TREE_CODE (TREE_TYPE (TREE_TYPE (decl))) == FUNCTION_TYPE)
309 : : return OMP_CLAUSE_DEFAULT_FIRSTPRIVATE;
310 : :
311 : : /* COMMON and EQUIVALENCE decls are shared. They
312 : : are only referenced through DECL_VALUE_EXPR of the variables
313 : : contained in them. If those are privatized, they will not be
314 : : gimplified to the COMMON or EQUIVALENCE decls. */
315 : 6549 : if (GFC_DECL_COMMON_OR_EQUIV (decl) && ! DECL_HAS_VALUE_EXPR_P (decl))
316 : : return OMP_CLAUSE_DEFAULT_SHARED;
317 : :
318 : 6520 : if (GFC_DECL_RESULT (decl) && ! DECL_HAS_VALUE_EXPR_P (decl))
319 : : return OMP_CLAUSE_DEFAULT_SHARED;
320 : :
321 : : /* These are either array or derived parameters, or vtables.
322 : : In the former cases, the OpenMP standard doesn't consider them to be
323 : : variables at all (they can't be redefined), but they can nevertheless appear
324 : : in parallel/task regions and for default(none) purposes treat them as shared.
325 : : For vtables likely the same handling is desirable. */
326 : 4887 : if (VAR_P (decl) && TREE_READONLY (decl)
327 : 6523 : && (TREE_STATIC (decl) || DECL_EXTERNAL (decl)))
328 : 3 : return OMP_CLAUSE_DEFAULT_SHARED;
329 : :
330 : : return OMP_CLAUSE_DEFAULT_UNSPECIFIED;
331 : : }
332 : :
333 : :
334 : : /* OMP_CLAUSE_DEFAULTMAP_CATEGORY_UNSPECIFIED unless OpenMP mapping attribute
335 : : of DECL is predetermined. */
336 : :
337 : : enum omp_clause_defaultmap_kind
338 : 3684 : gfc_omp_predetermined_mapping (tree decl)
339 : : {
340 : 3684 : if (DECL_ARTIFICIAL (decl)
341 : 842 : && ! GFC_DECL_RESULT (decl)
342 : 4526 : && ! (DECL_LANG_SPECIFIC (decl)
343 : 64 : && GFC_DECL_SAVED_DESCRIPTOR (decl)))
344 : : return OMP_CLAUSE_DEFAULTMAP_TO;
345 : :
346 : : /* Dummy procedures aren't considered variables by OpenMP, thus are
347 : : disallowed in OpenMP clauses. They are represented as PARM_DECLs
348 : : in the middle-end, so return OMP_CLAUSE_DEFAULTMAP_FIRSTPRIVATE here
349 : : to avoid complaining about their uses with defaultmap(none). */
350 : 2882 : if (TREE_CODE (decl) == PARM_DECL
351 : 1742 : && TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE
352 : 3232 : && TREE_CODE (TREE_TYPE (TREE_TYPE (decl))) == FUNCTION_TYPE)
353 : : return OMP_CLAUSE_DEFAULTMAP_FIRSTPRIVATE;
354 : :
355 : : /* These are either array or derived parameters, or vtables. */
356 : 1140 : if (VAR_P (decl) && TREE_READONLY (decl)
357 : 2875 : && (TREE_STATIC (decl) || DECL_EXTERNAL (decl)))
358 : 0 : return OMP_CLAUSE_DEFAULTMAP_TO;
359 : :
360 : : return OMP_CLAUSE_DEFAULTMAP_CATEGORY_UNSPECIFIED;
361 : : }
362 : :
363 : :
364 : : /* Return decl that should be used when reporting DEFAULT(NONE)
365 : : diagnostics. */
366 : :
367 : : tree
368 : 104 : gfc_omp_report_decl (tree decl)
369 : : {
370 : 104 : if (DECL_ARTIFICIAL (decl)
371 : 3 : && DECL_LANG_SPECIFIC (decl)
372 : 107 : && GFC_DECL_SAVED_DESCRIPTOR (decl))
373 : 3 : return GFC_DECL_SAVED_DESCRIPTOR (decl);
374 : :
375 : : return decl;
376 : : }
377 : :
378 : : /* Return true if TYPE has any allocatable components. */
379 : :
380 : : static bool
381 : 94456 : gfc_has_alloc_comps (tree type, tree decl)
382 : : {
383 : 94456 : tree field, ftype;
384 : :
385 : 94456 : if (POINTER_TYPE_P (type))
386 : : {
387 : 3090 : if (GFC_DECL_GET_SCALAR_ALLOCATABLE (decl))
388 : 2313 : type = TREE_TYPE (type);
389 : 777 : else if (GFC_DECL_GET_SCALAR_POINTER (decl))
390 : : return false;
391 : : }
392 : :
393 : 94320 : if (GFC_DESCRIPTOR_TYPE_P (type)
394 : 94320 : && (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER
395 : 2886 : || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT))
396 : : return false;
397 : :
398 : 94211 : if (GFC_DESCRIPTOR_TYPE_P (type) || GFC_ARRAY_TYPE_P (type))
399 : 6551 : type = gfc_get_element_type (type);
400 : :
401 : 94211 : if (TREE_CODE (type) != RECORD_TYPE)
402 : : return false;
403 : :
404 : 6063 : for (field = TYPE_FIELDS (type); field; field = DECL_CHAIN (field))
405 : : {
406 : 5576 : ftype = TREE_TYPE (field);
407 : 5576 : if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field))
408 : : return true;
409 : 5574 : if (GFC_DESCRIPTOR_TYPE_P (ftype)
410 : 5574 : && GFC_TYPE_ARRAY_AKIND (ftype) == GFC_ARRAY_ALLOCATABLE)
411 : : return true;
412 : 3846 : if (gfc_has_alloc_comps (ftype, field))
413 : : return true;
414 : : }
415 : : return false;
416 : : }
417 : :
418 : : /* Return true if TYPE is polymorphic but not with pointer attribute. */
419 : :
420 : : static bool
421 : 40788 : gfc_is_polymorphic_nonptr (tree type)
422 : : {
423 : 40788 : if (POINTER_TYPE_P (type))
424 : 3322 : type = TREE_TYPE (type);
425 : 40788 : return GFC_CLASS_TYPE_P (type);
426 : : }
427 : :
428 : : /* Return true if TYPE is unlimited polymorphic but not with pointer attribute;
429 : : unlimited means also intrinsic types are handled and _len is used. */
430 : :
431 : : static bool
432 : 36 : gfc_is_unlimited_polymorphic_nonptr (tree type)
433 : : {
434 : 36 : if (POINTER_TYPE_P (type))
435 : 0 : type = TREE_TYPE (type);
436 : 36 : if (!GFC_CLASS_TYPE_P (type))
437 : : return false;
438 : :
439 : 36 : tree field = TYPE_FIELDS (type); /* _data */
440 : 36 : gcc_assert (field);
441 : 36 : field = DECL_CHAIN (field); /* _vptr */
442 : 36 : gcc_assert (field);
443 : 36 : field = DECL_CHAIN (field);
444 : 36 : if (!field)
445 : : return false;
446 : 24 : gcc_assert (strcmp ("_len", IDENTIFIER_POINTER (DECL_NAME (field))) == 0);
447 : : return true;
448 : : }
449 : :
450 : : /* Return true if the DECL is for an allocatable array or scalar. */
451 : :
452 : : bool
453 : 3684 : gfc_omp_allocatable_p (tree decl)
454 : : {
455 : 3684 : if (!DECL_P (decl))
456 : : return false;
457 : :
458 : 3684 : if (GFC_DECL_GET_SCALAR_ALLOCATABLE (decl))
459 : : return true;
460 : :
461 : 3487 : tree type = TREE_TYPE (decl);
462 : 3487 : if (gfc_omp_privatize_by_reference (decl))
463 : 1729 : type = TREE_TYPE (type);
464 : :
465 : 3487 : if (GFC_DESCRIPTOR_TYPE_P (type)
466 : 3487 : && GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE)
467 : : return true;
468 : :
469 : : return false;
470 : : }
471 : :
472 : :
473 : : /* Return true if DECL in private clause needs
474 : : OMP_CLAUSE_PRIVATE_OUTER_REF on the private clause. */
475 : : bool
476 : 13884 : gfc_omp_private_outer_ref (tree decl)
477 : : {
478 : 13884 : tree type = TREE_TYPE (decl);
479 : :
480 : 13884 : if (gfc_omp_privatize_by_reference (decl))
481 : 611 : type = TREE_TYPE (type);
482 : :
483 : 13884 : if (GFC_DESCRIPTOR_TYPE_P (type)
484 : 13884 : && GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE)
485 : : return true;
486 : :
487 : 13758 : if (GFC_DECL_GET_SCALAR_ALLOCATABLE (decl))
488 : : return true;
489 : :
490 : 13672 : if (gfc_has_alloc_comps (type, decl))
491 : : return true;
492 : :
493 : : return false;
494 : : }
495 : :
496 : : /* Callback for gfc_omp_unshare_expr. */
497 : :
498 : : static tree
499 : 92286 : gfc_omp_unshare_expr_r (tree *tp, int *walk_subtrees, void *)
500 : : {
501 : 92286 : tree t = *tp;
502 : 92286 : enum tree_code code = TREE_CODE (t);
503 : :
504 : : /* Stop at types, decls, constants like copy_tree_r. */
505 : 92286 : if (TREE_CODE_CLASS (code) == tcc_type
506 : : || TREE_CODE_CLASS (code) == tcc_declaration
507 : 92286 : || TREE_CODE_CLASS (code) == tcc_constant
508 : 61181 : || code == BLOCK)
509 : 31105 : *walk_subtrees = 0;
510 : 61181 : else if (handled_component_p (t)
511 : 46252 : || TREE_CODE (t) == MEM_REF)
512 : : {
513 : 14989 : *tp = unshare_expr (t);
514 : 14989 : *walk_subtrees = 0;
515 : : }
516 : :
517 : 92286 : return NULL_TREE;
518 : : }
519 : :
520 : : /* Unshare in expr anything that the FE which normally doesn't
521 : : care much about tree sharing (because during gimplification
522 : : everything is unshared) could cause problems with tree sharing
523 : : at omp-low.cc time. */
524 : :
525 : : static tree
526 : 5067 : gfc_omp_unshare_expr (tree expr)
527 : : {
528 : 5067 : walk_tree (&expr, gfc_omp_unshare_expr_r, NULL, NULL);
529 : 5067 : return expr;
530 : : }
531 : :
532 : : enum walk_alloc_comps
533 : : {
534 : : WALK_ALLOC_COMPS_DTOR,
535 : : WALK_ALLOC_COMPS_DEFAULT_CTOR,
536 : : WALK_ALLOC_COMPS_COPY_CTOR
537 : : };
538 : :
539 : : /* Handle allocatable components in OpenMP clauses. */
540 : :
541 : : static tree
542 : 2801 : gfc_walk_alloc_comps (tree decl, tree dest, tree var,
543 : : enum walk_alloc_comps kind)
544 : : {
545 : 2801 : stmtblock_t block, tmpblock;
546 : 2801 : tree type = TREE_TYPE (decl), then_b, tem, field;
547 : 2801 : gfc_init_block (&block);
548 : :
549 : 2801 : if (GFC_ARRAY_TYPE_P (type) || GFC_DESCRIPTOR_TYPE_P (type))
550 : : {
551 : 1092 : if (GFC_DESCRIPTOR_TYPE_P (type))
552 : : {
553 : 548 : gfc_init_block (&tmpblock);
554 : 1644 : tem = gfc_full_array_size (&tmpblock, decl,
555 : 548 : GFC_TYPE_ARRAY_RANK (type));
556 : 548 : then_b = gfc_finish_block (&tmpblock);
557 : 548 : gfc_add_expr_to_block (&block, gfc_omp_unshare_expr (then_b));
558 : 548 : tem = gfc_omp_unshare_expr (tem);
559 : 548 : tem = fold_build2_loc (input_location, MINUS_EXPR,
560 : : gfc_array_index_type, tem,
561 : : gfc_index_one_node);
562 : : }
563 : : else
564 : : {
565 : 544 : bool compute_nelts = false;
566 : 544 : if (!TYPE_DOMAIN (type)
567 : 544 : || TYPE_MAX_VALUE (TYPE_DOMAIN (type)) == NULL_TREE
568 : 544 : || TYPE_MIN_VALUE (TYPE_DOMAIN (type)) == error_mark_node
569 : 1088 : || TYPE_MAX_VALUE (TYPE_DOMAIN (type)) == error_mark_node)
570 : : compute_nelts = true;
571 : 544 : else if (VAR_P (TYPE_MAX_VALUE (TYPE_DOMAIN (type))))
572 : : {
573 : 80 : tree a = DECL_ATTRIBUTES (TYPE_MAX_VALUE (TYPE_DOMAIN (type)));
574 : 80 : if (lookup_attribute ("omp dummy var", a))
575 : : compute_nelts = true;
576 : : }
577 : : if (compute_nelts)
578 : : {
579 : 80 : tem = fold_build2 (EXACT_DIV_EXPR, sizetype,
580 : : TYPE_SIZE_UNIT (type),
581 : : TYPE_SIZE_UNIT (TREE_TYPE (type)));
582 : 80 : tem = size_binop (MINUS_EXPR, tem, size_one_node);
583 : : }
584 : : else
585 : 464 : tem = array_type_nelts_minus_one (type);
586 : 544 : tem = fold_convert (gfc_array_index_type, tem);
587 : : }
588 : :
589 : 1092 : tree nelems = gfc_evaluate_now (tem, &block);
590 : 1092 : tree index = gfc_create_var (gfc_array_index_type, "S");
591 : :
592 : 1092 : gfc_init_block (&tmpblock);
593 : 1092 : tem = gfc_conv_array_data (decl);
594 : 1092 : tree declvar = build_fold_indirect_ref_loc (input_location, tem);
595 : 1092 : tree declvref = gfc_build_array_ref (declvar, index, NULL);
596 : 1092 : tree destvar, destvref = NULL_TREE;
597 : 1092 : if (dest)
598 : : {
599 : 546 : tem = gfc_conv_array_data (dest);
600 : 546 : destvar = build_fold_indirect_ref_loc (input_location, tem);
601 : 546 : destvref = gfc_build_array_ref (destvar, index, NULL);
602 : : }
603 : 1092 : gfc_add_expr_to_block (&tmpblock,
604 : : gfc_walk_alloc_comps (declvref, destvref,
605 : : var, kind));
606 : :
607 : 1092 : gfc_loopinfo loop;
608 : 1092 : gfc_init_loopinfo (&loop);
609 : 1092 : loop.dimen = 1;
610 : 1092 : loop.from[0] = gfc_index_zero_node;
611 : 1092 : loop.loopvar[0] = index;
612 : 1092 : loop.to[0] = nelems;
613 : 1092 : gfc_trans_scalarizing_loops (&loop, &tmpblock);
614 : 1092 : gfc_add_block_to_block (&block, &loop.pre);
615 : 1092 : return gfc_finish_block (&block);
616 : : }
617 : 1709 : else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (var))
618 : : {
619 : 536 : decl = build_fold_indirect_ref_loc (input_location, decl);
620 : 536 : if (dest)
621 : 268 : dest = build_fold_indirect_ref_loc (input_location, dest);
622 : 536 : type = TREE_TYPE (decl);
623 : : }
624 : :
625 : 1709 : gcc_assert (TREE_CODE (type) == RECORD_TYPE);
626 : 11488 : for (field = TYPE_FIELDS (type); field; field = DECL_CHAIN (field))
627 : : {
628 : 9779 : tree ftype = TREE_TYPE (field);
629 : 9779 : tree declf, destf = NULL_TREE;
630 : 9779 : bool has_alloc_comps = gfc_has_alloc_comps (ftype, field);
631 : 9779 : if ((!GFC_DESCRIPTOR_TYPE_P (ftype)
632 : 1708 : || GFC_TYPE_ARRAY_AKIND (ftype) != GFC_ARRAY_ALLOCATABLE)
633 : 8071 : && !GFC_DECL_GET_SCALAR_ALLOCATABLE (field)
634 : 16153 : && !has_alloc_comps)
635 : 5950 : continue;
636 : 3829 : declf = fold_build3_loc (input_location, COMPONENT_REF, ftype,
637 : : decl, field, NULL_TREE);
638 : 3829 : if (dest)
639 : 1915 : destf = fold_build3_loc (input_location, COMPONENT_REF, ftype,
640 : : dest, field, NULL_TREE);
641 : :
642 : 3829 : tem = NULL_TREE;
643 : 3829 : switch (kind)
644 : : {
645 : : case WALK_ALLOC_COMPS_DTOR:
646 : : break;
647 : 961 : case WALK_ALLOC_COMPS_DEFAULT_CTOR:
648 : 961 : if (GFC_DESCRIPTOR_TYPE_P (ftype)
649 : 961 : && GFC_TYPE_ARRAY_AKIND (ftype) == GFC_ARRAY_ALLOCATABLE)
650 : : {
651 : 430 : gfc_add_modify (&block, unshare_expr (destf),
652 : : unshare_expr (declf));
653 : 430 : tem = gfc_duplicate_allocatable_nocopy
654 : 430 : (destf, declf, ftype,
655 : 430 : GFC_TYPE_ARRAY_RANK (ftype));
656 : : }
657 : 531 : else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field))
658 : 425 : tem = gfc_duplicate_allocatable_nocopy (destf, declf, ftype, 0);
659 : : break;
660 : 954 : case WALK_ALLOC_COMPS_COPY_CTOR:
661 : 954 : if (GFC_DESCRIPTOR_TYPE_P (ftype)
662 : 954 : && GFC_TYPE_ARRAY_AKIND (ftype) == GFC_ARRAY_ALLOCATABLE)
663 : 848 : tem = gfc_duplicate_allocatable (destf, declf, ftype,
664 : 424 : GFC_TYPE_ARRAY_RANK (ftype),
665 : : NULL_TREE);
666 : 530 : else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field))
667 : 424 : tem = gfc_duplicate_allocatable (destf, declf, ftype, 0,
668 : : NULL_TREE);
669 : : break;
670 : : }
671 : 1703 : if (tem)
672 : 1703 : gfc_add_expr_to_block (&block, gfc_omp_unshare_expr (tem));
673 : 3829 : if (has_alloc_comps)
674 : : {
675 : 1272 : gfc_init_block (&tmpblock);
676 : 1272 : gfc_add_expr_to_block (&tmpblock,
677 : : gfc_walk_alloc_comps (declf, destf,
678 : : field, kind));
679 : 1272 : then_b = gfc_finish_block (&tmpblock);
680 : 1272 : if (GFC_DESCRIPTOR_TYPE_P (ftype)
681 : 1272 : && GFC_TYPE_ARRAY_AKIND (ftype) == GFC_ARRAY_ALLOCATABLE)
682 : 424 : tem = gfc_conv_descriptor_data_get (unshare_expr (declf));
683 : 848 : else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field))
684 : 424 : tem = unshare_expr (declf);
685 : : else
686 : : tem = NULL_TREE;
687 : 848 : if (tem)
688 : : {
689 : 848 : tem = fold_convert (pvoid_type_node, tem);
690 : 848 : tem = fold_build2_loc (input_location, NE_EXPR,
691 : : logical_type_node, tem,
692 : : null_pointer_node);
693 : 848 : then_b = build3_loc (input_location, COND_EXPR, void_type_node,
694 : : tem, then_b,
695 : : build_empty_stmt (input_location));
696 : : }
697 : 1272 : gfc_add_expr_to_block (&block, then_b);
698 : : }
699 : 3829 : if (kind == WALK_ALLOC_COMPS_DTOR)
700 : : {
701 : 1914 : if (GFC_DESCRIPTOR_TYPE_P (ftype)
702 : 1914 : && GFC_TYPE_ARRAY_AKIND (ftype) == GFC_ARRAY_ALLOCATABLE)
703 : : {
704 : 854 : tem = gfc_conv_descriptor_data_get (unshare_expr (declf));
705 : 854 : tem = gfc_deallocate_with_status (tem, NULL_TREE, NULL_TREE,
706 : : NULL_TREE, NULL_TREE, true,
707 : : NULL,
708 : : GFC_CAF_COARRAY_NOCOARRAY);
709 : 854 : gfc_add_expr_to_block (&block, gfc_omp_unshare_expr (tem));
710 : : }
711 : 1060 : else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field))
712 : : {
713 : 848 : tem = gfc_call_free (unshare_expr (declf));
714 : 848 : gfc_add_expr_to_block (&block, gfc_omp_unshare_expr (tem));
715 : : }
716 : : }
717 : : }
718 : :
719 : 1709 : return gfc_finish_block (&block);
720 : : }
721 : :
722 : : /* Return code to initialize DECL with its default constructor, or
723 : : NULL if there's nothing to do. */
724 : :
725 : : tree
726 : 19813 : gfc_omp_clause_default_ctor (tree clause, tree decl, tree outer)
727 : : {
728 : 19813 : tree type = TREE_TYPE (decl), size, ptr, cond, then_b, else_b;
729 : 19813 : stmtblock_t block, cond_block;
730 : :
731 : 19813 : switch (OMP_CLAUSE_CODE (clause))
732 : : {
733 : : case OMP_CLAUSE__LOOPTEMP_:
734 : : case OMP_CLAUSE__REDUCTEMP_:
735 : : case OMP_CLAUSE__CONDTEMP_:
736 : : case OMP_CLAUSE__SCANTEMP_:
737 : : return NULL;
738 : 19786 : case OMP_CLAUSE_PRIVATE:
739 : 19786 : case OMP_CLAUSE_LASTPRIVATE:
740 : 19786 : case OMP_CLAUSE_LINEAR:
741 : 19786 : case OMP_CLAUSE_REDUCTION:
742 : 19786 : case OMP_CLAUSE_IN_REDUCTION:
743 : 19786 : case OMP_CLAUSE_TASK_REDUCTION:
744 : 19786 : break;
745 : 0 : default:
746 : 0 : gcc_unreachable ();
747 : : }
748 : :
749 : 19786 : if ((! GFC_DESCRIPTOR_TYPE_P (type)
750 : 263 : || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
751 : 19805 : && (!GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause))
752 : 85 : || !POINTER_TYPE_P (type)))
753 : : {
754 : 19457 : if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause)))
755 : : {
756 : 51 : gcc_assert (outer);
757 : 51 : gfc_start_block (&block);
758 : 102 : tree tem = gfc_walk_alloc_comps (outer, decl,
759 : 51 : OMP_CLAUSE_DECL (clause),
760 : : WALK_ALLOC_COMPS_DEFAULT_CTOR);
761 : 51 : gfc_add_expr_to_block (&block, tem);
762 : 51 : return gfc_finish_block (&block);
763 : : }
764 : : return NULL_TREE;
765 : : }
766 : :
767 : 329 : gcc_assert (outer != NULL_TREE);
768 : :
769 : : /* Allocatable arrays and scalars in PRIVATE clauses need to be set to
770 : : "not currently allocated" allocation status if outer
771 : : array is "not currently allocated", otherwise should be allocated. */
772 : 329 : gfc_start_block (&block);
773 : :
774 : 329 : gfc_init_block (&cond_block);
775 : :
776 : 329 : if (GFC_DESCRIPTOR_TYPE_P (type))
777 : : {
778 : 244 : gfc_add_modify (&cond_block, decl, outer);
779 : 244 : tree rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1];
780 : 244 : size = gfc_conv_descriptor_ubound_get (decl, rank);
781 : 244 : size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
782 : : size,
783 : : gfc_conv_descriptor_lbound_get (decl, rank));
784 : 244 : size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
785 : : size, gfc_index_one_node);
786 : 244 : if (GFC_TYPE_ARRAY_RANK (type) > 1)
787 : 130 : size = fold_build2_loc (input_location, MULT_EXPR,
788 : : gfc_array_index_type, size,
789 : : gfc_conv_descriptor_stride_get (decl, rank));
790 : 244 : tree esize = fold_convert (gfc_array_index_type,
791 : : TYPE_SIZE_UNIT (gfc_get_element_type (type)));
792 : 244 : size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
793 : : size, esize);
794 : 244 : size = unshare_expr (size);
795 : 244 : size = gfc_evaluate_now (fold_convert (size_type_node, size),
796 : : &cond_block);
797 : : }
798 : : else
799 : 85 : size = fold_convert (size_type_node, TYPE_SIZE_UNIT (TREE_TYPE (type)));
800 : 329 : ptr = gfc_create_var (pvoid_type_node, NULL);
801 : 329 : gfc_allocate_using_malloc (&cond_block, ptr, size, NULL_TREE);
802 : 329 : if (GFC_DESCRIPTOR_TYPE_P (type))
803 : 244 : gfc_conv_descriptor_data_set (&cond_block, unshare_expr (decl), ptr);
804 : : else
805 : 85 : gfc_add_modify (&cond_block, unshare_expr (decl),
806 : 85 : fold_convert (TREE_TYPE (decl), ptr));
807 : 329 : if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause)))
808 : : {
809 : 124 : tree tem = gfc_walk_alloc_comps (outer, decl,
810 : 62 : OMP_CLAUSE_DECL (clause),
811 : : WALK_ALLOC_COMPS_DEFAULT_CTOR);
812 : 62 : gfc_add_expr_to_block (&cond_block, tem);
813 : : }
814 : 329 : then_b = gfc_finish_block (&cond_block);
815 : :
816 : : /* Reduction clause requires allocated ALLOCATABLE. */
817 : 329 : if (OMP_CLAUSE_CODE (clause) != OMP_CLAUSE_REDUCTION
818 : 185 : && OMP_CLAUSE_CODE (clause) != OMP_CLAUSE_IN_REDUCTION
819 : 514 : && OMP_CLAUSE_CODE (clause) != OMP_CLAUSE_TASK_REDUCTION)
820 : : {
821 : 185 : gfc_init_block (&cond_block);
822 : 185 : if (GFC_DESCRIPTOR_TYPE_P (type))
823 : 124 : gfc_conv_descriptor_data_set (&cond_block, unshare_expr (decl),
824 : : null_pointer_node);
825 : : else
826 : 61 : gfc_add_modify (&cond_block, unshare_expr (decl),
827 : 61 : build_zero_cst (TREE_TYPE (decl)));
828 : 185 : else_b = gfc_finish_block (&cond_block);
829 : :
830 : 185 : tree tem = fold_convert (pvoid_type_node,
831 : : GFC_DESCRIPTOR_TYPE_P (type)
832 : : ? gfc_conv_descriptor_data_get (outer) : outer);
833 : 185 : tem = unshare_expr (tem);
834 : 185 : cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
835 : : tem, null_pointer_node);
836 : 185 : gfc_add_expr_to_block (&block,
837 : : build3_loc (input_location, COND_EXPR,
838 : : void_type_node, cond, then_b,
839 : : else_b));
840 : : /* Avoid -W*uninitialized warnings. */
841 : 185 : if (DECL_P (decl))
842 : 146 : suppress_warning (decl, OPT_Wuninitialized);
843 : : }
844 : : else
845 : 144 : gfc_add_expr_to_block (&block, then_b);
846 : :
847 : 329 : return gfc_finish_block (&block);
848 : : }
849 : :
850 : : /* Build and return code for a copy constructor from SRC to DEST. */
851 : :
852 : : tree
853 : 9279 : gfc_omp_clause_copy_ctor (tree clause, tree dest, tree src)
854 : : {
855 : 9279 : tree type = TREE_TYPE (dest), ptr, size, call;
856 : 9279 : tree decl_type = TREE_TYPE (OMP_CLAUSE_DECL (clause));
857 : 9279 : tree cond, then_b, else_b;
858 : 9279 : stmtblock_t block, cond_block;
859 : :
860 : 9279 : gcc_assert (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_FIRSTPRIVATE
861 : : || OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_LINEAR);
862 : :
863 : : /* Privatize pointer, only; cf. gfc_omp_predetermined_sharing. */
864 : 9279 : if (DECL_P (OMP_CLAUSE_DECL (clause))
865 : 9279 : && GFC_DECL_ASSOCIATE_VAR_P (OMP_CLAUSE_DECL (clause)))
866 : 27 : return build2 (MODIFY_EXPR, TREE_TYPE (dest), dest, src);
867 : :
868 : 9252 : if (DECL_ARTIFICIAL (OMP_CLAUSE_DECL (clause))
869 : 6160 : && DECL_LANG_SPECIFIC (OMP_CLAUSE_DECL (clause))
870 : 9433 : && GFC_DECL_SAVED_DESCRIPTOR (OMP_CLAUSE_DECL (clause)))
871 : 167 : decl_type
872 : 167 : = TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (OMP_CLAUSE_DECL (clause)));
873 : :
874 : 9252 : if (gfc_is_polymorphic_nonptr (decl_type))
875 : : {
876 : 40 : if (POINTER_TYPE_P (decl_type))
877 : 27 : decl_type = TREE_TYPE (decl_type);
878 : 40 : decl_type = TREE_TYPE (TYPE_FIELDS (decl_type));
879 : 40 : if (GFC_DESCRIPTOR_TYPE_P (decl_type) || GFC_ARRAY_TYPE_P (decl_type))
880 : 4 : fatal_error (input_location,
881 : : "Sorry, polymorphic arrays not yet supported for "
882 : : "firstprivate");
883 : 36 : tree src_len;
884 : 36 : tree nelems = build_int_cst (size_type_node, 1); /* Scalar. */
885 : 36 : tree src_data = gfc_class_data_get (unshare_expr (src));
886 : 36 : tree dest_data = gfc_class_data_get (unshare_expr (dest));
887 : 36 : bool unlimited = gfc_is_unlimited_polymorphic_nonptr (type);
888 : :
889 : 36 : gfc_start_block (&block);
890 : 36 : gfc_add_modify (&block, gfc_class_vptr_get (dest),
891 : : gfc_class_vptr_get (src));
892 : 36 : gfc_init_block (&cond_block);
893 : :
894 : 36 : if (unlimited)
895 : : {
896 : 24 : src_len = gfc_class_len_get (src);
897 : 24 : gfc_add_modify (&cond_block, gfc_class_len_get (unshare_expr (dest)), src_len);
898 : : }
899 : :
900 : : /* Use: size = class._vtab._size * (class._len > 0 ? class._len : 1). */
901 : 36 : size = fold_convert (size_type_node, gfc_class_vtab_size_get (src));
902 : 36 : if (unlimited)
903 : : {
904 : 24 : cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
905 : : unshare_expr (src_len),
906 : 24 : build_zero_cst (TREE_TYPE (src_len)));
907 : 24 : cond = build3_loc (input_location, COND_EXPR, size_type_node, cond,
908 : : fold_convert (size_type_node,
909 : : unshare_expr (src_len)),
910 : 24 : build_int_cst (size_type_node, 1));
911 : 24 : size = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
912 : : size, cond);
913 : : }
914 : :
915 : : /* Malloc memory + call class->_vpt->_copy. */
916 : 36 : call = builtin_decl_explicit (BUILT_IN_MALLOC);
917 : 36 : call = build_call_expr_loc (input_location, call, 1, size);
918 : 36 : gfc_add_modify (&cond_block, dest_data,
919 : 36 : fold_convert (TREE_TYPE (dest_data), call));
920 : 36 : gfc_add_expr_to_block (&cond_block,
921 : : gfc_copy_class_to_class (src, dest, nelems,
922 : : unlimited));
923 : :
924 : 36 : gcc_assert (TREE_CODE (dest_data) == COMPONENT_REF);
925 : 36 : if (!GFC_DECL_GET_SCALAR_ALLOCATABLE (TREE_OPERAND (dest_data, 1)))
926 : : {
927 : 12 : gfc_add_block_to_block (&block, &cond_block);
928 : : }
929 : : else
930 : : {
931 : : /* Create: if (class._data != 0) <cond_block> else class._data = NULL; */
932 : 24 : cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
933 : : src_data, null_pointer_node);
934 : 24 : gfc_add_expr_to_block (&block, build3_loc (input_location, COND_EXPR,
935 : : void_type_node, cond,
936 : : gfc_finish_block (&cond_block),
937 : : fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
938 : : unshare_expr (dest_data), null_pointer_node)));
939 : : }
940 : 36 : return gfc_finish_block (&block);
941 : : }
942 : :
943 : 9212 : if ((! GFC_DESCRIPTOR_TYPE_P (type)
944 : 138 : || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
945 : 9236 : && (!GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause))
946 : 77 : || !POINTER_TYPE_P (type)))
947 : : {
948 : 9023 : if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause)))
949 : : {
950 : 20 : gfc_start_block (&block);
951 : 20 : gfc_add_modify (&block, dest, src);
952 : 20 : tree tem = gfc_walk_alloc_comps (src, dest, OMP_CLAUSE_DECL (clause),
953 : : WALK_ALLOC_COMPS_COPY_CTOR);
954 : 20 : gfc_add_expr_to_block (&block, tem);
955 : 20 : return gfc_finish_block (&block);
956 : : }
957 : : else
958 : 9003 : return build2_v (MODIFY_EXPR, dest, src);
959 : : }
960 : :
961 : : /* Allocatable arrays in FIRSTPRIVATE clauses need to be allocated
962 : : and copied from SRC. */
963 : 189 : gfc_start_block (&block);
964 : :
965 : 189 : gfc_init_block (&cond_block);
966 : :
967 : 189 : gfc_add_modify (&cond_block, dest, fold_convert (TREE_TYPE (dest), src));
968 : 189 : if (GFC_DESCRIPTOR_TYPE_P (type))
969 : : {
970 : 114 : tree rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1];
971 : 114 : size = gfc_conv_descriptor_ubound_get (dest, rank);
972 : 114 : size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
973 : : size,
974 : : gfc_conv_descriptor_lbound_get (dest, rank));
975 : 114 : size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
976 : : size, gfc_index_one_node);
977 : 114 : if (GFC_TYPE_ARRAY_RANK (type) > 1)
978 : 42 : size = fold_build2_loc (input_location, MULT_EXPR,
979 : : gfc_array_index_type, size,
980 : : gfc_conv_descriptor_stride_get (dest, rank));
981 : 114 : tree esize = fold_convert (gfc_array_index_type,
982 : : TYPE_SIZE_UNIT (gfc_get_element_type (type)));
983 : 114 : size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
984 : : size, esize);
985 : 114 : size = unshare_expr (size);
986 : 114 : size = gfc_evaluate_now (fold_convert (size_type_node, size),
987 : : &cond_block);
988 : : }
989 : : else
990 : 75 : size = fold_convert (size_type_node, TYPE_SIZE_UNIT (TREE_TYPE (type)));
991 : 189 : ptr = gfc_create_var (pvoid_type_node, NULL);
992 : 189 : gfc_allocate_using_malloc (&cond_block, ptr, size, NULL_TREE);
993 : 189 : if (GFC_DESCRIPTOR_TYPE_P (type))
994 : 114 : gfc_conv_descriptor_data_set (&cond_block, unshare_expr (dest), ptr);
995 : : else
996 : 75 : gfc_add_modify (&cond_block, unshare_expr (dest),
997 : 75 : fold_convert (TREE_TYPE (dest), ptr));
998 : :
999 : 189 : tree srcptr = GFC_DESCRIPTOR_TYPE_P (type)
1000 : 189 : ? gfc_conv_descriptor_data_get (src) : src;
1001 : 189 : srcptr = unshare_expr (srcptr);
1002 : 189 : srcptr = fold_convert (pvoid_type_node, srcptr);
1003 : 189 : call = build_call_expr_loc (input_location,
1004 : : builtin_decl_explicit (BUILT_IN_MEMCPY), 3, ptr,
1005 : : srcptr, size);
1006 : 189 : gfc_add_expr_to_block (&cond_block, fold_convert (void_type_node, call));
1007 : 189 : if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause)))
1008 : : {
1009 : 48 : tree tem = gfc_walk_alloc_comps (src, dest,
1010 : 24 : OMP_CLAUSE_DECL (clause),
1011 : : WALK_ALLOC_COMPS_COPY_CTOR);
1012 : 24 : gfc_add_expr_to_block (&cond_block, tem);
1013 : : }
1014 : 189 : then_b = gfc_finish_block (&cond_block);
1015 : :
1016 : 189 : gfc_init_block (&cond_block);
1017 : 189 : if (GFC_DESCRIPTOR_TYPE_P (type))
1018 : 114 : gfc_conv_descriptor_data_set (&cond_block, unshare_expr (dest),
1019 : : null_pointer_node);
1020 : : else
1021 : 75 : gfc_add_modify (&cond_block, unshare_expr (dest),
1022 : 75 : build_zero_cst (TREE_TYPE (dest)));
1023 : 189 : else_b = gfc_finish_block (&cond_block);
1024 : :
1025 : 189 : cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1026 : : unshare_expr (srcptr), null_pointer_node);
1027 : 189 : gfc_add_expr_to_block (&block,
1028 : : build3_loc (input_location, COND_EXPR,
1029 : : void_type_node, cond, then_b, else_b));
1030 : : /* Avoid -W*uninitialized warnings. */
1031 : 189 : if (DECL_P (dest))
1032 : 121 : suppress_warning (dest, OPT_Wuninitialized);
1033 : :
1034 : 189 : return gfc_finish_block (&block);
1035 : : }
1036 : :
1037 : : /* Similarly, except use an intrinsic or pointer assignment operator
1038 : : instead. */
1039 : :
1040 : : tree
1041 : 6323 : gfc_omp_clause_assign_op (tree clause, tree dest, tree src)
1042 : : {
1043 : 6323 : tree type = TREE_TYPE (dest), ptr, size, call, nonalloc;
1044 : 6323 : tree cond, then_b, else_b;
1045 : 6323 : stmtblock_t block, cond_block, cond_block2, inner_block;
1046 : :
1047 : 6323 : if ((! GFC_DESCRIPTOR_TYPE_P (type)
1048 : 234 : || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
1049 : 12443 : && (!GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause))
1050 : 136 : || !POINTER_TYPE_P (type)))
1051 : : {
1052 : 5984 : if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause)))
1053 : : {
1054 : 30 : gfc_start_block (&block);
1055 : : /* First dealloc any allocatable components in DEST. */
1056 : 60 : tree tem = gfc_walk_alloc_comps (dest, NULL_TREE,
1057 : 30 : OMP_CLAUSE_DECL (clause),
1058 : : WALK_ALLOC_COMPS_DTOR);
1059 : 30 : gfc_add_expr_to_block (&block, tem);
1060 : : /* Then copy over toplevel data. */
1061 : 30 : gfc_add_modify (&block, dest, src);
1062 : : /* Finally allocate any allocatable components and copy. */
1063 : 30 : tem = gfc_walk_alloc_comps (src, dest, OMP_CLAUSE_DECL (clause),
1064 : : WALK_ALLOC_COMPS_COPY_CTOR);
1065 : 30 : gfc_add_expr_to_block (&block, tem);
1066 : 30 : return gfc_finish_block (&block);
1067 : : }
1068 : : else
1069 : 5954 : return build2_v (MODIFY_EXPR, dest, src);
1070 : : }
1071 : :
1072 : 339 : gfc_start_block (&block);
1073 : :
1074 : 339 : if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause)))
1075 : : {
1076 : 32 : then_b = gfc_walk_alloc_comps (dest, NULL_TREE, OMP_CLAUSE_DECL (clause),
1077 : : WALK_ALLOC_COMPS_DTOR);
1078 : 32 : tree tem = fold_convert (pvoid_type_node,
1079 : : GFC_DESCRIPTOR_TYPE_P (type)
1080 : : ? gfc_conv_descriptor_data_get (dest) : dest);
1081 : 32 : tem = unshare_expr (tem);
1082 : 32 : cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1083 : : tem, null_pointer_node);
1084 : 32 : tem = build3_loc (input_location, COND_EXPR, void_type_node, cond,
1085 : : then_b, build_empty_stmt (input_location));
1086 : 32 : gfc_add_expr_to_block (&block, tem);
1087 : : }
1088 : :
1089 : 339 : gfc_init_block (&cond_block);
1090 : :
1091 : 339 : if (GFC_DESCRIPTOR_TYPE_P (type))
1092 : : {
1093 : 203 : tree rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1];
1094 : 203 : size = gfc_conv_descriptor_ubound_get (src, rank);
1095 : 203 : size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
1096 : : size,
1097 : : gfc_conv_descriptor_lbound_get (src, rank));
1098 : 203 : size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
1099 : : size, gfc_index_one_node);
1100 : 203 : if (GFC_TYPE_ARRAY_RANK (type) > 1)
1101 : 88 : size = fold_build2_loc (input_location, MULT_EXPR,
1102 : : gfc_array_index_type, size,
1103 : : gfc_conv_descriptor_stride_get (src, rank));
1104 : 203 : tree esize = fold_convert (gfc_array_index_type,
1105 : : TYPE_SIZE_UNIT (gfc_get_element_type (type)));
1106 : 203 : size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
1107 : : size, esize);
1108 : 203 : size = unshare_expr (size);
1109 : 203 : size = gfc_evaluate_now (fold_convert (size_type_node, size),
1110 : : &cond_block);
1111 : : }
1112 : : else
1113 : 136 : size = fold_convert (size_type_node, TYPE_SIZE_UNIT (TREE_TYPE (type)));
1114 : 339 : ptr = gfc_create_var (pvoid_type_node, NULL);
1115 : :
1116 : 339 : tree destptr = GFC_DESCRIPTOR_TYPE_P (type)
1117 : 339 : ? gfc_conv_descriptor_data_get (dest) : dest;
1118 : 339 : destptr = unshare_expr (destptr);
1119 : 339 : destptr = fold_convert (pvoid_type_node, destptr);
1120 : 339 : gfc_add_modify (&cond_block, ptr, destptr);
1121 : :
1122 : 339 : nonalloc = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
1123 : : destptr, null_pointer_node);
1124 : 339 : cond = nonalloc;
1125 : 339 : if (GFC_DESCRIPTOR_TYPE_P (type))
1126 : : {
1127 : : int i;
1128 : 494 : for (i = 0; i < GFC_TYPE_ARRAY_RANK (type); i++)
1129 : : {
1130 : 291 : tree rank = gfc_rank_cst[i];
1131 : 291 : tree tem = gfc_conv_descriptor_ubound_get (src, rank);
1132 : 291 : tem = fold_build2_loc (input_location, MINUS_EXPR,
1133 : : gfc_array_index_type, tem,
1134 : : gfc_conv_descriptor_lbound_get (src, rank));
1135 : 291 : tem = fold_build2_loc (input_location, PLUS_EXPR,
1136 : : gfc_array_index_type, tem,
1137 : : gfc_conv_descriptor_lbound_get (dest, rank));
1138 : 291 : tem = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1139 : : tem, gfc_conv_descriptor_ubound_get (dest,
1140 : : rank));
1141 : 291 : cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
1142 : : logical_type_node, cond, tem);
1143 : : }
1144 : : }
1145 : :
1146 : 339 : gfc_init_block (&cond_block2);
1147 : :
1148 : 339 : if (GFC_DESCRIPTOR_TYPE_P (type))
1149 : : {
1150 : 203 : gfc_init_block (&inner_block);
1151 : 203 : gfc_allocate_using_malloc (&inner_block, ptr, size, NULL_TREE);
1152 : 203 : then_b = gfc_finish_block (&inner_block);
1153 : :
1154 : 203 : gfc_init_block (&inner_block);
1155 : 203 : gfc_add_modify (&inner_block, ptr,
1156 : : gfc_call_realloc (&inner_block, ptr, size));
1157 : 203 : else_b = gfc_finish_block (&inner_block);
1158 : :
1159 : 203 : gfc_add_expr_to_block (&cond_block2,
1160 : : build3_loc (input_location, COND_EXPR,
1161 : : void_type_node,
1162 : : unshare_expr (nonalloc),
1163 : : then_b, else_b));
1164 : 203 : gfc_add_modify (&cond_block2, dest, src);
1165 : 203 : gfc_conv_descriptor_data_set (&cond_block2, unshare_expr (dest), ptr);
1166 : : }
1167 : : else
1168 : : {
1169 : 136 : gfc_allocate_using_malloc (&cond_block2, ptr, size, NULL_TREE);
1170 : 136 : gfc_add_modify (&cond_block2, unshare_expr (dest),
1171 : : fold_convert (type, ptr));
1172 : : }
1173 : 339 : then_b = gfc_finish_block (&cond_block2);
1174 : 339 : else_b = build_empty_stmt (input_location);
1175 : :
1176 : 339 : gfc_add_expr_to_block (&cond_block,
1177 : : build3_loc (input_location, COND_EXPR,
1178 : : void_type_node, unshare_expr (cond),
1179 : : then_b, else_b));
1180 : :
1181 : 339 : tree srcptr = GFC_DESCRIPTOR_TYPE_P (type)
1182 : 339 : ? gfc_conv_descriptor_data_get (src) : src;
1183 : 339 : srcptr = unshare_expr (srcptr);
1184 : 339 : srcptr = fold_convert (pvoid_type_node, srcptr);
1185 : 339 : call = build_call_expr_loc (input_location,
1186 : : builtin_decl_explicit (BUILT_IN_MEMCPY), 3, ptr,
1187 : : srcptr, size);
1188 : 339 : gfc_add_expr_to_block (&cond_block, fold_convert (void_type_node, call));
1189 : 339 : if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause)))
1190 : : {
1191 : 64 : tree tem = gfc_walk_alloc_comps (src, dest,
1192 : 32 : OMP_CLAUSE_DECL (clause),
1193 : : WALK_ALLOC_COMPS_COPY_CTOR);
1194 : 32 : gfc_add_expr_to_block (&cond_block, tem);
1195 : : }
1196 : 339 : then_b = gfc_finish_block (&cond_block);
1197 : :
1198 : 339 : if (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_COPYIN)
1199 : : {
1200 : 66 : gfc_init_block (&cond_block);
1201 : 66 : if (GFC_DESCRIPTOR_TYPE_P (type))
1202 : : {
1203 : 48 : tree tmp = gfc_conv_descriptor_data_get (unshare_expr (dest));
1204 : 48 : tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE,
1205 : : NULL_TREE, NULL_TREE, true, NULL,
1206 : : GFC_CAF_COARRAY_NOCOARRAY);
1207 : 48 : gfc_add_expr_to_block (&cond_block, tmp);
1208 : : }
1209 : : else
1210 : : {
1211 : 18 : destptr = gfc_evaluate_now (destptr, &cond_block);
1212 : 18 : gfc_add_expr_to_block (&cond_block, gfc_call_free (destptr));
1213 : 18 : gfc_add_modify (&cond_block, unshare_expr (dest),
1214 : 18 : build_zero_cst (TREE_TYPE (dest)));
1215 : : }
1216 : 66 : else_b = gfc_finish_block (&cond_block);
1217 : :
1218 : 66 : cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1219 : : unshare_expr (srcptr), null_pointer_node);
1220 : 66 : gfc_add_expr_to_block (&block,
1221 : : build3_loc (input_location, COND_EXPR,
1222 : : void_type_node, cond,
1223 : : then_b, else_b));
1224 : : }
1225 : : else
1226 : 273 : gfc_add_expr_to_block (&block, then_b);
1227 : :
1228 : 339 : return gfc_finish_block (&block);
1229 : : }
1230 : :
1231 : : static void
1232 : 84 : gfc_omp_linear_clause_add_loop (stmtblock_t *block, tree dest, tree src,
1233 : : tree add, tree nelems)
1234 : : {
1235 : 84 : stmtblock_t tmpblock;
1236 : 84 : tree desta, srca, index = gfc_create_var (gfc_array_index_type, "S");
1237 : 84 : nelems = gfc_evaluate_now (nelems, block);
1238 : :
1239 : 84 : gfc_init_block (&tmpblock);
1240 : 84 : if (TREE_CODE (TREE_TYPE (dest)) == ARRAY_TYPE)
1241 : : {
1242 : 60 : desta = gfc_build_array_ref (dest, index, NULL);
1243 : 60 : srca = gfc_build_array_ref (src, index, NULL);
1244 : : }
1245 : : else
1246 : : {
1247 : 24 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (dest)));
1248 : 24 : tree idx = fold_build2 (MULT_EXPR, sizetype,
1249 : : fold_convert (sizetype, index),
1250 : : TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (dest))));
1251 : 24 : desta = build_fold_indirect_ref (fold_build2 (POINTER_PLUS_EXPR,
1252 : : TREE_TYPE (dest), dest,
1253 : : idx));
1254 : 24 : srca = build_fold_indirect_ref (fold_build2 (POINTER_PLUS_EXPR,
1255 : : TREE_TYPE (src), src,
1256 : : idx));
1257 : : }
1258 : 84 : gfc_add_modify (&tmpblock, desta,
1259 : 84 : fold_build2 (PLUS_EXPR, TREE_TYPE (desta),
1260 : : srca, add));
1261 : :
1262 : 84 : gfc_loopinfo loop;
1263 : 84 : gfc_init_loopinfo (&loop);
1264 : 84 : loop.dimen = 1;
1265 : 84 : loop.from[0] = gfc_index_zero_node;
1266 : 84 : loop.loopvar[0] = index;
1267 : 84 : loop.to[0] = nelems;
1268 : 84 : gfc_trans_scalarizing_loops (&loop, &tmpblock);
1269 : 84 : gfc_add_block_to_block (block, &loop.pre);
1270 : 84 : }
1271 : :
1272 : : /* Build and return code for a constructor of DEST that initializes
1273 : : it to SRC plus ADD (ADD is scalar integer). */
1274 : :
1275 : : tree
1276 : 108 : gfc_omp_clause_linear_ctor (tree clause, tree dest, tree src, tree add)
1277 : : {
1278 : 108 : tree type = TREE_TYPE (dest), ptr, size, nelems = NULL_TREE;
1279 : 108 : stmtblock_t block;
1280 : :
1281 : 108 : gcc_assert (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_LINEAR);
1282 : :
1283 : 108 : gfc_start_block (&block);
1284 : 108 : add = gfc_evaluate_now (add, &block);
1285 : :
1286 : 108 : if ((! GFC_DESCRIPTOR_TYPE_P (type)
1287 : 24 : || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
1288 : 192 : && (!GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause))
1289 : 24 : || !POINTER_TYPE_P (type)))
1290 : : {
1291 : 60 : bool compute_nelts = false;
1292 : 60 : gcc_assert (TREE_CODE (type) == ARRAY_TYPE);
1293 : 60 : if (!TYPE_DOMAIN (type)
1294 : 60 : || TYPE_MAX_VALUE (TYPE_DOMAIN (type)) == NULL_TREE
1295 : 60 : || TYPE_MIN_VALUE (TYPE_DOMAIN (type)) == error_mark_node
1296 : 120 : || TYPE_MAX_VALUE (TYPE_DOMAIN (type)) == error_mark_node)
1297 : : compute_nelts = true;
1298 : 60 : else if (VAR_P (TYPE_MAX_VALUE (TYPE_DOMAIN (type))))
1299 : : {
1300 : 48 : tree a = DECL_ATTRIBUTES (TYPE_MAX_VALUE (TYPE_DOMAIN (type)));
1301 : 48 : if (lookup_attribute ("omp dummy var", a))
1302 : : compute_nelts = true;
1303 : : }
1304 : : if (compute_nelts)
1305 : : {
1306 : 48 : nelems = fold_build2 (EXACT_DIV_EXPR, sizetype,
1307 : : TYPE_SIZE_UNIT (type),
1308 : : TYPE_SIZE_UNIT (TREE_TYPE (type)));
1309 : 48 : nelems = size_binop (MINUS_EXPR, nelems, size_one_node);
1310 : : }
1311 : : else
1312 : 12 : nelems = array_type_nelts_minus_one (type);
1313 : 60 : nelems = fold_convert (gfc_array_index_type, nelems);
1314 : :
1315 : 60 : gfc_omp_linear_clause_add_loop (&block, dest, src, add, nelems);
1316 : 60 : return gfc_finish_block (&block);
1317 : : }
1318 : :
1319 : : /* Allocatable arrays in LINEAR clauses need to be allocated
1320 : : and copied from SRC. */
1321 : 48 : gfc_add_modify (&block, dest, src);
1322 : 48 : if (GFC_DESCRIPTOR_TYPE_P (type))
1323 : : {
1324 : 24 : tree rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1];
1325 : 24 : size = gfc_conv_descriptor_ubound_get (dest, rank);
1326 : 24 : size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
1327 : : size,
1328 : : gfc_conv_descriptor_lbound_get (dest, rank));
1329 : 24 : size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
1330 : : size, gfc_index_one_node);
1331 : 24 : if (GFC_TYPE_ARRAY_RANK (type) > 1)
1332 : 0 : size = fold_build2_loc (input_location, MULT_EXPR,
1333 : : gfc_array_index_type, size,
1334 : : gfc_conv_descriptor_stride_get (dest, rank));
1335 : 24 : tree esize = fold_convert (gfc_array_index_type,
1336 : : TYPE_SIZE_UNIT (gfc_get_element_type (type)));
1337 : 24 : nelems = gfc_evaluate_now (unshare_expr (size), &block);
1338 : 24 : size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
1339 : : nelems, unshare_expr (esize));
1340 : 24 : size = gfc_evaluate_now (fold_convert (size_type_node, size),
1341 : : &block);
1342 : 24 : nelems = fold_build2_loc (input_location, MINUS_EXPR,
1343 : : gfc_array_index_type, nelems,
1344 : : gfc_index_one_node);
1345 : : }
1346 : : else
1347 : 24 : size = fold_convert (size_type_node, TYPE_SIZE_UNIT (TREE_TYPE (type)));
1348 : 48 : ptr = gfc_create_var (pvoid_type_node, NULL);
1349 : 48 : gfc_allocate_using_malloc (&block, ptr, size, NULL_TREE);
1350 : 48 : if (GFC_DESCRIPTOR_TYPE_P (type))
1351 : : {
1352 : 24 : gfc_conv_descriptor_data_set (&block, unshare_expr (dest), ptr);
1353 : 24 : tree etype = gfc_get_element_type (type);
1354 : 24 : ptr = fold_convert (build_pointer_type (etype), ptr);
1355 : 24 : tree srcptr = gfc_conv_descriptor_data_get (unshare_expr (src));
1356 : 24 : srcptr = fold_convert (build_pointer_type (etype), srcptr);
1357 : 24 : gfc_omp_linear_clause_add_loop (&block, ptr, srcptr, add, nelems);
1358 : : }
1359 : : else
1360 : : {
1361 : 24 : gfc_add_modify (&block, unshare_expr (dest),
1362 : 24 : fold_convert (TREE_TYPE (dest), ptr));
1363 : 24 : ptr = fold_convert (TREE_TYPE (dest), ptr);
1364 : 24 : tree dstm = build_fold_indirect_ref (ptr);
1365 : 24 : tree srcm = build_fold_indirect_ref (unshare_expr (src));
1366 : 24 : gfc_add_modify (&block, dstm,
1367 : 24 : fold_build2 (PLUS_EXPR, TREE_TYPE (add), srcm, add));
1368 : : }
1369 : 48 : return gfc_finish_block (&block);
1370 : : }
1371 : :
1372 : : /* Build and return code destructing DECL. Return NULL if nothing
1373 : : to be done. */
1374 : :
1375 : : tree
1376 : 31563 : gfc_omp_clause_dtor (tree clause, tree decl)
1377 : : {
1378 : 31563 : tree type = TREE_TYPE (decl), tem;
1379 : 31563 : tree decl_type = TREE_TYPE (OMP_CLAUSE_DECL (clause));
1380 : :
1381 : : /* Only pointer was privatized; cf. gfc_omp_clause_copy_ctor. */
1382 : 31563 : if (DECL_P (OMP_CLAUSE_DECL (clause))
1383 : 31563 : && GFC_DECL_ASSOCIATE_VAR_P (OMP_CLAUSE_DECL (clause)))
1384 : : return NULL_TREE;
1385 : :
1386 : 31536 : if (DECL_ARTIFICIAL (OMP_CLAUSE_DECL (clause))
1387 : 11913 : && DECL_LANG_SPECIFIC (OMP_CLAUSE_DECL (clause))
1388 : 31889 : && GFC_DECL_SAVED_DESCRIPTOR (OMP_CLAUSE_DECL (clause)))
1389 : 339 : decl_type
1390 : 339 : = TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (OMP_CLAUSE_DECL (clause)));
1391 : 31536 : if (gfc_is_polymorphic_nonptr (decl_type))
1392 : : {
1393 : 37 : if (POINTER_TYPE_P (decl_type))
1394 : 24 : decl_type = TREE_TYPE (decl_type);
1395 : 37 : decl_type = TREE_TYPE (TYPE_FIELDS (decl_type));
1396 : 37 : if (GFC_DESCRIPTOR_TYPE_P (decl_type) || GFC_ARRAY_TYPE_P (decl_type))
1397 : 0 : fatal_error (input_location,
1398 : : "Sorry, polymorphic arrays not yet supported for "
1399 : : "firstprivate");
1400 : 37 : stmtblock_t block, cond_block;
1401 : 37 : gfc_start_block (&block);
1402 : 37 : gfc_init_block (&cond_block);
1403 : 37 : tree final = gfc_class_vtab_final_get (decl);
1404 : 37 : tree size = fold_convert (size_type_node, gfc_class_vtab_size_get (decl));
1405 : 37 : gfc_se se;
1406 : 37 : gfc_init_se (&se, NULL);
1407 : 37 : symbol_attribute attr = {};
1408 : 37 : tree data = gfc_class_data_get (decl);
1409 : 37 : tree desc = gfc_conv_scalar_to_descriptor (&se, data, attr);
1410 : :
1411 : : /* Call class->_vpt->_finalize + free. */
1412 : 37 : tree call = build_fold_indirect_ref (final);
1413 : 37 : call = build_call_expr_loc (input_location, call, 3,
1414 : : gfc_build_addr_expr (NULL, desc),
1415 : : size, boolean_false_node);
1416 : 37 : gfc_add_block_to_block (&cond_block, &se.pre);
1417 : 37 : gfc_add_expr_to_block (&cond_block, fold_convert (void_type_node, call));
1418 : 37 : gfc_add_block_to_block (&cond_block, &se.post);
1419 : : /* Create: if (_vtab && _final) <cond_block> */
1420 : 37 : tree cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
1421 : : gfc_class_vptr_get (decl),
1422 : : null_pointer_node);
1423 : 37 : tree cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
1424 : : final, null_pointer_node);
1425 : 37 : cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
1426 : : boolean_type_node, cond, cond2);
1427 : 37 : gfc_add_expr_to_block (&block, build3_loc (input_location, COND_EXPR,
1428 : : void_type_node, cond,
1429 : : gfc_finish_block (&cond_block), NULL_TREE));
1430 : 37 : call = builtin_decl_explicit (BUILT_IN_FREE);
1431 : 37 : call = build_call_expr_loc (input_location, call, 1, data);
1432 : 37 : gfc_add_expr_to_block (&block, fold_convert (void_type_node, call));
1433 : 37 : return gfc_finish_block (&block);
1434 : : }
1435 : :
1436 : 31499 : if ((! GFC_DESCRIPTOR_TYPE_P (type)
1437 : 433 : || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
1438 : 31550 : && (!GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause))
1439 : 186 : || !POINTER_TYPE_P (type)))
1440 : : {
1441 : 30933 : if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause)))
1442 : 140 : return gfc_walk_alloc_comps (decl, NULL_TREE,
1443 : 70 : OMP_CLAUSE_DECL (clause),
1444 : 70 : WALK_ALLOC_COMPS_DTOR);
1445 : : return NULL_TREE;
1446 : : }
1447 : :
1448 : 566 : if (GFC_DESCRIPTOR_TYPE_P (type))
1449 : : {
1450 : : /* Allocatable arrays in FIRSTPRIVATE/LASTPRIVATE etc. clauses need
1451 : : to be deallocated if they were allocated. */
1452 : 382 : tem = gfc_conv_descriptor_data_get (decl);
1453 : 382 : tem = gfc_deallocate_with_status (tem, NULL_TREE, NULL_TREE, NULL_TREE,
1454 : : NULL_TREE, true, NULL,
1455 : : GFC_CAF_COARRAY_NOCOARRAY);
1456 : : }
1457 : : else
1458 : 184 : tem = gfc_call_free (decl);
1459 : 566 : tem = gfc_omp_unshare_expr (tem);
1460 : :
1461 : 566 : if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause)))
1462 : : {
1463 : 86 : stmtblock_t block;
1464 : 86 : tree then_b;
1465 : :
1466 : 86 : gfc_init_block (&block);
1467 : 172 : gfc_add_expr_to_block (&block,
1468 : : gfc_walk_alloc_comps (decl, NULL_TREE,
1469 : 86 : OMP_CLAUSE_DECL (clause),
1470 : : WALK_ALLOC_COMPS_DTOR));
1471 : 86 : gfc_add_expr_to_block (&block, tem);
1472 : 86 : then_b = gfc_finish_block (&block);
1473 : :
1474 : 86 : tem = fold_convert (pvoid_type_node,
1475 : : GFC_DESCRIPTOR_TYPE_P (type)
1476 : : ? gfc_conv_descriptor_data_get (decl) : decl);
1477 : 86 : tem = unshare_expr (tem);
1478 : 86 : tree cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1479 : : tem, null_pointer_node);
1480 : 86 : tem = build3_loc (input_location, COND_EXPR, void_type_node, cond,
1481 : : then_b, build_empty_stmt (input_location));
1482 : : }
1483 : : return tem;
1484 : : }
1485 : :
1486 : : /* Build a conditional expression in BLOCK. If COND_VAL is not
1487 : : null, then the block THEN_B is executed, otherwise ELSE_VAL
1488 : : is assigned to VAL. */
1489 : :
1490 : : static void
1491 : 1020 : gfc_build_cond_assign (stmtblock_t *block, tree val, tree cond_val,
1492 : : tree then_b, tree else_val)
1493 : : {
1494 : 1020 : stmtblock_t cond_block;
1495 : 1020 : tree else_b = NULL_TREE;
1496 : 1020 : tree val_ty = TREE_TYPE (val);
1497 : :
1498 : 1020 : if (else_val)
1499 : : {
1500 : 1020 : gfc_init_block (&cond_block);
1501 : 1020 : gfc_add_modify (&cond_block, val, fold_convert (val_ty, else_val));
1502 : 1020 : else_b = gfc_finish_block (&cond_block);
1503 : : }
1504 : 1020 : gfc_add_expr_to_block (block,
1505 : : build3_loc (input_location, COND_EXPR, void_type_node,
1506 : : cond_val, then_b, else_b));
1507 : 1020 : }
1508 : :
1509 : : /* Build a conditional expression in BLOCK, returning a temporary
1510 : : variable containing the result. If COND_VAL is not null, then
1511 : : THEN_VAL will be assigned to the variable, otherwise ELSE_VAL
1512 : : is assigned.
1513 : : */
1514 : :
1515 : : static tree
1516 : 1019 : gfc_build_cond_assign_expr (stmtblock_t *block, tree cond_val,
1517 : : tree then_val, tree else_val)
1518 : : {
1519 : 1019 : tree val;
1520 : 1019 : tree val_ty = TREE_TYPE (then_val);
1521 : 1019 : stmtblock_t cond_block;
1522 : :
1523 : 1019 : val = create_tmp_var (val_ty);
1524 : :
1525 : 1019 : gfc_init_block (&cond_block);
1526 : 1019 : gfc_add_modify (&cond_block, val, then_val);
1527 : 1019 : tree then_b = gfc_finish_block (&cond_block);
1528 : :
1529 : 1019 : gfc_build_cond_assign (block, val, cond_val, then_b, else_val);
1530 : :
1531 : 1019 : return val;
1532 : : }
1533 : :
1534 : : void
1535 : 27871 : gfc_omp_finish_clause (tree c, gimple_seq *pre_p, bool openacc)
1536 : : {
1537 : 27871 : if (OMP_CLAUSE_CODE (c) != OMP_CLAUSE_MAP)
1538 : : return;
1539 : :
1540 : 6624 : tree decl = OMP_CLAUSE_DECL (c);
1541 : :
1542 : : /* Assumed-size arrays can't be mapped implicitly, they have to be
1543 : : mapped explicitly using array sections. */
1544 : 6624 : if (TREE_CODE (decl) == PARM_DECL
1545 : 1026 : && GFC_ARRAY_TYPE_P (TREE_TYPE (decl))
1546 : 356 : && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (decl)) == GFC_ARRAY_UNKNOWN
1547 : 6980 : && GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (decl),
1548 : : GFC_TYPE_ARRAY_RANK (TREE_TYPE (decl)) - 1)
1549 : : == NULL)
1550 : : {
1551 : 1 : error_at (OMP_CLAUSE_LOCATION (c),
1552 : : "implicit mapping of assumed size array %qD", decl);
1553 : 1 : return;
1554 : : }
1555 : :
1556 : 6623 : if (!openacc && GFC_CLASS_TYPE_P (TREE_TYPE (decl)))
1557 : 1 : warning_at (OMP_CLAUSE_LOCATION (c), OPT_Wopenmp,
1558 : : "Implicit mapping of polymorphic variable %qD is "
1559 : : "unspecified behavior", decl);
1560 : :
1561 : 6623 : tree c2 = NULL_TREE, c3 = NULL_TREE, c4 = NULL_TREE;
1562 : 6623 : tree present = gfc_omp_check_optional_argument (decl, true);
1563 : 6623 : if (POINTER_TYPE_P (TREE_TYPE (decl)))
1564 : : {
1565 : 1247 : if (!gfc_omp_privatize_by_reference (decl)
1566 : 138 : && !GFC_DECL_GET_SCALAR_POINTER (decl)
1567 : 74 : && !GFC_DECL_GET_SCALAR_ALLOCATABLE (decl)
1568 : 3 : && !GFC_DECL_CRAY_POINTEE (decl)
1569 : 1250 : && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (decl))))
1570 : : return;
1571 : 1244 : tree orig_decl = decl;
1572 : :
1573 : 1244 : c4 = build_omp_clause (OMP_CLAUSE_LOCATION (c), OMP_CLAUSE_MAP);
1574 : 1244 : OMP_CLAUSE_SET_MAP_KIND (c4, GOMP_MAP_POINTER);
1575 : 1244 : OMP_CLAUSE_DECL (c4) = decl;
1576 : 1244 : OMP_CLAUSE_SIZE (c4) = size_int (0);
1577 : 1244 : decl = build_fold_indirect_ref (decl);
1578 : 1244 : if (present
1579 : 1244 : && (GFC_DECL_GET_SCALAR_POINTER (orig_decl)
1580 : 265 : || GFC_DECL_GET_SCALAR_ALLOCATABLE (orig_decl)))
1581 : : {
1582 : 66 : c2 = build_omp_clause (input_location, OMP_CLAUSE_MAP);
1583 : 66 : OMP_CLAUSE_SET_MAP_KIND (c2, GOMP_MAP_POINTER);
1584 : 66 : OMP_CLAUSE_DECL (c2) = decl;
1585 : 66 : OMP_CLAUSE_SIZE (c2) = size_int (0);
1586 : :
1587 : 66 : stmtblock_t block;
1588 : 66 : gfc_start_block (&block);
1589 : 66 : tree ptr = decl;
1590 : 66 : ptr = gfc_build_cond_assign_expr (&block, present, decl,
1591 : : null_pointer_node);
1592 : 66 : gimplify_and_add (gfc_finish_block (&block), pre_p);
1593 : 66 : ptr = build_fold_indirect_ref (ptr);
1594 : 66 : OMP_CLAUSE_DECL (c) = ptr;
1595 : 66 : OMP_CLAUSE_SIZE (c) = TYPE_SIZE_UNIT (TREE_TYPE (ptr));
1596 : : }
1597 : : else
1598 : : {
1599 : 1178 : OMP_CLAUSE_DECL (c) = decl;
1600 : 1178 : OMP_CLAUSE_SIZE (c) = NULL_TREE;
1601 : : }
1602 : 1244 : if (TREE_CODE (TREE_TYPE (orig_decl)) == REFERENCE_TYPE
1603 : 1244 : && (GFC_DECL_GET_SCALAR_POINTER (orig_decl)
1604 : 388 : || GFC_DECL_GET_SCALAR_ALLOCATABLE (orig_decl)))
1605 : : {
1606 : 66 : c3 = build_omp_clause (OMP_CLAUSE_LOCATION (c), OMP_CLAUSE_MAP);
1607 : 66 : OMP_CLAUSE_SET_MAP_KIND (c3, GOMP_MAP_POINTER);
1608 : 66 : OMP_CLAUSE_DECL (c3) = unshare_expr (decl);
1609 : 66 : OMP_CLAUSE_SIZE (c3) = size_int (0);
1610 : 66 : decl = build_fold_indirect_ref (decl);
1611 : 66 : OMP_CLAUSE_DECL (c) = decl;
1612 : : }
1613 : : }
1614 : 6620 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
1615 : : {
1616 : 1724 : stmtblock_t block;
1617 : 1724 : gfc_start_block (&block);
1618 : 1724 : tree type = TREE_TYPE (decl);
1619 : 1724 : tree ptr = gfc_conv_descriptor_data_get (decl);
1620 : :
1621 : : /* OpenMP: automatically map pointer targets with the pointer;
1622 : : hence, always update the descriptor/pointer itself.
1623 : : NOTE: This also remaps the pointer for allocatable arrays with
1624 : : 'target' attribute which also don't have the 'restrict' qualifier. */
1625 : 1724 : bool always_modifier = false;
1626 : :
1627 : 1724 : if (!openacc
1628 : 1724 : && !(TYPE_QUALS (TREE_TYPE (ptr)) & TYPE_QUAL_RESTRICT))
1629 : : always_modifier = true;
1630 : :
1631 : 1724 : if (present)
1632 : 55 : ptr = gfc_build_cond_assign_expr (&block, present, ptr,
1633 : : null_pointer_node);
1634 : 1724 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (ptr)));
1635 : 1724 : ptr = build_fold_indirect_ref (ptr);
1636 : 1724 : OMP_CLAUSE_DECL (c) = ptr;
1637 : 1724 : c2 = build_omp_clause (input_location, OMP_CLAUSE_MAP);
1638 : 1724 : OMP_CLAUSE_SET_MAP_KIND (c2, GOMP_MAP_TO_PSET);
1639 : 1724 : if (present)
1640 : : {
1641 : 55 : ptr = create_tmp_var (TREE_TYPE (TREE_OPERAND (decl, 0)));
1642 : 55 : gfc_add_modify (&block, ptr, TREE_OPERAND (decl, 0));
1643 : :
1644 : 55 : OMP_CLAUSE_DECL (c2) = build_fold_indirect_ref (ptr);
1645 : : }
1646 : : else
1647 : 1669 : OMP_CLAUSE_DECL (c2) = decl;
1648 : 1724 : OMP_CLAUSE_SIZE (c2) = TYPE_SIZE_UNIT (type);
1649 : 1724 : c3 = build_omp_clause (OMP_CLAUSE_LOCATION (c), OMP_CLAUSE_MAP);
1650 : 3237 : OMP_CLAUSE_SET_MAP_KIND (c3, always_modifier ? GOMP_MAP_ALWAYS_POINTER
1651 : : : GOMP_MAP_POINTER);
1652 : 1724 : if (present)
1653 : : {
1654 : 55 : ptr = gfc_conv_descriptor_data_get (decl);
1655 : 55 : ptr = gfc_build_addr_expr (NULL, ptr);
1656 : 55 : ptr = gfc_build_cond_assign_expr (&block, present,
1657 : : ptr, null_pointer_node);
1658 : 55 : ptr = build_fold_indirect_ref (ptr);
1659 : 55 : OMP_CLAUSE_DECL (c3) = ptr;
1660 : : }
1661 : : else
1662 : 1669 : OMP_CLAUSE_DECL (c3) = gfc_conv_descriptor_data_get (decl);
1663 : 1724 : OMP_CLAUSE_SIZE (c3) = size_int (0);
1664 : 1724 : tree size = create_tmp_var (gfc_array_index_type);
1665 : 1724 : tree elemsz = TYPE_SIZE_UNIT (gfc_get_element_type (type));
1666 : 1724 : elemsz = fold_convert (gfc_array_index_type, elemsz);
1667 : 1724 : if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE
1668 : 212 : || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER
1669 : 1725 : || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT)
1670 : : {
1671 : 1723 : stmtblock_t cond_block;
1672 : 1723 : tree tem, then_b, else_b, zero, cond;
1673 : :
1674 : 1723 : gfc_init_block (&cond_block);
1675 : 5169 : tem = gfc_full_array_size (&cond_block, decl,
1676 : 1723 : GFC_TYPE_ARRAY_RANK (type));
1677 : 1723 : gfc_add_modify (&cond_block, size, tem);
1678 : 1723 : gfc_add_modify (&cond_block, size,
1679 : : fold_build2 (MULT_EXPR, gfc_array_index_type,
1680 : : size, elemsz));
1681 : 1723 : then_b = gfc_finish_block (&cond_block);
1682 : 1723 : gfc_init_block (&cond_block);
1683 : 1723 : zero = build_int_cst (gfc_array_index_type, 0);
1684 : 1723 : gfc_add_modify (&cond_block, size, zero);
1685 : 1723 : else_b = gfc_finish_block (&cond_block);
1686 : 1723 : tem = gfc_conv_descriptor_data_get (decl);
1687 : 1723 : tem = fold_convert (pvoid_type_node, tem);
1688 : 1723 : cond = fold_build2_loc (input_location, NE_EXPR,
1689 : : boolean_type_node, tem, null_pointer_node);
1690 : 1723 : if (present)
1691 : : {
1692 : 54 : cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
1693 : : boolean_type_node, present, cond);
1694 : : }
1695 : 1723 : gfc_add_expr_to_block (&block, build3_loc (input_location, COND_EXPR,
1696 : : void_type_node, cond,
1697 : : then_b, else_b));
1698 : : }
1699 : 1 : else if (present)
1700 : : {
1701 : 1 : stmtblock_t cond_block;
1702 : 1 : tree then_b;
1703 : :
1704 : 1 : gfc_init_block (&cond_block);
1705 : 1 : gfc_add_modify (&cond_block, size,
1706 : : gfc_full_array_size (&cond_block, decl,
1707 : 1 : GFC_TYPE_ARRAY_RANK (type)));
1708 : 1 : gfc_add_modify (&cond_block, size,
1709 : : fold_build2 (MULT_EXPR, gfc_array_index_type,
1710 : : size, elemsz));
1711 : 1 : then_b = gfc_finish_block (&cond_block);
1712 : :
1713 : 1 : gfc_build_cond_assign (&block, size, present, then_b,
1714 : 1 : build_int_cst (gfc_array_index_type, 0));
1715 : : }
1716 : : else
1717 : : {
1718 : 0 : gfc_add_modify (&block, size,
1719 : : gfc_full_array_size (&block, decl,
1720 : 0 : GFC_TYPE_ARRAY_RANK (type)));
1721 : 0 : gfc_add_modify (&block, size,
1722 : : fold_build2 (MULT_EXPR, gfc_array_index_type,
1723 : : size, elemsz));
1724 : : }
1725 : 1724 : OMP_CLAUSE_SIZE (c) = size;
1726 : 1724 : tree stmt = gfc_finish_block (&block);
1727 : 1724 : gimplify_and_add (stmt, pre_p);
1728 : : }
1729 : 6620 : tree last = c;
1730 : 6620 : if (OMP_CLAUSE_SIZE (c) == NULL_TREE)
1731 : 1116 : OMP_CLAUSE_SIZE (c)
1732 : 3178 : = DECL_P (decl) ? DECL_SIZE_UNIT (decl)
1733 : 946 : : TYPE_SIZE_UNIT (TREE_TYPE (decl));
1734 : 6620 : if (gimplify_expr (&OMP_CLAUSE_SIZE (c), pre_p,
1735 : : NULL, is_gimple_val, fb_rvalue) == GS_ERROR)
1736 : 0 : OMP_CLAUSE_SIZE (c) = size_int (0);
1737 : 6620 : if (c2)
1738 : : {
1739 : 1790 : OMP_CLAUSE_CHAIN (c2) = OMP_CLAUSE_CHAIN (last);
1740 : 1790 : OMP_CLAUSE_CHAIN (last) = c2;
1741 : 1790 : last = c2;
1742 : : }
1743 : 6620 : if (c3)
1744 : : {
1745 : 1790 : OMP_CLAUSE_CHAIN (c3) = OMP_CLAUSE_CHAIN (last);
1746 : 1790 : OMP_CLAUSE_CHAIN (last) = c3;
1747 : 1790 : last = c3;
1748 : : }
1749 : 6620 : if (c4)
1750 : : {
1751 : 1244 : OMP_CLAUSE_CHAIN (c4) = OMP_CLAUSE_CHAIN (last);
1752 : 1244 : OMP_CLAUSE_CHAIN (last) = c4;
1753 : : }
1754 : : }
1755 : :
1756 : :
1757 : : /* Return true if DECL is a scalar variable (for the purpose of
1758 : : implicit firstprivatization/mapping). Only if 'ptr_alloc_ok.'
1759 : : is true, allocatables and pointers are permitted. */
1760 : :
1761 : : bool
1762 : 3478 : gfc_omp_scalar_p (tree decl, bool ptr_alloc_ok)
1763 : : {
1764 : 3478 : tree type = TREE_TYPE (decl);
1765 : 3478 : if (TREE_CODE (type) == REFERENCE_TYPE)
1766 : 1310 : type = TREE_TYPE (type);
1767 : 3478 : if (TREE_CODE (type) == POINTER_TYPE)
1768 : : {
1769 : 562 : if (GFC_DECL_GET_SCALAR_ALLOCATABLE (decl)
1770 : 562 : || GFC_DECL_GET_SCALAR_POINTER (decl))
1771 : : {
1772 : 150 : if (!ptr_alloc_ok)
1773 : : return false;
1774 : 0 : type = TREE_TYPE (type);
1775 : : }
1776 : 412 : if (GFC_ARRAY_TYPE_P (type)
1777 : 412 : || GFC_CLASS_TYPE_P (type))
1778 : : return false;
1779 : : }
1780 : 2953 : if ((TREE_CODE (type) == ARRAY_TYPE || TREE_CODE (type) == INTEGER_TYPE)
1781 : 5338 : && TYPE_STRING_FLAG (type))
1782 : : return false;
1783 : 3028 : if (INTEGRAL_TYPE_P (type)
1784 : 3028 : || SCALAR_FLOAT_TYPE_P (type)
1785 : 3028 : || COMPLEX_FLOAT_TYPE_P (type))
1786 : 2531 : return true;
1787 : : return false;
1788 : : }
1789 : :
1790 : :
1791 : : /* Return true if DECL is a scalar with target attribute but does not have the
1792 : : allocatable (or pointer) attribute (for the purpose of implicit mapping). */
1793 : :
1794 : : bool
1795 : 3371 : gfc_omp_scalar_target_p (tree decl)
1796 : : {
1797 : 3371 : return (DECL_P (decl) && GFC_DECL_GET_SCALAR_TARGET (decl)
1798 : 3471 : && gfc_omp_scalar_p (decl, false));
1799 : : }
1800 : :
1801 : :
1802 : : /* Return true if DECL's DECL_VALUE_EXPR (if any) should be
1803 : : disregarded in OpenMP construct, because it is going to be
1804 : : remapped during OpenMP lowering. SHARED is true if DECL
1805 : : is going to be shared, false if it is going to be privatized. */
1806 : :
1807 : : bool
1808 : 1555650 : gfc_omp_disregard_value_expr (tree decl, bool shared)
1809 : : {
1810 : 1555650 : if (GFC_DECL_COMMON_OR_EQUIV (decl)
1811 : 1555650 : && DECL_HAS_VALUE_EXPR_P (decl))
1812 : : {
1813 : 3039 : tree value = DECL_VALUE_EXPR (decl);
1814 : :
1815 : 3039 : if (TREE_CODE (value) == COMPONENT_REF
1816 : 3039 : && VAR_P (TREE_OPERAND (value, 0))
1817 : 6078 : && GFC_DECL_COMMON_OR_EQUIV (TREE_OPERAND (value, 0)))
1818 : : {
1819 : : /* If variable in COMMON or EQUIVALENCE is privatized, return
1820 : : true, as just that variable is supposed to be privatized,
1821 : : not the whole COMMON or whole EQUIVALENCE.
1822 : : For shared variables in COMMON or EQUIVALENCE, let them be
1823 : : gimplified to DECL_VALUE_EXPR, so that for multiple shared vars
1824 : : from the same COMMON or EQUIVALENCE just one sharing of the
1825 : : whole COMMON or EQUIVALENCE is enough. */
1826 : 3039 : return ! shared;
1827 : : }
1828 : : }
1829 : :
1830 : 1552611 : if (GFC_DECL_RESULT (decl) && DECL_HAS_VALUE_EXPR_P (decl))
1831 : 374 : return ! shared;
1832 : :
1833 : : return false;
1834 : : }
1835 : :
1836 : : /* Return true if DECL that is shared iff SHARED is true should
1837 : : be put into OMP_CLAUSE_PRIVATE with OMP_CLAUSE_PRIVATE_DEBUG
1838 : : flag set. */
1839 : :
1840 : : bool
1841 : 37527 : gfc_omp_private_debug_clause (tree decl, bool shared)
1842 : : {
1843 : 37527 : if (GFC_DECL_CRAY_POINTEE (decl))
1844 : : return true;
1845 : :
1846 : 37491 : if (GFC_DECL_COMMON_OR_EQUIV (decl)
1847 : 37491 : && DECL_HAS_VALUE_EXPR_P (decl))
1848 : : {
1849 : 326 : tree value = DECL_VALUE_EXPR (decl);
1850 : :
1851 : 326 : if (TREE_CODE (value) == COMPONENT_REF
1852 : 326 : && VAR_P (TREE_OPERAND (value, 0))
1853 : 652 : && GFC_DECL_COMMON_OR_EQUIV (TREE_OPERAND (value, 0)))
1854 : : return shared;
1855 : : }
1856 : :
1857 : : return false;
1858 : : }
1859 : :
1860 : : /* Register language specific type size variables as potentially OpenMP
1861 : : firstprivate variables. */
1862 : :
1863 : : void
1864 : 20989 : gfc_omp_firstprivatize_type_sizes (struct gimplify_omp_ctx *ctx, tree type)
1865 : : {
1866 : 20989 : if (GFC_ARRAY_TYPE_P (type) || GFC_DESCRIPTOR_TYPE_P (type))
1867 : : {
1868 : 3854 : int r;
1869 : :
1870 : 3854 : gcc_assert (TYPE_LANG_SPECIFIC (type) != NULL);
1871 : 8906 : for (r = 0; r < GFC_TYPE_ARRAY_RANK (type); r++)
1872 : : {
1873 : 5052 : omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_LBOUND (type, r));
1874 : 5052 : omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_UBOUND (type, r));
1875 : 5052 : omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_STRIDE (type, r));
1876 : : }
1877 : 3854 : omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_SIZE (type));
1878 : 3854 : omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_OFFSET (type));
1879 : : }
1880 : 20989 : }
1881 : :
1882 : :
1883 : : static inline tree
1884 : 71697 : gfc_trans_add_clause (tree node, tree tail)
1885 : : {
1886 : 71697 : OMP_CLAUSE_CHAIN (node) = tail;
1887 : 71697 : return node;
1888 : : }
1889 : :
1890 : : static tree
1891 : 41409 : gfc_trans_omp_variable (gfc_symbol *sym, bool declare_simd)
1892 : : {
1893 : 41409 : if (declare_simd)
1894 : : {
1895 : 192 : int cnt = 0;
1896 : 192 : gfc_symbol *proc_sym;
1897 : 192 : gfc_formal_arglist *f;
1898 : :
1899 : 192 : gcc_assert (sym->attr.dummy);
1900 : 192 : proc_sym = sym->ns->proc_name;
1901 : 192 : if (proc_sym->attr.entry_master)
1902 : 0 : ++cnt;
1903 : 192 : if (gfc_return_by_reference (proc_sym))
1904 : : {
1905 : 0 : ++cnt;
1906 : 0 : if (proc_sym->ts.type == BT_CHARACTER)
1907 : 0 : ++cnt;
1908 : : }
1909 : 364 : for (f = gfc_sym_get_dummy_args (proc_sym); f; f = f->next)
1910 : 364 : if (f->sym == sym)
1911 : : break;
1912 : 172 : else if (f->sym)
1913 : 172 : ++cnt;
1914 : 192 : gcc_assert (f);
1915 : 192 : return build_int_cst (integer_type_node, cnt);
1916 : : }
1917 : :
1918 : 41217 : tree t = gfc_get_symbol_decl (sym);
1919 : 41217 : tree parent_decl;
1920 : 41217 : int parent_flag;
1921 : 41217 : bool return_value;
1922 : 41217 : bool alternate_entry;
1923 : 41217 : bool entry_master;
1924 : :
1925 : 41217 : return_value = sym->attr.function && sym->result == sym;
1926 : 158 : alternate_entry = sym->attr.function && sym->attr.entry
1927 : 41251 : && sym->result == sym;
1928 : 82434 : entry_master = sym->attr.result
1929 : 182 : && sym->ns->proc_name->attr.entry_master
1930 : 41229 : && !gfc_return_by_reference (sym->ns->proc_name);
1931 : 82434 : parent_decl = current_function_decl
1932 : 41217 : ? DECL_CONTEXT (current_function_decl) : NULL_TREE;
1933 : :
1934 : 41217 : if ((t == parent_decl && return_value)
1935 : 41210 : || (sym->ns && sym->ns->proc_name
1936 : 41210 : && sym->ns->proc_name->backend_decl == parent_decl
1937 : 2163 : && (alternate_entry || entry_master)))
1938 : : parent_flag = 1;
1939 : : else
1940 : 41208 : parent_flag = 0;
1941 : :
1942 : : /* Special case for assigning the return value of a function.
1943 : : Self recursive functions must have an explicit return value. */
1944 : 41217 : if (return_value && (t == current_function_decl || parent_flag))
1945 : 88 : t = gfc_get_fake_result_decl (sym, parent_flag);
1946 : :
1947 : : /* Similarly for alternate entry points. */
1948 : 41129 : else if (alternate_entry
1949 : 32 : && (sym->ns->proc_name->backend_decl == current_function_decl
1950 : 0 : || parent_flag))
1951 : : {
1952 : 32 : gfc_entry_list *el = NULL;
1953 : :
1954 : 51 : for (el = sym->ns->entries; el; el = el->next)
1955 : 51 : if (sym == el->sym)
1956 : : {
1957 : 32 : t = gfc_get_fake_result_decl (sym, parent_flag);
1958 : 32 : break;
1959 : : }
1960 : : }
1961 : :
1962 : 41097 : else if (entry_master
1963 : 12 : && (sym->ns->proc_name->backend_decl == current_function_decl
1964 : 0 : || parent_flag))
1965 : 12 : t = gfc_get_fake_result_decl (sym, parent_flag);
1966 : :
1967 : : return t;
1968 : : }
1969 : :
1970 : : static tree
1971 : 11069 : gfc_trans_omp_variable_list (enum omp_clause_code code,
1972 : : gfc_omp_namelist *namelist, tree list,
1973 : : bool declare_simd)
1974 : : {
1975 : 28774 : for (; namelist != NULL; namelist = namelist->next)
1976 : 17705 : if (namelist->sym->attr.referenced || declare_simd)
1977 : : {
1978 : 17705 : tree t = gfc_trans_omp_variable (namelist->sym, declare_simd);
1979 : 17705 : if (t != error_mark_node)
1980 : : {
1981 : 17705 : tree node;
1982 : 17705 : node = build_omp_clause (input_location, code);
1983 : 17705 : OMP_CLAUSE_DECL (node) = t;
1984 : 17705 : list = gfc_trans_add_clause (node, list);
1985 : :
1986 : 17705 : if (code == OMP_CLAUSE_LASTPRIVATE
1987 : 2864 : && namelist->u.lastprivate_conditional)
1988 : 88 : OMP_CLAUSE_LASTPRIVATE_CONDITIONAL (node) = 1;
1989 : : }
1990 : : }
1991 : 11069 : return list;
1992 : : }
1993 : :
1994 : : struct omp_udr_find_orig_data
1995 : : {
1996 : : gfc_omp_udr *omp_udr;
1997 : : bool omp_orig_seen;
1998 : : };
1999 : :
2000 : : static int
2001 : 678 : omp_udr_find_orig (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
2002 : : void *data)
2003 : : {
2004 : 678 : struct omp_udr_find_orig_data *cd = (struct omp_udr_find_orig_data *) data;
2005 : 678 : if ((*e)->expr_type == EXPR_VARIABLE
2006 : 366 : && (*e)->symtree->n.sym == cd->omp_udr->omp_orig)
2007 : 72 : cd->omp_orig_seen = true;
2008 : :
2009 : 678 : return 0;
2010 : : }
2011 : :
2012 : : static void
2013 : 683 : gfc_trans_omp_array_reduction_or_udr (tree c, gfc_omp_namelist *n, locus where)
2014 : : {
2015 : 683 : gfc_symbol *sym = n->sym;
2016 : 683 : gfc_symtree *root1 = NULL, *root2 = NULL, *root3 = NULL, *root4 = NULL;
2017 : 683 : gfc_symtree *symtree1, *symtree2, *symtree3, *symtree4 = NULL;
2018 : 683 : gfc_symbol init_val_sym, outer_sym, intrinsic_sym;
2019 : 683 : gfc_symbol omp_var_copy[4];
2020 : 683 : gfc_expr *e1, *e2, *e3, *e4;
2021 : 683 : gfc_ref *ref;
2022 : 683 : tree decl, backend_decl, stmt, type, outer_decl;
2023 : 683 : locus old_loc = gfc_current_locus;
2024 : 683 : const char *iname;
2025 : 683 : bool t;
2026 : 683 : gfc_omp_udr *udr = n->u2.udr ? n->u2.udr->udr : NULL;
2027 : :
2028 : 683 : decl = OMP_CLAUSE_DECL (c);
2029 : 683 : gfc_current_locus = where;
2030 : 683 : type = TREE_TYPE (decl);
2031 : 683 : outer_decl = create_tmp_var_raw (type);
2032 : 683 : if (TREE_CODE (decl) == PARM_DECL
2033 : 31 : && TREE_CODE (type) == REFERENCE_TYPE
2034 : 12 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type))
2035 : 695 : && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (type)) == GFC_ARRAY_ALLOCATABLE)
2036 : : {
2037 : 12 : decl = build_fold_indirect_ref (decl);
2038 : 12 : type = TREE_TYPE (type);
2039 : : }
2040 : :
2041 : : /* Create a fake symbol for init value. */
2042 : 683 : memset (&init_val_sym, 0, sizeof (init_val_sym));
2043 : 683 : init_val_sym.ns = sym->ns;
2044 : 683 : init_val_sym.name = sym->name;
2045 : 683 : init_val_sym.ts = sym->ts;
2046 : 683 : init_val_sym.attr.referenced = 1;
2047 : 683 : init_val_sym.declared_at = where;
2048 : 683 : init_val_sym.attr.flavor = FL_VARIABLE;
2049 : 683 : if (OMP_CLAUSE_REDUCTION_CODE (c) != ERROR_MARK)
2050 : 283 : backend_decl = omp_reduction_init (c, gfc_sym_type (&init_val_sym));
2051 : 400 : else if (udr->initializer_ns)
2052 : : backend_decl = NULL;
2053 : : else
2054 : 130 : switch (sym->ts.type)
2055 : : {
2056 : 15 : case BT_LOGICAL:
2057 : 15 : case BT_INTEGER:
2058 : 15 : case BT_REAL:
2059 : 15 : case BT_COMPLEX:
2060 : 15 : backend_decl = build_zero_cst (gfc_sym_type (&init_val_sym));
2061 : 15 : break;
2062 : : default:
2063 : : backend_decl = NULL_TREE;
2064 : : break;
2065 : : }
2066 : 683 : init_val_sym.backend_decl = backend_decl;
2067 : :
2068 : : /* Create a fake symbol for the outer array reference. */
2069 : 683 : outer_sym = *sym;
2070 : 683 : if (sym->as)
2071 : 426 : outer_sym.as = gfc_copy_array_spec (sym->as);
2072 : 683 : outer_sym.attr.dummy = 0;
2073 : 683 : outer_sym.attr.result = 0;
2074 : 683 : outer_sym.attr.flavor = FL_VARIABLE;
2075 : 683 : outer_sym.backend_decl = outer_decl;
2076 : 683 : if (decl != OMP_CLAUSE_DECL (c))
2077 : 12 : outer_sym.backend_decl = build_fold_indirect_ref (outer_decl);
2078 : :
2079 : : /* Create fake symtrees for it. */
2080 : 683 : symtree1 = gfc_new_symtree (&root1, sym->name);
2081 : 683 : symtree1->n.sym = sym;
2082 : 683 : gcc_assert (symtree1 == root1);
2083 : :
2084 : 683 : symtree2 = gfc_new_symtree (&root2, sym->name);
2085 : 683 : symtree2->n.sym = &init_val_sym;
2086 : 683 : gcc_assert (symtree2 == root2);
2087 : :
2088 : 683 : symtree3 = gfc_new_symtree (&root3, sym->name);
2089 : 683 : symtree3->n.sym = &outer_sym;
2090 : 683 : gcc_assert (symtree3 == root3);
2091 : :
2092 : 683 : memset (omp_var_copy, 0, sizeof omp_var_copy);
2093 : 683 : if (udr)
2094 : : {
2095 : 400 : omp_var_copy[0] = *udr->omp_out;
2096 : 400 : omp_var_copy[1] = *udr->omp_in;
2097 : 400 : *udr->omp_out = outer_sym;
2098 : 400 : *udr->omp_in = *sym;
2099 : 400 : if (udr->initializer_ns)
2100 : : {
2101 : 270 : omp_var_copy[2] = *udr->omp_priv;
2102 : 270 : omp_var_copy[3] = *udr->omp_orig;
2103 : 270 : *udr->omp_priv = *sym;
2104 : 270 : *udr->omp_orig = outer_sym;
2105 : : }
2106 : : }
2107 : :
2108 : : /* Create expressions. */
2109 : 683 : e1 = gfc_get_expr ();
2110 : 683 : e1->expr_type = EXPR_VARIABLE;
2111 : 683 : e1->where = where;
2112 : 683 : e1->symtree = symtree1;
2113 : 683 : e1->ts = sym->ts;
2114 : 683 : if (sym->attr.dimension)
2115 : : {
2116 : 426 : e1->ref = ref = gfc_get_ref ();
2117 : 426 : ref->type = REF_ARRAY;
2118 : 426 : ref->u.ar.where = where;
2119 : 426 : ref->u.ar.as = sym->as;
2120 : 426 : ref->u.ar.type = AR_FULL;
2121 : 426 : ref->u.ar.dimen = 0;
2122 : : }
2123 : 683 : t = gfc_resolve_expr (e1);
2124 : 683 : gcc_assert (t);
2125 : :
2126 : 683 : e2 = NULL;
2127 : 683 : if (backend_decl != NULL_TREE)
2128 : : {
2129 : 298 : e2 = gfc_get_expr ();
2130 : 298 : e2->expr_type = EXPR_VARIABLE;
2131 : 298 : e2->where = where;
2132 : 298 : e2->symtree = symtree2;
2133 : 298 : e2->ts = sym->ts;
2134 : 298 : t = gfc_resolve_expr (e2);
2135 : 298 : gcc_assert (t);
2136 : : }
2137 : 385 : else if (udr->initializer_ns == NULL)
2138 : : {
2139 : 115 : gcc_assert (sym->ts.type == BT_DERIVED);
2140 : 115 : e2 = gfc_default_initializer (&sym->ts);
2141 : 115 : gcc_assert (e2);
2142 : 115 : t = gfc_resolve_expr (e2);
2143 : 115 : gcc_assert (t);
2144 : : }
2145 : 270 : else if (n->u2.udr->initializer->op == EXEC_ASSIGN)
2146 : : {
2147 : 204 : e2 = gfc_copy_expr (n->u2.udr->initializer->expr2);
2148 : 204 : t = gfc_resolve_expr (e2);
2149 : 204 : gcc_assert (t);
2150 : : }
2151 : 683 : if (udr && udr->initializer_ns)
2152 : : {
2153 : 270 : struct omp_udr_find_orig_data cd;
2154 : 270 : cd.omp_udr = udr;
2155 : 270 : cd.omp_orig_seen = false;
2156 : 270 : gfc_code_walker (&n->u2.udr->initializer,
2157 : : gfc_dummy_code_callback, omp_udr_find_orig, &cd);
2158 : 270 : if (cd.omp_orig_seen)
2159 : 72 : OMP_CLAUSE_REDUCTION_OMP_ORIG_REF (c) = 1;
2160 : : }
2161 : :
2162 : 683 : e3 = gfc_copy_expr (e1);
2163 : 683 : e3->symtree = symtree3;
2164 : 683 : t = gfc_resolve_expr (e3);
2165 : 683 : gcc_assert (t);
2166 : :
2167 : 683 : iname = NULL;
2168 : 683 : e4 = NULL;
2169 : 683 : switch (OMP_CLAUSE_REDUCTION_CODE (c))
2170 : : {
2171 : 159 : case PLUS_EXPR:
2172 : 159 : case MINUS_EXPR:
2173 : 159 : e4 = gfc_add (e3, e1);
2174 : 159 : break;
2175 : 26 : case MULT_EXPR:
2176 : 26 : e4 = gfc_multiply (e3, e1);
2177 : 26 : break;
2178 : 6 : case TRUTH_ANDIF_EXPR:
2179 : 6 : e4 = gfc_and (e3, e1);
2180 : 6 : break;
2181 : 6 : case TRUTH_ORIF_EXPR:
2182 : 6 : e4 = gfc_or (e3, e1);
2183 : 6 : break;
2184 : 6 : case EQ_EXPR:
2185 : 6 : e4 = gfc_eqv (e3, e1);
2186 : 6 : break;
2187 : 6 : case NE_EXPR:
2188 : 6 : e4 = gfc_neqv (e3, e1);
2189 : 6 : break;
2190 : : case MIN_EXPR:
2191 : : iname = "min";
2192 : : break;
2193 : : case MAX_EXPR:
2194 : : iname = "max";
2195 : : break;
2196 : : case BIT_AND_EXPR:
2197 : : iname = "iand";
2198 : : break;
2199 : : case BIT_IOR_EXPR:
2200 : : iname = "ior";
2201 : : break;
2202 : : case BIT_XOR_EXPR:
2203 : : iname = "ieor";
2204 : : break;
2205 : 400 : case ERROR_MARK:
2206 : 400 : if (n->u2.udr->combiner->op == EXEC_ASSIGN)
2207 : : {
2208 : 334 : gfc_free_expr (e3);
2209 : 334 : e3 = gfc_copy_expr (n->u2.udr->combiner->expr1);
2210 : 334 : e4 = gfc_copy_expr (n->u2.udr->combiner->expr2);
2211 : 334 : t = gfc_resolve_expr (e3);
2212 : 334 : gcc_assert (t);
2213 : 334 : t = gfc_resolve_expr (e4);
2214 : 334 : gcc_assert (t);
2215 : : }
2216 : : break;
2217 : 0 : default:
2218 : 0 : gcc_unreachable ();
2219 : : }
2220 : 209 : if (iname != NULL)
2221 : : {
2222 : 74 : memset (&intrinsic_sym, 0, sizeof (intrinsic_sym));
2223 : 74 : intrinsic_sym.ns = sym->ns;
2224 : 74 : intrinsic_sym.name = iname;
2225 : 74 : intrinsic_sym.ts = sym->ts;
2226 : 74 : intrinsic_sym.attr.referenced = 1;
2227 : 74 : intrinsic_sym.attr.intrinsic = 1;
2228 : 74 : intrinsic_sym.attr.function = 1;
2229 : 74 : intrinsic_sym.attr.implicit_type = 1;
2230 : 74 : intrinsic_sym.result = &intrinsic_sym;
2231 : 74 : intrinsic_sym.declared_at = where;
2232 : :
2233 : 74 : symtree4 = gfc_new_symtree (&root4, iname);
2234 : 74 : symtree4->n.sym = &intrinsic_sym;
2235 : 74 : gcc_assert (symtree4 == root4);
2236 : :
2237 : 74 : e4 = gfc_get_expr ();
2238 : 74 : e4->expr_type = EXPR_FUNCTION;
2239 : 74 : e4->where = where;
2240 : 74 : e4->symtree = symtree4;
2241 : 74 : e4->value.function.actual = gfc_get_actual_arglist ();
2242 : 74 : e4->value.function.actual->expr = e3;
2243 : 74 : e4->value.function.actual->next = gfc_get_actual_arglist ();
2244 : 74 : e4->value.function.actual->next->expr = e1;
2245 : : }
2246 : 683 : if (OMP_CLAUSE_REDUCTION_CODE (c) != ERROR_MARK)
2247 : : {
2248 : : /* e1 and e3 have been stored as arguments of e4, avoid sharing. */
2249 : 283 : e1 = gfc_copy_expr (e1);
2250 : 283 : e3 = gfc_copy_expr (e3);
2251 : 283 : t = gfc_resolve_expr (e4);
2252 : 283 : gcc_assert (t);
2253 : : }
2254 : :
2255 : : /* Create the init statement list. */
2256 : 683 : pushlevel ();
2257 : 683 : if (e2)
2258 : 617 : stmt = gfc_trans_assignment (e1, e2, false, false);
2259 : : else
2260 : 66 : stmt = gfc_trans_call (n->u2.udr->initializer, false,
2261 : : NULL_TREE, NULL_TREE, false);
2262 : 683 : if (TREE_CODE (stmt) != BIND_EXPR)
2263 : 196 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
2264 : : else
2265 : 487 : poplevel (0, 0);
2266 : 683 : OMP_CLAUSE_REDUCTION_INIT (c) = stmt;
2267 : :
2268 : : /* Create the merge statement list. */
2269 : 683 : pushlevel ();
2270 : 683 : if (e4)
2271 : 617 : stmt = gfc_trans_assignment (e3, e4, false, true);
2272 : : else
2273 : 66 : stmt = gfc_trans_call (n->u2.udr->combiner, false,
2274 : : NULL_TREE, NULL_TREE, false);
2275 : 683 : if (TREE_CODE (stmt) != BIND_EXPR)
2276 : 233 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
2277 : : else
2278 : 450 : poplevel (0, 0);
2279 : 683 : OMP_CLAUSE_REDUCTION_MERGE (c) = stmt;
2280 : :
2281 : : /* And stick the placeholder VAR_DECL into the clause as well. */
2282 : 683 : OMP_CLAUSE_REDUCTION_PLACEHOLDER (c) = outer_decl;
2283 : :
2284 : 683 : gfc_current_locus = old_loc;
2285 : :
2286 : 683 : gfc_free_expr (e1);
2287 : 683 : if (e2)
2288 : 617 : gfc_free_expr (e2);
2289 : 683 : gfc_free_expr (e3);
2290 : 683 : if (e4)
2291 : 617 : gfc_free_expr (e4);
2292 : 683 : free (symtree1);
2293 : 683 : free (symtree2);
2294 : 683 : free (symtree3);
2295 : 683 : free (symtree4);
2296 : 683 : if (outer_sym.as)
2297 : 426 : gfc_free_array_spec (outer_sym.as);
2298 : :
2299 : 683 : if (udr)
2300 : : {
2301 : 400 : *udr->omp_out = omp_var_copy[0];
2302 : 400 : *udr->omp_in = omp_var_copy[1];
2303 : 400 : if (udr->initializer_ns)
2304 : : {
2305 : 270 : *udr->omp_priv = omp_var_copy[2];
2306 : 270 : *udr->omp_orig = omp_var_copy[3];
2307 : : }
2308 : : }
2309 : 683 : }
2310 : :
2311 : : static tree
2312 : 3645 : gfc_trans_omp_reduction_list (int kind, gfc_omp_namelist *namelist, tree list,
2313 : : locus where, bool mark_addressable)
2314 : : {
2315 : 3645 : omp_clause_code clause = OMP_CLAUSE_REDUCTION;
2316 : 3645 : switch (kind)
2317 : : {
2318 : : case OMP_LIST_REDUCTION:
2319 : : case OMP_LIST_REDUCTION_INSCAN:
2320 : : case OMP_LIST_REDUCTION_TASK:
2321 : : break;
2322 : : case OMP_LIST_IN_REDUCTION:
2323 : : clause = OMP_CLAUSE_IN_REDUCTION;
2324 : : break;
2325 : : case OMP_LIST_TASK_REDUCTION:
2326 : : clause = OMP_CLAUSE_TASK_REDUCTION;
2327 : : break;
2328 : 0 : default:
2329 : 0 : gcc_unreachable ();
2330 : : }
2331 : 8205 : for (; namelist != NULL; namelist = namelist->next)
2332 : 4560 : if (namelist->sym->attr.referenced)
2333 : : {
2334 : 4560 : tree t = gfc_trans_omp_variable (namelist->sym, false);
2335 : 4560 : if (t != error_mark_node)
2336 : : {
2337 : 4560 : tree node = build_omp_clause (gfc_get_location (&namelist->where),
2338 : : clause);
2339 : 4560 : OMP_CLAUSE_DECL (node) = t;
2340 : 4560 : if (mark_addressable)
2341 : 37 : TREE_ADDRESSABLE (t) = 1;
2342 : 4560 : if (kind == OMP_LIST_REDUCTION_INSCAN)
2343 : 20 : OMP_CLAUSE_REDUCTION_INSCAN (node) = 1;
2344 : 4560 : if (kind == OMP_LIST_REDUCTION_TASK)
2345 : 91 : OMP_CLAUSE_REDUCTION_TASK (node) = 1;
2346 : 4560 : switch (namelist->u.reduction_op)
2347 : : {
2348 : 2202 : case OMP_REDUCTION_PLUS:
2349 : 2202 : OMP_CLAUSE_REDUCTION_CODE (node) = PLUS_EXPR;
2350 : 2202 : break;
2351 : 147 : case OMP_REDUCTION_MINUS:
2352 : 147 : OMP_CLAUSE_REDUCTION_CODE (node) = MINUS_EXPR;
2353 : 147 : break;
2354 : 239 : case OMP_REDUCTION_TIMES:
2355 : 239 : OMP_CLAUSE_REDUCTION_CODE (node) = MULT_EXPR;
2356 : 239 : break;
2357 : 90 : case OMP_REDUCTION_AND:
2358 : 90 : OMP_CLAUSE_REDUCTION_CODE (node) = TRUTH_ANDIF_EXPR;
2359 : 90 : break;
2360 : 783 : case OMP_REDUCTION_OR:
2361 : 783 : OMP_CLAUSE_REDUCTION_CODE (node) = TRUTH_ORIF_EXPR;
2362 : 783 : break;
2363 : 84 : case OMP_REDUCTION_EQV:
2364 : 84 : OMP_CLAUSE_REDUCTION_CODE (node) = EQ_EXPR;
2365 : 84 : break;
2366 : 84 : case OMP_REDUCTION_NEQV:
2367 : 84 : OMP_CLAUSE_REDUCTION_CODE (node) = NE_EXPR;
2368 : 84 : break;
2369 : 211 : case OMP_REDUCTION_MAX:
2370 : 211 : OMP_CLAUSE_REDUCTION_CODE (node) = MAX_EXPR;
2371 : 211 : break;
2372 : 199 : case OMP_REDUCTION_MIN:
2373 : 199 : OMP_CLAUSE_REDUCTION_CODE (node) = MIN_EXPR;
2374 : 199 : break;
2375 : 38 : case OMP_REDUCTION_IAND:
2376 : 38 : OMP_CLAUSE_REDUCTION_CODE (node) = BIT_AND_EXPR;
2377 : 38 : break;
2378 : 47 : case OMP_REDUCTION_IOR:
2379 : 47 : OMP_CLAUSE_REDUCTION_CODE (node) = BIT_IOR_EXPR;
2380 : 47 : break;
2381 : 36 : case OMP_REDUCTION_IEOR:
2382 : 36 : OMP_CLAUSE_REDUCTION_CODE (node) = BIT_XOR_EXPR;
2383 : 36 : break;
2384 : 400 : case OMP_REDUCTION_USER:
2385 : 400 : OMP_CLAUSE_REDUCTION_CODE (node) = ERROR_MARK;
2386 : 400 : break;
2387 : 0 : default:
2388 : 0 : gcc_unreachable ();
2389 : : }
2390 : 4560 : if (namelist->sym->attr.dimension
2391 : 4134 : || namelist->u.reduction_op == OMP_REDUCTION_USER
2392 : 3890 : || namelist->sym->attr.allocatable)
2393 : 683 : gfc_trans_omp_array_reduction_or_udr (node, namelist, where);
2394 : 4560 : list = gfc_trans_add_clause (node, list);
2395 : : }
2396 : : }
2397 : 3645 : return list;
2398 : : }
2399 : :
2400 : : static inline tree
2401 : 3353 : gfc_convert_expr_to_tree (stmtblock_t *block, gfc_expr *expr)
2402 : : {
2403 : 3353 : gfc_se se;
2404 : 3353 : tree result;
2405 : :
2406 : 3353 : gfc_init_se (&se, NULL );
2407 : 3353 : gfc_conv_expr (&se, expr);
2408 : 3353 : gfc_add_block_to_block (block, &se.pre);
2409 : 3353 : result = gfc_evaluate_now (se.expr, block);
2410 : 3353 : gfc_add_block_to_block (block, &se.post);
2411 : :
2412 : 3353 : return result;
2413 : : }
2414 : :
2415 : : static vec<tree, va_heap, vl_embed> *doacross_steps;
2416 : :
2417 : :
2418 : : /* Translate an array section or array element. */
2419 : :
2420 : : static void
2421 : 3957 : gfc_trans_omp_array_section (stmtblock_t *block, gfc_exec_op op,
2422 : : gfc_omp_namelist *n, tree decl, bool element,
2423 : : bool openmp, gomp_map_kind ptr_kind, tree &node,
2424 : : tree &node2, tree &node3, tree &node4)
2425 : : {
2426 : 3957 : gfc_se se;
2427 : 3957 : tree ptr, ptr2;
2428 : 3957 : tree elemsz = NULL_TREE;
2429 : :
2430 : 3957 : gfc_init_se (&se, NULL);
2431 : 3957 : if (element)
2432 : : {
2433 : 170 : gfc_conv_expr_reference (&se, n->expr);
2434 : 170 : gfc_add_block_to_block (block, &se.pre);
2435 : 170 : ptr = se.expr;
2436 : : }
2437 : : else
2438 : : {
2439 : 3787 : gfc_conv_expr_descriptor (&se, n->expr);
2440 : 3787 : ptr = gfc_conv_array_data (se.expr);
2441 : : }
2442 : 3957 : if (n->expr->ts.type == BT_CHARACTER && n->expr->ts.deferred)
2443 : : {
2444 : 0 : gcc_assert (se.string_length);
2445 : 0 : tree len = gfc_evaluate_now (se.string_length, block);
2446 : 0 : elemsz = gfc_get_char_type (n->expr->ts.kind);
2447 : 0 : elemsz = TYPE_SIZE_UNIT (elemsz);
2448 : 0 : elemsz = fold_build2 (MULT_EXPR, size_type_node,
2449 : : fold_convert (size_type_node, len), elemsz);
2450 : : }
2451 : 3957 : if (element)
2452 : : {
2453 : 170 : if (!elemsz)
2454 : 170 : elemsz = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (ptr)));
2455 : 170 : OMP_CLAUSE_SIZE (node) = elemsz;
2456 : : }
2457 : : else
2458 : : {
2459 : 3787 : tree type = TREE_TYPE (se.expr);
2460 : 3787 : gfc_add_block_to_block (block, &se.pre);
2461 : 3787 : OMP_CLAUSE_SIZE (node) = gfc_full_array_size (block, se.expr,
2462 : 3787 : GFC_TYPE_ARRAY_RANK (type));
2463 : 3787 : if (!elemsz)
2464 : 3787 : elemsz = TYPE_SIZE_UNIT (gfc_get_element_type (type));
2465 : 3787 : elemsz = fold_convert (gfc_array_index_type, elemsz);
2466 : 3787 : OMP_CLAUSE_SIZE (node) = fold_build2 (MULT_EXPR, gfc_array_index_type,
2467 : : OMP_CLAUSE_SIZE (node), elemsz);
2468 : : }
2469 : 3957 : gcc_assert (se.post.head == NULL_TREE);
2470 : 3957 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (ptr)));
2471 : 3957 : OMP_CLAUSE_DECL (node) = build_fold_indirect_ref (ptr);
2472 : 3957 : ptr = fold_convert (ptrdiff_type_node, ptr);
2473 : :
2474 : 7670 : if (POINTER_TYPE_P (TREE_TYPE (decl))
2475 : 322 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (decl)))
2476 : 78 : && ptr_kind == GOMP_MAP_POINTER
2477 : 78 : && op != EXEC_OMP_TARGET_EXIT_DATA
2478 : 78 : && OMP_CLAUSE_MAP_KIND (node) != GOMP_MAP_RELEASE
2479 : 4035 : && OMP_CLAUSE_MAP_KIND (node) != GOMP_MAP_DELETE)
2480 : :
2481 : : {
2482 : 78 : node4 = build_omp_clause (input_location,
2483 : : OMP_CLAUSE_MAP);
2484 : 78 : OMP_CLAUSE_SET_MAP_KIND (node4, GOMP_MAP_POINTER);
2485 : 78 : OMP_CLAUSE_DECL (node4) = decl;
2486 : 78 : OMP_CLAUSE_SIZE (node4) = size_int (0);
2487 : 78 : decl = build_fold_indirect_ref (decl);
2488 : : }
2489 : 3879 : else if (ptr_kind == GOMP_MAP_ALWAYS_POINTER
2490 : 0 : && n->expr->ts.type == BT_CHARACTER
2491 : 0 : && n->expr->ts.deferred)
2492 : : {
2493 : 0 : gomp_map_kind map_kind;
2494 : 0 : if (OMP_CLAUSE_MAP_KIND (node) == GOMP_MAP_DELETE)
2495 : 0 : map_kind = OMP_CLAUSE_MAP_KIND (node);
2496 : 0 : else if (op == EXEC_OMP_TARGET_EXIT_DATA
2497 : 0 : || OMP_CLAUSE_MAP_KIND (node) == GOMP_MAP_RELEASE)
2498 : : map_kind = GOMP_MAP_RELEASE;
2499 : : else
2500 : : map_kind = GOMP_MAP_TO;
2501 : 0 : gcc_assert (se.string_length);
2502 : 0 : node4 = build_omp_clause (input_location, OMP_CLAUSE_MAP);
2503 : 0 : OMP_CLAUSE_SET_MAP_KIND (node4, map_kind);
2504 : 0 : OMP_CLAUSE_DECL (node4) = se.string_length;
2505 : 0 : OMP_CLAUSE_SIZE (node4) = TYPE_SIZE_UNIT (gfc_charlen_type_node);
2506 : : }
2507 : 3957 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
2508 : : {
2509 : 2704 : tree type = TREE_TYPE (decl);
2510 : 2704 : ptr2 = gfc_conv_descriptor_data_get (decl);
2511 : 2704 : node2 = build_omp_clause (input_location, OMP_CLAUSE_MAP);
2512 : 2704 : OMP_CLAUSE_DECL (node2) = decl;
2513 : 2704 : OMP_CLAUSE_SIZE (node2) = TYPE_SIZE_UNIT (type);
2514 : 2704 : if (OMP_CLAUSE_MAP_KIND (node) == GOMP_MAP_DELETE
2515 : 2703 : || OMP_CLAUSE_MAP_KIND (node) == GOMP_MAP_RELEASE
2516 : 2494 : || op == EXEC_OMP_TARGET_EXIT_DATA
2517 : 5198 : || op == EXEC_OACC_EXIT_DATA)
2518 : : {
2519 : 391 : gomp_map_kind map_kind
2520 : 391 : = OMP_CLAUSE_MAP_KIND (node) == GOMP_MAP_DELETE ? GOMP_MAP_DELETE
2521 : 391 : : GOMP_MAP_RELEASE;
2522 : 391 : OMP_CLAUSE_SET_MAP_KIND (node2, map_kind);
2523 : 391 : OMP_CLAUSE_RELEASE_DESCRIPTOR (node2) = 1;
2524 : : }
2525 : : else
2526 : 2313 : OMP_CLAUSE_SET_MAP_KIND (node2, GOMP_MAP_TO_PSET);
2527 : 2704 : node3 = build_omp_clause (input_location, OMP_CLAUSE_MAP);
2528 : 2704 : OMP_CLAUSE_SET_MAP_KIND (node3, ptr_kind);
2529 : 2704 : OMP_CLAUSE_DECL (node3) = gfc_conv_descriptor_data_get (decl);
2530 : : /* This purposely does not include GOMP_MAP_ALWAYS_POINTER. The extra
2531 : : cast prevents gimplify.cc from recognising it as being part of the
2532 : : struct - and adding an 'alloc: for the 'desc.data' pointer, which
2533 : : would break as the 'desc' (the descriptor) is also mapped
2534 : : (see node4 above). */
2535 : 2704 : if (ptr_kind == GOMP_MAP_ATTACH_DETACH && !openmp)
2536 : 141 : STRIP_NOPS (OMP_CLAUSE_DECL (node3));
2537 : : }
2538 : : else
2539 : : {
2540 : 1253 : if (TREE_CODE (TREE_TYPE (decl)) == ARRAY_TYPE)
2541 : : {
2542 : 1009 : tree offset;
2543 : 1009 : ptr2 = build_fold_addr_expr (decl);
2544 : 1009 : offset = fold_build2 (MINUS_EXPR, ptrdiff_type_node, ptr,
2545 : : fold_convert (ptrdiff_type_node, ptr2));
2546 : 1009 : offset = build2 (TRUNC_DIV_EXPR, ptrdiff_type_node,
2547 : : offset, fold_convert (ptrdiff_type_node, elemsz));
2548 : 1009 : offset = build4_loc (input_location, ARRAY_REF,
2549 : 1009 : TREE_TYPE (TREE_TYPE (decl)),
2550 : : decl, offset, NULL_TREE, NULL_TREE);
2551 : 1009 : OMP_CLAUSE_DECL (node) = offset;
2552 : :
2553 : 1009 : if (ptr_kind == GOMP_MAP_ATTACH_DETACH && openmp)
2554 : 143 : return;
2555 : : }
2556 : : else
2557 : : {
2558 : 244 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (decl)));
2559 : : ptr2 = decl;
2560 : : }
2561 : 1110 : node3 = build_omp_clause (input_location,
2562 : : OMP_CLAUSE_MAP);
2563 : 1110 : OMP_CLAUSE_SET_MAP_KIND (node3, ptr_kind);
2564 : 1110 : OMP_CLAUSE_DECL (node3) = decl;
2565 : : }
2566 : 3814 : ptr2 = fold_convert (ptrdiff_type_node, ptr2);
2567 : 3814 : OMP_CLAUSE_SIZE (node3) = fold_build2 (MINUS_EXPR, ptrdiff_type_node,
2568 : : ptr, ptr2);
2569 : : }
2570 : :
2571 : : static tree
2572 : 43 : handle_iterator (gfc_namespace *ns, stmtblock_t *iter_block, tree block)
2573 : : {
2574 : 43 : tree list = NULL_TREE;
2575 : 88 : for (gfc_symbol *sym = ns->omp_affinity_iterators; sym; sym = sym->tlink)
2576 : : {
2577 : 45 : gfc_constructor *c;
2578 : 45 : gfc_se se;
2579 : :
2580 : 45 : tree last = make_tree_vec (6);
2581 : 45 : tree iter_var = gfc_get_symbol_decl (sym);
2582 : 45 : tree type = TREE_TYPE (iter_var);
2583 : 45 : TREE_VEC_ELT (last, 0) = iter_var;
2584 : 45 : DECL_CHAIN (iter_var) = BLOCK_VARS (block);
2585 : 45 : BLOCK_VARS (block) = iter_var;
2586 : :
2587 : : /* begin */
2588 : 45 : c = gfc_constructor_first (sym->value->value.constructor);
2589 : 45 : gfc_init_se (&se, NULL);
2590 : 45 : gfc_conv_expr (&se, c->expr);
2591 : 45 : gfc_add_block_to_block (iter_block, &se.pre);
2592 : 45 : gfc_add_block_to_block (iter_block, &se.post);
2593 : 45 : TREE_VEC_ELT (last, 1) = fold_convert (type,
2594 : : gfc_evaluate_now (se.expr,
2595 : : iter_block));
2596 : : /* end */
2597 : 45 : c = gfc_constructor_next (c);
2598 : 45 : gfc_init_se (&se, NULL);
2599 : 45 : gfc_conv_expr (&se, c->expr);
2600 : 45 : gfc_add_block_to_block (iter_block, &se.pre);
2601 : 45 : gfc_add_block_to_block (iter_block, &se.post);
2602 : 45 : TREE_VEC_ELT (last, 2) = fold_convert (type,
2603 : : gfc_evaluate_now (se.expr,
2604 : : iter_block));
2605 : : /* step */
2606 : 45 : c = gfc_constructor_next (c);
2607 : 45 : tree step;
2608 : 45 : if (c)
2609 : : {
2610 : 5 : gfc_init_se (&se, NULL);
2611 : 5 : gfc_conv_expr (&se, c->expr);
2612 : 5 : gfc_add_block_to_block (iter_block, &se.pre);
2613 : 5 : gfc_add_block_to_block (iter_block, &se.post);
2614 : 5 : gfc_conv_expr (&se, c->expr);
2615 : 5 : step = fold_convert (type,
2616 : : gfc_evaluate_now (se.expr,
2617 : : iter_block));
2618 : : }
2619 : : else
2620 : 40 : step = build_int_cst (type, 1);
2621 : 45 : TREE_VEC_ELT (last, 3) = step;
2622 : : /* orig_step */
2623 : 45 : TREE_VEC_ELT (last, 4) = save_expr (step);
2624 : 45 : TREE_CHAIN (last) = list;
2625 : 45 : list = last;
2626 : : }
2627 : 43 : return list;
2628 : : }
2629 : :
2630 : : /* To alleviate quadratic behaviour in checking each entry of a
2631 : : gfc_omp_namelist against every other entry, we build a hashtable indexed by
2632 : : gfc_symbol pointer, which we can use in the usual case that a map
2633 : : expression has a symbol as its root term. Return a namelist based on the
2634 : : root symbol used by N, building a new table in SYM_ROOTED_NL using the
2635 : : gfc_omp_namelist N2 (all clauses) if we haven't done so already. */
2636 : :
2637 : : static gfc_omp_namelist *
2638 : 528 : get_symbol_rooted_namelist (hash_map<gfc_symbol *,
2639 : : gfc_omp_namelist *> *&sym_rooted_nl,
2640 : : gfc_omp_namelist *n,
2641 : : gfc_omp_namelist *n2, bool *sym_based)
2642 : : {
2643 : : /* Early-out if we have a NULL clause list (e.g. for OpenACC). */
2644 : 528 : if (!n2)
2645 : : return NULL;
2646 : :
2647 : 491 : gfc_symbol *use_sym = NULL;
2648 : :
2649 : : /* We're only interested in cases where we have an expression, e.g. a
2650 : : component access. */
2651 : 491 : if (n->expr && n->expr->expr_type == EXPR_VARIABLE && n->expr->symtree)
2652 : 491 : use_sym = n->expr->symtree->n.sym;
2653 : :
2654 : 491 : *sym_based = false;
2655 : :
2656 : 491 : if (!use_sym)
2657 : : return n2;
2658 : :
2659 : 491 : if (!sym_rooted_nl)
2660 : : {
2661 : 237 : sym_rooted_nl = new hash_map<gfc_symbol *, gfc_omp_namelist *> ();
2662 : :
2663 : 1140 : for (; n2 != NULL; n2 = n2->next)
2664 : : {
2665 : 903 : if (!n2->expr
2666 : 902 : || n2->expr->expr_type != EXPR_VARIABLE
2667 : 902 : || !n2->expr->symtree)
2668 : 1 : continue;
2669 : :
2670 : 902 : gfc_omp_namelist *nl_copy = gfc_get_omp_namelist ();
2671 : 902 : memcpy (nl_copy, n2, sizeof *nl_copy);
2672 : 902 : nl_copy->u2.duplicate_of = n2;
2673 : 902 : nl_copy->next = NULL;
2674 : :
2675 : 902 : gfc_symbol *idx_sym = n2->expr->symtree->n.sym;
2676 : :
2677 : 902 : bool existed;
2678 : 902 : gfc_omp_namelist *&entry
2679 : 902 : = sym_rooted_nl->get_or_insert (idx_sym, &existed);
2680 : 902 : if (existed)
2681 : 614 : nl_copy->next = entry;
2682 : 902 : entry = nl_copy;
2683 : : }
2684 : : }
2685 : :
2686 : 491 : gfc_omp_namelist **n2_sym = sym_rooted_nl->get (use_sym);
2687 : :
2688 : 491 : if (n2_sym)
2689 : : {
2690 : 491 : *sym_based = true;
2691 : 491 : return *n2_sym;
2692 : : }
2693 : :
2694 : : return NULL;
2695 : : }
2696 : :
2697 : : static tree
2698 : 30032 : gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
2699 : : locus where, bool declare_simd = false,
2700 : : bool openacc = false, gfc_exec_op op = EXEC_NOP)
2701 : : {
2702 : 30032 : tree omp_clauses = NULL_TREE, prev_clauses, chunk_size, c;
2703 : 30032 : tree iterator = NULL_TREE;
2704 : 30032 : tree tree_block = NULL_TREE;
2705 : 30032 : stmtblock_t iter_block;
2706 : 30032 : int list, ifc;
2707 : 30032 : enum omp_clause_code clause_code;
2708 : 30032 : gfc_omp_namelist *prev = NULL;
2709 : 30032 : gfc_se se;
2710 : :
2711 : 30032 : if (clauses == NULL)
2712 : : return NULL_TREE;
2713 : :
2714 : 30020 : hash_map<gfc_symbol *, gfc_omp_namelist *> *sym_rooted_nl = NULL;
2715 : :
2716 : 1110740 : for (list = 0; list < OMP_LIST_NUM; list++)
2717 : : {
2718 : 1080720 : gfc_omp_namelist *n = clauses->lists[list];
2719 : :
2720 : 1080720 : if (n == NULL)
2721 : 1054268 : continue;
2722 : 26452 : switch (list)
2723 : : {
2724 : 3645 : case OMP_LIST_REDUCTION:
2725 : 3645 : case OMP_LIST_REDUCTION_INSCAN:
2726 : 3645 : case OMP_LIST_REDUCTION_TASK:
2727 : 3645 : case OMP_LIST_IN_REDUCTION:
2728 : 3645 : case OMP_LIST_TASK_REDUCTION:
2729 : : /* An OpenACC async clause indicates the need to set reduction
2730 : : arguments addressable, to allow asynchronous copy-out. */
2731 : 3645 : omp_clauses = gfc_trans_omp_reduction_list (list, n, omp_clauses,
2732 : 3645 : where, clauses->async);
2733 : 3645 : break;
2734 : 5939 : case OMP_LIST_PRIVATE:
2735 : 5939 : clause_code = OMP_CLAUSE_PRIVATE;
2736 : 5939 : goto add_clause;
2737 : 1066 : case OMP_LIST_SHARED:
2738 : 1066 : clause_code = OMP_CLAUSE_SHARED;
2739 : 1066 : goto add_clause;
2740 : 1048 : case OMP_LIST_FIRSTPRIVATE:
2741 : 1048 : clause_code = OMP_CLAUSE_FIRSTPRIVATE;
2742 : 1048 : goto add_clause;
2743 : 1661 : case OMP_LIST_LASTPRIVATE:
2744 : 1661 : clause_code = OMP_CLAUSE_LASTPRIVATE;
2745 : 1661 : goto add_clause;
2746 : 96 : case OMP_LIST_COPYIN:
2747 : 96 : clause_code = OMP_CLAUSE_COPYIN;
2748 : 96 : goto add_clause;
2749 : 74 : case OMP_LIST_COPYPRIVATE:
2750 : 74 : clause_code = OMP_CLAUSE_COPYPRIVATE;
2751 : 74 : goto add_clause;
2752 : 66 : case OMP_LIST_UNIFORM:
2753 : 66 : clause_code = OMP_CLAUSE_UNIFORM;
2754 : 66 : goto add_clause;
2755 : 49 : case OMP_LIST_USE_DEVICE:
2756 : 49 : case OMP_LIST_USE_DEVICE_PTR:
2757 : 49 : clause_code = OMP_CLAUSE_USE_DEVICE_PTR;
2758 : 49 : goto add_clause;
2759 : 921 : case OMP_LIST_USE_DEVICE_ADDR:
2760 : 921 : clause_code = OMP_CLAUSE_USE_DEVICE_ADDR;
2761 : 921 : goto add_clause;
2762 : 27 : case OMP_LIST_IS_DEVICE_PTR:
2763 : 27 : clause_code = OMP_CLAUSE_IS_DEVICE_PTR;
2764 : 27 : goto add_clause;
2765 : 99 : case OMP_LIST_HAS_DEVICE_ADDR:
2766 : 99 : clause_code = OMP_CLAUSE_HAS_DEVICE_ADDR;
2767 : 99 : goto add_clause;
2768 : 2 : case OMP_LIST_NONTEMPORAL:
2769 : 2 : clause_code = OMP_CLAUSE_NONTEMPORAL;
2770 : 2 : goto add_clause;
2771 : 9 : case OMP_LIST_SCAN_IN:
2772 : 9 : clause_code = OMP_CLAUSE_INCLUSIVE;
2773 : 9 : goto add_clause;
2774 : 7 : case OMP_LIST_SCAN_EX:
2775 : 7 : clause_code = OMP_CLAUSE_EXCLUSIVE;
2776 : 7 : goto add_clause;
2777 : 3 : case OMP_LIST_USE:
2778 : 3 : clause_code = OMP_CLAUSE_USE;
2779 : 3 : goto add_clause;
2780 : 2 : case OMP_LIST_DESTROY:
2781 : 2 : clause_code = OMP_CLAUSE_DESTROY;
2782 : 2 : goto add_clause;
2783 : :
2784 : 11069 : add_clause:
2785 : 11069 : omp_clauses
2786 : 11069 : = gfc_trans_omp_variable_list (clause_code, n, omp_clauses,
2787 : : declare_simd);
2788 : 11069 : break;
2789 : :
2790 : : case OMP_LIST_INIT:
2791 : : {
2792 : : tree pref_type = NULL_TREE;
2793 : : const char *last = NULL;
2794 : 26 : for (; n != NULL; n = n->next)
2795 : 21 : if (n->sym->attr.referenced)
2796 : : {
2797 : 21 : tree t = gfc_trans_omp_variable (n->sym, false);
2798 : 21 : if (t == error_mark_node)
2799 : 0 : continue;
2800 : 21 : tree node = build_omp_clause (input_location,
2801 : : OMP_CLAUSE_INIT);
2802 : 21 : OMP_CLAUSE_DECL (node) = t;
2803 : 21 : if (n->u.init.target)
2804 : 9 : OMP_CLAUSE_INIT_TARGET (node) = 1;
2805 : 21 : if (n->u.init.targetsync)
2806 : 10 : OMP_CLAUSE_INIT_TARGETSYNC (node) = 1;
2807 : 21 : if (last != n->u2.init_interop)
2808 : : {
2809 : 6 : last = n->u2.init_interop;
2810 : 6 : if (n->u2.init_interop == NULL)
2811 : : pref_type = NULL_TREE;
2812 : : else
2813 : : {
2814 : 5 : pref_type = build_string (n->u.init.len,
2815 : : n->u2.init_interop);
2816 : 5 : TREE_TYPE (pref_type)
2817 : 10 : = build_array_type_nelts (unsigned_char_type_node,
2818 : 5 : n->u.init.len);
2819 : : }
2820 : : }
2821 : 21 : OMP_CLAUSE_INIT_PREFER_TYPE (node) = pref_type;
2822 : 21 : omp_clauses = gfc_trans_add_clause (node, omp_clauses);
2823 : : }
2824 : : break;
2825 : : }
2826 : :
2827 : : case OMP_LIST_ALIGNED:
2828 : 256 : for (; n != NULL; n = n->next)
2829 : 149 : if (n->sym->attr.referenced || declare_simd)
2830 : : {
2831 : 149 : tree t = gfc_trans_omp_variable (n->sym, declare_simd);
2832 : 149 : if (t != error_mark_node)
2833 : : {
2834 : 149 : tree node = build_omp_clause (input_location,
2835 : : OMP_CLAUSE_ALIGNED);
2836 : 149 : OMP_CLAUSE_DECL (node) = t;
2837 : 149 : if (n->expr)
2838 : : {
2839 : 148 : tree alignment_var;
2840 : :
2841 : 148 : if (declare_simd)
2842 : 5 : alignment_var = gfc_conv_constant_to_tree (n->expr);
2843 : : else
2844 : : {
2845 : 143 : gfc_init_se (&se, NULL);
2846 : 143 : gfc_conv_expr (&se, n->expr);
2847 : 143 : gfc_add_block_to_block (block, &se.pre);
2848 : 143 : alignment_var = gfc_evaluate_now (se.expr, block);
2849 : 143 : gfc_add_block_to_block (block, &se.post);
2850 : : }
2851 : 148 : OMP_CLAUSE_ALIGNED_ALIGNMENT (node) = alignment_var;
2852 : : }
2853 : 149 : omp_clauses = gfc_trans_add_clause (node, omp_clauses);
2854 : : }
2855 : : }
2856 : : break;
2857 : : case OMP_LIST_ALLOCATE:
2858 : : {
2859 : : tree allocator_ = NULL_TREE;
2860 : : gfc_expr *alloc_expr = NULL;
2861 : 582 : for (; n != NULL; n = n->next)
2862 : 377 : if (n->sym->attr.referenced)
2863 : : {
2864 : 377 : tree t = gfc_trans_omp_variable (n->sym, false);
2865 : 377 : if (t != error_mark_node)
2866 : : {
2867 : 377 : tree node = build_omp_clause (input_location,
2868 : : OMP_CLAUSE_ALLOCATE);
2869 : 377 : OMP_CLAUSE_DECL (node) = t;
2870 : 377 : if (n->u2.allocator)
2871 : : {
2872 : 242 : if (alloc_expr != n->u2.allocator)
2873 : : {
2874 : 125 : gfc_init_se (&se, NULL);
2875 : 125 : gfc_conv_expr (&se, n->u2.allocator);
2876 : 125 : gfc_add_block_to_block (block, &se.pre);
2877 : 125 : allocator_ = gfc_evaluate_now (se.expr, block);
2878 : 125 : gfc_add_block_to_block (block, &se.post);
2879 : : }
2880 : 242 : OMP_CLAUSE_ALLOCATE_ALLOCATOR (node) = allocator_;
2881 : : }
2882 : 377 : alloc_expr = n->u2.allocator;
2883 : 377 : if (n->u.align)
2884 : : {
2885 : 3 : tree align_;
2886 : 3 : gfc_init_se (&se, NULL);
2887 : 3 : gfc_conv_expr (&se, n->u.align);
2888 : 3 : gcc_assert (CONSTANT_CLASS_P (se.expr)
2889 : : && se.pre.head == NULL
2890 : : && se.post.head == NULL);
2891 : 3 : align_ = se.expr;
2892 : 3 : OMP_CLAUSE_ALLOCATE_ALIGN (node) = align_;
2893 : : }
2894 : 377 : omp_clauses = gfc_trans_add_clause (node, omp_clauses);
2895 : : }
2896 : : }
2897 : : else
2898 : 0 : alloc_expr = n->u2.allocator;
2899 : : }
2900 : : break;
2901 : : case OMP_LIST_LINEAR:
2902 : : {
2903 : : gfc_expr *last_step_expr = NULL;
2904 : : tree last_step = NULL_TREE;
2905 : : bool last_step_parm = false;
2906 : :
2907 : 1298 : for (; n != NULL; n = n->next)
2908 : : {
2909 : 800 : if (n->expr)
2910 : : {
2911 : 781 : last_step_expr = n->expr;
2912 : 781 : last_step = NULL_TREE;
2913 : 781 : last_step_parm = false;
2914 : : }
2915 : 800 : if (n->sym->attr.referenced || declare_simd)
2916 : : {
2917 : 800 : tree t = gfc_trans_omp_variable (n->sym, declare_simd);
2918 : 800 : if (t != error_mark_node)
2919 : : {
2920 : 800 : tree node = build_omp_clause (input_location,
2921 : : OMP_CLAUSE_LINEAR);
2922 : 800 : OMP_CLAUSE_DECL (node) = t;
2923 : 800 : omp_clause_linear_kind kind;
2924 : 800 : switch (n->u.linear.op)
2925 : : {
2926 : : case OMP_LINEAR_DEFAULT:
2927 : : kind = OMP_CLAUSE_LINEAR_DEFAULT;
2928 : : break;
2929 : : case OMP_LINEAR_REF:
2930 : : kind = OMP_CLAUSE_LINEAR_REF;
2931 : : break;
2932 : : case OMP_LINEAR_VAL:
2933 : : kind = OMP_CLAUSE_LINEAR_VAL;
2934 : : break;
2935 : : case OMP_LINEAR_UVAL:
2936 : : kind = OMP_CLAUSE_LINEAR_UVAL;
2937 : : break;
2938 : 0 : default:
2939 : 0 : gcc_unreachable ();
2940 : : }
2941 : 800 : OMP_CLAUSE_LINEAR_KIND (node) = kind;
2942 : 800 : OMP_CLAUSE_LINEAR_OLD_LINEAR_MODIFIER (node)
2943 : 800 : = n->u.linear.old_modifier;
2944 : 800 : if (last_step_expr && last_step == NULL_TREE)
2945 : : {
2946 : 781 : if (!declare_simd)
2947 : : {
2948 : 695 : gfc_init_se (&se, NULL);
2949 : 695 : gfc_conv_expr (&se, last_step_expr);
2950 : 695 : gfc_add_block_to_block (block, &se.pre);
2951 : 695 : last_step = gfc_evaluate_now (se.expr, block);
2952 : 695 : gfc_add_block_to_block (block, &se.post);
2953 : : }
2954 : 86 : else if (last_step_expr->expr_type == EXPR_VARIABLE)
2955 : : {
2956 : 2 : gfc_symbol *s = last_step_expr->symtree->n.sym;
2957 : 2 : last_step = gfc_trans_omp_variable (s, true);
2958 : 2 : last_step_parm = true;
2959 : : }
2960 : : else
2961 : 84 : last_step
2962 : 84 : = gfc_conv_constant_to_tree (last_step_expr);
2963 : : }
2964 : 800 : if (last_step_parm)
2965 : : {
2966 : 2 : OMP_CLAUSE_LINEAR_VARIABLE_STRIDE (node) = 1;
2967 : 2 : OMP_CLAUSE_LINEAR_STEP (node) = last_step;
2968 : : }
2969 : : else
2970 : : {
2971 : 798 : if (kind == OMP_CLAUSE_LINEAR_REF)
2972 : : {
2973 : 34 : tree type;
2974 : 34 : if (n->sym->attr.flavor == FL_PROCEDURE)
2975 : : {
2976 : 0 : type = gfc_get_function_type (n->sym);
2977 : 0 : type = build_pointer_type (type);
2978 : : }
2979 : : else
2980 : 34 : type = gfc_sym_type (n->sym);
2981 : 34 : if (POINTER_TYPE_P (type))
2982 : 34 : type = TREE_TYPE (type);
2983 : : /* Otherwise to be determined what exactly
2984 : : should be done. */
2985 : 34 : tree t = fold_convert (sizetype, last_step);
2986 : 34 : t = size_binop (MULT_EXPR, t,
2987 : : TYPE_SIZE_UNIT (type));
2988 : 34 : OMP_CLAUSE_LINEAR_STEP (node) = t;
2989 : : }
2990 : : else
2991 : : {
2992 : 764 : tree type
2993 : 764 : = gfc_typenode_for_spec (&n->sym->ts);
2994 : 764 : OMP_CLAUSE_LINEAR_STEP (node)
2995 : 1528 : = fold_convert (type, last_step);
2996 : : }
2997 : : }
2998 : 800 : if (n->sym->attr.dimension || n->sym->attr.allocatable)
2999 : 222 : OMP_CLAUSE_LINEAR_ARRAY (node) = 1;
3000 : 800 : omp_clauses = gfc_trans_add_clause (node, omp_clauses);
3001 : : }
3002 : : }
3003 : : }
3004 : : }
3005 : : break;
3006 : : case OMP_LIST_AFFINITY:
3007 : : case OMP_LIST_DEPEND:
3008 : : iterator = NULL_TREE;
3009 : : prev = NULL;
3010 : : prev_clauses = omp_clauses;
3011 : 1556 : for (; n != NULL; n = n->next)
3012 : : {
3013 : 842 : if (iterator && prev->u2.ns != n->u2.ns)
3014 : : {
3015 : 12 : BLOCK_SUBBLOCKS (tree_block) = gfc_finish_block (&iter_block);
3016 : 12 : TREE_VEC_ELT (iterator, 5) = tree_block;
3017 : 26 : for (tree c = omp_clauses; c != prev_clauses;
3018 : 14 : c = OMP_CLAUSE_CHAIN (c))
3019 : 28 : OMP_CLAUSE_DECL (c) = build_tree_list (iterator,
3020 : 14 : OMP_CLAUSE_DECL (c));
3021 : : prev_clauses = omp_clauses;
3022 : : iterator = NULL_TREE;
3023 : : }
3024 : 842 : if (n->u2.ns && (!prev || prev->u2.ns != n->u2.ns))
3025 : : {
3026 : 43 : gfc_init_block (&iter_block);
3027 : 43 : tree_block = make_node (BLOCK);
3028 : 43 : TREE_USED (tree_block) = 1;
3029 : 43 : BLOCK_VARS (tree_block) = NULL_TREE;
3030 : 43 : iterator = handle_iterator (n->u2.ns, block,
3031 : : tree_block);
3032 : : }
3033 : 842 : if (!iterator)
3034 : 790 : gfc_init_block (&iter_block);
3035 : 842 : prev = n;
3036 : 842 : if (list == OMP_LIST_DEPEND
3037 : 816 : && (n->u.depend_doacross_op == OMP_DOACROSS_SINK_FIRST
3038 : 816 : || n->u.depend_doacross_op == OMP_DEPEND_SINK_FIRST))
3039 : : {
3040 : 227 : tree vec = NULL_TREE;
3041 : 227 : unsigned int i;
3042 : 227 : bool is_depend
3043 : : = n->u.depend_doacross_op == OMP_DEPEND_SINK_FIRST;
3044 : 227 : for (i = 0; ; i++)
3045 : : {
3046 : 1218 : tree addend = integer_zero_node, t;
3047 : 1218 : bool neg = false;
3048 : 1218 : if (n->sym && n->expr)
3049 : : {
3050 : 558 : addend = gfc_conv_constant_to_tree (n->expr);
3051 : 558 : if (TREE_CODE (addend) == INTEGER_CST
3052 : 558 : && tree_int_cst_sgn (addend) == -1)
3053 : : {
3054 : 407 : neg = true;
3055 : 407 : addend = const_unop (NEGATE_EXPR,
3056 : 407 : TREE_TYPE (addend), addend);
3057 : : }
3058 : : }
3059 : :
3060 : 1218 : if (n->sym == NULL)
3061 : 0 : t = null_pointer_node; /* "omp_cur_iteration - 1". */
3062 : : else
3063 : 1218 : t = gfc_trans_omp_variable (n->sym, false);
3064 : 1218 : if (t != error_mark_node)
3065 : : {
3066 : 1218 : if (i < vec_safe_length (doacross_steps)
3067 : 426 : && !integer_zerop (addend)
3068 : 630 : && (*doacross_steps)[i])
3069 : : {
3070 : 204 : tree step = (*doacross_steps)[i];
3071 : 204 : addend = fold_convert (TREE_TYPE (step), addend);
3072 : 204 : addend = build2 (TRUNC_DIV_EXPR,
3073 : 204 : TREE_TYPE (step), addend, step);
3074 : : }
3075 : 1218 : vec = tree_cons (addend, t, vec);
3076 : 1218 : if (neg)
3077 : 407 : OMP_CLAUSE_DOACROSS_SINK_NEGATIVE (vec) = 1;
3078 : : }
3079 : 1218 : if (n->next == NULL
3080 : 1057 : || n->next->u.depend_doacross_op != OMP_DOACROSS_SINK)
3081 : : break;
3082 : 991 : n = n->next;
3083 : 991 : }
3084 : 227 : if (vec == NULL_TREE)
3085 : 0 : continue;
3086 : :
3087 : 227 : tree node = build_omp_clause (input_location,
3088 : : OMP_CLAUSE_DOACROSS);
3089 : 227 : OMP_CLAUSE_DOACROSS_KIND (node) = OMP_CLAUSE_DOACROSS_SINK;
3090 : 227 : OMP_CLAUSE_DOACROSS_DEPEND (node) = is_depend;
3091 : 227 : OMP_CLAUSE_DECL (node) = nreverse (vec);
3092 : 227 : omp_clauses = gfc_trans_add_clause (node, omp_clauses);
3093 : 227 : continue;
3094 : 227 : }
3095 : :
3096 : 615 : if (n->sym && !n->sym->attr.referenced)
3097 : 0 : continue;
3098 : :
3099 : 641 : tree node = build_omp_clause (input_location,
3100 : : list == OMP_LIST_DEPEND
3101 : : ? OMP_CLAUSE_DEPEND
3102 : : : OMP_CLAUSE_AFFINITY);
3103 : 615 : if (n->sym == NULL) /* omp_all_memory */
3104 : 9 : OMP_CLAUSE_DECL (node) = null_pointer_node;
3105 : 606 : else if (n->expr == NULL || n->expr->ref->u.ar.type == AR_FULL)
3106 : : {
3107 : 397 : tree decl = gfc_trans_omp_variable (n->sym, false);
3108 : 397 : if (gfc_omp_privatize_by_reference (decl))
3109 : 60 : decl = build_fold_indirect_ref (decl);
3110 : 397 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
3111 : : {
3112 : 23 : decl = gfc_conv_descriptor_data_get (decl);
3113 : 23 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (decl)));
3114 : 23 : decl = build_fold_indirect_ref (decl);
3115 : : }
3116 : 374 : else if (n->sym->attr.allocatable || n->sym->attr.pointer)
3117 : 22 : decl = build_fold_indirect_ref (decl);
3118 : 352 : else if (DECL_P (decl))
3119 : 321 : TREE_ADDRESSABLE (decl) = 1;
3120 : 397 : OMP_CLAUSE_DECL (node) = decl;
3121 : 397 : }
3122 : : else
3123 : : {
3124 : 209 : tree ptr;
3125 : 209 : gfc_init_se (&se, NULL);
3126 : 209 : if (n->expr->ref->u.ar.type == AR_ELEMENT)
3127 : : {
3128 : 130 : gfc_conv_expr_reference (&se, n->expr);
3129 : 130 : ptr = se.expr;
3130 : : }
3131 : : else
3132 : : {
3133 : 79 : gfc_conv_expr_descriptor (&se, n->expr);
3134 : 79 : ptr = gfc_conv_array_data (se.expr);
3135 : : }
3136 : 209 : gfc_add_block_to_block (&iter_block, &se.pre);
3137 : 209 : gfc_add_block_to_block (&iter_block, &se.post);
3138 : 209 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (ptr)));
3139 : 209 : OMP_CLAUSE_DECL (node) = build_fold_indirect_ref (ptr);
3140 : : }
3141 : 615 : if (list == OMP_LIST_DEPEND)
3142 : 589 : switch (n->u.depend_doacross_op)
3143 : : {
3144 : 224 : case OMP_DEPEND_IN:
3145 : 224 : OMP_CLAUSE_DEPEND_KIND (node) = OMP_CLAUSE_DEPEND_IN;
3146 : 224 : break;
3147 : 256 : case OMP_DEPEND_OUT:
3148 : 256 : OMP_CLAUSE_DEPEND_KIND (node) = OMP_CLAUSE_DEPEND_OUT;
3149 : 256 : break;
3150 : 50 : case OMP_DEPEND_INOUT:
3151 : 50 : OMP_CLAUSE_DEPEND_KIND (node) = OMP_CLAUSE_DEPEND_INOUT;
3152 : 50 : break;
3153 : 9 : case OMP_DEPEND_INOUTSET:
3154 : 9 : OMP_CLAUSE_DEPEND_KIND (node) = OMP_CLAUSE_DEPEND_INOUTSET;
3155 : 9 : break;
3156 : 15 : case OMP_DEPEND_MUTEXINOUTSET:
3157 : 15 : OMP_CLAUSE_DEPEND_KIND (node)
3158 : 15 : = OMP_CLAUSE_DEPEND_MUTEXINOUTSET;
3159 : 15 : break;
3160 : 35 : case OMP_DEPEND_DEPOBJ:
3161 : 35 : OMP_CLAUSE_DEPEND_KIND (node) = OMP_CLAUSE_DEPEND_DEPOBJ;
3162 : 35 : break;
3163 : 0 : default:
3164 : 0 : gcc_unreachable ();
3165 : : }
3166 : 615 : if (!iterator)
3167 : 563 : gfc_add_block_to_block (block, &iter_block);
3168 : 615 : omp_clauses = gfc_trans_add_clause (node, omp_clauses);
3169 : : }
3170 : 714 : if (iterator)
3171 : : {
3172 : 31 : BLOCK_SUBBLOCKS (tree_block) = gfc_finish_block (&iter_block);
3173 : 31 : TREE_VEC_ELT (iterator, 5) = tree_block;
3174 : 70 : for (tree c = omp_clauses; c != prev_clauses;
3175 : 39 : c = OMP_CLAUSE_CHAIN (c))
3176 : 78 : OMP_CLAUSE_DECL (c) = build_tree_list (iterator,
3177 : 39 : OMP_CLAUSE_DECL (c));
3178 : : }
3179 : : break;
3180 : : case OMP_LIST_MAP:
3181 : 22830 : for (; n != NULL; n = n->next)
3182 : : {
3183 : 14409 : if (!n->sym->attr.referenced)
3184 : 280 : continue;
3185 : :
3186 : 14409 : bool always_modifier = false;
3187 : 14409 : tree node = build_omp_clause (input_location, OMP_CLAUSE_MAP);
3188 : 14409 : tree node2 = NULL_TREE;
3189 : 14409 : tree node3 = NULL_TREE;
3190 : 14409 : tree node4 = NULL_TREE;
3191 : 14409 : tree node5 = NULL_TREE;
3192 : :
3193 : : /* OpenMP: automatically map pointer targets with the pointer;
3194 : : hence, always update the descriptor/pointer itself. */
3195 : 14409 : if (!openacc
3196 : 14409 : && ((n->expr == NULL && n->sym->attr.pointer)
3197 : 13639 : || (n->expr && gfc_expr_attr (n->expr).pointer)))
3198 : 1333 : always_modifier = true;
3199 : :
3200 : 14409 : if (n->u.map.readonly)
3201 : 22 : OMP_CLAUSE_MAP_READONLY (node) = 1;
3202 : :
3203 : 14409 : switch (n->u.map.op)
3204 : : {
3205 : 997 : case OMP_MAP_ALLOC:
3206 : 997 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ALLOC);
3207 : 997 : break;
3208 : 63 : case OMP_MAP_IF_PRESENT:
3209 : 63 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_IF_PRESENT);
3210 : 63 : break;
3211 : 62 : case OMP_MAP_ATTACH:
3212 : 62 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ATTACH);
3213 : 62 : break;
3214 : 3901 : case OMP_MAP_TO:
3215 : 3901 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_TO);
3216 : 3901 : break;
3217 : 2740 : case OMP_MAP_FROM:
3218 : 2740 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FROM);
3219 : 2740 : break;
3220 : 4264 : case OMP_MAP_TOFROM:
3221 : 4264 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_TOFROM);
3222 : 4264 : break;
3223 : 32 : case OMP_MAP_ALWAYS_TO:
3224 : 32 : always_modifier = true;
3225 : 32 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ALWAYS_TO);
3226 : 32 : break;
3227 : 14 : case OMP_MAP_ALWAYS_FROM:
3228 : 14 : always_modifier = true;
3229 : 14 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ALWAYS_FROM);
3230 : 14 : break;
3231 : 169 : case OMP_MAP_ALWAYS_TOFROM:
3232 : 169 : always_modifier = true;
3233 : 169 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ALWAYS_TOFROM);
3234 : 169 : break;
3235 : 6 : case OMP_MAP_PRESENT_ALLOC:
3236 : 6 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_PRESENT_ALLOC);
3237 : 6 : break;
3238 : 13 : case OMP_MAP_PRESENT_TO:
3239 : 13 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_PRESENT_TO);
3240 : 13 : break;
3241 : 4 : case OMP_MAP_PRESENT_FROM:
3242 : 4 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_PRESENT_FROM);
3243 : 4 : break;
3244 : 2 : case OMP_MAP_PRESENT_TOFROM:
3245 : 2 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_PRESENT_TOFROM);
3246 : 2 : break;
3247 : 8 : case OMP_MAP_ALWAYS_PRESENT_TO:
3248 : 8 : always_modifier = true;
3249 : 8 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ALWAYS_PRESENT_TO);
3250 : 8 : break;
3251 : 4 : case OMP_MAP_ALWAYS_PRESENT_FROM:
3252 : 4 : always_modifier = true;
3253 : 4 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ALWAYS_PRESENT_FROM);
3254 : 4 : break;
3255 : 2 : case OMP_MAP_ALWAYS_PRESENT_TOFROM:
3256 : 2 : always_modifier = true;
3257 : 2 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ALWAYS_PRESENT_TOFROM);
3258 : 2 : break;
3259 : 382 : case OMP_MAP_RELEASE:
3260 : 382 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_RELEASE);
3261 : 382 : break;
3262 : 56 : case OMP_MAP_DELETE:
3263 : 56 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_DELETE);
3264 : 56 : break;
3265 : 40 : case OMP_MAP_DETACH:
3266 : 40 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_DETACH);
3267 : 40 : break;
3268 : 63 : case OMP_MAP_FORCE_ALLOC:
3269 : 63 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_ALLOC);
3270 : 63 : break;
3271 : 465 : case OMP_MAP_FORCE_TO:
3272 : 465 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_TO);
3273 : 465 : break;
3274 : 577 : case OMP_MAP_FORCE_FROM:
3275 : 577 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_FROM);
3276 : 577 : break;
3277 : 0 : case OMP_MAP_FORCE_TOFROM:
3278 : 0 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_TOFROM);
3279 : 0 : break;
3280 : 542 : case OMP_MAP_FORCE_PRESENT:
3281 : 542 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_PRESENT);
3282 : 542 : break;
3283 : 3 : case OMP_MAP_FORCE_DEVICEPTR:
3284 : 3 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_DEVICEPTR);
3285 : 3 : break;
3286 : 0 : default:
3287 : 0 : gcc_unreachable ();
3288 : : }
3289 : :
3290 : 14409 : tree decl = gfc_trans_omp_variable (n->sym, false);
3291 : 14409 : if (DECL_P (decl))
3292 : 14409 : TREE_ADDRESSABLE (decl) = 1;
3293 : :
3294 : 14409 : gfc_ref *lastref = NULL;
3295 : :
3296 : 14409 : if (n->expr)
3297 : 12531 : for (gfc_ref *ref = n->expr->ref; ref; ref = ref->next)
3298 : 7327 : if (ref->type == REF_COMPONENT || ref->type == REF_ARRAY)
3299 : 7327 : lastref = ref;
3300 : :
3301 : 5204 : bool allocatable = false, pointer = false;
3302 : :
3303 : 5204 : if (lastref && lastref->type == REF_COMPONENT)
3304 : : {
3305 : 413 : gfc_component *c = lastref->u.c.component;
3306 : :
3307 : 413 : if (c->ts.type == BT_CLASS)
3308 : : {
3309 : 24 : pointer = CLASS_DATA (c)->attr.class_pointer;
3310 : 24 : allocatable = CLASS_DATA (c)->attr.allocatable;
3311 : : }
3312 : : else
3313 : : {
3314 : 389 : pointer = c->attr.pointer;
3315 : 389 : allocatable = c->attr.allocatable;
3316 : : }
3317 : : }
3318 : :
3319 : 14409 : if (n->expr == NULL
3320 : 5204 : || (n->expr->ref->type == REF_ARRAY
3321 : 3528 : && n->expr->ref->u.ar.type == AR_FULL))
3322 : : {
3323 : 9205 : gomp_map_kind map_kind;
3324 : 9205 : tree type = TREE_TYPE (decl);
3325 : 9205 : if (n->sym->ts.type == BT_CHARACTER
3326 : 182 : && n->sym->ts.deferred
3327 : 68 : && n->sym->attr.omp_declare_target
3328 : 8 : && (always_modifier || n->sym->attr.pointer)
3329 : 8 : && op != EXEC_OMP_TARGET_EXIT_DATA
3330 : 4 : && n->u.map.op != OMP_MAP_DELETE
3331 : 4 : && n->u.map.op != OMP_MAP_RELEASE)
3332 : : {
3333 : 4 : gcc_assert (n->sym->ts.u.cl->backend_decl);
3334 : 4 : node5 = build_omp_clause (input_location, OMP_CLAUSE_MAP);
3335 : 4 : OMP_CLAUSE_SET_MAP_KIND (node5, GOMP_MAP_ALWAYS_TO);
3336 : 4 : OMP_CLAUSE_DECL (node5) = n->sym->ts.u.cl->backend_decl;
3337 : 4 : OMP_CLAUSE_SIZE (node5)
3338 : 8 : = TYPE_SIZE_UNIT (gfc_charlen_type_node);
3339 : : }
3340 : :
3341 : 9205 : tree present = gfc_omp_check_optional_argument (decl, true);
3342 : 9205 : if (openacc && n->sym->ts.type == BT_CLASS)
3343 : : {
3344 : 60 : if (n->sym->attr.optional)
3345 : 0 : sorry ("optional class parameter");
3346 : 60 : tree ptr = gfc_class_data_get (decl);
3347 : 60 : ptr = build_fold_indirect_ref (ptr);
3348 : 60 : OMP_CLAUSE_DECL (node) = ptr;
3349 : 60 : OMP_CLAUSE_SIZE (node) = gfc_class_vtab_size_get (decl);
3350 : 60 : node2 = build_omp_clause (input_location, OMP_CLAUSE_MAP);
3351 : 60 : OMP_CLAUSE_SET_MAP_KIND (node2, GOMP_MAP_ATTACH_DETACH);
3352 : 60 : OMP_CLAUSE_DECL (node2) = gfc_class_data_get (decl);
3353 : 60 : OMP_CLAUSE_SIZE (node2) = size_int (0);
3354 : 60 : goto finalize_map_clause;
3355 : : }
3356 : 9145 : else if (POINTER_TYPE_P (type)
3357 : 9145 : && (gfc_omp_privatize_by_reference (decl)
3358 : 419 : || GFC_DECL_GET_SCALAR_POINTER (decl)
3359 : 257 : || GFC_DECL_GET_SCALAR_ALLOCATABLE (decl)
3360 : 78 : || GFC_DECL_CRAY_POINTEE (decl)
3361 : 78 : || GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type))
3362 : 78 : || (n->sym->ts.type == BT_DERIVED
3363 : 8 : && (n->sym->ts.u.derived->ts.f90_type
3364 : : != BT_VOID))))
3365 : : {
3366 : 3257 : tree orig_decl = decl;
3367 : :
3368 : : /* For nonallocatable, nonpointer arrays, a temporary
3369 : : variable is generated, but this one is only defined if
3370 : : the variable is present; hence, we now set it to NULL
3371 : : to avoid accessing undefined variables. We cannot use
3372 : : a temporary variable here as otherwise the replacement
3373 : : of the variables in omp-low.cc will not work. */
3374 : 3257 : if (present && GFC_ARRAY_TYPE_P (type))
3375 : : {
3376 : 283 : tree tmp = fold_build2_loc (input_location,
3377 : : MODIFY_EXPR,
3378 : : void_type_node, decl,
3379 : : null_pointer_node);
3380 : 283 : tree cond = fold_build1_loc (input_location,
3381 : : TRUTH_NOT_EXPR,
3382 : : boolean_type_node,
3383 : : present);
3384 : 283 : gfc_add_expr_to_block (block,
3385 : : build3_loc (input_location,
3386 : : COND_EXPR,
3387 : : void_type_node,
3388 : : cond, tmp,
3389 : : NULL_TREE));
3390 : : }
3391 : : /* For descriptor types, the unmapping happens below. */
3392 : 3257 : if (op != EXEC_OMP_TARGET_EXIT_DATA
3393 : 3257 : || !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
3394 : : {
3395 : 3257 : enum gomp_map_kind gmk = GOMP_MAP_POINTER;
3396 : 3257 : if (op == EXEC_OMP_TARGET_EXIT_DATA
3397 : 32 : && n->u.map.op == OMP_MAP_DELETE)
3398 : : gmk = GOMP_MAP_DELETE;
3399 : 27 : else if (op == EXEC_OMP_TARGET_EXIT_DATA)
3400 : 27 : gmk = GOMP_MAP_RELEASE;
3401 : 3257 : tree size;
3402 : 3257 : if (gmk == GOMP_MAP_RELEASE || gmk == GOMP_MAP_DELETE)
3403 : 32 : size = TYPE_SIZE_UNIT (TREE_TYPE (decl));
3404 : : else
3405 : 3225 : size = size_int (0);
3406 : 3257 : node4 = build_omp_clause (input_location,
3407 : : OMP_CLAUSE_MAP);
3408 : 3257 : OMP_CLAUSE_SET_MAP_KIND (node4, gmk);
3409 : 3257 : OMP_CLAUSE_DECL (node4) = decl;
3410 : 3257 : OMP_CLAUSE_SIZE (node4) = size;
3411 : : }
3412 : 3257 : decl = build_fold_indirect_ref (decl);
3413 : 3257 : if ((TREE_CODE (TREE_TYPE (orig_decl)) == REFERENCE_TYPE
3414 : 2033 : || gfc_omp_is_optional_argument (orig_decl))
3415 : 4305 : && (GFC_DECL_GET_SCALAR_POINTER (orig_decl)
3416 : 2102 : || GFC_DECL_GET_SCALAR_ALLOCATABLE (orig_decl)))
3417 : : {
3418 : 406 : enum gomp_map_kind gmk;
3419 : 406 : if (op == EXEC_OMP_TARGET_EXIT_DATA
3420 : 8 : && n->u.map.op == OMP_MAP_DELETE)
3421 : : gmk = GOMP_MAP_DELETE;
3422 : 6 : else if (op == EXEC_OMP_TARGET_EXIT_DATA)
3423 : : gmk = GOMP_MAP_RELEASE;
3424 : : else
3425 : : gmk = GOMP_MAP_POINTER;
3426 : 406 : tree size;
3427 : 406 : if (gmk == GOMP_MAP_RELEASE || gmk == GOMP_MAP_DELETE)
3428 : 8 : size = TYPE_SIZE_UNIT (TREE_TYPE (decl));
3429 : : else
3430 : 398 : size = size_int (0);
3431 : 406 : node3 = build_omp_clause (input_location,
3432 : : OMP_CLAUSE_MAP);
3433 : 406 : OMP_CLAUSE_SET_MAP_KIND (node3, gmk);
3434 : 406 : OMP_CLAUSE_DECL (node3) = decl;
3435 : 406 : OMP_CLAUSE_SIZE (node3) = size;
3436 : 406 : decl = build_fold_indirect_ref (decl);
3437 : : }
3438 : : }
3439 : 9145 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
3440 : : {
3441 : 1362 : tree type = TREE_TYPE (decl);
3442 : 1362 : tree ptr = gfc_conv_descriptor_data_get (decl);
3443 : 1362 : if (present)
3444 : 308 : ptr = gfc_build_cond_assign_expr (block, present, ptr,
3445 : : null_pointer_node);
3446 : 1362 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (ptr)));
3447 : 1362 : ptr = build_fold_indirect_ref (ptr);
3448 : 1362 : OMP_CLAUSE_DECL (node) = ptr;
3449 : 1362 : node2 = build_omp_clause (input_location, OMP_CLAUSE_MAP);
3450 : 1362 : OMP_CLAUSE_DECL (node2) = decl;
3451 : 1362 : OMP_CLAUSE_SIZE (node2) = TYPE_SIZE_UNIT (type);
3452 : 1362 : if (n->u.map.op == OMP_MAP_DELETE)
3453 : : map_kind = GOMP_MAP_DELETE;
3454 : 1335 : else if (op == EXEC_OMP_TARGET_EXIT_DATA
3455 : 1280 : || n->u.map.op == OMP_MAP_RELEASE)
3456 : : map_kind = GOMP_MAP_RELEASE;
3457 : : else
3458 : 1362 : map_kind = GOMP_MAP_TO_PSET;
3459 : 1362 : OMP_CLAUSE_SET_MAP_KIND (node2, map_kind);
3460 : :
3461 : 1362 : if (op != EXEC_OMP_TARGET_EXIT_DATA
3462 : 1280 : && n->u.map.op != OMP_MAP_DELETE
3463 : 1280 : && n->u.map.op != OMP_MAP_RELEASE)
3464 : : {
3465 : 1238 : node3 = build_omp_clause (input_location,
3466 : : OMP_CLAUSE_MAP);
3467 : 1238 : if (present)
3468 : : {
3469 : 308 : ptr = gfc_conv_descriptor_data_get (decl);
3470 : 308 : ptr = gfc_build_addr_expr (NULL, ptr);
3471 : 308 : ptr = gfc_build_cond_assign_expr (
3472 : : block, present, ptr, null_pointer_node);
3473 : 308 : ptr = build_fold_indirect_ref (ptr);
3474 : 308 : OMP_CLAUSE_DECL (node3) = ptr;
3475 : : }
3476 : : else
3477 : 930 : OMP_CLAUSE_DECL (node3)
3478 : 1860 : = gfc_conv_descriptor_data_get (decl);
3479 : 1238 : OMP_CLAUSE_SIZE (node3) = size_int (0);
3480 : :
3481 : 1238 : if (n->u.map.op == OMP_MAP_ATTACH)
3482 : : {
3483 : : /* Standalone attach clauses used with arrays with
3484 : : descriptors must copy the descriptor to the
3485 : : target, else they won't have anything to
3486 : : perform the attachment onto (see OpenACC 2.6,
3487 : : "2.6.3. Data Structures with Pointers"). */
3488 : 7 : OMP_CLAUSE_SET_MAP_KIND (node3, GOMP_MAP_ATTACH);
3489 : : /* We don't want to map PTR at all in this case,
3490 : : so delete its node and shuffle the others
3491 : : down. */
3492 : 7 : node = node2;
3493 : 7 : node2 = node3;
3494 : 7 : node3 = NULL;
3495 : 7 : goto finalize_map_clause;
3496 : : }
3497 : 1231 : else if (n->u.map.op == OMP_MAP_DETACH)
3498 : : {
3499 : 2 : OMP_CLAUSE_SET_MAP_KIND (node3, GOMP_MAP_DETACH);
3500 : : /* Similarly to above, we don't want to unmap PTR
3501 : : here. */
3502 : 2 : node = node2;
3503 : 2 : node2 = node3;
3504 : 2 : node3 = NULL;
3505 : 2 : goto finalize_map_clause;
3506 : : }
3507 : : else
3508 : 1996 : OMP_CLAUSE_SET_MAP_KIND (node3,
3509 : : always_modifier
3510 : : ? GOMP_MAP_ALWAYS_POINTER
3511 : : : GOMP_MAP_POINTER);
3512 : : }
3513 : :
3514 : : /* We have to check for n->sym->attr.dimension because
3515 : : of scalar coarrays. */
3516 : 1353 : if ((n->sym->attr.pointer || n->sym->attr.allocatable)
3517 : 1353 : && n->sym->attr.dimension)
3518 : : {
3519 : 1353 : stmtblock_t cond_block;
3520 : 1353 : tree size
3521 : 1353 : = gfc_create_var (gfc_array_index_type, NULL);
3522 : 1353 : tree tem, then_b, else_b, zero, cond;
3523 : :
3524 : 1353 : gfc_init_block (&cond_block);
3525 : 1353 : tem
3526 : 2706 : = gfc_full_array_size (&cond_block, decl,
3527 : 1353 : GFC_TYPE_ARRAY_RANK (type));
3528 : 1353 : tree elemsz;
3529 : 1353 : if (n->sym->ts.type == BT_CHARACTER
3530 : 40 : && n->sym->ts.deferred)
3531 : : {
3532 : 32 : tree len = n->sym->ts.u.cl->backend_decl;
3533 : 32 : len = fold_convert (size_type_node, len);
3534 : 32 : elemsz = gfc_get_char_type (n->sym->ts.kind);
3535 : 32 : elemsz = TYPE_SIZE_UNIT (elemsz);
3536 : 32 : elemsz = fold_build2 (MULT_EXPR, size_type_node,
3537 : : len, elemsz);
3538 : 32 : }
3539 : : else
3540 : 1321 : elemsz
3541 : 1321 : = TYPE_SIZE_UNIT (gfc_get_element_type (type));
3542 : 1353 : elemsz = fold_convert (gfc_array_index_type, elemsz);
3543 : 1353 : tem = fold_build2 (MULT_EXPR, gfc_array_index_type,
3544 : : tem, elemsz);
3545 : 1353 : gfc_add_modify (&cond_block, size, tem);
3546 : 1353 : then_b = gfc_finish_block (&cond_block);
3547 : 1353 : gfc_init_block (&cond_block);
3548 : 1353 : zero = build_int_cst (gfc_array_index_type, 0);
3549 : 1353 : gfc_add_modify (&cond_block, size, zero);
3550 : 1353 : else_b = gfc_finish_block (&cond_block);
3551 : 1353 : tem = gfc_conv_descriptor_data_get (decl);
3552 : 1353 : tem = fold_convert (pvoid_type_node, tem);
3553 : 1353 : cond = fold_build2_loc (input_location, NE_EXPR,
3554 : : boolean_type_node,
3555 : : tem, null_pointer_node);
3556 : 1353 : if (present)
3557 : 308 : cond = fold_build2_loc (input_location,
3558 : : TRUTH_ANDIF_EXPR,
3559 : : boolean_type_node,
3560 : : present, cond);
3561 : 1353 : gfc_add_expr_to_block (block,
3562 : : build3_loc (input_location,
3563 : : COND_EXPR,
3564 : : void_type_node,
3565 : : cond, then_b,
3566 : : else_b));
3567 : 1353 : OMP_CLAUSE_SIZE (node) = size;
3568 : 1353 : }
3569 : 0 : else if (n->sym->attr.dimension)
3570 : : {
3571 : 0 : stmtblock_t cond_block;
3572 : 0 : gfc_init_block (&cond_block);
3573 : 0 : tree size = gfc_full_array_size (&cond_block, decl,
3574 : 0 : GFC_TYPE_ARRAY_RANK (type));
3575 : 0 : tree elemsz
3576 : 0 : = TYPE_SIZE_UNIT (gfc_get_element_type (type));
3577 : 0 : elemsz = fold_convert (gfc_array_index_type, elemsz);
3578 : 0 : size = fold_build2 (MULT_EXPR, gfc_array_index_type,
3579 : : size, elemsz);
3580 : 0 : size = gfc_evaluate_now (size, &cond_block);
3581 : 0 : if (present)
3582 : : {
3583 : 0 : tree var = gfc_create_var (gfc_array_index_type,
3584 : : NULL);
3585 : 0 : gfc_add_modify (&cond_block, var, size);
3586 : 0 : tree cond_body = gfc_finish_block (&cond_block);
3587 : 0 : tree cond = build3_loc (input_location, COND_EXPR,
3588 : : void_type_node, present,
3589 : : cond_body, NULL_TREE);
3590 : 0 : gfc_add_expr_to_block (block, cond);
3591 : 0 : OMP_CLAUSE_SIZE (node) = var;
3592 : : }
3593 : : else
3594 : : {
3595 : 0 : gfc_add_block_to_block (block, &cond_block);
3596 : 0 : OMP_CLAUSE_SIZE (node) = size;
3597 : : }
3598 : : }
3599 : : }
3600 : 7783 : else if (present
3601 : 842 : && INDIRECT_REF_P (decl)
3602 : 8523 : && INDIRECT_REF_P (TREE_OPERAND (decl, 0)))
3603 : : {
3604 : : /* A single indirectref is handled by the middle end. */
3605 : 227 : gcc_assert (!POINTER_TYPE_P (TREE_TYPE (decl)));
3606 : 227 : decl = TREE_OPERAND (decl, 0);
3607 : 227 : decl = gfc_build_cond_assign_expr (block, present, decl,
3608 : : null_pointer_node);
3609 : 227 : OMP_CLAUSE_DECL (node) = build_fold_indirect_ref (decl);
3610 : : }
3611 : : else
3612 : 7556 : OMP_CLAUSE_DECL (node) = decl;
3613 : :
3614 : 9136 : if (!n->sym->attr.dimension
3615 : 5764 : && n->sym->ts.type == BT_CHARACTER
3616 : 126 : && n->sym->ts.deferred)
3617 : : {
3618 : 36 : if (!DECL_P (decl))
3619 : : {
3620 : 34 : gcc_assert (TREE_CODE (decl) == INDIRECT_REF);
3621 : 34 : decl = TREE_OPERAND (decl, 0);
3622 : : }
3623 : 36 : tree cond = fold_build2_loc (input_location, NE_EXPR,
3624 : : boolean_type_node,
3625 : : decl, null_pointer_node);
3626 : 36 : if (present)
3627 : 2 : cond = fold_build2_loc (input_location,
3628 : : TRUTH_ANDIF_EXPR,
3629 : : boolean_type_node,
3630 : : present, cond);
3631 : 36 : tree len = n->sym->ts.u.cl->backend_decl;
3632 : 36 : len = fold_convert (size_type_node, len);
3633 : 36 : tree size = gfc_get_char_type (n->sym->ts.kind);
3634 : 36 : size = TYPE_SIZE_UNIT (size);
3635 : 36 : size = fold_build2 (MULT_EXPR, size_type_node, len, size);
3636 : 36 : size = build3_loc (input_location,
3637 : : COND_EXPR,
3638 : : size_type_node,
3639 : : cond, size,
3640 : : size_zero_node);
3641 : 36 : size = gfc_evaluate_now (size, block);
3642 : 36 : OMP_CLAUSE_SIZE (node) = size;
3643 : : }
3644 : : }
3645 : 5204 : else if (n->expr
3646 : 5204 : && n->expr->expr_type == EXPR_VARIABLE
3647 : 5204 : && n->expr->ref->type == REF_ARRAY
3648 : 3528 : && !n->expr->ref->next)
3649 : : {
3650 : : /* An array element or array section which is not part of a
3651 : : derived type, etc. */
3652 : 3273 : bool element = n->expr->ref->u.ar.type == AR_ELEMENT;
3653 : 3273 : tree type = TREE_TYPE (decl);
3654 : 3273 : gomp_map_kind k = GOMP_MAP_POINTER;
3655 : 3273 : if (!openacc
3656 : 426 : && !GFC_DESCRIPTOR_TYPE_P (type)
3657 : 3646 : && !(POINTER_TYPE_P (type)
3658 : 241 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type))))
3659 : : k = GOMP_MAP_FIRSTPRIVATE_POINTER;
3660 : 3273 : gfc_trans_omp_array_section (block, op, n, decl, element,
3661 : 3273 : !openacc, k, node, node2,
3662 : : node3, node4);
3663 : 3273 : }
3664 : 1931 : else if (n->expr
3665 : 1931 : && n->expr->expr_type == EXPR_VARIABLE
3666 : 1931 : && (n->expr->ref->type == REF_COMPONENT
3667 : : || n->expr->ref->type == REF_ARRAY)
3668 : 1931 : && lastref
3669 : 1931 : && lastref->type == REF_COMPONENT
3670 : 413 : && lastref->u.c.component->ts.type != BT_CLASS
3671 : 389 : && lastref->u.c.component->ts.type != BT_DERIVED
3672 : 311 : && !lastref->u.c.component->attr.dimension)
3673 : : {
3674 : : /* Derived type access with last component being a scalar. */
3675 : 311 : gfc_init_se (&se, NULL);
3676 : :
3677 : 311 : gfc_conv_expr (&se, n->expr);
3678 : 311 : gfc_add_block_to_block (block, &se.pre);
3679 : : /* For BT_CHARACTER a pointer is returned. */
3680 : 311 : OMP_CLAUSE_DECL (node)
3681 : 534 : = POINTER_TYPE_P (TREE_TYPE (se.expr))
3682 : 311 : ? build_fold_indirect_ref (se.expr) : se.expr;
3683 : 311 : gfc_add_block_to_block (block, &se.post);
3684 : 311 : if (pointer || allocatable)
3685 : : {
3686 : : /* If it's a bare attach/detach clause, we just want
3687 : : to perform a single attach/detach operation, of the
3688 : : pointer itself, not of the pointed-to object. */
3689 : 140 : if (openacc
3690 : 68 : && (n->u.map.op == OMP_MAP_ATTACH
3691 : 50 : || n->u.map.op == OMP_MAP_DETACH))
3692 : : {
3693 : 36 : OMP_CLAUSE_DECL (node)
3694 : 36 : = build_fold_addr_expr (OMP_CLAUSE_DECL (node));
3695 : 36 : OMP_CLAUSE_SIZE (node) = size_zero_node;
3696 : 36 : goto finalize_map_clause;
3697 : : }
3698 : :
3699 : 104 : node2 = build_omp_clause (input_location,
3700 : : OMP_CLAUSE_MAP);
3701 : 104 : OMP_CLAUSE_SET_MAP_KIND (node2, GOMP_MAP_ATTACH_DETACH);
3702 : 104 : OMP_CLAUSE_DECL (node2)
3703 : 144 : = POINTER_TYPE_P (TREE_TYPE (se.expr))
3704 : 104 : ? se.expr
3705 : 40 : : gfc_build_addr_expr (NULL, se.expr);
3706 : 104 : OMP_CLAUSE_SIZE (node2) = size_int (0);
3707 : 104 : if (!openacc
3708 : 72 : && n->expr->ts.type == BT_CHARACTER
3709 : 48 : && n->expr->ts.deferred)
3710 : : {
3711 : 48 : gcc_assert (se.string_length);
3712 : 48 : tree tmp
3713 : 48 : = gfc_get_char_type (n->expr->ts.kind);
3714 : 48 : OMP_CLAUSE_SIZE (node)
3715 : 48 : = fold_build2 (MULT_EXPR, size_type_node,
3716 : : fold_convert (size_type_node,
3717 : : se.string_length),
3718 : : TYPE_SIZE_UNIT (tmp));
3719 : 48 : gomp_map_kind kind;
3720 : 48 : if (n->u.map.op == OMP_MAP_DELETE)
3721 : : kind = GOMP_MAP_DELETE;
3722 : 48 : else if (op == EXEC_OMP_TARGET_EXIT_DATA)
3723 : : kind = GOMP_MAP_RELEASE;
3724 : : else
3725 : 44 : kind = GOMP_MAP_TO;
3726 : 48 : node3 = build_omp_clause (input_location,
3727 : : OMP_CLAUSE_MAP);
3728 : 48 : OMP_CLAUSE_SET_MAP_KIND (node3, kind);
3729 : 48 : OMP_CLAUSE_DECL (node3) = se.string_length;
3730 : 48 : OMP_CLAUSE_SIZE (node3)
3731 : 96 : = TYPE_SIZE_UNIT (gfc_charlen_type_node);
3732 : : }
3733 : : }
3734 : : }
3735 : 1620 : else if (n->expr
3736 : 1620 : && n->expr->expr_type == EXPR_VARIABLE
3737 : 1620 : && (n->expr->ref->type == REF_COMPONENT
3738 : : || n->expr->ref->type == REF_ARRAY))
3739 : : {
3740 : 1620 : gfc_init_se (&se, NULL);
3741 : 1620 : se.expr = gfc_maybe_dereference_var (n->sym, decl);
3742 : :
3743 : 5354 : for (gfc_ref *ref = n->expr->ref; ref; ref = ref->next)
3744 : : {
3745 : 3734 : if (ref->type == REF_COMPONENT)
3746 : : {
3747 : 1853 : if (ref->u.c.sym->attr.extension)
3748 : 91 : conv_parent_component_references (&se, ref);
3749 : :
3750 : 1853 : gfc_conv_component_ref (&se, ref);
3751 : : }
3752 : 1881 : else if (ref->type == REF_ARRAY)
3753 : : {
3754 : 1881 : if (ref->u.ar.type == AR_ELEMENT && ref->next)
3755 : 363 : gfc_conv_array_ref (&se, &ref->u.ar, n->expr,
3756 : 363 : &n->expr->where);
3757 : : else
3758 : 1518 : gcc_assert (!ref->next);
3759 : : }
3760 : : else
3761 : 0 : sorry ("unhandled expression type");
3762 : : }
3763 : :
3764 : 1620 : tree inner = se.expr;
3765 : :
3766 : : /* Last component is a derived type or class pointer. */
3767 : 1620 : if (lastref->type == REF_COMPONENT
3768 : 102 : && (lastref->u.c.component->ts.type == BT_DERIVED
3769 : 24 : || lastref->u.c.component->ts.type == BT_CLASS))
3770 : : {
3771 : 102 : if (pointer || (openacc && allocatable))
3772 : : {
3773 : : /* If it's a bare attach/detach clause, we just want
3774 : : to perform a single attach/detach operation, of the
3775 : : pointer itself, not of the pointed-to object. */
3776 : 55 : if (openacc
3777 : 49 : && (n->u.map.op == OMP_MAP_ATTACH
3778 : 43 : || n->u.map.op == OMP_MAP_DETACH))
3779 : : {
3780 : 12 : OMP_CLAUSE_DECL (node)
3781 : 12 : = build_fold_addr_expr (inner);
3782 : 12 : OMP_CLAUSE_SIZE (node) = size_zero_node;
3783 : 18 : goto finalize_map_clause;
3784 : : }
3785 : :
3786 : 43 : gfc_omp_namelist *n2
3787 : 6 : = openacc ? NULL : clauses->lists[OMP_LIST_MAP];
3788 : :
3789 : 43 : bool sym_based;
3790 : 43 : n2 = get_symbol_rooted_namelist (sym_rooted_nl, n,
3791 : : n2, &sym_based);
3792 : :
3793 : : /* If the last reference is a pointer to a derived
3794 : : type ("foo%dt_ptr"), check if any subcomponents
3795 : : of the same derived type member are being mapped
3796 : : elsewhere in the clause list ("foo%dt_ptr%x",
3797 : : etc.). If we have such subcomponent mappings,
3798 : : we only create an ALLOC node for the pointer
3799 : : itself, and inhibit mapping the whole derived
3800 : : type. */
3801 : :
3802 : 43 : for (; n2 != NULL; n2 = n2->next)
3803 : : {
3804 : 6 : if ((!sym_based && n == n2)
3805 : 6 : || (sym_based && n == n2->u2.duplicate_of)
3806 : 6 : || !n2->expr)
3807 : 0 : continue;
3808 : :
3809 : 6 : if (!gfc_omp_expr_prefix_same (n->expr,
3810 : : n2->expr))
3811 : 0 : continue;
3812 : :
3813 : 6 : gfc_ref *ref1 = n->expr->ref;
3814 : 6 : gfc_ref *ref2 = n2->expr->ref;
3815 : :
3816 : 6 : while (ref1->next && ref2->next)
3817 : : {
3818 : : ref1 = ref1->next;
3819 : : ref2 = ref2->next;
3820 : : }
3821 : :
3822 : 6 : if (ref2->next)
3823 : : {
3824 : 6 : inner = build_fold_addr_expr (inner);
3825 : 6 : OMP_CLAUSE_SET_MAP_KIND (node,
3826 : : GOMP_MAP_ALLOC);
3827 : 6 : OMP_CLAUSE_DECL (node) = inner;
3828 : 6 : OMP_CLAUSE_SIZE (node)
3829 : 6 : = TYPE_SIZE_UNIT (TREE_TYPE (inner));
3830 : 6 : goto finalize_map_clause;
3831 : : }
3832 : : }
3833 : :
3834 : 37 : tree data, size;
3835 : :
3836 : 37 : if (lastref->u.c.component->ts.type == BT_CLASS)
3837 : : {
3838 : 24 : data = gfc_class_data_get (inner);
3839 : 24 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (data)));
3840 : 24 : data = build_fold_indirect_ref (data);
3841 : 24 : size = gfc_class_vtab_size_get (inner);
3842 : : }
3843 : : else /* BT_DERIVED. */
3844 : : {
3845 : 13 : data = inner;
3846 : 13 : size = TYPE_SIZE_UNIT (TREE_TYPE (inner));
3847 : : }
3848 : :
3849 : 37 : OMP_CLAUSE_DECL (node) = data;
3850 : 37 : OMP_CLAUSE_SIZE (node) = size;
3851 : 37 : node2 = build_omp_clause (input_location,
3852 : : OMP_CLAUSE_MAP);
3853 : 37 : OMP_CLAUSE_SET_MAP_KIND (node2,
3854 : : GOMP_MAP_ATTACH_DETACH);
3855 : 37 : OMP_CLAUSE_DECL (node2) = build_fold_addr_expr (data);
3856 : 37 : OMP_CLAUSE_SIZE (node2) = size_int (0);
3857 : 37 : }
3858 : : else
3859 : : {
3860 : 47 : OMP_CLAUSE_DECL (node) = inner;
3861 : 47 : OMP_CLAUSE_SIZE (node)
3862 : 94 : = TYPE_SIZE_UNIT (TREE_TYPE (inner));
3863 : : }
3864 : : }
3865 : 1518 : else if (lastref->type == REF_ARRAY
3866 : 1518 : && lastref->u.ar.type == AR_FULL)
3867 : : {
3868 : : /* Bare attach and detach clauses don't want any
3869 : : additional nodes. */
3870 : 834 : if ((n->u.map.op == OMP_MAP_ATTACH
3871 : 803 : || n->u.map.op == OMP_MAP_DETACH)
3872 : 848 : && (POINTER_TYPE_P (TREE_TYPE (inner))
3873 : 45 : || GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (inner))))
3874 : : {
3875 : 45 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (inner)))
3876 : : {
3877 : 45 : tree ptr = gfc_conv_descriptor_data_get (inner);
3878 : 45 : OMP_CLAUSE_DECL (node) = ptr;
3879 : : }
3880 : : else
3881 : 0 : OMP_CLAUSE_DECL (node) = inner;
3882 : 45 : OMP_CLAUSE_SIZE (node) = size_zero_node;
3883 : 45 : goto finalize_map_clause;
3884 : : }
3885 : :
3886 : 789 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (inner)))
3887 : : {
3888 : 625 : gomp_map_kind map_kind;
3889 : 625 : tree type = TREE_TYPE (inner);
3890 : 625 : tree ptr = gfc_conv_descriptor_data_get (inner);
3891 : 625 : ptr = build_fold_indirect_ref (ptr);
3892 : 625 : OMP_CLAUSE_DECL (node) = ptr;
3893 : 625 : int rank = GFC_TYPE_ARRAY_RANK (type);
3894 : 625 : OMP_CLAUSE_SIZE (node)
3895 : 625 : = gfc_full_array_size (block, inner, rank);
3896 : 625 : tree elemsz
3897 : 625 : = TYPE_SIZE_UNIT (gfc_get_element_type (type));
3898 : 625 : map_kind = OMP_CLAUSE_MAP_KIND (node);
3899 : 625 : if (GOMP_MAP_COPY_TO_P (map_kind)
3900 : 107 : || map_kind == GOMP_MAP_ALLOC)
3901 : 539 : map_kind = ((GOMP_MAP_ALWAYS_P (map_kind)
3902 : 1018 : || gfc_expr_attr (n->expr).pointer)
3903 : 539 : ? GOMP_MAP_ALWAYS_TO : GOMP_MAP_TO);
3904 : 86 : else if (n->u.map.op == OMP_MAP_RELEASE
3905 : 82 : || n->u.map.op == OMP_MAP_DELETE)
3906 : : ;
3907 : 81 : else if (op == EXEC_OMP_TARGET_EXIT_DATA
3908 : 81 : || op == EXEC_OACC_EXIT_DATA)
3909 : : map_kind = GOMP_MAP_RELEASE;
3910 : : else
3911 : 29 : map_kind = GOMP_MAP_ALLOC;
3912 : 625 : if (!openacc
3913 : 485 : && n->expr->ts.type == BT_CHARACTER
3914 : 36 : && n->expr->ts.deferred)
3915 : : {
3916 : 36 : gcc_assert (se.string_length);
3917 : 36 : tree len = fold_convert (size_type_node,
3918 : : se.string_length);
3919 : 36 : elemsz = gfc_get_char_type (n->expr->ts.kind);
3920 : 36 : elemsz = TYPE_SIZE_UNIT (elemsz);
3921 : 36 : elemsz = fold_build2 (MULT_EXPR, size_type_node,
3922 : : len, elemsz);
3923 : 36 : node4 = build_omp_clause (input_location,
3924 : : OMP_CLAUSE_MAP);
3925 : 36 : OMP_CLAUSE_SET_MAP_KIND (node4, map_kind);
3926 : 36 : OMP_CLAUSE_DECL (node4) = se.string_length;
3927 : 36 : OMP_CLAUSE_SIZE (node4)
3928 : 72 : = TYPE_SIZE_UNIT (gfc_charlen_type_node);
3929 : : }
3930 : 625 : elemsz = fold_convert (gfc_array_index_type, elemsz);
3931 : 625 : OMP_CLAUSE_SIZE (node)
3932 : 625 : = fold_build2 (MULT_EXPR, gfc_array_index_type,
3933 : : OMP_CLAUSE_SIZE (node), elemsz);
3934 : 625 : node2 = build_omp_clause (input_location,
3935 : : OMP_CLAUSE_MAP);
3936 : 625 : if (map_kind == GOMP_MAP_RELEASE
3937 : 625 : || map_kind == GOMP_MAP_DELETE)
3938 : : {
3939 : 57 : OMP_CLAUSE_SET_MAP_KIND (node2, map_kind);
3940 : 57 : OMP_CLAUSE_RELEASE_DESCRIPTOR (node2) = 1;
3941 : : }
3942 : : else
3943 : 568 : OMP_CLAUSE_SET_MAP_KIND (node2,
3944 : : GOMP_MAP_TO_PSET);
3945 : 625 : OMP_CLAUSE_DECL (node2) = inner;
3946 : 625 : OMP_CLAUSE_SIZE (node2) = TYPE_SIZE_UNIT (type);
3947 : 625 : if (!openacc)
3948 : : {
3949 : 485 : gfc_omp_namelist *n2
3950 : : = clauses->lists[OMP_LIST_MAP];
3951 : :
3952 : : /* If we don't have a mapping of a smaller part
3953 : : of the array -- or we can't prove that we do
3954 : : statically -- set this flag. If there is a
3955 : : mapping of a smaller part of the array after
3956 : : all, this will turn into a no-op at
3957 : : runtime. */
3958 : 485 : OMP_CLAUSE_MAP_RUNTIME_IMPLICIT_P (node) = 1;
3959 : :
3960 : 485 : bool sym_based;
3961 : 485 : n2 = get_symbol_rooted_namelist (sym_rooted_nl,
3962 : : n, n2,
3963 : : &sym_based);
3964 : :
3965 : 485 : bool drop_mapping = false;
3966 : :
3967 : 1523 : for (; n2 != NULL; n2 = n2->next)
3968 : : {
3969 : 1318 : if ((!sym_based && n == n2)
3970 : 1318 : || (sym_based && n == n2->u2.duplicate_of)
3971 : 1095 : || !n2->expr)
3972 : 223 : continue;
3973 : :
3974 : 1095 : if (!gfc_omp_expr_prefix_same (n->expr,
3975 : : n2->expr))
3976 : 815 : continue;
3977 : :
3978 : 280 : gfc_ref *ref1 = n->expr->ref;
3979 : 280 : gfc_ref *ref2 = n2->expr->ref;
3980 : :
3981 : : /* We know ref1 and ref2 overlap. We're
3982 : : interested in whether ref2 describes a
3983 : : smaller part of the array than ref1, which
3984 : : we already know refers to the full
3985 : : array. */
3986 : :
3987 : 620 : while (ref1->next && ref2->next)
3988 : : {
3989 : : ref1 = ref1->next;
3990 : : ref2 = ref2->next;
3991 : : }
3992 : :
3993 : 280 : if (ref2->next
3994 : 280 : || (ref2->type == REF_ARRAY
3995 : 280 : && (ref2->u.ar.type == AR_ELEMENT
3996 : 280 : || (ref2->u.ar.type
3997 : : == AR_SECTION))))
3998 : : {
3999 : : drop_mapping = true;
4000 : : break;
4001 : : }
4002 : : }
4003 : 485 : if (drop_mapping)
4004 : 280 : continue;
4005 : : }
4006 : 345 : node3 = build_omp_clause (input_location,
4007 : : OMP_CLAUSE_MAP);
4008 : 345 : OMP_CLAUSE_SET_MAP_KIND (node3,
4009 : : GOMP_MAP_ATTACH_DETACH);
4010 : 345 : OMP_CLAUSE_DECL (node3)
4011 : 345 : = gfc_conv_descriptor_data_get (inner);
4012 : : /* Similar to gfc_trans_omp_array_section (details
4013 : : there), we add/keep the cast for OpenMP to prevent
4014 : : that an 'alloc:' gets added for node3 ('desc.data')
4015 : : as that is part of the whole descriptor (node3).
4016 : : TODO: Remove once the ME handles this properly. */
4017 : 345 : if (!openacc)
4018 : 205 : OMP_CLAUSE_DECL (node3)
4019 : 410 : = fold_convert (TREE_TYPE (TREE_OPERAND(ptr, 0)),
4020 : : OMP_CLAUSE_DECL (node3));
4021 : : else
4022 : 140 : STRIP_NOPS (OMP_CLAUSE_DECL (node3));
4023 : 345 : OMP_CLAUSE_SIZE (node3) = size_int (0);
4024 : : }
4025 : : else
4026 : 164 : OMP_CLAUSE_DECL (node) = inner;
4027 : : }
4028 : 684 : else if (lastref->type == REF_ARRAY)
4029 : : {
4030 : : /* An array element or section. */
4031 : 684 : bool element = lastref->u.ar.type == AR_ELEMENT;
4032 : 684 : gomp_map_kind kind = GOMP_MAP_ATTACH_DETACH;
4033 : 684 : gfc_trans_omp_array_section (block, op, n, inner, element,
4034 : 684 : !openacc, kind, node, node2,
4035 : : node3, node4);
4036 : : }
4037 : : else
4038 : 0 : gcc_unreachable ();
4039 : : }
4040 : : else
4041 : 0 : sorry ("unhandled expression");
4042 : :
4043 : 14129 : finalize_map_clause:
4044 : :
4045 : 14129 : omp_clauses = gfc_trans_add_clause (node, omp_clauses);
4046 : 14129 : if (node2)
4047 : 4612 : omp_clauses = gfc_trans_add_clause (node2, omp_clauses);
4048 : 14129 : if (node3)
4049 : 5842 : omp_clauses = gfc_trans_add_clause (node3, omp_clauses);
4050 : 14129 : if (node4)
4051 : 3371 : omp_clauses = gfc_trans_add_clause (node4, omp_clauses);
4052 : 14129 : if (node5)
4053 : 4 : omp_clauses = gfc_trans_add_clause (node5, omp_clauses);
4054 : : }
4055 : : break;
4056 : : case OMP_LIST_TO:
4057 : : case OMP_LIST_FROM:
4058 : : case OMP_LIST_CACHE:
4059 : 3637 : for (; n != NULL; n = n->next)
4060 : : {
4061 : 1861 : if (!n->sym->attr.referenced)
4062 : 0 : continue;
4063 : :
4064 : 1861 : switch (list)
4065 : : {
4066 : : case OMP_LIST_TO:
4067 : : clause_code = OMP_CLAUSE_TO;
4068 : : break;
4069 : 1028 : case OMP_LIST_FROM:
4070 : 1028 : clause_code = OMP_CLAUSE_FROM;
4071 : 1028 : break;
4072 : 82 : case OMP_LIST_CACHE:
4073 : 82 : clause_code = OMP_CLAUSE__CACHE_;
4074 : 82 : break;
4075 : 0 : default:
4076 : 0 : gcc_unreachable ();
4077 : : }
4078 : 1861 : tree node = build_omp_clause (input_location, clause_code);
4079 : 1861 : if (n->expr == NULL
4080 : 128 : || (n->expr->ref->type == REF_ARRAY
4081 : 116 : && n->expr->ref->u.ar.type == AR_FULL
4082 : 0 : && n->expr->ref->next == NULL))
4083 : : {
4084 : 1733 : tree decl = gfc_trans_omp_variable (n->sym, false);
4085 : 1733 : if (gfc_omp_privatize_by_reference (decl))
4086 : : {
4087 : 1047 : if (gfc_omp_is_allocatable_or_ptr (decl))
4088 : 240 : decl = build_fold_indirect_ref (decl);
4089 : 1047 : decl = build_fold_indirect_ref (decl);
4090 : : }
4091 : 686 : else if (DECL_P (decl))
4092 : 686 : TREE_ADDRESSABLE (decl) = 1;
4093 : 1733 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
4094 : : {
4095 : 597 : tree type = TREE_TYPE (decl);
4096 : 597 : tree ptr = gfc_conv_descriptor_data_get (decl);
4097 : 597 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (ptr)));
4098 : 597 : ptr = build_fold_indirect_ref (ptr);
4099 : 597 : OMP_CLAUSE_DECL (node) = ptr;
4100 : 597 : OMP_CLAUSE_SIZE (node)
4101 : 597 : = gfc_full_array_size (block, decl,
4102 : 597 : GFC_TYPE_ARRAY_RANK (type));
4103 : 597 : tree elemsz
4104 : 597 : = TYPE_SIZE_UNIT (gfc_get_element_type (type));
4105 : 597 : elemsz = fold_convert (gfc_array_index_type, elemsz);
4106 : 1194 : OMP_CLAUSE_SIZE (node)
4107 : 1194 : = fold_build2 (MULT_EXPR, gfc_array_index_type,
4108 : : OMP_CLAUSE_SIZE (node), elemsz);
4109 : : }
4110 : : else
4111 : : {
4112 : 1136 : OMP_CLAUSE_DECL (node) = decl;
4113 : 1136 : if (gfc_omp_is_allocatable_or_ptr (decl))
4114 : 120 : OMP_CLAUSE_SIZE (node)
4115 : 240 : = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (decl)));
4116 : : }
4117 : : }
4118 : : else
4119 : : {
4120 : 128 : tree ptr;
4121 : 128 : gfc_init_se (&se, NULL);
4122 : 128 : if (n->expr->rank == 0)
4123 : : {
4124 : 5 : gfc_conv_expr_reference (&se, n->expr);
4125 : 5 : ptr = se.expr;
4126 : 5 : gfc_add_block_to_block (block, &se.pre);
4127 : 5 : OMP_CLAUSE_SIZE (node)
4128 : 10 : = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (ptr)));
4129 : : }
4130 : : else
4131 : : {
4132 : 123 : gfc_conv_expr_descriptor (&se, n->expr);
4133 : 123 : ptr = gfc_conv_array_data (se.expr);
4134 : 123 : tree type = TREE_TYPE (se.expr);
4135 : 123 : gfc_add_block_to_block (block, &se.pre);
4136 : 123 : OMP_CLAUSE_SIZE (node)
4137 : 123 : = gfc_full_array_size (block, se.expr,
4138 : 123 : GFC_TYPE_ARRAY_RANK (type));
4139 : 123 : tree elemsz
4140 : 123 : = TYPE_SIZE_UNIT (gfc_get_element_type (type));
4141 : 123 : elemsz = fold_convert (gfc_array_index_type, elemsz);
4142 : 246 : OMP_CLAUSE_SIZE (node)
4143 : 246 : = fold_build2 (MULT_EXPR, gfc_array_index_type,
4144 : : OMP_CLAUSE_SIZE (node), elemsz);
4145 : : }
4146 : 128 : gfc_add_block_to_block (block, &se.post);
4147 : 128 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (ptr)));
4148 : 128 : OMP_CLAUSE_DECL (node) = build_fold_indirect_ref (ptr);
4149 : : }
4150 : 1861 : if (n->u.present_modifier)
4151 : 5 : OMP_CLAUSE_MOTION_PRESENT (node) = 1;
4152 : 1861 : if (list == OMP_LIST_CACHE && n->u.map.readonly)
4153 : 16 : OMP_CLAUSE__CACHE__READONLY (node) = 1;
4154 : 1861 : omp_clauses = gfc_trans_add_clause (node, omp_clauses);
4155 : : }
4156 : : break;
4157 : : case OMP_LIST_USES_ALLOCATORS:
4158 : : /* Ignore pre-defined allocators as no special treatment is needed. */
4159 : 30 : for (; n != NULL; n = n->next)
4160 : 28 : if (n->sym->attr.flavor == FL_VARIABLE)
4161 : : break;
4162 : 12 : if (n != NULL)
4163 : 10 : sorry_at (input_location, "%<uses_allocators%> clause with traits "
4164 : : "and memory spaces");
4165 : : break;
4166 : : default:
4167 : : break;
4168 : : }
4169 : : }
4170 : :
4171 : : /* Free hashmap if we built it. */
4172 : 30020 : if (sym_rooted_nl)
4173 : : {
4174 : 237 : typedef hash_map<gfc_symbol *, gfc_omp_namelist *>::iterator hti;
4175 : 813 : for (hti it = sym_rooted_nl->begin (); it != sym_rooted_nl->end (); ++it)
4176 : : {
4177 : 288 : gfc_omp_namelist *&nl = (*it).second;
4178 : 1190 : while (nl)
4179 : : {
4180 : 902 : gfc_omp_namelist *next = nl->next;
4181 : 902 : free (nl);
4182 : 902 : nl = next;
4183 : : }
4184 : : }
4185 : 237 : delete sym_rooted_nl;
4186 : : }
4187 : :
4188 : 30020 : if (clauses->if_expr)
4189 : : {
4190 : 1105 : tree if_var;
4191 : :
4192 : 1105 : gfc_init_se (&se, NULL);
4193 : 1105 : gfc_conv_expr (&se, clauses->if_expr);
4194 : 1105 : gfc_add_block_to_block (block, &se.pre);
4195 : 1105 : if_var = gfc_evaluate_now (se.expr, block);
4196 : 1105 : gfc_add_block_to_block (block, &se.post);
4197 : :
4198 : 1105 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_IF);
4199 : 1105 : OMP_CLAUSE_IF_MODIFIER (c) = ERROR_MARK;
4200 : 1105 : OMP_CLAUSE_IF_EXPR (c) = if_var;
4201 : 1105 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
4202 : : }
4203 : :
4204 : 330220 : for (ifc = 0; ifc < OMP_IF_LAST; ifc++)
4205 : 300200 : if (clauses->if_exprs[ifc])
4206 : : {
4207 : 123 : tree if_var;
4208 : :
4209 : 123 : gfc_init_se (&se, NULL);
4210 : 123 : gfc_conv_expr (&se, clauses->if_exprs[ifc]);
4211 : 123 : gfc_add_block_to_block (block, &se.pre);
4212 : 123 : if_var = gfc_evaluate_now (se.expr, block);
4213 : 123 : gfc_add_block_to_block (block, &se.post);
4214 : :
4215 : 123 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_IF);
4216 : 123 : switch (ifc)
4217 : : {
4218 : 0 : case OMP_IF_CANCEL:
4219 : 0 : OMP_CLAUSE_IF_MODIFIER (c) = VOID_CST;
4220 : 0 : break;
4221 : 40 : case OMP_IF_PARALLEL:
4222 : 40 : OMP_CLAUSE_IF_MODIFIER (c) = OMP_PARALLEL;
4223 : 40 : break;
4224 : 39 : case OMP_IF_SIMD:
4225 : 39 : OMP_CLAUSE_IF_MODIFIER (c) = OMP_SIMD;
4226 : 39 : break;
4227 : 1 : case OMP_IF_TASK:
4228 : 1 : OMP_CLAUSE_IF_MODIFIER (c) = OMP_TASK;
4229 : 1 : break;
4230 : 23 : case OMP_IF_TASKLOOP:
4231 : 23 : OMP_CLAUSE_IF_MODIFIER (c) = OMP_TASKLOOP;
4232 : 23 : break;
4233 : 16 : case OMP_IF_TARGET:
4234 : 16 : OMP_CLAUSE_IF_MODIFIER (c) = OMP_TARGET;
4235 : 16 : break;
4236 : 1 : case OMP_IF_TARGET_DATA:
4237 : 1 : OMP_CLAUSE_IF_MODIFIER (c) = OMP_TARGET_DATA;
4238 : 1 : break;
4239 : 1 : case OMP_IF_TARGET_UPDATE:
4240 : 1 : OMP_CLAUSE_IF_MODIFIER (c) = OMP_TARGET_UPDATE;
4241 : 1 : break;
4242 : 1 : case OMP_IF_TARGET_ENTER_DATA:
4243 : 1 : OMP_CLAUSE_IF_MODIFIER (c) = OMP_TARGET_ENTER_DATA;
4244 : 1 : break;
4245 : 1 : case OMP_IF_TARGET_EXIT_DATA:
4246 : 1 : OMP_CLAUSE_IF_MODIFIER (c) = OMP_TARGET_EXIT_DATA;
4247 : 1 : break;
4248 : : default:
4249 : : gcc_unreachable ();
4250 : : }
4251 : 123 : OMP_CLAUSE_IF_EXPR (c) = if_var;
4252 : 123 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
4253 : : }
4254 : :
4255 : 30020 : if (clauses->self_expr)
4256 : : {
4257 : 158 : tree self_var;
4258 : :
4259 : 158 : gfc_init_se (&se, NULL);
4260 : 158 : gfc_conv_expr (&se, clauses->self_expr);
4261 : 158 : gfc_add_block_to_block (block, &se.pre);
4262 : 158 : self_var = gfc_evaluate_now (se.expr, block);
4263 : 158 : gfc_add_block_to_block (block, &se.post);
4264 : :
4265 : 158 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_SELF);
4266 : 158 : OMP_CLAUSE_SELF_EXPR (c) = self_var;
4267 : 158 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
4268 : : }
4269 : :
4270 : 30020 : if (clauses->final_expr)
4271 : : {
4272 : 64 : tree final_var;
4273 : :
4274 : 64 : gfc_init_se (&se, NULL);
4275 : 64 : gfc_conv_expr (&se, clauses->final_expr);
4276 : 64 : gfc_add_block_to_block (block, &se.pre);
4277 : 64 : final_var = gfc_evaluate_now (se.expr, block);
4278 : 64 : gfc_add_block_to_block (block, &se.post);
4279 : :
4280 : 64 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_FINAL);
4281 : 64 : OMP_CLAUSE_FINAL_EXPR (c) = final_var;
4282 : 64 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
4283 : : }
4284 : :
4285 : 30020 : if (clauses->num_threads)
4286 : : {
4287 : 942 : tree num_threads;
4288 : :
4289 : 942 : gfc_init_se (&se, NULL);
4290 : 942 : gfc_conv_expr (&se, clauses->num_threads);
4291 : 942 : gfc_add_block_to_block (block, &se.pre);
4292 : 942 : num_threads = gfc_evaluate_now (se.expr, block);
4293 : 942 : gfc_add_block_to_block (block, &se.post);
4294 : :
4295 : 942 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NUM_THREADS);
4296 : 942 : OMP_CLAUSE_NUM_THREADS_EXPR (c) = num_threads;
4297 : 942 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
4298 : : }
4299 : :
4300 : 30020 : chunk_size = NULL_TREE;
4301 : 30020 : if (clauses->chunk_size)
4302 : : {
4303 : 493 : gfc_init_se (&se, NULL);
4304 : 493 : gfc_conv_expr (&se, clauses->chunk_size);
4305 : 493 : gfc_add_block_to_block (block, &se.pre);
4306 : 493 : chunk_size = gfc_evaluate_now (se.expr, block);
4307 : 493 : gfc_add_block_to_block (block, &se.post);
4308 : : }
4309 : :
4310 : 30020 : if (clauses->sched_kind != OMP_SCHED_NONE)
4311 : : {
4312 : 754 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_SCHEDULE);
4313 : 754 : OMP_CLAUSE_SCHEDULE_CHUNK_EXPR (c) = chunk_size;
4314 : 754 : switch (clauses->sched_kind)
4315 : : {
4316 : 393 : case OMP_SCHED_STATIC:
4317 : 393 : OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_STATIC;
4318 : 393 : break;
4319 : 159 : case OMP_SCHED_DYNAMIC:
4320 : 159 : OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_DYNAMIC;
4321 : 159 : break;
4322 : 111 : case OMP_SCHED_GUIDED:
4323 : 111 : OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_GUIDED;
4324 : 111 : break;
4325 : 84 : case OMP_SCHED_RUNTIME:
4326 : 84 : OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_RUNTIME;
4327 : 84 : break;
4328 : 7 : case OMP_SCHED_AUTO:
4329 : 7 : OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_AUTO;
4330 : 7 : break;
4331 : 0 : default:
4332 : 0 : gcc_unreachable ();
4333 : : }
4334 : 754 : if (clauses->sched_monotonic)
4335 : 54 : OMP_CLAUSE_SCHEDULE_KIND (c)
4336 : 27 : = (omp_clause_schedule_kind) (OMP_CLAUSE_SCHEDULE_KIND (c)
4337 : : | OMP_CLAUSE_SCHEDULE_MONOTONIC);
4338 : 727 : else if (clauses->sched_nonmonotonic)
4339 : 46 : OMP_CLAUSE_SCHEDULE_KIND (c)
4340 : 23 : = (omp_clause_schedule_kind) (OMP_CLAUSE_SCHEDULE_KIND (c)
4341 : : | OMP_CLAUSE_SCHEDULE_NONMONOTONIC);
4342 : 754 : if (clauses->sched_simd)
4343 : 17 : OMP_CLAUSE_SCHEDULE_SIMD (c) = 1;
4344 : 754 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
4345 : : }
4346 : :
4347 : 30020 : if (clauses->default_sharing != OMP_DEFAULT_UNKNOWN)
4348 : : {
4349 : 1046 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_DEFAULT);
4350 : 1046 : switch (clauses->default_sharing)
4351 : : {
4352 : 641 : case OMP_DEFAULT_NONE:
4353 : 641 : OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_NONE;
4354 : 641 : break;
4355 : 183 : case OMP_DEFAULT_SHARED:
4356 : 183 : OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_SHARED;
4357 : 183 : break;
4358 : 24 : case OMP_DEFAULT_PRIVATE:
4359 : 24 : OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_PRIVATE;
4360 : 24 : break;
4361 : 8 : case OMP_DEFAULT_FIRSTPRIVATE:
4362 : 8 : OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_FIRSTPRIVATE;
4363 : 8 : break;
4364 : 190 : case OMP_DEFAULT_PRESENT:
4365 : 190 : OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_PRESENT;
4366 : 190 : break;
4367 : 0 : default:
4368 : 0 : gcc_unreachable ();
4369 : : }
4370 : 1046 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
4371 : : }
4372 : :
4373 : 30020 : if (clauses->nowait)
4374 : : {
4375 : 2009 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NOWAIT);
4376 : 2009 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
4377 : : }
4378 : :
4379 : 30020 : if (clauses->full)
4380 : : {
4381 : 52 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_FULL);
4382 : 52 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
4383 : : }
4384 : :
4385 : 30020 : if (clauses->partial)
4386 : : {
4387 : 264 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_PARTIAL);
4388 : 264 : OMP_CLAUSE_PARTIAL_EXPR (c)
4389 : 528 : = (clauses->partial > 0
4390 : 264 : ? build_int_cst (integer_type_node, clauses->partial)
4391 : : : NULL_TREE);
4392 : 264 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
4393 : : }
4394 : :
4395 : 30020 : if (clauses->sizes_list)
4396 : : {
4397 : : tree list = NULL_TREE;
4398 : 344 : for (gfc_expr_list *el = clauses->sizes_list; el; el = el->next)
4399 : 224 : list = tree_cons (NULL_TREE, gfc_convert_expr_to_tree (block, el->expr),
4400 : : list);
4401 : :
4402 : 120 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_SIZES);
4403 : 120 : OMP_CLAUSE_SIZES_LIST (c) = nreverse (list);
4404 : 120 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
4405 : : }
4406 : :
4407 : 30020 : if (clauses->ordered)
4408 : : {
4409 : 313 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_ORDERED);
4410 : 313 : OMP_CLAUSE_ORDERED_EXPR (c)
4411 : 313 : = clauses->orderedc ? build_int_cst (integer_type_node,
4412 : 132 : clauses->orderedc) : NULL_TREE;
4413 : 313 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
4414 : : }
4415 : :
4416 : 30020 : if (clauses->order_concurrent)
4417 : : {
4418 : 303 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_ORDER);
4419 : 303 : OMP_CLAUSE_ORDER_UNCONSTRAINED (c) = clauses->order_unconstrained;
4420 : 303 : OMP_CLAUSE_ORDER_REPRODUCIBLE (c) = clauses->order_reproducible;
4421 : 303 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
4422 : : }
4423 : :
4424 : 30020 : if (clauses->untied)
4425 : : {
4426 : 141 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_UNTIED);
4427 : 141 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
4428 : : }
4429 : :
4430 : 30020 : if (clauses->mergeable)
4431 : : {
4432 : 32 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_MERGEABLE);
4433 : 32 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
4434 : : }
4435 : :
4436 : 30020 : if (clauses->collapse)
4437 : : {
4438 : 1630 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_COLLAPSE);
4439 : 1630 : OMP_CLAUSE_COLLAPSE_EXPR (c)
4440 : 1630 : = build_int_cst (integer_type_node, clauses->collapse);
4441 : 1630 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
4442 : : }
4443 : :
4444 : 30020 : if (clauses->inbranch)
4445 : : {
4446 : 18 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_INBRANCH);
4447 : 18 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
4448 : : }
4449 : :
4450 : 30020 : if (clauses->notinbranch)
4451 : : {
4452 : 28 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NOTINBRANCH);
4453 : 28 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
4454 : : }
4455 : :
4456 : 30020 : switch (clauses->cancel)
4457 : : {
4458 : : case OMP_CANCEL_UNKNOWN:
4459 : : break;
4460 : 0 : case OMP_CANCEL_PARALLEL:
4461 : 0 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_PARALLEL);
4462 : 0 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
4463 : 0 : break;
4464 : 0 : case OMP_CANCEL_SECTIONS:
4465 : 0 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_SECTIONS);
4466 : 0 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
4467 : 0 : break;
4468 : 0 : case OMP_CANCEL_DO:
4469 : 0 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_FOR);
4470 : 0 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
4471 : 0 : break;
4472 : 0 : case OMP_CANCEL_TASKGROUP:
4473 : 0 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_TASKGROUP);
4474 : 0 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
4475 : 0 : break;
4476 : : }
4477 : :
4478 : 30020 : if (clauses->proc_bind != OMP_PROC_BIND_UNKNOWN)
4479 : : {
4480 : 64 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_PROC_BIND);
4481 : 64 : switch (clauses->proc_bind)
4482 : : {
4483 : 1 : case OMP_PROC_BIND_PRIMARY:
4484 : 1 : OMP_CLAUSE_PROC_BIND_KIND (c) = OMP_CLAUSE_PROC_BIND_PRIMARY;
4485 : 1 : break;
4486 : 9 : case OMP_PROC_BIND_MASTER:
4487 : 9 : OMP_CLAUSE_PROC_BIND_KIND (c) = OMP_CLAUSE_PROC_BIND_MASTER;
4488 : 9 : break;
4489 : 53 : case OMP_PROC_BIND_SPREAD:
4490 : 53 : OMP_CLAUSE_PROC_BIND_KIND (c) = OMP_CLAUSE_PROC_BIND_SPREAD;
4491 : 53 : break;
4492 : 1 : case OMP_PROC_BIND_CLOSE:
4493 : 1 : OMP_CLAUSE_PROC_BIND_KIND (c) = OMP_CLAUSE_PROC_BIND_CLOSE;
4494 : 1 : break;
4495 : 0 : default:
4496 : 0 : gcc_unreachable ();
4497 : : }
4498 : 64 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
4499 : : }
4500 : :
4501 : 30020 : if (clauses->safelen_expr)
4502 : : {
4503 : 89 : tree safelen_var;
4504 : :
4505 : 89 : gfc_init_se (&se, NULL);
4506 : 89 : gfc_conv_expr (&se, clauses->safelen_expr);
4507 : 89 : gfc_add_block_to_block (block, &se.pre);
4508 : 89 : safelen_var = gfc_evaluate_now (se.expr, block);
4509 : 89 : gfc_add_block_to_block (block, &se.post);
4510 : :
4511 : 89 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_SAFELEN);
4512 : 89 : OMP_CLAUSE_SAFELEN_EXPR (c) = safelen_var;
4513 : 89 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
4514 : : }
4515 : :
4516 : 30020 : if (clauses->simdlen_expr)
4517 : : {
4518 : 110 : if (declare_simd)
4519 : : {
4520 : 65 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_SIMDLEN);
4521 : 65 : OMP_CLAUSE_SIMDLEN_EXPR (c)
4522 : 65 : = gfc_conv_constant_to_tree (clauses->simdlen_expr);
4523 : 65 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
4524 : : }
4525 : : else
4526 : : {
4527 : 45 : tree simdlen_var;
4528 : :
4529 : 45 : gfc_init_se (&se, NULL);
4530 : 45 : gfc_conv_expr (&se, clauses->simdlen_expr);
4531 : 45 : gfc_add_block_to_block (block, &se.pre);
4532 : 45 : simdlen_var = gfc_evaluate_now (se.expr, block);
4533 : 45 : gfc_add_block_to_block (block, &se.post);
4534 : :
4535 : 45 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_SIMDLEN);
4536 : 45 : OMP_CLAUSE_SIMDLEN_EXPR (c) = simdlen_var;
4537 : 45 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
4538 : : }
4539 : : }
4540 : :
4541 : 30020 : if (clauses->num_teams_upper)
4542 : : {
4543 : 111 : tree num_teams_lower = NULL_TREE, num_teams_upper;
4544 : :
4545 : 111 : gfc_init_se (&se, NULL);
4546 : 111 : gfc_conv_expr (&se, clauses->num_teams_upper);
4547 : 111 : gfc_add_block_to_block (block, &se.pre);
4548 : 111 : num_teams_upper = gfc_evaluate_now (se.expr, block);
4549 : 111 : gfc_add_block_to_block (block, &se.post);
4550 : :
4551 : 111 : if (clauses->num_teams_lower)
4552 : : {
4553 : 21 : gfc_init_se (&se, NULL);
4554 : 21 : gfc_conv_expr (&se, clauses->num_teams_lower);
4555 : 21 : gfc_add_block_to_block (block, &se.pre);
4556 : 21 : num_teams_lower = gfc_evaluate_now (se.expr, block);
4557 : 21 : gfc_add_block_to_block (block, &se.post);
4558 : : }
4559 : 111 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NUM_TEAMS);
4560 : 111 : OMP_CLAUSE_NUM_TEAMS_LOWER_EXPR (c) = num_teams_lower;
4561 : 111 : OMP_CLAUSE_NUM_TEAMS_UPPER_EXPR (c) = num_teams_upper;
4562 : 111 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
4563 : : }
4564 : :
4565 : 30020 : if (clauses->device)
4566 : : {
4567 : 209 : tree device;
4568 : :
4569 : 209 : gfc_init_se (&se, NULL);
4570 : 209 : gfc_conv_expr (&se, clauses->device);
4571 : 209 : gfc_add_block_to_block (block, &se.pre);
4572 : 209 : device = gfc_evaluate_now (se.expr, block);
4573 : 209 : gfc_add_block_to_block (block, &se.post);
4574 : :
4575 : 209 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_DEVICE);
4576 : 209 : OMP_CLAUSE_DEVICE_ID (c) = device;
4577 : :
4578 : 209 : if (clauses->ancestor)
4579 : 39 : OMP_CLAUSE_DEVICE_ANCESTOR (c) = 1;
4580 : :
4581 : 209 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
4582 : : }
4583 : :
4584 : 30020 : if (clauses->thread_limit)
4585 : : {
4586 : 105 : tree thread_limit;
4587 : :
4588 : 105 : gfc_init_se (&se, NULL);
4589 : 105 : gfc_conv_expr (&se, clauses->thread_limit);
4590 : 105 : gfc_add_block_to_block (block, &se.pre);
4591 : 105 : thread_limit = gfc_evaluate_now (se.expr, block);
4592 : 105 : gfc_add_block_to_block (block, &se.post);
4593 : :
4594 : 105 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_THREAD_LIMIT);
4595 : 105 : OMP_CLAUSE_THREAD_LIMIT_EXPR (c) = thread_limit;
4596 : 105 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
4597 : : }
4598 : :
4599 : 30020 : chunk_size = NULL_TREE;
4600 : 30020 : if (clauses->dist_chunk_size)
4601 : : {
4602 : 81 : gfc_init_se (&se, NULL);
4603 : 81 : gfc_conv_expr (&se, clauses->dist_chunk_size);
4604 : 81 : gfc_add_block_to_block (block, &se.pre);
4605 : 81 : chunk_size = gfc_evaluate_now (se.expr, block);
4606 : 81 : gfc_add_block_to_block (block, &se.post);
4607 : : }
4608 : :
4609 : 30020 : if (clauses->dist_sched_kind != OMP_SCHED_NONE)
4610 : : {
4611 : 94 : c = build_omp_clause (gfc_get_location (&where),
4612 : : OMP_CLAUSE_DIST_SCHEDULE);
4613 : 94 : OMP_CLAUSE_DIST_SCHEDULE_CHUNK_EXPR (c) = chunk_size;
4614 : 94 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
4615 : : }
4616 : :
4617 : 30020 : if (clauses->grainsize)
4618 : : {
4619 : 43 : tree grainsize;
4620 : :
4621 : 43 : gfc_init_se (&se, NULL);
4622 : 43 : gfc_conv_expr (&se, clauses->grainsize);
4623 : 43 : gfc_add_block_to_block (block, &se.pre);
4624 : 43 : grainsize = gfc_evaluate_now (se.expr, block);
4625 : 43 : gfc_add_block_to_block (block, &se.post);
4626 : :
4627 : 43 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_GRAINSIZE);
4628 : 43 : OMP_CLAUSE_GRAINSIZE_EXPR (c) = grainsize;
4629 : 43 : if (clauses->grainsize_strict)
4630 : 6 : OMP_CLAUSE_GRAINSIZE_STRICT (c) = 1;
4631 : 43 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
4632 : : }
4633 : :
4634 : 30020 : if (clauses->num_tasks)
4635 : : {
4636 : 35 : tree num_tasks;
4637 : :
4638 : 35 : gfc_init_se (&se, NULL);
4639 : 35 : gfc_conv_expr (&se, clauses->num_tasks);
4640 : 35 : gfc_add_block_to_block (block, &se.pre);
4641 : 35 : num_tasks = gfc_evaluate_now (se.expr, block);
4642 : 35 : gfc_add_block_to_block (block, &se.post);
4643 : :
4644 : 35 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NUM_TASKS);
4645 : 35 : OMP_CLAUSE_NUM_TASKS_EXPR (c) = num_tasks;
4646 : 35 : if (clauses->num_tasks_strict)
4647 : 6 : OMP_CLAUSE_NUM_TASKS_STRICT (c) = 1;
4648 : 35 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
4649 : : }
4650 : :
4651 : 30020 : if (clauses->priority)
4652 : : {
4653 : 34 : tree priority;
4654 : :
4655 : 34 : gfc_init_se (&se, NULL);
4656 : 34 : gfc_conv_expr (&se, clauses->priority);
4657 : 34 : gfc_add_block_to_block (block, &se.pre);
4658 : 34 : priority = gfc_evaluate_now (se.expr, block);
4659 : 34 : gfc_add_block_to_block (block, &se.post);
4660 : :
4661 : 34 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_PRIORITY);
4662 : 34 : OMP_CLAUSE_PRIORITY_EXPR (c) = priority;
4663 : 34 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
4664 : : }
4665 : :
4666 : 30020 : if (clauses->detach)
4667 : : {
4668 : 116 : tree detach;
4669 : :
4670 : 116 : gfc_init_se (&se, NULL);
4671 : 116 : gfc_conv_expr (&se, clauses->detach);
4672 : 116 : gfc_add_block_to_block (block, &se.pre);
4673 : 116 : detach = se.expr;
4674 : 116 : gfc_add_block_to_block (block, &se.post);
4675 : :
4676 : 116 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_DETACH);
4677 : 116 : TREE_ADDRESSABLE (detach) = 1;
4678 : 116 : OMP_CLAUSE_DECL (c) = detach;
4679 : 116 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
4680 : : }
4681 : :
4682 : 30020 : if (clauses->filter)
4683 : : {
4684 : 31 : tree filter;
4685 : :
4686 : 31 : gfc_init_se (&se, NULL);
4687 : 31 : gfc_conv_expr (&se, clauses->filter);
4688 : 31 : gfc_add_block_to_block (block, &se.pre);
4689 : 31 : filter = gfc_evaluate_now (se.expr, block);
4690 : 31 : gfc_add_block_to_block (block, &se.post);
4691 : :
4692 : 31 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_FILTER);
4693 : 31 : OMP_CLAUSE_FILTER_EXPR (c) = filter;
4694 : 31 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
4695 : : }
4696 : :
4697 : 30020 : if (clauses->hint)
4698 : : {
4699 : 8 : tree hint;
4700 : :
4701 : 8 : gfc_init_se (&se, NULL);
4702 : 8 : gfc_conv_expr (&se, clauses->hint);
4703 : 8 : gfc_add_block_to_block (block, &se.pre);
4704 : 8 : hint = gfc_evaluate_now (se.expr, block);
4705 : 8 : gfc_add_block_to_block (block, &se.post);
4706 : :
4707 : 8 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_HINT);
4708 : 8 : OMP_CLAUSE_HINT_EXPR (c) = hint;
4709 : 8 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
4710 : : }
4711 : :
4712 : 30020 : if (clauses->simd)
4713 : : {
4714 : 22 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_SIMD);
4715 : 22 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
4716 : : }
4717 : 30020 : if (clauses->threads)
4718 : : {
4719 : 11 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_THREADS);
4720 : 11 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
4721 : : }
4722 : 30020 : if (clauses->nogroup)
4723 : : {
4724 : 13 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NOGROUP);
4725 : 13 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
4726 : : }
4727 : :
4728 : 210140 : for (int i = 0; i < OMP_DEFAULTMAP_CAT_NUM; i++)
4729 : : {
4730 : 180120 : if (clauses->defaultmap[i] == OMP_DEFAULTMAP_UNSET)
4731 : 179977 : continue;
4732 : 143 : enum omp_clause_defaultmap_kind behavior, category;
4733 : 143 : switch ((gfc_omp_defaultmap_category) i)
4734 : : {
4735 : : case OMP_DEFAULTMAP_CAT_UNCATEGORIZED:
4736 : : category = OMP_CLAUSE_DEFAULTMAP_CATEGORY_UNSPECIFIED;
4737 : : break;
4738 : : case OMP_DEFAULTMAP_CAT_ALL:
4739 : : category = OMP_CLAUSE_DEFAULTMAP_CATEGORY_ALL;
4740 : : break;
4741 : : case OMP_DEFAULTMAP_CAT_SCALAR:
4742 : : category = OMP_CLAUSE_DEFAULTMAP_CATEGORY_SCALAR;
4743 : : break;
4744 : : case OMP_DEFAULTMAP_CAT_AGGREGATE:
4745 : : category = OMP_CLAUSE_DEFAULTMAP_CATEGORY_AGGREGATE;
4746 : : break;
4747 : : case OMP_DEFAULTMAP_CAT_ALLOCATABLE:
4748 : : category = OMP_CLAUSE_DEFAULTMAP_CATEGORY_ALLOCATABLE;
4749 : : break;
4750 : : case OMP_DEFAULTMAP_CAT_POINTER:
4751 : : category = OMP_CLAUSE_DEFAULTMAP_CATEGORY_POINTER;
4752 : : break;
4753 : : default: gcc_unreachable ();
4754 : : }
4755 : 143 : switch (clauses->defaultmap[i])
4756 : : {
4757 : : case OMP_DEFAULTMAP_ALLOC:
4758 : : behavior = OMP_CLAUSE_DEFAULTMAP_ALLOC;
4759 : : break;
4760 : : case OMP_DEFAULTMAP_TO: behavior = OMP_CLAUSE_DEFAULTMAP_TO; break;
4761 : : case OMP_DEFAULTMAP_FROM: behavior = OMP_CLAUSE_DEFAULTMAP_FROM; break;
4762 : : case OMP_DEFAULTMAP_TOFROM:
4763 : : behavior = OMP_CLAUSE_DEFAULTMAP_TOFROM;
4764 : : break;
4765 : : case OMP_DEFAULTMAP_FIRSTPRIVATE:
4766 : : behavior = OMP_CLAUSE_DEFAULTMAP_FIRSTPRIVATE;
4767 : : break;
4768 : : case OMP_DEFAULTMAP_PRESENT:
4769 : : behavior = OMP_CLAUSE_DEFAULTMAP_PRESENT;
4770 : : break;
4771 : : case OMP_DEFAULTMAP_NONE: behavior = OMP_CLAUSE_DEFAULTMAP_NONE; break;
4772 : : case OMP_DEFAULTMAP_DEFAULT:
4773 : : behavior = OMP_CLAUSE_DEFAULTMAP_DEFAULT;
4774 : : break;
4775 : 0 : default: gcc_unreachable ();
4776 : : }
4777 : 143 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_DEFAULTMAP);
4778 : 143 : OMP_CLAUSE_DEFAULTMAP_SET_KIND (c, behavior, category);
4779 : 143 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
4780 : : }
4781 : :
4782 : 30020 : if (clauses->doacross_source)
4783 : : {
4784 : 131 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_DOACROSS);
4785 : 131 : OMP_CLAUSE_DOACROSS_KIND (c) = OMP_CLAUSE_DOACROSS_SOURCE;
4786 : 131 : OMP_CLAUSE_DOACROSS_DEPEND (c) = clauses->depend_source;
4787 : 131 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
4788 : : }
4789 : :
4790 : 30020 : if (clauses->async)
4791 : : {
4792 : 539 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_ASYNC);
4793 : 539 : if (clauses->async_expr)
4794 : 539 : OMP_CLAUSE_ASYNC_EXPR (c)
4795 : 1078 : = gfc_convert_expr_to_tree (block, clauses->async_expr);
4796 : : else
4797 : 0 : OMP_CLAUSE_ASYNC_EXPR (c) = NULL;
4798 : 539 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
4799 : : }
4800 : 30020 : if (clauses->seq)
4801 : : {
4802 : 113 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_SEQ);
4803 : 113 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
4804 : : }
4805 : 30020 : if (clauses->par_auto)
4806 : : {
4807 : 46 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_AUTO);
4808 : 46 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
4809 : : }
4810 : 30020 : if (clauses->if_present)
4811 : : {
4812 : 23 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_IF_PRESENT);
4813 : 23 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
4814 : : }
4815 : 30020 : if (clauses->finalize)
4816 : : {
4817 : 15 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_FINALIZE);
4818 : 15 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
4819 : : }
4820 : 30020 : if (clauses->independent)
4821 : : {
4822 : 184 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_INDEPENDENT);
4823 : 184 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
4824 : : }
4825 : 30020 : if (clauses->wait_list)
4826 : : {
4827 : : gfc_expr_list *el;
4828 : :
4829 : 317 : for (el = clauses->wait_list; el; el = el->next)
4830 : : {
4831 : 172 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_WAIT);
4832 : 172 : OMP_CLAUSE_DECL (c) = gfc_convert_expr_to_tree (block, el->expr);
4833 : 172 : OMP_CLAUSE_CHAIN (c) = omp_clauses;
4834 : 172 : omp_clauses = c;
4835 : : }
4836 : : }
4837 : 30020 : if (clauses->num_gangs_expr)
4838 : : {
4839 : 666 : tree num_gangs_var
4840 : 666 : = gfc_convert_expr_to_tree (block, clauses->num_gangs_expr);
4841 : 666 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NUM_GANGS);
4842 : 666 : OMP_CLAUSE_NUM_GANGS_EXPR (c) = num_gangs_var;
4843 : 666 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
4844 : : }
4845 : 30020 : if (clauses->num_workers_expr)
4846 : : {
4847 : 583 : tree num_workers_var
4848 : 583 : = gfc_convert_expr_to_tree (block, clauses->num_workers_expr);
4849 : 583 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NUM_WORKERS);
4850 : 583 : OMP_CLAUSE_NUM_WORKERS_EXPR (c) = num_workers_var;
4851 : 583 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
4852 : : }
4853 : 30020 : if (clauses->vector_length_expr)
4854 : : {
4855 : 553 : tree vector_length_var
4856 : 553 : = gfc_convert_expr_to_tree (block, clauses->vector_length_expr);
4857 : 553 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_VECTOR_LENGTH);
4858 : 553 : OMP_CLAUSE_VECTOR_LENGTH_EXPR (c) = vector_length_var;
4859 : 553 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
4860 : : }
4861 : 30020 : if (clauses->tile_list)
4862 : : {
4863 : : tree list = NULL_TREE;
4864 : 171 : for (gfc_expr_list *el = clauses->tile_list; el; el = el->next)
4865 : 112 : list = tree_cons (NULL_TREE, gfc_convert_expr_to_tree (block, el->expr),
4866 : : list);
4867 : :
4868 : 59 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_TILE);
4869 : 59 : OMP_CLAUSE_TILE_LIST (c) = nreverse (list);
4870 : 59 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
4871 : : }
4872 : 30020 : if (clauses->vector)
4873 : : {
4874 : 791 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_VECTOR);
4875 : 791 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
4876 : :
4877 : 791 : if (clauses->vector_expr)
4878 : : {
4879 : 115 : tree vector_var
4880 : 115 : = gfc_convert_expr_to_tree (block, clauses->vector_expr);
4881 : 115 : OMP_CLAUSE_VECTOR_EXPR (c) = vector_var;
4882 : :
4883 : : /* TODO: We're not capturing location information for individual
4884 : : clauses. However, if we have an expression attached to the
4885 : : clause, that one provides better location information. */
4886 : 230 : OMP_CLAUSE_LOCATION (c)
4887 : 115 : = gfc_get_location (&clauses->vector_expr->where);
4888 : : }
4889 : : }
4890 : 30020 : if (clauses->worker)
4891 : : {
4892 : 685 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_WORKER);
4893 : 685 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
4894 : :
4895 : 685 : if (clauses->worker_expr)
4896 : : {
4897 : 85 : tree worker_var
4898 : 85 : = gfc_convert_expr_to_tree (block, clauses->worker_expr);
4899 : 85 : OMP_CLAUSE_WORKER_EXPR (c) = worker_var;
4900 : :
4901 : : /* TODO: We're not capturing location information for individual
4902 : : clauses. However, if we have an expression attached to the
4903 : : clause, that one provides better location information. */
4904 : 170 : OMP_CLAUSE_LOCATION (c)
4905 : 85 : = gfc_get_location (&clauses->worker_expr->where);
4906 : : }
4907 : : }
4908 : 30020 : if (clauses->gang)
4909 : : {
4910 : 951 : tree arg;
4911 : 951 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_GANG);
4912 : 951 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
4913 : :
4914 : 951 : if (clauses->gang_num_expr)
4915 : : {
4916 : 97 : arg = gfc_convert_expr_to_tree (block, clauses->gang_num_expr);
4917 : 97 : OMP_CLAUSE_GANG_EXPR (c) = arg;
4918 : :
4919 : : /* TODO: We're not capturing location information for individual
4920 : : clauses. However, if we have an expression attached to the
4921 : : clause, that one provides better location information. */
4922 : 194 : OMP_CLAUSE_LOCATION (c)
4923 : 97 : = gfc_get_location (&clauses->gang_num_expr->where);
4924 : : }
4925 : :
4926 : 951 : if (clauses->gang_static)
4927 : : {
4928 : 190 : arg = clauses->gang_static_expr
4929 : 95 : ? gfc_convert_expr_to_tree (block, clauses->gang_static_expr)
4930 : : : integer_minus_one_node;
4931 : 95 : OMP_CLAUSE_GANG_STATIC_EXPR (c) = arg;
4932 : : }
4933 : : }
4934 : 30020 : if (clauses->bind != OMP_BIND_UNSET)
4935 : : {
4936 : 30 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_BIND);
4937 : 30 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
4938 : 30 : switch (clauses->bind)
4939 : : {
4940 : 10 : case OMP_BIND_TEAMS:
4941 : 10 : OMP_CLAUSE_BIND_KIND (c) = OMP_CLAUSE_BIND_TEAMS;
4942 : 10 : break;
4943 : 15 : case OMP_BIND_PARALLEL:
4944 : 15 : OMP_CLAUSE_BIND_KIND (c) = OMP_CLAUSE_BIND_PARALLEL;
4945 : 15 : break;
4946 : 5 : case OMP_BIND_THREAD:
4947 : 5 : OMP_CLAUSE_BIND_KIND (c) = OMP_CLAUSE_BIND_THREAD;
4948 : 5 : break;
4949 : 0 : default:
4950 : 0 : gcc_unreachable ();
4951 : : }
4952 : : }
4953 : : /* OpenACC 'nohost' clauses cannot appear here. */
4954 : 30020 : gcc_checking_assert (!clauses->nohost);
4955 : :
4956 : 30020 : return nreverse (omp_clauses);
4957 : : }
4958 : :
4959 : : /* Like gfc_trans_code, but force creation of a BIND_EXPR around it. */
4960 : :
4961 : : static tree
4962 : 20086 : gfc_trans_omp_code (gfc_code *code, bool force_empty)
4963 : : {
4964 : 20086 : tree stmt;
4965 : :
4966 : 20086 : pushlevel ();
4967 : 20086 : stmt = gfc_trans_code (code);
4968 : 20086 : if (TREE_CODE (stmt) != BIND_EXPR)
4969 : : {
4970 : 17938 : if (!IS_EMPTY_STMT (stmt) || force_empty)
4971 : : {
4972 : 17848 : tree block = poplevel (1, 0);
4973 : 17848 : stmt = build3_v (BIND_EXPR, NULL, stmt, block);
4974 : : }
4975 : : else
4976 : 90 : poplevel (0, 0);
4977 : : }
4978 : : else
4979 : 2148 : poplevel (0, 0);
4980 : 20086 : return stmt;
4981 : : }
4982 : :
4983 : : /* Translate OpenACC 'parallel', 'kernels', 'serial', 'data', 'host_data'
4984 : : construct. */
4985 : :
4986 : : static tree
4987 : 4028 : gfc_trans_oacc_construct (gfc_code *code)
4988 : : {
4989 : 4028 : stmtblock_t block;
4990 : 4028 : tree stmt, oacc_clauses;
4991 : 4028 : enum tree_code construct_code;
4992 : :
4993 : 4028 : switch (code->op)
4994 : : {
4995 : : case EXEC_OACC_PARALLEL:
4996 : : construct_code = OACC_PARALLEL;
4997 : : break;
4998 : : case EXEC_OACC_KERNELS:
4999 : : construct_code = OACC_KERNELS;
5000 : : break;
5001 : : case EXEC_OACC_SERIAL:
5002 : : construct_code = OACC_SERIAL;
5003 : : break;
5004 : : case EXEC_OACC_DATA:
5005 : : construct_code = OACC_DATA;
5006 : : break;
5007 : : case EXEC_OACC_HOST_DATA:
5008 : : construct_code = OACC_HOST_DATA;
5009 : : break;
5010 : 0 : default:
5011 : 0 : gcc_unreachable ();
5012 : : }
5013 : :
5014 : 4028 : gfc_start_block (&block);
5015 : 4028 : oacc_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
5016 : : code->loc, false, true);
5017 : 4028 : pushlevel ();
5018 : 4028 : stmt = gfc_trans_omp_code (code->block->next, true);
5019 : 4028 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
5020 : 4028 : stmt = build2_loc (gfc_get_location (&code->loc), construct_code,
5021 : : void_type_node, stmt, oacc_clauses);
5022 : 4028 : gfc_add_expr_to_block (&block, stmt);
5023 : 4028 : return gfc_finish_block (&block);
5024 : : }
5025 : :
5026 : : /* update, enter_data, exit_data, cache. */
5027 : : static tree
5028 : 2075 : gfc_trans_oacc_executable_directive (gfc_code *code)
5029 : : {
5030 : 2075 : stmtblock_t block;
5031 : 2075 : tree stmt, oacc_clauses;
5032 : 2075 : enum tree_code construct_code;
5033 : :
5034 : 2075 : switch (code->op)
5035 : : {
5036 : : case EXEC_OACC_UPDATE:
5037 : : construct_code = OACC_UPDATE;
5038 : : break;
5039 : 767 : case EXEC_OACC_ENTER_DATA:
5040 : 767 : construct_code = OACC_ENTER_DATA;
5041 : 767 : break;
5042 : 545 : case EXEC_OACC_EXIT_DATA:
5043 : 545 : construct_code = OACC_EXIT_DATA;
5044 : 545 : break;
5045 : 74 : case EXEC_OACC_CACHE:
5046 : 74 : construct_code = OACC_CACHE;
5047 : 74 : break;
5048 : 0 : default:
5049 : 0 : gcc_unreachable ();
5050 : : }
5051 : :
5052 : 2075 : gfc_start_block (&block);
5053 : 2075 : oacc_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
5054 : : code->loc, false, true, code->op);
5055 : 2075 : stmt = build1_loc (input_location, construct_code, void_type_node,
5056 : : oacc_clauses);
5057 : 2075 : gfc_add_expr_to_block (&block, stmt);
5058 : 2075 : return gfc_finish_block (&block);
5059 : : }
5060 : :
5061 : : static tree
5062 : 167 : gfc_trans_oacc_wait_directive (gfc_code *code)
5063 : : {
5064 : 167 : stmtblock_t block;
5065 : 167 : tree stmt, t;
5066 : 167 : vec<tree, va_gc> *args;
5067 : 167 : int nparms = 0;
5068 : 167 : gfc_expr_list *el;
5069 : 167 : gfc_omp_clauses *clauses = code->ext.omp_clauses;
5070 : 167 : location_t loc = input_location;
5071 : :
5072 : 291 : for (el = clauses->wait_list; el; el = el->next)
5073 : 124 : nparms++;
5074 : :
5075 : 167 : vec_alloc (args, nparms + 2);
5076 : 167 : stmt = builtin_decl_explicit (BUILT_IN_GOACC_WAIT);
5077 : :
5078 : 167 : gfc_start_block (&block);
5079 : :
5080 : 167 : if (clauses->async_expr)
5081 : 0 : t = gfc_convert_expr_to_tree (&block, clauses->async_expr);
5082 : : else
5083 : 167 : t = build_int_cst (integer_type_node, -2);
5084 : :
5085 : 167 : args->quick_push (t);
5086 : 167 : args->quick_push (build_int_cst (integer_type_node, nparms));
5087 : :
5088 : 291 : for (el = clauses->wait_list; el; el = el->next)
5089 : 124 : args->quick_push (gfc_convert_expr_to_tree (&block, el->expr));
5090 : :
5091 : 167 : stmt = build_call_expr_loc_vec (loc, stmt, args);
5092 : 167 : gfc_add_expr_to_block (&block, stmt);
5093 : :
5094 : 167 : vec_free (args);
5095 : :
5096 : 167 : return gfc_finish_block (&block);
5097 : : }
5098 : :
5099 : : static tree gfc_trans_omp_sections (gfc_code *, gfc_omp_clauses *);
5100 : : static tree gfc_trans_omp_workshare (gfc_code *, gfc_omp_clauses *);
5101 : :
5102 : : static tree
5103 : 31 : gfc_trans_omp_allocators (gfc_code *code)
5104 : : {
5105 : 31 : static bool warned = false;
5106 : 31 : gfc_omp_namelist *omp_allocate
5107 : 31 : = code->ext.omp_clauses->lists[OMP_LIST_ALLOCATE];
5108 : 31 : if (!flag_openmp_allocators && !warned)
5109 : : {
5110 : 2 : omp_allocate = NULL;
5111 : 2 : gfc_error ("%<!$OMP %s%> at %L requires %<-fopenmp-allocators%>",
5112 : 2 : code->op == EXEC_OMP_ALLOCATE ? "ALLOCATE" : "ALLOCATORS",
5113 : : &code->loc);
5114 : 2 : warning (0, "All files that might deallocate such a variable must be "
5115 : : "compiled with %<-fopenmp-allocators%>");
5116 : 2 : inform (UNKNOWN_LOCATION,
5117 : : "This includes explicit DEALLOCATE, reallocation on intrinsic "
5118 : : "assignment, INTENT(OUT) for allocatable dummy arguments, and "
5119 : : "reallocation of allocatable components allocated with an "
5120 : : "OpenMP allocator");
5121 : 2 : warned = true;
5122 : : }
5123 : 31 : return gfc_trans_allocate (code->block->next, omp_allocate);
5124 : : }
5125 : :
5126 : : static tree
5127 : 10 : gfc_trans_omp_assume (gfc_code *code)
5128 : : {
5129 : 10 : stmtblock_t block;
5130 : 10 : gfc_init_block (&block);
5131 : 10 : gfc_omp_assumptions *assume = code->ext.omp_clauses->assume;
5132 : 10 : if (assume)
5133 : 19 : for (gfc_expr_list *el = assume->holds; el; el = el->next)
5134 : : {
5135 : 9 : location_t loc = gfc_get_location (&el->expr->where);
5136 : 9 : gfc_se se;
5137 : 9 : gfc_init_se (&se, NULL);
5138 : 9 : gfc_conv_expr (&se, el->expr);
5139 : 9 : tree t;
5140 : 9 : if (se.pre.head == NULL_TREE && se.post.head == NULL_TREE)
5141 : 8 : t = se.expr;
5142 : : else
5143 : : {
5144 : 1 : tree var = create_tmp_var_raw (boolean_type_node);
5145 : 1 : DECL_CONTEXT (var) = current_function_decl;
5146 : 1 : stmtblock_t block2;
5147 : 1 : gfc_init_block (&block2);
5148 : 1 : gfc_add_block_to_block (&block2, &se.pre);
5149 : 1 : gfc_add_modify_loc (loc, &block2, var,
5150 : : fold_convert_loc (loc, boolean_type_node,
5151 : : se.expr));
5152 : 1 : gfc_add_block_to_block (&block2, &se.post);
5153 : 1 : t = gfc_finish_block (&block2);
5154 : 1 : t = build4 (TARGET_EXPR, boolean_type_node, var, t, NULL, NULL);
5155 : : }
5156 : 9 : t = build_call_expr_internal_loc (loc, IFN_ASSUME,
5157 : : void_type_node, 1, t);
5158 : 9 : gfc_add_expr_to_block (&block, t);
5159 : : }
5160 : 10 : gfc_add_expr_to_block (&block, gfc_trans_omp_code (code->block->next, true));
5161 : 10 : return gfc_finish_block (&block);
5162 : : }
5163 : :
5164 : : static tree
5165 : 2613 : gfc_trans_omp_atomic (gfc_code *code)
5166 : : {
5167 : 2613 : gfc_code *atomic_code = code->block;
5168 : 2613 : gfc_se lse;
5169 : 2613 : gfc_se rse;
5170 : 2613 : gfc_se vse;
5171 : 2613 : gfc_expr *expr1, *expr2, *e, *capture_expr1 = NULL, *capture_expr2 = NULL;
5172 : 2613 : gfc_symbol *var;
5173 : 2613 : stmtblock_t block;
5174 : 2613 : tree lhsaddr, type, rhs, x, compare = NULL_TREE, comp_tgt = NULL_TREE;
5175 : 2613 : enum tree_code op = ERROR_MARK;
5176 : 2613 : enum tree_code aop = OMP_ATOMIC;
5177 : 2613 : bool var_on_left = false, else_branch = false;
5178 : 2613 : enum omp_memory_order mo, fail_mo;
5179 : 2613 : switch (atomic_code->ext.omp_clauses->memorder)
5180 : : {
5181 : : case OMP_MEMORDER_UNSET: mo = OMP_MEMORY_ORDER_UNSPECIFIED; break;
5182 : : case OMP_MEMORDER_ACQ_REL: mo = OMP_MEMORY_ORDER_ACQ_REL; break;
5183 : : case OMP_MEMORDER_ACQUIRE: mo = OMP_MEMORY_ORDER_ACQUIRE; break;
5184 : : case OMP_MEMORDER_RELAXED: mo = OMP_MEMORY_ORDER_RELAXED; break;
5185 : : case OMP_MEMORDER_RELEASE: mo = OMP_MEMORY_ORDER_RELEASE; break;
5186 : : case OMP_MEMORDER_SEQ_CST: mo = OMP_MEMORY_ORDER_SEQ_CST; break;
5187 : 0 : default: gcc_unreachable ();
5188 : : }
5189 : 2613 : switch (atomic_code->ext.omp_clauses->fail)
5190 : : {
5191 : : case OMP_MEMORDER_UNSET: fail_mo = OMP_FAIL_MEMORY_ORDER_UNSPECIFIED; break;
5192 : 14 : case OMP_MEMORDER_ACQUIRE: fail_mo = OMP_FAIL_MEMORY_ORDER_ACQUIRE; break;
5193 : 26 : case OMP_MEMORDER_RELAXED: fail_mo = OMP_FAIL_MEMORY_ORDER_RELAXED; break;
5194 : 2 : case OMP_MEMORDER_SEQ_CST: fail_mo = OMP_FAIL_MEMORY_ORDER_SEQ_CST; break;
5195 : 0 : default: gcc_unreachable ();
5196 : : }
5197 : 2613 : mo = (omp_memory_order) (mo | fail_mo);
5198 : :
5199 : 2613 : code = code->block->next;
5200 : 2613 : if (atomic_code->ext.omp_clauses->compare)
5201 : : {
5202 : 144 : gfc_expr *comp_expr;
5203 : 144 : if (code->op == EXEC_IF)
5204 : : {
5205 : 125 : comp_expr = code->block->expr1;
5206 : 125 : gcc_assert (code->block->next->op == EXEC_ASSIGN);
5207 : 125 : expr1 = code->block->next->expr1;
5208 : 125 : expr2 = code->block->next->expr2;
5209 : 125 : if (code->block->block)
5210 : : {
5211 : 64 : gcc_assert (atomic_code->ext.omp_clauses->capture
5212 : : && code->block->block->next->op == EXEC_ASSIGN);
5213 : 64 : else_branch = true;
5214 : 64 : aop = OMP_ATOMIC_CAPTURE_OLD;
5215 : 64 : capture_expr1 = code->block->block->next->expr1;
5216 : 64 : capture_expr2 = code->block->block->next->expr2;
5217 : : }
5218 : 61 : else if (atomic_code->ext.omp_clauses->capture)
5219 : : {
5220 : 19 : gcc_assert (code->next->op == EXEC_ASSIGN);
5221 : 19 : aop = OMP_ATOMIC_CAPTURE_NEW;
5222 : 19 : capture_expr1 = code->next->expr1;
5223 : 19 : capture_expr2 = code->next->expr2;
5224 : : }
5225 : : }
5226 : : else
5227 : : {
5228 : 19 : gcc_assert (atomic_code->ext.omp_clauses->capture
5229 : : && code->op == EXEC_ASSIGN
5230 : : && code->next->op == EXEC_IF);
5231 : 19 : aop = OMP_ATOMIC_CAPTURE_OLD;
5232 : 19 : capture_expr1 = code->expr1;
5233 : 19 : capture_expr2 = code->expr2;
5234 : 19 : expr1 = code->next->block->next->expr1;
5235 : 19 : expr2 = code->next->block->next->expr2;
5236 : 19 : comp_expr = code->next->block->expr1;
5237 : : }
5238 : 144 : gfc_init_se (&lse, NULL);
5239 : 144 : gfc_conv_expr (&lse, comp_expr->value.op.op2);
5240 : 144 : gfc_add_block_to_block (&block, &lse.pre);
5241 : 144 : compare = lse.expr;
5242 : 144 : var = expr1->symtree->n.sym;
5243 : : }
5244 : : else
5245 : : {
5246 : 2469 : gcc_assert (code->op == EXEC_ASSIGN);
5247 : 2469 : expr1 = code->expr1;
5248 : 2469 : expr2 = code->expr2;
5249 : 2469 : if (atomic_code->ext.omp_clauses->capture
5250 : 483 : && (expr2->expr_type == EXPR_VARIABLE
5251 : 245 : || (expr2->expr_type == EXPR_FUNCTION
5252 : 113 : && expr2->value.function.isym
5253 : 113 : && expr2->value.function.isym->id == GFC_ISYM_CONVERSION
5254 : 41 : && (expr2->value.function.actual->expr->expr_type
5255 : : == EXPR_VARIABLE))))
5256 : : {
5257 : 255 : capture_expr1 = expr1;
5258 : 255 : capture_expr2 = expr2;
5259 : 255 : expr1 = code->next->expr1;
5260 : 255 : expr2 = code->next->expr2;
5261 : 255 : aop = OMP_ATOMIC_CAPTURE_OLD;
5262 : : }
5263 : 2214 : else if (atomic_code->ext.omp_clauses->capture)
5264 : : {
5265 : 228 : aop = OMP_ATOMIC_CAPTURE_NEW;
5266 : 228 : capture_expr1 = code->next->expr1;
5267 : 228 : capture_expr2 = code->next->expr2;
5268 : : }
5269 : 2469 : var = expr1->symtree->n.sym;
5270 : : }
5271 : :
5272 : 2613 : gfc_init_se (&lse, NULL);
5273 : 2613 : gfc_init_se (&rse, NULL);
5274 : 2613 : gfc_init_se (&vse, NULL);
5275 : 2613 : gfc_start_block (&block);
5276 : :
5277 : 2613 : if (((atomic_code->ext.omp_clauses->atomic_op & GFC_OMP_ATOMIC_MASK)
5278 : : != GFC_OMP_ATOMIC_WRITE)
5279 : 2207 : && expr2->expr_type == EXPR_FUNCTION
5280 : 472 : && expr2->value.function.isym
5281 : 472 : && expr2->value.function.isym->id == GFC_ISYM_CONVERSION)
5282 : 139 : expr2 = expr2->value.function.actual->expr;
5283 : :
5284 : 2613 : if ((atomic_code->ext.omp_clauses->atomic_op & GFC_OMP_ATOMIC_MASK)
5285 : : == GFC_OMP_ATOMIC_READ)
5286 : : {
5287 : 494 : gfc_conv_expr (&vse, expr1);
5288 : 494 : gfc_add_block_to_block (&block, &vse.pre);
5289 : :
5290 : 494 : gfc_conv_expr (&lse, expr2);
5291 : 494 : gfc_add_block_to_block (&block, &lse.pre);
5292 : 494 : type = TREE_TYPE (lse.expr);
5293 : 494 : lhsaddr = gfc_build_addr_expr (NULL, lse.expr);
5294 : :
5295 : 494 : x = build1 (OMP_ATOMIC_READ, type, lhsaddr);
5296 : 494 : OMP_ATOMIC_MEMORY_ORDER (x) = mo;
5297 : 494 : x = convert (TREE_TYPE (vse.expr), x);
5298 : 494 : gfc_add_modify (&block, vse.expr, x);
5299 : :
5300 : 494 : gfc_add_block_to_block (&block, &lse.pre);
5301 : 494 : gfc_add_block_to_block (&block, &rse.pre);
5302 : :
5303 : 494 : return gfc_finish_block (&block);
5304 : : }
5305 : :
5306 : 2119 : if (capture_expr2
5307 : 585 : && capture_expr2->expr_type == EXPR_FUNCTION
5308 : 21 : && capture_expr2->value.function.isym
5309 : 21 : && capture_expr2->value.function.isym->id == GFC_ISYM_CONVERSION)
5310 : 21 : capture_expr2 = capture_expr2->value.function.actual->expr;
5311 : 585 : gcc_assert (!capture_expr2 || capture_expr2->expr_type == EXPR_VARIABLE);
5312 : :
5313 : 2119 : if (aop == OMP_ATOMIC_CAPTURE_OLD)
5314 : : {
5315 : 338 : gfc_conv_expr (&vse, capture_expr1);
5316 : 338 : gfc_add_block_to_block (&block, &vse.pre);
5317 : 338 : gfc_conv_expr (&lse, capture_expr2);
5318 : 338 : gfc_add_block_to_block (&block, &lse.pre);
5319 : 338 : gfc_init_se (&lse, NULL);
5320 : : }
5321 : :
5322 : 2119 : gfc_conv_expr (&lse, expr1);
5323 : 2119 : gfc_add_block_to_block (&block, &lse.pre);
5324 : 2119 : type = TREE_TYPE (lse.expr);
5325 : 2119 : lhsaddr = gfc_build_addr_expr (NULL, lse.expr);
5326 : :
5327 : 2119 : if (((atomic_code->ext.omp_clauses->atomic_op & GFC_OMP_ATOMIC_MASK)
5328 : : == GFC_OMP_ATOMIC_WRITE)
5329 : 1713 : || (atomic_code->ext.omp_clauses->atomic_op & GFC_OMP_ATOMIC_SWAP)
5330 : 1691 : || compare)
5331 : : {
5332 : 572 : gfc_conv_expr (&rse, expr2);
5333 : 572 : gfc_add_block_to_block (&block, &rse.pre);
5334 : : }
5335 : 1547 : else if (expr2->expr_type == EXPR_OP)
5336 : : {
5337 : 1201 : gfc_expr *e;
5338 : 1201 : switch (expr2->value.op.op)
5339 : : {
5340 : : case INTRINSIC_PLUS:
5341 : : op = PLUS_EXPR;
5342 : : break;
5343 : 91 : case INTRINSIC_TIMES:
5344 : 91 : op = MULT_EXPR;
5345 : 91 : break;
5346 : 113 : case INTRINSIC_MINUS:
5347 : 113 : op = MINUS_EXPR;
5348 : 113 : break;
5349 : 91 : case INTRINSIC_DIVIDE:
5350 : 91 : if (expr2->ts.type == BT_INTEGER)
5351 : : op = TRUNC_DIV_EXPR;
5352 : : else
5353 : 74 : op = RDIV_EXPR;
5354 : : break;
5355 : 43 : case INTRINSIC_AND:
5356 : 43 : op = TRUTH_ANDIF_EXPR;
5357 : 43 : break;
5358 : 49 : case INTRINSIC_OR:
5359 : 49 : op = TRUTH_ORIF_EXPR;
5360 : 49 : break;
5361 : 43 : case INTRINSIC_EQV:
5362 : 43 : op = EQ_EXPR;
5363 : 43 : break;
5364 : 43 : case INTRINSIC_NEQV:
5365 : 43 : op = NE_EXPR;
5366 : 43 : break;
5367 : 0 : default:
5368 : 0 : gcc_unreachable ();
5369 : : }
5370 : 1201 : e = expr2->value.op.op1;
5371 : 1201 : if (e->expr_type == EXPR_FUNCTION
5372 : 48 : && e->value.function.isym
5373 : 48 : && e->value.function.isym->id == GFC_ISYM_CONVERSION)
5374 : 48 : e = e->value.function.actual->expr;
5375 : 1201 : if (e->expr_type == EXPR_VARIABLE
5376 : 942 : && e->symtree != NULL
5377 : 942 : && e->symtree->n.sym == var)
5378 : : {
5379 : 927 : expr2 = expr2->value.op.op2;
5380 : 927 : var_on_left = true;
5381 : : }
5382 : : else
5383 : : {
5384 : 274 : e = expr2->value.op.op2;
5385 : 274 : if (e->expr_type == EXPR_FUNCTION
5386 : 48 : && e->value.function.isym
5387 : 48 : && e->value.function.isym->id == GFC_ISYM_CONVERSION)
5388 : 48 : e = e->value.function.actual->expr;
5389 : 274 : gcc_assert (e->expr_type == EXPR_VARIABLE
5390 : : && e->symtree != NULL
5391 : : && e->symtree->n.sym == var);
5392 : : expr2 = expr2->value.op.op1;
5393 : : var_on_left = false;
5394 : : }
5395 : 1201 : gfc_conv_expr (&rse, expr2);
5396 : 1201 : gfc_add_block_to_block (&block, &rse.pre);
5397 : : }
5398 : : else
5399 : : {
5400 : 346 : gcc_assert (expr2->expr_type == EXPR_FUNCTION);
5401 : 346 : switch (expr2->value.function.isym->id)
5402 : : {
5403 : : case GFC_ISYM_MIN:
5404 : : op = MIN_EXPR;
5405 : : break;
5406 : 114 : case GFC_ISYM_MAX:
5407 : 114 : op = MAX_EXPR;
5408 : 114 : break;
5409 : 47 : case GFC_ISYM_IAND:
5410 : 47 : op = BIT_AND_EXPR;
5411 : 47 : break;
5412 : 49 : case GFC_ISYM_IOR:
5413 : 49 : op = BIT_IOR_EXPR;
5414 : 49 : break;
5415 : 45 : case GFC_ISYM_IEOR:
5416 : 45 : op = BIT_XOR_EXPR;
5417 : 45 : break;
5418 : 0 : default:
5419 : 0 : gcc_unreachable ();
5420 : : }
5421 : 346 : e = expr2->value.function.actual->expr;
5422 : 346 : if (e->expr_type == EXPR_FUNCTION
5423 : 13 : && e->value.function.isym
5424 : 13 : && e->value.function.isym->id == GFC_ISYM_CONVERSION)
5425 : 13 : e = e->value.function.actual->expr;
5426 : 346 : gcc_assert (e->expr_type == EXPR_VARIABLE
5427 : : && e->symtree != NULL
5428 : : && e->symtree->n.sym == var);
5429 : :
5430 : 346 : gfc_conv_expr (&rse, expr2->value.function.actual->next->expr);
5431 : 346 : gfc_add_block_to_block (&block, &rse.pre);
5432 : 346 : if (expr2->value.function.actual->next->next != NULL)
5433 : : {
5434 : 26 : tree accum = gfc_create_var (TREE_TYPE (rse.expr), NULL);
5435 : 26 : gfc_actual_arglist *arg;
5436 : :
5437 : 26 : gfc_add_modify (&block, accum, rse.expr);
5438 : 64 : for (arg = expr2->value.function.actual->next->next; arg;
5439 : 38 : arg = arg->next)
5440 : : {
5441 : 38 : gfc_init_block (&rse.pre);
5442 : 38 : gfc_conv_expr (&rse, arg->expr);
5443 : 38 : gfc_add_block_to_block (&block, &rse.pre);
5444 : 38 : x = fold_build2_loc (input_location, op, TREE_TYPE (accum),
5445 : : accum, rse.expr);
5446 : 38 : gfc_add_modify (&block, accum, x);
5447 : : }
5448 : :
5449 : 26 : rse.expr = accum;
5450 : : }
5451 : :
5452 : 346 : expr2 = expr2->value.function.actual->next->expr;
5453 : : }
5454 : :
5455 : 2119 : lhsaddr = save_expr (lhsaddr);
5456 : 2119 : if (TREE_CODE (lhsaddr) != SAVE_EXPR
5457 : 2119 : && (TREE_CODE (lhsaddr) != ADDR_EXPR
5458 : 1659 : || !VAR_P (TREE_OPERAND (lhsaddr, 0))))
5459 : : {
5460 : : /* Make sure LHS is simple enough so that goa_lhs_expr_p can recognize
5461 : : it even after unsharing function body. */
5462 : 44 : tree var = create_tmp_var_raw (TREE_TYPE (lhsaddr));
5463 : 44 : DECL_CONTEXT (var) = current_function_decl;
5464 : 44 : lhsaddr = build4 (TARGET_EXPR, TREE_TYPE (lhsaddr), var, lhsaddr,
5465 : : NULL_TREE, NULL_TREE);
5466 : : }
5467 : :
5468 : 2119 : if (compare)
5469 : : {
5470 : 144 : tree var = create_tmp_var_raw (TREE_TYPE (lhsaddr));
5471 : 144 : DECL_CONTEXT (var) = current_function_decl;
5472 : 144 : lhsaddr = build4 (TARGET_EXPR, TREE_TYPE (lhsaddr), var, lhsaddr, NULL,
5473 : : NULL);
5474 : 144 : lse.expr = build_fold_indirect_ref_loc (input_location, lhsaddr);
5475 : 144 : compare = convert (TREE_TYPE (lse.expr), compare);
5476 : 144 : compare = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
5477 : : lse.expr, compare);
5478 : : }
5479 : :
5480 : 2119 : if (expr2->expr_type == EXPR_VARIABLE || compare)
5481 : 460 : rhs = rse.expr;
5482 : : else
5483 : 1659 : rhs = gfc_evaluate_now (rse.expr, &block);
5484 : :
5485 : 2119 : if (((atomic_code->ext.omp_clauses->atomic_op & GFC_OMP_ATOMIC_MASK)
5486 : : == GFC_OMP_ATOMIC_WRITE)
5487 : 1713 : || (atomic_code->ext.omp_clauses->atomic_op & GFC_OMP_ATOMIC_SWAP)
5488 : 1691 : || compare)
5489 : : x = rhs;
5490 : : else
5491 : : {
5492 : 1547 : x = convert (TREE_TYPE (rhs),
5493 : : build_fold_indirect_ref_loc (input_location, lhsaddr));
5494 : 1547 : if (var_on_left)
5495 : 927 : x = fold_build2_loc (input_location, op, TREE_TYPE (rhs), x, rhs);
5496 : : else
5497 : 620 : x = fold_build2_loc (input_location, op, TREE_TYPE (rhs), rhs, x);
5498 : : }
5499 : :
5500 : 2119 : if (TREE_CODE (TREE_TYPE (rhs)) == COMPLEX_TYPE
5501 : 2119 : && TREE_CODE (type) != COMPLEX_TYPE)
5502 : 0 : x = fold_build1_loc (input_location, REALPART_EXPR,
5503 : 0 : TREE_TYPE (TREE_TYPE (rhs)), x);
5504 : :
5505 : 2119 : gfc_add_block_to_block (&block, &lse.pre);
5506 : 2119 : gfc_add_block_to_block (&block, &rse.pre);
5507 : :
5508 : 2119 : if (aop == OMP_ATOMIC_CAPTURE_NEW)
5509 : : {
5510 : 247 : gfc_conv_expr (&vse, capture_expr1);
5511 : 247 : gfc_add_block_to_block (&block, &vse.pre);
5512 : 247 : gfc_add_block_to_block (&block, &lse.pre);
5513 : : }
5514 : :
5515 : 2119 : if (compare && else_branch)
5516 : : {
5517 : 64 : tree var2 = create_tmp_var_raw (boolean_type_node);
5518 : 64 : DECL_CONTEXT (var2) = current_function_decl;
5519 : 64 : comp_tgt = build4 (TARGET_EXPR, boolean_type_node, var2,
5520 : : boolean_false_node, NULL, NULL);
5521 : 64 : compare = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (var2),
5522 : : var2, compare);
5523 : 64 : TREE_OPERAND (compare, 0) = comp_tgt;
5524 : 64 : compare = omit_one_operand_loc (input_location, boolean_type_node,
5525 : : compare, comp_tgt);
5526 : : }
5527 : :
5528 : 2119 : if (compare)
5529 : 144 : x = build3_loc (input_location, COND_EXPR, type, compare,
5530 : : convert (type, x), lse.expr);
5531 : :
5532 : 2119 : if (aop == OMP_ATOMIC)
5533 : : {
5534 : 1534 : x = build2_v (OMP_ATOMIC, lhsaddr, convert (type, x));
5535 : 1534 : OMP_ATOMIC_MEMORY_ORDER (x) = mo;
5536 : 1534 : OMP_ATOMIC_WEAK (x) = atomic_code->ext.omp_clauses->weak;
5537 : 1534 : gfc_add_expr_to_block (&block, x);
5538 : : }
5539 : : else
5540 : : {
5541 : 585 : x = build2 (aop, type, lhsaddr, convert (type, x));
5542 : 585 : OMP_ATOMIC_MEMORY_ORDER (x) = mo;
5543 : 585 : OMP_ATOMIC_WEAK (x) = atomic_code->ext.omp_clauses->weak;
5544 : 585 : if (compare && else_branch)
5545 : : {
5546 : 64 : tree vtmp = create_tmp_var_raw (TREE_TYPE (x));
5547 : 64 : DECL_CONTEXT (vtmp) = current_function_decl;
5548 : 64 : x = fold_build2_loc (input_location, MODIFY_EXPR,
5549 : 64 : TREE_TYPE (vtmp), vtmp, x);
5550 : 64 : vtmp = build4 (TARGET_EXPR, TREE_TYPE (vtmp), vtmp,
5551 : 64 : build_zero_cst (TREE_TYPE (vtmp)), NULL, NULL);
5552 : 64 : TREE_OPERAND (x, 0) = vtmp;
5553 : 64 : tree x2 = convert (TREE_TYPE (vse.expr), vtmp);
5554 : 64 : x2 = fold_build2_loc (input_location, MODIFY_EXPR,
5555 : 64 : TREE_TYPE (vse.expr), vse.expr, x2);
5556 : 64 : x2 = build3_loc (input_location, COND_EXPR, void_type_node, comp_tgt,
5557 : : void_node, x2);
5558 : 64 : x = omit_one_operand_loc (input_location, TREE_TYPE (x2), x2, x);
5559 : 64 : gfc_add_expr_to_block (&block, x);
5560 : : }
5561 : : else
5562 : : {
5563 : 521 : x = convert (TREE_TYPE (vse.expr), x);
5564 : 521 : gfc_add_modify (&block, vse.expr, x);
5565 : : }
5566 : : }
5567 : :
5568 : 2119 : return gfc_finish_block (&block);
5569 : : }
5570 : :
5571 : : static tree
5572 : 602 : gfc_trans_omp_barrier (void)
5573 : : {
5574 : 602 : tree decl = builtin_decl_explicit (BUILT_IN_GOMP_BARRIER);
5575 : 602 : return build_call_expr_loc (input_location, decl, 0);
5576 : : }
5577 : :
5578 : : static tree
5579 : 310 : gfc_trans_omp_cancel (gfc_code *code)
5580 : : {
5581 : 310 : int mask = 0;
5582 : 310 : tree ifc = boolean_true_node;
5583 : 310 : stmtblock_t block;
5584 : 310 : switch (code->ext.omp_clauses->cancel)
5585 : : {
5586 : : case OMP_CANCEL_PARALLEL: mask = 1; break;
5587 : : case OMP_CANCEL_DO: mask = 2; break;
5588 : : case OMP_CANCEL_SECTIONS: mask = 4; break;
5589 : : case OMP_CANCEL_TASKGROUP: mask = 8; break;
5590 : 0 : default: gcc_unreachable ();
5591 : : }
5592 : 310 : gfc_start_block (&block);
5593 : 310 : if (code->ext.omp_clauses->if_expr
5594 : 219 : || code->ext.omp_clauses->if_exprs[OMP_IF_CANCEL])
5595 : : {
5596 : 99 : gfc_se se;
5597 : 99 : tree if_var;
5598 : :
5599 : 99 : gcc_assert ((code->ext.omp_clauses->if_expr == NULL)
5600 : : ^ (code->ext.omp_clauses->if_exprs[OMP_IF_CANCEL] == NULL));
5601 : 99 : gfc_init_se (&se, NULL);
5602 : 99 : gfc_conv_expr (&se, code->ext.omp_clauses->if_expr != NULL
5603 : : ? code->ext.omp_clauses->if_expr
5604 : : : code->ext.omp_clauses->if_exprs[OMP_IF_CANCEL]);
5605 : 99 : gfc_add_block_to_block (&block, &se.pre);
5606 : 99 : if_var = gfc_evaluate_now (se.expr, &block);
5607 : 99 : gfc_add_block_to_block (&block, &se.post);
5608 : 99 : tree type = TREE_TYPE (if_var);
5609 : 99 : ifc = fold_build2_loc (input_location, NE_EXPR,
5610 : : boolean_type_node, if_var,
5611 : : build_zero_cst (type));
5612 : : }
5613 : 310 : tree decl = builtin_decl_explicit (BUILT_IN_GOMP_CANCEL);
5614 : 310 : tree c_bool_type = TREE_TYPE (TREE_TYPE (decl));
5615 : 310 : ifc = fold_convert (c_bool_type, ifc);
5616 : 310 : gfc_add_expr_to_block (&block,
5617 : : build_call_expr_loc (input_location, decl, 2,
5618 : 310 : build_int_cst (integer_type_node,
5619 : : mask), ifc));
5620 : 310 : return gfc_finish_block (&block);
5621 : : }
5622 : :
5623 : : static tree
5624 : 170 : gfc_trans_omp_cancellation_point (gfc_code *code)
5625 : : {
5626 : 170 : int mask = 0;
5627 : 170 : switch (code->ext.omp_clauses->cancel)
5628 : : {
5629 : : case OMP_CANCEL_PARALLEL: mask = 1; break;
5630 : : case OMP_CANCEL_DO: mask = 2; break;
5631 : : case OMP_CANCEL_SECTIONS: mask = 4; break;
5632 : : case OMP_CANCEL_TASKGROUP: mask = 8; break;
5633 : 0 : default: gcc_unreachable ();
5634 : : }
5635 : 170 : tree decl = builtin_decl_explicit (BUILT_IN_GOMP_CANCELLATION_POINT);
5636 : 170 : return build_call_expr_loc (input_location, decl, 1,
5637 : 340 : build_int_cst (integer_type_node, mask));
5638 : : }
5639 : :
5640 : : static tree
5641 : 143 : gfc_trans_omp_critical (gfc_code *code)
5642 : : {
5643 : 143 : stmtblock_t block;
5644 : 143 : tree stmt, name = NULL_TREE;
5645 : 143 : if (code->ext.omp_clauses->critical_name != NULL)
5646 : 36 : name = get_identifier (code->ext.omp_clauses->critical_name);
5647 : 143 : gfc_start_block (&block);
5648 : 143 : stmt = make_node (OMP_CRITICAL);
5649 : 143 : SET_EXPR_LOCATION (stmt, gfc_get_location (&code->loc));
5650 : 143 : TREE_TYPE (stmt) = void_type_node;
5651 : 143 : OMP_CRITICAL_BODY (stmt) = gfc_trans_code (code->block->next);
5652 : 143 : OMP_CRITICAL_NAME (stmt) = name;
5653 : 143 : OMP_CRITICAL_CLAUSES (stmt) = gfc_trans_omp_clauses (&block,
5654 : : code->ext.omp_clauses,
5655 : : code->loc);
5656 : 143 : gfc_add_expr_to_block (&block, stmt);
5657 : 143 : return gfc_finish_block (&block);
5658 : : }
5659 : :
5660 : : typedef struct dovar_init_d {
5661 : : gfc_symbol *sym;
5662 : : tree var;
5663 : : tree init;
5664 : : bool non_unit_iter;
5665 : : } dovar_init;
5666 : :
5667 : : static bool
5668 : 2884 : gfc_nonrect_loop_expr (stmtblock_t *pblock, gfc_se *sep, int loop_n,
5669 : : gfc_code *code, gfc_expr *expr, vec<dovar_init> *inits,
5670 : : int simple, gfc_expr *curr_loop_var)
5671 : : {
5672 : 2884 : int i;
5673 : 4771 : for (i = 0; i < loop_n; i++)
5674 : : {
5675 : 2441 : gcc_assert (code->ext.iterator->var->expr_type == EXPR_VARIABLE);
5676 : 2441 : if (gfc_find_sym_in_expr (code->ext.iterator->var->symtree->n.sym, expr))
5677 : : break;
5678 : 1887 : code = code->block->next;
5679 : : }
5680 : 2884 : if (i >= loop_n)
5681 : : return false;
5682 : :
5683 : : /* Canonical format: TREE_VEC with [var, multiplier, offset]. */
5684 : 554 : gfc_symbol *var = code->ext.iterator->var->symtree->n.sym;
5685 : :
5686 : 554 : tree tree_var = NULL_TREE;
5687 : 554 : tree a1 = integer_one_node;
5688 : 554 : tree a2 = integer_zero_node;
5689 : :
5690 : 554 : if (!simple)
5691 : : {
5692 : : /* FIXME: Handle non-const iter steps, cf. PR fortran/110735. */
5693 : 6 : sorry_at (gfc_get_location (&curr_loop_var->where),
5694 : : "non-rectangular loop nest with non-constant step for %qs",
5695 : 3 : curr_loop_var->symtree->n.sym->name);
5696 : 3 : return false;
5697 : : }
5698 : :
5699 : : dovar_init *di;
5700 : : unsigned ix;
5701 : 551 : FOR_EACH_VEC_ELT (*inits, ix, di)
5702 : 18 : if (di->sym == var)
5703 : : {
5704 : 18 : if (!di->non_unit_iter)
5705 : : {
5706 : 16 : tree_var = di->init;
5707 : 16 : gcc_assert (DECL_P (tree_var));
5708 : : break;
5709 : : }
5710 : : else
5711 : : {
5712 : : /* FIXME: Handle non-const iter steps, cf. PR fortran/110735. */
5713 : 2 : sorry_at (gfc_get_location (&code->loc),
5714 : : "non-rectangular loop nest with non-constant step "
5715 : : "for %qs", var->name);
5716 : 2 : inform (gfc_get_location (&expr->where), "Used here");
5717 : 2 : return false;
5718 : : }
5719 : : }
5720 : 533 : if (tree_var == NULL_TREE)
5721 : 533 : tree_var = var->backend_decl;
5722 : :
5723 : 549 : if (expr->expr_type == EXPR_VARIABLE)
5724 : 54 : gcc_assert (expr->symtree->n.sym == var);
5725 : 495 : else if (expr->expr_type != EXPR_OP
5726 : 495 : || (expr->value.op.op != INTRINSIC_TIMES
5727 : 479 : && expr->value.op.op != INTRINSIC_PLUS
5728 : 359 : && expr->value.op.op != INTRINSIC_MINUS))
5729 : 0 : gcc_unreachable ();
5730 : : else
5731 : : {
5732 : 495 : gfc_se se;
5733 : 495 : gfc_expr *et = NULL, *eo = NULL, *e = expr;
5734 : 495 : if (expr->value.op.op != INTRINSIC_TIMES)
5735 : : {
5736 : 479 : if (gfc_find_sym_in_expr (var, expr->value.op.op1))
5737 : : {
5738 : 431 : e = expr->value.op.op1;
5739 : 431 : eo = expr->value.op.op2;
5740 : : }
5741 : : else
5742 : : {
5743 : 48 : eo = expr->value.op.op1;
5744 : 48 : e = expr->value.op.op2;
5745 : : }
5746 : : }
5747 : 495 : if (e->value.op.op == INTRINSIC_TIMES)
5748 : : {
5749 : 91 : if (e->value.op.op1->expr_type == EXPR_VARIABLE
5750 : 91 : && e->value.op.op1->symtree->n.sym == var)
5751 : 51 : et = e->value.op.op2;
5752 : : else
5753 : : {
5754 : 40 : et = e->value.op.op1;
5755 : 40 : gcc_assert (e->value.op.op2->expr_type == EXPR_VARIABLE
5756 : : && e->value.op.op2->symtree->n.sym == var);
5757 : : }
5758 : : }
5759 : : else
5760 : 404 : gcc_assert (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym == var);
5761 : 91 : if (et != NULL)
5762 : : {
5763 : 91 : gfc_init_se (&se, NULL);
5764 : 91 : gfc_conv_expr_val (&se, et);
5765 : 91 : gfc_add_block_to_block (pblock, &se.pre);
5766 : 91 : a1 = se.expr;
5767 : : }
5768 : 495 : if (eo != NULL)
5769 : : {
5770 : 479 : gfc_init_se (&se, NULL);
5771 : 479 : gfc_conv_expr_val (&se, eo);
5772 : 479 : gfc_add_block_to_block (pblock, &se.pre);
5773 : 479 : a2 = se.expr;
5774 : 479 : if (expr->value.op.op == INTRINSIC_MINUS && expr->value.op.op2 == eo)
5775 : : /* outer-var - a2. */
5776 : 335 : a2 = fold_build1 (NEGATE_EXPR, TREE_TYPE (a2), a2);
5777 : 144 : else if (expr->value.op.op == INTRINSIC_MINUS)
5778 : : /* a2 - outer-var. */
5779 : 24 : a1 = fold_build1 (NEGATE_EXPR, TREE_TYPE (a1), a1);
5780 : : }
5781 : 495 : a1 = DECL_P (a1) ? a1 : gfc_evaluate_now (a1, pblock);
5782 : 495 : a2 = DECL_P (a2) ? a2 : gfc_evaluate_now (a2, pblock);
5783 : : }
5784 : :
5785 : 549 : gfc_init_se (sep, NULL);
5786 : 549 : sep->expr = make_tree_vec (3);
5787 : 549 : TREE_VEC_ELT (sep->expr, 0) = tree_var;
5788 : 549 : TREE_VEC_ELT (sep->expr, 1) = fold_convert (TREE_TYPE (tree_var), a1);
5789 : 549 : TREE_VEC_ELT (sep->expr, 2) = fold_convert (TREE_TYPE (tree_var), a2);
5790 : :
5791 : 549 : return true;
5792 : : }
5793 : :
5794 : : int
5795 : 707 : gfc_expr_list_len (gfc_expr_list *list)
5796 : : {
5797 : 707 : unsigned len = 0;
5798 : 2089 : for (; list; list = list->next)
5799 : 1382 : len++;
5800 : :
5801 : 707 : return len;
5802 : : }
5803 : :
5804 : : static tree
5805 : 9002 : gfc_trans_omp_do (gfc_code *code, gfc_exec_op op, stmtblock_t *pblock,
5806 : : gfc_omp_clauses *do_clauses, tree par_clauses)
5807 : : {
5808 : 9002 : gfc_se se;
5809 : 9002 : tree dovar, stmt, from, to, step, type, init, cond, incr, orig_decls;
5810 : 9002 : tree local_dovar = NULL_TREE, cycle_label, tmp, omp_clauses;
5811 : 9002 : stmtblock_t block;
5812 : 9002 : stmtblock_t body;
5813 : 9002 : gfc_omp_clauses *clauses = code->ext.omp_clauses;
5814 : 9002 : int i, collapse = clauses->collapse;
5815 : 9002 : vec<dovar_init> inits = vNULL;
5816 : 9002 : dovar_init *di;
5817 : 9002 : unsigned ix;
5818 : 9002 : vec<tree, va_heap, vl_embed> *saved_doacross_steps = doacross_steps;
5819 : 18004 : gfc_expr_list *oacc_tile
5820 : 9002 : = do_clauses ? do_clauses->tile_list : clauses->tile_list;
5821 : 18004 : gfc_expr_list *sizes
5822 : 9002 : = do_clauses ? do_clauses->sizes_list : clauses->sizes_list;
5823 : 9002 : gfc_code *orig_code = code;
5824 : :
5825 : : /* Both collapsed and tiled loops are lowered the same way. In
5826 : : OpenACC, those clauses are not compatible, so prioritize the tile
5827 : : clause, if present. */
5828 : 9002 : if (oacc_tile)
5829 : 59 : collapse = gfc_expr_list_len (oacc_tile);
5830 : 8943 : else if (sizes)
5831 : 120 : collapse = gfc_expr_list_len (sizes);
5832 : :
5833 : 9002 : doacross_steps = NULL;
5834 : 9002 : if (clauses->orderedc)
5835 : 132 : collapse = clauses->orderedc;
5836 : 9002 : if (collapse <= 0)
5837 : : collapse = 1;
5838 : :
5839 : 9002 : code = code->block->next;
5840 : :
5841 : 9002 : init = make_tree_vec (collapse);
5842 : 9002 : cond = make_tree_vec (collapse);
5843 : 9002 : incr = make_tree_vec (collapse);
5844 : 9002 : orig_decls = clauses->ordered ? make_tree_vec (collapse) : NULL_TREE;
5845 : :
5846 : 9002 : if (pblock == NULL)
5847 : : {
5848 : 5726 : gfc_start_block (&block);
5849 : 5726 : pblock = █
5850 : : }
5851 : :
5852 : : /* simd schedule modifier is only useful for composite do simd and other
5853 : : constructs including that, where gfc_trans_omp_do is only called
5854 : : on the simd construct and DO's clauses are translated elsewhere. */
5855 : 9002 : do_clauses->sched_simd = false;
5856 : :
5857 : 9002 : omp_clauses = gfc_trans_omp_clauses (pblock, do_clauses, code->loc);
5858 : :
5859 : 20479 : for (i = 0; i < collapse; i++)
5860 : : {
5861 : 11477 : int simple = 0;
5862 : 11477 : int dovar_found = 0;
5863 : 11477 : tree dovar_decl;
5864 : :
5865 : 11477 : if (code->op == EXEC_OMP_TILE || code->op == EXEC_OMP_UNROLL)
5866 : : {
5867 : 325 : TREE_VEC_ELT (init, i) = NULL_TREE;
5868 : 325 : TREE_VEC_ELT (cond, i) = NULL_TREE;
5869 : 325 : TREE_VEC_ELT (incr, i) = NULL_TREE;
5870 : 325 : TREE_VEC_ELT (incr, i) = NULL_TREE;
5871 : 325 : if (orig_decls)
5872 : 2 : TREE_VEC_ELT (orig_decls, i) = NULL_TREE;
5873 : 325 : continue;
5874 : : }
5875 : 11152 : gcc_assert (code->op == EXEC_DO);
5876 : 11152 : if (clauses)
5877 : : {
5878 : 11152 : gfc_omp_namelist *n = NULL;
5879 : 11152 : if (op == EXEC_OMP_SIMD && collapse == 1)
5880 : 939 : for (n = clauses->lists[OMP_LIST_LINEAR];
5881 : 1239 : n != NULL; n = n->next)
5882 : 443 : if (code->ext.iterator->var->symtree->n.sym == n->sym)
5883 : : {
5884 : : dovar_found = 3;
5885 : : break;
5886 : : }
5887 : 11152 : if (n == NULL && op != EXEC_OMP_DISTRIBUTE)
5888 : 10915 : for (n = clauses->lists[OMP_LIST_LASTPRIVATE];
5889 : 12974 : n != NULL; n = n->next)
5890 : 3436 : if (code->ext.iterator->var->symtree->n.sym == n->sym)
5891 : : {
5892 : : dovar_found = 2;
5893 : : break;
5894 : : }
5895 : 11152 : if (n == NULL)
5896 : 10856 : for (n = clauses->lists[OMP_LIST_PRIVATE]; n != NULL; n = n->next)
5897 : 6476 : if (code->ext.iterator->var->symtree->n.sym == n->sym)
5898 : : {
5899 : : dovar_found = 1;
5900 : : break;
5901 : : }
5902 : : }
5903 : :
5904 : : /* Evaluate all the expressions in the iterator. */
5905 : 11152 : gfc_init_se (&se, NULL);
5906 : 11152 : gfc_conv_expr_lhs (&se, code->ext.iterator->var);
5907 : 11152 : gfc_add_block_to_block (pblock, &se.pre);
5908 : 11152 : local_dovar = dovar_decl = dovar = se.expr;
5909 : 11152 : type = TREE_TYPE (dovar);
5910 : 11152 : gcc_assert (TREE_CODE (type) == INTEGER_TYPE);
5911 : :
5912 : 11152 : gfc_init_se (&se, NULL);
5913 : 11152 : gfc_conv_expr_val (&se, code->ext.iterator->step);
5914 : 11152 : gfc_add_block_to_block (pblock, &se.pre);
5915 : 11152 : step = gfc_evaluate_now (se.expr, pblock);
5916 : :
5917 : 11152 : if (TREE_CODE (step) == INTEGER_CST)
5918 : 10541 : simple = tree_int_cst_sgn (step);
5919 : :
5920 : 11152 : gfc_init_se (&se, NULL);
5921 : 11152 : if (!clauses->non_rectangular
5922 : 12594 : || !gfc_nonrect_loop_expr (pblock, &se, i, orig_code->block->next,
5923 : : code->ext.iterator->start, &inits, simple,
5924 : 1442 : code->ext.iterator->var))
5925 : : {
5926 : 10836 : gfc_conv_expr_val (&se, code->ext.iterator->start);
5927 : 10836 : gfc_add_block_to_block (pblock, &se.pre);
5928 : 10836 : if (!DECL_P (se.expr))
5929 : 10418 : se.expr = gfc_evaluate_now (se.expr, pblock);
5930 : : }
5931 : 11152 : from = se.expr;
5932 : :
5933 : 11152 : gfc_init_se (&se, NULL);
5934 : 11152 : if (!clauses->non_rectangular
5935 : 12594 : || !gfc_nonrect_loop_expr (pblock, &se, i, orig_code->block->next,
5936 : : code->ext.iterator->end, &inits, simple,
5937 : 1442 : code->ext.iterator->var))
5938 : : {
5939 : 10919 : gfc_conv_expr_val (&se, code->ext.iterator->end);
5940 : 10919 : gfc_add_block_to_block (pblock, &se.pre);
5941 : 10919 : if (!DECL_P (se.expr))
5942 : 9686 : se.expr = gfc_evaluate_now (se.expr, pblock);
5943 : : }
5944 : 11152 : to = se.expr;
5945 : :
5946 : 11152 : if (!DECL_P (dovar))
5947 : 38 : dovar_decl
5948 : 38 : = gfc_trans_omp_variable (code->ext.iterator->var->symtree->n.sym,
5949 : : false);
5950 : 11152 : if (simple && !DECL_P (dovar))
5951 : : {
5952 : 38 : const char *name = code->ext.iterator->var->symtree->n.sym->name;
5953 : 38 : local_dovar = gfc_create_var (type, name);
5954 : 38 : dovar_init e = {code->ext.iterator->var->symtree->n.sym,
5955 : 38 : dovar, local_dovar, false};
5956 : 38 : inits.safe_push (e);
5957 : : }
5958 : : /* Loop body. */
5959 : 11152 : if (simple)
5960 : : {
5961 : 10541 : TREE_VEC_ELT (init, i) = build2_v (MODIFY_EXPR, local_dovar, from);
5962 : : /* The condition should not be folded. */
5963 : 11093 : TREE_VEC_ELT (cond, i) = build2_loc (input_location, simple > 0
5964 : : ? LE_EXPR : GE_EXPR,
5965 : : logical_type_node, local_dovar,
5966 : : to);
5967 : 10541 : TREE_VEC_ELT (incr, i) = fold_build2_loc (input_location, PLUS_EXPR,
5968 : : type, local_dovar, step);
5969 : 10541 : TREE_VEC_ELT (incr, i) = fold_build2_loc (input_location,
5970 : : MODIFY_EXPR,
5971 : : type, local_dovar,
5972 : 10541 : TREE_VEC_ELT (incr, i));
5973 : 10541 : if (orig_decls && !clauses->orderedc)
5974 : : orig_decls = NULL;
5975 : 380 : else if (orig_decls)
5976 : 380 : TREE_VEC_ELT (orig_decls, i) = dovar_decl;
5977 : : }
5978 : : else
5979 : : {
5980 : : /* STEP is not 1 or -1. Use:
5981 : : for (count = 0; count < (to + step - from) / step; count++)
5982 : : {
5983 : : dovar = from + count * step;
5984 : : body;
5985 : : cycle_label:;
5986 : : } */
5987 : 611 : tmp = fold_build2_loc (input_location, MINUS_EXPR, type, step, from);
5988 : 611 : tmp = fold_build2_loc (input_location, PLUS_EXPR, type, to, tmp);
5989 : 611 : tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, type, tmp,
5990 : : step);
5991 : 611 : tmp = gfc_evaluate_now (tmp, pblock);
5992 : 611 : local_dovar = gfc_create_var (type, "count");
5993 : 611 : TREE_VEC_ELT (init, i) = build2_v (MODIFY_EXPR, local_dovar,
5994 : : build_int_cst (type, 0));
5995 : : /* The condition should not be folded. */
5996 : 611 : TREE_VEC_ELT (cond, i) = build2_loc (input_location, LT_EXPR,
5997 : : logical_type_node,
5998 : : local_dovar, tmp);
5999 : 611 : TREE_VEC_ELT (incr, i) = fold_build2_loc (input_location, PLUS_EXPR,
6000 : : type, local_dovar,
6001 : 611 : build_int_cst (type, 1));
6002 : 611 : TREE_VEC_ELT (incr, i) = fold_build2_loc (input_location,
6003 : : MODIFY_EXPR, type,
6004 : : local_dovar,
6005 : 611 : TREE_VEC_ELT (incr, i));
6006 : :
6007 : : /* Initialize DOVAR. */
6008 : 611 : tmp = fold_build2_loc (input_location, MULT_EXPR, type, local_dovar,
6009 : : step);
6010 : 611 : tmp = fold_build2_loc (input_location, PLUS_EXPR, type, from, tmp);
6011 : 611 : dovar_init e = {code->ext.iterator->var->symtree->n.sym,
6012 : 611 : dovar, tmp, true};
6013 : 611 : inits.safe_push (e);
6014 : 611 : if (clauses->orderedc)
6015 : : {
6016 : 192 : if (doacross_steps == NULL)
6017 : 47 : vec_safe_grow_cleared (doacross_steps, clauses->orderedc, true);
6018 : 192 : (*doacross_steps)[i] = step;
6019 : : }
6020 : 611 : if (orig_decls)
6021 : 198 : TREE_VEC_ELT (orig_decls, i) = dovar_decl;
6022 : : }
6023 : :
6024 : 11152 : if (dovar_found == 3
6025 : 11152 : && op == EXEC_OMP_SIMD
6026 : 143 : && collapse == 1
6027 : 143 : && local_dovar != dovar)
6028 : : {
6029 : 120 : for (tmp = omp_clauses; tmp; tmp = OMP_CLAUSE_CHAIN (tmp))
6030 : 120 : if (OMP_CLAUSE_CODE (tmp) == OMP_CLAUSE_LINEAR
6031 : 120 : && OMP_CLAUSE_DECL (tmp) == dovar)
6032 : : {
6033 : 30 : OMP_CLAUSE_LINEAR_NO_COPYIN (tmp) = 1;
6034 : 30 : break;
6035 : : }
6036 : : }
6037 : 11152 : if (!dovar_found && op == EXEC_OMP_SIMD)
6038 : : {
6039 : 1355 : if (collapse == 1)
6040 : : {
6041 : 786 : tmp = build_omp_clause (input_location, OMP_CLAUSE_LINEAR);
6042 : 786 : OMP_CLAUSE_LINEAR_STEP (tmp) = step;
6043 : 786 : OMP_CLAUSE_LINEAR_NO_COPYIN (tmp) = 1;
6044 : 786 : OMP_CLAUSE_DECL (tmp) = dovar_decl;
6045 : 786 : omp_clauses = gfc_trans_add_clause (tmp, omp_clauses);
6046 : 786 : if (local_dovar != dovar)
6047 : : dovar_found = 3;
6048 : : }
6049 : : }
6050 : 9797 : else if (!dovar_found && local_dovar != dovar)
6051 : : {
6052 : 280 : tmp = build_omp_clause (input_location, OMP_CLAUSE_PRIVATE);
6053 : 280 : OMP_CLAUSE_DECL (tmp) = dovar_decl;
6054 : 280 : omp_clauses = gfc_trans_add_clause (tmp, omp_clauses);
6055 : : }
6056 : 11122 : if (dovar_found > 1)
6057 : : {
6058 : 1550 : tree c = NULL;
6059 : :
6060 : 1550 : tmp = NULL;
6061 : 1550 : if (local_dovar != dovar)
6062 : : {
6063 : : /* If dovar is lastprivate, but different counter is used,
6064 : : dovar += step needs to be added to
6065 : : OMP_CLAUSE_LASTPRIVATE_STMT, otherwise the copied dovar
6066 : : will have the value on entry of the last loop, rather
6067 : : than value after iterator increment. */
6068 : 243 : if (clauses->orderedc)
6069 : : {
6070 : 60 : if (clauses->collapse <= 1 || i >= clauses->collapse)
6071 : : tmp = local_dovar;
6072 : : else
6073 : 36 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
6074 : : type, local_dovar,
6075 : : build_one_cst (type));
6076 : 60 : tmp = fold_build2_loc (input_location, MULT_EXPR, type,
6077 : : tmp, step);
6078 : 60 : tmp = fold_build2_loc (input_location, PLUS_EXPR, type,
6079 : : from, tmp);
6080 : : }
6081 : : else
6082 : 183 : tmp = fold_build2_loc (input_location, PLUS_EXPR, type,
6083 : : dovar, step);
6084 : 243 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, type,
6085 : : dovar, tmp);
6086 : 934 : for (c = omp_clauses; c ; c = OMP_CLAUSE_CHAIN (c))
6087 : 613 : if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_LASTPRIVATE
6088 : 613 : && OMP_CLAUSE_DECL (c) == dovar_decl)
6089 : : {
6090 : 105 : OMP_CLAUSE_LASTPRIVATE_STMT (c) = tmp;
6091 : 105 : break;
6092 : : }
6093 : 508 : else if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_LINEAR
6094 : 508 : && OMP_CLAUSE_DECL (c) == dovar_decl)
6095 : : {
6096 : 60 : OMP_CLAUSE_LINEAR_STMT (c) = tmp;
6097 : 60 : break;
6098 : : }
6099 : : }
6100 : 1550 : if (c == NULL && op == EXEC_OMP_DO && par_clauses != NULL)
6101 : : {
6102 : 892 : for (c = par_clauses; c ; c = OMP_CLAUSE_CHAIN (c))
6103 : 892 : if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_LASTPRIVATE
6104 : 892 : && OMP_CLAUSE_DECL (c) == dovar_decl)
6105 : : {
6106 : 406 : tree l = build_omp_clause (input_location,
6107 : : OMP_CLAUSE_LASTPRIVATE);
6108 : 406 : if (OMP_CLAUSE_LASTPRIVATE_CONDITIONAL (c))
6109 : 4 : OMP_CLAUSE_LASTPRIVATE_CONDITIONAL (l) = 1;
6110 : 406 : OMP_CLAUSE_DECL (l) = dovar_decl;
6111 : 406 : OMP_CLAUSE_CHAIN (l) = omp_clauses;
6112 : 406 : OMP_CLAUSE_LASTPRIVATE_STMT (l) = tmp;
6113 : 406 : omp_clauses = l;
6114 : 406 : OMP_CLAUSE_SET_CODE (c, OMP_CLAUSE_SHARED);
6115 : 406 : break;
6116 : : }
6117 : : }
6118 : 1550 : gcc_assert (local_dovar == dovar || c != NULL);
6119 : : }
6120 : 11152 : if (local_dovar != dovar)
6121 : : {
6122 : 649 : if (op != EXEC_OMP_SIMD || dovar_found == 1)
6123 : 570 : tmp = build_omp_clause (input_location, OMP_CLAUSE_PRIVATE);
6124 : 79 : else if (collapse == 1)
6125 : : {
6126 : 60 : tmp = build_omp_clause (input_location, OMP_CLAUSE_LINEAR);
6127 : 60 : OMP_CLAUSE_LINEAR_STEP (tmp) = build_int_cst (type, 1);
6128 : 60 : OMP_CLAUSE_LINEAR_NO_COPYIN (tmp) = 1;
6129 : 60 : OMP_CLAUSE_LINEAR_NO_COPYOUT (tmp) = 1;
6130 : : }
6131 : : else
6132 : 19 : tmp = build_omp_clause (input_location, OMP_CLAUSE_LASTPRIVATE);
6133 : 649 : OMP_CLAUSE_DECL (tmp) = local_dovar;
6134 : 649 : omp_clauses = gfc_trans_add_clause (tmp, omp_clauses);
6135 : : }
6136 : :
6137 : 11152 : if (i + 1 < collapse)
6138 : 2447 : code = code->block->next;
6139 : : }
6140 : :
6141 : 9002 : if (pblock != &block)
6142 : : {
6143 : 3276 : pushlevel ();
6144 : 3276 : gfc_start_block (&block);
6145 : : }
6146 : :
6147 : 9002 : gfc_start_block (&body);
6148 : :
6149 : 18653 : FOR_EACH_VEC_ELT (inits, ix, di)
6150 : 649 : gfc_add_modify (&body, di->var, di->init);
6151 : 9002 : inits.release ();
6152 : :
6153 : : /* Cycle statement is implemented with a goto. Exit statement must not be
6154 : : present for this loop. */
6155 : 9002 : cycle_label = gfc_build_label_decl (NULL_TREE);
6156 : :
6157 : : /* Put these labels where they can be found later. */
6158 : :
6159 : 9002 : code->cycle_label = cycle_label;
6160 : 9002 : code->exit_label = NULL_TREE;
6161 : :
6162 : : /* Main loop body. */
6163 : 9002 : if (clauses->lists[OMP_LIST_REDUCTION_INSCAN])
6164 : : {
6165 : 16 : gfc_code *code1, *scan, *code2, *tmpcode;
6166 : 16 : code1 = tmpcode = code->block->next;
6167 : 16 : if (tmpcode && tmpcode->op != EXEC_OMP_SCAN)
6168 : 18 : while (tmpcode && tmpcode->next && tmpcode->next->op != EXEC_OMP_SCAN)
6169 : : tmpcode = tmpcode->next;
6170 : 16 : scan = tmpcode->op == EXEC_OMP_SCAN ? tmpcode : tmpcode->next;
6171 : 16 : if (code1 != scan)
6172 : 16 : tmpcode->next = NULL;
6173 : 16 : code2 = scan->next;
6174 : 16 : gcc_assert (scan->op == EXEC_OMP_SCAN);
6175 : 16 : location_t loc = gfc_get_location (&scan->loc);
6176 : :
6177 : 16 : tmp = code1 != scan ? gfc_trans_code (code1) : build_empty_stmt (loc);
6178 : 16 : tmp = build2 (OMP_SCAN, void_type_node, tmp, NULL_TREE);
6179 : 16 : SET_EXPR_LOCATION (tmp, loc);
6180 : 16 : gfc_add_expr_to_block (&body, tmp);
6181 : 16 : input_location = loc;
6182 : 16 : tree c = gfc_trans_omp_clauses (&body, scan->ext.omp_clauses, scan->loc);
6183 : 16 : tmp = code2 ? gfc_trans_code (code2) : build_empty_stmt (loc);
6184 : 16 : tmp = build2 (OMP_SCAN, void_type_node, tmp, c);
6185 : 16 : SET_EXPR_LOCATION (tmp, loc);
6186 : 16 : if (code1 != scan)
6187 : 16 : tmpcode->next = scan;
6188 : : }
6189 : 8986 : else if (code->op == EXEC_OMP_TILE || code->op == EXEC_OMP_UNROLL)
6190 : 297 : tmp = gfc_trans_omp_code (code, true);
6191 : : else
6192 : 8689 : tmp = gfc_trans_omp_code (code->block->next, true);
6193 : 9002 : gfc_add_expr_to_block (&body, tmp);
6194 : :
6195 : : /* Label for cycle statements (if needed). */
6196 : 9002 : if (TREE_USED (cycle_label))
6197 : : {
6198 : 9002 : tmp = build1_v (LABEL_EXPR, cycle_label);
6199 : 9002 : gfc_add_expr_to_block (&body, tmp);
6200 : : }
6201 : :
6202 : : /* End of loop body. */
6203 : 9002 : switch (op)
6204 : : {
6205 : 1461 : case EXEC_OMP_SIMD: stmt = make_node (OMP_SIMD); break;
6206 : 2337 : case EXEC_OMP_DO: stmt = make_node (OMP_FOR); break;
6207 : 80 : case EXEC_OMP_DISTRIBUTE: stmt = make_node (OMP_DISTRIBUTE); break;
6208 : 98 : case EXEC_OMP_LOOP: stmt = make_node (OMP_LOOP); break;
6209 : 114 : case EXEC_OMP_TASKLOOP: stmt = make_node (OMP_TASKLOOP); break;
6210 : 4460 : case EXEC_OACC_LOOP: stmt = make_node (OACC_LOOP); break;
6211 : 120 : case EXEC_OMP_TILE: stmt = make_node (OMP_TILE); break;
6212 : 332 : case EXEC_OMP_UNROLL: stmt = make_node (OMP_UNROLL); break;
6213 : 0 : default: gcc_unreachable ();
6214 : : }
6215 : :
6216 : 9002 : SET_EXPR_LOCATION (stmt, gfc_get_location (&orig_code->loc));
6217 : 9002 : TREE_TYPE (stmt) = void_type_node;
6218 : 9002 : OMP_FOR_BODY (stmt) = gfc_finish_block (&body);
6219 : 9002 : OMP_FOR_CLAUSES (stmt) = omp_clauses;
6220 : 9002 : OMP_FOR_INIT (stmt) = init;
6221 : 9002 : OMP_FOR_COND (stmt) = cond;
6222 : 9002 : OMP_FOR_INCR (stmt) = incr;
6223 : 9002 : if (orig_decls)
6224 : 138 : OMP_FOR_ORIG_DECLS (stmt) = orig_decls;
6225 : 9002 : OMP_FOR_NON_RECTANGULAR (stmt) = clauses->non_rectangular;
6226 : 9002 : gfc_add_expr_to_block (&block, stmt);
6227 : :
6228 : 9002 : vec_free (doacross_steps);
6229 : 9002 : doacross_steps = saved_doacross_steps;
6230 : :
6231 : 9002 : return gfc_finish_block (&block);
6232 : : }
6233 : :
6234 : : /* Translate combined OpenACC 'parallel loop', 'kernels loop', 'serial loop'
6235 : : construct. */
6236 : :
6237 : : static tree
6238 : 1374 : gfc_trans_oacc_combined_directive (gfc_code *code)
6239 : : {
6240 : 1374 : stmtblock_t block, *pblock = NULL;
6241 : 1374 : gfc_omp_clauses construct_clauses, loop_clauses;
6242 : 1374 : tree stmt, oacc_clauses = NULL_TREE;
6243 : 1374 : enum tree_code construct_code;
6244 : 1374 : location_t loc = input_location;
6245 : :
6246 : 1374 : switch (code->op)
6247 : : {
6248 : : case EXEC_OACC_PARALLEL_LOOP:
6249 : : construct_code = OACC_PARALLEL;
6250 : : break;
6251 : : case EXEC_OACC_KERNELS_LOOP:
6252 : : construct_code = OACC_KERNELS;
6253 : : break;
6254 : : case EXEC_OACC_SERIAL_LOOP:
6255 : : construct_code = OACC_SERIAL;
6256 : : break;
6257 : 0 : default:
6258 : 0 : gcc_unreachable ();
6259 : : }
6260 : :
6261 : 1374 : gfc_start_block (&block);
6262 : :
6263 : 1374 : memset (&loop_clauses, 0, sizeof (loop_clauses));
6264 : 1374 : if (code->ext.omp_clauses != NULL)
6265 : : {
6266 : 1374 : memcpy (&construct_clauses, code->ext.omp_clauses,
6267 : : sizeof (construct_clauses));
6268 : 1374 : loop_clauses.collapse = construct_clauses.collapse;
6269 : 1374 : loop_clauses.gang = construct_clauses.gang;
6270 : 1374 : loop_clauses.gang_static = construct_clauses.gang_static;
6271 : 1374 : loop_clauses.gang_num_expr = construct_clauses.gang_num_expr;
6272 : 1374 : loop_clauses.gang_static_expr = construct_clauses.gang_static_expr;
6273 : 1374 : loop_clauses.vector = construct_clauses.vector;
6274 : 1374 : loop_clauses.vector_expr = construct_clauses.vector_expr;
6275 : 1374 : loop_clauses.worker = construct_clauses.worker;
6276 : 1374 : loop_clauses.worker_expr = construct_clauses.worker_expr;
6277 : 1374 : loop_clauses.seq = construct_clauses.seq;
6278 : 1374 : loop_clauses.par_auto = construct_clauses.par_auto;
6279 : 1374 : loop_clauses.independent = construct_clauses.independent;
6280 : 1374 : loop_clauses.tile_list = construct_clauses.tile_list;
6281 : 1374 : loop_clauses.lists[OMP_LIST_PRIVATE]
6282 : 1374 : = construct_clauses.lists[OMP_LIST_PRIVATE];
6283 : 1374 : loop_clauses.lists[OMP_LIST_REDUCTION]
6284 : 1374 : = construct_clauses.lists[OMP_LIST_REDUCTION];
6285 : 1374 : construct_clauses.gang = false;
6286 : 1374 : construct_clauses.gang_static = false;
6287 : 1374 : construct_clauses.gang_num_expr = NULL;
6288 : 1374 : construct_clauses.gang_static_expr = NULL;
6289 : 1374 : construct_clauses.vector = false;
6290 : 1374 : construct_clauses.vector_expr = NULL;
6291 : 1374 : construct_clauses.worker = false;
6292 : 1374 : construct_clauses.worker_expr = NULL;
6293 : 1374 : construct_clauses.seq = false;
6294 : 1374 : construct_clauses.par_auto = false;
6295 : 1374 : construct_clauses.independent = false;
6296 : 1374 : construct_clauses.independent = false;
6297 : 1374 : construct_clauses.tile_list = NULL;
6298 : 1374 : construct_clauses.lists[OMP_LIST_PRIVATE] = NULL;
6299 : 1374 : if (construct_code == OACC_KERNELS)
6300 : 86 : construct_clauses.lists[OMP_LIST_REDUCTION] = NULL;
6301 : 1374 : oacc_clauses = gfc_trans_omp_clauses (&block, &construct_clauses,
6302 : : code->loc, false, true);
6303 : : }
6304 : 1374 : if (!loop_clauses.seq)
6305 : : pblock = █
6306 : : else
6307 : 31 : pushlevel ();
6308 : 1374 : stmt = gfc_trans_omp_do (code, EXEC_OACC_LOOP, pblock, &loop_clauses, NULL);
6309 : 1374 : protected_set_expr_location (stmt, loc);
6310 : 1374 : if (TREE_CODE (stmt) != BIND_EXPR)
6311 : 1374 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
6312 : : else
6313 : 0 : poplevel (0, 0);
6314 : 1374 : stmt = build2_loc (loc, construct_code, void_type_node, stmt, oacc_clauses);
6315 : 1374 : gfc_add_expr_to_block (&block, stmt);
6316 : 1374 : return gfc_finish_block (&block);
6317 : : }
6318 : :
6319 : : static tree
6320 : 106 : gfc_trans_omp_depobj (gfc_code *code)
6321 : : {
6322 : 106 : stmtblock_t block;
6323 : 106 : gfc_se se;
6324 : 106 : gfc_init_se (&se, NULL);
6325 : 106 : gfc_init_block (&block);
6326 : 106 : gfc_conv_expr (&se, code->ext.omp_clauses->depobj);
6327 : 106 : gcc_assert (se.pre.head == NULL && se.post.head == NULL);
6328 : 106 : tree depobj = se.expr;
6329 : 106 : location_t loc = EXPR_LOCATION (depobj);
6330 : 106 : if (!POINTER_TYPE_P (TREE_TYPE (depobj)))
6331 : 106 : depobj = gfc_build_addr_expr (NULL, depobj);
6332 : 106 : depobj = fold_convert (build_pointer_type_for_mode (ptr_type_node,
6333 : : TYPE_MODE (ptr_type_node),
6334 : : true), depobj);
6335 : 106 : gfc_omp_namelist *n = code->ext.omp_clauses->lists[OMP_LIST_DEPEND];
6336 : 106 : if (n)
6337 : : {
6338 : 82 : tree var;
6339 : 82 : if (!n->sym) /* omp_all_memory. */
6340 : 3 : var = null_pointer_node;
6341 : 79 : else if (n->expr && n->expr->ref->u.ar.type != AR_FULL)
6342 : : {
6343 : 18 : gfc_init_se (&se, NULL);
6344 : 18 : if (n->expr->ref->u.ar.type == AR_ELEMENT)
6345 : : {
6346 : 18 : gfc_conv_expr_reference (&se, n->expr);
6347 : 18 : var = se.expr;
6348 : : }
6349 : : else
6350 : : {
6351 : 0 : gfc_conv_expr_descriptor (&se, n->expr);
6352 : 0 : var = gfc_conv_array_data (se.expr);
6353 : : }
6354 : 18 : gfc_add_block_to_block (&block, &se.pre);
6355 : 18 : gfc_add_block_to_block (&block, &se.post);
6356 : 18 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (var)));
6357 : : }
6358 : : else
6359 : : {
6360 : 61 : var = gfc_get_symbol_decl (n->sym);
6361 : 98 : if (POINTER_TYPE_P (TREE_TYPE (var))
6362 : 71 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (var))))
6363 : 8 : var = build_fold_indirect_ref (var);
6364 : 61 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (var)))
6365 : : {
6366 : 12 : var = gfc_conv_descriptor_data_get (var);
6367 : 12 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (var)));
6368 : : }
6369 : 49 : else if ((n->sym->attr.allocatable || n->sym->attr.pointer)
6370 : 13 : && n->sym->attr.dummy)
6371 : 8 : var = build_fold_indirect_ref (var);
6372 : 66 : else if (!POINTER_TYPE_P (TREE_TYPE (var))
6373 : 43 : || (n->sym->ts.f90_type == BT_VOID
6374 : 11 : && !POINTER_TYPE_P (TREE_TYPE (TREE_TYPE (var)))
6375 : 7 : && !GFC_ARRAY_TYPE_P (TREE_TYPE (TREE_TYPE (var)))))
6376 : : {
6377 : 28 : TREE_ADDRESSABLE (var) = 1;
6378 : 28 : var = gfc_build_addr_expr (NULL, var);
6379 : : }
6380 : : }
6381 : 82 : depobj = save_expr (depobj);
6382 : 82 : tree r = build_fold_indirect_ref_loc (loc, depobj);
6383 : 82 : gfc_add_expr_to_block (&block,
6384 : : build2 (MODIFY_EXPR, void_type_node, r, var));
6385 : : }
6386 : :
6387 : : /* Only one may be set. */
6388 : 106 : gcc_assert (((int)(n != NULL) + (int)(code->ext.omp_clauses->destroy)
6389 : : + (int)(code->ext.omp_clauses->depobj_update != OMP_DEPEND_UNSET))
6390 : : == 1);
6391 : 106 : int k = -1; /* omp_clauses->destroy */
6392 : 106 : if (!code->ext.omp_clauses->destroy)
6393 : 91 : switch (code->ext.omp_clauses->depobj_update != OMP_DEPEND_UNSET
6394 : 91 : ? code->ext.omp_clauses->depobj_update : n->u.depend_doacross_op)
6395 : : {
6396 : : case OMP_DEPEND_IN: k = GOMP_DEPEND_IN; break;
6397 : : case OMP_DEPEND_OUT: k = GOMP_DEPEND_OUT; break;
6398 : : case OMP_DEPEND_INOUT: k = GOMP_DEPEND_INOUT; break;
6399 : : case OMP_DEPEND_INOUTSET: k = GOMP_DEPEND_INOUTSET; break;
6400 : : case OMP_DEPEND_MUTEXINOUTSET: k = GOMP_DEPEND_MUTEXINOUTSET; break;
6401 : 0 : default: gcc_unreachable ();
6402 : : }
6403 : 106 : tree t = build_int_cst (ptr_type_node, k);
6404 : 106 : depobj = build2_loc (loc, POINTER_PLUS_EXPR, TREE_TYPE (depobj), depobj,
6405 : 106 : TYPE_SIZE_UNIT (ptr_type_node));
6406 : 106 : depobj = build_fold_indirect_ref_loc (loc, depobj);
6407 : 106 : gfc_add_expr_to_block (&block, build2 (MODIFY_EXPR, void_type_node, depobj, t));
6408 : :
6409 : 106 : return gfc_finish_block (&block);
6410 : : }
6411 : :
6412 : : static tree
6413 : 18 : gfc_trans_omp_error (gfc_code *code)
6414 : : {
6415 : 18 : stmtblock_t block;
6416 : 18 : gfc_se se;
6417 : 18 : tree len, message;
6418 : 18 : bool fatal = code->ext.omp_clauses->severity == OMP_SEVERITY_FATAL;
6419 : 31 : tree fndecl = builtin_decl_explicit (fatal ? BUILT_IN_GOMP_ERROR
6420 : : : BUILT_IN_GOMP_WARNING);
6421 : 18 : gfc_start_block (&block);
6422 : 18 : gfc_init_se (&se, NULL );
6423 : 18 : if (!code->ext.omp_clauses->message)
6424 : : {
6425 : 3 : message = null_pointer_node;
6426 : 3 : len = build_int_cst (size_type_node, 0);
6427 : : }
6428 : : else
6429 : : {
6430 : 15 : gfc_conv_expr (&se, code->ext.omp_clauses->message);
6431 : 15 : message = se.expr;
6432 : 15 : if (!POINTER_TYPE_P (TREE_TYPE (message)))
6433 : : /* To ensure an ARRAY_TYPE is not passed as such. */
6434 : 6 : message = gfc_build_addr_expr (NULL, message);
6435 : 15 : len = se.string_length;
6436 : : }
6437 : 18 : gfc_add_block_to_block (&block, &se.pre);
6438 : 18 : gfc_add_expr_to_block (&block, build_call_expr_loc (input_location, fndecl,
6439 : : 2, message, len));
6440 : 18 : gfc_add_block_to_block (&block, &se.post);
6441 : 18 : return gfc_finish_block (&block);
6442 : : }
6443 : :
6444 : : static tree
6445 : 69 : gfc_trans_omp_flush (gfc_code *code)
6446 : : {
6447 : 69 : tree call;
6448 : 69 : if (!code->ext.omp_clauses
6449 : 4 : || code->ext.omp_clauses->memorder == OMP_MEMORDER_UNSET
6450 : 4 : || code->ext.omp_clauses->memorder == OMP_MEMORDER_SEQ_CST)
6451 : : {
6452 : 66 : call = builtin_decl_explicit (BUILT_IN_SYNC_SYNCHRONIZE);
6453 : 66 : call = build_call_expr_loc (input_location, call, 0);
6454 : : }
6455 : : else
6456 : : {
6457 : 3 : enum memmodel mo = MEMMODEL_LAST;
6458 : 3 : switch (code->ext.omp_clauses->memorder)
6459 : : {
6460 : : case OMP_MEMORDER_ACQ_REL: mo = MEMMODEL_ACQ_REL; break;
6461 : : case OMP_MEMORDER_RELEASE: mo = MEMMODEL_RELEASE; break;
6462 : : case OMP_MEMORDER_ACQUIRE: mo = MEMMODEL_ACQUIRE; break;
6463 : 0 : default: gcc_unreachable (); break;
6464 : : }
6465 : 3 : call = builtin_decl_explicit (BUILT_IN_ATOMIC_THREAD_FENCE);
6466 : 3 : call = build_call_expr_loc (input_location, call, 1,
6467 : 3 : build_int_cst (integer_type_node, mo));
6468 : : }
6469 : 69 : return call;
6470 : : }
6471 : :
6472 : : static tree
6473 : 115 : gfc_trans_omp_master (gfc_code *code)
6474 : : {
6475 : 115 : tree stmt = gfc_trans_code (code->block->next);
6476 : 115 : if (IS_EMPTY_STMT (stmt))
6477 : : return stmt;
6478 : 109 : return build1_v (OMP_MASTER, stmt);
6479 : : }
6480 : :
6481 : : static tree
6482 : 49 : gfc_trans_omp_masked (gfc_code *code, gfc_omp_clauses *clauses)
6483 : : {
6484 : 49 : stmtblock_t block;
6485 : 49 : tree body = gfc_trans_code (code->block->next);
6486 : 49 : if (IS_EMPTY_STMT (body))
6487 : : return body;
6488 : 40 : if (!clauses)
6489 : 33 : clauses = code->ext.omp_clauses;
6490 : 40 : gfc_start_block (&block);
6491 : 40 : tree omp_clauses = gfc_trans_omp_clauses (&block, clauses, code->loc);
6492 : 40 : tree stmt = make_node (OMP_MASKED);
6493 : 40 : SET_EXPR_LOCATION (stmt, gfc_get_location (&code->loc));
6494 : 40 : TREE_TYPE (stmt) = void_type_node;
6495 : 40 : OMP_MASKED_BODY (stmt) = body;
6496 : 40 : OMP_MASKED_CLAUSES (stmt) = omp_clauses;
6497 : 40 : gfc_add_expr_to_block (&block, stmt);
6498 : 40 : return gfc_finish_block (&block);
6499 : : }
6500 : :
6501 : :
6502 : : static tree
6503 : 519 : gfc_trans_omp_ordered (gfc_code *code)
6504 : : {
6505 : 519 : if (!flag_openmp)
6506 : : {
6507 : 5 : if (!code->ext.omp_clauses->simd)
6508 : 3 : return gfc_trans_code (code->block ? code->block->next : NULL);
6509 : 2 : code->ext.omp_clauses->threads = 0;
6510 : : }
6511 : 516 : tree omp_clauses = gfc_trans_omp_clauses (NULL, code->ext.omp_clauses,
6512 : : code->loc);
6513 : 516 : return build2_loc (input_location, OMP_ORDERED, void_type_node,
6514 : 516 : code->block ? gfc_trans_code (code->block->next)
6515 : 516 : : NULL_TREE, omp_clauses);
6516 : : }
6517 : :
6518 : : static tree
6519 : 1851 : gfc_trans_omp_parallel (gfc_code *code)
6520 : : {
6521 : 1851 : stmtblock_t block;
6522 : 1851 : tree stmt, omp_clauses;
6523 : :
6524 : 1851 : gfc_start_block (&block);
6525 : 1851 : omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
6526 : : code->loc);
6527 : 1851 : pushlevel ();
6528 : 1851 : stmt = gfc_trans_omp_code (code->block->next, true);
6529 : 1851 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
6530 : 1851 : stmt = build2_loc (input_location, OMP_PARALLEL, void_type_node, stmt,
6531 : : omp_clauses);
6532 : 1851 : gfc_add_expr_to_block (&block, stmt);
6533 : 1851 : return gfc_finish_block (&block);
6534 : : }
6535 : :
6536 : : enum
6537 : : {
6538 : : GFC_OMP_SPLIT_SIMD,
6539 : : GFC_OMP_SPLIT_DO,
6540 : : GFC_OMP_SPLIT_PARALLEL,
6541 : : GFC_OMP_SPLIT_DISTRIBUTE,
6542 : : GFC_OMP_SPLIT_TEAMS,
6543 : : GFC_OMP_SPLIT_TARGET,
6544 : : GFC_OMP_SPLIT_TASKLOOP,
6545 : : GFC_OMP_SPLIT_MASKED,
6546 : : GFC_OMP_SPLIT_NUM
6547 : : };
6548 : :
6549 : : enum
6550 : : {
6551 : : GFC_OMP_MASK_SIMD = (1 << GFC_OMP_SPLIT_SIMD),
6552 : : GFC_OMP_MASK_DO = (1 << GFC_OMP_SPLIT_DO),
6553 : : GFC_OMP_MASK_PARALLEL = (1 << GFC_OMP_SPLIT_PARALLEL),
6554 : : GFC_OMP_MASK_DISTRIBUTE = (1 << GFC_OMP_SPLIT_DISTRIBUTE),
6555 : : GFC_OMP_MASK_TEAMS = (1 << GFC_OMP_SPLIT_TEAMS),
6556 : : GFC_OMP_MASK_TARGET = (1 << GFC_OMP_SPLIT_TARGET),
6557 : : GFC_OMP_MASK_TASKLOOP = (1 << GFC_OMP_SPLIT_TASKLOOP),
6558 : : GFC_OMP_MASK_MASKED = (1 << GFC_OMP_SPLIT_MASKED)
6559 : : };
6560 : :
6561 : : /* If a var is in lastprivate/firstprivate/reduction but not in a
6562 : : data mapping/sharing clause, add it to 'map(tofrom:' if is_target
6563 : : and to 'shared' otherwise. */
6564 : : static void
6565 : 2426 : gfc_add_clause_implicitly (gfc_omp_clauses *clauses_out,
6566 : : gfc_omp_clauses *clauses_in,
6567 : : bool is_target, bool is_parallel_do)
6568 : : {
6569 : 2426 : int clauselist_to_add = is_target ? OMP_LIST_MAP : OMP_LIST_SHARED;
6570 : 2426 : gfc_omp_namelist *tail = NULL;
6571 : 14556 : for (int i = 0; i < 5; ++i)
6572 : : {
6573 : 12130 : gfc_omp_namelist *n;
6574 : 12130 : switch (i)
6575 : : {
6576 : 2426 : case 0: n = clauses_in->lists[OMP_LIST_FIRSTPRIVATE]; break;
6577 : 2426 : case 1: n = clauses_in->lists[OMP_LIST_LASTPRIVATE]; break;
6578 : 2426 : case 2: n = clauses_in->lists[OMP_LIST_REDUCTION]; break;
6579 : 2426 : case 3: n = clauses_in->lists[OMP_LIST_REDUCTION_INSCAN]; break;
6580 : 2426 : case 4: n = clauses_in->lists[OMP_LIST_REDUCTION_TASK]; break;
6581 : : default: gcc_unreachable ();
6582 : : }
6583 : 15471 : for (; n != NULL; n = n->next)
6584 : : {
6585 : : gfc_omp_namelist *n2, **n_firstp = NULL, **n_lastp = NULL;
6586 : 20677 : for (int j = 0; j < 6; ++j)
6587 : : {
6588 : 18208 : gfc_omp_namelist **n2ref = NULL, *prev2 = NULL;
6589 : 18208 : switch (j)
6590 : : {
6591 : 3341 : case 0:
6592 : 3341 : n2ref = &clauses_out->lists[clauselist_to_add];
6593 : 3341 : break;
6594 : 3305 : case 1:
6595 : 3305 : n2ref = &clauses_out->lists[OMP_LIST_FIRSTPRIVATE];
6596 : 3305 : break;
6597 : 3305 : case 2:
6598 : 3305 : if (is_target)
6599 : 255 : n2ref = &clauses_in->lists[OMP_LIST_LASTPRIVATE];
6600 : : else
6601 : 3050 : n2ref = &clauses_out->lists[OMP_LIST_LASTPRIVATE];
6602 : : break;
6603 : 3305 : case 3: n2ref = &clauses_out->lists[OMP_LIST_REDUCTION]; break;
6604 : 2476 : case 4:
6605 : 2476 : n2ref = &clauses_out->lists[OMP_LIST_REDUCTION_INSCAN];
6606 : 2476 : break;
6607 : 2476 : case 5:
6608 : 2476 : n2ref = &clauses_out->lists[OMP_LIST_REDUCTION_TASK];
6609 : 2476 : break;
6610 : : default: gcc_unreachable ();
6611 : : }
6612 : 28482 : for (n2 = *n2ref; n2 != NULL; prev2 = n2, n2 = n2->next)
6613 : 13540 : if (n2->sym == n->sym)
6614 : : break;
6615 : 18208 : if (n2)
6616 : : {
6617 : 3266 : if (j == 0 /* clauselist_to_add */)
6618 : : break; /* Already present. */
6619 : 3230 : if (j == 1 /* OMP_LIST_FIRSTPRIVATE */)
6620 : : {
6621 : 1128 : n_firstp = prev2 ? &prev2->next : n2ref;
6622 : 1128 : continue;
6623 : : }
6624 : 2102 : if (j == 2 /* OMP_LIST_LASTPRIVATE */)
6625 : : {
6626 : 1266 : n_lastp = prev2 ? &prev2->next : n2ref;
6627 : 1266 : continue;
6628 : : }
6629 : : break;
6630 : : }
6631 : : }
6632 : 3341 : if (n_firstp && n_lastp)
6633 : : {
6634 : : /* For parallel do, GCC puts firstprivate/lastprivate
6635 : : on the parallel. */
6636 : 283 : if (is_parallel_do)
6637 : 280 : continue;
6638 : 3 : *n_firstp = (*n_firstp)->next;
6639 : 3 : if (!is_target)
6640 : 0 : *n_lastp = (*n_lastp)->next;
6641 : : }
6642 : 3058 : else if (is_target && n_lastp)
6643 : : ;
6644 : 3003 : else if (n2 || n_firstp || n_lastp)
6645 : 2645 : continue;
6646 : 416 : if (clauses_out->lists[clauselist_to_add]
6647 : 305 : && (clauses_out->lists[clauselist_to_add]
6648 : 305 : == clauses_in->lists[clauselist_to_add]))
6649 : : {
6650 : : gfc_omp_namelist *p = NULL;
6651 : 421 : for (n2 = clauses_in->lists[clauselist_to_add]; n2; n2 = n2->next)
6652 : : {
6653 : 273 : if (p)
6654 : : {
6655 : 125 : p->next = gfc_get_omp_namelist ();
6656 : 125 : p = p->next;
6657 : : }
6658 : : else
6659 : : {
6660 : 148 : p = gfc_get_omp_namelist ();
6661 : 148 : clauses_out->lists[clauselist_to_add] = p;
6662 : : }
6663 : 273 : *p = *n2;
6664 : : }
6665 : : }
6666 : 416 : if (!tail)
6667 : : {
6668 : 287 : tail = clauses_out->lists[clauselist_to_add];
6669 : 412 : for (; tail && tail->next; tail = tail->next)
6670 : : ;
6671 : : }
6672 : 416 : n2 = gfc_get_omp_namelist ();
6673 : 416 : n2->where = n->where;
6674 : 416 : n2->sym = n->sym;
6675 : 416 : if (is_target)
6676 : 119 : n2->u.map.op = OMP_MAP_TOFROM;
6677 : 416 : if (tail)
6678 : : {
6679 : 305 : tail->next = n2;
6680 : 305 : tail = n2;
6681 : : }
6682 : : else
6683 : 111 : clauses_out->lists[clauselist_to_add] = n2;
6684 : : }
6685 : : }
6686 : 2426 : }
6687 : :
6688 : : /* Kind of opposite to above, add firstprivate to CLAUSES_OUT if it is mapped
6689 : : in CLAUSES_IN's FIRSTPRIVATE list but not its MAP list. */
6690 : :
6691 : : static void
6692 : 314 : gfc_add_firstprivate_if_unmapped (gfc_omp_clauses *clauses_out,
6693 : : gfc_omp_clauses *clauses_in)
6694 : : {
6695 : 314 : gfc_omp_namelist *n = clauses_in->lists[OMP_LIST_FIRSTPRIVATE];
6696 : 314 : gfc_omp_namelist **tail = NULL;
6697 : :
6698 : 464 : for (; n != NULL; n = n->next)
6699 : : {
6700 : 150 : gfc_omp_namelist *n2 = clauses_out->lists[OMP_LIST_MAP];
6701 : 192 : for (; n2 != NULL; n2 = n2->next)
6702 : 53 : if (n->sym == n2->sym)
6703 : : break;
6704 : 150 : if (n2 == NULL)
6705 : : {
6706 : 139 : gfc_omp_namelist *dup = gfc_get_omp_namelist ();
6707 : 139 : *dup = *n;
6708 : 139 : dup->next = NULL;
6709 : 139 : if (!tail)
6710 : : {
6711 : 76 : tail = &clauses_out->lists[OMP_LIST_FIRSTPRIVATE];
6712 : 76 : while (*tail && (*tail)->next)
6713 : 0 : tail = &(*tail)->next;
6714 : : }
6715 : 139 : *tail = dup;
6716 : 139 : tail = &(*tail)->next;
6717 : : }
6718 : : }
6719 : 314 : }
6720 : :
6721 : : static void
6722 : 3840 : gfc_free_split_omp_clauses (gfc_code *code, gfc_omp_clauses *clausesa)
6723 : : {
6724 : 34560 : for (int i = 0; i < GFC_OMP_SPLIT_NUM; ++i)
6725 : 1136640 : for (int j = 0; j < OMP_LIST_NUM; ++j)
6726 : 1105920 : if (clausesa[i].lists[j] && clausesa[i].lists[j] != code->ext.omp_clauses->lists[j])
6727 : 1397 : for (gfc_omp_namelist *n = clausesa[i].lists[j]; n;)
6728 : : {
6729 : 956 : gfc_omp_namelist *p = n;
6730 : 956 : n = n->next;
6731 : 956 : free (p);
6732 : : }
6733 : 3840 : }
6734 : :
6735 : : static void
6736 : 3840 : gfc_split_omp_clauses (gfc_code *code,
6737 : : gfc_omp_clauses clausesa[GFC_OMP_SPLIT_NUM])
6738 : : {
6739 : 3840 : int mask = 0, innermost = 0;
6740 : 3840 : bool is_loop = false;
6741 : 3840 : memset (clausesa, 0, GFC_OMP_SPLIT_NUM * sizeof (gfc_omp_clauses));
6742 : 3840 : switch (code->op)
6743 : : {
6744 : : case EXEC_OMP_DISTRIBUTE:
6745 : : innermost = GFC_OMP_SPLIT_DISTRIBUTE;
6746 : : break;
6747 : 30 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
6748 : 30 : mask = GFC_OMP_MASK_DISTRIBUTE | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO;
6749 : 30 : innermost = GFC_OMP_SPLIT_DO;
6750 : 30 : break;
6751 : 28 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
6752 : 28 : mask = GFC_OMP_MASK_DISTRIBUTE | GFC_OMP_MASK_PARALLEL
6753 : : | GFC_OMP_MASK_DO | GFC_OMP_MASK_SIMD;
6754 : 28 : innermost = GFC_OMP_SPLIT_SIMD;
6755 : 28 : break;
6756 : 47 : case EXEC_OMP_DISTRIBUTE_SIMD:
6757 : 47 : mask = GFC_OMP_MASK_DISTRIBUTE | GFC_OMP_MASK_SIMD;
6758 : 47 : innermost = GFC_OMP_SPLIT_SIMD;
6759 : 47 : break;
6760 : 0 : case EXEC_OMP_DO:
6761 : 0 : case EXEC_OMP_LOOP:
6762 : 0 : innermost = GFC_OMP_SPLIT_DO;
6763 : 0 : break;
6764 : 126 : case EXEC_OMP_DO_SIMD:
6765 : 126 : mask = GFC_OMP_MASK_DO | GFC_OMP_MASK_SIMD;
6766 : 126 : innermost = GFC_OMP_SPLIT_SIMD;
6767 : 126 : break;
6768 : 0 : case EXEC_OMP_PARALLEL:
6769 : 0 : innermost = GFC_OMP_SPLIT_PARALLEL;
6770 : 0 : break;
6771 : 1080 : case EXEC_OMP_PARALLEL_DO:
6772 : 1080 : case EXEC_OMP_PARALLEL_LOOP:
6773 : 1080 : mask = GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO;
6774 : 1080 : innermost = GFC_OMP_SPLIT_DO;
6775 : 1080 : break;
6776 : 278 : case EXEC_OMP_PARALLEL_DO_SIMD:
6777 : 278 : mask = GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO | GFC_OMP_MASK_SIMD;
6778 : 278 : innermost = GFC_OMP_SPLIT_SIMD;
6779 : 278 : break;
6780 : 11 : case EXEC_OMP_PARALLEL_MASKED:
6781 : 11 : mask = GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_MASKED;
6782 : 11 : innermost = GFC_OMP_SPLIT_MASKED;
6783 : 11 : break;
6784 : 14 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
6785 : 14 : mask = (GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_MASKED
6786 : : | GFC_OMP_MASK_TASKLOOP | GFC_OMP_MASK_SIMD);
6787 : 14 : innermost = GFC_OMP_SPLIT_TASKLOOP;
6788 : 14 : break;
6789 : 20 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
6790 : 20 : mask = GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_TASKLOOP | GFC_OMP_MASK_SIMD;
6791 : 20 : innermost = GFC_OMP_SPLIT_TASKLOOP;
6792 : 20 : break;
6793 : 24 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
6794 : 24 : mask = (GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_MASKED
6795 : : | GFC_OMP_MASK_TASKLOOP | GFC_OMP_MASK_SIMD);
6796 : 24 : innermost = GFC_OMP_SPLIT_SIMD;
6797 : 24 : break;
6798 : 28 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
6799 : 28 : mask = GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_TASKLOOP | GFC_OMP_MASK_SIMD;
6800 : 28 : innermost = GFC_OMP_SPLIT_SIMD;
6801 : 28 : break;
6802 : 0 : case EXEC_OMP_SIMD:
6803 : 0 : innermost = GFC_OMP_SPLIT_SIMD;
6804 : 0 : break;
6805 : 1498 : case EXEC_OMP_TARGET:
6806 : 1498 : innermost = GFC_OMP_SPLIT_TARGET;
6807 : 1498 : break;
6808 : 20 : case EXEC_OMP_TARGET_PARALLEL:
6809 : 20 : mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_PARALLEL;
6810 : 20 : innermost = GFC_OMP_SPLIT_PARALLEL;
6811 : 20 : break;
6812 : 70 : case EXEC_OMP_TARGET_PARALLEL_DO:
6813 : 70 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
6814 : 70 : mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO;
6815 : 70 : innermost = GFC_OMP_SPLIT_DO;
6816 : 70 : break;
6817 : 15 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
6818 : 15 : mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO
6819 : : | GFC_OMP_MASK_SIMD;
6820 : 15 : innermost = GFC_OMP_SPLIT_SIMD;
6821 : 15 : break;
6822 : 26 : case EXEC_OMP_TARGET_SIMD:
6823 : 26 : mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_SIMD;
6824 : 26 : innermost = GFC_OMP_SPLIT_SIMD;
6825 : 26 : break;
6826 : 63 : case EXEC_OMP_TARGET_TEAMS:
6827 : 63 : mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS;
6828 : 63 : innermost = GFC_OMP_SPLIT_TEAMS;
6829 : 63 : break;
6830 : 14 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
6831 : 14 : mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS
6832 : : | GFC_OMP_MASK_DISTRIBUTE;
6833 : 14 : innermost = GFC_OMP_SPLIT_DISTRIBUTE;
6834 : 14 : break;
6835 : 49 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
6836 : 49 : mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE
6837 : : | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO;
6838 : 49 : innermost = GFC_OMP_SPLIT_DO;
6839 : 49 : break;
6840 : 29 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
6841 : 29 : mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE
6842 : : | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO | GFC_OMP_MASK_SIMD;
6843 : 29 : innermost = GFC_OMP_SPLIT_SIMD;
6844 : 29 : break;
6845 : 16 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
6846 : 16 : mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS
6847 : : | GFC_OMP_MASK_DISTRIBUTE | GFC_OMP_MASK_SIMD;
6848 : 16 : innermost = GFC_OMP_SPLIT_SIMD;
6849 : 16 : break;
6850 : 12 : case EXEC_OMP_TARGET_TEAMS_LOOP:
6851 : 12 : mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DO;
6852 : 12 : innermost = GFC_OMP_SPLIT_DO;
6853 : 12 : break;
6854 : 8 : case EXEC_OMP_MASKED_TASKLOOP:
6855 : 8 : mask = GFC_OMP_MASK_MASKED | GFC_OMP_MASK_TASKLOOP;
6856 : 8 : innermost = GFC_OMP_SPLIT_TASKLOOP;
6857 : 8 : break;
6858 : 0 : case EXEC_OMP_MASTER_TASKLOOP:
6859 : 0 : case EXEC_OMP_TASKLOOP:
6860 : 0 : innermost = GFC_OMP_SPLIT_TASKLOOP;
6861 : 0 : break;
6862 : 22 : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
6863 : 22 : mask = GFC_OMP_MASK_MASKED | GFC_OMP_MASK_TASKLOOP | GFC_OMP_MASK_SIMD;
6864 : 22 : innermost = GFC_OMP_SPLIT_SIMD;
6865 : 22 : break;
6866 : 46 : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
6867 : 46 : case EXEC_OMP_TASKLOOP_SIMD:
6868 : 46 : mask = GFC_OMP_MASK_TASKLOOP | GFC_OMP_MASK_SIMD;
6869 : 46 : innermost = GFC_OMP_SPLIT_SIMD;
6870 : 46 : break;
6871 : 121 : case EXEC_OMP_TEAMS:
6872 : 121 : innermost = GFC_OMP_SPLIT_TEAMS;
6873 : 121 : break;
6874 : 14 : case EXEC_OMP_TEAMS_DISTRIBUTE:
6875 : 14 : mask = GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE;
6876 : 14 : innermost = GFC_OMP_SPLIT_DISTRIBUTE;
6877 : 14 : break;
6878 : 32 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
6879 : 32 : mask = GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE
6880 : : | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO;
6881 : 32 : innermost = GFC_OMP_SPLIT_DO;
6882 : 32 : break;
6883 : 56 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
6884 : 56 : mask = GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE
6885 : : | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO | GFC_OMP_MASK_SIMD;
6886 : 56 : innermost = GFC_OMP_SPLIT_SIMD;
6887 : 56 : break;
6888 : 37 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
6889 : 37 : mask = GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE | GFC_OMP_MASK_SIMD;
6890 : 37 : innermost = GFC_OMP_SPLIT_SIMD;
6891 : 37 : break;
6892 : : case EXEC_OMP_TEAMS_LOOP:
6893 : : mask = GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DO;
6894 : : innermost = GFC_OMP_SPLIT_DO;
6895 : : break;
6896 : 0 : default:
6897 : 0 : gcc_unreachable ();
6898 : : }
6899 : 3834 : if (mask == 0)
6900 : : {
6901 : 1619 : clausesa[innermost] = *code->ext.omp_clauses;
6902 : 1619 : return;
6903 : : }
6904 : : /* Loops are similar to DO but still a bit different. */
6905 : 2221 : switch (code->op)
6906 : : {
6907 : 39 : case EXEC_OMP_LOOP:
6908 : 39 : case EXEC_OMP_PARALLEL_LOOP:
6909 : 39 : case EXEC_OMP_TEAMS_LOOP:
6910 : 39 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
6911 : 39 : case EXEC_OMP_TARGET_TEAMS_LOOP:
6912 : 39 : is_loop = true;
6913 : 2221 : default:
6914 : 2221 : break;
6915 : : }
6916 : 2221 : if (code->ext.omp_clauses != NULL)
6917 : : {
6918 : 2221 : if (mask & GFC_OMP_MASK_TARGET)
6919 : : {
6920 : : /* First the clauses that are unique to some constructs. */
6921 : 314 : clausesa[GFC_OMP_SPLIT_TARGET].lists[OMP_LIST_MAP]
6922 : 314 : = code->ext.omp_clauses->lists[OMP_LIST_MAP];
6923 : 314 : clausesa[GFC_OMP_SPLIT_TARGET].lists[OMP_LIST_IS_DEVICE_PTR]
6924 : 314 : = code->ext.omp_clauses->lists[OMP_LIST_IS_DEVICE_PTR];
6925 : 314 : clausesa[GFC_OMP_SPLIT_TARGET].lists[OMP_LIST_HAS_DEVICE_ADDR]
6926 : 314 : = code->ext.omp_clauses->lists[OMP_LIST_HAS_DEVICE_ADDR];
6927 : 314 : clausesa[GFC_OMP_SPLIT_TARGET].device
6928 : 314 : = code->ext.omp_clauses->device;
6929 : 314 : clausesa[GFC_OMP_SPLIT_TARGET].thread_limit
6930 : 314 : = code->ext.omp_clauses->thread_limit;
6931 : 314 : clausesa[GFC_OMP_SPLIT_TARGET].lists[OMP_LIST_USES_ALLOCATORS]
6932 : 314 : = code->ext.omp_clauses->lists[OMP_LIST_USES_ALLOCATORS];
6933 : 2198 : for (int i = 0; i < OMP_DEFAULTMAP_CAT_NUM; i++)
6934 : 1884 : clausesa[GFC_OMP_SPLIT_TARGET].defaultmap[i]
6935 : 1884 : = code->ext.omp_clauses->defaultmap[i];
6936 : 314 : clausesa[GFC_OMP_SPLIT_TARGET].if_exprs[OMP_IF_TARGET]
6937 : 314 : = code->ext.omp_clauses->if_exprs[OMP_IF_TARGET];
6938 : : /* And this is copied to all. */
6939 : 314 : clausesa[GFC_OMP_SPLIT_TARGET].if_expr
6940 : 314 : = code->ext.omp_clauses->if_expr;
6941 : 314 : clausesa[GFC_OMP_SPLIT_TARGET].nowait
6942 : 314 : = code->ext.omp_clauses->nowait;
6943 : : }
6944 : 2221 : if (mask & GFC_OMP_MASK_TEAMS)
6945 : : {
6946 : : /* First the clauses that are unique to some constructs. */
6947 : 328 : clausesa[GFC_OMP_SPLIT_TEAMS].num_teams_lower
6948 : 328 : = code->ext.omp_clauses->num_teams_lower;
6949 : 328 : clausesa[GFC_OMP_SPLIT_TEAMS].num_teams_upper
6950 : 328 : = code->ext.omp_clauses->num_teams_upper;
6951 : 328 : clausesa[GFC_OMP_SPLIT_TEAMS].thread_limit
6952 : 328 : = code->ext.omp_clauses->thread_limit;
6953 : : /* Shared and default clauses are allowed on parallel, teams
6954 : : and taskloop. */
6955 : 328 : clausesa[GFC_OMP_SPLIT_TEAMS].lists[OMP_LIST_SHARED]
6956 : 328 : = code->ext.omp_clauses->lists[OMP_LIST_SHARED];
6957 : 328 : clausesa[GFC_OMP_SPLIT_TEAMS].default_sharing
6958 : 328 : = code->ext.omp_clauses->default_sharing;
6959 : : }
6960 : 2221 : if (mask & GFC_OMP_MASK_DISTRIBUTE)
6961 : : {
6962 : : /* First the clauses that are unique to some constructs. */
6963 : 352 : clausesa[GFC_OMP_SPLIT_DISTRIBUTE].dist_sched_kind
6964 : 352 : = code->ext.omp_clauses->dist_sched_kind;
6965 : 352 : clausesa[GFC_OMP_SPLIT_DISTRIBUTE].dist_chunk_size
6966 : 352 : = code->ext.omp_clauses->dist_chunk_size;
6967 : : /* Duplicate collapse. */
6968 : 352 : clausesa[GFC_OMP_SPLIT_DISTRIBUTE].collapse
6969 : 352 : = code->ext.omp_clauses->collapse;
6970 : 352 : clausesa[GFC_OMP_SPLIT_DISTRIBUTE].order_concurrent
6971 : 352 : = code->ext.omp_clauses->order_concurrent;
6972 : 352 : clausesa[GFC_OMP_SPLIT_DISTRIBUTE].order_unconstrained
6973 : 352 : = code->ext.omp_clauses->order_unconstrained;
6974 : 352 : clausesa[GFC_OMP_SPLIT_DISTRIBUTE].order_reproducible
6975 : 352 : = code->ext.omp_clauses->order_reproducible;
6976 : : }
6977 : 2221 : if (mask & GFC_OMP_MASK_PARALLEL)
6978 : : {
6979 : : /* First the clauses that are unique to some constructs. */
6980 : 1784 : clausesa[GFC_OMP_SPLIT_PARALLEL].lists[OMP_LIST_COPYIN]
6981 : 1784 : = code->ext.omp_clauses->lists[OMP_LIST_COPYIN];
6982 : 1784 : clausesa[GFC_OMP_SPLIT_PARALLEL].num_threads
6983 : 1784 : = code->ext.omp_clauses->num_threads;
6984 : 1784 : clausesa[GFC_OMP_SPLIT_PARALLEL].proc_bind
6985 : 1784 : = code->ext.omp_clauses->proc_bind;
6986 : : /* Shared and default clauses are allowed on parallel, teams
6987 : : and taskloop. */
6988 : 1784 : clausesa[GFC_OMP_SPLIT_PARALLEL].lists[OMP_LIST_SHARED]
6989 : 1784 : = code->ext.omp_clauses->lists[OMP_LIST_SHARED];
6990 : 1784 : clausesa[GFC_OMP_SPLIT_PARALLEL].default_sharing
6991 : 1784 : = code->ext.omp_clauses->default_sharing;
6992 : 1784 : clausesa[GFC_OMP_SPLIT_PARALLEL].if_exprs[OMP_IF_PARALLEL]
6993 : 1784 : = code->ext.omp_clauses->if_exprs[OMP_IF_PARALLEL];
6994 : : /* And this is copied to all. */
6995 : 1784 : clausesa[GFC_OMP_SPLIT_PARALLEL].if_expr
6996 : 1784 : = code->ext.omp_clauses->if_expr;
6997 : : }
6998 : 2221 : if (mask & GFC_OMP_MASK_MASKED)
6999 : 79 : clausesa[GFC_OMP_SPLIT_MASKED].filter = code->ext.omp_clauses->filter;
7000 : 2221 : if ((mask & GFC_OMP_MASK_DO) && !is_loop)
7001 : : {
7002 : : /* First the clauses that are unique to some constructs. */
7003 : 1772 : clausesa[GFC_OMP_SPLIT_DO].ordered
7004 : 1772 : = code->ext.omp_clauses->ordered;
7005 : 1772 : clausesa[GFC_OMP_SPLIT_DO].orderedc
7006 : 1772 : = code->ext.omp_clauses->orderedc;
7007 : 1772 : clausesa[GFC_OMP_SPLIT_DO].sched_kind
7008 : 1772 : = code->ext.omp_clauses->sched_kind;
7009 : 1772 : if (innermost == GFC_OMP_SPLIT_SIMD)
7010 : 532 : clausesa[GFC_OMP_SPLIT_DO].sched_simd
7011 : 532 : = code->ext.omp_clauses->sched_simd;
7012 : 1772 : clausesa[GFC_OMP_SPLIT_DO].sched_monotonic
7013 : 1772 : = code->ext.omp_clauses->sched_monotonic;
7014 : 1772 : clausesa[GFC_OMP_SPLIT_DO].sched_nonmonotonic
7015 : 1772 : = code->ext.omp_clauses->sched_nonmonotonic;
7016 : 1772 : clausesa[GFC_OMP_SPLIT_DO].chunk_size
7017 : 1772 : = code->ext.omp_clauses->chunk_size;
7018 : 1772 : clausesa[GFC_OMP_SPLIT_DO].nowait
7019 : 1772 : = code->ext.omp_clauses->nowait;
7020 : : }
7021 : 1811 : if (mask & GFC_OMP_MASK_DO)
7022 : : {
7023 : 1811 : clausesa[GFC_OMP_SPLIT_DO].bind
7024 : 1811 : = code->ext.omp_clauses->bind;
7025 : : /* Duplicate collapse. */
7026 : 1811 : clausesa[GFC_OMP_SPLIT_DO].collapse
7027 : 1811 : = code->ext.omp_clauses->collapse;
7028 : 1811 : clausesa[GFC_OMP_SPLIT_DO].order_concurrent
7029 : 1811 : = code->ext.omp_clauses->order_concurrent;
7030 : 1811 : clausesa[GFC_OMP_SPLIT_DO].order_unconstrained
7031 : 1811 : = code->ext.omp_clauses->order_unconstrained;
7032 : 1811 : clausesa[GFC_OMP_SPLIT_DO].order_reproducible
7033 : 1811 : = code->ext.omp_clauses->order_reproducible;
7034 : : }
7035 : 2221 : if (mask & GFC_OMP_MASK_SIMD)
7036 : : {
7037 : 812 : clausesa[GFC_OMP_SPLIT_SIMD].safelen_expr
7038 : 812 : = code->ext.omp_clauses->safelen_expr;
7039 : 812 : clausesa[GFC_OMP_SPLIT_SIMD].simdlen_expr
7040 : 812 : = code->ext.omp_clauses->simdlen_expr;
7041 : 812 : clausesa[GFC_OMP_SPLIT_SIMD].lists[OMP_LIST_ALIGNED]
7042 : 812 : = code->ext.omp_clauses->lists[OMP_LIST_ALIGNED];
7043 : : /* Duplicate collapse. */
7044 : 812 : clausesa[GFC_OMP_SPLIT_SIMD].collapse
7045 : 812 : = code->ext.omp_clauses->collapse;
7046 : 812 : clausesa[GFC_OMP_SPLIT_SIMD].if_exprs[OMP_IF_SIMD]
7047 : 812 : = code->ext.omp_clauses->if_exprs[OMP_IF_SIMD];
7048 : 812 : clausesa[GFC_OMP_SPLIT_SIMD].order_concurrent
7049 : 812 : = code->ext.omp_clauses->order_concurrent;
7050 : 812 : clausesa[GFC_OMP_SPLIT_SIMD].order_unconstrained
7051 : 812 : = code->ext.omp_clauses->order_unconstrained;
7052 : 812 : clausesa[GFC_OMP_SPLIT_SIMD].order_reproducible
7053 : 812 : = code->ext.omp_clauses->order_reproducible;
7054 : : /* And this is copied to all. */
7055 : 812 : clausesa[GFC_OMP_SPLIT_SIMD].if_expr
7056 : 812 : = code->ext.omp_clauses->if_expr;
7057 : : }
7058 : 2221 : if (mask & GFC_OMP_MASK_TASKLOOP)
7059 : : {
7060 : : /* First the clauses that are unique to some constructs. */
7061 : 162 : clausesa[GFC_OMP_SPLIT_TASKLOOP].nogroup
7062 : 162 : = code->ext.omp_clauses->nogroup;
7063 : 162 : clausesa[GFC_OMP_SPLIT_TASKLOOP].grainsize
7064 : 162 : = code->ext.omp_clauses->grainsize;
7065 : 162 : clausesa[GFC_OMP_SPLIT_TASKLOOP].grainsize_strict
7066 : 162 : = code->ext.omp_clauses->grainsize_strict;
7067 : 162 : clausesa[GFC_OMP_SPLIT_TASKLOOP].num_tasks
7068 : 162 : = code->ext.omp_clauses->num_tasks;
7069 : 162 : clausesa[GFC_OMP_SPLIT_TASKLOOP].num_tasks_strict
7070 : 162 : = code->ext.omp_clauses->num_tasks_strict;
7071 : 162 : clausesa[GFC_OMP_SPLIT_TASKLOOP].priority
7072 : 162 : = code->ext.omp_clauses->priority;
7073 : 162 : clausesa[GFC_OMP_SPLIT_TASKLOOP].final_expr
7074 : 162 : = code->ext.omp_clauses->final_expr;
7075 : 162 : clausesa[GFC_OMP_SPLIT_TASKLOOP].untied
7076 : 162 : = code->ext.omp_clauses->untied;
7077 : 162 : clausesa[GFC_OMP_SPLIT_TASKLOOP].mergeable
7078 : 162 : = code->ext.omp_clauses->mergeable;
7079 : 162 : clausesa[GFC_OMP_SPLIT_TASKLOOP].if_exprs[OMP_IF_TASKLOOP]
7080 : 162 : = code->ext.omp_clauses->if_exprs[OMP_IF_TASKLOOP];
7081 : : /* And this is copied to all. */
7082 : 162 : clausesa[GFC_OMP_SPLIT_TASKLOOP].if_expr
7083 : 162 : = code->ext.omp_clauses->if_expr;
7084 : : /* Shared and default clauses are allowed on parallel, teams
7085 : : and taskloop. */
7086 : 162 : clausesa[GFC_OMP_SPLIT_TASKLOOP].lists[OMP_LIST_SHARED]
7087 : 162 : = code->ext.omp_clauses->lists[OMP_LIST_SHARED];
7088 : 162 : clausesa[GFC_OMP_SPLIT_TASKLOOP].default_sharing
7089 : 162 : = code->ext.omp_clauses->default_sharing;
7090 : : /* Duplicate collapse. */
7091 : 162 : clausesa[GFC_OMP_SPLIT_TASKLOOP].collapse
7092 : 162 : = code->ext.omp_clauses->collapse;
7093 : : }
7094 : : /* Private clause is supported on all constructs but master/masked,
7095 : : it is enough to put it on the innermost one except for master/masked. For
7096 : : !$ omp parallel do put it on parallel though,
7097 : : as that's what we did for OpenMP 3.1. */
7098 : 2221 : clausesa[((innermost == GFC_OMP_SPLIT_DO && !is_loop)
7099 : : || code->op == EXEC_OMP_PARALLEL_MASTER
7100 : 981 : || code->op == EXEC_OMP_PARALLEL_MASKED)
7101 : 970 : ? (int) GFC_OMP_SPLIT_PARALLEL
7102 : 3191 : : innermost].lists[OMP_LIST_PRIVATE]
7103 : 2221 : = code->ext.omp_clauses->lists[OMP_LIST_PRIVATE];
7104 : : /* Firstprivate clause is supported on all constructs but
7105 : : simd and masked/master. Put it on the outermost of those and duplicate
7106 : : on parallel and teams. */
7107 : 2221 : if (mask & GFC_OMP_MASK_TARGET)
7108 : 314 : gfc_add_firstprivate_if_unmapped (&clausesa[GFC_OMP_SPLIT_TARGET],
7109 : : code->ext.omp_clauses);
7110 : 2221 : if (mask & GFC_OMP_MASK_TEAMS)
7111 : 328 : clausesa[GFC_OMP_SPLIT_TEAMS].lists[OMP_LIST_FIRSTPRIVATE]
7112 : 328 : = code->ext.omp_clauses->lists[OMP_LIST_FIRSTPRIVATE];
7113 : 1893 : else if (mask & GFC_OMP_MASK_DISTRIBUTE)
7114 : 105 : clausesa[GFC_OMP_SPLIT_DISTRIBUTE].lists[OMP_LIST_FIRSTPRIVATE]
7115 : 105 : = code->ext.omp_clauses->lists[OMP_LIST_FIRSTPRIVATE];
7116 : 2221 : if (mask & GFC_OMP_MASK_TASKLOOP)
7117 : 162 : clausesa[GFC_OMP_SPLIT_TASKLOOP].lists[OMP_LIST_FIRSTPRIVATE]
7118 : 162 : = code->ext.omp_clauses->lists[OMP_LIST_FIRSTPRIVATE];
7119 : 2221 : if ((mask & GFC_OMP_MASK_PARALLEL)
7120 : : && !(mask & GFC_OMP_MASK_TASKLOOP))
7121 : 1698 : clausesa[GFC_OMP_SPLIT_PARALLEL].lists[OMP_LIST_FIRSTPRIVATE]
7122 : 1698 : = code->ext.omp_clauses->lists[OMP_LIST_FIRSTPRIVATE];
7123 : 523 : else if ((mask & GFC_OMP_MASK_DO) && !is_loop)
7124 : 126 : clausesa[GFC_OMP_SPLIT_DO].lists[OMP_LIST_FIRSTPRIVATE]
7125 : 126 : = code->ext.omp_clauses->lists[OMP_LIST_FIRSTPRIVATE];
7126 : : /* Lastprivate is allowed on distribute, do, simd, taskloop and loop.
7127 : : In parallel do{, simd} we actually want to put it on
7128 : : parallel rather than do. */
7129 : 2221 : if (mask & GFC_OMP_MASK_DISTRIBUTE)
7130 : 352 : clausesa[GFC_OMP_SPLIT_DISTRIBUTE].lists[OMP_LIST_LASTPRIVATE]
7131 : 352 : = code->ext.omp_clauses->lists[OMP_LIST_LASTPRIVATE];
7132 : 2221 : if (mask & GFC_OMP_MASK_TASKLOOP)
7133 : 162 : clausesa[GFC_OMP_SPLIT_TASKLOOP].lists[OMP_LIST_LASTPRIVATE]
7134 : 162 : = code->ext.omp_clauses->lists[OMP_LIST_LASTPRIVATE];
7135 : 2221 : if ((mask & GFC_OMP_MASK_PARALLEL) && !is_loop
7136 : 1763 : && !(mask & GFC_OMP_MASK_TASKLOOP))
7137 : 1677 : clausesa[GFC_OMP_SPLIT_PARALLEL].lists[OMP_LIST_LASTPRIVATE]
7138 : 1677 : = code->ext.omp_clauses->lists[OMP_LIST_LASTPRIVATE];
7139 : 544 : else if (mask & GFC_OMP_MASK_DO)
7140 : 165 : clausesa[GFC_OMP_SPLIT_DO].lists[OMP_LIST_LASTPRIVATE]
7141 : 165 : = code->ext.omp_clauses->lists[OMP_LIST_LASTPRIVATE];
7142 : 2221 : if (mask & GFC_OMP_MASK_SIMD)
7143 : 812 : clausesa[GFC_OMP_SPLIT_SIMD].lists[OMP_LIST_LASTPRIVATE]
7144 : 812 : = code->ext.omp_clauses->lists[OMP_LIST_LASTPRIVATE];
7145 : : /* Reduction is allowed on simd, do, parallel, teams, taskloop, and loop.
7146 : : Duplicate it on all of them, but
7147 : : - omit on do if parallel is present;
7148 : : - omit on task and parallel if loop is present;
7149 : : additionally, inscan applies to do/simd only. */
7150 : 8884 : for (int i = OMP_LIST_REDUCTION; i <= OMP_LIST_REDUCTION_TASK; i++)
7151 : : {
7152 : 6663 : if (mask & GFC_OMP_MASK_TASKLOOP
7153 : 486 : && i != OMP_LIST_REDUCTION_INSCAN)
7154 : 324 : clausesa[GFC_OMP_SPLIT_TASKLOOP].lists[i]
7155 : 324 : = code->ext.omp_clauses->lists[i];
7156 : 6663 : if (mask & GFC_OMP_MASK_TEAMS
7157 : 984 : && i != OMP_LIST_REDUCTION_INSCAN
7158 : 984 : && !is_loop)
7159 : 620 : clausesa[GFC_OMP_SPLIT_TEAMS].lists[i]
7160 : 620 : = code->ext.omp_clauses->lists[i];
7161 : 6663 : if (mask & GFC_OMP_MASK_PARALLEL
7162 : 5352 : && i != OMP_LIST_REDUCTION_INSCAN
7163 : 3568 : && !(mask & GFC_OMP_MASK_TASKLOOP)
7164 : 3396 : && !is_loop)
7165 : 3354 : clausesa[GFC_OMP_SPLIT_PARALLEL].lists[i]
7166 : 3354 : = code->ext.omp_clauses->lists[i];
7167 : 3309 : else if (mask & GFC_OMP_MASK_DO)
7168 : 2141 : clausesa[GFC_OMP_SPLIT_DO].lists[i]
7169 : 2141 : = code->ext.omp_clauses->lists[i];
7170 : 6663 : if (mask & GFC_OMP_MASK_SIMD)
7171 : 2436 : clausesa[GFC_OMP_SPLIT_SIMD].lists[i]
7172 : 2436 : = code->ext.omp_clauses->lists[i];
7173 : : }
7174 : 2221 : if (mask & GFC_OMP_MASK_TARGET)
7175 : 314 : clausesa[GFC_OMP_SPLIT_TARGET].lists[OMP_LIST_IN_REDUCTION]
7176 : 314 : = code->ext.omp_clauses->lists[OMP_LIST_IN_REDUCTION];
7177 : 2221 : if (mask & GFC_OMP_MASK_TASKLOOP)
7178 : 162 : clausesa[GFC_OMP_SPLIT_TASKLOOP].lists[OMP_LIST_IN_REDUCTION]
7179 : 162 : = code->ext.omp_clauses->lists[OMP_LIST_IN_REDUCTION];
7180 : : /* Linear clause is supported on do and simd,
7181 : : put it on the innermost one. */
7182 : 2221 : clausesa[innermost].lists[OMP_LIST_LINEAR]
7183 : 2221 : = code->ext.omp_clauses->lists[OMP_LIST_LINEAR];
7184 : : }
7185 : : /* Propagate firstprivate/lastprivate/reduction vars to
7186 : : shared (parallel, teams) and map-tofrom (target). */
7187 : 2221 : if (mask & GFC_OMP_MASK_TARGET)
7188 : 314 : gfc_add_clause_implicitly (&clausesa[GFC_OMP_SPLIT_TARGET],
7189 : : code->ext.omp_clauses, true, false);
7190 : 2221 : if ((mask & GFC_OMP_MASK_PARALLEL) && innermost != GFC_OMP_MASK_PARALLEL)
7191 : 1784 : gfc_add_clause_implicitly (&clausesa[GFC_OMP_SPLIT_PARALLEL],
7192 : : code->ext.omp_clauses, false,
7193 : 1784 : mask & GFC_OMP_MASK_DO);
7194 : 2221 : if (mask & GFC_OMP_MASK_TEAMS && innermost != GFC_OMP_MASK_TEAMS)
7195 : 328 : gfc_add_clause_implicitly (&clausesa[GFC_OMP_SPLIT_TEAMS],
7196 : : code->ext.omp_clauses, false, false);
7197 : 2221 : if (((mask & (GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO))
7198 : : == (GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO))
7199 : 1667 : && !is_loop)
7200 : 1646 : clausesa[GFC_OMP_SPLIT_DO].nowait = true;
7201 : :
7202 : : /* Distribute allocate clause to do, parallel, distribute, teams, target
7203 : : and taskloop. The code below iterates over variables in the
7204 : : allocate list and checks if that available is also in any
7205 : : privatization clause on those construct. If yes, then we add it
7206 : : to the list of 'allocate'ed variables for that construct. If a
7207 : : variable is found in none of them then we issue an error. */
7208 : :
7209 : 2221 : if (code->ext.omp_clauses->lists[OMP_LIST_ALLOCATE])
7210 : : {
7211 : : gfc_omp_namelist *alloc_nl, *priv_nl;
7212 : : gfc_omp_namelist *tails[GFC_OMP_SPLIT_NUM];
7213 : 104 : for (alloc_nl = code->ext.omp_clauses->lists[OMP_LIST_ALLOCATE];
7214 : 181 : alloc_nl; alloc_nl = alloc_nl->next)
7215 : : {
7216 : : bool found = false;
7217 : 728 : for (int i = GFC_OMP_SPLIT_DO; i <= GFC_OMP_SPLIT_TASKLOOP; i++)
7218 : : {
7219 : : gfc_omp_namelist *p;
7220 : : int list;
7221 : 23088 : for (list = 0; list < OMP_LIST_NUM; list++)
7222 : : {
7223 : 22464 : switch (list)
7224 : : {
7225 : 5616 : case OMP_LIST_PRIVATE:
7226 : 5616 : case OMP_LIST_FIRSTPRIVATE:
7227 : 5616 : case OMP_LIST_LASTPRIVATE:
7228 : 5616 : case OMP_LIST_REDUCTION:
7229 : 5616 : case OMP_LIST_REDUCTION_INSCAN:
7230 : 5616 : case OMP_LIST_REDUCTION_TASK:
7231 : 5616 : case OMP_LIST_IN_REDUCTION:
7232 : 5616 : case OMP_LIST_TASK_REDUCTION:
7233 : 5616 : case OMP_LIST_LINEAR:
7234 : 6092 : for (priv_nl = clausesa[i].lists[list]; priv_nl;
7235 : 476 : priv_nl = priv_nl->next)
7236 : 476 : if (alloc_nl->sym == priv_nl->sym)
7237 : : {
7238 : 131 : found = true;
7239 : 131 : p = gfc_get_omp_namelist ();
7240 : 131 : p->sym = alloc_nl->sym;
7241 : 131 : p->expr = alloc_nl->expr;
7242 : 131 : p->u.align = alloc_nl->u.align;
7243 : 131 : p->u2.allocator = alloc_nl->u2.allocator;
7244 : 131 : p->where = alloc_nl->where;
7245 : 131 : if (clausesa[i].lists[OMP_LIST_ALLOCATE] == NULL)
7246 : : {
7247 : 109 : clausesa[i].lists[OMP_LIST_ALLOCATE] = p;
7248 : 109 : tails[i] = p;
7249 : : }
7250 : : else
7251 : : {
7252 : 22 : tails[i]->next = p;
7253 : 22 : tails[i] = tails[i]->next;
7254 : : }
7255 : : }
7256 : : break;
7257 : : default:
7258 : : break;
7259 : : }
7260 : : }
7261 : : }
7262 : 104 : if (!found)
7263 : 1 : gfc_error ("%qs specified in %<allocate%> clause at %L but not "
7264 : : "in an explicit privatization clause",
7265 : 1 : alloc_nl->sym->name, &alloc_nl->where);
7266 : : }
7267 : : }
7268 : : }
7269 : :
7270 : : static tree
7271 : 532 : gfc_trans_omp_do_simd (gfc_code *code, stmtblock_t *pblock,
7272 : : gfc_omp_clauses *clausesa, tree omp_clauses)
7273 : : {
7274 : 532 : stmtblock_t block;
7275 : 532 : gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM];
7276 : 532 : tree stmt, body, omp_do_clauses = NULL_TREE;
7277 : 532 : bool free_clausesa = false;
7278 : :
7279 : 532 : if (pblock == NULL)
7280 : 404 : gfc_start_block (&block);
7281 : : else
7282 : 128 : gfc_init_block (&block);
7283 : :
7284 : 532 : if (clausesa == NULL)
7285 : : {
7286 : 126 : clausesa = clausesa_buf;
7287 : 126 : gfc_split_omp_clauses (code, clausesa);
7288 : 126 : free_clausesa = true;
7289 : : }
7290 : 532 : if (flag_openmp)
7291 : 527 : omp_do_clauses
7292 : 527 : = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_DO], code->loc);
7293 : 660 : body = gfc_trans_omp_do (code, EXEC_OMP_SIMD, pblock ? pblock : &block,
7294 : : &clausesa[GFC_OMP_SPLIT_SIMD], omp_clauses);
7295 : 532 : if (pblock == NULL)
7296 : : {
7297 : 404 : if (TREE_CODE (body) != BIND_EXPR)
7298 : 404 : body = build3_v (BIND_EXPR, NULL, body, poplevel (1, 0));
7299 : : else
7300 : 0 : poplevel (0, 0);
7301 : : }
7302 : 128 : else if (TREE_CODE (body) != BIND_EXPR)
7303 : 128 : body = build3_v (BIND_EXPR, NULL, body, NULL_TREE);
7304 : 532 : if (flag_openmp)
7305 : : {
7306 : 527 : stmt = make_node (OMP_FOR);
7307 : 527 : SET_EXPR_LOCATION (stmt, gfc_get_location (&code->loc));
7308 : 527 : TREE_TYPE (stmt) = void_type_node;
7309 : 527 : OMP_FOR_BODY (stmt) = body;
7310 : 527 : OMP_FOR_CLAUSES (stmt) = omp_do_clauses;
7311 : : }
7312 : : else
7313 : : stmt = body;
7314 : 532 : gfc_add_expr_to_block (&block, stmt);
7315 : 532 : if (free_clausesa)
7316 : 126 : gfc_free_split_omp_clauses (code, clausesa);
7317 : 532 : return gfc_finish_block (&block);
7318 : : }
7319 : :
7320 : : static tree
7321 : 1261 : gfc_trans_omp_parallel_do (gfc_code *code, bool is_loop, stmtblock_t *pblock,
7322 : : gfc_omp_clauses *clausesa)
7323 : : {
7324 : 1261 : stmtblock_t block, *new_pblock = pblock;
7325 : 1261 : gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM];
7326 : 1261 : tree stmt, omp_clauses = NULL_TREE;
7327 : 1261 : bool free_clausesa = false;
7328 : :
7329 : 1261 : if (pblock == NULL)
7330 : 1080 : gfc_start_block (&block);
7331 : : else
7332 : 181 : gfc_init_block (&block);
7333 : :
7334 : 1261 : if (clausesa == NULL)
7335 : : {
7336 : 1080 : clausesa = clausesa_buf;
7337 : 1080 : gfc_split_omp_clauses (code, clausesa);
7338 : 1080 : free_clausesa = true;
7339 : : }
7340 : 1261 : omp_clauses
7341 : 1261 : = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_PARALLEL],
7342 : : code->loc);
7343 : 1261 : if (pblock == NULL)
7344 : : {
7345 : 1080 : if (!clausesa[GFC_OMP_SPLIT_DO].ordered
7346 : 1071 : && clausesa[GFC_OMP_SPLIT_DO].sched_kind != OMP_SCHED_STATIC)
7347 : : new_pblock = █
7348 : : else
7349 : 65 : pushlevel ();
7350 : : }
7351 : 2501 : stmt = gfc_trans_omp_do (code, is_loop ? EXEC_OMP_LOOP : EXEC_OMP_DO,
7352 : : new_pblock, &clausesa[GFC_OMP_SPLIT_DO],
7353 : : omp_clauses);
7354 : 1261 : if (pblock == NULL)
7355 : : {
7356 : 1080 : if (TREE_CODE (stmt) != BIND_EXPR)
7357 : 1064 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
7358 : : else
7359 : 16 : poplevel (0, 0);
7360 : : }
7361 : 181 : else if (TREE_CODE (stmt) != BIND_EXPR)
7362 : 181 : stmt = build3_v (BIND_EXPR, NULL, stmt, NULL_TREE);
7363 : 1261 : stmt = build2_loc (gfc_get_location (&code->loc), OMP_PARALLEL,
7364 : : void_type_node, stmt, omp_clauses);
7365 : 1261 : OMP_PARALLEL_COMBINED (stmt) = 1;
7366 : 1261 : gfc_add_expr_to_block (&block, stmt);
7367 : 1261 : if (free_clausesa)
7368 : 1080 : gfc_free_split_omp_clauses (code, clausesa);
7369 : 1261 : return gfc_finish_block (&block);
7370 : : }
7371 : :
7372 : : static tree
7373 : 406 : gfc_trans_omp_parallel_do_simd (gfc_code *code, stmtblock_t *pblock,
7374 : : gfc_omp_clauses *clausesa)
7375 : : {
7376 : 406 : stmtblock_t block;
7377 : 406 : gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM];
7378 : 406 : tree stmt, omp_clauses = NULL_TREE;
7379 : 406 : bool free_clausesa = false;
7380 : :
7381 : 406 : if (pblock == NULL)
7382 : 278 : gfc_start_block (&block);
7383 : : else
7384 : 128 : gfc_init_block (&block);
7385 : :
7386 : 406 : if (clausesa == NULL)
7387 : : {
7388 : 278 : clausesa = clausesa_buf;
7389 : 278 : gfc_split_omp_clauses (code, clausesa);
7390 : 278 : free_clausesa = true;
7391 : : }
7392 : 406 : if (flag_openmp)
7393 : 403 : omp_clauses
7394 : 403 : = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_PARALLEL],
7395 : : code->loc);
7396 : 406 : if (pblock == NULL)
7397 : 278 : pushlevel ();
7398 : 406 : stmt = gfc_trans_omp_do_simd (code, pblock, clausesa, omp_clauses);
7399 : 406 : if (pblock == NULL)
7400 : : {
7401 : 278 : if (TREE_CODE (stmt) != BIND_EXPR)
7402 : 207 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
7403 : : else
7404 : 71 : poplevel (0, 0);
7405 : : }
7406 : 128 : else if (TREE_CODE (stmt) != BIND_EXPR)
7407 : 128 : stmt = build3_v (BIND_EXPR, NULL, stmt, NULL_TREE);
7408 : 406 : if (flag_openmp)
7409 : : {
7410 : 403 : stmt = build2_loc (gfc_get_location (&code->loc), OMP_PARALLEL,
7411 : : void_type_node, stmt, omp_clauses);
7412 : 403 : OMP_PARALLEL_COMBINED (stmt) = 1;
7413 : : }
7414 : 406 : gfc_add_expr_to_block (&block, stmt);
7415 : 406 : if (free_clausesa)
7416 : 278 : gfc_free_split_omp_clauses (code, clausesa);
7417 : 406 : return gfc_finish_block (&block);
7418 : : }
7419 : :
7420 : : static tree
7421 : 54 : gfc_trans_omp_parallel_sections (gfc_code *code)
7422 : : {
7423 : 54 : stmtblock_t block;
7424 : 54 : gfc_omp_clauses section_clauses;
7425 : 54 : tree stmt, omp_clauses;
7426 : :
7427 : 54 : memset (§ion_clauses, 0, sizeof (section_clauses));
7428 : 54 : section_clauses.nowait = true;
7429 : :
7430 : 54 : gfc_start_block (&block);
7431 : 54 : omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
7432 : : code->loc);
7433 : 54 : pushlevel ();
7434 : 54 : stmt = gfc_trans_omp_sections (code, §ion_clauses);
7435 : 54 : if (TREE_CODE (stmt) != BIND_EXPR)
7436 : 54 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
7437 : : else
7438 : 0 : poplevel (0, 0);
7439 : 54 : stmt = build2_loc (gfc_get_location (&code->loc), OMP_PARALLEL,
7440 : : void_type_node, stmt, omp_clauses);
7441 : 54 : OMP_PARALLEL_COMBINED (stmt) = 1;
7442 : 54 : gfc_add_expr_to_block (&block, stmt);
7443 : 54 : return gfc_finish_block (&block);
7444 : : }
7445 : :
7446 : : static tree
7447 : 50 : gfc_trans_omp_parallel_workshare (gfc_code *code)
7448 : : {
7449 : 50 : stmtblock_t block;
7450 : 50 : gfc_omp_clauses workshare_clauses;
7451 : 50 : tree stmt, omp_clauses;
7452 : :
7453 : 50 : memset (&workshare_clauses, 0, sizeof (workshare_clauses));
7454 : 50 : workshare_clauses.nowait = true;
7455 : :
7456 : 50 : gfc_start_block (&block);
7457 : 50 : omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
7458 : : code->loc);
7459 : 50 : pushlevel ();
7460 : 50 : stmt = gfc_trans_omp_workshare (code, &workshare_clauses);
7461 : 50 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
7462 : 50 : stmt = build2_loc (gfc_get_location (&code->loc), OMP_PARALLEL,
7463 : : void_type_node, stmt, omp_clauses);
7464 : 50 : OMP_PARALLEL_COMBINED (stmt) = 1;
7465 : 50 : gfc_add_expr_to_block (&block, stmt);
7466 : 50 : return gfc_finish_block (&block);
7467 : : }
7468 : :
7469 : : static tree
7470 : 53 : gfc_trans_omp_scope (gfc_code *code)
7471 : : {
7472 : 53 : stmtblock_t block;
7473 : 53 : tree body = gfc_trans_code (code->block->next);
7474 : 53 : if (IS_EMPTY_STMT (body))
7475 : : return body;
7476 : 51 : gfc_start_block (&block);
7477 : 51 : tree omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
7478 : : code->loc);
7479 : 51 : tree stmt = make_node (OMP_SCOPE);
7480 : 51 : SET_EXPR_LOCATION (stmt, gfc_get_location (&code->loc));
7481 : 51 : TREE_TYPE (stmt) = void_type_node;
7482 : 51 : OMP_SCOPE_BODY (stmt) = body;
7483 : 51 : OMP_SCOPE_CLAUSES (stmt) = omp_clauses;
7484 : 51 : gfc_add_expr_to_block (&block, stmt);
7485 : 51 : return gfc_finish_block (&block);
7486 : : }
7487 : :
7488 : : static tree
7489 : 129 : gfc_trans_omp_sections (gfc_code *code, gfc_omp_clauses *clauses)
7490 : : {
7491 : 129 : stmtblock_t block, body;
7492 : 129 : tree omp_clauses, stmt;
7493 : 129 : bool has_lastprivate = clauses->lists[OMP_LIST_LASTPRIVATE] != NULL;
7494 : 129 : location_t loc = gfc_get_location (&code->loc);
7495 : :
7496 : 129 : gfc_start_block (&block);
7497 : :
7498 : 129 : omp_clauses = gfc_trans_omp_clauses (&block, clauses, code->loc);
7499 : :
7500 : 129 : gfc_init_block (&body);
7501 : 499 : for (code = code->block; code; code = code->block)
7502 : : {
7503 : : /* Last section is special because of lastprivate, so even if it
7504 : : is empty, chain it in. */
7505 : 370 : stmt = gfc_trans_omp_code (code->next,
7506 : 370 : has_lastprivate && code->block == NULL);
7507 : 370 : if (! IS_EMPTY_STMT (stmt))
7508 : : {
7509 : 280 : stmt = build1_v (OMP_SECTION, stmt);
7510 : 280 : gfc_add_expr_to_block (&body, stmt);
7511 : : }
7512 : : }
7513 : 129 : stmt = gfc_finish_block (&body);
7514 : :
7515 : 129 : stmt = build2_loc (loc, OMP_SECTIONS, void_type_node, stmt, omp_clauses);
7516 : 129 : gfc_add_expr_to_block (&block, stmt);
7517 : :
7518 : 129 : return gfc_finish_block (&block);
7519 : : }
7520 : :
7521 : : static tree
7522 : 565 : gfc_trans_omp_single (gfc_code *code, gfc_omp_clauses *clauses)
7523 : : {
7524 : 565 : stmtblock_t block;
7525 : 565 : gfc_start_block (&block);
7526 : 565 : tree omp_clauses = gfc_trans_omp_clauses (&block, clauses, code->loc);
7527 : 565 : tree stmt = gfc_trans_omp_code (code->block->next, true);
7528 : 565 : stmt = build2_loc (gfc_get_location (&code->loc), OMP_SINGLE, void_type_node,
7529 : : stmt, omp_clauses);
7530 : 565 : gfc_add_expr_to_block (&block, stmt);
7531 : 565 : return gfc_finish_block (&block);
7532 : : }
7533 : :
7534 : : static tree
7535 : 1121 : gfc_trans_omp_task (gfc_code *code)
7536 : : {
7537 : 1121 : stmtblock_t block;
7538 : 1121 : tree stmt, omp_clauses;
7539 : :
7540 : 1121 : gfc_start_block (&block);
7541 : 1121 : omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
7542 : : code->loc);
7543 : 1121 : pushlevel ();
7544 : 1121 : stmt = gfc_trans_omp_code (code->block->next, true);
7545 : 1121 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
7546 : 1121 : stmt = build2_loc (gfc_get_location (&code->loc), OMP_TASK, void_type_node,
7547 : : stmt, omp_clauses);
7548 : 1121 : gfc_add_expr_to_block (&block, stmt);
7549 : 1121 : return gfc_finish_block (&block);
7550 : : }
7551 : :
7552 : : static tree
7553 : 181 : gfc_trans_omp_taskgroup (gfc_code *code)
7554 : : {
7555 : 181 : stmtblock_t block;
7556 : 181 : gfc_start_block (&block);
7557 : 181 : tree body = gfc_trans_code (code->block->next);
7558 : 181 : tree stmt = make_node (OMP_TASKGROUP);
7559 : 181 : SET_EXPR_LOCATION (stmt, gfc_get_location (&code->loc));
7560 : 181 : TREE_TYPE (stmt) = void_type_node;
7561 : 181 : OMP_TASKGROUP_BODY (stmt) = body;
7562 : 181 : OMP_TASKGROUP_CLAUSES (stmt) = gfc_trans_omp_clauses (&block,
7563 : : code->ext.omp_clauses,
7564 : : code->loc);
7565 : 181 : gfc_add_expr_to_block (&block, stmt);
7566 : 181 : return gfc_finish_block (&block);
7567 : : }
7568 : :
7569 : : static tree
7570 : 143 : gfc_trans_omp_taskwait (gfc_code *code)
7571 : : {
7572 : 143 : if (!code->ext.omp_clauses)
7573 : : {
7574 : 131 : tree decl = builtin_decl_explicit (BUILT_IN_GOMP_TASKWAIT);
7575 : 131 : return build_call_expr_loc (input_location, decl, 0);
7576 : : }
7577 : 12 : stmtblock_t block;
7578 : 12 : gfc_start_block (&block);
7579 : 12 : tree stmt = make_node (OMP_TASK);
7580 : 12 : SET_EXPR_LOCATION (stmt, gfc_get_location (&code->loc));
7581 : 12 : TREE_TYPE (stmt) = void_type_node;
7582 : 12 : OMP_TASK_BODY (stmt) = NULL_TREE;
7583 : 12 : OMP_TASK_CLAUSES (stmt) = gfc_trans_omp_clauses (&block,
7584 : : code->ext.omp_clauses,
7585 : : code->loc);
7586 : 12 : gfc_add_expr_to_block (&block, stmt);
7587 : 12 : return gfc_finish_block (&block);
7588 : : }
7589 : :
7590 : : static tree
7591 : 8 : gfc_trans_omp_taskyield (void)
7592 : : {
7593 : 8 : tree decl = builtin_decl_explicit (BUILT_IN_GOMP_TASKYIELD);
7594 : 8 : return build_call_expr_loc (input_location, decl, 0);
7595 : : }
7596 : :
7597 : : static tree
7598 : 324 : gfc_trans_omp_distribute (gfc_code *code, gfc_omp_clauses *clausesa)
7599 : : {
7600 : 324 : stmtblock_t block;
7601 : 324 : gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM];
7602 : 324 : tree stmt, omp_clauses = NULL_TREE;
7603 : 324 : bool free_clausesa = false;
7604 : :
7605 : 324 : gfc_start_block (&block);
7606 : 324 : if (clausesa == NULL)
7607 : : {
7608 : 105 : clausesa = clausesa_buf;
7609 : 105 : gfc_split_omp_clauses (code, clausesa);
7610 : 105 : free_clausesa = true;
7611 : : }
7612 : 324 : if (flag_openmp)
7613 : 324 : omp_clauses
7614 : 324 : = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_DISTRIBUTE],
7615 : : code->loc);
7616 : 324 : switch (code->op)
7617 : : {
7618 : 0 : case EXEC_OMP_DISTRIBUTE:
7619 : 0 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
7620 : 0 : case EXEC_OMP_TEAMS_DISTRIBUTE:
7621 : : /* This is handled in gfc_trans_omp_do. */
7622 : 0 : gcc_unreachable ();
7623 : 111 : break;
7624 : 111 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
7625 : 111 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
7626 : 111 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
7627 : 111 : stmt = gfc_trans_omp_parallel_do (code, false, &block, clausesa);
7628 : 111 : if (TREE_CODE (stmt) != BIND_EXPR)
7629 : 111 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
7630 : : else
7631 : 0 : poplevel (0, 0);
7632 : : break;
7633 : 113 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
7634 : 113 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
7635 : 113 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
7636 : 113 : stmt = gfc_trans_omp_parallel_do_simd (code, &block, clausesa);
7637 : 113 : if (TREE_CODE (stmt) != BIND_EXPR)
7638 : 113 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
7639 : : else
7640 : 0 : poplevel (0, 0);
7641 : : break;
7642 : 100 : case EXEC_OMP_DISTRIBUTE_SIMD:
7643 : 100 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
7644 : 100 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
7645 : 100 : stmt = gfc_trans_omp_do (code, EXEC_OMP_SIMD, &block,
7646 : : &clausesa[GFC_OMP_SPLIT_SIMD], NULL_TREE);
7647 : 100 : if (TREE_CODE (stmt) != BIND_EXPR)
7648 : 100 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
7649 : : else
7650 : 0 : poplevel (0, 0);
7651 : : break;
7652 : 0 : default:
7653 : 0 : gcc_unreachable ();
7654 : : }
7655 : 324 : if (flag_openmp)
7656 : : {
7657 : 324 : tree distribute = make_node (OMP_DISTRIBUTE);
7658 : 324 : SET_EXPR_LOCATION (distribute, gfc_get_location (&code->loc));
7659 : 324 : TREE_TYPE (distribute) = void_type_node;
7660 : 324 : OMP_FOR_BODY (distribute) = stmt;
7661 : 324 : OMP_FOR_CLAUSES (distribute) = omp_clauses;
7662 : 324 : stmt = distribute;
7663 : : }
7664 : 324 : gfc_add_expr_to_block (&block, stmt);
7665 : 324 : if (free_clausesa)
7666 : 105 : gfc_free_split_omp_clauses (code, clausesa);
7667 : 324 : return gfc_finish_block (&block);
7668 : : }
7669 : :
7670 : : static tree
7671 : 449 : gfc_trans_omp_teams (gfc_code *code, gfc_omp_clauses *clausesa,
7672 : : tree omp_clauses)
7673 : : {
7674 : 449 : stmtblock_t block;
7675 : 449 : gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM];
7676 : 449 : tree stmt;
7677 : 449 : bool combined = true, free_clausesa = false;
7678 : :
7679 : 449 : gfc_start_block (&block);
7680 : 449 : if (clausesa == NULL)
7681 : : {
7682 : 266 : clausesa = clausesa_buf;
7683 : 266 : gfc_split_omp_clauses (code, clausesa);
7684 : 266 : free_clausesa = true;
7685 : : }
7686 : 449 : if (flag_openmp)
7687 : : {
7688 : 449 : omp_clauses
7689 : 449 : = chainon (omp_clauses,
7690 : : gfc_trans_omp_clauses (&block,
7691 : : &clausesa[GFC_OMP_SPLIT_TEAMS],
7692 : : code->loc));
7693 : 449 : pushlevel ();
7694 : : }
7695 : 449 : switch (code->op)
7696 : : {
7697 : 184 : case EXEC_OMP_TARGET_TEAMS:
7698 : 184 : case EXEC_OMP_TEAMS:
7699 : 184 : stmt = gfc_trans_omp_code (code->block->next, true);
7700 : 184 : combined = false;
7701 : 184 : break;
7702 : 28 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
7703 : 28 : case EXEC_OMP_TEAMS_DISTRIBUTE:
7704 : 28 : stmt = gfc_trans_omp_do (code, EXEC_OMP_DISTRIBUTE, NULL,
7705 : : &clausesa[GFC_OMP_SPLIT_DISTRIBUTE],
7706 : : NULL);
7707 : 28 : break;
7708 : 18 : case EXEC_OMP_TARGET_TEAMS_LOOP:
7709 : 18 : case EXEC_OMP_TEAMS_LOOP:
7710 : 18 : stmt = gfc_trans_omp_do (code, EXEC_OMP_LOOP, NULL,
7711 : : &clausesa[GFC_OMP_SPLIT_DO],
7712 : : NULL);
7713 : 18 : break;
7714 : 219 : default:
7715 : 219 : stmt = gfc_trans_omp_distribute (code, clausesa);
7716 : 219 : break;
7717 : : }
7718 : 449 : if (flag_openmp)
7719 : : {
7720 : 449 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
7721 : 449 : stmt = build2_loc (gfc_get_location (&code->loc), OMP_TEAMS,
7722 : : void_type_node, stmt, omp_clauses);
7723 : 449 : if (combined)
7724 : 265 : OMP_TEAMS_COMBINED (stmt) = 1;
7725 : : }
7726 : 449 : gfc_add_expr_to_block (&block, stmt);
7727 : 449 : if (free_clausesa)
7728 : 266 : gfc_free_split_omp_clauses (code, clausesa);
7729 : 449 : return gfc_finish_block (&block);
7730 : : }
7731 : :
7732 : : static tree
7733 : 1812 : gfc_trans_omp_target (gfc_code *code)
7734 : : {
7735 : 1812 : stmtblock_t block;
7736 : 1812 : gfc_omp_clauses clausesa[GFC_OMP_SPLIT_NUM];
7737 : 1812 : tree stmt, omp_clauses = NULL_TREE;
7738 : :
7739 : 1812 : gfc_start_block (&block);
7740 : 1812 : gfc_split_omp_clauses (code, clausesa);
7741 : 1812 : if (flag_openmp)
7742 : 1812 : omp_clauses
7743 : 1812 : = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_TARGET],
7744 : : code->loc);
7745 : 1812 : switch (code->op)
7746 : : {
7747 : 1498 : case EXEC_OMP_TARGET:
7748 : 1498 : pushlevel ();
7749 : 1498 : stmt = gfc_trans_omp_code (code->block->next, true);
7750 : 1498 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
7751 : 1498 : break;
7752 : 20 : case EXEC_OMP_TARGET_PARALLEL:
7753 : 20 : {
7754 : 20 : stmtblock_t iblock;
7755 : :
7756 : 20 : pushlevel ();
7757 : 20 : gfc_start_block (&iblock);
7758 : 20 : tree inner_clauses
7759 : 20 : = gfc_trans_omp_clauses (&iblock, &clausesa[GFC_OMP_SPLIT_PARALLEL],
7760 : : code->loc);
7761 : 20 : stmt = gfc_trans_omp_code (code->block->next, true);
7762 : 20 : stmt = build2_loc (input_location, OMP_PARALLEL, void_type_node, stmt,
7763 : : inner_clauses);
7764 : 20 : gfc_add_expr_to_block (&iblock, stmt);
7765 : 20 : stmt = gfc_finish_block (&iblock);
7766 : 20 : if (TREE_CODE (stmt) != BIND_EXPR)
7767 : 17 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
7768 : : else
7769 : 3 : poplevel (0, 0);
7770 : : }
7771 : 20 : break;
7772 : 70 : case EXEC_OMP_TARGET_PARALLEL_DO:
7773 : 70 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
7774 : 70 : stmt = gfc_trans_omp_parallel_do (code,
7775 : : (code->op
7776 : : == EXEC_OMP_TARGET_PARALLEL_LOOP),
7777 : : &block, clausesa);
7778 : 70 : if (TREE_CODE (stmt) != BIND_EXPR)
7779 : 70 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
7780 : : else
7781 : 0 : poplevel (0, 0);
7782 : : break;
7783 : 15 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
7784 : 15 : stmt = gfc_trans_omp_parallel_do_simd (code, &block, clausesa);
7785 : 15 : if (TREE_CODE (stmt) != BIND_EXPR)
7786 : 15 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
7787 : : else
7788 : 0 : poplevel (0, 0);
7789 : : break;
7790 : 26 : case EXEC_OMP_TARGET_SIMD:
7791 : 26 : stmt = gfc_trans_omp_do (code, EXEC_OMP_SIMD, &block,
7792 : : &clausesa[GFC_OMP_SPLIT_SIMD], NULL_TREE);
7793 : 26 : if (TREE_CODE (stmt) != BIND_EXPR)
7794 : 26 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
7795 : : else
7796 : 0 : poplevel (0, 0);
7797 : : break;
7798 : 183 : default:
7799 : 183 : if (flag_openmp
7800 : 183 : && (clausesa[GFC_OMP_SPLIT_TEAMS].num_teams_upper
7801 : 133 : || clausesa[GFC_OMP_SPLIT_TEAMS].thread_limit))
7802 : : {
7803 : 51 : gfc_omp_clauses clausesb;
7804 : 51 : tree teams_clauses;
7805 : : /* For combined !$omp target teams, the num_teams and
7806 : : thread_limit clauses are evaluated before entering the
7807 : : target construct. */
7808 : 51 : memset (&clausesb, '\0', sizeof (clausesb));
7809 : 51 : clausesb.num_teams_lower
7810 : 51 : = clausesa[GFC_OMP_SPLIT_TEAMS].num_teams_lower;
7811 : 51 : clausesb.num_teams_upper
7812 : 51 : = clausesa[GFC_OMP_SPLIT_TEAMS].num_teams_upper;
7813 : 51 : clausesb.thread_limit = clausesa[GFC_OMP_SPLIT_TEAMS].thread_limit;
7814 : 51 : clausesa[GFC_OMP_SPLIT_TEAMS].num_teams_lower = NULL;
7815 : 51 : clausesa[GFC_OMP_SPLIT_TEAMS].num_teams_upper = NULL;
7816 : 51 : clausesa[GFC_OMP_SPLIT_TEAMS].thread_limit = NULL;
7817 : 51 : teams_clauses
7818 : 51 : = gfc_trans_omp_clauses (&block, &clausesb, code->loc);
7819 : 51 : pushlevel ();
7820 : 51 : stmt = gfc_trans_omp_teams (code, clausesa, teams_clauses);
7821 : 51 : }
7822 : : else
7823 : : {
7824 : 132 : pushlevel ();
7825 : 132 : stmt = gfc_trans_omp_teams (code, clausesa, NULL_TREE);
7826 : : }
7827 : 183 : if (TREE_CODE (stmt) != BIND_EXPR)
7828 : 182 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
7829 : : else
7830 : 1 : poplevel (0, 0);
7831 : : break;
7832 : : }
7833 : 1812 : if (flag_openmp)
7834 : : {
7835 : 1812 : stmt = build2_loc (gfc_get_location (&code->loc), OMP_TARGET,
7836 : : void_type_node, stmt, omp_clauses);
7837 : 1812 : if (code->op != EXEC_OMP_TARGET)
7838 : 314 : OMP_TARGET_COMBINED (stmt) = 1;
7839 : 1812 : cfun->has_omp_target = true;
7840 : : }
7841 : 1812 : gfc_add_expr_to_block (&block, stmt);
7842 : 1812 : gfc_free_split_omp_clauses (code, clausesa);
7843 : 1812 : return gfc_finish_block (&block);
7844 : : }
7845 : :
7846 : : static tree
7847 : 79 : gfc_trans_omp_taskloop (gfc_code *code, gfc_exec_op op)
7848 : : {
7849 : 79 : stmtblock_t block;
7850 : 79 : gfc_omp_clauses clausesa[GFC_OMP_SPLIT_NUM];
7851 : 79 : tree stmt, omp_clauses = NULL_TREE;
7852 : :
7853 : 79 : gfc_start_block (&block);
7854 : 79 : gfc_split_omp_clauses (code, clausesa);
7855 : 79 : if (flag_openmp)
7856 : 79 : omp_clauses
7857 : 79 : = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_TASKLOOP],
7858 : : code->loc);
7859 : 79 : switch (op)
7860 : : {
7861 : 0 : case EXEC_OMP_TASKLOOP:
7862 : : /* This is handled in gfc_trans_omp_do. */
7863 : 0 : gcc_unreachable ();
7864 : 79 : break;
7865 : 79 : case EXEC_OMP_TASKLOOP_SIMD:
7866 : 79 : stmt = gfc_trans_omp_do (code, EXEC_OMP_SIMD, &block,
7867 : : &clausesa[GFC_OMP_SPLIT_SIMD], NULL_TREE);
7868 : 79 : if (TREE_CODE (stmt) != BIND_EXPR)
7869 : 79 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
7870 : : else
7871 : 0 : poplevel (0, 0);
7872 : 79 : break;
7873 : 0 : default:
7874 : 0 : gcc_unreachable ();
7875 : : }
7876 : 79 : if (flag_openmp)
7877 : : {
7878 : 79 : tree taskloop = make_node (OMP_TASKLOOP);
7879 : 79 : SET_EXPR_LOCATION (taskloop, gfc_get_location (&code->loc));
7880 : 79 : TREE_TYPE (taskloop) = void_type_node;
7881 : 79 : OMP_FOR_BODY (taskloop) = stmt;
7882 : 79 : OMP_FOR_CLAUSES (taskloop) = omp_clauses;
7883 : 79 : stmt = taskloop;
7884 : : }
7885 : 79 : gfc_add_expr_to_block (&block, stmt);
7886 : 79 : gfc_free_split_omp_clauses (code, clausesa);
7887 : 79 : return gfc_finish_block (&block);
7888 : : }
7889 : :
7890 : : static tree
7891 : 84 : gfc_trans_omp_master_masked_taskloop (gfc_code *code, gfc_exec_op op)
7892 : : {
7893 : 84 : gfc_omp_clauses clausesa[GFC_OMP_SPLIT_NUM];
7894 : 84 : stmtblock_t block;
7895 : 84 : tree stmt;
7896 : :
7897 : 84 : if (op != EXEC_OMP_MASTER_TASKLOOP_SIMD
7898 : 55 : && code->op != EXEC_OMP_MASTER_TASKLOOP)
7899 : 44 : gfc_split_omp_clauses (code, clausesa);
7900 : :
7901 : 84 : pushlevel ();
7902 : 84 : if (op == EXEC_OMP_MASKED_TASKLOOP_SIMD
7903 : 84 : || op == EXEC_OMP_MASTER_TASKLOOP_SIMD)
7904 : 48 : stmt = gfc_trans_omp_taskloop (code, EXEC_OMP_TASKLOOP_SIMD);
7905 : : else
7906 : : {
7907 : 36 : gcc_assert (op == EXEC_OMP_MASKED_TASKLOOP
7908 : : || op == EXEC_OMP_MASTER_TASKLOOP);
7909 : 36 : stmt = gfc_trans_omp_do (code, EXEC_OMP_TASKLOOP, NULL,
7910 : 36 : code->op != EXEC_OMP_MASTER_TASKLOOP
7911 : : ? &clausesa[GFC_OMP_SPLIT_TASKLOOP]
7912 : : : code->ext.omp_clauses, NULL);
7913 : : }
7914 : 84 : if (TREE_CODE (stmt) != BIND_EXPR)
7915 : 55 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
7916 : : else
7917 : 29 : poplevel (0, 0);
7918 : 84 : gfc_start_block (&block);
7919 : 84 : if (op == EXEC_OMP_MASKED_TASKLOOP || op == EXEC_OMP_MASKED_TASKLOOP_SIMD)
7920 : : {
7921 : 34 : tree clauses = gfc_trans_omp_clauses (&block,
7922 : : &clausesa[GFC_OMP_SPLIT_MASKED],
7923 : : code->loc);
7924 : 34 : tree msk = make_node (OMP_MASKED);
7925 : 34 : SET_EXPR_LOCATION (msk, gfc_get_location (&code->loc));
7926 : 34 : TREE_TYPE (msk) = void_type_node;
7927 : 34 : OMP_MASKED_BODY (msk) = stmt;
7928 : 34 : OMP_MASKED_CLAUSES (msk) = clauses;
7929 : 34 : OMP_MASKED_COMBINED (msk) = 1;
7930 : 34 : gfc_add_expr_to_block (&block, msk);
7931 : : }
7932 : : else
7933 : : {
7934 : 50 : gcc_assert (op == EXEC_OMP_MASTER_TASKLOOP
7935 : : || op == EXEC_OMP_MASTER_TASKLOOP_SIMD);
7936 : 50 : stmt = build1_v (OMP_MASTER, stmt);
7937 : 50 : gfc_add_expr_to_block (&block, stmt);
7938 : : }
7939 : 84 : if (op != EXEC_OMP_MASTER_TASKLOOP_SIMD
7940 : 55 : && code->op != EXEC_OMP_MASTER_TASKLOOP)
7941 : 44 : gfc_free_split_omp_clauses (code, clausesa);
7942 : 84 : return gfc_finish_block (&block);
7943 : : }
7944 : :
7945 : : static tree
7946 : 61 : gfc_trans_omp_parallel_master_masked (gfc_code *code)
7947 : : {
7948 : 61 : stmtblock_t block;
7949 : 61 : tree stmt, omp_clauses;
7950 : 61 : gfc_omp_clauses clausesa[GFC_OMP_SPLIT_NUM];
7951 : 61 : bool parallel_combined = false;
7952 : :
7953 : 61 : if (code->op != EXEC_OMP_PARALLEL_MASTER)
7954 : 50 : gfc_split_omp_clauses (code, clausesa);
7955 : :
7956 : 61 : gfc_start_block (&block);
7957 : 61 : omp_clauses = gfc_trans_omp_clauses (&block,
7958 : 61 : code->op == EXEC_OMP_PARALLEL_MASTER
7959 : : ? code->ext.omp_clauses
7960 : : : &clausesa[GFC_OMP_SPLIT_PARALLEL],
7961 : : code->loc);
7962 : 61 : pushlevel ();
7963 : 61 : if (code->op == EXEC_OMP_PARALLEL_MASTER)
7964 : 11 : stmt = gfc_trans_omp_master (code);
7965 : 50 : else if (code->op == EXEC_OMP_PARALLEL_MASKED)
7966 : 11 : stmt = gfc_trans_omp_masked (code, &clausesa[GFC_OMP_SPLIT_MASKED]);
7967 : : else
7968 : : {
7969 : 39 : gfc_exec_op op;
7970 : 39 : switch (code->op)
7971 : : {
7972 : : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
7973 : : op = EXEC_OMP_MASKED_TASKLOOP;
7974 : : break;
7975 : 8 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
7976 : 8 : op = EXEC_OMP_MASKED_TASKLOOP_SIMD;
7977 : 8 : break;
7978 : 10 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
7979 : 10 : op = EXEC_OMP_MASTER_TASKLOOP;
7980 : 10 : break;
7981 : 14 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
7982 : 14 : op = EXEC_OMP_MASTER_TASKLOOP_SIMD;
7983 : 14 : break;
7984 : 0 : default:
7985 : 0 : gcc_unreachable ();
7986 : : }
7987 : 39 : stmt = gfc_trans_omp_master_masked_taskloop (code, op);
7988 : 39 : parallel_combined = true;
7989 : : }
7990 : 61 : if (TREE_CODE (stmt) != BIND_EXPR)
7991 : 48 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
7992 : : else
7993 : 13 : poplevel (0, 0);
7994 : 61 : stmt = build2_loc (gfc_get_location (&code->loc), OMP_PARALLEL,
7995 : : void_type_node, stmt, omp_clauses);
7996 : : /* masked does have just filter clause, but during gimplification
7997 : : isn't represented by a gimplification omp context, so for
7998 : : !$omp parallel masked don't set OMP_PARALLEL_COMBINED,
7999 : : so that
8000 : : !$omp parallel masked
8001 : : !$omp taskloop simd lastprivate (x)
8002 : : isn't confused with
8003 : : !$omp parallel masked taskloop simd lastprivate (x) */
8004 : 61 : if (parallel_combined)
8005 : 39 : OMP_PARALLEL_COMBINED (stmt) = 1;
8006 : 61 : gfc_add_expr_to_block (&block, stmt);
8007 : 61 : if (code->op != EXEC_OMP_PARALLEL_MASTER)
8008 : 50 : gfc_free_split_omp_clauses (code, clausesa);
8009 : 61 : return gfc_finish_block (&block);
8010 : : }
8011 : :
8012 : : static tree
8013 : 1379 : gfc_trans_omp_target_data (gfc_code *code)
8014 : : {
8015 : 1379 : stmtblock_t block;
8016 : 1379 : tree stmt, omp_clauses;
8017 : :
8018 : 1379 : gfc_start_block (&block);
8019 : 1379 : omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
8020 : : code->loc);
8021 : 1379 : stmt = gfc_trans_omp_code (code->block->next, true);
8022 : 1379 : stmt = build2_loc (gfc_get_location (&code->loc), OMP_TARGET_DATA,
8023 : : void_type_node, stmt, omp_clauses);
8024 : 1379 : gfc_add_expr_to_block (&block, stmt);
8025 : 1379 : return gfc_finish_block (&block);
8026 : : }
8027 : :
8028 : : static tree
8029 : 264 : gfc_trans_omp_target_enter_data (gfc_code *code)
8030 : : {
8031 : 264 : stmtblock_t block;
8032 : 264 : tree stmt, omp_clauses;
8033 : :
8034 : 264 : gfc_start_block (&block);
8035 : 264 : omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
8036 : : code->loc);
8037 : 264 : stmt = build1_loc (input_location, OMP_TARGET_ENTER_DATA, void_type_node,
8038 : : omp_clauses);
8039 : 264 : gfc_add_expr_to_block (&block, stmt);
8040 : 264 : return gfc_finish_block (&block);
8041 : : }
8042 : :
8043 : : static tree
8044 : 208 : gfc_trans_omp_target_exit_data (gfc_code *code)
8045 : : {
8046 : 208 : stmtblock_t block;
8047 : 208 : tree stmt, omp_clauses;
8048 : :
8049 : 208 : gfc_start_block (&block);
8050 : 208 : omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
8051 : : code->loc, false, false, code->op);
8052 : 208 : stmt = build1_loc (input_location, OMP_TARGET_EXIT_DATA, void_type_node,
8053 : : omp_clauses);
8054 : 208 : gfc_add_expr_to_block (&block, stmt);
8055 : 208 : return gfc_finish_block (&block);
8056 : : }
8057 : :
8058 : : static tree
8059 : 1701 : gfc_trans_omp_target_update (gfc_code *code)
8060 : : {
8061 : 1701 : stmtblock_t block;
8062 : 1701 : tree stmt, omp_clauses;
8063 : :
8064 : 1701 : gfc_start_block (&block);
8065 : 1701 : omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
8066 : : code->loc);
8067 : 1701 : stmt = build1_loc (input_location, OMP_TARGET_UPDATE, void_type_node,
8068 : : omp_clauses);
8069 : 1701 : gfc_add_expr_to_block (&block, stmt);
8070 : 1701 : return gfc_finish_block (&block);
8071 : : }
8072 : :
8073 : : static tree
8074 : 5 : gfc_trans_openmp_interop (gfc_code *code, gfc_omp_clauses *clauses)
8075 : : {
8076 : 5 : stmtblock_t block;
8077 : 5 : gfc_start_block (&block);
8078 : 5 : tree omp_clauses = gfc_trans_omp_clauses (&block, clauses, code->loc);
8079 : 5 : tree stmt = build1_loc (input_location, OMP_INTEROP, void_type_node,
8080 : : omp_clauses);
8081 : 5 : gfc_add_expr_to_block (&block, stmt);
8082 : 5 : return gfc_finish_block (&block);
8083 : : }
8084 : :
8085 : : static tree
8086 : 85 : gfc_trans_omp_workshare (gfc_code *code, gfc_omp_clauses *clauses)
8087 : : {
8088 : 85 : tree res, tmp, stmt;
8089 : 85 : stmtblock_t block, *pblock = NULL;
8090 : 85 : stmtblock_t singleblock;
8091 : 85 : int saved_ompws_flags;
8092 : 85 : bool singleblock_in_progress = false;
8093 : : /* True if previous gfc_code in workshare construct is not workshared. */
8094 : 85 : bool prev_singleunit;
8095 : 85 : location_t loc = gfc_get_location (&code->loc);
8096 : :
8097 : 85 : code = code->block->next;
8098 : :
8099 : 85 : pushlevel ();
8100 : :
8101 : 85 : gfc_start_block (&block);
8102 : 85 : pblock = █
8103 : :
8104 : 85 : ompws_flags = OMPWS_WORKSHARE_FLAG;
8105 : 85 : prev_singleunit = false;
8106 : :
8107 : : /* Translate statements one by one to trees until we reach
8108 : : the end of the workshare construct. Adjacent gfc_codes that
8109 : : are a single unit of work are clustered and encapsulated in a
8110 : : single OMP_SINGLE construct. */
8111 : 282 : for (; code; code = code->next)
8112 : : {
8113 : 197 : if (code->here != 0)
8114 : : {
8115 : 0 : res = gfc_trans_label_here (code);
8116 : 0 : gfc_add_expr_to_block (pblock, res);
8117 : : }
8118 : :
8119 : : /* No dependence analysis, use for clauses with wait.
8120 : : If this is the last gfc_code, use default omp_clauses. */
8121 : 197 : if (code->next == NULL && clauses->nowait)
8122 : 60 : ompws_flags |= OMPWS_NOWAIT;
8123 : :
8124 : : /* By default, every gfc_code is a single unit of work. */
8125 : 197 : ompws_flags |= OMPWS_CURR_SINGLEUNIT;
8126 : 197 : ompws_flags &= ~(OMPWS_SCALARIZER_WS | OMPWS_SCALARIZER_BODY);
8127 : :
8128 : 197 : switch (code->op)
8129 : : {
8130 : : case EXEC_NOP:
8131 : : res = NULL_TREE;
8132 : : break;
8133 : :
8134 : 125 : case EXEC_ASSIGN:
8135 : 125 : res = gfc_trans_assign (code);
8136 : 125 : break;
8137 : :
8138 : 0 : case EXEC_POINTER_ASSIGN:
8139 : 0 : res = gfc_trans_pointer_assign (code);
8140 : 0 : break;
8141 : :
8142 : 0 : case EXEC_INIT_ASSIGN:
8143 : 0 : res = gfc_trans_init_assign (code);
8144 : 0 : break;
8145 : :
8146 : 24 : case EXEC_FORALL:
8147 : 24 : res = gfc_trans_forall (code);
8148 : 24 : break;
8149 : :
8150 : 19 : case EXEC_WHERE:
8151 : 19 : res = gfc_trans_where (code);
8152 : 19 : break;
8153 : :
8154 : 7 : case EXEC_OMP_ATOMIC:
8155 : 7 : res = gfc_trans_omp_directive (code);
8156 : 7 : break;
8157 : :
8158 : 17 : case EXEC_OMP_PARALLEL:
8159 : 17 : case EXEC_OMP_PARALLEL_DO:
8160 : 17 : case EXEC_OMP_PARALLEL_MASTER:
8161 : 17 : case EXEC_OMP_PARALLEL_SECTIONS:
8162 : 17 : case EXEC_OMP_PARALLEL_WORKSHARE:
8163 : 17 : case EXEC_OMP_CRITICAL:
8164 : 17 : saved_ompws_flags = ompws_flags;
8165 : 17 : ompws_flags = 0;
8166 : 17 : res = gfc_trans_omp_directive (code);
8167 : 17 : ompws_flags = saved_ompws_flags;
8168 : 17 : break;
8169 : :
8170 : 5 : case EXEC_BLOCK:
8171 : 5 : res = gfc_trans_block_construct (code);
8172 : 5 : break;
8173 : :
8174 : 0 : default:
8175 : 0 : gfc_internal_error ("gfc_trans_omp_workshare(): Bad statement code");
8176 : : }
8177 : :
8178 : 197 : input_location = gfc_get_location (&code->loc);
8179 : :
8180 : 197 : if (res != NULL_TREE && ! IS_EMPTY_STMT (res))
8181 : : {
8182 : 197 : if (prev_singleunit)
8183 : : {
8184 : 72 : if (ompws_flags & OMPWS_CURR_SINGLEUNIT)
8185 : : /* Add current gfc_code to single block. */
8186 : 44 : gfc_add_expr_to_block (&singleblock, res);
8187 : : else
8188 : : {
8189 : : /* Finish single block and add it to pblock. */
8190 : 28 : tmp = gfc_finish_block (&singleblock);
8191 : 28 : tmp = build2_loc (loc, OMP_SINGLE,
8192 : : void_type_node, tmp, NULL_TREE);
8193 : 28 : gfc_add_expr_to_block (pblock, tmp);
8194 : : /* Add current gfc_code to pblock. */
8195 : 28 : gfc_add_expr_to_block (pblock, res);
8196 : 28 : singleblock_in_progress = false;
8197 : : }
8198 : : }
8199 : : else
8200 : : {
8201 : 125 : if (ompws_flags & OMPWS_CURR_SINGLEUNIT)
8202 : : {
8203 : : /* Start single block. */
8204 : 73 : gfc_init_block (&singleblock);
8205 : 73 : gfc_add_expr_to_block (&singleblock, res);
8206 : 73 : singleblock_in_progress = true;
8207 : 73 : loc = gfc_get_location (&code->loc);
8208 : : }
8209 : : else
8210 : : /* Add the new statement to the block. */
8211 : 52 : gfc_add_expr_to_block (pblock, res);
8212 : : }
8213 : 197 : prev_singleunit = (ompws_flags & OMPWS_CURR_SINGLEUNIT) != 0;
8214 : : }
8215 : : }
8216 : :
8217 : : /* Finish remaining SINGLE block, if we were in the middle of one. */
8218 : 85 : if (singleblock_in_progress)
8219 : : {
8220 : : /* Finish single block and add it to pblock. */
8221 : 45 : tmp = gfc_finish_block (&singleblock);
8222 : 45 : tmp = build2_loc (loc, OMP_SINGLE, void_type_node, tmp,
8223 : 45 : clauses->nowait
8224 : 27 : ? build_omp_clause (input_location, OMP_CLAUSE_NOWAIT)
8225 : : : NULL_TREE);
8226 : 45 : gfc_add_expr_to_block (pblock, tmp);
8227 : : }
8228 : :
8229 : 85 : stmt = gfc_finish_block (pblock);
8230 : 85 : if (TREE_CODE (stmt) != BIND_EXPR)
8231 : : {
8232 : 65 : if (!IS_EMPTY_STMT (stmt))
8233 : : {
8234 : 65 : tree bindblock = poplevel (1, 0);
8235 : 65 : stmt = build3_v (BIND_EXPR, NULL, stmt, bindblock);
8236 : : }
8237 : : else
8238 : 0 : poplevel (0, 0);
8239 : : }
8240 : : else
8241 : 20 : poplevel (0, 0);
8242 : :
8243 : 85 : if (IS_EMPTY_STMT (stmt) && !clauses->nowait)
8244 : 0 : stmt = gfc_trans_omp_barrier ();
8245 : :
8246 : 85 : ompws_flags = 0;
8247 : 85 : return stmt;
8248 : : }
8249 : :
8250 : : tree
8251 : 74 : gfc_trans_oacc_declare (gfc_code *code)
8252 : : {
8253 : 74 : stmtblock_t block;
8254 : 74 : tree stmt, oacc_clauses;
8255 : 74 : enum tree_code construct_code;
8256 : :
8257 : 74 : construct_code = OACC_DATA;
8258 : :
8259 : 74 : gfc_start_block (&block);
8260 : :
8261 : 74 : oacc_clauses = gfc_trans_omp_clauses (&block, code->ext.oacc_declare->clauses,
8262 : : code->loc, false, true);
8263 : 74 : stmt = gfc_trans_omp_code (code->block->next, true);
8264 : 74 : stmt = build2_loc (input_location, construct_code, void_type_node, stmt,
8265 : : oacc_clauses);
8266 : 74 : gfc_add_expr_to_block (&block, stmt);
8267 : :
8268 : 74 : return gfc_finish_block (&block);
8269 : : }
8270 : :
8271 : : tree
8272 : 11347 : gfc_trans_oacc_directive (gfc_code *code)
8273 : : {
8274 : 11347 : switch (code->op)
8275 : : {
8276 : 1374 : case EXEC_OACC_PARALLEL_LOOP:
8277 : 1374 : case EXEC_OACC_KERNELS_LOOP:
8278 : 1374 : case EXEC_OACC_SERIAL_LOOP:
8279 : 1374 : return gfc_trans_oacc_combined_directive (code);
8280 : 4028 : case EXEC_OACC_PARALLEL:
8281 : 4028 : case EXEC_OACC_KERNELS:
8282 : 4028 : case EXEC_OACC_SERIAL:
8283 : 4028 : case EXEC_OACC_DATA:
8284 : 4028 : case EXEC_OACC_HOST_DATA:
8285 : 4028 : return gfc_trans_oacc_construct (code);
8286 : 3086 : case EXEC_OACC_LOOP:
8287 : 3086 : return gfc_trans_omp_do (code, code->op, NULL, code->ext.omp_clauses,
8288 : 3086 : NULL);
8289 : 2075 : case EXEC_OACC_UPDATE:
8290 : 2075 : case EXEC_OACC_CACHE:
8291 : 2075 : case EXEC_OACC_ENTER_DATA:
8292 : 2075 : case EXEC_OACC_EXIT_DATA:
8293 : 2075 : return gfc_trans_oacc_executable_directive (code);
8294 : 167 : case EXEC_OACC_WAIT:
8295 : 167 : return gfc_trans_oacc_wait_directive (code);
8296 : 543 : case EXEC_OACC_ATOMIC:
8297 : 543 : return gfc_trans_omp_atomic (code);
8298 : 74 : case EXEC_OACC_DECLARE:
8299 : 74 : return gfc_trans_oacc_declare (code);
8300 : 0 : default:
8301 : 0 : gcc_unreachable ();
8302 : : }
8303 : : }
8304 : :
8305 : : tree
8306 : 18149 : gfc_trans_omp_directive (gfc_code *code)
8307 : : {
8308 : 18149 : switch (code->op)
8309 : : {
8310 : 31 : case EXEC_OMP_ALLOCATE:
8311 : 31 : case EXEC_OMP_ALLOCATORS:
8312 : 31 : return gfc_trans_omp_allocators (code);
8313 : 10 : case EXEC_OMP_ASSUME:
8314 : 10 : return gfc_trans_omp_assume (code);
8315 : 2070 : case EXEC_OMP_ATOMIC:
8316 : 2070 : return gfc_trans_omp_atomic (code);
8317 : 602 : case EXEC_OMP_BARRIER:
8318 : 602 : return gfc_trans_omp_barrier ();
8319 : 310 : case EXEC_OMP_CANCEL:
8320 : 310 : return gfc_trans_omp_cancel (code);
8321 : 170 : case EXEC_OMP_CANCELLATION_POINT:
8322 : 170 : return gfc_trans_omp_cancellation_point (code);
8323 : 143 : case EXEC_OMP_CRITICAL:
8324 : 143 : return gfc_trans_omp_critical (code);
8325 : 106 : case EXEC_OMP_DEPOBJ:
8326 : 106 : return gfc_trans_omp_depobj (code);
8327 : 2462 : case EXEC_OMP_DISTRIBUTE:
8328 : 2462 : case EXEC_OMP_DO:
8329 : 2462 : case EXEC_OMP_LOOP:
8330 : 2462 : case EXEC_OMP_SIMD:
8331 : 2462 : case EXEC_OMP_TASKLOOP:
8332 : 2462 : case EXEC_OMP_TILE:
8333 : 2462 : case EXEC_OMP_UNROLL:
8334 : 2462 : return gfc_trans_omp_do (code, code->op, NULL, code->ext.omp_clauses,
8335 : 2462 : NULL);
8336 : 105 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
8337 : 105 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
8338 : 105 : case EXEC_OMP_DISTRIBUTE_SIMD:
8339 : 105 : return gfc_trans_omp_distribute (code, NULL);
8340 : 126 : case EXEC_OMP_DO_SIMD:
8341 : 126 : return gfc_trans_omp_do_simd (code, NULL, NULL, NULL_TREE);
8342 : 18 : case EXEC_OMP_ERROR:
8343 : 18 : return gfc_trans_omp_error (code);
8344 : 69 : case EXEC_OMP_FLUSH:
8345 : 69 : return gfc_trans_omp_flush (code);
8346 : 38 : case EXEC_OMP_MASKED:
8347 : 38 : return gfc_trans_omp_masked (code, NULL);
8348 : 104 : case EXEC_OMP_MASTER:
8349 : 104 : return gfc_trans_omp_master (code);
8350 : 45 : case EXEC_OMP_MASKED_TASKLOOP:
8351 : 45 : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
8352 : 45 : case EXEC_OMP_MASTER_TASKLOOP:
8353 : 45 : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
8354 : 45 : return gfc_trans_omp_master_masked_taskloop (code, code->op);
8355 : 519 : case EXEC_OMP_ORDERED:
8356 : 519 : return gfc_trans_omp_ordered (code);
8357 : 1851 : case EXEC_OMP_PARALLEL:
8358 : 1851 : return gfc_trans_omp_parallel (code);
8359 : 1070 : case EXEC_OMP_PARALLEL_DO:
8360 : 1070 : return gfc_trans_omp_parallel_do (code, false, NULL, NULL);
8361 : 10 : case EXEC_OMP_PARALLEL_LOOP:
8362 : 10 : return gfc_trans_omp_parallel_do (code, true, NULL, NULL);
8363 : 278 : case EXEC_OMP_PARALLEL_DO_SIMD:
8364 : 278 : return gfc_trans_omp_parallel_do_simd (code, NULL, NULL);
8365 : 61 : case EXEC_OMP_PARALLEL_MASKED:
8366 : 61 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
8367 : 61 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
8368 : 61 : case EXEC_OMP_PARALLEL_MASTER:
8369 : 61 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
8370 : 61 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
8371 : 61 : return gfc_trans_omp_parallel_master_masked (code);
8372 : 54 : case EXEC_OMP_PARALLEL_SECTIONS:
8373 : 54 : return gfc_trans_omp_parallel_sections (code);
8374 : 50 : case EXEC_OMP_PARALLEL_WORKSHARE:
8375 : 50 : return gfc_trans_omp_parallel_workshare (code);
8376 : 53 : case EXEC_OMP_SCOPE:
8377 : 53 : return gfc_trans_omp_scope (code);
8378 : 75 : case EXEC_OMP_SECTIONS:
8379 : 75 : return gfc_trans_omp_sections (code, code->ext.omp_clauses);
8380 : 565 : case EXEC_OMP_SINGLE:
8381 : 565 : return gfc_trans_omp_single (code, code->ext.omp_clauses);
8382 : 1812 : case EXEC_OMP_TARGET:
8383 : 1812 : case EXEC_OMP_TARGET_PARALLEL:
8384 : 1812 : case EXEC_OMP_TARGET_PARALLEL_DO:
8385 : 1812 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
8386 : 1812 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
8387 : 1812 : case EXEC_OMP_TARGET_SIMD:
8388 : 1812 : case EXEC_OMP_TARGET_TEAMS:
8389 : 1812 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
8390 : 1812 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
8391 : 1812 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
8392 : 1812 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
8393 : 1812 : case EXEC_OMP_TARGET_TEAMS_LOOP:
8394 : 1812 : return gfc_trans_omp_target (code);
8395 : 1379 : case EXEC_OMP_TARGET_DATA:
8396 : 1379 : return gfc_trans_omp_target_data (code);
8397 : 264 : case EXEC_OMP_TARGET_ENTER_DATA:
8398 : 264 : return gfc_trans_omp_target_enter_data (code);
8399 : 208 : case EXEC_OMP_TARGET_EXIT_DATA:
8400 : 208 : return gfc_trans_omp_target_exit_data (code);
8401 : 1701 : case EXEC_OMP_TARGET_UPDATE:
8402 : 1701 : return gfc_trans_omp_target_update (code);
8403 : 1121 : case EXEC_OMP_TASK:
8404 : 1121 : return gfc_trans_omp_task (code);
8405 : 181 : case EXEC_OMP_TASKGROUP:
8406 : 181 : return gfc_trans_omp_taskgroup (code);
8407 : 31 : case EXEC_OMP_TASKLOOP_SIMD:
8408 : 31 : return gfc_trans_omp_taskloop (code, code->op);
8409 : 143 : case EXEC_OMP_TASKWAIT:
8410 : 143 : return gfc_trans_omp_taskwait (code);
8411 : 8 : case EXEC_OMP_TASKYIELD:
8412 : 8 : return gfc_trans_omp_taskyield ();
8413 : 266 : case EXEC_OMP_TEAMS:
8414 : 266 : case EXEC_OMP_TEAMS_DISTRIBUTE:
8415 : 266 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
8416 : 266 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
8417 : 266 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
8418 : 266 : case EXEC_OMP_TEAMS_LOOP:
8419 : 266 : return gfc_trans_omp_teams (code, NULL, NULL_TREE);
8420 : 35 : case EXEC_OMP_WORKSHARE:
8421 : 35 : return gfc_trans_omp_workshare (code, code->ext.omp_clauses);
8422 : 5 : case EXEC_OMP_INTEROP:
8423 : 5 : return gfc_trans_openmp_interop (code, code->ext.omp_clauses);
8424 : 0 : default:
8425 : 0 : gcc_unreachable ();
8426 : : }
8427 : : }
8428 : :
8429 : : void
8430 : 114 : gfc_trans_omp_declare_simd (gfc_namespace *ns)
8431 : : {
8432 : 114 : if (ns->entries)
8433 : : return;
8434 : :
8435 : 114 : gfc_omp_declare_simd *ods;
8436 : 272 : for (ods = ns->omp_declare_simd; ods; ods = ods->next)
8437 : : {
8438 : 158 : tree c = gfc_trans_omp_clauses (NULL, ods->clauses, ods->where, true);
8439 : 158 : tree fndecl = ns->proc_name->backend_decl;
8440 : 158 : if (c != NULL_TREE)
8441 : 108 : c = tree_cons (NULL_TREE, c, NULL_TREE);
8442 : 158 : c = build_tree_list (get_identifier ("omp declare simd"), c);
8443 : 158 : TREE_CHAIN (c) = DECL_ATTRIBUTES (fndecl);
8444 : 158 : DECL_ATTRIBUTES (fndecl) = c;
8445 : : }
8446 : : }
8447 : :
8448 : : void
8449 : 9661 : gfc_trans_omp_declare_variant (gfc_namespace *ns)
8450 : : {
8451 : 9661 : tree base_fn_decl = ns->proc_name->backend_decl;
8452 : 9661 : gfc_namespace *search_ns = ns;
8453 : 9661 : gfc_omp_declare_variant *next;
8454 : :
8455 : 9661 : for (gfc_omp_declare_variant *odv = search_ns->omp_declare_variant;
8456 : 24357 : search_ns; odv = next)
8457 : : {
8458 : : /* Look in the parent namespace if there are no more directives in the
8459 : : current namespace. */
8460 : 14696 : if (!odv)
8461 : : {
8462 : 14405 : search_ns = search_ns->parent;
8463 : 14405 : if (search_ns)
8464 : 4744 : next = search_ns->omp_declare_variant;
8465 : 14405 : continue;
8466 : : }
8467 : :
8468 : 291 : next = odv->next;
8469 : :
8470 : 291 : if (odv->error_p)
8471 : 17 : continue;
8472 : :
8473 : : /* Check directive the first time it is encountered. */
8474 : 274 : bool error_found = true;
8475 : :
8476 : 274 : if (odv->checked_p)
8477 : 32 : error_found = false;
8478 : 274 : if (odv->base_proc_symtree == NULL)
8479 : : {
8480 : 259 : if (!search_ns->proc_name->attr.function
8481 : 259 : && !search_ns->proc_name->attr.subroutine)
8482 : 1 : gfc_error ("The base name for %<declare variant%> must be "
8483 : : "specified at %L ", &odv->where);
8484 : : else
8485 : : error_found = false;
8486 : : }
8487 : : else
8488 : : {
8489 : 15 : if (!search_ns->contained
8490 : 3 : && strcmp (odv->base_proc_symtree->name,
8491 : 3 : ns->proc_name->name))
8492 : 1 : gfc_error ("The base name at %L does not match the name of the "
8493 : : "current procedure", &odv->where);
8494 : 14 : else if (odv->base_proc_symtree->n.sym->attr.entry)
8495 : 1 : gfc_error ("The base name at %L must not be an entry name",
8496 : : &odv->where);
8497 : 13 : else if (odv->base_proc_symtree->n.sym->attr.generic)
8498 : 1 : gfc_error ("The base name at %L must not be a generic name",
8499 : : &odv->where);
8500 : 12 : else if (odv->base_proc_symtree->n.sym->attr.proc_pointer)
8501 : 1 : gfc_error ("The base name at %L must not be a procedure pointer",
8502 : : &odv->where);
8503 : 11 : else if (odv->base_proc_symtree->n.sym->attr.implicit_type)
8504 : 1 : gfc_error ("The base procedure at %L must have an explicit "
8505 : : "interface", &odv->where);
8506 : : else
8507 : : error_found = false;
8508 : : }
8509 : :
8510 : 274 : odv->checked_p = true;
8511 : 274 : if (error_found)
8512 : : {
8513 : 6 : odv->error_p = true;
8514 : 6 : continue;
8515 : : }
8516 : :
8517 : : /* Ignore directives that do not apply to the current procedure. */
8518 : 268 : if ((odv->base_proc_symtree == NULL && search_ns != ns)
8519 : 242 : || (odv->base_proc_symtree != NULL
8520 : 10 : && strcmp (odv->base_proc_symtree->name, ns->proc_name->name)))
8521 : 33 : continue;
8522 : :
8523 : 235 : tree set_selectors = NULL_TREE;
8524 : 235 : gfc_omp_set_selector *oss;
8525 : :
8526 : 518 : for (oss = odv->set_selectors; oss; oss = oss->next)
8527 : : {
8528 : 283 : tree selectors = NULL_TREE;
8529 : 283 : gfc_omp_selector *os;
8530 : 283 : enum omp_tss_code set = oss->code;
8531 : 283 : gcc_assert (set != OMP_TRAIT_SET_INVALID);
8532 : :
8533 : 662 : for (os = oss->trait_selectors; os; os = os->next)
8534 : : {
8535 : 379 : tree scoreval = NULL_TREE;
8536 : 379 : tree properties = NULL_TREE;
8537 : 379 : gfc_omp_trait_property *otp;
8538 : 379 : enum omp_ts_code sel = os->code;
8539 : :
8540 : : /* Per the spec, "Implementations can ignore specified
8541 : : selectors that are not those described in this section";
8542 : : however, we must record such selectors because they
8543 : : cause match failures. */
8544 : 379 : if (sel == OMP_TRAIT_INVALID)
8545 : : {
8546 : 1 : selectors = make_trait_selector (sel, NULL_TREE, NULL_TREE,
8547 : : selectors);
8548 : 1 : continue;
8549 : : }
8550 : :
8551 : 652 : for (otp = os->properties; otp; otp = otp->next)
8552 : : {
8553 : 274 : switch (otp->property_kind)
8554 : : {
8555 : 33 : case OMP_TRAIT_PROPERTY_DEV_NUM_EXPR:
8556 : 33 : case OMP_TRAIT_PROPERTY_BOOL_EXPR:
8557 : 33 : {
8558 : 33 : gfc_se se;
8559 : 33 : gfc_init_se (&se, NULL);
8560 : 33 : gfc_conv_expr (&se, otp->expr);
8561 : 33 : properties = make_trait_property (NULL_TREE, se.expr,
8562 : : properties);
8563 : : }
8564 : 33 : break;
8565 : 22 : case OMP_TRAIT_PROPERTY_ID:
8566 : 22 : properties
8567 : 22 : = make_trait_property (get_identifier (otp->name),
8568 : : NULL_TREE, properties);
8569 : 22 : break;
8570 : 205 : case OMP_TRAIT_PROPERTY_NAME_LIST:
8571 : 205 : {
8572 : 205 : tree prop = OMP_TP_NAMELIST_NODE;
8573 : 205 : tree value = NULL_TREE;
8574 : 205 : if (otp->is_name)
8575 : 160 : value = get_identifier (otp->name);
8576 : : else
8577 : 45 : value = gfc_conv_constant_to_tree (otp->expr);
8578 : :
8579 : 205 : properties = make_trait_property (prop, value,
8580 : : properties);
8581 : : }
8582 : 205 : break;
8583 : 14 : case OMP_TRAIT_PROPERTY_CLAUSE_LIST:
8584 : 14 : properties = gfc_trans_omp_clauses (NULL, otp->clauses,
8585 : : odv->where, true);
8586 : 14 : break;
8587 : 0 : default:
8588 : 0 : gcc_unreachable ();
8589 : : }
8590 : : }
8591 : :
8592 : 378 : if (os->score)
8593 : : {
8594 : 49 : gfc_se se;
8595 : 49 : gfc_init_se (&se, NULL);
8596 : 49 : gfc_conv_expr (&se, os->score);
8597 : 49 : scoreval = se.expr;
8598 : : }
8599 : :
8600 : 378 : selectors = make_trait_selector (sel, scoreval,
8601 : : properties, selectors);
8602 : : }
8603 : 283 : set_selectors = make_trait_set_selector (set, selectors,
8604 : : set_selectors);
8605 : : }
8606 : :
8607 : 235 : const char *variant_proc_name = odv->variant_proc_symtree->name;
8608 : 235 : gfc_symbol *variant_proc_sym = odv->variant_proc_symtree->n.sym;
8609 : 235 : if (variant_proc_sym == NULL || variant_proc_sym->attr.implicit_type)
8610 : : {
8611 : 14 : gfc_symtree *proc_st;
8612 : 14 : gfc_find_sym_tree (variant_proc_name, gfc_current_ns, 1, &proc_st);
8613 : 14 : variant_proc_sym = proc_st->n.sym;
8614 : : }
8615 : 14 : if (variant_proc_sym == NULL)
8616 : : {
8617 : 0 : gfc_error ("Cannot find symbol %qs", variant_proc_name);
8618 : 0 : continue;
8619 : : }
8620 : 235 : set_selectors = omp_check_context_selector
8621 : 235 : (gfc_get_location (&odv->where), set_selectors);
8622 : 235 : if (set_selectors != error_mark_node)
8623 : : {
8624 : 215 : if (!variant_proc_sym->attr.implicit_type
8625 : : && !variant_proc_sym->attr.subroutine
8626 : 215 : && !variant_proc_sym->attr.function)
8627 : : {
8628 : 0 : gfc_error ("variant %qs at %L is not a function or subroutine",
8629 : : variant_proc_name, &odv->where);
8630 : 0 : variant_proc_sym = NULL;
8631 : : }
8632 : 215 : else if (omp_get_context_selector (set_selectors,
8633 : : OMP_TRAIT_SET_CONSTRUCT,
8634 : : OMP_TRAIT_CONSTRUCT_SIMD)
8635 : : == NULL_TREE)
8636 : : {
8637 : 201 : char err[256];
8638 : 201 : if (!gfc_compare_interfaces (ns->proc_name, variant_proc_sym,
8639 : : variant_proc_sym->name, 0, 1,
8640 : : err, sizeof (err), NULL, NULL))
8641 : : {
8642 : 2 : gfc_error ("variant %qs and base %qs at %L have "
8643 : : "incompatible types: %s",
8644 : 2 : variant_proc_name, ns->proc_name->name,
8645 : : &odv->where, err);
8646 : 2 : variant_proc_sym = NULL;
8647 : : }
8648 : : }
8649 : 201 : if (variant_proc_sym != NULL)
8650 : : {
8651 : 213 : gfc_set_sym_referenced (variant_proc_sym);
8652 : 213 : tree construct
8653 : 213 : = omp_get_context_selector_list (set_selectors,
8654 : : OMP_TRAIT_SET_CONSTRUCT);
8655 : 213 : omp_mark_declare_variant (gfc_get_location (&odv->where),
8656 : : gfc_get_symbol_decl (variant_proc_sym),
8657 : : construct);
8658 : 213 : if (omp_context_selector_matches (set_selectors))
8659 : : {
8660 : 134 : tree id = get_identifier ("omp declare variant base");
8661 : 134 : tree variant = gfc_get_symbol_decl (variant_proc_sym);
8662 : 134 : DECL_ATTRIBUTES (base_fn_decl)
8663 : 268 : = tree_cons (id, build_tree_list (variant, set_selectors),
8664 : 134 : DECL_ATTRIBUTES (base_fn_decl));
8665 : : }
8666 : : }
8667 : : }
8668 : : }
8669 : 9661 : }
8670 : :
8671 : : /* Add ptr for tracking as being allocated by GOMP_alloc. */
8672 : :
8673 : : tree
8674 : 29 : gfc_omp_call_add_alloc (tree ptr)
8675 : : {
8676 : 29 : static tree fn = NULL_TREE;
8677 : 29 : if (fn == NULL_TREE)
8678 : : {
8679 : 6 : fn = build_function_type_list (void_type_node, ptr_type_node, NULL_TREE);
8680 : 6 : tree att = build_tree_list (NULL_TREE, build_string (4, ". R "));
8681 : 6 : att = tree_cons (get_identifier ("fn spec"), att, TYPE_ATTRIBUTES (fn));
8682 : 6 : fn = build_type_attribute_variant (fn, att);
8683 : 6 : fn = build_fn_decl ("GOMP_add_alloc", fn);
8684 : : }
8685 : 29 : return build_call_expr_loc (input_location, fn, 1, ptr);
8686 : : }
8687 : :
8688 : : /* Generated function returns true when it was tracked via GOMP_add_alloc and
8689 : : removes it from the tracking. As called just before GOMP_free or omp_realloc
8690 : : the pointer is or might become invalid, thus, it is always removed. */
8691 : :
8692 : : tree
8693 : 47 : gfc_omp_call_is_alloc (tree ptr)
8694 : : {
8695 : 47 : static tree fn = NULL_TREE;
8696 : 47 : if (fn == NULL_TREE)
8697 : : {
8698 : 6 : fn = build_function_type_list (boolean_type_node, ptr_type_node,
8699 : : NULL_TREE);
8700 : 6 : tree att = build_tree_list (NULL_TREE, build_string (4, ". R "));
8701 : 6 : att = tree_cons (get_identifier ("fn spec"), att, TYPE_ATTRIBUTES (fn));
8702 : 6 : fn = build_type_attribute_variant (fn, att);
8703 : 6 : fn = build_fn_decl ("GOMP_is_alloc", fn);
8704 : : }
8705 : 47 : return build_call_expr_loc (input_location, fn, 1, ptr);
8706 : : }
|
