1 /* OpenMP directive translation -- generate GCC trees from gfc_code.
2 Copyright (C) 2005, 2006, 2007, 2008, 2009, 2010
3 Free Software Foundation, Inc.
4 Contributed by Jakub Jelinek <jakub@redhat.com>
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
25 #include "coretypes.h"
27 #include "gimple.h" /* For create_tmp_var_raw. */
28 #include "diagnostic-core.h" /* For internal_error. */
31 #include "trans-stmt.h"
32 #include "trans-types.h"
33 #include "trans-array.h"
34 #include "trans-const.h"
39 /* True if OpenMP should privatize what this DECL points to rather
40 than the DECL itself. */
43 gfc_omp_privatize_by_reference (const_tree decl
)
45 tree type
= TREE_TYPE (decl
);
47 if (TREE_CODE (type
) == REFERENCE_TYPE
48 && (!DECL_ARTIFICIAL (decl
) || TREE_CODE (decl
) == PARM_DECL
))
51 if (TREE_CODE (type
) == POINTER_TYPE
)
53 /* Array POINTER/ALLOCATABLE have aggregate types, all user variables
54 that have POINTER_TYPE type and don't have GFC_POINTER_TYPE_P
55 set are supposed to be privatized by reference. */
56 if (GFC_POINTER_TYPE_P (type
))
59 if (!DECL_ARTIFICIAL (decl
)
60 && TREE_CODE (TREE_TYPE (type
)) != FUNCTION_TYPE
)
63 /* Some arrays are expanded as DECL_ARTIFICIAL pointers
65 if (DECL_LANG_SPECIFIC (decl
)
66 && GFC_DECL_SAVED_DESCRIPTOR (decl
))
73 /* True if OpenMP sharing attribute of DECL is predetermined. */
75 enum omp_clause_default_kind
76 gfc_omp_predetermined_sharing (tree decl
)
78 if (DECL_ARTIFICIAL (decl
)
79 && ! GFC_DECL_RESULT (decl
)
80 && ! (DECL_LANG_SPECIFIC (decl
)
81 && GFC_DECL_SAVED_DESCRIPTOR (decl
)))
82 return OMP_CLAUSE_DEFAULT_SHARED
;
84 /* Cray pointees shouldn't be listed in any clauses and should be
85 gimplified to dereference of the corresponding Cray pointer.
86 Make them all private, so that they are emitted in the debug
88 if (GFC_DECL_CRAY_POINTEE (decl
))
89 return OMP_CLAUSE_DEFAULT_PRIVATE
;
91 /* Assumed-size arrays are predetermined to inherit sharing
92 attributes of the associated actual argument, which is shared
94 if (TREE_CODE (decl
) == PARM_DECL
95 && GFC_ARRAY_TYPE_P (TREE_TYPE (decl
))
96 && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (decl
)) == GFC_ARRAY_UNKNOWN
97 && GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (decl
),
98 GFC_TYPE_ARRAY_RANK (TREE_TYPE (decl
)) - 1)
100 return OMP_CLAUSE_DEFAULT_SHARED
;
102 /* Dummy procedures aren't considered variables by OpenMP, thus are
103 disallowed in OpenMP clauses. They are represented as PARM_DECLs
104 in the middle-end, so return OMP_CLAUSE_DEFAULT_FIRSTPRIVATE here
105 to avoid complaining about their uses with default(none). */
106 if (TREE_CODE (decl
) == PARM_DECL
107 && TREE_CODE (TREE_TYPE (decl
)) == POINTER_TYPE
108 && TREE_CODE (TREE_TYPE (TREE_TYPE (decl
))) == FUNCTION_TYPE
)
109 return OMP_CLAUSE_DEFAULT_FIRSTPRIVATE
;
111 /* COMMON and EQUIVALENCE decls are shared. They
112 are only referenced through DECL_VALUE_EXPR of the variables
113 contained in them. If those are privatized, they will not be
114 gimplified to the COMMON or EQUIVALENCE decls. */
115 if (GFC_DECL_COMMON_OR_EQUIV (decl
) && ! DECL_HAS_VALUE_EXPR_P (decl
))
116 return OMP_CLAUSE_DEFAULT_SHARED
;
118 if (GFC_DECL_RESULT (decl
) && ! DECL_HAS_VALUE_EXPR_P (decl
))
119 return OMP_CLAUSE_DEFAULT_SHARED
;
121 return OMP_CLAUSE_DEFAULT_UNSPECIFIED
;
124 /* Return decl that should be used when reporting DEFAULT(NONE)
128 gfc_omp_report_decl (tree decl
)
130 if (DECL_ARTIFICIAL (decl
)
131 && DECL_LANG_SPECIFIC (decl
)
132 && GFC_DECL_SAVED_DESCRIPTOR (decl
))
133 return GFC_DECL_SAVED_DESCRIPTOR (decl
);
138 /* Return true if DECL in private clause needs
139 OMP_CLAUSE_PRIVATE_OUTER_REF on the private clause. */
141 gfc_omp_private_outer_ref (tree decl
)
143 tree type
= TREE_TYPE (decl
);
145 if (GFC_DESCRIPTOR_TYPE_P (type
)
146 && GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ALLOCATABLE
)
152 /* Return code to initialize DECL with its default constructor, or
153 NULL if there's nothing to do. */
156 gfc_omp_clause_default_ctor (tree clause
, tree decl
, tree outer
)
158 tree type
= TREE_TYPE (decl
), rank
, size
, esize
, ptr
, cond
, then_b
, else_b
;
159 stmtblock_t block
, cond_block
;
161 if (! GFC_DESCRIPTOR_TYPE_P (type
)
162 || GFC_TYPE_ARRAY_AKIND (type
) != GFC_ARRAY_ALLOCATABLE
)
165 gcc_assert (outer
!= NULL
);
166 gcc_assert (OMP_CLAUSE_CODE (clause
) == OMP_CLAUSE_PRIVATE
167 || OMP_CLAUSE_CODE (clause
) == OMP_CLAUSE_LASTPRIVATE
);
169 /* Allocatable arrays in PRIVATE clauses need to be set to
170 "not currently allocated" allocation status if outer
171 array is "not currently allocated", otherwise should be allocated. */
172 gfc_start_block (&block
);
174 gfc_init_block (&cond_block
);
176 gfc_add_modify (&cond_block
, decl
, outer
);
177 rank
= gfc_rank_cst
[GFC_TYPE_ARRAY_RANK (type
) - 1];
178 size
= gfc_conv_descriptor_ubound_get (decl
, rank
);
179 size
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, size
,
180 gfc_conv_descriptor_lbound_get (decl
, rank
));
181 size
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, size
,
183 if (GFC_TYPE_ARRAY_RANK (type
) > 1)
184 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
,
185 gfc_conv_descriptor_stride_get (decl
, rank
));
186 esize
= fold_convert (gfc_array_index_type
,
187 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
188 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
, esize
);
189 size
= gfc_evaluate_now (fold_convert (size_type_node
, size
), &cond_block
);
190 ptr
= gfc_allocate_array_with_status (&cond_block
,
191 build_int_cst (pvoid_type_node
, 0),
193 gfc_conv_descriptor_data_set (&cond_block
, decl
, ptr
);
194 then_b
= gfc_finish_block (&cond_block
);
196 gfc_init_block (&cond_block
);
197 gfc_conv_descriptor_data_set (&cond_block
, decl
, null_pointer_node
);
198 else_b
= gfc_finish_block (&cond_block
);
200 cond
= fold_build2 (NE_EXPR
, boolean_type_node
,
201 fold_convert (pvoid_type_node
,
202 gfc_conv_descriptor_data_get (outer
)),
204 gfc_add_expr_to_block (&block
, build3 (COND_EXPR
, void_type_node
,
205 cond
, then_b
, else_b
));
207 return gfc_finish_block (&block
);
210 /* Build and return code for a copy constructor from SRC to DEST. */
213 gfc_omp_clause_copy_ctor (tree clause
, tree dest
, tree src
)
215 tree type
= TREE_TYPE (dest
), ptr
, size
, esize
, rank
, call
;
218 if (! GFC_DESCRIPTOR_TYPE_P (type
)
219 || GFC_TYPE_ARRAY_AKIND (type
) != GFC_ARRAY_ALLOCATABLE
)
220 return build2_v (MODIFY_EXPR
, dest
, src
);
222 gcc_assert (OMP_CLAUSE_CODE (clause
) == OMP_CLAUSE_FIRSTPRIVATE
);
224 /* Allocatable arrays in FIRSTPRIVATE clauses need to be allocated
225 and copied from SRC. */
226 gfc_start_block (&block
);
228 gfc_add_modify (&block
, dest
, src
);
229 rank
= gfc_rank_cst
[GFC_TYPE_ARRAY_RANK (type
) - 1];
230 size
= gfc_conv_descriptor_ubound_get (dest
, rank
);
231 size
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, size
,
232 gfc_conv_descriptor_lbound_get (dest
, rank
));
233 size
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, size
,
235 if (GFC_TYPE_ARRAY_RANK (type
) > 1)
236 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
,
237 gfc_conv_descriptor_stride_get (dest
, rank
));
238 esize
= fold_convert (gfc_array_index_type
,
239 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
240 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
, esize
);
241 size
= gfc_evaluate_now (fold_convert (size_type_node
, size
), &block
);
242 ptr
= gfc_allocate_array_with_status (&block
,
243 build_int_cst (pvoid_type_node
, 0),
245 gfc_conv_descriptor_data_set (&block
, dest
, ptr
);
246 call
= build_call_expr_loc (input_location
,
247 built_in_decls
[BUILT_IN_MEMCPY
], 3, ptr
,
248 fold_convert (pvoid_type_node
,
249 gfc_conv_descriptor_data_get (src
)),
251 gfc_add_expr_to_block (&block
, fold_convert (void_type_node
, call
));
253 return gfc_finish_block (&block
);
256 /* Similarly, except use an assignment operator instead. */
259 gfc_omp_clause_assign_op (tree clause ATTRIBUTE_UNUSED
, tree dest
, tree src
)
261 tree type
= TREE_TYPE (dest
), rank
, size
, esize
, call
;
264 if (! GFC_DESCRIPTOR_TYPE_P (type
)
265 || GFC_TYPE_ARRAY_AKIND (type
) != GFC_ARRAY_ALLOCATABLE
)
266 return build2_v (MODIFY_EXPR
, dest
, src
);
268 /* Handle copying allocatable arrays. */
269 gfc_start_block (&block
);
271 rank
= gfc_rank_cst
[GFC_TYPE_ARRAY_RANK (type
) - 1];
272 size
= gfc_conv_descriptor_ubound_get (dest
, rank
);
273 size
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, size
,
274 gfc_conv_descriptor_lbound_get (dest
, rank
));
275 size
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, size
,
277 if (GFC_TYPE_ARRAY_RANK (type
) > 1)
278 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
,
279 gfc_conv_descriptor_stride_get (dest
, rank
));
280 esize
= fold_convert (gfc_array_index_type
,
281 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
282 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
, esize
);
283 size
= gfc_evaluate_now (fold_convert (size_type_node
, size
), &block
);
284 call
= build_call_expr_loc (input_location
,
285 built_in_decls
[BUILT_IN_MEMCPY
], 3,
286 fold_convert (pvoid_type_node
,
287 gfc_conv_descriptor_data_get (dest
)),
288 fold_convert (pvoid_type_node
,
289 gfc_conv_descriptor_data_get (src
)),
291 gfc_add_expr_to_block (&block
, fold_convert (void_type_node
, call
));
293 return gfc_finish_block (&block
);
296 /* Build and return code destructing DECL. Return NULL if nothing
300 gfc_omp_clause_dtor (tree clause ATTRIBUTE_UNUSED
, tree decl
)
302 tree type
= TREE_TYPE (decl
);
304 if (! GFC_DESCRIPTOR_TYPE_P (type
)
305 || GFC_TYPE_ARRAY_AKIND (type
) != GFC_ARRAY_ALLOCATABLE
)
308 /* Allocatable arrays in FIRSTPRIVATE/LASTPRIVATE etc. clauses need
309 to be deallocated if they were allocated. */
310 return gfc_trans_dealloc_allocated (decl
);
314 /* Return true if DECL's DECL_VALUE_EXPR (if any) should be
315 disregarded in OpenMP construct, because it is going to be
316 remapped during OpenMP lowering. SHARED is true if DECL
317 is going to be shared, false if it is going to be privatized. */
320 gfc_omp_disregard_value_expr (tree decl
, bool shared
)
322 if (GFC_DECL_COMMON_OR_EQUIV (decl
)
323 && DECL_HAS_VALUE_EXPR_P (decl
))
325 tree value
= DECL_VALUE_EXPR (decl
);
327 if (TREE_CODE (value
) == COMPONENT_REF
328 && TREE_CODE (TREE_OPERAND (value
, 0)) == VAR_DECL
329 && GFC_DECL_COMMON_OR_EQUIV (TREE_OPERAND (value
, 0)))
331 /* If variable in COMMON or EQUIVALENCE is privatized, return
332 true, as just that variable is supposed to be privatized,
333 not the whole COMMON or whole EQUIVALENCE.
334 For shared variables in COMMON or EQUIVALENCE, let them be
335 gimplified to DECL_VALUE_EXPR, so that for multiple shared vars
336 from the same COMMON or EQUIVALENCE just one sharing of the
337 whole COMMON or EQUIVALENCE is enough. */
342 if (GFC_DECL_RESULT (decl
) && DECL_HAS_VALUE_EXPR_P (decl
))
348 /* Return true if DECL that is shared iff SHARED is true should
349 be put into OMP_CLAUSE_PRIVATE with OMP_CLAUSE_PRIVATE_DEBUG
353 gfc_omp_private_debug_clause (tree decl
, bool shared
)
355 if (GFC_DECL_CRAY_POINTEE (decl
))
358 if (GFC_DECL_COMMON_OR_EQUIV (decl
)
359 && DECL_HAS_VALUE_EXPR_P (decl
))
361 tree value
= DECL_VALUE_EXPR (decl
);
363 if (TREE_CODE (value
) == COMPONENT_REF
364 && TREE_CODE (TREE_OPERAND (value
, 0)) == VAR_DECL
365 && GFC_DECL_COMMON_OR_EQUIV (TREE_OPERAND (value
, 0)))
372 /* Register language specific type size variables as potentially OpenMP
373 firstprivate variables. */
376 gfc_omp_firstprivatize_type_sizes (struct gimplify_omp_ctx
*ctx
, tree type
)
378 if (GFC_ARRAY_TYPE_P (type
) || GFC_DESCRIPTOR_TYPE_P (type
))
382 gcc_assert (TYPE_LANG_SPECIFIC (type
) != NULL
);
383 for (r
= 0; r
< GFC_TYPE_ARRAY_RANK (type
); r
++)
385 omp_firstprivatize_variable (ctx
, GFC_TYPE_ARRAY_LBOUND (type
, r
));
386 omp_firstprivatize_variable (ctx
, GFC_TYPE_ARRAY_UBOUND (type
, r
));
387 omp_firstprivatize_variable (ctx
, GFC_TYPE_ARRAY_STRIDE (type
, r
));
389 omp_firstprivatize_variable (ctx
, GFC_TYPE_ARRAY_SIZE (type
));
390 omp_firstprivatize_variable (ctx
, GFC_TYPE_ARRAY_OFFSET (type
));
396 gfc_trans_add_clause (tree node
, tree tail
)
398 OMP_CLAUSE_CHAIN (node
) = tail
;
403 gfc_trans_omp_variable (gfc_symbol
*sym
)
405 tree t
= gfc_get_symbol_decl (sym
);
409 bool alternate_entry
;
412 return_value
= sym
->attr
.function
&& sym
->result
== sym
;
413 alternate_entry
= sym
->attr
.function
&& sym
->attr
.entry
414 && sym
->result
== sym
;
415 entry_master
= sym
->attr
.result
416 && sym
->ns
->proc_name
->attr
.entry_master
417 && !gfc_return_by_reference (sym
->ns
->proc_name
);
418 parent_decl
= DECL_CONTEXT (current_function_decl
);
420 if ((t
== parent_decl
&& return_value
)
421 || (sym
->ns
&& sym
->ns
->proc_name
422 && sym
->ns
->proc_name
->backend_decl
== parent_decl
423 && (alternate_entry
|| entry_master
)))
428 /* Special case for assigning the return value of a function.
429 Self recursive functions must have an explicit return value. */
430 if (return_value
&& (t
== current_function_decl
|| parent_flag
))
431 t
= gfc_get_fake_result_decl (sym
, parent_flag
);
433 /* Similarly for alternate entry points. */
434 else if (alternate_entry
435 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
438 gfc_entry_list
*el
= NULL
;
440 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
443 t
= gfc_get_fake_result_decl (sym
, parent_flag
);
448 else if (entry_master
449 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
451 t
= gfc_get_fake_result_decl (sym
, parent_flag
);
457 gfc_trans_omp_variable_list (enum omp_clause_code code
, gfc_namelist
*namelist
,
460 for (; namelist
!= NULL
; namelist
= namelist
->next
)
461 if (namelist
->sym
->attr
.referenced
)
463 tree t
= gfc_trans_omp_variable (namelist
->sym
);
464 if (t
!= error_mark_node
)
466 tree node
= build_omp_clause (input_location
, code
);
467 OMP_CLAUSE_DECL (node
) = t
;
468 list
= gfc_trans_add_clause (node
, list
);
475 gfc_trans_omp_array_reduction (tree c
, gfc_symbol
*sym
, locus where
)
477 gfc_symtree
*root1
= NULL
, *root2
= NULL
, *root3
= NULL
, *root4
= NULL
;
478 gfc_symtree
*symtree1
, *symtree2
, *symtree3
, *symtree4
= NULL
;
479 gfc_symbol init_val_sym
, outer_sym
, intrinsic_sym
;
480 gfc_expr
*e1
, *e2
, *e3
, *e4
;
482 tree decl
, backend_decl
, stmt
;
483 locus old_loc
= gfc_current_locus
;
487 decl
= OMP_CLAUSE_DECL (c
);
488 gfc_current_locus
= where
;
490 /* Create a fake symbol for init value. */
491 memset (&init_val_sym
, 0, sizeof (init_val_sym
));
492 init_val_sym
.ns
= sym
->ns
;
493 init_val_sym
.name
= sym
->name
;
494 init_val_sym
.ts
= sym
->ts
;
495 init_val_sym
.attr
.referenced
= 1;
496 init_val_sym
.declared_at
= where
;
497 init_val_sym
.attr
.flavor
= FL_VARIABLE
;
498 backend_decl
= omp_reduction_init (c
, gfc_sym_type (&init_val_sym
));
499 init_val_sym
.backend_decl
= backend_decl
;
501 /* Create a fake symbol for the outer array reference. */
503 outer_sym
.as
= gfc_copy_array_spec (sym
->as
);
504 outer_sym
.attr
.dummy
= 0;
505 outer_sym
.attr
.result
= 0;
506 outer_sym
.attr
.flavor
= FL_VARIABLE
;
507 outer_sym
.backend_decl
= create_tmp_var_raw (TREE_TYPE (decl
), NULL
);
509 /* Create fake symtrees for it. */
510 symtree1
= gfc_new_symtree (&root1
, sym
->name
);
511 symtree1
->n
.sym
= sym
;
512 gcc_assert (symtree1
== root1
);
514 symtree2
= gfc_new_symtree (&root2
, sym
->name
);
515 symtree2
->n
.sym
= &init_val_sym
;
516 gcc_assert (symtree2
== root2
);
518 symtree3
= gfc_new_symtree (&root3
, sym
->name
);
519 symtree3
->n
.sym
= &outer_sym
;
520 gcc_assert (symtree3
== root3
);
522 /* Create expressions. */
523 e1
= gfc_get_expr ();
524 e1
->expr_type
= EXPR_VARIABLE
;
526 e1
->symtree
= symtree1
;
528 e1
->ref
= ref
= gfc_get_ref ();
529 ref
->type
= REF_ARRAY
;
530 ref
->u
.ar
.where
= where
;
531 ref
->u
.ar
.as
= sym
->as
;
532 ref
->u
.ar
.type
= AR_FULL
;
534 t
= gfc_resolve_expr (e1
);
535 gcc_assert (t
== SUCCESS
);
537 e2
= gfc_get_expr ();
538 e2
->expr_type
= EXPR_VARIABLE
;
540 e2
->symtree
= symtree2
;
542 t
= gfc_resolve_expr (e2
);
543 gcc_assert (t
== SUCCESS
);
545 e3
= gfc_copy_expr (e1
);
546 e3
->symtree
= symtree3
;
547 t
= gfc_resolve_expr (e3
);
548 gcc_assert (t
== SUCCESS
);
551 switch (OMP_CLAUSE_REDUCTION_CODE (c
))
555 e4
= gfc_add (e3
, e1
);
558 e4
= gfc_multiply (e3
, e1
);
560 case TRUTH_ANDIF_EXPR
:
561 e4
= gfc_and (e3
, e1
);
563 case TRUTH_ORIF_EXPR
:
564 e4
= gfc_or (e3
, e1
);
567 e4
= gfc_eqv (e3
, e1
);
570 e4
= gfc_neqv (e3
, e1
);
592 memset (&intrinsic_sym
, 0, sizeof (intrinsic_sym
));
593 intrinsic_sym
.ns
= sym
->ns
;
594 intrinsic_sym
.name
= iname
;
595 intrinsic_sym
.ts
= sym
->ts
;
596 intrinsic_sym
.attr
.referenced
= 1;
597 intrinsic_sym
.attr
.intrinsic
= 1;
598 intrinsic_sym
.attr
.function
= 1;
599 intrinsic_sym
.result
= &intrinsic_sym
;
600 intrinsic_sym
.declared_at
= where
;
602 symtree4
= gfc_new_symtree (&root4
, iname
);
603 symtree4
->n
.sym
= &intrinsic_sym
;
604 gcc_assert (symtree4
== root4
);
606 e4
= gfc_get_expr ();
607 e4
->expr_type
= EXPR_FUNCTION
;
609 e4
->symtree
= symtree4
;
610 e4
->value
.function
.isym
= gfc_find_function (iname
);
611 e4
->value
.function
.actual
= gfc_get_actual_arglist ();
612 e4
->value
.function
.actual
->expr
= e3
;
613 e4
->value
.function
.actual
->next
= gfc_get_actual_arglist ();
614 e4
->value
.function
.actual
->next
->expr
= e1
;
616 /* e1 and e3 have been stored as arguments of e4, avoid sharing. */
617 e1
= gfc_copy_expr (e1
);
618 e3
= gfc_copy_expr (e3
);
619 t
= gfc_resolve_expr (e4
);
620 gcc_assert (t
== SUCCESS
);
622 /* Create the init statement list. */
624 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
))
625 && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (decl
)) == GFC_ARRAY_ALLOCATABLE
)
627 /* If decl is an allocatable array, it needs to be allocated
628 with the same bounds as the outer var. */
629 tree type
= TREE_TYPE (decl
), rank
, size
, esize
, ptr
;
632 gfc_start_block (&block
);
634 gfc_add_modify (&block
, decl
, outer_sym
.backend_decl
);
635 rank
= gfc_rank_cst
[GFC_TYPE_ARRAY_RANK (type
) - 1];
636 size
= gfc_conv_descriptor_ubound_get (decl
, rank
);
637 size
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, size
,
638 gfc_conv_descriptor_lbound_get (decl
, rank
));
639 size
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, size
,
641 if (GFC_TYPE_ARRAY_RANK (type
) > 1)
642 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
,
643 gfc_conv_descriptor_stride_get (decl
, rank
));
644 esize
= fold_convert (gfc_array_index_type
,
645 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
646 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
, esize
);
647 size
= gfc_evaluate_now (fold_convert (size_type_node
, size
), &block
);
648 ptr
= gfc_allocate_array_with_status (&block
,
649 build_int_cst (pvoid_type_node
, 0),
651 gfc_conv_descriptor_data_set (&block
, decl
, ptr
);
652 gfc_add_expr_to_block (&block
, gfc_trans_assignment (e1
, e2
, false,
654 stmt
= gfc_finish_block (&block
);
657 stmt
= gfc_trans_assignment (e1
, e2
, false, false);
658 if (TREE_CODE (stmt
) != BIND_EXPR
)
659 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0, 0));
662 OMP_CLAUSE_REDUCTION_INIT (c
) = stmt
;
664 /* Create the merge statement list. */
666 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
))
667 && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (decl
)) == GFC_ARRAY_ALLOCATABLE
)
669 /* If decl is an allocatable array, it needs to be deallocated
673 gfc_start_block (&block
);
674 gfc_add_expr_to_block (&block
, gfc_trans_assignment (e3
, e4
, false,
676 gfc_add_expr_to_block (&block
, gfc_trans_dealloc_allocated (decl
));
677 stmt
= gfc_finish_block (&block
);
680 stmt
= gfc_trans_assignment (e3
, e4
, false, true);
681 if (TREE_CODE (stmt
) != BIND_EXPR
)
682 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0, 0));
685 OMP_CLAUSE_REDUCTION_MERGE (c
) = stmt
;
687 /* And stick the placeholder VAR_DECL into the clause as well. */
688 OMP_CLAUSE_REDUCTION_PLACEHOLDER (c
) = outer_sym
.backend_decl
;
690 gfc_current_locus
= old_loc
;
701 gfc_free_array_spec (outer_sym
.as
);
705 gfc_trans_omp_reduction_list (gfc_namelist
*namelist
, tree list
,
706 enum tree_code reduction_code
, locus where
)
708 for (; namelist
!= NULL
; namelist
= namelist
->next
)
709 if (namelist
->sym
->attr
.referenced
)
711 tree t
= gfc_trans_omp_variable (namelist
->sym
);
712 if (t
!= error_mark_node
)
714 tree node
= build_omp_clause (where
.lb
->location
,
715 OMP_CLAUSE_REDUCTION
);
716 OMP_CLAUSE_DECL (node
) = t
;
717 OMP_CLAUSE_REDUCTION_CODE (node
) = reduction_code
;
718 if (namelist
->sym
->attr
.dimension
)
719 gfc_trans_omp_array_reduction (node
, namelist
->sym
, where
);
720 list
= gfc_trans_add_clause (node
, list
);
727 gfc_trans_omp_clauses (stmtblock_t
*block
, gfc_omp_clauses
*clauses
,
730 tree omp_clauses
= NULL_TREE
, chunk_size
, c
;
732 enum omp_clause_code clause_code
;
738 for (list
= 0; list
< OMP_LIST_NUM
; list
++)
740 gfc_namelist
*n
= clauses
->lists
[list
];
744 if (list
>= OMP_LIST_REDUCTION_FIRST
745 && list
<= OMP_LIST_REDUCTION_LAST
)
747 enum tree_code reduction_code
;
751 reduction_code
= PLUS_EXPR
;
754 reduction_code
= MULT_EXPR
;
757 reduction_code
= MINUS_EXPR
;
760 reduction_code
= TRUTH_ANDIF_EXPR
;
763 reduction_code
= TRUTH_ORIF_EXPR
;
766 reduction_code
= EQ_EXPR
;
769 reduction_code
= NE_EXPR
;
772 reduction_code
= MAX_EXPR
;
775 reduction_code
= MIN_EXPR
;
778 reduction_code
= BIT_AND_EXPR
;
781 reduction_code
= BIT_IOR_EXPR
;
784 reduction_code
= BIT_XOR_EXPR
;
790 = gfc_trans_omp_reduction_list (n
, omp_clauses
, reduction_code
,
796 case OMP_LIST_PRIVATE
:
797 clause_code
= OMP_CLAUSE_PRIVATE
;
799 case OMP_LIST_SHARED
:
800 clause_code
= OMP_CLAUSE_SHARED
;
802 case OMP_LIST_FIRSTPRIVATE
:
803 clause_code
= OMP_CLAUSE_FIRSTPRIVATE
;
805 case OMP_LIST_LASTPRIVATE
:
806 clause_code
= OMP_CLAUSE_LASTPRIVATE
;
808 case OMP_LIST_COPYIN
:
809 clause_code
= OMP_CLAUSE_COPYIN
;
811 case OMP_LIST_COPYPRIVATE
:
812 clause_code
= OMP_CLAUSE_COPYPRIVATE
;
816 = gfc_trans_omp_variable_list (clause_code
, n
, omp_clauses
);
823 if (clauses
->if_expr
)
827 gfc_init_se (&se
, NULL
);
828 gfc_conv_expr (&se
, clauses
->if_expr
);
829 gfc_add_block_to_block (block
, &se
.pre
);
830 if_var
= gfc_evaluate_now (se
.expr
, block
);
831 gfc_add_block_to_block (block
, &se
.post
);
833 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_IF
);
834 OMP_CLAUSE_IF_EXPR (c
) = if_var
;
835 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
838 if (clauses
->num_threads
)
842 gfc_init_se (&se
, NULL
);
843 gfc_conv_expr (&se
, clauses
->num_threads
);
844 gfc_add_block_to_block (block
, &se
.pre
);
845 num_threads
= gfc_evaluate_now (se
.expr
, block
);
846 gfc_add_block_to_block (block
, &se
.post
);
848 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_NUM_THREADS
);
849 OMP_CLAUSE_NUM_THREADS_EXPR (c
) = num_threads
;
850 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
853 chunk_size
= NULL_TREE
;
854 if (clauses
->chunk_size
)
856 gfc_init_se (&se
, NULL
);
857 gfc_conv_expr (&se
, clauses
->chunk_size
);
858 gfc_add_block_to_block (block
, &se
.pre
);
859 chunk_size
= gfc_evaluate_now (se
.expr
, block
);
860 gfc_add_block_to_block (block
, &se
.post
);
863 if (clauses
->sched_kind
!= OMP_SCHED_NONE
)
865 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_SCHEDULE
);
866 OMP_CLAUSE_SCHEDULE_CHUNK_EXPR (c
) = chunk_size
;
867 switch (clauses
->sched_kind
)
869 case OMP_SCHED_STATIC
:
870 OMP_CLAUSE_SCHEDULE_KIND (c
) = OMP_CLAUSE_SCHEDULE_STATIC
;
872 case OMP_SCHED_DYNAMIC
:
873 OMP_CLAUSE_SCHEDULE_KIND (c
) = OMP_CLAUSE_SCHEDULE_DYNAMIC
;
875 case OMP_SCHED_GUIDED
:
876 OMP_CLAUSE_SCHEDULE_KIND (c
) = OMP_CLAUSE_SCHEDULE_GUIDED
;
878 case OMP_SCHED_RUNTIME
:
879 OMP_CLAUSE_SCHEDULE_KIND (c
) = OMP_CLAUSE_SCHEDULE_RUNTIME
;
882 OMP_CLAUSE_SCHEDULE_KIND (c
) = OMP_CLAUSE_SCHEDULE_AUTO
;
887 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
890 if (clauses
->default_sharing
!= OMP_DEFAULT_UNKNOWN
)
892 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_DEFAULT
);
893 switch (clauses
->default_sharing
)
895 case OMP_DEFAULT_NONE
:
896 OMP_CLAUSE_DEFAULT_KIND (c
) = OMP_CLAUSE_DEFAULT_NONE
;
898 case OMP_DEFAULT_SHARED
:
899 OMP_CLAUSE_DEFAULT_KIND (c
) = OMP_CLAUSE_DEFAULT_SHARED
;
901 case OMP_DEFAULT_PRIVATE
:
902 OMP_CLAUSE_DEFAULT_KIND (c
) = OMP_CLAUSE_DEFAULT_PRIVATE
;
904 case OMP_DEFAULT_FIRSTPRIVATE
:
905 OMP_CLAUSE_DEFAULT_KIND (c
) = OMP_CLAUSE_DEFAULT_FIRSTPRIVATE
;
910 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
915 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_NOWAIT
);
916 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
919 if (clauses
->ordered
)
921 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_ORDERED
);
922 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
927 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_UNTIED
);
928 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
931 if (clauses
->collapse
)
933 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_COLLAPSE
);
934 OMP_CLAUSE_COLLAPSE_EXPR (c
) = build_int_cst (NULL
, clauses
->collapse
);
935 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
941 /* Like gfc_trans_code, but force creation of a BIND_EXPR around it. */
944 gfc_trans_omp_code (gfc_code
*code
, bool force_empty
)
949 stmt
= gfc_trans_code (code
);
950 if (TREE_CODE (stmt
) != BIND_EXPR
)
952 if (!IS_EMPTY_STMT (stmt
) || force_empty
)
954 tree block
= poplevel (1, 0, 0);
955 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, block
);
966 static tree
gfc_trans_omp_sections (gfc_code
*, gfc_omp_clauses
*);
967 static tree
gfc_trans_omp_workshare (gfc_code
*, gfc_omp_clauses
*);
970 gfc_trans_omp_atomic (gfc_code
*code
)
977 tree lhsaddr
, type
, rhs
, x
;
978 enum tree_code op
= ERROR_MARK
;
979 bool var_on_left
= false;
981 code
= code
->block
->next
;
982 gcc_assert (code
->op
== EXEC_ASSIGN
);
983 gcc_assert (code
->next
== NULL
);
984 var
= code
->expr1
->symtree
->n
.sym
;
986 gfc_init_se (&lse
, NULL
);
987 gfc_init_se (&rse
, NULL
);
988 gfc_start_block (&block
);
990 gfc_conv_expr (&lse
, code
->expr1
);
991 gfc_add_block_to_block (&block
, &lse
.pre
);
992 type
= TREE_TYPE (lse
.expr
);
993 lhsaddr
= gfc_build_addr_expr (NULL
, lse
.expr
);
996 if (expr2
->expr_type
== EXPR_FUNCTION
997 && expr2
->value
.function
.isym
->id
== GFC_ISYM_CONVERSION
)
998 expr2
= expr2
->value
.function
.actual
->expr
;
1000 if (expr2
->expr_type
== EXPR_OP
)
1003 switch (expr2
->value
.op
.op
)
1005 case INTRINSIC_PLUS
:
1008 case INTRINSIC_TIMES
:
1011 case INTRINSIC_MINUS
:
1014 case INTRINSIC_DIVIDE
:
1015 if (expr2
->ts
.type
== BT_INTEGER
)
1016 op
= TRUNC_DIV_EXPR
;
1021 op
= TRUTH_ANDIF_EXPR
;
1024 op
= TRUTH_ORIF_EXPR
;
1029 case INTRINSIC_NEQV
:
1035 e
= expr2
->value
.op
.op1
;
1036 if (e
->expr_type
== EXPR_FUNCTION
1037 && e
->value
.function
.isym
->id
== GFC_ISYM_CONVERSION
)
1038 e
= e
->value
.function
.actual
->expr
;
1039 if (e
->expr_type
== EXPR_VARIABLE
1040 && e
->symtree
!= NULL
1041 && e
->symtree
->n
.sym
== var
)
1043 expr2
= expr2
->value
.op
.op2
;
1048 e
= expr2
->value
.op
.op2
;
1049 if (e
->expr_type
== EXPR_FUNCTION
1050 && e
->value
.function
.isym
->id
== GFC_ISYM_CONVERSION
)
1051 e
= e
->value
.function
.actual
->expr
;
1052 gcc_assert (e
->expr_type
== EXPR_VARIABLE
1053 && e
->symtree
!= NULL
1054 && e
->symtree
->n
.sym
== var
);
1055 expr2
= expr2
->value
.op
.op1
;
1056 var_on_left
= false;
1058 gfc_conv_expr (&rse
, expr2
);
1059 gfc_add_block_to_block (&block
, &rse
.pre
);
1063 gcc_assert (expr2
->expr_type
== EXPR_FUNCTION
);
1064 switch (expr2
->value
.function
.isym
->id
)
1084 e
= expr2
->value
.function
.actual
->expr
;
1085 gcc_assert (e
->expr_type
== EXPR_VARIABLE
1086 && e
->symtree
!= NULL
1087 && e
->symtree
->n
.sym
== var
);
1089 gfc_conv_expr (&rse
, expr2
->value
.function
.actual
->next
->expr
);
1090 gfc_add_block_to_block (&block
, &rse
.pre
);
1091 if (expr2
->value
.function
.actual
->next
->next
!= NULL
)
1093 tree accum
= gfc_create_var (TREE_TYPE (rse
.expr
), NULL
);
1094 gfc_actual_arglist
*arg
;
1096 gfc_add_modify (&block
, accum
, rse
.expr
);
1097 for (arg
= expr2
->value
.function
.actual
->next
->next
; arg
;
1100 gfc_init_block (&rse
.pre
);
1101 gfc_conv_expr (&rse
, arg
->expr
);
1102 gfc_add_block_to_block (&block
, &rse
.pre
);
1103 x
= fold_build2 (op
, TREE_TYPE (accum
), accum
, rse
.expr
);
1104 gfc_add_modify (&block
, accum
, x
);
1110 expr2
= expr2
->value
.function
.actual
->next
->expr
;
1113 lhsaddr
= save_expr (lhsaddr
);
1114 rhs
= gfc_evaluate_now (rse
.expr
, &block
);
1115 x
= convert (TREE_TYPE (rhs
), build_fold_indirect_ref_loc (input_location
,
1119 x
= fold_build2 (op
, TREE_TYPE (rhs
), x
, rhs
);
1121 x
= fold_build2 (op
, TREE_TYPE (rhs
), rhs
, x
);
1123 if (TREE_CODE (TREE_TYPE (rhs
)) == COMPLEX_TYPE
1124 && TREE_CODE (type
) != COMPLEX_TYPE
)
1125 x
= fold_build1 (REALPART_EXPR
, TREE_TYPE (TREE_TYPE (rhs
)), x
);
1127 x
= build2_v (OMP_ATOMIC
, lhsaddr
, convert (type
, x
));
1128 gfc_add_expr_to_block (&block
, x
);
1130 gfc_add_block_to_block (&block
, &lse
.pre
);
1131 gfc_add_block_to_block (&block
, &rse
.pre
);
1133 return gfc_finish_block (&block
);
1137 gfc_trans_omp_barrier (void)
1139 tree decl
= built_in_decls
[BUILT_IN_GOMP_BARRIER
];
1140 return build_call_expr_loc (input_location
, decl
, 0);
1144 gfc_trans_omp_critical (gfc_code
*code
)
1146 tree name
= NULL_TREE
, stmt
;
1147 if (code
->ext
.omp_name
!= NULL
)
1148 name
= get_identifier (code
->ext
.omp_name
);
1149 stmt
= gfc_trans_code (code
->block
->next
);
1150 return build2 (OMP_CRITICAL
, void_type_node
, stmt
, name
);
1153 typedef struct dovar_init_d
{
1158 DEF_VEC_O(dovar_init
);
1159 DEF_VEC_ALLOC_O(dovar_init
,heap
);
1162 gfc_trans_omp_do (gfc_code
*code
, stmtblock_t
*pblock
,
1163 gfc_omp_clauses
*do_clauses
, tree par_clauses
)
1166 tree dovar
, stmt
, from
, to
, step
, type
, init
, cond
, incr
;
1167 tree count
= NULL_TREE
, cycle_label
, tmp
, omp_clauses
;
1170 gfc_omp_clauses
*clauses
= code
->ext
.omp_clauses
;
1171 int i
, collapse
= clauses
->collapse
;
1172 VEC(dovar_init
,heap
) *inits
= NULL
;
1179 code
= code
->block
->next
;
1180 gcc_assert (code
->op
== EXEC_DO
);
1182 init
= make_tree_vec (collapse
);
1183 cond
= make_tree_vec (collapse
);
1184 incr
= make_tree_vec (collapse
);
1188 gfc_start_block (&block
);
1192 omp_clauses
= gfc_trans_omp_clauses (pblock
, do_clauses
, code
->loc
);
1194 for (i
= 0; i
< collapse
; i
++)
1197 int dovar_found
= 0;
1203 for (n
= clauses
->lists
[OMP_LIST_LASTPRIVATE
]; n
!= NULL
;
1205 if (code
->ext
.iterator
->var
->symtree
->n
.sym
== n
->sym
)
1210 for (n
= clauses
->lists
[OMP_LIST_PRIVATE
]; n
!= NULL
; n
= n
->next
)
1211 if (code
->ext
.iterator
->var
->symtree
->n
.sym
== n
->sym
)
1217 /* Evaluate all the expressions in the iterator. */
1218 gfc_init_se (&se
, NULL
);
1219 gfc_conv_expr_lhs (&se
, code
->ext
.iterator
->var
);
1220 gfc_add_block_to_block (pblock
, &se
.pre
);
1222 type
= TREE_TYPE (dovar
);
1223 gcc_assert (TREE_CODE (type
) == INTEGER_TYPE
);
1225 gfc_init_se (&se
, NULL
);
1226 gfc_conv_expr_val (&se
, code
->ext
.iterator
->start
);
1227 gfc_add_block_to_block (pblock
, &se
.pre
);
1228 from
= gfc_evaluate_now (se
.expr
, pblock
);
1230 gfc_init_se (&se
, NULL
);
1231 gfc_conv_expr_val (&se
, code
->ext
.iterator
->end
);
1232 gfc_add_block_to_block (pblock
, &se
.pre
);
1233 to
= gfc_evaluate_now (se
.expr
, pblock
);
1235 gfc_init_se (&se
, NULL
);
1236 gfc_conv_expr_val (&se
, code
->ext
.iterator
->step
);
1237 gfc_add_block_to_block (pblock
, &se
.pre
);
1238 step
= gfc_evaluate_now (se
.expr
, pblock
);
1241 /* Special case simple loops. */
1242 if (TREE_CODE (dovar
) == VAR_DECL
)
1244 if (integer_onep (step
))
1246 else if (tree_int_cst_equal (step
, integer_minus_one_node
))
1251 = gfc_trans_omp_variable (code
->ext
.iterator
->var
->symtree
->n
.sym
);
1256 TREE_VEC_ELT (init
, i
) = build2_v (MODIFY_EXPR
, dovar
, from
);
1257 TREE_VEC_ELT (cond
, i
) = fold_build2 (simple
> 0 ? LE_EXPR
: GE_EXPR
,
1258 boolean_type_node
, dovar
, to
);
1259 TREE_VEC_ELT (incr
, i
) = fold_build2 (PLUS_EXPR
, type
, dovar
, step
);
1260 TREE_VEC_ELT (incr
, i
) = fold_build2 (MODIFY_EXPR
, type
, dovar
,
1261 TREE_VEC_ELT (incr
, i
));
1265 /* STEP is not 1 or -1. Use:
1266 for (count = 0; count < (to + step - from) / step; count++)
1268 dovar = from + count * step;
1272 tmp
= fold_build2 (MINUS_EXPR
, type
, step
, from
);
1273 tmp
= fold_build2 (PLUS_EXPR
, type
, to
, tmp
);
1274 tmp
= fold_build2 (TRUNC_DIV_EXPR
, type
, tmp
, step
);
1275 tmp
= gfc_evaluate_now (tmp
, pblock
);
1276 count
= gfc_create_var (type
, "count");
1277 TREE_VEC_ELT (init
, i
) = build2_v (MODIFY_EXPR
, count
,
1278 build_int_cst (type
, 0));
1279 TREE_VEC_ELT (cond
, i
) = fold_build2 (LT_EXPR
, boolean_type_node
,
1281 TREE_VEC_ELT (incr
, i
) = fold_build2 (PLUS_EXPR
, type
, count
,
1282 build_int_cst (type
, 1));
1283 TREE_VEC_ELT (incr
, i
) = fold_build2 (MODIFY_EXPR
, type
,
1284 count
, TREE_VEC_ELT (incr
, i
));
1286 /* Initialize DOVAR. */
1287 tmp
= fold_build2 (MULT_EXPR
, type
, count
, step
);
1288 tmp
= fold_build2 (PLUS_EXPR
, type
, from
, tmp
);
1289 di
= VEC_safe_push (dovar_init
, heap
, inits
, NULL
);
1296 tmp
= build_omp_clause (input_location
, OMP_CLAUSE_PRIVATE
);
1297 OMP_CLAUSE_DECL (tmp
) = dovar_decl
;
1298 omp_clauses
= gfc_trans_add_clause (tmp
, omp_clauses
);
1300 else if (dovar_found
== 2)
1307 /* If dovar is lastprivate, but different counter is used,
1308 dovar += step needs to be added to
1309 OMP_CLAUSE_LASTPRIVATE_STMT, otherwise the copied dovar
1310 will have the value on entry of the last loop, rather
1311 than value after iterator increment. */
1312 tmp
= gfc_evaluate_now (step
, pblock
);
1313 tmp
= fold_build2 (PLUS_EXPR
, type
, dovar
, tmp
);
1314 tmp
= fold_build2 (MODIFY_EXPR
, type
, dovar
, tmp
);
1315 for (c
= omp_clauses
; c
; c
= OMP_CLAUSE_CHAIN (c
))
1316 if (OMP_CLAUSE_CODE (c
) == OMP_CLAUSE_LASTPRIVATE
1317 && OMP_CLAUSE_DECL (c
) == dovar_decl
)
1319 OMP_CLAUSE_LASTPRIVATE_STMT (c
) = tmp
;
1323 if (c
== NULL
&& par_clauses
!= NULL
)
1325 for (c
= par_clauses
; c
; c
= OMP_CLAUSE_CHAIN (c
))
1326 if (OMP_CLAUSE_CODE (c
) == OMP_CLAUSE_LASTPRIVATE
1327 && OMP_CLAUSE_DECL (c
) == dovar_decl
)
1329 tree l
= build_omp_clause (input_location
,
1330 OMP_CLAUSE_LASTPRIVATE
);
1331 OMP_CLAUSE_DECL (l
) = dovar_decl
;
1332 OMP_CLAUSE_CHAIN (l
) = omp_clauses
;
1333 OMP_CLAUSE_LASTPRIVATE_STMT (l
) = tmp
;
1335 OMP_CLAUSE_SET_CODE (c
, OMP_CLAUSE_SHARED
);
1339 gcc_assert (simple
|| c
!= NULL
);
1343 tmp
= build_omp_clause (input_location
, OMP_CLAUSE_PRIVATE
);
1344 OMP_CLAUSE_DECL (tmp
) = count
;
1345 omp_clauses
= gfc_trans_add_clause (tmp
, omp_clauses
);
1348 if (i
+ 1 < collapse
)
1349 code
= code
->block
->next
;
1352 if (pblock
!= &block
)
1355 gfc_start_block (&block
);
1358 gfc_start_block (&body
);
1360 for (ix
= 0; VEC_iterate (dovar_init
, inits
, ix
, di
); ix
++)
1361 gfc_add_modify (&body
, di
->var
, di
->init
);
1362 VEC_free (dovar_init
, heap
, inits
);
1364 /* Cycle statement is implemented with a goto. Exit statement must not be
1365 present for this loop. */
1366 cycle_label
= gfc_build_label_decl (NULL_TREE
);
1368 /* Put these labels where they can be found later. */
1370 code
->block
->cycle_label
= cycle_label
;
1371 code
->block
->exit_label
= NULL_TREE
;
1373 /* Main loop body. */
1374 tmp
= gfc_trans_omp_code (code
->block
->next
, true);
1375 gfc_add_expr_to_block (&body
, tmp
);
1377 /* Label for cycle statements (if needed). */
1378 if (TREE_USED (cycle_label
))
1380 tmp
= build1_v (LABEL_EXPR
, cycle_label
);
1381 gfc_add_expr_to_block (&body
, tmp
);
1384 /* End of loop body. */
1385 stmt
= make_node (OMP_FOR
);
1387 TREE_TYPE (stmt
) = void_type_node
;
1388 OMP_FOR_BODY (stmt
) = gfc_finish_block (&body
);
1389 OMP_FOR_CLAUSES (stmt
) = omp_clauses
;
1390 OMP_FOR_INIT (stmt
) = init
;
1391 OMP_FOR_COND (stmt
) = cond
;
1392 OMP_FOR_INCR (stmt
) = incr
;
1393 gfc_add_expr_to_block (&block
, stmt
);
1395 return gfc_finish_block (&block
);
1399 gfc_trans_omp_flush (void)
1401 tree decl
= built_in_decls
[BUILT_IN_SYNCHRONIZE
];
1402 return build_call_expr_loc (input_location
, decl
, 0);
1406 gfc_trans_omp_master (gfc_code
*code
)
1408 tree stmt
= gfc_trans_code (code
->block
->next
);
1409 if (IS_EMPTY_STMT (stmt
))
1411 return build1_v (OMP_MASTER
, stmt
);
1415 gfc_trans_omp_ordered (gfc_code
*code
)
1417 return build1_v (OMP_ORDERED
, gfc_trans_code (code
->block
->next
));
1421 gfc_trans_omp_parallel (gfc_code
*code
)
1424 tree stmt
, omp_clauses
;
1426 gfc_start_block (&block
);
1427 omp_clauses
= gfc_trans_omp_clauses (&block
, code
->ext
.omp_clauses
,
1429 stmt
= gfc_trans_omp_code (code
->block
->next
, true);
1430 stmt
= build2 (OMP_PARALLEL
, void_type_node
, stmt
, omp_clauses
);
1431 gfc_add_expr_to_block (&block
, stmt
);
1432 return gfc_finish_block (&block
);
1436 gfc_trans_omp_parallel_do (gfc_code
*code
)
1438 stmtblock_t block
, *pblock
= NULL
;
1439 gfc_omp_clauses parallel_clauses
, do_clauses
;
1440 tree stmt
, omp_clauses
= NULL_TREE
;
1442 gfc_start_block (&block
);
1444 memset (&do_clauses
, 0, sizeof (do_clauses
));
1445 if (code
->ext
.omp_clauses
!= NULL
)
1447 memcpy (¶llel_clauses
, code
->ext
.omp_clauses
,
1448 sizeof (parallel_clauses
));
1449 do_clauses
.sched_kind
= parallel_clauses
.sched_kind
;
1450 do_clauses
.chunk_size
= parallel_clauses
.chunk_size
;
1451 do_clauses
.ordered
= parallel_clauses
.ordered
;
1452 do_clauses
.collapse
= parallel_clauses
.collapse
;
1453 parallel_clauses
.sched_kind
= OMP_SCHED_NONE
;
1454 parallel_clauses
.chunk_size
= NULL
;
1455 parallel_clauses
.ordered
= false;
1456 parallel_clauses
.collapse
= 0;
1457 omp_clauses
= gfc_trans_omp_clauses (&block
, ¶llel_clauses
,
1460 do_clauses
.nowait
= true;
1461 if (!do_clauses
.ordered
&& do_clauses
.sched_kind
!= OMP_SCHED_STATIC
)
1465 stmt
= gfc_trans_omp_do (code
, pblock
, &do_clauses
, omp_clauses
);
1466 if (TREE_CODE (stmt
) != BIND_EXPR
)
1467 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0, 0));
1470 stmt
= build2 (OMP_PARALLEL
, void_type_node
, stmt
, omp_clauses
);
1471 OMP_PARALLEL_COMBINED (stmt
) = 1;
1472 gfc_add_expr_to_block (&block
, stmt
);
1473 return gfc_finish_block (&block
);
1477 gfc_trans_omp_parallel_sections (gfc_code
*code
)
1480 gfc_omp_clauses section_clauses
;
1481 tree stmt
, omp_clauses
;
1483 memset (§ion_clauses
, 0, sizeof (section_clauses
));
1484 section_clauses
.nowait
= true;
1486 gfc_start_block (&block
);
1487 omp_clauses
= gfc_trans_omp_clauses (&block
, code
->ext
.omp_clauses
,
1490 stmt
= gfc_trans_omp_sections (code
, §ion_clauses
);
1491 if (TREE_CODE (stmt
) != BIND_EXPR
)
1492 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0, 0));
1495 stmt
= build2 (OMP_PARALLEL
, void_type_node
, stmt
, omp_clauses
);
1496 OMP_PARALLEL_COMBINED (stmt
) = 1;
1497 gfc_add_expr_to_block (&block
, stmt
);
1498 return gfc_finish_block (&block
);
1502 gfc_trans_omp_parallel_workshare (gfc_code
*code
)
1505 gfc_omp_clauses workshare_clauses
;
1506 tree stmt
, omp_clauses
;
1508 memset (&workshare_clauses
, 0, sizeof (workshare_clauses
));
1509 workshare_clauses
.nowait
= true;
1511 gfc_start_block (&block
);
1512 omp_clauses
= gfc_trans_omp_clauses (&block
, code
->ext
.omp_clauses
,
1515 stmt
= gfc_trans_omp_workshare (code
, &workshare_clauses
);
1516 if (TREE_CODE (stmt
) != BIND_EXPR
)
1517 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0, 0));
1520 stmt
= build2 (OMP_PARALLEL
, void_type_node
, stmt
, omp_clauses
);
1521 OMP_PARALLEL_COMBINED (stmt
) = 1;
1522 gfc_add_expr_to_block (&block
, stmt
);
1523 return gfc_finish_block (&block
);
1527 gfc_trans_omp_sections (gfc_code
*code
, gfc_omp_clauses
*clauses
)
1529 stmtblock_t block
, body
;
1530 tree omp_clauses
, stmt
;
1531 bool has_lastprivate
= clauses
->lists
[OMP_LIST_LASTPRIVATE
] != NULL
;
1533 gfc_start_block (&block
);
1535 omp_clauses
= gfc_trans_omp_clauses (&block
, clauses
, code
->loc
);
1537 gfc_init_block (&body
);
1538 for (code
= code
->block
; code
; code
= code
->block
)
1540 /* Last section is special because of lastprivate, so even if it
1541 is empty, chain it in. */
1542 stmt
= gfc_trans_omp_code (code
->next
,
1543 has_lastprivate
&& code
->block
== NULL
);
1544 if (! IS_EMPTY_STMT (stmt
))
1546 stmt
= build1_v (OMP_SECTION
, stmt
);
1547 gfc_add_expr_to_block (&body
, stmt
);
1550 stmt
= gfc_finish_block (&body
);
1552 stmt
= build2 (OMP_SECTIONS
, void_type_node
, stmt
, omp_clauses
);
1553 gfc_add_expr_to_block (&block
, stmt
);
1555 return gfc_finish_block (&block
);
1559 gfc_trans_omp_single (gfc_code
*code
, gfc_omp_clauses
*clauses
)
1561 tree omp_clauses
= gfc_trans_omp_clauses (NULL
, clauses
, code
->loc
);
1562 tree stmt
= gfc_trans_omp_code (code
->block
->next
, true);
1563 stmt
= build2 (OMP_SINGLE
, void_type_node
, stmt
, omp_clauses
);
1568 gfc_trans_omp_task (gfc_code
*code
)
1571 tree stmt
, omp_clauses
;
1573 gfc_start_block (&block
);
1574 omp_clauses
= gfc_trans_omp_clauses (&block
, code
->ext
.omp_clauses
,
1576 stmt
= gfc_trans_omp_code (code
->block
->next
, true);
1577 stmt
= build2 (OMP_TASK
, void_type_node
, stmt
, omp_clauses
);
1578 gfc_add_expr_to_block (&block
, stmt
);
1579 return gfc_finish_block (&block
);
1583 gfc_trans_omp_taskwait (void)
1585 tree decl
= built_in_decls
[BUILT_IN_GOMP_TASKWAIT
];
1586 return build_call_expr_loc (input_location
, decl
, 0);
1590 gfc_trans_omp_workshare (gfc_code
*code
, gfc_omp_clauses
*clauses
)
1592 tree res
, tmp
, stmt
;
1593 stmtblock_t block
, *pblock
= NULL
;
1594 stmtblock_t singleblock
;
1595 int saved_ompws_flags
;
1596 bool singleblock_in_progress
= false;
1597 /* True if previous gfc_code in workshare construct is not workshared. */
1598 bool prev_singleunit
;
1600 code
= code
->block
->next
;
1605 return build_empty_stmt (input_location
);
1607 gfc_start_block (&block
);
1610 ompws_flags
= OMPWS_WORKSHARE_FLAG
;
1611 prev_singleunit
= false;
1613 /* Translate statements one by one to trees until we reach
1614 the end of the workshare construct. Adjacent gfc_codes that
1615 are a single unit of work are clustered and encapsulated in a
1616 single OMP_SINGLE construct. */
1617 for (; code
; code
= code
->next
)
1619 if (code
->here
!= 0)
1621 res
= gfc_trans_label_here (code
);
1622 gfc_add_expr_to_block (pblock
, res
);
1625 /* No dependence analysis, use for clauses with wait.
1626 If this is the last gfc_code, use default omp_clauses. */
1627 if (code
->next
== NULL
&& clauses
->nowait
)
1628 ompws_flags
|= OMPWS_NOWAIT
;
1630 /* By default, every gfc_code is a single unit of work. */
1631 ompws_flags
|= OMPWS_CURR_SINGLEUNIT
;
1632 ompws_flags
&= ~OMPWS_SCALARIZER_WS
;
1641 res
= gfc_trans_assign (code
);
1644 case EXEC_POINTER_ASSIGN
:
1645 res
= gfc_trans_pointer_assign (code
);
1648 case EXEC_INIT_ASSIGN
:
1649 res
= gfc_trans_init_assign (code
);
1653 res
= gfc_trans_forall (code
);
1657 res
= gfc_trans_where (code
);
1660 case EXEC_OMP_ATOMIC
:
1661 res
= gfc_trans_omp_directive (code
);
1664 case EXEC_OMP_PARALLEL
:
1665 case EXEC_OMP_PARALLEL_DO
:
1666 case EXEC_OMP_PARALLEL_SECTIONS
:
1667 case EXEC_OMP_PARALLEL_WORKSHARE
:
1668 case EXEC_OMP_CRITICAL
:
1669 saved_ompws_flags
= ompws_flags
;
1671 res
= gfc_trans_omp_directive (code
);
1672 ompws_flags
= saved_ompws_flags
;
1676 internal_error ("gfc_trans_omp_workshare(): Bad statement code");
1679 gfc_set_backend_locus (&code
->loc
);
1681 if (res
!= NULL_TREE
&& ! IS_EMPTY_STMT (res
))
1683 if (prev_singleunit
)
1685 if (ompws_flags
& OMPWS_CURR_SINGLEUNIT
)
1686 /* Add current gfc_code to single block. */
1687 gfc_add_expr_to_block (&singleblock
, res
);
1690 /* Finish single block and add it to pblock. */
1691 tmp
= gfc_finish_block (&singleblock
);
1692 tmp
= build2 (OMP_SINGLE
, void_type_node
, tmp
, NULL_TREE
);
1693 gfc_add_expr_to_block (pblock
, tmp
);
1694 /* Add current gfc_code to pblock. */
1695 gfc_add_expr_to_block (pblock
, res
);
1696 singleblock_in_progress
= false;
1701 if (ompws_flags
& OMPWS_CURR_SINGLEUNIT
)
1703 /* Start single block. */
1704 gfc_init_block (&singleblock
);
1705 gfc_add_expr_to_block (&singleblock
, res
);
1706 singleblock_in_progress
= true;
1709 /* Add the new statement to the block. */
1710 gfc_add_expr_to_block (pblock
, res
);
1712 prev_singleunit
= (ompws_flags
& OMPWS_CURR_SINGLEUNIT
) != 0;
1716 /* Finish remaining SINGLE block, if we were in the middle of one. */
1717 if (singleblock_in_progress
)
1719 /* Finish single block and add it to pblock. */
1720 tmp
= gfc_finish_block (&singleblock
);
1721 tmp
= build2 (OMP_SINGLE
, void_type_node
, tmp
,
1723 ? build_omp_clause (input_location
, OMP_CLAUSE_NOWAIT
)
1725 gfc_add_expr_to_block (pblock
, tmp
);
1728 stmt
= gfc_finish_block (pblock
);
1729 if (TREE_CODE (stmt
) != BIND_EXPR
)
1731 if (!IS_EMPTY_STMT (stmt
))
1733 tree bindblock
= poplevel (1, 0, 0);
1734 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, bindblock
);
1747 gfc_trans_omp_directive (gfc_code
*code
)
1751 case EXEC_OMP_ATOMIC
:
1752 return gfc_trans_omp_atomic (code
);
1753 case EXEC_OMP_BARRIER
:
1754 return gfc_trans_omp_barrier ();
1755 case EXEC_OMP_CRITICAL
:
1756 return gfc_trans_omp_critical (code
);
1758 return gfc_trans_omp_do (code
, NULL
, code
->ext
.omp_clauses
, NULL
);
1759 case EXEC_OMP_FLUSH
:
1760 return gfc_trans_omp_flush ();
1761 case EXEC_OMP_MASTER
:
1762 return gfc_trans_omp_master (code
);
1763 case EXEC_OMP_ORDERED
:
1764 return gfc_trans_omp_ordered (code
);
1765 case EXEC_OMP_PARALLEL
:
1766 return gfc_trans_omp_parallel (code
);
1767 case EXEC_OMP_PARALLEL_DO
:
1768 return gfc_trans_omp_parallel_do (code
);
1769 case EXEC_OMP_PARALLEL_SECTIONS
:
1770 return gfc_trans_omp_parallel_sections (code
);
1771 case EXEC_OMP_PARALLEL_WORKSHARE
:
1772 return gfc_trans_omp_parallel_workshare (code
);
1773 case EXEC_OMP_SECTIONS
:
1774 return gfc_trans_omp_sections (code
, code
->ext
.omp_clauses
);
1775 case EXEC_OMP_SINGLE
:
1776 return gfc_trans_omp_single (code
, code
->ext
.omp_clauses
);
1778 return gfc_trans_omp_task (code
);
1779 case EXEC_OMP_TASKWAIT
:
1780 return gfc_trans_omp_taskwait ();
1781 case EXEC_OMP_WORKSHARE
:
1782 return gfc_trans_omp_workshare (code
, code
->ext
.omp_clauses
);