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