1 /* OpenMP directive translation -- generate GCC trees from gfc_code.
2 Copyright (C) 2005, 2006, 2007, 2008, 2009, 2010, 2011
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_loc (input_location, MINUS_EXPR, gfc_array_index_type,
180 size, gfc_conv_descriptor_lbound_get (decl, rank));
181 size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
182 size, gfc_index_one_node);
183 if (GFC_TYPE_ARRAY_RANK (type) > 1)
184 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
185 size, 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_loc (input_location, MULT_EXPR, gfc_array_index_type,
190 size = gfc_evaluate_now (fold_convert (size_type_node, size), &cond_block);
191 ptr = gfc_allocate_allocatable_with_status (&cond_block,
192 build_int_cst (pvoid_type_node, 0),
194 gfc_conv_descriptor_data_set (&cond_block, decl, ptr);
195 then_b = gfc_finish_block (&cond_block);
197 gfc_init_block (&cond_block);
198 gfc_conv_descriptor_data_set (&cond_block, decl, null_pointer_node);
199 else_b = gfc_finish_block (&cond_block);
201 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
202 fold_convert (pvoid_type_node,
203 gfc_conv_descriptor_data_get (outer)),
205 gfc_add_expr_to_block (&block, build3_loc (input_location, COND_EXPR,
206 void_type_node, cond, then_b, else_b));
208 return gfc_finish_block (&block);
211 /* Build and return code for a copy constructor from SRC to DEST. */
214 gfc_omp_clause_copy_ctor (tree clause, tree dest, tree src)
216 tree type = TREE_TYPE (dest), ptr, size, esize, rank, call;
219 if (! GFC_DESCRIPTOR_TYPE_P (type)
220 || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
221 return build2_v (MODIFY_EXPR, dest, src);
223 gcc_assert (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_FIRSTPRIVATE);
225 /* Allocatable arrays in FIRSTPRIVATE clauses need to be allocated
226 and copied from SRC. */
227 gfc_start_block (&block);
229 gfc_add_modify (&block, dest, src);
230 rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1];
231 size = gfc_conv_descriptor_ubound_get (dest, rank);
232 size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
233 size, gfc_conv_descriptor_lbound_get (dest, rank));
234 size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
235 size, gfc_index_one_node);
236 if (GFC_TYPE_ARRAY_RANK (type) > 1)
237 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
238 size, gfc_conv_descriptor_stride_get (dest, rank));
239 esize = fold_convert (gfc_array_index_type,
240 TYPE_SIZE_UNIT (gfc_get_element_type (type)));
241 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
243 size = gfc_evaluate_now (fold_convert (size_type_node, size), &block);
244 ptr = gfc_allocate_allocatable_with_status (&block,
245 build_int_cst (pvoid_type_node, 0),
247 gfc_conv_descriptor_data_set (&block, dest, ptr);
248 call = build_call_expr_loc (input_location,
249 built_in_decls[BUILT_IN_MEMCPY], 3, ptr,
250 fold_convert (pvoid_type_node,
251 gfc_conv_descriptor_data_get (src)),
253 gfc_add_expr_to_block (&block, fold_convert (void_type_node, call));
255 return gfc_finish_block (&block);
258 /* Similarly, except use an assignment operator instead. */
261 gfc_omp_clause_assign_op (tree clause ATTRIBUTE_UNUSED, tree dest, tree src)
263 tree type = TREE_TYPE (dest), rank, size, esize, call;
266 if (! GFC_DESCRIPTOR_TYPE_P (type)
267 || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
268 return build2_v (MODIFY_EXPR, dest, src);
270 /* Handle copying allocatable arrays. */
271 gfc_start_block (&block);
273 rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1];
274 size = gfc_conv_descriptor_ubound_get (dest, rank);
275 size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
276 size, gfc_conv_descriptor_lbound_get (dest, rank));
277 size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
278 size, gfc_index_one_node);
279 if (GFC_TYPE_ARRAY_RANK (type) > 1)
280 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
281 size, gfc_conv_descriptor_stride_get (dest, rank));
282 esize = fold_convert (gfc_array_index_type,
283 TYPE_SIZE_UNIT (gfc_get_element_type (type)));
284 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
286 size = gfc_evaluate_now (fold_convert (size_type_node, size), &block);
287 call = build_call_expr_loc (input_location,
288 built_in_decls[BUILT_IN_MEMCPY], 3,
289 fold_convert (pvoid_type_node,
290 gfc_conv_descriptor_data_get (dest)),
291 fold_convert (pvoid_type_node,
292 gfc_conv_descriptor_data_get (src)),
294 gfc_add_expr_to_block (&block, fold_convert (void_type_node, call));
296 return gfc_finish_block (&block);
299 /* Build and return code destructing DECL. Return NULL if nothing
303 gfc_omp_clause_dtor (tree clause ATTRIBUTE_UNUSED, tree decl)
305 tree type = TREE_TYPE (decl);
307 if (! GFC_DESCRIPTOR_TYPE_P (type)
308 || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
311 /* Allocatable arrays in FIRSTPRIVATE/LASTPRIVATE etc. clauses need
312 to be deallocated if they were allocated. */
313 return gfc_trans_dealloc_allocated (decl);
317 /* Return true if DECL's DECL_VALUE_EXPR (if any) should be
318 disregarded in OpenMP construct, because it is going to be
319 remapped during OpenMP lowering. SHARED is true if DECL
320 is going to be shared, false if it is going to be privatized. */
323 gfc_omp_disregard_value_expr (tree decl, bool shared)
325 if (GFC_DECL_COMMON_OR_EQUIV (decl)
326 && DECL_HAS_VALUE_EXPR_P (decl))
328 tree value = DECL_VALUE_EXPR (decl);
330 if (TREE_CODE (value) == COMPONENT_REF
331 && TREE_CODE (TREE_OPERAND (value, 0)) == VAR_DECL
332 && GFC_DECL_COMMON_OR_EQUIV (TREE_OPERAND (value, 0)))
334 /* If variable in COMMON or EQUIVALENCE is privatized, return
335 true, as just that variable is supposed to be privatized,
336 not the whole COMMON or whole EQUIVALENCE.
337 For shared variables in COMMON or EQUIVALENCE, let them be
338 gimplified to DECL_VALUE_EXPR, so that for multiple shared vars
339 from the same COMMON or EQUIVALENCE just one sharing of the
340 whole COMMON or EQUIVALENCE is enough. */
345 if (GFC_DECL_RESULT (decl) && DECL_HAS_VALUE_EXPR_P (decl))
351 /* Return true if DECL that is shared iff SHARED is true should
352 be put into OMP_CLAUSE_PRIVATE with OMP_CLAUSE_PRIVATE_DEBUG
356 gfc_omp_private_debug_clause (tree decl, bool shared)
358 if (GFC_DECL_CRAY_POINTEE (decl))
361 if (GFC_DECL_COMMON_OR_EQUIV (decl)
362 && DECL_HAS_VALUE_EXPR_P (decl))
364 tree value = DECL_VALUE_EXPR (decl);
366 if (TREE_CODE (value) == COMPONENT_REF
367 && TREE_CODE (TREE_OPERAND (value, 0)) == VAR_DECL
368 && GFC_DECL_COMMON_OR_EQUIV (TREE_OPERAND (value, 0)))
375 /* Register language specific type size variables as potentially OpenMP
376 firstprivate variables. */
379 gfc_omp_firstprivatize_type_sizes (struct gimplify_omp_ctx *ctx, tree type)
381 if (GFC_ARRAY_TYPE_P (type) || GFC_DESCRIPTOR_TYPE_P (type))
385 gcc_assert (TYPE_LANG_SPECIFIC (type) != NULL);
386 for (r = 0; r < GFC_TYPE_ARRAY_RANK (type); r++)
388 omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_LBOUND (type, r));
389 omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_UBOUND (type, r));
390 omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_STRIDE (type, r));
392 omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_SIZE (type));
393 omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_OFFSET (type));
399 gfc_trans_add_clause (tree node, tree tail)
401 OMP_CLAUSE_CHAIN (node) = tail;
406 gfc_trans_omp_variable (gfc_symbol *sym)
408 tree t = gfc_get_symbol_decl (sym);
412 bool alternate_entry;
415 return_value = sym->attr.function && sym->result == sym;
416 alternate_entry = sym->attr.function && sym->attr.entry
417 && sym->result == sym;
418 entry_master = sym->attr.result
419 && sym->ns->proc_name->attr.entry_master
420 && !gfc_return_by_reference (sym->ns->proc_name);
421 parent_decl = DECL_CONTEXT (current_function_decl);
423 if ((t == parent_decl && return_value)
424 || (sym->ns && sym->ns->proc_name
425 && sym->ns->proc_name->backend_decl == parent_decl
426 && (alternate_entry || entry_master)))
431 /* Special case for assigning the return value of a function.
432 Self recursive functions must have an explicit return value. */
433 if (return_value && (t == current_function_decl || parent_flag))
434 t = gfc_get_fake_result_decl (sym, parent_flag);
436 /* Similarly for alternate entry points. */
437 else if (alternate_entry
438 && (sym->ns->proc_name->backend_decl == current_function_decl
441 gfc_entry_list *el = NULL;
443 for (el = sym->ns->entries; el; el = el->next)
446 t = gfc_get_fake_result_decl (sym, parent_flag);
451 else if (entry_master
452 && (sym->ns->proc_name->backend_decl == current_function_decl
454 t = gfc_get_fake_result_decl (sym, parent_flag);
460 gfc_trans_omp_variable_list (enum omp_clause_code code, gfc_namelist *namelist,
463 for (; namelist != NULL; namelist = namelist->next)
464 if (namelist->sym->attr.referenced)
466 tree t = gfc_trans_omp_variable (namelist->sym);
467 if (t != error_mark_node)
469 tree node = build_omp_clause (input_location, code);
470 OMP_CLAUSE_DECL (node) = t;
471 list = gfc_trans_add_clause (node, list);
478 gfc_trans_omp_array_reduction (tree c, gfc_symbol *sym, locus where)
480 gfc_symtree *root1 = NULL, *root2 = NULL, *root3 = NULL, *root4 = NULL;
481 gfc_symtree *symtree1, *symtree2, *symtree3, *symtree4 = NULL;
482 gfc_symbol init_val_sym, outer_sym, intrinsic_sym;
483 gfc_expr *e1, *e2, *e3, *e4;
485 tree decl, backend_decl, stmt, type, outer_decl;
486 locus old_loc = gfc_current_locus;
490 decl = OMP_CLAUSE_DECL (c);
491 gfc_current_locus = where;
492 type = TREE_TYPE (decl);
493 outer_decl = create_tmp_var_raw (type, NULL);
494 if (TREE_CODE (decl) == PARM_DECL
495 && TREE_CODE (type) == REFERENCE_TYPE
496 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type))
497 && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (type)) == GFC_ARRAY_ALLOCATABLE)
499 decl = build_fold_indirect_ref (decl);
500 type = TREE_TYPE (type);
503 /* Create a fake symbol for init value. */
504 memset (&init_val_sym, 0, sizeof (init_val_sym));
505 init_val_sym.ns = sym->ns;
506 init_val_sym.name = sym->name;
507 init_val_sym.ts = sym->ts;
508 init_val_sym.attr.referenced = 1;
509 init_val_sym.declared_at = where;
510 init_val_sym.attr.flavor = FL_VARIABLE;
511 backend_decl = omp_reduction_init (c, gfc_sym_type (&init_val_sym));
512 init_val_sym.backend_decl = backend_decl;
514 /* Create a fake symbol for the outer array reference. */
516 outer_sym.as = gfc_copy_array_spec (sym->as);
517 outer_sym.attr.dummy = 0;
518 outer_sym.attr.result = 0;
519 outer_sym.attr.flavor = FL_VARIABLE;
520 outer_sym.backend_decl = outer_decl;
521 if (decl != OMP_CLAUSE_DECL (c))
522 outer_sym.backend_decl = build_fold_indirect_ref (outer_decl);
524 /* Create fake symtrees for it. */
525 symtree1 = gfc_new_symtree (&root1, sym->name);
526 symtree1->n.sym = sym;
527 gcc_assert (symtree1 == root1);
529 symtree2 = gfc_new_symtree (&root2, sym->name);
530 symtree2->n.sym = &init_val_sym;
531 gcc_assert (symtree2 == root2);
533 symtree3 = gfc_new_symtree (&root3, sym->name);
534 symtree3->n.sym = &outer_sym;
535 gcc_assert (symtree3 == root3);
537 /* Create expressions. */
538 e1 = gfc_get_expr ();
539 e1->expr_type = EXPR_VARIABLE;
541 e1->symtree = symtree1;
543 e1->ref = ref = gfc_get_ref ();
544 ref->type = REF_ARRAY;
545 ref->u.ar.where = where;
546 ref->u.ar.as = sym->as;
547 ref->u.ar.type = AR_FULL;
549 t = gfc_resolve_expr (e1);
550 gcc_assert (t == SUCCESS);
552 e2 = gfc_get_expr ();
553 e2->expr_type = EXPR_VARIABLE;
555 e2->symtree = symtree2;
557 t = gfc_resolve_expr (e2);
558 gcc_assert (t == SUCCESS);
560 e3 = gfc_copy_expr (e1);
561 e3->symtree = symtree3;
562 t = gfc_resolve_expr (e3);
563 gcc_assert (t == SUCCESS);
566 switch (OMP_CLAUSE_REDUCTION_CODE (c))
570 e4 = gfc_add (e3, e1);
573 e4 = gfc_multiply (e3, e1);
575 case TRUTH_ANDIF_EXPR:
576 e4 = gfc_and (e3, e1);
578 case TRUTH_ORIF_EXPR:
579 e4 = gfc_or (e3, e1);
582 e4 = gfc_eqv (e3, e1);
585 e4 = gfc_neqv (e3, e1);
607 memset (&intrinsic_sym, 0, sizeof (intrinsic_sym));
608 intrinsic_sym.ns = sym->ns;
609 intrinsic_sym.name = iname;
610 intrinsic_sym.ts = sym->ts;
611 intrinsic_sym.attr.referenced = 1;
612 intrinsic_sym.attr.intrinsic = 1;
613 intrinsic_sym.attr.function = 1;
614 intrinsic_sym.result = &intrinsic_sym;
615 intrinsic_sym.declared_at = where;
617 symtree4 = gfc_new_symtree (&root4, iname);
618 symtree4->n.sym = &intrinsic_sym;
619 gcc_assert (symtree4 == root4);
621 e4 = gfc_get_expr ();
622 e4->expr_type = EXPR_FUNCTION;
624 e4->symtree = symtree4;
625 e4->value.function.isym = gfc_find_function (iname);
626 e4->value.function.actual = gfc_get_actual_arglist ();
627 e4->value.function.actual->expr = e3;
628 e4->value.function.actual->next = gfc_get_actual_arglist ();
629 e4->value.function.actual->next->expr = e1;
631 /* e1 and e3 have been stored as arguments of e4, avoid sharing. */
632 e1 = gfc_copy_expr (e1);
633 e3 = gfc_copy_expr (e3);
634 t = gfc_resolve_expr (e4);
635 gcc_assert (t == SUCCESS);
637 /* Create the init statement list. */
639 if (GFC_DESCRIPTOR_TYPE_P (type)
640 && GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE)
642 /* If decl is an allocatable array, it needs to be allocated
643 with the same bounds as the outer var. */
644 tree rank, size, esize, ptr;
647 gfc_start_block (&block);
649 gfc_add_modify (&block, decl, outer_sym.backend_decl);
650 rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1];
651 size = gfc_conv_descriptor_ubound_get (decl, rank);
652 size = fold_build2_loc (input_location, MINUS_EXPR,
653 gfc_array_index_type, size,
654 gfc_conv_descriptor_lbound_get (decl, rank));
655 size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
656 size, gfc_index_one_node);
657 if (GFC_TYPE_ARRAY_RANK (type) > 1)
658 size = fold_build2_loc (input_location, MULT_EXPR,
659 gfc_array_index_type, size,
660 gfc_conv_descriptor_stride_get (decl, rank));
661 esize = fold_convert (gfc_array_index_type,
662 TYPE_SIZE_UNIT (gfc_get_element_type (type)));
663 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
665 size = gfc_evaluate_now (fold_convert (size_type_node, size), &block);
666 ptr = gfc_allocate_allocatable_with_status (&block,
667 build_int_cst (pvoid_type_node, 0),
669 gfc_conv_descriptor_data_set (&block, decl, ptr);
670 gfc_add_expr_to_block (&block, gfc_trans_assignment (e1, e2, false,
672 stmt = gfc_finish_block (&block);
675 stmt = gfc_trans_assignment (e1, e2, false, false);
676 if (TREE_CODE (stmt) != BIND_EXPR)
677 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0));
680 OMP_CLAUSE_REDUCTION_INIT (c) = stmt;
682 /* Create the merge statement list. */
684 if (GFC_DESCRIPTOR_TYPE_P (type)
685 && GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE)
687 /* If decl is an allocatable array, it needs to be deallocated
691 gfc_start_block (&block);
692 gfc_add_expr_to_block (&block, gfc_trans_assignment (e3, e4, false,
694 gfc_add_expr_to_block (&block, gfc_trans_dealloc_allocated (decl));
695 stmt = gfc_finish_block (&block);
698 stmt = gfc_trans_assignment (e3, e4, false, true);
699 if (TREE_CODE (stmt) != BIND_EXPR)
700 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0));
703 OMP_CLAUSE_REDUCTION_MERGE (c) = stmt;
705 /* And stick the placeholder VAR_DECL into the clause as well. */
706 OMP_CLAUSE_REDUCTION_PLACEHOLDER (c) = outer_decl;
708 gfc_current_locus = old_loc;
718 gfc_free_array_spec (outer_sym.as);
722 gfc_trans_omp_reduction_list (gfc_namelist *namelist, tree list,
723 enum tree_code reduction_code, locus where)
725 for (; namelist != NULL; namelist = namelist->next)
726 if (namelist->sym->attr.referenced)
728 tree t = gfc_trans_omp_variable (namelist->sym);
729 if (t != error_mark_node)
731 tree node = build_omp_clause (where.lb->location,
732 OMP_CLAUSE_REDUCTION);
733 OMP_CLAUSE_DECL (node) = t;
734 OMP_CLAUSE_REDUCTION_CODE (node) = reduction_code;
735 if (namelist->sym->attr.dimension)
736 gfc_trans_omp_array_reduction (node, namelist->sym, where);
737 list = gfc_trans_add_clause (node, list);
744 gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
747 tree omp_clauses = NULL_TREE, chunk_size, c;
749 enum omp_clause_code clause_code;
755 for (list = 0; list < OMP_LIST_NUM; list++)
757 gfc_namelist *n = clauses->lists[list];
761 if (list >= OMP_LIST_REDUCTION_FIRST
762 && list <= OMP_LIST_REDUCTION_LAST)
764 enum tree_code reduction_code;
768 reduction_code = PLUS_EXPR;
771 reduction_code = MULT_EXPR;
774 reduction_code = MINUS_EXPR;
777 reduction_code = TRUTH_ANDIF_EXPR;
780 reduction_code = TRUTH_ORIF_EXPR;
783 reduction_code = EQ_EXPR;
786 reduction_code = NE_EXPR;
789 reduction_code = MAX_EXPR;
792 reduction_code = MIN_EXPR;
795 reduction_code = BIT_AND_EXPR;
798 reduction_code = BIT_IOR_EXPR;
801 reduction_code = BIT_XOR_EXPR;
807 = gfc_trans_omp_reduction_list (n, omp_clauses, reduction_code,
813 case OMP_LIST_PRIVATE:
814 clause_code = OMP_CLAUSE_PRIVATE;
816 case OMP_LIST_SHARED:
817 clause_code = OMP_CLAUSE_SHARED;
819 case OMP_LIST_FIRSTPRIVATE:
820 clause_code = OMP_CLAUSE_FIRSTPRIVATE;
822 case OMP_LIST_LASTPRIVATE:
823 clause_code = OMP_CLAUSE_LASTPRIVATE;
825 case OMP_LIST_COPYIN:
826 clause_code = OMP_CLAUSE_COPYIN;
828 case OMP_LIST_COPYPRIVATE:
829 clause_code = OMP_CLAUSE_COPYPRIVATE;
833 = gfc_trans_omp_variable_list (clause_code, n, omp_clauses);
840 if (clauses->if_expr)
844 gfc_init_se (&se, NULL);
845 gfc_conv_expr (&se, clauses->if_expr);
846 gfc_add_block_to_block (block, &se.pre);
847 if_var = gfc_evaluate_now (se.expr, block);
848 gfc_add_block_to_block (block, &se.post);
850 c = build_omp_clause (where.lb->location, OMP_CLAUSE_IF);
851 OMP_CLAUSE_IF_EXPR (c) = if_var;
852 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
855 if (clauses->num_threads)
859 gfc_init_se (&se, NULL);
860 gfc_conv_expr (&se, clauses->num_threads);
861 gfc_add_block_to_block (block, &se.pre);
862 num_threads = gfc_evaluate_now (se.expr, block);
863 gfc_add_block_to_block (block, &se.post);
865 c = build_omp_clause (where.lb->location, OMP_CLAUSE_NUM_THREADS);
866 OMP_CLAUSE_NUM_THREADS_EXPR (c) = num_threads;
867 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
870 chunk_size = NULL_TREE;
871 if (clauses->chunk_size)
873 gfc_init_se (&se, NULL);
874 gfc_conv_expr (&se, clauses->chunk_size);
875 gfc_add_block_to_block (block, &se.pre);
876 chunk_size = gfc_evaluate_now (se.expr, block);
877 gfc_add_block_to_block (block, &se.post);
880 if (clauses->sched_kind != OMP_SCHED_NONE)
882 c = build_omp_clause (where.lb->location, OMP_CLAUSE_SCHEDULE);
883 OMP_CLAUSE_SCHEDULE_CHUNK_EXPR (c) = chunk_size;
884 switch (clauses->sched_kind)
886 case OMP_SCHED_STATIC:
887 OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_STATIC;
889 case OMP_SCHED_DYNAMIC:
890 OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_DYNAMIC;
892 case OMP_SCHED_GUIDED:
893 OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_GUIDED;
895 case OMP_SCHED_RUNTIME:
896 OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_RUNTIME;
899 OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_AUTO;
904 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
907 if (clauses->default_sharing != OMP_DEFAULT_UNKNOWN)
909 c = build_omp_clause (where.lb->location, OMP_CLAUSE_DEFAULT);
910 switch (clauses->default_sharing)
912 case OMP_DEFAULT_NONE:
913 OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_NONE;
915 case OMP_DEFAULT_SHARED:
916 OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_SHARED;
918 case OMP_DEFAULT_PRIVATE:
919 OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_PRIVATE;
921 case OMP_DEFAULT_FIRSTPRIVATE:
922 OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_FIRSTPRIVATE;
927 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
932 c = build_omp_clause (where.lb->location, OMP_CLAUSE_NOWAIT);
933 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
936 if (clauses->ordered)
938 c = build_omp_clause (where.lb->location, OMP_CLAUSE_ORDERED);
939 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
944 c = build_omp_clause (where.lb->location, OMP_CLAUSE_UNTIED);
945 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
948 if (clauses->collapse)
950 c = build_omp_clause (where.lb->location, OMP_CLAUSE_COLLAPSE);
951 OMP_CLAUSE_COLLAPSE_EXPR (c)
952 = build_int_cst (integer_type_node, clauses->collapse);
953 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
959 /* Like gfc_trans_code, but force creation of a BIND_EXPR around it. */
962 gfc_trans_omp_code (gfc_code *code, bool force_empty)
967 stmt = gfc_trans_code (code);
968 if (TREE_CODE (stmt) != BIND_EXPR)
970 if (!IS_EMPTY_STMT (stmt) || force_empty)
972 tree block = poplevel (1, 0, 0);
973 stmt = build3_v (BIND_EXPR, NULL, stmt, block);
984 static tree gfc_trans_omp_sections (gfc_code *, gfc_omp_clauses *);
985 static tree gfc_trans_omp_workshare (gfc_code *, gfc_omp_clauses *);
988 gfc_trans_omp_atomic (gfc_code *code)
995 tree lhsaddr, type, rhs, x;
996 enum tree_code op = ERROR_MARK;
997 bool var_on_left = false;
999 code = code->block->next;
1000 gcc_assert (code->op == EXEC_ASSIGN);
1001 gcc_assert (code->next == NULL);
1002 var = code->expr1->symtree->n.sym;
1004 gfc_init_se (&lse, NULL);
1005 gfc_init_se (&rse, NULL);
1006 gfc_start_block (&block);
1008 gfc_conv_expr (&lse, code->expr1);
1009 gfc_add_block_to_block (&block, &lse.pre);
1010 type = TREE_TYPE (lse.expr);
1011 lhsaddr = gfc_build_addr_expr (NULL, lse.expr);
1013 expr2 = code->expr2;
1014 if (expr2->expr_type == EXPR_FUNCTION
1015 && expr2->value.function.isym->id == GFC_ISYM_CONVERSION)
1016 expr2 = expr2->value.function.actual->expr;
1018 if (expr2->expr_type == EXPR_OP)
1021 switch (expr2->value.op.op)
1023 case INTRINSIC_PLUS:
1026 case INTRINSIC_TIMES:
1029 case INTRINSIC_MINUS:
1032 case INTRINSIC_DIVIDE:
1033 if (expr2->ts.type == BT_INTEGER)
1034 op = TRUNC_DIV_EXPR;
1039 op = TRUTH_ANDIF_EXPR;
1042 op = TRUTH_ORIF_EXPR;
1047 case INTRINSIC_NEQV:
1053 e = expr2->value.op.op1;
1054 if (e->expr_type == EXPR_FUNCTION
1055 && e->value.function.isym->id == GFC_ISYM_CONVERSION)
1056 e = e->value.function.actual->expr;
1057 if (e->expr_type == EXPR_VARIABLE
1058 && e->symtree != NULL
1059 && e->symtree->n.sym == var)
1061 expr2 = expr2->value.op.op2;
1066 e = expr2->value.op.op2;
1067 if (e->expr_type == EXPR_FUNCTION
1068 && e->value.function.isym->id == GFC_ISYM_CONVERSION)
1069 e = e->value.function.actual->expr;
1070 gcc_assert (e->expr_type == EXPR_VARIABLE
1071 && e->symtree != NULL
1072 && e->symtree->n.sym == var);
1073 expr2 = expr2->value.op.op1;
1074 var_on_left = false;
1076 gfc_conv_expr (&rse, expr2);
1077 gfc_add_block_to_block (&block, &rse.pre);
1081 gcc_assert (expr2->expr_type == EXPR_FUNCTION);
1082 switch (expr2->value.function.isym->id)
1102 e = expr2->value.function.actual->expr;
1103 gcc_assert (e->expr_type == EXPR_VARIABLE
1104 && e->symtree != NULL
1105 && e->symtree->n.sym == var);
1107 gfc_conv_expr (&rse, expr2->value.function.actual->next->expr);
1108 gfc_add_block_to_block (&block, &rse.pre);
1109 if (expr2->value.function.actual->next->next != NULL)
1111 tree accum = gfc_create_var (TREE_TYPE (rse.expr), NULL);
1112 gfc_actual_arglist *arg;
1114 gfc_add_modify (&block, accum, rse.expr);
1115 for (arg = expr2->value.function.actual->next->next; arg;
1118 gfc_init_block (&rse.pre);
1119 gfc_conv_expr (&rse, arg->expr);
1120 gfc_add_block_to_block (&block, &rse.pre);
1121 x = fold_build2_loc (input_location, op, TREE_TYPE (accum),
1123 gfc_add_modify (&block, accum, x);
1129 expr2 = expr2->value.function.actual->next->expr;
1132 lhsaddr = save_expr (lhsaddr);
1133 rhs = gfc_evaluate_now (rse.expr, &block);
1134 x = convert (TREE_TYPE (rhs), build_fold_indirect_ref_loc (input_location,
1138 x = fold_build2_loc (input_location, op, TREE_TYPE (rhs), x, rhs);
1140 x = fold_build2_loc (input_location, op, TREE_TYPE (rhs), rhs, x);
1142 if (TREE_CODE (TREE_TYPE (rhs)) == COMPLEX_TYPE
1143 && TREE_CODE (type) != COMPLEX_TYPE)
1144 x = fold_build1_loc (input_location, REALPART_EXPR,
1145 TREE_TYPE (TREE_TYPE (rhs)), x);
1147 x = build2_v (OMP_ATOMIC, lhsaddr, convert (type, x));
1148 gfc_add_expr_to_block (&block, x);
1150 gfc_add_block_to_block (&block, &lse.pre);
1151 gfc_add_block_to_block (&block, &rse.pre);
1153 return gfc_finish_block (&block);
1157 gfc_trans_omp_barrier (void)
1159 tree decl = built_in_decls [BUILT_IN_GOMP_BARRIER];
1160 return build_call_expr_loc (input_location, decl, 0);
1164 gfc_trans_omp_critical (gfc_code *code)
1166 tree name = NULL_TREE, stmt;
1167 if (code->ext.omp_name != NULL)
1168 name = get_identifier (code->ext.omp_name);
1169 stmt = gfc_trans_code (code->block->next);
1170 return build2_loc (input_location, OMP_CRITICAL, void_type_node, stmt, name);
1173 typedef struct dovar_init_d {
1178 DEF_VEC_O(dovar_init);
1179 DEF_VEC_ALLOC_O(dovar_init,heap);
1182 gfc_trans_omp_do (gfc_code *code, stmtblock_t *pblock,
1183 gfc_omp_clauses *do_clauses, tree par_clauses)
1186 tree dovar, stmt, from, to, step, type, init, cond, incr;
1187 tree count = NULL_TREE, cycle_label, tmp, omp_clauses;
1190 gfc_omp_clauses *clauses = code->ext.omp_clauses;
1191 int i, collapse = clauses->collapse;
1192 VEC(dovar_init,heap) *inits = NULL;
1199 code = code->block->next;
1200 gcc_assert (code->op == EXEC_DO);
1202 init = make_tree_vec (collapse);
1203 cond = make_tree_vec (collapse);
1204 incr = make_tree_vec (collapse);
1208 gfc_start_block (&block);
1212 omp_clauses = gfc_trans_omp_clauses (pblock, do_clauses, code->loc);
1214 for (i = 0; i < collapse; i++)
1217 int dovar_found = 0;
1223 for (n = clauses->lists[OMP_LIST_LASTPRIVATE]; n != NULL;
1225 if (code->ext.iterator->var->symtree->n.sym == n->sym)
1230 for (n = clauses->lists[OMP_LIST_PRIVATE]; n != NULL; n = n->next)
1231 if (code->ext.iterator->var->symtree->n.sym == n->sym)
1237 /* Evaluate all the expressions in the iterator. */
1238 gfc_init_se (&se, NULL);
1239 gfc_conv_expr_lhs (&se, code->ext.iterator->var);
1240 gfc_add_block_to_block (pblock, &se.pre);
1242 type = TREE_TYPE (dovar);
1243 gcc_assert (TREE_CODE (type) == INTEGER_TYPE);
1245 gfc_init_se (&se, NULL);
1246 gfc_conv_expr_val (&se, code->ext.iterator->start);
1247 gfc_add_block_to_block (pblock, &se.pre);
1248 from = gfc_evaluate_now (se.expr, pblock);
1250 gfc_init_se (&se, NULL);
1251 gfc_conv_expr_val (&se, code->ext.iterator->end);
1252 gfc_add_block_to_block (pblock, &se.pre);
1253 to = gfc_evaluate_now (se.expr, pblock);
1255 gfc_init_se (&se, NULL);
1256 gfc_conv_expr_val (&se, code->ext.iterator->step);
1257 gfc_add_block_to_block (pblock, &se.pre);
1258 step = gfc_evaluate_now (se.expr, pblock);
1261 /* Special case simple loops. */
1262 if (TREE_CODE (dovar) == VAR_DECL)
1264 if (integer_onep (step))
1266 else if (tree_int_cst_equal (step, integer_minus_one_node))
1271 = gfc_trans_omp_variable (code->ext.iterator->var->symtree->n.sym);
1276 TREE_VEC_ELT (init, i) = build2_v (MODIFY_EXPR, dovar, from);
1277 /* The condition should not be folded. */
1278 TREE_VEC_ELT (cond, i) = build2_loc (input_location, simple > 0
1279 ? LE_EXPR : GE_EXPR,
1280 boolean_type_node, dovar, to);
1281 TREE_VEC_ELT (incr, i) = fold_build2_loc (input_location, PLUS_EXPR,
1283 TREE_VEC_ELT (incr, i) = fold_build2_loc (input_location,
1286 TREE_VEC_ELT (incr, i));
1290 /* STEP is not 1 or -1. Use:
1291 for (count = 0; count < (to + step - from) / step; count++)
1293 dovar = from + count * step;
1297 tmp = fold_build2_loc (input_location, MINUS_EXPR, type, step, from);
1298 tmp = fold_build2_loc (input_location, PLUS_EXPR, type, to, tmp);
1299 tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, type, tmp,
1301 tmp = gfc_evaluate_now (tmp, pblock);
1302 count = gfc_create_var (type, "count");
1303 TREE_VEC_ELT (init, i) = build2_v (MODIFY_EXPR, count,
1304 build_int_cst (type, 0));
1305 /* The condition should not be folded. */
1306 TREE_VEC_ELT (cond, i) = build2_loc (input_location, LT_EXPR,
1309 TREE_VEC_ELT (incr, i) = fold_build2_loc (input_location, PLUS_EXPR,
1311 build_int_cst (type, 1));
1312 TREE_VEC_ELT (incr, i) = fold_build2_loc (input_location,
1313 MODIFY_EXPR, type, count,
1314 TREE_VEC_ELT (incr, i));
1316 /* Initialize DOVAR. */
1317 tmp = fold_build2_loc (input_location, MULT_EXPR, type, count, step);
1318 tmp = fold_build2_loc (input_location, PLUS_EXPR, type, from, tmp);
1319 di = VEC_safe_push (dovar_init, heap, inits, NULL);
1326 tmp = build_omp_clause (input_location, OMP_CLAUSE_PRIVATE);
1327 OMP_CLAUSE_DECL (tmp) = dovar_decl;
1328 omp_clauses = gfc_trans_add_clause (tmp, omp_clauses);
1330 else if (dovar_found == 2)
1337 /* If dovar is lastprivate, but different counter is used,
1338 dovar += step needs to be added to
1339 OMP_CLAUSE_LASTPRIVATE_STMT, otherwise the copied dovar
1340 will have the value on entry of the last loop, rather
1341 than value after iterator increment. */
1342 tmp = gfc_evaluate_now (step, pblock);
1343 tmp = fold_build2_loc (input_location, PLUS_EXPR, type, dovar,
1345 tmp = fold_build2_loc (input_location, MODIFY_EXPR, type,
1347 for (c = omp_clauses; c ; c = OMP_CLAUSE_CHAIN (c))
1348 if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_LASTPRIVATE
1349 && OMP_CLAUSE_DECL (c) == dovar_decl)
1351 OMP_CLAUSE_LASTPRIVATE_STMT (c) = tmp;
1355 if (c == NULL && par_clauses != NULL)
1357 for (c = par_clauses; c ; c = OMP_CLAUSE_CHAIN (c))
1358 if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_LASTPRIVATE
1359 && OMP_CLAUSE_DECL (c) == dovar_decl)
1361 tree l = build_omp_clause (input_location,
1362 OMP_CLAUSE_LASTPRIVATE);
1363 OMP_CLAUSE_DECL (l) = dovar_decl;
1364 OMP_CLAUSE_CHAIN (l) = omp_clauses;
1365 OMP_CLAUSE_LASTPRIVATE_STMT (l) = tmp;
1367 OMP_CLAUSE_SET_CODE (c, OMP_CLAUSE_SHARED);
1371 gcc_assert (simple || c != NULL);
1375 tmp = build_omp_clause (input_location, OMP_CLAUSE_PRIVATE);
1376 OMP_CLAUSE_DECL (tmp) = count;
1377 omp_clauses = gfc_trans_add_clause (tmp, omp_clauses);
1380 if (i + 1 < collapse)
1381 code = code->block->next;
1384 if (pblock != &block)
1387 gfc_start_block (&block);
1390 gfc_start_block (&body);
1392 FOR_EACH_VEC_ELT (dovar_init, inits, ix, di)
1393 gfc_add_modify (&body, di->var, di->init);
1394 VEC_free (dovar_init, heap, inits);
1396 /* Cycle statement is implemented with a goto. Exit statement must not be
1397 present for this loop. */
1398 cycle_label = gfc_build_label_decl (NULL_TREE);
1400 /* Put these labels where they can be found later. */
1402 code->cycle_label = cycle_label;
1403 code->exit_label = NULL_TREE;
1405 /* Main loop body. */
1406 tmp = gfc_trans_omp_code (code->block->next, true);
1407 gfc_add_expr_to_block (&body, tmp);
1409 /* Label for cycle statements (if needed). */
1410 if (TREE_USED (cycle_label))
1412 tmp = build1_v (LABEL_EXPR, cycle_label);
1413 gfc_add_expr_to_block (&body, tmp);
1416 /* End of loop body. */
1417 stmt = make_node (OMP_FOR);
1419 TREE_TYPE (stmt) = void_type_node;
1420 OMP_FOR_BODY (stmt) = gfc_finish_block (&body);
1421 OMP_FOR_CLAUSES (stmt) = omp_clauses;
1422 OMP_FOR_INIT (stmt) = init;
1423 OMP_FOR_COND (stmt) = cond;
1424 OMP_FOR_INCR (stmt) = incr;
1425 gfc_add_expr_to_block (&block, stmt);
1427 return gfc_finish_block (&block);
1431 gfc_trans_omp_flush (void)
1433 tree decl = built_in_decls [BUILT_IN_SYNC_SYNCHRONIZE];
1434 return build_call_expr_loc (input_location, decl, 0);
1438 gfc_trans_omp_master (gfc_code *code)
1440 tree stmt = gfc_trans_code (code->block->next);
1441 if (IS_EMPTY_STMT (stmt))
1443 return build1_v (OMP_MASTER, stmt);
1447 gfc_trans_omp_ordered (gfc_code *code)
1449 return build1_v (OMP_ORDERED, gfc_trans_code (code->block->next));
1453 gfc_trans_omp_parallel (gfc_code *code)
1456 tree stmt, omp_clauses;
1458 gfc_start_block (&block);
1459 omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
1461 stmt = gfc_trans_omp_code (code->block->next, true);
1462 stmt = build2_loc (input_location, OMP_PARALLEL, void_type_node, stmt,
1464 gfc_add_expr_to_block (&block, stmt);
1465 return gfc_finish_block (&block);
1469 gfc_trans_omp_parallel_do (gfc_code *code)
1471 stmtblock_t block, *pblock = NULL;
1472 gfc_omp_clauses parallel_clauses, do_clauses;
1473 tree stmt, omp_clauses = NULL_TREE;
1475 gfc_start_block (&block);
1477 memset (&do_clauses, 0, sizeof (do_clauses));
1478 if (code->ext.omp_clauses != NULL)
1480 memcpy (¶llel_clauses, code->ext.omp_clauses,
1481 sizeof (parallel_clauses));
1482 do_clauses.sched_kind = parallel_clauses.sched_kind;
1483 do_clauses.chunk_size = parallel_clauses.chunk_size;
1484 do_clauses.ordered = parallel_clauses.ordered;
1485 do_clauses.collapse = parallel_clauses.collapse;
1486 parallel_clauses.sched_kind = OMP_SCHED_NONE;
1487 parallel_clauses.chunk_size = NULL;
1488 parallel_clauses.ordered = false;
1489 parallel_clauses.collapse = 0;
1490 omp_clauses = gfc_trans_omp_clauses (&block, ¶llel_clauses,
1493 do_clauses.nowait = true;
1494 if (!do_clauses.ordered && do_clauses.sched_kind != OMP_SCHED_STATIC)
1498 stmt = gfc_trans_omp_do (code, pblock, &do_clauses, omp_clauses);
1499 if (TREE_CODE (stmt) != BIND_EXPR)
1500 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0));
1503 stmt = build2_loc (input_location, OMP_PARALLEL, void_type_node, stmt,
1505 OMP_PARALLEL_COMBINED (stmt) = 1;
1506 gfc_add_expr_to_block (&block, stmt);
1507 return gfc_finish_block (&block);
1511 gfc_trans_omp_parallel_sections (gfc_code *code)
1514 gfc_omp_clauses section_clauses;
1515 tree stmt, omp_clauses;
1517 memset (§ion_clauses, 0, sizeof (section_clauses));
1518 section_clauses.nowait = true;
1520 gfc_start_block (&block);
1521 omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
1524 stmt = gfc_trans_omp_sections (code, §ion_clauses);
1525 if (TREE_CODE (stmt) != BIND_EXPR)
1526 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0));
1529 stmt = build2_loc (input_location, OMP_PARALLEL, void_type_node, stmt,
1531 OMP_PARALLEL_COMBINED (stmt) = 1;
1532 gfc_add_expr_to_block (&block, stmt);
1533 return gfc_finish_block (&block);
1537 gfc_trans_omp_parallel_workshare (gfc_code *code)
1540 gfc_omp_clauses workshare_clauses;
1541 tree stmt, omp_clauses;
1543 memset (&workshare_clauses, 0, sizeof (workshare_clauses));
1544 workshare_clauses.nowait = true;
1546 gfc_start_block (&block);
1547 omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
1550 stmt = gfc_trans_omp_workshare (code, &workshare_clauses);
1551 if (TREE_CODE (stmt) != BIND_EXPR)
1552 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0));
1555 stmt = build2_loc (input_location, OMP_PARALLEL, void_type_node, stmt,
1557 OMP_PARALLEL_COMBINED (stmt) = 1;
1558 gfc_add_expr_to_block (&block, stmt);
1559 return gfc_finish_block (&block);
1563 gfc_trans_omp_sections (gfc_code *code, gfc_omp_clauses *clauses)
1565 stmtblock_t block, body;
1566 tree omp_clauses, stmt;
1567 bool has_lastprivate = clauses->lists[OMP_LIST_LASTPRIVATE] != NULL;
1569 gfc_start_block (&block);
1571 omp_clauses = gfc_trans_omp_clauses (&block, clauses, code->loc);
1573 gfc_init_block (&body);
1574 for (code = code->block; code; code = code->block)
1576 /* Last section is special because of lastprivate, so even if it
1577 is empty, chain it in. */
1578 stmt = gfc_trans_omp_code (code->next,
1579 has_lastprivate && code->block == NULL);
1580 if (! IS_EMPTY_STMT (stmt))
1582 stmt = build1_v (OMP_SECTION, stmt);
1583 gfc_add_expr_to_block (&body, stmt);
1586 stmt = gfc_finish_block (&body);
1588 stmt = build2_loc (input_location, OMP_SECTIONS, void_type_node, stmt,
1590 gfc_add_expr_to_block (&block, stmt);
1592 return gfc_finish_block (&block);
1596 gfc_trans_omp_single (gfc_code *code, gfc_omp_clauses *clauses)
1598 tree omp_clauses = gfc_trans_omp_clauses (NULL, clauses, code->loc);
1599 tree stmt = gfc_trans_omp_code (code->block->next, true);
1600 stmt = build2_loc (input_location, OMP_SINGLE, void_type_node, stmt,
1606 gfc_trans_omp_task (gfc_code *code)
1609 tree stmt, omp_clauses;
1611 gfc_start_block (&block);
1612 omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
1614 stmt = gfc_trans_omp_code (code->block->next, true);
1615 stmt = build2_loc (input_location, OMP_TASK, void_type_node, stmt,
1617 gfc_add_expr_to_block (&block, stmt);
1618 return gfc_finish_block (&block);
1622 gfc_trans_omp_taskwait (void)
1624 tree decl = built_in_decls [BUILT_IN_GOMP_TASKWAIT];
1625 return build_call_expr_loc (input_location, decl, 0);
1629 gfc_trans_omp_workshare (gfc_code *code, gfc_omp_clauses *clauses)
1631 tree res, tmp, stmt;
1632 stmtblock_t block, *pblock = NULL;
1633 stmtblock_t singleblock;
1634 int saved_ompws_flags;
1635 bool singleblock_in_progress = false;
1636 /* True if previous gfc_code in workshare construct is not workshared. */
1637 bool prev_singleunit;
1639 code = code->block->next;
1644 return build_empty_stmt (input_location);
1646 gfc_start_block (&block);
1649 ompws_flags = OMPWS_WORKSHARE_FLAG;
1650 prev_singleunit = false;
1652 /* Translate statements one by one to trees until we reach
1653 the end of the workshare construct. Adjacent gfc_codes that
1654 are a single unit of work are clustered and encapsulated in a
1655 single OMP_SINGLE construct. */
1656 for (; code; code = code->next)
1658 if (code->here != 0)
1660 res = gfc_trans_label_here (code);
1661 gfc_add_expr_to_block (pblock, res);
1664 /* No dependence analysis, use for clauses with wait.
1665 If this is the last gfc_code, use default omp_clauses. */
1666 if (code->next == NULL && clauses->nowait)
1667 ompws_flags |= OMPWS_NOWAIT;
1669 /* By default, every gfc_code is a single unit of work. */
1670 ompws_flags |= OMPWS_CURR_SINGLEUNIT;
1671 ompws_flags &= ~OMPWS_SCALARIZER_WS;
1680 res = gfc_trans_assign (code);
1683 case EXEC_POINTER_ASSIGN:
1684 res = gfc_trans_pointer_assign (code);
1687 case EXEC_INIT_ASSIGN:
1688 res = gfc_trans_init_assign (code);
1692 res = gfc_trans_forall (code);
1696 res = gfc_trans_where (code);
1699 case EXEC_OMP_ATOMIC:
1700 res = gfc_trans_omp_directive (code);
1703 case EXEC_OMP_PARALLEL:
1704 case EXEC_OMP_PARALLEL_DO:
1705 case EXEC_OMP_PARALLEL_SECTIONS:
1706 case EXEC_OMP_PARALLEL_WORKSHARE:
1707 case EXEC_OMP_CRITICAL:
1708 saved_ompws_flags = ompws_flags;
1710 res = gfc_trans_omp_directive (code);
1711 ompws_flags = saved_ompws_flags;
1715 internal_error ("gfc_trans_omp_workshare(): Bad statement code");
1718 gfc_set_backend_locus (&code->loc);
1720 if (res != NULL_TREE && ! IS_EMPTY_STMT (res))
1722 if (prev_singleunit)
1724 if (ompws_flags & OMPWS_CURR_SINGLEUNIT)
1725 /* Add current gfc_code to single block. */
1726 gfc_add_expr_to_block (&singleblock, res);
1729 /* Finish single block and add it to pblock. */
1730 tmp = gfc_finish_block (&singleblock);
1731 tmp = build2_loc (input_location, OMP_SINGLE,
1732 void_type_node, tmp, NULL_TREE);
1733 gfc_add_expr_to_block (pblock, tmp);
1734 /* Add current gfc_code to pblock. */
1735 gfc_add_expr_to_block (pblock, res);
1736 singleblock_in_progress = false;
1741 if (ompws_flags & OMPWS_CURR_SINGLEUNIT)
1743 /* Start single block. */
1744 gfc_init_block (&singleblock);
1745 gfc_add_expr_to_block (&singleblock, res);
1746 singleblock_in_progress = true;
1749 /* Add the new statement to the block. */
1750 gfc_add_expr_to_block (pblock, res);
1752 prev_singleunit = (ompws_flags & OMPWS_CURR_SINGLEUNIT) != 0;
1756 /* Finish remaining SINGLE block, if we were in the middle of one. */
1757 if (singleblock_in_progress)
1759 /* Finish single block and add it to pblock. */
1760 tmp = gfc_finish_block (&singleblock);
1761 tmp = build2_loc (input_location, OMP_SINGLE, void_type_node, tmp,
1763 ? build_omp_clause (input_location, OMP_CLAUSE_NOWAIT)
1765 gfc_add_expr_to_block (pblock, tmp);
1768 stmt = gfc_finish_block (pblock);
1769 if (TREE_CODE (stmt) != BIND_EXPR)
1771 if (!IS_EMPTY_STMT (stmt))
1773 tree bindblock = poplevel (1, 0, 0);
1774 stmt = build3_v (BIND_EXPR, NULL, stmt, bindblock);
1787 gfc_trans_omp_directive (gfc_code *code)
1791 case EXEC_OMP_ATOMIC:
1792 return gfc_trans_omp_atomic (code);
1793 case EXEC_OMP_BARRIER:
1794 return gfc_trans_omp_barrier ();
1795 case EXEC_OMP_CRITICAL:
1796 return gfc_trans_omp_critical (code);
1798 return gfc_trans_omp_do (code, NULL, code->ext.omp_clauses, NULL);
1799 case EXEC_OMP_FLUSH:
1800 return gfc_trans_omp_flush ();
1801 case EXEC_OMP_MASTER:
1802 return gfc_trans_omp_master (code);
1803 case EXEC_OMP_ORDERED:
1804 return gfc_trans_omp_ordered (code);
1805 case EXEC_OMP_PARALLEL:
1806 return gfc_trans_omp_parallel (code);
1807 case EXEC_OMP_PARALLEL_DO:
1808 return gfc_trans_omp_parallel_do (code);
1809 case EXEC_OMP_PARALLEL_SECTIONS:
1810 return gfc_trans_omp_parallel_sections (code);
1811 case EXEC_OMP_PARALLEL_WORKSHARE:
1812 return gfc_trans_omp_parallel_workshare (code);
1813 case EXEC_OMP_SECTIONS:
1814 return gfc_trans_omp_sections (code, code->ext.omp_clauses);
1815 case EXEC_OMP_SINGLE:
1816 return gfc_trans_omp_single (code, code->ext.omp_clauses);
1818 return gfc_trans_omp_task (code);
1819 case EXEC_OMP_TASKWAIT:
1820 return gfc_trans_omp_taskwait ();
1821 case EXEC_OMP_WORKSHARE:
1822 return gfc_trans_omp_workshare (code, code->ext.omp_clauses);