1 /* OpenMP directive translation -- generate GCC trees from gfc_code.
2 Copyright (C) 2005-2020 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__
51 /* True if OpenMP should regard this DECL as being a scalar which has Fortran's
52 allocatable or pointer attribute. */
55 gfc_omp_is_allocatable_or_ptr (const_tree decl
)
58 && (GFC_DECL_GET_SCALAR_POINTER (decl
)
59 || GFC_DECL_GET_SCALAR_ALLOCATABLE (decl
)));
62 /* True if the argument is an optional argument; except that false is also
63 returned for arguments with the value attribute (nonpointers) and for
64 assumed-shape variables (decl is a local variable containing arg->data).
65 Note that pvoid_type_node is for 'type(c_ptr), value. */
68 gfc_omp_is_optional_argument (const_tree decl
)
70 return (TREE_CODE (decl
) == PARM_DECL
71 && DECL_LANG_SPECIFIC (decl
)
72 && TREE_CODE (TREE_TYPE (decl
)) == POINTER_TYPE
73 && !VOID_TYPE_P (TREE_TYPE (TREE_TYPE (decl
)))
74 && GFC_DECL_OPTIONAL_ARGUMENT (decl
));
77 /* Check whether this DECL belongs to a Fortran optional argument.
78 With 'for_present_check' set to false, decls which are optional parameters
79 themselve are returned as tree - or a NULL_TREE otherwise. Those decls are
80 always pointers. With 'for_present_check' set to true, the decl for checking
81 whether an argument is present is returned; for arguments with value
82 attribute this is the hidden argument and of BOOLEAN_TYPE. If the decl is
83 unrelated to optional arguments, NULL_TREE is returned. */
86 gfc_omp_check_optional_argument (tree decl
, bool for_present_check
)
88 if (!for_present_check
)
89 return gfc_omp_is_optional_argument (decl
) ? decl
: NULL_TREE
;
91 if (!DECL_LANG_SPECIFIC (decl
))
94 tree orig_decl
= decl
;
96 /* For assumed-shape arrays, a local decl with arg->data is used. */
97 if (TREE_CODE (decl
) != PARM_DECL
98 && (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
))
99 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl
))))
100 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
102 if (decl
== NULL_TREE
103 || TREE_CODE (decl
) != PARM_DECL
104 || !DECL_LANG_SPECIFIC (decl
)
105 || !GFC_DECL_OPTIONAL_ARGUMENT (decl
))
108 /* Scalars with VALUE attribute which are passed by value use a hidden
109 argument to denote the present status. They are passed as nonpointer type
110 with one exception: 'type(c_ptr), value' as 'void*'. */
111 /* Cf. trans-expr.c's gfc_conv_expr_present. */
112 if (TREE_CODE (TREE_TYPE (decl
)) != POINTER_TYPE
113 || VOID_TYPE_P (TREE_TYPE (TREE_TYPE (decl
))))
115 char name
[GFC_MAX_SYMBOL_LEN
+ 2];
119 strcpy (&name
[1], IDENTIFIER_POINTER (DECL_NAME (decl
)));
120 tree_name
= get_identifier (name
);
122 /* Walk function argument list to find the hidden arg. */
123 decl
= DECL_ARGUMENTS (DECL_CONTEXT (decl
));
124 for ( ; decl
!= NULL_TREE
; decl
= TREE_CHAIN (decl
))
125 if (DECL_NAME (decl
) == tree_name
126 && DECL_ARTIFICIAL (decl
))
133 return fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
134 orig_decl
, null_pointer_node
);
138 /* Returns tree with NULL if it is not an array descriptor and with the tree to
139 access the 'data' component otherwise. With type_only = true, it returns the
140 TREE_TYPE without creating a new tree. */
143 gfc_omp_array_data (tree decl
, bool type_only
)
145 tree type
= TREE_TYPE (decl
);
147 if (POINTER_TYPE_P (type
))
148 type
= TREE_TYPE (type
);
150 if (!GFC_DESCRIPTOR_TYPE_P (type
))
154 return GFC_TYPE_ARRAY_DATAPTR_TYPE (type
);
156 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
157 decl
= build_fold_indirect_ref (decl
);
159 decl
= gfc_conv_descriptor_data_get (decl
);
164 /* True if OpenMP should privatize what this DECL points to rather
165 than the DECL itself. */
168 gfc_omp_privatize_by_reference (const_tree decl
)
170 tree type
= TREE_TYPE (decl
);
172 if (TREE_CODE (type
) == REFERENCE_TYPE
173 && (!DECL_ARTIFICIAL (decl
) || TREE_CODE (decl
) == PARM_DECL
))
176 if (TREE_CODE (type
) == POINTER_TYPE
177 && gfc_omp_is_optional_argument (decl
))
180 if (TREE_CODE (type
) == POINTER_TYPE
)
182 while (TREE_CODE (decl
) == COMPONENT_REF
)
183 decl
= TREE_OPERAND (decl
, 1);
185 /* Array POINTER/ALLOCATABLE have aggregate types, all user variables
186 that have POINTER_TYPE type and aren't scalar pointers, scalar
187 allocatables, Cray pointees or C pointers are supposed to be
188 privatized by reference. */
189 if (GFC_DECL_GET_SCALAR_POINTER (decl
)
190 || GFC_DECL_GET_SCALAR_ALLOCATABLE (decl
)
191 || GFC_DECL_CRAY_POINTEE (decl
)
192 || GFC_DECL_ASSOCIATE_VAR_P (decl
)
193 || VOID_TYPE_P (TREE_TYPE (TREE_TYPE (decl
))))
196 if (!DECL_ARTIFICIAL (decl
)
197 && TREE_CODE (TREE_TYPE (type
)) != FUNCTION_TYPE
)
200 /* Some arrays are expanded as DECL_ARTIFICIAL pointers
202 if (DECL_LANG_SPECIFIC (decl
)
203 && GFC_DECL_SAVED_DESCRIPTOR (decl
))
210 /* OMP_CLAUSE_DEFAULT_UNSPECIFIED unless OpenMP sharing attribute
211 of DECL is predetermined. */
213 enum omp_clause_default_kind
214 gfc_omp_predetermined_sharing (tree decl
)
216 /* Associate names preserve the association established during ASSOCIATE.
217 As they are implemented either as pointers to the selector or array
218 descriptor and shouldn't really change in the ASSOCIATE region,
219 this decl can be either shared or firstprivate. If it is a pointer,
220 use firstprivate, as it is cheaper that way, otherwise make it shared. */
221 if (GFC_DECL_ASSOCIATE_VAR_P (decl
))
223 if (TREE_CODE (TREE_TYPE (decl
)) == POINTER_TYPE
)
224 return OMP_CLAUSE_DEFAULT_FIRSTPRIVATE
;
226 return OMP_CLAUSE_DEFAULT_SHARED
;
229 if (DECL_ARTIFICIAL (decl
)
230 && ! GFC_DECL_RESULT (decl
)
231 && ! (DECL_LANG_SPECIFIC (decl
)
232 && GFC_DECL_SAVED_DESCRIPTOR (decl
)))
233 return OMP_CLAUSE_DEFAULT_SHARED
;
235 /* Cray pointees shouldn't be listed in any clauses and should be
236 gimplified to dereference of the corresponding Cray pointer.
237 Make them all private, so that they are emitted in the debug
239 if (GFC_DECL_CRAY_POINTEE (decl
))
240 return OMP_CLAUSE_DEFAULT_PRIVATE
;
242 /* Assumed-size arrays are predetermined shared. */
243 if (TREE_CODE (decl
) == PARM_DECL
244 && GFC_ARRAY_TYPE_P (TREE_TYPE (decl
))
245 && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (decl
)) == GFC_ARRAY_UNKNOWN
246 && GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (decl
),
247 GFC_TYPE_ARRAY_RANK (TREE_TYPE (decl
)) - 1)
249 return OMP_CLAUSE_DEFAULT_SHARED
;
251 /* Dummy procedures aren't considered variables by OpenMP, thus are
252 disallowed in OpenMP clauses. They are represented as PARM_DECLs
253 in the middle-end, so return OMP_CLAUSE_DEFAULT_FIRSTPRIVATE here
254 to avoid complaining about their uses with default(none). */
255 if (TREE_CODE (decl
) == PARM_DECL
256 && TREE_CODE (TREE_TYPE (decl
)) == POINTER_TYPE
257 && TREE_CODE (TREE_TYPE (TREE_TYPE (decl
))) == FUNCTION_TYPE
)
258 return OMP_CLAUSE_DEFAULT_FIRSTPRIVATE
;
260 /* COMMON and EQUIVALENCE decls are shared. They
261 are only referenced through DECL_VALUE_EXPR of the variables
262 contained in them. If those are privatized, they will not be
263 gimplified to the COMMON or EQUIVALENCE decls. */
264 if (GFC_DECL_COMMON_OR_EQUIV (decl
) && ! DECL_HAS_VALUE_EXPR_P (decl
))
265 return OMP_CLAUSE_DEFAULT_SHARED
;
267 if (GFC_DECL_RESULT (decl
) && ! DECL_HAS_VALUE_EXPR_P (decl
))
268 return OMP_CLAUSE_DEFAULT_SHARED
;
270 /* These are either array or derived parameters, or vtables.
271 In the former cases, the OpenMP standard doesn't consider them to be
272 variables at all (they can't be redefined), but they can nevertheless appear
273 in parallel/task regions and for default(none) purposes treat them as shared.
274 For vtables likely the same handling is desirable. */
275 if (VAR_P (decl
) && TREE_READONLY (decl
)
276 && (TREE_STATIC (decl
) || DECL_EXTERNAL (decl
)))
277 return OMP_CLAUSE_DEFAULT_SHARED
;
279 return OMP_CLAUSE_DEFAULT_UNSPECIFIED
;
283 /* OMP_CLAUSE_DEFAULTMAP_CATEGORY_UNSPECIFIED unless OpenMP mapping attribute
284 of DECL is predetermined. */
286 enum omp_clause_defaultmap_kind
287 gfc_omp_predetermined_mapping (tree decl
)
289 if (DECL_ARTIFICIAL (decl
)
290 && ! GFC_DECL_RESULT (decl
)
291 && ! (DECL_LANG_SPECIFIC (decl
)
292 && GFC_DECL_SAVED_DESCRIPTOR (decl
)))
293 return OMP_CLAUSE_DEFAULTMAP_TO
;
295 /* These are either array or derived parameters, or vtables. */
296 if (VAR_P (decl
) && TREE_READONLY (decl
)
297 && (TREE_STATIC (decl
) || DECL_EXTERNAL (decl
)))
298 return OMP_CLAUSE_DEFAULTMAP_TO
;
300 return OMP_CLAUSE_DEFAULTMAP_CATEGORY_UNSPECIFIED
;
304 /* Return decl that should be used when reporting DEFAULT(NONE)
308 gfc_omp_report_decl (tree decl
)
310 if (DECL_ARTIFICIAL (decl
)
311 && DECL_LANG_SPECIFIC (decl
)
312 && GFC_DECL_SAVED_DESCRIPTOR (decl
))
313 return GFC_DECL_SAVED_DESCRIPTOR (decl
);
318 /* Return true if TYPE has any allocatable components. */
321 gfc_has_alloc_comps (tree type
, tree decl
)
325 if (POINTER_TYPE_P (type
))
327 if (GFC_DECL_GET_SCALAR_ALLOCATABLE (decl
))
328 type
= TREE_TYPE (type
);
329 else if (GFC_DECL_GET_SCALAR_POINTER (decl
))
333 if (GFC_DESCRIPTOR_TYPE_P (type
)
334 && (GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_POINTER
335 || GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_POINTER_CONT
))
338 if (GFC_DESCRIPTOR_TYPE_P (type
) || GFC_ARRAY_TYPE_P (type
))
339 type
= gfc_get_element_type (type
);
341 if (TREE_CODE (type
) != RECORD_TYPE
)
344 for (field
= TYPE_FIELDS (type
); field
; field
= DECL_CHAIN (field
))
346 ftype
= TREE_TYPE (field
);
347 if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field
))
349 if (GFC_DESCRIPTOR_TYPE_P (ftype
)
350 && GFC_TYPE_ARRAY_AKIND (ftype
) == GFC_ARRAY_ALLOCATABLE
)
352 if (gfc_has_alloc_comps (ftype
, field
))
358 /* Return true if DECL in private clause needs
359 OMP_CLAUSE_PRIVATE_OUTER_REF on the private clause. */
361 gfc_omp_private_outer_ref (tree decl
)
363 tree type
= TREE_TYPE (decl
);
365 if (gfc_omp_privatize_by_reference (decl
))
366 type
= TREE_TYPE (type
);
368 if (GFC_DESCRIPTOR_TYPE_P (type
)
369 && GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ALLOCATABLE
)
372 if (GFC_DECL_GET_SCALAR_ALLOCATABLE (decl
))
375 if (gfc_has_alloc_comps (type
, decl
))
381 /* Callback for gfc_omp_unshare_expr. */
384 gfc_omp_unshare_expr_r (tree
*tp
, int *walk_subtrees
, void *)
387 enum tree_code code
= TREE_CODE (t
);
389 /* Stop at types, decls, constants like copy_tree_r. */
390 if (TREE_CODE_CLASS (code
) == tcc_type
391 || TREE_CODE_CLASS (code
) == tcc_declaration
392 || TREE_CODE_CLASS (code
) == tcc_constant
395 else if (handled_component_p (t
)
396 || TREE_CODE (t
) == MEM_REF
)
398 *tp
= unshare_expr (t
);
405 /* Unshare in expr anything that the FE which normally doesn't
406 care much about tree sharing (because during gimplification
407 everything is unshared) could cause problems with tree sharing
408 at omp-low.c time. */
411 gfc_omp_unshare_expr (tree expr
)
413 walk_tree (&expr
, gfc_omp_unshare_expr_r
, NULL
, NULL
);
417 enum walk_alloc_comps
419 WALK_ALLOC_COMPS_DTOR
,
420 WALK_ALLOC_COMPS_DEFAULT_CTOR
,
421 WALK_ALLOC_COMPS_COPY_CTOR
424 /* Handle allocatable components in OpenMP clauses. */
427 gfc_walk_alloc_comps (tree decl
, tree dest
, tree var
,
428 enum walk_alloc_comps kind
)
430 stmtblock_t block
, tmpblock
;
431 tree type
= TREE_TYPE (decl
), then_b
, tem
, field
;
432 gfc_init_block (&block
);
434 if (GFC_ARRAY_TYPE_P (type
) || GFC_DESCRIPTOR_TYPE_P (type
))
436 if (GFC_DESCRIPTOR_TYPE_P (type
))
438 gfc_init_block (&tmpblock
);
439 tem
= gfc_full_array_size (&tmpblock
, decl
,
440 GFC_TYPE_ARRAY_RANK (type
));
441 then_b
= gfc_finish_block (&tmpblock
);
442 gfc_add_expr_to_block (&block
, gfc_omp_unshare_expr (then_b
));
443 tem
= gfc_omp_unshare_expr (tem
);
444 tem
= fold_build2_loc (input_location
, MINUS_EXPR
,
445 gfc_array_index_type
, tem
,
450 bool compute_nelts
= false;
451 if (!TYPE_DOMAIN (type
)
452 || TYPE_MAX_VALUE (TYPE_DOMAIN (type
)) == NULL_TREE
453 || TYPE_MIN_VALUE (TYPE_DOMAIN (type
)) == error_mark_node
454 || TYPE_MAX_VALUE (TYPE_DOMAIN (type
)) == error_mark_node
)
455 compute_nelts
= true;
456 else if (VAR_P (TYPE_MAX_VALUE (TYPE_DOMAIN (type
))))
458 tree a
= DECL_ATTRIBUTES (TYPE_MAX_VALUE (TYPE_DOMAIN (type
)));
459 if (lookup_attribute ("omp dummy var", a
))
460 compute_nelts
= true;
464 tem
= fold_build2 (EXACT_DIV_EXPR
, sizetype
,
465 TYPE_SIZE_UNIT (type
),
466 TYPE_SIZE_UNIT (TREE_TYPE (type
)));
467 tem
= size_binop (MINUS_EXPR
, tem
, size_one_node
);
470 tem
= array_type_nelts (type
);
471 tem
= fold_convert (gfc_array_index_type
, tem
);
474 tree nelems
= gfc_evaluate_now (tem
, &block
);
475 tree index
= gfc_create_var (gfc_array_index_type
, "S");
477 gfc_init_block (&tmpblock
);
478 tem
= gfc_conv_array_data (decl
);
479 tree declvar
= build_fold_indirect_ref_loc (input_location
, tem
);
480 tree declvref
= gfc_build_array_ref (declvar
, index
, NULL
);
481 tree destvar
, destvref
= NULL_TREE
;
484 tem
= gfc_conv_array_data (dest
);
485 destvar
= build_fold_indirect_ref_loc (input_location
, tem
);
486 destvref
= gfc_build_array_ref (destvar
, index
, NULL
);
488 gfc_add_expr_to_block (&tmpblock
,
489 gfc_walk_alloc_comps (declvref
, destvref
,
493 gfc_init_loopinfo (&loop
);
495 loop
.from
[0] = gfc_index_zero_node
;
496 loop
.loopvar
[0] = index
;
498 gfc_trans_scalarizing_loops (&loop
, &tmpblock
);
499 gfc_add_block_to_block (&block
, &loop
.pre
);
500 return gfc_finish_block (&block
);
502 else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (var
))
504 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
506 dest
= build_fold_indirect_ref_loc (input_location
, dest
);
507 type
= TREE_TYPE (decl
);
510 gcc_assert (TREE_CODE (type
) == RECORD_TYPE
);
511 for (field
= TYPE_FIELDS (type
); field
; field
= DECL_CHAIN (field
))
513 tree ftype
= TREE_TYPE (field
);
514 tree declf
, destf
= NULL_TREE
;
515 bool has_alloc_comps
= gfc_has_alloc_comps (ftype
, field
);
516 if ((!GFC_DESCRIPTOR_TYPE_P (ftype
)
517 || GFC_TYPE_ARRAY_AKIND (ftype
) != GFC_ARRAY_ALLOCATABLE
)
518 && !GFC_DECL_GET_SCALAR_ALLOCATABLE (field
)
521 declf
= fold_build3_loc (input_location
, COMPONENT_REF
, ftype
,
522 decl
, field
, NULL_TREE
);
524 destf
= fold_build3_loc (input_location
, COMPONENT_REF
, ftype
,
525 dest
, field
, NULL_TREE
);
530 case WALK_ALLOC_COMPS_DTOR
:
532 case WALK_ALLOC_COMPS_DEFAULT_CTOR
:
533 if (GFC_DESCRIPTOR_TYPE_P (ftype
)
534 && GFC_TYPE_ARRAY_AKIND (ftype
) == GFC_ARRAY_ALLOCATABLE
)
536 gfc_add_modify (&block
, unshare_expr (destf
),
537 unshare_expr (declf
));
538 tem
= gfc_duplicate_allocatable_nocopy
539 (destf
, declf
, ftype
,
540 GFC_TYPE_ARRAY_RANK (ftype
));
542 else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field
))
543 tem
= gfc_duplicate_allocatable_nocopy (destf
, declf
, ftype
, 0);
545 case WALK_ALLOC_COMPS_COPY_CTOR
:
546 if (GFC_DESCRIPTOR_TYPE_P (ftype
)
547 && GFC_TYPE_ARRAY_AKIND (ftype
) == GFC_ARRAY_ALLOCATABLE
)
548 tem
= gfc_duplicate_allocatable (destf
, declf
, ftype
,
549 GFC_TYPE_ARRAY_RANK (ftype
),
551 else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field
))
552 tem
= gfc_duplicate_allocatable (destf
, declf
, ftype
, 0,
557 gfc_add_expr_to_block (&block
, gfc_omp_unshare_expr (tem
));
560 gfc_init_block (&tmpblock
);
561 gfc_add_expr_to_block (&tmpblock
,
562 gfc_walk_alloc_comps (declf
, destf
,
564 then_b
= gfc_finish_block (&tmpblock
);
565 if (GFC_DESCRIPTOR_TYPE_P (ftype
)
566 && GFC_TYPE_ARRAY_AKIND (ftype
) == GFC_ARRAY_ALLOCATABLE
)
567 tem
= gfc_conv_descriptor_data_get (unshare_expr (declf
));
568 else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field
))
569 tem
= unshare_expr (declf
);
574 tem
= fold_convert (pvoid_type_node
, tem
);
575 tem
= fold_build2_loc (input_location
, NE_EXPR
,
576 logical_type_node
, tem
,
578 then_b
= build3_loc (input_location
, COND_EXPR
, void_type_node
,
580 build_empty_stmt (input_location
));
582 gfc_add_expr_to_block (&block
, then_b
);
584 if (kind
== WALK_ALLOC_COMPS_DTOR
)
586 if (GFC_DESCRIPTOR_TYPE_P (ftype
)
587 && GFC_TYPE_ARRAY_AKIND (ftype
) == GFC_ARRAY_ALLOCATABLE
)
589 tem
= gfc_conv_descriptor_data_get (unshare_expr (declf
));
590 tem
= gfc_deallocate_with_status (tem
, NULL_TREE
, NULL_TREE
,
591 NULL_TREE
, NULL_TREE
, true,
593 GFC_CAF_COARRAY_NOCOARRAY
);
594 gfc_add_expr_to_block (&block
, gfc_omp_unshare_expr (tem
));
596 else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field
))
598 tem
= gfc_call_free (unshare_expr (declf
));
599 gfc_add_expr_to_block (&block
, gfc_omp_unshare_expr (tem
));
604 return gfc_finish_block (&block
);
607 /* Return code to initialize DECL with its default constructor, or
608 NULL if there's nothing to do. */
611 gfc_omp_clause_default_ctor (tree clause
, tree decl
, tree outer
)
613 tree type
= TREE_TYPE (decl
), size
, ptr
, cond
, then_b
, else_b
;
614 stmtblock_t block
, cond_block
;
616 switch (OMP_CLAUSE_CODE (clause
))
618 case OMP_CLAUSE__LOOPTEMP_
:
619 case OMP_CLAUSE__REDUCTEMP_
:
620 case OMP_CLAUSE__CONDTEMP_
:
621 case OMP_CLAUSE__SCANTEMP_
:
623 case OMP_CLAUSE_PRIVATE
:
624 case OMP_CLAUSE_LASTPRIVATE
:
625 case OMP_CLAUSE_LINEAR
:
626 case OMP_CLAUSE_REDUCTION
:
632 if ((! GFC_DESCRIPTOR_TYPE_P (type
)
633 || GFC_TYPE_ARRAY_AKIND (type
) != GFC_ARRAY_ALLOCATABLE
)
634 && (!GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause
))
635 || !POINTER_TYPE_P (type
)))
637 if (gfc_has_alloc_comps (type
, OMP_CLAUSE_DECL (clause
)))
640 gfc_start_block (&block
);
641 tree tem
= gfc_walk_alloc_comps (outer
, decl
,
642 OMP_CLAUSE_DECL (clause
),
643 WALK_ALLOC_COMPS_DEFAULT_CTOR
);
644 gfc_add_expr_to_block (&block
, tem
);
645 return gfc_finish_block (&block
);
650 gcc_assert (outer
!= NULL_TREE
);
652 /* Allocatable arrays and scalars in PRIVATE clauses need to be set to
653 "not currently allocated" allocation status if outer
654 array is "not currently allocated", otherwise should be allocated. */
655 gfc_start_block (&block
);
657 gfc_init_block (&cond_block
);
659 if (GFC_DESCRIPTOR_TYPE_P (type
))
661 gfc_add_modify (&cond_block
, decl
, outer
);
662 tree rank
= gfc_rank_cst
[GFC_TYPE_ARRAY_RANK (type
) - 1];
663 size
= gfc_conv_descriptor_ubound_get (decl
, rank
);
664 size
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
666 gfc_conv_descriptor_lbound_get (decl
, rank
));
667 size
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
668 size
, gfc_index_one_node
);
669 if (GFC_TYPE_ARRAY_RANK (type
) > 1)
670 size
= fold_build2_loc (input_location
, MULT_EXPR
,
671 gfc_array_index_type
, size
,
672 gfc_conv_descriptor_stride_get (decl
, rank
));
673 tree esize
= fold_convert (gfc_array_index_type
,
674 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
675 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
677 size
= unshare_expr (size
);
678 size
= gfc_evaluate_now (fold_convert (size_type_node
, size
),
682 size
= fold_convert (size_type_node
, TYPE_SIZE_UNIT (TREE_TYPE (type
)));
683 ptr
= gfc_create_var (pvoid_type_node
, NULL
);
684 gfc_allocate_using_malloc (&cond_block
, ptr
, size
, NULL_TREE
);
685 if (GFC_DESCRIPTOR_TYPE_P (type
))
686 gfc_conv_descriptor_data_set (&cond_block
, unshare_expr (decl
), ptr
);
688 gfc_add_modify (&cond_block
, unshare_expr (decl
),
689 fold_convert (TREE_TYPE (decl
), ptr
));
690 if (gfc_has_alloc_comps (type
, OMP_CLAUSE_DECL (clause
)))
692 tree tem
= gfc_walk_alloc_comps (outer
, decl
,
693 OMP_CLAUSE_DECL (clause
),
694 WALK_ALLOC_COMPS_DEFAULT_CTOR
);
695 gfc_add_expr_to_block (&cond_block
, tem
);
697 then_b
= gfc_finish_block (&cond_block
);
699 /* Reduction clause requires allocated ALLOCATABLE. */
700 if (OMP_CLAUSE_CODE (clause
) != OMP_CLAUSE_REDUCTION
)
702 gfc_init_block (&cond_block
);
703 if (GFC_DESCRIPTOR_TYPE_P (type
))
704 gfc_conv_descriptor_data_set (&cond_block
, unshare_expr (decl
),
707 gfc_add_modify (&cond_block
, unshare_expr (decl
),
708 build_zero_cst (TREE_TYPE (decl
)));
709 else_b
= gfc_finish_block (&cond_block
);
711 tree tem
= fold_convert (pvoid_type_node
,
712 GFC_DESCRIPTOR_TYPE_P (type
)
713 ? gfc_conv_descriptor_data_get (outer
) : outer
);
714 tem
= unshare_expr (tem
);
715 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
716 tem
, null_pointer_node
);
717 gfc_add_expr_to_block (&block
,
718 build3_loc (input_location
, COND_EXPR
,
719 void_type_node
, cond
, then_b
,
721 /* Avoid -W*uninitialized warnings. */
723 TREE_NO_WARNING (decl
) = 1;
726 gfc_add_expr_to_block (&block
, then_b
);
728 return gfc_finish_block (&block
);
731 /* Build and return code for a copy constructor from SRC to DEST. */
734 gfc_omp_clause_copy_ctor (tree clause
, tree dest
, tree src
)
736 tree type
= TREE_TYPE (dest
), ptr
, size
, call
;
737 tree cond
, then_b
, else_b
;
738 stmtblock_t block
, cond_block
;
740 gcc_assert (OMP_CLAUSE_CODE (clause
) == OMP_CLAUSE_FIRSTPRIVATE
741 || OMP_CLAUSE_CODE (clause
) == OMP_CLAUSE_LINEAR
);
743 if ((! GFC_DESCRIPTOR_TYPE_P (type
)
744 || GFC_TYPE_ARRAY_AKIND (type
) != GFC_ARRAY_ALLOCATABLE
)
745 && (!GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause
))
746 || !POINTER_TYPE_P (type
)))
748 if (gfc_has_alloc_comps (type
, OMP_CLAUSE_DECL (clause
)))
750 gfc_start_block (&block
);
751 gfc_add_modify (&block
, dest
, src
);
752 tree tem
= gfc_walk_alloc_comps (src
, dest
, OMP_CLAUSE_DECL (clause
),
753 WALK_ALLOC_COMPS_COPY_CTOR
);
754 gfc_add_expr_to_block (&block
, tem
);
755 return gfc_finish_block (&block
);
758 return build2_v (MODIFY_EXPR
, dest
, src
);
761 /* Allocatable arrays in FIRSTPRIVATE clauses need to be allocated
762 and copied from SRC. */
763 gfc_start_block (&block
);
765 gfc_init_block (&cond_block
);
767 gfc_add_modify (&cond_block
, dest
, src
);
768 if (GFC_DESCRIPTOR_TYPE_P (type
))
770 tree rank
= gfc_rank_cst
[GFC_TYPE_ARRAY_RANK (type
) - 1];
771 size
= gfc_conv_descriptor_ubound_get (dest
, rank
);
772 size
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
774 gfc_conv_descriptor_lbound_get (dest
, rank
));
775 size
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
776 size
, gfc_index_one_node
);
777 if (GFC_TYPE_ARRAY_RANK (type
) > 1)
778 size
= fold_build2_loc (input_location
, MULT_EXPR
,
779 gfc_array_index_type
, size
,
780 gfc_conv_descriptor_stride_get (dest
, rank
));
781 tree esize
= fold_convert (gfc_array_index_type
,
782 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
783 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
785 size
= unshare_expr (size
);
786 size
= gfc_evaluate_now (fold_convert (size_type_node
, size
),
790 size
= fold_convert (size_type_node
, TYPE_SIZE_UNIT (TREE_TYPE (type
)));
791 ptr
= gfc_create_var (pvoid_type_node
, NULL
);
792 gfc_allocate_using_malloc (&cond_block
, ptr
, size
, NULL_TREE
);
793 if (GFC_DESCRIPTOR_TYPE_P (type
))
794 gfc_conv_descriptor_data_set (&cond_block
, unshare_expr (dest
), ptr
);
796 gfc_add_modify (&cond_block
, unshare_expr (dest
),
797 fold_convert (TREE_TYPE (dest
), ptr
));
799 tree srcptr
= GFC_DESCRIPTOR_TYPE_P (type
)
800 ? gfc_conv_descriptor_data_get (src
) : src
;
801 srcptr
= unshare_expr (srcptr
);
802 srcptr
= fold_convert (pvoid_type_node
, srcptr
);
803 call
= build_call_expr_loc (input_location
,
804 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3, ptr
,
806 gfc_add_expr_to_block (&cond_block
, fold_convert (void_type_node
, call
));
807 if (gfc_has_alloc_comps (type
, OMP_CLAUSE_DECL (clause
)))
809 tree tem
= gfc_walk_alloc_comps (src
, dest
,
810 OMP_CLAUSE_DECL (clause
),
811 WALK_ALLOC_COMPS_COPY_CTOR
);
812 gfc_add_expr_to_block (&cond_block
, tem
);
814 then_b
= gfc_finish_block (&cond_block
);
816 gfc_init_block (&cond_block
);
817 if (GFC_DESCRIPTOR_TYPE_P (type
))
818 gfc_conv_descriptor_data_set (&cond_block
, unshare_expr (dest
),
821 gfc_add_modify (&cond_block
, unshare_expr (dest
),
822 build_zero_cst (TREE_TYPE (dest
)));
823 else_b
= gfc_finish_block (&cond_block
);
825 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
826 unshare_expr (srcptr
), null_pointer_node
);
827 gfc_add_expr_to_block (&block
,
828 build3_loc (input_location
, COND_EXPR
,
829 void_type_node
, cond
, then_b
, else_b
));
830 /* Avoid -W*uninitialized warnings. */
832 TREE_NO_WARNING (dest
) = 1;
834 return gfc_finish_block (&block
);
837 /* Similarly, except use an intrinsic or pointer assignment operator
841 gfc_omp_clause_assign_op (tree clause
, tree dest
, tree src
)
843 tree type
= TREE_TYPE (dest
), ptr
, size
, call
, nonalloc
;
844 tree cond
, then_b
, else_b
;
845 stmtblock_t block
, cond_block
, cond_block2
, inner_block
;
847 if ((! GFC_DESCRIPTOR_TYPE_P (type
)
848 || GFC_TYPE_ARRAY_AKIND (type
) != GFC_ARRAY_ALLOCATABLE
)
849 && (!GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause
))
850 || !POINTER_TYPE_P (type
)))
852 if (gfc_has_alloc_comps (type
, OMP_CLAUSE_DECL (clause
)))
854 gfc_start_block (&block
);
855 /* First dealloc any allocatable components in DEST. */
856 tree tem
= gfc_walk_alloc_comps (dest
, NULL_TREE
,
857 OMP_CLAUSE_DECL (clause
),
858 WALK_ALLOC_COMPS_DTOR
);
859 gfc_add_expr_to_block (&block
, tem
);
860 /* Then copy over toplevel data. */
861 gfc_add_modify (&block
, dest
, src
);
862 /* Finally allocate any allocatable components and copy. */
863 tem
= gfc_walk_alloc_comps (src
, dest
, OMP_CLAUSE_DECL (clause
),
864 WALK_ALLOC_COMPS_COPY_CTOR
);
865 gfc_add_expr_to_block (&block
, tem
);
866 return gfc_finish_block (&block
);
869 return build2_v (MODIFY_EXPR
, dest
, src
);
872 gfc_start_block (&block
);
874 if (gfc_has_alloc_comps (type
, OMP_CLAUSE_DECL (clause
)))
876 then_b
= gfc_walk_alloc_comps (dest
, NULL_TREE
, OMP_CLAUSE_DECL (clause
),
877 WALK_ALLOC_COMPS_DTOR
);
878 tree tem
= fold_convert (pvoid_type_node
,
879 GFC_DESCRIPTOR_TYPE_P (type
)
880 ? gfc_conv_descriptor_data_get (dest
) : dest
);
881 tem
= unshare_expr (tem
);
882 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
883 tem
, null_pointer_node
);
884 tem
= build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
885 then_b
, build_empty_stmt (input_location
));
886 gfc_add_expr_to_block (&block
, tem
);
889 gfc_init_block (&cond_block
);
891 if (GFC_DESCRIPTOR_TYPE_P (type
))
893 tree rank
= gfc_rank_cst
[GFC_TYPE_ARRAY_RANK (type
) - 1];
894 size
= gfc_conv_descriptor_ubound_get (src
, rank
);
895 size
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
897 gfc_conv_descriptor_lbound_get (src
, rank
));
898 size
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
899 size
, gfc_index_one_node
);
900 if (GFC_TYPE_ARRAY_RANK (type
) > 1)
901 size
= fold_build2_loc (input_location
, MULT_EXPR
,
902 gfc_array_index_type
, size
,
903 gfc_conv_descriptor_stride_get (src
, rank
));
904 tree esize
= fold_convert (gfc_array_index_type
,
905 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
906 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
908 size
= unshare_expr (size
);
909 size
= gfc_evaluate_now (fold_convert (size_type_node
, size
),
913 size
= fold_convert (size_type_node
, TYPE_SIZE_UNIT (TREE_TYPE (type
)));
914 ptr
= gfc_create_var (pvoid_type_node
, NULL
);
916 tree destptr
= GFC_DESCRIPTOR_TYPE_P (type
)
917 ? gfc_conv_descriptor_data_get (dest
) : dest
;
918 destptr
= unshare_expr (destptr
);
919 destptr
= fold_convert (pvoid_type_node
, destptr
);
920 gfc_add_modify (&cond_block
, ptr
, destptr
);
922 nonalloc
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
923 destptr
, null_pointer_node
);
925 if (GFC_DESCRIPTOR_TYPE_P (type
))
928 for (i
= 0; i
< GFC_TYPE_ARRAY_RANK (type
); i
++)
930 tree rank
= gfc_rank_cst
[i
];
931 tree tem
= gfc_conv_descriptor_ubound_get (src
, rank
);
932 tem
= fold_build2_loc (input_location
, MINUS_EXPR
,
933 gfc_array_index_type
, tem
,
934 gfc_conv_descriptor_lbound_get (src
, rank
));
935 tem
= fold_build2_loc (input_location
, PLUS_EXPR
,
936 gfc_array_index_type
, tem
,
937 gfc_conv_descriptor_lbound_get (dest
, rank
));
938 tem
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
939 tem
, gfc_conv_descriptor_ubound_get (dest
,
941 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
942 logical_type_node
, cond
, tem
);
946 gfc_init_block (&cond_block2
);
948 if (GFC_DESCRIPTOR_TYPE_P (type
))
950 gfc_init_block (&inner_block
);
951 gfc_allocate_using_malloc (&inner_block
, ptr
, size
, NULL_TREE
);
952 then_b
= gfc_finish_block (&inner_block
);
954 gfc_init_block (&inner_block
);
955 gfc_add_modify (&inner_block
, ptr
,
956 gfc_call_realloc (&inner_block
, ptr
, size
));
957 else_b
= gfc_finish_block (&inner_block
);
959 gfc_add_expr_to_block (&cond_block2
,
960 build3_loc (input_location
, COND_EXPR
,
962 unshare_expr (nonalloc
),
964 gfc_add_modify (&cond_block2
, dest
, src
);
965 gfc_conv_descriptor_data_set (&cond_block2
, unshare_expr (dest
), ptr
);
969 gfc_allocate_using_malloc (&cond_block2
, ptr
, size
, NULL_TREE
);
970 gfc_add_modify (&cond_block2
, unshare_expr (dest
),
971 fold_convert (type
, ptr
));
973 then_b
= gfc_finish_block (&cond_block2
);
974 else_b
= build_empty_stmt (input_location
);
976 gfc_add_expr_to_block (&cond_block
,
977 build3_loc (input_location
, COND_EXPR
,
978 void_type_node
, unshare_expr (cond
),
981 tree srcptr
= GFC_DESCRIPTOR_TYPE_P (type
)
982 ? gfc_conv_descriptor_data_get (src
) : src
;
983 srcptr
= unshare_expr (srcptr
);
984 srcptr
= fold_convert (pvoid_type_node
, srcptr
);
985 call
= build_call_expr_loc (input_location
,
986 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3, ptr
,
988 gfc_add_expr_to_block (&cond_block
, fold_convert (void_type_node
, call
));
989 if (gfc_has_alloc_comps (type
, OMP_CLAUSE_DECL (clause
)))
991 tree tem
= gfc_walk_alloc_comps (src
, dest
,
992 OMP_CLAUSE_DECL (clause
),
993 WALK_ALLOC_COMPS_COPY_CTOR
);
994 gfc_add_expr_to_block (&cond_block
, tem
);
996 then_b
= gfc_finish_block (&cond_block
);
998 if (OMP_CLAUSE_CODE (clause
) == OMP_CLAUSE_COPYIN
)
1000 gfc_init_block (&cond_block
);
1001 if (GFC_DESCRIPTOR_TYPE_P (type
))
1003 tree tmp
= gfc_conv_descriptor_data_get (unshare_expr (dest
));
1004 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, NULL_TREE
,
1005 NULL_TREE
, NULL_TREE
, true, NULL
,
1006 GFC_CAF_COARRAY_NOCOARRAY
);
1007 gfc_add_expr_to_block (&cond_block
, tmp
);
1011 destptr
= gfc_evaluate_now (destptr
, &cond_block
);
1012 gfc_add_expr_to_block (&cond_block
, gfc_call_free (destptr
));
1013 gfc_add_modify (&cond_block
, unshare_expr (dest
),
1014 build_zero_cst (TREE_TYPE (dest
)));
1016 else_b
= gfc_finish_block (&cond_block
);
1018 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
1019 unshare_expr (srcptr
), null_pointer_node
);
1020 gfc_add_expr_to_block (&block
,
1021 build3_loc (input_location
, COND_EXPR
,
1022 void_type_node
, cond
,
1026 gfc_add_expr_to_block (&block
, then_b
);
1028 return gfc_finish_block (&block
);
1032 gfc_omp_linear_clause_add_loop (stmtblock_t
*block
, tree dest
, tree src
,
1033 tree add
, tree nelems
)
1035 stmtblock_t tmpblock
;
1036 tree desta
, srca
, index
= gfc_create_var (gfc_array_index_type
, "S");
1037 nelems
= gfc_evaluate_now (nelems
, block
);
1039 gfc_init_block (&tmpblock
);
1040 if (TREE_CODE (TREE_TYPE (dest
)) == ARRAY_TYPE
)
1042 desta
= gfc_build_array_ref (dest
, index
, NULL
);
1043 srca
= gfc_build_array_ref (src
, index
, NULL
);
1047 gcc_assert (POINTER_TYPE_P (TREE_TYPE (dest
)));
1048 tree idx
= fold_build2 (MULT_EXPR
, sizetype
,
1049 fold_convert (sizetype
, index
),
1050 TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (dest
))));
1051 desta
= build_fold_indirect_ref (fold_build2 (POINTER_PLUS_EXPR
,
1052 TREE_TYPE (dest
), dest
,
1054 srca
= build_fold_indirect_ref (fold_build2 (POINTER_PLUS_EXPR
,
1055 TREE_TYPE (src
), src
,
1058 gfc_add_modify (&tmpblock
, desta
,
1059 fold_build2 (PLUS_EXPR
, TREE_TYPE (desta
),
1063 gfc_init_loopinfo (&loop
);
1065 loop
.from
[0] = gfc_index_zero_node
;
1066 loop
.loopvar
[0] = index
;
1067 loop
.to
[0] = nelems
;
1068 gfc_trans_scalarizing_loops (&loop
, &tmpblock
);
1069 gfc_add_block_to_block (block
, &loop
.pre
);
1072 /* Build and return code for a constructor of DEST that initializes
1073 it to SRC plus ADD (ADD is scalar integer). */
1076 gfc_omp_clause_linear_ctor (tree clause
, tree dest
, tree src
, tree add
)
1078 tree type
= TREE_TYPE (dest
), ptr
, size
, nelems
= NULL_TREE
;
1081 gcc_assert (OMP_CLAUSE_CODE (clause
) == OMP_CLAUSE_LINEAR
);
1083 gfc_start_block (&block
);
1084 add
= gfc_evaluate_now (add
, &block
);
1086 if ((! GFC_DESCRIPTOR_TYPE_P (type
)
1087 || GFC_TYPE_ARRAY_AKIND (type
) != GFC_ARRAY_ALLOCATABLE
)
1088 && (!GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause
))
1089 || !POINTER_TYPE_P (type
)))
1091 bool compute_nelts
= false;
1092 gcc_assert (TREE_CODE (type
) == ARRAY_TYPE
);
1093 if (!TYPE_DOMAIN (type
)
1094 || TYPE_MAX_VALUE (TYPE_DOMAIN (type
)) == NULL_TREE
1095 || TYPE_MIN_VALUE (TYPE_DOMAIN (type
)) == error_mark_node
1096 || TYPE_MAX_VALUE (TYPE_DOMAIN (type
)) == error_mark_node
)
1097 compute_nelts
= true;
1098 else if (VAR_P (TYPE_MAX_VALUE (TYPE_DOMAIN (type
))))
1100 tree a
= DECL_ATTRIBUTES (TYPE_MAX_VALUE (TYPE_DOMAIN (type
)));
1101 if (lookup_attribute ("omp dummy var", a
))
1102 compute_nelts
= true;
1106 nelems
= fold_build2 (EXACT_DIV_EXPR
, sizetype
,
1107 TYPE_SIZE_UNIT (type
),
1108 TYPE_SIZE_UNIT (TREE_TYPE (type
)));
1109 nelems
= size_binop (MINUS_EXPR
, nelems
, size_one_node
);
1112 nelems
= array_type_nelts (type
);
1113 nelems
= fold_convert (gfc_array_index_type
, nelems
);
1115 gfc_omp_linear_clause_add_loop (&block
, dest
, src
, add
, nelems
);
1116 return gfc_finish_block (&block
);
1119 /* Allocatable arrays in LINEAR clauses need to be allocated
1120 and copied from SRC. */
1121 gfc_add_modify (&block
, dest
, src
);
1122 if (GFC_DESCRIPTOR_TYPE_P (type
))
1124 tree rank
= gfc_rank_cst
[GFC_TYPE_ARRAY_RANK (type
) - 1];
1125 size
= gfc_conv_descriptor_ubound_get (dest
, rank
);
1126 size
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
1128 gfc_conv_descriptor_lbound_get (dest
, rank
));
1129 size
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1130 size
, gfc_index_one_node
);
1131 if (GFC_TYPE_ARRAY_RANK (type
) > 1)
1132 size
= fold_build2_loc (input_location
, MULT_EXPR
,
1133 gfc_array_index_type
, size
,
1134 gfc_conv_descriptor_stride_get (dest
, rank
));
1135 tree esize
= fold_convert (gfc_array_index_type
,
1136 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
1137 nelems
= gfc_evaluate_now (unshare_expr (size
), &block
);
1138 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
1139 nelems
, unshare_expr (esize
));
1140 size
= gfc_evaluate_now (fold_convert (size_type_node
, size
),
1142 nelems
= fold_build2_loc (input_location
, MINUS_EXPR
,
1143 gfc_array_index_type
, nelems
,
1144 gfc_index_one_node
);
1147 size
= fold_convert (size_type_node
, TYPE_SIZE_UNIT (TREE_TYPE (type
)));
1148 ptr
= gfc_create_var (pvoid_type_node
, NULL
);
1149 gfc_allocate_using_malloc (&block
, ptr
, size
, NULL_TREE
);
1150 if (GFC_DESCRIPTOR_TYPE_P (type
))
1152 gfc_conv_descriptor_data_set (&block
, unshare_expr (dest
), ptr
);
1153 tree etype
= gfc_get_element_type (type
);
1154 ptr
= fold_convert (build_pointer_type (etype
), ptr
);
1155 tree srcptr
= gfc_conv_descriptor_data_get (unshare_expr (src
));
1156 srcptr
= fold_convert (build_pointer_type (etype
), srcptr
);
1157 gfc_omp_linear_clause_add_loop (&block
, ptr
, srcptr
, add
, nelems
);
1161 gfc_add_modify (&block
, unshare_expr (dest
),
1162 fold_convert (TREE_TYPE (dest
), ptr
));
1163 ptr
= fold_convert (TREE_TYPE (dest
), ptr
);
1164 tree dstm
= build_fold_indirect_ref (ptr
);
1165 tree srcm
= build_fold_indirect_ref (unshare_expr (src
));
1166 gfc_add_modify (&block
, dstm
,
1167 fold_build2 (PLUS_EXPR
, TREE_TYPE (add
), srcm
, add
));
1169 return gfc_finish_block (&block
);
1172 /* Build and return code destructing DECL. Return NULL if nothing
1176 gfc_omp_clause_dtor (tree clause
, tree decl
)
1178 tree type
= TREE_TYPE (decl
), tem
;
1180 if ((! GFC_DESCRIPTOR_TYPE_P (type
)
1181 || GFC_TYPE_ARRAY_AKIND (type
) != GFC_ARRAY_ALLOCATABLE
)
1182 && (!GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause
))
1183 || !POINTER_TYPE_P (type
)))
1185 if (gfc_has_alloc_comps (type
, OMP_CLAUSE_DECL (clause
)))
1186 return gfc_walk_alloc_comps (decl
, NULL_TREE
,
1187 OMP_CLAUSE_DECL (clause
),
1188 WALK_ALLOC_COMPS_DTOR
);
1192 if (GFC_DESCRIPTOR_TYPE_P (type
))
1194 /* Allocatable arrays in FIRSTPRIVATE/LASTPRIVATE etc. clauses need
1195 to be deallocated if they were allocated. */
1196 tem
= gfc_conv_descriptor_data_get (decl
);
1197 tem
= gfc_deallocate_with_status (tem
, NULL_TREE
, NULL_TREE
, NULL_TREE
,
1198 NULL_TREE
, true, NULL
,
1199 GFC_CAF_COARRAY_NOCOARRAY
);
1202 tem
= gfc_call_free (decl
);
1203 tem
= gfc_omp_unshare_expr (tem
);
1205 if (gfc_has_alloc_comps (type
, OMP_CLAUSE_DECL (clause
)))
1210 gfc_init_block (&block
);
1211 gfc_add_expr_to_block (&block
,
1212 gfc_walk_alloc_comps (decl
, NULL_TREE
,
1213 OMP_CLAUSE_DECL (clause
),
1214 WALK_ALLOC_COMPS_DTOR
));
1215 gfc_add_expr_to_block (&block
, tem
);
1216 then_b
= gfc_finish_block (&block
);
1218 tem
= fold_convert (pvoid_type_node
,
1219 GFC_DESCRIPTOR_TYPE_P (type
)
1220 ? gfc_conv_descriptor_data_get (decl
) : decl
);
1221 tem
= unshare_expr (tem
);
1222 tree cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
1223 tem
, null_pointer_node
);
1224 tem
= build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
1225 then_b
, build_empty_stmt (input_location
));
1230 /* Build a conditional expression in BLOCK. If COND_VAL is not
1231 null, then the block THEN_B is executed, otherwise ELSE_VAL
1232 is assigned to VAL. */
1235 gfc_build_cond_assign (stmtblock_t
*block
, tree val
, tree cond_val
,
1236 tree then_b
, tree else_val
)
1238 stmtblock_t cond_block
;
1239 tree else_b
= NULL_TREE
;
1240 tree val_ty
= TREE_TYPE (val
);
1244 gfc_init_block (&cond_block
);
1245 gfc_add_modify (&cond_block
, val
, fold_convert (val_ty
, else_val
));
1246 else_b
= gfc_finish_block (&cond_block
);
1248 gfc_add_expr_to_block (block
,
1249 build3_loc (input_location
, COND_EXPR
, void_type_node
,
1250 cond_val
, then_b
, else_b
));
1253 /* Build a conditional expression in BLOCK, returning a temporary
1254 variable containing the result. If COND_VAL is not null, then
1255 THEN_VAL will be assigned to the variable, otherwise ELSE_VAL
1260 gfc_build_cond_assign_expr (stmtblock_t
*block
, tree cond_val
,
1261 tree then_val
, tree else_val
)
1264 tree val_ty
= TREE_TYPE (then_val
);
1265 stmtblock_t cond_block
;
1267 val
= create_tmp_var (val_ty
);
1269 gfc_init_block (&cond_block
);
1270 gfc_add_modify (&cond_block
, val
, then_val
);
1271 tree then_b
= gfc_finish_block (&cond_block
);
1273 gfc_build_cond_assign (block
, val
, cond_val
, then_b
, else_val
);
1279 gfc_omp_finish_clause (tree c
, gimple_seq
*pre_p
)
1281 if (OMP_CLAUSE_CODE (c
) != OMP_CLAUSE_MAP
)
1284 tree decl
= OMP_CLAUSE_DECL (c
);
1286 /* Assumed-size arrays can't be mapped implicitly, they have to be
1287 mapped explicitly using array sections. */
1288 if (TREE_CODE (decl
) == PARM_DECL
1289 && GFC_ARRAY_TYPE_P (TREE_TYPE (decl
))
1290 && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (decl
)) == GFC_ARRAY_UNKNOWN
1291 && GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (decl
),
1292 GFC_TYPE_ARRAY_RANK (TREE_TYPE (decl
)) - 1)
1295 error_at (OMP_CLAUSE_LOCATION (c
),
1296 "implicit mapping of assumed size array %qD", decl
);
1300 tree c2
= NULL_TREE
, c3
= NULL_TREE
, c4
= NULL_TREE
;
1301 tree present
= gfc_omp_check_optional_argument (decl
, true);
1302 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
1304 if (!gfc_omp_privatize_by_reference (decl
)
1305 && !GFC_DECL_GET_SCALAR_POINTER (decl
)
1306 && !GFC_DECL_GET_SCALAR_ALLOCATABLE (decl
)
1307 && !GFC_DECL_CRAY_POINTEE (decl
)
1308 && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (decl
))))
1310 tree orig_decl
= decl
;
1312 c4
= build_omp_clause (OMP_CLAUSE_LOCATION (c
), OMP_CLAUSE_MAP
);
1313 OMP_CLAUSE_SET_MAP_KIND (c4
, GOMP_MAP_POINTER
);
1314 OMP_CLAUSE_DECL (c4
) = decl
;
1315 OMP_CLAUSE_SIZE (c4
) = size_int (0);
1316 decl
= build_fold_indirect_ref (decl
);
1318 && (GFC_DECL_GET_SCALAR_POINTER (orig_decl
)
1319 || GFC_DECL_GET_SCALAR_ALLOCATABLE (orig_decl
)))
1321 c2
= build_omp_clause (input_location
, OMP_CLAUSE_MAP
);
1322 OMP_CLAUSE_SET_MAP_KIND (c2
, GOMP_MAP_POINTER
);
1323 OMP_CLAUSE_DECL (c2
) = decl
;
1324 OMP_CLAUSE_SIZE (c2
) = size_int (0);
1327 gfc_start_block (&block
);
1329 ptr
= gfc_build_cond_assign_expr (&block
, present
, decl
,
1331 gimplify_and_add (gfc_finish_block (&block
), pre_p
);
1332 ptr
= build_fold_indirect_ref (ptr
);
1333 OMP_CLAUSE_DECL (c
) = ptr
;
1334 OMP_CLAUSE_SIZE (c
) = TYPE_SIZE_UNIT (TREE_TYPE (ptr
));
1338 OMP_CLAUSE_DECL (c
) = decl
;
1339 OMP_CLAUSE_SIZE (c
) = NULL_TREE
;
1341 if (TREE_CODE (TREE_TYPE (orig_decl
)) == REFERENCE_TYPE
1342 && (GFC_DECL_GET_SCALAR_POINTER (orig_decl
)
1343 || GFC_DECL_GET_SCALAR_ALLOCATABLE (orig_decl
)))
1345 c3
= build_omp_clause (OMP_CLAUSE_LOCATION (c
), OMP_CLAUSE_MAP
);
1346 OMP_CLAUSE_SET_MAP_KIND (c3
, GOMP_MAP_POINTER
);
1347 OMP_CLAUSE_DECL (c3
) = unshare_expr (decl
);
1348 OMP_CLAUSE_SIZE (c3
) = size_int (0);
1349 decl
= build_fold_indirect_ref (decl
);
1350 OMP_CLAUSE_DECL (c
) = decl
;
1353 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
)))
1356 gfc_start_block (&block
);
1357 tree type
= TREE_TYPE (decl
);
1358 tree ptr
= gfc_conv_descriptor_data_get (decl
);
1361 ptr
= gfc_build_cond_assign_expr (&block
, present
, ptr
,
1363 ptr
= fold_convert (build_pointer_type (char_type_node
), ptr
);
1364 ptr
= build_fold_indirect_ref (ptr
);
1365 OMP_CLAUSE_DECL (c
) = ptr
;
1366 c2
= build_omp_clause (input_location
, OMP_CLAUSE_MAP
);
1367 OMP_CLAUSE_SET_MAP_KIND (c2
, GOMP_MAP_TO_PSET
);
1370 ptr
= create_tmp_var (TREE_TYPE (TREE_OPERAND (decl
, 0)));
1371 gfc_add_modify (&block
, ptr
, TREE_OPERAND (decl
, 0));
1373 OMP_CLAUSE_DECL (c2
) = build_fold_indirect_ref (ptr
);
1376 OMP_CLAUSE_DECL (c2
) = decl
;
1377 OMP_CLAUSE_SIZE (c2
) = TYPE_SIZE_UNIT (type
);
1378 c3
= build_omp_clause (OMP_CLAUSE_LOCATION (c
), OMP_CLAUSE_MAP
);
1379 OMP_CLAUSE_SET_MAP_KIND (c3
, GOMP_MAP_POINTER
);
1382 ptr
= gfc_conv_descriptor_data_get (decl
);
1383 ptr
= gfc_build_addr_expr (NULL
, ptr
);
1384 ptr
= gfc_build_cond_assign_expr (&block
, present
,
1385 ptr
, null_pointer_node
);
1386 ptr
= build_fold_indirect_ref (ptr
);
1387 OMP_CLAUSE_DECL (c3
) = ptr
;
1390 OMP_CLAUSE_DECL (c3
) = gfc_conv_descriptor_data_get (decl
);
1391 OMP_CLAUSE_SIZE (c3
) = size_int (0);
1392 tree size
= create_tmp_var (gfc_array_index_type
);
1393 tree elemsz
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
1394 elemsz
= fold_convert (gfc_array_index_type
, elemsz
);
1395 if (GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_POINTER
1396 || GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_POINTER_CONT
)
1398 stmtblock_t cond_block
;
1399 tree tem
, then_b
, else_b
, zero
, cond
;
1401 gfc_init_block (&cond_block
);
1402 tem
= gfc_full_array_size (&cond_block
, decl
,
1403 GFC_TYPE_ARRAY_RANK (type
));
1404 gfc_add_modify (&cond_block
, size
, tem
);
1405 gfc_add_modify (&cond_block
, size
,
1406 fold_build2 (MULT_EXPR
, gfc_array_index_type
,
1408 then_b
= gfc_finish_block (&cond_block
);
1409 gfc_init_block (&cond_block
);
1410 zero
= build_int_cst (gfc_array_index_type
, 0);
1411 gfc_add_modify (&cond_block
, size
, zero
);
1412 else_b
= gfc_finish_block (&cond_block
);
1413 tem
= gfc_conv_descriptor_data_get (decl
);
1414 tem
= fold_convert (pvoid_type_node
, tem
);
1415 cond
= fold_build2_loc (input_location
, NE_EXPR
,
1416 boolean_type_node
, tem
, null_pointer_node
);
1419 cond
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
1420 boolean_type_node
, present
, cond
);
1422 gfc_add_expr_to_block (&block
, build3_loc (input_location
, COND_EXPR
,
1423 void_type_node
, cond
,
1428 stmtblock_t cond_block
;
1431 gfc_init_block (&cond_block
);
1432 gfc_add_modify (&cond_block
, size
,
1433 gfc_full_array_size (&cond_block
, decl
,
1434 GFC_TYPE_ARRAY_RANK (type
)));
1435 gfc_add_modify (&cond_block
, size
,
1436 fold_build2 (MULT_EXPR
, gfc_array_index_type
,
1438 then_b
= gfc_finish_block (&cond_block
);
1440 gfc_build_cond_assign (&block
, size
, present
, then_b
,
1441 build_int_cst (gfc_array_index_type
, 0));
1445 gfc_add_modify (&block
, size
,
1446 gfc_full_array_size (&block
, decl
,
1447 GFC_TYPE_ARRAY_RANK (type
)));
1448 gfc_add_modify (&block
, size
,
1449 fold_build2 (MULT_EXPR
, gfc_array_index_type
,
1452 OMP_CLAUSE_SIZE (c
) = size
;
1453 tree stmt
= gfc_finish_block (&block
);
1454 gimplify_and_add (stmt
, pre_p
);
1457 if (OMP_CLAUSE_SIZE (c
) == NULL_TREE
)
1459 = DECL_P (decl
) ? DECL_SIZE_UNIT (decl
)
1460 : TYPE_SIZE_UNIT (TREE_TYPE (decl
));
1463 OMP_CLAUSE_CHAIN (c2
) = OMP_CLAUSE_CHAIN (last
);
1464 OMP_CLAUSE_CHAIN (last
) = c2
;
1469 OMP_CLAUSE_CHAIN (c3
) = OMP_CLAUSE_CHAIN (last
);
1470 OMP_CLAUSE_CHAIN (last
) = c3
;
1475 OMP_CLAUSE_CHAIN (c4
) = OMP_CLAUSE_CHAIN (last
);
1476 OMP_CLAUSE_CHAIN (last
) = c4
;
1481 /* Return true if DECL is a scalar variable (for the purpose of
1482 implicit firstprivatization). */
1485 gfc_omp_scalar_p (tree decl
)
1487 tree type
= TREE_TYPE (decl
);
1488 if (TREE_CODE (type
) == REFERENCE_TYPE
)
1489 type
= TREE_TYPE (type
);
1490 if (TREE_CODE (type
) == POINTER_TYPE
)
1492 if (GFC_DECL_GET_SCALAR_ALLOCATABLE (decl
)
1493 || GFC_DECL_GET_SCALAR_POINTER (decl
))
1494 type
= TREE_TYPE (type
);
1495 if (GFC_ARRAY_TYPE_P (type
)
1496 || GFC_CLASS_TYPE_P (type
))
1499 if ((TREE_CODE (type
) == ARRAY_TYPE
|| TREE_CODE (type
) == INTEGER_TYPE
)
1500 && TYPE_STRING_FLAG (type
))
1502 if (INTEGRAL_TYPE_P (type
)
1503 || SCALAR_FLOAT_TYPE_P (type
)
1504 || COMPLEX_FLOAT_TYPE_P (type
))
1510 /* Return true if DECL's DECL_VALUE_EXPR (if any) should be
1511 disregarded in OpenMP construct, because it is going to be
1512 remapped during OpenMP lowering. SHARED is true if DECL
1513 is going to be shared, false if it is going to be privatized. */
1516 gfc_omp_disregard_value_expr (tree decl
, bool shared
)
1518 if (GFC_DECL_COMMON_OR_EQUIV (decl
)
1519 && DECL_HAS_VALUE_EXPR_P (decl
))
1521 tree value
= DECL_VALUE_EXPR (decl
);
1523 if (TREE_CODE (value
) == COMPONENT_REF
1524 && VAR_P (TREE_OPERAND (value
, 0))
1525 && GFC_DECL_COMMON_OR_EQUIV (TREE_OPERAND (value
, 0)))
1527 /* If variable in COMMON or EQUIVALENCE is privatized, return
1528 true, as just that variable is supposed to be privatized,
1529 not the whole COMMON or whole EQUIVALENCE.
1530 For shared variables in COMMON or EQUIVALENCE, let them be
1531 gimplified to DECL_VALUE_EXPR, so that for multiple shared vars
1532 from the same COMMON or EQUIVALENCE just one sharing of the
1533 whole COMMON or EQUIVALENCE is enough. */
1538 if (GFC_DECL_RESULT (decl
) && DECL_HAS_VALUE_EXPR_P (decl
))
1544 /* Return true if DECL that is shared iff SHARED is true should
1545 be put into OMP_CLAUSE_PRIVATE with OMP_CLAUSE_PRIVATE_DEBUG
1549 gfc_omp_private_debug_clause (tree decl
, bool shared
)
1551 if (GFC_DECL_CRAY_POINTEE (decl
))
1554 if (GFC_DECL_COMMON_OR_EQUIV (decl
)
1555 && DECL_HAS_VALUE_EXPR_P (decl
))
1557 tree value
= DECL_VALUE_EXPR (decl
);
1559 if (TREE_CODE (value
) == COMPONENT_REF
1560 && VAR_P (TREE_OPERAND (value
, 0))
1561 && GFC_DECL_COMMON_OR_EQUIV (TREE_OPERAND (value
, 0)))
1568 /* Register language specific type size variables as potentially OpenMP
1569 firstprivate variables. */
1572 gfc_omp_firstprivatize_type_sizes (struct gimplify_omp_ctx
*ctx
, tree type
)
1574 if (GFC_ARRAY_TYPE_P (type
) || GFC_DESCRIPTOR_TYPE_P (type
))
1578 gcc_assert (TYPE_LANG_SPECIFIC (type
) != NULL
);
1579 for (r
= 0; r
< GFC_TYPE_ARRAY_RANK (type
); r
++)
1581 omp_firstprivatize_variable (ctx
, GFC_TYPE_ARRAY_LBOUND (type
, r
));
1582 omp_firstprivatize_variable (ctx
, GFC_TYPE_ARRAY_UBOUND (type
, r
));
1583 omp_firstprivatize_variable (ctx
, GFC_TYPE_ARRAY_STRIDE (type
, r
));
1585 omp_firstprivatize_variable (ctx
, GFC_TYPE_ARRAY_SIZE (type
));
1586 omp_firstprivatize_variable (ctx
, GFC_TYPE_ARRAY_OFFSET (type
));
1592 gfc_trans_add_clause (tree node
, tree tail
)
1594 OMP_CLAUSE_CHAIN (node
) = tail
;
1599 gfc_trans_omp_variable (gfc_symbol
*sym
, bool declare_simd
)
1604 gfc_symbol
*proc_sym
;
1605 gfc_formal_arglist
*f
;
1607 gcc_assert (sym
->attr
.dummy
);
1608 proc_sym
= sym
->ns
->proc_name
;
1609 if (proc_sym
->attr
.entry_master
)
1611 if (gfc_return_by_reference (proc_sym
))
1614 if (proc_sym
->ts
.type
== BT_CHARACTER
)
1617 for (f
= gfc_sym_get_dummy_args (proc_sym
); f
; f
= f
->next
)
1623 return build_int_cst (integer_type_node
, cnt
);
1626 tree t
= gfc_get_symbol_decl (sym
);
1630 bool alternate_entry
;
1633 return_value
= sym
->attr
.function
&& sym
->result
== sym
;
1634 alternate_entry
= sym
->attr
.function
&& sym
->attr
.entry
1635 && sym
->result
== sym
;
1636 entry_master
= sym
->attr
.result
1637 && sym
->ns
->proc_name
->attr
.entry_master
1638 && !gfc_return_by_reference (sym
->ns
->proc_name
);
1639 parent_decl
= current_function_decl
1640 ? DECL_CONTEXT (current_function_decl
) : NULL_TREE
;
1642 if ((t
== parent_decl
&& return_value
)
1643 || (sym
->ns
&& sym
->ns
->proc_name
1644 && sym
->ns
->proc_name
->backend_decl
== parent_decl
1645 && (alternate_entry
|| entry_master
)))
1650 /* Special case for assigning the return value of a function.
1651 Self recursive functions must have an explicit return value. */
1652 if (return_value
&& (t
== current_function_decl
|| parent_flag
))
1653 t
= gfc_get_fake_result_decl (sym
, parent_flag
);
1655 /* Similarly for alternate entry points. */
1656 else if (alternate_entry
1657 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
1660 gfc_entry_list
*el
= NULL
;
1662 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
1665 t
= gfc_get_fake_result_decl (sym
, parent_flag
);
1670 else if (entry_master
1671 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
1673 t
= gfc_get_fake_result_decl (sym
, parent_flag
);
1679 gfc_trans_omp_variable_list (enum omp_clause_code code
,
1680 gfc_omp_namelist
*namelist
, tree list
,
1683 for (; namelist
!= NULL
; namelist
= namelist
->next
)
1684 if (namelist
->sym
->attr
.referenced
|| declare_simd
)
1686 tree t
= gfc_trans_omp_variable (namelist
->sym
, declare_simd
);
1687 if (t
!= error_mark_node
)
1689 tree node
= build_omp_clause (input_location
, code
);
1690 OMP_CLAUSE_DECL (node
) = t
;
1691 list
= gfc_trans_add_clause (node
, list
);
1693 if (code
== OMP_CLAUSE_LASTPRIVATE
1694 && namelist
->u
.lastprivate_conditional
)
1695 OMP_CLAUSE_LASTPRIVATE_CONDITIONAL (node
) = 1;
1701 struct omp_udr_find_orig_data
1703 gfc_omp_udr
*omp_udr
;
1708 omp_udr_find_orig (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
1711 struct omp_udr_find_orig_data
*cd
= (struct omp_udr_find_orig_data
*) data
;
1712 if ((*e
)->expr_type
== EXPR_VARIABLE
1713 && (*e
)->symtree
->n
.sym
== cd
->omp_udr
->omp_orig
)
1714 cd
->omp_orig_seen
= true;
1720 gfc_trans_omp_array_reduction_or_udr (tree c
, gfc_omp_namelist
*n
, locus where
)
1722 gfc_symbol
*sym
= n
->sym
;
1723 gfc_symtree
*root1
= NULL
, *root2
= NULL
, *root3
= NULL
, *root4
= NULL
;
1724 gfc_symtree
*symtree1
, *symtree2
, *symtree3
, *symtree4
= NULL
;
1725 gfc_symbol init_val_sym
, outer_sym
, intrinsic_sym
;
1726 gfc_symbol omp_var_copy
[4];
1727 gfc_expr
*e1
, *e2
, *e3
, *e4
;
1729 tree decl
, backend_decl
, stmt
, type
, outer_decl
;
1730 locus old_loc
= gfc_current_locus
;
1733 gfc_omp_udr
*udr
= n
->udr
? n
->udr
->udr
: NULL
;
1735 decl
= OMP_CLAUSE_DECL (c
);
1736 gfc_current_locus
= where
;
1737 type
= TREE_TYPE (decl
);
1738 outer_decl
= create_tmp_var_raw (type
);
1739 if (TREE_CODE (decl
) == PARM_DECL
1740 && TREE_CODE (type
) == REFERENCE_TYPE
1741 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type
))
1742 && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (type
)) == GFC_ARRAY_ALLOCATABLE
)
1744 decl
= build_fold_indirect_ref (decl
);
1745 type
= TREE_TYPE (type
);
1748 /* Create a fake symbol for init value. */
1749 memset (&init_val_sym
, 0, sizeof (init_val_sym
));
1750 init_val_sym
.ns
= sym
->ns
;
1751 init_val_sym
.name
= sym
->name
;
1752 init_val_sym
.ts
= sym
->ts
;
1753 init_val_sym
.attr
.referenced
= 1;
1754 init_val_sym
.declared_at
= where
;
1755 init_val_sym
.attr
.flavor
= FL_VARIABLE
;
1756 if (OMP_CLAUSE_REDUCTION_CODE (c
) != ERROR_MARK
)
1757 backend_decl
= omp_reduction_init (c
, gfc_sym_type (&init_val_sym
));
1758 else if (udr
->initializer_ns
)
1759 backend_decl
= NULL
;
1761 switch (sym
->ts
.type
)
1767 backend_decl
= build_zero_cst (gfc_sym_type (&init_val_sym
));
1770 backend_decl
= NULL_TREE
;
1773 init_val_sym
.backend_decl
= backend_decl
;
1775 /* Create a fake symbol for the outer array reference. */
1778 outer_sym
.as
= gfc_copy_array_spec (sym
->as
);
1779 outer_sym
.attr
.dummy
= 0;
1780 outer_sym
.attr
.result
= 0;
1781 outer_sym
.attr
.flavor
= FL_VARIABLE
;
1782 outer_sym
.backend_decl
= outer_decl
;
1783 if (decl
!= OMP_CLAUSE_DECL (c
))
1784 outer_sym
.backend_decl
= build_fold_indirect_ref (outer_decl
);
1786 /* Create fake symtrees for it. */
1787 symtree1
= gfc_new_symtree (&root1
, sym
->name
);
1788 symtree1
->n
.sym
= sym
;
1789 gcc_assert (symtree1
== root1
);
1791 symtree2
= gfc_new_symtree (&root2
, sym
->name
);
1792 symtree2
->n
.sym
= &init_val_sym
;
1793 gcc_assert (symtree2
== root2
);
1795 symtree3
= gfc_new_symtree (&root3
, sym
->name
);
1796 symtree3
->n
.sym
= &outer_sym
;
1797 gcc_assert (symtree3
== root3
);
1799 memset (omp_var_copy
, 0, sizeof omp_var_copy
);
1802 omp_var_copy
[0] = *udr
->omp_out
;
1803 omp_var_copy
[1] = *udr
->omp_in
;
1804 *udr
->omp_out
= outer_sym
;
1805 *udr
->omp_in
= *sym
;
1806 if (udr
->initializer_ns
)
1808 omp_var_copy
[2] = *udr
->omp_priv
;
1809 omp_var_copy
[3] = *udr
->omp_orig
;
1810 *udr
->omp_priv
= *sym
;
1811 *udr
->omp_orig
= outer_sym
;
1815 /* Create expressions. */
1816 e1
= gfc_get_expr ();
1817 e1
->expr_type
= EXPR_VARIABLE
;
1819 e1
->symtree
= symtree1
;
1821 if (sym
->attr
.dimension
)
1823 e1
->ref
= ref
= gfc_get_ref ();
1824 ref
->type
= REF_ARRAY
;
1825 ref
->u
.ar
.where
= where
;
1826 ref
->u
.ar
.as
= sym
->as
;
1827 ref
->u
.ar
.type
= AR_FULL
;
1828 ref
->u
.ar
.dimen
= 0;
1830 t
= gfc_resolve_expr (e1
);
1834 if (backend_decl
!= NULL_TREE
)
1836 e2
= gfc_get_expr ();
1837 e2
->expr_type
= EXPR_VARIABLE
;
1839 e2
->symtree
= symtree2
;
1841 t
= gfc_resolve_expr (e2
);
1844 else if (udr
->initializer_ns
== NULL
)
1846 gcc_assert (sym
->ts
.type
== BT_DERIVED
);
1847 e2
= gfc_default_initializer (&sym
->ts
);
1849 t
= gfc_resolve_expr (e2
);
1852 else if (n
->udr
->initializer
->op
== EXEC_ASSIGN
)
1854 e2
= gfc_copy_expr (n
->udr
->initializer
->expr2
);
1855 t
= gfc_resolve_expr (e2
);
1858 if (udr
&& udr
->initializer_ns
)
1860 struct omp_udr_find_orig_data cd
;
1862 cd
.omp_orig_seen
= false;
1863 gfc_code_walker (&n
->udr
->initializer
,
1864 gfc_dummy_code_callback
, omp_udr_find_orig
, &cd
);
1865 if (cd
.omp_orig_seen
)
1866 OMP_CLAUSE_REDUCTION_OMP_ORIG_REF (c
) = 1;
1869 e3
= gfc_copy_expr (e1
);
1870 e3
->symtree
= symtree3
;
1871 t
= gfc_resolve_expr (e3
);
1876 switch (OMP_CLAUSE_REDUCTION_CODE (c
))
1880 e4
= gfc_add (e3
, e1
);
1883 e4
= gfc_multiply (e3
, e1
);
1885 case TRUTH_ANDIF_EXPR
:
1886 e4
= gfc_and (e3
, e1
);
1888 case TRUTH_ORIF_EXPR
:
1889 e4
= gfc_or (e3
, e1
);
1892 e4
= gfc_eqv (e3
, e1
);
1895 e4
= gfc_neqv (e3
, e1
);
1913 if (n
->udr
->combiner
->op
== EXEC_ASSIGN
)
1916 e3
= gfc_copy_expr (n
->udr
->combiner
->expr1
);
1917 e4
= gfc_copy_expr (n
->udr
->combiner
->expr2
);
1918 t
= gfc_resolve_expr (e3
);
1920 t
= gfc_resolve_expr (e4
);
1929 memset (&intrinsic_sym
, 0, sizeof (intrinsic_sym
));
1930 intrinsic_sym
.ns
= sym
->ns
;
1931 intrinsic_sym
.name
= iname
;
1932 intrinsic_sym
.ts
= sym
->ts
;
1933 intrinsic_sym
.attr
.referenced
= 1;
1934 intrinsic_sym
.attr
.intrinsic
= 1;
1935 intrinsic_sym
.attr
.function
= 1;
1936 intrinsic_sym
.attr
.implicit_type
= 1;
1937 intrinsic_sym
.result
= &intrinsic_sym
;
1938 intrinsic_sym
.declared_at
= where
;
1940 symtree4
= gfc_new_symtree (&root4
, iname
);
1941 symtree4
->n
.sym
= &intrinsic_sym
;
1942 gcc_assert (symtree4
== root4
);
1944 e4
= gfc_get_expr ();
1945 e4
->expr_type
= EXPR_FUNCTION
;
1947 e4
->symtree
= symtree4
;
1948 e4
->value
.function
.actual
= gfc_get_actual_arglist ();
1949 e4
->value
.function
.actual
->expr
= e3
;
1950 e4
->value
.function
.actual
->next
= gfc_get_actual_arglist ();
1951 e4
->value
.function
.actual
->next
->expr
= e1
;
1953 if (OMP_CLAUSE_REDUCTION_CODE (c
) != ERROR_MARK
)
1955 /* e1 and e3 have been stored as arguments of e4, avoid sharing. */
1956 e1
= gfc_copy_expr (e1
);
1957 e3
= gfc_copy_expr (e3
);
1958 t
= gfc_resolve_expr (e4
);
1962 /* Create the init statement list. */
1965 stmt
= gfc_trans_assignment (e1
, e2
, false, false);
1967 stmt
= gfc_trans_call (n
->udr
->initializer
, false,
1968 NULL_TREE
, NULL_TREE
, false);
1969 if (TREE_CODE (stmt
) != BIND_EXPR
)
1970 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
1973 OMP_CLAUSE_REDUCTION_INIT (c
) = stmt
;
1975 /* Create the merge statement list. */
1978 stmt
= gfc_trans_assignment (e3
, e4
, false, true);
1980 stmt
= gfc_trans_call (n
->udr
->combiner
, false,
1981 NULL_TREE
, NULL_TREE
, false);
1982 if (TREE_CODE (stmt
) != BIND_EXPR
)
1983 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
1986 OMP_CLAUSE_REDUCTION_MERGE (c
) = stmt
;
1988 /* And stick the placeholder VAR_DECL into the clause as well. */
1989 OMP_CLAUSE_REDUCTION_PLACEHOLDER (c
) = outer_decl
;
1991 gfc_current_locus
= old_loc
;
2004 gfc_free_array_spec (outer_sym
.as
);
2008 *udr
->omp_out
= omp_var_copy
[0];
2009 *udr
->omp_in
= omp_var_copy
[1];
2010 if (udr
->initializer_ns
)
2012 *udr
->omp_priv
= omp_var_copy
[2];
2013 *udr
->omp_orig
= omp_var_copy
[3];
2019 gfc_trans_omp_reduction_list (gfc_omp_namelist
*namelist
, tree list
,
2020 locus where
, bool mark_addressable
)
2022 for (; namelist
!= NULL
; namelist
= namelist
->next
)
2023 if (namelist
->sym
->attr
.referenced
)
2025 tree t
= gfc_trans_omp_variable (namelist
->sym
, false);
2026 if (t
!= error_mark_node
)
2028 tree node
= build_omp_clause (gfc_get_location (&namelist
->where
),
2029 OMP_CLAUSE_REDUCTION
);
2030 OMP_CLAUSE_DECL (node
) = t
;
2031 if (mark_addressable
)
2032 TREE_ADDRESSABLE (t
) = 1;
2033 switch (namelist
->u
.reduction_op
)
2035 case OMP_REDUCTION_PLUS
:
2036 OMP_CLAUSE_REDUCTION_CODE (node
) = PLUS_EXPR
;
2038 case OMP_REDUCTION_MINUS
:
2039 OMP_CLAUSE_REDUCTION_CODE (node
) = MINUS_EXPR
;
2041 case OMP_REDUCTION_TIMES
:
2042 OMP_CLAUSE_REDUCTION_CODE (node
) = MULT_EXPR
;
2044 case OMP_REDUCTION_AND
:
2045 OMP_CLAUSE_REDUCTION_CODE (node
) = TRUTH_ANDIF_EXPR
;
2047 case OMP_REDUCTION_OR
:
2048 OMP_CLAUSE_REDUCTION_CODE (node
) = TRUTH_ORIF_EXPR
;
2050 case OMP_REDUCTION_EQV
:
2051 OMP_CLAUSE_REDUCTION_CODE (node
) = EQ_EXPR
;
2053 case OMP_REDUCTION_NEQV
:
2054 OMP_CLAUSE_REDUCTION_CODE (node
) = NE_EXPR
;
2056 case OMP_REDUCTION_MAX
:
2057 OMP_CLAUSE_REDUCTION_CODE (node
) = MAX_EXPR
;
2059 case OMP_REDUCTION_MIN
:
2060 OMP_CLAUSE_REDUCTION_CODE (node
) = MIN_EXPR
;
2062 case OMP_REDUCTION_IAND
:
2063 OMP_CLAUSE_REDUCTION_CODE (node
) = BIT_AND_EXPR
;
2065 case OMP_REDUCTION_IOR
:
2066 OMP_CLAUSE_REDUCTION_CODE (node
) = BIT_IOR_EXPR
;
2068 case OMP_REDUCTION_IEOR
:
2069 OMP_CLAUSE_REDUCTION_CODE (node
) = BIT_XOR_EXPR
;
2071 case OMP_REDUCTION_USER
:
2072 OMP_CLAUSE_REDUCTION_CODE (node
) = ERROR_MARK
;
2077 if (namelist
->sym
->attr
.dimension
2078 || namelist
->u
.reduction_op
== OMP_REDUCTION_USER
2079 || namelist
->sym
->attr
.allocatable
)
2080 gfc_trans_omp_array_reduction_or_udr (node
, namelist
, where
);
2081 list
= gfc_trans_add_clause (node
, list
);
2088 gfc_convert_expr_to_tree (stmtblock_t
*block
, gfc_expr
*expr
)
2093 gfc_init_se (&se
, NULL
);
2094 gfc_conv_expr (&se
, expr
);
2095 gfc_add_block_to_block (block
, &se
.pre
);
2096 result
= gfc_evaluate_now (se
.expr
, block
);
2097 gfc_add_block_to_block (block
, &se
.post
);
2102 static vec
<tree
, va_heap
, vl_embed
> *doacross_steps
;
2105 /* Translate an array section or array element. */
2108 gfc_trans_omp_array_section (stmtblock_t
*block
, gfc_omp_namelist
*n
,
2109 tree decl
, bool element
, gomp_map_kind ptr_kind
,
2110 tree
&node
, tree
&node2
, tree
&node3
, tree
&node4
)
2114 tree elemsz
= NULL_TREE
;
2116 gfc_init_se (&se
, NULL
);
2120 gfc_conv_expr_reference (&se
, n
->expr
);
2121 gfc_add_block_to_block (block
, &se
.pre
);
2123 OMP_CLAUSE_SIZE (node
) = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (ptr
)));
2124 elemsz
= OMP_CLAUSE_SIZE (node
);
2128 gfc_conv_expr_descriptor (&se
, n
->expr
);
2129 ptr
= gfc_conv_array_data (se
.expr
);
2130 tree type
= TREE_TYPE (se
.expr
);
2131 gfc_add_block_to_block (block
, &se
.pre
);
2132 OMP_CLAUSE_SIZE (node
) = gfc_full_array_size (block
, se
.expr
,
2133 GFC_TYPE_ARRAY_RANK (type
));
2134 elemsz
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
2135 elemsz
= fold_convert (gfc_array_index_type
, elemsz
);
2136 OMP_CLAUSE_SIZE (node
) = fold_build2 (MULT_EXPR
, gfc_array_index_type
,
2137 OMP_CLAUSE_SIZE (node
), elemsz
);
2139 gcc_assert (se
.post
.head
== NULL_TREE
);
2140 ptr
= fold_convert (build_pointer_type (char_type_node
), ptr
);
2141 OMP_CLAUSE_DECL (node
) = build_fold_indirect_ref (ptr
);
2142 ptr
= fold_convert (ptrdiff_type_node
, ptr
);
2144 if (POINTER_TYPE_P (TREE_TYPE (decl
))
2145 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (decl
)))
2146 && ptr_kind
== GOMP_MAP_POINTER
)
2148 node4
= build_omp_clause (input_location
,
2150 OMP_CLAUSE_SET_MAP_KIND (node4
, GOMP_MAP_POINTER
);
2151 OMP_CLAUSE_DECL (node4
) = decl
;
2152 OMP_CLAUSE_SIZE (node4
) = size_int (0);
2153 decl
= build_fold_indirect_ref (decl
);
2155 else if (ptr_kind
== GOMP_MAP_ALWAYS_POINTER
2156 && n
->expr
->ts
.type
== BT_CHARACTER
2157 && n
->expr
->ts
.deferred
)
2159 gomp_map_kind map_kind
;
2160 if (GOMP_MAP_COPY_TO_P (OMP_CLAUSE_MAP_KIND (node
)))
2161 map_kind
= GOMP_MAP_TO
;
2162 else if (OMP_CLAUSE_MAP_KIND (node
) == GOMP_MAP_RELEASE
2163 || OMP_CLAUSE_MAP_KIND (node
) == GOMP_MAP_DELETE
)
2164 map_kind
= OMP_CLAUSE_MAP_KIND (node
);
2166 map_kind
= GOMP_MAP_ALLOC
;
2167 gcc_assert (se
.string_length
);
2168 node4
= build_omp_clause (input_location
, OMP_CLAUSE_MAP
);
2169 OMP_CLAUSE_SET_MAP_KIND (node4
, map_kind
);
2170 OMP_CLAUSE_DECL (node4
) = se
.string_length
;
2171 OMP_CLAUSE_SIZE (node4
) = TYPE_SIZE_UNIT (gfc_charlen_type_node
);
2173 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
)))
2176 tree type
= TREE_TYPE (decl
);
2177 ptr2
= gfc_conv_descriptor_data_get (decl
);
2178 desc_node
= build_omp_clause (input_location
, OMP_CLAUSE_MAP
);
2179 OMP_CLAUSE_DECL (desc_node
) = decl
;
2180 OMP_CLAUSE_SIZE (desc_node
) = TYPE_SIZE_UNIT (type
);
2181 if (ptr_kind
== GOMP_MAP_ALWAYS_POINTER
)
2183 OMP_CLAUSE_SET_MAP_KIND (desc_node
, GOMP_MAP_TO
);
2185 node
= desc_node
; /* Needs to come first. */
2189 OMP_CLAUSE_SET_MAP_KIND (desc_node
, GOMP_MAP_TO_PSET
);
2192 node3
= build_omp_clause (input_location
,
2194 OMP_CLAUSE_SET_MAP_KIND (node3
, ptr_kind
);
2195 OMP_CLAUSE_DECL (node3
)
2196 = gfc_conv_descriptor_data_get (decl
);
2197 /* This purposely does not include GOMP_MAP_ALWAYS_POINTER. The extra
2198 cast prevents gimplify.c from recognising it as being part of the
2199 struct – and adding an 'alloc: for the 'desc.data' pointer, which
2200 would break as the 'desc' (the descriptor) is also mapped
2201 (see node4 above). */
2202 if (ptr_kind
== GOMP_MAP_ATTACH_DETACH
)
2203 STRIP_NOPS (OMP_CLAUSE_DECL (node3
));
2207 if (TREE_CODE (TREE_TYPE (decl
)) == ARRAY_TYPE
)
2210 ptr2
= build_fold_addr_expr (decl
);
2211 offset
= fold_build2 (MINUS_EXPR
, ptrdiff_type_node
, ptr
,
2212 fold_convert (ptrdiff_type_node
, ptr2
));
2213 offset
= build2 (TRUNC_DIV_EXPR
, ptrdiff_type_node
,
2214 offset
, fold_convert (ptrdiff_type_node
, elemsz
));
2215 offset
= build4_loc (input_location
, ARRAY_REF
,
2216 TREE_TYPE (TREE_TYPE (decl
)),
2217 decl
, offset
, NULL_TREE
, NULL_TREE
);
2218 OMP_CLAUSE_DECL (node
) = offset
;
2222 gcc_assert (POINTER_TYPE_P (TREE_TYPE (decl
)));
2225 node3
= build_omp_clause (input_location
,
2227 OMP_CLAUSE_SET_MAP_KIND (node3
, ptr_kind
);
2228 OMP_CLAUSE_DECL (node3
) = decl
;
2230 ptr2
= fold_convert (ptrdiff_type_node
, ptr2
);
2231 OMP_CLAUSE_SIZE (node3
) = fold_build2 (MINUS_EXPR
, ptrdiff_type_node
,
2236 gfc_trans_omp_clauses (stmtblock_t
*block
, gfc_omp_clauses
*clauses
,
2237 locus where
, bool declare_simd
= false,
2238 bool openacc
= false)
2240 tree omp_clauses
= NULL_TREE
, chunk_size
, c
;
2242 enum omp_clause_code clause_code
;
2245 if (clauses
== NULL
)
2248 for (list
= 0; list
< OMP_LIST_NUM
; list
++)
2250 gfc_omp_namelist
*n
= clauses
->lists
[list
];
2256 case OMP_LIST_REDUCTION
:
2257 /* An OpenACC async clause indicates the need to set reduction
2258 arguments addressable, to allow asynchronous copy-out. */
2259 omp_clauses
= gfc_trans_omp_reduction_list (n
, omp_clauses
, where
,
2262 case OMP_LIST_PRIVATE
:
2263 clause_code
= OMP_CLAUSE_PRIVATE
;
2265 case OMP_LIST_SHARED
:
2266 clause_code
= OMP_CLAUSE_SHARED
;
2268 case OMP_LIST_FIRSTPRIVATE
:
2269 clause_code
= OMP_CLAUSE_FIRSTPRIVATE
;
2271 case OMP_LIST_LASTPRIVATE
:
2272 clause_code
= OMP_CLAUSE_LASTPRIVATE
;
2274 case OMP_LIST_COPYIN
:
2275 clause_code
= OMP_CLAUSE_COPYIN
;
2277 case OMP_LIST_COPYPRIVATE
:
2278 clause_code
= OMP_CLAUSE_COPYPRIVATE
;
2280 case OMP_LIST_UNIFORM
:
2281 clause_code
= OMP_CLAUSE_UNIFORM
;
2283 case OMP_LIST_USE_DEVICE
:
2284 case OMP_LIST_USE_DEVICE_PTR
:
2285 clause_code
= OMP_CLAUSE_USE_DEVICE_PTR
;
2287 case OMP_LIST_USE_DEVICE_ADDR
:
2288 clause_code
= OMP_CLAUSE_USE_DEVICE_ADDR
;
2290 case OMP_LIST_IS_DEVICE_PTR
:
2291 clause_code
= OMP_CLAUSE_IS_DEVICE_PTR
;
2293 case OMP_LIST_NONTEMPORAL
:
2294 clause_code
= OMP_CLAUSE_NONTEMPORAL
;
2299 = gfc_trans_omp_variable_list (clause_code
, n
, omp_clauses
,
2302 case OMP_LIST_ALIGNED
:
2303 for (; n
!= NULL
; n
= n
->next
)
2304 if (n
->sym
->attr
.referenced
|| declare_simd
)
2306 tree t
= gfc_trans_omp_variable (n
->sym
, declare_simd
);
2307 if (t
!= error_mark_node
)
2309 tree node
= build_omp_clause (input_location
,
2310 OMP_CLAUSE_ALIGNED
);
2311 OMP_CLAUSE_DECL (node
) = t
;
2317 alignment_var
= gfc_conv_constant_to_tree (n
->expr
);
2320 gfc_init_se (&se
, NULL
);
2321 gfc_conv_expr (&se
, n
->expr
);
2322 gfc_add_block_to_block (block
, &se
.pre
);
2323 alignment_var
= gfc_evaluate_now (se
.expr
, block
);
2324 gfc_add_block_to_block (block
, &se
.post
);
2326 OMP_CLAUSE_ALIGNED_ALIGNMENT (node
) = alignment_var
;
2328 omp_clauses
= gfc_trans_add_clause (node
, omp_clauses
);
2332 case OMP_LIST_LINEAR
:
2334 gfc_expr
*last_step_expr
= NULL
;
2335 tree last_step
= NULL_TREE
;
2336 bool last_step_parm
= false;
2338 for (; n
!= NULL
; n
= n
->next
)
2342 last_step_expr
= n
->expr
;
2343 last_step
= NULL_TREE
;
2344 last_step_parm
= false;
2346 if (n
->sym
->attr
.referenced
|| declare_simd
)
2348 tree t
= gfc_trans_omp_variable (n
->sym
, declare_simd
);
2349 if (t
!= error_mark_node
)
2351 tree node
= build_omp_clause (input_location
,
2353 OMP_CLAUSE_DECL (node
) = t
;
2354 omp_clause_linear_kind kind
;
2355 switch (n
->u
.linear_op
)
2357 case OMP_LINEAR_DEFAULT
:
2358 kind
= OMP_CLAUSE_LINEAR_DEFAULT
;
2360 case OMP_LINEAR_REF
:
2361 kind
= OMP_CLAUSE_LINEAR_REF
;
2363 case OMP_LINEAR_VAL
:
2364 kind
= OMP_CLAUSE_LINEAR_VAL
;
2366 case OMP_LINEAR_UVAL
:
2367 kind
= OMP_CLAUSE_LINEAR_UVAL
;
2372 OMP_CLAUSE_LINEAR_KIND (node
) = kind
;
2373 if (last_step_expr
&& last_step
== NULL_TREE
)
2377 gfc_init_se (&se
, NULL
);
2378 gfc_conv_expr (&se
, last_step_expr
);
2379 gfc_add_block_to_block (block
, &se
.pre
);
2380 last_step
= gfc_evaluate_now (se
.expr
, block
);
2381 gfc_add_block_to_block (block
, &se
.post
);
2383 else if (last_step_expr
->expr_type
== EXPR_VARIABLE
)
2385 gfc_symbol
*s
= last_step_expr
->symtree
->n
.sym
;
2386 last_step
= gfc_trans_omp_variable (s
, true);
2387 last_step_parm
= true;
2391 = gfc_conv_constant_to_tree (last_step_expr
);
2395 OMP_CLAUSE_LINEAR_VARIABLE_STRIDE (node
) = 1;
2396 OMP_CLAUSE_LINEAR_STEP (node
) = last_step
;
2400 if (kind
== OMP_CLAUSE_LINEAR_REF
)
2403 if (n
->sym
->attr
.flavor
== FL_PROCEDURE
)
2405 type
= gfc_get_function_type (n
->sym
);
2406 type
= build_pointer_type (type
);
2409 type
= gfc_sym_type (n
->sym
);
2410 if (POINTER_TYPE_P (type
))
2411 type
= TREE_TYPE (type
);
2412 /* Otherwise to be determined what exactly
2414 tree t
= fold_convert (sizetype
, last_step
);
2415 t
= size_binop (MULT_EXPR
, t
,
2416 TYPE_SIZE_UNIT (type
));
2417 OMP_CLAUSE_LINEAR_STEP (node
) = t
;
2422 = gfc_typenode_for_spec (&n
->sym
->ts
);
2423 OMP_CLAUSE_LINEAR_STEP (node
)
2424 = fold_convert (type
, last_step
);
2427 if (n
->sym
->attr
.dimension
|| n
->sym
->attr
.allocatable
)
2428 OMP_CLAUSE_LINEAR_ARRAY (node
) = 1;
2429 omp_clauses
= gfc_trans_add_clause (node
, omp_clauses
);
2435 case OMP_LIST_DEPEND
:
2436 for (; n
!= NULL
; n
= n
->next
)
2438 if (n
->u
.depend_op
== OMP_DEPEND_SINK_FIRST
)
2440 tree vec
= NULL_TREE
;
2444 tree addend
= integer_zero_node
, t
;
2448 addend
= gfc_conv_constant_to_tree (n
->expr
);
2449 if (TREE_CODE (addend
) == INTEGER_CST
2450 && tree_int_cst_sgn (addend
) == -1)
2453 addend
= const_unop (NEGATE_EXPR
,
2454 TREE_TYPE (addend
), addend
);
2457 t
= gfc_trans_omp_variable (n
->sym
, false);
2458 if (t
!= error_mark_node
)
2460 if (i
< vec_safe_length (doacross_steps
)
2461 && !integer_zerop (addend
)
2462 && (*doacross_steps
)[i
])
2464 tree step
= (*doacross_steps
)[i
];
2465 addend
= fold_convert (TREE_TYPE (step
), addend
);
2466 addend
= build2 (TRUNC_DIV_EXPR
,
2467 TREE_TYPE (step
), addend
, step
);
2469 vec
= tree_cons (addend
, t
, vec
);
2471 OMP_CLAUSE_DEPEND_SINK_NEGATIVE (vec
) = 1;
2474 || n
->next
->u
.depend_op
!= OMP_DEPEND_SINK
)
2478 if (vec
== NULL_TREE
)
2481 tree node
= build_omp_clause (input_location
,
2483 OMP_CLAUSE_DEPEND_KIND (node
) = OMP_CLAUSE_DEPEND_SINK
;
2484 OMP_CLAUSE_DECL (node
) = nreverse (vec
);
2485 omp_clauses
= gfc_trans_add_clause (node
, omp_clauses
);
2489 if (!n
->sym
->attr
.referenced
)
2492 tree node
= build_omp_clause (input_location
, OMP_CLAUSE_DEPEND
);
2493 if (n
->expr
== NULL
|| n
->expr
->ref
->u
.ar
.type
== AR_FULL
)
2495 tree decl
= gfc_trans_omp_variable (n
->sym
, false);
2496 if (gfc_omp_privatize_by_reference (decl
))
2497 decl
= build_fold_indirect_ref (decl
);
2498 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
)))
2500 decl
= gfc_conv_descriptor_data_get (decl
);
2501 decl
= fold_convert (build_pointer_type (char_type_node
),
2503 decl
= build_fold_indirect_ref (decl
);
2505 else if (DECL_P (decl
))
2506 TREE_ADDRESSABLE (decl
) = 1;
2507 OMP_CLAUSE_DECL (node
) = decl
;
2512 gfc_init_se (&se
, NULL
);
2513 if (n
->expr
->ref
->u
.ar
.type
== AR_ELEMENT
)
2515 gfc_conv_expr_reference (&se
, n
->expr
);
2520 gfc_conv_expr_descriptor (&se
, n
->expr
);
2521 ptr
= gfc_conv_array_data (se
.expr
);
2523 gfc_add_block_to_block (block
, &se
.pre
);
2524 gfc_add_block_to_block (block
, &se
.post
);
2525 ptr
= fold_convert (build_pointer_type (char_type_node
),
2527 OMP_CLAUSE_DECL (node
) = build_fold_indirect_ref (ptr
);
2529 switch (n
->u
.depend_op
)
2532 OMP_CLAUSE_DEPEND_KIND (node
) = OMP_CLAUSE_DEPEND_IN
;
2534 case OMP_DEPEND_OUT
:
2535 OMP_CLAUSE_DEPEND_KIND (node
) = OMP_CLAUSE_DEPEND_OUT
;
2537 case OMP_DEPEND_INOUT
:
2538 OMP_CLAUSE_DEPEND_KIND (node
) = OMP_CLAUSE_DEPEND_INOUT
;
2543 omp_clauses
= gfc_trans_add_clause (node
, omp_clauses
);
2547 for (; n
!= NULL
; n
= n
->next
)
2549 if (!n
->sym
->attr
.referenced
)
2552 tree node
= build_omp_clause (input_location
, OMP_CLAUSE_MAP
);
2553 tree node2
= NULL_TREE
;
2554 tree node3
= NULL_TREE
;
2555 tree node4
= NULL_TREE
;
2557 switch (n
->u
.map_op
)
2560 OMP_CLAUSE_SET_MAP_KIND (node
, GOMP_MAP_ALLOC
);
2562 case OMP_MAP_IF_PRESENT
:
2563 OMP_CLAUSE_SET_MAP_KIND (node
, GOMP_MAP_IF_PRESENT
);
2565 case OMP_MAP_ATTACH
:
2566 OMP_CLAUSE_SET_MAP_KIND (node
, GOMP_MAP_ATTACH
);
2569 OMP_CLAUSE_SET_MAP_KIND (node
, GOMP_MAP_TO
);
2572 OMP_CLAUSE_SET_MAP_KIND (node
, GOMP_MAP_FROM
);
2574 case OMP_MAP_TOFROM
:
2575 OMP_CLAUSE_SET_MAP_KIND (node
, GOMP_MAP_TOFROM
);
2577 case OMP_MAP_ALWAYS_TO
:
2578 OMP_CLAUSE_SET_MAP_KIND (node
, GOMP_MAP_ALWAYS_TO
);
2580 case OMP_MAP_ALWAYS_FROM
:
2581 OMP_CLAUSE_SET_MAP_KIND (node
, GOMP_MAP_ALWAYS_FROM
);
2583 case OMP_MAP_ALWAYS_TOFROM
:
2584 OMP_CLAUSE_SET_MAP_KIND (node
, GOMP_MAP_ALWAYS_TOFROM
);
2586 case OMP_MAP_RELEASE
:
2587 OMP_CLAUSE_SET_MAP_KIND (node
, GOMP_MAP_RELEASE
);
2589 case OMP_MAP_DELETE
:
2590 OMP_CLAUSE_SET_MAP_KIND (node
, GOMP_MAP_DELETE
);
2592 case OMP_MAP_DETACH
:
2593 OMP_CLAUSE_SET_MAP_KIND (node
, GOMP_MAP_DETACH
);
2595 case OMP_MAP_FORCE_ALLOC
:
2596 OMP_CLAUSE_SET_MAP_KIND (node
, GOMP_MAP_FORCE_ALLOC
);
2598 case OMP_MAP_FORCE_TO
:
2599 OMP_CLAUSE_SET_MAP_KIND (node
, GOMP_MAP_FORCE_TO
);
2601 case OMP_MAP_FORCE_FROM
:
2602 OMP_CLAUSE_SET_MAP_KIND (node
, GOMP_MAP_FORCE_FROM
);
2604 case OMP_MAP_FORCE_TOFROM
:
2605 OMP_CLAUSE_SET_MAP_KIND (node
, GOMP_MAP_FORCE_TOFROM
);
2607 case OMP_MAP_FORCE_PRESENT
:
2608 OMP_CLAUSE_SET_MAP_KIND (node
, GOMP_MAP_FORCE_PRESENT
);
2610 case OMP_MAP_FORCE_DEVICEPTR
:
2611 OMP_CLAUSE_SET_MAP_KIND (node
, GOMP_MAP_FORCE_DEVICEPTR
);
2617 tree decl
= gfc_trans_omp_variable (n
->sym
, false);
2619 TREE_ADDRESSABLE (decl
) = 1;
2621 || (n
->expr
->ref
->type
== REF_ARRAY
2622 && n
->expr
->ref
->u
.ar
.type
== AR_FULL
))
2624 tree present
= gfc_omp_check_optional_argument (decl
, true);
2625 if (openacc
&& n
->sym
->ts
.type
== BT_CLASS
)
2627 tree type
= TREE_TYPE (decl
);
2628 if (n
->sym
->attr
.optional
)
2629 sorry ("optional class parameter");
2630 if (POINTER_TYPE_P (type
))
2632 node4
= build_omp_clause (input_location
,
2634 OMP_CLAUSE_SET_MAP_KIND (node4
, GOMP_MAP_POINTER
);
2635 OMP_CLAUSE_DECL (node4
) = decl
;
2636 OMP_CLAUSE_SIZE (node4
) = size_int (0);
2637 decl
= build_fold_indirect_ref (decl
);
2639 tree ptr
= gfc_class_data_get (decl
);
2640 ptr
= build_fold_indirect_ref (ptr
);
2641 OMP_CLAUSE_DECL (node
) = ptr
;
2642 OMP_CLAUSE_SIZE (node
) = gfc_class_vtab_size_get (decl
);
2643 node2
= build_omp_clause (input_location
, OMP_CLAUSE_MAP
);
2644 OMP_CLAUSE_SET_MAP_KIND (node2
, GOMP_MAP_TO_PSET
);
2645 OMP_CLAUSE_DECL (node2
) = decl
;
2646 OMP_CLAUSE_SIZE (node2
) = TYPE_SIZE_UNIT (type
);
2647 node3
= build_omp_clause (input_location
, OMP_CLAUSE_MAP
);
2648 OMP_CLAUSE_SET_MAP_KIND (node3
, GOMP_MAP_ATTACH_DETACH
);
2649 OMP_CLAUSE_DECL (node3
) = gfc_class_data_get (decl
);
2650 OMP_CLAUSE_SIZE (node3
) = size_int (0);
2651 goto finalize_map_clause
;
2653 else if (POINTER_TYPE_P (TREE_TYPE (decl
))
2654 && (gfc_omp_privatize_by_reference (decl
)
2655 || GFC_DECL_GET_SCALAR_POINTER (decl
)
2656 || GFC_DECL_GET_SCALAR_ALLOCATABLE (decl
)
2657 || GFC_DECL_CRAY_POINTEE (decl
)
2658 || GFC_DESCRIPTOR_TYPE_P
2659 (TREE_TYPE (TREE_TYPE (decl
)))
2660 || n
->sym
->ts
.type
== BT_DERIVED
))
2662 tree orig_decl
= decl
;
2664 /* For nonallocatable, nonpointer arrays, a temporary
2665 variable is generated, but this one is only defined if
2666 the variable is present; hence, we now set it to NULL
2667 to avoid accessing undefined variables. We cannot use
2668 a temporary variable here as otherwise the replacement
2669 of the variables in omp-low.c will not work. */
2670 if (present
&& GFC_ARRAY_TYPE_P (TREE_TYPE (decl
)))
2672 tree tmp
= fold_build2_loc (input_location
,
2674 void_type_node
, decl
,
2676 tree cond
= fold_build1_loc (input_location
,
2680 gfc_add_expr_to_block (block
,
2681 build3_loc (input_location
,
2687 node4
= build_omp_clause (input_location
,
2689 OMP_CLAUSE_SET_MAP_KIND (node4
, GOMP_MAP_POINTER
);
2690 OMP_CLAUSE_DECL (node4
) = decl
;
2691 OMP_CLAUSE_SIZE (node4
) = size_int (0);
2692 decl
= build_fold_indirect_ref (decl
);
2693 if ((TREE_CODE (TREE_TYPE (orig_decl
)) == REFERENCE_TYPE
2694 || gfc_omp_is_optional_argument (orig_decl
))
2695 && (GFC_DECL_GET_SCALAR_POINTER (orig_decl
)
2696 || GFC_DECL_GET_SCALAR_ALLOCATABLE (orig_decl
)))
2698 node3
= build_omp_clause (input_location
,
2700 OMP_CLAUSE_SET_MAP_KIND (node3
, GOMP_MAP_POINTER
);
2701 OMP_CLAUSE_DECL (node3
) = decl
;
2702 OMP_CLAUSE_SIZE (node3
) = size_int (0);
2703 decl
= build_fold_indirect_ref (decl
);
2706 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
)))
2708 tree type
= TREE_TYPE (decl
);
2709 tree ptr
= gfc_conv_descriptor_data_get (decl
);
2711 ptr
= gfc_build_cond_assign_expr (block
, present
, ptr
,
2713 ptr
= fold_convert (build_pointer_type (char_type_node
),
2715 ptr
= build_fold_indirect_ref (ptr
);
2716 OMP_CLAUSE_DECL (node
) = ptr
;
2717 node2
= build_omp_clause (input_location
,
2719 OMP_CLAUSE_SET_MAP_KIND (node2
, GOMP_MAP_TO_PSET
);
2720 OMP_CLAUSE_DECL (node2
) = decl
;
2721 OMP_CLAUSE_SIZE (node2
) = TYPE_SIZE_UNIT (type
);
2722 node3
= build_omp_clause (input_location
,
2726 ptr
= gfc_conv_descriptor_data_get (decl
);
2727 ptr
= gfc_build_addr_expr (NULL
, ptr
);
2728 ptr
= gfc_build_cond_assign_expr (block
, present
, ptr
,
2730 ptr
= build_fold_indirect_ref (ptr
);
2731 OMP_CLAUSE_DECL (node3
) = ptr
;
2734 OMP_CLAUSE_DECL (node3
)
2735 = gfc_conv_descriptor_data_get (decl
);
2736 OMP_CLAUSE_SIZE (node3
) = size_int (0);
2737 if (n
->u
.map_op
== OMP_MAP_ATTACH
)
2739 /* Standalone attach clauses used with arrays with
2740 descriptors must copy the descriptor to the target,
2741 else they won't have anything to perform the
2742 attachment onto (see OpenACC 2.6, "2.6.3. Data
2743 Structures with Pointers"). */
2744 OMP_CLAUSE_SET_MAP_KIND (node3
, GOMP_MAP_ATTACH
);
2745 /* We don't want to map PTR at all in this case, so
2746 delete its node and shuffle the others down. */
2750 goto finalize_map_clause
;
2752 else if (n
->u
.map_op
== OMP_MAP_DETACH
)
2754 OMP_CLAUSE_SET_MAP_KIND (node3
, GOMP_MAP_DETACH
);
2755 /* Similarly to above, we don't want to unmap PTR
2760 goto finalize_map_clause
;
2763 OMP_CLAUSE_SET_MAP_KIND (node3
, GOMP_MAP_POINTER
);
2765 /* We have to check for n->sym->attr.dimension because
2766 of scalar coarrays. */
2767 if (n
->sym
->attr
.pointer
&& n
->sym
->attr
.dimension
)
2769 stmtblock_t cond_block
;
2771 = gfc_create_var (gfc_array_index_type
, NULL
);
2772 tree tem
, then_b
, else_b
, zero
, cond
;
2774 gfc_init_block (&cond_block
);
2776 = gfc_full_array_size (&cond_block
, decl
,
2777 GFC_TYPE_ARRAY_RANK (type
));
2778 gfc_add_modify (&cond_block
, size
, tem
);
2779 then_b
= gfc_finish_block (&cond_block
);
2780 gfc_init_block (&cond_block
);
2781 zero
= build_int_cst (gfc_array_index_type
, 0);
2782 gfc_add_modify (&cond_block
, size
, zero
);
2783 else_b
= gfc_finish_block (&cond_block
);
2784 tem
= gfc_conv_descriptor_data_get (decl
);
2785 tem
= fold_convert (pvoid_type_node
, tem
);
2786 cond
= fold_build2_loc (input_location
, NE_EXPR
,
2788 tem
, null_pointer_node
);
2790 cond
= fold_build2_loc (input_location
,
2794 gfc_add_expr_to_block (block
,
2795 build3_loc (input_location
,
2800 OMP_CLAUSE_SIZE (node
) = size
;
2802 else if (n
->sym
->attr
.dimension
)
2804 stmtblock_t cond_block
;
2805 gfc_init_block (&cond_block
);
2806 tree size
= gfc_full_array_size (&cond_block
, decl
,
2807 GFC_TYPE_ARRAY_RANK (type
));
2810 tree var
= gfc_create_var (gfc_array_index_type
,
2812 gfc_add_modify (&cond_block
, var
, size
);
2813 tree cond_body
= gfc_finish_block (&cond_block
);
2814 tree cond
= build3_loc (input_location
, COND_EXPR
,
2815 void_type_node
, present
,
2816 cond_body
, NULL_TREE
);
2817 gfc_add_expr_to_block (block
, cond
);
2818 OMP_CLAUSE_SIZE (node
) = var
;
2822 gfc_add_block_to_block (block
, &cond_block
);
2823 OMP_CLAUSE_SIZE (node
) = size
;
2826 if (n
->sym
->attr
.dimension
)
2829 = TYPE_SIZE_UNIT (gfc_get_element_type (type
));
2830 elemsz
= fold_convert (gfc_array_index_type
, elemsz
);
2831 OMP_CLAUSE_SIZE (node
)
2832 = fold_build2 (MULT_EXPR
, gfc_array_index_type
,
2833 OMP_CLAUSE_SIZE (node
), elemsz
);
2837 && TREE_CODE (decl
) == INDIRECT_REF
2838 && (TREE_CODE (TREE_OPERAND (decl
, 0))
2841 /* A single indirectref is handled by the middle end. */
2842 gcc_assert (!POINTER_TYPE_P (TREE_TYPE (decl
)));
2843 decl
= TREE_OPERAND (decl
, 0);
2844 decl
= gfc_build_cond_assign_expr (block
, present
, decl
,
2846 OMP_CLAUSE_DECL (node
) = build_fold_indirect_ref (decl
);
2849 OMP_CLAUSE_DECL (node
) = decl
;
2852 && n
->expr
->expr_type
== EXPR_VARIABLE
2853 && n
->expr
->ref
->type
== REF_COMPONENT
)
2857 for (gfc_ref
*ref
= n
->expr
->ref
; ref
; ref
= ref
->next
)
2858 if (ref
->type
== REF_COMPONENT
)
2861 symbol_attribute sym_attr
;
2863 if (lastcomp
->u
.c
.component
->ts
.type
== BT_CLASS
)
2864 sym_attr
= CLASS_DATA (lastcomp
->u
.c
.component
)->attr
;
2866 sym_attr
= lastcomp
->u
.c
.component
->attr
;
2868 gfc_init_se (&se
, NULL
);
2870 if (!sym_attr
.dimension
2871 && lastcomp
->u
.c
.component
->ts
.type
!= BT_CLASS
2872 && lastcomp
->u
.c
.component
->ts
.type
!= BT_DERIVED
)
2874 /* Last component is a scalar. */
2875 gfc_conv_expr (&se
, n
->expr
);
2876 gfc_add_block_to_block (block
, &se
.pre
);
2877 /* For BT_CHARACTER a pointer is returned. */
2878 OMP_CLAUSE_DECL (node
)
2879 = POINTER_TYPE_P (TREE_TYPE (se
.expr
))
2880 ? build_fold_indirect_ref (se
.expr
) : se
.expr
;
2881 gfc_add_block_to_block (block
, &se
.post
);
2882 if (sym_attr
.pointer
|| sym_attr
.allocatable
)
2884 node2
= build_omp_clause (input_location
,
2886 OMP_CLAUSE_SET_MAP_KIND (node2
,
2888 ? GOMP_MAP_ATTACH_DETACH
2889 : GOMP_MAP_ALWAYS_POINTER
);
2890 OMP_CLAUSE_DECL (node2
)
2891 = POINTER_TYPE_P (TREE_TYPE (se
.expr
))
2892 ? se
.expr
: gfc_build_addr_expr (NULL
, se
.expr
);
2893 OMP_CLAUSE_SIZE (node2
) = size_int (0);
2895 && n
->expr
->ts
.type
== BT_CHARACTER
2896 && n
->expr
->ts
.deferred
)
2898 gcc_assert (se
.string_length
);
2899 tree tmp
= gfc_get_char_type (n
->expr
->ts
.kind
);
2900 OMP_CLAUSE_SIZE (node
)
2901 = fold_build2 (MULT_EXPR
, size_type_node
,
2902 fold_convert (size_type_node
,
2904 TYPE_SIZE_UNIT (tmp
));
2905 node3
= build_omp_clause (input_location
,
2907 OMP_CLAUSE_SET_MAP_KIND (node3
, GOMP_MAP_TO
);
2908 OMP_CLAUSE_DECL (node3
) = se
.string_length
;
2909 OMP_CLAUSE_SIZE (node3
)
2910 = TYPE_SIZE_UNIT (gfc_charlen_type_node
);
2913 goto finalize_map_clause
;
2916 se
.expr
= gfc_maybe_dereference_var (n
->sym
, decl
);
2918 for (gfc_ref
*ref
= n
->expr
->ref
;
2919 ref
&& ref
!= lastcomp
->next
;
2922 if (ref
->type
== REF_COMPONENT
)
2924 if (ref
->u
.c
.sym
->attr
.extension
)
2925 conv_parent_component_references (&se
, ref
);
2927 gfc_conv_component_ref (&se
, ref
);
2930 sorry ("unhandled derived-type component");
2933 tree inner
= se
.expr
;
2935 /* Last component is a derived type or class pointer. */
2936 if (lastcomp
->u
.c
.component
->ts
.type
== BT_DERIVED
2937 || lastcomp
->u
.c
.component
->ts
.type
== BT_CLASS
)
2939 if (sym_attr
.pointer
|| (openacc
&& sym_attr
.allocatable
))
2943 if (lastcomp
->u
.c
.component
->ts
.type
== BT_CLASS
)
2945 data
= gfc_class_data_get (inner
);
2946 size
= gfc_class_vtab_size_get (inner
);
2948 else /* BT_DERIVED. */
2951 size
= TYPE_SIZE_UNIT (TREE_TYPE (inner
));
2954 OMP_CLAUSE_DECL (node
)
2955 = build_fold_indirect_ref (data
);
2956 OMP_CLAUSE_SIZE (node
) = size
;
2957 node2
= build_omp_clause (input_location
,
2959 OMP_CLAUSE_SET_MAP_KIND (node2
,
2961 ? GOMP_MAP_ATTACH_DETACH
2962 : GOMP_MAP_ALWAYS_POINTER
);
2963 OMP_CLAUSE_DECL (node2
) = data
;
2964 OMP_CLAUSE_SIZE (node2
) = size_int (0);
2968 OMP_CLAUSE_DECL (node
) = inner
;
2969 OMP_CLAUSE_SIZE (node
)
2970 = TYPE_SIZE_UNIT (TREE_TYPE (inner
));
2973 else if (lastcomp
->next
2974 && lastcomp
->next
->type
== REF_ARRAY
2975 && lastcomp
->next
->u
.ar
.type
== AR_FULL
)
2977 /* Just pass the (auto-dereferenced) decl through for
2978 bare attach and detach clauses. */
2979 if (n
->u
.map_op
== OMP_MAP_ATTACH
2980 || n
->u
.map_op
== OMP_MAP_DETACH
)
2982 OMP_CLAUSE_DECL (node
) = inner
;
2983 OMP_CLAUSE_SIZE (node
) = size_zero_node
;
2984 goto finalize_map_clause
;
2987 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (inner
)))
2989 gomp_map_kind map_kind
;
2991 tree type
= TREE_TYPE (inner
);
2992 tree ptr
= gfc_conv_descriptor_data_get (inner
);
2993 ptr
= build_fold_indirect_ref (ptr
);
2994 OMP_CLAUSE_DECL (node
) = ptr
;
2995 int rank
= GFC_TYPE_ARRAY_RANK (type
);
2996 OMP_CLAUSE_SIZE (node
)
2997 = gfc_full_array_size (block
, inner
, rank
);
2999 = TYPE_SIZE_UNIT (gfc_get_element_type (type
));
3000 if (GOMP_MAP_COPY_TO_P (OMP_CLAUSE_MAP_KIND (node
)))
3001 map_kind
= GOMP_MAP_TO
;
3002 else if (n
->u
.map_op
== OMP_MAP_RELEASE
3003 || n
->u
.map_op
== OMP_MAP_DELETE
)
3004 map_kind
= OMP_CLAUSE_MAP_KIND (node
);
3006 map_kind
= GOMP_MAP_ALLOC
;
3008 && n
->expr
->ts
.type
== BT_CHARACTER
3009 && n
->expr
->ts
.deferred
)
3011 gcc_assert (se
.string_length
);
3012 tree len
= fold_convert (size_type_node
,
3014 elemsz
= gfc_get_char_type (n
->expr
->ts
.kind
);
3015 elemsz
= TYPE_SIZE_UNIT (elemsz
);
3016 elemsz
= fold_build2 (MULT_EXPR
, size_type_node
,
3018 node4
= build_omp_clause (input_location
,
3020 OMP_CLAUSE_SET_MAP_KIND (node4
, map_kind
);
3021 OMP_CLAUSE_DECL (node4
) = se
.string_length
;
3022 OMP_CLAUSE_SIZE (node4
)
3023 = TYPE_SIZE_UNIT (gfc_charlen_type_node
);
3025 elemsz
= fold_convert (gfc_array_index_type
, elemsz
);
3026 OMP_CLAUSE_SIZE (node
)
3027 = fold_build2 (MULT_EXPR
, gfc_array_index_type
,
3028 OMP_CLAUSE_SIZE (node
), elemsz
);
3029 desc_node
= build_omp_clause (input_location
,
3032 OMP_CLAUSE_SET_MAP_KIND (desc_node
,
3035 OMP_CLAUSE_SET_MAP_KIND (desc_node
, map_kind
);
3036 OMP_CLAUSE_DECL (desc_node
) = inner
;
3037 OMP_CLAUSE_SIZE (desc_node
) = TYPE_SIZE_UNIT (type
);
3043 node
= desc_node
; /* Put first. */
3045 node3
= build_omp_clause (input_location
,
3047 OMP_CLAUSE_SET_MAP_KIND (node3
,
3049 ? GOMP_MAP_ATTACH_DETACH
3050 : GOMP_MAP_ALWAYS_POINTER
);
3051 OMP_CLAUSE_DECL (node3
)
3052 = gfc_conv_descriptor_data_get (inner
);
3053 /* Similar to gfc_trans_omp_array_section (details
3054 there), we add/keep the cast for OpenMP to prevent
3055 that an 'alloc:' gets added for node3 ('desc.data')
3056 as that is part of the whole descriptor (node3).
3057 TODO: Remove once the ME handles this properly. */
3059 OMP_CLAUSE_DECL (node3
)
3060 = fold_convert (TREE_TYPE (TREE_OPERAND(ptr
, 0)),
3061 OMP_CLAUSE_DECL (node3
));
3063 STRIP_NOPS (OMP_CLAUSE_DECL (node3
));
3064 OMP_CLAUSE_SIZE (node3
) = size_int (0);
3067 OMP_CLAUSE_DECL (node
) = inner
;
3069 else /* An array element or section. */
3073 && lastcomp
->next
->type
== REF_ARRAY
3074 && lastcomp
->next
->u
.ar
.type
== AR_ELEMENT
);
3076 gomp_map_kind kind
= (openacc
? GOMP_MAP_ATTACH_DETACH
3077 : GOMP_MAP_ALWAYS_POINTER
);
3078 gfc_trans_omp_array_section (block
, n
, inner
, element
,
3079 kind
, node
, node2
, node3
,
3083 else /* An array element or array section. */
3085 bool element
= n
->expr
->ref
->u
.ar
.type
== AR_ELEMENT
;
3086 gfc_trans_omp_array_section (block
, n
, decl
, element
,
3087 GOMP_MAP_POINTER
, node
, node2
,
3091 finalize_map_clause
:
3093 omp_clauses
= gfc_trans_add_clause (node
, omp_clauses
);
3095 omp_clauses
= gfc_trans_add_clause (node2
, omp_clauses
);
3097 omp_clauses
= gfc_trans_add_clause (node3
, omp_clauses
);
3099 omp_clauses
= gfc_trans_add_clause (node4
, omp_clauses
);
3104 case OMP_LIST_CACHE
:
3105 for (; n
!= NULL
; n
= n
->next
)
3107 if (!n
->sym
->attr
.referenced
)
3113 clause_code
= OMP_CLAUSE_TO
;
3116 clause_code
= OMP_CLAUSE_FROM
;
3118 case OMP_LIST_CACHE
:
3119 clause_code
= OMP_CLAUSE__CACHE_
;
3124 tree node
= build_omp_clause (input_location
, clause_code
);
3125 if (n
->expr
== NULL
|| n
->expr
->ref
->u
.ar
.type
== AR_FULL
)
3127 tree decl
= gfc_trans_omp_variable (n
->sym
, false);
3128 if (gfc_omp_privatize_by_reference (decl
))
3130 if (gfc_omp_is_allocatable_or_ptr (decl
))
3131 decl
= build_fold_indirect_ref (decl
);
3132 decl
= build_fold_indirect_ref (decl
);
3134 else if (DECL_P (decl
))
3135 TREE_ADDRESSABLE (decl
) = 1;
3136 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
)))
3138 tree type
= TREE_TYPE (decl
);
3139 tree ptr
= gfc_conv_descriptor_data_get (decl
);
3140 ptr
= fold_convert (build_pointer_type (char_type_node
),
3142 ptr
= build_fold_indirect_ref (ptr
);
3143 OMP_CLAUSE_DECL (node
) = ptr
;
3144 OMP_CLAUSE_SIZE (node
)
3145 = gfc_full_array_size (block
, decl
,
3146 GFC_TYPE_ARRAY_RANK (type
));
3148 = TYPE_SIZE_UNIT (gfc_get_element_type (type
));
3149 elemsz
= fold_convert (gfc_array_index_type
, elemsz
);
3150 OMP_CLAUSE_SIZE (node
)
3151 = fold_build2 (MULT_EXPR
, gfc_array_index_type
,
3152 OMP_CLAUSE_SIZE (node
), elemsz
);
3156 OMP_CLAUSE_DECL (node
) = decl
;
3157 if (gfc_omp_is_allocatable_or_ptr (decl
))
3158 OMP_CLAUSE_SIZE (node
)
3159 = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (decl
)));
3165 gfc_init_se (&se
, NULL
);
3166 if (n
->expr
->ref
->u
.ar
.type
== AR_ELEMENT
)
3168 gfc_conv_expr_reference (&se
, n
->expr
);
3170 gfc_add_block_to_block (block
, &se
.pre
);
3171 OMP_CLAUSE_SIZE (node
)
3172 = TYPE_SIZE_UNIT (TREE_TYPE (ptr
));
3176 gfc_conv_expr_descriptor (&se
, n
->expr
);
3177 ptr
= gfc_conv_array_data (se
.expr
);
3178 tree type
= TREE_TYPE (se
.expr
);
3179 gfc_add_block_to_block (block
, &se
.pre
);
3180 OMP_CLAUSE_SIZE (node
)
3181 = gfc_full_array_size (block
, se
.expr
,
3182 GFC_TYPE_ARRAY_RANK (type
));
3184 = TYPE_SIZE_UNIT (gfc_get_element_type (type
));
3185 elemsz
= fold_convert (gfc_array_index_type
, elemsz
);
3186 OMP_CLAUSE_SIZE (node
)
3187 = fold_build2 (MULT_EXPR
, gfc_array_index_type
,
3188 OMP_CLAUSE_SIZE (node
), elemsz
);
3190 gfc_add_block_to_block (block
, &se
.post
);
3191 ptr
= fold_convert (build_pointer_type (char_type_node
),
3193 OMP_CLAUSE_DECL (node
) = build_fold_indirect_ref (ptr
);
3195 omp_clauses
= gfc_trans_add_clause (node
, omp_clauses
);
3203 if (clauses
->if_expr
)
3207 gfc_init_se (&se
, NULL
);
3208 gfc_conv_expr (&se
, clauses
->if_expr
);
3209 gfc_add_block_to_block (block
, &se
.pre
);
3210 if_var
= gfc_evaluate_now (se
.expr
, block
);
3211 gfc_add_block_to_block (block
, &se
.post
);
3213 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_IF
);
3214 OMP_CLAUSE_IF_MODIFIER (c
) = ERROR_MARK
;
3215 OMP_CLAUSE_IF_EXPR (c
) = if_var
;
3216 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3218 for (ifc
= 0; ifc
< OMP_IF_LAST
; ifc
++)
3219 if (clauses
->if_exprs
[ifc
])
3223 gfc_init_se (&se
, NULL
);
3224 gfc_conv_expr (&se
, clauses
->if_exprs
[ifc
]);
3225 gfc_add_block_to_block (block
, &se
.pre
);
3226 if_var
= gfc_evaluate_now (se
.expr
, block
);
3227 gfc_add_block_to_block (block
, &se
.post
);
3229 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_IF
);
3233 OMP_CLAUSE_IF_MODIFIER (c
) = VOID_CST
;
3235 case OMP_IF_PARALLEL
:
3236 OMP_CLAUSE_IF_MODIFIER (c
) = OMP_PARALLEL
;
3239 OMP_CLAUSE_IF_MODIFIER (c
) = OMP_SIMD
;
3242 OMP_CLAUSE_IF_MODIFIER (c
) = OMP_TASK
;
3244 case OMP_IF_TASKLOOP
:
3245 OMP_CLAUSE_IF_MODIFIER (c
) = OMP_TASKLOOP
;
3248 OMP_CLAUSE_IF_MODIFIER (c
) = OMP_TARGET
;
3250 case OMP_IF_TARGET_DATA
:
3251 OMP_CLAUSE_IF_MODIFIER (c
) = OMP_TARGET_DATA
;
3253 case OMP_IF_TARGET_UPDATE
:
3254 OMP_CLAUSE_IF_MODIFIER (c
) = OMP_TARGET_UPDATE
;
3256 case OMP_IF_TARGET_ENTER_DATA
:
3257 OMP_CLAUSE_IF_MODIFIER (c
) = OMP_TARGET_ENTER_DATA
;
3259 case OMP_IF_TARGET_EXIT_DATA
:
3260 OMP_CLAUSE_IF_MODIFIER (c
) = OMP_TARGET_EXIT_DATA
;
3265 OMP_CLAUSE_IF_EXPR (c
) = if_var
;
3266 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3269 if (clauses
->final_expr
)
3273 gfc_init_se (&se
, NULL
);
3274 gfc_conv_expr (&se
, clauses
->final_expr
);
3275 gfc_add_block_to_block (block
, &se
.pre
);
3276 final_var
= gfc_evaluate_now (se
.expr
, block
);
3277 gfc_add_block_to_block (block
, &se
.post
);
3279 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_FINAL
);
3280 OMP_CLAUSE_FINAL_EXPR (c
) = final_var
;
3281 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3284 if (clauses
->num_threads
)
3288 gfc_init_se (&se
, NULL
);
3289 gfc_conv_expr (&se
, clauses
->num_threads
);
3290 gfc_add_block_to_block (block
, &se
.pre
);
3291 num_threads
= gfc_evaluate_now (se
.expr
, block
);
3292 gfc_add_block_to_block (block
, &se
.post
);
3294 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_NUM_THREADS
);
3295 OMP_CLAUSE_NUM_THREADS_EXPR (c
) = num_threads
;
3296 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3299 chunk_size
= NULL_TREE
;
3300 if (clauses
->chunk_size
)
3302 gfc_init_se (&se
, NULL
);
3303 gfc_conv_expr (&se
, clauses
->chunk_size
);
3304 gfc_add_block_to_block (block
, &se
.pre
);
3305 chunk_size
= gfc_evaluate_now (se
.expr
, block
);
3306 gfc_add_block_to_block (block
, &se
.post
);
3309 if (clauses
->sched_kind
!= OMP_SCHED_NONE
)
3311 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_SCHEDULE
);
3312 OMP_CLAUSE_SCHEDULE_CHUNK_EXPR (c
) = chunk_size
;
3313 switch (clauses
->sched_kind
)
3315 case OMP_SCHED_STATIC
:
3316 OMP_CLAUSE_SCHEDULE_KIND (c
) = OMP_CLAUSE_SCHEDULE_STATIC
;
3318 case OMP_SCHED_DYNAMIC
:
3319 OMP_CLAUSE_SCHEDULE_KIND (c
) = OMP_CLAUSE_SCHEDULE_DYNAMIC
;
3321 case OMP_SCHED_GUIDED
:
3322 OMP_CLAUSE_SCHEDULE_KIND (c
) = OMP_CLAUSE_SCHEDULE_GUIDED
;
3324 case OMP_SCHED_RUNTIME
:
3325 OMP_CLAUSE_SCHEDULE_KIND (c
) = OMP_CLAUSE_SCHEDULE_RUNTIME
;
3327 case OMP_SCHED_AUTO
:
3328 OMP_CLAUSE_SCHEDULE_KIND (c
) = OMP_CLAUSE_SCHEDULE_AUTO
;
3333 if (clauses
->sched_monotonic
)
3334 OMP_CLAUSE_SCHEDULE_KIND (c
)
3335 = (omp_clause_schedule_kind
) (OMP_CLAUSE_SCHEDULE_KIND (c
)
3336 | OMP_CLAUSE_SCHEDULE_MONOTONIC
);
3337 else if (clauses
->sched_nonmonotonic
)
3338 OMP_CLAUSE_SCHEDULE_KIND (c
)
3339 = (omp_clause_schedule_kind
) (OMP_CLAUSE_SCHEDULE_KIND (c
)
3340 | OMP_CLAUSE_SCHEDULE_NONMONOTONIC
);
3341 if (clauses
->sched_simd
)
3342 OMP_CLAUSE_SCHEDULE_SIMD (c
) = 1;
3343 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3346 if (clauses
->default_sharing
!= OMP_DEFAULT_UNKNOWN
)
3348 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_DEFAULT
);
3349 switch (clauses
->default_sharing
)
3351 case OMP_DEFAULT_NONE
:
3352 OMP_CLAUSE_DEFAULT_KIND (c
) = OMP_CLAUSE_DEFAULT_NONE
;
3354 case OMP_DEFAULT_SHARED
:
3355 OMP_CLAUSE_DEFAULT_KIND (c
) = OMP_CLAUSE_DEFAULT_SHARED
;
3357 case OMP_DEFAULT_PRIVATE
:
3358 OMP_CLAUSE_DEFAULT_KIND (c
) = OMP_CLAUSE_DEFAULT_PRIVATE
;
3360 case OMP_DEFAULT_FIRSTPRIVATE
:
3361 OMP_CLAUSE_DEFAULT_KIND (c
) = OMP_CLAUSE_DEFAULT_FIRSTPRIVATE
;
3363 case OMP_DEFAULT_PRESENT
:
3364 OMP_CLAUSE_DEFAULT_KIND (c
) = OMP_CLAUSE_DEFAULT_PRESENT
;
3369 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3372 if (clauses
->nowait
)
3374 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_NOWAIT
);
3375 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3378 if (clauses
->ordered
)
3380 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_ORDERED
);
3381 OMP_CLAUSE_ORDERED_EXPR (c
)
3382 = clauses
->orderedc
? build_int_cst (integer_type_node
,
3383 clauses
->orderedc
) : NULL_TREE
;
3384 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3387 if (clauses
->order_concurrent
)
3389 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_ORDER
);
3390 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3393 if (clauses
->untied
)
3395 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_UNTIED
);
3396 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3399 if (clauses
->mergeable
)
3401 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_MERGEABLE
);
3402 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3405 if (clauses
->collapse
)
3407 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_COLLAPSE
);
3408 OMP_CLAUSE_COLLAPSE_EXPR (c
)
3409 = build_int_cst (integer_type_node
, clauses
->collapse
);
3410 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3413 if (clauses
->inbranch
)
3415 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_INBRANCH
);
3416 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3419 if (clauses
->notinbranch
)
3421 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_NOTINBRANCH
);
3422 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3425 switch (clauses
->cancel
)
3427 case OMP_CANCEL_UNKNOWN
:
3429 case OMP_CANCEL_PARALLEL
:
3430 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_PARALLEL
);
3431 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3433 case OMP_CANCEL_SECTIONS
:
3434 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_SECTIONS
);
3435 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3438 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_FOR
);
3439 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3441 case OMP_CANCEL_TASKGROUP
:
3442 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_TASKGROUP
);
3443 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3447 if (clauses
->proc_bind
!= OMP_PROC_BIND_UNKNOWN
)
3449 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_PROC_BIND
);
3450 switch (clauses
->proc_bind
)
3452 case OMP_PROC_BIND_MASTER
:
3453 OMP_CLAUSE_PROC_BIND_KIND (c
) = OMP_CLAUSE_PROC_BIND_MASTER
;
3455 case OMP_PROC_BIND_SPREAD
:
3456 OMP_CLAUSE_PROC_BIND_KIND (c
) = OMP_CLAUSE_PROC_BIND_SPREAD
;
3458 case OMP_PROC_BIND_CLOSE
:
3459 OMP_CLAUSE_PROC_BIND_KIND (c
) = OMP_CLAUSE_PROC_BIND_CLOSE
;
3464 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3467 if (clauses
->safelen_expr
)
3471 gfc_init_se (&se
, NULL
);
3472 gfc_conv_expr (&se
, clauses
->safelen_expr
);
3473 gfc_add_block_to_block (block
, &se
.pre
);
3474 safelen_var
= gfc_evaluate_now (se
.expr
, block
);
3475 gfc_add_block_to_block (block
, &se
.post
);
3477 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_SAFELEN
);
3478 OMP_CLAUSE_SAFELEN_EXPR (c
) = safelen_var
;
3479 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3482 if (clauses
->simdlen_expr
)
3486 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_SIMDLEN
);
3487 OMP_CLAUSE_SIMDLEN_EXPR (c
)
3488 = gfc_conv_constant_to_tree (clauses
->simdlen_expr
);
3489 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3495 gfc_init_se (&se
, NULL
);
3496 gfc_conv_expr (&se
, clauses
->simdlen_expr
);
3497 gfc_add_block_to_block (block
, &se
.pre
);
3498 simdlen_var
= gfc_evaluate_now (se
.expr
, block
);
3499 gfc_add_block_to_block (block
, &se
.post
);
3501 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_SIMDLEN
);
3502 OMP_CLAUSE_SIMDLEN_EXPR (c
) = simdlen_var
;
3503 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3507 if (clauses
->num_teams
)
3511 gfc_init_se (&se
, NULL
);
3512 gfc_conv_expr (&se
, clauses
->num_teams
);
3513 gfc_add_block_to_block (block
, &se
.pre
);
3514 num_teams
= gfc_evaluate_now (se
.expr
, block
);
3515 gfc_add_block_to_block (block
, &se
.post
);
3517 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_NUM_TEAMS
);
3518 OMP_CLAUSE_NUM_TEAMS_EXPR (c
) = num_teams
;
3519 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3522 if (clauses
->device
)
3526 gfc_init_se (&se
, NULL
);
3527 gfc_conv_expr (&se
, clauses
->device
);
3528 gfc_add_block_to_block (block
, &se
.pre
);
3529 device
= gfc_evaluate_now (se
.expr
, block
);
3530 gfc_add_block_to_block (block
, &se
.post
);
3532 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_DEVICE
);
3533 OMP_CLAUSE_DEVICE_ID (c
) = device
;
3534 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3537 if (clauses
->thread_limit
)
3541 gfc_init_se (&se
, NULL
);
3542 gfc_conv_expr (&se
, clauses
->thread_limit
);
3543 gfc_add_block_to_block (block
, &se
.pre
);
3544 thread_limit
= gfc_evaluate_now (se
.expr
, block
);
3545 gfc_add_block_to_block (block
, &se
.post
);
3547 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_THREAD_LIMIT
);
3548 OMP_CLAUSE_THREAD_LIMIT_EXPR (c
) = thread_limit
;
3549 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3552 chunk_size
= NULL_TREE
;
3553 if (clauses
->dist_chunk_size
)
3555 gfc_init_se (&se
, NULL
);
3556 gfc_conv_expr (&se
, clauses
->dist_chunk_size
);
3557 gfc_add_block_to_block (block
, &se
.pre
);
3558 chunk_size
= gfc_evaluate_now (se
.expr
, block
);
3559 gfc_add_block_to_block (block
, &se
.post
);
3562 if (clauses
->dist_sched_kind
!= OMP_SCHED_NONE
)
3564 c
= build_omp_clause (gfc_get_location (&where
),
3565 OMP_CLAUSE_DIST_SCHEDULE
);
3566 OMP_CLAUSE_DIST_SCHEDULE_CHUNK_EXPR (c
) = chunk_size
;
3567 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3570 if (clauses
->grainsize
)
3574 gfc_init_se (&se
, NULL
);
3575 gfc_conv_expr (&se
, clauses
->grainsize
);
3576 gfc_add_block_to_block (block
, &se
.pre
);
3577 grainsize
= gfc_evaluate_now (se
.expr
, block
);
3578 gfc_add_block_to_block (block
, &se
.post
);
3580 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_GRAINSIZE
);
3581 OMP_CLAUSE_GRAINSIZE_EXPR (c
) = grainsize
;
3582 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3585 if (clauses
->num_tasks
)
3589 gfc_init_se (&se
, NULL
);
3590 gfc_conv_expr (&se
, clauses
->num_tasks
);
3591 gfc_add_block_to_block (block
, &se
.pre
);
3592 num_tasks
= gfc_evaluate_now (se
.expr
, block
);
3593 gfc_add_block_to_block (block
, &se
.post
);
3595 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_NUM_TASKS
);
3596 OMP_CLAUSE_NUM_TASKS_EXPR (c
) = num_tasks
;
3597 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3600 if (clauses
->priority
)
3604 gfc_init_se (&se
, NULL
);
3605 gfc_conv_expr (&se
, clauses
->priority
);
3606 gfc_add_block_to_block (block
, &se
.pre
);
3607 priority
= gfc_evaluate_now (se
.expr
, block
);
3608 gfc_add_block_to_block (block
, &se
.post
);
3610 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_PRIORITY
);
3611 OMP_CLAUSE_PRIORITY_EXPR (c
) = priority
;
3612 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3619 gfc_init_se (&se
, NULL
);
3620 gfc_conv_expr (&se
, clauses
->hint
);
3621 gfc_add_block_to_block (block
, &se
.pre
);
3622 hint
= gfc_evaluate_now (se
.expr
, block
);
3623 gfc_add_block_to_block (block
, &se
.post
);
3625 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_HINT
);
3626 OMP_CLAUSE_HINT_EXPR (c
) = hint
;
3627 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3632 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_SIMD
);
3633 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3635 if (clauses
->threads
)
3637 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_THREADS
);
3638 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3640 if (clauses
->nogroup
)
3642 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_NOGROUP
);
3643 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3645 if (clauses
->defaultmap
)
3647 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_DEFAULTMAP
);
3648 OMP_CLAUSE_DEFAULTMAP_SET_KIND (c
, OMP_CLAUSE_DEFAULTMAP_TOFROM
,
3649 OMP_CLAUSE_DEFAULTMAP_CATEGORY_SCALAR
);
3650 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3652 if (clauses
->depend_source
)
3654 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_DEPEND
);
3655 OMP_CLAUSE_DEPEND_KIND (c
) = OMP_CLAUSE_DEPEND_SOURCE
;
3656 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3661 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_ASYNC
);
3662 if (clauses
->async_expr
)
3663 OMP_CLAUSE_ASYNC_EXPR (c
)
3664 = gfc_convert_expr_to_tree (block
, clauses
->async_expr
);
3666 OMP_CLAUSE_ASYNC_EXPR (c
) = NULL
;
3667 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3671 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_SEQ
);
3672 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3674 if (clauses
->par_auto
)
3676 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_AUTO
);
3677 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3679 if (clauses
->if_present
)
3681 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_IF_PRESENT
);
3682 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3684 if (clauses
->finalize
)
3686 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_FINALIZE
);
3687 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3689 if (clauses
->independent
)
3691 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_INDEPENDENT
);
3692 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3694 if (clauses
->wait_list
)
3698 for (el
= clauses
->wait_list
; el
; el
= el
->next
)
3700 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_WAIT
);
3701 OMP_CLAUSE_DECL (c
) = gfc_convert_expr_to_tree (block
, el
->expr
);
3702 OMP_CLAUSE_CHAIN (c
) = omp_clauses
;
3706 if (clauses
->num_gangs_expr
)
3709 = gfc_convert_expr_to_tree (block
, clauses
->num_gangs_expr
);
3710 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_NUM_GANGS
);
3711 OMP_CLAUSE_NUM_GANGS_EXPR (c
) = num_gangs_var
;
3712 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3714 if (clauses
->num_workers_expr
)
3716 tree num_workers_var
3717 = gfc_convert_expr_to_tree (block
, clauses
->num_workers_expr
);
3718 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_NUM_WORKERS
);
3719 OMP_CLAUSE_NUM_WORKERS_EXPR (c
) = num_workers_var
;
3720 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3722 if (clauses
->vector_length_expr
)
3724 tree vector_length_var
3725 = gfc_convert_expr_to_tree (block
, clauses
->vector_length_expr
);
3726 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_VECTOR_LENGTH
);
3727 OMP_CLAUSE_VECTOR_LENGTH_EXPR (c
) = vector_length_var
;
3728 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3730 if (clauses
->tile_list
)
3732 vec
<tree
, va_gc
> *tvec
;
3735 vec_alloc (tvec
, 4);
3737 for (el
= clauses
->tile_list
; el
; el
= el
->next
)
3738 vec_safe_push (tvec
, gfc_convert_expr_to_tree (block
, el
->expr
));
3740 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_TILE
);
3741 OMP_CLAUSE_TILE_LIST (c
) = build_tree_list_vec (tvec
);
3742 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3745 if (clauses
->vector
)
3747 if (clauses
->vector_expr
)
3750 = gfc_convert_expr_to_tree (block
, clauses
->vector_expr
);
3751 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_VECTOR
);
3752 OMP_CLAUSE_VECTOR_EXPR (c
) = vector_var
;
3753 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3757 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_VECTOR
);
3758 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3761 if (clauses
->worker
)
3763 if (clauses
->worker_expr
)
3766 = gfc_convert_expr_to_tree (block
, clauses
->worker_expr
);
3767 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_WORKER
);
3768 OMP_CLAUSE_WORKER_EXPR (c
) = worker_var
;
3769 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3773 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_WORKER
);
3774 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3780 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_GANG
);
3781 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3782 if (clauses
->gang_num_expr
)
3784 arg
= gfc_convert_expr_to_tree (block
, clauses
->gang_num_expr
);
3785 OMP_CLAUSE_GANG_EXPR (c
) = arg
;
3787 if (clauses
->gang_static
)
3789 arg
= clauses
->gang_static_expr
3790 ? gfc_convert_expr_to_tree (block
, clauses
->gang_static_expr
)
3791 : integer_minus_one_node
;
3792 OMP_CLAUSE_GANG_STATIC_EXPR (c
) = arg
;
3796 return nreverse (omp_clauses
);
3799 /* Like gfc_trans_code, but force creation of a BIND_EXPR around it. */
3802 gfc_trans_omp_code (gfc_code
*code
, bool force_empty
)
3807 stmt
= gfc_trans_code (code
);
3808 if (TREE_CODE (stmt
) != BIND_EXPR
)
3810 if (!IS_EMPTY_STMT (stmt
) || force_empty
)
3812 tree block
= poplevel (1, 0);
3813 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, block
);
3823 /* Translate OpenACC 'parallel', 'kernels', 'serial', 'data', 'host_data'
3827 gfc_trans_oacc_construct (gfc_code
*code
)
3830 tree stmt
, oacc_clauses
;
3831 enum tree_code construct_code
;
3835 case EXEC_OACC_PARALLEL
:
3836 construct_code
= OACC_PARALLEL
;
3838 case EXEC_OACC_KERNELS
:
3839 construct_code
= OACC_KERNELS
;
3841 case EXEC_OACC_SERIAL
:
3842 construct_code
= OACC_SERIAL
;
3844 case EXEC_OACC_DATA
:
3845 construct_code
= OACC_DATA
;
3847 case EXEC_OACC_HOST_DATA
:
3848 construct_code
= OACC_HOST_DATA
;
3854 gfc_start_block (&block
);
3855 oacc_clauses
= gfc_trans_omp_clauses (&block
, code
->ext
.omp_clauses
,
3856 code
->loc
, false, true);
3857 stmt
= gfc_trans_omp_code (code
->block
->next
, true);
3858 stmt
= build2_loc (input_location
, construct_code
, void_type_node
, stmt
,
3860 gfc_add_expr_to_block (&block
, stmt
);
3861 return gfc_finish_block (&block
);
3864 /* update, enter_data, exit_data, cache. */
3866 gfc_trans_oacc_executable_directive (gfc_code
*code
)
3869 tree stmt
, oacc_clauses
;
3870 enum tree_code construct_code
;
3874 case EXEC_OACC_UPDATE
:
3875 construct_code
= OACC_UPDATE
;
3877 case EXEC_OACC_ENTER_DATA
:
3878 construct_code
= OACC_ENTER_DATA
;
3880 case EXEC_OACC_EXIT_DATA
:
3881 construct_code
= OACC_EXIT_DATA
;
3883 case EXEC_OACC_CACHE
:
3884 construct_code
= OACC_CACHE
;
3890 gfc_start_block (&block
);
3891 oacc_clauses
= gfc_trans_omp_clauses (&block
, code
->ext
.omp_clauses
,
3892 code
->loc
, false, true);
3893 stmt
= build1_loc (input_location
, construct_code
, void_type_node
,
3895 gfc_add_expr_to_block (&block
, stmt
);
3896 return gfc_finish_block (&block
);
3900 gfc_trans_oacc_wait_directive (gfc_code
*code
)
3904 vec
<tree
, va_gc
> *args
;
3907 gfc_omp_clauses
*clauses
= code
->ext
.omp_clauses
;
3908 location_t loc
= input_location
;
3910 for (el
= clauses
->wait_list
; el
; el
= el
->next
)
3913 vec_alloc (args
, nparms
+ 2);
3914 stmt
= builtin_decl_explicit (BUILT_IN_GOACC_WAIT
);
3916 gfc_start_block (&block
);
3918 if (clauses
->async_expr
)
3919 t
= gfc_convert_expr_to_tree (&block
, clauses
->async_expr
);
3921 t
= build_int_cst (integer_type_node
, -2);
3923 args
->quick_push (t
);
3924 args
->quick_push (build_int_cst (integer_type_node
, nparms
));
3926 for (el
= clauses
->wait_list
; el
; el
= el
->next
)
3927 args
->quick_push (gfc_convert_expr_to_tree (&block
, el
->expr
));
3929 stmt
= build_call_expr_loc_vec (loc
, stmt
, args
);
3930 gfc_add_expr_to_block (&block
, stmt
);
3934 return gfc_finish_block (&block
);
3937 static tree
gfc_trans_omp_sections (gfc_code
*, gfc_omp_clauses
*);
3938 static tree
gfc_trans_omp_workshare (gfc_code
*, gfc_omp_clauses
*);
3941 gfc_trans_omp_atomic (gfc_code
*code
)
3943 gfc_code
*atomic_code
= code
;
3947 gfc_expr
*expr2
, *e
;
3950 tree lhsaddr
, type
, rhs
, x
;
3951 enum tree_code op
= ERROR_MARK
;
3952 enum tree_code aop
= OMP_ATOMIC
;
3953 bool var_on_left
= false;
3954 enum omp_memory_order mo
;
3955 if (atomic_code
->ext
.omp_atomic
& GFC_OMP_ATOMIC_SEQ_CST
)
3956 mo
= OMP_MEMORY_ORDER_SEQ_CST
;
3957 else if (atomic_code
->ext
.omp_atomic
& GFC_OMP_ATOMIC_ACQ_REL
)
3958 mo
= OMP_MEMORY_ORDER_ACQ_REL
;
3960 mo
= OMP_MEMORY_ORDER_RELAXED
;
3962 code
= code
->block
->next
;
3963 gcc_assert (code
->op
== EXEC_ASSIGN
);
3964 var
= code
->expr1
->symtree
->n
.sym
;
3966 gfc_init_se (&lse
, NULL
);
3967 gfc_init_se (&rse
, NULL
);
3968 gfc_init_se (&vse
, NULL
);
3969 gfc_start_block (&block
);
3971 expr2
= code
->expr2
;
3972 if (((atomic_code
->ext
.omp_atomic
& GFC_OMP_ATOMIC_MASK
)
3973 != GFC_OMP_ATOMIC_WRITE
)
3974 && expr2
->expr_type
== EXPR_FUNCTION
3975 && expr2
->value
.function
.isym
3976 && expr2
->value
.function
.isym
->id
== GFC_ISYM_CONVERSION
)
3977 expr2
= expr2
->value
.function
.actual
->expr
;
3979 switch (atomic_code
->ext
.omp_atomic
& GFC_OMP_ATOMIC_MASK
)
3981 case GFC_OMP_ATOMIC_READ
:
3982 gfc_conv_expr (&vse
, code
->expr1
);
3983 gfc_add_block_to_block (&block
, &vse
.pre
);
3985 gfc_conv_expr (&lse
, expr2
);
3986 gfc_add_block_to_block (&block
, &lse
.pre
);
3987 type
= TREE_TYPE (lse
.expr
);
3988 lhsaddr
= gfc_build_addr_expr (NULL
, lse
.expr
);
3990 x
= build1 (OMP_ATOMIC_READ
, type
, lhsaddr
);
3991 OMP_ATOMIC_MEMORY_ORDER (x
) = mo
;
3992 x
= convert (TREE_TYPE (vse
.expr
), x
);
3993 gfc_add_modify (&block
, vse
.expr
, x
);
3995 gfc_add_block_to_block (&block
, &lse
.pre
);
3996 gfc_add_block_to_block (&block
, &rse
.pre
);
3998 return gfc_finish_block (&block
);
3999 case GFC_OMP_ATOMIC_CAPTURE
:
4000 aop
= OMP_ATOMIC_CAPTURE_NEW
;
4001 if (expr2
->expr_type
== EXPR_VARIABLE
)
4003 aop
= OMP_ATOMIC_CAPTURE_OLD
;
4004 gfc_conv_expr (&vse
, code
->expr1
);
4005 gfc_add_block_to_block (&block
, &vse
.pre
);
4007 gfc_conv_expr (&lse
, expr2
);
4008 gfc_add_block_to_block (&block
, &lse
.pre
);
4009 gfc_init_se (&lse
, NULL
);
4011 var
= code
->expr1
->symtree
->n
.sym
;
4012 expr2
= code
->expr2
;
4013 if (expr2
->expr_type
== EXPR_FUNCTION
4014 && expr2
->value
.function
.isym
4015 && expr2
->value
.function
.isym
->id
== GFC_ISYM_CONVERSION
)
4016 expr2
= expr2
->value
.function
.actual
->expr
;
4023 gfc_conv_expr (&lse
, code
->expr1
);
4024 gfc_add_block_to_block (&block
, &lse
.pre
);
4025 type
= TREE_TYPE (lse
.expr
);
4026 lhsaddr
= gfc_build_addr_expr (NULL
, lse
.expr
);
4028 if (((atomic_code
->ext
.omp_atomic
& GFC_OMP_ATOMIC_MASK
)
4029 == GFC_OMP_ATOMIC_WRITE
)
4030 || (atomic_code
->ext
.omp_atomic
& GFC_OMP_ATOMIC_SWAP
))
4032 gfc_conv_expr (&rse
, expr2
);
4033 gfc_add_block_to_block (&block
, &rse
.pre
);
4035 else if (expr2
->expr_type
== EXPR_OP
)
4038 switch (expr2
->value
.op
.op
)
4040 case INTRINSIC_PLUS
:
4043 case INTRINSIC_TIMES
:
4046 case INTRINSIC_MINUS
:
4049 case INTRINSIC_DIVIDE
:
4050 if (expr2
->ts
.type
== BT_INTEGER
)
4051 op
= TRUNC_DIV_EXPR
;
4056 op
= TRUTH_ANDIF_EXPR
;
4059 op
= TRUTH_ORIF_EXPR
;
4064 case INTRINSIC_NEQV
:
4070 e
= expr2
->value
.op
.op1
;
4071 if (e
->expr_type
== EXPR_FUNCTION
4072 && e
->value
.function
.isym
4073 && e
->value
.function
.isym
->id
== GFC_ISYM_CONVERSION
)
4074 e
= e
->value
.function
.actual
->expr
;
4075 if (e
->expr_type
== EXPR_VARIABLE
4076 && e
->symtree
!= NULL
4077 && e
->symtree
->n
.sym
== var
)
4079 expr2
= expr2
->value
.op
.op2
;
4084 e
= expr2
->value
.op
.op2
;
4085 if (e
->expr_type
== EXPR_FUNCTION
4086 && e
->value
.function
.isym
4087 && e
->value
.function
.isym
->id
== GFC_ISYM_CONVERSION
)
4088 e
= e
->value
.function
.actual
->expr
;
4089 gcc_assert (e
->expr_type
== EXPR_VARIABLE
4090 && e
->symtree
!= NULL
4091 && e
->symtree
->n
.sym
== var
);
4092 expr2
= expr2
->value
.op
.op1
;
4093 var_on_left
= false;
4095 gfc_conv_expr (&rse
, expr2
);
4096 gfc_add_block_to_block (&block
, &rse
.pre
);
4100 gcc_assert (expr2
->expr_type
== EXPR_FUNCTION
);
4101 switch (expr2
->value
.function
.isym
->id
)
4121 e
= expr2
->value
.function
.actual
->expr
;
4122 gcc_assert (e
->expr_type
== EXPR_VARIABLE
4123 && e
->symtree
!= NULL
4124 && e
->symtree
->n
.sym
== var
);
4126 gfc_conv_expr (&rse
, expr2
->value
.function
.actual
->next
->expr
);
4127 gfc_add_block_to_block (&block
, &rse
.pre
);
4128 if (expr2
->value
.function
.actual
->next
->next
!= NULL
)
4130 tree accum
= gfc_create_var (TREE_TYPE (rse
.expr
), NULL
);
4131 gfc_actual_arglist
*arg
;
4133 gfc_add_modify (&block
, accum
, rse
.expr
);
4134 for (arg
= expr2
->value
.function
.actual
->next
->next
; arg
;
4137 gfc_init_block (&rse
.pre
);
4138 gfc_conv_expr (&rse
, arg
->expr
);
4139 gfc_add_block_to_block (&block
, &rse
.pre
);
4140 x
= fold_build2_loc (input_location
, op
, TREE_TYPE (accum
),
4142 gfc_add_modify (&block
, accum
, x
);
4148 expr2
= expr2
->value
.function
.actual
->next
->expr
;
4151 lhsaddr
= save_expr (lhsaddr
);
4152 if (TREE_CODE (lhsaddr
) != SAVE_EXPR
4153 && (TREE_CODE (lhsaddr
) != ADDR_EXPR
4154 || !VAR_P (TREE_OPERAND (lhsaddr
, 0))))
4156 /* Make sure LHS is simple enough so that goa_lhs_expr_p can recognize
4157 it even after unsharing function body. */
4158 tree var
= create_tmp_var_raw (TREE_TYPE (lhsaddr
));
4159 DECL_CONTEXT (var
) = current_function_decl
;
4160 lhsaddr
= build4 (TARGET_EXPR
, TREE_TYPE (lhsaddr
), var
, lhsaddr
,
4161 NULL_TREE
, NULL_TREE
);
4164 rhs
= gfc_evaluate_now (rse
.expr
, &block
);
4166 if (((atomic_code
->ext
.omp_atomic
& GFC_OMP_ATOMIC_MASK
)
4167 == GFC_OMP_ATOMIC_WRITE
)
4168 || (atomic_code
->ext
.omp_atomic
& GFC_OMP_ATOMIC_SWAP
))
4172 x
= convert (TREE_TYPE (rhs
),
4173 build_fold_indirect_ref_loc (input_location
, lhsaddr
));
4175 x
= fold_build2_loc (input_location
, op
, TREE_TYPE (rhs
), x
, rhs
);
4177 x
= fold_build2_loc (input_location
, op
, TREE_TYPE (rhs
), rhs
, x
);
4180 if (TREE_CODE (TREE_TYPE (rhs
)) == COMPLEX_TYPE
4181 && TREE_CODE (type
) != COMPLEX_TYPE
)
4182 x
= fold_build1_loc (input_location
, REALPART_EXPR
,
4183 TREE_TYPE (TREE_TYPE (rhs
)), x
);
4185 gfc_add_block_to_block (&block
, &lse
.pre
);
4186 gfc_add_block_to_block (&block
, &rse
.pre
);
4188 if (aop
== OMP_ATOMIC
)
4190 x
= build2_v (OMP_ATOMIC
, lhsaddr
, convert (type
, x
));
4191 OMP_ATOMIC_MEMORY_ORDER (x
) = mo
;
4192 gfc_add_expr_to_block (&block
, x
);
4196 if (aop
== OMP_ATOMIC_CAPTURE_NEW
)
4199 expr2
= code
->expr2
;
4200 if (expr2
->expr_type
== EXPR_FUNCTION
4201 && expr2
->value
.function
.isym
4202 && expr2
->value
.function
.isym
->id
== GFC_ISYM_CONVERSION
)
4203 expr2
= expr2
->value
.function
.actual
->expr
;
4205 gcc_assert (expr2
->expr_type
== EXPR_VARIABLE
);
4206 gfc_conv_expr (&vse
, code
->expr1
);
4207 gfc_add_block_to_block (&block
, &vse
.pre
);
4209 gfc_init_se (&lse
, NULL
);
4210 gfc_conv_expr (&lse
, expr2
);
4211 gfc_add_block_to_block (&block
, &lse
.pre
);
4213 x
= build2 (aop
, type
, lhsaddr
, convert (type
, x
));
4214 OMP_ATOMIC_MEMORY_ORDER (x
) = mo
;
4215 x
= convert (TREE_TYPE (vse
.expr
), x
);
4216 gfc_add_modify (&block
, vse
.expr
, x
);
4219 return gfc_finish_block (&block
);
4223 gfc_trans_omp_barrier (void)
4225 tree decl
= builtin_decl_explicit (BUILT_IN_GOMP_BARRIER
);
4226 return build_call_expr_loc (input_location
, decl
, 0);
4230 gfc_trans_omp_cancel (gfc_code
*code
)
4233 tree ifc
= boolean_true_node
;
4235 switch (code
->ext
.omp_clauses
->cancel
)
4237 case OMP_CANCEL_PARALLEL
: mask
= 1; break;
4238 case OMP_CANCEL_DO
: mask
= 2; break;
4239 case OMP_CANCEL_SECTIONS
: mask
= 4; break;
4240 case OMP_CANCEL_TASKGROUP
: mask
= 8; break;
4241 default: gcc_unreachable ();
4243 gfc_start_block (&block
);
4244 if (code
->ext
.omp_clauses
->if_expr
4245 || code
->ext
.omp_clauses
->if_exprs
[OMP_IF_CANCEL
])
4250 gcc_assert ((code
->ext
.omp_clauses
->if_expr
== NULL
)
4251 ^ (code
->ext
.omp_clauses
->if_exprs
[OMP_IF_CANCEL
] == NULL
));
4252 gfc_init_se (&se
, NULL
);
4253 gfc_conv_expr (&se
, code
->ext
.omp_clauses
->if_expr
!= NULL
4254 ? code
->ext
.omp_clauses
->if_expr
4255 : code
->ext
.omp_clauses
->if_exprs
[OMP_IF_CANCEL
]);
4256 gfc_add_block_to_block (&block
, &se
.pre
);
4257 if_var
= gfc_evaluate_now (se
.expr
, &block
);
4258 gfc_add_block_to_block (&block
, &se
.post
);
4259 tree type
= TREE_TYPE (if_var
);
4260 ifc
= fold_build2_loc (input_location
, NE_EXPR
,
4261 boolean_type_node
, if_var
,
4262 build_zero_cst (type
));
4264 tree decl
= builtin_decl_explicit (BUILT_IN_GOMP_CANCEL
);
4265 tree c_bool_type
= TREE_TYPE (TREE_TYPE (decl
));
4266 ifc
= fold_convert (c_bool_type
, ifc
);
4267 gfc_add_expr_to_block (&block
,
4268 build_call_expr_loc (input_location
, decl
, 2,
4269 build_int_cst (integer_type_node
,
4271 return gfc_finish_block (&block
);
4275 gfc_trans_omp_cancellation_point (gfc_code
*code
)
4278 switch (code
->ext
.omp_clauses
->cancel
)
4280 case OMP_CANCEL_PARALLEL
: mask
= 1; break;
4281 case OMP_CANCEL_DO
: mask
= 2; break;
4282 case OMP_CANCEL_SECTIONS
: mask
= 4; break;
4283 case OMP_CANCEL_TASKGROUP
: mask
= 8; break;
4284 default: gcc_unreachable ();
4286 tree decl
= builtin_decl_explicit (BUILT_IN_GOMP_CANCELLATION_POINT
);
4287 return build_call_expr_loc (input_location
, decl
, 1,
4288 build_int_cst (integer_type_node
, mask
));
4292 gfc_trans_omp_critical (gfc_code
*code
)
4295 tree stmt
, name
= NULL_TREE
;
4296 if (code
->ext
.omp_clauses
->critical_name
!= NULL
)
4297 name
= get_identifier (code
->ext
.omp_clauses
->critical_name
);
4298 gfc_start_block (&block
);
4299 stmt
= make_node (OMP_CRITICAL
);
4300 TREE_TYPE (stmt
) = void_type_node
;
4301 OMP_CRITICAL_BODY (stmt
) = gfc_trans_code (code
->block
->next
);
4302 OMP_CRITICAL_NAME (stmt
) = name
;
4303 OMP_CRITICAL_CLAUSES (stmt
) = gfc_trans_omp_clauses (&block
,
4304 code
->ext
.omp_clauses
,
4306 gfc_add_expr_to_block (&block
, stmt
);
4307 return gfc_finish_block (&block
);
4310 typedef struct dovar_init_d
{
4317 gfc_trans_omp_do (gfc_code
*code
, gfc_exec_op op
, stmtblock_t
*pblock
,
4318 gfc_omp_clauses
*do_clauses
, tree par_clauses
)
4321 tree dovar
, stmt
, from
, to
, step
, type
, init
, cond
, incr
, orig_decls
;
4322 tree count
= NULL_TREE
, cycle_label
, tmp
, omp_clauses
;
4325 gfc_omp_clauses
*clauses
= code
->ext
.omp_clauses
;
4326 int i
, collapse
= clauses
->collapse
;
4327 vec
<dovar_init
> inits
= vNULL
;
4330 vec
<tree
, va_heap
, vl_embed
> *saved_doacross_steps
= doacross_steps
;
4331 gfc_expr_list
*tile
= do_clauses
? do_clauses
->tile_list
: clauses
->tile_list
;
4333 /* Both collapsed and tiled loops are lowered the same way. In
4334 OpenACC, those clauses are not compatible, so prioritize the tile
4335 clause, if present. */
4339 for (gfc_expr_list
*el
= tile
; el
; el
= el
->next
)
4343 doacross_steps
= NULL
;
4344 if (clauses
->orderedc
)
4345 collapse
= clauses
->orderedc
;
4349 code
= code
->block
->next
;
4350 gcc_assert (code
->op
== EXEC_DO
);
4352 init
= make_tree_vec (collapse
);
4353 cond
= make_tree_vec (collapse
);
4354 incr
= make_tree_vec (collapse
);
4355 orig_decls
= clauses
->orderedc
? make_tree_vec (collapse
) : NULL_TREE
;
4359 gfc_start_block (&block
);
4363 /* simd schedule modifier is only useful for composite do simd and other
4364 constructs including that, where gfc_trans_omp_do is only called
4365 on the simd construct and DO's clauses are translated elsewhere. */
4366 do_clauses
->sched_simd
= false;
4368 omp_clauses
= gfc_trans_omp_clauses (pblock
, do_clauses
, code
->loc
);
4370 for (i
= 0; i
< collapse
; i
++)
4373 int dovar_found
= 0;
4378 gfc_omp_namelist
*n
= NULL
;
4379 if (op
!= EXEC_OMP_DISTRIBUTE
)
4380 for (n
= clauses
->lists
[(op
== EXEC_OMP_SIMD
&& collapse
== 1)
4381 ? OMP_LIST_LINEAR
: OMP_LIST_LASTPRIVATE
];
4382 n
!= NULL
; n
= n
->next
)
4383 if (code
->ext
.iterator
->var
->symtree
->n
.sym
== n
->sym
)
4387 else if (n
== NULL
&& op
!= EXEC_OMP_SIMD
)
4388 for (n
= clauses
->lists
[OMP_LIST_PRIVATE
]; n
!= NULL
; n
= n
->next
)
4389 if (code
->ext
.iterator
->var
->symtree
->n
.sym
== n
->sym
)
4395 /* Evaluate all the expressions in the iterator. */
4396 gfc_init_se (&se
, NULL
);
4397 gfc_conv_expr_lhs (&se
, code
->ext
.iterator
->var
);
4398 gfc_add_block_to_block (pblock
, &se
.pre
);
4400 type
= TREE_TYPE (dovar
);
4401 gcc_assert (TREE_CODE (type
) == INTEGER_TYPE
);
4403 gfc_init_se (&se
, NULL
);
4404 gfc_conv_expr_val (&se
, code
->ext
.iterator
->start
);
4405 gfc_add_block_to_block (pblock
, &se
.pre
);
4406 from
= gfc_evaluate_now (se
.expr
, pblock
);
4408 gfc_init_se (&se
, NULL
);
4409 gfc_conv_expr_val (&se
, code
->ext
.iterator
->end
);
4410 gfc_add_block_to_block (pblock
, &se
.pre
);
4411 to
= gfc_evaluate_now (se
.expr
, pblock
);
4413 gfc_init_se (&se
, NULL
);
4414 gfc_conv_expr_val (&se
, code
->ext
.iterator
->step
);
4415 gfc_add_block_to_block (pblock
, &se
.pre
);
4416 step
= gfc_evaluate_now (se
.expr
, pblock
);
4419 /* Special case simple loops. */
4422 if (integer_onep (step
))
4424 else if (tree_int_cst_equal (step
, integer_minus_one_node
))
4429 = gfc_trans_omp_variable (code
->ext
.iterator
->var
->symtree
->n
.sym
,
4435 TREE_VEC_ELT (init
, i
) = build2_v (MODIFY_EXPR
, dovar
, from
);
4436 /* The condition should not be folded. */
4437 TREE_VEC_ELT (cond
, i
) = build2_loc (input_location
, simple
> 0
4438 ? LE_EXPR
: GE_EXPR
,
4439 logical_type_node
, dovar
, to
);
4440 TREE_VEC_ELT (incr
, i
) = fold_build2_loc (input_location
, PLUS_EXPR
,
4442 TREE_VEC_ELT (incr
, i
) = fold_build2_loc (input_location
,
4445 TREE_VEC_ELT (incr
, i
));
4449 /* STEP is not 1 or -1. Use:
4450 for (count = 0; count < (to + step - from) / step; count++)
4452 dovar = from + count * step;
4456 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, step
, from
);
4457 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, to
, tmp
);
4458 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, type
, tmp
,
4460 tmp
= gfc_evaluate_now (tmp
, pblock
);
4461 count
= gfc_create_var (type
, "count");
4462 TREE_VEC_ELT (init
, i
) = build2_v (MODIFY_EXPR
, count
,
4463 build_int_cst (type
, 0));
4464 /* The condition should not be folded. */
4465 TREE_VEC_ELT (cond
, i
) = build2_loc (input_location
, LT_EXPR
,
4468 TREE_VEC_ELT (incr
, i
) = fold_build2_loc (input_location
, PLUS_EXPR
,
4470 build_int_cst (type
, 1));
4471 TREE_VEC_ELT (incr
, i
) = fold_build2_loc (input_location
,
4472 MODIFY_EXPR
, type
, count
,
4473 TREE_VEC_ELT (incr
, i
));
4475 /* Initialize DOVAR. */
4476 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, type
, count
, step
);
4477 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, from
, tmp
);
4478 dovar_init e
= {dovar
, tmp
};
4479 inits
.safe_push (e
);
4480 if (clauses
->orderedc
)
4482 if (doacross_steps
== NULL
)
4483 vec_safe_grow_cleared (doacross_steps
, clauses
->orderedc
, true);
4484 (*doacross_steps
)[i
] = step
;
4488 TREE_VEC_ELT (orig_decls
, i
) = dovar_decl
;
4490 if (dovar_found
== 2
4491 && op
== EXEC_OMP_SIMD
4495 for (tmp
= omp_clauses
; tmp
; tmp
= OMP_CLAUSE_CHAIN (tmp
))
4496 if (OMP_CLAUSE_CODE (tmp
) == OMP_CLAUSE_LINEAR
4497 && OMP_CLAUSE_DECL (tmp
) == dovar
)
4499 OMP_CLAUSE_LINEAR_NO_COPYIN (tmp
) = 1;
4503 if (!dovar_found
&& op
== EXEC_OMP_SIMD
)
4507 tmp
= build_omp_clause (input_location
, OMP_CLAUSE_LINEAR
);
4508 OMP_CLAUSE_LINEAR_STEP (tmp
) = step
;
4509 OMP_CLAUSE_LINEAR_NO_COPYIN (tmp
) = 1;
4510 OMP_CLAUSE_DECL (tmp
) = dovar_decl
;
4511 omp_clauses
= gfc_trans_add_clause (tmp
, omp_clauses
);
4516 else if (!dovar_found
&& !simple
)
4518 tmp
= build_omp_clause (input_location
, OMP_CLAUSE_PRIVATE
);
4519 OMP_CLAUSE_DECL (tmp
) = dovar_decl
;
4520 omp_clauses
= gfc_trans_add_clause (tmp
, omp_clauses
);
4522 if (dovar_found
== 2)
4529 /* If dovar is lastprivate, but different counter is used,
4530 dovar += step needs to be added to
4531 OMP_CLAUSE_LASTPRIVATE_STMT, otherwise the copied dovar
4532 will have the value on entry of the last loop, rather
4533 than value after iterator increment. */
4534 if (clauses
->orderedc
)
4536 if (clauses
->collapse
<= 1 || i
>= clauses
->collapse
)
4539 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4540 type
, count
, build_one_cst (type
));
4541 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, type
,
4543 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
,
4548 tmp
= gfc_evaluate_now (step
, pblock
);
4549 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
,
4552 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, type
,
4554 for (c
= omp_clauses
; c
; c
= OMP_CLAUSE_CHAIN (c
))
4555 if (OMP_CLAUSE_CODE (c
) == OMP_CLAUSE_LASTPRIVATE
4556 && OMP_CLAUSE_DECL (c
) == dovar_decl
)
4558 OMP_CLAUSE_LASTPRIVATE_STMT (c
) = tmp
;
4561 else if (OMP_CLAUSE_CODE (c
) == OMP_CLAUSE_LINEAR
4562 && OMP_CLAUSE_DECL (c
) == dovar_decl
)
4564 OMP_CLAUSE_LINEAR_STMT (c
) = tmp
;
4568 if (c
== NULL
&& op
== EXEC_OMP_DO
&& par_clauses
!= NULL
)
4570 for (c
= par_clauses
; c
; c
= OMP_CLAUSE_CHAIN (c
))
4571 if (OMP_CLAUSE_CODE (c
) == OMP_CLAUSE_LASTPRIVATE
4572 && OMP_CLAUSE_DECL (c
) == dovar_decl
)
4574 tree l
= build_omp_clause (input_location
,
4575 OMP_CLAUSE_LASTPRIVATE
);
4576 if (OMP_CLAUSE_LASTPRIVATE_CONDITIONAL (c
))
4577 OMP_CLAUSE_LASTPRIVATE_CONDITIONAL (l
) = 1;
4578 OMP_CLAUSE_DECL (l
) = dovar_decl
;
4579 OMP_CLAUSE_CHAIN (l
) = omp_clauses
;
4580 OMP_CLAUSE_LASTPRIVATE_STMT (l
) = tmp
;
4582 OMP_CLAUSE_SET_CODE (c
, OMP_CLAUSE_SHARED
);
4586 gcc_assert (simple
|| c
!= NULL
);
4590 if (op
!= EXEC_OMP_SIMD
)
4591 tmp
= build_omp_clause (input_location
, OMP_CLAUSE_PRIVATE
);
4592 else if (collapse
== 1)
4594 tmp
= build_omp_clause (input_location
, OMP_CLAUSE_LINEAR
);
4595 OMP_CLAUSE_LINEAR_STEP (tmp
) = build_int_cst (type
, 1);
4596 OMP_CLAUSE_LINEAR_NO_COPYIN (tmp
) = 1;
4597 OMP_CLAUSE_LINEAR_NO_COPYOUT (tmp
) = 1;
4600 tmp
= build_omp_clause (input_location
, OMP_CLAUSE_LASTPRIVATE
);
4601 OMP_CLAUSE_DECL (tmp
) = count
;
4602 omp_clauses
= gfc_trans_add_clause (tmp
, omp_clauses
);
4605 if (i
+ 1 < collapse
)
4606 code
= code
->block
->next
;
4609 if (pblock
!= &block
)
4612 gfc_start_block (&block
);
4615 gfc_start_block (&body
);
4617 FOR_EACH_VEC_ELT (inits
, ix
, di
)
4618 gfc_add_modify (&body
, di
->var
, di
->init
);
4621 /* Cycle statement is implemented with a goto. Exit statement must not be
4622 present for this loop. */
4623 cycle_label
= gfc_build_label_decl (NULL_TREE
);
4625 /* Put these labels where they can be found later. */
4627 code
->cycle_label
= cycle_label
;
4628 code
->exit_label
= NULL_TREE
;
4630 /* Main loop body. */
4631 tmp
= gfc_trans_omp_code (code
->block
->next
, true);
4632 gfc_add_expr_to_block (&body
, tmp
);
4634 /* Label for cycle statements (if needed). */
4635 if (TREE_USED (cycle_label
))
4637 tmp
= build1_v (LABEL_EXPR
, cycle_label
);
4638 gfc_add_expr_to_block (&body
, tmp
);
4641 /* End of loop body. */
4644 case EXEC_OMP_SIMD
: stmt
= make_node (OMP_SIMD
); break;
4645 case EXEC_OMP_DO
: stmt
= make_node (OMP_FOR
); break;
4646 case EXEC_OMP_DISTRIBUTE
: stmt
= make_node (OMP_DISTRIBUTE
); break;
4647 case EXEC_OMP_TASKLOOP
: stmt
= make_node (OMP_TASKLOOP
); break;
4648 case EXEC_OACC_LOOP
: stmt
= make_node (OACC_LOOP
); break;
4649 default: gcc_unreachable ();
4652 TREE_TYPE (stmt
) = void_type_node
;
4653 OMP_FOR_BODY (stmt
) = gfc_finish_block (&body
);
4654 OMP_FOR_CLAUSES (stmt
) = omp_clauses
;
4655 OMP_FOR_INIT (stmt
) = init
;
4656 OMP_FOR_COND (stmt
) = cond
;
4657 OMP_FOR_INCR (stmt
) = incr
;
4659 OMP_FOR_ORIG_DECLS (stmt
) = orig_decls
;
4660 gfc_add_expr_to_block (&block
, stmt
);
4662 vec_free (doacross_steps
);
4663 doacross_steps
= saved_doacross_steps
;
4665 return gfc_finish_block (&block
);
4668 /* Translate combined OpenACC 'parallel loop', 'kernels loop', 'serial loop'
4672 gfc_trans_oacc_combined_directive (gfc_code
*code
)
4674 stmtblock_t block
, *pblock
= NULL
;
4675 gfc_omp_clauses construct_clauses
, loop_clauses
;
4676 tree stmt
, oacc_clauses
= NULL_TREE
;
4677 enum tree_code construct_code
;
4678 location_t loc
= input_location
;
4682 case EXEC_OACC_PARALLEL_LOOP
:
4683 construct_code
= OACC_PARALLEL
;
4685 case EXEC_OACC_KERNELS_LOOP
:
4686 construct_code
= OACC_KERNELS
;
4688 case EXEC_OACC_SERIAL_LOOP
:
4689 construct_code
= OACC_SERIAL
;
4695 gfc_start_block (&block
);
4697 memset (&loop_clauses
, 0, sizeof (loop_clauses
));
4698 if (code
->ext
.omp_clauses
!= NULL
)
4700 memcpy (&construct_clauses
, code
->ext
.omp_clauses
,
4701 sizeof (construct_clauses
));
4702 loop_clauses
.collapse
= construct_clauses
.collapse
;
4703 loop_clauses
.gang
= construct_clauses
.gang
;
4704 loop_clauses
.gang_static
= construct_clauses
.gang_static
;
4705 loop_clauses
.gang_num_expr
= construct_clauses
.gang_num_expr
;
4706 loop_clauses
.gang_static_expr
= construct_clauses
.gang_static_expr
;
4707 loop_clauses
.vector
= construct_clauses
.vector
;
4708 loop_clauses
.vector_expr
= construct_clauses
.vector_expr
;
4709 loop_clauses
.worker
= construct_clauses
.worker
;
4710 loop_clauses
.worker_expr
= construct_clauses
.worker_expr
;
4711 loop_clauses
.seq
= construct_clauses
.seq
;
4712 loop_clauses
.par_auto
= construct_clauses
.par_auto
;
4713 loop_clauses
.independent
= construct_clauses
.independent
;
4714 loop_clauses
.tile_list
= construct_clauses
.tile_list
;
4715 loop_clauses
.lists
[OMP_LIST_PRIVATE
]
4716 = construct_clauses
.lists
[OMP_LIST_PRIVATE
];
4717 loop_clauses
.lists
[OMP_LIST_REDUCTION
]
4718 = construct_clauses
.lists
[OMP_LIST_REDUCTION
];
4719 construct_clauses
.gang
= false;
4720 construct_clauses
.gang_static
= false;
4721 construct_clauses
.gang_num_expr
= NULL
;
4722 construct_clauses
.gang_static_expr
= NULL
;
4723 construct_clauses
.vector
= false;
4724 construct_clauses
.vector_expr
= NULL
;
4725 construct_clauses
.worker
= false;
4726 construct_clauses
.worker_expr
= NULL
;
4727 construct_clauses
.seq
= false;
4728 construct_clauses
.par_auto
= false;
4729 construct_clauses
.independent
= false;
4730 construct_clauses
.independent
= false;
4731 construct_clauses
.tile_list
= NULL
;
4732 construct_clauses
.lists
[OMP_LIST_PRIVATE
] = NULL
;
4733 if (construct_code
== OACC_KERNELS
)
4734 construct_clauses
.lists
[OMP_LIST_REDUCTION
] = NULL
;
4735 oacc_clauses
= gfc_trans_omp_clauses (&block
, &construct_clauses
,
4736 code
->loc
, false, true);
4738 if (!loop_clauses
.seq
)
4742 stmt
= gfc_trans_omp_do (code
, EXEC_OACC_LOOP
, pblock
, &loop_clauses
, NULL
);
4743 protected_set_expr_location (stmt
, loc
);
4744 if (TREE_CODE (stmt
) != BIND_EXPR
)
4745 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
4748 stmt
= build2_loc (loc
, construct_code
, void_type_node
, stmt
, oacc_clauses
);
4749 gfc_add_expr_to_block (&block
, stmt
);
4750 return gfc_finish_block (&block
);
4754 gfc_trans_omp_flush (void)
4756 tree decl
= builtin_decl_explicit (BUILT_IN_SYNC_SYNCHRONIZE
);
4757 return build_call_expr_loc (input_location
, decl
, 0);
4761 gfc_trans_omp_master (gfc_code
*code
)
4763 tree stmt
= gfc_trans_code (code
->block
->next
);
4764 if (IS_EMPTY_STMT (stmt
))
4766 return build1_v (OMP_MASTER
, stmt
);
4770 gfc_trans_omp_ordered (gfc_code
*code
)
4774 if (!code
->ext
.omp_clauses
->simd
)
4775 return gfc_trans_code (code
->block
? code
->block
->next
: NULL
);
4776 code
->ext
.omp_clauses
->threads
= 0;
4778 tree omp_clauses
= gfc_trans_omp_clauses (NULL
, code
->ext
.omp_clauses
,
4780 return build2_loc (input_location
, OMP_ORDERED
, void_type_node
,
4781 code
->block
? gfc_trans_code (code
->block
->next
)
4782 : NULL_TREE
, omp_clauses
);
4786 gfc_trans_omp_parallel (gfc_code
*code
)
4789 tree stmt
, omp_clauses
;
4791 gfc_start_block (&block
);
4792 omp_clauses
= gfc_trans_omp_clauses (&block
, code
->ext
.omp_clauses
,
4795 stmt
= gfc_trans_omp_code (code
->block
->next
, true);
4796 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
4797 stmt
= build2_loc (input_location
, OMP_PARALLEL
, void_type_node
, stmt
,
4799 gfc_add_expr_to_block (&block
, stmt
);
4800 return gfc_finish_block (&block
);
4807 GFC_OMP_SPLIT_PARALLEL
,
4808 GFC_OMP_SPLIT_DISTRIBUTE
,
4809 GFC_OMP_SPLIT_TEAMS
,
4810 GFC_OMP_SPLIT_TARGET
,
4811 GFC_OMP_SPLIT_TASKLOOP
,
4817 GFC_OMP_MASK_SIMD
= (1 << GFC_OMP_SPLIT_SIMD
),
4818 GFC_OMP_MASK_DO
= (1 << GFC_OMP_SPLIT_DO
),
4819 GFC_OMP_MASK_PARALLEL
= (1 << GFC_OMP_SPLIT_PARALLEL
),
4820 GFC_OMP_MASK_DISTRIBUTE
= (1 << GFC_OMP_SPLIT_DISTRIBUTE
),
4821 GFC_OMP_MASK_TEAMS
= (1 << GFC_OMP_SPLIT_TEAMS
),
4822 GFC_OMP_MASK_TARGET
= (1 << GFC_OMP_SPLIT_TARGET
),
4823 GFC_OMP_MASK_TASKLOOP
= (1 << GFC_OMP_SPLIT_TASKLOOP
)
4827 gfc_split_omp_clauses (gfc_code
*code
,
4828 gfc_omp_clauses clausesa
[GFC_OMP_SPLIT_NUM
])
4830 int mask
= 0, innermost
= 0;
4831 memset (clausesa
, 0, GFC_OMP_SPLIT_NUM
* sizeof (gfc_omp_clauses
));
4834 case EXEC_OMP_DISTRIBUTE
:
4835 innermost
= GFC_OMP_SPLIT_DISTRIBUTE
;
4837 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
4838 mask
= GFC_OMP_MASK_DISTRIBUTE
| GFC_OMP_MASK_PARALLEL
| GFC_OMP_MASK_DO
;
4839 innermost
= GFC_OMP_SPLIT_DO
;
4841 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
4842 mask
= GFC_OMP_MASK_DISTRIBUTE
| GFC_OMP_MASK_PARALLEL
4843 | GFC_OMP_MASK_DO
| GFC_OMP_MASK_SIMD
;
4844 innermost
= GFC_OMP_SPLIT_SIMD
;
4846 case EXEC_OMP_DISTRIBUTE_SIMD
:
4847 mask
= GFC_OMP_MASK_DISTRIBUTE
| GFC_OMP_MASK_SIMD
;
4848 innermost
= GFC_OMP_SPLIT_SIMD
;
4851 innermost
= GFC_OMP_SPLIT_DO
;
4853 case EXEC_OMP_DO_SIMD
:
4854 mask
= GFC_OMP_MASK_DO
| GFC_OMP_MASK_SIMD
;
4855 innermost
= GFC_OMP_SPLIT_SIMD
;
4857 case EXEC_OMP_PARALLEL
:
4858 innermost
= GFC_OMP_SPLIT_PARALLEL
;
4860 case EXEC_OMP_PARALLEL_DO
:
4861 mask
= GFC_OMP_MASK_PARALLEL
| GFC_OMP_MASK_DO
;
4862 innermost
= GFC_OMP_SPLIT_DO
;
4864 case EXEC_OMP_PARALLEL_DO_SIMD
:
4865 mask
= GFC_OMP_MASK_PARALLEL
| GFC_OMP_MASK_DO
| GFC_OMP_MASK_SIMD
;
4866 innermost
= GFC_OMP_SPLIT_SIMD
;
4869 innermost
= GFC_OMP_SPLIT_SIMD
;
4871 case EXEC_OMP_TARGET
:
4872 innermost
= GFC_OMP_SPLIT_TARGET
;
4874 case EXEC_OMP_TARGET_PARALLEL
:
4875 mask
= GFC_OMP_MASK_TARGET
| GFC_OMP_MASK_PARALLEL
;
4876 innermost
= GFC_OMP_SPLIT_PARALLEL
;
4878 case EXEC_OMP_TARGET_PARALLEL_DO
:
4879 mask
= GFC_OMP_MASK_TARGET
| GFC_OMP_MASK_PARALLEL
| GFC_OMP_MASK_DO
;
4880 innermost
= GFC_OMP_SPLIT_DO
;
4882 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
4883 mask
= GFC_OMP_MASK_TARGET
| GFC_OMP_MASK_PARALLEL
| GFC_OMP_MASK_DO
4884 | GFC_OMP_MASK_SIMD
;
4885 innermost
= GFC_OMP_SPLIT_SIMD
;
4887 case EXEC_OMP_TARGET_SIMD
:
4888 mask
= GFC_OMP_MASK_TARGET
| GFC_OMP_MASK_SIMD
;
4889 innermost
= GFC_OMP_SPLIT_SIMD
;
4891 case EXEC_OMP_TARGET_TEAMS
:
4892 mask
= GFC_OMP_MASK_TARGET
| GFC_OMP_MASK_TEAMS
;
4893 innermost
= GFC_OMP_SPLIT_TEAMS
;
4895 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
4896 mask
= GFC_OMP_MASK_TARGET
| GFC_OMP_MASK_TEAMS
4897 | GFC_OMP_MASK_DISTRIBUTE
;
4898 innermost
= GFC_OMP_SPLIT_DISTRIBUTE
;
4900 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
4901 mask
= GFC_OMP_MASK_TARGET
| GFC_OMP_MASK_TEAMS
| GFC_OMP_MASK_DISTRIBUTE
4902 | GFC_OMP_MASK_PARALLEL
| GFC_OMP_MASK_DO
;
4903 innermost
= GFC_OMP_SPLIT_DO
;
4905 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
4906 mask
= GFC_OMP_MASK_TARGET
| GFC_OMP_MASK_TEAMS
| GFC_OMP_MASK_DISTRIBUTE
4907 | GFC_OMP_MASK_PARALLEL
| GFC_OMP_MASK_DO
| GFC_OMP_MASK_SIMD
;
4908 innermost
= GFC_OMP_SPLIT_SIMD
;
4910 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
4911 mask
= GFC_OMP_MASK_TARGET
| GFC_OMP_MASK_TEAMS
4912 | GFC_OMP_MASK_DISTRIBUTE
| GFC_OMP_MASK_SIMD
;
4913 innermost
= GFC_OMP_SPLIT_SIMD
;
4915 case EXEC_OMP_TASKLOOP
:
4916 innermost
= GFC_OMP_SPLIT_TASKLOOP
;
4918 case EXEC_OMP_TASKLOOP_SIMD
:
4919 mask
= GFC_OMP_MASK_TASKLOOP
| GFC_OMP_MASK_SIMD
;
4920 innermost
= GFC_OMP_SPLIT_SIMD
;
4922 case EXEC_OMP_TEAMS
:
4923 innermost
= GFC_OMP_SPLIT_TEAMS
;
4925 case EXEC_OMP_TEAMS_DISTRIBUTE
:
4926 mask
= GFC_OMP_MASK_TEAMS
| GFC_OMP_MASK_DISTRIBUTE
;
4927 innermost
= GFC_OMP_SPLIT_DISTRIBUTE
;
4929 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
4930 mask
= GFC_OMP_MASK_TEAMS
| GFC_OMP_MASK_DISTRIBUTE
4931 | GFC_OMP_MASK_PARALLEL
| GFC_OMP_MASK_DO
;
4932 innermost
= GFC_OMP_SPLIT_DO
;
4934 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
4935 mask
= GFC_OMP_MASK_TEAMS
| GFC_OMP_MASK_DISTRIBUTE
4936 | GFC_OMP_MASK_PARALLEL
| GFC_OMP_MASK_DO
| GFC_OMP_MASK_SIMD
;
4937 innermost
= GFC_OMP_SPLIT_SIMD
;
4939 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
4940 mask
= GFC_OMP_MASK_TEAMS
| GFC_OMP_MASK_DISTRIBUTE
| GFC_OMP_MASK_SIMD
;
4941 innermost
= GFC_OMP_SPLIT_SIMD
;
4948 clausesa
[innermost
] = *code
->ext
.omp_clauses
;
4951 if (code
->ext
.omp_clauses
!= NULL
)
4953 if (mask
& GFC_OMP_MASK_TARGET
)
4955 /* First the clauses that are unique to some constructs. */
4956 clausesa
[GFC_OMP_SPLIT_TARGET
].lists
[OMP_LIST_MAP
]
4957 = code
->ext
.omp_clauses
->lists
[OMP_LIST_MAP
];
4958 clausesa
[GFC_OMP_SPLIT_TARGET
].lists
[OMP_LIST_IS_DEVICE_PTR
]
4959 = code
->ext
.omp_clauses
->lists
[OMP_LIST_IS_DEVICE_PTR
];
4960 clausesa
[GFC_OMP_SPLIT_TARGET
].device
4961 = code
->ext
.omp_clauses
->device
;
4962 clausesa
[GFC_OMP_SPLIT_TARGET
].defaultmap
4963 = code
->ext
.omp_clauses
->defaultmap
;
4964 clausesa
[GFC_OMP_SPLIT_TARGET
].if_exprs
[OMP_IF_TARGET
]
4965 = code
->ext
.omp_clauses
->if_exprs
[OMP_IF_TARGET
];
4966 /* And this is copied to all. */
4967 clausesa
[GFC_OMP_SPLIT_TARGET
].if_expr
4968 = code
->ext
.omp_clauses
->if_expr
;
4970 if (mask
& GFC_OMP_MASK_TEAMS
)
4972 /* First the clauses that are unique to some constructs. */
4973 clausesa
[GFC_OMP_SPLIT_TEAMS
].num_teams
4974 = code
->ext
.omp_clauses
->num_teams
;
4975 clausesa
[GFC_OMP_SPLIT_TEAMS
].thread_limit
4976 = code
->ext
.omp_clauses
->thread_limit
;
4977 /* Shared and default clauses are allowed on parallel, teams
4979 clausesa
[GFC_OMP_SPLIT_TEAMS
].lists
[OMP_LIST_SHARED
]
4980 = code
->ext
.omp_clauses
->lists
[OMP_LIST_SHARED
];
4981 clausesa
[GFC_OMP_SPLIT_TEAMS
].default_sharing
4982 = code
->ext
.omp_clauses
->default_sharing
;
4984 if (mask
& GFC_OMP_MASK_DISTRIBUTE
)
4986 /* First the clauses that are unique to some constructs. */
4987 clausesa
[GFC_OMP_SPLIT_DISTRIBUTE
].dist_sched_kind
4988 = code
->ext
.omp_clauses
->dist_sched_kind
;
4989 clausesa
[GFC_OMP_SPLIT_DISTRIBUTE
].dist_chunk_size
4990 = code
->ext
.omp_clauses
->dist_chunk_size
;
4991 /* Duplicate collapse. */
4992 clausesa
[GFC_OMP_SPLIT_DISTRIBUTE
].collapse
4993 = code
->ext
.omp_clauses
->collapse
;
4994 clausesa
[GFC_OMP_SPLIT_DISTRIBUTE
].order_concurrent
4995 = code
->ext
.omp_clauses
->order_concurrent
;
4997 if (mask
& GFC_OMP_MASK_PARALLEL
)
4999 /* First the clauses that are unique to some constructs. */
5000 clausesa
[GFC_OMP_SPLIT_PARALLEL
].lists
[OMP_LIST_COPYIN
]
5001 = code
->ext
.omp_clauses
->lists
[OMP_LIST_COPYIN
];
5002 clausesa
[GFC_OMP_SPLIT_PARALLEL
].num_threads
5003 = code
->ext
.omp_clauses
->num_threads
;
5004 clausesa
[GFC_OMP_SPLIT_PARALLEL
].proc_bind
5005 = code
->ext
.omp_clauses
->proc_bind
;
5006 /* Shared and default clauses are allowed on parallel, teams
5008 clausesa
[GFC_OMP_SPLIT_PARALLEL
].lists
[OMP_LIST_SHARED
]
5009 = code
->ext
.omp_clauses
->lists
[OMP_LIST_SHARED
];
5010 clausesa
[GFC_OMP_SPLIT_PARALLEL
].default_sharing
5011 = code
->ext
.omp_clauses
->default_sharing
;
5012 clausesa
[GFC_OMP_SPLIT_PARALLEL
].if_exprs
[OMP_IF_PARALLEL
]
5013 = code
->ext
.omp_clauses
->if_exprs
[OMP_IF_PARALLEL
];
5014 /* And this is copied to all. */
5015 clausesa
[GFC_OMP_SPLIT_PARALLEL
].if_expr
5016 = code
->ext
.omp_clauses
->if_expr
;
5018 if (mask
& GFC_OMP_MASK_DO
)
5020 /* First the clauses that are unique to some constructs. */
5021 clausesa
[GFC_OMP_SPLIT_DO
].ordered
5022 = code
->ext
.omp_clauses
->ordered
;
5023 clausesa
[GFC_OMP_SPLIT_DO
].orderedc
5024 = code
->ext
.omp_clauses
->orderedc
;
5025 clausesa
[GFC_OMP_SPLIT_DO
].sched_kind
5026 = code
->ext
.omp_clauses
->sched_kind
;
5027 if (innermost
== GFC_OMP_SPLIT_SIMD
)
5028 clausesa
[GFC_OMP_SPLIT_DO
].sched_simd
5029 = code
->ext
.omp_clauses
->sched_simd
;
5030 clausesa
[GFC_OMP_SPLIT_DO
].sched_monotonic
5031 = code
->ext
.omp_clauses
->sched_monotonic
;
5032 clausesa
[GFC_OMP_SPLIT_DO
].sched_nonmonotonic
5033 = code
->ext
.omp_clauses
->sched_nonmonotonic
;
5034 clausesa
[GFC_OMP_SPLIT_DO
].chunk_size
5035 = code
->ext
.omp_clauses
->chunk_size
;
5036 clausesa
[GFC_OMP_SPLIT_DO
].nowait
5037 = code
->ext
.omp_clauses
->nowait
;
5038 /* Duplicate collapse. */
5039 clausesa
[GFC_OMP_SPLIT_DO
].collapse
5040 = code
->ext
.omp_clauses
->collapse
;
5041 clausesa
[GFC_OMP_SPLIT_DO
].order_concurrent
5042 = code
->ext
.omp_clauses
->order_concurrent
;
5044 if (mask
& GFC_OMP_MASK_SIMD
)
5046 clausesa
[GFC_OMP_SPLIT_SIMD
].safelen_expr
5047 = code
->ext
.omp_clauses
->safelen_expr
;
5048 clausesa
[GFC_OMP_SPLIT_SIMD
].simdlen_expr
5049 = code
->ext
.omp_clauses
->simdlen_expr
;
5050 clausesa
[GFC_OMP_SPLIT_SIMD
].lists
[OMP_LIST_ALIGNED
]
5051 = code
->ext
.omp_clauses
->lists
[OMP_LIST_ALIGNED
];
5052 /* Duplicate collapse. */
5053 clausesa
[GFC_OMP_SPLIT_SIMD
].collapse
5054 = code
->ext
.omp_clauses
->collapse
;
5055 clausesa
[GFC_OMP_SPLIT_SIMD
].if_exprs
[OMP_IF_SIMD
]
5056 = code
->ext
.omp_clauses
->if_exprs
[OMP_IF_SIMD
];
5057 clausesa
[GFC_OMP_SPLIT_SIMD
].order_concurrent
5058 = code
->ext
.omp_clauses
->order_concurrent
;
5059 /* And this is copied to all. */
5060 clausesa
[GFC_OMP_SPLIT_SIMD
].if_expr
5061 = code
->ext
.omp_clauses
->if_expr
;
5063 if (mask
& GFC_OMP_MASK_TASKLOOP
)
5065 /* First the clauses that are unique to some constructs. */
5066 clausesa
[GFC_OMP_SPLIT_TASKLOOP
].nogroup
5067 = code
->ext
.omp_clauses
->nogroup
;
5068 clausesa
[GFC_OMP_SPLIT_TASKLOOP
].grainsize
5069 = code
->ext
.omp_clauses
->grainsize
;
5070 clausesa
[GFC_OMP_SPLIT_TASKLOOP
].num_tasks
5071 = code
->ext
.omp_clauses
->num_tasks
;
5072 clausesa
[GFC_OMP_SPLIT_TASKLOOP
].priority
5073 = code
->ext
.omp_clauses
->priority
;
5074 clausesa
[GFC_OMP_SPLIT_TASKLOOP
].final_expr
5075 = code
->ext
.omp_clauses
->final_expr
;
5076 clausesa
[GFC_OMP_SPLIT_TASKLOOP
].untied
5077 = code
->ext
.omp_clauses
->untied
;
5078 clausesa
[GFC_OMP_SPLIT_TASKLOOP
].mergeable
5079 = code
->ext
.omp_clauses
->mergeable
;
5080 clausesa
[GFC_OMP_SPLIT_TASKLOOP
].if_exprs
[OMP_IF_TASKLOOP
]
5081 = code
->ext
.omp_clauses
->if_exprs
[OMP_IF_TASKLOOP
];
5082 /* And this is copied to all. */
5083 clausesa
[GFC_OMP_SPLIT_TASKLOOP
].if_expr
5084 = code
->ext
.omp_clauses
->if_expr
;
5085 /* Shared and default clauses are allowed on parallel, teams
5087 clausesa
[GFC_OMP_SPLIT_TASKLOOP
].lists
[OMP_LIST_SHARED
]
5088 = code
->ext
.omp_clauses
->lists
[OMP_LIST_SHARED
];
5089 clausesa
[GFC_OMP_SPLIT_TASKLOOP
].default_sharing
5090 = code
->ext
.omp_clauses
->default_sharing
;
5091 /* Duplicate collapse. */
5092 clausesa
[GFC_OMP_SPLIT_TASKLOOP
].collapse
5093 = code
->ext
.omp_clauses
->collapse
;
5095 /* Private clause is supported on all constructs,
5096 it is enough to put it on the innermost one. For
5097 !$ omp parallel do put it on parallel though,
5098 as that's what we did for OpenMP 3.1. */
5099 clausesa
[innermost
== GFC_OMP_SPLIT_DO
5100 ? (int) GFC_OMP_SPLIT_PARALLEL
5101 : innermost
].lists
[OMP_LIST_PRIVATE
]
5102 = code
->ext
.omp_clauses
->lists
[OMP_LIST_PRIVATE
];
5103 /* Firstprivate clause is supported on all constructs but
5104 simd. Put it on the outermost of those and duplicate
5105 on parallel and teams. */
5106 if (mask
& GFC_OMP_MASK_TARGET
)
5107 clausesa
[GFC_OMP_SPLIT_TARGET
].lists
[OMP_LIST_FIRSTPRIVATE
]
5108 = code
->ext
.omp_clauses
->lists
[OMP_LIST_FIRSTPRIVATE
];
5109 if (mask
& GFC_OMP_MASK_TEAMS
)
5110 clausesa
[GFC_OMP_SPLIT_TEAMS
].lists
[OMP_LIST_FIRSTPRIVATE
]
5111 = code
->ext
.omp_clauses
->lists
[OMP_LIST_FIRSTPRIVATE
];
5112 else if (mask
& GFC_OMP_MASK_DISTRIBUTE
)
5113 clausesa
[GFC_OMP_SPLIT_DISTRIBUTE
].lists
[OMP_LIST_FIRSTPRIVATE
]
5114 = code
->ext
.omp_clauses
->lists
[OMP_LIST_FIRSTPRIVATE
];
5115 if (mask
& GFC_OMP_MASK_PARALLEL
)
5116 clausesa
[GFC_OMP_SPLIT_PARALLEL
].lists
[OMP_LIST_FIRSTPRIVATE
]
5117 = code
->ext
.omp_clauses
->lists
[OMP_LIST_FIRSTPRIVATE
];
5118 else if (mask
& GFC_OMP_MASK_DO
)
5119 clausesa
[GFC_OMP_SPLIT_DO
].lists
[OMP_LIST_FIRSTPRIVATE
]
5120 = code
->ext
.omp_clauses
->lists
[OMP_LIST_FIRSTPRIVATE
];
5121 /* Lastprivate is allowed on distribute, do and simd.
5122 In parallel do{, simd} we actually want to put it on
5123 parallel rather than do. */
5124 if (mask
& GFC_OMP_MASK_DISTRIBUTE
)
5125 clausesa
[GFC_OMP_SPLIT_DISTRIBUTE
].lists
[OMP_LIST_LASTPRIVATE
]
5126 = code
->ext
.omp_clauses
->lists
[OMP_LIST_LASTPRIVATE
];
5127 if (mask
& GFC_OMP_MASK_PARALLEL
)
5128 clausesa
[GFC_OMP_SPLIT_PARALLEL
].lists
[OMP_LIST_LASTPRIVATE
]
5129 = code
->ext
.omp_clauses
->lists
[OMP_LIST_LASTPRIVATE
];
5130 else if (mask
& GFC_OMP_MASK_DO
)
5131 clausesa
[GFC_OMP_SPLIT_DO
].lists
[OMP_LIST_LASTPRIVATE
]
5132 = code
->ext
.omp_clauses
->lists
[OMP_LIST_LASTPRIVATE
];
5133 if (mask
& GFC_OMP_MASK_SIMD
)
5134 clausesa
[GFC_OMP_SPLIT_SIMD
].lists
[OMP_LIST_LASTPRIVATE
]
5135 = code
->ext
.omp_clauses
->lists
[OMP_LIST_LASTPRIVATE
];
5136 /* Reduction is allowed on simd, do, parallel and teams.
5137 Duplicate it on all of them, but omit on do if
5138 parallel is present. */
5139 if (mask
& GFC_OMP_MASK_TEAMS
)
5140 clausesa
[GFC_OMP_SPLIT_TEAMS
].lists
[OMP_LIST_REDUCTION
]
5141 = code
->ext
.omp_clauses
->lists
[OMP_LIST_REDUCTION
];
5142 if (mask
& GFC_OMP_MASK_PARALLEL
)
5143 clausesa
[GFC_OMP_SPLIT_PARALLEL
].lists
[OMP_LIST_REDUCTION
]
5144 = code
->ext
.omp_clauses
->lists
[OMP_LIST_REDUCTION
];
5145 else if (mask
& GFC_OMP_MASK_DO
)
5146 clausesa
[GFC_OMP_SPLIT_DO
].lists
[OMP_LIST_REDUCTION
]
5147 = code
->ext
.omp_clauses
->lists
[OMP_LIST_REDUCTION
];
5148 if (mask
& GFC_OMP_MASK_SIMD
)
5149 clausesa
[GFC_OMP_SPLIT_SIMD
].lists
[OMP_LIST_REDUCTION
]
5150 = code
->ext
.omp_clauses
->lists
[OMP_LIST_REDUCTION
];
5151 /* Linear clause is supported on do and simd,
5152 put it on the innermost one. */
5153 clausesa
[innermost
].lists
[OMP_LIST_LINEAR
]
5154 = code
->ext
.omp_clauses
->lists
[OMP_LIST_LINEAR
];
5156 if ((mask
& (GFC_OMP_MASK_PARALLEL
| GFC_OMP_MASK_DO
))
5157 == (GFC_OMP_MASK_PARALLEL
| GFC_OMP_MASK_DO
))
5158 clausesa
[GFC_OMP_SPLIT_DO
].nowait
= true;
5162 gfc_trans_omp_do_simd (gfc_code
*code
, stmtblock_t
*pblock
,
5163 gfc_omp_clauses
*clausesa
, tree omp_clauses
)
5166 gfc_omp_clauses clausesa_buf
[GFC_OMP_SPLIT_NUM
];
5167 tree stmt
, body
, omp_do_clauses
= NULL_TREE
;
5170 gfc_start_block (&block
);
5172 gfc_init_block (&block
);
5174 if (clausesa
== NULL
)
5176 clausesa
= clausesa_buf
;
5177 gfc_split_omp_clauses (code
, clausesa
);
5181 = gfc_trans_omp_clauses (&block
, &clausesa
[GFC_OMP_SPLIT_DO
], code
->loc
);
5182 body
= gfc_trans_omp_do (code
, EXEC_OMP_SIMD
, pblock
? pblock
: &block
,
5183 &clausesa
[GFC_OMP_SPLIT_SIMD
], omp_clauses
);
5186 if (TREE_CODE (body
) != BIND_EXPR
)
5187 body
= build3_v (BIND_EXPR
, NULL
, body
, poplevel (1, 0));
5191 else if (TREE_CODE (body
) != BIND_EXPR
)
5192 body
= build3_v (BIND_EXPR
, NULL
, body
, NULL_TREE
);
5195 stmt
= make_node (OMP_FOR
);
5196 TREE_TYPE (stmt
) = void_type_node
;
5197 OMP_FOR_BODY (stmt
) = body
;
5198 OMP_FOR_CLAUSES (stmt
) = omp_do_clauses
;
5202 gfc_add_expr_to_block (&block
, stmt
);
5203 return gfc_finish_block (&block
);
5207 gfc_trans_omp_parallel_do (gfc_code
*code
, stmtblock_t
*pblock
,
5208 gfc_omp_clauses
*clausesa
)
5210 stmtblock_t block
, *new_pblock
= pblock
;
5211 gfc_omp_clauses clausesa_buf
[GFC_OMP_SPLIT_NUM
];
5212 tree stmt
, omp_clauses
= NULL_TREE
;
5215 gfc_start_block (&block
);
5217 gfc_init_block (&block
);
5219 if (clausesa
== NULL
)
5221 clausesa
= clausesa_buf
;
5222 gfc_split_omp_clauses (code
, clausesa
);
5225 = gfc_trans_omp_clauses (&block
, &clausesa
[GFC_OMP_SPLIT_PARALLEL
],
5229 if (!clausesa
[GFC_OMP_SPLIT_DO
].ordered
5230 && clausesa
[GFC_OMP_SPLIT_DO
].sched_kind
!= OMP_SCHED_STATIC
)
5231 new_pblock
= &block
;
5235 stmt
= gfc_trans_omp_do (code
, EXEC_OMP_DO
, new_pblock
,
5236 &clausesa
[GFC_OMP_SPLIT_DO
], omp_clauses
);
5239 if (TREE_CODE (stmt
) != BIND_EXPR
)
5240 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
5244 else if (TREE_CODE (stmt
) != BIND_EXPR
)
5245 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, NULL_TREE
);
5246 stmt
= build2_loc (input_location
, OMP_PARALLEL
, void_type_node
, stmt
,
5248 OMP_PARALLEL_COMBINED (stmt
) = 1;
5249 gfc_add_expr_to_block (&block
, stmt
);
5250 return gfc_finish_block (&block
);
5254 gfc_trans_omp_parallel_do_simd (gfc_code
*code
, stmtblock_t
*pblock
,
5255 gfc_omp_clauses
*clausesa
)
5258 gfc_omp_clauses clausesa_buf
[GFC_OMP_SPLIT_NUM
];
5259 tree stmt
, omp_clauses
= NULL_TREE
;
5262 gfc_start_block (&block
);
5264 gfc_init_block (&block
);
5266 if (clausesa
== NULL
)
5268 clausesa
= clausesa_buf
;
5269 gfc_split_omp_clauses (code
, clausesa
);
5273 = gfc_trans_omp_clauses (&block
, &clausesa
[GFC_OMP_SPLIT_PARALLEL
],
5277 stmt
= gfc_trans_omp_do_simd (code
, pblock
, clausesa
, omp_clauses
);
5280 if (TREE_CODE (stmt
) != BIND_EXPR
)
5281 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
5285 else if (TREE_CODE (stmt
) != BIND_EXPR
)
5286 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, NULL_TREE
);
5289 stmt
= build2_loc (input_location
, OMP_PARALLEL
, void_type_node
, stmt
,
5291 OMP_PARALLEL_COMBINED (stmt
) = 1;
5293 gfc_add_expr_to_block (&block
, stmt
);
5294 return gfc_finish_block (&block
);
5298 gfc_trans_omp_parallel_sections (gfc_code
*code
)
5301 gfc_omp_clauses section_clauses
;
5302 tree stmt
, omp_clauses
;
5304 memset (§ion_clauses
, 0, sizeof (section_clauses
));
5305 section_clauses
.nowait
= true;
5307 gfc_start_block (&block
);
5308 omp_clauses
= gfc_trans_omp_clauses (&block
, code
->ext
.omp_clauses
,
5311 stmt
= gfc_trans_omp_sections (code
, §ion_clauses
);
5312 if (TREE_CODE (stmt
) != BIND_EXPR
)
5313 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
5316 stmt
= build2_loc (input_location
, OMP_PARALLEL
, void_type_node
, stmt
,
5318 OMP_PARALLEL_COMBINED (stmt
) = 1;
5319 gfc_add_expr_to_block (&block
, stmt
);
5320 return gfc_finish_block (&block
);
5324 gfc_trans_omp_parallel_workshare (gfc_code
*code
)
5327 gfc_omp_clauses workshare_clauses
;
5328 tree stmt
, omp_clauses
;
5330 memset (&workshare_clauses
, 0, sizeof (workshare_clauses
));
5331 workshare_clauses
.nowait
= true;
5333 gfc_start_block (&block
);
5334 omp_clauses
= gfc_trans_omp_clauses (&block
, code
->ext
.omp_clauses
,
5337 stmt
= gfc_trans_omp_workshare (code
, &workshare_clauses
);
5338 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
5339 stmt
= build2_loc (input_location
, OMP_PARALLEL
, void_type_node
, stmt
,
5341 OMP_PARALLEL_COMBINED (stmt
) = 1;
5342 gfc_add_expr_to_block (&block
, stmt
);
5343 return gfc_finish_block (&block
);
5347 gfc_trans_omp_sections (gfc_code
*code
, gfc_omp_clauses
*clauses
)
5349 stmtblock_t block
, body
;
5350 tree omp_clauses
, stmt
;
5351 bool has_lastprivate
= clauses
->lists
[OMP_LIST_LASTPRIVATE
] != NULL
;
5353 gfc_start_block (&block
);
5355 omp_clauses
= gfc_trans_omp_clauses (&block
, clauses
, code
->loc
);
5357 gfc_init_block (&body
);
5358 for (code
= code
->block
; code
; code
= code
->block
)
5360 /* Last section is special because of lastprivate, so even if it
5361 is empty, chain it in. */
5362 stmt
= gfc_trans_omp_code (code
->next
,
5363 has_lastprivate
&& code
->block
== NULL
);
5364 if (! IS_EMPTY_STMT (stmt
))
5366 stmt
= build1_v (OMP_SECTION
, stmt
);
5367 gfc_add_expr_to_block (&body
, stmt
);
5370 stmt
= gfc_finish_block (&body
);
5372 stmt
= build2_loc (input_location
, OMP_SECTIONS
, void_type_node
, stmt
,
5374 gfc_add_expr_to_block (&block
, stmt
);
5376 return gfc_finish_block (&block
);
5380 gfc_trans_omp_single (gfc_code
*code
, gfc_omp_clauses
*clauses
)
5382 tree omp_clauses
= gfc_trans_omp_clauses (NULL
, clauses
, code
->loc
);
5383 tree stmt
= gfc_trans_omp_code (code
->block
->next
, true);
5384 stmt
= build2_loc (input_location
, OMP_SINGLE
, void_type_node
, stmt
,
5390 gfc_trans_omp_task (gfc_code
*code
)
5393 tree stmt
, omp_clauses
;
5395 gfc_start_block (&block
);
5396 omp_clauses
= gfc_trans_omp_clauses (&block
, code
->ext
.omp_clauses
,
5399 stmt
= gfc_trans_omp_code (code
->block
->next
, true);
5400 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
5401 stmt
= build2_loc (input_location
, OMP_TASK
, void_type_node
, stmt
,
5403 gfc_add_expr_to_block (&block
, stmt
);
5404 return gfc_finish_block (&block
);
5408 gfc_trans_omp_taskgroup (gfc_code
*code
)
5410 tree body
= gfc_trans_code (code
->block
->next
);
5411 tree stmt
= make_node (OMP_TASKGROUP
);
5412 TREE_TYPE (stmt
) = void_type_node
;
5413 OMP_TASKGROUP_BODY (stmt
) = body
;
5414 OMP_TASKGROUP_CLAUSES (stmt
) = NULL_TREE
;
5419 gfc_trans_omp_taskwait (void)
5421 tree decl
= builtin_decl_explicit (BUILT_IN_GOMP_TASKWAIT
);
5422 return build_call_expr_loc (input_location
, decl
, 0);
5426 gfc_trans_omp_taskyield (void)
5428 tree decl
= builtin_decl_explicit (BUILT_IN_GOMP_TASKYIELD
);
5429 return build_call_expr_loc (input_location
, decl
, 0);
5433 gfc_trans_omp_distribute (gfc_code
*code
, gfc_omp_clauses
*clausesa
)
5436 gfc_omp_clauses clausesa_buf
[GFC_OMP_SPLIT_NUM
];
5437 tree stmt
, omp_clauses
= NULL_TREE
;
5439 gfc_start_block (&block
);
5440 if (clausesa
== NULL
)
5442 clausesa
= clausesa_buf
;
5443 gfc_split_omp_clauses (code
, clausesa
);
5447 = gfc_trans_omp_clauses (&block
, &clausesa
[GFC_OMP_SPLIT_DISTRIBUTE
],
5451 case EXEC_OMP_DISTRIBUTE
:
5452 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
5453 case EXEC_OMP_TEAMS_DISTRIBUTE
:
5454 /* This is handled in gfc_trans_omp_do. */
5457 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
5458 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
5459 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
5460 stmt
= gfc_trans_omp_parallel_do (code
, &block
, clausesa
);
5461 if (TREE_CODE (stmt
) != BIND_EXPR
)
5462 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
5466 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
5467 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
5468 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
5469 stmt
= gfc_trans_omp_parallel_do_simd (code
, &block
, clausesa
);
5470 if (TREE_CODE (stmt
) != BIND_EXPR
)
5471 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
5475 case EXEC_OMP_DISTRIBUTE_SIMD
:
5476 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
5477 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
5478 stmt
= gfc_trans_omp_do (code
, EXEC_OMP_SIMD
, &block
,
5479 &clausesa
[GFC_OMP_SPLIT_SIMD
], NULL_TREE
);
5480 if (TREE_CODE (stmt
) != BIND_EXPR
)
5481 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
5490 tree distribute
= make_node (OMP_DISTRIBUTE
);
5491 TREE_TYPE (distribute
) = void_type_node
;
5492 OMP_FOR_BODY (distribute
) = stmt
;
5493 OMP_FOR_CLAUSES (distribute
) = omp_clauses
;
5496 gfc_add_expr_to_block (&block
, stmt
);
5497 return gfc_finish_block (&block
);
5501 gfc_trans_omp_teams (gfc_code
*code
, gfc_omp_clauses
*clausesa
,
5505 gfc_omp_clauses clausesa_buf
[GFC_OMP_SPLIT_NUM
];
5507 bool combined
= true;
5509 gfc_start_block (&block
);
5510 if (clausesa
== NULL
)
5512 clausesa
= clausesa_buf
;
5513 gfc_split_omp_clauses (code
, clausesa
);
5518 = chainon (omp_clauses
,
5519 gfc_trans_omp_clauses (&block
,
5520 &clausesa
[GFC_OMP_SPLIT_TEAMS
],
5526 case EXEC_OMP_TARGET_TEAMS
:
5527 case EXEC_OMP_TEAMS
:
5528 stmt
= gfc_trans_omp_code (code
->block
->next
, true);
5531 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
5532 case EXEC_OMP_TEAMS_DISTRIBUTE
:
5533 stmt
= gfc_trans_omp_do (code
, EXEC_OMP_DISTRIBUTE
, NULL
,
5534 &clausesa
[GFC_OMP_SPLIT_DISTRIBUTE
],
5538 stmt
= gfc_trans_omp_distribute (code
, clausesa
);
5543 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
5544 stmt
= build2_loc (input_location
, OMP_TEAMS
, void_type_node
, stmt
,
5547 OMP_TEAMS_COMBINED (stmt
) = 1;
5549 gfc_add_expr_to_block (&block
, stmt
);
5550 return gfc_finish_block (&block
);
5554 gfc_trans_omp_target (gfc_code
*code
)
5557 gfc_omp_clauses clausesa
[GFC_OMP_SPLIT_NUM
];
5558 tree stmt
, omp_clauses
= NULL_TREE
;
5560 gfc_start_block (&block
);
5561 gfc_split_omp_clauses (code
, clausesa
);
5564 = gfc_trans_omp_clauses (&block
, &clausesa
[GFC_OMP_SPLIT_TARGET
],
5568 case EXEC_OMP_TARGET
:
5570 stmt
= gfc_trans_omp_code (code
->block
->next
, true);
5571 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
5573 case EXEC_OMP_TARGET_PARALLEL
:
5578 gfc_start_block (&iblock
);
5580 = gfc_trans_omp_clauses (&iblock
, &clausesa
[GFC_OMP_SPLIT_PARALLEL
],
5582 stmt
= gfc_trans_omp_code (code
->block
->next
, true);
5583 stmt
= build2_loc (input_location
, OMP_PARALLEL
, void_type_node
, stmt
,
5585 gfc_add_expr_to_block (&iblock
, stmt
);
5586 stmt
= gfc_finish_block (&iblock
);
5587 if (TREE_CODE (stmt
) != BIND_EXPR
)
5588 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
5593 case EXEC_OMP_TARGET_PARALLEL_DO
:
5594 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
5595 stmt
= gfc_trans_omp_parallel_do (code
, &block
, clausesa
);
5596 if (TREE_CODE (stmt
) != BIND_EXPR
)
5597 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
5601 case EXEC_OMP_TARGET_SIMD
:
5602 stmt
= gfc_trans_omp_do (code
, EXEC_OMP_SIMD
, &block
,
5603 &clausesa
[GFC_OMP_SPLIT_SIMD
], NULL_TREE
);
5604 if (TREE_CODE (stmt
) != BIND_EXPR
)
5605 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
5611 && (clausesa
[GFC_OMP_SPLIT_TEAMS
].num_teams
5612 || clausesa
[GFC_OMP_SPLIT_TEAMS
].thread_limit
))
5614 gfc_omp_clauses clausesb
;
5616 /* For combined !$omp target teams, the num_teams and
5617 thread_limit clauses are evaluated before entering the
5618 target construct. */
5619 memset (&clausesb
, '\0', sizeof (clausesb
));
5620 clausesb
.num_teams
= clausesa
[GFC_OMP_SPLIT_TEAMS
].num_teams
;
5621 clausesb
.thread_limit
= clausesa
[GFC_OMP_SPLIT_TEAMS
].thread_limit
;
5622 clausesa
[GFC_OMP_SPLIT_TEAMS
].num_teams
= NULL
;
5623 clausesa
[GFC_OMP_SPLIT_TEAMS
].thread_limit
= NULL
;
5625 = gfc_trans_omp_clauses (&block
, &clausesb
, code
->loc
);
5627 stmt
= gfc_trans_omp_teams (code
, clausesa
, teams_clauses
);
5632 stmt
= gfc_trans_omp_teams (code
, clausesa
, NULL_TREE
);
5634 if (TREE_CODE (stmt
) != BIND_EXPR
)
5635 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
5642 stmt
= build2_loc (input_location
, OMP_TARGET
, void_type_node
, stmt
,
5644 if (code
->op
!= EXEC_OMP_TARGET
)
5645 OMP_TARGET_COMBINED (stmt
) = 1;
5646 cfun
->has_omp_target
= true;
5648 gfc_add_expr_to_block (&block
, stmt
);
5649 return gfc_finish_block (&block
);
5653 gfc_trans_omp_taskloop (gfc_code
*code
)
5656 gfc_omp_clauses clausesa
[GFC_OMP_SPLIT_NUM
];
5657 tree stmt
, omp_clauses
= NULL_TREE
;
5659 gfc_start_block (&block
);
5660 gfc_split_omp_clauses (code
, clausesa
);
5663 = gfc_trans_omp_clauses (&block
, &clausesa
[GFC_OMP_SPLIT_TASKLOOP
],
5667 case EXEC_OMP_TASKLOOP
:
5668 /* This is handled in gfc_trans_omp_do. */
5671 case EXEC_OMP_TASKLOOP_SIMD
:
5672 stmt
= gfc_trans_omp_do (code
, EXEC_OMP_SIMD
, &block
,
5673 &clausesa
[GFC_OMP_SPLIT_SIMD
], NULL_TREE
);
5674 if (TREE_CODE (stmt
) != BIND_EXPR
)
5675 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
5684 tree taskloop
= make_node (OMP_TASKLOOP
);
5685 TREE_TYPE (taskloop
) = void_type_node
;
5686 OMP_FOR_BODY (taskloop
) = stmt
;
5687 OMP_FOR_CLAUSES (taskloop
) = omp_clauses
;
5690 gfc_add_expr_to_block (&block
, stmt
);
5691 return gfc_finish_block (&block
);
5695 gfc_trans_omp_target_data (gfc_code
*code
)
5698 tree stmt
, omp_clauses
;
5700 gfc_start_block (&block
);
5701 omp_clauses
= gfc_trans_omp_clauses (&block
, code
->ext
.omp_clauses
,
5703 stmt
= gfc_trans_omp_code (code
->block
->next
, true);
5704 stmt
= build2_loc (input_location
, OMP_TARGET_DATA
, void_type_node
, stmt
,
5706 gfc_add_expr_to_block (&block
, stmt
);
5707 return gfc_finish_block (&block
);
5711 gfc_trans_omp_target_enter_data (gfc_code
*code
)
5714 tree stmt
, omp_clauses
;
5716 gfc_start_block (&block
);
5717 omp_clauses
= gfc_trans_omp_clauses (&block
, code
->ext
.omp_clauses
,
5719 stmt
= build1_loc (input_location
, OMP_TARGET_ENTER_DATA
, void_type_node
,
5721 gfc_add_expr_to_block (&block
, stmt
);
5722 return gfc_finish_block (&block
);
5726 gfc_trans_omp_target_exit_data (gfc_code
*code
)
5729 tree stmt
, omp_clauses
;
5731 gfc_start_block (&block
);
5732 omp_clauses
= gfc_trans_omp_clauses (&block
, code
->ext
.omp_clauses
,
5734 stmt
= build1_loc (input_location
, OMP_TARGET_EXIT_DATA
, void_type_node
,
5736 gfc_add_expr_to_block (&block
, stmt
);
5737 return gfc_finish_block (&block
);
5741 gfc_trans_omp_target_update (gfc_code
*code
)
5744 tree stmt
, omp_clauses
;
5746 gfc_start_block (&block
);
5747 omp_clauses
= gfc_trans_omp_clauses (&block
, code
->ext
.omp_clauses
,
5749 stmt
= build1_loc (input_location
, OMP_TARGET_UPDATE
, void_type_node
,
5751 gfc_add_expr_to_block (&block
, stmt
);
5752 return gfc_finish_block (&block
);
5756 gfc_trans_omp_workshare (gfc_code
*code
, gfc_omp_clauses
*clauses
)
5758 tree res
, tmp
, stmt
;
5759 stmtblock_t block
, *pblock
= NULL
;
5760 stmtblock_t singleblock
;
5761 int saved_ompws_flags
;
5762 bool singleblock_in_progress
= false;
5763 /* True if previous gfc_code in workshare construct is not workshared. */
5764 bool prev_singleunit
;
5766 code
= code
->block
->next
;
5770 gfc_start_block (&block
);
5773 ompws_flags
= OMPWS_WORKSHARE_FLAG
;
5774 prev_singleunit
= false;
5776 /* Translate statements one by one to trees until we reach
5777 the end of the workshare construct. Adjacent gfc_codes that
5778 are a single unit of work are clustered and encapsulated in a
5779 single OMP_SINGLE construct. */
5780 for (; code
; code
= code
->next
)
5782 if (code
->here
!= 0)
5784 res
= gfc_trans_label_here (code
);
5785 gfc_add_expr_to_block (pblock
, res
);
5788 /* No dependence analysis, use for clauses with wait.
5789 If this is the last gfc_code, use default omp_clauses. */
5790 if (code
->next
== NULL
&& clauses
->nowait
)
5791 ompws_flags
|= OMPWS_NOWAIT
;
5793 /* By default, every gfc_code is a single unit of work. */
5794 ompws_flags
|= OMPWS_CURR_SINGLEUNIT
;
5795 ompws_flags
&= ~(OMPWS_SCALARIZER_WS
| OMPWS_SCALARIZER_BODY
);
5804 res
= gfc_trans_assign (code
);
5807 case EXEC_POINTER_ASSIGN
:
5808 res
= gfc_trans_pointer_assign (code
);
5811 case EXEC_INIT_ASSIGN
:
5812 res
= gfc_trans_init_assign (code
);
5816 res
= gfc_trans_forall (code
);
5820 res
= gfc_trans_where (code
);
5823 case EXEC_OMP_ATOMIC
:
5824 res
= gfc_trans_omp_directive (code
);
5827 case EXEC_OMP_PARALLEL
:
5828 case EXEC_OMP_PARALLEL_DO
:
5829 case EXEC_OMP_PARALLEL_SECTIONS
:
5830 case EXEC_OMP_PARALLEL_WORKSHARE
:
5831 case EXEC_OMP_CRITICAL
:
5832 saved_ompws_flags
= ompws_flags
;
5834 res
= gfc_trans_omp_directive (code
);
5835 ompws_flags
= saved_ompws_flags
;
5839 gfc_internal_error ("gfc_trans_omp_workshare(): Bad statement code");
5842 gfc_set_backend_locus (&code
->loc
);
5844 if (res
!= NULL_TREE
&& ! IS_EMPTY_STMT (res
))
5846 if (prev_singleunit
)
5848 if (ompws_flags
& OMPWS_CURR_SINGLEUNIT
)
5849 /* Add current gfc_code to single block. */
5850 gfc_add_expr_to_block (&singleblock
, res
);
5853 /* Finish single block and add it to pblock. */
5854 tmp
= gfc_finish_block (&singleblock
);
5855 tmp
= build2_loc (input_location
, OMP_SINGLE
,
5856 void_type_node
, tmp
, NULL_TREE
);
5857 gfc_add_expr_to_block (pblock
, tmp
);
5858 /* Add current gfc_code to pblock. */
5859 gfc_add_expr_to_block (pblock
, res
);
5860 singleblock_in_progress
= false;
5865 if (ompws_flags
& OMPWS_CURR_SINGLEUNIT
)
5867 /* Start single block. */
5868 gfc_init_block (&singleblock
);
5869 gfc_add_expr_to_block (&singleblock
, res
);
5870 singleblock_in_progress
= true;
5873 /* Add the new statement to the block. */
5874 gfc_add_expr_to_block (pblock
, res
);
5876 prev_singleunit
= (ompws_flags
& OMPWS_CURR_SINGLEUNIT
) != 0;
5880 /* Finish remaining SINGLE block, if we were in the middle of one. */
5881 if (singleblock_in_progress
)
5883 /* Finish single block and add it to pblock. */
5884 tmp
= gfc_finish_block (&singleblock
);
5885 tmp
= build2_loc (input_location
, OMP_SINGLE
, void_type_node
, tmp
,
5887 ? build_omp_clause (input_location
, OMP_CLAUSE_NOWAIT
)
5889 gfc_add_expr_to_block (pblock
, tmp
);
5892 stmt
= gfc_finish_block (pblock
);
5893 if (TREE_CODE (stmt
) != BIND_EXPR
)
5895 if (!IS_EMPTY_STMT (stmt
))
5897 tree bindblock
= poplevel (1, 0);
5898 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, bindblock
);
5906 if (IS_EMPTY_STMT (stmt
) && !clauses
->nowait
)
5907 stmt
= gfc_trans_omp_barrier ();
5914 gfc_trans_oacc_declare (gfc_code
*code
)
5917 tree stmt
, oacc_clauses
;
5918 enum tree_code construct_code
;
5920 construct_code
= OACC_DATA
;
5922 gfc_start_block (&block
);
5924 oacc_clauses
= gfc_trans_omp_clauses (&block
, code
->ext
.oacc_declare
->clauses
,
5925 code
->loc
, false, true);
5926 stmt
= gfc_trans_omp_code (code
->block
->next
, true);
5927 stmt
= build2_loc (input_location
, construct_code
, void_type_node
, stmt
,
5929 gfc_add_expr_to_block (&block
, stmt
);
5931 return gfc_finish_block (&block
);
5935 gfc_trans_oacc_directive (gfc_code
*code
)
5939 case EXEC_OACC_PARALLEL_LOOP
:
5940 case EXEC_OACC_KERNELS_LOOP
:
5941 case EXEC_OACC_SERIAL_LOOP
:
5942 return gfc_trans_oacc_combined_directive (code
);
5943 case EXEC_OACC_PARALLEL
:
5944 case EXEC_OACC_KERNELS
:
5945 case EXEC_OACC_SERIAL
:
5946 case EXEC_OACC_DATA
:
5947 case EXEC_OACC_HOST_DATA
:
5948 return gfc_trans_oacc_construct (code
);
5949 case EXEC_OACC_LOOP
:
5950 return gfc_trans_omp_do (code
, code
->op
, NULL
, code
->ext
.omp_clauses
,
5952 case EXEC_OACC_UPDATE
:
5953 case EXEC_OACC_CACHE
:
5954 case EXEC_OACC_ENTER_DATA
:
5955 case EXEC_OACC_EXIT_DATA
:
5956 return gfc_trans_oacc_executable_directive (code
);
5957 case EXEC_OACC_WAIT
:
5958 return gfc_trans_oacc_wait_directive (code
);
5959 case EXEC_OACC_ATOMIC
:
5960 return gfc_trans_omp_atomic (code
);
5961 case EXEC_OACC_DECLARE
:
5962 return gfc_trans_oacc_declare (code
);
5969 gfc_trans_omp_directive (gfc_code
*code
)
5973 case EXEC_OMP_ATOMIC
:
5974 return gfc_trans_omp_atomic (code
);
5975 case EXEC_OMP_BARRIER
:
5976 return gfc_trans_omp_barrier ();
5977 case EXEC_OMP_CANCEL
:
5978 return gfc_trans_omp_cancel (code
);
5979 case EXEC_OMP_CANCELLATION_POINT
:
5980 return gfc_trans_omp_cancellation_point (code
);
5981 case EXEC_OMP_CRITICAL
:
5982 return gfc_trans_omp_critical (code
);
5983 case EXEC_OMP_DISTRIBUTE
:
5986 case EXEC_OMP_TASKLOOP
:
5987 return gfc_trans_omp_do (code
, code
->op
, NULL
, code
->ext
.omp_clauses
,
5989 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
5990 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
5991 case EXEC_OMP_DISTRIBUTE_SIMD
:
5992 return gfc_trans_omp_distribute (code
, NULL
);
5993 case EXEC_OMP_DO_SIMD
:
5994 return gfc_trans_omp_do_simd (code
, NULL
, NULL
, NULL_TREE
);
5995 case EXEC_OMP_FLUSH
:
5996 return gfc_trans_omp_flush ();
5997 case EXEC_OMP_MASTER
:
5998 return gfc_trans_omp_master (code
);
5999 case EXEC_OMP_ORDERED
:
6000 return gfc_trans_omp_ordered (code
);
6001 case EXEC_OMP_PARALLEL
:
6002 return gfc_trans_omp_parallel (code
);
6003 case EXEC_OMP_PARALLEL_DO
:
6004 return gfc_trans_omp_parallel_do (code
, NULL
, NULL
);
6005 case EXEC_OMP_PARALLEL_DO_SIMD
:
6006 return gfc_trans_omp_parallel_do_simd (code
, NULL
, NULL
);
6007 case EXEC_OMP_PARALLEL_SECTIONS
:
6008 return gfc_trans_omp_parallel_sections (code
);
6009 case EXEC_OMP_PARALLEL_WORKSHARE
:
6010 return gfc_trans_omp_parallel_workshare (code
);
6011 case EXEC_OMP_SECTIONS
:
6012 return gfc_trans_omp_sections (code
, code
->ext
.omp_clauses
);
6013 case EXEC_OMP_SINGLE
:
6014 return gfc_trans_omp_single (code
, code
->ext
.omp_clauses
);
6015 case EXEC_OMP_TARGET
:
6016 case EXEC_OMP_TARGET_PARALLEL
:
6017 case EXEC_OMP_TARGET_PARALLEL_DO
:
6018 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
6019 case EXEC_OMP_TARGET_SIMD
:
6020 case EXEC_OMP_TARGET_TEAMS
:
6021 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
6022 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
6023 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
6024 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
6025 return gfc_trans_omp_target (code
);
6026 case EXEC_OMP_TARGET_DATA
:
6027 return gfc_trans_omp_target_data (code
);
6028 case EXEC_OMP_TARGET_ENTER_DATA
:
6029 return gfc_trans_omp_target_enter_data (code
);
6030 case EXEC_OMP_TARGET_EXIT_DATA
:
6031 return gfc_trans_omp_target_exit_data (code
);
6032 case EXEC_OMP_TARGET_UPDATE
:
6033 return gfc_trans_omp_target_update (code
);
6035 return gfc_trans_omp_task (code
);
6036 case EXEC_OMP_TASKGROUP
:
6037 return gfc_trans_omp_taskgroup (code
);
6038 case EXEC_OMP_TASKLOOP_SIMD
:
6039 return gfc_trans_omp_taskloop (code
);
6040 case EXEC_OMP_TASKWAIT
:
6041 return gfc_trans_omp_taskwait ();
6042 case EXEC_OMP_TASKYIELD
:
6043 return gfc_trans_omp_taskyield ();
6044 case EXEC_OMP_TEAMS
:
6045 case EXEC_OMP_TEAMS_DISTRIBUTE
:
6046 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
6047 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
6048 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
6049 return gfc_trans_omp_teams (code
, NULL
, NULL_TREE
);
6050 case EXEC_OMP_WORKSHARE
:
6051 return gfc_trans_omp_workshare (code
, code
->ext
.omp_clauses
);
6058 gfc_trans_omp_declare_simd (gfc_namespace
*ns
)
6063 gfc_omp_declare_simd
*ods
;
6064 for (ods
= ns
->omp_declare_simd
; ods
; ods
= ods
->next
)
6066 tree c
= gfc_trans_omp_clauses (NULL
, ods
->clauses
, ods
->where
, true);
6067 tree fndecl
= ns
->proc_name
->backend_decl
;
6069 c
= tree_cons (NULL_TREE
, c
, NULL_TREE
);
6070 c
= build_tree_list (get_identifier ("omp declare simd"), c
);
6071 TREE_CHAIN (c
) = DECL_ATTRIBUTES (fndecl
);
6072 DECL_ATTRIBUTES (fndecl
) = c
;