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