1 /* Pass manager for Fortran front end.
2 Copyright (C) 2010, 2011, 2012 Free Software Foundation, Inc.
3 Contributed by Thomas König.
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
23 #include "coretypes.h"
27 #include "dependency.h"
28 #include "constructor.h"
31 /* Forward declarations. */
33 static void strip_function_call (gfc_expr
*);
34 static void optimize_namespace (gfc_namespace
*);
35 static void optimize_assignment (gfc_code
*);
36 static bool optimize_op (gfc_expr
*);
37 static bool optimize_comparison (gfc_expr
*, gfc_intrinsic_op
);
38 static bool optimize_trim (gfc_expr
*);
39 static bool optimize_lexical_comparison (gfc_expr
*);
40 static void optimize_minmaxloc (gfc_expr
**);
41 static bool is_empty_string (gfc_expr
*e
);
42 static void doloop_warn (gfc_namespace
*);
44 /* How deep we are inside an argument list. */
46 static int count_arglist
;
48 /* Pointer to an array of gfc_expr ** we operate on, plus its size
51 static gfc_expr
***expr_array
;
52 static int expr_size
, expr_count
;
54 /* Pointer to the gfc_code we currently work on - to be able to insert
55 a block before the statement. */
57 static gfc_code
**current_code
;
59 /* Pointer to the block to be inserted, and the statement we are
60 changing within the block. */
62 static gfc_code
*inserted_block
, **changed_statement
;
64 /* The namespace we are currently dealing with. */
66 static gfc_namespace
*current_ns
;
68 /* If we are within any forall loop. */
70 static int forall_level
;
72 /* Keep track of whether we are within an OMP workshare. */
74 static bool in_omp_workshare
;
76 /* Keep track of iterators for array constructors. */
78 static int iterator_level
;
80 /* Keep track of DO loop levels. */
82 static gfc_code
**doloop_list
;
83 static int doloop_size
, doloop_level
;
85 /* Vector of gfc_expr * to keep track of DO loops. */
87 struct my_struct
*evec
;
89 /* Entry point - run all passes for a namespace. */
92 gfc_run_passes (gfc_namespace
*ns
)
95 /* Warn about dubious DO loops where the index might
100 doloop_list
= XNEWVEC(gfc_code
*, doloop_size
);
102 XDELETEVEC (doloop_list
);
104 if (gfc_option
.flag_frontend_optimize
)
107 expr_array
= XNEWVEC(gfc_expr
**, expr_size
);
109 optimize_namespace (ns
);
110 if (gfc_option
.dump_fortran_optimized
)
111 gfc_dump_parse_tree (ns
, stdout
);
113 XDELETEVEC (expr_array
);
117 /* Callback for each gfc_code node invoked through gfc_code_walker
118 from optimize_namespace. */
121 optimize_code (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
122 void *data ATTRIBUTE_UNUSED
)
129 if (op
== EXEC_CALL
|| op
== EXEC_COMPCALL
|| op
== EXEC_ASSIGN_CALL
130 || op
== EXEC_CALL_PPC
)
135 if (op
== EXEC_ASSIGN
)
136 optimize_assignment (*c
);
140 /* Callback for each gfc_expr node invoked through gfc_code_walker
141 from optimize_namespace. */
144 optimize_expr (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
145 void *data ATTRIBUTE_UNUSED
)
149 if ((*e
)->expr_type
== EXPR_FUNCTION
)
152 function_expr
= true;
155 function_expr
= false;
157 if (optimize_trim (*e
))
158 gfc_simplify_expr (*e
, 0);
160 if (optimize_lexical_comparison (*e
))
161 gfc_simplify_expr (*e
, 0);
163 if ((*e
)->expr_type
== EXPR_OP
&& optimize_op (*e
))
164 gfc_simplify_expr (*e
, 0);
166 if ((*e
)->expr_type
== EXPR_FUNCTION
&& (*e
)->value
.function
.isym
)
167 switch ((*e
)->value
.function
.isym
->id
)
169 case GFC_ISYM_MINLOC
:
170 case GFC_ISYM_MAXLOC
:
171 optimize_minmaxloc (e
);
184 /* Callback function for common function elimination, called from cfe_expr_0.
185 Put all eligible function expressions into expr_array. */
188 cfe_register_funcs (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
189 void *data ATTRIBUTE_UNUSED
)
192 if ((*e
)->expr_type
!= EXPR_FUNCTION
)
195 /* We don't do character functions with unknown charlens. */
196 if ((*e
)->ts
.type
== BT_CHARACTER
197 && ((*e
)->ts
.u
.cl
== NULL
|| (*e
)->ts
.u
.cl
->length
== NULL
198 || (*e
)->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
201 /* We don't do function elimination within FORALL statements, it can
202 lead to wrong-code in certain circumstances. */
204 if (forall_level
> 0)
207 /* Function elimination inside an iterator could lead to functions which
208 depend on iterator variables being moved outside. FIXME: We should check
209 if the functions do indeed depend on the iterator variable. */
211 if (iterator_level
> 0)
214 /* If we don't know the shape at compile time, we create an allocatable
215 temporary variable to hold the intermediate result, but only if
216 allocation on assignment is active. */
218 if ((*e
)->rank
> 0 && (*e
)->shape
== NULL
&& !gfc_option
.flag_realloc_lhs
)
221 /* Skip the test for pure functions if -faggressive-function-elimination
223 if ((*e
)->value
.function
.esym
)
225 /* Don't create an array temporary for elemental functions. */
226 if ((*e
)->value
.function
.esym
->attr
.elemental
&& (*e
)->rank
> 0)
229 /* Only eliminate potentially impure functions if the
230 user specifically requested it. */
231 if (!gfc_option
.flag_aggressive_function_elimination
232 && !(*e
)->value
.function
.esym
->attr
.pure
233 && !(*e
)->value
.function
.esym
->attr
.implicit_pure
)
237 if ((*e
)->value
.function
.isym
)
239 /* Conversions are handled on the fly by the middle end,
240 transpose during trans-* stages and TRANSFER by the middle end. */
241 if ((*e
)->value
.function
.isym
->id
== GFC_ISYM_CONVERSION
242 || (*e
)->value
.function
.isym
->id
== GFC_ISYM_TRANSFER
243 || gfc_inline_intrinsic_function_p (*e
))
246 /* Don't create an array temporary for elemental functions,
247 as this would be wasteful of memory.
248 FIXME: Create a scalar temporary during scalarization. */
249 if ((*e
)->value
.function
.isym
->elemental
&& (*e
)->rank
> 0)
252 if (!(*e
)->value
.function
.isym
->pure
)
256 if (expr_count
>= expr_size
)
258 expr_size
+= expr_size
;
259 expr_array
= XRESIZEVEC(gfc_expr
**, expr_array
, expr_size
);
261 expr_array
[expr_count
] = e
;
266 /* Returns a new expression (a variable) to be used in place of the old one,
267 with an assignment statement before the current statement to set
268 the value of the variable. Creates a new BLOCK for the statement if
269 that hasn't already been done and puts the statement, plus the
270 newly created variables, in that block. */
273 create_var (gfc_expr
* e
)
275 char name
[GFC_MAX_SYMBOL_LEN
+1];
277 gfc_symtree
*symtree
;
284 /* If the block hasn't already been created, do so. */
285 if (inserted_block
== NULL
)
287 inserted_block
= XCNEW (gfc_code
);
288 inserted_block
->op
= EXEC_BLOCK
;
289 inserted_block
->loc
= (*current_code
)->loc
;
290 ns
= gfc_build_block_ns (current_ns
);
291 inserted_block
->ext
.block
.ns
= ns
;
292 inserted_block
->ext
.block
.assoc
= NULL
;
294 ns
->code
= *current_code
;
296 /* If the statement has a label, make sure it is transferred to
297 the newly created block. */
299 if ((*current_code
)->here
)
301 inserted_block
->here
= (*current_code
)->here
;
302 (*current_code
)->here
= NULL
;
305 inserted_block
->next
= (*current_code
)->next
;
306 changed_statement
= &(inserted_block
->ext
.block
.ns
->code
);
307 (*current_code
)->next
= NULL
;
308 /* Insert the BLOCK at the right position. */
309 *current_code
= inserted_block
;
310 ns
->parent
= current_ns
;
313 ns
= inserted_block
->ext
.block
.ns
;
315 sprintf(name
, "__var_%d",num
++);
316 if (gfc_get_sym_tree (name
, ns
, &symtree
, false) != 0)
319 symbol
= symtree
->n
.sym
;
324 symbol
->as
= gfc_get_array_spec ();
325 symbol
->as
->rank
= e
->rank
;
327 if (e
->shape
== NULL
)
329 /* We don't know the shape at compile time, so we use an
331 symbol
->as
->type
= AS_DEFERRED
;
332 symbol
->attr
.allocatable
= 1;
336 symbol
->as
->type
= AS_EXPLICIT
;
337 /* Copy the shape. */
338 for (i
=0; i
<e
->rank
; i
++)
342 p
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
344 mpz_set_si (p
->value
.integer
, 1);
345 symbol
->as
->lower
[i
] = p
;
347 q
= gfc_get_constant_expr (BT_INTEGER
, gfc_index_integer_kind
,
349 mpz_set (q
->value
.integer
, e
->shape
[i
]);
350 symbol
->as
->upper
[i
] = q
;
355 symbol
->attr
.flavor
= FL_VARIABLE
;
356 symbol
->attr
.referenced
= 1;
357 symbol
->attr
.dimension
= e
->rank
> 0;
358 gfc_commit_symbol (symbol
);
360 result
= gfc_get_expr ();
361 result
->expr_type
= EXPR_VARIABLE
;
363 result
->rank
= e
->rank
;
364 result
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
365 result
->symtree
= symtree
;
366 result
->where
= e
->where
;
369 result
->ref
= gfc_get_ref ();
370 result
->ref
->type
= REF_ARRAY
;
371 result
->ref
->u
.ar
.type
= AR_FULL
;
372 result
->ref
->u
.ar
.where
= e
->where
;
373 result
->ref
->u
.ar
.as
= symbol
->ts
.type
== BT_CLASS
374 ? CLASS_DATA (symbol
)->as
: symbol
->as
;
375 if (gfc_option
.warn_array_temp
)
376 gfc_warning ("Creating array temporary at %L", &(e
->where
));
379 /* Generate the new assignment. */
380 n
= XCNEW (gfc_code
);
382 n
->loc
= (*current_code
)->loc
;
383 n
->next
= *changed_statement
;
384 n
->expr1
= gfc_copy_expr (result
);
386 *changed_statement
= n
;
391 /* Warn about function elimination. */
394 warn_function_elimination (gfc_expr
*e
)
396 if (e
->expr_type
!= EXPR_FUNCTION
)
398 if (e
->value
.function
.esym
)
399 gfc_warning ("Removing call to function '%s' at %L",
400 e
->value
.function
.esym
->name
, &(e
->where
));
401 else if (e
->value
.function
.isym
)
402 gfc_warning ("Removing call to function '%s' at %L",
403 e
->value
.function
.isym
->name
, &(e
->where
));
405 /* Callback function for the code walker for doing common function
406 elimination. This builds up the list of functions in the expression
407 and goes through them to detect duplicates, which it then replaces
411 cfe_expr_0 (gfc_expr
**e
, int *walk_subtrees
,
412 void *data ATTRIBUTE_UNUSED
)
417 /* Don't do this optimization within OMP workshare. */
419 if (in_omp_workshare
)
427 gfc_expr_walker (e
, cfe_register_funcs
, NULL
);
429 /* Walk through all the functions. */
431 for (i
=1; i
<expr_count
; i
++)
433 /* Skip if the function has been replaced by a variable already. */
434 if ((*(expr_array
[i
]))->expr_type
== EXPR_VARIABLE
)
440 if (gfc_dep_compare_functions(*(expr_array
[i
]),
441 *(expr_array
[j
]), true) == 0)
444 newvar
= create_var (*(expr_array
[i
]));
446 if (gfc_option
.warn_function_elimination
)
447 warn_function_elimination (*(expr_array
[j
]));
449 free (*(expr_array
[j
]));
450 *(expr_array
[j
]) = gfc_copy_expr (newvar
);
454 *(expr_array
[i
]) = newvar
;
457 /* We did all the necessary walking in this function. */
462 /* Callback function for common function elimination, called from
463 gfc_code_walker. This keeps track of the current code, in order
464 to insert statements as needed. */
467 cfe_code (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
468 void *data ATTRIBUTE_UNUSED
)
471 inserted_block
= NULL
;
472 changed_statement
= NULL
;
476 /* Dummy function for expression call back, for use when we
477 really don't want to do any walking. */
480 dummy_expr_callback (gfc_expr
**e ATTRIBUTE_UNUSED
, int *walk_subtrees
,
481 void *data ATTRIBUTE_UNUSED
)
487 /* Code callback function for converting
494 This is because common function elimination would otherwise place the
495 temporary variables outside the loop. */
498 convert_do_while (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
499 void *data ATTRIBUTE_UNUSED
)
502 gfc_code
*c_if1
, *c_if2
, *c_exit
;
504 gfc_expr
*e_not
, *e_cond
;
506 if (co
->op
!= EXEC_DO_WHILE
)
509 if (co
->expr1
== NULL
|| co
->expr1
->expr_type
== EXPR_CONSTANT
)
514 /* Generate the condition of the if statement, which is .not. the original
516 e_not
= gfc_get_expr ();
517 e_not
->ts
= e_cond
->ts
;
518 e_not
->where
= e_cond
->where
;
519 e_not
->expr_type
= EXPR_OP
;
520 e_not
->value
.op
.op
= INTRINSIC_NOT
;
521 e_not
->value
.op
.op1
= e_cond
;
523 /* Generate the EXIT statement. */
524 c_exit
= XCNEW (gfc_code
);
525 c_exit
->op
= EXEC_EXIT
;
526 c_exit
->ext
.which_construct
= co
;
527 c_exit
->loc
= co
->loc
;
529 /* Generate the IF statement. */
530 c_if2
= XCNEW (gfc_code
);
532 c_if2
->expr1
= e_not
;
533 c_if2
->next
= c_exit
;
534 c_if2
->loc
= co
->loc
;
536 /* ... plus the one to chain it to. */
537 c_if1
= XCNEW (gfc_code
);
539 c_if1
->block
= c_if2
;
540 c_if1
->loc
= co
->loc
;
542 /* Make the DO WHILE loop into a DO block by replacing the condition
543 with a true constant. */
544 co
->expr1
= gfc_get_logical_expr (gfc_default_integer_kind
, &co
->loc
, true);
546 /* Hang the generated if statement into the loop body. */
548 loopblock
= co
->block
->next
;
549 co
->block
->next
= c_if1
;
550 c_if1
->next
= loopblock
;
555 /* Code callback function for converting
568 because otherwise common function elimination would place the BLOCKs
569 into the wrong place. */
572 convert_elseif (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
573 void *data ATTRIBUTE_UNUSED
)
576 gfc_code
*c_if1
, *c_if2
, *else_stmt
;
578 if (co
->op
!= EXEC_IF
)
581 /* This loop starts out with the first ELSE statement. */
582 else_stmt
= co
->block
->block
;
584 while (else_stmt
!= NULL
)
588 /* If there is no condition, we're done. */
589 if (else_stmt
->expr1
== NULL
)
592 next_else
= else_stmt
->block
;
594 /* Generate the new IF statement. */
595 c_if2
= XCNEW (gfc_code
);
597 c_if2
->expr1
= else_stmt
->expr1
;
598 c_if2
->next
= else_stmt
->next
;
599 c_if2
->loc
= else_stmt
->loc
;
600 c_if2
->block
= next_else
;
602 /* ... plus the one to chain it to. */
603 c_if1
= XCNEW (gfc_code
);
605 c_if1
->block
= c_if2
;
606 c_if1
->loc
= else_stmt
->loc
;
608 /* Insert the new IF after the ELSE. */
609 else_stmt
->expr1
= NULL
;
610 else_stmt
->next
= c_if1
;
611 else_stmt
->block
= NULL
;
613 else_stmt
= next_else
;
615 /* Don't walk subtrees. */
618 /* Optimize a namespace, including all contained namespaces. */
621 optimize_namespace (gfc_namespace
*ns
)
627 in_omp_workshare
= false;
629 gfc_code_walker (&ns
->code
, convert_do_while
, dummy_expr_callback
, NULL
);
630 gfc_code_walker (&ns
->code
, convert_elseif
, dummy_expr_callback
, NULL
);
631 gfc_code_walker (&ns
->code
, cfe_code
, cfe_expr_0
, NULL
);
632 gfc_code_walker (&ns
->code
, optimize_code
, optimize_expr
, NULL
);
634 /* BLOCKs are handled in the expression walker below. */
635 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
637 if (ns
->code
== NULL
|| ns
->code
->op
!= EXEC_BLOCK
)
638 optimize_namespace (ns
);
645 a = matmul(b,c) ; a = a + d
646 where the array function is not elemental and not allocatable
647 and does not depend on the left-hand side.
651 optimize_binop_array_assignment (gfc_code
*c
, gfc_expr
**rhs
, bool seen_op
)
656 if (e
->expr_type
== EXPR_OP
)
658 switch (e
->value
.op
.op
)
660 /* Unary operators and exponentiation: Only look at a single
663 case INTRINSIC_UPLUS
:
664 case INTRINSIC_UMINUS
:
665 case INTRINSIC_PARENTHESES
:
666 case INTRINSIC_POWER
:
667 if (optimize_binop_array_assignment (c
, &e
->value
.op
.op1
, seen_op
))
672 /* Binary operators. */
673 if (optimize_binop_array_assignment (c
, &e
->value
.op
.op1
, true))
676 if (optimize_binop_array_assignment (c
, &e
->value
.op
.op2
, true))
682 else if (seen_op
&& e
->expr_type
== EXPR_FUNCTION
&& e
->rank
> 0
683 && ! (e
->value
.function
.esym
684 && (e
->value
.function
.esym
->attr
.elemental
685 || e
->value
.function
.esym
->attr
.allocatable
686 || e
->value
.function
.esym
->ts
.type
!= c
->expr1
->ts
.type
687 || e
->value
.function
.esym
->ts
.kind
!= c
->expr1
->ts
.kind
))
688 && ! (e
->value
.function
.isym
689 && (e
->value
.function
.isym
->elemental
690 || e
->ts
.type
!= c
->expr1
->ts
.type
691 || e
->ts
.kind
!= c
->expr1
->ts
.kind
))
692 && ! gfc_inline_intrinsic_function_p (e
))
698 /* Insert a new assignment statement after the current one. */
699 n
= XCNEW (gfc_code
);
705 n
->expr1
= gfc_copy_expr (c
->expr1
);
707 new_expr
= gfc_copy_expr (c
->expr1
);
715 /* Nothing to optimize. */
719 /* Remove unneeded TRIMs at the end of expressions. */
722 remove_trim (gfc_expr
*rhs
)
728 /* Check for a // b // trim(c). Looping is probably not
729 necessary because the parser usually generates
730 (// (// a b ) trim(c) ) , but better safe than sorry. */
732 while (rhs
->expr_type
== EXPR_OP
733 && rhs
->value
.op
.op
== INTRINSIC_CONCAT
)
734 rhs
= rhs
->value
.op
.op2
;
736 while (rhs
->expr_type
== EXPR_FUNCTION
&& rhs
->value
.function
.isym
737 && rhs
->value
.function
.isym
->id
== GFC_ISYM_TRIM
)
739 strip_function_call (rhs
);
740 /* Recursive call to catch silly stuff like trim ( a // trim(b)). */
748 /* Optimizations for an assignment. */
751 optimize_assignment (gfc_code
* c
)
758 if (lhs
->ts
.type
== BT_CHARACTER
&& !lhs
->ts
.deferred
)
760 /* Optimize a = trim(b) to a = b. */
763 /* Replace a = ' ' by a = '' to optimize away a memcpy. */
764 if (is_empty_string(rhs
))
765 rhs
->value
.character
.length
= 0;
768 if (lhs
->rank
> 0 && gfc_check_dependency (lhs
, rhs
, true) == 0)
769 optimize_binop_array_assignment (c
, &rhs
, false);
773 /* Remove an unneeded function call, modifying the expression.
774 This replaces the function call with the value of its
775 first argument. The rest of the argument list is freed. */
778 strip_function_call (gfc_expr
*e
)
781 gfc_actual_arglist
*a
;
783 a
= e
->value
.function
.actual
;
785 /* We should have at least one argument. */
786 gcc_assert (a
->expr
!= NULL
);
790 /* Free the remaining arglist, if any. */
792 gfc_free_actual_arglist (a
->next
);
794 /* Graft the argument expression onto the original function. */
800 /* Optimization of lexical comparison functions. */
803 optimize_lexical_comparison (gfc_expr
*e
)
805 if (e
->expr_type
!= EXPR_FUNCTION
|| e
->value
.function
.isym
== NULL
)
808 switch (e
->value
.function
.isym
->id
)
811 return optimize_comparison (e
, INTRINSIC_LE
);
814 return optimize_comparison (e
, INTRINSIC_GE
);
817 return optimize_comparison (e
, INTRINSIC_GT
);
820 return optimize_comparison (e
, INTRINSIC_LT
);
828 /* Recursive optimization of operators. */
831 optimize_op (gfc_expr
*e
)
833 gfc_intrinsic_op op
= e
->value
.op
.op
;
835 /* Only use new-style comparisons. */
838 case INTRINSIC_EQ_OS
:
842 case INTRINSIC_GE_OS
:
846 case INTRINSIC_LE_OS
:
850 case INTRINSIC_NE_OS
:
854 case INTRINSIC_GT_OS
:
858 case INTRINSIC_LT_OS
:
874 return optimize_comparison (e
, op
);
884 /* Return true if a constant string contains only blanks. */
887 is_empty_string (gfc_expr
*e
)
891 if (e
->ts
.type
!= BT_CHARACTER
|| e
->expr_type
!= EXPR_CONSTANT
)
894 for (i
=0; i
< e
->value
.character
.length
; i
++)
896 if (e
->value
.character
.string
[i
] != ' ')
904 /* Insert a call to the intrinsic len_trim. Use a different name for
905 the symbol tree so we don't run into trouble when the user has
906 renamed len_trim for some reason. */
909 get_len_trim_call (gfc_expr
*str
, int kind
)
912 gfc_actual_arglist
*actual_arglist
, *next
;
914 fcn
= gfc_get_expr ();
915 fcn
->expr_type
= EXPR_FUNCTION
;
916 fcn
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_LEN_TRIM
);
917 actual_arglist
= gfc_get_actual_arglist ();
918 actual_arglist
->expr
= str
;
919 next
= gfc_get_actual_arglist ();
920 next
->expr
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, kind
);
921 actual_arglist
->next
= next
;
923 fcn
->value
.function
.actual
= actual_arglist
;
924 fcn
->where
= str
->where
;
925 fcn
->ts
.type
= BT_INTEGER
;
926 fcn
->ts
.kind
= gfc_charlen_int_kind
;
928 gfc_get_sym_tree ("__internal_len_trim", current_ns
, &fcn
->symtree
, false);
929 fcn
->symtree
->n
.sym
->ts
= fcn
->ts
;
930 fcn
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
931 fcn
->symtree
->n
.sym
->attr
.function
= 1;
932 fcn
->symtree
->n
.sym
->attr
.elemental
= 1;
933 fcn
->symtree
->n
.sym
->attr
.referenced
= 1;
934 fcn
->symtree
->n
.sym
->attr
.access
= ACCESS_PRIVATE
;
935 gfc_commit_symbol (fcn
->symtree
->n
.sym
);
940 /* Optimize expressions for equality. */
943 optimize_comparison (gfc_expr
*e
, gfc_intrinsic_op op
)
949 gfc_actual_arglist
*firstarg
, *secondarg
;
951 if (e
->expr_type
== EXPR_OP
)
955 op1
= e
->value
.op
.op1
;
956 op2
= e
->value
.op
.op2
;
958 else if (e
->expr_type
== EXPR_FUNCTION
)
960 /* One of the lexical comparison functions. */
961 firstarg
= e
->value
.function
.actual
;
962 secondarg
= firstarg
->next
;
963 op1
= firstarg
->expr
;
964 op2
= secondarg
->expr
;
969 /* Strip off unneeded TRIM calls from string comparisons. */
971 change
= remove_trim (op1
);
973 if (remove_trim (op2
))
976 /* An expression of type EXPR_CONSTANT is only valid for scalars. */
977 /* TODO: A scalar constant may be acceptable in some cases (the scalarizer
978 handles them well). However, there are also cases that need a non-scalar
979 argument. For example the any intrinsic. See PR 45380. */
983 /* Replace a == '' with len_trim(a) == 0 and a /= '' with
985 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
986 && (op
== INTRINSIC_EQ
|| op
== INTRINSIC_NE
))
988 bool empty_op1
, empty_op2
;
989 empty_op1
= is_empty_string (op1
);
990 empty_op2
= is_empty_string (op2
);
992 if (empty_op1
|| empty_op2
)
998 /* This can only happen when an error for comparing
999 characters of different kinds has already been issued. */
1000 if (empty_op1
&& empty_op2
)
1003 zero
= gfc_get_int_expr (gfc_charlen_int_kind
, &e
->where
, 0);
1004 str
= empty_op1
? op2
: op1
;
1006 fcn
= get_len_trim_call (str
, gfc_charlen_int_kind
);
1010 gfc_free_expr (op1
);
1012 gfc_free_expr (op2
);
1016 e
->value
.op
.op1
= fcn
;
1017 e
->value
.op
.op2
= zero
;
1022 /* Don't compare REAL or COMPLEX expressions when honoring NaNs. */
1024 if (flag_finite_math_only
1025 || (op1
->ts
.type
!= BT_REAL
&& op2
->ts
.type
!= BT_REAL
1026 && op1
->ts
.type
!= BT_COMPLEX
&& op2
->ts
.type
!= BT_COMPLEX
))
1028 eq
= gfc_dep_compare_expr (op1
, op2
);
1031 /* Replace A // B < A // C with B < C, and A // B < C // B
1033 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
1034 && op1
->value
.op
.op
== INTRINSIC_CONCAT
1035 && op2
->value
.op
.op
== INTRINSIC_CONCAT
)
1037 gfc_expr
*op1_left
= op1
->value
.op
.op1
;
1038 gfc_expr
*op2_left
= op2
->value
.op
.op1
;
1039 gfc_expr
*op1_right
= op1
->value
.op
.op2
;
1040 gfc_expr
*op2_right
= op2
->value
.op
.op2
;
1042 if (gfc_dep_compare_expr (op1_left
, op2_left
) == 0)
1044 /* Watch out for 'A ' // x vs. 'A' // x. */
1046 if (op1_left
->expr_type
== EXPR_CONSTANT
1047 && op2_left
->expr_type
== EXPR_CONSTANT
1048 && op1_left
->value
.character
.length
1049 != op2_left
->value
.character
.length
)
1057 firstarg
->expr
= op1_right
;
1058 secondarg
->expr
= op2_right
;
1062 e
->value
.op
.op1
= op1_right
;
1063 e
->value
.op
.op2
= op2_right
;
1065 optimize_comparison (e
, op
);
1069 if (gfc_dep_compare_expr (op1_right
, op2_right
) == 0)
1075 firstarg
->expr
= op1_left
;
1076 secondarg
->expr
= op2_left
;
1080 e
->value
.op
.op1
= op1_left
;
1081 e
->value
.op
.op2
= op2_left
;
1084 optimize_comparison (e
, op
);
1091 /* eq can only be -1, 0 or 1 at this point. */
1119 gfc_internal_error ("illegal OP in optimize_comparison");
1123 /* Replace the expression by a constant expression. The typespec
1124 and where remains the way it is. */
1127 e
->expr_type
= EXPR_CONSTANT
;
1128 e
->value
.logical
= result
;
1136 /* Optimize a trim function by replacing it with an equivalent substring
1137 involving a call to len_trim. This only works for expressions where
1138 variables are trimmed. Return true if anything was modified. */
1141 optimize_trim (gfc_expr
*e
)
1146 gfc_ref
**rr
= NULL
;
1148 /* Don't do this optimization within an argument list, because
1149 otherwise aliasing issues may occur. */
1151 if (count_arglist
!= 1)
1154 if (e
->ts
.type
!= BT_CHARACTER
|| e
->expr_type
!= EXPR_FUNCTION
1155 || e
->value
.function
.isym
== NULL
1156 || e
->value
.function
.isym
->id
!= GFC_ISYM_TRIM
)
1159 a
= e
->value
.function
.actual
->expr
;
1161 if (a
->expr_type
!= EXPR_VARIABLE
)
1164 /* Follow all references to find the correct place to put the newly
1165 created reference. FIXME: Also handle substring references and
1166 array references. Array references cause strange regressions at
1171 for (rr
= &(a
->ref
); *rr
; rr
= &((*rr
)->next
))
1173 if ((*rr
)->type
== REF_SUBSTRING
|| (*rr
)->type
== REF_ARRAY
)
1178 strip_function_call (e
);
1183 /* Create the reference. */
1185 ref
= gfc_get_ref ();
1186 ref
->type
= REF_SUBSTRING
;
1188 /* Set the start of the reference. */
1190 ref
->u
.ss
.start
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
1192 /* Build the function call to len_trim(x, gfc_default_integer_kind). */
1194 fcn
= get_len_trim_call (gfc_copy_expr (e
), gfc_default_integer_kind
);
1196 /* Set the end of the reference to the call to len_trim. */
1198 ref
->u
.ss
.end
= fcn
;
1199 gcc_assert (rr
!= NULL
&& *rr
== NULL
);
1204 /* Optimize minloc(b), where b is rank 1 array, into
1205 (/ minloc(b, dim=1) /), and similarly for maxloc,
1206 as the latter forms are expanded inline. */
1209 optimize_minmaxloc (gfc_expr
**e
)
1212 gfc_actual_arglist
*a
;
1216 || fn
->value
.function
.actual
== NULL
1217 || fn
->value
.function
.actual
->expr
== NULL
1218 || fn
->value
.function
.actual
->expr
->rank
!= 1)
1221 *e
= gfc_get_array_expr (fn
->ts
.type
, fn
->ts
.kind
, &fn
->where
);
1222 (*e
)->shape
= fn
->shape
;
1225 gfc_constructor_append_expr (&(*e
)->value
.constructor
, fn
, &fn
->where
);
1227 name
= XALLOCAVEC (char, strlen (fn
->value
.function
.name
) + 1);
1228 strcpy (name
, fn
->value
.function
.name
);
1229 p
= strstr (name
, "loc0");
1231 fn
->value
.function
.name
= gfc_get_string (name
);
1232 if (fn
->value
.function
.actual
->next
)
1234 a
= fn
->value
.function
.actual
->next
;
1235 gcc_assert (a
->expr
== NULL
);
1239 a
= gfc_get_actual_arglist ();
1240 fn
->value
.function
.actual
->next
= a
;
1242 a
->expr
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
1244 mpz_set_ui (a
->expr
->value
.integer
, 1);
1247 /* Callback function for code checking that we do not pass a DO variable to an
1248 INTENT(OUT) or INTENT(INOUT) dummy variable. */
1251 doloop_code (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
1252 void *data ATTRIBUTE_UNUSED
)
1256 gfc_formal_arglist
*f
;
1257 gfc_actual_arglist
*a
;
1265 /* Grow the temporary storage if necessary. */
1266 if (doloop_level
>= doloop_size
)
1268 doloop_size
= 2 * doloop_size
;
1269 doloop_list
= XRESIZEVEC (gfc_code
*, doloop_list
, doloop_size
);
1272 /* Mark the DO loop variable if there is one. */
1273 if (co
->ext
.iterator
&& co
->ext
.iterator
->var
)
1274 doloop_list
[doloop_level
] = co
;
1276 doloop_list
[doloop_level
] = NULL
;
1280 f
= co
->symtree
->n
.sym
->formal
;
1282 /* Withot a formal arglist, there is only unknown INTENT,
1283 which we don't check for. */
1291 for (i
=0; i
<doloop_level
; i
++)
1295 if (doloop_list
[i
] == NULL
)
1298 do_sym
= doloop_list
[i
]->ext
.iterator
->var
->symtree
->n
.sym
;
1300 if (a
->expr
&& a
->expr
->symtree
1301 && a
->expr
->symtree
->n
.sym
== do_sym
)
1303 if (f
->sym
->attr
.intent
== INTENT_OUT
)
1304 gfc_error_now("Variable '%s' at %L set to undefined value "
1305 "inside loop beginning at %L as INTENT(OUT) "
1306 "argument to subroutine '%s'", do_sym
->name
,
1307 &a
->expr
->where
, &doloop_list
[i
]->loc
,
1308 co
->symtree
->n
.sym
->name
);
1309 else if (f
->sym
->attr
.intent
== INTENT_INOUT
)
1310 gfc_error_now("Variable '%s' at %L not definable inside loop "
1311 "beginning at %L as INTENT(INOUT) argument to "
1312 "subroutine '%s'", do_sym
->name
,
1313 &a
->expr
->where
, &doloop_list
[i
]->loc
,
1314 co
->symtree
->n
.sym
->name
);
1328 /* Callback function for functions checking that we do not pass a DO variable
1329 to an INTENT(OUT) or INTENT(INOUT) dummy variable. */
1332 do_function (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
1333 void *data ATTRIBUTE_UNUSED
)
1335 gfc_formal_arglist
*f
;
1336 gfc_actual_arglist
*a
;
1341 if (expr
->expr_type
!= EXPR_FUNCTION
)
1344 /* Intrinsic functions don't modify their arguments. */
1346 if (expr
->value
.function
.isym
)
1349 f
= expr
->symtree
->n
.sym
->formal
;
1351 /* Without a formal arglist, there is only unknown INTENT,
1352 which we don't check for. */
1356 a
= expr
->value
.function
.actual
;
1360 for (i
=0; i
<doloop_level
; i
++)
1365 if (doloop_list
[i
] == NULL
)
1368 do_sym
= doloop_list
[i
]->ext
.iterator
->var
->symtree
->n
.sym
;
1370 if (a
->expr
&& a
->expr
->symtree
1371 && a
->expr
->symtree
->n
.sym
== do_sym
)
1373 if (f
->sym
->attr
.intent
== INTENT_OUT
)
1374 gfc_error_now("Variable '%s' at %L set to undefined value "
1375 "inside loop beginning at %L as INTENT(OUT) "
1376 "argument to function '%s'", do_sym
->name
,
1377 &a
->expr
->where
, &doloop_list
[i
]->loc
,
1378 expr
->symtree
->n
.sym
->name
);
1379 else if (f
->sym
->attr
.intent
== INTENT_INOUT
)
1380 gfc_error_now("Variable '%s' at %L not definable inside loop "
1381 "beginning at %L as INTENT(INOUT) argument to "
1382 "function '%s'", do_sym
->name
,
1383 &a
->expr
->where
, &doloop_list
[i
]->loc
,
1384 expr
->symtree
->n
.sym
->name
);
1395 doloop_warn (gfc_namespace
*ns
)
1397 gfc_code_walker (&ns
->code
, doloop_code
, do_function
, NULL
);
1401 #define WALK_SUBEXPR(NODE) \
1404 result = gfc_expr_walker (&(NODE), exprfn, data); \
1409 #define WALK_SUBEXPR_TAIL(NODE) e = &(NODE); continue
1411 /* Walk expression *E, calling EXPRFN on each expression in it. */
1414 gfc_expr_walker (gfc_expr
**e
, walk_expr_fn_t exprfn
, void *data
)
1418 int walk_subtrees
= 1;
1419 gfc_actual_arglist
*a
;
1423 int result
= exprfn (e
, &walk_subtrees
, data
);
1427 switch ((*e
)->expr_type
)
1430 WALK_SUBEXPR ((*e
)->value
.op
.op1
);
1431 WALK_SUBEXPR_TAIL ((*e
)->value
.op
.op2
);
1434 for (a
= (*e
)->value
.function
.actual
; a
; a
= a
->next
)
1435 WALK_SUBEXPR (a
->expr
);
1439 WALK_SUBEXPR ((*e
)->value
.compcall
.base_object
);
1440 for (a
= (*e
)->value
.compcall
.actual
; a
; a
= a
->next
)
1441 WALK_SUBEXPR (a
->expr
);
1444 case EXPR_STRUCTURE
:
1446 for (c
= gfc_constructor_first ((*e
)->value
.constructor
); c
;
1447 c
= gfc_constructor_next (c
))
1449 if (c
->iterator
== NULL
)
1450 WALK_SUBEXPR (c
->expr
);
1454 WALK_SUBEXPR (c
->expr
);
1456 WALK_SUBEXPR (c
->iterator
->var
);
1457 WALK_SUBEXPR (c
->iterator
->start
);
1458 WALK_SUBEXPR (c
->iterator
->end
);
1459 WALK_SUBEXPR (c
->iterator
->step
);
1463 if ((*e
)->expr_type
!= EXPR_ARRAY
)
1466 /* Fall through to the variable case in order to walk the
1469 case EXPR_SUBSTRING
:
1471 for (r
= (*e
)->ref
; r
; r
= r
->next
)
1480 if (ar
->type
== AR_SECTION
|| ar
->type
== AR_ELEMENT
)
1482 for (i
=0; i
< ar
->dimen
; i
++)
1484 WALK_SUBEXPR (ar
->start
[i
]);
1485 WALK_SUBEXPR (ar
->end
[i
]);
1486 WALK_SUBEXPR (ar
->stride
[i
]);
1493 WALK_SUBEXPR (r
->u
.ss
.start
);
1494 WALK_SUBEXPR (r
->u
.ss
.end
);
1510 #define WALK_SUBCODE(NODE) \
1513 result = gfc_code_walker (&(NODE), codefn, exprfn, data); \
1519 /* Walk code *C, calling CODEFN on each gfc_code node in it and calling EXPRFN
1520 on each expression in it. If any of the hooks returns non-zero, that
1521 value is immediately returned. If the hook sets *WALK_SUBTREES to 0,
1522 no subcodes or subexpressions are traversed. */
1525 gfc_code_walker (gfc_code
**c
, walk_code_fn_t codefn
, walk_expr_fn_t exprfn
,
1528 for (; *c
; c
= &(*c
)->next
)
1530 int walk_subtrees
= 1;
1531 int result
= codefn (c
, &walk_subtrees
, data
);
1538 gfc_actual_arglist
*a
;
1540 gfc_association_list
*alist
;
1541 bool saved_in_omp_workshare
;
1543 /* There might be statement insertions before the current code,
1544 which must not affect the expression walker. */
1547 saved_in_omp_workshare
= in_omp_workshare
;
1553 WALK_SUBCODE (co
->ext
.block
.ns
->code
);
1554 for (alist
= co
->ext
.block
.assoc
; alist
; alist
= alist
->next
)
1555 WALK_SUBEXPR (alist
->target
);
1560 WALK_SUBEXPR (co
->ext
.iterator
->var
);
1561 WALK_SUBEXPR (co
->ext
.iterator
->start
);
1562 WALK_SUBEXPR (co
->ext
.iterator
->end
);
1563 WALK_SUBEXPR (co
->ext
.iterator
->step
);
1567 case EXEC_ASSIGN_CALL
:
1568 for (a
= co
->ext
.actual
; a
; a
= a
->next
)
1569 WALK_SUBEXPR (a
->expr
);
1573 WALK_SUBEXPR (co
->expr1
);
1574 for (a
= co
->ext
.actual
; a
; a
= a
->next
)
1575 WALK_SUBEXPR (a
->expr
);
1579 WALK_SUBEXPR (co
->expr1
);
1580 for (b
= co
->block
; b
; b
= b
->block
)
1583 for (cp
= b
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
1585 WALK_SUBEXPR (cp
->low
);
1586 WALK_SUBEXPR (cp
->high
);
1588 WALK_SUBCODE (b
->next
);
1593 case EXEC_DEALLOCATE
:
1596 for (a
= co
->ext
.alloc
.list
; a
; a
= a
->next
)
1597 WALK_SUBEXPR (a
->expr
);
1602 case EXEC_DO_CONCURRENT
:
1604 gfc_forall_iterator
*fa
;
1605 for (fa
= co
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
1607 WALK_SUBEXPR (fa
->var
);
1608 WALK_SUBEXPR (fa
->start
);
1609 WALK_SUBEXPR (fa
->end
);
1610 WALK_SUBEXPR (fa
->stride
);
1612 if (co
->op
== EXEC_FORALL
)
1618 WALK_SUBEXPR (co
->ext
.open
->unit
);
1619 WALK_SUBEXPR (co
->ext
.open
->file
);
1620 WALK_SUBEXPR (co
->ext
.open
->status
);
1621 WALK_SUBEXPR (co
->ext
.open
->access
);
1622 WALK_SUBEXPR (co
->ext
.open
->form
);
1623 WALK_SUBEXPR (co
->ext
.open
->recl
);
1624 WALK_SUBEXPR (co
->ext
.open
->blank
);
1625 WALK_SUBEXPR (co
->ext
.open
->position
);
1626 WALK_SUBEXPR (co
->ext
.open
->action
);
1627 WALK_SUBEXPR (co
->ext
.open
->delim
);
1628 WALK_SUBEXPR (co
->ext
.open
->pad
);
1629 WALK_SUBEXPR (co
->ext
.open
->iostat
);
1630 WALK_SUBEXPR (co
->ext
.open
->iomsg
);
1631 WALK_SUBEXPR (co
->ext
.open
->convert
);
1632 WALK_SUBEXPR (co
->ext
.open
->decimal
);
1633 WALK_SUBEXPR (co
->ext
.open
->encoding
);
1634 WALK_SUBEXPR (co
->ext
.open
->round
);
1635 WALK_SUBEXPR (co
->ext
.open
->sign
);
1636 WALK_SUBEXPR (co
->ext
.open
->asynchronous
);
1637 WALK_SUBEXPR (co
->ext
.open
->id
);
1638 WALK_SUBEXPR (co
->ext
.open
->newunit
);
1642 WALK_SUBEXPR (co
->ext
.close
->unit
);
1643 WALK_SUBEXPR (co
->ext
.close
->status
);
1644 WALK_SUBEXPR (co
->ext
.close
->iostat
);
1645 WALK_SUBEXPR (co
->ext
.close
->iomsg
);
1648 case EXEC_BACKSPACE
:
1652 WALK_SUBEXPR (co
->ext
.filepos
->unit
);
1653 WALK_SUBEXPR (co
->ext
.filepos
->iostat
);
1654 WALK_SUBEXPR (co
->ext
.filepos
->iomsg
);
1658 WALK_SUBEXPR (co
->ext
.inquire
->unit
);
1659 WALK_SUBEXPR (co
->ext
.inquire
->file
);
1660 WALK_SUBEXPR (co
->ext
.inquire
->iomsg
);
1661 WALK_SUBEXPR (co
->ext
.inquire
->iostat
);
1662 WALK_SUBEXPR (co
->ext
.inquire
->exist
);
1663 WALK_SUBEXPR (co
->ext
.inquire
->opened
);
1664 WALK_SUBEXPR (co
->ext
.inquire
->number
);
1665 WALK_SUBEXPR (co
->ext
.inquire
->named
);
1666 WALK_SUBEXPR (co
->ext
.inquire
->name
);
1667 WALK_SUBEXPR (co
->ext
.inquire
->access
);
1668 WALK_SUBEXPR (co
->ext
.inquire
->sequential
);
1669 WALK_SUBEXPR (co
->ext
.inquire
->direct
);
1670 WALK_SUBEXPR (co
->ext
.inquire
->form
);
1671 WALK_SUBEXPR (co
->ext
.inquire
->formatted
);
1672 WALK_SUBEXPR (co
->ext
.inquire
->unformatted
);
1673 WALK_SUBEXPR (co
->ext
.inquire
->recl
);
1674 WALK_SUBEXPR (co
->ext
.inquire
->nextrec
);
1675 WALK_SUBEXPR (co
->ext
.inquire
->blank
);
1676 WALK_SUBEXPR (co
->ext
.inquire
->position
);
1677 WALK_SUBEXPR (co
->ext
.inquire
->action
);
1678 WALK_SUBEXPR (co
->ext
.inquire
->read
);
1679 WALK_SUBEXPR (co
->ext
.inquire
->write
);
1680 WALK_SUBEXPR (co
->ext
.inquire
->readwrite
);
1681 WALK_SUBEXPR (co
->ext
.inquire
->delim
);
1682 WALK_SUBEXPR (co
->ext
.inquire
->encoding
);
1683 WALK_SUBEXPR (co
->ext
.inquire
->pad
);
1684 WALK_SUBEXPR (co
->ext
.inquire
->iolength
);
1685 WALK_SUBEXPR (co
->ext
.inquire
->convert
);
1686 WALK_SUBEXPR (co
->ext
.inquire
->strm_pos
);
1687 WALK_SUBEXPR (co
->ext
.inquire
->asynchronous
);
1688 WALK_SUBEXPR (co
->ext
.inquire
->decimal
);
1689 WALK_SUBEXPR (co
->ext
.inquire
->pending
);
1690 WALK_SUBEXPR (co
->ext
.inquire
->id
);
1691 WALK_SUBEXPR (co
->ext
.inquire
->sign
);
1692 WALK_SUBEXPR (co
->ext
.inquire
->size
);
1693 WALK_SUBEXPR (co
->ext
.inquire
->round
);
1697 WALK_SUBEXPR (co
->ext
.wait
->unit
);
1698 WALK_SUBEXPR (co
->ext
.wait
->iostat
);
1699 WALK_SUBEXPR (co
->ext
.wait
->iomsg
);
1700 WALK_SUBEXPR (co
->ext
.wait
->id
);
1705 WALK_SUBEXPR (co
->ext
.dt
->io_unit
);
1706 WALK_SUBEXPR (co
->ext
.dt
->format_expr
);
1707 WALK_SUBEXPR (co
->ext
.dt
->rec
);
1708 WALK_SUBEXPR (co
->ext
.dt
->advance
);
1709 WALK_SUBEXPR (co
->ext
.dt
->iostat
);
1710 WALK_SUBEXPR (co
->ext
.dt
->size
);
1711 WALK_SUBEXPR (co
->ext
.dt
->iomsg
);
1712 WALK_SUBEXPR (co
->ext
.dt
->id
);
1713 WALK_SUBEXPR (co
->ext
.dt
->pos
);
1714 WALK_SUBEXPR (co
->ext
.dt
->asynchronous
);
1715 WALK_SUBEXPR (co
->ext
.dt
->blank
);
1716 WALK_SUBEXPR (co
->ext
.dt
->decimal
);
1717 WALK_SUBEXPR (co
->ext
.dt
->delim
);
1718 WALK_SUBEXPR (co
->ext
.dt
->pad
);
1719 WALK_SUBEXPR (co
->ext
.dt
->round
);
1720 WALK_SUBEXPR (co
->ext
.dt
->sign
);
1721 WALK_SUBEXPR (co
->ext
.dt
->extra_comma
);
1724 case EXEC_OMP_PARALLEL
:
1725 case EXEC_OMP_PARALLEL_DO
:
1726 case EXEC_OMP_PARALLEL_SECTIONS
:
1728 in_omp_workshare
= false;
1730 /* This goto serves as a shortcut to avoid code
1731 duplication or a larger if or switch statement. */
1732 goto check_omp_clauses
;
1734 case EXEC_OMP_WORKSHARE
:
1735 case EXEC_OMP_PARALLEL_WORKSHARE
:
1737 in_omp_workshare
= true;
1742 case EXEC_OMP_SECTIONS
:
1743 case EXEC_OMP_SINGLE
:
1744 case EXEC_OMP_END_SINGLE
:
1747 /* Come to this label only from the
1748 EXEC_OMP_PARALLEL_* cases above. */
1752 if (co
->ext
.omp_clauses
)
1754 WALK_SUBEXPR (co
->ext
.omp_clauses
->if_expr
);
1755 WALK_SUBEXPR (co
->ext
.omp_clauses
->final_expr
);
1756 WALK_SUBEXPR (co
->ext
.omp_clauses
->num_threads
);
1757 WALK_SUBEXPR (co
->ext
.omp_clauses
->chunk_size
);
1764 WALK_SUBEXPR (co
->expr1
);
1765 WALK_SUBEXPR (co
->expr2
);
1766 WALK_SUBEXPR (co
->expr3
);
1767 WALK_SUBEXPR (co
->expr4
);
1768 for (b
= co
->block
; b
; b
= b
->block
)
1770 WALK_SUBEXPR (b
->expr1
);
1771 WALK_SUBEXPR (b
->expr2
);
1772 WALK_SUBCODE (b
->next
);
1775 if (co
->op
== EXEC_FORALL
)
1778 if (co
->op
== EXEC_DO
)
1781 in_omp_workshare
= saved_in_omp_workshare
;