1 /* Pass manager for Fortran front end.
2 Copyright (C) 2010-2016 Free Software Foundation, Inc.
3 Contributed by Thomas König.
4
5 This file is part of GCC.
6
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
10 version.
11
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
15 for more details.
16
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/>. */
20
21 #include "config.h"
22 #include "system.h"
23 #include "coretypes.h"
24 #include "options.h"
25 #include "gfortran.h"
26 #include "dependency.h"
27 #include "constructor.h"
28 #include "intrinsic.h"
29
30 /* Forward declarations. */
31
32 static void strip_function_call (gfc_expr *);
33 static void optimize_namespace (gfc_namespace *);
34 static void optimize_assignment (gfc_code *);
35 static bool optimize_op (gfc_expr *);
36 static bool optimize_comparison (gfc_expr *, gfc_intrinsic_op);
37 static bool optimize_trim (gfc_expr *);
38 static bool optimize_lexical_comparison (gfc_expr *);
39 static void optimize_minmaxloc (gfc_expr **);
40 static bool is_empty_string (gfc_expr *e);
41 static void doloop_warn (gfc_namespace *);
42 static void optimize_reduction (gfc_namespace *);
43 static int callback_reduction (gfc_expr **, int *, void *);
44 static void realloc_strings (gfc_namespace *);
45 static gfc_expr *create_var (gfc_expr *, const char *vname=NULL);
46 static int inline_matmul_assign (gfc_code **, int *, void *);
47 static gfc_code * create_do_loop (gfc_expr *, gfc_expr *, gfc_expr *,
48 locus *, gfc_namespace *,
49 char *vname=NULL);
50
51 /* How deep we are inside an argument list. */
52
53 static int count_arglist;
54
55 /* Vector of gfc_expr ** we operate on. */
56
57 static vec<gfc_expr **> expr_array;
58
59 /* Pointer to the gfc_code we currently work on - to be able to insert
60 a block before the statement. */
61
62 static gfc_code **current_code;
63
64 /* Pointer to the block to be inserted, and the statement we are
65 changing within the block. */
66
67 static gfc_code *inserted_block, **changed_statement;
68
69 /* The namespace we are currently dealing with. */
70
71 static gfc_namespace *current_ns;
72
73 /* If we are within any forall loop. */
74
75 static int forall_level;
76
77 /* Keep track of whether we are within an OMP workshare. */
78
79 static bool in_omp_workshare;
80
81 /* Keep track of whether we are within a WHERE statement. */
82
83 static bool in_where;
84
85 /* Keep track of iterators for array constructors. */
86
87 static int iterator_level;
88
89 /* Keep track of DO loop levels. */
90
91 static vec<gfc_code *> doloop_list;
92
93 static int doloop_level;
94
95 /* Vector of gfc_expr * to keep track of DO loops. */
96
97 struct my_struct *evec;
98
99 /* Keep track of association lists. */
100
101 static bool in_assoc_list;
102
103 /* Counter for temporary variables. */
104
105 static int var_num = 1;
106
107 /* What sort of matrix we are dealing with when inlining MATMUL. */
108
109 enum matrix_case { none=0, A2B2, A2B1, A1B2, A2B2T };
110
111 /* Keep track of the number of expressions we have inserted so far
112 using create_var. */
113
114 int n_vars;
115
116 /* Entry point - run all passes for a namespace. */
117
118 void
gfc_run_passes(gfc_namespace * ns)119 gfc_run_passes (gfc_namespace *ns)
120 {
121
122 /* Warn about dubious DO loops where the index might
123 change. */
124
125 doloop_level = 0;
126 doloop_warn (ns);
127 doloop_list.release ();
128 int w, e;
129
130 gfc_get_errors (&w, &e);
131 if (e > 0)
132 return;
133
134 if (flag_frontend_optimize)
135 {
136 optimize_namespace (ns);
137 optimize_reduction (ns);
138 if (flag_dump_fortran_optimized)
139 gfc_dump_parse_tree (ns, stdout);
140
141 expr_array.release ();
142 }
143
144 if (flag_realloc_lhs)
145 realloc_strings (ns);
146 }
147
148 /* Callback for each gfc_code node invoked from check_realloc_strings.
149 For an allocatable LHS string which also appears as a variable on
150 the RHS, replace
151
152 a = a(x:y)
153
154 with
155
156 tmp = a(x:y)
157 a = tmp
158 */
159
160 static int
realloc_string_callback(gfc_code ** c,int * walk_subtrees ATTRIBUTE_UNUSED,void * data ATTRIBUTE_UNUSED)161 realloc_string_callback (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
162 void *data ATTRIBUTE_UNUSED)
163 {
164 gfc_expr *expr1, *expr2;
165 gfc_code *co = *c;
166 gfc_expr *n;
167 gfc_ref *ref;
168 bool found_substr;
169
170 if (co->op != EXEC_ASSIGN)
171 return 0;
172
173 expr1 = co->expr1;
174 if (expr1->ts.type != BT_CHARACTER || expr1->rank != 0
175 || !gfc_expr_attr(expr1).allocatable
176 || !expr1->ts.deferred)
177 return 0;
178
179 expr2 = gfc_discard_nops (co->expr2);
180 if (expr2->expr_type != EXPR_VARIABLE)
181 return 0;
182
183 found_substr = false;
184 for (ref = expr2->ref; ref; ref = ref->next)
185 {
186 if (ref->type == REF_SUBSTRING)
187 {
188 found_substr = true;
189 break;
190 }
191 }
192 if (!found_substr)
193 return 0;
194
195 if (!gfc_check_dependency (expr1, expr2, true))
196 return 0;
197
198 /* gfc_check_dependency doesn't always pick up identical expressions.
199 However, eliminating the above sends the compiler into an infinite
200 loop on valid expressions. Without this check, the gimplifier emits
201 an ICE for a = a, where a is deferred character length. */
202 if (!gfc_dep_compare_expr (expr1, expr2))
203 return 0;
204
205 current_code = c;
206 inserted_block = NULL;
207 changed_statement = NULL;
208 n = create_var (expr2, "realloc_string");
209 co->expr2 = n;
210 return 0;
211 }
212
213 /* Callback for each gfc_code node invoked through gfc_code_walker
214 from optimize_namespace. */
215
216 static int
optimize_code(gfc_code ** c,int * walk_subtrees ATTRIBUTE_UNUSED,void * data ATTRIBUTE_UNUSED)217 optimize_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
218 void *data ATTRIBUTE_UNUSED)
219 {
220
221 gfc_exec_op op;
222
223 op = (*c)->op;
224
225 if (op == EXEC_CALL || op == EXEC_COMPCALL || op == EXEC_ASSIGN_CALL
226 || op == EXEC_CALL_PPC)
227 count_arglist = 1;
228 else
229 count_arglist = 0;
230
231 current_code = c;
232 inserted_block = NULL;
233 changed_statement = NULL;
234
235 if (op == EXEC_ASSIGN)
236 optimize_assignment (*c);
237 return 0;
238 }
239
240 /* Callback for each gfc_expr node invoked through gfc_code_walker
241 from optimize_namespace. */
242
243 static int
optimize_expr(gfc_expr ** e,int * walk_subtrees ATTRIBUTE_UNUSED,void * data ATTRIBUTE_UNUSED)244 optimize_expr (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
245 void *data ATTRIBUTE_UNUSED)
246 {
247 bool function_expr;
248
249 if ((*e)->expr_type == EXPR_FUNCTION)
250 {
251 count_arglist ++;
252 function_expr = true;
253 }
254 else
255 function_expr = false;
256
257 if (optimize_trim (*e))
258 gfc_simplify_expr (*e, 0);
259
260 if (optimize_lexical_comparison (*e))
261 gfc_simplify_expr (*e, 0);
262
263 if ((*e)->expr_type == EXPR_OP && optimize_op (*e))
264 gfc_simplify_expr (*e, 0);
265
266 if ((*e)->expr_type == EXPR_FUNCTION && (*e)->value.function.isym)
267 switch ((*e)->value.function.isym->id)
268 {
269 case GFC_ISYM_MINLOC:
270 case GFC_ISYM_MAXLOC:
271 optimize_minmaxloc (e);
272 break;
273 default:
274 break;
275 }
276
277 if (function_expr)
278 count_arglist --;
279
280 return 0;
281 }
282
283 /* Auxiliary function to handle the arguments to reduction intrnisics. If the
284 function is a scalar, just copy it; otherwise returns the new element, the
285 old one can be freed. */
286
287 static gfc_expr *
copy_walk_reduction_arg(gfc_constructor * c,gfc_expr * fn)288 copy_walk_reduction_arg (gfc_constructor *c, gfc_expr *fn)
289 {
290 gfc_expr *fcn, *e = c->expr;
291
292 fcn = gfc_copy_expr (e);
293 if (c->iterator)
294 {
295 gfc_constructor_base newbase;
296 gfc_expr *new_expr;
297 gfc_constructor *new_c;
298
299 newbase = NULL;
300 new_expr = gfc_get_expr ();
301 new_expr->expr_type = EXPR_ARRAY;
302 new_expr->ts = e->ts;
303 new_expr->where = e->where;
304 new_expr->rank = 1;
305 new_c = gfc_constructor_append_expr (&newbase, fcn, &(e->where));
306 new_c->iterator = c->iterator;
307 new_expr->value.constructor = newbase;
308 c->iterator = NULL;
309
310 fcn = new_expr;
311 }
312
313 if (fcn->rank != 0)
314 {
315 gfc_isym_id id = fn->value.function.isym->id;
316
317 if (id == GFC_ISYM_SUM || id == GFC_ISYM_PRODUCT)
318 fcn = gfc_build_intrinsic_call (current_ns, id,
319 fn->value.function.isym->name,
320 fn->where, 3, fcn, NULL, NULL);
321 else if (id == GFC_ISYM_ANY || id == GFC_ISYM_ALL)
322 fcn = gfc_build_intrinsic_call (current_ns, id,
323 fn->value.function.isym->name,
324 fn->where, 2, fcn, NULL);
325 else
326 gfc_internal_error ("Illegal id in copy_walk_reduction_arg");
327
328 fcn->symtree->n.sym->attr.access = ACCESS_PRIVATE;
329 }
330
331 return fcn;
332 }
333
334 /* Callback function for optimzation of reductions to scalars. Transform ANY
335 ([f1,f2,f3, ...]) to f1 .or. f2 .or. f3 .or. ..., with ANY, SUM and PRODUCT
336 correspondingly. Handly only the simple cases without MASK and DIM. */
337
338 static int
callback_reduction(gfc_expr ** e,int * walk_subtrees ATTRIBUTE_UNUSED,void * data ATTRIBUTE_UNUSED)339 callback_reduction (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
340 void *data ATTRIBUTE_UNUSED)
341 {
342 gfc_expr *fn, *arg;
343 gfc_intrinsic_op op;
344 gfc_isym_id id;
345 gfc_actual_arglist *a;
346 gfc_actual_arglist *dim;
347 gfc_constructor *c;
348 gfc_expr *res, *new_expr;
349 gfc_actual_arglist *mask;
350
351 fn = *e;
352
353 if (fn->rank != 0 || fn->expr_type != EXPR_FUNCTION
354 || fn->value.function.isym == NULL)
355 return 0;
356
357 id = fn->value.function.isym->id;
358
359 if (id != GFC_ISYM_SUM && id != GFC_ISYM_PRODUCT
360 && id != GFC_ISYM_ANY && id != GFC_ISYM_ALL)
361 return 0;
362
363 a = fn->value.function.actual;
364
365 /* Don't handle MASK or DIM. */
366
367 dim = a->next;
368
369 if (dim->expr != NULL)
370 return 0;
371
372 if (id == GFC_ISYM_SUM || id == GFC_ISYM_PRODUCT)
373 {
374 mask = dim->next;
375 if ( mask->expr != NULL)
376 return 0;
377 }
378
379 arg = a->expr;
380
381 if (arg->expr_type != EXPR_ARRAY)
382 return 0;
383
384 switch (id)
385 {
386 case GFC_ISYM_SUM:
387 op = INTRINSIC_PLUS;
388 break;
389
390 case GFC_ISYM_PRODUCT:
391 op = INTRINSIC_TIMES;
392 break;
393
394 case GFC_ISYM_ANY:
395 op = INTRINSIC_OR;
396 break;
397
398 case GFC_ISYM_ALL:
399 op = INTRINSIC_AND;
400 break;
401
402 default:
403 return 0;
404 }
405
406 c = gfc_constructor_first (arg->value.constructor);
407
408 /* Don't do any simplififcation if we have
409 - no element in the constructor or
410 - only have a single element in the array which contains an
411 iterator. */
412
413 if (c == NULL)
414 return 0;
415
416 res = copy_walk_reduction_arg (c, fn);
417
418 c = gfc_constructor_next (c);
419 while (c)
420 {
421 new_expr = gfc_get_expr ();
422 new_expr->ts = fn->ts;
423 new_expr->expr_type = EXPR_OP;
424 new_expr->rank = fn->rank;
425 new_expr->where = fn->where;
426 new_expr->value.op.op = op;
427 new_expr->value.op.op1 = res;
428 new_expr->value.op.op2 = copy_walk_reduction_arg (c, fn);
429 res = new_expr;
430 c = gfc_constructor_next (c);
431 }
432
433 gfc_simplify_expr (res, 0);
434 *e = res;
435 gfc_free_expr (fn);
436
437 return 0;
438 }
439
440 /* Callback function for common function elimination, called from cfe_expr_0.
441 Put all eligible function expressions into expr_array. */
442
443 static int
cfe_register_funcs(gfc_expr ** e,int * walk_subtrees ATTRIBUTE_UNUSED,void * data ATTRIBUTE_UNUSED)444 cfe_register_funcs (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
445 void *data ATTRIBUTE_UNUSED)
446 {
447
448 if ((*e)->expr_type != EXPR_FUNCTION)
449 return 0;
450
451 /* We don't do character functions with unknown charlens. */
452 if ((*e)->ts.type == BT_CHARACTER
453 && ((*e)->ts.u.cl == NULL || (*e)->ts.u.cl->length == NULL
454 || (*e)->ts.u.cl->length->expr_type != EXPR_CONSTANT))
455 return 0;
456
457 /* We don't do function elimination within FORALL statements, it can
458 lead to wrong-code in certain circumstances. */
459
460 if (forall_level > 0)
461 return 0;
462
463 /* Function elimination inside an iterator could lead to functions which
464 depend on iterator variables being moved outside. FIXME: We should check
465 if the functions do indeed depend on the iterator variable. */
466
467 if (iterator_level > 0)
468 return 0;
469
470 /* If we don't know the shape at compile time, we create an allocatable
471 temporary variable to hold the intermediate result, but only if
472 allocation on assignment is active. */
473
474 if ((*e)->rank > 0 && (*e)->shape == NULL && !flag_realloc_lhs)
475 return 0;
476
477 /* Skip the test for pure functions if -faggressive-function-elimination
478 is specified. */
479 if ((*e)->value.function.esym)
480 {
481 /* Don't create an array temporary for elemental functions. */
482 if ((*e)->value.function.esym->attr.elemental && (*e)->rank > 0)
483 return 0;
484
485 /* Only eliminate potentially impure functions if the
486 user specifically requested it. */
487 if (!flag_aggressive_function_elimination
488 && !(*e)->value.function.esym->attr.pure
489 && !(*e)->value.function.esym->attr.implicit_pure)
490 return 0;
491 }
492
493 if ((*e)->value.function.isym)
494 {
495 /* Conversions are handled on the fly by the middle end,
496 transpose during trans-* stages and TRANSFER by the middle end. */
497 if ((*e)->value.function.isym->id == GFC_ISYM_CONVERSION
498 || (*e)->value.function.isym->id == GFC_ISYM_TRANSFER
499 || gfc_inline_intrinsic_function_p (*e))
500 return 0;
501
502 /* Don't create an array temporary for elemental functions,
503 as this would be wasteful of memory.
504 FIXME: Create a scalar temporary during scalarization. */
505 if ((*e)->value.function.isym->elemental && (*e)->rank > 0)
506 return 0;
507
508 if (!(*e)->value.function.isym->pure)
509 return 0;
510 }
511
512 expr_array.safe_push (e);
513 return 0;
514 }
515
516 /* Auxiliary function to check if an expression is a temporary created by
517 create var. */
518
519 static bool
is_fe_temp(gfc_expr * e)520 is_fe_temp (gfc_expr *e)
521 {
522 if (e->expr_type != EXPR_VARIABLE)
523 return false;
524
525 return e->symtree->n.sym->attr.fe_temp;
526 }
527
528 /* Determine the length of a string, if it can be evaluated as a constant
529 expression. Return a newly allocated gfc_expr or NULL on failure.
530 If the user specified a substring which is potentially longer than
531 the string itself, the string will be padded with spaces, which
532 is harmless. */
533
534 static gfc_expr *
constant_string_length(gfc_expr * e)535 constant_string_length (gfc_expr *e)
536 {
537
538 gfc_expr *length;
539 gfc_ref *ref;
540 gfc_expr *res;
541 mpz_t value;
542
543 if (e->ts.u.cl)
544 {
545 length = e->ts.u.cl->length;
546 if (length && length->expr_type == EXPR_CONSTANT)
547 return gfc_copy_expr(length);
548 }
549
550 /* Return length of substring, if constant. */
551 for (ref = e->ref; ref; ref = ref->next)
552 {
553 if (ref->type == REF_SUBSTRING
554 && gfc_dep_difference (ref->u.ss.end, ref->u.ss.start, &value))
555 {
556 res = gfc_get_constant_expr (BT_INTEGER, gfc_charlen_int_kind,
557 &e->where);
558
559 mpz_add_ui (res->value.integer, value, 1);
560 mpz_clear (value);
561 return res;
562 }
563 }
564
565 /* Return length of char symbol, if constant. */
566
567 if (e->symtree->n.sym->ts.u.cl && e->symtree->n.sym->ts.u.cl->length
568 && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
569 return gfc_copy_expr (e->symtree->n.sym->ts.u.cl->length);
570
571 return NULL;
572
573 }
574
575 /* Insert a block at the current position unless it has already
576 been inserted; in this case use the one already there. */
577
578 static gfc_namespace*
insert_block()579 insert_block ()
580 {
581 gfc_namespace *ns;
582
583 /* If the block hasn't already been created, do so. */
584 if (inserted_block == NULL)
585 {
586 inserted_block = XCNEW (gfc_code);
587 inserted_block->op = EXEC_BLOCK;
588 inserted_block->loc = (*current_code)->loc;
589 ns = gfc_build_block_ns (current_ns);
590 inserted_block->ext.block.ns = ns;
591 inserted_block->ext.block.assoc = NULL;
592
593 ns->code = *current_code;
594
595 /* If the statement has a label, make sure it is transferred to
596 the newly created block. */
597
598 if ((*current_code)->here)
599 {
600 inserted_block->here = (*current_code)->here;
601 (*current_code)->here = NULL;
602 }
603
604 inserted_block->next = (*current_code)->next;
605 changed_statement = &(inserted_block->ext.block.ns->code);
606 (*current_code)->next = NULL;
607 /* Insert the BLOCK at the right position. */
608 *current_code = inserted_block;
609 ns->parent = current_ns;
610 }
611 else
612 ns = inserted_block->ext.block.ns;
613
614 return ns;
615 }
616
617 /* Returns a new expression (a variable) to be used in place of the old one,
618 with an optional assignment statement before the current statement to set
619 the value of the variable. Creates a new BLOCK for the statement if that
620 hasn't already been done and puts the statement, plus the newly created
621 variables, in that block. Special cases: If the expression is constant or
622 a temporary which has already been created, just copy it. */
623
624 static gfc_expr*
create_var(gfc_expr * e,const char * vname)625 create_var (gfc_expr * e, const char *vname)
626 {
627 char name[GFC_MAX_SYMBOL_LEN +1];
628 gfc_symtree *symtree;
629 gfc_symbol *symbol;
630 gfc_expr *result;
631 gfc_code *n;
632 gfc_namespace *ns;
633 int i;
634 bool deferred;
635
636 if (e->expr_type == EXPR_CONSTANT || is_fe_temp (e))
637 return gfc_copy_expr (e);
638
639 ns = insert_block ();
640
641 if (vname)
642 snprintf (name, GFC_MAX_SYMBOL_LEN, "__var_%d_%s", var_num++, vname);
643 else
644 snprintf (name, GFC_MAX_SYMBOL_LEN, "__var_%d", var_num++);
645
646 if (gfc_get_sym_tree (name, ns, &symtree, false) != 0)
647 gcc_unreachable ();
648
649 symbol = symtree->n.sym;
650 symbol->ts = e->ts;
651
652 if (e->rank > 0)
653 {
654 symbol->as = gfc_get_array_spec ();
655 symbol->as->rank = e->rank;
656
657 if (e->shape == NULL)
658 {
659 /* We don't know the shape at compile time, so we use an
660 allocatable. */
661 symbol->as->type = AS_DEFERRED;
662 symbol->attr.allocatable = 1;
663 }
664 else
665 {
666 symbol->as->type = AS_EXPLICIT;
667 /* Copy the shape. */
668 for (i=0; i<e->rank; i++)
669 {
670 gfc_expr *p, *q;
671
672 p = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
673 &(e->where));
674 mpz_set_si (p->value.integer, 1);
675 symbol->as->lower[i] = p;
676
677 q = gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
678 &(e->where));
679 mpz_set (q->value.integer, e->shape[i]);
680 symbol->as->upper[i] = q;
681 }
682 }
683 }
684
685 deferred = 0;
686 if (e->ts.type == BT_CHARACTER && e->rank == 0)
687 {
688 gfc_expr *length;
689
690 symbol->ts.u.cl = gfc_new_charlen (ns, NULL);
691 length = constant_string_length (e);
692 if (length)
693 symbol->ts.u.cl->length = length;
694 else
695 {
696 symbol->attr.allocatable = 1;
697 deferred = 1;
698 }
699 }
700
701 symbol->attr.flavor = FL_VARIABLE;
702 symbol->attr.referenced = 1;
703 symbol->attr.dimension = e->rank > 0;
704 symbol->attr.fe_temp = 1;
705 gfc_commit_symbol (symbol);
706
707 result = gfc_get_expr ();
708 result->expr_type = EXPR_VARIABLE;
709 result->ts = e->ts;
710 result->ts.deferred = deferred;
711 result->rank = e->rank;
712 result->shape = gfc_copy_shape (e->shape, e->rank);
713 result->symtree = symtree;
714 result->where = e->where;
715 if (e->rank > 0)
716 {
717 result->ref = gfc_get_ref ();
718 result->ref->type = REF_ARRAY;
719 result->ref->u.ar.type = AR_FULL;
720 result->ref->u.ar.where = e->where;
721 result->ref->u.ar.dimen = e->rank;
722 result->ref->u.ar.as = symbol->ts.type == BT_CLASS
723 ? CLASS_DATA (symbol)->as : symbol->as;
724 if (warn_array_temporaries)
725 gfc_warning (OPT_Warray_temporaries,
726 "Creating array temporary at %L", &(e->where));
727 }
728
729 /* Generate the new assignment. */
730 n = XCNEW (gfc_code);
731 n->op = EXEC_ASSIGN;
732 n->loc = (*current_code)->loc;
733 n->next = *changed_statement;
734 n->expr1 = gfc_copy_expr (result);
735 n->expr2 = e;
736 *changed_statement = n;
737 n_vars ++;
738
739 return result;
740 }
741
742 /* Warn about function elimination. */
743
744 static void
do_warn_function_elimination(gfc_expr * e)745 do_warn_function_elimination (gfc_expr *e)
746 {
747 if (e->expr_type != EXPR_FUNCTION)
748 return;
749 if (e->value.function.esym)
750 gfc_warning (0, "Removing call to function %qs at %L",
751 e->value.function.esym->name, &(e->where));
752 else if (e->value.function.isym)
753 gfc_warning (0, "Removing call to function %qs at %L",
754 e->value.function.isym->name, &(e->where));
755 }
756 /* Callback function for the code walker for doing common function
757 elimination. This builds up the list of functions in the expression
758 and goes through them to detect duplicates, which it then replaces
759 by variables. */
760
761 static int
cfe_expr_0(gfc_expr ** e,int * walk_subtrees,void * data ATTRIBUTE_UNUSED)762 cfe_expr_0 (gfc_expr **e, int *walk_subtrees,
763 void *data ATTRIBUTE_UNUSED)
764 {
765 int i,j;
766 gfc_expr *newvar;
767 gfc_expr **ei, **ej;
768
769 /* Don't do this optimization within OMP workshare or ASSOC lists. */
770
771 if (in_omp_workshare || in_assoc_list)
772 {
773 *walk_subtrees = 0;
774 return 0;
775 }
776
777 expr_array.release ();
778
779 gfc_expr_walker (e, cfe_register_funcs, NULL);
780
781 /* Walk through all the functions. */
782
783 FOR_EACH_VEC_ELT_FROM (expr_array, i, ei, 1)
784 {
785 /* Skip if the function has been replaced by a variable already. */
786 if ((*ei)->expr_type == EXPR_VARIABLE)
787 continue;
788
789 newvar = NULL;
790 for (j=0; j<i; j++)
791 {
792 ej = expr_array[j];
793 if (gfc_dep_compare_functions (*ei, *ej, true) == 0)
794 {
795 if (newvar == NULL)
796 newvar = create_var (*ei, "fcn");
797
798 if (warn_function_elimination)
799 do_warn_function_elimination (*ej);
800
801 free (*ej);
802 *ej = gfc_copy_expr (newvar);
803 }
804 }
805 if (newvar)
806 *ei = newvar;
807 }
808
809 /* We did all the necessary walking in this function. */
810 *walk_subtrees = 0;
811 return 0;
812 }
813
814 /* Callback function for common function elimination, called from
815 gfc_code_walker. This keeps track of the current code, in order
816 to insert statements as needed. */
817
818 static int
cfe_code(gfc_code ** c,int * walk_subtrees,void * data ATTRIBUTE_UNUSED)819 cfe_code (gfc_code **c, int *walk_subtrees, void *data ATTRIBUTE_UNUSED)
820 {
821 current_code = c;
822 inserted_block = NULL;
823 changed_statement = NULL;
824
825 /* Do not do anything inside a WHERE statement; scalar assignments, BLOCKs
826 and allocation on assigment are prohibited inside WHERE, and finally
827 masking an expression would lead to wrong-code when replacing
828
829 WHERE (a>0)
830 b = sum(foo(a) + foo(a))
831 END WHERE
832
833 with
834
835 WHERE (a > 0)
836 tmp = foo(a)
837 b = sum(tmp + tmp)
838 END WHERE
839 */
840
841 if ((*c)->op == EXEC_WHERE)
842 {
843 *walk_subtrees = 0;
844 return 0;
845 }
846
847
848 return 0;
849 }
850
851 /* Dummy function for expression call back, for use when we
852 really don't want to do any walking. */
853
854 static int
dummy_expr_callback(gfc_expr ** e ATTRIBUTE_UNUSED,int * walk_subtrees,void * data ATTRIBUTE_UNUSED)855 dummy_expr_callback (gfc_expr **e ATTRIBUTE_UNUSED, int *walk_subtrees,
856 void *data ATTRIBUTE_UNUSED)
857 {
858 *walk_subtrees = 0;
859 return 0;
860 }
861
862 /* Dummy function for code callback, for use when we really
863 don't want to do anything. */
864 int
gfc_dummy_code_callback(gfc_code ** e ATTRIBUTE_UNUSED,int * walk_subtrees ATTRIBUTE_UNUSED,void * data ATTRIBUTE_UNUSED)865 gfc_dummy_code_callback (gfc_code **e ATTRIBUTE_UNUSED,
866 int *walk_subtrees ATTRIBUTE_UNUSED,
867 void *data ATTRIBUTE_UNUSED)
868 {
869 return 0;
870 }
871
872 /* Code callback function for converting
873 do while(a)
874 end do
875 into the equivalent
876 do
877 if (.not. a) exit
878 end do
879 This is because common function elimination would otherwise place the
880 temporary variables outside the loop. */
881
882 static int
convert_do_while(gfc_code ** c,int * walk_subtrees ATTRIBUTE_UNUSED,void * data ATTRIBUTE_UNUSED)883 convert_do_while (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
884 void *data ATTRIBUTE_UNUSED)
885 {
886 gfc_code *co = *c;
887 gfc_code *c_if1, *c_if2, *c_exit;
888 gfc_code *loopblock;
889 gfc_expr *e_not, *e_cond;
890
891 if (co->op != EXEC_DO_WHILE)
892 return 0;
893
894 if (co->expr1 == NULL || co->expr1->expr_type == EXPR_CONSTANT)
895 return 0;
896
897 e_cond = co->expr1;
898
899 /* Generate the condition of the if statement, which is .not. the original
900 statement. */
901 e_not = gfc_get_expr ();
902 e_not->ts = e_cond->ts;
903 e_not->where = e_cond->where;
904 e_not->expr_type = EXPR_OP;
905 e_not->value.op.op = INTRINSIC_NOT;
906 e_not->value.op.op1 = e_cond;
907
908 /* Generate the EXIT statement. */
909 c_exit = XCNEW (gfc_code);
910 c_exit->op = EXEC_EXIT;
911 c_exit->ext.which_construct = co;
912 c_exit->loc = co->loc;
913
914 /* Generate the IF statement. */
915 c_if2 = XCNEW (gfc_code);
916 c_if2->op = EXEC_IF;
917 c_if2->expr1 = e_not;
918 c_if2->next = c_exit;
919 c_if2->loc = co->loc;
920
921 /* ... plus the one to chain it to. */
922 c_if1 = XCNEW (gfc_code);
923 c_if1->op = EXEC_IF;
924 c_if1->block = c_if2;
925 c_if1->loc = co->loc;
926
927 /* Make the DO WHILE loop into a DO block by replacing the condition
928 with a true constant. */
929 co->expr1 = gfc_get_logical_expr (gfc_default_integer_kind, &co->loc, true);
930
931 /* Hang the generated if statement into the loop body. */
932
933 loopblock = co->block->next;
934 co->block->next = c_if1;
935 c_if1->next = loopblock;
936
937 return 0;
938 }
939
940 /* Code callback function for converting
941 if (a) then
942 ...
943 else if (b) then
944 end if
945
946 into
947 if (a) then
948 else
949 if (b) then
950 end if
951 end if
952
953 because otherwise common function elimination would place the BLOCKs
954 into the wrong place. */
955
956 static int
convert_elseif(gfc_code ** c,int * walk_subtrees ATTRIBUTE_UNUSED,void * data ATTRIBUTE_UNUSED)957 convert_elseif (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
958 void *data ATTRIBUTE_UNUSED)
959 {
960 gfc_code *co = *c;
961 gfc_code *c_if1, *c_if2, *else_stmt;
962
963 if (co->op != EXEC_IF)
964 return 0;
965
966 /* This loop starts out with the first ELSE statement. */
967 else_stmt = co->block->block;
968
969 while (else_stmt != NULL)
970 {
971 gfc_code *next_else;
972
973 /* If there is no condition, we're done. */
974 if (else_stmt->expr1 == NULL)
975 break;
976
977 next_else = else_stmt->block;
978
979 /* Generate the new IF statement. */
980 c_if2 = XCNEW (gfc_code);
981 c_if2->op = EXEC_IF;
982 c_if2->expr1 = else_stmt->expr1;
983 c_if2->next = else_stmt->next;
984 c_if2->loc = else_stmt->loc;
985 c_if2->block = next_else;
986
987 /* ... plus the one to chain it to. */
988 c_if1 = XCNEW (gfc_code);
989 c_if1->op = EXEC_IF;
990 c_if1->block = c_if2;
991 c_if1->loc = else_stmt->loc;
992
993 /* Insert the new IF after the ELSE. */
994 else_stmt->expr1 = NULL;
995 else_stmt->next = c_if1;
996 else_stmt->block = NULL;
997
998 else_stmt = next_else;
999 }
1000 /* Don't walk subtrees. */
1001 return 0;
1002 }
1003
1004 /* Optimize a namespace, including all contained namespaces. */
1005
1006 static void
optimize_namespace(gfc_namespace * ns)1007 optimize_namespace (gfc_namespace *ns)
1008 {
1009 gfc_namespace *saved_ns = gfc_current_ns;
1010 current_ns = ns;
1011 gfc_current_ns = ns;
1012 forall_level = 0;
1013 iterator_level = 0;
1014 in_assoc_list = false;
1015 in_omp_workshare = false;
1016
1017 gfc_code_walker (&ns->code, convert_do_while, dummy_expr_callback, NULL);
1018 gfc_code_walker (&ns->code, convert_elseif, dummy_expr_callback, NULL);
1019 gfc_code_walker (&ns->code, cfe_code, cfe_expr_0, NULL);
1020 gfc_code_walker (&ns->code, optimize_code, optimize_expr, NULL);
1021 if (flag_inline_matmul_limit != 0)
1022 gfc_code_walker (&ns->code, inline_matmul_assign, dummy_expr_callback,
1023 NULL);
1024
1025 /* BLOCKs are handled in the expression walker below. */
1026 for (ns = ns->contained; ns; ns = ns->sibling)
1027 {
1028 if (ns->code == NULL || ns->code->op != EXEC_BLOCK)
1029 optimize_namespace (ns);
1030 }
1031 gfc_current_ns = saved_ns;
1032 }
1033
1034 /* Handle dependencies for allocatable strings which potentially redefine
1035 themselves in an assignment. */
1036
1037 static void
realloc_strings(gfc_namespace * ns)1038 realloc_strings (gfc_namespace *ns)
1039 {
1040 current_ns = ns;
1041 gfc_code_walker (&ns->code, realloc_string_callback, dummy_expr_callback, NULL);
1042
1043 for (ns = ns->contained; ns; ns = ns->sibling)
1044 {
1045 if (ns->code == NULL || ns->code->op != EXEC_BLOCK)
1046 realloc_strings (ns);
1047 }
1048
1049 }
1050
1051 static void
optimize_reduction(gfc_namespace * ns)1052 optimize_reduction (gfc_namespace *ns)
1053 {
1054 current_ns = ns;
1055 gfc_code_walker (&ns->code, gfc_dummy_code_callback,
1056 callback_reduction, NULL);
1057
1058 /* BLOCKs are handled in the expression walker below. */
1059 for (ns = ns->contained; ns; ns = ns->sibling)
1060 {
1061 if (ns->code == NULL || ns->code->op != EXEC_BLOCK)
1062 optimize_reduction (ns);
1063 }
1064 }
1065
1066 /* Replace code like
1067 a = matmul(b,c) + d
1068 with
1069 a = matmul(b,c) ; a = a + d
1070 where the array function is not elemental and not allocatable
1071 and does not depend on the left-hand side.
1072 */
1073
1074 static bool
optimize_binop_array_assignment(gfc_code * c,gfc_expr ** rhs,bool seen_op)1075 optimize_binop_array_assignment (gfc_code *c, gfc_expr **rhs, bool seen_op)
1076 {
1077 gfc_expr *e;
1078
1079 if (!*rhs)
1080 return false;
1081
1082 e = *rhs;
1083 if (e->expr_type == EXPR_OP)
1084 {
1085 switch (e->value.op.op)
1086 {
1087 /* Unary operators and exponentiation: Only look at a single
1088 operand. */
1089 case INTRINSIC_NOT:
1090 case INTRINSIC_UPLUS:
1091 case INTRINSIC_UMINUS:
1092 case INTRINSIC_PARENTHESES:
1093 case INTRINSIC_POWER:
1094 if (optimize_binop_array_assignment (c, &e->value.op.op1, seen_op))
1095 return true;
1096 break;
1097
1098 case INTRINSIC_CONCAT:
1099 /* Do not do string concatenations. */
1100 break;
1101
1102 default:
1103 /* Binary operators. */
1104 if (optimize_binop_array_assignment (c, &e->value.op.op1, true))
1105 return true;
1106
1107 if (optimize_binop_array_assignment (c, &e->value.op.op2, true))
1108 return true;
1109
1110 break;
1111 }
1112 }
1113 else if (seen_op && e->expr_type == EXPR_FUNCTION && e->rank > 0
1114 && ! (e->value.function.esym
1115 && (e->value.function.esym->attr.elemental
1116 || e->value.function.esym->attr.allocatable
1117 || e->value.function.esym->ts.type != c->expr1->ts.type
1118 || e->value.function.esym->ts.kind != c->expr1->ts.kind))
1119 && ! (e->value.function.isym
1120 && (e->value.function.isym->elemental
1121 || e->ts.type != c->expr1->ts.type
1122 || e->ts.kind != c->expr1->ts.kind))
1123 && ! gfc_inline_intrinsic_function_p (e))
1124 {
1125
1126 gfc_code *n;
1127 gfc_expr *new_expr;
1128
1129 /* Insert a new assignment statement after the current one. */
1130 n = XCNEW (gfc_code);
1131 n->op = EXEC_ASSIGN;
1132 n->loc = c->loc;
1133 n->next = c->next;
1134 c->next = n;
1135
1136 n->expr1 = gfc_copy_expr (c->expr1);
1137 n->expr2 = c->expr2;
1138 new_expr = gfc_copy_expr (c->expr1);
1139 c->expr2 = e;
1140 *rhs = new_expr;
1141
1142 return true;
1143
1144 }
1145
1146 /* Nothing to optimize. */
1147 return false;
1148 }
1149
1150 /* Remove unneeded TRIMs at the end of expressions. */
1151
1152 static bool
remove_trim(gfc_expr * rhs)1153 remove_trim (gfc_expr *rhs)
1154 {
1155 bool ret;
1156
1157 ret = false;
1158 if (!rhs)
1159 return ret;
1160
1161 /* Check for a // b // trim(c). Looping is probably not
1162 necessary because the parser usually generates
1163 (// (// a b ) trim(c) ) , but better safe than sorry. */
1164
1165 while (rhs->expr_type == EXPR_OP
1166 && rhs->value.op.op == INTRINSIC_CONCAT)
1167 rhs = rhs->value.op.op2;
1168
1169 while (rhs->expr_type == EXPR_FUNCTION && rhs->value.function.isym
1170 && rhs->value.function.isym->id == GFC_ISYM_TRIM)
1171 {
1172 strip_function_call (rhs);
1173 /* Recursive call to catch silly stuff like trim ( a // trim(b)). */
1174 remove_trim (rhs);
1175 ret = true;
1176 }
1177
1178 return ret;
1179 }
1180
1181 /* Optimizations for an assignment. */
1182
1183 static void
optimize_assignment(gfc_code * c)1184 optimize_assignment (gfc_code * c)
1185 {
1186 gfc_expr *lhs, *rhs;
1187
1188 lhs = c->expr1;
1189 rhs = c->expr2;
1190
1191 if (lhs->ts.type == BT_CHARACTER && !lhs->ts.deferred)
1192 {
1193 /* Optimize a = trim(b) to a = b. */
1194 remove_trim (rhs);
1195
1196 /* Replace a = ' ' by a = '' to optimize away a memcpy. */
1197 if (is_empty_string (rhs))
1198 rhs->value.character.length = 0;
1199 }
1200
1201 if (lhs->rank > 0 && gfc_check_dependency (lhs, rhs, true) == 0)
1202 optimize_binop_array_assignment (c, &rhs, false);
1203 }
1204
1205
1206 /* Remove an unneeded function call, modifying the expression.
1207 This replaces the function call with the value of its
1208 first argument. The rest of the argument list is freed. */
1209
1210 static void
strip_function_call(gfc_expr * e)1211 strip_function_call (gfc_expr *e)
1212 {
1213 gfc_expr *e1;
1214 gfc_actual_arglist *a;
1215
1216 a = e->value.function.actual;
1217
1218 /* We should have at least one argument. */
1219 gcc_assert (a->expr != NULL);
1220
1221 e1 = a->expr;
1222
1223 /* Free the remaining arglist, if any. */
1224 if (a->next)
1225 gfc_free_actual_arglist (a->next);
1226
1227 /* Graft the argument expression onto the original function. */
1228 *e = *e1;
1229 free (e1);
1230
1231 }
1232
1233 /* Optimization of lexical comparison functions. */
1234
1235 static bool
optimize_lexical_comparison(gfc_expr * e)1236 optimize_lexical_comparison (gfc_expr *e)
1237 {
1238 if (e->expr_type != EXPR_FUNCTION || e->value.function.isym == NULL)
1239 return false;
1240
1241 switch (e->value.function.isym->id)
1242 {
1243 case GFC_ISYM_LLE:
1244 return optimize_comparison (e, INTRINSIC_LE);
1245
1246 case GFC_ISYM_LGE:
1247 return optimize_comparison (e, INTRINSIC_GE);
1248
1249 case GFC_ISYM_LGT:
1250 return optimize_comparison (e, INTRINSIC_GT);
1251
1252 case GFC_ISYM_LLT:
1253 return optimize_comparison (e, INTRINSIC_LT);
1254
1255 default:
1256 break;
1257 }
1258 return false;
1259 }
1260
1261 /* Combine stuff like [a]>b into [a>b], for easier optimization later. Do not
1262 do CHARACTER because of possible pessimization involving character
1263 lengths. */
1264
1265 static bool
combine_array_constructor(gfc_expr * e)1266 combine_array_constructor (gfc_expr *e)
1267 {
1268
1269 gfc_expr *op1, *op2;
1270 gfc_expr *scalar;
1271 gfc_expr *new_expr;
1272 gfc_constructor *c, *new_c;
1273 gfc_constructor_base oldbase, newbase;
1274 bool scalar_first;
1275
1276 /* Array constructors have rank one. */
1277 if (e->rank != 1)
1278 return false;
1279
1280 /* Don't try to combine association lists, this makes no sense
1281 and leads to an ICE. */
1282 if (in_assoc_list)
1283 return false;
1284
1285 /* With FORALL, the BLOCKS created by create_var will cause an ICE. */
1286 if (forall_level > 0)
1287 return false;
1288
1289 /* Inside an iterator, things can get hairy; we are likely to create
1290 an invalid temporary variable. */
1291 if (iterator_level > 0)
1292 return false;
1293
1294 op1 = e->value.op.op1;
1295 op2 = e->value.op.op2;
1296
1297 if (!op1 || !op2)
1298 return false;
1299
1300 if (op1->expr_type == EXPR_ARRAY && op2->rank == 0)
1301 scalar_first = false;
1302 else if (op2->expr_type == EXPR_ARRAY && op1->rank == 0)
1303 {
1304 scalar_first = true;
1305 op1 = e->value.op.op2;
1306 op2 = e->value.op.op1;
1307 }
1308 else
1309 return false;
1310
1311 if (op2->ts.type == BT_CHARACTER)
1312 return false;
1313
1314 scalar = create_var (gfc_copy_expr (op2), "constr");
1315
1316 oldbase = op1->value.constructor;
1317 newbase = NULL;
1318 e->expr_type = EXPR_ARRAY;
1319
1320 for (c = gfc_constructor_first (oldbase); c;
1321 c = gfc_constructor_next (c))
1322 {
1323 new_expr = gfc_get_expr ();
1324 new_expr->ts = e->ts;
1325 new_expr->expr_type = EXPR_OP;
1326 new_expr->rank = c->expr->rank;
1327 new_expr->where = c->where;
1328 new_expr->value.op.op = e->value.op.op;
1329
1330 if (scalar_first)
1331 {
1332 new_expr->value.op.op1 = gfc_copy_expr (scalar);
1333 new_expr->value.op.op2 = gfc_copy_expr (c->expr);
1334 }
1335 else
1336 {
1337 new_expr->value.op.op1 = gfc_copy_expr (c->expr);
1338 new_expr->value.op.op2 = gfc_copy_expr (scalar);
1339 }
1340
1341 new_c = gfc_constructor_append_expr (&newbase, new_expr, &(e->where));
1342 new_c->iterator = c->iterator;
1343 c->iterator = NULL;
1344 }
1345
1346 gfc_free_expr (op1);
1347 gfc_free_expr (op2);
1348 gfc_free_expr (scalar);
1349
1350 e->value.constructor = newbase;
1351 return true;
1352 }
1353
1354 /* Change (-1)**k into 1-ishift(iand(k,1),1) and
1355 2**k into ishift(1,k) */
1356
1357 static bool
optimize_power(gfc_expr * e)1358 optimize_power (gfc_expr *e)
1359 {
1360 gfc_expr *op1, *op2;
1361 gfc_expr *iand, *ishft;
1362
1363 if (e->ts.type != BT_INTEGER)
1364 return false;
1365
1366 op1 = e->value.op.op1;
1367
1368 if (op1 == NULL || op1->expr_type != EXPR_CONSTANT)
1369 return false;
1370
1371 if (mpz_cmp_si (op1->value.integer, -1L) == 0)
1372 {
1373 gfc_free_expr (op1);
1374
1375 op2 = e->value.op.op2;
1376
1377 if (op2 == NULL)
1378 return false;
1379
1380 iand = gfc_build_intrinsic_call (current_ns, GFC_ISYM_IAND,
1381 "_internal_iand", e->where, 2, op2,
1382 gfc_get_int_expr (e->ts.kind,
1383 &e->where, 1));
1384
1385 ishft = gfc_build_intrinsic_call (current_ns, GFC_ISYM_ISHFT,
1386 "_internal_ishft", e->where, 2, iand,
1387 gfc_get_int_expr (e->ts.kind,
1388 &e->where, 1));
1389
1390 e->value.op.op = INTRINSIC_MINUS;
1391 e->value.op.op1 = gfc_get_int_expr (e->ts.kind, &e->where, 1);
1392 e->value.op.op2 = ishft;
1393 return true;
1394 }
1395 else if (mpz_cmp_si (op1->value.integer, 2L) == 0)
1396 {
1397 gfc_free_expr (op1);
1398
1399 op2 = e->value.op.op2;
1400 if (op2 == NULL)
1401 return false;
1402
1403 ishft = gfc_build_intrinsic_call (current_ns, GFC_ISYM_ISHFT,
1404 "_internal_ishft", e->where, 2,
1405 gfc_get_int_expr (e->ts.kind,
1406 &e->where, 1),
1407 op2);
1408 *e = *ishft;
1409 return true;
1410 }
1411
1412 else if (mpz_cmp_si (op1->value.integer, 1L) == 0)
1413 {
1414 op2 = e->value.op.op2;
1415 if (op2 == NULL)
1416 return false;
1417
1418 gfc_free_expr (op1);
1419 gfc_free_expr (op2);
1420
1421 e->expr_type = EXPR_CONSTANT;
1422 e->value.op.op1 = NULL;
1423 e->value.op.op2 = NULL;
1424 mpz_init_set_si (e->value.integer, 1);
1425 /* Typespec and location are still OK. */
1426 return true;
1427 }
1428
1429 return false;
1430 }
1431
1432 /* Recursive optimization of operators. */
1433
1434 static bool
optimize_op(gfc_expr * e)1435 optimize_op (gfc_expr *e)
1436 {
1437 bool changed;
1438
1439 gfc_intrinsic_op op = e->value.op.op;
1440
1441 changed = false;
1442
1443 /* Only use new-style comparisons. */
1444 switch(op)
1445 {
1446 case INTRINSIC_EQ_OS:
1447 op = INTRINSIC_EQ;
1448 break;
1449
1450 case INTRINSIC_GE_OS:
1451 op = INTRINSIC_GE;
1452 break;
1453
1454 case INTRINSIC_LE_OS:
1455 op = INTRINSIC_LE;
1456 break;
1457
1458 case INTRINSIC_NE_OS:
1459 op = INTRINSIC_NE;
1460 break;
1461
1462 case INTRINSIC_GT_OS:
1463 op = INTRINSIC_GT;
1464 break;
1465
1466 case INTRINSIC_LT_OS:
1467 op = INTRINSIC_LT;
1468 break;
1469
1470 default:
1471 break;
1472 }
1473
1474 switch (op)
1475 {
1476 case INTRINSIC_EQ:
1477 case INTRINSIC_GE:
1478 case INTRINSIC_LE:
1479 case INTRINSIC_NE:
1480 case INTRINSIC_GT:
1481 case INTRINSIC_LT:
1482 changed = optimize_comparison (e, op);
1483
1484 /* Fall through */
1485 /* Look at array constructors. */
1486 case INTRINSIC_PLUS:
1487 case INTRINSIC_MINUS:
1488 case INTRINSIC_TIMES:
1489 case INTRINSIC_DIVIDE:
1490 return combine_array_constructor (e) || changed;
1491
1492 case INTRINSIC_POWER:
1493 return optimize_power (e);
1494 break;
1495
1496 default:
1497 break;
1498 }
1499
1500 return false;
1501 }
1502
1503
1504 /* Return true if a constant string contains only blanks. */
1505
1506 static bool
is_empty_string(gfc_expr * e)1507 is_empty_string (gfc_expr *e)
1508 {
1509 int i;
1510
1511 if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT)
1512 return false;
1513
1514 for (i=0; i < e->value.character.length; i++)
1515 {
1516 if (e->value.character.string[i] != ' ')
1517 return false;
1518 }
1519
1520 return true;
1521 }
1522
1523
1524 /* Insert a call to the intrinsic len_trim. Use a different name for
1525 the symbol tree so we don't run into trouble when the user has
1526 renamed len_trim for some reason. */
1527
1528 static gfc_expr*
get_len_trim_call(gfc_expr * str,int kind)1529 get_len_trim_call (gfc_expr *str, int kind)
1530 {
1531 gfc_expr *fcn;
1532 gfc_actual_arglist *actual_arglist, *next;
1533
1534 fcn = gfc_get_expr ();
1535 fcn->expr_type = EXPR_FUNCTION;
1536 fcn->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_LEN_TRIM);
1537 actual_arglist = gfc_get_actual_arglist ();
1538 actual_arglist->expr = str;
1539 next = gfc_get_actual_arglist ();
1540 next->expr = gfc_get_int_expr (gfc_default_integer_kind, NULL, kind);
1541 actual_arglist->next = next;
1542
1543 fcn->value.function.actual = actual_arglist;
1544 fcn->where = str->where;
1545 fcn->ts.type = BT_INTEGER;
1546 fcn->ts.kind = gfc_charlen_int_kind;
1547
1548 gfc_get_sym_tree ("__internal_len_trim", current_ns, &fcn->symtree, false);
1549 fcn->symtree->n.sym->ts = fcn->ts;
1550 fcn->symtree->n.sym->attr.flavor = FL_PROCEDURE;
1551 fcn->symtree->n.sym->attr.function = 1;
1552 fcn->symtree->n.sym->attr.elemental = 1;
1553 fcn->symtree->n.sym->attr.referenced = 1;
1554 fcn->symtree->n.sym->attr.access = ACCESS_PRIVATE;
1555 gfc_commit_symbol (fcn->symtree->n.sym);
1556
1557 return fcn;
1558 }
1559
1560 /* Optimize expressions for equality. */
1561
1562 static bool
optimize_comparison(gfc_expr * e,gfc_intrinsic_op op)1563 optimize_comparison (gfc_expr *e, gfc_intrinsic_op op)
1564 {
1565 gfc_expr *op1, *op2;
1566 bool change;
1567 int eq;
1568 bool result;
1569 gfc_actual_arglist *firstarg, *secondarg;
1570
1571 if (e->expr_type == EXPR_OP)
1572 {
1573 firstarg = NULL;
1574 secondarg = NULL;
1575 op1 = e->value.op.op1;
1576 op2 = e->value.op.op2;
1577 }
1578 else if (e->expr_type == EXPR_FUNCTION)
1579 {
1580 /* One of the lexical comparison functions. */
1581 firstarg = e->value.function.actual;
1582 secondarg = firstarg->next;
1583 op1 = firstarg->expr;
1584 op2 = secondarg->expr;
1585 }
1586 else
1587 gcc_unreachable ();
1588
1589 /* Strip off unneeded TRIM calls from string comparisons. */
1590
1591 change = remove_trim (op1);
1592
1593 if (remove_trim (op2))
1594 change = true;
1595
1596 /* An expression of type EXPR_CONSTANT is only valid for scalars. */
1597 /* TODO: A scalar constant may be acceptable in some cases (the scalarizer
1598 handles them well). However, there are also cases that need a non-scalar
1599 argument. For example the any intrinsic. See PR 45380. */
1600 if (e->rank > 0)
1601 return change;
1602
1603 /* Replace a == '' with len_trim(a) == 0 and a /= '' with
1604 len_trim(a) != 0 */
1605 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
1606 && (op == INTRINSIC_EQ || op == INTRINSIC_NE))
1607 {
1608 bool empty_op1, empty_op2;
1609 empty_op1 = is_empty_string (op1);
1610 empty_op2 = is_empty_string (op2);
1611
1612 if (empty_op1 || empty_op2)
1613 {
1614 gfc_expr *fcn;
1615 gfc_expr *zero;
1616 gfc_expr *str;
1617
1618 /* This can only happen when an error for comparing
1619 characters of different kinds has already been issued. */
1620 if (empty_op1 && empty_op2)
1621 return false;
1622
1623 zero = gfc_get_int_expr (gfc_charlen_int_kind, &e->where, 0);
1624 str = empty_op1 ? op2 : op1;
1625
1626 fcn = get_len_trim_call (str, gfc_charlen_int_kind);
1627
1628
1629 if (empty_op1)
1630 gfc_free_expr (op1);
1631 else
1632 gfc_free_expr (op2);
1633
1634 op1 = fcn;
1635 op2 = zero;
1636 e->value.op.op1 = fcn;
1637 e->value.op.op2 = zero;
1638 }
1639 }
1640
1641
1642 /* Don't compare REAL or COMPLEX expressions when honoring NaNs. */
1643
1644 if (flag_finite_math_only
1645 || (op1->ts.type != BT_REAL && op2->ts.type != BT_REAL
1646 && op1->ts.type != BT_COMPLEX && op2->ts.type != BT_COMPLEX))
1647 {
1648 eq = gfc_dep_compare_expr (op1, op2);
1649 if (eq <= -2)
1650 {
1651 /* Replace A // B < A // C with B < C, and A // B < C // B
1652 with A < C. */
1653 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
1654 && op1->expr_type == EXPR_OP
1655 && op1->value.op.op == INTRINSIC_CONCAT
1656 && op2->expr_type == EXPR_OP
1657 && op2->value.op.op == INTRINSIC_CONCAT)
1658 {
1659 gfc_expr *op1_left = op1->value.op.op1;
1660 gfc_expr *op2_left = op2->value.op.op1;
1661 gfc_expr *op1_right = op1->value.op.op2;
1662 gfc_expr *op2_right = op2->value.op.op2;
1663
1664 if (gfc_dep_compare_expr (op1_left, op2_left) == 0)
1665 {
1666 /* Watch out for 'A ' // x vs. 'A' // x. */
1667
1668 if (op1_left->expr_type == EXPR_CONSTANT
1669 && op2_left->expr_type == EXPR_CONSTANT
1670 && op1_left->value.character.length
1671 != op2_left->value.character.length)
1672 return change;
1673 else
1674 {
1675 free (op1_left);
1676 free (op2_left);
1677 if (firstarg)
1678 {
1679 firstarg->expr = op1_right;
1680 secondarg->expr = op2_right;
1681 }
1682 else
1683 {
1684 e->value.op.op1 = op1_right;
1685 e->value.op.op2 = op2_right;
1686 }
1687 optimize_comparison (e, op);
1688 return true;
1689 }
1690 }
1691 if (gfc_dep_compare_expr (op1_right, op2_right) == 0)
1692 {
1693 free (op1_right);
1694 free (op2_right);
1695 if (firstarg)
1696 {
1697 firstarg->expr = op1_left;
1698 secondarg->expr = op2_left;
1699 }
1700 else
1701 {
1702 e->value.op.op1 = op1_left;
1703 e->value.op.op2 = op2_left;
1704 }
1705
1706 optimize_comparison (e, op);
1707 return true;
1708 }
1709 }
1710 }
1711 else
1712 {
1713 /* eq can only be -1, 0 or 1 at this point. */
1714 switch (op)
1715 {
1716 case INTRINSIC_EQ:
1717 result = eq == 0;
1718 break;
1719
1720 case INTRINSIC_GE:
1721 result = eq >= 0;
1722 break;
1723
1724 case INTRINSIC_LE:
1725 result = eq <= 0;
1726 break;
1727
1728 case INTRINSIC_NE:
1729 result = eq != 0;
1730 break;
1731
1732 case INTRINSIC_GT:
1733 result = eq > 0;
1734 break;
1735
1736 case INTRINSIC_LT:
1737 result = eq < 0;
1738 break;
1739
1740 default:
1741 gfc_internal_error ("illegal OP in optimize_comparison");
1742 break;
1743 }
1744
1745 /* Replace the expression by a constant expression. The typespec
1746 and where remains the way it is. */
1747 free (op1);
1748 free (op2);
1749 e->expr_type = EXPR_CONSTANT;
1750 e->value.logical = result;
1751 return true;
1752 }
1753 }
1754
1755 return change;
1756 }
1757
1758 /* Optimize a trim function by replacing it with an equivalent substring
1759 involving a call to len_trim. This only works for expressions where
1760 variables are trimmed. Return true if anything was modified. */
1761
1762 static bool
optimize_trim(gfc_expr * e)1763 optimize_trim (gfc_expr *e)
1764 {
1765 gfc_expr *a;
1766 gfc_ref *ref;
1767 gfc_expr *fcn;
1768 gfc_ref **rr = NULL;
1769
1770 /* Don't do this optimization within an argument list, because
1771 otherwise aliasing issues may occur. */
1772
1773 if (count_arglist != 1)
1774 return false;
1775
1776 if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_FUNCTION
1777 || e->value.function.isym == NULL
1778 || e->value.function.isym->id != GFC_ISYM_TRIM)
1779 return false;
1780
1781 a = e->value.function.actual->expr;
1782
1783 if (a->expr_type != EXPR_VARIABLE)
1784 return false;
1785
1786 /* This would pessimize the idiom a = trim(a) for reallocatable strings. */
1787
1788 if (a->symtree->n.sym->attr.allocatable)
1789 return false;
1790
1791 /* Follow all references to find the correct place to put the newly
1792 created reference. FIXME: Also handle substring references and
1793 array references. Array references cause strange regressions at
1794 the moment. */
1795
1796 if (a->ref)
1797 {
1798 for (rr = &(a->ref); *rr; rr = &((*rr)->next))
1799 {
1800 if ((*rr)->type == REF_SUBSTRING || (*rr)->type == REF_ARRAY)
1801 return false;
1802 }
1803 }
1804
1805 strip_function_call (e);
1806
1807 if (e->ref == NULL)
1808 rr = &(e->ref);
1809
1810 /* Create the reference. */
1811
1812 ref = gfc_get_ref ();
1813 ref->type = REF_SUBSTRING;
1814
1815 /* Set the start of the reference. */
1816
1817 ref->u.ss.start = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
1818
1819 /* Build the function call to len_trim(x, gfc_default_integer_kind). */
1820
1821 fcn = get_len_trim_call (gfc_copy_expr (e), gfc_default_integer_kind);
1822
1823 /* Set the end of the reference to the call to len_trim. */
1824
1825 ref->u.ss.end = fcn;
1826 gcc_assert (rr != NULL && *rr == NULL);
1827 *rr = ref;
1828 return true;
1829 }
1830
1831 /* Optimize minloc(b), where b is rank 1 array, into
1832 (/ minloc(b, dim=1) /), and similarly for maxloc,
1833 as the latter forms are expanded inline. */
1834
1835 static void
optimize_minmaxloc(gfc_expr ** e)1836 optimize_minmaxloc (gfc_expr **e)
1837 {
1838 gfc_expr *fn = *e;
1839 gfc_actual_arglist *a;
1840 char *name, *p;
1841
1842 if (fn->rank != 1
1843 || fn->value.function.actual == NULL
1844 || fn->value.function.actual->expr == NULL
1845 || fn->value.function.actual->expr->rank != 1)
1846 return;
1847
1848 *e = gfc_get_array_expr (fn->ts.type, fn->ts.kind, &fn->where);
1849 (*e)->shape = fn->shape;
1850 fn->rank = 0;
1851 fn->shape = NULL;
1852 gfc_constructor_append_expr (&(*e)->value.constructor, fn, &fn->where);
1853
1854 name = XALLOCAVEC (char, strlen (fn->value.function.name) + 1);
1855 strcpy (name, fn->value.function.name);
1856 p = strstr (name, "loc0");
1857 p[3] = '1';
1858 fn->value.function.name = gfc_get_string (name);
1859 if (fn->value.function.actual->next)
1860 {
1861 a = fn->value.function.actual->next;
1862 gcc_assert (a->expr == NULL);
1863 }
1864 else
1865 {
1866 a = gfc_get_actual_arglist ();
1867 fn->value.function.actual->next = a;
1868 }
1869 a->expr = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
1870 &fn->where);
1871 mpz_set_ui (a->expr->value.integer, 1);
1872 }
1873
1874 /* Callback function for code checking that we do not pass a DO variable to an
1875 INTENT(OUT) or INTENT(INOUT) dummy variable. */
1876
1877 static int
doloop_code(gfc_code ** c,int * walk_subtrees ATTRIBUTE_UNUSED,void * data ATTRIBUTE_UNUSED)1878 doloop_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
1879 void *data ATTRIBUTE_UNUSED)
1880 {
1881 gfc_code *co;
1882 int i;
1883 gfc_formal_arglist *f;
1884 gfc_actual_arglist *a;
1885 gfc_code *cl;
1886
1887 co = *c;
1888
1889 /* If the doloop_list grew, we have to truncate it here. */
1890
1891 if ((unsigned) doloop_level < doloop_list.length())
1892 doloop_list.truncate (doloop_level);
1893
1894 switch (co->op)
1895 {
1896 case EXEC_DO:
1897
1898 if (co->ext.iterator && co->ext.iterator->var)
1899 doloop_list.safe_push (co);
1900 else
1901 doloop_list.safe_push ((gfc_code *) NULL);
1902 break;
1903
1904 case EXEC_CALL:
1905
1906 if (co->resolved_sym == NULL)
1907 break;
1908
1909 f = gfc_sym_get_dummy_args (co->resolved_sym);
1910
1911 /* Withot a formal arglist, there is only unknown INTENT,
1912 which we don't check for. */
1913 if (f == NULL)
1914 break;
1915
1916 a = co->ext.actual;
1917
1918 while (a && f)
1919 {
1920 FOR_EACH_VEC_ELT (doloop_list, i, cl)
1921 {
1922 gfc_symbol *do_sym;
1923
1924 if (cl == NULL)
1925 break;
1926
1927 do_sym = cl->ext.iterator->var->symtree->n.sym;
1928
1929 if (a->expr && a->expr->symtree
1930 && a->expr->symtree->n.sym == do_sym)
1931 {
1932 if (f->sym->attr.intent == INTENT_OUT)
1933 gfc_error_now ("Variable %qs at %L set to undefined "
1934 "value inside loop beginning at %L as "
1935 "INTENT(OUT) argument to subroutine %qs",
1936 do_sym->name, &a->expr->where,
1937 &doloop_list[i]->loc,
1938 co->symtree->n.sym->name);
1939 else if (f->sym->attr.intent == INTENT_INOUT)
1940 gfc_error_now ("Variable %qs at %L not definable inside "
1941 "loop beginning at %L as INTENT(INOUT) "
1942 "argument to subroutine %qs",
1943 do_sym->name, &a->expr->where,
1944 &doloop_list[i]->loc,
1945 co->symtree->n.sym->name);
1946 }
1947 }
1948 a = a->next;
1949 f = f->next;
1950 }
1951 break;
1952
1953 default:
1954 break;
1955 }
1956 return 0;
1957 }
1958
1959 /* Callback function for functions checking that we do not pass a DO variable
1960 to an INTENT(OUT) or INTENT(INOUT) dummy variable. */
1961
1962 static int
do_function(gfc_expr ** e,int * walk_subtrees ATTRIBUTE_UNUSED,void * data ATTRIBUTE_UNUSED)1963 do_function (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
1964 void *data ATTRIBUTE_UNUSED)
1965 {
1966 gfc_formal_arglist *f;
1967 gfc_actual_arglist *a;
1968 gfc_expr *expr;
1969 gfc_code *dl;
1970 int i;
1971
1972 expr = *e;
1973 if (expr->expr_type != EXPR_FUNCTION)
1974 return 0;
1975
1976 /* Intrinsic functions don't modify their arguments. */
1977
1978 if (expr->value.function.isym)
1979 return 0;
1980
1981 f = gfc_sym_get_dummy_args (expr->symtree->n.sym);
1982
1983 /* Without a formal arglist, there is only unknown INTENT,
1984 which we don't check for. */
1985 if (f == NULL)
1986 return 0;
1987
1988 a = expr->value.function.actual;
1989
1990 while (a && f)
1991 {
1992 FOR_EACH_VEC_ELT (doloop_list, i, dl)
1993 {
1994 gfc_symbol *do_sym;
1995
1996 if (dl == NULL)
1997 break;
1998
1999 do_sym = dl->ext.iterator->var->symtree->n.sym;
2000
2001 if (a->expr && a->expr->symtree
2002 && a->expr->symtree->n.sym == do_sym)
2003 {
2004 if (f->sym->attr.intent == INTENT_OUT)
2005 gfc_error_now ("Variable %qs at %L set to undefined value "
2006 "inside loop beginning at %L as INTENT(OUT) "
2007 "argument to function %qs", do_sym->name,
2008 &a->expr->where, &doloop_list[i]->loc,
2009 expr->symtree->n.sym->name);
2010 else if (f->sym->attr.intent == INTENT_INOUT)
2011 gfc_error_now ("Variable %qs at %L not definable inside loop"
2012 " beginning at %L as INTENT(INOUT) argument to"
2013 " function %qs", do_sym->name,
2014 &a->expr->where, &doloop_list[i]->loc,
2015 expr->symtree->n.sym->name);
2016 }
2017 }
2018 a = a->next;
2019 f = f->next;
2020 }
2021
2022 return 0;
2023 }
2024
2025 static void
doloop_warn(gfc_namespace * ns)2026 doloop_warn (gfc_namespace *ns)
2027 {
2028 gfc_code_walker (&ns->code, doloop_code, do_function, NULL);
2029 }
2030
2031 /* This selction deals with inlining calls to MATMUL. */
2032
2033 /* Auxiliary function to build and simplify an array inquiry function.
2034 dim is zero-based. */
2035
2036 static gfc_expr *
get_array_inq_function(gfc_isym_id id,gfc_expr * e,int dim)2037 get_array_inq_function (gfc_isym_id id, gfc_expr *e, int dim)
2038 {
2039 gfc_expr *fcn;
2040 gfc_expr *dim_arg, *kind;
2041 const char *name;
2042 gfc_expr *ec;
2043
2044 switch (id)
2045 {
2046 case GFC_ISYM_LBOUND:
2047 name = "_gfortran_lbound";
2048 break;
2049
2050 case GFC_ISYM_UBOUND:
2051 name = "_gfortran_ubound";
2052 break;
2053
2054 case GFC_ISYM_SIZE:
2055 name = "_gfortran_size";
2056 break;
2057
2058 default:
2059 gcc_unreachable ();
2060 }
2061
2062 dim_arg = gfc_get_int_expr (gfc_default_integer_kind, &e->where, dim);
2063 kind = gfc_get_int_expr (gfc_default_integer_kind, &e->where,
2064 gfc_index_integer_kind);
2065
2066 ec = gfc_copy_expr (e);
2067 fcn = gfc_build_intrinsic_call (current_ns, id, name, e->where, 3,
2068 ec, dim_arg, kind);
2069 gfc_simplify_expr (fcn, 0);
2070 return fcn;
2071 }
2072
2073 /* Builds a logical expression. */
2074
2075 static gfc_expr*
build_logical_expr(gfc_intrinsic_op op,gfc_expr * e1,gfc_expr * e2)2076 build_logical_expr (gfc_intrinsic_op op, gfc_expr *e1, gfc_expr *e2)
2077 {
2078 gfc_typespec ts;
2079 gfc_expr *res;
2080
2081 ts.type = BT_LOGICAL;
2082 ts.kind = gfc_default_logical_kind;
2083 res = gfc_get_expr ();
2084 res->where = e1->where;
2085 res->expr_type = EXPR_OP;
2086 res->value.op.op = op;
2087 res->value.op.op1 = e1;
2088 res->value.op.op2 = e2;
2089 res->ts = ts;
2090
2091 return res;
2092 }
2093
2094
2095 /* Return an operation of one two gfc_expr (one if e2 is NULL). This assumes
2096 compatible typespecs. */
2097
2098 static gfc_expr *
get_operand(gfc_intrinsic_op op,gfc_expr * e1,gfc_expr * e2)2099 get_operand (gfc_intrinsic_op op, gfc_expr *e1, gfc_expr *e2)
2100 {
2101 gfc_expr *res;
2102
2103 res = gfc_get_expr ();
2104 res->ts = e1->ts;
2105 res->where = e1->where;
2106 res->expr_type = EXPR_OP;
2107 res->value.op.op = op;
2108 res->value.op.op1 = e1;
2109 res->value.op.op2 = e2;
2110 gfc_simplify_expr (res, 0);
2111 return res;
2112 }
2113
2114 /* Generate the IF statement for a runtime check if we want to do inlining or
2115 not - putting in the code for both branches and putting it into the syntax
2116 tree is the caller's responsibility. For fixed array sizes, this should be
2117 removed by DCE. Only called for rank-two matrices A and B. */
2118
2119 static gfc_code *
inline_limit_check(gfc_expr * a,gfc_expr * b,enum matrix_case m_case)2120 inline_limit_check (gfc_expr *a, gfc_expr *b, enum matrix_case m_case)
2121 {
2122 gfc_expr *inline_limit;
2123 gfc_code *if_1, *if_2, *else_2;
2124 gfc_expr *b2, *a2, *a1, *m1, *m2;
2125 gfc_typespec ts;
2126 gfc_expr *cond;
2127
2128 gcc_assert (m_case == A2B2 || m_case == A2B2T);
2129
2130 /* Calculation is done in real to avoid integer overflow. */
2131
2132 inline_limit = gfc_get_constant_expr (BT_REAL, gfc_default_real_kind,
2133 &a->where);
2134 mpfr_set_si (inline_limit->value.real, flag_inline_matmul_limit,
2135 GFC_RND_MODE);
2136 mpfr_pow_ui (inline_limit->value.real, inline_limit->value.real, 3,
2137 GFC_RND_MODE);
2138
2139 a1 = get_array_inq_function (GFC_ISYM_SIZE, a, 1);
2140 a2 = get_array_inq_function (GFC_ISYM_SIZE, a, 2);
2141 b2 = get_array_inq_function (GFC_ISYM_SIZE, b, 2);
2142
2143 gfc_clear_ts (&ts);
2144 ts.type = BT_REAL;
2145 ts.kind = gfc_default_real_kind;
2146 gfc_convert_type_warn (a1, &ts, 2, 0);
2147 gfc_convert_type_warn (a2, &ts, 2, 0);
2148 gfc_convert_type_warn (b2, &ts, 2, 0);
2149
2150 m1 = get_operand (INTRINSIC_TIMES, a1, a2);
2151 m2 = get_operand (INTRINSIC_TIMES, m1, b2);
2152
2153 cond = build_logical_expr (INTRINSIC_LE, m2, inline_limit);
2154 gfc_simplify_expr (cond, 0);
2155
2156 else_2 = XCNEW (gfc_code);
2157 else_2->op = EXEC_IF;
2158 else_2->loc = a->where;
2159
2160 if_2 = XCNEW (gfc_code);
2161 if_2->op = EXEC_IF;
2162 if_2->expr1 = cond;
2163 if_2->loc = a->where;
2164 if_2->block = else_2;
2165
2166 if_1 = XCNEW (gfc_code);
2167 if_1->op = EXEC_IF;
2168 if_1->block = if_2;
2169 if_1->loc = a->where;
2170
2171 return if_1;
2172 }
2173
2174
2175 /* Insert code to issue a runtime error if the expressions are not equal. */
2176
2177 static gfc_code *
runtime_error_ne(gfc_expr * e1,gfc_expr * e2,const char * msg)2178 runtime_error_ne (gfc_expr *e1, gfc_expr *e2, const char *msg)
2179 {
2180 gfc_expr *cond;
2181 gfc_code *if_1, *if_2;
2182 gfc_code *c;
2183 gfc_actual_arglist *a1, *a2, *a3;
2184
2185 gcc_assert (e1->where.lb);
2186 /* Build the call to runtime_error. */
2187 c = XCNEW (gfc_code);
2188 c->op = EXEC_CALL;
2189 c->loc = e1->where;
2190
2191 /* Get a null-terminated message string. */
2192
2193 a1 = gfc_get_actual_arglist ();
2194 a1->expr = gfc_get_character_expr (gfc_default_character_kind, &e1->where,
2195 msg, strlen(msg)+1);
2196 c->ext.actual = a1;
2197
2198 /* Pass the value of the first expression. */
2199 a2 = gfc_get_actual_arglist ();
2200 a2->expr = gfc_copy_expr (e1);
2201 a1->next = a2;
2202
2203 /* Pass the value of the second expression. */
2204 a3 = gfc_get_actual_arglist ();
2205 a3->expr = gfc_copy_expr (e2);
2206 a2->next = a3;
2207
2208 gfc_check_fe_runtime_error (c->ext.actual);
2209 gfc_resolve_fe_runtime_error (c);
2210
2211 if_2 = XCNEW (gfc_code);
2212 if_2->op = EXEC_IF;
2213 if_2->loc = e1->where;
2214 if_2->next = c;
2215
2216 if_1 = XCNEW (gfc_code);
2217 if_1->op = EXEC_IF;
2218 if_1->block = if_2;
2219 if_1->loc = e1->where;
2220
2221 cond = build_logical_expr (INTRINSIC_NE, e1, e2);
2222 gfc_simplify_expr (cond, 0);
2223 if_2->expr1 = cond;
2224
2225 return if_1;
2226 }
2227
2228 /* Handle matrix reallocation. Caller is responsible to insert into
2229 the code tree.
2230
2231 For the two-dimensional case, build
2232
2233 if (allocated(c)) then
2234 if (size(c,1) /= size(a,1) .or. size(c,2) /= size(b,2)) then
2235 deallocate(c)
2236 allocate (c(size(a,1), size(b,2)))
2237 end if
2238 else
2239 allocate (c(size(a,1),size(b,2)))
2240 end if
2241
2242 and for the other cases correspondingly.
2243 */
2244
2245 static gfc_code *
matmul_lhs_realloc(gfc_expr * c,gfc_expr * a,gfc_expr * b,enum matrix_case m_case)2246 matmul_lhs_realloc (gfc_expr *c, gfc_expr *a, gfc_expr *b,
2247 enum matrix_case m_case)
2248 {
2249
2250 gfc_expr *allocated, *alloc_expr;
2251 gfc_code *if_alloc_1, *if_alloc_2, *if_size_1, *if_size_2;
2252 gfc_code *else_alloc;
2253 gfc_code *deallocate, *allocate1, *allocate_else;
2254 gfc_array_ref *ar;
2255 gfc_expr *cond, *ne1, *ne2;
2256
2257 if (warn_realloc_lhs)
2258 gfc_warning (OPT_Wrealloc_lhs,
2259 "Code for reallocating the allocatable array at %L will "
2260 "be added", &c->where);
2261
2262 alloc_expr = gfc_copy_expr (c);
2263
2264 ar = gfc_find_array_ref (alloc_expr);
2265 gcc_assert (ar && ar->type == AR_FULL);
2266
2267 /* c comes in as a full ref. Change it into a copy and make it into an
2268 element ref so it has the right form for for ALLOCATE. In the same
2269 switch statement, also generate the size comparison for the secod IF
2270 statement. */
2271
2272 ar->type = AR_ELEMENT;
2273
2274 switch (m_case)
2275 {
2276 case A2B2:
2277 ar->start[0] = get_array_inq_function (GFC_ISYM_SIZE, a, 1);
2278 ar->start[1] = get_array_inq_function (GFC_ISYM_SIZE, b, 2);
2279 ne1 = build_logical_expr (INTRINSIC_NE,
2280 get_array_inq_function (GFC_ISYM_SIZE, c, 1),
2281 get_array_inq_function (GFC_ISYM_SIZE, a, 1));
2282 ne2 = build_logical_expr (INTRINSIC_NE,
2283 get_array_inq_function (GFC_ISYM_SIZE, c, 2),
2284 get_array_inq_function (GFC_ISYM_SIZE, b, 2));
2285 cond = build_logical_expr (INTRINSIC_OR, ne1, ne2);
2286 break;
2287
2288 case A2B2T:
2289 ar->start[0] = get_array_inq_function (GFC_ISYM_SIZE, a, 1);
2290 ar->start[1] = get_array_inq_function (GFC_ISYM_SIZE, b, 1);
2291
2292 ne1 = build_logical_expr (INTRINSIC_NE,
2293 get_array_inq_function (GFC_ISYM_SIZE, c, 1),
2294 get_array_inq_function (GFC_ISYM_SIZE, a, 1));
2295 ne2 = build_logical_expr (INTRINSIC_NE,
2296 get_array_inq_function (GFC_ISYM_SIZE, c, 2),
2297 get_array_inq_function (GFC_ISYM_SIZE, b, 1));
2298 cond = build_logical_expr (INTRINSIC_OR, ne1, ne2);
2299 break;
2300
2301 case A2B1:
2302 ar->start[0] = get_array_inq_function (GFC_ISYM_SIZE, a, 1);
2303 cond = build_logical_expr (INTRINSIC_NE,
2304 get_array_inq_function (GFC_ISYM_SIZE, c, 1),
2305 get_array_inq_function (GFC_ISYM_SIZE, a, 2));
2306 break;
2307
2308 case A1B2:
2309 ar->start[0] = get_array_inq_function (GFC_ISYM_SIZE, b, 2);
2310 cond = build_logical_expr (INTRINSIC_NE,
2311 get_array_inq_function (GFC_ISYM_SIZE, c, 1),
2312 get_array_inq_function (GFC_ISYM_SIZE, b, 2));
2313 break;
2314
2315 default:
2316 gcc_unreachable();
2317
2318 }
2319
2320 gfc_simplify_expr (cond, 0);
2321
2322 /* We need two identical allocate statements in two
2323 branches of the IF statement. */
2324
2325 allocate1 = XCNEW (gfc_code);
2326 allocate1->op = EXEC_ALLOCATE;
2327 allocate1->ext.alloc.list = gfc_get_alloc ();
2328 allocate1->loc = c->where;
2329 allocate1->ext.alloc.list->expr = gfc_copy_expr (alloc_expr);
2330
2331 allocate_else = XCNEW (gfc_code);
2332 allocate_else->op = EXEC_ALLOCATE;
2333 allocate_else->ext.alloc.list = gfc_get_alloc ();
2334 allocate_else->loc = c->where;
2335 allocate_else->ext.alloc.list->expr = alloc_expr;
2336
2337 allocated = gfc_build_intrinsic_call (current_ns, GFC_ISYM_ALLOCATED,
2338 "_gfortran_allocated", c->where,
2339 1, gfc_copy_expr (c));
2340
2341 deallocate = XCNEW (gfc_code);
2342 deallocate->op = EXEC_DEALLOCATE;
2343 deallocate->ext.alloc.list = gfc_get_alloc ();
2344 deallocate->ext.alloc.list->expr = gfc_copy_expr (c);
2345 deallocate->next = allocate1;
2346 deallocate->loc = c->where;
2347
2348 if_size_2 = XCNEW (gfc_code);
2349 if_size_2->op = EXEC_IF;
2350 if_size_2->expr1 = cond;
2351 if_size_2->loc = c->where;
2352 if_size_2->next = deallocate;
2353
2354 if_size_1 = XCNEW (gfc_code);
2355 if_size_1->op = EXEC_IF;
2356 if_size_1->block = if_size_2;
2357 if_size_1->loc = c->where;
2358
2359 else_alloc = XCNEW (gfc_code);
2360 else_alloc->op = EXEC_IF;
2361 else_alloc->loc = c->where;
2362 else_alloc->next = allocate_else;
2363
2364 if_alloc_2 = XCNEW (gfc_code);
2365 if_alloc_2->op = EXEC_IF;
2366 if_alloc_2->expr1 = allocated;
2367 if_alloc_2->loc = c->where;
2368 if_alloc_2->next = if_size_1;
2369 if_alloc_2->block = else_alloc;
2370
2371 if_alloc_1 = XCNEW (gfc_code);
2372 if_alloc_1->op = EXEC_IF;
2373 if_alloc_1->block = if_alloc_2;
2374 if_alloc_1->loc = c->where;
2375
2376 return if_alloc_1;
2377 }
2378
2379 /* Callback function for has_function_or_op. */
2380
2381 static int
is_function_or_op(gfc_expr ** e,int * walk_subtrees ATTRIBUTE_UNUSED,void * data ATTRIBUTE_UNUSED)2382 is_function_or_op (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
2383 void *data ATTRIBUTE_UNUSED)
2384 {
2385 if ((*e) == 0)
2386 return 0;
2387 else
2388 return (*e)->expr_type == EXPR_FUNCTION
2389 || (*e)->expr_type == EXPR_OP;
2390 }
2391
2392 /* Returns true if the expression contains a function. */
2393
2394 static bool
has_function_or_op(gfc_expr ** e)2395 has_function_or_op (gfc_expr **e)
2396 {
2397 if (e == NULL)
2398 return false;
2399 else
2400 return gfc_expr_walker (e, is_function_or_op, NULL);
2401 }
2402
2403 /* Freeze (assign to a temporary variable) a single expression. */
2404
2405 static void
freeze_expr(gfc_expr ** ep)2406 freeze_expr (gfc_expr **ep)
2407 {
2408 gfc_expr *ne;
2409 if (has_function_or_op (ep))
2410 {
2411 ne = create_var (*ep, "freeze");
2412 *ep = ne;
2413 }
2414 }
2415
2416 /* Go through an expression's references and assign them to temporary
2417 variables if they contain functions. This is usually done prior to
2418 front-end scalarization to avoid multiple invocations of functions. */
2419
2420 static void
freeze_references(gfc_expr * e)2421 freeze_references (gfc_expr *e)
2422 {
2423 gfc_ref *r;
2424 gfc_array_ref *ar;
2425 int i;
2426
2427 for (r=e->ref; r; r=r->next)
2428 {
2429 if (r->type == REF_SUBSTRING)
2430 {
2431 if (r->u.ss.start != NULL)
2432 freeze_expr (&r->u.ss.start);
2433
2434 if (r->u.ss.end != NULL)
2435 freeze_expr (&r->u.ss.end);
2436 }
2437 else if (r->type == REF_ARRAY)
2438 {
2439 ar = &r->u.ar;
2440 switch (ar->type)
2441 {
2442 case AR_FULL:
2443 break;
2444
2445 case AR_SECTION:
2446 for (i=0; i<ar->dimen; i++)
2447 {
2448 if (ar->dimen_type[i] == DIMEN_RANGE)
2449 {
2450 freeze_expr (&ar->start[i]);
2451 freeze_expr (&ar->end[i]);
2452 freeze_expr (&ar->stride[i]);
2453 }
2454 else if (ar->dimen_type[i] == DIMEN_ELEMENT)
2455 {
2456 freeze_expr (&ar->start[i]);
2457 }
2458 }
2459 break;
2460
2461 case AR_ELEMENT:
2462 for (i=0; i<ar->dimen; i++)
2463 freeze_expr (&ar->start[i]);
2464 break;
2465
2466 default:
2467 break;
2468 }
2469 }
2470 }
2471 }
2472
2473 /* Convert to gfc_index_integer_kind if needed, just do a copy otherwise. */
2474
2475 static gfc_expr *
convert_to_index_kind(gfc_expr * e)2476 convert_to_index_kind (gfc_expr *e)
2477 {
2478 gfc_expr *res;
2479
2480 gcc_assert (e != NULL);
2481
2482 res = gfc_copy_expr (e);
2483
2484 gcc_assert (e->ts.type == BT_INTEGER);
2485
2486 if (res->ts.kind != gfc_index_integer_kind)
2487 {
2488 gfc_typespec ts;
2489 gfc_clear_ts (&ts);
2490 ts.type = BT_INTEGER;
2491 ts.kind = gfc_index_integer_kind;
2492
2493 gfc_convert_type_warn (e, &ts, 2, 0);
2494 }
2495
2496 return res;
2497 }
2498
2499 /* Function to create a DO loop including creation of the
2500 iteration variable. gfc_expr are copied.*/
2501
2502 static gfc_code *
create_do_loop(gfc_expr * start,gfc_expr * end,gfc_expr * step,locus * where,gfc_namespace * ns,char * vname)2503 create_do_loop (gfc_expr *start, gfc_expr *end, gfc_expr *step, locus *where,
2504 gfc_namespace *ns, char *vname)
2505 {
2506
2507 char name[GFC_MAX_SYMBOL_LEN +1];
2508 gfc_symtree *symtree;
2509 gfc_symbol *symbol;
2510 gfc_expr *i;
2511 gfc_code *n, *n2;
2512
2513 /* Create an expression for the iteration variable. */
2514 if (vname)
2515 sprintf (name, "__var_%d_do_%s", var_num++, vname);
2516 else
2517 sprintf (name, "__var_%d_do", var_num++);
2518
2519
2520 if (gfc_get_sym_tree (name, ns, &symtree, false) != 0)
2521 gcc_unreachable ();
2522
2523 /* Create the loop variable. */
2524
2525 symbol = symtree->n.sym;
2526 symbol->ts.type = BT_INTEGER;
2527 symbol->ts.kind = gfc_index_integer_kind;
2528 symbol->attr.flavor = FL_VARIABLE;
2529 symbol->attr.referenced = 1;
2530 symbol->attr.dimension = 0;
2531 symbol->attr.fe_temp = 1;
2532 gfc_commit_symbol (symbol);
2533
2534 i = gfc_get_expr ();
2535 i->expr_type = EXPR_VARIABLE;
2536 i->ts = symbol->ts;
2537 i->rank = 0;
2538 i->where = *where;
2539 i->symtree = symtree;
2540
2541 /* ... and the nested DO statements. */
2542 n = XCNEW (gfc_code);
2543 n->op = EXEC_DO;
2544 n->loc = *where;
2545 n->ext.iterator = gfc_get_iterator ();
2546 n->ext.iterator->var = i;
2547 n->ext.iterator->start = convert_to_index_kind (start);
2548 n->ext.iterator->end = convert_to_index_kind (end);
2549 if (step)
2550 n->ext.iterator->step = convert_to_index_kind (step);
2551 else
2552 n->ext.iterator->step = gfc_get_int_expr (gfc_index_integer_kind,
2553 where, 1);
2554
2555 n2 = XCNEW (gfc_code);
2556 n2->op = EXEC_DO;
2557 n2->loc = *where;
2558 n2->next = NULL;
2559 n->block = n2;
2560 return n;
2561 }
2562
2563 /* Get the upper bound of the DO loops for matmul along a dimension. This
2564 is one-based. */
2565
2566 static gfc_expr*
get_size_m1(gfc_expr * e,int dimen)2567 get_size_m1 (gfc_expr *e, int dimen)
2568 {
2569 mpz_t size;
2570 gfc_expr *res;
2571
2572 if (gfc_array_dimen_size (e, dimen - 1, &size))
2573 {
2574 res = gfc_get_constant_expr (BT_INTEGER,
2575 gfc_index_integer_kind, &e->where);
2576 mpz_sub_ui (res->value.integer, size, 1);
2577 mpz_clear (size);
2578 }
2579 else
2580 {
2581 res = get_operand (INTRINSIC_MINUS,
2582 get_array_inq_function (GFC_ISYM_SIZE, e, dimen),
2583 gfc_get_int_expr (gfc_index_integer_kind,
2584 &e->where, 1));
2585 gfc_simplify_expr (res, 0);
2586 }
2587
2588 return res;
2589 }
2590
2591 /* Function to return a scalarized expression. It is assumed that indices are
2592 zero based to make generation of DO loops easier. A zero as index will
2593 access the first element along a dimension. Single element references will
2594 be skipped. A NULL as an expression will be replaced by a full reference.
2595 This assumes that the index loops have gfc_index_integer_kind, and that all
2596 references have been frozen. */
2597
2598 static gfc_expr*
scalarized_expr(gfc_expr * e_in,gfc_expr ** index,int count_index)2599 scalarized_expr (gfc_expr *e_in, gfc_expr **index, int count_index)
2600 {
2601 gfc_array_ref *ar;
2602 int i;
2603 int rank;
2604 gfc_expr *e;
2605 int i_index;
2606 bool was_fullref;
2607
2608 e = gfc_copy_expr(e_in);
2609
2610 rank = e->rank;
2611
2612 ar = gfc_find_array_ref (e);
2613
2614 /* We scalarize count_index variables, reducing the rank by count_index. */
2615
2616 e->rank = rank - count_index;
2617
2618 was_fullref = ar->type == AR_FULL;
2619
2620 if (e->rank == 0)
2621 ar->type = AR_ELEMENT;
2622 else
2623 ar->type = AR_SECTION;
2624
2625 /* Loop over the indices. For each index, create the expression
2626 index * stride + lbound(e, dim). */
2627
2628 i_index = 0;
2629 for (i=0; i < ar->dimen; i++)
2630 {
2631 if (was_fullref || ar->dimen_type[i] == DIMEN_RANGE)
2632 {
2633 if (index[i_index] != NULL)
2634 {
2635 gfc_expr *lbound, *nindex;
2636 gfc_expr *loopvar;
2637
2638 loopvar = gfc_copy_expr (index[i_index]);
2639
2640 if (ar->stride[i])
2641 {
2642 gfc_expr *tmp;
2643
2644 tmp = gfc_copy_expr(ar->stride[i]);
2645 if (tmp->ts.kind != gfc_index_integer_kind)
2646 {
2647 gfc_typespec ts;
2648 gfc_clear_ts (&ts);
2649 ts.type = BT_INTEGER;
2650 ts.kind = gfc_index_integer_kind;
2651 gfc_convert_type (tmp, &ts, 2);
2652 }
2653 nindex = get_operand (INTRINSIC_TIMES, loopvar, tmp);
2654 }
2655 else
2656 nindex = loopvar;
2657
2658 /* Calculate the lower bound of the expression. */
2659 if (ar->start[i])
2660 {
2661 lbound = gfc_copy_expr (ar->start[i]);
2662 if (lbound->ts.kind != gfc_index_integer_kind)
2663 {
2664 gfc_typespec ts;
2665 gfc_clear_ts (&ts);
2666 ts.type = BT_INTEGER;
2667 ts.kind = gfc_index_integer_kind;
2668 gfc_convert_type (lbound, &ts, 2);
2669
2670 }
2671 }
2672 else
2673 {
2674 gfc_expr *lbound_e;
2675 gfc_ref *ref;
2676
2677 lbound_e = gfc_copy_expr (e_in);
2678
2679 for (ref = lbound_e->ref; ref; ref = ref->next)
2680 if (ref->type == REF_ARRAY
2681 && (ref->u.ar.type == AR_FULL
2682 || ref->u.ar.type == AR_SECTION))
2683 break;
2684
2685 if (ref->next)
2686 {
2687 gfc_free_ref_list (ref->next);
2688 ref->next = NULL;
2689 }
2690
2691 if (!was_fullref)
2692 {
2693 /* Look at full individual sections, like a(:). The first index
2694 is the lbound of a full ref. */
2695 int j;
2696 gfc_array_ref *ar;
2697
2698 ar = &ref->u.ar;
2699 ar->type = AR_FULL;
2700 for (j = 0; j < ar->dimen; j++)
2701 {
2702 gfc_free_expr (ar->start[j]);
2703 ar->start[j] = NULL;
2704 gfc_free_expr (ar->end[j]);
2705 ar->end[j] = NULL;
2706 gfc_free_expr (ar->stride[j]);
2707 ar->stride[j] = NULL;
2708 }
2709
2710 /* We have to get rid of the shape, if there is one. Do
2711 so by freeing it and calling gfc_resolve to rebuild
2712 it, if necessary. */
2713
2714 if (lbound_e->shape)
2715 gfc_free_shape (&(lbound_e->shape), lbound_e->rank);
2716
2717 lbound_e->rank = ar->dimen;
2718 gfc_resolve_expr (lbound_e);
2719 }
2720 lbound = get_array_inq_function (GFC_ISYM_LBOUND, lbound_e,
2721 i + 1);
2722 gfc_free_expr (lbound_e);
2723 }
2724
2725 ar->dimen_type[i] = DIMEN_ELEMENT;
2726
2727 gfc_free_expr (ar->start[i]);
2728 ar->start[i] = get_operand (INTRINSIC_PLUS, nindex, lbound);
2729
2730 gfc_free_expr (ar->end[i]);
2731 ar->end[i] = NULL;
2732 gfc_free_expr (ar->stride[i]);
2733 ar->stride[i] = NULL;
2734 gfc_simplify_expr (ar->start[i], 0);
2735 }
2736 else if (was_fullref)
2737 {
2738 gfc_internal_error ("Scalarization using DIMEN_RANGE unimplemented");
2739 }
2740 i_index ++;
2741 }
2742 }
2743
2744 return e;
2745 }
2746
2747 /* Helper function to check for a dimen vector as subscript. */
2748
2749 static bool
has_dimen_vector_ref(gfc_expr * e)2750 has_dimen_vector_ref (gfc_expr *e)
2751 {
2752 gfc_array_ref *ar;
2753 int i;
2754
2755 ar = gfc_find_array_ref (e);
2756 gcc_assert (ar);
2757 if (ar->type == AR_FULL)
2758 return false;
2759
2760 for (i=0; i<ar->dimen; i++)
2761 if (ar->dimen_type[i] == DIMEN_VECTOR)
2762 return true;
2763
2764 return false;
2765 }
2766
2767 /* If handed an expression of the form
2768
2769 TRANSPOSE(CONJG(A))
2770
2771 check if A can be handled by matmul and return if there is an uneven number
2772 of CONJG calls. Return a pointer to the array when everything is OK, NULL
2773 otherwise. The caller has to check for the correct rank. */
2774
2775 static gfc_expr*
check_conjg_transpose_variable(gfc_expr * e,bool * conjg,bool * transpose)2776 check_conjg_transpose_variable (gfc_expr *e, bool *conjg, bool *transpose)
2777 {
2778 *conjg = false;
2779 *transpose = false;
2780
2781 do
2782 {
2783 if (e->expr_type == EXPR_VARIABLE)
2784 {
2785 gcc_assert (e->rank == 1 || e->rank == 2);
2786 return e;
2787 }
2788 else if (e->expr_type == EXPR_FUNCTION)
2789 {
2790 if (e->value.function.isym == NULL)
2791 return NULL;
2792
2793 if (e->value.function.isym->id == GFC_ISYM_CONJG)
2794 *conjg = !*conjg;
2795 else if (e->value.function.isym->id == GFC_ISYM_TRANSPOSE)
2796 *transpose = !*transpose;
2797 else return NULL;
2798 }
2799 else
2800 return NULL;
2801
2802 e = e->value.function.actual->expr;
2803 }
2804 while(1);
2805
2806 return NULL;
2807 }
2808
2809 /* Inline assignments of the form c = matmul(a,b).
2810 Handle only the cases currently where b and c are rank-two arrays.
2811
2812 This basically translates the code to
2813
2814 BLOCK
2815 integer i,j,k
2816 c = 0
2817 do j=0, size(b,2)-1
2818 do k=0, size(a, 2)-1
2819 do i=0, size(a, 1)-1
2820 c(i * stride(c,1) + lbound(c,1), j * stride(c,2) + lbound(c,2)) =
2821 c(i * stride(c,1) + lbound(c,1), j * stride(c,2) + lbound(c,2)) +
2822 a(i * stride(a,1) + lbound(a,1), k * stride(a,2) + lbound(a,2)) *
2823 b(k * stride(b,1) + lbound(b,1), j * stride(b,2) + lbound(b,2))
2824 end do
2825 end do
2826 end do
2827 END BLOCK
2828
2829 */
2830
2831 static int
inline_matmul_assign(gfc_code ** c,int * walk_subtrees,void * data ATTRIBUTE_UNUSED)2832 inline_matmul_assign (gfc_code **c, int *walk_subtrees,
2833 void *data ATTRIBUTE_UNUSED)
2834 {
2835 gfc_code *co = *c;
2836 gfc_expr *expr1, *expr2;
2837 gfc_expr *matrix_a, *matrix_b;
2838 gfc_actual_arglist *a, *b;
2839 gfc_code *do_1, *do_2, *do_3, *assign_zero, *assign_matmul;
2840 gfc_expr *zero_e;
2841 gfc_expr *u1, *u2, *u3;
2842 gfc_expr *list[2];
2843 gfc_expr *ascalar, *bscalar, *cscalar;
2844 gfc_expr *mult;
2845 gfc_expr *var_1, *var_2, *var_3;
2846 gfc_expr *zero;
2847 gfc_namespace *ns;
2848 gfc_intrinsic_op op_times, op_plus;
2849 enum matrix_case m_case;
2850 int i;
2851 gfc_code *if_limit = NULL;
2852 gfc_code **next_code_point;
2853 bool conjg_a, conjg_b, transpose_a, transpose_b;
2854
2855 if (co->op != EXEC_ASSIGN)
2856 return 0;
2857
2858 if (in_where)
2859 return 0;
2860
2861 /* The BLOCKS generated for the temporary variables and FORALL don't
2862 mix. */
2863 if (forall_level > 0)
2864 return 0;
2865
2866 /* For now don't do anything in OpenMP workshare, it confuses
2867 its translation, which expects only the allowed statements in there.
2868 We should figure out how to parallelize this eventually. */
2869 if (in_omp_workshare)
2870 return 0;
2871
2872 expr1 = co->expr1;
2873 expr2 = co->expr2;
2874 if (expr2->expr_type != EXPR_FUNCTION
2875 || expr2->value.function.isym == NULL
2876 || expr2->value.function.isym->id != GFC_ISYM_MATMUL)
2877 return 0;
2878
2879 current_code = c;
2880 inserted_block = NULL;
2881 changed_statement = NULL;
2882
2883 a = expr2->value.function.actual;
2884 matrix_a = check_conjg_transpose_variable (a->expr, &conjg_a, &transpose_a);
2885 if (transpose_a || matrix_a == NULL)
2886 return 0;
2887
2888 b = a->next;
2889 matrix_b = check_conjg_transpose_variable (b->expr, &conjg_b, &transpose_b);
2890 if (matrix_b == NULL)
2891 return 0;
2892
2893 if (has_dimen_vector_ref (expr1) || has_dimen_vector_ref (matrix_a)
2894 || has_dimen_vector_ref (matrix_b))
2895 return 0;
2896
2897 /* We do not handle data dependencies yet. */
2898 if (gfc_check_dependency (expr1, matrix_a, true)
2899 || gfc_check_dependency (expr1, matrix_b, true))
2900 return 0;
2901
2902 if (matrix_a->rank == 2)
2903 {
2904 if (matrix_b->rank == 1)
2905 m_case = A2B1;
2906 else
2907 {
2908 if (transpose_b)
2909 m_case = A2B2T;
2910 else
2911 m_case = A2B2;
2912 }
2913 }
2914 else
2915 {
2916 /* Vector * Transpose(B) not handled yet. */
2917 if (transpose_b)
2918 m_case = none;
2919 else
2920 m_case = A1B2;
2921 }
2922
2923 if (m_case == none)
2924 return 0;
2925
2926 ns = insert_block ();
2927
2928 /* Assign the type of the zero expression for initializing the resulting
2929 array, and the expression (+ and * for real, integer and complex;
2930 .and. and .or for logical. */
2931
2932 switch(expr1->ts.type)
2933 {
2934 case BT_INTEGER:
2935 zero_e = gfc_get_int_expr (expr1->ts.kind, &expr1->where, 0);
2936 op_times = INTRINSIC_TIMES;
2937 op_plus = INTRINSIC_PLUS;
2938 break;
2939
2940 case BT_LOGICAL:
2941 op_times = INTRINSIC_AND;
2942 op_plus = INTRINSIC_OR;
2943 zero_e = gfc_get_logical_expr (expr1->ts.kind, &expr1->where,
2944 0);
2945 break;
2946 case BT_REAL:
2947 zero_e = gfc_get_constant_expr (BT_REAL, expr1->ts.kind,
2948 &expr1->where);
2949 mpfr_set_si (zero_e->value.real, 0, GFC_RND_MODE);
2950 op_times = INTRINSIC_TIMES;
2951 op_plus = INTRINSIC_PLUS;
2952 break;
2953
2954 case BT_COMPLEX:
2955 zero_e = gfc_get_constant_expr (BT_COMPLEX, expr1->ts.kind,
2956 &expr1->where);
2957 mpc_set_si_si (zero_e->value.complex, 0, 0, GFC_RND_MODE);
2958 op_times = INTRINSIC_TIMES;
2959 op_plus = INTRINSIC_PLUS;
2960
2961 break;
2962
2963 default:
2964 gcc_unreachable();
2965 }
2966
2967 current_code = &ns->code;
2968
2969 /* Freeze the references, keeping track of how many temporary variables were
2970 created. */
2971 n_vars = 0;
2972 freeze_references (matrix_a);
2973 freeze_references (matrix_b);
2974 freeze_references (expr1);
2975
2976 if (n_vars == 0)
2977 next_code_point = current_code;
2978 else
2979 {
2980 next_code_point = &ns->code;
2981 for (i=0; i<n_vars; i++)
2982 next_code_point = &(*next_code_point)->next;
2983 }
2984
2985 /* Take care of the inline flag. If the limit check evaluates to a
2986 constant, dead code elimination will eliminate the unneeded branch. */
2987
2988 if (m_case == A2B2 && flag_inline_matmul_limit > 0)
2989 {
2990 if_limit = inline_limit_check (matrix_a, matrix_b, m_case);
2991
2992 /* Insert the original statement into the else branch. */
2993 if_limit->block->block->next = co;
2994 co->next = NULL;
2995
2996 /* ... and the new ones go into the original one. */
2997 *next_code_point = if_limit;
2998 next_code_point = &if_limit->block->next;
2999 }
3000
3001 assign_zero = XCNEW (gfc_code);
3002 assign_zero->op = EXEC_ASSIGN;
3003 assign_zero->loc = co->loc;
3004 assign_zero->expr1 = gfc_copy_expr (expr1);
3005 assign_zero->expr2 = zero_e;
3006
3007 /* Handle the reallocation, if needed. */
3008 if (flag_realloc_lhs && gfc_is_reallocatable_lhs (expr1))
3009 {
3010 gfc_code *lhs_alloc;
3011
3012 /* Only need to check a single dimension for the A2B2 case for
3013 bounds checking, the rest will be allocated. */
3014
3015 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS && m_case == A2B2)
3016 {
3017 gfc_code *test;
3018 gfc_expr *a2, *b1;
3019
3020 a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2);
3021 b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
3022 test = runtime_error_ne (b1, a2, "Dimension of array B incorrect "
3023 "in MATMUL intrinsic: Is %ld, should be %ld");
3024 *next_code_point = test;
3025 next_code_point = &test->next;
3026 }
3027
3028
3029 lhs_alloc = matmul_lhs_realloc (expr1, matrix_a, matrix_b, m_case);
3030
3031 *next_code_point = lhs_alloc;
3032 next_code_point = &lhs_alloc->next;
3033
3034 }
3035 else if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3036 {
3037 gfc_code *test;
3038 gfc_expr *a2, *b1, *c1, *c2, *a1, *b2;
3039
3040 if (m_case == A2B2 || m_case == A2B1)
3041 {
3042 a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2);
3043 b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
3044 test = runtime_error_ne (b1, a2, "Dimension of array B incorrect "
3045 "in MATMUL intrinsic: Is %ld, should be %ld");
3046 *next_code_point = test;
3047 next_code_point = &test->next;
3048
3049 c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1);
3050 a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1);
3051
3052 if (m_case == A2B2)
3053 test = runtime_error_ne (c1, a1, "Incorrect extent in return array in "
3054 "MATMUL intrinsic for dimension 1: "
3055 "is %ld, should be %ld");
3056 else if (m_case == A2B1)
3057 test = runtime_error_ne (c1, a1, "Incorrect extent in return array in "
3058 "MATMUL intrinsic: "
3059 "is %ld, should be %ld");
3060
3061
3062 *next_code_point = test;
3063 next_code_point = &test->next;
3064 }
3065 else if (m_case == A1B2)
3066 {
3067 a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1);
3068 b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
3069 test = runtime_error_ne (b1, a1, "Dimension of array B incorrect "
3070 "in MATMUL intrinsic: Is %ld, should be %ld");
3071 *next_code_point = test;
3072 next_code_point = &test->next;
3073
3074 c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1);
3075 b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2);
3076
3077 test = runtime_error_ne (c1, b2, "Incorrect extent in return array in "
3078 "MATMUL intrinsic: "
3079 "is %ld, should be %ld");
3080
3081 *next_code_point = test;
3082 next_code_point = &test->next;
3083 }
3084
3085 if (m_case == A2B2)
3086 {
3087 c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2);
3088 b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2);
3089 test = runtime_error_ne (c2, b2, "Incorrect extent in return array in "
3090 "MATMUL intrinsic for dimension 2: is %ld, should be %ld");
3091
3092 *next_code_point = test;
3093 next_code_point = &test->next;
3094 }
3095
3096 if (m_case == A2B2T)
3097 {
3098 c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1);
3099 a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1);
3100 test = runtime_error_ne (c1, a1, "Incorrect extent in return array in "
3101 "MATMUL intrinsic for dimension 1: "
3102 "is %ld, should be %ld");
3103
3104 *next_code_point = test;
3105 next_code_point = &test->next;
3106
3107 c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2);
3108 b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
3109 test = runtime_error_ne (c2, b1, "Incorrect extent in return array in "
3110 "MATMUL intrinsic for dimension 2: "
3111 "is %ld, should be %ld");
3112 *next_code_point = test;
3113 next_code_point = &test->next;
3114
3115 a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2);
3116 b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2);
3117
3118 test = runtime_error_ne (b2, a2, "Incorrect extent in argument B in "
3119 "MATMUL intrnisic for dimension 2: "
3120 "is %ld, should be %ld");
3121 *next_code_point = test;
3122 next_code_point = &test->next;
3123
3124 }
3125 }
3126
3127 *next_code_point = assign_zero;
3128
3129 zero = gfc_get_int_expr (gfc_index_integer_kind, &co->loc, 0);
3130
3131 assign_matmul = XCNEW (gfc_code);
3132 assign_matmul->op = EXEC_ASSIGN;
3133 assign_matmul->loc = co->loc;
3134
3135 /* Get the bounds for the loops, create them and create the scalarized
3136 expressions. */
3137
3138 switch (m_case)
3139 {
3140 case A2B2:
3141 inline_limit_check (matrix_a, matrix_b, m_case);
3142
3143 u1 = get_size_m1 (matrix_b, 2);
3144 u2 = get_size_m1 (matrix_a, 2);
3145 u3 = get_size_m1 (matrix_a, 1);
3146
3147 do_1 = create_do_loop (gfc_copy_expr (zero), u1, NULL, &co->loc, ns);
3148 do_2 = create_do_loop (gfc_copy_expr (zero), u2, NULL, &co->loc, ns);
3149 do_3 = create_do_loop (gfc_copy_expr (zero), u3, NULL, &co->loc, ns);
3150
3151 do_1->block->next = do_2;
3152 do_2->block->next = do_3;
3153 do_3->block->next = assign_matmul;
3154
3155 var_1 = do_1->ext.iterator->var;
3156 var_2 = do_2->ext.iterator->var;
3157 var_3 = do_3->ext.iterator->var;
3158
3159 list[0] = var_3;
3160 list[1] = var_1;
3161 cscalar = scalarized_expr (co->expr1, list, 2);
3162
3163 list[0] = var_3;
3164 list[1] = var_2;
3165 ascalar = scalarized_expr (matrix_a, list, 2);
3166
3167 list[0] = var_2;
3168 list[1] = var_1;
3169 bscalar = scalarized_expr (matrix_b, list, 2);
3170
3171 break;
3172
3173 case A2B2T:
3174 inline_limit_check (matrix_a, matrix_b, m_case);
3175
3176 u1 = get_size_m1 (matrix_b, 1);
3177 u2 = get_size_m1 (matrix_a, 2);
3178 u3 = get_size_m1 (matrix_a, 1);
3179
3180 do_1 = create_do_loop (gfc_copy_expr (zero), u1, NULL, &co->loc, ns);
3181 do_2 = create_do_loop (gfc_copy_expr (zero), u2, NULL, &co->loc, ns);
3182 do_3 = create_do_loop (gfc_copy_expr (zero), u3, NULL, &co->loc, ns);
3183
3184 do_1->block->next = do_2;
3185 do_2->block->next = do_3;
3186 do_3->block->next = assign_matmul;
3187
3188 var_1 = do_1->ext.iterator->var;
3189 var_2 = do_2->ext.iterator->var;
3190 var_3 = do_3->ext.iterator->var;
3191
3192 list[0] = var_3;
3193 list[1] = var_1;
3194 cscalar = scalarized_expr (co->expr1, list, 2);
3195
3196 list[0] = var_3;
3197 list[1] = var_2;
3198 ascalar = scalarized_expr (matrix_a, list, 2);
3199
3200 list[0] = var_1;
3201 list[1] = var_2;
3202 bscalar = scalarized_expr (matrix_b, list, 2);
3203
3204 break;
3205
3206 case A2B1:
3207 u1 = get_size_m1 (matrix_b, 1);
3208 u2 = get_size_m1 (matrix_a, 1);
3209
3210 do_1 = create_do_loop (gfc_copy_expr (zero), u1, NULL, &co->loc, ns);
3211 do_2 = create_do_loop (gfc_copy_expr (zero), u2, NULL, &co->loc, ns);
3212
3213 do_1->block->next = do_2;
3214 do_2->block->next = assign_matmul;
3215
3216 var_1 = do_1->ext.iterator->var;
3217 var_2 = do_2->ext.iterator->var;
3218
3219 list[0] = var_2;
3220 cscalar = scalarized_expr (co->expr1, list, 1);
3221
3222 list[0] = var_2;
3223 list[1] = var_1;
3224 ascalar = scalarized_expr (matrix_a, list, 2);
3225
3226 list[0] = var_1;
3227 bscalar = scalarized_expr (matrix_b, list, 1);
3228
3229 break;
3230
3231 case A1B2:
3232 u1 = get_size_m1 (matrix_b, 2);
3233 u2 = get_size_m1 (matrix_a, 1);
3234
3235 do_1 = create_do_loop (gfc_copy_expr (zero), u1, NULL, &co->loc, ns);
3236 do_2 = create_do_loop (gfc_copy_expr (zero), u2, NULL, &co->loc, ns);
3237
3238 do_1->block->next = do_2;
3239 do_2->block->next = assign_matmul;
3240
3241 var_1 = do_1->ext.iterator->var;
3242 var_2 = do_2->ext.iterator->var;
3243
3244 list[0] = var_1;
3245 cscalar = scalarized_expr (co->expr1, list, 1);
3246
3247 list[0] = var_2;
3248 ascalar = scalarized_expr (matrix_a, list, 1);
3249
3250 list[0] = var_2;
3251 list[1] = var_1;
3252 bscalar = scalarized_expr (matrix_b, list, 2);
3253
3254 break;
3255
3256 default:
3257 gcc_unreachable();
3258 }
3259
3260 if (conjg_a)
3261 ascalar = gfc_build_intrinsic_call (ns, GFC_ISYM_CONJG, "conjg",
3262 matrix_a->where, 1, ascalar);
3263
3264 if (conjg_b)
3265 bscalar = gfc_build_intrinsic_call (ns, GFC_ISYM_CONJG, "conjg",
3266 matrix_b->where, 1, bscalar);
3267
3268 /* First loop comes after the zero assignment. */
3269 assign_zero->next = do_1;
3270
3271 /* Build the assignment expression in the loop. */
3272 assign_matmul->expr1 = gfc_copy_expr (cscalar);
3273
3274 mult = get_operand (op_times, ascalar, bscalar);
3275 assign_matmul->expr2 = get_operand (op_plus, cscalar, mult);
3276
3277 /* If we don't want to keep the original statement around in
3278 the else branch, we can free it. */
3279
3280 if (if_limit == NULL)
3281 gfc_free_statements(co);
3282 else
3283 co->next = NULL;
3284
3285 gfc_free_expr (zero);
3286 *walk_subtrees = 0;
3287 return 0;
3288 }
3289
3290 #define WALK_SUBEXPR(NODE) \
3291 do \
3292 { \
3293 result = gfc_expr_walker (&(NODE), exprfn, data); \
3294 if (result) \
3295 return result; \
3296 } \
3297 while (0)
3298 #define WALK_SUBEXPR_TAIL(NODE) e = &(NODE); continue
3299
3300 /* Walk expression *E, calling EXPRFN on each expression in it. */
3301
3302 int
gfc_expr_walker(gfc_expr ** e,walk_expr_fn_t exprfn,void * data)3303 gfc_expr_walker (gfc_expr **e, walk_expr_fn_t exprfn, void *data)
3304 {
3305 while (*e)
3306 {
3307 int walk_subtrees = 1;
3308 gfc_actual_arglist *a;
3309 gfc_ref *r;
3310 gfc_constructor *c;
3311
3312 int result = exprfn (e, &walk_subtrees, data);
3313 if (result)
3314 return result;
3315 if (walk_subtrees)
3316 switch ((*e)->expr_type)
3317 {
3318 case EXPR_OP:
3319 WALK_SUBEXPR ((*e)->value.op.op1);
3320 WALK_SUBEXPR_TAIL ((*e)->value.op.op2);
3321 break;
3322 case EXPR_FUNCTION:
3323 for (a = (*e)->value.function.actual; a; a = a->next)
3324 WALK_SUBEXPR (a->expr);
3325 break;
3326 case EXPR_COMPCALL:
3327 case EXPR_PPC:
3328 WALK_SUBEXPR ((*e)->value.compcall.base_object);
3329 for (a = (*e)->value.compcall.actual; a; a = a->next)
3330 WALK_SUBEXPR (a->expr);
3331 break;
3332
3333 case EXPR_STRUCTURE:
3334 case EXPR_ARRAY:
3335 for (c = gfc_constructor_first ((*e)->value.constructor); c;
3336 c = gfc_constructor_next (c))
3337 {
3338 if (c->iterator == NULL)
3339 WALK_SUBEXPR (c->expr);
3340 else
3341 {
3342 iterator_level ++;
3343 WALK_SUBEXPR (c->expr);
3344 iterator_level --;
3345 WALK_SUBEXPR (c->iterator->var);
3346 WALK_SUBEXPR (c->iterator->start);
3347 WALK_SUBEXPR (c->iterator->end);
3348 WALK_SUBEXPR (c->iterator->step);
3349 }
3350 }
3351
3352 if ((*e)->expr_type != EXPR_ARRAY)
3353 break;
3354
3355 /* Fall through to the variable case in order to walk the
3356 reference. */
3357
3358 case EXPR_SUBSTRING:
3359 case EXPR_VARIABLE:
3360 for (r = (*e)->ref; r; r = r->next)
3361 {
3362 gfc_array_ref *ar;
3363 int i;
3364
3365 switch (r->type)
3366 {
3367 case REF_ARRAY:
3368 ar = &r->u.ar;
3369 if (ar->type == AR_SECTION || ar->type == AR_ELEMENT)
3370 {
3371 for (i=0; i< ar->dimen; i++)
3372 {
3373 WALK_SUBEXPR (ar->start[i]);
3374 WALK_SUBEXPR (ar->end[i]);
3375 WALK_SUBEXPR (ar->stride[i]);
3376 }
3377 }
3378
3379 break;
3380
3381 case REF_SUBSTRING:
3382 WALK_SUBEXPR (r->u.ss.start);
3383 WALK_SUBEXPR (r->u.ss.end);
3384 break;
3385
3386 case REF_COMPONENT:
3387 break;
3388 }
3389 }
3390
3391 default:
3392 break;
3393 }
3394 return 0;
3395 }
3396 return 0;
3397 }
3398
3399 #define WALK_SUBCODE(NODE) \
3400 do \
3401 { \
3402 result = gfc_code_walker (&(NODE), codefn, exprfn, data); \
3403 if (result) \
3404 return result; \
3405 } \
3406 while (0)
3407
3408 /* Walk code *C, calling CODEFN on each gfc_code node in it and calling EXPRFN
3409 on each expression in it. If any of the hooks returns non-zero, that
3410 value is immediately returned. If the hook sets *WALK_SUBTREES to 0,
3411 no subcodes or subexpressions are traversed. */
3412
3413 int
gfc_code_walker(gfc_code ** c,walk_code_fn_t codefn,walk_expr_fn_t exprfn,void * data)3414 gfc_code_walker (gfc_code **c, walk_code_fn_t codefn, walk_expr_fn_t exprfn,
3415 void *data)
3416 {
3417 for (; *c; c = &(*c)->next)
3418 {
3419 int walk_subtrees = 1;
3420 int result = codefn (c, &walk_subtrees, data);
3421 if (result)
3422 return result;
3423
3424 if (walk_subtrees)
3425 {
3426 gfc_code *b;
3427 gfc_actual_arglist *a;
3428 gfc_code *co;
3429 gfc_association_list *alist;
3430 bool saved_in_omp_workshare;
3431 bool saved_in_where;
3432
3433 /* There might be statement insertions before the current code,
3434 which must not affect the expression walker. */
3435
3436 co = *c;
3437 saved_in_omp_workshare = in_omp_workshare;
3438 saved_in_where = in_where;
3439
3440 switch (co->op)
3441 {
3442
3443 case EXEC_BLOCK:
3444 WALK_SUBCODE (co->ext.block.ns->code);
3445 if (co->ext.block.assoc)
3446 {
3447 bool saved_in_assoc_list = in_assoc_list;
3448
3449 in_assoc_list = true;
3450 for (alist = co->ext.block.assoc; alist; alist = alist->next)
3451 WALK_SUBEXPR (alist->target);
3452
3453 in_assoc_list = saved_in_assoc_list;
3454 }
3455
3456 break;
3457
3458 case EXEC_DO:
3459 doloop_level ++;
3460 WALK_SUBEXPR (co->ext.iterator->var);
3461 WALK_SUBEXPR (co->ext.iterator->start);
3462 WALK_SUBEXPR (co->ext.iterator->end);
3463 WALK_SUBEXPR (co->ext.iterator->step);
3464 break;
3465
3466 case EXEC_WHERE:
3467 in_where = true;
3468 break;
3469
3470 case EXEC_CALL:
3471 case EXEC_ASSIGN_CALL:
3472 for (a = co->ext.actual; a; a = a->next)
3473 WALK_SUBEXPR (a->expr);
3474 break;
3475
3476 case EXEC_CALL_PPC:
3477 WALK_SUBEXPR (co->expr1);
3478 for (a = co->ext.actual; a; a = a->next)
3479 WALK_SUBEXPR (a->expr);
3480 break;
3481
3482 case EXEC_SELECT:
3483 WALK_SUBEXPR (co->expr1);
3484 for (b = co->block; b; b = b->block)
3485 {
3486 gfc_case *cp;
3487 for (cp = b->ext.block.case_list; cp; cp = cp->next)
3488 {
3489 WALK_SUBEXPR (cp->low);
3490 WALK_SUBEXPR (cp->high);
3491 }
3492 WALK_SUBCODE (b->next);
3493 }
3494 continue;
3495
3496 case EXEC_ALLOCATE:
3497 case EXEC_DEALLOCATE:
3498 {
3499 gfc_alloc *a;
3500 for (a = co->ext.alloc.list; a; a = a->next)
3501 WALK_SUBEXPR (a->expr);
3502 break;
3503 }
3504
3505 case EXEC_FORALL:
3506 case EXEC_DO_CONCURRENT:
3507 {
3508 gfc_forall_iterator *fa;
3509 for (fa = co->ext.forall_iterator; fa; fa = fa->next)
3510 {
3511 WALK_SUBEXPR (fa->var);
3512 WALK_SUBEXPR (fa->start);
3513 WALK_SUBEXPR (fa->end);
3514 WALK_SUBEXPR (fa->stride);
3515 }
3516 if (co->op == EXEC_FORALL)
3517 forall_level ++;
3518 break;
3519 }
3520
3521 case EXEC_OPEN:
3522 WALK_SUBEXPR (co->ext.open->unit);
3523 WALK_SUBEXPR (co->ext.open->file);
3524 WALK_SUBEXPR (co->ext.open->status);
3525 WALK_SUBEXPR (co->ext.open->access);
3526 WALK_SUBEXPR (co->ext.open->form);
3527 WALK_SUBEXPR (co->ext.open->recl);
3528 WALK_SUBEXPR (co->ext.open->blank);
3529 WALK_SUBEXPR (co->ext.open->position);
3530 WALK_SUBEXPR (co->ext.open->action);
3531 WALK_SUBEXPR (co->ext.open->delim);
3532 WALK_SUBEXPR (co->ext.open->pad);
3533 WALK_SUBEXPR (co->ext.open->iostat);
3534 WALK_SUBEXPR (co->ext.open->iomsg);
3535 WALK_SUBEXPR (co->ext.open->convert);
3536 WALK_SUBEXPR (co->ext.open->decimal);
3537 WALK_SUBEXPR (co->ext.open->encoding);
3538 WALK_SUBEXPR (co->ext.open->round);
3539 WALK_SUBEXPR (co->ext.open->sign);
3540 WALK_SUBEXPR (co->ext.open->asynchronous);
3541 WALK_SUBEXPR (co->ext.open->id);
3542 WALK_SUBEXPR (co->ext.open->newunit);
3543 break;
3544
3545 case EXEC_CLOSE:
3546 WALK_SUBEXPR (co->ext.close->unit);
3547 WALK_SUBEXPR (co->ext.close->status);
3548 WALK_SUBEXPR (co->ext.close->iostat);
3549 WALK_SUBEXPR (co->ext.close->iomsg);
3550 break;
3551
3552 case EXEC_BACKSPACE:
3553 case EXEC_ENDFILE:
3554 case EXEC_REWIND:
3555 case EXEC_FLUSH:
3556 WALK_SUBEXPR (co->ext.filepos->unit);
3557 WALK_SUBEXPR (co->ext.filepos->iostat);
3558 WALK_SUBEXPR (co->ext.filepos->iomsg);
3559 break;
3560
3561 case EXEC_INQUIRE:
3562 WALK_SUBEXPR (co->ext.inquire->unit);
3563 WALK_SUBEXPR (co->ext.inquire->file);
3564 WALK_SUBEXPR (co->ext.inquire->iomsg);
3565 WALK_SUBEXPR (co->ext.inquire->iostat);
3566 WALK_SUBEXPR (co->ext.inquire->exist);
3567 WALK_SUBEXPR (co->ext.inquire->opened);
3568 WALK_SUBEXPR (co->ext.inquire->number);
3569 WALK_SUBEXPR (co->ext.inquire->named);
3570 WALK_SUBEXPR (co->ext.inquire->name);
3571 WALK_SUBEXPR (co->ext.inquire->access);
3572 WALK_SUBEXPR (co->ext.inquire->sequential);
3573 WALK_SUBEXPR (co->ext.inquire->direct);
3574 WALK_SUBEXPR (co->ext.inquire->form);
3575 WALK_SUBEXPR (co->ext.inquire->formatted);
3576 WALK_SUBEXPR (co->ext.inquire->unformatted);
3577 WALK_SUBEXPR (co->ext.inquire->recl);
3578 WALK_SUBEXPR (co->ext.inquire->nextrec);
3579 WALK_SUBEXPR (co->ext.inquire->blank);
3580 WALK_SUBEXPR (co->ext.inquire->position);
3581 WALK_SUBEXPR (co->ext.inquire->action);
3582 WALK_SUBEXPR (co->ext.inquire->read);
3583 WALK_SUBEXPR (co->ext.inquire->write);
3584 WALK_SUBEXPR (co->ext.inquire->readwrite);
3585 WALK_SUBEXPR (co->ext.inquire->delim);
3586 WALK_SUBEXPR (co->ext.inquire->encoding);
3587 WALK_SUBEXPR (co->ext.inquire->pad);
3588 WALK_SUBEXPR (co->ext.inquire->iolength);
3589 WALK_SUBEXPR (co->ext.inquire->convert);
3590 WALK_SUBEXPR (co->ext.inquire->strm_pos);
3591 WALK_SUBEXPR (co->ext.inquire->asynchronous);
3592 WALK_SUBEXPR (co->ext.inquire->decimal);
3593 WALK_SUBEXPR (co->ext.inquire->pending);
3594 WALK_SUBEXPR (co->ext.inquire->id);
3595 WALK_SUBEXPR (co->ext.inquire->sign);
3596 WALK_SUBEXPR (co->ext.inquire->size);
3597 WALK_SUBEXPR (co->ext.inquire->round);
3598 break;
3599
3600 case EXEC_WAIT:
3601 WALK_SUBEXPR (co->ext.wait->unit);
3602 WALK_SUBEXPR (co->ext.wait->iostat);
3603 WALK_SUBEXPR (co->ext.wait->iomsg);
3604 WALK_SUBEXPR (co->ext.wait->id);
3605 break;
3606
3607 case EXEC_READ:
3608 case EXEC_WRITE:
3609 WALK_SUBEXPR (co->ext.dt->io_unit);
3610 WALK_SUBEXPR (co->ext.dt->format_expr);
3611 WALK_SUBEXPR (co->ext.dt->rec);
3612 WALK_SUBEXPR (co->ext.dt->advance);
3613 WALK_SUBEXPR (co->ext.dt->iostat);
3614 WALK_SUBEXPR (co->ext.dt->size);
3615 WALK_SUBEXPR (co->ext.dt->iomsg);
3616 WALK_SUBEXPR (co->ext.dt->id);
3617 WALK_SUBEXPR (co->ext.dt->pos);
3618 WALK_SUBEXPR (co->ext.dt->asynchronous);
3619 WALK_SUBEXPR (co->ext.dt->blank);
3620 WALK_SUBEXPR (co->ext.dt->decimal);
3621 WALK_SUBEXPR (co->ext.dt->delim);
3622 WALK_SUBEXPR (co->ext.dt->pad);
3623 WALK_SUBEXPR (co->ext.dt->round);
3624 WALK_SUBEXPR (co->ext.dt->sign);
3625 WALK_SUBEXPR (co->ext.dt->extra_comma);
3626 break;
3627
3628 case EXEC_OMP_PARALLEL:
3629 case EXEC_OMP_PARALLEL_DO:
3630 case EXEC_OMP_PARALLEL_DO_SIMD:
3631 case EXEC_OMP_PARALLEL_SECTIONS:
3632
3633 in_omp_workshare = false;
3634
3635 /* This goto serves as a shortcut to avoid code
3636 duplication or a larger if or switch statement. */
3637 goto check_omp_clauses;
3638
3639 case EXEC_OMP_WORKSHARE:
3640 case EXEC_OMP_PARALLEL_WORKSHARE:
3641
3642 in_omp_workshare = true;
3643
3644 /* Fall through */
3645
3646 case EXEC_OMP_DISTRIBUTE:
3647 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
3648 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
3649 case EXEC_OMP_DISTRIBUTE_SIMD:
3650 case EXEC_OMP_DO:
3651 case EXEC_OMP_DO_SIMD:
3652 case EXEC_OMP_SECTIONS:
3653 case EXEC_OMP_SINGLE:
3654 case EXEC_OMP_END_SINGLE:
3655 case EXEC_OMP_SIMD:
3656 case EXEC_OMP_TARGET:
3657 case EXEC_OMP_TARGET_DATA:
3658 case EXEC_OMP_TARGET_TEAMS:
3659 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
3660 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
3661 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
3662 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
3663 case EXEC_OMP_TARGET_UPDATE:
3664 case EXEC_OMP_TASK:
3665 case EXEC_OMP_TEAMS:
3666 case EXEC_OMP_TEAMS_DISTRIBUTE:
3667 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
3668 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
3669 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
3670
3671 /* Come to this label only from the
3672 EXEC_OMP_PARALLEL_* cases above. */
3673
3674 check_omp_clauses:
3675
3676 if (co->ext.omp_clauses)
3677 {
3678 gfc_omp_namelist *n;
3679 static int list_types[]
3680 = { OMP_LIST_ALIGNED, OMP_LIST_LINEAR, OMP_LIST_DEPEND,
3681 OMP_LIST_MAP, OMP_LIST_TO, OMP_LIST_FROM };
3682 size_t idx;
3683 WALK_SUBEXPR (co->ext.omp_clauses->if_expr);
3684 WALK_SUBEXPR (co->ext.omp_clauses->final_expr);
3685 WALK_SUBEXPR (co->ext.omp_clauses->num_threads);
3686 WALK_SUBEXPR (co->ext.omp_clauses->chunk_size);
3687 WALK_SUBEXPR (co->ext.omp_clauses->safelen_expr);
3688 WALK_SUBEXPR (co->ext.omp_clauses->simdlen_expr);
3689 WALK_SUBEXPR (co->ext.omp_clauses->num_teams);
3690 WALK_SUBEXPR (co->ext.omp_clauses->device);
3691 WALK_SUBEXPR (co->ext.omp_clauses->thread_limit);
3692 WALK_SUBEXPR (co->ext.omp_clauses->dist_chunk_size);
3693 for (idx = 0;
3694 idx < sizeof (list_types) / sizeof (list_types[0]);
3695 idx++)
3696 for (n = co->ext.omp_clauses->lists[list_types[idx]];
3697 n; n = n->next)
3698 WALK_SUBEXPR (n->expr);
3699 }
3700 break;
3701 default:
3702 break;
3703 }
3704
3705 WALK_SUBEXPR (co->expr1);
3706 WALK_SUBEXPR (co->expr2);
3707 WALK_SUBEXPR (co->expr3);
3708 WALK_SUBEXPR (co->expr4);
3709 for (b = co->block; b; b = b->block)
3710 {
3711 WALK_SUBEXPR (b->expr1);
3712 WALK_SUBEXPR (b->expr2);
3713 WALK_SUBCODE (b->next);
3714 }
3715
3716 if (co->op == EXEC_FORALL)
3717 forall_level --;
3718
3719 if (co->op == EXEC_DO)
3720 doloop_level --;
3721
3722 in_omp_workshare = saved_in_omp_workshare;
3723 in_where = saved_in_where;
3724 }
3725 }
3726 return 0;
3727 }
3728