?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
svn merge -r 217500:218679 svn+ssh://gcc.gnu.org/svn/gcc/trunk
[official-gcc.git] / gcc / fortran / trans-openmp.c
blobbdc00c84c77b7682359a690467ca0230a3576369
1 /* OpenMP directive translation -- generate GCC trees from gfc_code.
2 Copyright (C) 2005-2014 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 "tree.h"
26 #include "gimple-expr.h"
27 #include "gimplify.h" /* For create_tmp_var_raw. */
28 #include "stringpool.h"
29 #include "gfortran.h"
30 #include "diagnostic-core.h" /* For internal_error. */
31 #include "trans.h"
32 #include "trans-stmt.h"
33 #include "trans-types.h"
34 #include "trans-array.h"
35 #include "trans-const.h"
36 #include "arith.h"
37 #include "omp-low.h"
38
39 int ompws_flags;
40
41 /* True if OpenMP should privatize what this DECL points to rather
42 than the DECL itself. */
43
44 bool
45 gfc_omp_privatize_by_reference (const_tree decl)
46 {
47 tree type = TREE_TYPE (decl);
48
49 if (TREE_CODE (type) == REFERENCE_TYPE
50 && (!DECL_ARTIFICIAL (decl) || TREE_CODE (decl) == PARM_DECL))
51 return true;
52
53 if (TREE_CODE (type) == POINTER_TYPE)
54 {
55 /* Array POINTER/ALLOCATABLE have aggregate types, all user variables
56 that have POINTER_TYPE type and aren't scalar pointers, scalar
57 allocatables, Cray pointees or C pointers are supposed to be
58 privatized by reference. */
59 if (GFC_DECL_GET_SCALAR_POINTER (decl)
60 || GFC_DECL_GET_SCALAR_ALLOCATABLE (decl)
61 || GFC_DECL_CRAY_POINTEE (decl)
62 || VOID_TYPE_P (TREE_TYPE (TREE_TYPE (decl))))
63 return false;
64
65 if (!DECL_ARTIFICIAL (decl)
66 && TREE_CODE (TREE_TYPE (type)) != FUNCTION_TYPE)
67 return true;
68
69 /* Some arrays are expanded as DECL_ARTIFICIAL pointers
70 by the frontend. */
71 if (DECL_LANG_SPECIFIC (decl)
72 && GFC_DECL_SAVED_DESCRIPTOR (decl))
73 return true;
74 }
75
76 return false;
77 }
78
79 /* True if OpenMP sharing attribute of DECL is predetermined. */
80
81 enum omp_clause_default_kind
82 gfc_omp_predetermined_sharing (tree decl)
83 {
84 /* Associate names preserve the association established during ASSOCIATE.
85 As they are implemented either as pointers to the selector or array
86 descriptor and shouldn't really change in the ASSOCIATE region,
87 this decl can be either shared or firstprivate. If it is a pointer,
88 use firstprivate, as it is cheaper that way, otherwise make it shared. */
89 if (GFC_DECL_ASSOCIATE_VAR_P (decl))
90 {
91 if (TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE)
92 return OMP_CLAUSE_DEFAULT_FIRSTPRIVATE;
93 else
94 return OMP_CLAUSE_DEFAULT_SHARED;
95 }
96
97 if (DECL_ARTIFICIAL (decl)
98 && ! GFC_DECL_RESULT (decl)
99 && ! (DECL_LANG_SPECIFIC (decl)
100 && GFC_DECL_SAVED_DESCRIPTOR (decl)))
101 return OMP_CLAUSE_DEFAULT_SHARED;
102
103 /* Cray pointees shouldn't be listed in any clauses and should be
104 gimplified to dereference of the corresponding Cray pointer.
105 Make them all private, so that they are emitted in the debug
106 information. */
107 if (GFC_DECL_CRAY_POINTEE (decl))
108 return OMP_CLAUSE_DEFAULT_PRIVATE;
109
110 /* Assumed-size arrays are predetermined shared. */
111 if (TREE_CODE (decl) == PARM_DECL
112 && GFC_ARRAY_TYPE_P (TREE_TYPE (decl))
113 && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (decl)) == GFC_ARRAY_UNKNOWN
114 && GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (decl),
115 GFC_TYPE_ARRAY_RANK (TREE_TYPE (decl)) - 1)
116 == NULL)
117 return OMP_CLAUSE_DEFAULT_SHARED;
118
119 /* Dummy procedures aren't considered variables by OpenMP, thus are
120 disallowed in OpenMP clauses. They are represented as PARM_DECLs
121 in the middle-end, so return OMP_CLAUSE_DEFAULT_FIRSTPRIVATE here
122 to avoid complaining about their uses with default(none). */
123 if (TREE_CODE (decl) == PARM_DECL
124 && TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE
125 && TREE_CODE (TREE_TYPE (TREE_TYPE (decl))) == FUNCTION_TYPE)
126 return OMP_CLAUSE_DEFAULT_FIRSTPRIVATE;
127
128 /* COMMON and EQUIVALENCE decls are shared. They
129 are only referenced through DECL_VALUE_EXPR of the variables
130 contained in them. If those are privatized, they will not be
131 gimplified to the COMMON or EQUIVALENCE decls. */
132 if (GFC_DECL_COMMON_OR_EQUIV (decl) && ! DECL_HAS_VALUE_EXPR_P (decl))
133 return OMP_CLAUSE_DEFAULT_SHARED;
134
135 if (GFC_DECL_RESULT (decl) && ! DECL_HAS_VALUE_EXPR_P (decl))
136 return OMP_CLAUSE_DEFAULT_SHARED;
137
138 /* These are either array or derived parameters, or vtables.
139 In the former cases, the OpenMP standard doesn't consider them to be
140 variables at all (they can't be redefined), but they can nevertheless appear
141 in parallel/task regions and for default(none) purposes treat them as shared.
142 For vtables likely the same handling is desirable. */
143 if (TREE_CODE (decl) == VAR_DECL
144 && TREE_READONLY (decl)
145 && TREE_STATIC (decl))
146 return OMP_CLAUSE_DEFAULT_SHARED;
147
148 return OMP_CLAUSE_DEFAULT_UNSPECIFIED;
149 }
150
151 /* Return decl that should be used when reporting DEFAULT(NONE)
152 diagnostics. */
153
154 tree
155 gfc_omp_report_decl (tree decl)
156 {
157 if (DECL_ARTIFICIAL (decl)
158 && DECL_LANG_SPECIFIC (decl)
159 && GFC_DECL_SAVED_DESCRIPTOR (decl))
160 return GFC_DECL_SAVED_DESCRIPTOR (decl);
161
162 return decl;
163 }
164
165 /* Return true if TYPE has any allocatable components. */
166
167 static bool
168 gfc_has_alloc_comps (tree type, tree decl)
169 {
170 tree field, ftype;
171
172 if (POINTER_TYPE_P (type))
173 {
174 if (GFC_DECL_GET_SCALAR_ALLOCATABLE (decl))
175 type = TREE_TYPE (type);
176 else if (GFC_DECL_GET_SCALAR_POINTER (decl))
177 return false;
178 }
179
180 while (GFC_DESCRIPTOR_TYPE_P (type) || GFC_ARRAY_TYPE_P (type))
181 type = gfc_get_element_type (type);
182
183 if (TREE_CODE (type) != RECORD_TYPE)
184 return false;
185
186 for (field = TYPE_FIELDS (type); field; field = DECL_CHAIN (field))
187 {
188 ftype = TREE_TYPE (field);
189 if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field))
190 return true;
191 if (GFC_DESCRIPTOR_TYPE_P (ftype)
192 && GFC_TYPE_ARRAY_AKIND (ftype) == GFC_ARRAY_ALLOCATABLE)
193 return true;
194 if (gfc_has_alloc_comps (ftype, field))
195 return true;
196 }
197 return false;
198 }
199
200 /* Return true if DECL in private clause needs
201 OMP_CLAUSE_PRIVATE_OUTER_REF on the private clause. */
202 bool
203 gfc_omp_private_outer_ref (tree decl)
204 {
205 tree type = TREE_TYPE (decl);
206
207 if (GFC_DESCRIPTOR_TYPE_P (type)
208 && GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE)
209 return true;
210
211 if (GFC_DECL_GET_SCALAR_ALLOCATABLE (decl))
212 return true;
213
214 if (gfc_omp_privatize_by_reference (decl))
215 type = TREE_TYPE (type);
216
217 if (gfc_has_alloc_comps (type, decl))
218 return true;
219
220 return false;
221 }
222
223 /* Callback for gfc_omp_unshare_expr. */
224
225 static tree
226 gfc_omp_unshare_expr_r (tree *tp, int *walk_subtrees, void *)
227 {
228 tree t = *tp;
229 enum tree_code code = TREE_CODE (t);
230
231 /* Stop at types, decls, constants like copy_tree_r. */
232 if (TREE_CODE_CLASS (code) == tcc_type
233 || TREE_CODE_CLASS (code) == tcc_declaration
234 || TREE_CODE_CLASS (code) == tcc_constant
235 || code == BLOCK)
236 *walk_subtrees = 0;
237 else if (handled_component_p (t)
238 || TREE_CODE (t) == MEM_REF)
239 {
240 *tp = unshare_expr (t);
241 *walk_subtrees = 0;
242 }
243
244 return NULL_TREE;
245 }
246
247 /* Unshare in expr anything that the FE which normally doesn't
248 care much about tree sharing (because during gimplification
249 everything is unshared) could cause problems with tree sharing
250 at omp-low.c time. */
251
252 static tree
253 gfc_omp_unshare_expr (tree expr)
254 {
255 walk_tree (&expr, gfc_omp_unshare_expr_r, NULL, NULL);
256 return expr;
257 }
258
259 enum walk_alloc_comps
260 {
261 WALK_ALLOC_COMPS_DTOR,
262 WALK_ALLOC_COMPS_DEFAULT_CTOR,
263 WALK_ALLOC_COMPS_COPY_CTOR
264 };
265
266 /* Handle allocatable components in OpenMP clauses. */
267
268 static tree
269 gfc_walk_alloc_comps (tree decl, tree dest, tree var,
270 enum walk_alloc_comps kind)
271 {
272 stmtblock_t block, tmpblock;
273 tree type = TREE_TYPE (decl), then_b, tem, field;
274 gfc_init_block (&block);
275
276 if (GFC_ARRAY_TYPE_P (type) || GFC_DESCRIPTOR_TYPE_P (type))
277 {
278 if (GFC_DESCRIPTOR_TYPE_P (type))
279 {
280 gfc_init_block (&tmpblock);
281 tem = gfc_full_array_size (&tmpblock, decl,
282 GFC_TYPE_ARRAY_RANK (type));
283 then_b = gfc_finish_block (&tmpblock);
284 gfc_add_expr_to_block (&block, gfc_omp_unshare_expr (then_b));
285 tem = gfc_omp_unshare_expr (tem);
286 tem = fold_build2_loc (input_location, MINUS_EXPR,
287 gfc_array_index_type, tem,
288 gfc_index_one_node);
289 }
290 else
291 {
292 if (!TYPE_DOMAIN (type)
293 || TYPE_MAX_VALUE (TYPE_DOMAIN (type)) == NULL_TREE
294 || TYPE_MIN_VALUE (TYPE_DOMAIN (type)) == error_mark_node
295 || TYPE_MAX_VALUE (TYPE_DOMAIN (type)) == error_mark_node)
296 {
297 tem = fold_build2 (EXACT_DIV_EXPR, sizetype,
298 TYPE_SIZE_UNIT (type),
299 TYPE_SIZE_UNIT (TREE_TYPE (type)));
300 tem = size_binop (MINUS_EXPR, tem, size_one_node);
301 }
302 else
303 tem = array_type_nelts (type);
304 tem = fold_convert (gfc_array_index_type, tem);
305 }
306
307 tree nelems = gfc_evaluate_now (tem, &block);
308 tree index = gfc_create_var (gfc_array_index_type, "S");
309
310 gfc_init_block (&tmpblock);
311 tem = gfc_conv_array_data (decl);
312 tree declvar = build_fold_indirect_ref_loc (input_location, tem);
313 tree declvref = gfc_build_array_ref (declvar, index, NULL);
314 tree destvar, destvref = NULL_TREE;
315 if (dest)
316 {
317 tem = gfc_conv_array_data (dest);
318 destvar = build_fold_indirect_ref_loc (input_location, tem);
319 destvref = gfc_build_array_ref (destvar, index, NULL);
320 }
321 gfc_add_expr_to_block (&tmpblock,
322 gfc_walk_alloc_comps (declvref, destvref,
323 var, kind));
324
325 gfc_loopinfo loop;
326 gfc_init_loopinfo (&loop);
327 loop.dimen = 1;
328 loop.from[0] = gfc_index_zero_node;
329 loop.loopvar[0] = index;
330 loop.to[0] = nelems;
331 gfc_trans_scalarizing_loops (&loop, &tmpblock);
332 gfc_add_block_to_block (&block, &loop.pre);
333 return gfc_finish_block (&block);
334 }
335 else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (var))
336 {
337 decl = build_fold_indirect_ref_loc (input_location, decl);
338 if (dest)
339 dest = build_fold_indirect_ref_loc (input_location, dest);
340 type = TREE_TYPE (decl);
341 }
342
343 gcc_assert (TREE_CODE (type) == RECORD_TYPE);
344 for (field = TYPE_FIELDS (type); field; field = DECL_CHAIN (field))
345 {
346 tree ftype = TREE_TYPE (field);
347 tree declf, destf = NULL_TREE;
348 bool has_alloc_comps = gfc_has_alloc_comps (ftype, field);
349 if ((!GFC_DESCRIPTOR_TYPE_P (ftype)
350 || GFC_TYPE_ARRAY_AKIND (ftype) != GFC_ARRAY_ALLOCATABLE)
351 && !GFC_DECL_GET_SCALAR_ALLOCATABLE (field)
352 && !has_alloc_comps)
353 continue;
354 declf = fold_build3_loc (input_location, COMPONENT_REF, ftype,
355 decl, field, NULL_TREE);
356 if (dest)
357 destf = fold_build3_loc (input_location, COMPONENT_REF, ftype,
358 dest, field, NULL_TREE);
359
360 tem = NULL_TREE;
361 switch (kind)
362 {
363 case WALK_ALLOC_COMPS_DTOR:
364 break;
365 case WALK_ALLOC_COMPS_DEFAULT_CTOR:
366 if (GFC_DESCRIPTOR_TYPE_P (ftype)
367 && GFC_TYPE_ARRAY_AKIND (ftype) == GFC_ARRAY_ALLOCATABLE)
368 {
369 gfc_add_modify (&block, unshare_expr (destf),
370 unshare_expr (declf));
371 tem = gfc_duplicate_allocatable_nocopy
372 (destf, declf, ftype,
373 GFC_TYPE_ARRAY_RANK (ftype));
374 }
375 else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field))
376 tem = gfc_duplicate_allocatable_nocopy (destf, declf, ftype, 0);
377 break;
378 case WALK_ALLOC_COMPS_COPY_CTOR:
379 if (GFC_DESCRIPTOR_TYPE_P (ftype)
380 && GFC_TYPE_ARRAY_AKIND (ftype) == GFC_ARRAY_ALLOCATABLE)
381 tem = gfc_duplicate_allocatable (destf, declf, ftype,
382 GFC_TYPE_ARRAY_RANK (ftype));
383 else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field))
384 tem = gfc_duplicate_allocatable (destf, declf, ftype, 0);
385 break;
386 }
387 if (tem)
388 gfc_add_expr_to_block (&block, gfc_omp_unshare_expr (tem));
389 if (has_alloc_comps)
390 {
391 gfc_init_block (&tmpblock);
392 gfc_add_expr_to_block (&tmpblock,
393 gfc_walk_alloc_comps (declf, destf,
394 field, kind));
395 then_b = gfc_finish_block (&tmpblock);
396 if (GFC_DESCRIPTOR_TYPE_P (ftype)
397 && GFC_TYPE_ARRAY_AKIND (ftype) == GFC_ARRAY_ALLOCATABLE)
398 tem = gfc_conv_descriptor_data_get (unshare_expr (declf));
399 else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field))
400 tem = unshare_expr (declf);
401 else
402 tem = NULL_TREE;
403 if (tem)
404 {
405 tem = fold_convert (pvoid_type_node, tem);
406 tem = fold_build2_loc (input_location, NE_EXPR,
407 boolean_type_node, tem,
408 null_pointer_node);
409 then_b = build3_loc (input_location, COND_EXPR, void_type_node,
410 tem, then_b,
411 build_empty_stmt (input_location));
412 }
413 gfc_add_expr_to_block (&block, then_b);
414 }
415 if (kind == WALK_ALLOC_COMPS_DTOR)
416 {
417 if (GFC_DESCRIPTOR_TYPE_P (ftype)
418 && GFC_TYPE_ARRAY_AKIND (ftype) == GFC_ARRAY_ALLOCATABLE)
419 {
420 tem = gfc_trans_dealloc_allocated (unshare_expr (declf),
421 false, NULL);
422 gfc_add_expr_to_block (&block, gfc_omp_unshare_expr (tem));
423 }
424 else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field))
425 {
426 tem = gfc_call_free (unshare_expr (declf));
427 gfc_add_expr_to_block (&block, gfc_omp_unshare_expr (tem));
428 }
429 }
430 }
431
432 return gfc_finish_block (&block);
433 }
434
435 /* Return code to initialize DECL with its default constructor, or
436 NULL if there's nothing to do. */
437
438 tree
439 gfc_omp_clause_default_ctor (tree clause, tree decl, tree outer)
440 {
441 tree type = TREE_TYPE (decl), size, ptr, cond, then_b, else_b;
442 stmtblock_t block, cond_block;
443
444 gcc_assert (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_PRIVATE
445 || OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_LASTPRIVATE
446 || OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_LINEAR
447 || OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_REDUCTION);
448
449 if ((! GFC_DESCRIPTOR_TYPE_P (type)
450 || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
451 && !GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause)))
452 {
453 if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause)))
454 {
455 gcc_assert (outer);
456 gfc_start_block (&block);
457 tree tem = gfc_walk_alloc_comps (outer, decl,
458 OMP_CLAUSE_DECL (clause),
459 WALK_ALLOC_COMPS_DEFAULT_CTOR);
460 gfc_add_expr_to_block (&block, tem);
461 return gfc_finish_block (&block);
462 }
463 return NULL_TREE;
464 }
465
466 gcc_assert (outer != NULL_TREE);
467
468 /* Allocatable arrays and scalars in PRIVATE clauses need to be set to
469 "not currently allocated" allocation status if outer
470 array is "not currently allocated", otherwise should be allocated. */
471 gfc_start_block (&block);
472
473 gfc_init_block (&cond_block);
474
475 if (GFC_DESCRIPTOR_TYPE_P (type))
476 {
477 gfc_add_modify (&cond_block, decl, outer);
478 tree rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1];
479 size = gfc_conv_descriptor_ubound_get (decl, rank);
480 size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
481 size,
482 gfc_conv_descriptor_lbound_get (decl, rank));
483 size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
484 size, gfc_index_one_node);
485 if (GFC_TYPE_ARRAY_RANK (type) > 1)
486 size = fold_build2_loc (input_location, MULT_EXPR,
487 gfc_array_index_type, size,
488 gfc_conv_descriptor_stride_get (decl, rank));
489 tree esize = fold_convert (gfc_array_index_type,
490 TYPE_SIZE_UNIT (gfc_get_element_type (type)));
491 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
492 size, esize);
493 size = unshare_expr (size);
494 size = gfc_evaluate_now (fold_convert (size_type_node, size),
495 &cond_block);
496 }
497 else
498 size = fold_convert (size_type_node, TYPE_SIZE_UNIT (TREE_TYPE (type)));
499 ptr = gfc_create_var (pvoid_type_node, NULL);
500 gfc_allocate_using_malloc (&cond_block, ptr, size, NULL_TREE);
501 if (GFC_DESCRIPTOR_TYPE_P (type))
502 gfc_conv_descriptor_data_set (&cond_block, unshare_expr (decl), ptr);
503 else
504 gfc_add_modify (&cond_block, unshare_expr (decl),
505 fold_convert (TREE_TYPE (decl), ptr));
506 if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause)))
507 {
508 tree tem = gfc_walk_alloc_comps (outer, decl,
509 OMP_CLAUSE_DECL (clause),
510 WALK_ALLOC_COMPS_DEFAULT_CTOR);
511 gfc_add_expr_to_block (&cond_block, tem);
512 }
513 then_b = gfc_finish_block (&cond_block);
514
515 /* Reduction clause requires allocated ALLOCATABLE. */
516 if (OMP_CLAUSE_CODE (clause) != OMP_CLAUSE_REDUCTION)
517 {
518 gfc_init_block (&cond_block);
519 if (GFC_DESCRIPTOR_TYPE_P (type))
520 gfc_conv_descriptor_data_set (&cond_block, unshare_expr (decl),
521 null_pointer_node);
522 else
523 gfc_add_modify (&cond_block, unshare_expr (decl),
524 build_zero_cst (TREE_TYPE (decl)));
525 else_b = gfc_finish_block (&cond_block);
526
527 tree tem = fold_convert (pvoid_type_node,
528 GFC_DESCRIPTOR_TYPE_P (type)
529 ? gfc_conv_descriptor_data_get (outer) : outer);
530 tem = unshare_expr (tem);
531 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
532 tem, null_pointer_node);
533 gfc_add_expr_to_block (&block,
534 build3_loc (input_location, COND_EXPR,
535 void_type_node, cond, then_b,
536 else_b));
537 }
538 else
539 gfc_add_expr_to_block (&block, then_b);
540
541 return gfc_finish_block (&block);
542 }
543
544 /* Build and return code for a copy constructor from SRC to DEST. */
545
546 tree
547 gfc_omp_clause_copy_ctor (tree clause, tree dest, tree src)
548 {
549 tree type = TREE_TYPE (dest), ptr, size, call;
550 tree cond, then_b, else_b;
551 stmtblock_t block, cond_block;
552
553 gcc_assert (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_FIRSTPRIVATE
554 || OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_LINEAR);
555
556 if ((! GFC_DESCRIPTOR_TYPE_P (type)
557 || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
558 && !GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause)))
559 {
560 if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause)))
561 {
562 gfc_start_block (&block);
563 gfc_add_modify (&block, dest, src);
564 tree tem = gfc_walk_alloc_comps (src, dest, OMP_CLAUSE_DECL (clause),
565 WALK_ALLOC_COMPS_COPY_CTOR);
566 gfc_add_expr_to_block (&block, tem);
567 return gfc_finish_block (&block);
568 }
569 else
570 return build2_v (MODIFY_EXPR, dest, src);
571 }
572
573 /* Allocatable arrays in FIRSTPRIVATE clauses need to be allocated
574 and copied from SRC. */
575 gfc_start_block (&block);
576
577 gfc_init_block (&cond_block);
578
579 gfc_add_modify (&cond_block, dest, src);
580 if (GFC_DESCRIPTOR_TYPE_P (type))
581 {
582 tree rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1];
583 size = gfc_conv_descriptor_ubound_get (dest, rank);
584 size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
585 size,
586 gfc_conv_descriptor_lbound_get (dest, rank));
587 size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
588 size, gfc_index_one_node);
589 if (GFC_TYPE_ARRAY_RANK (type) > 1)
590 size = fold_build2_loc (input_location, MULT_EXPR,
591 gfc_array_index_type, size,
592 gfc_conv_descriptor_stride_get (dest, rank));
593 tree esize = fold_convert (gfc_array_index_type,
594 TYPE_SIZE_UNIT (gfc_get_element_type (type)));
595 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
596 size, esize);
597 size = unshare_expr (size);
598 size = gfc_evaluate_now (fold_convert (size_type_node, size),
599 &cond_block);
600 }
601 else
602 size = fold_convert (size_type_node, TYPE_SIZE_UNIT (TREE_TYPE (type)));
603 ptr = gfc_create_var (pvoid_type_node, NULL);
604 gfc_allocate_using_malloc (&cond_block, ptr, size, NULL_TREE);
605 if (GFC_DESCRIPTOR_TYPE_P (type))
606 gfc_conv_descriptor_data_set (&cond_block, unshare_expr (dest), ptr);
607 else
608 gfc_add_modify (&cond_block, unshare_expr (dest),
609 fold_convert (TREE_TYPE (dest), ptr));
610
611 tree srcptr = GFC_DESCRIPTOR_TYPE_P (type)
612 ? gfc_conv_descriptor_data_get (src) : src;
613 srcptr = unshare_expr (srcptr);
614 srcptr = fold_convert (pvoid_type_node, srcptr);
615 call = build_call_expr_loc (input_location,
616 builtin_decl_explicit (BUILT_IN_MEMCPY), 3, ptr,
617 srcptr, size);
618 gfc_add_expr_to_block (&cond_block, fold_convert (void_type_node, call));
619 if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause)))
620 {
621 tree tem = gfc_walk_alloc_comps (src, dest,
622 OMP_CLAUSE_DECL (clause),
623 WALK_ALLOC_COMPS_COPY_CTOR);
624 gfc_add_expr_to_block (&cond_block, tem);
625 }
626 then_b = gfc_finish_block (&cond_block);
627
628 gfc_init_block (&cond_block);
629 if (GFC_DESCRIPTOR_TYPE_P (type))
630 gfc_conv_descriptor_data_set (&cond_block, unshare_expr (dest),
631 null_pointer_node);
632 else
633 gfc_add_modify (&cond_block, unshare_expr (dest),
634 build_zero_cst (TREE_TYPE (dest)));
635 else_b = gfc_finish_block (&cond_block);
636
637 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
638 unshare_expr (srcptr), null_pointer_node);
639 gfc_add_expr_to_block (&block,
640 build3_loc (input_location, COND_EXPR,
641 void_type_node, cond, then_b, else_b));
642
643 return gfc_finish_block (&block);
644 }
645
646 /* Similarly, except use an intrinsic or pointer assignment operator
647 instead. */
648
649 tree
650 gfc_omp_clause_assign_op (tree clause, tree dest, tree src)
651 {
652 tree type = TREE_TYPE (dest), ptr, size, call, nonalloc;
653 tree cond, then_b, else_b;
654 stmtblock_t block, cond_block, cond_block2, inner_block;
655
656 if ((! GFC_DESCRIPTOR_TYPE_P (type)
657 || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
658 && !GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause)))
659 {
660 if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause)))
661 {
662 gfc_start_block (&block);
663 /* First dealloc any allocatable components in DEST. */
664 tree tem = gfc_walk_alloc_comps (dest, NULL_TREE,
665 OMP_CLAUSE_DECL (clause),
666 WALK_ALLOC_COMPS_DTOR);
667 gfc_add_expr_to_block (&block, tem);
668 /* Then copy over toplevel data. */
669 gfc_add_modify (&block, dest, src);
670 /* Finally allocate any allocatable components and copy. */
671 tem = gfc_walk_alloc_comps (src, dest, OMP_CLAUSE_DECL (clause),
672 WALK_ALLOC_COMPS_COPY_CTOR);
673 gfc_add_expr_to_block (&block, tem);
674 return gfc_finish_block (&block);
675 }
676 else
677 return build2_v (MODIFY_EXPR, dest, src);
678 }
679
680 gfc_start_block (&block);
681
682 if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause)))
683 {
684 then_b = gfc_walk_alloc_comps (dest, NULL_TREE, OMP_CLAUSE_DECL (clause),
685 WALK_ALLOC_COMPS_DTOR);
686 tree tem = fold_convert (pvoid_type_node,
687 GFC_DESCRIPTOR_TYPE_P (type)
688 ? gfc_conv_descriptor_data_get (dest) : dest);
689 tem = unshare_expr (tem);
690 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
691 tem, null_pointer_node);
692 tem = build3_loc (input_location, COND_EXPR, void_type_node, cond,
693 then_b, build_empty_stmt (input_location));
694 gfc_add_expr_to_block (&block, tem);
695 }
696
697 gfc_init_block (&cond_block);
698
699 if (GFC_DESCRIPTOR_TYPE_P (type))
700 {
701 tree rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1];
702 size = gfc_conv_descriptor_ubound_get (src, rank);
703 size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
704 size,
705 gfc_conv_descriptor_lbound_get (src, rank));
706 size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
707 size, gfc_index_one_node);
708 if (GFC_TYPE_ARRAY_RANK (type) > 1)
709 size = fold_build2_loc (input_location, MULT_EXPR,
710 gfc_array_index_type, size,
711 gfc_conv_descriptor_stride_get (src, rank));
712 tree esize = fold_convert (gfc_array_index_type,
713 TYPE_SIZE_UNIT (gfc_get_element_type (type)));
714 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
715 size, esize);
716 size = unshare_expr (size);
717 size = gfc_evaluate_now (fold_convert (size_type_node, size),
718 &cond_block);
719 }
720 else
721 size = fold_convert (size_type_node, TYPE_SIZE_UNIT (TREE_TYPE (type)));
722 ptr = gfc_create_var (pvoid_type_node, NULL);
723
724 tree destptr = GFC_DESCRIPTOR_TYPE_P (type)
725 ? gfc_conv_descriptor_data_get (dest) : dest;
726 destptr = unshare_expr (destptr);
727 destptr = fold_convert (pvoid_type_node, destptr);
728 gfc_add_modify (&cond_block, ptr, destptr);
729
730 nonalloc = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
731 destptr, null_pointer_node);
732 cond = nonalloc;
733 if (GFC_DESCRIPTOR_TYPE_P (type))
734 {
735 int i;
736 for (i = 0; i < GFC_TYPE_ARRAY_RANK (type); i++)
737 {
738 tree rank = gfc_rank_cst[i];
739 tree tem = gfc_conv_descriptor_ubound_get (src, rank);
740 tem = fold_build2_loc (input_location, MINUS_EXPR,
741 gfc_array_index_type, tem,
742 gfc_conv_descriptor_lbound_get (src, rank));
743 tem = fold_build2_loc (input_location, PLUS_EXPR,
744 gfc_array_index_type, tem,
745 gfc_conv_descriptor_lbound_get (dest, rank));
746 tem = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
747 tem, gfc_conv_descriptor_ubound_get (dest,
748 rank));
749 cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
750 boolean_type_node, cond, tem);
751 }
752 }
753
754 gfc_init_block (&cond_block2);
755
756 if (GFC_DESCRIPTOR_TYPE_P (type))
757 {
758 gfc_init_block (&inner_block);
759 gfc_allocate_using_malloc (&inner_block, ptr, size, NULL_TREE);
760 then_b = gfc_finish_block (&inner_block);
761
762 gfc_init_block (&inner_block);
763 gfc_add_modify (&inner_block, ptr,
764 gfc_call_realloc (&inner_block, ptr, size));
765 else_b = gfc_finish_block (&inner_block);
766
767 gfc_add_expr_to_block (&cond_block2,
768 build3_loc (input_location, COND_EXPR,
769 void_type_node,
770 unshare_expr (nonalloc),
771 then_b, else_b));
772 gfc_add_modify (&cond_block2, dest, src);
773 gfc_conv_descriptor_data_set (&cond_block2, unshare_expr (dest), ptr);
774 }
775 else
776 {
777 gfc_allocate_using_malloc (&cond_block2, ptr, size, NULL_TREE);
778 gfc_add_modify (&cond_block2, unshare_expr (dest),
779 fold_convert (type, ptr));
780 }
781 then_b = gfc_finish_block (&cond_block2);
782 else_b = build_empty_stmt (input_location);
783
784 gfc_add_expr_to_block (&cond_block,
785 build3_loc (input_location, COND_EXPR,
786 void_type_node, unshare_expr (cond),
787 then_b, else_b));
788
789 tree srcptr = GFC_DESCRIPTOR_TYPE_P (type)
790 ? gfc_conv_descriptor_data_get (src) : src;
791 srcptr = unshare_expr (srcptr);
792 srcptr = fold_convert (pvoid_type_node, srcptr);
793 call = build_call_expr_loc (input_location,
794 builtin_decl_explicit (BUILT_IN_MEMCPY), 3, ptr,
795 srcptr, size);
796 gfc_add_expr_to_block (&cond_block, fold_convert (void_type_node, call));
797 if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause)))
798 {
799 tree tem = gfc_walk_alloc_comps (src, dest,
800 OMP_CLAUSE_DECL (clause),
801 WALK_ALLOC_COMPS_COPY_CTOR);
802 gfc_add_expr_to_block (&cond_block, tem);
803 }
804 then_b = gfc_finish_block (&cond_block);
805
806 if (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_COPYIN)
807 {
808 gfc_init_block (&cond_block);
809 if (GFC_DESCRIPTOR_TYPE_P (type))
810 gfc_add_expr_to_block (&cond_block,
811 gfc_trans_dealloc_allocated (unshare_expr (dest),
812 false, NULL));
813 else
814 {
815 destptr = gfc_evaluate_now (destptr, &cond_block);
816 gfc_add_expr_to_block (&cond_block, gfc_call_free (destptr));
817 gfc_add_modify (&cond_block, unshare_expr (dest),
818 build_zero_cst (TREE_TYPE (dest)));
819 }
820 else_b = gfc_finish_block (&cond_block);
821
822 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
823 unshare_expr (srcptr), null_pointer_node);
824 gfc_add_expr_to_block (&block,
825 build3_loc (input_location, COND_EXPR,
826 void_type_node, cond,
827 then_b, else_b));
828 }
829 else
830 gfc_add_expr_to_block (&block, then_b);
831
832 return gfc_finish_block (&block);
833 }
834
835 static void
836 gfc_omp_linear_clause_add_loop (stmtblock_t *block, tree dest, tree src,
837 tree add, tree nelems)
838 {
839 stmtblock_t tmpblock;
840 tree desta, srca, index = gfc_create_var (gfc_array_index_type, "S");
841 nelems = gfc_evaluate_now (nelems, block);
842
843 gfc_init_block (&tmpblock);
844 if (TREE_CODE (TREE_TYPE (dest)) == ARRAY_TYPE)
845 {
846 desta = gfc_build_array_ref (dest, index, NULL);
847 srca = gfc_build_array_ref (src, index, NULL);
848 }
849 else
850 {
851 gcc_assert (POINTER_TYPE_P (TREE_TYPE (dest)));
852 tree idx = fold_build2 (MULT_EXPR, sizetype,
853 fold_convert (sizetype, index),
854 TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (dest))));
855 desta = build_fold_indirect_ref (fold_build2 (POINTER_PLUS_EXPR,
856 TREE_TYPE (dest), dest,
857 idx));
858 srca = build_fold_indirect_ref (fold_build2 (POINTER_PLUS_EXPR,
859 TREE_TYPE (src), src,
860 idx));
861 }
862 gfc_add_modify (&tmpblock, desta,
863 fold_build2 (PLUS_EXPR, TREE_TYPE (desta),
864 srca, add));
865
866 gfc_loopinfo loop;
867 gfc_init_loopinfo (&loop);
868 loop.dimen = 1;
869 loop.from[0] = gfc_index_zero_node;
870 loop.loopvar[0] = index;
871 loop.to[0] = nelems;
872 gfc_trans_scalarizing_loops (&loop, &tmpblock);
873 gfc_add_block_to_block (block, &loop.pre);
874 }
875
876 /* Build and return code for a constructor of DEST that initializes
877 it to SRC plus ADD (ADD is scalar integer). */
878
879 tree
880 gfc_omp_clause_linear_ctor (tree clause, tree dest, tree src, tree add)
881 {
882 tree type = TREE_TYPE (dest), ptr, size, nelems = NULL_TREE;
883 stmtblock_t block;
884
885 gcc_assert (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_LINEAR);
886
887 gfc_start_block (&block);
888 add = gfc_evaluate_now (add, &block);
889
890 if ((! GFC_DESCRIPTOR_TYPE_P (type)
891 || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
892 && !GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause)))
893 {
894 gcc_assert (TREE_CODE (type) == ARRAY_TYPE);
895 if (!TYPE_DOMAIN (type)
896 || TYPE_MAX_VALUE (TYPE_DOMAIN (type)) == NULL_TREE
897 || TYPE_MIN_VALUE (TYPE_DOMAIN (type)) == error_mark_node
898 || TYPE_MAX_VALUE (TYPE_DOMAIN (type)) == error_mark_node)
899 {
900 nelems = fold_build2 (EXACT_DIV_EXPR, sizetype,
901 TYPE_SIZE_UNIT (type),
902 TYPE_SIZE_UNIT (TREE_TYPE (type)));
903 nelems = size_binop (MINUS_EXPR, nelems, size_one_node);
904 }
905 else
906 nelems = array_type_nelts (type);
907 nelems = fold_convert (gfc_array_index_type, nelems);
908
909 gfc_omp_linear_clause_add_loop (&block, dest, src, add, nelems);
910 return gfc_finish_block (&block);
911 }
912
913 /* Allocatable arrays in LINEAR clauses need to be allocated
914 and copied from SRC. */
915 gfc_add_modify (&block, dest, src);
916 if (GFC_DESCRIPTOR_TYPE_P (type))
917 {
918 tree rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1];
919 size = gfc_conv_descriptor_ubound_get (dest, rank);
920 size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
921 size,
922 gfc_conv_descriptor_lbound_get (dest, rank));
923 size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
924 size, gfc_index_one_node);
925 if (GFC_TYPE_ARRAY_RANK (type) > 1)
926 size = fold_build2_loc (input_location, MULT_EXPR,
927 gfc_array_index_type, size,
928 gfc_conv_descriptor_stride_get (dest, rank));
929 tree esize = fold_convert (gfc_array_index_type,
930 TYPE_SIZE_UNIT (gfc_get_element_type (type)));
931 nelems = gfc_evaluate_now (unshare_expr (size), &block);
932 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
933 nelems, unshare_expr (esize));
934 size = gfc_evaluate_now (fold_convert (size_type_node, size),
935 &block);
936 nelems = fold_build2_loc (input_location, MINUS_EXPR,
937 gfc_array_index_type, nelems,
938 gfc_index_one_node);
939 }
940 else
941 size = fold_convert (size_type_node, TYPE_SIZE_UNIT (TREE_TYPE (type)));
942 ptr = gfc_create_var (pvoid_type_node, NULL);
943 gfc_allocate_using_malloc (&block, ptr, size, NULL_TREE);
944 if (GFC_DESCRIPTOR_TYPE_P (type))
945 {
946 gfc_conv_descriptor_data_set (&block, unshare_expr (dest), ptr);
947 tree etype = gfc_get_element_type (type);
948 ptr = fold_convert (build_pointer_type (etype), ptr);
949 tree srcptr = gfc_conv_descriptor_data_get (unshare_expr (src));
950 srcptr = fold_convert (build_pointer_type (etype), srcptr);
951 gfc_omp_linear_clause_add_loop (&block, ptr, srcptr, add, nelems);
952 }
953 else
954 {
955 gfc_add_modify (&block, unshare_expr (dest),
956 fold_convert (TREE_TYPE (dest), ptr));
957 ptr = fold_convert (TREE_TYPE (dest), ptr);
958 tree dstm = build_fold_indirect_ref (ptr);
959 tree srcm = build_fold_indirect_ref (unshare_expr (src));
960 gfc_add_modify (&block, dstm,
961 fold_build2 (PLUS_EXPR, TREE_TYPE (add), srcm, add));
962 }
963 return gfc_finish_block (&block);
964 }
965
966 /* Build and return code destructing DECL. Return NULL if nothing
967 to be done. */
968
969 tree
970 gfc_omp_clause_dtor (tree clause, tree decl)
971 {
972 tree type = TREE_TYPE (decl), tem;
973
974 if ((! GFC_DESCRIPTOR_TYPE_P (type)
975 || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
976 && !GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause)))
977 {
978 if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause)))
979 return gfc_walk_alloc_comps (decl, NULL_TREE,
980 OMP_CLAUSE_DECL (clause),
981 WALK_ALLOC_COMPS_DTOR);
982 return NULL_TREE;
983 }
984
985 if (GFC_DESCRIPTOR_TYPE_P (type))
986 /* Allocatable arrays in FIRSTPRIVATE/LASTPRIVATE etc. clauses need
987 to be deallocated if they were allocated. */
988 tem = gfc_trans_dealloc_allocated (decl, false, NULL);
989 else
990 tem = gfc_call_free (decl);
991 tem = gfc_omp_unshare_expr (tem);
992
993 if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause)))
994 {
995 stmtblock_t block;
996 tree then_b;
997
998 gfc_init_block (&block);
999 gfc_add_expr_to_block (&block,
1000 gfc_walk_alloc_comps (decl, NULL_TREE,
1001 OMP_CLAUSE_DECL (clause),
1002 WALK_ALLOC_COMPS_DTOR));
1003 gfc_add_expr_to_block (&block, tem);
1004 then_b = gfc_finish_block (&block);
1005
1006 tem = fold_convert (pvoid_type_node,
1007 GFC_DESCRIPTOR_TYPE_P (type)
1008 ? gfc_conv_descriptor_data_get (decl) : decl);
1009 tem = unshare_expr (tem);
1010 tree cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
1011 tem, null_pointer_node);
1012 tem = build3_loc (input_location, COND_EXPR, void_type_node, cond,
1013 then_b, build_empty_stmt (input_location));
1014 }
1015 return tem;
1016 }
1017
1018
1019 void
1020 gfc_omp_finish_clause (tree c, gimple_seq *pre_p)
1021 {
1022 if (OMP_CLAUSE_CODE (c) != OMP_CLAUSE_MAP)
1023 return;
1024
1025 tree decl = OMP_CLAUSE_DECL (c);
1026 tree c2 = NULL_TREE, c3 = NULL_TREE, c4 = NULL_TREE;
1027 if (POINTER_TYPE_P (TREE_TYPE (decl)))
1028 {
1029 if (!gfc_omp_privatize_by_reference (decl)
1030 && !GFC_DECL_GET_SCALAR_POINTER (decl)
1031 && !GFC_DECL_GET_SCALAR_ALLOCATABLE (decl)
1032 && !GFC_DECL_CRAY_POINTEE (decl)
1033 && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (decl))))
1034 return;
1035 tree orig_decl = decl;
1036 c4 = build_omp_clause (OMP_CLAUSE_LOCATION (c), OMP_CLAUSE_MAP);
1037 OMP_CLAUSE_MAP_KIND (c4) = OMP_CLAUSE_MAP_POINTER;
1038 OMP_CLAUSE_DECL (c4) = decl;
1039 OMP_CLAUSE_SIZE (c4) = size_int (0);
1040 decl = build_fold_indirect_ref (decl);
1041 OMP_CLAUSE_DECL (c) = decl;
1042 OMP_CLAUSE_SIZE (c) = NULL_TREE;
1043 if (TREE_CODE (TREE_TYPE (orig_decl)) == REFERENCE_TYPE
1044 && (GFC_DECL_GET_SCALAR_POINTER (orig_decl)
1045 || GFC_DECL_GET_SCALAR_ALLOCATABLE (orig_decl)))
1046 {
1047 c3 = build_omp_clause (OMP_CLAUSE_LOCATION (c), OMP_CLAUSE_MAP);
1048 OMP_CLAUSE_MAP_KIND (c3) = OMP_CLAUSE_MAP_POINTER;
1049 OMP_CLAUSE_DECL (c3) = unshare_expr (decl);
1050 OMP_CLAUSE_SIZE (c3) = size_int (0);
1051 decl = build_fold_indirect_ref (decl);
1052 OMP_CLAUSE_DECL (c) = decl;
1053 }
1054 }
1055 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
1056 {
1057 stmtblock_t block;
1058 gfc_start_block (&block);
1059 tree type = TREE_TYPE (decl);
1060 tree ptr = gfc_conv_descriptor_data_get (decl);
1061 ptr = fold_convert (build_pointer_type (char_type_node), ptr);
1062 ptr = build_fold_indirect_ref (ptr);
1063 OMP_CLAUSE_DECL (c) = ptr;
1064 c2 = build_omp_clause (input_location, OMP_CLAUSE_MAP);
1065 OMP_CLAUSE_MAP_KIND (c2) = OMP_CLAUSE_MAP_TO_PSET;
1066 OMP_CLAUSE_DECL (c2) = decl;
1067 OMP_CLAUSE_SIZE (c2) = TYPE_SIZE_UNIT (type);
1068 c3 = build_omp_clause (OMP_CLAUSE_LOCATION (c), OMP_CLAUSE_MAP);
1069 OMP_CLAUSE_MAP_KIND (c3) = OMP_CLAUSE_MAP_POINTER;
1070 OMP_CLAUSE_DECL (c3) = gfc_conv_descriptor_data_get (decl);
1071 OMP_CLAUSE_SIZE (c3) = size_int (0);
1072 tree size = create_tmp_var (gfc_array_index_type);
1073 tree elemsz = TYPE_SIZE_UNIT (gfc_get_element_type (type));
1074 elemsz = fold_convert (gfc_array_index_type, elemsz);
1075 if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER
1076 || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT)
1077 {
1078 stmtblock_t cond_block;
1079 tree tem, then_b, else_b, zero, cond;
1080
1081 gfc_init_block (&cond_block);
1082 tem = gfc_full_array_size (&cond_block, decl,
1083 GFC_TYPE_ARRAY_RANK (type));
1084 gfc_add_modify (&cond_block, size, tem);
1085 gfc_add_modify (&cond_block, size,
1086 fold_build2 (MULT_EXPR, gfc_array_index_type,
1087 size, elemsz));
1088 then_b = gfc_finish_block (&cond_block);
1089 gfc_init_block (&cond_block);
1090 zero = build_int_cst (gfc_array_index_type, 0);
1091 gfc_add_modify (&cond_block, size, zero);
1092 else_b = gfc_finish_block (&cond_block);
1093 tem = gfc_conv_descriptor_data_get (decl);
1094 tem = fold_convert (pvoid_type_node, tem);
1095 cond = fold_build2_loc (input_location, NE_EXPR,
1096 boolean_type_node, tem, null_pointer_node);
1097 gfc_add_expr_to_block (&block, build3_loc (input_location, COND_EXPR,
1098 void_type_node, cond,
1099 then_b, else_b));
1100 }
1101 else
1102 {
1103 gfc_add_modify (&block, size,
1104 gfc_full_array_size (&block, decl,
1105 GFC_TYPE_ARRAY_RANK (type)));
1106 gfc_add_modify (&block, size,
1107 fold_build2 (MULT_EXPR, gfc_array_index_type,
1108 size, elemsz));
1109 }
1110 OMP_CLAUSE_SIZE (c) = size;
1111 tree stmt = gfc_finish_block (&block);
1112 gimplify_and_add (stmt, pre_p);
1113 }
1114 tree last = c;
1115 if (OMP_CLAUSE_SIZE (c) == NULL_TREE)
1116 OMP_CLAUSE_SIZE (c)
1117 = DECL_P (decl) ? DECL_SIZE_UNIT (decl)
1118 : TYPE_SIZE_UNIT (TREE_TYPE (decl));
1119 if (c2)
1120 {
1121 OMP_CLAUSE_CHAIN (c2) = OMP_CLAUSE_CHAIN (last);
1122 OMP_CLAUSE_CHAIN (last) = c2;
1123 last = c2;
1124 }
1125 if (c3)
1126 {
1127 OMP_CLAUSE_CHAIN (c3) = OMP_CLAUSE_CHAIN (last);
1128 OMP_CLAUSE_CHAIN (last) = c3;
1129 last = c3;
1130 }
1131 if (c4)
1132 {
1133 OMP_CLAUSE_CHAIN (c4) = OMP_CLAUSE_CHAIN (last);
1134 OMP_CLAUSE_CHAIN (last) = c4;
1135 last = c4;
1136 }
1137 }
1138
1139
1140 /* Return true if DECL's DECL_VALUE_EXPR (if any) should be
1141 disregarded in OpenMP construct, because it is going to be
1142 remapped during OpenMP lowering. SHARED is true if DECL
1143 is going to be shared, false if it is going to be privatized. */
1144
1145 bool
1146 gfc_omp_disregard_value_expr (tree decl, bool shared)
1147 {
1148 if (GFC_DECL_COMMON_OR_EQUIV (decl)
1149 && DECL_HAS_VALUE_EXPR_P (decl))
1150 {
1151 tree value = DECL_VALUE_EXPR (decl);
1152
1153 if (TREE_CODE (value) == COMPONENT_REF
1154 && TREE_CODE (TREE_OPERAND (value, 0)) == VAR_DECL
1155 && GFC_DECL_COMMON_OR_EQUIV (TREE_OPERAND (value, 0)))
1156 {
1157 /* If variable in COMMON or EQUIVALENCE is privatized, return
1158 true, as just that variable is supposed to be privatized,
1159 not the whole COMMON or whole EQUIVALENCE.
1160 For shared variables in COMMON or EQUIVALENCE, let them be
1161 gimplified to DECL_VALUE_EXPR, so that for multiple shared vars
1162 from the same COMMON or EQUIVALENCE just one sharing of the
1163 whole COMMON or EQUIVALENCE is enough. */
1164 return ! shared;
1165 }
1166 }
1167
1168 if (GFC_DECL_RESULT (decl) && DECL_HAS_VALUE_EXPR_P (decl))
1169 return ! shared;
1170
1171 return false;
1172 }
1173
1174 /* Return true if DECL that is shared iff SHARED is true should
1175 be put into OMP_CLAUSE_PRIVATE with OMP_CLAUSE_PRIVATE_DEBUG
1176 flag set. */
1177
1178 bool
1179 gfc_omp_private_debug_clause (tree decl, bool shared)
1180 {
1181 if (GFC_DECL_CRAY_POINTEE (decl))
1182 return true;
1183
1184 if (GFC_DECL_COMMON_OR_EQUIV (decl)
1185 && DECL_HAS_VALUE_EXPR_P (decl))
1186 {
1187 tree value = DECL_VALUE_EXPR (decl);
1188
1189 if (TREE_CODE (value) == COMPONENT_REF
1190 && TREE_CODE (TREE_OPERAND (value, 0)) == VAR_DECL
1191 && GFC_DECL_COMMON_OR_EQUIV (TREE_OPERAND (value, 0)))
1192 return shared;
1193 }
1194
1195 return false;
1196 }
1197
1198 /* Register language specific type size variables as potentially OpenMP
1199 firstprivate variables. */
1200
1201 void
1202 gfc_omp_firstprivatize_type_sizes (struct gimplify_omp_ctx *ctx, tree type)
1203 {
1204 if (GFC_ARRAY_TYPE_P (type) || GFC_DESCRIPTOR_TYPE_P (type))
1205 {
1206 int r;
1207
1208 gcc_assert (TYPE_LANG_SPECIFIC (type) != NULL);
1209 for (r = 0; r < GFC_TYPE_ARRAY_RANK (type); r++)
1210 {
1211 omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_LBOUND (type, r));
1212 omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_UBOUND (type, r));
1213 omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_STRIDE (type, r));
1214 }
1215 omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_SIZE (type));
1216 omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_OFFSET (type));
1217 }
1218 }
1219
1220
1221 static inline tree
1222 gfc_trans_add_clause (tree node, tree tail)
1223 {
1224 OMP_CLAUSE_CHAIN (node) = tail;
1225 return node;
1226 }
1227
1228 static tree
1229 gfc_trans_omp_variable (gfc_symbol *sym, bool declare_simd)
1230 {
1231 if (declare_simd)
1232 {
1233 int cnt = 0;
1234 gfc_symbol *proc_sym;
1235 gfc_formal_arglist *f;
1236
1237 gcc_assert (sym->attr.dummy);
1238 proc_sym = sym->ns->proc_name;
1239 if (proc_sym->attr.entry_master)
1240 ++cnt;
1241 if (gfc_return_by_reference (proc_sym))
1242 {
1243 ++cnt;
1244 if (proc_sym->ts.type == BT_CHARACTER)
1245 ++cnt;
1246 }
1247 for (f = gfc_sym_get_dummy_args (proc_sym); f; f = f->next)
1248 if (f->sym == sym)
1249 break;
1250 else if (f->sym)
1251 ++cnt;
1252 gcc_assert (f);
1253 return build_int_cst (integer_type_node, cnt);
1254 }
1255
1256 tree t = gfc_get_symbol_decl (sym);
1257 tree parent_decl;
1258 int parent_flag;
1259 bool return_value;
1260 bool alternate_entry;
1261 bool entry_master;
1262
1263 return_value = sym->attr.function && sym->result == sym;
1264 alternate_entry = sym->attr.function && sym->attr.entry
1265 && sym->result == sym;
1266 entry_master = sym->attr.result
1267 && sym->ns->proc_name->attr.entry_master
1268 && !gfc_return_by_reference (sym->ns->proc_name);
1269 parent_decl = current_function_decl
1270 ? DECL_CONTEXT (current_function_decl) : NULL_TREE;
1271
1272 if ((t == parent_decl && return_value)
1273 || (sym->ns && sym->ns->proc_name
1274 && sym->ns->proc_name->backend_decl == parent_decl
1275 && (alternate_entry || entry_master)))
1276 parent_flag = 1;
1277 else
1278 parent_flag = 0;
1279
1280 /* Special case for assigning the return value of a function.
1281 Self recursive functions must have an explicit return value. */
1282 if (return_value && (t == current_function_decl || parent_flag))
1283 t = gfc_get_fake_result_decl (sym, parent_flag);
1284
1285 /* Similarly for alternate entry points. */
1286 else if (alternate_entry
1287 && (sym->ns->proc_name->backend_decl == current_function_decl
1288 || parent_flag))
1289 {
1290 gfc_entry_list *el = NULL;
1291
1292 for (el = sym->ns->entries; el; el = el->next)
1293 if (sym == el->sym)
1294 {
1295 t = gfc_get_fake_result_decl (sym, parent_flag);
1296 break;
1297 }
1298 }
1299
1300 else if (entry_master
1301 && (sym->ns->proc_name->backend_decl == current_function_decl
1302 || parent_flag))
1303 t = gfc_get_fake_result_decl (sym, parent_flag);
1304
1305 return t;
1306 }
1307
1308 static tree
1309 gfc_trans_omp_variable_list (enum omp_clause_code code,
1310 gfc_omp_namelist *namelist, tree list,
1311 bool declare_simd)
1312 {
1313 for (; namelist != NULL; namelist = namelist->next)
1314 if (namelist->sym->attr.referenced || declare_simd)
1315 {
1316 tree t = gfc_trans_omp_variable (namelist->sym, declare_simd);
1317 if (t != error_mark_node)
1318 {
1319 tree node = build_omp_clause (input_location, code);
1320 OMP_CLAUSE_DECL (node) = t;
1321 list = gfc_trans_add_clause (node, list);
1322 }
1323 }
1324 return list;
1325 }
1326
1327 struct omp_udr_find_orig_data
1328 {
1329 gfc_omp_udr *omp_udr;
1330 bool omp_orig_seen;
1331 };
1332
1333 static int
1334 omp_udr_find_orig (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
1335 void *data)
1336 {
1337 struct omp_udr_find_orig_data *cd = (struct omp_udr_find_orig_data *) data;
1338 if ((*e)->expr_type == EXPR_VARIABLE
1339 && (*e)->symtree->n.sym == cd->omp_udr->omp_orig)
1340 cd->omp_orig_seen = true;
1341
1342 return 0;
1343 }
1344
1345 static void
1346 gfc_trans_omp_array_reduction_or_udr (tree c, gfc_omp_namelist *n, locus where)
1347 {
1348 gfc_symbol *sym = n->sym;
1349 gfc_symtree *root1 = NULL, *root2 = NULL, *root3 = NULL, *root4 = NULL;
1350 gfc_symtree *symtree1, *symtree2, *symtree3, *symtree4 = NULL;
1351 gfc_symbol init_val_sym, outer_sym, intrinsic_sym;
1352 gfc_symbol omp_var_copy[4];
1353 gfc_expr *e1, *e2, *e3, *e4;
1354 gfc_ref *ref;
1355 tree decl, backend_decl, stmt, type, outer_decl;
1356 locus old_loc = gfc_current_locus;
1357 const char *iname;
1358 bool t;
1359 gfc_omp_udr *udr = n->udr ? n->udr->udr : NULL;
1360
1361 decl = OMP_CLAUSE_DECL (c);
1362 gfc_current_locus = where;
1363 type = TREE_TYPE (decl);
1364 outer_decl = create_tmp_var_raw (type);
1365 if (TREE_CODE (decl) == PARM_DECL
1366 && TREE_CODE (type) == REFERENCE_TYPE
1367 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type))
1368 && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (type)) == GFC_ARRAY_ALLOCATABLE)
1369 {
1370 decl = build_fold_indirect_ref (decl);
1371 type = TREE_TYPE (type);
1372 }
1373
1374 /* Create a fake symbol for init value. */
1375 memset (&init_val_sym, 0, sizeof (init_val_sym));
1376 init_val_sym.ns = sym->ns;
1377 init_val_sym.name = sym->name;
1378 init_val_sym.ts = sym->ts;
1379 init_val_sym.attr.referenced = 1;
1380 init_val_sym.declared_at = where;
1381 init_val_sym.attr.flavor = FL_VARIABLE;
1382 if (OMP_CLAUSE_REDUCTION_CODE (c) != ERROR_MARK)
1383 backend_decl = omp_reduction_init (c, gfc_sym_type (&init_val_sym));
1384 else if (udr->initializer_ns)
1385 backend_decl = NULL;
1386 else
1387 switch (sym->ts.type)
1388 {
1389 case BT_LOGICAL:
1390 case BT_INTEGER:
1391 case BT_REAL:
1392 case BT_COMPLEX:
1393 backend_decl = build_zero_cst (gfc_sym_type (&init_val_sym));
1394 break;
1395 default:
1396 backend_decl = NULL_TREE;
1397 break;
1398 }
1399 init_val_sym.backend_decl = backend_decl;
1400
1401 /* Create a fake symbol for the outer array reference. */
1402 outer_sym = *sym;
1403 if (sym->as)
1404 outer_sym.as = gfc_copy_array_spec (sym->as);
1405 outer_sym.attr.dummy = 0;
1406 outer_sym.attr.result = 0;
1407 outer_sym.attr.flavor = FL_VARIABLE;
1408 outer_sym.backend_decl = outer_decl;
1409 if (decl != OMP_CLAUSE_DECL (c))
1410 outer_sym.backend_decl = build_fold_indirect_ref (outer_decl);
1411
1412 /* Create fake symtrees for it. */
1413 symtree1 = gfc_new_symtree (&root1, sym->name);
1414 symtree1->n.sym = sym;
1415 gcc_assert (symtree1 == root1);
1416
1417 symtree2 = gfc_new_symtree (&root2, sym->name);
1418 symtree2->n.sym = &init_val_sym;
1419 gcc_assert (symtree2 == root2);
1420
1421 symtree3 = gfc_new_symtree (&root3, sym->name);
1422 symtree3->n.sym = &outer_sym;
1423 gcc_assert (symtree3 == root3);
1424
1425 memset (omp_var_copy, 0, sizeof omp_var_copy);
1426 if (udr)
1427 {
1428 omp_var_copy[0] = *udr->omp_out;
1429 omp_var_copy[1] = *udr->omp_in;
1430 *udr->omp_out = outer_sym;
1431 *udr->omp_in = *sym;
1432 if (udr->initializer_ns)
1433 {
1434 omp_var_copy[2] = *udr->omp_priv;
1435 omp_var_copy[3] = *udr->omp_orig;
1436 *udr->omp_priv = *sym;
1437 *udr->omp_orig = outer_sym;
1438 }
1439 }
1440
1441 /* Create expressions. */
1442 e1 = gfc_get_expr ();
1443 e1->expr_type = EXPR_VARIABLE;
1444 e1->where = where;
1445 e1->symtree = symtree1;
1446 e1->ts = sym->ts;
1447 if (sym->attr.dimension)
1448 {
1449 e1->ref = ref = gfc_get_ref ();
1450 ref->type = REF_ARRAY;
1451 ref->u.ar.where = where;
1452 ref->u.ar.as = sym->as;
1453 ref->u.ar.type = AR_FULL;
1454 ref->u.ar.dimen = 0;
1455 }
1456 t = gfc_resolve_expr (e1);
1457 gcc_assert (t);
1458
1459 e2 = NULL;
1460 if (backend_decl != NULL_TREE)
1461 {
1462 e2 = gfc_get_expr ();
1463 e2->expr_type = EXPR_VARIABLE;
1464 e2->where = where;
1465 e2->symtree = symtree2;
1466 e2->ts = sym->ts;
1467 t = gfc_resolve_expr (e2);
1468 gcc_assert (t);
1469 }
1470 else if (udr->initializer_ns == NULL)
1471 {
1472 gcc_assert (sym->ts.type == BT_DERIVED);
1473 e2 = gfc_default_initializer (&sym->ts);
1474 gcc_assert (e2);
1475 t = gfc_resolve_expr (e2);
1476 gcc_assert (t);
1477 }
1478 else if (n->udr->initializer->op == EXEC_ASSIGN)
1479 {
1480 e2 = gfc_copy_expr (n->udr->initializer->expr2);
1481 t = gfc_resolve_expr (e2);
1482 gcc_assert (t);
1483 }
1484 if (udr && udr->initializer_ns)
1485 {
1486 struct omp_udr_find_orig_data cd;
1487 cd.omp_udr = udr;
1488 cd.omp_orig_seen = false;
1489 gfc_code_walker (&n->udr->initializer,
1490 gfc_dummy_code_callback, omp_udr_find_orig, &cd);
1491 if (cd.omp_orig_seen)
1492 OMP_CLAUSE_REDUCTION_OMP_ORIG_REF (c) = 1;
1493 }
1494
1495 e3 = gfc_copy_expr (e1);
1496 e3->symtree = symtree3;
1497 t = gfc_resolve_expr (e3);
1498 gcc_assert (t);
1499
1500 iname = NULL;
1501 e4 = NULL;
1502 switch (OMP_CLAUSE_REDUCTION_CODE (c))
1503 {
1504 case PLUS_EXPR:
1505 case MINUS_EXPR:
1506 e4 = gfc_add (e3, e1);
1507 break;
1508 case MULT_EXPR:
1509 e4 = gfc_multiply (e3, e1);
1510 break;
1511 case TRUTH_ANDIF_EXPR:
1512 e4 = gfc_and (e3, e1);
1513 break;
1514 case TRUTH_ORIF_EXPR:
1515 e4 = gfc_or (e3, e1);
1516 break;
1517 case EQ_EXPR:
1518 e4 = gfc_eqv (e3, e1);
1519 break;
1520 case NE_EXPR:
1521 e4 = gfc_neqv (e3, e1);
1522 break;
1523 case MIN_EXPR:
1524 iname = "min";
1525 break;
1526 case MAX_EXPR:
1527 iname = "max";
1528 break;
1529 case BIT_AND_EXPR:
1530 iname = "iand";
1531 break;
1532 case BIT_IOR_EXPR:
1533 iname = "ior";
1534 break;
1535 case BIT_XOR_EXPR:
1536 iname = "ieor";
1537 break;
1538 case ERROR_MARK:
1539 if (n->udr->combiner->op == EXEC_ASSIGN)
1540 {
1541 gfc_free_expr (e3);
1542 e3 = gfc_copy_expr (n->udr->combiner->expr1);
1543 e4 = gfc_copy_expr (n->udr->combiner->expr2);
1544 t = gfc_resolve_expr (e3);
1545 gcc_assert (t);
1546 t = gfc_resolve_expr (e4);
1547 gcc_assert (t);
1548 }
1549 break;
1550 default:
1551 gcc_unreachable ();
1552 }
1553 if (iname != NULL)
1554 {
1555 memset (&intrinsic_sym, 0, sizeof (intrinsic_sym));
1556 intrinsic_sym.ns = sym->ns;
1557 intrinsic_sym.name = iname;
1558 intrinsic_sym.ts = sym->ts;
1559 intrinsic_sym.attr.referenced = 1;
1560 intrinsic_sym.attr.intrinsic = 1;
1561 intrinsic_sym.attr.function = 1;
1562 intrinsic_sym.result = &intrinsic_sym;
1563 intrinsic_sym.declared_at = where;
1564
1565 symtree4 = gfc_new_symtree (&root4, iname);
1566 symtree4->n.sym = &intrinsic_sym;
1567 gcc_assert (symtree4 == root4);
1568
1569 e4 = gfc_get_expr ();
1570 e4->expr_type = EXPR_FUNCTION;
1571 e4->where = where;
1572 e4->symtree = symtree4;
1573 e4->value.function.actual = gfc_get_actual_arglist ();
1574 e4->value.function.actual->expr = e3;
1575 e4->value.function.actual->next = gfc_get_actual_arglist ();
1576 e4->value.function.actual->next->expr = e1;
1577 }
1578 if (OMP_CLAUSE_REDUCTION_CODE (c) != ERROR_MARK)
1579 {
1580 /* e1 and e3 have been stored as arguments of e4, avoid sharing. */
1581 e1 = gfc_copy_expr (e1);
1582 e3 = gfc_copy_expr (e3);
1583 t = gfc_resolve_expr (e4);
1584 gcc_assert (t);
1585 }
1586
1587 /* Create the init statement list. */
1588 pushlevel ();
1589 if (e2)
1590 stmt = gfc_trans_assignment (e1, e2, false, false);
1591 else
1592 stmt = gfc_trans_call (n->udr->initializer, false,
1593 NULL_TREE, NULL_TREE, false);
1594 if (TREE_CODE (stmt) != BIND_EXPR)
1595 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
1596 else
1597 poplevel (0, 0);
1598 OMP_CLAUSE_REDUCTION_INIT (c) = stmt;
1599
1600 /* Create the merge statement list. */
1601 pushlevel ();
1602 if (e4)
1603 stmt = gfc_trans_assignment (e3, e4, false, true);
1604 else
1605 stmt = gfc_trans_call (n->udr->combiner, false,
1606 NULL_TREE, NULL_TREE, false);
1607 if (TREE_CODE (stmt) != BIND_EXPR)
1608 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
1609 else
1610 poplevel (0, 0);
1611 OMP_CLAUSE_REDUCTION_MERGE (c) = stmt;
1612
1613 /* And stick the placeholder VAR_DECL into the clause as well. */
1614 OMP_CLAUSE_REDUCTION_PLACEHOLDER (c) = outer_decl;
1615
1616 gfc_current_locus = old_loc;
1617
1618 gfc_free_expr (e1);
1619 if (e2)
1620 gfc_free_expr (e2);
1621 gfc_free_expr (e3);
1622 if (e4)
1623 gfc_free_expr (e4);
1624 free (symtree1);
1625 free (symtree2);
1626 free (symtree3);
1627 free (symtree4);
1628 if (outer_sym.as)
1629 gfc_free_array_spec (outer_sym.as);
1630
1631 if (udr)
1632 {
1633 *udr->omp_out = omp_var_copy[0];
1634 *udr->omp_in = omp_var_copy[1];
1635 if (udr->initializer_ns)
1636 {
1637 *udr->omp_priv = omp_var_copy[2];
1638 *udr->omp_orig = omp_var_copy[3];
1639 }
1640 }
1641 }
1642
1643 static tree
1644 gfc_trans_omp_reduction_list (gfc_omp_namelist *namelist, tree list,
1645 locus where)
1646 {
1647 for (; namelist != NULL; namelist = namelist->next)
1648 if (namelist->sym->attr.referenced)
1649 {
1650 tree t = gfc_trans_omp_variable (namelist->sym, false);
1651 if (t != error_mark_node)
1652 {
1653 tree node = build_omp_clause (where.lb->location,
1654 OMP_CLAUSE_REDUCTION);
1655 OMP_CLAUSE_DECL (node) = t;
1656 switch (namelist->u.reduction_op)
1657 {
1658 case OMP_REDUCTION_PLUS:
1659 OMP_CLAUSE_REDUCTION_CODE (node) = PLUS_EXPR;
1660 break;
1661 case OMP_REDUCTION_MINUS:
1662 OMP_CLAUSE_REDUCTION_CODE (node) = MINUS_EXPR;
1663 break;
1664 case OMP_REDUCTION_TIMES:
1665 OMP_CLAUSE_REDUCTION_CODE (node) = MULT_EXPR;
1666 break;
1667 case OMP_REDUCTION_AND:
1668 OMP_CLAUSE_REDUCTION_CODE (node) = TRUTH_ANDIF_EXPR;
1669 break;
1670 case OMP_REDUCTION_OR:
1671 OMP_CLAUSE_REDUCTION_CODE (node) = TRUTH_ORIF_EXPR;
1672 break;
1673 case OMP_REDUCTION_EQV:
1674 OMP_CLAUSE_REDUCTION_CODE (node) = EQ_EXPR;
1675 break;
1676 case OMP_REDUCTION_NEQV:
1677 OMP_CLAUSE_REDUCTION_CODE (node) = NE_EXPR;
1678 break;
1679 case OMP_REDUCTION_MAX:
1680 OMP_CLAUSE_REDUCTION_CODE (node) = MAX_EXPR;
1681 break;
1682 case OMP_REDUCTION_MIN:
1683 OMP_CLAUSE_REDUCTION_CODE (node) = MIN_EXPR;
1684 break;
1685 case OMP_REDUCTION_IAND:
1686 OMP_CLAUSE_REDUCTION_CODE (node) = BIT_AND_EXPR;
1687 break;
1688 case OMP_REDUCTION_IOR:
1689 OMP_CLAUSE_REDUCTION_CODE (node) = BIT_IOR_EXPR;
1690 break;
1691 case OMP_REDUCTION_IEOR:
1692 OMP_CLAUSE_REDUCTION_CODE (node) = BIT_XOR_EXPR;
1693 break;
1694 case OMP_REDUCTION_USER:
1695 OMP_CLAUSE_REDUCTION_CODE (node) = ERROR_MARK;
1696 break;
1697 default:
1698 gcc_unreachable ();
1699 }
1700 if (namelist->sym->attr.dimension
1701 || namelist->u.reduction_op == OMP_REDUCTION_USER
1702 || namelist->sym->attr.allocatable)
1703 gfc_trans_omp_array_reduction_or_udr (node, namelist, where);
1704 list = gfc_trans_add_clause (node, list);
1705 }
1706 }
1707 return list;
1708 }
1709
1710 static inline tree
1711 gfc_convert_expr_to_tree (stmtblock_t *block, gfc_expr *expr)
1712 {
1713 gfc_se se;
1714 tree result;
1715
1716 gfc_init_se (&se, NULL );
1717 gfc_conv_expr (&se, expr);
1718 gfc_add_block_to_block (block, &se.pre);
1719 result = gfc_evaluate_now (se.expr, block);
1720 gfc_add_block_to_block (block, &se.post);
1721
1722 return result;
1723 }
1724
1725 static tree
1726 gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
1727 locus where, bool declare_simd = false)
1728 {
1729 tree omp_clauses = NULL_TREE, chunk_size, c;
1730 int list;
1731 enum omp_clause_code clause_code;
1732 gfc_se se;
1733
1734 if (clauses == NULL)
1735 return NULL_TREE;
1736
1737 for (list = 0; list < OMP_LIST_NUM; list++)
1738 {
1739 gfc_omp_namelist *n = clauses->lists[list];
1740
1741 if (n == NULL)
1742 continue;
1743 switch (list)
1744 {
1745 case OMP_LIST_REDUCTION:
1746 omp_clauses = gfc_trans_omp_reduction_list (n, omp_clauses, where);
1747 break;
1748 case OMP_LIST_PRIVATE:
1749 clause_code = OMP_CLAUSE_PRIVATE;
1750 goto add_clause;
1751 case OMP_LIST_SHARED:
1752 clause_code = OMP_CLAUSE_SHARED;
1753 goto add_clause;
1754 case OMP_LIST_FIRSTPRIVATE:
1755 clause_code = OMP_CLAUSE_FIRSTPRIVATE;
1756 goto add_clause;
1757 case OMP_LIST_LASTPRIVATE:
1758 clause_code = OMP_CLAUSE_LASTPRIVATE;
1759 goto add_clause;
1760 case OMP_LIST_COPYIN:
1761 clause_code = OMP_CLAUSE_COPYIN;
1762 goto add_clause;
1763 case OMP_LIST_COPYPRIVATE:
1764 clause_code = OMP_CLAUSE_COPYPRIVATE;
1765 goto add_clause;
1766 case OMP_LIST_UNIFORM:
1767 clause_code = OMP_CLAUSE_UNIFORM;
1768 goto add_clause;
1769 case OMP_LIST_USE_DEVICE:
1770 clause_code = OMP_CLAUSE_USE_DEVICE;
1771 goto add_clause;
1772 case OMP_LIST_DEVICE_RESIDENT:
1773 clause_code = OMP_CLAUSE_DEVICE_RESIDENT;
1774 goto add_clause;
1775 case OMP_LIST_CACHE:
1776 clause_code = OMP_CLAUSE__CACHE_;
1777 goto add_clause;
1778
1779 add_clause:
1780 omp_clauses
1781 = gfc_trans_omp_variable_list (clause_code, n, omp_clauses,
1782 declare_simd);
1783 break;
1784 case OMP_LIST_ALIGNED:
1785 for (; n != NULL; n = n->next)
1786 if (n->sym->attr.referenced || declare_simd)
1787 {
1788 tree t = gfc_trans_omp_variable (n->sym, declare_simd);
1789 if (t != error_mark_node)
1790 {
1791 tree node = build_omp_clause (input_location,
1792 OMP_CLAUSE_ALIGNED);
1793 OMP_CLAUSE_DECL (node) = t;
1794 if (n->expr)
1795 {
1796 tree alignment_var;
1797
1798 if (block == NULL)
1799 alignment_var = gfc_conv_constant_to_tree (n->expr);
1800 else
1801 {
1802 gfc_init_se (&se, NULL);
1803 gfc_conv_expr (&se, n->expr);
1804 gfc_add_block_to_block (block, &se.pre);
1805 alignment_var = gfc_evaluate_now (se.expr, block);
1806 gfc_add_block_to_block (block, &se.post);
1807 }
1808 OMP_CLAUSE_ALIGNED_ALIGNMENT (node) = alignment_var;
1809 }
1810 omp_clauses = gfc_trans_add_clause (node, omp_clauses);
1811 }
1812 }
1813 break;
1814 case OMP_LIST_LINEAR:
1815 {
1816 gfc_expr *last_step_expr = NULL;
1817 tree last_step = NULL_TREE;
1818
1819 for (; n != NULL; n = n->next)
1820 {
1821 if (n->expr)
1822 {
1823 last_step_expr = n->expr;
1824 last_step = NULL_TREE;
1825 }
1826 if (n->sym->attr.referenced || declare_simd)
1827 {
1828 tree t = gfc_trans_omp_variable (n->sym, declare_simd);
1829 if (t != error_mark_node)
1830 {
1831 tree node = build_omp_clause (input_location,
1832 OMP_CLAUSE_LINEAR);
1833 OMP_CLAUSE_DECL (node) = t;
1834 if (last_step_expr && last_step == NULL_TREE)
1835 {
1836 if (block == NULL)
1837 last_step
1838 = gfc_conv_constant_to_tree (last_step_expr);
1839 else
1840 {
1841 gfc_init_se (&se, NULL);
1842 gfc_conv_expr (&se, last_step_expr);
1843 gfc_add_block_to_block (block, &se.pre);
1844 last_step = gfc_evaluate_now (se.expr, block);
1845 gfc_add_block_to_block (block, &se.post);
1846 }
1847 }
1848 OMP_CLAUSE_LINEAR_STEP (node)
1849 = fold_convert (gfc_typenode_for_spec (&n->sym->ts),
1850 last_step);
1851 if (n->sym->attr.dimension || n->sym->attr.allocatable)
1852 OMP_CLAUSE_LINEAR_ARRAY (node) = 1;
1853 omp_clauses = gfc_trans_add_clause (node, omp_clauses);
1854 }
1855 }
1856 }
1857 }
1858 break;
1859 case OMP_LIST_DEPEND:
1860 for (; n != NULL; n = n->next)
1861 {
1862 if (!n->sym->attr.referenced)
1863 continue;
1864
1865 tree node = build_omp_clause (input_location, OMP_CLAUSE_DEPEND);
1866 if (n->expr == NULL || n->expr->ref->u.ar.type == AR_FULL)
1867 {
1868 tree decl = gfc_get_symbol_decl (n->sym);
1869 if (gfc_omp_privatize_by_reference (decl))
1870 decl = build_fold_indirect_ref (decl);
1871 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
1872 {
1873 decl = gfc_conv_descriptor_data_get (decl);
1874 decl = fold_convert (build_pointer_type (char_type_node),
1875 decl);
1876 decl = build_fold_indirect_ref (decl);
1877 }
1878 else if (DECL_P (decl))
1879 TREE_ADDRESSABLE (decl) = 1;
1880 OMP_CLAUSE_DECL (node) = decl;
1881 }
1882 else
1883 {
1884 tree ptr;
1885 gfc_init_se (&se, NULL);
1886 if (n->expr->ref->u.ar.type == AR_ELEMENT)
1887 {
1888 gfc_conv_expr_reference (&se, n->expr);
1889 ptr = se.expr;
1890 }
1891 else
1892 {
1893 gfc_conv_expr_descriptor (&se, n->expr);
1894 ptr = gfc_conv_array_data (se.expr);
1895 }
1896 gfc_add_block_to_block (block, &se.pre);
1897 gfc_add_block_to_block (block, &se.post);
1898 ptr = fold_convert (build_pointer_type (char_type_node),
1899 ptr);
1900 OMP_CLAUSE_DECL (node) = build_fold_indirect_ref (ptr);
1901 }
1902 switch (n->u.depend_op)
1903 {
1904 case OMP_DEPEND_IN:
1905 OMP_CLAUSE_DEPEND_KIND (node) = OMP_CLAUSE_DEPEND_IN;
1906 break;
1907 case OMP_DEPEND_OUT:
1908 OMP_CLAUSE_DEPEND_KIND (node) = OMP_CLAUSE_DEPEND_OUT;
1909 break;
1910 case OMP_DEPEND_INOUT:
1911 OMP_CLAUSE_DEPEND_KIND (node) = OMP_CLAUSE_DEPEND_INOUT;
1912 break;
1913 default:
1914 gcc_unreachable ();
1915 }
1916 omp_clauses = gfc_trans_add_clause (node, omp_clauses);
1917 }
1918 break;
1919 case OMP_LIST_MAP:
1920 for (; n != NULL; n = n->next)
1921 {
1922 if (!n->sym->attr.referenced)
1923 continue;
1924
1925 tree node = build_omp_clause (input_location, OMP_CLAUSE_MAP);
1926 tree node2 = NULL_TREE;
1927 tree node3 = NULL_TREE;
1928 tree node4 = NULL_TREE;
1929 tree decl = gfc_get_symbol_decl (n->sym);
1930 if (DECL_P (decl))
1931 TREE_ADDRESSABLE (decl) = 1;
1932 if (n->expr == NULL || n->expr->ref->u.ar.type == AR_FULL)
1933 {
1934 if (POINTER_TYPE_P (TREE_TYPE (decl))
1935 && (gfc_omp_privatize_by_reference (decl)
1936 || GFC_DECL_GET_SCALAR_POINTER (decl)
1937 || GFC_DECL_GET_SCALAR_ALLOCATABLE (decl)
1938 || GFC_DECL_CRAY_POINTEE (decl)
1939 || GFC_DESCRIPTOR_TYPE_P
1940 (TREE_TYPE (TREE_TYPE (decl)))))
1941 {
1942 tree orig_decl = decl;
1943 node4 = build_omp_clause (input_location,
1944 OMP_CLAUSE_MAP);
1945 OMP_CLAUSE_MAP_KIND (node4) = OMP_CLAUSE_MAP_POINTER;
1946 OMP_CLAUSE_DECL (node4) = decl;
1947 OMP_CLAUSE_SIZE (node4) = size_int (0);
1948 decl = build_fold_indirect_ref (decl);
1949 if (TREE_CODE (TREE_TYPE (orig_decl)) == REFERENCE_TYPE
1950 && (GFC_DECL_GET_SCALAR_POINTER (orig_decl)
1951 || GFC_DECL_GET_SCALAR_ALLOCATABLE (orig_decl)))
1952 {
1953 node3 = build_omp_clause (input_location,
1954 OMP_CLAUSE_MAP);
1955 OMP_CLAUSE_MAP_KIND (node3) = OMP_CLAUSE_MAP_POINTER;
1956 OMP_CLAUSE_DECL (node3) = decl;
1957 OMP_CLAUSE_SIZE (node3) = size_int (0);
1958 decl = build_fold_indirect_ref (decl);
1959 }
1960 }
1961 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
1962 {
1963 tree type = TREE_TYPE (decl);
1964 tree ptr = gfc_conv_descriptor_data_get (decl);
1965 ptr = fold_convert (build_pointer_type (char_type_node),
1966 ptr);
1967 ptr = build_fold_indirect_ref (ptr);
1968 OMP_CLAUSE_DECL (node) = ptr;
1969 node2 = build_omp_clause (input_location,
1970 OMP_CLAUSE_MAP);
1971 OMP_CLAUSE_MAP_KIND (node2) = OMP_CLAUSE_MAP_TO_PSET;
1972 OMP_CLAUSE_DECL (node2) = decl;
1973 OMP_CLAUSE_SIZE (node2) = TYPE_SIZE_UNIT (type);
1974 node3 = build_omp_clause (input_location,
1975 OMP_CLAUSE_MAP);
1976 OMP_CLAUSE_MAP_KIND (node3) = OMP_CLAUSE_MAP_POINTER;
1977 OMP_CLAUSE_DECL (node3)
1978 = gfc_conv_descriptor_data_get (decl);
1979 OMP_CLAUSE_SIZE (node3) = size_int (0);
1980 if (n->sym->attr.pointer)
1981 {
1982 stmtblock_t cond_block;
1983 tree size
1984 = gfc_create_var (gfc_array_index_type, NULL);
1985 tree tem, then_b, else_b, zero, cond;
1986
1987 gfc_init_block (&cond_block);
1988 tem
1989 = gfc_full_array_size (&cond_block, decl,
1990 GFC_TYPE_ARRAY_RANK (type));
1991 gfc_add_modify (&cond_block, size, tem);
1992 then_b = gfc_finish_block (&cond_block);
1993 gfc_init_block (&cond_block);
1994 zero = build_int_cst (gfc_array_index_type, 0);
1995 gfc_add_modify (&cond_block, size, zero);
1996 else_b = gfc_finish_block (&cond_block);
1997 tem = gfc_conv_descriptor_data_get (decl);
1998 tem = fold_convert (pvoid_type_node, tem);
1999 cond = fold_build2_loc (input_location, NE_EXPR,
2000 boolean_type_node,
2001 tem, null_pointer_node);
2002 gfc_add_expr_to_block (block,
2003 build3_loc (input_location,
2004 COND_EXPR,
2005 void_type_node,
2006 cond, then_b,
2007 else_b));
2008 OMP_CLAUSE_SIZE (node) = size;
2009 }
2010 else
2011 OMP_CLAUSE_SIZE (node)
2012 = gfc_full_array_size (block, decl,
2013 GFC_TYPE_ARRAY_RANK (type));
2014 tree elemsz
2015 = TYPE_SIZE_UNIT (gfc_get_element_type (type));
2016 elemsz = fold_convert (gfc_array_index_type, elemsz);
2017 OMP_CLAUSE_SIZE (node)
2018 = fold_build2 (MULT_EXPR, gfc_array_index_type,
2019 OMP_CLAUSE_SIZE (node), elemsz);
2020 }
2021 else
2022 OMP_CLAUSE_DECL (node) = decl;
2023 }
2024 else
2025 {
2026 tree ptr, ptr2;
2027 gfc_init_se (&se, NULL);
2028 if (n->expr->ref->u.ar.type == AR_ELEMENT)
2029 {
2030 gfc_conv_expr_reference (&se, n->expr);
2031 gfc_add_block_to_block (block, &se.pre);
2032 ptr = se.expr;
2033 OMP_CLAUSE_SIZE (node)
2034 = TYPE_SIZE_UNIT (TREE_TYPE (ptr));
2035 }
2036 else
2037 {
2038 gfc_conv_expr_descriptor (&se, n->expr);
2039 ptr = gfc_conv_array_data (se.expr);
2040 tree type = TREE_TYPE (se.expr);
2041 gfc_add_block_to_block (block, &se.pre);
2042 OMP_CLAUSE_SIZE (node)
2043 = gfc_full_array_size (block, se.expr,
2044 GFC_TYPE_ARRAY_RANK (type));
2045 tree elemsz
2046 = TYPE_SIZE_UNIT (gfc_get_element_type (type));
2047 elemsz = fold_convert (gfc_array_index_type, elemsz);
2048 OMP_CLAUSE_SIZE (node)
2049 = fold_build2 (MULT_EXPR, gfc_array_index_type,
2050 OMP_CLAUSE_SIZE (node), elemsz);
2051 }
2052 gfc_add_block_to_block (block, &se.post);
2053 ptr = fold_convert (build_pointer_type (char_type_node),
2054 ptr);
2055 OMP_CLAUSE_DECL (node) = build_fold_indirect_ref (ptr);
2056
2057 if (POINTER_TYPE_P (TREE_TYPE (decl))
2058 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (decl))))
2059 {
2060 node4 = build_omp_clause (input_location,
2061 OMP_CLAUSE_MAP);
2062 OMP_CLAUSE_MAP_KIND (node4) = OMP_CLAUSE_MAP_POINTER;
2063 OMP_CLAUSE_DECL (node4) = decl;
2064 OMP_CLAUSE_SIZE (node4) = size_int (0);
2065 decl = build_fold_indirect_ref (decl);
2066 }
2067 ptr = fold_convert (sizetype, ptr);
2068 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
2069 {
2070 tree type = TREE_TYPE (decl);
2071 ptr2 = gfc_conv_descriptor_data_get (decl);
2072 node2 = build_omp_clause (input_location,
2073 OMP_CLAUSE_MAP);
2074 OMP_CLAUSE_MAP_KIND (node2) = OMP_CLAUSE_MAP_TO_PSET;
2075 OMP_CLAUSE_DECL (node2) = decl;
2076 OMP_CLAUSE_SIZE (node2) = TYPE_SIZE_UNIT (type);
2077 node3 = build_omp_clause (input_location,
2078 OMP_CLAUSE_MAP);
2079 OMP_CLAUSE_MAP_KIND (node3) = OMP_CLAUSE_MAP_POINTER;
2080 OMP_CLAUSE_DECL (node3)
2081 = gfc_conv_descriptor_data_get (decl);
2082 }
2083 else
2084 {
2085 if (TREE_CODE (TREE_TYPE (decl)) == ARRAY_TYPE)
2086 ptr2 = build_fold_addr_expr (decl);
2087 else
2088 {
2089 gcc_assert (POINTER_TYPE_P (TREE_TYPE (decl)));
2090 ptr2 = decl;
2091 }
2092 node3 = build_omp_clause (input_location,
2093 OMP_CLAUSE_MAP);
2094 OMP_CLAUSE_MAP_KIND (node3) = OMP_CLAUSE_MAP_POINTER;
2095 OMP_CLAUSE_DECL (node3) = decl;
2096 }
2097 ptr2 = fold_convert (sizetype, ptr2);
2098 OMP_CLAUSE_SIZE (node3)
2099 = fold_build2 (MINUS_EXPR, sizetype, ptr, ptr2);
2100 }
2101 switch (n->u.map_op)
2102 {
2103 case OMP_MAP_ALLOC:
2104 OMP_CLAUSE_MAP_KIND (node) = OMP_CLAUSE_MAP_ALLOC;
2105 break;
2106 case OMP_MAP_TO:
2107 OMP_CLAUSE_MAP_KIND (node) = OMP_CLAUSE_MAP_TO;
2108 break;
2109 case OMP_MAP_FROM:
2110 OMP_CLAUSE_MAP_KIND (node) = OMP_CLAUSE_MAP_FROM;
2111 break;
2112 case OMP_MAP_TOFROM:
2113 OMP_CLAUSE_MAP_KIND (node) = OMP_CLAUSE_MAP_TOFROM;
2114 break;
2115 case OMP_MAP_FORCE_ALLOC:
2116 OMP_CLAUSE_MAP_KIND (node) = OMP_CLAUSE_MAP_FORCE_ALLOC;
2117 break;
2118 case OMP_MAP_FORCE_DEALLOC:
2119 OMP_CLAUSE_MAP_KIND (node) = OMP_CLAUSE_MAP_FORCE_DEALLOC;
2120 break;
2121 case OMP_MAP_FORCE_TO:
2122 OMP_CLAUSE_MAP_KIND (node) = OMP_CLAUSE_MAP_FORCE_TO;
2123 break;
2124 case OMP_MAP_FORCE_FROM:
2125 OMP_CLAUSE_MAP_KIND (node) = OMP_CLAUSE_MAP_FORCE_FROM;
2126 break;
2127 case OMP_MAP_FORCE_TOFROM:
2128 OMP_CLAUSE_MAP_KIND (node) = OMP_CLAUSE_MAP_FORCE_TOFROM;
2129 break;
2130 case OMP_MAP_FORCE_PRESENT:
2131 OMP_CLAUSE_MAP_KIND (node) = OMP_CLAUSE_MAP_FORCE_PRESENT;
2132 break;
2133 case OMP_MAP_FORCE_DEVICEPTR:
2134 OMP_CLAUSE_MAP_KIND (node) = OMP_CLAUSE_MAP_FORCE_DEVICEPTR;
2135 break;
2136 default:
2137 gcc_unreachable ();
2138 }
2139 omp_clauses = gfc_trans_add_clause (node, omp_clauses);
2140 if (node2)
2141 omp_clauses = gfc_trans_add_clause (node2, omp_clauses);
2142 if (node3)
2143 omp_clauses = gfc_trans_add_clause (node3, omp_clauses);
2144 if (node4)
2145 omp_clauses = gfc_trans_add_clause (node4, omp_clauses);
2146 }
2147 break;
2148 case OMP_LIST_TO:
2149 case OMP_LIST_FROM:
2150 for (; n != NULL; n = n->next)
2151 {
2152 if (!n->sym->attr.referenced)
2153 continue;
2154
2155 tree node = build_omp_clause (input_location,
2156 list == OMP_LIST_TO
2157 ? OMP_CLAUSE_TO : OMP_CLAUSE_FROM);
2158 if (n->expr == NULL || n->expr->ref->u.ar.type == AR_FULL)
2159 {
2160 tree decl = gfc_get_symbol_decl (n->sym);
2161 if (gfc_omp_privatize_by_reference (decl))
2162 decl = build_fold_indirect_ref (decl);
2163 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
2164 {
2165 tree type = TREE_TYPE (decl);
2166 tree ptr = gfc_conv_descriptor_data_get (decl);
2167 ptr = fold_convert (build_pointer_type (char_type_node),
2168 ptr);
2169 ptr = build_fold_indirect_ref (ptr);
2170 OMP_CLAUSE_DECL (node) = ptr;
2171 OMP_CLAUSE_SIZE (node)
2172 = gfc_full_array_size (block, decl,
2173 GFC_TYPE_ARRAY_RANK (type));
2174 tree elemsz
2175 = TYPE_SIZE_UNIT (gfc_get_element_type (type));
2176 elemsz = fold_convert (gfc_array_index_type, elemsz);
2177 OMP_CLAUSE_SIZE (node)
2178 = fold_build2 (MULT_EXPR, gfc_array_index_type,
2179 OMP_CLAUSE_SIZE (node), elemsz);
2180 }
2181 else
2182 OMP_CLAUSE_DECL (node) = decl;
2183 }
2184 else
2185 {
2186 tree ptr;
2187 gfc_init_se (&se, NULL);
2188 if (n->expr->ref->u.ar.type == AR_ELEMENT)
2189 {
2190 gfc_conv_expr_reference (&se, n->expr);
2191 ptr = se.expr;
2192 gfc_add_block_to_block (block, &se.pre);
2193 OMP_CLAUSE_SIZE (node)
2194 = TYPE_SIZE_UNIT (TREE_TYPE (ptr));
2195 }
2196 else
2197 {
2198 gfc_conv_expr_descriptor (&se, n->expr);
2199 ptr = gfc_conv_array_data (se.expr);
2200 tree type = TREE_TYPE (se.expr);
2201 gfc_add_block_to_block (block, &se.pre);
2202 OMP_CLAUSE_SIZE (node)
2203 = gfc_full_array_size (block, se.expr,
2204 GFC_TYPE_ARRAY_RANK (type));
2205 tree elemsz
2206 = TYPE_SIZE_UNIT (gfc_get_element_type (type));
2207 elemsz = fold_convert (gfc_array_index_type, elemsz);
2208 OMP_CLAUSE_SIZE (node)
2209 = fold_build2 (MULT_EXPR, gfc_array_index_type,
2210 OMP_CLAUSE_SIZE (node), elemsz);
2211 }
2212 gfc_add_block_to_block (block, &se.post);
2213 ptr = fold_convert (build_pointer_type (char_type_node),
2214 ptr);
2215 OMP_CLAUSE_DECL (node) = build_fold_indirect_ref (ptr);
2216 }
2217 omp_clauses = gfc_trans_add_clause (node, omp_clauses);
2218 }
2219 break;
2220 default:
2221 break;
2222 }
2223 }
2224
2225 if (clauses->if_expr)
2226 {
2227 tree if_var;
2228
2229 gfc_init_se (&se, NULL);
2230 gfc_conv_expr (&se, clauses->if_expr);
2231 gfc_add_block_to_block (block, &se.pre);
2232 if_var = gfc_evaluate_now (se.expr, block);
2233 gfc_add_block_to_block (block, &se.post);
2234
2235 c = build_omp_clause (where.lb->location, OMP_CLAUSE_IF);
2236 OMP_CLAUSE_IF_EXPR (c) = if_var;
2237 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2238 }
2239
2240 if (clauses->final_expr)
2241 {
2242 tree final_var;
2243
2244 gfc_init_se (&se, NULL);
2245 gfc_conv_expr (&se, clauses->final_expr);
2246 gfc_add_block_to_block (block, &se.pre);
2247 final_var = gfc_evaluate_now (se.expr, block);
2248 gfc_add_block_to_block (block, &se.post);
2249
2250 c = build_omp_clause (where.lb->location, OMP_CLAUSE_FINAL);
2251 OMP_CLAUSE_FINAL_EXPR (c) = final_var;
2252 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2253 }
2254
2255 if (clauses->num_threads)
2256 {
2257 tree num_threads;
2258
2259 gfc_init_se (&se, NULL);
2260 gfc_conv_expr (&se, clauses->num_threads);
2261 gfc_add_block_to_block (block, &se.pre);
2262 num_threads = gfc_evaluate_now (se.expr, block);
2263 gfc_add_block_to_block (block, &se.post);
2264
2265 c = build_omp_clause (where.lb->location, OMP_CLAUSE_NUM_THREADS);
2266 OMP_CLAUSE_NUM_THREADS_EXPR (c) = num_threads;
2267 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2268 }
2269
2270 chunk_size = NULL_TREE;
2271 if (clauses->chunk_size)
2272 {
2273 gfc_init_se (&se, NULL);
2274 gfc_conv_expr (&se, clauses->chunk_size);
2275 gfc_add_block_to_block (block, &se.pre);
2276 chunk_size = gfc_evaluate_now (se.expr, block);
2277 gfc_add_block_to_block (block, &se.post);
2278 }
2279
2280 if (clauses->sched_kind != OMP_SCHED_NONE)
2281 {
2282 c = build_omp_clause (where.lb->location, OMP_CLAUSE_SCHEDULE);
2283 OMP_CLAUSE_SCHEDULE_CHUNK_EXPR (c) = chunk_size;
2284 switch (clauses->sched_kind)
2285 {
2286 case OMP_SCHED_STATIC:
2287 OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_STATIC;
2288 break;
2289 case OMP_SCHED_DYNAMIC:
2290 OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_DYNAMIC;
2291 break;
2292 case OMP_SCHED_GUIDED:
2293 OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_GUIDED;
2294 break;
2295 case OMP_SCHED_RUNTIME:
2296 OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_RUNTIME;
2297 break;
2298 case OMP_SCHED_AUTO:
2299 OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_AUTO;
2300 break;
2301 default:
2302 gcc_unreachable ();
2303 }
2304 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2305 }
2306
2307 if (clauses->default_sharing != OMP_DEFAULT_UNKNOWN)
2308 {
2309 c = build_omp_clause (where.lb->location, OMP_CLAUSE_DEFAULT);
2310 switch (clauses->default_sharing)
2311 {
2312 case OMP_DEFAULT_NONE:
2313 OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_NONE;
2314 break;
2315 case OMP_DEFAULT_SHARED:
2316 OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_SHARED;
2317 break;
2318 case OMP_DEFAULT_PRIVATE:
2319 OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_PRIVATE;
2320 break;
2321 case OMP_DEFAULT_FIRSTPRIVATE:
2322 OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_FIRSTPRIVATE;
2323 break;
2324 default:
2325 gcc_unreachable ();
2326 }
2327 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2328 }
2329
2330 if (clauses->nowait)
2331 {
2332 c = build_omp_clause (where.lb->location, OMP_CLAUSE_NOWAIT);
2333 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2334 }
2335
2336 if (clauses->ordered)
2337 {
2338 c = build_omp_clause (where.lb->location, OMP_CLAUSE_ORDERED);
2339 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2340 }
2341
2342 if (clauses->untied)
2343 {
2344 c = build_omp_clause (where.lb->location, OMP_CLAUSE_UNTIED);
2345 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2346 }
2347
2348 if (clauses->mergeable)
2349 {
2350 c = build_omp_clause (where.lb->location, OMP_CLAUSE_MERGEABLE);
2351 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2352 }
2353
2354 if (clauses->collapse)
2355 {
2356 c = build_omp_clause (where.lb->location, OMP_CLAUSE_COLLAPSE);
2357 OMP_CLAUSE_COLLAPSE_EXPR (c)
2358 = build_int_cst (integer_type_node, clauses->collapse);
2359 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2360 }
2361
2362 if (clauses->inbranch)
2363 {
2364 c = build_omp_clause (where.lb->location, OMP_CLAUSE_INBRANCH);
2365 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2366 }
2367
2368 if (clauses->notinbranch)
2369 {
2370 c = build_omp_clause (where.lb->location, OMP_CLAUSE_NOTINBRANCH);
2371 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2372 }
2373
2374 switch (clauses->cancel)
2375 {
2376 case OMP_CANCEL_UNKNOWN:
2377 break;
2378 case OMP_CANCEL_PARALLEL:
2379 c = build_omp_clause (where.lb->location, OMP_CLAUSE_PARALLEL);
2380 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2381 break;
2382 case OMP_CANCEL_SECTIONS:
2383 c = build_omp_clause (where.lb->location, OMP_CLAUSE_SECTIONS);
2384 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2385 break;
2386 case OMP_CANCEL_DO:
2387 c = build_omp_clause (where.lb->location, OMP_CLAUSE_FOR);
2388 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2389 break;
2390 case OMP_CANCEL_TASKGROUP:
2391 c = build_omp_clause (where.lb->location, OMP_CLAUSE_TASKGROUP);
2392 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2393 break;
2394 }
2395
2396 if (clauses->proc_bind != OMP_PROC_BIND_UNKNOWN)
2397 {
2398 c = build_omp_clause (where.lb->location, OMP_CLAUSE_PROC_BIND);
2399 switch (clauses->proc_bind)
2400 {
2401 case OMP_PROC_BIND_MASTER:
2402 OMP_CLAUSE_PROC_BIND_KIND (c) = OMP_CLAUSE_PROC_BIND_MASTER;
2403 break;
2404 case OMP_PROC_BIND_SPREAD:
2405 OMP_CLAUSE_PROC_BIND_KIND (c) = OMP_CLAUSE_PROC_BIND_SPREAD;
2406 break;
2407 case OMP_PROC_BIND_CLOSE:
2408 OMP_CLAUSE_PROC_BIND_KIND (c) = OMP_CLAUSE_PROC_BIND_CLOSE;
2409 break;
2410 default:
2411 gcc_unreachable ();
2412 }
2413 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2414 }
2415
2416 if (clauses->safelen_expr)
2417 {
2418 tree safelen_var;
2419
2420 gfc_init_se (&se, NULL);
2421 gfc_conv_expr (&se, clauses->safelen_expr);
2422 gfc_add_block_to_block (block, &se.pre);
2423 safelen_var = gfc_evaluate_now (se.expr, block);
2424 gfc_add_block_to_block (block, &se.post);
2425
2426 c = build_omp_clause (where.lb->location, OMP_CLAUSE_SAFELEN);
2427 OMP_CLAUSE_SAFELEN_EXPR (c) = safelen_var;
2428 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2429 }
2430
2431 if (clauses->simdlen_expr)
2432 {
2433 c = build_omp_clause (where.lb->location, OMP_CLAUSE_SIMDLEN);
2434 OMP_CLAUSE_SIMDLEN_EXPR (c)
2435 = gfc_conv_constant_to_tree (clauses->simdlen_expr);
2436 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2437 }
2438
2439 if (clauses->num_teams)
2440 {
2441 tree num_teams;
2442
2443 gfc_init_se (&se, NULL);
2444 gfc_conv_expr (&se, clauses->num_teams);
2445 gfc_add_block_to_block (block, &se.pre);
2446 num_teams = gfc_evaluate_now (se.expr, block);
2447 gfc_add_block_to_block (block, &se.post);
2448
2449 c = build_omp_clause (where.lb->location, OMP_CLAUSE_NUM_TEAMS);
2450 OMP_CLAUSE_NUM_TEAMS_EXPR (c) = num_teams;
2451 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2452 }
2453
2454 if (clauses->device)
2455 {
2456 tree device;
2457
2458 gfc_init_se (&se, NULL);
2459 gfc_conv_expr (&se, clauses->device);
2460 gfc_add_block_to_block (block, &se.pre);
2461 device = gfc_evaluate_now (se.expr, block);
2462 gfc_add_block_to_block (block, &se.post);
2463
2464 c = build_omp_clause (where.lb->location, OMP_CLAUSE_DEVICE);
2465 OMP_CLAUSE_DEVICE_ID (c) = device;
2466 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2467 }
2468
2469 if (clauses->thread_limit)
2470 {
2471 tree thread_limit;
2472
2473 gfc_init_se (&se, NULL);
2474 gfc_conv_expr (&se, clauses->thread_limit);
2475 gfc_add_block_to_block (block, &se.pre);
2476 thread_limit = gfc_evaluate_now (se.expr, block);
2477 gfc_add_block_to_block (block, &se.post);
2478
2479 c = build_omp_clause (where.lb->location, OMP_CLAUSE_THREAD_LIMIT);
2480 OMP_CLAUSE_THREAD_LIMIT_EXPR (c) = thread_limit;
2481 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2482 }
2483
2484 chunk_size = NULL_TREE;
2485 if (clauses->dist_chunk_size)
2486 {
2487 gfc_init_se (&se, NULL);
2488 gfc_conv_expr (&se, clauses->dist_chunk_size);
2489 gfc_add_block_to_block (block, &se.pre);
2490 chunk_size = gfc_evaluate_now (se.expr, block);
2491 gfc_add_block_to_block (block, &se.post);
2492 }
2493
2494 if (clauses->dist_sched_kind != OMP_SCHED_NONE)
2495 {
2496 c = build_omp_clause (where.lb->location, OMP_CLAUSE_DIST_SCHEDULE);
2497 OMP_CLAUSE_DIST_SCHEDULE_CHUNK_EXPR (c) = chunk_size;
2498 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2499 }
2500
2501 if (clauses->async)
2502 {
2503 c = build_omp_clause (where.lb->location, OMP_CLAUSE_ASYNC);
2504 if (clauses->async_expr)
2505 OMP_CLAUSE_ASYNC_EXPR (c)
2506 = gfc_convert_expr_to_tree (block, clauses->async_expr);
2507 else
2508 OMP_CLAUSE_ASYNC_EXPR (c) = NULL;
2509 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2510 }
2511 if (clauses->seq)
2512 {
2513 c = build_omp_clause (where.lb->location, OMP_CLAUSE_ORDERED);
2514 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2515 }
2516 if (clauses->independent)
2517 {
2518 c = build_omp_clause (where.lb->location, OMP_CLAUSE_INDEPENDENT);
2519 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2520 }
2521 if (clauses->wait_list)
2522 {
2523 gfc_expr_list *el;
2524
2525 for (el = clauses->wait_list; el; el = el->next)
2526 {
2527 c = build_omp_clause (where.lb->location, OMP_CLAUSE_WAIT);
2528 OMP_CLAUSE_DECL (c) = gfc_convert_expr_to_tree (block, el->expr);
2529 OMP_CLAUSE_CHAIN (c) = omp_clauses;
2530 omp_clauses = c;
2531 }
2532 }
2533 if (clauses->num_gangs_expr)
2534 {
2535 tree num_gangs_var
2536 = gfc_convert_expr_to_tree (block, clauses->num_gangs_expr);
2537 c = build_omp_clause (where.lb->location, OMP_CLAUSE_NUM_GANGS);
2538 OMP_CLAUSE_NUM_GANGS_EXPR (c) = num_gangs_var;
2539 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2540 }
2541 if (clauses->num_workers_expr)
2542 {
2543 tree num_workers_var
2544 = gfc_convert_expr_to_tree (block, clauses->num_workers_expr);
2545 c = build_omp_clause (where.lb->location, OMP_CLAUSE_NUM_WORKERS);
2546 OMP_CLAUSE_NUM_WORKERS_EXPR (c) = num_workers_var;
2547 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2548 }
2549 if (clauses->vector_length_expr)
2550 {
2551 tree vector_length_var
2552 = gfc_convert_expr_to_tree (block, clauses->vector_length_expr);
2553 c = build_omp_clause (where.lb->location, OMP_CLAUSE_VECTOR_LENGTH);
2554 OMP_CLAUSE_VECTOR_LENGTH_EXPR (c) = vector_length_var;
2555 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2556 }
2557 if (clauses->vector)
2558 {
2559 if (clauses->vector_expr)
2560 {
2561 tree vector_var
2562 = gfc_convert_expr_to_tree (block, clauses->vector_expr);
2563 c = build_omp_clause (where.lb->location, OMP_CLAUSE_VECTOR);
2564 OMP_CLAUSE_VECTOR_EXPR (c) = vector_var;
2565 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2566 }
2567 else
2568 {
2569 c = build_omp_clause (where.lb->location, OMP_CLAUSE_VECTOR);
2570 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2571 }
2572 }
2573 if (clauses->worker)
2574 {
2575 if (clauses->worker_expr)
2576 {
2577 tree worker_var
2578 = gfc_convert_expr_to_tree (block, clauses->worker_expr);
2579 c = build_omp_clause (where.lb->location, OMP_CLAUSE_WORKER);
2580 OMP_CLAUSE_WORKER_EXPR (c) = worker_var;
2581 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2582 }
2583 else
2584 {
2585 c = build_omp_clause (where.lb->location, OMP_CLAUSE_WORKER);
2586 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2587 }
2588 }
2589 if (clauses->gang)
2590 {
2591 if (clauses->gang_expr)
2592 {
2593 tree gang_var
2594 = gfc_convert_expr_to_tree (block, clauses->gang_expr);
2595 c = build_omp_clause (where.lb->location, OMP_CLAUSE_GANG);
2596 OMP_CLAUSE_GANG_EXPR (c) = gang_var;
2597 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2598 }
2599 else
2600 {
2601 c = build_omp_clause (where.lb->location, OMP_CLAUSE_GANG);
2602 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
2603 }
2604 }
2605
2606 return nreverse (omp_clauses);
2607 }
2608
2609 /* Like gfc_trans_code, but force creation of a BIND_EXPR around it. */
2610
2611 static tree
2612 gfc_trans_omp_code (gfc_code *code, bool force_empty)
2613 {
2614 tree stmt;
2615
2616 pushlevel ();
2617 stmt = gfc_trans_code (code);
2618 if (TREE_CODE (stmt) != BIND_EXPR)
2619 {
2620 if (!IS_EMPTY_STMT (stmt) || force_empty)
2621 {
2622 tree block = poplevel (1, 0);
2623 stmt = build3_v (BIND_EXPR, NULL, stmt, block);
2624 }
2625 else
2626 poplevel (0, 0);
2627 }
2628 else
2629 poplevel (0, 0);
2630 return stmt;
2631 }
2632
2633 /* Trans OpenACC directives. */
2634 /* parallel, kernels, data and host_data. */
2635 static tree
2636 gfc_trans_oacc_construct (gfc_code *code)
2637 {
2638 stmtblock_t block;
2639 tree stmt, oacc_clauses;
2640 enum tree_code construct_code;
2641
2642 switch (code->op)
2643 {
2644 case EXEC_OACC_PARALLEL:
2645 construct_code = OACC_PARALLEL;
2646 break;
2647 case EXEC_OACC_KERNELS:
2648 construct_code = OACC_KERNELS;
2649 break;
2650 case EXEC_OACC_DATA:
2651 construct_code = OACC_DATA;
2652 break;
2653 case EXEC_OACC_HOST_DATA:
2654 construct_code = OACC_HOST_DATA;
2655 break;
2656 default:
2657 gcc_unreachable ();
2658 }
2659
2660 gfc_start_block (&block);
2661 oacc_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
2662 code->loc);
2663 stmt = gfc_trans_omp_code (code->block->next, true);
2664 stmt = build2_loc (input_location, construct_code, void_type_node, stmt,
2665 oacc_clauses);
2666 gfc_add_expr_to_block (&block, stmt);
2667 return gfc_finish_block (&block);
2668 }
2669
2670 /* update, enter_data, exit_data, cache. */
2671 static tree
2672 gfc_trans_oacc_executable_directive (gfc_code *code)
2673 {
2674 stmtblock_t block;
2675 tree stmt, oacc_clauses;
2676 enum tree_code construct_code;
2677
2678 switch (code->op)
2679 {
2680 case EXEC_OACC_UPDATE:
2681 construct_code = OACC_UPDATE;
2682 break;
2683 case EXEC_OACC_ENTER_DATA:
2684 construct_code = OACC_ENTER_DATA;
2685 break;
2686 case EXEC_OACC_EXIT_DATA:
2687 construct_code = OACC_EXIT_DATA;
2688 break;
2689 case EXEC_OACC_CACHE:
2690 construct_code = OACC_CACHE;
2691 break;
2692 default:
2693 gcc_unreachable ();
2694 }
2695
2696 gfc_start_block (&block);
2697 oacc_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
2698 code->loc);
2699 stmt = build1_loc (input_location, construct_code, void_type_node,
2700 oacc_clauses);
2701 gfc_add_expr_to_block (&block, stmt);
2702 return gfc_finish_block (&block);
2703 }
2704
2705 static tree
2706 gfc_trans_oacc_wait_directive (gfc_code *code)
2707 {
2708 stmtblock_t block;
2709 tree stmt, t;
2710 vec<tree, va_gc> *args;
2711 int nparms = 0;
2712 gfc_expr_list *el;
2713 gfc_omp_clauses *clauses = code->ext.omp_clauses;
2714 location_t loc = input_location;
2715
2716 for (el = clauses->wait_list; el; el = el->next)
2717 nparms++;
2718
2719 vec_alloc (args, nparms + 2);
2720 stmt = builtin_decl_explicit (BUILT_IN_GOACC_WAIT);
2721
2722 gfc_start_block (&block);
2723
2724 if (clauses->async_expr)
2725 t = gfc_convert_expr_to_tree (&block, clauses->async_expr);
2726 else
2727 t = build_int_cst (integer_type_node, -2);
2728
2729 args->quick_push (t);
2730 args->quick_push (build_int_cst (integer_type_node, nparms));
2731
2732 for (el = clauses->wait_list; el; el = el->next)
2733 args->quick_push (gfc_convert_expr_to_tree (&block, el->expr));
2734
2735 stmt = build_call_expr_loc_vec (loc, stmt, args);
2736 gfc_add_expr_to_block (&block, stmt);
2737
2738 vec_free (args);
2739
2740 return gfc_finish_block (&block);
2741 }
2742
2743 static tree gfc_trans_omp_sections (gfc_code *, gfc_omp_clauses *);
2744 static tree gfc_trans_omp_workshare (gfc_code *, gfc_omp_clauses *);
2745
2746 static tree
2747 gfc_trans_omp_atomic (gfc_code *code)
2748 {
2749 gfc_code *atomic_code = code;
2750 gfc_se lse;
2751 gfc_se rse;
2752 gfc_se vse;
2753 gfc_expr *expr2, *e;
2754 gfc_symbol *var;
2755 stmtblock_t block;
2756 tree lhsaddr, type, rhs, x;
2757 enum tree_code op = ERROR_MARK;
2758 enum tree_code aop = OMP_ATOMIC;
2759 bool var_on_left = false;
2760 bool seq_cst = (atomic_code->ext.omp_atomic & GFC_OMP_ATOMIC_SEQ_CST) != 0;
2761
2762 code = code->block->next;
2763 gcc_assert (code->op == EXEC_ASSIGN);
2764 var = code->expr1->symtree->n.sym;
2765
2766 gfc_init_se (&lse, NULL);
2767 gfc_init_se (&rse, NULL);
2768 gfc_init_se (&vse, NULL);
2769 gfc_start_block (&block);
2770
2771 expr2 = code->expr2;
2772 if (expr2->expr_type == EXPR_FUNCTION
2773 && expr2->value.function.isym->id == GFC_ISYM_CONVERSION)
2774 expr2 = expr2->value.function.actual->expr;
2775
2776 switch (atomic_code->ext.omp_atomic & GFC_OMP_ATOMIC_MASK)
2777 {
2778 case GFC_OMP_ATOMIC_READ:
2779 gfc_conv_expr (&vse, code->expr1);
2780 gfc_add_block_to_block (&block, &vse.pre);
2781
2782 gfc_conv_expr (&lse, expr2);
2783 gfc_add_block_to_block (&block, &lse.pre);
2784 type = TREE_TYPE (lse.expr);
2785 lhsaddr = gfc_build_addr_expr (NULL, lse.expr);
2786
2787 x = build1 (OMP_ATOMIC_READ, type, lhsaddr);
2788 OMP_ATOMIC_SEQ_CST (x) = seq_cst;
2789 x = convert (TREE_TYPE (vse.expr), x);
2790 gfc_add_modify (&block, vse.expr, x);
2791
2792 gfc_add_block_to_block (&block, &lse.pre);
2793 gfc_add_block_to_block (&block, &rse.pre);
2794
2795 return gfc_finish_block (&block);
2796 case GFC_OMP_ATOMIC_CAPTURE:
2797 aop = OMP_ATOMIC_CAPTURE_NEW;
2798 if (expr2->expr_type == EXPR_VARIABLE)
2799 {
2800 aop = OMP_ATOMIC_CAPTURE_OLD;
2801 gfc_conv_expr (&vse, code->expr1);
2802 gfc_add_block_to_block (&block, &vse.pre);
2803
2804 gfc_conv_expr (&lse, expr2);
2805 gfc_add_block_to_block (&block, &lse.pre);
2806 gfc_init_se (&lse, NULL);
2807 code = code->next;
2808 var = code->expr1->symtree->n.sym;
2809 expr2 = code->expr2;
2810 if (expr2->expr_type == EXPR_FUNCTION
2811 && expr2->value.function.isym->id == GFC_ISYM_CONVERSION)
2812 expr2 = expr2->value.function.actual->expr;
2813 }
2814 break;
2815 default:
2816 break;
2817 }
2818
2819 gfc_conv_expr (&lse, code->expr1);
2820 gfc_add_block_to_block (&block, &lse.pre);
2821 type = TREE_TYPE (lse.expr);
2822 lhsaddr = gfc_build_addr_expr (NULL, lse.expr);
2823
2824 if (((atomic_code->ext.omp_atomic & GFC_OMP_ATOMIC_MASK)
2825 == GFC_OMP_ATOMIC_WRITE)
2826 || (atomic_code->ext.omp_atomic & GFC_OMP_ATOMIC_SWAP))
2827 {
2828 gfc_conv_expr (&rse, expr2);
2829 gfc_add_block_to_block (&block, &rse.pre);
2830 }
2831 else if (expr2->expr_type == EXPR_OP)
2832 {
2833 gfc_expr *e;
2834 switch (expr2->value.op.op)
2835 {
2836 case INTRINSIC_PLUS:
2837 op = PLUS_EXPR;
2838 break;
2839 case INTRINSIC_TIMES:
2840 op = MULT_EXPR;
2841 break;
2842 case INTRINSIC_MINUS:
2843 op = MINUS_EXPR;
2844 break;
2845 case INTRINSIC_DIVIDE:
2846 if (expr2->ts.type == BT_INTEGER)
2847 op = TRUNC_DIV_EXPR;
2848 else
2849 op = RDIV_EXPR;
2850 break;
2851 case INTRINSIC_AND:
2852 op = TRUTH_ANDIF_EXPR;
2853 break;
2854 case INTRINSIC_OR:
2855 op = TRUTH_ORIF_EXPR;
2856 break;
2857 case INTRINSIC_EQV:
2858 op = EQ_EXPR;
2859 break;
2860 case INTRINSIC_NEQV:
2861 op = NE_EXPR;
2862 break;
2863 default:
2864 gcc_unreachable ();
2865 }
2866 e = expr2->value.op.op1;
2867 if (e->expr_type == EXPR_FUNCTION
2868 && e->value.function.isym->id == GFC_ISYM_CONVERSION)
2869 e = e->value.function.actual->expr;
2870 if (e->expr_type == EXPR_VARIABLE
2871 && e->symtree != NULL
2872 && e->symtree->n.sym == var)
2873 {
2874 expr2 = expr2->value.op.op2;
2875 var_on_left = true;
2876 }
2877 else
2878 {
2879 e = expr2->value.op.op2;
2880 if (e->expr_type == EXPR_FUNCTION
2881 && e->value.function.isym->id == GFC_ISYM_CONVERSION)
2882 e = e->value.function.actual->expr;
2883 gcc_assert (e->expr_type == EXPR_VARIABLE
2884 && e->symtree != NULL
2885 && e->symtree->n.sym == var);
2886 expr2 = expr2->value.op.op1;
2887 var_on_left = false;
2888 }
2889 gfc_conv_expr (&rse, expr2);
2890 gfc_add_block_to_block (&block, &rse.pre);
2891 }
2892 else
2893 {
2894 gcc_assert (expr2->expr_type == EXPR_FUNCTION);
2895 switch (expr2->value.function.isym->id)
2896 {
2897 case GFC_ISYM_MIN:
2898 op = MIN_EXPR;
2899 break;
2900 case GFC_ISYM_MAX:
2901 op = MAX_EXPR;
2902 break;
2903 case GFC_ISYM_IAND:
2904 op = BIT_AND_EXPR;
2905 break;
2906 case GFC_ISYM_IOR:
2907 op = BIT_IOR_EXPR;
2908 break;
2909 case GFC_ISYM_IEOR:
2910 op = BIT_XOR_EXPR;
2911 break;
2912 default:
2913 gcc_unreachable ();
2914 }
2915 e = expr2->value.function.actual->expr;
2916 gcc_assert (e->expr_type == EXPR_VARIABLE
2917 && e->symtree != NULL
2918 && e->symtree->n.sym == var);
2919
2920 gfc_conv_expr (&rse, expr2->value.function.actual->next->expr);
2921 gfc_add_block_to_block (&block, &rse.pre);
2922 if (expr2->value.function.actual->next->next != NULL)
2923 {
2924 tree accum = gfc_create_var (TREE_TYPE (rse.expr), NULL);
2925 gfc_actual_arglist *arg;
2926
2927 gfc_add_modify (&block, accum, rse.expr);
2928 for (arg = expr2->value.function.actual->next->next; arg;
2929 arg = arg->next)
2930 {
2931 gfc_init_block (&rse.pre);
2932 gfc_conv_expr (&rse, arg->expr);
2933 gfc_add_block_to_block (&block, &rse.pre);
2934 x = fold_build2_loc (input_location, op, TREE_TYPE (accum),
2935 accum, rse.expr);
2936 gfc_add_modify (&block, accum, x);
2937 }
2938
2939 rse.expr = accum;
2940 }
2941
2942 expr2 = expr2->value.function.actual->next->expr;
2943 }
2944
2945 lhsaddr = save_expr (lhsaddr);
2946 if (TREE_CODE (lhsaddr) != SAVE_EXPR
2947 && (TREE_CODE (lhsaddr) != ADDR_EXPR
2948 || TREE_CODE (TREE_OPERAND (lhsaddr, 0)) != VAR_DECL))
2949 {
2950 /* Make sure LHS is simple enough so that goa_lhs_expr_p can recognize
2951 it even after unsharing function body. */
2952 tree var = create_tmp_var_raw (TREE_TYPE (lhsaddr));
2953 DECL_CONTEXT (var) = current_function_decl;
2954 lhsaddr = build4 (TARGET_EXPR, TREE_TYPE (lhsaddr), var, lhsaddr,
2955 NULL_TREE, NULL_TREE);
2956 }
2957
2958 rhs = gfc_evaluate_now (rse.expr, &block);
2959
2960 if (((atomic_code->ext.omp_atomic & GFC_OMP_ATOMIC_MASK)
2961 == GFC_OMP_ATOMIC_WRITE)
2962 || (atomic_code->ext.omp_atomic & GFC_OMP_ATOMIC_SWAP))
2963 x = rhs;
2964 else
2965 {
2966 x = convert (TREE_TYPE (rhs),
2967 build_fold_indirect_ref_loc (input_location, lhsaddr));
2968 if (var_on_left)
2969 x = fold_build2_loc (input_location, op, TREE_TYPE (rhs), x, rhs);
2970 else
2971 x = fold_build2_loc (input_location, op, TREE_TYPE (rhs), rhs, x);
2972 }
2973
2974 if (TREE_CODE (TREE_TYPE (rhs)) == COMPLEX_TYPE
2975 && TREE_CODE (type) != COMPLEX_TYPE)
2976 x = fold_build1_loc (input_location, REALPART_EXPR,
2977 TREE_TYPE (TREE_TYPE (rhs)), x);
2978
2979 gfc_add_block_to_block (&block, &lse.pre);
2980 gfc_add_block_to_block (&block, &rse.pre);
2981
2982 if (aop == OMP_ATOMIC)
2983 {
2984 x = build2_v (OMP_ATOMIC, lhsaddr, convert (type, x));
2985 OMP_ATOMIC_SEQ_CST (x) = seq_cst;
2986 gfc_add_expr_to_block (&block, x);
2987 }
2988 else
2989 {
2990 if (aop == OMP_ATOMIC_CAPTURE_NEW)
2991 {
2992 code = code->next;
2993 expr2 = code->expr2;
2994 if (expr2->expr_type == EXPR_FUNCTION
2995 && expr2->value.function.isym->id == GFC_ISYM_CONVERSION)
2996 expr2 = expr2->value.function.actual->expr;
2997
2998 gcc_assert (expr2->expr_type == EXPR_VARIABLE);
2999 gfc_conv_expr (&vse, code->expr1);
3000 gfc_add_block_to_block (&block, &vse.pre);
3001
3002 gfc_init_se (&lse, NULL);
3003 gfc_conv_expr (&lse, expr2);
3004 gfc_add_block_to_block (&block, &lse.pre);
3005 }
3006 x = build2 (aop, type, lhsaddr, convert (type, x));
3007 OMP_ATOMIC_SEQ_CST (x) = seq_cst;
3008 x = convert (TREE_TYPE (vse.expr), x);
3009 gfc_add_modify (&block, vse.expr, x);
3010 }
3011
3012 return gfc_finish_block (&block);
3013 }
3014
3015 static tree
3016 gfc_trans_omp_barrier (void)
3017 {
3018 tree decl = builtin_decl_explicit (BUILT_IN_GOMP_BARRIER);
3019 return build_call_expr_loc (input_location, decl, 0);
3020 }
3021
3022 static tree
3023 gfc_trans_omp_cancel (gfc_code *code)
3024 {
3025 int mask = 0;
3026 tree ifc = boolean_true_node;
3027 stmtblock_t block;
3028 switch (code->ext.omp_clauses->cancel)
3029 {
3030 case OMP_CANCEL_PARALLEL: mask = 1; break;
3031 case OMP_CANCEL_DO: mask = 2; break;
3032 case OMP_CANCEL_SECTIONS: mask = 4; break;
3033 case OMP_CANCEL_TASKGROUP: mask = 8; break;
3034 default: gcc_unreachable ();
3035 }
3036 gfc_start_block (&block);
3037 if (code->ext.omp_clauses->if_expr)
3038 {
3039 gfc_se se;
3040 tree if_var;
3041
3042 gfc_init_se (&se, NULL);
3043 gfc_conv_expr (&se, code->ext.omp_clauses->if_expr);
3044 gfc_add_block_to_block (&block, &se.pre);
3045 if_var = gfc_evaluate_now (se.expr, &block);
3046 gfc_add_block_to_block (&block, &se.post);
3047 tree type = TREE_TYPE (if_var);
3048 ifc = fold_build2_loc (input_location, NE_EXPR,
3049 boolean_type_node, if_var,
3050 build_zero_cst (type));
3051 }
3052 tree decl = builtin_decl_explicit (BUILT_IN_GOMP_CANCEL);
3053 tree c_bool_type = TREE_TYPE (TREE_TYPE (decl));
3054 ifc = fold_convert (c_bool_type, ifc);
3055 gfc_add_expr_to_block (&block,
3056 build_call_expr_loc (input_location, decl, 2,
3057 build_int_cst (integer_type_node,
3058 mask), ifc));
3059 return gfc_finish_block (&block);
3060 }
3061
3062 static tree
3063 gfc_trans_omp_cancellation_point (gfc_code *code)
3064 {
3065 int mask = 0;
3066 switch (code->ext.omp_clauses->cancel)
3067 {
3068 case OMP_CANCEL_PARALLEL: mask = 1; break;
3069 case OMP_CANCEL_DO: mask = 2; break;
3070 case OMP_CANCEL_SECTIONS: mask = 4; break;
3071 case OMP_CANCEL_TASKGROUP: mask = 8; break;
3072 default: gcc_unreachable ();
3073 }
3074 tree decl = builtin_decl_explicit (BUILT_IN_GOMP_CANCELLATION_POINT);
3075 return build_call_expr_loc (input_location, decl, 1,
3076 build_int_cst (integer_type_node, mask));
3077 }
3078
3079 static tree
3080 gfc_trans_omp_critical (gfc_code *code)
3081 {
3082 tree name = NULL_TREE, stmt;
3083 if (code->ext.omp_name != NULL)
3084 name = get_identifier (code->ext.omp_name);
3085 stmt = gfc_trans_code (code->block->next);
3086 return build2_loc (input_location, OMP_CRITICAL, void_type_node, stmt, name);
3087 }
3088
3089 typedef struct dovar_init_d {
3090 tree var;
3091 tree init;
3092 } dovar_init;
3093
3094
3095 static tree
3096 gfc_trans_omp_do (gfc_code *code, gfc_exec_op op, stmtblock_t *pblock,
3097 gfc_omp_clauses *do_clauses, tree par_clauses)
3098 {
3099 gfc_se se;
3100 tree dovar, stmt, from, to, step, type, init, cond, incr;
3101 tree count = NULL_TREE, cycle_label, tmp, omp_clauses;
3102 stmtblock_t block;
3103 stmtblock_t body;
3104 gfc_omp_clauses *clauses = code->ext.omp_clauses;
3105 int i, collapse = clauses->collapse;
3106 vec<dovar_init> inits = vNULL;
3107 dovar_init *di;
3108 unsigned ix;
3109
3110 if (collapse <= 0)
3111 collapse = 1;
3112
3113 code = code->block->next;
3114 gcc_assert (code->op == EXEC_DO);
3115
3116 init = make_tree_vec (collapse);
3117 cond = make_tree_vec (collapse);
3118 incr = make_tree_vec (collapse);
3119
3120 if (pblock == NULL)
3121 {
3122 gfc_start_block (&block);
3123 pblock = &block;
3124 }
3125
3126 omp_clauses = gfc_trans_omp_clauses (pblock, do_clauses, code->loc);
3127
3128 for (i = 0; i < collapse; i++)
3129 {
3130 int simple = 0;
3131 int dovar_found = 0;
3132 tree dovar_decl;
3133
3134 if (clauses)
3135 {
3136 gfc_omp_namelist *n = NULL;
3137 if (op != EXEC_OMP_DISTRIBUTE)
3138 for (n = clauses->lists[(op == EXEC_OMP_SIMD && collapse == 1)
3139 ? OMP_LIST_LINEAR : OMP_LIST_LASTPRIVATE];
3140 n != NULL; n = n->next)
3141 if (code->ext.iterator->var->symtree->n.sym == n->sym)
3142 break;
3143 if (n != NULL)
3144 dovar_found = 1;
3145 else if (n == NULL && op != EXEC_OMP_SIMD)
3146 for (n = clauses->lists[OMP_LIST_PRIVATE]; n != NULL; n = n->next)
3147 if (code->ext.iterator->var->symtree->n.sym == n->sym)
3148 break;
3149 if (n != NULL)
3150 dovar_found++;
3151 }
3152
3153 /* Evaluate all the expressions in the iterator. */
3154 gfc_init_se (&se, NULL);
3155 gfc_conv_expr_lhs (&se, code->ext.iterator->var);
3156 gfc_add_block_to_block (pblock, &se.pre);
3157 dovar = se.expr;
3158 type = TREE_TYPE (dovar);
3159 gcc_assert (TREE_CODE (type) == INTEGER_TYPE);
3160
3161 gfc_init_se (&se, NULL);
3162 gfc_conv_expr_val (&se, code->ext.iterator->start);
3163 gfc_add_block_to_block (pblock, &se.pre);
3164 from = gfc_evaluate_now (se.expr, pblock);
3165
3166 gfc_init_se (&se, NULL);
3167 gfc_conv_expr_val (&se, code->ext.iterator->end);
3168 gfc_add_block_to_block (pblock, &se.pre);
3169 to = gfc_evaluate_now (se.expr, pblock);
3170
3171 gfc_init_se (&se, NULL);
3172 gfc_conv_expr_val (&se, code->ext.iterator->step);
3173 gfc_add_block_to_block (pblock, &se.pre);
3174 step = gfc_evaluate_now (se.expr, pblock);
3175 dovar_decl = dovar;
3176
3177 /* Special case simple loops. */
3178 if (TREE_CODE (dovar) == VAR_DECL)
3179 {
3180 if (integer_onep (step))
3181 simple = 1;
3182 else if (tree_int_cst_equal (step, integer_minus_one_node))
3183 simple = -1;
3184 }
3185 else
3186 dovar_decl
3187 = gfc_trans_omp_variable (code->ext.iterator->var->symtree->n.sym,
3188 false);
3189
3190 /* Loop body. */
3191 if (simple)
3192 {
3193 TREE_VEC_ELT (init, i) = build2_v (MODIFY_EXPR, dovar, from);
3194 /* The condition should not be folded. */
3195 TREE_VEC_ELT (cond, i) = build2_loc (input_location, simple > 0
3196 ? LE_EXPR : GE_EXPR,
3197 boolean_type_node, dovar, to);
3198 TREE_VEC_ELT (incr, i) = fold_build2_loc (input_location, PLUS_EXPR,
3199 type, dovar, step);
3200 TREE_VEC_ELT (incr, i) = fold_build2_loc (input_location,
3201 MODIFY_EXPR,
3202 type, dovar,
3203 TREE_VEC_ELT (incr, i));
3204 }
3205 else
3206 {
3207 /* STEP is not 1 or -1. Use:
3208 for (count = 0; count < (to + step - from) / step; count++)
3209 {
3210 dovar = from + count * step;
3211 body;
3212 cycle_label:;
3213 } */
3214 tmp = fold_build2_loc (input_location, MINUS_EXPR, type, step, from);
3215 tmp = fold_build2_loc (input_location, PLUS_EXPR, type, to, tmp);
3216 tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, type, tmp,
3217 step);
3218 tmp = gfc_evaluate_now (tmp, pblock);
3219 count = gfc_create_var (type, "count");
3220 TREE_VEC_ELT (init, i) = build2_v (MODIFY_EXPR, count,
3221 build_int_cst (type, 0));
3222 /* The condition should not be folded. */
3223 TREE_VEC_ELT (cond, i) = build2_loc (input_location, LT_EXPR,
3224 boolean_type_node,
3225 count, tmp);
3226 TREE_VEC_ELT (incr, i) = fold_build2_loc (input_location, PLUS_EXPR,
3227 type, count,
3228 build_int_cst (type, 1));
3229 TREE_VEC_ELT (incr, i) = fold_build2_loc (input_location,
3230 MODIFY_EXPR, type, count,
3231 TREE_VEC_ELT (incr, i));
3232
3233 /* Initialize DOVAR. */
3234 tmp = fold_build2_loc (input_location, MULT_EXPR, type, count, step);
3235 tmp = fold_build2_loc (input_location, PLUS_EXPR, type, from, tmp);
3236 dovar_init e = {dovar, tmp};
3237 inits.safe_push (e);
3238 }
3239
3240 if (!dovar_found)
3241 {
3242 if (op == EXEC_OMP_SIMD)
3243 {
3244 if (collapse == 1)
3245 {
3246 tmp = build_omp_clause (input_location, OMP_CLAUSE_LINEAR);
3247 OMP_CLAUSE_LINEAR_STEP (tmp) = step;
3248 }
3249 else
3250 tmp = build_omp_clause (input_location, OMP_CLAUSE_LASTPRIVATE);
3251 if (!simple)
3252 dovar_found = 2;
3253 }
3254 else
3255 tmp = build_omp_clause (input_location, OMP_CLAUSE_PRIVATE);
3256 OMP_CLAUSE_DECL (tmp) = dovar_decl;
3257 omp_clauses = gfc_trans_add_clause (tmp, omp_clauses);
3258 }
3259 if (dovar_found == 2)
3260 {
3261 tree c = NULL;
3262
3263 tmp = NULL;
3264 if (!simple)
3265 {
3266 /* If dovar is lastprivate, but different counter is used,
3267 dovar += step needs to be added to
3268 OMP_CLAUSE_LASTPRIVATE_STMT, otherwise the copied dovar
3269 will have the value on entry of the last loop, rather
3270 than value after iterator increment. */
3271 tmp = gfc_evaluate_now (step, pblock);
3272 tmp = fold_build2_loc (input_location, PLUS_EXPR, type, dovar,
3273 tmp);
3274 tmp = fold_build2_loc (input_location, MODIFY_EXPR, type,
3275 dovar, tmp);
3276 for (c = omp_clauses; c ; c = OMP_CLAUSE_CHAIN (c))
3277 if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_LASTPRIVATE
3278 && OMP_CLAUSE_DECL (c) == dovar_decl)
3279 {
3280 OMP_CLAUSE_LASTPRIVATE_STMT (c) = tmp;
3281 break;
3282 }
3283 else if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_LINEAR
3284 && OMP_CLAUSE_DECL (c) == dovar_decl)
3285 {
3286 OMP_CLAUSE_LINEAR_STMT (c) = tmp;
3287 break;
3288 }
3289 }
3290 if (c == NULL && op == EXEC_OMP_DO && par_clauses != NULL)
3291 {
3292 for (c = par_clauses; c ; c = OMP_CLAUSE_CHAIN (c))
3293 if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_LASTPRIVATE
3294 && OMP_CLAUSE_DECL (c) == dovar_decl)
3295 {
3296 tree l = build_omp_clause (input_location,
3297 OMP_CLAUSE_LASTPRIVATE);
3298 OMP_CLAUSE_DECL (l) = dovar_decl;
3299 OMP_CLAUSE_CHAIN (l) = omp_clauses;
3300 OMP_CLAUSE_LASTPRIVATE_STMT (l) = tmp;
3301 omp_clauses = l;
3302 OMP_CLAUSE_SET_CODE (c, OMP_CLAUSE_SHARED);
3303 break;
3304 }
3305 }
3306 gcc_assert (simple || c != NULL);
3307 }
3308 if (!simple)
3309 {
3310 if (op != EXEC_OMP_SIMD)
3311 tmp = build_omp_clause (input_location, OMP_CLAUSE_PRIVATE);
3312 else if (collapse == 1)
3313 {
3314 tmp = build_omp_clause (input_location, OMP_CLAUSE_LINEAR);
3315 OMP_CLAUSE_LINEAR_STEP (tmp) = step;
3316 OMP_CLAUSE_LINEAR_NO_COPYIN (tmp) = 1;
3317 OMP_CLAUSE_LINEAR_NO_COPYOUT (tmp) = 1;
3318 }
3319 else
3320 tmp = build_omp_clause (input_location, OMP_CLAUSE_LASTPRIVATE);
3321 OMP_CLAUSE_DECL (tmp) = count;
3322 omp_clauses = gfc_trans_add_clause (tmp, omp_clauses);
3323 }
3324
3325 if (i + 1 < collapse)
3326 code = code->block->next;
3327 }
3328
3329 if (pblock != &block)
3330 {
3331 pushlevel ();
3332 gfc_start_block (&block);
3333 }
3334
3335 gfc_start_block (&body);
3336
3337 FOR_EACH_VEC_ELT (inits, ix, di)
3338 gfc_add_modify (&body, di->var, di->init);
3339 inits.release ();
3340
3341 /* Cycle statement is implemented with a goto. Exit statement must not be
3342 present for this loop. */
3343 cycle_label = gfc_build_label_decl (NULL_TREE);
3344
3345 /* Put these labels where they can be found later. */
3346
3347 code->cycle_label = cycle_label;
3348 code->exit_label = NULL_TREE;
3349
3350 /* Main loop body. */
3351 tmp = gfc_trans_omp_code (code->block->next, true);
3352 gfc_add_expr_to_block (&body, tmp);
3353
3354 /* Label for cycle statements (if needed). */
3355 if (TREE_USED (cycle_label))
3356 {
3357 tmp = build1_v (LABEL_EXPR, cycle_label);
3358 gfc_add_expr_to_block (&body, tmp);
3359 }
3360
3361 /* End of loop body. */
3362 switch (op)
3363 {
3364 case EXEC_OMP_SIMD: stmt = make_node (OMP_SIMD); break;
3365 case EXEC_OMP_DO: stmt = make_node (OMP_FOR); break;
3366 case EXEC_OMP_DISTRIBUTE: stmt = make_node (OMP_DISTRIBUTE); break;
3367 case EXEC_OACC_LOOP: stmt = make_node (OACC_LOOP); break;
3368 default: gcc_unreachable ();
3369 }
3370
3371 TREE_TYPE (stmt) = void_type_node;
3372 OMP_FOR_BODY (stmt) = gfc_finish_block (&body);
3373 OMP_FOR_CLAUSES (stmt) = omp_clauses;
3374 OMP_FOR_INIT (stmt) = init;
3375 OMP_FOR_COND (stmt) = cond;
3376 OMP_FOR_INCR (stmt) = incr;
3377 gfc_add_expr_to_block (&block, stmt);
3378
3379 return gfc_finish_block (&block);
3380 }
3381
3382 /* parallel loop and kernels loop. */
3383 static tree
3384 gfc_trans_oacc_combined_directive (gfc_code *code)
3385 {
3386 stmtblock_t block, *pblock = NULL;
3387 gfc_omp_clauses construct_clauses, loop_clauses;
3388 tree stmt, oacc_clauses = NULL_TREE;
3389 enum tree_code construct_code;
3390
3391 switch (code->op)
3392 {
3393 case EXEC_OACC_PARALLEL_LOOP:
3394 construct_code = OACC_PARALLEL;
3395 break;
3396 case EXEC_OACC_KERNELS_LOOP:
3397 construct_code = OACC_KERNELS;
3398 break;
3399 default:
3400 gcc_unreachable ();
3401 }
3402
3403 gfc_start_block (&block);
3404
3405 memset (&loop_clauses, 0, sizeof (loop_clauses));
3406 if (code->ext.omp_clauses != NULL)
3407 {
3408 memcpy (&construct_clauses, code->ext.omp_clauses,
3409 sizeof (construct_clauses));
3410 loop_clauses.collapse = construct_clauses.collapse;
3411 loop_clauses.gang = construct_clauses.gang;
3412 loop_clauses.vector = construct_clauses.vector;
3413 loop_clauses.worker = construct_clauses.worker;
3414 loop_clauses.seq = construct_clauses.seq;
3415 loop_clauses.independent = construct_clauses.independent;
3416 construct_clauses.collapse = 0;
3417 construct_clauses.gang = false;
3418 construct_clauses.vector = false;
3419 construct_clauses.worker = false;
3420 construct_clauses.seq = false;
3421 construct_clauses.independent = false;
3422 oacc_clauses = gfc_trans_omp_clauses (&block, &construct_clauses,
3423 code->loc);
3424 }
3425 if (!loop_clauses.seq)
3426 pblock = &block;
3427 else
3428 pushlevel ();
3429 stmt = gfc_trans_omp_do (code, code->op, pblock, &loop_clauses, NULL);
3430 if (TREE_CODE (stmt) != BIND_EXPR)
3431 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
3432 else
3433 poplevel (0, 0);
3434 stmt = build2_loc (input_location, construct_code, void_type_node, stmt,
3435 oacc_clauses);
3436 if (code->op == EXEC_OACC_KERNELS_LOOP)
3437 OACC_KERNELS_COMBINED (stmt) = 1;
3438 else
3439 OACC_PARALLEL_COMBINED (stmt) = 1;
3440 gfc_add_expr_to_block (&block, stmt);
3441 return gfc_finish_block (&block);
3442 }
3443
3444 static tree
3445 gfc_trans_omp_flush (void)
3446 {
3447 tree decl = builtin_decl_explicit (BUILT_IN_SYNC_SYNCHRONIZE);
3448 return build_call_expr_loc (input_location, decl, 0);
3449 }
3450
3451 static tree
3452 gfc_trans_omp_master (gfc_code *code)
3453 {
3454 tree stmt = gfc_trans_code (code->block->next);
3455 if (IS_EMPTY_STMT (stmt))
3456 return stmt;
3457 return build1_v (OMP_MASTER, stmt);
3458 }
3459
3460 static tree
3461 gfc_trans_omp_ordered (gfc_code *code)
3462 {
3463 return build1_v (OMP_ORDERED, gfc_trans_code (code->block->next));
3464 }
3465
3466 static tree
3467 gfc_trans_omp_parallel (gfc_code *code)
3468 {
3469 stmtblock_t block;
3470 tree stmt, omp_clauses;
3471
3472 gfc_start_block (&block);
3473 omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
3474 code->loc);
3475 stmt = gfc_trans_omp_code (code->block->next, true);
3476 stmt = build2_loc (input_location, OMP_PARALLEL, void_type_node, stmt,
3477 omp_clauses);
3478 gfc_add_expr_to_block (&block, stmt);
3479 return gfc_finish_block (&block);
3480 }
3481
3482 enum
3483 {
3484 GFC_OMP_SPLIT_SIMD,
3485 GFC_OMP_SPLIT_DO,
3486 GFC_OMP_SPLIT_PARALLEL,
3487 GFC_OMP_SPLIT_DISTRIBUTE,
3488 GFC_OMP_SPLIT_TEAMS,
3489 GFC_OMP_SPLIT_TARGET,
3490 GFC_OMP_SPLIT_NUM
3491 };
3492
3493 enum
3494 {
3495 GFC_OMP_MASK_SIMD = (1 << GFC_OMP_SPLIT_SIMD),
3496 GFC_OMP_MASK_DO = (1 << GFC_OMP_SPLIT_DO),
3497 GFC_OMP_MASK_PARALLEL = (1 << GFC_OMP_SPLIT_PARALLEL),
3498 GFC_OMP_MASK_DISTRIBUTE = (1 << GFC_OMP_SPLIT_DISTRIBUTE),
3499 GFC_OMP_MASK_TEAMS = (1 << GFC_OMP_SPLIT_TEAMS),
3500 GFC_OMP_MASK_TARGET = (1 << GFC_OMP_SPLIT_TARGET)
3501 };
3502
3503 static void
3504 gfc_split_omp_clauses (gfc_code *code,
3505 gfc_omp_clauses clausesa[GFC_OMP_SPLIT_NUM])
3506 {
3507 int mask = 0, innermost = 0;
3508 memset (clausesa, 0, GFC_OMP_SPLIT_NUM * sizeof (gfc_omp_clauses));
3509 switch (code->op)
3510 {
3511 case EXEC_OMP_DISTRIBUTE:
3512 innermost = GFC_OMP_SPLIT_DISTRIBUTE;
3513 break;
3514 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
3515 mask = GFC_OMP_MASK_DISTRIBUTE | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO;
3516 innermost = GFC_OMP_SPLIT_DO;
3517 break;
3518 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
3519 mask = GFC_OMP_MASK_DISTRIBUTE | GFC_OMP_MASK_PARALLEL
3520 | GFC_OMP_MASK_DO | GFC_OMP_MASK_SIMD;
3521 innermost = GFC_OMP_SPLIT_SIMD;
3522 break;
3523 case EXEC_OMP_DISTRIBUTE_SIMD:
3524 mask = GFC_OMP_MASK_DISTRIBUTE | GFC_OMP_MASK_SIMD;
3525 innermost = GFC_OMP_SPLIT_SIMD;
3526 break;
3527 case EXEC_OMP_DO:
3528 innermost = GFC_OMP_SPLIT_DO;
3529 break;
3530 case EXEC_OMP_DO_SIMD:
3531 mask = GFC_OMP_MASK_DO | GFC_OMP_MASK_SIMD;
3532 innermost = GFC_OMP_SPLIT_SIMD;
3533 break;
3534 case EXEC_OMP_PARALLEL:
3535 innermost = GFC_OMP_SPLIT_PARALLEL;
3536 break;
3537 case EXEC_OMP_PARALLEL_DO:
3538 mask = GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO;
3539 innermost = GFC_OMP_SPLIT_DO;
3540 break;
3541 case EXEC_OMP_PARALLEL_DO_SIMD:
3542 mask = GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO | GFC_OMP_MASK_SIMD;
3543 innermost = GFC_OMP_SPLIT_SIMD;
3544 break;
3545 case EXEC_OMP_SIMD:
3546 innermost = GFC_OMP_SPLIT_SIMD;
3547 break;
3548 case EXEC_OMP_TARGET:
3549 innermost = GFC_OMP_SPLIT_TARGET;
3550 break;
3551 case EXEC_OMP_TARGET_TEAMS:
3552 mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS;
3553 innermost = GFC_OMP_SPLIT_TEAMS;
3554 break;
3555 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
3556 mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS
3557 | GFC_OMP_MASK_DISTRIBUTE;
3558 innermost = GFC_OMP_SPLIT_DISTRIBUTE;
3559 break;
3560 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
3561 mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE
3562 | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO;
3563 innermost = GFC_OMP_SPLIT_DO;
3564 break;
3565 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
3566 mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE
3567 | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO | GFC_OMP_MASK_SIMD;
3568 innermost = GFC_OMP_SPLIT_SIMD;
3569 break;
3570 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
3571 mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS
3572 | GFC_OMP_MASK_DISTRIBUTE | GFC_OMP_MASK_SIMD;
3573 innermost = GFC_OMP_SPLIT_SIMD;
3574 break;
3575 case EXEC_OMP_TEAMS:
3576 innermost = GFC_OMP_SPLIT_TEAMS;
3577 break;
3578 case EXEC_OMP_TEAMS_DISTRIBUTE:
3579 mask = GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE;
3580 innermost = GFC_OMP_SPLIT_DISTRIBUTE;
3581 break;
3582 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
3583 mask = GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE
3584 | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO;
3585 innermost = GFC_OMP_SPLIT_DO;
3586 break;
3587 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
3588 mask = GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE
3589 | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO | GFC_OMP_MASK_SIMD;
3590 innermost = GFC_OMP_SPLIT_SIMD;
3591 break;
3592 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
3593 mask = GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE | GFC_OMP_MASK_SIMD;
3594 innermost = GFC_OMP_SPLIT_SIMD;
3595 break;
3596 default:
3597 gcc_unreachable ();
3598 }
3599 if (mask == 0)
3600 {
3601 clausesa[innermost] = *code->ext.omp_clauses;
3602 return;
3603 }
3604 if (code->ext.omp_clauses != NULL)
3605 {
3606 if (mask & GFC_OMP_MASK_TARGET)
3607 {
3608 /* First the clauses that are unique to some constructs. */
3609 clausesa[GFC_OMP_SPLIT_TARGET].lists[OMP_LIST_MAP]
3610 = code->ext.omp_clauses->lists[OMP_LIST_MAP];
3611 clausesa[GFC_OMP_SPLIT_TARGET].device
3612 = code->ext.omp_clauses->device;
3613 }
3614 if (mask & GFC_OMP_MASK_TEAMS)
3615 {
3616 /* First the clauses that are unique to some constructs. */
3617 clausesa[GFC_OMP_SPLIT_TEAMS].num_teams
3618 = code->ext.omp_clauses->num_teams;
3619 clausesa[GFC_OMP_SPLIT_TEAMS].thread_limit
3620 = code->ext.omp_clauses->thread_limit;
3621 /* Shared and default clauses are allowed on parallel and teams. */
3622 clausesa[GFC_OMP_SPLIT_TEAMS].lists[OMP_LIST_SHARED]
3623 = code->ext.omp_clauses->lists[OMP_LIST_SHARED];
3624 clausesa[GFC_OMP_SPLIT_TEAMS].default_sharing
3625 = code->ext.omp_clauses->default_sharing;
3626 }
3627 if (mask & GFC_OMP_MASK_DISTRIBUTE)
3628 {
3629 /* First the clauses that are unique to some constructs. */
3630 clausesa[GFC_OMP_SPLIT_DISTRIBUTE].dist_sched_kind
3631 = code->ext.omp_clauses->dist_sched_kind;
3632 clausesa[GFC_OMP_SPLIT_DISTRIBUTE].dist_chunk_size
3633 = code->ext.omp_clauses->dist_chunk_size;
3634 /* Duplicate collapse. */
3635 clausesa[GFC_OMP_SPLIT_DISTRIBUTE].collapse
3636 = code->ext.omp_clauses->collapse;
3637 }
3638 if (mask & GFC_OMP_MASK_PARALLEL)
3639 {
3640 /* First the clauses that are unique to some constructs. */
3641 clausesa[GFC_OMP_SPLIT_PARALLEL].lists[OMP_LIST_COPYIN]
3642 = code->ext.omp_clauses->lists[OMP_LIST_COPYIN];
3643 clausesa[GFC_OMP_SPLIT_PARALLEL].num_threads
3644 = code->ext.omp_clauses->num_threads;
3645 clausesa[GFC_OMP_SPLIT_PARALLEL].proc_bind
3646 = code->ext.omp_clauses->proc_bind;
3647 /* Shared and default clauses are allowed on parallel and teams. */
3648 clausesa[GFC_OMP_SPLIT_PARALLEL].lists[OMP_LIST_SHARED]
3649 = code->ext.omp_clauses->lists[OMP_LIST_SHARED];
3650 clausesa[GFC_OMP_SPLIT_PARALLEL].default_sharing
3651 = code->ext.omp_clauses->default_sharing;
3652 }
3653 if (mask & GFC_OMP_MASK_DO)
3654 {
3655 /* First the clauses that are unique to some constructs. */
3656 clausesa[GFC_OMP_SPLIT_DO].ordered
3657 = code->ext.omp_clauses->ordered;
3658 clausesa[GFC_OMP_SPLIT_DO].sched_kind
3659 = code->ext.omp_clauses->sched_kind;
3660 clausesa[GFC_OMP_SPLIT_DO].chunk_size
3661 = code->ext.omp_clauses->chunk_size;
3662 clausesa[GFC_OMP_SPLIT_DO].nowait
3663 = code->ext.omp_clauses->nowait;
3664 /* Duplicate collapse. */
3665 clausesa[GFC_OMP_SPLIT_DO].collapse
3666 = code->ext.omp_clauses->collapse;
3667 }
3668 if (mask & GFC_OMP_MASK_SIMD)
3669 {
3670 clausesa[GFC_OMP_SPLIT_SIMD].safelen_expr
3671 = code->ext.omp_clauses->safelen_expr;
3672 clausesa[GFC_OMP_SPLIT_SIMD].lists[OMP_LIST_LINEAR]
3673 = code->ext.omp_clauses->lists[OMP_LIST_LINEAR];
3674 clausesa[GFC_OMP_SPLIT_SIMD].lists[OMP_LIST_ALIGNED]
3675 = code->ext.omp_clauses->lists[OMP_LIST_ALIGNED];
3676 /* Duplicate collapse. */
3677 clausesa[GFC_OMP_SPLIT_SIMD].collapse
3678 = code->ext.omp_clauses->collapse;
3679 }
3680 /* Private clause is supported on all constructs but target,
3681 it is enough to put it on the innermost one. For
3682 !$ omp do put it on parallel though,
3683 as that's what we did for OpenMP 3.1. */
3684 clausesa[innermost == GFC_OMP_SPLIT_DO
3685 ? (int) GFC_OMP_SPLIT_PARALLEL
3686 : innermost].lists[OMP_LIST_PRIVATE]
3687 = code->ext.omp_clauses->lists[OMP_LIST_PRIVATE];
3688 /* Firstprivate clause is supported on all constructs but
3689 target and simd. Put it on the outermost of those and
3690 duplicate on parallel. */
3691 if (mask & GFC_OMP_MASK_TEAMS)
3692 clausesa[GFC_OMP_SPLIT_TEAMS].lists[OMP_LIST_FIRSTPRIVATE]
3693 = code->ext.omp_clauses->lists[OMP_LIST_FIRSTPRIVATE];
3694 else if (mask & GFC_OMP_MASK_DISTRIBUTE)
3695 clausesa[GFC_OMP_SPLIT_DISTRIBUTE].lists[OMP_LIST_FIRSTPRIVATE]
3696 = code->ext.omp_clauses->lists[OMP_LIST_FIRSTPRIVATE];
3697 if (mask & GFC_OMP_MASK_PARALLEL)
3698 clausesa[GFC_OMP_SPLIT_PARALLEL].lists[OMP_LIST_FIRSTPRIVATE]
3699 = code->ext.omp_clauses->lists[OMP_LIST_FIRSTPRIVATE];
3700 else if (mask & GFC_OMP_MASK_DO)
3701 clausesa[GFC_OMP_SPLIT_DO].lists[OMP_LIST_FIRSTPRIVATE]
3702 = code->ext.omp_clauses->lists[OMP_LIST_FIRSTPRIVATE];
3703 /* Lastprivate is allowed on do and simd. In
3704 parallel do{, simd} we actually want to put it on
3705 parallel rather than do. */
3706 if (mask & GFC_OMP_MASK_PARALLEL)
3707 clausesa[GFC_OMP_SPLIT_PARALLEL].lists[OMP_LIST_LASTPRIVATE]
3708 = code->ext.omp_clauses->lists[OMP_LIST_LASTPRIVATE];
3709 else if (mask & GFC_OMP_MASK_DO)
3710 clausesa[GFC_OMP_SPLIT_DO].lists[OMP_LIST_LASTPRIVATE]
3711 = code->ext.omp_clauses->lists[OMP_LIST_LASTPRIVATE];
3712 if (mask & GFC_OMP_MASK_SIMD)
3713 clausesa[GFC_OMP_SPLIT_SIMD].lists[OMP_LIST_LASTPRIVATE]
3714 = code->ext.omp_clauses->lists[OMP_LIST_LASTPRIVATE];
3715 /* Reduction is allowed on simd, do, parallel and teams.
3716 Duplicate it on all of them, but omit on do if
3717 parallel is present. */
3718 if (mask & GFC_OMP_MASK_TEAMS)
3719 clausesa[GFC_OMP_SPLIT_TEAMS].lists[OMP_LIST_REDUCTION]
3720 = code->ext.omp_clauses->lists[OMP_LIST_REDUCTION];
3721 if (mask & GFC_OMP_MASK_PARALLEL)
3722 clausesa[GFC_OMP_SPLIT_PARALLEL].lists[OMP_LIST_REDUCTION]
3723 = code->ext.omp_clauses->lists[OMP_LIST_REDUCTION];
3724 else if (mask & GFC_OMP_MASK_DO)
3725 clausesa[GFC_OMP_SPLIT_DO].lists[OMP_LIST_REDUCTION]
3726 = code->ext.omp_clauses->lists[OMP_LIST_REDUCTION];
3727 if (mask & GFC_OMP_MASK_SIMD)
3728 clausesa[GFC_OMP_SPLIT_SIMD].lists[OMP_LIST_REDUCTION]
3729 = code->ext.omp_clauses->lists[OMP_LIST_REDUCTION];
3730 /* FIXME: This is currently being discussed. */
3731 if (mask & GFC_OMP_MASK_PARALLEL)
3732 clausesa[GFC_OMP_SPLIT_PARALLEL].if_expr
3733 = code->ext.omp_clauses->if_expr;
3734 else
3735 clausesa[GFC_OMP_SPLIT_TARGET].if_expr
3736 = code->ext.omp_clauses->if_expr;
3737 }
3738 if ((mask & (GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO))
3739 == (GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO))
3740 clausesa[GFC_OMP_SPLIT_DO].nowait = true;
3741 }
3742
3743 static tree
3744 gfc_trans_omp_do_simd (gfc_code *code, stmtblock_t *pblock,
3745 gfc_omp_clauses *clausesa, tree omp_clauses)
3746 {
3747 stmtblock_t block;
3748 gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM];
3749 tree stmt, body, omp_do_clauses = NULL_TREE;
3750
3751 if (pblock == NULL)
3752 gfc_start_block (&block);
3753 else
3754 gfc_init_block (&block);
3755
3756 if (clausesa == NULL)
3757 {
3758 clausesa = clausesa_buf;
3759 gfc_split_omp_clauses (code, clausesa);
3760 }
3761 if (gfc_option.gfc_flag_openmp)
3762 omp_do_clauses
3763 = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_DO], code->loc);
3764 body = gfc_trans_omp_do (code, EXEC_OMP_SIMD, pblock ? pblock : &block,
3765 &clausesa[GFC_OMP_SPLIT_SIMD], omp_clauses);
3766 if (pblock == NULL)
3767 {
3768 if (TREE_CODE (body) != BIND_EXPR)
3769 body = build3_v (BIND_EXPR, NULL, body, poplevel (1, 0));
3770 else
3771 poplevel (0, 0);
3772 }
3773 else if (TREE_CODE (body) != BIND_EXPR)
3774 body = build3_v (BIND_EXPR, NULL, body, NULL_TREE);
3775 if (gfc_option.gfc_flag_openmp)
3776 {
3777 stmt = make_node (OMP_FOR);
3778 TREE_TYPE (stmt) = void_type_node;
3779 OMP_FOR_BODY (stmt) = body;
3780 OMP_FOR_CLAUSES (stmt) = omp_do_clauses;
3781 }
3782 else
3783 stmt = body;
3784 gfc_add_expr_to_block (&block, stmt);
3785 return gfc_finish_block (&block);
3786 }
3787
3788 static tree
3789 gfc_trans_omp_parallel_do (gfc_code *code, stmtblock_t *pblock,
3790 gfc_omp_clauses *clausesa)
3791 {
3792 stmtblock_t block, *new_pblock = pblock;
3793 gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM];
3794 tree stmt, omp_clauses = NULL_TREE;
3795
3796 if (pblock == NULL)
3797 gfc_start_block (&block);
3798 else
3799 gfc_init_block (&block);
3800
3801 if (clausesa == NULL)
3802 {
3803 clausesa = clausesa_buf;
3804 gfc_split_omp_clauses (code, clausesa);
3805 }
3806 omp_clauses
3807 = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_PARALLEL],
3808 code->loc);
3809 if (pblock == NULL)
3810 {
3811 if (!clausesa[GFC_OMP_SPLIT_DO].ordered
3812 && clausesa[GFC_OMP_SPLIT_DO].sched_kind != OMP_SCHED_STATIC)
3813 new_pblock = &block;
3814 else
3815 pushlevel ();
3816 }
3817 stmt = gfc_trans_omp_do (code, EXEC_OMP_DO, new_pblock,
3818 &clausesa[GFC_OMP_SPLIT_DO], omp_clauses);
3819 if (pblock == NULL)
3820 {
3821 if (TREE_CODE (stmt) != BIND_EXPR)
3822 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
3823 else
3824 poplevel (0, 0);
3825 }
3826 else if (TREE_CODE (stmt) != BIND_EXPR)
3827 stmt = build3_v (BIND_EXPR, NULL, stmt, NULL_TREE);
3828 stmt = build2_loc (input_location, OMP_PARALLEL, void_type_node, stmt,
3829 omp_clauses);
3830 OMP_PARALLEL_COMBINED (stmt) = 1;
3831 gfc_add_expr_to_block (&block, stmt);
3832 return gfc_finish_block (&block);
3833 }
3834
3835 static tree
3836 gfc_trans_omp_parallel_do_simd (gfc_code *code, stmtblock_t *pblock,
3837 gfc_omp_clauses *clausesa)
3838 {
3839 stmtblock_t block;
3840 gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM];
3841 tree stmt, omp_clauses = NULL_TREE;
3842
3843 if (pblock == NULL)
3844 gfc_start_block (&block);
3845 else
3846 gfc_init_block (&block);
3847
3848 if (clausesa == NULL)
3849 {
3850 clausesa = clausesa_buf;
3851 gfc_split_omp_clauses (code, clausesa);
3852 }
3853 if (gfc_option.gfc_flag_openmp)
3854 omp_clauses
3855 = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_PARALLEL],
3856 code->loc);
3857 if (pblock == NULL)
3858 pushlevel ();
3859 stmt = gfc_trans_omp_do_simd (code, pblock, clausesa, omp_clauses);
3860 if (pblock == NULL)
3861 {
3862 if (TREE_CODE (stmt) != BIND_EXPR)
3863 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
3864 else
3865 poplevel (0, 0);
3866 }
3867 else if (TREE_CODE (stmt) != BIND_EXPR)
3868 stmt = build3_v (BIND_EXPR, NULL, stmt, NULL_TREE);
3869 if (gfc_option.gfc_flag_openmp)
3870 {
3871 stmt = build2_loc (input_location, OMP_PARALLEL, void_type_node, stmt,
3872 omp_clauses);
3873 OMP_PARALLEL_COMBINED (stmt) = 1;
3874 }
3875 gfc_add_expr_to_block (&block, stmt);
3876 return gfc_finish_block (&block);
3877 }
3878
3879 static tree
3880 gfc_trans_omp_parallel_sections (gfc_code *code)
3881 {
3882 stmtblock_t block;
3883 gfc_omp_clauses section_clauses;
3884 tree stmt, omp_clauses;
3885
3886 memset (&section_clauses, 0, sizeof (section_clauses));
3887 section_clauses.nowait = true;
3888
3889 gfc_start_block (&block);
3890 omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
3891 code->loc);
3892 pushlevel ();
3893 stmt = gfc_trans_omp_sections (code, &section_clauses);
3894 if (TREE_CODE (stmt) != BIND_EXPR)
3895 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
3896 else
3897 poplevel (0, 0);
3898 stmt = build2_loc (input_location, OMP_PARALLEL, void_type_node, stmt,
3899 omp_clauses);
3900 OMP_PARALLEL_COMBINED (stmt) = 1;
3901 gfc_add_expr_to_block (&block, stmt);
3902 return gfc_finish_block (&block);
3903 }
3904
3905 static tree
3906 gfc_trans_omp_parallel_workshare (gfc_code *code)
3907 {
3908 stmtblock_t block;
3909 gfc_omp_clauses workshare_clauses;
3910 tree stmt, omp_clauses;
3911
3912 memset (&workshare_clauses, 0, sizeof (workshare_clauses));
3913 workshare_clauses.nowait = true;
3914
3915 gfc_start_block (&block);
3916 omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
3917 code->loc);
3918 pushlevel ();
3919 stmt = gfc_trans_omp_workshare (code, &workshare_clauses);
3920 if (TREE_CODE (stmt) != BIND_EXPR)
3921 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
3922 else
3923 poplevel (0, 0);
3924 stmt = build2_loc (input_location, OMP_PARALLEL, void_type_node, stmt,
3925 omp_clauses);
3926 OMP_PARALLEL_COMBINED (stmt) = 1;
3927 gfc_add_expr_to_block (&block, stmt);
3928 return gfc_finish_block (&block);
3929 }
3930
3931 static tree
3932 gfc_trans_omp_sections (gfc_code *code, gfc_omp_clauses *clauses)
3933 {
3934 stmtblock_t block, body;
3935 tree omp_clauses, stmt;
3936 bool has_lastprivate = clauses->lists[OMP_LIST_LASTPRIVATE] != NULL;
3937
3938 gfc_start_block (&block);
3939
3940 omp_clauses = gfc_trans_omp_clauses (&block, clauses, code->loc);
3941
3942 gfc_init_block (&body);
3943 for (code = code->block; code; code = code->block)
3944 {
3945 /* Last section is special because of lastprivate, so even if it
3946 is empty, chain it in. */
3947 stmt = gfc_trans_omp_code (code->next,
3948 has_lastprivate && code->block == NULL);
3949 if (! IS_EMPTY_STMT (stmt))
3950 {
3951 stmt = build1_v (OMP_SECTION, stmt);
3952 gfc_add_expr_to_block (&body, stmt);
3953 }
3954 }
3955 stmt = gfc_finish_block (&body);
3956
3957 stmt = build2_loc (input_location, OMP_SECTIONS, void_type_node, stmt,
3958 omp_clauses);
3959 gfc_add_expr_to_block (&block, stmt);
3960
3961 return gfc_finish_block (&block);
3962 }
3963
3964 static tree
3965 gfc_trans_omp_single (gfc_code *code, gfc_omp_clauses *clauses)
3966 {
3967 tree omp_clauses = gfc_trans_omp_clauses (NULL, clauses, code->loc);
3968 tree stmt = gfc_trans_omp_code (code->block->next, true);
3969 stmt = build2_loc (input_location, OMP_SINGLE, void_type_node, stmt,
3970 omp_clauses);
3971 return stmt;
3972 }
3973
3974 static tree
3975 gfc_trans_omp_task (gfc_code *code)
3976 {
3977 stmtblock_t block;
3978 tree stmt, omp_clauses;
3979
3980 gfc_start_block (&block);
3981 omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
3982 code->loc);
3983 stmt = gfc_trans_omp_code (code->block->next, true);
3984 stmt = build2_loc (input_location, OMP_TASK, void_type_node, stmt,
3985 omp_clauses);
3986 gfc_add_expr_to_block (&block, stmt);
3987 return gfc_finish_block (&block);
3988 }
3989
3990 static tree
3991 gfc_trans_omp_taskgroup (gfc_code *code)
3992 {
3993 tree stmt = gfc_trans_code (code->block->next);
3994 return build1_loc (input_location, OMP_TASKGROUP, void_type_node, stmt);
3995 }
3996
3997 static tree
3998 gfc_trans_omp_taskwait (void)
3999 {
4000 tree decl = builtin_decl_explicit (BUILT_IN_GOMP_TASKWAIT);
4001 return build_call_expr_loc (input_location, decl, 0);
4002 }
4003
4004 static tree
4005 gfc_trans_omp_taskyield (void)
4006 {
4007 tree decl = builtin_decl_explicit (BUILT_IN_GOMP_TASKYIELD);
4008 return build_call_expr_loc (input_location, decl, 0);
4009 }
4010
4011 static tree
4012 gfc_trans_omp_distribute (gfc_code *code, gfc_omp_clauses *clausesa)
4013 {
4014 stmtblock_t block;
4015 gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM];
4016 tree stmt, omp_clauses = NULL_TREE;
4017
4018 gfc_start_block (&block);
4019 if (clausesa == NULL)
4020 {
4021 clausesa = clausesa_buf;
4022 gfc_split_omp_clauses (code, clausesa);
4023 }
4024 if (gfc_option.gfc_flag_openmp)
4025 omp_clauses
4026 = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_DISTRIBUTE],
4027 code->loc);
4028 switch (code->op)
4029 {
4030 case EXEC_OMP_DISTRIBUTE:
4031 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
4032 case EXEC_OMP_TEAMS_DISTRIBUTE:
4033 /* This is handled in gfc_trans_omp_do. */
4034 gcc_unreachable ();
4035 break;
4036 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
4037 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
4038 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
4039 stmt = gfc_trans_omp_parallel_do (code, &block, clausesa);
4040 if (TREE_CODE (stmt) != BIND_EXPR)
4041 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
4042 else
4043 poplevel (0, 0);
4044 break;
4045 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
4046 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
4047 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
4048 stmt = gfc_trans_omp_parallel_do_simd (code, &block, clausesa);
4049 if (TREE_CODE (stmt) != BIND_EXPR)
4050 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
4051 else
4052 poplevel (0, 0);
4053 break;
4054 case EXEC_OMP_DISTRIBUTE_SIMD:
4055 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
4056 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
4057 stmt = gfc_trans_omp_do (code, EXEC_OMP_SIMD, &block,
4058 &clausesa[GFC_OMP_SPLIT_SIMD], NULL_TREE);
4059 if (TREE_CODE (stmt) != BIND_EXPR)
4060 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
4061 else
4062 poplevel (0, 0);
4063 break;
4064 default:
4065 gcc_unreachable ();
4066 }
4067 if (gfc_option.gfc_flag_openmp)
4068 {
4069 tree distribute = make_node (OMP_DISTRIBUTE);
4070 TREE_TYPE (distribute) = void_type_node;
4071 OMP_FOR_BODY (distribute) = stmt;
4072 OMP_FOR_CLAUSES (distribute) = omp_clauses;
4073 stmt = distribute;
4074 }
4075 gfc_add_expr_to_block (&block, stmt);
4076 return gfc_finish_block (&block);
4077 }
4078
4079 static tree
4080 gfc_trans_omp_teams (gfc_code *code, gfc_omp_clauses *clausesa)
4081 {
4082 stmtblock_t block;
4083 gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM];
4084 tree stmt, omp_clauses = NULL_TREE;
4085
4086 gfc_start_block (&block);
4087 if (clausesa == NULL)
4088 {
4089 clausesa = clausesa_buf;
4090 gfc_split_omp_clauses (code, clausesa);
4091 }
4092 if (gfc_option.gfc_flag_openmp)
4093 omp_clauses
4094 = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_TEAMS],
4095 code->loc);
4096 switch (code->op)
4097 {
4098 case EXEC_OMP_TARGET_TEAMS:
4099 case EXEC_OMP_TEAMS:
4100 stmt = gfc_trans_omp_code (code->block->next, true);
4101 break;
4102 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
4103 case EXEC_OMP_TEAMS_DISTRIBUTE:
4104 stmt = gfc_trans_omp_do (code, EXEC_OMP_DISTRIBUTE, NULL,
4105 &clausesa[GFC_OMP_SPLIT_DISTRIBUTE],
4106 NULL);
4107 break;
4108 default:
4109 stmt = gfc_trans_omp_distribute (code, clausesa);
4110 break;
4111 }
4112 stmt = build2_loc (input_location, OMP_TEAMS, void_type_node, stmt,
4113 omp_clauses);
4114 gfc_add_expr_to_block (&block, stmt);
4115 return gfc_finish_block (&block);
4116 }
4117
4118 static tree
4119 gfc_trans_omp_target (gfc_code *code)
4120 {
4121 stmtblock_t block;
4122 gfc_omp_clauses clausesa[GFC_OMP_SPLIT_NUM];
4123 tree stmt, omp_clauses = NULL_TREE;
4124
4125 gfc_start_block (&block);
4126 gfc_split_omp_clauses (code, clausesa);
4127 if (gfc_option.gfc_flag_openmp)
4128 omp_clauses
4129 = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_TARGET],
4130 code->loc);
4131 if (code->op == EXEC_OMP_TARGET)
4132 stmt = gfc_trans_omp_code (code->block->next, true);
4133 else
4134 stmt = gfc_trans_omp_teams (code, clausesa);
4135 if (TREE_CODE (stmt) != BIND_EXPR)
4136 stmt = build3_v (BIND_EXPR, NULL, stmt, NULL_TREE);
4137 if (gfc_option.gfc_flag_openmp)
4138 stmt = build2_loc (input_location, OMP_TARGET, void_type_node, stmt,
4139 omp_clauses);
4140 gfc_add_expr_to_block (&block, stmt);
4141 return gfc_finish_block (&block);
4142 }
4143
4144 static tree
4145 gfc_trans_omp_target_data (gfc_code *code)
4146 {
4147 stmtblock_t block;
4148 tree stmt, omp_clauses;
4149
4150 gfc_start_block (&block);
4151 omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
4152 code->loc);
4153 stmt = gfc_trans_omp_code (code->block->next, true);
4154 stmt = build2_loc (input_location, OMP_TARGET_DATA, void_type_node, stmt,
4155 omp_clauses);
4156 gfc_add_expr_to_block (&block, stmt);
4157 return gfc_finish_block (&block);
4158 }
4159
4160 static tree
4161 gfc_trans_omp_target_update (gfc_code *code)
4162 {
4163 stmtblock_t block;
4164 tree stmt, omp_clauses;
4165
4166 gfc_start_block (&block);
4167 omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
4168 code->loc);
4169 stmt = build1_loc (input_location, OMP_TARGET_UPDATE, void_type_node,
4170 omp_clauses);
4171 gfc_add_expr_to_block (&block, stmt);
4172 return gfc_finish_block (&block);
4173 }
4174
4175 static tree
4176 gfc_trans_omp_workshare (gfc_code *code, gfc_omp_clauses *clauses)
4177 {
4178 tree res, tmp, stmt;
4179 stmtblock_t block, *pblock = NULL;
4180 stmtblock_t singleblock;
4181 int saved_ompws_flags;
4182 bool singleblock_in_progress = false;
4183 /* True if previous gfc_code in workshare construct is not workshared. */
4184 bool prev_singleunit;
4185
4186 code = code->block->next;
4187
4188 pushlevel ();
4189
4190 gfc_start_block (&block);
4191 pblock = &block;
4192
4193 ompws_flags = OMPWS_WORKSHARE_FLAG;
4194 prev_singleunit = false;
4195
4196 /* Translate statements one by one to trees until we reach
4197 the end of the workshare construct. Adjacent gfc_codes that
4198 are a single unit of work are clustered and encapsulated in a
4199 single OMP_SINGLE construct. */
4200 for (; code; code = code->next)
4201 {
4202 if (code->here != 0)
4203 {
4204 res = gfc_trans_label_here (code);
4205 gfc_add_expr_to_block (pblock, res);
4206 }
4207
4208 /* No dependence analysis, use for clauses with wait.
4209 If this is the last gfc_code, use default omp_clauses. */
4210 if (code->next == NULL && clauses->nowait)
4211 ompws_flags |= OMPWS_NOWAIT;
4212
4213 /* By default, every gfc_code is a single unit of work. */
4214 ompws_flags |= OMPWS_CURR_SINGLEUNIT;
4215 ompws_flags &= ~OMPWS_SCALARIZER_WS;
4216
4217 switch (code->op)
4218 {
4219 case EXEC_NOP:
4220 res = NULL_TREE;
4221 break;
4222
4223 case EXEC_ASSIGN:
4224 res = gfc_trans_assign (code);
4225 break;
4226
4227 case EXEC_POINTER_ASSIGN:
4228 res = gfc_trans_pointer_assign (code);
4229 break;
4230
4231 case EXEC_INIT_ASSIGN:
4232 res = gfc_trans_init_assign (code);
4233 break;
4234
4235 case EXEC_FORALL:
4236 res = gfc_trans_forall (code);
4237 break;
4238
4239 case EXEC_WHERE:
4240 res = gfc_trans_where (code);
4241 break;
4242
4243 case EXEC_OMP_ATOMIC:
4244 res = gfc_trans_omp_directive (code);
4245 break;
4246
4247 case EXEC_OMP_PARALLEL:
4248 case EXEC_OMP_PARALLEL_DO:
4249 case EXEC_OMP_PARALLEL_SECTIONS:
4250 case EXEC_OMP_PARALLEL_WORKSHARE:
4251 case EXEC_OMP_CRITICAL:
4252 saved_ompws_flags = ompws_flags;
4253 ompws_flags = 0;
4254 res = gfc_trans_omp_directive (code);
4255 ompws_flags = saved_ompws_flags;
4256 break;
4257
4258 default:
4259 gfc_internal_error ("gfc_trans_omp_workshare(): Bad statement code");
4260 }
4261
4262 gfc_set_backend_locus (&code->loc);
4263
4264 if (res != NULL_TREE && ! IS_EMPTY_STMT (res))
4265 {
4266 if (prev_singleunit)
4267 {
4268 if (ompws_flags & OMPWS_CURR_SINGLEUNIT)
4269 /* Add current gfc_code to single block. */
4270 gfc_add_expr_to_block (&singleblock, res);
4271 else
4272 {
4273 /* Finish single block and add it to pblock. */
4274 tmp = gfc_finish_block (&singleblock);
4275 tmp = build2_loc (input_location, OMP_SINGLE,
4276 void_type_node, tmp, NULL_TREE);
4277 gfc_add_expr_to_block (pblock, tmp);
4278 /* Add current gfc_code to pblock. */
4279 gfc_add_expr_to_block (pblock, res);
4280 singleblock_in_progress = false;
4281 }
4282 }
4283 else
4284 {
4285 if (ompws_flags & OMPWS_CURR_SINGLEUNIT)
4286 {
4287 /* Start single block. */
4288 gfc_init_block (&singleblock);
4289 gfc_add_expr_to_block (&singleblock, res);
4290 singleblock_in_progress = true;
4291 }
4292 else
4293 /* Add the new statement to the block. */
4294 gfc_add_expr_to_block (pblock, res);
4295 }
4296 prev_singleunit = (ompws_flags & OMPWS_CURR_SINGLEUNIT) != 0;
4297 }
4298 }
4299
4300 /* Finish remaining SINGLE block, if we were in the middle of one. */
4301 if (singleblock_in_progress)
4302 {
4303 /* Finish single block and add it to pblock. */
4304 tmp = gfc_finish_block (&singleblock);
4305 tmp = build2_loc (input_location, OMP_SINGLE, void_type_node, tmp,
4306 clauses->nowait
4307 ? build_omp_clause (input_location, OMP_CLAUSE_NOWAIT)
4308 : NULL_TREE);
4309 gfc_add_expr_to_block (pblock, tmp);
4310 }
4311
4312 stmt = gfc_finish_block (pblock);
4313 if (TREE_CODE (stmt) != BIND_EXPR)
4314 {
4315 if (!IS_EMPTY_STMT (stmt))
4316 {
4317 tree bindblock = poplevel (1, 0);
4318 stmt = build3_v (BIND_EXPR, NULL, stmt, bindblock);
4319 }
4320 else
4321 poplevel (0, 0);
4322 }
4323 else
4324 poplevel (0, 0);
4325
4326 if (IS_EMPTY_STMT (stmt) && !clauses->nowait)
4327 stmt = gfc_trans_omp_barrier ();
4328
4329 ompws_flags = 0;
4330 return stmt;
4331 }
4332
4333 tree
4334 gfc_trans_oacc_declare (stmtblock_t *block, gfc_namespace *ns)
4335 {
4336 tree oacc_clauses;
4337 oacc_clauses = gfc_trans_omp_clauses (block, ns->oacc_declare_clauses,
4338 ns->oacc_declare_clauses->loc);
4339 return build1_loc (ns->oacc_declare_clauses->loc.lb->location,
4340 OACC_DECLARE, void_type_node, oacc_clauses);
4341 }
4342
4343 tree
4344 gfc_trans_oacc_directive (gfc_code *code)
4345 {
4346 switch (code->op)
4347 {
4348 case EXEC_OACC_PARALLEL_LOOP:
4349 case EXEC_OACC_KERNELS_LOOP:
4350 return gfc_trans_oacc_combined_directive (code);
4351 case EXEC_OACC_PARALLEL:
4352 case EXEC_OACC_KERNELS:
4353 case EXEC_OACC_DATA:
4354 case EXEC_OACC_HOST_DATA:
4355 return gfc_trans_oacc_construct (code);
4356 case EXEC_OACC_LOOP:
4357 return gfc_trans_omp_do (code, code->op, NULL, code->ext.omp_clauses,
4358 NULL);
4359 case EXEC_OACC_UPDATE:
4360 case EXEC_OACC_CACHE:
4361 case EXEC_OACC_ENTER_DATA:
4362 case EXEC_OACC_EXIT_DATA:
4363 return gfc_trans_oacc_executable_directive (code);
4364 case EXEC_OACC_WAIT:
4365 return gfc_trans_oacc_wait_directive (code);
4366 default:
4367 gcc_unreachable ();
4368 }
4369 }
4370
4371 tree
4372 gfc_trans_omp_directive (gfc_code *code)
4373 {
4374 switch (code->op)
4375 {
4376 case EXEC_OMP_ATOMIC:
4377 return gfc_trans_omp_atomic (code);
4378 case EXEC_OMP_BARRIER:
4379 return gfc_trans_omp_barrier ();
4380 case EXEC_OMP_CANCEL:
4381 return gfc_trans_omp_cancel (code);
4382 case EXEC_OMP_CANCELLATION_POINT:
4383 return gfc_trans_omp_cancellation_point (code);
4384 case EXEC_OMP_CRITICAL:
4385 return gfc_trans_omp_critical (code);
4386 case EXEC_OMP_DISTRIBUTE:
4387 case EXEC_OMP_DO:
4388 case EXEC_OMP_SIMD:
4389 return gfc_trans_omp_do (code, code->op, NULL, code->ext.omp_clauses,
4390 NULL);
4391 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
4392 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
4393 case EXEC_OMP_DISTRIBUTE_SIMD:
4394 return gfc_trans_omp_distribute (code, NULL);
4395 case EXEC_OMP_DO_SIMD:
4396 return gfc_trans_omp_do_simd (code, NULL, NULL, NULL_TREE);
4397 case EXEC_OMP_FLUSH:
4398 return gfc_trans_omp_flush ();
4399 case EXEC_OMP_MASTER:
4400 return gfc_trans_omp_master (code);
4401 case EXEC_OMP_ORDERED:
4402 return gfc_trans_omp_ordered (code);
4403 case EXEC_OMP_PARALLEL:
4404 return gfc_trans_omp_parallel (code);
4405 case EXEC_OMP_PARALLEL_DO:
4406 return gfc_trans_omp_parallel_do (code, NULL, NULL);
4407 case EXEC_OMP_PARALLEL_DO_SIMD:
4408 return gfc_trans_omp_parallel_do_simd (code, NULL, NULL);
4409 case EXEC_OMP_PARALLEL_SECTIONS:
4410 return gfc_trans_omp_parallel_sections (code);
4411 case EXEC_OMP_PARALLEL_WORKSHARE:
4412 return gfc_trans_omp_parallel_workshare (code);
4413 case EXEC_OMP_SECTIONS:
4414 return gfc_trans_omp_sections (code, code->ext.omp_clauses);
4415 case EXEC_OMP_SINGLE:
4416 return gfc_trans_omp_single (code, code->ext.omp_clauses);
4417 case EXEC_OMP_TARGET:
4418 case EXEC_OMP_TARGET_TEAMS:
4419 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
4420 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
4421 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
4422 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
4423 return gfc_trans_omp_target (code);
4424 case EXEC_OMP_TARGET_DATA:
4425 return gfc_trans_omp_target_data (code);
4426 case EXEC_OMP_TARGET_UPDATE:
4427 return gfc_trans_omp_target_update (code);
4428 case EXEC_OMP_TASK:
4429 return gfc_trans_omp_task (code);
4430 case EXEC_OMP_TASKGROUP:
4431 return gfc_trans_omp_taskgroup (code);
4432 case EXEC_OMP_TASKWAIT:
4433 return gfc_trans_omp_taskwait ();
4434 case EXEC_OMP_TASKYIELD:
4435 return gfc_trans_omp_taskyield ();
4436 case EXEC_OMP_TEAMS:
4437 case EXEC_OMP_TEAMS_DISTRIBUTE:
4438 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
4439 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
4440 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
4441 return gfc_trans_omp_teams (code, NULL);
4442 case EXEC_OMP_WORKSHARE:
4443 return gfc_trans_omp_workshare (code, code->ext.omp_clauses);
4444 default:
4445 gcc_unreachable ();
4446 }
4447 }
4448
4449 void
4450 gfc_trans_omp_declare_simd (gfc_namespace *ns)
4451 {
4452 if (ns->entries)
4453 return;
4454
4455 gfc_omp_declare_simd *ods;
4456 for (ods = ns->omp_declare_simd; ods; ods = ods->next)
4457 {
4458 tree c = gfc_trans_omp_clauses (NULL, ods->clauses, ods->where, true);
4459 tree fndecl = ns->proc_name->backend_decl;
4460 if (c != NULL_TREE)
4461 c = tree_cons (NULL_TREE, c, NULL_TREE);
4462 c = build_tree_list (get_identifier ("omp declare simd"), c);
4463 TREE_CHAIN (c) = DECL_ATTRIBUTES (fndecl);
4464 DECL_ATTRIBUTES (fndecl) = c;
4465 }
4466 }
Mirror of the offical gcc git repository hosted at gcc.gnu.org