1 /* OpenMP directive translation -- generate GCC trees from gfc_code.
2 Copyright (C) 2005, 2006 Free Software Foundation, Inc.
3 Contributed by Jakub Jelinek <jakub@redhat.com>
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 2, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING. If not, write to the Free
19 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
25 #include "coretypes.h"
27 #include "tree-gimple.h"
33 #include "trans-stmt.h"
34 #include "trans-types.h"
35 #include "trans-array.h"
36 #include "trans-const.h"
40 /* True if OpenMP should privatize what this DECL points to rather
41 than the DECL itself. */
44 gfc_omp_privatize_by_reference (tree decl)
46 tree type = TREE_TYPE (decl);
48 if (TREE_CODE (type) == REFERENCE_TYPE)
51 if (TREE_CODE (type) == POINTER_TYPE)
53 /* POINTER/ALLOCATABLE have aggregate types, all user variables
54 that have POINTER_TYPE type are supposed to be privatized
56 if (!DECL_ARTIFICIAL (decl))
59 /* Some arrays are expanded as DECL_ARTIFICIAL pointers
61 if (DECL_LANG_SPECIFIC (decl)
62 && GFC_DECL_SAVED_DESCRIPTOR (decl))
69 /* True if OpenMP sharing attribute of DECL is predetermined. */
71 enum omp_clause_default_kind
72 gfc_omp_predetermined_sharing (tree decl)
74 if (DECL_ARTIFICIAL (decl) && ! GFC_DECL_RESULT (decl))
75 return OMP_CLAUSE_DEFAULT_SHARED;
77 /* Cray pointees shouldn't be listed in any clauses and should be
78 gimplified to dereference of the corresponding Cray pointer.
79 Make them all private, so that they are emitted in the debug
81 if (GFC_DECL_CRAY_POINTEE (decl))
82 return OMP_CLAUSE_DEFAULT_PRIVATE;
84 /* COMMON and EQUIVALENCE decls are shared. They
85 are only referenced through DECL_VALUE_EXPR of the variables
86 contained in them. If those are privatized, they will not be
87 gimplified to the COMMON or EQUIVALENCE decls. */
88 if (GFC_DECL_COMMON_OR_EQUIV (decl) && ! DECL_HAS_VALUE_EXPR_P (decl))
89 return OMP_CLAUSE_DEFAULT_SHARED;
91 if (GFC_DECL_RESULT (decl) && ! DECL_HAS_VALUE_EXPR_P (decl))
92 return OMP_CLAUSE_DEFAULT_SHARED;
94 return OMP_CLAUSE_DEFAULT_UNSPECIFIED;
97 /* Return true if DECL's DECL_VALUE_EXPR (if any) should be
98 disregarded in OpenMP construct, because it is going to be
99 remapped during OpenMP lowering. SHARED is true if DECL
100 is going to be shared, false if it is going to be privatized. */
103 gfc_omp_disregard_value_expr (tree decl, bool shared)
105 if (GFC_DECL_COMMON_OR_EQUIV (decl)
106 && DECL_HAS_VALUE_EXPR_P (decl))
108 tree value = DECL_VALUE_EXPR (decl);
110 if (TREE_CODE (value) == COMPONENT_REF
111 && TREE_CODE (TREE_OPERAND (value, 0)) == VAR_DECL
112 && GFC_DECL_COMMON_OR_EQUIV (TREE_OPERAND (value, 0)))
114 /* If variable in COMMON or EQUIVALENCE is privatized, return
115 true, as just that variable is supposed to be privatized,
116 not the whole COMMON or whole EQUIVALENCE.
117 For shared variables in COMMON or EQUIVALENCE, let them be
118 gimplified to DECL_VALUE_EXPR, so that for multiple shared vars
119 from the same COMMON or EQUIVALENCE just one sharing of the
120 whole COMMON or EQUIVALENCE is enough. */
125 if (GFC_DECL_RESULT (decl) && DECL_HAS_VALUE_EXPR_P (decl))
131 /* Return true if DECL that is shared iff SHARED is true should
132 be put into OMP_CLAUSE_PRIVATE with OMP_CLAUSE_PRIVATE_DEBUG
136 gfc_omp_private_debug_clause (tree decl, bool shared)
138 if (GFC_DECL_CRAY_POINTEE (decl))
141 if (GFC_DECL_COMMON_OR_EQUIV (decl)
142 && DECL_HAS_VALUE_EXPR_P (decl))
144 tree value = DECL_VALUE_EXPR (decl);
146 if (TREE_CODE (value) == COMPONENT_REF
147 && TREE_CODE (TREE_OPERAND (value, 0)) == VAR_DECL
148 && GFC_DECL_COMMON_OR_EQUIV (TREE_OPERAND (value, 0)))
155 /* Register language specific type size variables as potentially OpenMP
156 firstprivate variables. */
159 gfc_omp_firstprivatize_type_sizes (struct gimplify_omp_ctx *ctx, tree type)
161 if (GFC_ARRAY_TYPE_P (type) || GFC_DESCRIPTOR_TYPE_P (type))
165 gcc_assert (TYPE_LANG_SPECIFIC (type) != NULL);
166 for (r = 0; r < GFC_TYPE_ARRAY_RANK (type); r++)
168 omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_LBOUND (type, r));
169 omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_UBOUND (type, r));
170 omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_STRIDE (type, r));
172 omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_SIZE (type));
173 omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_OFFSET (type));
179 gfc_trans_add_clause (tree node, tree tail)
181 OMP_CLAUSE_CHAIN (node) = tail;
186 gfc_trans_omp_variable (gfc_symbol *sym)
188 tree t = gfc_get_symbol_decl (sym);
192 bool alternate_entry;
195 return_value = sym->attr.function && sym->result == sym;
196 alternate_entry = sym->attr.function && sym->attr.entry
197 && sym->result == sym;
198 entry_master = sym->attr.result
199 && sym->ns->proc_name->attr.entry_master
200 && !gfc_return_by_reference (sym->ns->proc_name);
201 parent_decl = DECL_CONTEXT (current_function_decl);
203 if ((t == parent_decl && return_value)
204 || (sym->ns && sym->ns->proc_name
205 && sym->ns->proc_name->backend_decl == parent_decl
206 && (alternate_entry || entry_master)))
211 /* Special case for assigning the return value of a function.
212 Self recursive functions must have an explicit return value. */
213 if (return_value && (t == current_function_decl || parent_flag))
214 t = gfc_get_fake_result_decl (sym, parent_flag);
216 /* Similarly for alternate entry points. */
217 else if (alternate_entry
218 && (sym->ns->proc_name->backend_decl == current_function_decl
221 gfc_entry_list *el = NULL;
223 for (el = sym->ns->entries; el; el = el->next)
226 t = gfc_get_fake_result_decl (sym, parent_flag);
231 else if (entry_master
232 && (sym->ns->proc_name->backend_decl == current_function_decl
234 t = gfc_get_fake_result_decl (sym, parent_flag);
240 gfc_trans_omp_variable_list (enum omp_clause_code code, gfc_namelist *namelist,
243 for (; namelist != NULL; namelist = namelist->next)
244 if (namelist->sym->attr.referenced)
246 tree t = gfc_trans_omp_variable (namelist->sym);
247 if (t != error_mark_node)
249 tree node = build_omp_clause (code);
250 OMP_CLAUSE_DECL (node) = t;
251 list = gfc_trans_add_clause (node, list);
258 gfc_trans_omp_array_reduction (tree c, gfc_symbol *sym, locus where)
260 gfc_symtree *root1 = NULL, *root2 = NULL, *root3 = NULL, *root4 = NULL;
261 gfc_symtree *symtree1, *symtree2, *symtree3, *symtree4 = NULL;
262 gfc_symbol init_val_sym, outer_sym, intrinsic_sym;
263 gfc_expr *e1, *e2, *e3, *e4;
265 tree decl, backend_decl, stmt;
266 locus old_loc = gfc_current_locus;
270 decl = OMP_CLAUSE_DECL (c);
271 gfc_current_locus = where;
273 /* Create a fake symbol for init value. */
274 memset (&init_val_sym, 0, sizeof (init_val_sym));
275 init_val_sym.ns = sym->ns;
276 init_val_sym.name = sym->name;
277 init_val_sym.ts = sym->ts;
278 init_val_sym.attr.referenced = 1;
279 init_val_sym.declared_at = where;
280 backend_decl = omp_reduction_init (c, gfc_sym_type (&init_val_sym));
281 init_val_sym.backend_decl = backend_decl;
283 /* Create a fake symbol for the outer array reference. */
285 outer_sym.as = gfc_copy_array_spec (sym->as);
286 outer_sym.attr.dummy = 0;
287 outer_sym.attr.result = 0;
288 outer_sym.backend_decl = create_tmp_var_raw (TREE_TYPE (decl), NULL);
290 /* Create fake symtrees for it. */
291 symtree1 = gfc_new_symtree (&root1, sym->name);
292 symtree1->n.sym = sym;
293 gcc_assert (symtree1 == root1);
295 symtree2 = gfc_new_symtree (&root2, sym->name);
296 symtree2->n.sym = &init_val_sym;
297 gcc_assert (symtree2 == root2);
299 symtree3 = gfc_new_symtree (&root3, sym->name);
300 symtree3->n.sym = &outer_sym;
301 gcc_assert (symtree3 == root3);
303 /* Create expressions. */
304 e1 = gfc_get_expr ();
305 e1->expr_type = EXPR_VARIABLE;
307 e1->symtree = symtree1;
309 e1->ref = ref = gfc_get_ref ();
310 ref->u.ar.where = where;
311 ref->u.ar.as = sym->as;
312 ref->u.ar.type = AR_FULL;
314 t = gfc_resolve_expr (e1);
315 gcc_assert (t == SUCCESS);
317 e2 = gfc_get_expr ();
318 e2->expr_type = EXPR_VARIABLE;
320 e2->symtree = symtree2;
322 t = gfc_resolve_expr (e2);
323 gcc_assert (t == SUCCESS);
325 e3 = gfc_copy_expr (e1);
326 e3->symtree = symtree3;
327 t = gfc_resolve_expr (e3);
328 gcc_assert (t == SUCCESS);
331 switch (OMP_CLAUSE_REDUCTION_CODE (c))
335 e4 = gfc_add (e3, e1);
338 e4 = gfc_multiply (e3, e1);
340 case TRUTH_ANDIF_EXPR:
341 e4 = gfc_and (e3, e1);
343 case TRUTH_ORIF_EXPR:
344 e4 = gfc_or (e3, e1);
347 e4 = gfc_eqv (e3, e1);
350 e4 = gfc_neqv (e3, e1);
372 memset (&intrinsic_sym, 0, sizeof (intrinsic_sym));
373 intrinsic_sym.ns = sym->ns;
374 intrinsic_sym.name = iname;
375 intrinsic_sym.ts = sym->ts;
376 intrinsic_sym.attr.referenced = 1;
377 intrinsic_sym.attr.intrinsic = 1;
378 intrinsic_sym.attr.function = 1;
379 intrinsic_sym.result = &intrinsic_sym;
380 intrinsic_sym.declared_at = where;
382 symtree4 = gfc_new_symtree (&root4, iname);
383 symtree4->n.sym = &intrinsic_sym;
384 gcc_assert (symtree4 == root4);
386 e4 = gfc_get_expr ();
387 e4->expr_type = EXPR_FUNCTION;
389 e4->symtree = symtree4;
390 e4->value.function.isym = gfc_find_function (iname);
391 e4->value.function.actual = gfc_get_actual_arglist ();
392 e4->value.function.actual->expr = e3;
393 e4->value.function.actual->next = gfc_get_actual_arglist ();
394 e4->value.function.actual->next->expr = e1;
396 /* e1 and e3 have been stored as arguments of e4, avoid sharing. */
397 e1 = gfc_copy_expr (e1);
398 e3 = gfc_copy_expr (e3);
399 t = gfc_resolve_expr (e4);
400 gcc_assert (t == SUCCESS);
402 /* Create the init statement list. */
404 stmt = gfc_trans_assignment (e1, e2);
405 if (TREE_CODE (stmt) != BIND_EXPR)
406 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0));
409 OMP_CLAUSE_REDUCTION_INIT (c) = stmt;
411 /* Create the merge statement list. */
413 stmt = gfc_trans_assignment (e3, e4);
414 if (TREE_CODE (stmt) != BIND_EXPR)
415 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0));
418 OMP_CLAUSE_REDUCTION_MERGE (c) = stmt;
420 /* And stick the placeholder VAR_DECL into the clause as well. */
421 OMP_CLAUSE_REDUCTION_PLACEHOLDER (c) = outer_sym.backend_decl;
423 gfc_current_locus = old_loc;
434 gfc_free_array_spec (outer_sym.as);
438 gfc_trans_omp_reduction_list (gfc_namelist *namelist, tree list,
439 enum tree_code reduction_code, locus where)
441 for (; namelist != NULL; namelist = namelist->next)
442 if (namelist->sym->attr.referenced)
444 tree t = gfc_trans_omp_variable (namelist->sym);
445 if (t != error_mark_node)
447 tree node = build_omp_clause (OMP_CLAUSE_REDUCTION);
448 OMP_CLAUSE_DECL (node) = t;
449 OMP_CLAUSE_REDUCTION_CODE (node) = reduction_code;
450 if (namelist->sym->attr.dimension)
451 gfc_trans_omp_array_reduction (node, namelist->sym, where);
452 list = gfc_trans_add_clause (node, list);
459 gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
462 tree omp_clauses = NULL_TREE, chunk_size, c, old_clauses;
464 enum omp_clause_code clause_code;
470 for (list = 0; list < OMP_LIST_NUM; list++)
472 gfc_namelist *n = clauses->lists[list];
476 if (list >= OMP_LIST_REDUCTION_FIRST
477 && list <= OMP_LIST_REDUCTION_LAST)
479 enum tree_code reduction_code;
483 reduction_code = PLUS_EXPR;
486 reduction_code = MULT_EXPR;
489 reduction_code = MINUS_EXPR;
492 reduction_code = TRUTH_ANDIF_EXPR;
495 reduction_code = TRUTH_ORIF_EXPR;
498 reduction_code = EQ_EXPR;
501 reduction_code = NE_EXPR;
504 reduction_code = MAX_EXPR;
507 reduction_code = MIN_EXPR;
510 reduction_code = BIT_AND_EXPR;
513 reduction_code = BIT_IOR_EXPR;
516 reduction_code = BIT_XOR_EXPR;
521 old_clauses = omp_clauses;
523 = gfc_trans_omp_reduction_list (n, omp_clauses, reduction_code,
529 case OMP_LIST_PRIVATE:
530 clause_code = OMP_CLAUSE_PRIVATE;
532 case OMP_LIST_SHARED:
533 clause_code = OMP_CLAUSE_SHARED;
535 case OMP_LIST_FIRSTPRIVATE:
536 clause_code = OMP_CLAUSE_FIRSTPRIVATE;
538 case OMP_LIST_LASTPRIVATE:
539 clause_code = OMP_CLAUSE_LASTPRIVATE;
541 case OMP_LIST_COPYIN:
542 clause_code = OMP_CLAUSE_COPYIN;
544 case OMP_LIST_COPYPRIVATE:
545 clause_code = OMP_CLAUSE_COPYPRIVATE;
549 = gfc_trans_omp_variable_list (clause_code, n, omp_clauses);
556 if (clauses->if_expr)
560 gfc_init_se (&se, NULL);
561 gfc_conv_expr (&se, clauses->if_expr);
562 gfc_add_block_to_block (block, &se.pre);
563 if_var = gfc_evaluate_now (se.expr, block);
564 gfc_add_block_to_block (block, &se.post);
566 c = build_omp_clause (OMP_CLAUSE_IF);
567 OMP_CLAUSE_IF_EXPR (c) = if_var;
568 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
571 if (clauses->num_threads)
575 gfc_init_se (&se, NULL);
576 gfc_conv_expr (&se, clauses->num_threads);
577 gfc_add_block_to_block (block, &se.pre);
578 num_threads = gfc_evaluate_now (se.expr, block);
579 gfc_add_block_to_block (block, &se.post);
581 c = build_omp_clause (OMP_CLAUSE_NUM_THREADS);
582 OMP_CLAUSE_NUM_THREADS_EXPR (c) = num_threads;
583 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
586 chunk_size = NULL_TREE;
587 if (clauses->chunk_size)
589 gfc_init_se (&se, NULL);
590 gfc_conv_expr (&se, clauses->chunk_size);
591 gfc_add_block_to_block (block, &se.pre);
592 chunk_size = gfc_evaluate_now (se.expr, block);
593 gfc_add_block_to_block (block, &se.post);
596 if (clauses->sched_kind != OMP_SCHED_NONE)
598 c = build_omp_clause (OMP_CLAUSE_SCHEDULE);
599 OMP_CLAUSE_SCHEDULE_CHUNK_EXPR (c) = chunk_size;
600 switch (clauses->sched_kind)
602 case OMP_SCHED_STATIC:
603 OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_STATIC;
605 case OMP_SCHED_DYNAMIC:
606 OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_DYNAMIC;
608 case OMP_SCHED_GUIDED:
609 OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_GUIDED;
611 case OMP_SCHED_RUNTIME:
612 OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_RUNTIME;
617 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
620 if (clauses->default_sharing != OMP_DEFAULT_UNKNOWN)
622 c = build_omp_clause (OMP_CLAUSE_DEFAULT);
623 switch (clauses->default_sharing)
625 case OMP_DEFAULT_NONE:
626 OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_NONE;
628 case OMP_DEFAULT_SHARED:
629 OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_SHARED;
631 case OMP_DEFAULT_PRIVATE:
632 OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_PRIVATE;
637 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
642 c = build_omp_clause (OMP_CLAUSE_NOWAIT);
643 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
646 if (clauses->ordered)
648 c = build_omp_clause (OMP_CLAUSE_ORDERED);
649 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
655 /* Like gfc_trans_code, but force creation of a BIND_EXPR around it. */
658 gfc_trans_omp_code (gfc_code *code, bool force_empty)
663 stmt = gfc_trans_code (code);
664 if (TREE_CODE (stmt) != BIND_EXPR)
666 if (!IS_EMPTY_STMT (stmt) || force_empty)
668 tree block = poplevel (1, 0, 0);
669 stmt = build3_v (BIND_EXPR, NULL, stmt, block);
680 static tree gfc_trans_omp_sections (gfc_code *, gfc_omp_clauses *);
681 static tree gfc_trans_omp_workshare (gfc_code *, gfc_omp_clauses *);
684 gfc_trans_omp_atomic (gfc_code *code)
691 tree lhsaddr, type, rhs, x;
692 enum tree_code op = ERROR_MARK;
693 bool var_on_left = false;
695 code = code->block->next;
696 gcc_assert (code->op == EXEC_ASSIGN);
697 gcc_assert (code->next == NULL);
698 var = code->expr->symtree->n.sym;
700 gfc_init_se (&lse, NULL);
701 gfc_init_se (&rse, NULL);
702 gfc_start_block (&block);
704 gfc_conv_expr (&lse, code->expr);
705 gfc_add_block_to_block (&block, &lse.pre);
706 type = TREE_TYPE (lse.expr);
707 lhsaddr = gfc_build_addr_expr (NULL, lse.expr);
710 if (expr2->expr_type == EXPR_FUNCTION
711 && expr2->value.function.isym->generic_id == GFC_ISYM_CONVERSION)
712 expr2 = expr2->value.function.actual->expr;
714 if (expr2->expr_type == EXPR_OP)
717 switch (expr2->value.op.operator)
722 case INTRINSIC_TIMES:
725 case INTRINSIC_MINUS:
728 case INTRINSIC_DIVIDE:
729 if (expr2->ts.type == BT_INTEGER)
735 op = TRUTH_ANDIF_EXPR;
738 op = TRUTH_ORIF_EXPR;
749 e = expr2->value.op.op1;
750 if (e->expr_type == EXPR_FUNCTION
751 && e->value.function.isym->generic_id == GFC_ISYM_CONVERSION)
752 e = e->value.function.actual->expr;
753 if (e->expr_type == EXPR_VARIABLE
754 && e->symtree != NULL
755 && e->symtree->n.sym == var)
757 expr2 = expr2->value.op.op2;
762 e = expr2->value.op.op2;
763 if (e->expr_type == EXPR_FUNCTION
764 && e->value.function.isym->generic_id == GFC_ISYM_CONVERSION)
765 e = e->value.function.actual->expr;
766 gcc_assert (e->expr_type == EXPR_VARIABLE
767 && e->symtree != NULL
768 && e->symtree->n.sym == var);
769 expr2 = expr2->value.op.op1;
772 gfc_conv_expr (&rse, expr2);
773 gfc_add_block_to_block (&block, &rse.pre);
777 gcc_assert (expr2->expr_type == EXPR_FUNCTION);
778 switch (expr2->value.function.isym->generic_id)
798 e = expr2->value.function.actual->expr;
799 gcc_assert (e->expr_type == EXPR_VARIABLE
800 && e->symtree != NULL
801 && e->symtree->n.sym == var);
803 gfc_conv_expr (&rse, expr2->value.function.actual->next->expr);
804 gfc_add_block_to_block (&block, &rse.pre);
805 if (expr2->value.function.actual->next->next != NULL)
807 tree accum = gfc_create_var (TREE_TYPE (rse.expr), NULL);
808 gfc_actual_arglist *arg;
810 gfc_add_modify_expr (&block, accum, rse.expr);
811 for (arg = expr2->value.function.actual->next->next; arg;
814 gfc_init_block (&rse.pre);
815 gfc_conv_expr (&rse, arg->expr);
816 gfc_add_block_to_block (&block, &rse.pre);
817 x = fold_build2 (op, TREE_TYPE (accum), accum, rse.expr);
818 gfc_add_modify_expr (&block, accum, x);
824 expr2 = expr2->value.function.actual->next->expr;
827 lhsaddr = save_expr (lhsaddr);
828 rhs = gfc_evaluate_now (rse.expr, &block);
829 x = convert (TREE_TYPE (rhs), build_fold_indirect_ref (lhsaddr));
832 x = fold_build2 (op, TREE_TYPE (rhs), x, rhs);
834 x = fold_build2 (op, TREE_TYPE (rhs), rhs, x);
836 if (TREE_CODE (TREE_TYPE (rhs)) == COMPLEX_TYPE
837 && TREE_CODE (type) != COMPLEX_TYPE)
838 x = build1 (REALPART_EXPR, TREE_TYPE (TREE_TYPE (rhs)), x);
840 x = build2_v (OMP_ATOMIC, lhsaddr, convert (type, x));
841 gfc_add_expr_to_block (&block, x);
843 gfc_add_block_to_block (&block, &lse.pre);
844 gfc_add_block_to_block (&block, &rse.pre);
846 return gfc_finish_block (&block);
850 gfc_trans_omp_barrier (void)
852 tree decl = built_in_decls [BUILT_IN_GOMP_BARRIER];
853 return build_function_call_expr (decl, NULL);
857 gfc_trans_omp_critical (gfc_code *code)
859 tree name = NULL_TREE, stmt;
860 if (code->ext.omp_name != NULL)
861 name = get_identifier (code->ext.omp_name);
862 stmt = gfc_trans_code (code->block->next);
863 return build2_v (OMP_CRITICAL, stmt, name);
867 gfc_trans_omp_do (gfc_code *code, stmtblock_t *pblock,
868 gfc_omp_clauses *clauses)
871 tree dovar, stmt, from, to, step, type, init, cond, incr;
872 tree count = NULL_TREE, cycle_label, tmp, omp_clauses;
876 bool dovar_found = false;
878 code = code->block->next;
879 gcc_assert (code->op == EXEC_DO);
883 gfc_start_block (&block);
887 omp_clauses = gfc_trans_omp_clauses (pblock, clauses, code->loc);
891 for (n = clauses->lists[OMP_LIST_LASTPRIVATE]; n != NULL; n = n->next)
892 if (code->ext.iterator->var->symtree->n.sym == n->sym)
895 for (n = clauses->lists[OMP_LIST_PRIVATE]; n != NULL; n = n->next)
896 if (code->ext.iterator->var->symtree->n.sym == n->sym)
902 /* Evaluate all the expressions in the iterator. */
903 gfc_init_se (&se, NULL);
904 gfc_conv_expr_lhs (&se, code->ext.iterator->var);
905 gfc_add_block_to_block (pblock, &se.pre);
907 type = TREE_TYPE (dovar);
908 gcc_assert (TREE_CODE (type) == INTEGER_TYPE);
910 gfc_init_se (&se, NULL);
911 gfc_conv_expr_val (&se, code->ext.iterator->start);
912 gfc_add_block_to_block (pblock, &se.pre);
913 from = gfc_evaluate_now (se.expr, pblock);
915 gfc_init_se (&se, NULL);
916 gfc_conv_expr_val (&se, code->ext.iterator->end);
917 gfc_add_block_to_block (pblock, &se.pre);
918 to = gfc_evaluate_now (se.expr, pblock);
920 gfc_init_se (&se, NULL);
921 gfc_conv_expr_val (&se, code->ext.iterator->step);
922 gfc_add_block_to_block (pblock, &se.pre);
923 step = gfc_evaluate_now (se.expr, pblock);
925 /* Special case simple loops. */
926 if (integer_onep (step))
928 else if (tree_int_cst_equal (step, integer_minus_one_node))
934 init = build2_v (MODIFY_EXPR, dovar, from);
935 cond = build2 (simple > 0 ? LE_EXPR : GE_EXPR, boolean_type_node,
937 incr = fold_build2 (PLUS_EXPR, type, dovar, step);
938 incr = fold_build2 (MODIFY_EXPR, type, dovar, incr);
939 if (pblock != &block)
942 gfc_start_block (&block);
944 gfc_start_block (&body);
948 /* STEP is not 1 or -1. Use:
949 for (count = 0; count < (to + step - from) / step; count++)
951 dovar = from + count * step;
955 tmp = fold_build2 (MINUS_EXPR, type, step, from);
956 tmp = fold_build2 (PLUS_EXPR, type, to, tmp);
957 tmp = fold_build2 (TRUNC_DIV_EXPR, type, tmp, step);
958 tmp = gfc_evaluate_now (tmp, pblock);
959 count = gfc_create_var (type, "count");
960 init = build2_v (MODIFY_EXPR, count, build_int_cst (type, 0));
961 cond = build2 (LT_EXPR, boolean_type_node, count, tmp);
962 incr = fold_build2 (PLUS_EXPR, type, count, build_int_cst (type, 1));
963 incr = fold_build2 (MODIFY_EXPR, type, count, incr);
965 if (pblock != &block)
968 gfc_start_block (&block);
970 gfc_start_block (&body);
972 /* Initialize DOVAR. */
973 tmp = fold_build2 (MULT_EXPR, type, count, step);
974 tmp = build2 (PLUS_EXPR, type, from, tmp);
975 gfc_add_modify_expr (&body, dovar, tmp);
980 tmp = build_omp_clause (OMP_CLAUSE_PRIVATE);
981 OMP_CLAUSE_DECL (tmp) = dovar;
982 omp_clauses = gfc_trans_add_clause (tmp, omp_clauses);
986 tmp = build_omp_clause (OMP_CLAUSE_PRIVATE);
987 OMP_CLAUSE_DECL (tmp) = count;
988 omp_clauses = gfc_trans_add_clause (tmp, omp_clauses);
991 /* Cycle statement is implemented with a goto. Exit statement must not be
992 present for this loop. */
993 cycle_label = gfc_build_label_decl (NULL_TREE);
995 /* Put these labels where they can be found later. We put the
996 labels in a TREE_LIST node (because TREE_CHAIN is already
997 used). cycle_label goes in TREE_PURPOSE (backend_decl), exit
998 label in TREE_VALUE (backend_decl). */
1000 code->block->backend_decl = tree_cons (cycle_label, NULL, NULL);
1002 /* Main loop body. */
1003 tmp = gfc_trans_omp_code (code->block->next, true);
1004 gfc_add_expr_to_block (&body, tmp);
1006 /* Label for cycle statements (if needed). */
1007 if (TREE_USED (cycle_label))
1009 tmp = build1_v (LABEL_EXPR, cycle_label);
1010 gfc_add_expr_to_block (&body, tmp);
1013 /* End of loop body. */
1014 stmt = make_node (OMP_FOR);
1016 TREE_TYPE (stmt) = void_type_node;
1017 OMP_FOR_BODY (stmt) = gfc_finish_block (&body);
1018 OMP_FOR_CLAUSES (stmt) = omp_clauses;
1019 OMP_FOR_INIT (stmt) = init;
1020 OMP_FOR_COND (stmt) = cond;
1021 OMP_FOR_INCR (stmt) = incr;
1022 gfc_add_expr_to_block (&block, stmt);
1024 return gfc_finish_block (&block);
1028 gfc_trans_omp_flush (void)
1030 tree decl = built_in_decls [BUILT_IN_SYNCHRONIZE];
1031 return build_function_call_expr (decl, NULL);
1035 gfc_trans_omp_master (gfc_code *code)
1037 tree stmt = gfc_trans_code (code->block->next);
1038 if (IS_EMPTY_STMT (stmt))
1040 return build1_v (OMP_MASTER, stmt);
1044 gfc_trans_omp_ordered (gfc_code *code)
1046 return build1_v (OMP_ORDERED, gfc_trans_code (code->block->next));
1050 gfc_trans_omp_parallel (gfc_code *code)
1053 tree stmt, omp_clauses;
1055 gfc_start_block (&block);
1056 omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
1058 stmt = gfc_trans_omp_code (code->block->next, true);
1059 stmt = build4_v (OMP_PARALLEL, stmt, omp_clauses, NULL, NULL);
1060 gfc_add_expr_to_block (&block, stmt);
1061 return gfc_finish_block (&block);
1065 gfc_trans_omp_parallel_do (gfc_code *code)
1067 stmtblock_t block, *pblock = NULL;
1068 gfc_omp_clauses parallel_clauses, do_clauses;
1069 tree stmt, omp_clauses = NULL_TREE;
1071 gfc_start_block (&block);
1073 memset (&do_clauses, 0, sizeof (do_clauses));
1074 if (code->ext.omp_clauses != NULL)
1076 memcpy (¶llel_clauses, code->ext.omp_clauses,
1077 sizeof (parallel_clauses));
1078 do_clauses.sched_kind = parallel_clauses.sched_kind;
1079 do_clauses.chunk_size = parallel_clauses.chunk_size;
1080 do_clauses.ordered = parallel_clauses.ordered;
1081 parallel_clauses.sched_kind = OMP_SCHED_NONE;
1082 parallel_clauses.chunk_size = NULL;
1083 parallel_clauses.ordered = false;
1084 omp_clauses = gfc_trans_omp_clauses (&block, ¶llel_clauses,
1087 do_clauses.nowait = true;
1088 if (!do_clauses.ordered && do_clauses.sched_kind != OMP_SCHED_STATIC)
1092 stmt = gfc_trans_omp_do (code, pblock, &do_clauses);
1093 if (TREE_CODE (stmt) != BIND_EXPR)
1094 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0));
1097 stmt = build4_v (OMP_PARALLEL, stmt, omp_clauses, NULL, NULL);
1098 OMP_PARALLEL_COMBINED (stmt) = 1;
1099 gfc_add_expr_to_block (&block, stmt);
1100 return gfc_finish_block (&block);
1104 gfc_trans_omp_parallel_sections (gfc_code *code)
1107 gfc_omp_clauses section_clauses;
1108 tree stmt, omp_clauses;
1110 memset (§ion_clauses, 0, sizeof (section_clauses));
1111 section_clauses.nowait = true;
1113 gfc_start_block (&block);
1114 omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
1117 stmt = gfc_trans_omp_sections (code, §ion_clauses);
1118 if (TREE_CODE (stmt) != BIND_EXPR)
1119 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0));
1122 stmt = build4_v (OMP_PARALLEL, stmt, omp_clauses, NULL, NULL);
1123 OMP_PARALLEL_COMBINED (stmt) = 1;
1124 gfc_add_expr_to_block (&block, stmt);
1125 return gfc_finish_block (&block);
1129 gfc_trans_omp_parallel_workshare (gfc_code *code)
1132 gfc_omp_clauses workshare_clauses;
1133 tree stmt, omp_clauses;
1135 memset (&workshare_clauses, 0, sizeof (workshare_clauses));
1136 workshare_clauses.nowait = true;
1138 gfc_start_block (&block);
1139 omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
1142 stmt = gfc_trans_omp_workshare (code, &workshare_clauses);
1143 if (TREE_CODE (stmt) != BIND_EXPR)
1144 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0));
1147 stmt = build4_v (OMP_PARALLEL, stmt, omp_clauses, NULL, NULL);
1148 OMP_PARALLEL_COMBINED (stmt) = 1;
1149 gfc_add_expr_to_block (&block, stmt);
1150 return gfc_finish_block (&block);
1154 gfc_trans_omp_sections (gfc_code *code, gfc_omp_clauses *clauses)
1156 stmtblock_t block, body;
1157 tree omp_clauses, stmt;
1158 bool has_lastprivate = clauses->lists[OMP_LIST_LASTPRIVATE] != NULL;
1160 gfc_start_block (&block);
1162 omp_clauses = gfc_trans_omp_clauses (&block, clauses, code->loc);
1164 gfc_init_block (&body);
1165 for (code = code->block; code; code = code->block)
1167 /* Last section is special because of lastprivate, so even if it
1168 is empty, chain it in. */
1169 stmt = gfc_trans_omp_code (code->next,
1170 has_lastprivate && code->block == NULL);
1171 if (! IS_EMPTY_STMT (stmt))
1173 stmt = build1_v (OMP_SECTION, stmt);
1174 gfc_add_expr_to_block (&body, stmt);
1177 stmt = gfc_finish_block (&body);
1179 stmt = build2_v (OMP_SECTIONS, stmt, omp_clauses);
1180 gfc_add_expr_to_block (&block, stmt);
1182 return gfc_finish_block (&block);
1186 gfc_trans_omp_single (gfc_code *code, gfc_omp_clauses *clauses)
1188 tree omp_clauses = gfc_trans_omp_clauses (NULL, clauses, code->loc);
1189 tree stmt = gfc_trans_omp_code (code->block->next, true);
1190 stmt = build2_v (OMP_SINGLE, stmt, omp_clauses);
1195 gfc_trans_omp_workshare (gfc_code *code, gfc_omp_clauses *clauses)
1198 return gfc_trans_omp_single (code, clauses);
1202 gfc_trans_omp_directive (gfc_code *code)
1206 case EXEC_OMP_ATOMIC:
1207 return gfc_trans_omp_atomic (code);
1208 case EXEC_OMP_BARRIER:
1209 return gfc_trans_omp_barrier ();
1210 case EXEC_OMP_CRITICAL:
1211 return gfc_trans_omp_critical (code);
1213 return gfc_trans_omp_do (code, NULL, code->ext.omp_clauses);
1214 case EXEC_OMP_FLUSH:
1215 return gfc_trans_omp_flush ();
1216 case EXEC_OMP_MASTER:
1217 return gfc_trans_omp_master (code);
1218 case EXEC_OMP_ORDERED:
1219 return gfc_trans_omp_ordered (code);
1220 case EXEC_OMP_PARALLEL:
1221 return gfc_trans_omp_parallel (code);
1222 case EXEC_OMP_PARALLEL_DO:
1223 return gfc_trans_omp_parallel_do (code);
1224 case EXEC_OMP_PARALLEL_SECTIONS:
1225 return gfc_trans_omp_parallel_sections (code);
1226 case EXEC_OMP_PARALLEL_WORKSHARE:
1227 return gfc_trans_omp_parallel_workshare (code);
1228 case EXEC_OMP_SECTIONS:
1229 return gfc_trans_omp_sections (code, code->ext.omp_clauses);
1230 case EXEC_OMP_SINGLE:
1231 return gfc_trans_omp_single (code, code->ext.omp_clauses);
1232 case EXEC_OMP_WORKSHARE:
1233 return gfc_trans_omp_workshare (code, code->ext.omp_clauses);