1 /* OpenMP directive translation -- generate GCC trees from gfc_code.
2 Copyright (C) 2005-2018 Free Software Foundation, Inc.
3 Contributed by Jakub Jelinek <jakub@redhat.com>
5 This file is part of GCC.
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
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
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/>. */
24 #include "coretypes.h"
28 #include "gimple-expr.h"
30 #include "stringpool.h"
31 #include "fold-const.h"
32 #include "gimplify.h" /* For create_tmp_var_raw. */
33 #include "trans-stmt.h"
34 #include "trans-types.h"
35 #include "trans-array.h"
36 #include "trans-const.h"
38 #include "gomp-constants.h"
39 #include "omp-general.h"
42 #define GCC_DIAG_STYLE __gcc_tdiag__
43 #include "diagnostic-core.h"
45 #define GCC_DIAG_STYLE __gcc_gfc__
49 /* True if OpenMP should privatize what this DECL points to rather
50 than the DECL itself. */
53 gfc_omp_privatize_by_reference (const_tree decl
)
55 tree type
= TREE_TYPE (decl
);
57 if (TREE_CODE (type
) == REFERENCE_TYPE
58 && (!DECL_ARTIFICIAL (decl
) || TREE_CODE (decl
) == PARM_DECL
))
61 if (TREE_CODE (type
) == POINTER_TYPE
)
63 /* Array POINTER/ALLOCATABLE have aggregate types, all user variables
64 that have POINTER_TYPE type and aren't scalar pointers, scalar
65 allocatables, Cray pointees or C pointers are supposed to be
66 privatized by reference. */
67 if (GFC_DECL_GET_SCALAR_POINTER (decl
)
68 || GFC_DECL_GET_SCALAR_ALLOCATABLE (decl
)
69 || GFC_DECL_CRAY_POINTEE (decl
)
70 || GFC_DECL_ASSOCIATE_VAR_P (decl
)
71 || VOID_TYPE_P (TREE_TYPE (TREE_TYPE (decl
))))
74 if (!DECL_ARTIFICIAL (decl
)
75 && TREE_CODE (TREE_TYPE (type
)) != FUNCTION_TYPE
)
78 /* Some arrays are expanded as DECL_ARTIFICIAL pointers
80 if (DECL_LANG_SPECIFIC (decl
)
81 && GFC_DECL_SAVED_DESCRIPTOR (decl
))
88 /* True if OpenMP sharing attribute of DECL is predetermined. */
90 enum omp_clause_default_kind
91 gfc_omp_predetermined_sharing (tree decl
)
93 /* Associate names preserve the association established during ASSOCIATE.
94 As they are implemented either as pointers to the selector or array
95 descriptor and shouldn't really change in the ASSOCIATE region,
96 this decl can be either shared or firstprivate. If it is a pointer,
97 use firstprivate, as it is cheaper that way, otherwise make it shared. */
98 if (GFC_DECL_ASSOCIATE_VAR_P (decl
))
100 if (TREE_CODE (TREE_TYPE (decl
)) == POINTER_TYPE
)
101 return OMP_CLAUSE_DEFAULT_FIRSTPRIVATE
;
103 return OMP_CLAUSE_DEFAULT_SHARED
;
106 if (DECL_ARTIFICIAL (decl
)
107 && ! GFC_DECL_RESULT (decl
)
108 && ! (DECL_LANG_SPECIFIC (decl
)
109 && GFC_DECL_SAVED_DESCRIPTOR (decl
)))
110 return OMP_CLAUSE_DEFAULT_SHARED
;
112 /* Cray pointees shouldn't be listed in any clauses and should be
113 gimplified to dereference of the corresponding Cray pointer.
114 Make them all private, so that they are emitted in the debug
116 if (GFC_DECL_CRAY_POINTEE (decl
))
117 return OMP_CLAUSE_DEFAULT_PRIVATE
;
119 /* Assumed-size arrays are predetermined shared. */
120 if (TREE_CODE (decl
) == PARM_DECL
121 && GFC_ARRAY_TYPE_P (TREE_TYPE (decl
))
122 && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (decl
)) == GFC_ARRAY_UNKNOWN
123 && GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (decl
),
124 GFC_TYPE_ARRAY_RANK (TREE_TYPE (decl
)) - 1)
126 return OMP_CLAUSE_DEFAULT_SHARED
;
128 /* Dummy procedures aren't considered variables by OpenMP, thus are
129 disallowed in OpenMP clauses. They are represented as PARM_DECLs
130 in the middle-end, so return OMP_CLAUSE_DEFAULT_FIRSTPRIVATE here
131 to avoid complaining about their uses with default(none). */
132 if (TREE_CODE (decl
) == PARM_DECL
133 && TREE_CODE (TREE_TYPE (decl
)) == POINTER_TYPE
134 && TREE_CODE (TREE_TYPE (TREE_TYPE (decl
))) == FUNCTION_TYPE
)
135 return OMP_CLAUSE_DEFAULT_FIRSTPRIVATE
;
137 /* COMMON and EQUIVALENCE decls are shared. They
138 are only referenced through DECL_VALUE_EXPR of the variables
139 contained in them. If those are privatized, they will not be
140 gimplified to the COMMON or EQUIVALENCE decls. */
141 if (GFC_DECL_COMMON_OR_EQUIV (decl
) && ! DECL_HAS_VALUE_EXPR_P (decl
))
142 return OMP_CLAUSE_DEFAULT_SHARED
;
144 if (GFC_DECL_RESULT (decl
) && ! DECL_HAS_VALUE_EXPR_P (decl
))
145 return OMP_CLAUSE_DEFAULT_SHARED
;
147 /* These are either array or derived parameters, or vtables.
148 In the former cases, the OpenMP standard doesn't consider them to be
149 variables at all (they can't be redefined), but they can nevertheless appear
150 in parallel/task regions and for default(none) purposes treat them as shared.
151 For vtables likely the same handling is desirable. */
152 if (VAR_P (decl
) && TREE_READONLY (decl
) && TREE_STATIC (decl
))
153 return OMP_CLAUSE_DEFAULT_SHARED
;
155 return OMP_CLAUSE_DEFAULT_UNSPECIFIED
;
158 /* Return decl that should be used when reporting DEFAULT(NONE)
162 gfc_omp_report_decl (tree decl
)
164 if (DECL_ARTIFICIAL (decl
)
165 && DECL_LANG_SPECIFIC (decl
)
166 && GFC_DECL_SAVED_DESCRIPTOR (decl
))
167 return GFC_DECL_SAVED_DESCRIPTOR (decl
);
172 /* Return true if TYPE has any allocatable components. */
175 gfc_has_alloc_comps (tree type
, tree decl
)
179 if (POINTER_TYPE_P (type
))
181 if (GFC_DECL_GET_SCALAR_ALLOCATABLE (decl
))
182 type
= TREE_TYPE (type
);
183 else if (GFC_DECL_GET_SCALAR_POINTER (decl
))
187 if (GFC_DESCRIPTOR_TYPE_P (type
) || GFC_ARRAY_TYPE_P (type
))
188 type
= gfc_get_element_type (type
);
190 if (TREE_CODE (type
) != RECORD_TYPE
)
193 for (field
= TYPE_FIELDS (type
); field
; field
= DECL_CHAIN (field
))
195 ftype
= TREE_TYPE (field
);
196 if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field
))
198 if (GFC_DESCRIPTOR_TYPE_P (ftype
)
199 && GFC_TYPE_ARRAY_AKIND (ftype
) == GFC_ARRAY_ALLOCATABLE
)
201 if (gfc_has_alloc_comps (ftype
, field
))
207 /* Return true if DECL in private clause needs
208 OMP_CLAUSE_PRIVATE_OUTER_REF on the private clause. */
210 gfc_omp_private_outer_ref (tree decl
)
212 tree type
= TREE_TYPE (decl
);
214 if (gfc_omp_privatize_by_reference (decl
))
215 type
= TREE_TYPE (type
);
217 if (GFC_DESCRIPTOR_TYPE_P (type
)
218 && GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ALLOCATABLE
)
221 if (GFC_DECL_GET_SCALAR_ALLOCATABLE (decl
))
224 if (gfc_has_alloc_comps (type
, decl
))
230 /* Callback for gfc_omp_unshare_expr. */
233 gfc_omp_unshare_expr_r (tree
*tp
, int *walk_subtrees
, void *)
236 enum tree_code code
= TREE_CODE (t
);
238 /* Stop at types, decls, constants like copy_tree_r. */
239 if (TREE_CODE_CLASS (code
) == tcc_type
240 || TREE_CODE_CLASS (code
) == tcc_declaration
241 || TREE_CODE_CLASS (code
) == tcc_constant
244 else if (handled_component_p (t
)
245 || TREE_CODE (t
) == MEM_REF
)
247 *tp
= unshare_expr (t
);
254 /* Unshare in expr anything that the FE which normally doesn't
255 care much about tree sharing (because during gimplification
256 everything is unshared) could cause problems with tree sharing
257 at omp-low.c time. */
260 gfc_omp_unshare_expr (tree expr
)
262 walk_tree (&expr
, gfc_omp_unshare_expr_r
, NULL
, NULL
);
266 enum walk_alloc_comps
268 WALK_ALLOC_COMPS_DTOR
,
269 WALK_ALLOC_COMPS_DEFAULT_CTOR
,
270 WALK_ALLOC_COMPS_COPY_CTOR
273 /* Handle allocatable components in OpenMP clauses. */
276 gfc_walk_alloc_comps (tree decl
, tree dest
, tree var
,
277 enum walk_alloc_comps kind
)
279 stmtblock_t block
, tmpblock
;
280 tree type
= TREE_TYPE (decl
), then_b
, tem
, field
;
281 gfc_init_block (&block
);
283 if (GFC_ARRAY_TYPE_P (type
) || GFC_DESCRIPTOR_TYPE_P (type
))
285 if (GFC_DESCRIPTOR_TYPE_P (type
))
287 gfc_init_block (&tmpblock
);
288 tem
= gfc_full_array_size (&tmpblock
, decl
,
289 GFC_TYPE_ARRAY_RANK (type
));
290 then_b
= gfc_finish_block (&tmpblock
);
291 gfc_add_expr_to_block (&block
, gfc_omp_unshare_expr (then_b
));
292 tem
= gfc_omp_unshare_expr (tem
);
293 tem
= fold_build2_loc (input_location
, MINUS_EXPR
,
294 gfc_array_index_type
, tem
,
299 if (!TYPE_DOMAIN (type
)
300 || TYPE_MAX_VALUE (TYPE_DOMAIN (type
)) == NULL_TREE
301 || TYPE_MIN_VALUE (TYPE_DOMAIN (type
)) == error_mark_node
302 || TYPE_MAX_VALUE (TYPE_DOMAIN (type
)) == error_mark_node
)
304 tem
= fold_build2 (EXACT_DIV_EXPR
, sizetype
,
305 TYPE_SIZE_UNIT (type
),
306 TYPE_SIZE_UNIT (TREE_TYPE (type
)));
307 tem
= size_binop (MINUS_EXPR
, tem
, size_one_node
);
310 tem
= array_type_nelts (type
);
311 tem
= fold_convert (gfc_array_index_type
, tem
);
314 tree nelems
= gfc_evaluate_now (tem
, &block
);
315 tree index
= gfc_create_var (gfc_array_index_type
, "S");
317 gfc_init_block (&tmpblock
);
318 tem
= gfc_conv_array_data (decl
);
319 tree declvar
= build_fold_indirect_ref_loc (input_location
, tem
);
320 tree declvref
= gfc_build_array_ref (declvar
, index
, NULL
);
321 tree destvar
, destvref
= NULL_TREE
;
324 tem
= gfc_conv_array_data (dest
);
325 destvar
= build_fold_indirect_ref_loc (input_location
, tem
);
326 destvref
= gfc_build_array_ref (destvar
, index
, NULL
);
328 gfc_add_expr_to_block (&tmpblock
,
329 gfc_walk_alloc_comps (declvref
, destvref
,
333 gfc_init_loopinfo (&loop
);
335 loop
.from
[0] = gfc_index_zero_node
;
336 loop
.loopvar
[0] = index
;
338 gfc_trans_scalarizing_loops (&loop
, &tmpblock
);
339 gfc_add_block_to_block (&block
, &loop
.pre
);
340 return gfc_finish_block (&block
);
342 else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (var
))
344 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
346 dest
= build_fold_indirect_ref_loc (input_location
, dest
);
347 type
= TREE_TYPE (decl
);
350 gcc_assert (TREE_CODE (type
) == RECORD_TYPE
);
351 for (field
= TYPE_FIELDS (type
); field
; field
= DECL_CHAIN (field
))
353 tree ftype
= TREE_TYPE (field
);
354 tree declf
, destf
= NULL_TREE
;
355 bool has_alloc_comps
= gfc_has_alloc_comps (ftype
, field
);
356 if ((!GFC_DESCRIPTOR_TYPE_P (ftype
)
357 || GFC_TYPE_ARRAY_AKIND (ftype
) != GFC_ARRAY_ALLOCATABLE
)
358 && !GFC_DECL_GET_SCALAR_ALLOCATABLE (field
)
361 declf
= fold_build3_loc (input_location
, COMPONENT_REF
, ftype
,
362 decl
, field
, NULL_TREE
);
364 destf
= fold_build3_loc (input_location
, COMPONENT_REF
, ftype
,
365 dest
, field
, NULL_TREE
);
370 case WALK_ALLOC_COMPS_DTOR
:
372 case WALK_ALLOC_COMPS_DEFAULT_CTOR
:
373 if (GFC_DESCRIPTOR_TYPE_P (ftype
)
374 && GFC_TYPE_ARRAY_AKIND (ftype
) == GFC_ARRAY_ALLOCATABLE
)
376 gfc_add_modify (&block
, unshare_expr (destf
),
377 unshare_expr (declf
));
378 tem
= gfc_duplicate_allocatable_nocopy
379 (destf
, declf
, ftype
,
380 GFC_TYPE_ARRAY_RANK (ftype
));
382 else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field
))
383 tem
= gfc_duplicate_allocatable_nocopy (destf
, declf
, ftype
, 0);
385 case WALK_ALLOC_COMPS_COPY_CTOR
:
386 if (GFC_DESCRIPTOR_TYPE_P (ftype
)
387 && GFC_TYPE_ARRAY_AKIND (ftype
) == GFC_ARRAY_ALLOCATABLE
)
388 tem
= gfc_duplicate_allocatable (destf
, declf
, ftype
,
389 GFC_TYPE_ARRAY_RANK (ftype
),
391 else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field
))
392 tem
= gfc_duplicate_allocatable (destf
, declf
, ftype
, 0,
397 gfc_add_expr_to_block (&block
, gfc_omp_unshare_expr (tem
));
400 gfc_init_block (&tmpblock
);
401 gfc_add_expr_to_block (&tmpblock
,
402 gfc_walk_alloc_comps (declf
, destf
,
404 then_b
= gfc_finish_block (&tmpblock
);
405 if (GFC_DESCRIPTOR_TYPE_P (ftype
)
406 && GFC_TYPE_ARRAY_AKIND (ftype
) == GFC_ARRAY_ALLOCATABLE
)
407 tem
= gfc_conv_descriptor_data_get (unshare_expr (declf
));
408 else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field
))
409 tem
= unshare_expr (declf
);
414 tem
= fold_convert (pvoid_type_node
, tem
);
415 tem
= fold_build2_loc (input_location
, NE_EXPR
,
416 logical_type_node
, tem
,
418 then_b
= build3_loc (input_location
, COND_EXPR
, void_type_node
,
420 build_empty_stmt (input_location
));
422 gfc_add_expr_to_block (&block
, then_b
);
424 if (kind
== WALK_ALLOC_COMPS_DTOR
)
426 if (GFC_DESCRIPTOR_TYPE_P (ftype
)
427 && GFC_TYPE_ARRAY_AKIND (ftype
) == GFC_ARRAY_ALLOCATABLE
)
429 tem
= gfc_conv_descriptor_data_get (unshare_expr (declf
));
430 tem
= gfc_deallocate_with_status (tem
, NULL_TREE
, NULL_TREE
,
431 NULL_TREE
, NULL_TREE
, true,
433 GFC_CAF_COARRAY_NOCOARRAY
);
434 gfc_add_expr_to_block (&block
, gfc_omp_unshare_expr (tem
));
436 else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field
))
438 tem
= gfc_call_free (unshare_expr (declf
));
439 gfc_add_expr_to_block (&block
, gfc_omp_unshare_expr (tem
));
444 return gfc_finish_block (&block
);
447 /* Return code to initialize DECL with its default constructor, or
448 NULL if there's nothing to do. */
451 gfc_omp_clause_default_ctor (tree clause
, tree decl
, tree outer
)
453 tree type
= TREE_TYPE (decl
), size
, ptr
, cond
, then_b
, else_b
;
454 stmtblock_t block
, cond_block
;
456 gcc_assert (OMP_CLAUSE_CODE (clause
) == OMP_CLAUSE_PRIVATE
457 || OMP_CLAUSE_CODE (clause
) == OMP_CLAUSE_LASTPRIVATE
458 || OMP_CLAUSE_CODE (clause
) == OMP_CLAUSE_LINEAR
459 || OMP_CLAUSE_CODE (clause
) == OMP_CLAUSE_REDUCTION
);
461 if ((! GFC_DESCRIPTOR_TYPE_P (type
)
462 || GFC_TYPE_ARRAY_AKIND (type
) != GFC_ARRAY_ALLOCATABLE
)
463 && (!GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause
))
464 || !POINTER_TYPE_P (type
)))
466 if (gfc_has_alloc_comps (type
, OMP_CLAUSE_DECL (clause
)))
469 gfc_start_block (&block
);
470 tree tem
= gfc_walk_alloc_comps (outer
, decl
,
471 OMP_CLAUSE_DECL (clause
),
472 WALK_ALLOC_COMPS_DEFAULT_CTOR
);
473 gfc_add_expr_to_block (&block
, tem
);
474 return gfc_finish_block (&block
);
479 gcc_assert (outer
!= NULL_TREE
);
481 /* Allocatable arrays and scalars in PRIVATE clauses need to be set to
482 "not currently allocated" allocation status if outer
483 array is "not currently allocated", otherwise should be allocated. */
484 gfc_start_block (&block
);
486 gfc_init_block (&cond_block
);
488 if (GFC_DESCRIPTOR_TYPE_P (type
))
490 gfc_add_modify (&cond_block
, decl
, outer
);
491 tree rank
= gfc_rank_cst
[GFC_TYPE_ARRAY_RANK (type
) - 1];
492 size
= gfc_conv_descriptor_ubound_get (decl
, rank
);
493 size
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
495 gfc_conv_descriptor_lbound_get (decl
, rank
));
496 size
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
497 size
, gfc_index_one_node
);
498 if (GFC_TYPE_ARRAY_RANK (type
) > 1)
499 size
= fold_build2_loc (input_location
, MULT_EXPR
,
500 gfc_array_index_type
, size
,
501 gfc_conv_descriptor_stride_get (decl
, rank
));
502 tree esize
= fold_convert (gfc_array_index_type
,
503 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
504 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
506 size
= unshare_expr (size
);
507 size
= gfc_evaluate_now (fold_convert (size_type_node
, size
),
511 size
= fold_convert (size_type_node
, TYPE_SIZE_UNIT (TREE_TYPE (type
)));
512 ptr
= gfc_create_var (pvoid_type_node
, NULL
);
513 gfc_allocate_using_malloc (&cond_block
, ptr
, size
, NULL_TREE
);
514 if (GFC_DESCRIPTOR_TYPE_P (type
))
515 gfc_conv_descriptor_data_set (&cond_block
, unshare_expr (decl
), ptr
);
517 gfc_add_modify (&cond_block
, unshare_expr (decl
),
518 fold_convert (TREE_TYPE (decl
), ptr
));
519 if (gfc_has_alloc_comps (type
, OMP_CLAUSE_DECL (clause
)))
521 tree tem
= gfc_walk_alloc_comps (outer
, decl
,
522 OMP_CLAUSE_DECL (clause
),
523 WALK_ALLOC_COMPS_DEFAULT_CTOR
);
524 gfc_add_expr_to_block (&cond_block
, tem
);
526 then_b
= gfc_finish_block (&cond_block
);
528 /* Reduction clause requires allocated ALLOCATABLE. */
529 if (OMP_CLAUSE_CODE (clause
) != OMP_CLAUSE_REDUCTION
)
531 gfc_init_block (&cond_block
);
532 if (GFC_DESCRIPTOR_TYPE_P (type
))
533 gfc_conv_descriptor_data_set (&cond_block
, unshare_expr (decl
),
536 gfc_add_modify (&cond_block
, unshare_expr (decl
),
537 build_zero_cst (TREE_TYPE (decl
)));
538 else_b
= gfc_finish_block (&cond_block
);
540 tree tem
= fold_convert (pvoid_type_node
,
541 GFC_DESCRIPTOR_TYPE_P (type
)
542 ? gfc_conv_descriptor_data_get (outer
) : outer
);
543 tem
= unshare_expr (tem
);
544 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
545 tem
, null_pointer_node
);
546 gfc_add_expr_to_block (&block
,
547 build3_loc (input_location
, COND_EXPR
,
548 void_type_node
, cond
, then_b
,
552 gfc_add_expr_to_block (&block
, then_b
);
554 return gfc_finish_block (&block
);
557 /* Build and return code for a copy constructor from SRC to DEST. */
560 gfc_omp_clause_copy_ctor (tree clause
, tree dest
, tree src
)
562 tree type
= TREE_TYPE (dest
), ptr
, size
, call
;
563 tree cond
, then_b
, else_b
;
564 stmtblock_t block
, cond_block
;
566 gcc_assert (OMP_CLAUSE_CODE (clause
) == OMP_CLAUSE_FIRSTPRIVATE
567 || OMP_CLAUSE_CODE (clause
) == OMP_CLAUSE_LINEAR
);
569 if ((! GFC_DESCRIPTOR_TYPE_P (type
)
570 || GFC_TYPE_ARRAY_AKIND (type
) != GFC_ARRAY_ALLOCATABLE
)
571 && (!GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause
))
572 || !POINTER_TYPE_P (type
)))
574 if (gfc_has_alloc_comps (type
, OMP_CLAUSE_DECL (clause
)))
576 gfc_start_block (&block
);
577 gfc_add_modify (&block
, dest
, src
);
578 tree tem
= gfc_walk_alloc_comps (src
, dest
, OMP_CLAUSE_DECL (clause
),
579 WALK_ALLOC_COMPS_COPY_CTOR
);
580 gfc_add_expr_to_block (&block
, tem
);
581 return gfc_finish_block (&block
);
584 return build2_v (MODIFY_EXPR
, dest
, src
);
587 /* Allocatable arrays in FIRSTPRIVATE clauses need to be allocated
588 and copied from SRC. */
589 gfc_start_block (&block
);
591 gfc_init_block (&cond_block
);
593 gfc_add_modify (&cond_block
, dest
, src
);
594 if (GFC_DESCRIPTOR_TYPE_P (type
))
596 tree rank
= gfc_rank_cst
[GFC_TYPE_ARRAY_RANK (type
) - 1];
597 size
= gfc_conv_descriptor_ubound_get (dest
, rank
);
598 size
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
600 gfc_conv_descriptor_lbound_get (dest
, rank
));
601 size
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
602 size
, gfc_index_one_node
);
603 if (GFC_TYPE_ARRAY_RANK (type
) > 1)
604 size
= fold_build2_loc (input_location
, MULT_EXPR
,
605 gfc_array_index_type
, size
,
606 gfc_conv_descriptor_stride_get (dest
, rank
));
607 tree esize
= fold_convert (gfc_array_index_type
,
608 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
609 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
611 size
= unshare_expr (size
);
612 size
= gfc_evaluate_now (fold_convert (size_type_node
, size
),
616 size
= fold_convert (size_type_node
, TYPE_SIZE_UNIT (TREE_TYPE (type
)));
617 ptr
= gfc_create_var (pvoid_type_node
, NULL
);
618 gfc_allocate_using_malloc (&cond_block
, ptr
, size
, NULL_TREE
);
619 if (GFC_DESCRIPTOR_TYPE_P (type
))
620 gfc_conv_descriptor_data_set (&cond_block
, unshare_expr (dest
), ptr
);
622 gfc_add_modify (&cond_block
, unshare_expr (dest
),
623 fold_convert (TREE_TYPE (dest
), ptr
));
625 tree srcptr
= GFC_DESCRIPTOR_TYPE_P (type
)
626 ? gfc_conv_descriptor_data_get (src
) : src
;
627 srcptr
= unshare_expr (srcptr
);
628 srcptr
= fold_convert (pvoid_type_node
, srcptr
);
629 call
= build_call_expr_loc (input_location
,
630 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3, ptr
,
632 gfc_add_expr_to_block (&cond_block
, fold_convert (void_type_node
, call
));
633 if (gfc_has_alloc_comps (type
, OMP_CLAUSE_DECL (clause
)))
635 tree tem
= gfc_walk_alloc_comps (src
, dest
,
636 OMP_CLAUSE_DECL (clause
),
637 WALK_ALLOC_COMPS_COPY_CTOR
);
638 gfc_add_expr_to_block (&cond_block
, tem
);
640 then_b
= gfc_finish_block (&cond_block
);
642 gfc_init_block (&cond_block
);
643 if (GFC_DESCRIPTOR_TYPE_P (type
))
644 gfc_conv_descriptor_data_set (&cond_block
, unshare_expr (dest
),
647 gfc_add_modify (&cond_block
, unshare_expr (dest
),
648 build_zero_cst (TREE_TYPE (dest
)));
649 else_b
= gfc_finish_block (&cond_block
);
651 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
652 unshare_expr (srcptr
), null_pointer_node
);
653 gfc_add_expr_to_block (&block
,
654 build3_loc (input_location
, COND_EXPR
,
655 void_type_node
, cond
, then_b
, else_b
));
657 return gfc_finish_block (&block
);
660 /* Similarly, except use an intrinsic or pointer assignment operator
664 gfc_omp_clause_assign_op (tree clause
, tree dest
, tree src
)
666 tree type
= TREE_TYPE (dest
), ptr
, size
, call
, nonalloc
;
667 tree cond
, then_b
, else_b
;
668 stmtblock_t block
, cond_block
, cond_block2
, inner_block
;
670 if ((! GFC_DESCRIPTOR_TYPE_P (type
)
671 || GFC_TYPE_ARRAY_AKIND (type
) != GFC_ARRAY_ALLOCATABLE
)
672 && (!GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause
))
673 || !POINTER_TYPE_P (type
)))
675 if (gfc_has_alloc_comps (type
, OMP_CLAUSE_DECL (clause
)))
677 gfc_start_block (&block
);
678 /* First dealloc any allocatable components in DEST. */
679 tree tem
= gfc_walk_alloc_comps (dest
, NULL_TREE
,
680 OMP_CLAUSE_DECL (clause
),
681 WALK_ALLOC_COMPS_DTOR
);
682 gfc_add_expr_to_block (&block
, tem
);
683 /* Then copy over toplevel data. */
684 gfc_add_modify (&block
, dest
, src
);
685 /* Finally allocate any allocatable components and copy. */
686 tem
= gfc_walk_alloc_comps (src
, dest
, OMP_CLAUSE_DECL (clause
),
687 WALK_ALLOC_COMPS_COPY_CTOR
);
688 gfc_add_expr_to_block (&block
, tem
);
689 return gfc_finish_block (&block
);
692 return build2_v (MODIFY_EXPR
, dest
, src
);
695 gfc_start_block (&block
);
697 if (gfc_has_alloc_comps (type
, OMP_CLAUSE_DECL (clause
)))
699 then_b
= gfc_walk_alloc_comps (dest
, NULL_TREE
, OMP_CLAUSE_DECL (clause
),
700 WALK_ALLOC_COMPS_DTOR
);
701 tree tem
= fold_convert (pvoid_type_node
,
702 GFC_DESCRIPTOR_TYPE_P (type
)
703 ? gfc_conv_descriptor_data_get (dest
) : dest
);
704 tem
= unshare_expr (tem
);
705 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
706 tem
, null_pointer_node
);
707 tem
= build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
708 then_b
, build_empty_stmt (input_location
));
709 gfc_add_expr_to_block (&block
, tem
);
712 gfc_init_block (&cond_block
);
714 if (GFC_DESCRIPTOR_TYPE_P (type
))
716 tree rank
= gfc_rank_cst
[GFC_TYPE_ARRAY_RANK (type
) - 1];
717 size
= gfc_conv_descriptor_ubound_get (src
, rank
);
718 size
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
720 gfc_conv_descriptor_lbound_get (src
, rank
));
721 size
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
722 size
, gfc_index_one_node
);
723 if (GFC_TYPE_ARRAY_RANK (type
) > 1)
724 size
= fold_build2_loc (input_location
, MULT_EXPR
,
725 gfc_array_index_type
, size
,
726 gfc_conv_descriptor_stride_get (src
, rank
));
727 tree esize
= fold_convert (gfc_array_index_type
,
728 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
729 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
731 size
= unshare_expr (size
);
732 size
= gfc_evaluate_now (fold_convert (size_type_node
, size
),
736 size
= fold_convert (size_type_node
, TYPE_SIZE_UNIT (TREE_TYPE (type
)));
737 ptr
= gfc_create_var (pvoid_type_node
, NULL
);
739 tree destptr
= GFC_DESCRIPTOR_TYPE_P (type
)
740 ? gfc_conv_descriptor_data_get (dest
) : dest
;
741 destptr
= unshare_expr (destptr
);
742 destptr
= fold_convert (pvoid_type_node
, destptr
);
743 gfc_add_modify (&cond_block
, ptr
, destptr
);
745 nonalloc
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
746 destptr
, null_pointer_node
);
748 if (GFC_DESCRIPTOR_TYPE_P (type
))
751 for (i
= 0; i
< GFC_TYPE_ARRAY_RANK (type
); i
++)
753 tree rank
= gfc_rank_cst
[i
];
754 tree tem
= gfc_conv_descriptor_ubound_get (src
, rank
);
755 tem
= fold_build2_loc (input_location
, MINUS_EXPR
,
756 gfc_array_index_type
, tem
,
757 gfc_conv_descriptor_lbound_get (src
, rank
));
758 tem
= fold_build2_loc (input_location
, PLUS_EXPR
,
759 gfc_array_index_type
, tem
,
760 gfc_conv_descriptor_lbound_get (dest
, rank
));
761 tem
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
762 tem
, gfc_conv_descriptor_ubound_get (dest
,
764 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
765 logical_type_node
, cond
, tem
);
769 gfc_init_block (&cond_block2
);
771 if (GFC_DESCRIPTOR_TYPE_P (type
))
773 gfc_init_block (&inner_block
);
774 gfc_allocate_using_malloc (&inner_block
, ptr
, size
, NULL_TREE
);
775 then_b
= gfc_finish_block (&inner_block
);
777 gfc_init_block (&inner_block
);
778 gfc_add_modify (&inner_block
, ptr
,
779 gfc_call_realloc (&inner_block
, ptr
, size
));
780 else_b
= gfc_finish_block (&inner_block
);
782 gfc_add_expr_to_block (&cond_block2
,
783 build3_loc (input_location
, COND_EXPR
,
785 unshare_expr (nonalloc
),
787 gfc_add_modify (&cond_block2
, dest
, src
);
788 gfc_conv_descriptor_data_set (&cond_block2
, unshare_expr (dest
), ptr
);
792 gfc_allocate_using_malloc (&cond_block2
, ptr
, size
, NULL_TREE
);
793 gfc_add_modify (&cond_block2
, unshare_expr (dest
),
794 fold_convert (type
, ptr
));
796 then_b
= gfc_finish_block (&cond_block2
);
797 else_b
= build_empty_stmt (input_location
);
799 gfc_add_expr_to_block (&cond_block
,
800 build3_loc (input_location
, COND_EXPR
,
801 void_type_node
, unshare_expr (cond
),
804 tree srcptr
= GFC_DESCRIPTOR_TYPE_P (type
)
805 ? gfc_conv_descriptor_data_get (src
) : src
;
806 srcptr
= unshare_expr (srcptr
);
807 srcptr
= fold_convert (pvoid_type_node
, srcptr
);
808 call
= build_call_expr_loc (input_location
,
809 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3, ptr
,
811 gfc_add_expr_to_block (&cond_block
, fold_convert (void_type_node
, call
));
812 if (gfc_has_alloc_comps (type
, OMP_CLAUSE_DECL (clause
)))
814 tree tem
= gfc_walk_alloc_comps (src
, dest
,
815 OMP_CLAUSE_DECL (clause
),
816 WALK_ALLOC_COMPS_COPY_CTOR
);
817 gfc_add_expr_to_block (&cond_block
, tem
);
819 then_b
= gfc_finish_block (&cond_block
);
821 if (OMP_CLAUSE_CODE (clause
) == OMP_CLAUSE_COPYIN
)
823 gfc_init_block (&cond_block
);
824 if (GFC_DESCRIPTOR_TYPE_P (type
))
826 tree tmp
= gfc_conv_descriptor_data_get (unshare_expr (dest
));
827 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, NULL_TREE
,
828 NULL_TREE
, NULL_TREE
, true, NULL
,
829 GFC_CAF_COARRAY_NOCOARRAY
);
830 gfc_add_expr_to_block (&cond_block
, tmp
);
834 destptr
= gfc_evaluate_now (destptr
, &cond_block
);
835 gfc_add_expr_to_block (&cond_block
, gfc_call_free (destptr
));
836 gfc_add_modify (&cond_block
, unshare_expr (dest
),
837 build_zero_cst (TREE_TYPE (dest
)));
839 else_b
= gfc_finish_block (&cond_block
);
841 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
842 unshare_expr (srcptr
), null_pointer_node
);
843 gfc_add_expr_to_block (&block
,
844 build3_loc (input_location
, COND_EXPR
,
845 void_type_node
, cond
,
849 gfc_add_expr_to_block (&block
, then_b
);
851 return gfc_finish_block (&block
);
855 gfc_omp_linear_clause_add_loop (stmtblock_t
*block
, tree dest
, tree src
,
856 tree add
, tree nelems
)
858 stmtblock_t tmpblock
;
859 tree desta
, srca
, index
= gfc_create_var (gfc_array_index_type
, "S");
860 nelems
= gfc_evaluate_now (nelems
, block
);
862 gfc_init_block (&tmpblock
);
863 if (TREE_CODE (TREE_TYPE (dest
)) == ARRAY_TYPE
)
865 desta
= gfc_build_array_ref (dest
, index
, NULL
);
866 srca
= gfc_build_array_ref (src
, index
, NULL
);
870 gcc_assert (POINTER_TYPE_P (TREE_TYPE (dest
)));
871 tree idx
= fold_build2 (MULT_EXPR
, sizetype
,
872 fold_convert (sizetype
, index
),
873 TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (dest
))));
874 desta
= build_fold_indirect_ref (fold_build2 (POINTER_PLUS_EXPR
,
875 TREE_TYPE (dest
), dest
,
877 srca
= build_fold_indirect_ref (fold_build2 (POINTER_PLUS_EXPR
,
878 TREE_TYPE (src
), src
,
881 gfc_add_modify (&tmpblock
, desta
,
882 fold_build2 (PLUS_EXPR
, TREE_TYPE (desta
),
886 gfc_init_loopinfo (&loop
);
888 loop
.from
[0] = gfc_index_zero_node
;
889 loop
.loopvar
[0] = index
;
891 gfc_trans_scalarizing_loops (&loop
, &tmpblock
);
892 gfc_add_block_to_block (block
, &loop
.pre
);
895 /* Build and return code for a constructor of DEST that initializes
896 it to SRC plus ADD (ADD is scalar integer). */
899 gfc_omp_clause_linear_ctor (tree clause
, tree dest
, tree src
, tree add
)
901 tree type
= TREE_TYPE (dest
), ptr
, size
, nelems
= NULL_TREE
;
904 gcc_assert (OMP_CLAUSE_CODE (clause
) == OMP_CLAUSE_LINEAR
);
906 gfc_start_block (&block
);
907 add
= gfc_evaluate_now (add
, &block
);
909 if ((! GFC_DESCRIPTOR_TYPE_P (type
)
910 || GFC_TYPE_ARRAY_AKIND (type
) != GFC_ARRAY_ALLOCATABLE
)
911 && (!GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause
))
912 || !POINTER_TYPE_P (type
)))
914 gcc_assert (TREE_CODE (type
) == ARRAY_TYPE
);
915 if (!TYPE_DOMAIN (type
)
916 || TYPE_MAX_VALUE (TYPE_DOMAIN (type
)) == NULL_TREE
917 || TYPE_MIN_VALUE (TYPE_DOMAIN (type
)) == error_mark_node
918 || TYPE_MAX_VALUE (TYPE_DOMAIN (type
)) == error_mark_node
)
920 nelems
= fold_build2 (EXACT_DIV_EXPR
, sizetype
,
921 TYPE_SIZE_UNIT (type
),
922 TYPE_SIZE_UNIT (TREE_TYPE (type
)));
923 nelems
= size_binop (MINUS_EXPR
, nelems
, size_one_node
);
926 nelems
= array_type_nelts (type
);
927 nelems
= fold_convert (gfc_array_index_type
, nelems
);
929 gfc_omp_linear_clause_add_loop (&block
, dest
, src
, add
, nelems
);
930 return gfc_finish_block (&block
);
933 /* Allocatable arrays in LINEAR clauses need to be allocated
934 and copied from SRC. */
935 gfc_add_modify (&block
, dest
, src
);
936 if (GFC_DESCRIPTOR_TYPE_P (type
))
938 tree rank
= gfc_rank_cst
[GFC_TYPE_ARRAY_RANK (type
) - 1];
939 size
= gfc_conv_descriptor_ubound_get (dest
, rank
);
940 size
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
942 gfc_conv_descriptor_lbound_get (dest
, rank
));
943 size
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
944 size
, gfc_index_one_node
);
945 if (GFC_TYPE_ARRAY_RANK (type
) > 1)
946 size
= fold_build2_loc (input_location
, MULT_EXPR
,
947 gfc_array_index_type
, size
,
948 gfc_conv_descriptor_stride_get (dest
, rank
));
949 tree esize
= fold_convert (gfc_array_index_type
,
950 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
951 nelems
= gfc_evaluate_now (unshare_expr (size
), &block
);
952 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
953 nelems
, unshare_expr (esize
));
954 size
= gfc_evaluate_now (fold_convert (size_type_node
, size
),
956 nelems
= fold_build2_loc (input_location
, MINUS_EXPR
,
957 gfc_array_index_type
, nelems
,
961 size
= fold_convert (size_type_node
, TYPE_SIZE_UNIT (TREE_TYPE (type
)));
962 ptr
= gfc_create_var (pvoid_type_node
, NULL
);
963 gfc_allocate_using_malloc (&block
, ptr
, size
, NULL_TREE
);
964 if (GFC_DESCRIPTOR_TYPE_P (type
))
966 gfc_conv_descriptor_data_set (&block
, unshare_expr (dest
), ptr
);
967 tree etype
= gfc_get_element_type (type
);
968 ptr
= fold_convert (build_pointer_type (etype
), ptr
);
969 tree srcptr
= gfc_conv_descriptor_data_get (unshare_expr (src
));
970 srcptr
= fold_convert (build_pointer_type (etype
), srcptr
);
971 gfc_omp_linear_clause_add_loop (&block
, ptr
, srcptr
, add
, nelems
);
975 gfc_add_modify (&block
, unshare_expr (dest
),
976 fold_convert (TREE_TYPE (dest
), ptr
));
977 ptr
= fold_convert (TREE_TYPE (dest
), ptr
);
978 tree dstm
= build_fold_indirect_ref (ptr
);
979 tree srcm
= build_fold_indirect_ref (unshare_expr (src
));
980 gfc_add_modify (&block
, dstm
,
981 fold_build2 (PLUS_EXPR
, TREE_TYPE (add
), srcm
, add
));
983 return gfc_finish_block (&block
);
986 /* Build and return code destructing DECL. Return NULL if nothing
990 gfc_omp_clause_dtor (tree clause
, tree decl
)
992 tree type
= TREE_TYPE (decl
), tem
;
994 if ((! GFC_DESCRIPTOR_TYPE_P (type
)
995 || GFC_TYPE_ARRAY_AKIND (type
) != GFC_ARRAY_ALLOCATABLE
)
996 && (!GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause
))
997 || !POINTER_TYPE_P (type
)))
999 if (gfc_has_alloc_comps (type
, OMP_CLAUSE_DECL (clause
)))
1000 return gfc_walk_alloc_comps (decl
, NULL_TREE
,
1001 OMP_CLAUSE_DECL (clause
),
1002 WALK_ALLOC_COMPS_DTOR
);
1006 if (GFC_DESCRIPTOR_TYPE_P (type
))
1008 /* Allocatable arrays in FIRSTPRIVATE/LASTPRIVATE etc. clauses need
1009 to be deallocated if they were allocated. */
1010 tem
= gfc_conv_descriptor_data_get (decl
);
1011 tem
= gfc_deallocate_with_status (tem
, NULL_TREE
, NULL_TREE
, NULL_TREE
,
1012 NULL_TREE
, true, NULL
,
1013 GFC_CAF_COARRAY_NOCOARRAY
);
1016 tem
= gfc_call_free (decl
);
1017 tem
= gfc_omp_unshare_expr (tem
);
1019 if (gfc_has_alloc_comps (type
, OMP_CLAUSE_DECL (clause
)))
1024 gfc_init_block (&block
);
1025 gfc_add_expr_to_block (&block
,
1026 gfc_walk_alloc_comps (decl
, NULL_TREE
,
1027 OMP_CLAUSE_DECL (clause
),
1028 WALK_ALLOC_COMPS_DTOR
));
1029 gfc_add_expr_to_block (&block
, tem
);
1030 then_b
= gfc_finish_block (&block
);
1032 tem
= fold_convert (pvoid_type_node
,
1033 GFC_DESCRIPTOR_TYPE_P (type
)
1034 ? gfc_conv_descriptor_data_get (decl
) : decl
);
1035 tem
= unshare_expr (tem
);
1036 tree cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
1037 tem
, null_pointer_node
);
1038 tem
= build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
1039 then_b
, build_empty_stmt (input_location
));
1046 gfc_omp_finish_clause (tree c
, gimple_seq
*pre_p
)
1048 if (OMP_CLAUSE_CODE (c
) != OMP_CLAUSE_MAP
)
1051 tree decl
= OMP_CLAUSE_DECL (c
);
1053 /* Assumed-size arrays can't be mapped implicitly, they have to be
1054 mapped explicitly using array sections. */
1055 if (TREE_CODE (decl
) == PARM_DECL
1056 && GFC_ARRAY_TYPE_P (TREE_TYPE (decl
))
1057 && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (decl
)) == GFC_ARRAY_UNKNOWN
1058 && GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (decl
),
1059 GFC_TYPE_ARRAY_RANK (TREE_TYPE (decl
)) - 1)
1062 error_at (OMP_CLAUSE_LOCATION (c
),
1063 "implicit mapping of assumed size array %qD", decl
);
1067 tree c2
= NULL_TREE
, c3
= NULL_TREE
, c4
= NULL_TREE
;
1068 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
1070 if (!gfc_omp_privatize_by_reference (decl
)
1071 && !GFC_DECL_GET_SCALAR_POINTER (decl
)
1072 && !GFC_DECL_GET_SCALAR_ALLOCATABLE (decl
)
1073 && !GFC_DECL_CRAY_POINTEE (decl
)
1074 && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (decl
))))
1076 tree orig_decl
= decl
;
1077 c4
= build_omp_clause (OMP_CLAUSE_LOCATION (c
), OMP_CLAUSE_MAP
);
1078 OMP_CLAUSE_SET_MAP_KIND (c4
, GOMP_MAP_POINTER
);
1079 OMP_CLAUSE_DECL (c4
) = decl
;
1080 OMP_CLAUSE_SIZE (c4
) = size_int (0);
1081 decl
= build_fold_indirect_ref (decl
);
1082 OMP_CLAUSE_DECL (c
) = decl
;
1083 OMP_CLAUSE_SIZE (c
) = NULL_TREE
;
1084 if (TREE_CODE (TREE_TYPE (orig_decl
)) == REFERENCE_TYPE
1085 && (GFC_DECL_GET_SCALAR_POINTER (orig_decl
)
1086 || GFC_DECL_GET_SCALAR_ALLOCATABLE (orig_decl
)))
1088 c3
= build_omp_clause (OMP_CLAUSE_LOCATION (c
), OMP_CLAUSE_MAP
);
1089 OMP_CLAUSE_SET_MAP_KIND (c3
, GOMP_MAP_POINTER
);
1090 OMP_CLAUSE_DECL (c3
) = unshare_expr (decl
);
1091 OMP_CLAUSE_SIZE (c3
) = size_int (0);
1092 decl
= build_fold_indirect_ref (decl
);
1093 OMP_CLAUSE_DECL (c
) = decl
;
1096 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
)))
1099 gfc_start_block (&block
);
1100 tree type
= TREE_TYPE (decl
);
1101 tree ptr
= gfc_conv_descriptor_data_get (decl
);
1102 ptr
= fold_convert (build_pointer_type (char_type_node
), ptr
);
1103 ptr
= build_fold_indirect_ref (ptr
);
1104 OMP_CLAUSE_DECL (c
) = ptr
;
1105 c2
= build_omp_clause (input_location
, OMP_CLAUSE_MAP
);
1106 OMP_CLAUSE_SET_MAP_KIND (c2
, GOMP_MAP_TO_PSET
);
1107 OMP_CLAUSE_DECL (c2
) = decl
;
1108 OMP_CLAUSE_SIZE (c2
) = TYPE_SIZE_UNIT (type
);
1109 c3
= build_omp_clause (OMP_CLAUSE_LOCATION (c
), OMP_CLAUSE_MAP
);
1110 OMP_CLAUSE_SET_MAP_KIND (c3
, GOMP_MAP_POINTER
);
1111 OMP_CLAUSE_DECL (c3
) = gfc_conv_descriptor_data_get (decl
);
1112 OMP_CLAUSE_SIZE (c3
) = size_int (0);
1113 tree size
= create_tmp_var (gfc_array_index_type
);
1114 tree elemsz
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
1115 elemsz
= fold_convert (gfc_array_index_type
, elemsz
);
1116 if (GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_POINTER
1117 || GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_POINTER_CONT
)
1119 stmtblock_t cond_block
;
1120 tree tem
, then_b
, else_b
, zero
, cond
;
1122 gfc_init_block (&cond_block
);
1123 tem
= gfc_full_array_size (&cond_block
, decl
,
1124 GFC_TYPE_ARRAY_RANK (type
));
1125 gfc_add_modify (&cond_block
, size
, tem
);
1126 gfc_add_modify (&cond_block
, size
,
1127 fold_build2 (MULT_EXPR
, gfc_array_index_type
,
1129 then_b
= gfc_finish_block (&cond_block
);
1130 gfc_init_block (&cond_block
);
1131 zero
= build_int_cst (gfc_array_index_type
, 0);
1132 gfc_add_modify (&cond_block
, size
, zero
);
1133 else_b
= gfc_finish_block (&cond_block
);
1134 tem
= gfc_conv_descriptor_data_get (decl
);
1135 tem
= fold_convert (pvoid_type_node
, tem
);
1136 cond
= fold_build2_loc (input_location
, NE_EXPR
,
1137 logical_type_node
, tem
, null_pointer_node
);
1138 gfc_add_expr_to_block (&block
, build3_loc (input_location
, COND_EXPR
,
1139 void_type_node
, cond
,
1144 gfc_add_modify (&block
, size
,
1145 gfc_full_array_size (&block
, decl
,
1146 GFC_TYPE_ARRAY_RANK (type
)));
1147 gfc_add_modify (&block
, size
,
1148 fold_build2 (MULT_EXPR
, gfc_array_index_type
,
1151 OMP_CLAUSE_SIZE (c
) = size
;
1152 tree stmt
= gfc_finish_block (&block
);
1153 gimplify_and_add (stmt
, pre_p
);
1156 if (OMP_CLAUSE_SIZE (c
) == NULL_TREE
)
1158 = DECL_P (decl
) ? DECL_SIZE_UNIT (decl
)
1159 : TYPE_SIZE_UNIT (TREE_TYPE (decl
));
1162 OMP_CLAUSE_CHAIN (c2
) = OMP_CLAUSE_CHAIN (last
);
1163 OMP_CLAUSE_CHAIN (last
) = c2
;
1168 OMP_CLAUSE_CHAIN (c3
) = OMP_CLAUSE_CHAIN (last
);
1169 OMP_CLAUSE_CHAIN (last
) = c3
;
1174 OMP_CLAUSE_CHAIN (c4
) = OMP_CLAUSE_CHAIN (last
);
1175 OMP_CLAUSE_CHAIN (last
) = c4
;
1181 /* Return true if DECL is a scalar variable (for the purpose of
1182 implicit firstprivatization). */
1185 gfc_omp_scalar_p (tree decl
)
1187 tree type
= TREE_TYPE (decl
);
1188 if (TREE_CODE (type
) == REFERENCE_TYPE
)
1189 type
= TREE_TYPE (type
);
1190 if (TREE_CODE (type
) == POINTER_TYPE
)
1192 if (GFC_DECL_GET_SCALAR_ALLOCATABLE (decl
)
1193 || GFC_DECL_GET_SCALAR_POINTER (decl
))
1194 type
= TREE_TYPE (type
);
1195 if (GFC_ARRAY_TYPE_P (type
)
1196 || GFC_CLASS_TYPE_P (type
))
1199 if (TYPE_STRING_FLAG (type
))
1201 if (INTEGRAL_TYPE_P (type
)
1202 || SCALAR_FLOAT_TYPE_P (type
)
1203 || COMPLEX_FLOAT_TYPE_P (type
))
1209 /* Return true if DECL's DECL_VALUE_EXPR (if any) should be
1210 disregarded in OpenMP construct, because it is going to be
1211 remapped during OpenMP lowering. SHARED is true if DECL
1212 is going to be shared, false if it is going to be privatized. */
1215 gfc_omp_disregard_value_expr (tree decl
, bool shared
)
1217 if (GFC_DECL_COMMON_OR_EQUIV (decl
)
1218 && DECL_HAS_VALUE_EXPR_P (decl
))
1220 tree value
= DECL_VALUE_EXPR (decl
);
1222 if (TREE_CODE (value
) == COMPONENT_REF
1223 && VAR_P (TREE_OPERAND (value
, 0))
1224 && GFC_DECL_COMMON_OR_EQUIV (TREE_OPERAND (value
, 0)))
1226 /* If variable in COMMON or EQUIVALENCE is privatized, return
1227 true, as just that variable is supposed to be privatized,
1228 not the whole COMMON or whole EQUIVALENCE.
1229 For shared variables in COMMON or EQUIVALENCE, let them be
1230 gimplified to DECL_VALUE_EXPR, so that for multiple shared vars
1231 from the same COMMON or EQUIVALENCE just one sharing of the
1232 whole COMMON or EQUIVALENCE is enough. */
1237 if (GFC_DECL_RESULT (decl
) && DECL_HAS_VALUE_EXPR_P (decl
))
1243 /* Return true if DECL that is shared iff SHARED is true should
1244 be put into OMP_CLAUSE_PRIVATE with OMP_CLAUSE_PRIVATE_DEBUG
1248 gfc_omp_private_debug_clause (tree decl
, bool shared
)
1250 if (GFC_DECL_CRAY_POINTEE (decl
))
1253 if (GFC_DECL_COMMON_OR_EQUIV (decl
)
1254 && DECL_HAS_VALUE_EXPR_P (decl
))
1256 tree value
= DECL_VALUE_EXPR (decl
);
1258 if (TREE_CODE (value
) == COMPONENT_REF
1259 && VAR_P (TREE_OPERAND (value
, 0))
1260 && GFC_DECL_COMMON_OR_EQUIV (TREE_OPERAND (value
, 0)))
1267 /* Register language specific type size variables as potentially OpenMP
1268 firstprivate variables. */
1271 gfc_omp_firstprivatize_type_sizes (struct gimplify_omp_ctx
*ctx
, tree type
)
1273 if (GFC_ARRAY_TYPE_P (type
) || GFC_DESCRIPTOR_TYPE_P (type
))
1277 gcc_assert (TYPE_LANG_SPECIFIC (type
) != NULL
);
1278 for (r
= 0; r
< GFC_TYPE_ARRAY_RANK (type
); r
++)
1280 omp_firstprivatize_variable (ctx
, GFC_TYPE_ARRAY_LBOUND (type
, r
));
1281 omp_firstprivatize_variable (ctx
, GFC_TYPE_ARRAY_UBOUND (type
, r
));
1282 omp_firstprivatize_variable (ctx
, GFC_TYPE_ARRAY_STRIDE (type
, r
));
1284 omp_firstprivatize_variable (ctx
, GFC_TYPE_ARRAY_SIZE (type
));
1285 omp_firstprivatize_variable (ctx
, GFC_TYPE_ARRAY_OFFSET (type
));
1291 gfc_trans_add_clause (tree node
, tree tail
)
1293 OMP_CLAUSE_CHAIN (node
) = tail
;
1298 gfc_trans_omp_variable (gfc_symbol
*sym
, bool declare_simd
)
1303 gfc_symbol
*proc_sym
;
1304 gfc_formal_arglist
*f
;
1306 gcc_assert (sym
->attr
.dummy
);
1307 proc_sym
= sym
->ns
->proc_name
;
1308 if (proc_sym
->attr
.entry_master
)
1310 if (gfc_return_by_reference (proc_sym
))
1313 if (proc_sym
->ts
.type
== BT_CHARACTER
)
1316 for (f
= gfc_sym_get_dummy_args (proc_sym
); f
; f
= f
->next
)
1322 return build_int_cst (integer_type_node
, cnt
);
1325 tree t
= gfc_get_symbol_decl (sym
);
1329 bool alternate_entry
;
1332 return_value
= sym
->attr
.function
&& sym
->result
== sym
;
1333 alternate_entry
= sym
->attr
.function
&& sym
->attr
.entry
1334 && sym
->result
== sym
;
1335 entry_master
= sym
->attr
.result
1336 && sym
->ns
->proc_name
->attr
.entry_master
1337 && !gfc_return_by_reference (sym
->ns
->proc_name
);
1338 parent_decl
= current_function_decl
1339 ? DECL_CONTEXT (current_function_decl
) : NULL_TREE
;
1341 if ((t
== parent_decl
&& return_value
)
1342 || (sym
->ns
&& sym
->ns
->proc_name
1343 && sym
->ns
->proc_name
->backend_decl
== parent_decl
1344 && (alternate_entry
|| entry_master
)))
1349 /* Special case for assigning the return value of a function.
1350 Self recursive functions must have an explicit return value. */
1351 if (return_value
&& (t
== current_function_decl
|| parent_flag
))
1352 t
= gfc_get_fake_result_decl (sym
, parent_flag
);
1354 /* Similarly for alternate entry points. */
1355 else if (alternate_entry
1356 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
1359 gfc_entry_list
*el
= NULL
;
1361 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
1364 t
= gfc_get_fake_result_decl (sym
, parent_flag
);
1369 else if (entry_master
1370 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
1372 t
= gfc_get_fake_result_decl (sym
, parent_flag
);
1378 gfc_trans_omp_variable_list (enum omp_clause_code code
,
1379 gfc_omp_namelist
*namelist
, tree list
,
1382 for (; namelist
!= NULL
; namelist
= namelist
->next
)
1383 if (namelist
->sym
->attr
.referenced
|| declare_simd
)
1385 tree t
= gfc_trans_omp_variable (namelist
->sym
, declare_simd
);
1386 if (t
!= error_mark_node
)
1388 tree node
= build_omp_clause (input_location
, code
);
1389 OMP_CLAUSE_DECL (node
) = t
;
1390 list
= gfc_trans_add_clause (node
, list
);
1396 struct omp_udr_find_orig_data
1398 gfc_omp_udr
*omp_udr
;
1403 omp_udr_find_orig (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
1406 struct omp_udr_find_orig_data
*cd
= (struct omp_udr_find_orig_data
*) data
;
1407 if ((*e
)->expr_type
== EXPR_VARIABLE
1408 && (*e
)->symtree
->n
.sym
== cd
->omp_udr
->omp_orig
)
1409 cd
->omp_orig_seen
= true;
1415 gfc_trans_omp_array_reduction_or_udr (tree c
, gfc_omp_namelist
*n
, locus where
)
1417 gfc_symbol
*sym
= n
->sym
;
1418 gfc_symtree
*root1
= NULL
, *root2
= NULL
, *root3
= NULL
, *root4
= NULL
;
1419 gfc_symtree
*symtree1
, *symtree2
, *symtree3
, *symtree4
= NULL
;
1420 gfc_symbol init_val_sym
, outer_sym
, intrinsic_sym
;
1421 gfc_symbol omp_var_copy
[4];
1422 gfc_expr
*e1
, *e2
, *e3
, *e4
;
1424 tree decl
, backend_decl
, stmt
, type
, outer_decl
;
1425 locus old_loc
= gfc_current_locus
;
1428 gfc_omp_udr
*udr
= n
->udr
? n
->udr
->udr
: NULL
;
1430 decl
= OMP_CLAUSE_DECL (c
);
1431 gfc_current_locus
= where
;
1432 type
= TREE_TYPE (decl
);
1433 outer_decl
= create_tmp_var_raw (type
);
1434 if (TREE_CODE (decl
) == PARM_DECL
1435 && TREE_CODE (type
) == REFERENCE_TYPE
1436 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type
))
1437 && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (type
)) == GFC_ARRAY_ALLOCATABLE
)
1439 decl
= build_fold_indirect_ref (decl
);
1440 type
= TREE_TYPE (type
);
1443 /* Create a fake symbol for init value. */
1444 memset (&init_val_sym
, 0, sizeof (init_val_sym
));
1445 init_val_sym
.ns
= sym
->ns
;
1446 init_val_sym
.name
= sym
->name
;
1447 init_val_sym
.ts
= sym
->ts
;
1448 init_val_sym
.attr
.referenced
= 1;
1449 init_val_sym
.declared_at
= where
;
1450 init_val_sym
.attr
.flavor
= FL_VARIABLE
;
1451 if (OMP_CLAUSE_REDUCTION_CODE (c
) != ERROR_MARK
)
1452 backend_decl
= omp_reduction_init (c
, gfc_sym_type (&init_val_sym
));
1453 else if (udr
->initializer_ns
)
1454 backend_decl
= NULL
;
1456 switch (sym
->ts
.type
)
1462 backend_decl
= build_zero_cst (gfc_sym_type (&init_val_sym
));
1465 backend_decl
= NULL_TREE
;
1468 init_val_sym
.backend_decl
= backend_decl
;
1470 /* Create a fake symbol for the outer array reference. */
1473 outer_sym
.as
= gfc_copy_array_spec (sym
->as
);
1474 outer_sym
.attr
.dummy
= 0;
1475 outer_sym
.attr
.result
= 0;
1476 outer_sym
.attr
.flavor
= FL_VARIABLE
;
1477 outer_sym
.backend_decl
= outer_decl
;
1478 if (decl
!= OMP_CLAUSE_DECL (c
))
1479 outer_sym
.backend_decl
= build_fold_indirect_ref (outer_decl
);
1481 /* Create fake symtrees for it. */
1482 symtree1
= gfc_new_symtree (&root1
, sym
->name
);
1483 symtree1
->n
.sym
= sym
;
1484 gcc_assert (symtree1
== root1
);
1486 symtree2
= gfc_new_symtree (&root2
, sym
->name
);
1487 symtree2
->n
.sym
= &init_val_sym
;
1488 gcc_assert (symtree2
== root2
);
1490 symtree3
= gfc_new_symtree (&root3
, sym
->name
);
1491 symtree3
->n
.sym
= &outer_sym
;
1492 gcc_assert (symtree3
== root3
);
1494 memset (omp_var_copy
, 0, sizeof omp_var_copy
);
1497 omp_var_copy
[0] = *udr
->omp_out
;
1498 omp_var_copy
[1] = *udr
->omp_in
;
1499 *udr
->omp_out
= outer_sym
;
1500 *udr
->omp_in
= *sym
;
1501 if (udr
->initializer_ns
)
1503 omp_var_copy
[2] = *udr
->omp_priv
;
1504 omp_var_copy
[3] = *udr
->omp_orig
;
1505 *udr
->omp_priv
= *sym
;
1506 *udr
->omp_orig
= outer_sym
;
1510 /* Create expressions. */
1511 e1
= gfc_get_expr ();
1512 e1
->expr_type
= EXPR_VARIABLE
;
1514 e1
->symtree
= symtree1
;
1516 if (sym
->attr
.dimension
)
1518 e1
->ref
= ref
= gfc_get_ref ();
1519 ref
->type
= REF_ARRAY
;
1520 ref
->u
.ar
.where
= where
;
1521 ref
->u
.ar
.as
= sym
->as
;
1522 ref
->u
.ar
.type
= AR_FULL
;
1523 ref
->u
.ar
.dimen
= 0;
1525 t
= gfc_resolve_expr (e1
);
1529 if (backend_decl
!= NULL_TREE
)
1531 e2
= gfc_get_expr ();
1532 e2
->expr_type
= EXPR_VARIABLE
;
1534 e2
->symtree
= symtree2
;
1536 t
= gfc_resolve_expr (e2
);
1539 else if (udr
->initializer_ns
== NULL
)
1541 gcc_assert (sym
->ts
.type
== BT_DERIVED
);
1542 e2
= gfc_default_initializer (&sym
->ts
);
1544 t
= gfc_resolve_expr (e2
);
1547 else if (n
->udr
->initializer
->op
== EXEC_ASSIGN
)
1549 e2
= gfc_copy_expr (n
->udr
->initializer
->expr2
);
1550 t
= gfc_resolve_expr (e2
);
1553 if (udr
&& udr
->initializer_ns
)
1555 struct omp_udr_find_orig_data cd
;
1557 cd
.omp_orig_seen
= false;
1558 gfc_code_walker (&n
->udr
->initializer
,
1559 gfc_dummy_code_callback
, omp_udr_find_orig
, &cd
);
1560 if (cd
.omp_orig_seen
)
1561 OMP_CLAUSE_REDUCTION_OMP_ORIG_REF (c
) = 1;
1564 e3
= gfc_copy_expr (e1
);
1565 e3
->symtree
= symtree3
;
1566 t
= gfc_resolve_expr (e3
);
1571 switch (OMP_CLAUSE_REDUCTION_CODE (c
))
1575 e4
= gfc_add (e3
, e1
);
1578 e4
= gfc_multiply (e3
, e1
);
1580 case TRUTH_ANDIF_EXPR
:
1581 e4
= gfc_and (e3
, e1
);
1583 case TRUTH_ORIF_EXPR
:
1584 e4
= gfc_or (e3
, e1
);
1587 e4
= gfc_eqv (e3
, e1
);
1590 e4
= gfc_neqv (e3
, e1
);
1608 if (n
->udr
->combiner
->op
== EXEC_ASSIGN
)
1611 e3
= gfc_copy_expr (n
->udr
->combiner
->expr1
);
1612 e4
= gfc_copy_expr (n
->udr
->combiner
->expr2
);
1613 t
= gfc_resolve_expr (e3
);
1615 t
= gfc_resolve_expr (e4
);
1624 memset (&intrinsic_sym
, 0, sizeof (intrinsic_sym
));
1625 intrinsic_sym
.ns
= sym
->ns
;
1626 intrinsic_sym
.name
= iname
;
1627 intrinsic_sym
.ts
= sym
->ts
;
1628 intrinsic_sym
.attr
.referenced
= 1;
1629 intrinsic_sym
.attr
.intrinsic
= 1;
1630 intrinsic_sym
.attr
.function
= 1;
1631 intrinsic_sym
.attr
.implicit_type
= 1;
1632 intrinsic_sym
.result
= &intrinsic_sym
;
1633 intrinsic_sym
.declared_at
= where
;
1635 symtree4
= gfc_new_symtree (&root4
, iname
);
1636 symtree4
->n
.sym
= &intrinsic_sym
;
1637 gcc_assert (symtree4
== root4
);
1639 e4
= gfc_get_expr ();
1640 e4
->expr_type
= EXPR_FUNCTION
;
1642 e4
->symtree
= symtree4
;
1643 e4
->value
.function
.actual
= gfc_get_actual_arglist ();
1644 e4
->value
.function
.actual
->expr
= e3
;
1645 e4
->value
.function
.actual
->next
= gfc_get_actual_arglist ();
1646 e4
->value
.function
.actual
->next
->expr
= e1
;
1648 if (OMP_CLAUSE_REDUCTION_CODE (c
) != ERROR_MARK
)
1650 /* e1 and e3 have been stored as arguments of e4, avoid sharing. */
1651 e1
= gfc_copy_expr (e1
);
1652 e3
= gfc_copy_expr (e3
);
1653 t
= gfc_resolve_expr (e4
);
1657 /* Create the init statement list. */
1660 stmt
= gfc_trans_assignment (e1
, e2
, false, false);
1662 stmt
= gfc_trans_call (n
->udr
->initializer
, false,
1663 NULL_TREE
, NULL_TREE
, false);
1664 if (TREE_CODE (stmt
) != BIND_EXPR
)
1665 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
1668 OMP_CLAUSE_REDUCTION_INIT (c
) = stmt
;
1670 /* Create the merge statement list. */
1673 stmt
= gfc_trans_assignment (e3
, e4
, false, true);
1675 stmt
= gfc_trans_call (n
->udr
->combiner
, false,
1676 NULL_TREE
, NULL_TREE
, false);
1677 if (TREE_CODE (stmt
) != BIND_EXPR
)
1678 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
1681 OMP_CLAUSE_REDUCTION_MERGE (c
) = stmt
;
1683 /* And stick the placeholder VAR_DECL into the clause as well. */
1684 OMP_CLAUSE_REDUCTION_PLACEHOLDER (c
) = outer_decl
;
1686 gfc_current_locus
= old_loc
;
1699 gfc_free_array_spec (outer_sym
.as
);
1703 *udr
->omp_out
= omp_var_copy
[0];
1704 *udr
->omp_in
= omp_var_copy
[1];
1705 if (udr
->initializer_ns
)
1707 *udr
->omp_priv
= omp_var_copy
[2];
1708 *udr
->omp_orig
= omp_var_copy
[3];
1714 gfc_trans_omp_reduction_list (gfc_omp_namelist
*namelist
, tree list
,
1715 locus where
, bool mark_addressable
)
1717 for (; namelist
!= NULL
; namelist
= namelist
->next
)
1718 if (namelist
->sym
->attr
.referenced
)
1720 tree t
= gfc_trans_omp_variable (namelist
->sym
, false);
1721 if (t
!= error_mark_node
)
1723 tree node
= build_omp_clause (where
.lb
->location
,
1724 OMP_CLAUSE_REDUCTION
);
1725 OMP_CLAUSE_DECL (node
) = t
;
1726 if (mark_addressable
)
1727 TREE_ADDRESSABLE (t
) = 1;
1728 switch (namelist
->u
.reduction_op
)
1730 case OMP_REDUCTION_PLUS
:
1731 OMP_CLAUSE_REDUCTION_CODE (node
) = PLUS_EXPR
;
1733 case OMP_REDUCTION_MINUS
:
1734 OMP_CLAUSE_REDUCTION_CODE (node
) = MINUS_EXPR
;
1736 case OMP_REDUCTION_TIMES
:
1737 OMP_CLAUSE_REDUCTION_CODE (node
) = MULT_EXPR
;
1739 case OMP_REDUCTION_AND
:
1740 OMP_CLAUSE_REDUCTION_CODE (node
) = TRUTH_ANDIF_EXPR
;
1742 case OMP_REDUCTION_OR
:
1743 OMP_CLAUSE_REDUCTION_CODE (node
) = TRUTH_ORIF_EXPR
;
1745 case OMP_REDUCTION_EQV
:
1746 OMP_CLAUSE_REDUCTION_CODE (node
) = EQ_EXPR
;
1748 case OMP_REDUCTION_NEQV
:
1749 OMP_CLAUSE_REDUCTION_CODE (node
) = NE_EXPR
;
1751 case OMP_REDUCTION_MAX
:
1752 OMP_CLAUSE_REDUCTION_CODE (node
) = MAX_EXPR
;
1754 case OMP_REDUCTION_MIN
:
1755 OMP_CLAUSE_REDUCTION_CODE (node
) = MIN_EXPR
;
1757 case OMP_REDUCTION_IAND
:
1758 OMP_CLAUSE_REDUCTION_CODE (node
) = BIT_AND_EXPR
;
1760 case OMP_REDUCTION_IOR
:
1761 OMP_CLAUSE_REDUCTION_CODE (node
) = BIT_IOR_EXPR
;
1763 case OMP_REDUCTION_IEOR
:
1764 OMP_CLAUSE_REDUCTION_CODE (node
) = BIT_XOR_EXPR
;
1766 case OMP_REDUCTION_USER
:
1767 OMP_CLAUSE_REDUCTION_CODE (node
) = ERROR_MARK
;
1772 if (namelist
->sym
->attr
.dimension
1773 || namelist
->u
.reduction_op
== OMP_REDUCTION_USER
1774 || namelist
->sym
->attr
.allocatable
)
1775 gfc_trans_omp_array_reduction_or_udr (node
, namelist
, where
);
1776 list
= gfc_trans_add_clause (node
, list
);
1783 gfc_convert_expr_to_tree (stmtblock_t
*block
, gfc_expr
*expr
)
1788 gfc_init_se (&se
, NULL
);
1789 gfc_conv_expr (&se
, expr
);
1790 gfc_add_block_to_block (block
, &se
.pre
);
1791 result
= gfc_evaluate_now (se
.expr
, block
);
1792 gfc_add_block_to_block (block
, &se
.post
);
1797 static vec
<tree
, va_heap
, vl_embed
> *doacross_steps
;
1800 gfc_trans_omp_clauses (stmtblock_t
*block
, gfc_omp_clauses
*clauses
,
1801 locus where
, bool declare_simd
= false)
1803 tree omp_clauses
= NULL_TREE
, chunk_size
, c
;
1805 enum omp_clause_code clause_code
;
1808 if (clauses
== NULL
)
1811 for (list
= 0; list
< OMP_LIST_NUM
; list
++)
1813 gfc_omp_namelist
*n
= clauses
->lists
[list
];
1819 case OMP_LIST_REDUCTION
:
1820 /* An OpenACC async clause indicates the need to set reduction
1821 arguments addressable, to allow asynchronous copy-out. */
1822 omp_clauses
= gfc_trans_omp_reduction_list (n
, omp_clauses
, where
,
1825 case OMP_LIST_PRIVATE
:
1826 clause_code
= OMP_CLAUSE_PRIVATE
;
1828 case OMP_LIST_SHARED
:
1829 clause_code
= OMP_CLAUSE_SHARED
;
1831 case OMP_LIST_FIRSTPRIVATE
:
1832 clause_code
= OMP_CLAUSE_FIRSTPRIVATE
;
1834 case OMP_LIST_LASTPRIVATE
:
1835 clause_code
= OMP_CLAUSE_LASTPRIVATE
;
1837 case OMP_LIST_COPYIN
:
1838 clause_code
= OMP_CLAUSE_COPYIN
;
1840 case OMP_LIST_COPYPRIVATE
:
1841 clause_code
= OMP_CLAUSE_COPYPRIVATE
;
1843 case OMP_LIST_UNIFORM
:
1844 clause_code
= OMP_CLAUSE_UNIFORM
;
1846 case OMP_LIST_USE_DEVICE
:
1847 case OMP_LIST_USE_DEVICE_PTR
:
1848 clause_code
= OMP_CLAUSE_USE_DEVICE_PTR
;
1850 case OMP_LIST_IS_DEVICE_PTR
:
1851 clause_code
= OMP_CLAUSE_IS_DEVICE_PTR
;
1856 = gfc_trans_omp_variable_list (clause_code
, n
, omp_clauses
,
1859 case OMP_LIST_ALIGNED
:
1860 for (; n
!= NULL
; n
= n
->next
)
1861 if (n
->sym
->attr
.referenced
|| declare_simd
)
1863 tree t
= gfc_trans_omp_variable (n
->sym
, declare_simd
);
1864 if (t
!= error_mark_node
)
1866 tree node
= build_omp_clause (input_location
,
1867 OMP_CLAUSE_ALIGNED
);
1868 OMP_CLAUSE_DECL (node
) = t
;
1874 alignment_var
= gfc_conv_constant_to_tree (n
->expr
);
1877 gfc_init_se (&se
, NULL
);
1878 gfc_conv_expr (&se
, n
->expr
);
1879 gfc_add_block_to_block (block
, &se
.pre
);
1880 alignment_var
= gfc_evaluate_now (se
.expr
, block
);
1881 gfc_add_block_to_block (block
, &se
.post
);
1883 OMP_CLAUSE_ALIGNED_ALIGNMENT (node
) = alignment_var
;
1885 omp_clauses
= gfc_trans_add_clause (node
, omp_clauses
);
1889 case OMP_LIST_LINEAR
:
1891 gfc_expr
*last_step_expr
= NULL
;
1892 tree last_step
= NULL_TREE
;
1893 bool last_step_parm
= false;
1895 for (; n
!= NULL
; n
= n
->next
)
1899 last_step_expr
= n
->expr
;
1900 last_step
= NULL_TREE
;
1901 last_step_parm
= false;
1903 if (n
->sym
->attr
.referenced
|| declare_simd
)
1905 tree t
= gfc_trans_omp_variable (n
->sym
, declare_simd
);
1906 if (t
!= error_mark_node
)
1908 tree node
= build_omp_clause (input_location
,
1910 OMP_CLAUSE_DECL (node
) = t
;
1911 omp_clause_linear_kind kind
;
1912 switch (n
->u
.linear_op
)
1914 case OMP_LINEAR_DEFAULT
:
1915 kind
= OMP_CLAUSE_LINEAR_DEFAULT
;
1917 case OMP_LINEAR_REF
:
1918 kind
= OMP_CLAUSE_LINEAR_REF
;
1920 case OMP_LINEAR_VAL
:
1921 kind
= OMP_CLAUSE_LINEAR_VAL
;
1923 case OMP_LINEAR_UVAL
:
1924 kind
= OMP_CLAUSE_LINEAR_UVAL
;
1929 OMP_CLAUSE_LINEAR_KIND (node
) = kind
;
1930 if (last_step_expr
&& last_step
== NULL_TREE
)
1934 gfc_init_se (&se
, NULL
);
1935 gfc_conv_expr (&se
, last_step_expr
);
1936 gfc_add_block_to_block (block
, &se
.pre
);
1937 last_step
= gfc_evaluate_now (se
.expr
, block
);
1938 gfc_add_block_to_block (block
, &se
.post
);
1940 else if (last_step_expr
->expr_type
== EXPR_VARIABLE
)
1942 gfc_symbol
*s
= last_step_expr
->symtree
->n
.sym
;
1943 last_step
= gfc_trans_omp_variable (s
, true);
1944 last_step_parm
= true;
1948 = gfc_conv_constant_to_tree (last_step_expr
);
1952 OMP_CLAUSE_LINEAR_VARIABLE_STRIDE (node
) = 1;
1953 OMP_CLAUSE_LINEAR_STEP (node
) = last_step
;
1957 if (kind
== OMP_CLAUSE_LINEAR_REF
)
1960 if (n
->sym
->attr
.flavor
== FL_PROCEDURE
)
1962 type
= gfc_get_function_type (n
->sym
);
1963 type
= build_pointer_type (type
);
1966 type
= gfc_sym_type (n
->sym
);
1967 if (POINTER_TYPE_P (type
))
1968 type
= TREE_TYPE (type
);
1969 /* Otherwise to be determined what exactly
1971 tree t
= fold_convert (sizetype
, last_step
);
1972 t
= size_binop (MULT_EXPR
, t
,
1973 TYPE_SIZE_UNIT (type
));
1974 OMP_CLAUSE_LINEAR_STEP (node
) = t
;
1979 = gfc_typenode_for_spec (&n
->sym
->ts
);
1980 OMP_CLAUSE_LINEAR_STEP (node
)
1981 = fold_convert (type
, last_step
);
1984 if (n
->sym
->attr
.dimension
|| n
->sym
->attr
.allocatable
)
1985 OMP_CLAUSE_LINEAR_ARRAY (node
) = 1;
1986 omp_clauses
= gfc_trans_add_clause (node
, omp_clauses
);
1992 case OMP_LIST_DEPEND
:
1993 for (; n
!= NULL
; n
= n
->next
)
1995 if (n
->u
.depend_op
== OMP_DEPEND_SINK_FIRST
)
1997 tree vec
= NULL_TREE
;
2001 tree addend
= integer_zero_node
, t
;
2005 addend
= gfc_conv_constant_to_tree (n
->expr
);
2006 if (TREE_CODE (addend
) == INTEGER_CST
2007 && tree_int_cst_sgn (addend
) == -1)
2010 addend
= const_unop (NEGATE_EXPR
,
2011 TREE_TYPE (addend
), addend
);
2014 t
= gfc_trans_omp_variable (n
->sym
, false);
2015 if (t
!= error_mark_node
)
2017 if (i
< vec_safe_length (doacross_steps
)
2018 && !integer_zerop (addend
)
2019 && (*doacross_steps
)[i
])
2021 tree step
= (*doacross_steps
)[i
];
2022 addend
= fold_convert (TREE_TYPE (step
), addend
);
2023 addend
= build2 (TRUNC_DIV_EXPR
,
2024 TREE_TYPE (step
), addend
, step
);
2026 vec
= tree_cons (addend
, t
, vec
);
2028 OMP_CLAUSE_DEPEND_SINK_NEGATIVE (vec
) = 1;
2031 || n
->next
->u
.depend_op
!= OMP_DEPEND_SINK
)
2035 if (vec
== NULL_TREE
)
2038 tree node
= build_omp_clause (input_location
,
2040 OMP_CLAUSE_DEPEND_KIND (node
) = OMP_CLAUSE_DEPEND_SINK
;
2041 OMP_CLAUSE_DECL (node
) = nreverse (vec
);
2042 omp_clauses
= gfc_trans_add_clause (node
, omp_clauses
);
2046 if (!n
->sym
->attr
.referenced
)
2049 tree node
= build_omp_clause (input_location
, OMP_CLAUSE_DEPEND
);
2050 if (n
->expr
== NULL
|| n
->expr
->ref
->u
.ar
.type
== AR_FULL
)
2052 tree decl
= gfc_get_symbol_decl (n
->sym
);
2053 if (gfc_omp_privatize_by_reference (decl
))
2054 decl
= build_fold_indirect_ref (decl
);
2055 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
)))
2057 decl
= gfc_conv_descriptor_data_get (decl
);
2058 decl
= fold_convert (build_pointer_type (char_type_node
),
2060 decl
= build_fold_indirect_ref (decl
);
2062 else if (DECL_P (decl
))
2063 TREE_ADDRESSABLE (decl
) = 1;
2064 OMP_CLAUSE_DECL (node
) = decl
;
2069 gfc_init_se (&se
, NULL
);
2070 if (n
->expr
->ref
->u
.ar
.type
== AR_ELEMENT
)
2072 gfc_conv_expr_reference (&se
, n
->expr
);
2077 gfc_conv_expr_descriptor (&se
, n
->expr
);
2078 ptr
= gfc_conv_array_data (se
.expr
);
2080 gfc_add_block_to_block (block
, &se
.pre
);
2081 gfc_add_block_to_block (block
, &se
.post
);
2082 ptr
= fold_convert (build_pointer_type (char_type_node
),
2084 OMP_CLAUSE_DECL (node
) = build_fold_indirect_ref (ptr
);
2086 switch (n
->u
.depend_op
)
2089 OMP_CLAUSE_DEPEND_KIND (node
) = OMP_CLAUSE_DEPEND_IN
;
2091 case OMP_DEPEND_OUT
:
2092 OMP_CLAUSE_DEPEND_KIND (node
) = OMP_CLAUSE_DEPEND_OUT
;
2094 case OMP_DEPEND_INOUT
:
2095 OMP_CLAUSE_DEPEND_KIND (node
) = OMP_CLAUSE_DEPEND_INOUT
;
2100 omp_clauses
= gfc_trans_add_clause (node
, omp_clauses
);
2104 for (; n
!= NULL
; n
= n
->next
)
2106 if (!n
->sym
->attr
.referenced
)
2109 tree node
= build_omp_clause (input_location
, OMP_CLAUSE_MAP
);
2110 tree node2
= NULL_TREE
;
2111 tree node3
= NULL_TREE
;
2112 tree node4
= NULL_TREE
;
2113 tree decl
= gfc_get_symbol_decl (n
->sym
);
2115 TREE_ADDRESSABLE (decl
) = 1;
2116 if (n
->expr
== NULL
|| n
->expr
->ref
->u
.ar
.type
== AR_FULL
)
2118 if (POINTER_TYPE_P (TREE_TYPE (decl
))
2119 && (gfc_omp_privatize_by_reference (decl
)
2120 || GFC_DECL_GET_SCALAR_POINTER (decl
)
2121 || GFC_DECL_GET_SCALAR_ALLOCATABLE (decl
)
2122 || GFC_DECL_CRAY_POINTEE (decl
)
2123 || GFC_DESCRIPTOR_TYPE_P
2124 (TREE_TYPE (TREE_TYPE (decl
)))))
2126 tree orig_decl
= decl
;
2127 node4
= build_omp_clause (input_location
,
2129 OMP_CLAUSE_SET_MAP_KIND (node4
, GOMP_MAP_POINTER
);
2130 OMP_CLAUSE_DECL (node4
) = decl
;
2131 OMP_CLAUSE_SIZE (node4
) = size_int (0);
2132 decl
= build_fold_indirect_ref (decl
);
2133 if (TREE_CODE (TREE_TYPE (orig_decl
)) == REFERENCE_TYPE
2134 && (GFC_DECL_GET_SCALAR_POINTER (orig_decl
)
2135 || GFC_DECL_GET_SCALAR_ALLOCATABLE (orig_decl
)))
2137 node3
= build_omp_clause (input_location
,
2139 OMP_CLAUSE_SET_MAP_KIND (node3
, GOMP_MAP_POINTER
);
2140 OMP_CLAUSE_DECL (node3
) = decl
;
2141 OMP_CLAUSE_SIZE (node3
) = size_int (0);
2142 decl
= build_fold_indirect_ref (decl
);
2145 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
)))
2147 tree type
= TREE_TYPE (decl
);
2148 tree ptr
= gfc_conv_descriptor_data_get (decl
);
2149 ptr
= fold_convert (build_pointer_type (char_type_node
),
2151 ptr
= build_fold_indirect_ref (ptr
);
2152 OMP_CLAUSE_DECL (node
) = ptr
;
2153 node2
= build_omp_clause (input_location
,
2155 OMP_CLAUSE_SET_MAP_KIND (node2
, GOMP_MAP_TO_PSET
);
2156 OMP_CLAUSE_DECL (node2
) = decl
;
2157 OMP_CLAUSE_SIZE (node2
) = TYPE_SIZE_UNIT (type
);
2158 node3
= build_omp_clause (input_location
,
2160 OMP_CLAUSE_SET_MAP_KIND (node3
, GOMP_MAP_POINTER
);
2161 OMP_CLAUSE_DECL (node3
)
2162 = gfc_conv_descriptor_data_get (decl
);
2163 OMP_CLAUSE_SIZE (node3
) = size_int (0);
2165 /* We have to check for n->sym->attr.dimension because
2166 of scalar coarrays. */
2167 if (n
->sym
->attr
.pointer
&& n
->sym
->attr
.dimension
)
2169 stmtblock_t cond_block
;
2171 = gfc_create_var (gfc_array_index_type
, NULL
);
2172 tree tem
, then_b
, else_b
, zero
, cond
;
2174 gfc_init_block (&cond_block
);
2176 = gfc_full_array_size (&cond_block
, decl
,
2177 GFC_TYPE_ARRAY_RANK (type
));
2178 gfc_add_modify (&cond_block
, size
, tem
);
2179 then_b
= gfc_finish_block (&cond_block
);
2180 gfc_init_block (&cond_block
);
2181 zero
= build_int_cst (gfc_array_index_type
, 0);
2182 gfc_add_modify (&cond_block
, size
, zero
);
2183 else_b
= gfc_finish_block (&cond_block
);
2184 tem
= gfc_conv_descriptor_data_get (decl
);
2185 tem
= fold_convert (pvoid_type_node
, tem
);
2186 cond
= fold_build2_loc (input_location
, NE_EXPR
,
2188 tem
, null_pointer_node
);
2189 gfc_add_expr_to_block (block
,
2190 build3_loc (input_location
,
2195 OMP_CLAUSE_SIZE (node
) = size
;
2197 else if (n
->sym
->attr
.dimension
)
2198 OMP_CLAUSE_SIZE (node
)
2199 = gfc_full_array_size (block
, decl
,
2200 GFC_TYPE_ARRAY_RANK (type
));
2201 if (n
->sym
->attr
.dimension
)
2204 = TYPE_SIZE_UNIT (gfc_get_element_type (type
));
2205 elemsz
= fold_convert (gfc_array_index_type
, elemsz
);
2206 OMP_CLAUSE_SIZE (node
)
2207 = fold_build2 (MULT_EXPR
, gfc_array_index_type
,
2208 OMP_CLAUSE_SIZE (node
), elemsz
);
2212 OMP_CLAUSE_DECL (node
) = decl
;
2217 gfc_init_se (&se
, NULL
);
2218 if (n
->expr
->ref
->u
.ar
.type
== AR_ELEMENT
)
2220 gfc_conv_expr_reference (&se
, n
->expr
);
2221 gfc_add_block_to_block (block
, &se
.pre
);
2223 OMP_CLAUSE_SIZE (node
)
2224 = TYPE_SIZE_UNIT (TREE_TYPE (ptr
));
2228 gfc_conv_expr_descriptor (&se
, n
->expr
);
2229 ptr
= gfc_conv_array_data (se
.expr
);
2230 tree type
= TREE_TYPE (se
.expr
);
2231 gfc_add_block_to_block (block
, &se
.pre
);
2232 OMP_CLAUSE_SIZE (node
)
2233 = gfc_full_array_size (block
, se
.expr
,
2234 GFC_TYPE_ARRAY_RANK (type
));
2236 = TYPE_SIZE_UNIT (gfc_get_element_type (type
));
2237 elemsz
= fold_convert (gfc_array_index_type
, elemsz
);
2238 OMP_CLAUSE_SIZE (node
)
2239 = fold_build2 (MULT_EXPR
, gfc_array_index_type
,
2240 OMP_CLAUSE_SIZE (node
), elemsz
);
2242 gfc_add_block_to_block (block
, &se
.post
);
2243 ptr
= fold_convert (build_pointer_type (char_type_node
),
2245 OMP_CLAUSE_DECL (node
) = build_fold_indirect_ref (ptr
);
2247 if (POINTER_TYPE_P (TREE_TYPE (decl
))
2248 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (decl
))))
2250 node4
= build_omp_clause (input_location
,
2252 OMP_CLAUSE_SET_MAP_KIND (node4
, GOMP_MAP_POINTER
);
2253 OMP_CLAUSE_DECL (node4
) = decl
;
2254 OMP_CLAUSE_SIZE (node4
) = size_int (0);
2255 decl
= build_fold_indirect_ref (decl
);
2257 ptr
= fold_convert (sizetype
, ptr
);
2258 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
)))
2260 tree type
= TREE_TYPE (decl
);
2261 ptr2
= gfc_conv_descriptor_data_get (decl
);
2262 node2
= build_omp_clause (input_location
,
2264 OMP_CLAUSE_SET_MAP_KIND (node2
, GOMP_MAP_TO_PSET
);
2265 OMP_CLAUSE_DECL (node2
) = decl
;
2266 OMP_CLAUSE_SIZE (node2
) = TYPE_SIZE_UNIT (type
);
2267 node3
= build_omp_clause (input_location
,
2269 OMP_CLAUSE_SET_MAP_KIND (node3
, GOMP_MAP_POINTER
);
2270 OMP_CLAUSE_DECL (node3
)
2271 = gfc_conv_descriptor_data_get (decl
);
2275 if (TREE_CODE (TREE_TYPE (decl
)) == ARRAY_TYPE
)
2276 ptr2
= build_fold_addr_expr (decl
);
2279 gcc_assert (POINTER_TYPE_P (TREE_TYPE (decl
)));
2282 node3
= build_omp_clause (input_location
,
2284 OMP_CLAUSE_SET_MAP_KIND (node3
, GOMP_MAP_POINTER
);
2285 OMP_CLAUSE_DECL (node3
) = decl
;
2287 ptr2
= fold_convert (sizetype
, ptr2
);
2288 OMP_CLAUSE_SIZE (node3
)
2289 = fold_build2 (MINUS_EXPR
, sizetype
, ptr
, ptr2
);
2291 switch (n
->u
.map_op
)
2294 OMP_CLAUSE_SET_MAP_KIND (node
, GOMP_MAP_ALLOC
);
2297 OMP_CLAUSE_SET_MAP_KIND (node
, GOMP_MAP_TO
);
2300 OMP_CLAUSE_SET_MAP_KIND (node
, GOMP_MAP_FROM
);
2302 case OMP_MAP_TOFROM
:
2303 OMP_CLAUSE_SET_MAP_KIND (node
, GOMP_MAP_TOFROM
);
2305 case OMP_MAP_ALWAYS_TO
:
2306 OMP_CLAUSE_SET_MAP_KIND (node
, GOMP_MAP_ALWAYS_TO
);
2308 case OMP_MAP_ALWAYS_FROM
:
2309 OMP_CLAUSE_SET_MAP_KIND (node
, GOMP_MAP_ALWAYS_FROM
);
2311 case OMP_MAP_ALWAYS_TOFROM
:
2312 OMP_CLAUSE_SET_MAP_KIND (node
, GOMP_MAP_ALWAYS_TOFROM
);
2314 case OMP_MAP_RELEASE
:
2315 OMP_CLAUSE_SET_MAP_KIND (node
, GOMP_MAP_RELEASE
);
2317 case OMP_MAP_DELETE
:
2318 OMP_CLAUSE_SET_MAP_KIND (node
, GOMP_MAP_DELETE
);
2320 case OMP_MAP_FORCE_ALLOC
:
2321 OMP_CLAUSE_SET_MAP_KIND (node
, GOMP_MAP_FORCE_ALLOC
);
2323 case OMP_MAP_FORCE_TO
:
2324 OMP_CLAUSE_SET_MAP_KIND (node
, GOMP_MAP_FORCE_TO
);
2326 case OMP_MAP_FORCE_FROM
:
2327 OMP_CLAUSE_SET_MAP_KIND (node
, GOMP_MAP_FORCE_FROM
);
2329 case OMP_MAP_FORCE_TOFROM
:
2330 OMP_CLAUSE_SET_MAP_KIND (node
, GOMP_MAP_FORCE_TOFROM
);
2332 case OMP_MAP_FORCE_PRESENT
:
2333 OMP_CLAUSE_SET_MAP_KIND (node
, GOMP_MAP_FORCE_PRESENT
);
2335 case OMP_MAP_FORCE_DEVICEPTR
:
2336 OMP_CLAUSE_SET_MAP_KIND (node
, GOMP_MAP_FORCE_DEVICEPTR
);
2341 omp_clauses
= gfc_trans_add_clause (node
, omp_clauses
);
2343 omp_clauses
= gfc_trans_add_clause (node2
, omp_clauses
);
2345 omp_clauses
= gfc_trans_add_clause (node3
, omp_clauses
);
2347 omp_clauses
= gfc_trans_add_clause (node4
, omp_clauses
);
2352 case OMP_LIST_CACHE
:
2353 for (; n
!= NULL
; n
= n
->next
)
2355 if (!n
->sym
->attr
.referenced
)
2361 clause_code
= OMP_CLAUSE_TO
;
2364 clause_code
= OMP_CLAUSE_FROM
;
2366 case OMP_LIST_CACHE
:
2367 clause_code
= OMP_CLAUSE__CACHE_
;
2372 tree node
= build_omp_clause (input_location
, clause_code
);
2373 if (n
->expr
== NULL
|| n
->expr
->ref
->u
.ar
.type
== AR_FULL
)
2375 tree decl
= gfc_get_symbol_decl (n
->sym
);
2376 if (gfc_omp_privatize_by_reference (decl
))
2377 decl
= build_fold_indirect_ref (decl
);
2378 else if (DECL_P (decl
))
2379 TREE_ADDRESSABLE (decl
) = 1;
2380 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
)))
2382 tree type
= TREE_TYPE (decl
);
2383 tree ptr
= gfc_conv_descriptor_data_get (decl
);
2384 ptr
= fold_convert (build_pointer_type (char_type_node
),
2386 ptr
= build_fold_indirect_ref (ptr
);
2387 OMP_CLAUSE_DECL (node
) = ptr
;
2388 OMP_CLAUSE_SIZE (node
)
2389 = gfc_full_array_size (block
, decl
,
2390 GFC_TYPE_ARRAY_RANK (type
));
2392 = TYPE_SIZE_UNIT (gfc_get_element_type (type
));
2393 elemsz
= fold_convert (gfc_array_index_type
, elemsz
);
2394 OMP_CLAUSE_SIZE (node
)
2395 = fold_build2 (MULT_EXPR
, gfc_array_index_type
,
2396 OMP_CLAUSE_SIZE (node
), elemsz
);
2399 OMP_CLAUSE_DECL (node
) = decl
;
2404 gfc_init_se (&se
, NULL
);
2405 if (n
->expr
->ref
->u
.ar
.type
== AR_ELEMENT
)
2407 gfc_conv_expr_reference (&se
, n
->expr
);
2409 gfc_add_block_to_block (block
, &se
.pre
);
2410 OMP_CLAUSE_SIZE (node
)
2411 = TYPE_SIZE_UNIT (TREE_TYPE (ptr
));
2415 gfc_conv_expr_descriptor (&se
, n
->expr
);
2416 ptr
= gfc_conv_array_data (se
.expr
);
2417 tree type
= TREE_TYPE (se
.expr
);
2418 gfc_add_block_to_block (block
, &se
.pre
);
2419 OMP_CLAUSE_SIZE (node
)
2420 = gfc_full_array_size (block
, se
.expr
,
2421 GFC_TYPE_ARRAY_RANK (type
));
2423 = TYPE_SIZE_UNIT (gfc_get_element_type (type
));
2424 elemsz
= fold_convert (gfc_array_index_type
, elemsz
);
2425 OMP_CLAUSE_SIZE (node
)
2426 = fold_build2 (MULT_EXPR
, gfc_array_index_type
,
2427 OMP_CLAUSE_SIZE (node
), elemsz
);
2429 gfc_add_block_to_block (block
, &se
.post
);
2430 ptr
= fold_convert (build_pointer_type (char_type_node
),
2432 OMP_CLAUSE_DECL (node
) = build_fold_indirect_ref (ptr
);
2434 omp_clauses
= gfc_trans_add_clause (node
, omp_clauses
);
2442 if (clauses
->if_expr
)
2446 gfc_init_se (&se
, NULL
);
2447 gfc_conv_expr (&se
, clauses
->if_expr
);
2448 gfc_add_block_to_block (block
, &se
.pre
);
2449 if_var
= gfc_evaluate_now (se
.expr
, block
);
2450 gfc_add_block_to_block (block
, &se
.post
);
2452 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_IF
);
2453 OMP_CLAUSE_IF_MODIFIER (c
) = ERROR_MARK
;
2454 OMP_CLAUSE_IF_EXPR (c
) = if_var
;
2455 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
2457 for (ifc
= 0; ifc
< OMP_IF_LAST
; ifc
++)
2458 if (clauses
->if_exprs
[ifc
])
2462 gfc_init_se (&se
, NULL
);
2463 gfc_conv_expr (&se
, clauses
->if_exprs
[ifc
]);
2464 gfc_add_block_to_block (block
, &se
.pre
);
2465 if_var
= gfc_evaluate_now (se
.expr
, block
);
2466 gfc_add_block_to_block (block
, &se
.post
);
2468 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_IF
);
2471 case OMP_IF_PARALLEL
:
2472 OMP_CLAUSE_IF_MODIFIER (c
) = OMP_PARALLEL
;
2475 OMP_CLAUSE_IF_MODIFIER (c
) = OMP_TASK
;
2477 case OMP_IF_TASKLOOP
:
2478 OMP_CLAUSE_IF_MODIFIER (c
) = OMP_TASKLOOP
;
2481 OMP_CLAUSE_IF_MODIFIER (c
) = OMP_TARGET
;
2483 case OMP_IF_TARGET_DATA
:
2484 OMP_CLAUSE_IF_MODIFIER (c
) = OMP_TARGET_DATA
;
2486 case OMP_IF_TARGET_UPDATE
:
2487 OMP_CLAUSE_IF_MODIFIER (c
) = OMP_TARGET_UPDATE
;
2489 case OMP_IF_TARGET_ENTER_DATA
:
2490 OMP_CLAUSE_IF_MODIFIER (c
) = OMP_TARGET_ENTER_DATA
;
2492 case OMP_IF_TARGET_EXIT_DATA
:
2493 OMP_CLAUSE_IF_MODIFIER (c
) = OMP_TARGET_EXIT_DATA
;
2498 OMP_CLAUSE_IF_EXPR (c
) = if_var
;
2499 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
2502 if (clauses
->final_expr
)
2506 gfc_init_se (&se
, NULL
);
2507 gfc_conv_expr (&se
, clauses
->final_expr
);
2508 gfc_add_block_to_block (block
, &se
.pre
);
2509 final_var
= gfc_evaluate_now (se
.expr
, block
);
2510 gfc_add_block_to_block (block
, &se
.post
);
2512 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_FINAL
);
2513 OMP_CLAUSE_FINAL_EXPR (c
) = final_var
;
2514 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
2517 if (clauses
->num_threads
)
2521 gfc_init_se (&se
, NULL
);
2522 gfc_conv_expr (&se
, clauses
->num_threads
);
2523 gfc_add_block_to_block (block
, &se
.pre
);
2524 num_threads
= gfc_evaluate_now (se
.expr
, block
);
2525 gfc_add_block_to_block (block
, &se
.post
);
2527 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_NUM_THREADS
);
2528 OMP_CLAUSE_NUM_THREADS_EXPR (c
) = num_threads
;
2529 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
2532 chunk_size
= NULL_TREE
;
2533 if (clauses
->chunk_size
)
2535 gfc_init_se (&se
, NULL
);
2536 gfc_conv_expr (&se
, clauses
->chunk_size
);
2537 gfc_add_block_to_block (block
, &se
.pre
);
2538 chunk_size
= gfc_evaluate_now (se
.expr
, block
);
2539 gfc_add_block_to_block (block
, &se
.post
);
2542 if (clauses
->sched_kind
!= OMP_SCHED_NONE
)
2544 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_SCHEDULE
);
2545 OMP_CLAUSE_SCHEDULE_CHUNK_EXPR (c
) = chunk_size
;
2546 switch (clauses
->sched_kind
)
2548 case OMP_SCHED_STATIC
:
2549 OMP_CLAUSE_SCHEDULE_KIND (c
) = OMP_CLAUSE_SCHEDULE_STATIC
;
2551 case OMP_SCHED_DYNAMIC
:
2552 OMP_CLAUSE_SCHEDULE_KIND (c
) = OMP_CLAUSE_SCHEDULE_DYNAMIC
;
2554 case OMP_SCHED_GUIDED
:
2555 OMP_CLAUSE_SCHEDULE_KIND (c
) = OMP_CLAUSE_SCHEDULE_GUIDED
;
2557 case OMP_SCHED_RUNTIME
:
2558 OMP_CLAUSE_SCHEDULE_KIND (c
) = OMP_CLAUSE_SCHEDULE_RUNTIME
;
2560 case OMP_SCHED_AUTO
:
2561 OMP_CLAUSE_SCHEDULE_KIND (c
) = OMP_CLAUSE_SCHEDULE_AUTO
;
2566 if (clauses
->sched_monotonic
)
2567 OMP_CLAUSE_SCHEDULE_KIND (c
)
2568 = (omp_clause_schedule_kind
) (OMP_CLAUSE_SCHEDULE_KIND (c
)
2569 | OMP_CLAUSE_SCHEDULE_MONOTONIC
);
2570 else if (clauses
->sched_nonmonotonic
)
2571 OMP_CLAUSE_SCHEDULE_KIND (c
)
2572 = (omp_clause_schedule_kind
) (OMP_CLAUSE_SCHEDULE_KIND (c
)
2573 | OMP_CLAUSE_SCHEDULE_NONMONOTONIC
);
2574 if (clauses
->sched_simd
)
2575 OMP_CLAUSE_SCHEDULE_SIMD (c
) = 1;
2576 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
2579 if (clauses
->default_sharing
!= OMP_DEFAULT_UNKNOWN
)
2581 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_DEFAULT
);
2582 switch (clauses
->default_sharing
)
2584 case OMP_DEFAULT_NONE
:
2585 OMP_CLAUSE_DEFAULT_KIND (c
) = OMP_CLAUSE_DEFAULT_NONE
;
2587 case OMP_DEFAULT_SHARED
:
2588 OMP_CLAUSE_DEFAULT_KIND (c
) = OMP_CLAUSE_DEFAULT_SHARED
;
2590 case OMP_DEFAULT_PRIVATE
:
2591 OMP_CLAUSE_DEFAULT_KIND (c
) = OMP_CLAUSE_DEFAULT_PRIVATE
;
2593 case OMP_DEFAULT_FIRSTPRIVATE
:
2594 OMP_CLAUSE_DEFAULT_KIND (c
) = OMP_CLAUSE_DEFAULT_FIRSTPRIVATE
;
2596 case OMP_DEFAULT_PRESENT
:
2597 OMP_CLAUSE_DEFAULT_KIND (c
) = OMP_CLAUSE_DEFAULT_PRESENT
;
2602 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
2605 if (clauses
->nowait
)
2607 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_NOWAIT
);
2608 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
2611 if (clauses
->ordered
)
2613 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_ORDERED
);
2614 OMP_CLAUSE_ORDERED_EXPR (c
)
2615 = clauses
->orderedc
? build_int_cst (integer_type_node
,
2616 clauses
->orderedc
) : NULL_TREE
;
2617 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
2620 if (clauses
->untied
)
2622 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_UNTIED
);
2623 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
2626 if (clauses
->mergeable
)
2628 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_MERGEABLE
);
2629 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
2632 if (clauses
->collapse
)
2634 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_COLLAPSE
);
2635 OMP_CLAUSE_COLLAPSE_EXPR (c
)
2636 = build_int_cst (integer_type_node
, clauses
->collapse
);
2637 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
2640 if (clauses
->inbranch
)
2642 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_INBRANCH
);
2643 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
2646 if (clauses
->notinbranch
)
2648 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_NOTINBRANCH
);
2649 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
2652 switch (clauses
->cancel
)
2654 case OMP_CANCEL_UNKNOWN
:
2656 case OMP_CANCEL_PARALLEL
:
2657 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_PARALLEL
);
2658 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
2660 case OMP_CANCEL_SECTIONS
:
2661 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_SECTIONS
);
2662 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
2665 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_FOR
);
2666 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
2668 case OMP_CANCEL_TASKGROUP
:
2669 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_TASKGROUP
);
2670 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
2674 if (clauses
->proc_bind
!= OMP_PROC_BIND_UNKNOWN
)
2676 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_PROC_BIND
);
2677 switch (clauses
->proc_bind
)
2679 case OMP_PROC_BIND_MASTER
:
2680 OMP_CLAUSE_PROC_BIND_KIND (c
) = OMP_CLAUSE_PROC_BIND_MASTER
;
2682 case OMP_PROC_BIND_SPREAD
:
2683 OMP_CLAUSE_PROC_BIND_KIND (c
) = OMP_CLAUSE_PROC_BIND_SPREAD
;
2685 case OMP_PROC_BIND_CLOSE
:
2686 OMP_CLAUSE_PROC_BIND_KIND (c
) = OMP_CLAUSE_PROC_BIND_CLOSE
;
2691 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
2694 if (clauses
->safelen_expr
)
2698 gfc_init_se (&se
, NULL
);
2699 gfc_conv_expr (&se
, clauses
->safelen_expr
);
2700 gfc_add_block_to_block (block
, &se
.pre
);
2701 safelen_var
= gfc_evaluate_now (se
.expr
, block
);
2702 gfc_add_block_to_block (block
, &se
.post
);
2704 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_SAFELEN
);
2705 OMP_CLAUSE_SAFELEN_EXPR (c
) = safelen_var
;
2706 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
2709 if (clauses
->simdlen_expr
)
2713 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_SIMDLEN
);
2714 OMP_CLAUSE_SIMDLEN_EXPR (c
)
2715 = gfc_conv_constant_to_tree (clauses
->simdlen_expr
);
2716 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
2722 gfc_init_se (&se
, NULL
);
2723 gfc_conv_expr (&se
, clauses
->simdlen_expr
);
2724 gfc_add_block_to_block (block
, &se
.pre
);
2725 simdlen_var
= gfc_evaluate_now (se
.expr
, block
);
2726 gfc_add_block_to_block (block
, &se
.post
);
2728 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_SIMDLEN
);
2729 OMP_CLAUSE_SIMDLEN_EXPR (c
) = simdlen_var
;
2730 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
2734 if (clauses
->num_teams
)
2738 gfc_init_se (&se
, NULL
);
2739 gfc_conv_expr (&se
, clauses
->num_teams
);
2740 gfc_add_block_to_block (block
, &se
.pre
);
2741 num_teams
= gfc_evaluate_now (se
.expr
, block
);
2742 gfc_add_block_to_block (block
, &se
.post
);
2744 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_NUM_TEAMS
);
2745 OMP_CLAUSE_NUM_TEAMS_EXPR (c
) = num_teams
;
2746 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
2749 if (clauses
->device
)
2753 gfc_init_se (&se
, NULL
);
2754 gfc_conv_expr (&se
, clauses
->device
);
2755 gfc_add_block_to_block (block
, &se
.pre
);
2756 device
= gfc_evaluate_now (se
.expr
, block
);
2757 gfc_add_block_to_block (block
, &se
.post
);
2759 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_DEVICE
);
2760 OMP_CLAUSE_DEVICE_ID (c
) = device
;
2761 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
2764 if (clauses
->thread_limit
)
2768 gfc_init_se (&se
, NULL
);
2769 gfc_conv_expr (&se
, clauses
->thread_limit
);
2770 gfc_add_block_to_block (block
, &se
.pre
);
2771 thread_limit
= gfc_evaluate_now (se
.expr
, block
);
2772 gfc_add_block_to_block (block
, &se
.post
);
2774 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_THREAD_LIMIT
);
2775 OMP_CLAUSE_THREAD_LIMIT_EXPR (c
) = thread_limit
;
2776 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
2779 chunk_size
= NULL_TREE
;
2780 if (clauses
->dist_chunk_size
)
2782 gfc_init_se (&se
, NULL
);
2783 gfc_conv_expr (&se
, clauses
->dist_chunk_size
);
2784 gfc_add_block_to_block (block
, &se
.pre
);
2785 chunk_size
= gfc_evaluate_now (se
.expr
, block
);
2786 gfc_add_block_to_block (block
, &se
.post
);
2789 if (clauses
->dist_sched_kind
!= OMP_SCHED_NONE
)
2791 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_DIST_SCHEDULE
);
2792 OMP_CLAUSE_DIST_SCHEDULE_CHUNK_EXPR (c
) = chunk_size
;
2793 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
2796 if (clauses
->grainsize
)
2800 gfc_init_se (&se
, NULL
);
2801 gfc_conv_expr (&se
, clauses
->grainsize
);
2802 gfc_add_block_to_block (block
, &se
.pre
);
2803 grainsize
= gfc_evaluate_now (se
.expr
, block
);
2804 gfc_add_block_to_block (block
, &se
.post
);
2806 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_GRAINSIZE
);
2807 OMP_CLAUSE_GRAINSIZE_EXPR (c
) = grainsize
;
2808 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
2811 if (clauses
->num_tasks
)
2815 gfc_init_se (&se
, NULL
);
2816 gfc_conv_expr (&se
, clauses
->num_tasks
);
2817 gfc_add_block_to_block (block
, &se
.pre
);
2818 num_tasks
= gfc_evaluate_now (se
.expr
, block
);
2819 gfc_add_block_to_block (block
, &se
.post
);
2821 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_NUM_TASKS
);
2822 OMP_CLAUSE_NUM_TASKS_EXPR (c
) = num_tasks
;
2823 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
2826 if (clauses
->priority
)
2830 gfc_init_se (&se
, NULL
);
2831 gfc_conv_expr (&se
, clauses
->priority
);
2832 gfc_add_block_to_block (block
, &se
.pre
);
2833 priority
= gfc_evaluate_now (se
.expr
, block
);
2834 gfc_add_block_to_block (block
, &se
.post
);
2836 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_PRIORITY
);
2837 OMP_CLAUSE_PRIORITY_EXPR (c
) = priority
;
2838 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
2845 gfc_init_se (&se
, NULL
);
2846 gfc_conv_expr (&se
, clauses
->hint
);
2847 gfc_add_block_to_block (block
, &se
.pre
);
2848 hint
= gfc_evaluate_now (se
.expr
, block
);
2849 gfc_add_block_to_block (block
, &se
.post
);
2851 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_HINT
);
2852 OMP_CLAUSE_HINT_EXPR (c
) = hint
;
2853 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
2858 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_SIMD
);
2859 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
2861 if (clauses
->threads
)
2863 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_THREADS
);
2864 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
2866 if (clauses
->nogroup
)
2868 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_NOGROUP
);
2869 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
2871 if (clauses
->defaultmap
)
2873 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_DEFAULTMAP
);
2874 OMP_CLAUSE_DEFAULTMAP_SET_KIND (c
, OMP_CLAUSE_DEFAULTMAP_TOFROM
,
2875 OMP_CLAUSE_DEFAULTMAP_CATEGORY_SCALAR
);
2876 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
2878 if (clauses
->depend_source
)
2880 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_DEPEND
);
2881 OMP_CLAUSE_DEPEND_KIND (c
) = OMP_CLAUSE_DEPEND_SOURCE
;
2882 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
2887 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_ASYNC
);
2888 if (clauses
->async_expr
)
2889 OMP_CLAUSE_ASYNC_EXPR (c
)
2890 = gfc_convert_expr_to_tree (block
, clauses
->async_expr
);
2892 OMP_CLAUSE_ASYNC_EXPR (c
) = NULL
;
2893 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
2897 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_SEQ
);
2898 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
2900 if (clauses
->par_auto
)
2902 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_AUTO
);
2903 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
2905 if (clauses
->if_present
)
2907 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_IF_PRESENT
);
2908 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
2910 if (clauses
->finalize
)
2912 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_FINALIZE
);
2913 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
2915 if (clauses
->independent
)
2917 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_INDEPENDENT
);
2918 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
2920 if (clauses
->wait_list
)
2924 for (el
= clauses
->wait_list
; el
; el
= el
->next
)
2926 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_WAIT
);
2927 OMP_CLAUSE_DECL (c
) = gfc_convert_expr_to_tree (block
, el
->expr
);
2928 OMP_CLAUSE_CHAIN (c
) = omp_clauses
;
2932 if (clauses
->num_gangs_expr
)
2935 = gfc_convert_expr_to_tree (block
, clauses
->num_gangs_expr
);
2936 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_NUM_GANGS
);
2937 OMP_CLAUSE_NUM_GANGS_EXPR (c
) = num_gangs_var
;
2938 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
2940 if (clauses
->num_workers_expr
)
2942 tree num_workers_var
2943 = gfc_convert_expr_to_tree (block
, clauses
->num_workers_expr
);
2944 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_NUM_WORKERS
);
2945 OMP_CLAUSE_NUM_WORKERS_EXPR (c
) = num_workers_var
;
2946 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
2948 if (clauses
->vector_length_expr
)
2950 tree vector_length_var
2951 = gfc_convert_expr_to_tree (block
, clauses
->vector_length_expr
);
2952 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_VECTOR_LENGTH
);
2953 OMP_CLAUSE_VECTOR_LENGTH_EXPR (c
) = vector_length_var
;
2954 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
2956 if (clauses
->tile_list
)
2958 vec
<tree
, va_gc
> *tvec
;
2961 vec_alloc (tvec
, 4);
2963 for (el
= clauses
->tile_list
; el
; el
= el
->next
)
2964 vec_safe_push (tvec
, gfc_convert_expr_to_tree (block
, el
->expr
));
2966 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_TILE
);
2967 OMP_CLAUSE_TILE_LIST (c
) = build_tree_list_vec (tvec
);
2968 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
2971 if (clauses
->vector
)
2973 if (clauses
->vector_expr
)
2976 = gfc_convert_expr_to_tree (block
, clauses
->vector_expr
);
2977 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_VECTOR
);
2978 OMP_CLAUSE_VECTOR_EXPR (c
) = vector_var
;
2979 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
2983 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_VECTOR
);
2984 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
2987 if (clauses
->worker
)
2989 if (clauses
->worker_expr
)
2992 = gfc_convert_expr_to_tree (block
, clauses
->worker_expr
);
2993 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_WORKER
);
2994 OMP_CLAUSE_WORKER_EXPR (c
) = worker_var
;
2995 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
2999 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_WORKER
);
3000 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3006 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_GANG
);
3007 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3008 if (clauses
->gang_num_expr
)
3010 arg
= gfc_convert_expr_to_tree (block
, clauses
->gang_num_expr
);
3011 OMP_CLAUSE_GANG_EXPR (c
) = arg
;
3013 if (clauses
->gang_static
)
3015 arg
= clauses
->gang_static_expr
3016 ? gfc_convert_expr_to_tree (block
, clauses
->gang_static_expr
)
3017 : integer_minus_one_node
;
3018 OMP_CLAUSE_GANG_STATIC_EXPR (c
) = arg
;
3022 return nreverse (omp_clauses
);
3025 /* Like gfc_trans_code, but force creation of a BIND_EXPR around it. */
3028 gfc_trans_omp_code (gfc_code
*code
, bool force_empty
)
3033 stmt
= gfc_trans_code (code
);
3034 if (TREE_CODE (stmt
) != BIND_EXPR
)
3036 if (!IS_EMPTY_STMT (stmt
) || force_empty
)
3038 tree block
= poplevel (1, 0);
3039 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, block
);
3049 /* Trans OpenACC directives. */
3050 /* parallel, kernels, data and host_data. */
3052 gfc_trans_oacc_construct (gfc_code
*code
)
3055 tree stmt
, oacc_clauses
;
3056 enum tree_code construct_code
;
3060 case EXEC_OACC_PARALLEL
:
3061 construct_code
= OACC_PARALLEL
;
3063 case EXEC_OACC_KERNELS
:
3064 construct_code
= OACC_KERNELS
;
3066 case EXEC_OACC_DATA
:
3067 construct_code
= OACC_DATA
;
3069 case EXEC_OACC_HOST_DATA
:
3070 construct_code
= OACC_HOST_DATA
;
3076 gfc_start_block (&block
);
3077 oacc_clauses
= gfc_trans_omp_clauses (&block
, code
->ext
.omp_clauses
,
3079 stmt
= gfc_trans_omp_code (code
->block
->next
, true);
3080 stmt
= build2_loc (input_location
, construct_code
, void_type_node
, stmt
,
3082 gfc_add_expr_to_block (&block
, stmt
);
3083 return gfc_finish_block (&block
);
3086 /* update, enter_data, exit_data, cache. */
3088 gfc_trans_oacc_executable_directive (gfc_code
*code
)
3091 tree stmt
, oacc_clauses
;
3092 enum tree_code construct_code
;
3096 case EXEC_OACC_UPDATE
:
3097 construct_code
= OACC_UPDATE
;
3099 case EXEC_OACC_ENTER_DATA
:
3100 construct_code
= OACC_ENTER_DATA
;
3102 case EXEC_OACC_EXIT_DATA
:
3103 construct_code
= OACC_EXIT_DATA
;
3105 case EXEC_OACC_CACHE
:
3106 construct_code
= OACC_CACHE
;
3112 gfc_start_block (&block
);
3113 oacc_clauses
= gfc_trans_omp_clauses (&block
, code
->ext
.omp_clauses
,
3115 stmt
= build1_loc (input_location
, construct_code
, void_type_node
,
3117 gfc_add_expr_to_block (&block
, stmt
);
3118 return gfc_finish_block (&block
);
3122 gfc_trans_oacc_wait_directive (gfc_code
*code
)
3126 vec
<tree
, va_gc
> *args
;
3129 gfc_omp_clauses
*clauses
= code
->ext
.omp_clauses
;
3130 location_t loc
= input_location
;
3132 for (el
= clauses
->wait_list
; el
; el
= el
->next
)
3135 vec_alloc (args
, nparms
+ 2);
3136 stmt
= builtin_decl_explicit (BUILT_IN_GOACC_WAIT
);
3138 gfc_start_block (&block
);
3140 if (clauses
->async_expr
)
3141 t
= gfc_convert_expr_to_tree (&block
, clauses
->async_expr
);
3143 t
= build_int_cst (integer_type_node
, -2);
3145 args
->quick_push (t
);
3146 args
->quick_push (build_int_cst (integer_type_node
, nparms
));
3148 for (el
= clauses
->wait_list
; el
; el
= el
->next
)
3149 args
->quick_push (gfc_convert_expr_to_tree (&block
, el
->expr
));
3151 stmt
= build_call_expr_loc_vec (loc
, stmt
, args
);
3152 gfc_add_expr_to_block (&block
, stmt
);
3156 return gfc_finish_block (&block
);
3159 static tree
gfc_trans_omp_sections (gfc_code
*, gfc_omp_clauses
*);
3160 static tree
gfc_trans_omp_workshare (gfc_code
*, gfc_omp_clauses
*);
3163 gfc_trans_omp_atomic (gfc_code
*code
)
3165 gfc_code
*atomic_code
= code
;
3169 gfc_expr
*expr2
, *e
;
3172 tree lhsaddr
, type
, rhs
, x
;
3173 enum tree_code op
= ERROR_MARK
;
3174 enum tree_code aop
= OMP_ATOMIC
;
3175 bool var_on_left
= false;
3176 enum omp_memory_order mo
3177 = ((atomic_code
->ext
.omp_atomic
& GFC_OMP_ATOMIC_SEQ_CST
)
3178 ? OMP_MEMORY_ORDER_SEQ_CST
: OMP_MEMORY_ORDER_RELAXED
);
3180 code
= code
->block
->next
;
3181 gcc_assert (code
->op
== EXEC_ASSIGN
);
3182 var
= code
->expr1
->symtree
->n
.sym
;
3184 gfc_init_se (&lse
, NULL
);
3185 gfc_init_se (&rse
, NULL
);
3186 gfc_init_se (&vse
, NULL
);
3187 gfc_start_block (&block
);
3189 expr2
= code
->expr2
;
3190 if (((atomic_code
->ext
.omp_atomic
& GFC_OMP_ATOMIC_MASK
)
3191 != GFC_OMP_ATOMIC_WRITE
)
3192 && (atomic_code
->ext
.omp_atomic
& GFC_OMP_ATOMIC_SWAP
) == 0
3193 && expr2
->expr_type
== EXPR_FUNCTION
3194 && expr2
->value
.function
.isym
3195 && expr2
->value
.function
.isym
->id
== GFC_ISYM_CONVERSION
)
3196 expr2
= expr2
->value
.function
.actual
->expr
;
3198 switch (atomic_code
->ext
.omp_atomic
& GFC_OMP_ATOMIC_MASK
)
3200 case GFC_OMP_ATOMIC_READ
:
3201 gfc_conv_expr (&vse
, code
->expr1
);
3202 gfc_add_block_to_block (&block
, &vse
.pre
);
3204 gfc_conv_expr (&lse
, expr2
);
3205 gfc_add_block_to_block (&block
, &lse
.pre
);
3206 type
= TREE_TYPE (lse
.expr
);
3207 lhsaddr
= gfc_build_addr_expr (NULL
, lse
.expr
);
3209 x
= build1 (OMP_ATOMIC_READ
, type
, lhsaddr
);
3210 OMP_ATOMIC_MEMORY_ORDER (x
) = mo
;
3211 x
= convert (TREE_TYPE (vse
.expr
), x
);
3212 gfc_add_modify (&block
, vse
.expr
, x
);
3214 gfc_add_block_to_block (&block
, &lse
.pre
);
3215 gfc_add_block_to_block (&block
, &rse
.pre
);
3217 return gfc_finish_block (&block
);
3218 case GFC_OMP_ATOMIC_CAPTURE
:
3219 aop
= OMP_ATOMIC_CAPTURE_NEW
;
3220 if (expr2
->expr_type
== EXPR_VARIABLE
)
3222 aop
= OMP_ATOMIC_CAPTURE_OLD
;
3223 gfc_conv_expr (&vse
, code
->expr1
);
3224 gfc_add_block_to_block (&block
, &vse
.pre
);
3226 gfc_conv_expr (&lse
, expr2
);
3227 gfc_add_block_to_block (&block
, &lse
.pre
);
3228 gfc_init_se (&lse
, NULL
);
3230 var
= code
->expr1
->symtree
->n
.sym
;
3231 expr2
= code
->expr2
;
3232 if (expr2
->expr_type
== EXPR_FUNCTION
3233 && expr2
->value
.function
.isym
3234 && expr2
->value
.function
.isym
->id
== GFC_ISYM_CONVERSION
)
3235 expr2
= expr2
->value
.function
.actual
->expr
;
3242 gfc_conv_expr (&lse
, code
->expr1
);
3243 gfc_add_block_to_block (&block
, &lse
.pre
);
3244 type
= TREE_TYPE (lse
.expr
);
3245 lhsaddr
= gfc_build_addr_expr (NULL
, lse
.expr
);
3247 if (((atomic_code
->ext
.omp_atomic
& GFC_OMP_ATOMIC_MASK
)
3248 == GFC_OMP_ATOMIC_WRITE
)
3249 || (atomic_code
->ext
.omp_atomic
& GFC_OMP_ATOMIC_SWAP
))
3251 gfc_conv_expr (&rse
, expr2
);
3252 gfc_add_block_to_block (&block
, &rse
.pre
);
3254 else if (expr2
->expr_type
== EXPR_OP
)
3257 switch (expr2
->value
.op
.op
)
3259 case INTRINSIC_PLUS
:
3262 case INTRINSIC_TIMES
:
3265 case INTRINSIC_MINUS
:
3268 case INTRINSIC_DIVIDE
:
3269 if (expr2
->ts
.type
== BT_INTEGER
)
3270 op
= TRUNC_DIV_EXPR
;
3275 op
= TRUTH_ANDIF_EXPR
;
3278 op
= TRUTH_ORIF_EXPR
;
3283 case INTRINSIC_NEQV
:
3289 e
= expr2
->value
.op
.op1
;
3290 if (e
->expr_type
== EXPR_FUNCTION
3291 && e
->value
.function
.isym
3292 && e
->value
.function
.isym
->id
== GFC_ISYM_CONVERSION
)
3293 e
= e
->value
.function
.actual
->expr
;
3294 if (e
->expr_type
== EXPR_VARIABLE
3295 && e
->symtree
!= NULL
3296 && e
->symtree
->n
.sym
== var
)
3298 expr2
= expr2
->value
.op
.op2
;
3303 e
= expr2
->value
.op
.op2
;
3304 if (e
->expr_type
== EXPR_FUNCTION
3305 && e
->value
.function
.isym
3306 && e
->value
.function
.isym
->id
== GFC_ISYM_CONVERSION
)
3307 e
= e
->value
.function
.actual
->expr
;
3308 gcc_assert (e
->expr_type
== EXPR_VARIABLE
3309 && e
->symtree
!= NULL
3310 && e
->symtree
->n
.sym
== var
);
3311 expr2
= expr2
->value
.op
.op1
;
3312 var_on_left
= false;
3314 gfc_conv_expr (&rse
, expr2
);
3315 gfc_add_block_to_block (&block
, &rse
.pre
);
3319 gcc_assert (expr2
->expr_type
== EXPR_FUNCTION
);
3320 switch (expr2
->value
.function
.isym
->id
)
3340 e
= expr2
->value
.function
.actual
->expr
;
3341 gcc_assert (e
->expr_type
== EXPR_VARIABLE
3342 && e
->symtree
!= NULL
3343 && e
->symtree
->n
.sym
== var
);
3345 gfc_conv_expr (&rse
, expr2
->value
.function
.actual
->next
->expr
);
3346 gfc_add_block_to_block (&block
, &rse
.pre
);
3347 if (expr2
->value
.function
.actual
->next
->next
!= NULL
)
3349 tree accum
= gfc_create_var (TREE_TYPE (rse
.expr
), NULL
);
3350 gfc_actual_arglist
*arg
;
3352 gfc_add_modify (&block
, accum
, rse
.expr
);
3353 for (arg
= expr2
->value
.function
.actual
->next
->next
; arg
;
3356 gfc_init_block (&rse
.pre
);
3357 gfc_conv_expr (&rse
, arg
->expr
);
3358 gfc_add_block_to_block (&block
, &rse
.pre
);
3359 x
= fold_build2_loc (input_location
, op
, TREE_TYPE (accum
),
3361 gfc_add_modify (&block
, accum
, x
);
3367 expr2
= expr2
->value
.function
.actual
->next
->expr
;
3370 lhsaddr
= save_expr (lhsaddr
);
3371 if (TREE_CODE (lhsaddr
) != SAVE_EXPR
3372 && (TREE_CODE (lhsaddr
) != ADDR_EXPR
3373 || !VAR_P (TREE_OPERAND (lhsaddr
, 0))))
3375 /* Make sure LHS is simple enough so that goa_lhs_expr_p can recognize
3376 it even after unsharing function body. */
3377 tree var
= create_tmp_var_raw (TREE_TYPE (lhsaddr
));
3378 DECL_CONTEXT (var
) = current_function_decl
;
3379 lhsaddr
= build4 (TARGET_EXPR
, TREE_TYPE (lhsaddr
), var
, lhsaddr
,
3380 NULL_TREE
, NULL_TREE
);
3383 rhs
= gfc_evaluate_now (rse
.expr
, &block
);
3385 if (((atomic_code
->ext
.omp_atomic
& GFC_OMP_ATOMIC_MASK
)
3386 == GFC_OMP_ATOMIC_WRITE
)
3387 || (atomic_code
->ext
.omp_atomic
& GFC_OMP_ATOMIC_SWAP
))
3391 x
= convert (TREE_TYPE (rhs
),
3392 build_fold_indirect_ref_loc (input_location
, lhsaddr
));
3394 x
= fold_build2_loc (input_location
, op
, TREE_TYPE (rhs
), x
, rhs
);
3396 x
= fold_build2_loc (input_location
, op
, TREE_TYPE (rhs
), rhs
, x
);
3399 if (TREE_CODE (TREE_TYPE (rhs
)) == COMPLEX_TYPE
3400 && TREE_CODE (type
) != COMPLEX_TYPE
)
3401 x
= fold_build1_loc (input_location
, REALPART_EXPR
,
3402 TREE_TYPE (TREE_TYPE (rhs
)), x
);
3404 gfc_add_block_to_block (&block
, &lse
.pre
);
3405 gfc_add_block_to_block (&block
, &rse
.pre
);
3407 if (aop
== OMP_ATOMIC
)
3409 x
= build2_v (OMP_ATOMIC
, lhsaddr
, convert (type
, x
));
3410 OMP_ATOMIC_MEMORY_ORDER (x
) = mo
;
3411 gfc_add_expr_to_block (&block
, x
);
3415 if (aop
== OMP_ATOMIC_CAPTURE_NEW
)
3418 expr2
= code
->expr2
;
3419 if (expr2
->expr_type
== EXPR_FUNCTION
3420 && expr2
->value
.function
.isym
3421 && expr2
->value
.function
.isym
->id
== GFC_ISYM_CONVERSION
)
3422 expr2
= expr2
->value
.function
.actual
->expr
;
3424 gcc_assert (expr2
->expr_type
== EXPR_VARIABLE
);
3425 gfc_conv_expr (&vse
, code
->expr1
);
3426 gfc_add_block_to_block (&block
, &vse
.pre
);
3428 gfc_init_se (&lse
, NULL
);
3429 gfc_conv_expr (&lse
, expr2
);
3430 gfc_add_block_to_block (&block
, &lse
.pre
);
3432 x
= build2 (aop
, type
, lhsaddr
, convert (type
, x
));
3433 OMP_ATOMIC_MEMORY_ORDER (x
) = mo
;
3434 x
= convert (TREE_TYPE (vse
.expr
), x
);
3435 gfc_add_modify (&block
, vse
.expr
, x
);
3438 return gfc_finish_block (&block
);
3442 gfc_trans_omp_barrier (void)
3444 tree decl
= builtin_decl_explicit (BUILT_IN_GOMP_BARRIER
);
3445 return build_call_expr_loc (input_location
, decl
, 0);
3449 gfc_trans_omp_cancel (gfc_code
*code
)
3452 tree ifc
= boolean_true_node
;
3454 switch (code
->ext
.omp_clauses
->cancel
)
3456 case OMP_CANCEL_PARALLEL
: mask
= 1; break;
3457 case OMP_CANCEL_DO
: mask
= 2; break;
3458 case OMP_CANCEL_SECTIONS
: mask
= 4; break;
3459 case OMP_CANCEL_TASKGROUP
: mask
= 8; break;
3460 default: gcc_unreachable ();
3462 gfc_start_block (&block
);
3463 if (code
->ext
.omp_clauses
->if_expr
)
3468 gfc_init_se (&se
, NULL
);
3469 gfc_conv_expr (&se
, code
->ext
.omp_clauses
->if_expr
);
3470 gfc_add_block_to_block (&block
, &se
.pre
);
3471 if_var
= gfc_evaluate_now (se
.expr
, &block
);
3472 gfc_add_block_to_block (&block
, &se
.post
);
3473 tree type
= TREE_TYPE (if_var
);
3474 ifc
= fold_build2_loc (input_location
, NE_EXPR
,
3475 boolean_type_node
, if_var
,
3476 build_zero_cst (type
));
3478 tree decl
= builtin_decl_explicit (BUILT_IN_GOMP_CANCEL
);
3479 tree c_bool_type
= TREE_TYPE (TREE_TYPE (decl
));
3480 ifc
= fold_convert (c_bool_type
, ifc
);
3481 gfc_add_expr_to_block (&block
,
3482 build_call_expr_loc (input_location
, decl
, 2,
3483 build_int_cst (integer_type_node
,
3485 return gfc_finish_block (&block
);
3489 gfc_trans_omp_cancellation_point (gfc_code
*code
)
3492 switch (code
->ext
.omp_clauses
->cancel
)
3494 case OMP_CANCEL_PARALLEL
: mask
= 1; break;
3495 case OMP_CANCEL_DO
: mask
= 2; break;
3496 case OMP_CANCEL_SECTIONS
: mask
= 4; break;
3497 case OMP_CANCEL_TASKGROUP
: mask
= 8; break;
3498 default: gcc_unreachable ();
3500 tree decl
= builtin_decl_explicit (BUILT_IN_GOMP_CANCELLATION_POINT
);
3501 return build_call_expr_loc (input_location
, decl
, 1,
3502 build_int_cst (integer_type_node
, mask
));
3506 gfc_trans_omp_critical (gfc_code
*code
)
3508 tree name
= NULL_TREE
, stmt
;
3509 if (code
->ext
.omp_clauses
!= NULL
)
3510 name
= get_identifier (code
->ext
.omp_clauses
->critical_name
);
3511 stmt
= gfc_trans_code (code
->block
->next
);
3512 return build3_loc (input_location
, OMP_CRITICAL
, void_type_node
, stmt
,
3516 typedef struct dovar_init_d
{
3523 gfc_trans_omp_do (gfc_code
*code
, gfc_exec_op op
, stmtblock_t
*pblock
,
3524 gfc_omp_clauses
*do_clauses
, tree par_clauses
)
3527 tree dovar
, stmt
, from
, to
, step
, type
, init
, cond
, incr
, orig_decls
;
3528 tree count
= NULL_TREE
, cycle_label
, tmp
, omp_clauses
;
3531 gfc_omp_clauses
*clauses
= code
->ext
.omp_clauses
;
3532 int i
, collapse
= clauses
->collapse
;
3533 vec
<dovar_init
> inits
= vNULL
;
3536 vec
<tree
, va_heap
, vl_embed
> *saved_doacross_steps
= doacross_steps
;
3537 gfc_expr_list
*tile
= do_clauses
? do_clauses
->tile_list
: clauses
->tile_list
;
3539 /* Both collapsed and tiled loops are lowered the same way. In
3540 OpenACC, those clauses are not compatible, so prioritize the tile
3541 clause, if present. */
3545 for (gfc_expr_list
*el
= tile
; el
; el
= el
->next
)
3549 doacross_steps
= NULL
;
3550 if (clauses
->orderedc
)
3551 collapse
= clauses
->orderedc
;
3555 code
= code
->block
->next
;
3556 gcc_assert (code
->op
== EXEC_DO
);
3558 init
= make_tree_vec (collapse
);
3559 cond
= make_tree_vec (collapse
);
3560 incr
= make_tree_vec (collapse
);
3561 orig_decls
= clauses
->orderedc
? make_tree_vec (collapse
) : NULL_TREE
;
3565 gfc_start_block (&block
);
3569 /* simd schedule modifier is only useful for composite do simd and other
3570 constructs including that, where gfc_trans_omp_do is only called
3571 on the simd construct and DO's clauses are translated elsewhere. */
3572 do_clauses
->sched_simd
= false;
3574 omp_clauses
= gfc_trans_omp_clauses (pblock
, do_clauses
, code
->loc
);
3576 for (i
= 0; i
< collapse
; i
++)
3579 int dovar_found
= 0;
3584 gfc_omp_namelist
*n
= NULL
;
3585 if (op
!= EXEC_OMP_DISTRIBUTE
)
3586 for (n
= clauses
->lists
[(op
== EXEC_OMP_SIMD
&& collapse
== 1)
3587 ? OMP_LIST_LINEAR
: OMP_LIST_LASTPRIVATE
];
3588 n
!= NULL
; n
= n
->next
)
3589 if (code
->ext
.iterator
->var
->symtree
->n
.sym
== n
->sym
)
3593 else if (n
== NULL
&& op
!= EXEC_OMP_SIMD
)
3594 for (n
= clauses
->lists
[OMP_LIST_PRIVATE
]; n
!= NULL
; n
= n
->next
)
3595 if (code
->ext
.iterator
->var
->symtree
->n
.sym
== n
->sym
)
3601 /* Evaluate all the expressions in the iterator. */
3602 gfc_init_se (&se
, NULL
);
3603 gfc_conv_expr_lhs (&se
, code
->ext
.iterator
->var
);
3604 gfc_add_block_to_block (pblock
, &se
.pre
);
3606 type
= TREE_TYPE (dovar
);
3607 gcc_assert (TREE_CODE (type
) == INTEGER_TYPE
);
3609 gfc_init_se (&se
, NULL
);
3610 gfc_conv_expr_val (&se
, code
->ext
.iterator
->start
);
3611 gfc_add_block_to_block (pblock
, &se
.pre
);
3612 from
= gfc_evaluate_now (se
.expr
, pblock
);
3614 gfc_init_se (&se
, NULL
);
3615 gfc_conv_expr_val (&se
, code
->ext
.iterator
->end
);
3616 gfc_add_block_to_block (pblock
, &se
.pre
);
3617 to
= gfc_evaluate_now (se
.expr
, pblock
);
3619 gfc_init_se (&se
, NULL
);
3620 gfc_conv_expr_val (&se
, code
->ext
.iterator
->step
);
3621 gfc_add_block_to_block (pblock
, &se
.pre
);
3622 step
= gfc_evaluate_now (se
.expr
, pblock
);
3625 /* Special case simple loops. */
3628 if (integer_onep (step
))
3630 else if (tree_int_cst_equal (step
, integer_minus_one_node
))
3635 = gfc_trans_omp_variable (code
->ext
.iterator
->var
->symtree
->n
.sym
,
3641 TREE_VEC_ELT (init
, i
) = build2_v (MODIFY_EXPR
, dovar
, from
);
3642 /* The condition should not be folded. */
3643 TREE_VEC_ELT (cond
, i
) = build2_loc (input_location
, simple
> 0
3644 ? LE_EXPR
: GE_EXPR
,
3645 logical_type_node
, dovar
, to
);
3646 TREE_VEC_ELT (incr
, i
) = fold_build2_loc (input_location
, PLUS_EXPR
,
3648 TREE_VEC_ELT (incr
, i
) = fold_build2_loc (input_location
,
3651 TREE_VEC_ELT (incr
, i
));
3655 /* STEP is not 1 or -1. Use:
3656 for (count = 0; count < (to + step - from) / step; count++)
3658 dovar = from + count * step;
3662 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, step
, from
);
3663 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, to
, tmp
);
3664 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, type
, tmp
,
3666 tmp
= gfc_evaluate_now (tmp
, pblock
);
3667 count
= gfc_create_var (type
, "count");
3668 TREE_VEC_ELT (init
, i
) = build2_v (MODIFY_EXPR
, count
,
3669 build_int_cst (type
, 0));
3670 /* The condition should not be folded. */
3671 TREE_VEC_ELT (cond
, i
) = build2_loc (input_location
, LT_EXPR
,
3674 TREE_VEC_ELT (incr
, i
) = fold_build2_loc (input_location
, PLUS_EXPR
,
3676 build_int_cst (type
, 1));
3677 TREE_VEC_ELT (incr
, i
) = fold_build2_loc (input_location
,
3678 MODIFY_EXPR
, type
, count
,
3679 TREE_VEC_ELT (incr
, i
));
3681 /* Initialize DOVAR. */
3682 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, type
, count
, step
);
3683 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, from
, tmp
);
3684 dovar_init e
= {dovar
, tmp
};
3685 inits
.safe_push (e
);
3686 if (clauses
->orderedc
)
3688 if (doacross_steps
== NULL
)
3689 vec_safe_grow_cleared (doacross_steps
, clauses
->orderedc
);
3690 (*doacross_steps
)[i
] = step
;
3694 TREE_VEC_ELT (orig_decls
, i
) = dovar_decl
;
3696 if (dovar_found
== 2
3697 && op
== EXEC_OMP_SIMD
3701 for (tmp
= omp_clauses
; tmp
; tmp
= OMP_CLAUSE_CHAIN (tmp
))
3702 if (OMP_CLAUSE_CODE (tmp
) == OMP_CLAUSE_LINEAR
3703 && OMP_CLAUSE_DECL (tmp
) == dovar
)
3705 OMP_CLAUSE_LINEAR_NO_COPYIN (tmp
) = 1;
3711 if (op
== EXEC_OMP_SIMD
)
3715 tmp
= build_omp_clause (input_location
, OMP_CLAUSE_LINEAR
);
3716 OMP_CLAUSE_LINEAR_STEP (tmp
) = step
;
3717 OMP_CLAUSE_LINEAR_NO_COPYIN (tmp
) = 1;
3720 tmp
= build_omp_clause (input_location
, OMP_CLAUSE_LASTPRIVATE
);
3725 tmp
= build_omp_clause (input_location
, OMP_CLAUSE_PRIVATE
);
3726 OMP_CLAUSE_DECL (tmp
) = dovar_decl
;
3727 omp_clauses
= gfc_trans_add_clause (tmp
, omp_clauses
);
3729 if (dovar_found
== 2)
3736 /* If dovar is lastprivate, but different counter is used,
3737 dovar += step needs to be added to
3738 OMP_CLAUSE_LASTPRIVATE_STMT, otherwise the copied dovar
3739 will have the value on entry of the last loop, rather
3740 than value after iterator increment. */
3741 if (clauses
->orderedc
)
3743 if (clauses
->collapse
<= 1 || i
>= clauses
->collapse
)
3746 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3747 type
, count
, build_one_cst (type
));
3748 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, type
,
3750 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
,
3755 tmp
= gfc_evaluate_now (step
, pblock
);
3756 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
,
3759 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, type
,
3761 for (c
= omp_clauses
; c
; c
= OMP_CLAUSE_CHAIN (c
))
3762 if (OMP_CLAUSE_CODE (c
) == OMP_CLAUSE_LASTPRIVATE
3763 && OMP_CLAUSE_DECL (c
) == dovar_decl
)
3765 OMP_CLAUSE_LASTPRIVATE_STMT (c
) = tmp
;
3768 else if (OMP_CLAUSE_CODE (c
) == OMP_CLAUSE_LINEAR
3769 && OMP_CLAUSE_DECL (c
) == dovar_decl
)
3771 OMP_CLAUSE_LINEAR_STMT (c
) = tmp
;
3775 if (c
== NULL
&& op
== EXEC_OMP_DO
&& par_clauses
!= NULL
)
3777 for (c
= par_clauses
; c
; c
= OMP_CLAUSE_CHAIN (c
))
3778 if (OMP_CLAUSE_CODE (c
) == OMP_CLAUSE_LASTPRIVATE
3779 && OMP_CLAUSE_DECL (c
) == dovar_decl
)
3781 tree l
= build_omp_clause (input_location
,
3782 OMP_CLAUSE_LASTPRIVATE
);
3783 OMP_CLAUSE_DECL (l
) = dovar_decl
;
3784 OMP_CLAUSE_CHAIN (l
) = omp_clauses
;
3785 OMP_CLAUSE_LASTPRIVATE_STMT (l
) = tmp
;
3787 OMP_CLAUSE_SET_CODE (c
, OMP_CLAUSE_SHARED
);
3791 gcc_assert (simple
|| c
!= NULL
);
3795 if (op
!= EXEC_OMP_SIMD
)
3796 tmp
= build_omp_clause (input_location
, OMP_CLAUSE_PRIVATE
);
3797 else if (collapse
== 1)
3799 tmp
= build_omp_clause (input_location
, OMP_CLAUSE_LINEAR
);
3800 OMP_CLAUSE_LINEAR_STEP (tmp
) = build_int_cst (type
, 1);
3801 OMP_CLAUSE_LINEAR_NO_COPYIN (tmp
) = 1;
3802 OMP_CLAUSE_LINEAR_NO_COPYOUT (tmp
) = 1;
3805 tmp
= build_omp_clause (input_location
, OMP_CLAUSE_LASTPRIVATE
);
3806 OMP_CLAUSE_DECL (tmp
) = count
;
3807 omp_clauses
= gfc_trans_add_clause (tmp
, omp_clauses
);
3810 if (i
+ 1 < collapse
)
3811 code
= code
->block
->next
;
3814 if (pblock
!= &block
)
3817 gfc_start_block (&block
);
3820 gfc_start_block (&body
);
3822 FOR_EACH_VEC_ELT (inits
, ix
, di
)
3823 gfc_add_modify (&body
, di
->var
, di
->init
);
3826 /* Cycle statement is implemented with a goto. Exit statement must not be
3827 present for this loop. */
3828 cycle_label
= gfc_build_label_decl (NULL_TREE
);
3830 /* Put these labels where they can be found later. */
3832 code
->cycle_label
= cycle_label
;
3833 code
->exit_label
= NULL_TREE
;
3835 /* Main loop body. */
3836 tmp
= gfc_trans_omp_code (code
->block
->next
, true);
3837 gfc_add_expr_to_block (&body
, tmp
);
3839 /* Label for cycle statements (if needed). */
3840 if (TREE_USED (cycle_label
))
3842 tmp
= build1_v (LABEL_EXPR
, cycle_label
);
3843 gfc_add_expr_to_block (&body
, tmp
);
3846 /* End of loop body. */
3849 case EXEC_OMP_SIMD
: stmt
= make_node (OMP_SIMD
); break;
3850 case EXEC_OMP_DO
: stmt
= make_node (OMP_FOR
); break;
3851 case EXEC_OMP_DISTRIBUTE
: stmt
= make_node (OMP_DISTRIBUTE
); break;
3852 case EXEC_OMP_TASKLOOP
: stmt
= make_node (OMP_TASKLOOP
); break;
3853 case EXEC_OACC_LOOP
: stmt
= make_node (OACC_LOOP
); break;
3854 default: gcc_unreachable ();
3857 TREE_TYPE (stmt
) = void_type_node
;
3858 OMP_FOR_BODY (stmt
) = gfc_finish_block (&body
);
3859 OMP_FOR_CLAUSES (stmt
) = omp_clauses
;
3860 OMP_FOR_INIT (stmt
) = init
;
3861 OMP_FOR_COND (stmt
) = cond
;
3862 OMP_FOR_INCR (stmt
) = incr
;
3864 OMP_FOR_ORIG_DECLS (stmt
) = orig_decls
;
3865 gfc_add_expr_to_block (&block
, stmt
);
3867 vec_free (doacross_steps
);
3868 doacross_steps
= saved_doacross_steps
;
3870 return gfc_finish_block (&block
);
3873 /* parallel loop and kernels loop. */
3875 gfc_trans_oacc_combined_directive (gfc_code
*code
)
3877 stmtblock_t block
, *pblock
= NULL
;
3878 gfc_omp_clauses construct_clauses
, loop_clauses
;
3879 tree stmt
, oacc_clauses
= NULL_TREE
;
3880 enum tree_code construct_code
;
3881 location_t loc
= input_location
;
3885 case EXEC_OACC_PARALLEL_LOOP
:
3886 construct_code
= OACC_PARALLEL
;
3888 case EXEC_OACC_KERNELS_LOOP
:
3889 construct_code
= OACC_KERNELS
;
3895 gfc_start_block (&block
);
3897 memset (&loop_clauses
, 0, sizeof (loop_clauses
));
3898 if (code
->ext
.omp_clauses
!= NULL
)
3900 memcpy (&construct_clauses
, code
->ext
.omp_clauses
,
3901 sizeof (construct_clauses
));
3902 loop_clauses
.collapse
= construct_clauses
.collapse
;
3903 loop_clauses
.gang
= construct_clauses
.gang
;
3904 loop_clauses
.gang_static
= construct_clauses
.gang_static
;
3905 loop_clauses
.gang_num_expr
= construct_clauses
.gang_num_expr
;
3906 loop_clauses
.gang_static_expr
= construct_clauses
.gang_static_expr
;
3907 loop_clauses
.vector
= construct_clauses
.vector
;
3908 loop_clauses
.vector_expr
= construct_clauses
.vector_expr
;
3909 loop_clauses
.worker
= construct_clauses
.worker
;
3910 loop_clauses
.worker_expr
= construct_clauses
.worker_expr
;
3911 loop_clauses
.seq
= construct_clauses
.seq
;
3912 loop_clauses
.par_auto
= construct_clauses
.par_auto
;
3913 loop_clauses
.independent
= construct_clauses
.independent
;
3914 loop_clauses
.tile_list
= construct_clauses
.tile_list
;
3915 loop_clauses
.lists
[OMP_LIST_PRIVATE
]
3916 = construct_clauses
.lists
[OMP_LIST_PRIVATE
];
3917 loop_clauses
.lists
[OMP_LIST_REDUCTION
]
3918 = construct_clauses
.lists
[OMP_LIST_REDUCTION
];
3919 construct_clauses
.gang
= false;
3920 construct_clauses
.gang_static
= false;
3921 construct_clauses
.gang_num_expr
= NULL
;
3922 construct_clauses
.gang_static_expr
= NULL
;
3923 construct_clauses
.vector
= false;
3924 construct_clauses
.vector_expr
= NULL
;
3925 construct_clauses
.worker
= false;
3926 construct_clauses
.worker_expr
= NULL
;
3927 construct_clauses
.seq
= false;
3928 construct_clauses
.par_auto
= false;
3929 construct_clauses
.independent
= false;
3930 construct_clauses
.independent
= false;
3931 construct_clauses
.tile_list
= NULL
;
3932 construct_clauses
.lists
[OMP_LIST_PRIVATE
] = NULL
;
3933 if (construct_code
== OACC_KERNELS
)
3934 construct_clauses
.lists
[OMP_LIST_REDUCTION
] = NULL
;
3935 oacc_clauses
= gfc_trans_omp_clauses (&block
, &construct_clauses
,
3938 if (!loop_clauses
.seq
)
3942 stmt
= gfc_trans_omp_do (code
, EXEC_OACC_LOOP
, pblock
, &loop_clauses
, NULL
);
3943 protected_set_expr_location (stmt
, loc
);
3944 if (TREE_CODE (stmt
) != BIND_EXPR
)
3945 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
3948 stmt
= build2_loc (loc
, construct_code
, void_type_node
, stmt
, oacc_clauses
);
3949 gfc_add_expr_to_block (&block
, stmt
);
3950 return gfc_finish_block (&block
);
3954 gfc_trans_omp_flush (void)
3956 tree decl
= builtin_decl_explicit (BUILT_IN_SYNC_SYNCHRONIZE
);
3957 return build_call_expr_loc (input_location
, decl
, 0);
3961 gfc_trans_omp_master (gfc_code
*code
)
3963 tree stmt
= gfc_trans_code (code
->block
->next
);
3964 if (IS_EMPTY_STMT (stmt
))
3966 return build1_v (OMP_MASTER
, stmt
);
3970 gfc_trans_omp_ordered (gfc_code
*code
)
3974 if (!code
->ext
.omp_clauses
->simd
)
3975 return gfc_trans_code (code
->block
? code
->block
->next
: NULL
);
3976 code
->ext
.omp_clauses
->threads
= 0;
3978 tree omp_clauses
= gfc_trans_omp_clauses (NULL
, code
->ext
.omp_clauses
,
3980 return build2_loc (input_location
, OMP_ORDERED
, void_type_node
,
3981 code
->block
? gfc_trans_code (code
->block
->next
)
3982 : NULL_TREE
, omp_clauses
);
3986 gfc_trans_omp_parallel (gfc_code
*code
)
3989 tree stmt
, omp_clauses
;
3991 gfc_start_block (&block
);
3992 omp_clauses
= gfc_trans_omp_clauses (&block
, code
->ext
.omp_clauses
,
3995 stmt
= gfc_trans_omp_code (code
->block
->next
, true);
3996 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
3997 stmt
= build2_loc (input_location
, OMP_PARALLEL
, void_type_node
, stmt
,
3999 gfc_add_expr_to_block (&block
, stmt
);
4000 return gfc_finish_block (&block
);
4007 GFC_OMP_SPLIT_PARALLEL
,
4008 GFC_OMP_SPLIT_DISTRIBUTE
,
4009 GFC_OMP_SPLIT_TEAMS
,
4010 GFC_OMP_SPLIT_TARGET
,
4011 GFC_OMP_SPLIT_TASKLOOP
,
4017 GFC_OMP_MASK_SIMD
= (1 << GFC_OMP_SPLIT_SIMD
),
4018 GFC_OMP_MASK_DO
= (1 << GFC_OMP_SPLIT_DO
),
4019 GFC_OMP_MASK_PARALLEL
= (1 << GFC_OMP_SPLIT_PARALLEL
),
4020 GFC_OMP_MASK_DISTRIBUTE
= (1 << GFC_OMP_SPLIT_DISTRIBUTE
),
4021 GFC_OMP_MASK_TEAMS
= (1 << GFC_OMP_SPLIT_TEAMS
),
4022 GFC_OMP_MASK_TARGET
= (1 << GFC_OMP_SPLIT_TARGET
),
4023 GFC_OMP_MASK_TASKLOOP
= (1 << GFC_OMP_SPLIT_TASKLOOP
)
4027 gfc_split_omp_clauses (gfc_code
*code
,
4028 gfc_omp_clauses clausesa
[GFC_OMP_SPLIT_NUM
])
4030 int mask
= 0, innermost
= 0;
4031 memset (clausesa
, 0, GFC_OMP_SPLIT_NUM
* sizeof (gfc_omp_clauses
));
4034 case EXEC_OMP_DISTRIBUTE
:
4035 innermost
= GFC_OMP_SPLIT_DISTRIBUTE
;
4037 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
4038 mask
= GFC_OMP_MASK_DISTRIBUTE
| GFC_OMP_MASK_PARALLEL
| GFC_OMP_MASK_DO
;
4039 innermost
= GFC_OMP_SPLIT_DO
;
4041 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
4042 mask
= GFC_OMP_MASK_DISTRIBUTE
| GFC_OMP_MASK_PARALLEL
4043 | GFC_OMP_MASK_DO
| GFC_OMP_MASK_SIMD
;
4044 innermost
= GFC_OMP_SPLIT_SIMD
;
4046 case EXEC_OMP_DISTRIBUTE_SIMD
:
4047 mask
= GFC_OMP_MASK_DISTRIBUTE
| GFC_OMP_MASK_SIMD
;
4048 innermost
= GFC_OMP_SPLIT_SIMD
;
4051 innermost
= GFC_OMP_SPLIT_DO
;
4053 case EXEC_OMP_DO_SIMD
:
4054 mask
= GFC_OMP_MASK_DO
| GFC_OMP_MASK_SIMD
;
4055 innermost
= GFC_OMP_SPLIT_SIMD
;
4057 case EXEC_OMP_PARALLEL
:
4058 innermost
= GFC_OMP_SPLIT_PARALLEL
;
4060 case EXEC_OMP_PARALLEL_DO
:
4061 mask
= GFC_OMP_MASK_PARALLEL
| GFC_OMP_MASK_DO
;
4062 innermost
= GFC_OMP_SPLIT_DO
;
4064 case EXEC_OMP_PARALLEL_DO_SIMD
:
4065 mask
= GFC_OMP_MASK_PARALLEL
| GFC_OMP_MASK_DO
| GFC_OMP_MASK_SIMD
;
4066 innermost
= GFC_OMP_SPLIT_SIMD
;
4069 innermost
= GFC_OMP_SPLIT_SIMD
;
4071 case EXEC_OMP_TARGET
:
4072 innermost
= GFC_OMP_SPLIT_TARGET
;
4074 case EXEC_OMP_TARGET_PARALLEL
:
4075 mask
= GFC_OMP_MASK_TARGET
| GFC_OMP_MASK_PARALLEL
;
4076 innermost
= GFC_OMP_SPLIT_PARALLEL
;
4078 case EXEC_OMP_TARGET_PARALLEL_DO
:
4079 mask
= GFC_OMP_MASK_TARGET
| GFC_OMP_MASK_PARALLEL
| GFC_OMP_MASK_DO
;
4080 innermost
= GFC_OMP_SPLIT_DO
;
4082 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
4083 mask
= GFC_OMP_MASK_TARGET
| GFC_OMP_MASK_PARALLEL
| GFC_OMP_MASK_DO
4084 | GFC_OMP_MASK_SIMD
;
4085 innermost
= GFC_OMP_SPLIT_SIMD
;
4087 case EXEC_OMP_TARGET_SIMD
:
4088 mask
= GFC_OMP_MASK_TARGET
| GFC_OMP_MASK_SIMD
;
4089 innermost
= GFC_OMP_SPLIT_SIMD
;
4091 case EXEC_OMP_TARGET_TEAMS
:
4092 mask
= GFC_OMP_MASK_TARGET
| GFC_OMP_MASK_TEAMS
;
4093 innermost
= GFC_OMP_SPLIT_TEAMS
;
4095 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
4096 mask
= GFC_OMP_MASK_TARGET
| GFC_OMP_MASK_TEAMS
4097 | GFC_OMP_MASK_DISTRIBUTE
;
4098 innermost
= GFC_OMP_SPLIT_DISTRIBUTE
;
4100 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
4101 mask
= GFC_OMP_MASK_TARGET
| GFC_OMP_MASK_TEAMS
| GFC_OMP_MASK_DISTRIBUTE
4102 | GFC_OMP_MASK_PARALLEL
| GFC_OMP_MASK_DO
;
4103 innermost
= GFC_OMP_SPLIT_DO
;
4105 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
4106 mask
= GFC_OMP_MASK_TARGET
| GFC_OMP_MASK_TEAMS
| GFC_OMP_MASK_DISTRIBUTE
4107 | GFC_OMP_MASK_PARALLEL
| GFC_OMP_MASK_DO
| GFC_OMP_MASK_SIMD
;
4108 innermost
= GFC_OMP_SPLIT_SIMD
;
4110 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
4111 mask
= GFC_OMP_MASK_TARGET
| GFC_OMP_MASK_TEAMS
4112 | GFC_OMP_MASK_DISTRIBUTE
| GFC_OMP_MASK_SIMD
;
4113 innermost
= GFC_OMP_SPLIT_SIMD
;
4115 case EXEC_OMP_TASKLOOP
:
4116 innermost
= GFC_OMP_SPLIT_TASKLOOP
;
4118 case EXEC_OMP_TASKLOOP_SIMD
:
4119 mask
= GFC_OMP_MASK_TASKLOOP
| GFC_OMP_MASK_SIMD
;
4120 innermost
= GFC_OMP_SPLIT_SIMD
;
4122 case EXEC_OMP_TEAMS
:
4123 innermost
= GFC_OMP_SPLIT_TEAMS
;
4125 case EXEC_OMP_TEAMS_DISTRIBUTE
:
4126 mask
= GFC_OMP_MASK_TEAMS
| GFC_OMP_MASK_DISTRIBUTE
;
4127 innermost
= GFC_OMP_SPLIT_DISTRIBUTE
;
4129 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
4130 mask
= GFC_OMP_MASK_TEAMS
| GFC_OMP_MASK_DISTRIBUTE
4131 | GFC_OMP_MASK_PARALLEL
| GFC_OMP_MASK_DO
;
4132 innermost
= GFC_OMP_SPLIT_DO
;
4134 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
4135 mask
= GFC_OMP_MASK_TEAMS
| GFC_OMP_MASK_DISTRIBUTE
4136 | GFC_OMP_MASK_PARALLEL
| GFC_OMP_MASK_DO
| GFC_OMP_MASK_SIMD
;
4137 innermost
= GFC_OMP_SPLIT_SIMD
;
4139 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
4140 mask
= GFC_OMP_MASK_TEAMS
| GFC_OMP_MASK_DISTRIBUTE
| GFC_OMP_MASK_SIMD
;
4141 innermost
= GFC_OMP_SPLIT_SIMD
;
4148 clausesa
[innermost
] = *code
->ext
.omp_clauses
;
4151 if (code
->ext
.omp_clauses
!= NULL
)
4153 if (mask
& GFC_OMP_MASK_TARGET
)
4155 /* First the clauses that are unique to some constructs. */
4156 clausesa
[GFC_OMP_SPLIT_TARGET
].lists
[OMP_LIST_MAP
]
4157 = code
->ext
.omp_clauses
->lists
[OMP_LIST_MAP
];
4158 clausesa
[GFC_OMP_SPLIT_TARGET
].lists
[OMP_LIST_IS_DEVICE_PTR
]
4159 = code
->ext
.omp_clauses
->lists
[OMP_LIST_IS_DEVICE_PTR
];
4160 clausesa
[GFC_OMP_SPLIT_TARGET
].device
4161 = code
->ext
.omp_clauses
->device
;
4162 clausesa
[GFC_OMP_SPLIT_TARGET
].defaultmap
4163 = code
->ext
.omp_clauses
->defaultmap
;
4164 clausesa
[GFC_OMP_SPLIT_TARGET
].if_exprs
[OMP_IF_TARGET
]
4165 = code
->ext
.omp_clauses
->if_exprs
[OMP_IF_TARGET
];
4166 /* And this is copied to all. */
4167 clausesa
[GFC_OMP_SPLIT_PARALLEL
].if_expr
4168 = code
->ext
.omp_clauses
->if_expr
;
4170 if (mask
& GFC_OMP_MASK_TEAMS
)
4172 /* First the clauses that are unique to some constructs. */
4173 clausesa
[GFC_OMP_SPLIT_TEAMS
].num_teams
4174 = code
->ext
.omp_clauses
->num_teams
;
4175 clausesa
[GFC_OMP_SPLIT_TEAMS
].thread_limit
4176 = code
->ext
.omp_clauses
->thread_limit
;
4177 /* Shared and default clauses are allowed on parallel, teams
4179 clausesa
[GFC_OMP_SPLIT_TEAMS
].lists
[OMP_LIST_SHARED
]
4180 = code
->ext
.omp_clauses
->lists
[OMP_LIST_SHARED
];
4181 clausesa
[GFC_OMP_SPLIT_TEAMS
].default_sharing
4182 = code
->ext
.omp_clauses
->default_sharing
;
4184 if (mask
& GFC_OMP_MASK_DISTRIBUTE
)
4186 /* First the clauses that are unique to some constructs. */
4187 clausesa
[GFC_OMP_SPLIT_DISTRIBUTE
].dist_sched_kind
4188 = code
->ext
.omp_clauses
->dist_sched_kind
;
4189 clausesa
[GFC_OMP_SPLIT_DISTRIBUTE
].dist_chunk_size
4190 = code
->ext
.omp_clauses
->dist_chunk_size
;
4191 /* Duplicate collapse. */
4192 clausesa
[GFC_OMP_SPLIT_DISTRIBUTE
].collapse
4193 = code
->ext
.omp_clauses
->collapse
;
4195 if (mask
& GFC_OMP_MASK_PARALLEL
)
4197 /* First the clauses that are unique to some constructs. */
4198 clausesa
[GFC_OMP_SPLIT_PARALLEL
].lists
[OMP_LIST_COPYIN
]
4199 = code
->ext
.omp_clauses
->lists
[OMP_LIST_COPYIN
];
4200 clausesa
[GFC_OMP_SPLIT_PARALLEL
].num_threads
4201 = code
->ext
.omp_clauses
->num_threads
;
4202 clausesa
[GFC_OMP_SPLIT_PARALLEL
].proc_bind
4203 = code
->ext
.omp_clauses
->proc_bind
;
4204 /* Shared and default clauses are allowed on parallel, teams
4206 clausesa
[GFC_OMP_SPLIT_PARALLEL
].lists
[OMP_LIST_SHARED
]
4207 = code
->ext
.omp_clauses
->lists
[OMP_LIST_SHARED
];
4208 clausesa
[GFC_OMP_SPLIT_PARALLEL
].default_sharing
4209 = code
->ext
.omp_clauses
->default_sharing
;
4210 clausesa
[GFC_OMP_SPLIT_PARALLEL
].if_exprs
[OMP_IF_PARALLEL
]
4211 = code
->ext
.omp_clauses
->if_exprs
[OMP_IF_PARALLEL
];
4212 /* And this is copied to all. */
4213 clausesa
[GFC_OMP_SPLIT_PARALLEL
].if_expr
4214 = code
->ext
.omp_clauses
->if_expr
;
4216 if (mask
& GFC_OMP_MASK_DO
)
4218 /* First the clauses that are unique to some constructs. */
4219 clausesa
[GFC_OMP_SPLIT_DO
].ordered
4220 = code
->ext
.omp_clauses
->ordered
;
4221 clausesa
[GFC_OMP_SPLIT_DO
].orderedc
4222 = code
->ext
.omp_clauses
->orderedc
;
4223 clausesa
[GFC_OMP_SPLIT_DO
].sched_kind
4224 = code
->ext
.omp_clauses
->sched_kind
;
4225 if (innermost
== GFC_OMP_SPLIT_SIMD
)
4226 clausesa
[GFC_OMP_SPLIT_DO
].sched_simd
4227 = code
->ext
.omp_clauses
->sched_simd
;
4228 clausesa
[GFC_OMP_SPLIT_DO
].sched_monotonic
4229 = code
->ext
.omp_clauses
->sched_monotonic
;
4230 clausesa
[GFC_OMP_SPLIT_DO
].sched_nonmonotonic
4231 = code
->ext
.omp_clauses
->sched_nonmonotonic
;
4232 clausesa
[GFC_OMP_SPLIT_DO
].chunk_size
4233 = code
->ext
.omp_clauses
->chunk_size
;
4234 clausesa
[GFC_OMP_SPLIT_DO
].nowait
4235 = code
->ext
.omp_clauses
->nowait
;
4236 /* Duplicate collapse. */
4237 clausesa
[GFC_OMP_SPLIT_DO
].collapse
4238 = code
->ext
.omp_clauses
->collapse
;
4240 if (mask
& GFC_OMP_MASK_SIMD
)
4242 clausesa
[GFC_OMP_SPLIT_SIMD
].safelen_expr
4243 = code
->ext
.omp_clauses
->safelen_expr
;
4244 clausesa
[GFC_OMP_SPLIT_SIMD
].simdlen_expr
4245 = code
->ext
.omp_clauses
->simdlen_expr
;
4246 clausesa
[GFC_OMP_SPLIT_SIMD
].lists
[OMP_LIST_ALIGNED
]
4247 = code
->ext
.omp_clauses
->lists
[OMP_LIST_ALIGNED
];
4248 /* Duplicate collapse. */
4249 clausesa
[GFC_OMP_SPLIT_SIMD
].collapse
4250 = code
->ext
.omp_clauses
->collapse
;
4252 if (mask
& GFC_OMP_MASK_TASKLOOP
)
4254 /* First the clauses that are unique to some constructs. */
4255 clausesa
[GFC_OMP_SPLIT_TASKLOOP
].nogroup
4256 = code
->ext
.omp_clauses
->nogroup
;
4257 clausesa
[GFC_OMP_SPLIT_TASKLOOP
].grainsize
4258 = code
->ext
.omp_clauses
->grainsize
;
4259 clausesa
[GFC_OMP_SPLIT_TASKLOOP
].num_tasks
4260 = code
->ext
.omp_clauses
->num_tasks
;
4261 clausesa
[GFC_OMP_SPLIT_TASKLOOP
].priority
4262 = code
->ext
.omp_clauses
->priority
;
4263 clausesa
[GFC_OMP_SPLIT_TASKLOOP
].final_expr
4264 = code
->ext
.omp_clauses
->final_expr
;
4265 clausesa
[GFC_OMP_SPLIT_TASKLOOP
].untied
4266 = code
->ext
.omp_clauses
->untied
;
4267 clausesa
[GFC_OMP_SPLIT_TASKLOOP
].mergeable
4268 = code
->ext
.omp_clauses
->mergeable
;
4269 clausesa
[GFC_OMP_SPLIT_TASKLOOP
].if_exprs
[OMP_IF_TASKLOOP
]
4270 = code
->ext
.omp_clauses
->if_exprs
[OMP_IF_TASKLOOP
];
4271 /* And this is copied to all. */
4272 clausesa
[GFC_OMP_SPLIT_TASKLOOP
].if_expr
4273 = code
->ext
.omp_clauses
->if_expr
;
4274 /* Shared and default clauses are allowed on parallel, teams
4276 clausesa
[GFC_OMP_SPLIT_TASKLOOP
].lists
[OMP_LIST_SHARED
]
4277 = code
->ext
.omp_clauses
->lists
[OMP_LIST_SHARED
];
4278 clausesa
[GFC_OMP_SPLIT_TASKLOOP
].default_sharing
4279 = code
->ext
.omp_clauses
->default_sharing
;
4280 /* Duplicate collapse. */
4281 clausesa
[GFC_OMP_SPLIT_TASKLOOP
].collapse
4282 = code
->ext
.omp_clauses
->collapse
;
4284 /* Private clause is supported on all constructs,
4285 it is enough to put it on the innermost one. For
4286 !$ omp parallel do put it on parallel though,
4287 as that's what we did for OpenMP 3.1. */
4288 clausesa
[innermost
== GFC_OMP_SPLIT_DO
4289 ? (int) GFC_OMP_SPLIT_PARALLEL
4290 : innermost
].lists
[OMP_LIST_PRIVATE
]
4291 = code
->ext
.omp_clauses
->lists
[OMP_LIST_PRIVATE
];
4292 /* Firstprivate clause is supported on all constructs but
4293 simd. Put it on the outermost of those and duplicate
4294 on parallel and teams. */
4295 if (mask
& GFC_OMP_MASK_TARGET
)
4296 clausesa
[GFC_OMP_SPLIT_TARGET
].lists
[OMP_LIST_FIRSTPRIVATE
]
4297 = code
->ext
.omp_clauses
->lists
[OMP_LIST_FIRSTPRIVATE
];
4298 if (mask
& GFC_OMP_MASK_TEAMS
)
4299 clausesa
[GFC_OMP_SPLIT_TEAMS
].lists
[OMP_LIST_FIRSTPRIVATE
]
4300 = code
->ext
.omp_clauses
->lists
[OMP_LIST_FIRSTPRIVATE
];
4301 else if (mask
& GFC_OMP_MASK_DISTRIBUTE
)
4302 clausesa
[GFC_OMP_SPLIT_DISTRIBUTE
].lists
[OMP_LIST_FIRSTPRIVATE
]
4303 = code
->ext
.omp_clauses
->lists
[OMP_LIST_FIRSTPRIVATE
];
4304 if (mask
& GFC_OMP_MASK_PARALLEL
)
4305 clausesa
[GFC_OMP_SPLIT_PARALLEL
].lists
[OMP_LIST_FIRSTPRIVATE
]
4306 = code
->ext
.omp_clauses
->lists
[OMP_LIST_FIRSTPRIVATE
];
4307 else if (mask
& GFC_OMP_MASK_DO
)
4308 clausesa
[GFC_OMP_SPLIT_DO
].lists
[OMP_LIST_FIRSTPRIVATE
]
4309 = code
->ext
.omp_clauses
->lists
[OMP_LIST_FIRSTPRIVATE
];
4310 /* Lastprivate is allowed on distribute, do and simd.
4311 In parallel do{, simd} we actually want to put it on
4312 parallel rather than do. */
4313 if (mask
& GFC_OMP_MASK_DISTRIBUTE
)
4314 clausesa
[GFC_OMP_SPLIT_DISTRIBUTE
].lists
[OMP_LIST_LASTPRIVATE
]
4315 = code
->ext
.omp_clauses
->lists
[OMP_LIST_LASTPRIVATE
];
4316 if (mask
& GFC_OMP_MASK_PARALLEL
)
4317 clausesa
[GFC_OMP_SPLIT_PARALLEL
].lists
[OMP_LIST_LASTPRIVATE
]
4318 = code
->ext
.omp_clauses
->lists
[OMP_LIST_LASTPRIVATE
];
4319 else if (mask
& GFC_OMP_MASK_DO
)
4320 clausesa
[GFC_OMP_SPLIT_DO
].lists
[OMP_LIST_LASTPRIVATE
]
4321 = code
->ext
.omp_clauses
->lists
[OMP_LIST_LASTPRIVATE
];
4322 if (mask
& GFC_OMP_MASK_SIMD
)
4323 clausesa
[GFC_OMP_SPLIT_SIMD
].lists
[OMP_LIST_LASTPRIVATE
]
4324 = code
->ext
.omp_clauses
->lists
[OMP_LIST_LASTPRIVATE
];
4325 /* Reduction is allowed on simd, do, parallel and teams.
4326 Duplicate it on all of them, but omit on do if
4327 parallel is present. */
4328 if (mask
& GFC_OMP_MASK_TEAMS
)
4329 clausesa
[GFC_OMP_SPLIT_TEAMS
].lists
[OMP_LIST_REDUCTION
]
4330 = code
->ext
.omp_clauses
->lists
[OMP_LIST_REDUCTION
];
4331 if (mask
& GFC_OMP_MASK_PARALLEL
)
4332 clausesa
[GFC_OMP_SPLIT_PARALLEL
].lists
[OMP_LIST_REDUCTION
]
4333 = code
->ext
.omp_clauses
->lists
[OMP_LIST_REDUCTION
];
4334 else if (mask
& GFC_OMP_MASK_DO
)
4335 clausesa
[GFC_OMP_SPLIT_DO
].lists
[OMP_LIST_REDUCTION
]
4336 = code
->ext
.omp_clauses
->lists
[OMP_LIST_REDUCTION
];
4337 if (mask
& GFC_OMP_MASK_SIMD
)
4338 clausesa
[GFC_OMP_SPLIT_SIMD
].lists
[OMP_LIST_REDUCTION
]
4339 = code
->ext
.omp_clauses
->lists
[OMP_LIST_REDUCTION
];
4340 /* Linear clause is supported on do and simd,
4341 put it on the innermost one. */
4342 clausesa
[innermost
].lists
[OMP_LIST_LINEAR
]
4343 = code
->ext
.omp_clauses
->lists
[OMP_LIST_LINEAR
];
4345 if ((mask
& (GFC_OMP_MASK_PARALLEL
| GFC_OMP_MASK_DO
))
4346 == (GFC_OMP_MASK_PARALLEL
| GFC_OMP_MASK_DO
))
4347 clausesa
[GFC_OMP_SPLIT_DO
].nowait
= true;
4351 gfc_trans_omp_do_simd (gfc_code
*code
, stmtblock_t
*pblock
,
4352 gfc_omp_clauses
*clausesa
, tree omp_clauses
)
4355 gfc_omp_clauses clausesa_buf
[GFC_OMP_SPLIT_NUM
];
4356 tree stmt
, body
, omp_do_clauses
= NULL_TREE
;
4359 gfc_start_block (&block
);
4361 gfc_init_block (&block
);
4363 if (clausesa
== NULL
)
4365 clausesa
= clausesa_buf
;
4366 gfc_split_omp_clauses (code
, clausesa
);
4370 = gfc_trans_omp_clauses (&block
, &clausesa
[GFC_OMP_SPLIT_DO
], code
->loc
);
4371 body
= gfc_trans_omp_do (code
, EXEC_OMP_SIMD
, pblock
? pblock
: &block
,
4372 &clausesa
[GFC_OMP_SPLIT_SIMD
], omp_clauses
);
4375 if (TREE_CODE (body
) != BIND_EXPR
)
4376 body
= build3_v (BIND_EXPR
, NULL
, body
, poplevel (1, 0));
4380 else if (TREE_CODE (body
) != BIND_EXPR
)
4381 body
= build3_v (BIND_EXPR
, NULL
, body
, NULL_TREE
);
4384 stmt
= make_node (OMP_FOR
);
4385 TREE_TYPE (stmt
) = void_type_node
;
4386 OMP_FOR_BODY (stmt
) = body
;
4387 OMP_FOR_CLAUSES (stmt
) = omp_do_clauses
;
4391 gfc_add_expr_to_block (&block
, stmt
);
4392 return gfc_finish_block (&block
);
4396 gfc_trans_omp_parallel_do (gfc_code
*code
, stmtblock_t
*pblock
,
4397 gfc_omp_clauses
*clausesa
)
4399 stmtblock_t block
, *new_pblock
= pblock
;
4400 gfc_omp_clauses clausesa_buf
[GFC_OMP_SPLIT_NUM
];
4401 tree stmt
, omp_clauses
= NULL_TREE
;
4404 gfc_start_block (&block
);
4406 gfc_init_block (&block
);
4408 if (clausesa
== NULL
)
4410 clausesa
= clausesa_buf
;
4411 gfc_split_omp_clauses (code
, clausesa
);
4414 = gfc_trans_omp_clauses (&block
, &clausesa
[GFC_OMP_SPLIT_PARALLEL
],
4418 if (!clausesa
[GFC_OMP_SPLIT_DO
].ordered
4419 && clausesa
[GFC_OMP_SPLIT_DO
].sched_kind
!= OMP_SCHED_STATIC
)
4420 new_pblock
= &block
;
4424 stmt
= gfc_trans_omp_do (code
, EXEC_OMP_DO
, new_pblock
,
4425 &clausesa
[GFC_OMP_SPLIT_DO
], omp_clauses
);
4428 if (TREE_CODE (stmt
) != BIND_EXPR
)
4429 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
4433 else if (TREE_CODE (stmt
) != BIND_EXPR
)
4434 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, NULL_TREE
);
4435 stmt
= build2_loc (input_location
, OMP_PARALLEL
, void_type_node
, stmt
,
4437 OMP_PARALLEL_COMBINED (stmt
) = 1;
4438 gfc_add_expr_to_block (&block
, stmt
);
4439 return gfc_finish_block (&block
);
4443 gfc_trans_omp_parallel_do_simd (gfc_code
*code
, stmtblock_t
*pblock
,
4444 gfc_omp_clauses
*clausesa
)
4447 gfc_omp_clauses clausesa_buf
[GFC_OMP_SPLIT_NUM
];
4448 tree stmt
, omp_clauses
= NULL_TREE
;
4451 gfc_start_block (&block
);
4453 gfc_init_block (&block
);
4455 if (clausesa
== NULL
)
4457 clausesa
= clausesa_buf
;
4458 gfc_split_omp_clauses (code
, clausesa
);
4462 = gfc_trans_omp_clauses (&block
, &clausesa
[GFC_OMP_SPLIT_PARALLEL
],
4466 stmt
= gfc_trans_omp_do_simd (code
, pblock
, clausesa
, omp_clauses
);
4469 if (TREE_CODE (stmt
) != BIND_EXPR
)
4470 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
4474 else if (TREE_CODE (stmt
) != BIND_EXPR
)
4475 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, NULL_TREE
);
4478 stmt
= build2_loc (input_location
, OMP_PARALLEL
, void_type_node
, stmt
,
4480 OMP_PARALLEL_COMBINED (stmt
) = 1;
4482 gfc_add_expr_to_block (&block
, stmt
);
4483 return gfc_finish_block (&block
);
4487 gfc_trans_omp_parallel_sections (gfc_code
*code
)
4490 gfc_omp_clauses section_clauses
;
4491 tree stmt
, omp_clauses
;
4493 memset (§ion_clauses
, 0, sizeof (section_clauses
));
4494 section_clauses
.nowait
= true;
4496 gfc_start_block (&block
);
4497 omp_clauses
= gfc_trans_omp_clauses (&block
, code
->ext
.omp_clauses
,
4500 stmt
= gfc_trans_omp_sections (code
, §ion_clauses
);
4501 if (TREE_CODE (stmt
) != BIND_EXPR
)
4502 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
4505 stmt
= build2_loc (input_location
, OMP_PARALLEL
, void_type_node
, stmt
,
4507 OMP_PARALLEL_COMBINED (stmt
) = 1;
4508 gfc_add_expr_to_block (&block
, stmt
);
4509 return gfc_finish_block (&block
);
4513 gfc_trans_omp_parallel_workshare (gfc_code
*code
)
4516 gfc_omp_clauses workshare_clauses
;
4517 tree stmt
, omp_clauses
;
4519 memset (&workshare_clauses
, 0, sizeof (workshare_clauses
));
4520 workshare_clauses
.nowait
= true;
4522 gfc_start_block (&block
);
4523 omp_clauses
= gfc_trans_omp_clauses (&block
, code
->ext
.omp_clauses
,
4526 stmt
= gfc_trans_omp_workshare (code
, &workshare_clauses
);
4527 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
4528 stmt
= build2_loc (input_location
, OMP_PARALLEL
, void_type_node
, stmt
,
4530 OMP_PARALLEL_COMBINED (stmt
) = 1;
4531 gfc_add_expr_to_block (&block
, stmt
);
4532 return gfc_finish_block (&block
);
4536 gfc_trans_omp_sections (gfc_code
*code
, gfc_omp_clauses
*clauses
)
4538 stmtblock_t block
, body
;
4539 tree omp_clauses
, stmt
;
4540 bool has_lastprivate
= clauses
->lists
[OMP_LIST_LASTPRIVATE
] != NULL
;
4542 gfc_start_block (&block
);
4544 omp_clauses
= gfc_trans_omp_clauses (&block
, clauses
, code
->loc
);
4546 gfc_init_block (&body
);
4547 for (code
= code
->block
; code
; code
= code
->block
)
4549 /* Last section is special because of lastprivate, so even if it
4550 is empty, chain it in. */
4551 stmt
= gfc_trans_omp_code (code
->next
,
4552 has_lastprivate
&& code
->block
== NULL
);
4553 if (! IS_EMPTY_STMT (stmt
))
4555 stmt
= build1_v (OMP_SECTION
, stmt
);
4556 gfc_add_expr_to_block (&body
, stmt
);
4559 stmt
= gfc_finish_block (&body
);
4561 stmt
= build2_loc (input_location
, OMP_SECTIONS
, void_type_node
, stmt
,
4563 gfc_add_expr_to_block (&block
, stmt
);
4565 return gfc_finish_block (&block
);
4569 gfc_trans_omp_single (gfc_code
*code
, gfc_omp_clauses
*clauses
)
4571 tree omp_clauses
= gfc_trans_omp_clauses (NULL
, clauses
, code
->loc
);
4572 tree stmt
= gfc_trans_omp_code (code
->block
->next
, true);
4573 stmt
= build2_loc (input_location
, OMP_SINGLE
, void_type_node
, stmt
,
4579 gfc_trans_omp_task (gfc_code
*code
)
4582 tree stmt
, omp_clauses
;
4584 gfc_start_block (&block
);
4585 omp_clauses
= gfc_trans_omp_clauses (&block
, code
->ext
.omp_clauses
,
4588 stmt
= gfc_trans_omp_code (code
->block
->next
, true);
4589 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
4590 stmt
= build2_loc (input_location
, OMP_TASK
, void_type_node
, stmt
,
4592 gfc_add_expr_to_block (&block
, stmt
);
4593 return gfc_finish_block (&block
);
4597 gfc_trans_omp_taskgroup (gfc_code
*code
)
4599 tree body
= gfc_trans_code (code
->block
->next
);
4600 tree stmt
= make_node (OMP_TASKGROUP
);
4601 TREE_TYPE (stmt
) = void_type_node
;
4602 OMP_TASKGROUP_BODY (stmt
) = body
;
4603 OMP_TASKGROUP_CLAUSES (stmt
) = NULL_TREE
;
4608 gfc_trans_omp_taskwait (void)
4610 tree decl
= builtin_decl_explicit (BUILT_IN_GOMP_TASKWAIT
);
4611 return build_call_expr_loc (input_location
, decl
, 0);
4615 gfc_trans_omp_taskyield (void)
4617 tree decl
= builtin_decl_explicit (BUILT_IN_GOMP_TASKYIELD
);
4618 return build_call_expr_loc (input_location
, decl
, 0);
4622 gfc_trans_omp_distribute (gfc_code
*code
, gfc_omp_clauses
*clausesa
)
4625 gfc_omp_clauses clausesa_buf
[GFC_OMP_SPLIT_NUM
];
4626 tree stmt
, omp_clauses
= NULL_TREE
;
4628 gfc_start_block (&block
);
4629 if (clausesa
== NULL
)
4631 clausesa
= clausesa_buf
;
4632 gfc_split_omp_clauses (code
, clausesa
);
4636 = gfc_trans_omp_clauses (&block
, &clausesa
[GFC_OMP_SPLIT_DISTRIBUTE
],
4640 case EXEC_OMP_DISTRIBUTE
:
4641 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
4642 case EXEC_OMP_TEAMS_DISTRIBUTE
:
4643 /* This is handled in gfc_trans_omp_do. */
4646 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
4647 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
4648 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
4649 stmt
= gfc_trans_omp_parallel_do (code
, &block
, clausesa
);
4650 if (TREE_CODE (stmt
) != BIND_EXPR
)
4651 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
4655 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
4656 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
4657 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
4658 stmt
= gfc_trans_omp_parallel_do_simd (code
, &block
, clausesa
);
4659 if (TREE_CODE (stmt
) != BIND_EXPR
)
4660 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
4664 case EXEC_OMP_DISTRIBUTE_SIMD
:
4665 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
4666 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
4667 stmt
= gfc_trans_omp_do (code
, EXEC_OMP_SIMD
, &block
,
4668 &clausesa
[GFC_OMP_SPLIT_SIMD
], NULL_TREE
);
4669 if (TREE_CODE (stmt
) != BIND_EXPR
)
4670 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
4679 tree distribute
= make_node (OMP_DISTRIBUTE
);
4680 TREE_TYPE (distribute
) = void_type_node
;
4681 OMP_FOR_BODY (distribute
) = stmt
;
4682 OMP_FOR_CLAUSES (distribute
) = omp_clauses
;
4685 gfc_add_expr_to_block (&block
, stmt
);
4686 return gfc_finish_block (&block
);
4690 gfc_trans_omp_teams (gfc_code
*code
, gfc_omp_clauses
*clausesa
,
4694 gfc_omp_clauses clausesa_buf
[GFC_OMP_SPLIT_NUM
];
4696 bool combined
= true;
4698 gfc_start_block (&block
);
4699 if (clausesa
== NULL
)
4701 clausesa
= clausesa_buf
;
4702 gfc_split_omp_clauses (code
, clausesa
);
4706 = chainon (omp_clauses
,
4707 gfc_trans_omp_clauses (&block
, &clausesa
[GFC_OMP_SPLIT_TEAMS
],
4711 case EXEC_OMP_TARGET_TEAMS
:
4712 case EXEC_OMP_TEAMS
:
4713 stmt
= gfc_trans_omp_code (code
->block
->next
, true);
4716 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
4717 case EXEC_OMP_TEAMS_DISTRIBUTE
:
4718 stmt
= gfc_trans_omp_do (code
, EXEC_OMP_DISTRIBUTE
, NULL
,
4719 &clausesa
[GFC_OMP_SPLIT_DISTRIBUTE
],
4723 stmt
= gfc_trans_omp_distribute (code
, clausesa
);
4728 stmt
= build2_loc (input_location
, OMP_TEAMS
, void_type_node
, stmt
,
4731 OMP_TEAMS_COMBINED (stmt
) = 1;
4733 gfc_add_expr_to_block (&block
, stmt
);
4734 return gfc_finish_block (&block
);
4738 gfc_trans_omp_target (gfc_code
*code
)
4741 gfc_omp_clauses clausesa
[GFC_OMP_SPLIT_NUM
];
4742 tree stmt
, omp_clauses
= NULL_TREE
;
4744 gfc_start_block (&block
);
4745 gfc_split_omp_clauses (code
, clausesa
);
4748 = gfc_trans_omp_clauses (&block
, &clausesa
[GFC_OMP_SPLIT_TARGET
],
4752 case EXEC_OMP_TARGET
:
4754 stmt
= gfc_trans_omp_code (code
->block
->next
, true);
4755 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
4757 case EXEC_OMP_TARGET_PARALLEL
:
4761 gfc_start_block (&iblock
);
4763 = gfc_trans_omp_clauses (&block
, &clausesa
[GFC_OMP_SPLIT_PARALLEL
],
4765 stmt
= gfc_trans_omp_code (code
->block
->next
, true);
4766 stmt
= build2_loc (input_location
, OMP_PARALLEL
, void_type_node
, stmt
,
4768 gfc_add_expr_to_block (&iblock
, stmt
);
4769 stmt
= gfc_finish_block (&iblock
);
4770 if (TREE_CODE (stmt
) != BIND_EXPR
)
4771 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
4776 case EXEC_OMP_TARGET_PARALLEL_DO
:
4777 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
4778 stmt
= gfc_trans_omp_parallel_do (code
, &block
, clausesa
);
4779 if (TREE_CODE (stmt
) != BIND_EXPR
)
4780 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
4784 case EXEC_OMP_TARGET_SIMD
:
4785 stmt
= gfc_trans_omp_do (code
, EXEC_OMP_SIMD
, &block
,
4786 &clausesa
[GFC_OMP_SPLIT_SIMD
], NULL_TREE
);
4787 if (TREE_CODE (stmt
) != BIND_EXPR
)
4788 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
4794 && (clausesa
[GFC_OMP_SPLIT_TEAMS
].num_teams
4795 || clausesa
[GFC_OMP_SPLIT_TEAMS
].thread_limit
))
4797 gfc_omp_clauses clausesb
;
4799 /* For combined !$omp target teams, the num_teams and
4800 thread_limit clauses are evaluated before entering the
4801 target construct. */
4802 memset (&clausesb
, '\0', sizeof (clausesb
));
4803 clausesb
.num_teams
= clausesa
[GFC_OMP_SPLIT_TEAMS
].num_teams
;
4804 clausesb
.thread_limit
= clausesa
[GFC_OMP_SPLIT_TEAMS
].thread_limit
;
4805 clausesa
[GFC_OMP_SPLIT_TEAMS
].num_teams
= NULL
;
4806 clausesa
[GFC_OMP_SPLIT_TEAMS
].thread_limit
= NULL
;
4808 = gfc_trans_omp_clauses (&block
, &clausesb
, code
->loc
);
4810 stmt
= gfc_trans_omp_teams (code
, clausesa
, teams_clauses
);
4815 stmt
= gfc_trans_omp_teams (code
, clausesa
, NULL_TREE
);
4817 if (TREE_CODE (stmt
) != BIND_EXPR
)
4818 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
4825 stmt
= build2_loc (input_location
, OMP_TARGET
, void_type_node
, stmt
,
4827 if (code
->op
!= EXEC_OMP_TARGET
)
4828 OMP_TARGET_COMBINED (stmt
) = 1;
4830 gfc_add_expr_to_block (&block
, stmt
);
4831 return gfc_finish_block (&block
);
4835 gfc_trans_omp_taskloop (gfc_code
*code
)
4838 gfc_omp_clauses clausesa
[GFC_OMP_SPLIT_NUM
];
4839 tree stmt
, omp_clauses
= NULL_TREE
;
4841 gfc_start_block (&block
);
4842 gfc_split_omp_clauses (code
, clausesa
);
4845 = gfc_trans_omp_clauses (&block
, &clausesa
[GFC_OMP_SPLIT_TASKLOOP
],
4849 case EXEC_OMP_TASKLOOP
:
4850 /* This is handled in gfc_trans_omp_do. */
4853 case EXEC_OMP_TASKLOOP_SIMD
:
4854 stmt
= gfc_trans_omp_do (code
, EXEC_OMP_SIMD
, &block
,
4855 &clausesa
[GFC_OMP_SPLIT_SIMD
], NULL_TREE
);
4856 if (TREE_CODE (stmt
) != BIND_EXPR
)
4857 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
4866 tree taskloop
= make_node (OMP_TASKLOOP
);
4867 TREE_TYPE (taskloop
) = void_type_node
;
4868 OMP_FOR_BODY (taskloop
) = stmt
;
4869 OMP_FOR_CLAUSES (taskloop
) = omp_clauses
;
4872 gfc_add_expr_to_block (&block
, stmt
);
4873 return gfc_finish_block (&block
);
4877 gfc_trans_omp_target_data (gfc_code
*code
)
4880 tree stmt
, omp_clauses
;
4882 gfc_start_block (&block
);
4883 omp_clauses
= gfc_trans_omp_clauses (&block
, code
->ext
.omp_clauses
,
4885 stmt
= gfc_trans_omp_code (code
->block
->next
, true);
4886 stmt
= build2_loc (input_location
, OMP_TARGET_DATA
, void_type_node
, stmt
,
4888 gfc_add_expr_to_block (&block
, stmt
);
4889 return gfc_finish_block (&block
);
4893 gfc_trans_omp_target_enter_data (gfc_code
*code
)
4896 tree stmt
, omp_clauses
;
4898 gfc_start_block (&block
);
4899 omp_clauses
= gfc_trans_omp_clauses (&block
, code
->ext
.omp_clauses
,
4901 stmt
= build1_loc (input_location
, OMP_TARGET_ENTER_DATA
, void_type_node
,
4903 gfc_add_expr_to_block (&block
, stmt
);
4904 return gfc_finish_block (&block
);
4908 gfc_trans_omp_target_exit_data (gfc_code
*code
)
4911 tree stmt
, omp_clauses
;
4913 gfc_start_block (&block
);
4914 omp_clauses
= gfc_trans_omp_clauses (&block
, code
->ext
.omp_clauses
,
4916 stmt
= build1_loc (input_location
, OMP_TARGET_EXIT_DATA
, void_type_node
,
4918 gfc_add_expr_to_block (&block
, stmt
);
4919 return gfc_finish_block (&block
);
4923 gfc_trans_omp_target_update (gfc_code
*code
)
4926 tree stmt
, omp_clauses
;
4928 gfc_start_block (&block
);
4929 omp_clauses
= gfc_trans_omp_clauses (&block
, code
->ext
.omp_clauses
,
4931 stmt
= build1_loc (input_location
, OMP_TARGET_UPDATE
, void_type_node
,
4933 gfc_add_expr_to_block (&block
, stmt
);
4934 return gfc_finish_block (&block
);
4938 gfc_trans_omp_workshare (gfc_code
*code
, gfc_omp_clauses
*clauses
)
4940 tree res
, tmp
, stmt
;
4941 stmtblock_t block
, *pblock
= NULL
;
4942 stmtblock_t singleblock
;
4943 int saved_ompws_flags
;
4944 bool singleblock_in_progress
= false;
4945 /* True if previous gfc_code in workshare construct is not workshared. */
4946 bool prev_singleunit
;
4948 code
= code
->block
->next
;
4952 gfc_start_block (&block
);
4955 ompws_flags
= OMPWS_WORKSHARE_FLAG
;
4956 prev_singleunit
= false;
4958 /* Translate statements one by one to trees until we reach
4959 the end of the workshare construct. Adjacent gfc_codes that
4960 are a single unit of work are clustered and encapsulated in a
4961 single OMP_SINGLE construct. */
4962 for (; code
; code
= code
->next
)
4964 if (code
->here
!= 0)
4966 res
= gfc_trans_label_here (code
);
4967 gfc_add_expr_to_block (pblock
, res
);
4970 /* No dependence analysis, use for clauses with wait.
4971 If this is the last gfc_code, use default omp_clauses. */
4972 if (code
->next
== NULL
&& clauses
->nowait
)
4973 ompws_flags
|= OMPWS_NOWAIT
;
4975 /* By default, every gfc_code is a single unit of work. */
4976 ompws_flags
|= OMPWS_CURR_SINGLEUNIT
;
4977 ompws_flags
&= ~(OMPWS_SCALARIZER_WS
| OMPWS_SCALARIZER_BODY
);
4986 res
= gfc_trans_assign (code
);
4989 case EXEC_POINTER_ASSIGN
:
4990 res
= gfc_trans_pointer_assign (code
);
4993 case EXEC_INIT_ASSIGN
:
4994 res
= gfc_trans_init_assign (code
);
4998 res
= gfc_trans_forall (code
);
5002 res
= gfc_trans_where (code
);
5005 case EXEC_OMP_ATOMIC
:
5006 res
= gfc_trans_omp_directive (code
);
5009 case EXEC_OMP_PARALLEL
:
5010 case EXEC_OMP_PARALLEL_DO
:
5011 case EXEC_OMP_PARALLEL_SECTIONS
:
5012 case EXEC_OMP_PARALLEL_WORKSHARE
:
5013 case EXEC_OMP_CRITICAL
:
5014 saved_ompws_flags
= ompws_flags
;
5016 res
= gfc_trans_omp_directive (code
);
5017 ompws_flags
= saved_ompws_flags
;
5021 gfc_internal_error ("gfc_trans_omp_workshare(): Bad statement code");
5024 gfc_set_backend_locus (&code
->loc
);
5026 if (res
!= NULL_TREE
&& ! IS_EMPTY_STMT (res
))
5028 if (prev_singleunit
)
5030 if (ompws_flags
& OMPWS_CURR_SINGLEUNIT
)
5031 /* Add current gfc_code to single block. */
5032 gfc_add_expr_to_block (&singleblock
, res
);
5035 /* Finish single block and add it to pblock. */
5036 tmp
= gfc_finish_block (&singleblock
);
5037 tmp
= build2_loc (input_location
, OMP_SINGLE
,
5038 void_type_node
, tmp
, NULL_TREE
);
5039 gfc_add_expr_to_block (pblock
, tmp
);
5040 /* Add current gfc_code to pblock. */
5041 gfc_add_expr_to_block (pblock
, res
);
5042 singleblock_in_progress
= false;
5047 if (ompws_flags
& OMPWS_CURR_SINGLEUNIT
)
5049 /* Start single block. */
5050 gfc_init_block (&singleblock
);
5051 gfc_add_expr_to_block (&singleblock
, res
);
5052 singleblock_in_progress
= true;
5055 /* Add the new statement to the block. */
5056 gfc_add_expr_to_block (pblock
, res
);
5058 prev_singleunit
= (ompws_flags
& OMPWS_CURR_SINGLEUNIT
) != 0;
5062 /* Finish remaining SINGLE block, if we were in the middle of one. */
5063 if (singleblock_in_progress
)
5065 /* Finish single block and add it to pblock. */
5066 tmp
= gfc_finish_block (&singleblock
);
5067 tmp
= build2_loc (input_location
, OMP_SINGLE
, void_type_node
, tmp
,
5069 ? build_omp_clause (input_location
, OMP_CLAUSE_NOWAIT
)
5071 gfc_add_expr_to_block (pblock
, tmp
);
5074 stmt
= gfc_finish_block (pblock
);
5075 if (TREE_CODE (stmt
) != BIND_EXPR
)
5077 if (!IS_EMPTY_STMT (stmt
))
5079 tree bindblock
= poplevel (1, 0);
5080 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, bindblock
);
5088 if (IS_EMPTY_STMT (stmt
) && !clauses
->nowait
)
5089 stmt
= gfc_trans_omp_barrier ();
5096 gfc_trans_oacc_declare (gfc_code
*code
)
5099 tree stmt
, oacc_clauses
;
5100 enum tree_code construct_code
;
5102 construct_code
= OACC_DATA
;
5104 gfc_start_block (&block
);
5106 oacc_clauses
= gfc_trans_omp_clauses (&block
, code
->ext
.oacc_declare
->clauses
,
5108 stmt
= gfc_trans_omp_code (code
->block
->next
, true);
5109 stmt
= build2_loc (input_location
, construct_code
, void_type_node
, stmt
,
5111 gfc_add_expr_to_block (&block
, stmt
);
5113 return gfc_finish_block (&block
);
5117 gfc_trans_oacc_directive (gfc_code
*code
)
5121 case EXEC_OACC_PARALLEL_LOOP
:
5122 case EXEC_OACC_KERNELS_LOOP
:
5123 return gfc_trans_oacc_combined_directive (code
);
5124 case EXEC_OACC_PARALLEL
:
5125 case EXEC_OACC_KERNELS
:
5126 case EXEC_OACC_DATA
:
5127 case EXEC_OACC_HOST_DATA
:
5128 return gfc_trans_oacc_construct (code
);
5129 case EXEC_OACC_LOOP
:
5130 return gfc_trans_omp_do (code
, code
->op
, NULL
, code
->ext
.omp_clauses
,
5132 case EXEC_OACC_UPDATE
:
5133 case EXEC_OACC_CACHE
:
5134 case EXEC_OACC_ENTER_DATA
:
5135 case EXEC_OACC_EXIT_DATA
:
5136 return gfc_trans_oacc_executable_directive (code
);
5137 case EXEC_OACC_WAIT
:
5138 return gfc_trans_oacc_wait_directive (code
);
5139 case EXEC_OACC_ATOMIC
:
5140 return gfc_trans_omp_atomic (code
);
5141 case EXEC_OACC_DECLARE
:
5142 return gfc_trans_oacc_declare (code
);
5149 gfc_trans_omp_directive (gfc_code
*code
)
5153 case EXEC_OMP_ATOMIC
:
5154 return gfc_trans_omp_atomic (code
);
5155 case EXEC_OMP_BARRIER
:
5156 return gfc_trans_omp_barrier ();
5157 case EXEC_OMP_CANCEL
:
5158 return gfc_trans_omp_cancel (code
);
5159 case EXEC_OMP_CANCELLATION_POINT
:
5160 return gfc_trans_omp_cancellation_point (code
);
5161 case EXEC_OMP_CRITICAL
:
5162 return gfc_trans_omp_critical (code
);
5163 case EXEC_OMP_DISTRIBUTE
:
5166 case EXEC_OMP_TASKLOOP
:
5167 return gfc_trans_omp_do (code
, code
->op
, NULL
, code
->ext
.omp_clauses
,
5169 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
5170 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
5171 case EXEC_OMP_DISTRIBUTE_SIMD
:
5172 return gfc_trans_omp_distribute (code
, NULL
);
5173 case EXEC_OMP_DO_SIMD
:
5174 return gfc_trans_omp_do_simd (code
, NULL
, NULL
, NULL_TREE
);
5175 case EXEC_OMP_FLUSH
:
5176 return gfc_trans_omp_flush ();
5177 case EXEC_OMP_MASTER
:
5178 return gfc_trans_omp_master (code
);
5179 case EXEC_OMP_ORDERED
:
5180 return gfc_trans_omp_ordered (code
);
5181 case EXEC_OMP_PARALLEL
:
5182 return gfc_trans_omp_parallel (code
);
5183 case EXEC_OMP_PARALLEL_DO
:
5184 return gfc_trans_omp_parallel_do (code
, NULL
, NULL
);
5185 case EXEC_OMP_PARALLEL_DO_SIMD
:
5186 return gfc_trans_omp_parallel_do_simd (code
, NULL
, NULL
);
5187 case EXEC_OMP_PARALLEL_SECTIONS
:
5188 return gfc_trans_omp_parallel_sections (code
);
5189 case EXEC_OMP_PARALLEL_WORKSHARE
:
5190 return gfc_trans_omp_parallel_workshare (code
);
5191 case EXEC_OMP_SECTIONS
:
5192 return gfc_trans_omp_sections (code
, code
->ext
.omp_clauses
);
5193 case EXEC_OMP_SINGLE
:
5194 return gfc_trans_omp_single (code
, code
->ext
.omp_clauses
);
5195 case EXEC_OMP_TARGET
:
5196 case EXEC_OMP_TARGET_PARALLEL
:
5197 case EXEC_OMP_TARGET_PARALLEL_DO
:
5198 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
5199 case EXEC_OMP_TARGET_SIMD
:
5200 case EXEC_OMP_TARGET_TEAMS
:
5201 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
5202 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
5203 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
5204 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
5205 return gfc_trans_omp_target (code
);
5206 case EXEC_OMP_TARGET_DATA
:
5207 return gfc_trans_omp_target_data (code
);
5208 case EXEC_OMP_TARGET_ENTER_DATA
:
5209 return gfc_trans_omp_target_enter_data (code
);
5210 case EXEC_OMP_TARGET_EXIT_DATA
:
5211 return gfc_trans_omp_target_exit_data (code
);
5212 case EXEC_OMP_TARGET_UPDATE
:
5213 return gfc_trans_omp_target_update (code
);
5215 return gfc_trans_omp_task (code
);
5216 case EXEC_OMP_TASKGROUP
:
5217 return gfc_trans_omp_taskgroup (code
);
5218 case EXEC_OMP_TASKLOOP_SIMD
:
5219 return gfc_trans_omp_taskloop (code
);
5220 case EXEC_OMP_TASKWAIT
:
5221 return gfc_trans_omp_taskwait ();
5222 case EXEC_OMP_TASKYIELD
:
5223 return gfc_trans_omp_taskyield ();
5224 case EXEC_OMP_TEAMS
:
5225 case EXEC_OMP_TEAMS_DISTRIBUTE
:
5226 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
5227 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
5228 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
5229 return gfc_trans_omp_teams (code
, NULL
, NULL_TREE
);
5230 case EXEC_OMP_WORKSHARE
:
5231 return gfc_trans_omp_workshare (code
, code
->ext
.omp_clauses
);
5238 gfc_trans_omp_declare_simd (gfc_namespace
*ns
)
5243 gfc_omp_declare_simd
*ods
;
5244 for (ods
= ns
->omp_declare_simd
; ods
; ods
= ods
->next
)
5246 tree c
= gfc_trans_omp_clauses (NULL
, ods
->clauses
, ods
->where
, true);
5247 tree fndecl
= ns
->proc_name
->backend_decl
;
5249 c
= tree_cons (NULL_TREE
, c
, NULL_TREE
);
5250 c
= build_tree_list (get_identifier ("omp declare simd"), c
);
5251 TREE_CHAIN (c
) = DECL_ATTRIBUTES (fndecl
);
5252 DECL_ATTRIBUTES (fndecl
) = c
;