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