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