?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Fix oversight in handling of reverse SSO in SRA pass
[official-gcc.git] / gcc / fortran / frontend-passes.c
blob996dcc2e5474b69b4e37102dfa46005121410fc2
1 /* Pass manager for Fortran front end.
2 Copyright (C) 2010-2021 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 int do_intent (gfc_expr **);
43 static int do_subscript (gfc_expr **);
44 static void optimize_reduction (gfc_namespace *);
45 static int callback_reduction (gfc_expr **, int *, void *);
46 static void realloc_strings (gfc_namespace *);
47 static gfc_expr *create_var (gfc_expr *, const char *vname=NULL);
48 static int matmul_to_var_expr (gfc_expr **, int *, void *);
49 static int matmul_to_var_code (gfc_code **, int *, void *);
50 static int inline_matmul_assign (gfc_code **, int *, void *);
51 static gfc_code * create_do_loop (gfc_expr *, gfc_expr *, gfc_expr *,
52 locus *, gfc_namespace *,
53 char *vname=NULL);
54 static gfc_expr* check_conjg_transpose_variable (gfc_expr *, bool *,
55 bool *);
56 static int call_external_blas (gfc_code **, int *, void *);
57 static int matmul_temp_args (gfc_code **, int *,void *data);
58 static int index_interchange (gfc_code **, int*, void *);
59 static bool is_fe_temp (gfc_expr *e);
60
61 #ifdef CHECKING_P
62 static void check_locus (gfc_namespace *);
63 #endif
64
65 /* How deep we are inside an argument list. */
66
67 static int count_arglist;
68
69 /* Vector of gfc_expr ** we operate on. */
70
71 static vec<gfc_expr **> expr_array;
72
73 /* Pointer to the gfc_code we currently work on - to be able to insert
74 a block before the statement. */
75
76 static gfc_code **current_code;
77
78 /* Pointer to the block to be inserted, and the statement we are
79 changing within the block. */
80
81 static gfc_code *inserted_block, **changed_statement;
82
83 /* The namespace we are currently dealing with. */
84
85 static gfc_namespace *current_ns;
86
87 /* If we are within any forall loop. */
88
89 static int forall_level;
90
91 /* Keep track of whether we are within an OMP workshare. */
92
93 static bool in_omp_workshare;
94
95 /* Keep track of whether we are within an OMP atomic. */
96
97 static bool in_omp_atomic;
98
99 /* Keep track of whether we are within a WHERE statement. */
100
101 static bool in_where;
102
103 /* Keep track of iterators for array constructors. */
104
105 static int iterator_level;
106
107 /* Keep track of DO loop levels. */
108
109 typedef struct {
110 gfc_code *c;
111 int branch_level;
112 bool seen_goto;
113 } do_t;
114
115 static vec<do_t> doloop_list;
116 static int doloop_level;
117
118 /* Keep track of if and select case levels. */
119
120 static int if_level;
121 static int select_level;
122
123 /* Vector of gfc_expr * to keep track of DO loops. */
124
125 struct my_struct *evec;
126
127 /* Keep track of association lists. */
128
129 static bool in_assoc_list;
130
131 /* Counter for temporary variables. */
132
133 static int var_num = 1;
134
135 /* What sort of matrix we are dealing with when inlining MATMUL. */
136
137 enum matrix_case { none=0, A2B2, A2B1, A1B2, A2B2T, A2TB2, A2TB2T };
138
139 /* Keep track of the number of expressions we have inserted so far
140 using create_var. */
141
142 int n_vars;
143
144 /* Entry point - run all passes for a namespace. */
145
146 void
147 gfc_run_passes (gfc_namespace *ns)
148 {
149
150 /* Warn about dubious DO loops where the index might
151 change. */
152
153 doloop_level = 0;
154 if_level = 0;
155 select_level = 0;
156 doloop_warn (ns);
157 doloop_list.release ();
158 int w, e;
159
160 #ifdef CHECKING_P
161 check_locus (ns);
162 #endif
163
164 gfc_get_errors (&w, &e);
165 if (e > 0)
166 return;
167
168 if (flag_frontend_optimize || flag_frontend_loop_interchange)
169 optimize_namespace (ns);
170
171 if (flag_frontend_optimize)
172 {
173 optimize_reduction (ns);
174 if (flag_dump_fortran_optimized)
175 gfc_dump_parse_tree (ns, stdout);
176
177 expr_array.release ();
178 }
179
180 if (flag_realloc_lhs)
181 realloc_strings (ns);
182 }
183
184 #ifdef CHECKING_P
185
186 /* Callback function: Warn if there is no location information in a
187 statement. */
188
189 static int
190 check_locus_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
191 void *data ATTRIBUTE_UNUSED)
192 {
193 current_code = c;
194 if (c && *c && (((*c)->loc.nextc == NULL) || ((*c)->loc.lb == NULL)))
195 gfc_warning_internal (0, "Inconsistent internal state: "
196 "No location in statement");
197
198 return 0;
199 }
200
201
202 /* Callback function: Warn if there is no location information in an
203 expression. */
204
205 static int
206 check_locus_expr (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
207 void *data ATTRIBUTE_UNUSED)
208 {
209
210 if (e && *e && (((*e)->where.nextc == NULL || (*e)->where.lb == NULL)))
211 gfc_warning_internal (0, "Inconsistent internal state: "
212 "No location in expression near %L",
213 &((*current_code)->loc));
214 return 0;
215 }
216
217 /* Run check for missing location information. */
218
219 static void
220 check_locus (gfc_namespace *ns)
221 {
222 gfc_code_walker (&ns->code, check_locus_code, check_locus_expr, NULL);
223
224 for (ns = ns->contained; ns; ns = ns->sibling)
225 {
226 if (ns->code == NULL || ns->code->op != EXEC_BLOCK)
227 check_locus (ns);
228 }
229 }
230
231 #endif
232
233 /* Callback for each gfc_code node invoked from check_realloc_strings.
234 For an allocatable LHS string which also appears as a variable on
235 the RHS, replace
236
237 a = a(x:y)
238
239 with
240
241 tmp = a(x:y)
242 a = tmp
243 */
244
245 static int
246 realloc_string_callback (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
247 void *data ATTRIBUTE_UNUSED)
248 {
249 gfc_expr *expr1, *expr2;
250 gfc_code *co = *c;
251 gfc_expr *n;
252 gfc_ref *ref;
253 bool found_substr;
254
255 if (co->op != EXEC_ASSIGN)
256 return 0;
257
258 expr1 = co->expr1;
259 if (expr1->ts.type != BT_CHARACTER
260 || !gfc_expr_attr(expr1).allocatable
261 || !expr1->ts.deferred)
262 return 0;
263
264 if (is_fe_temp (expr1))
265 return 0;
266
267 expr2 = gfc_discard_nops (co->expr2);
268
269 if (expr2->expr_type == EXPR_VARIABLE)
270 {
271 found_substr = false;
272 for (ref = expr2->ref; ref; ref = ref->next)
273 {
274 if (ref->type == REF_SUBSTRING)
275 {
276 found_substr = true;
277 break;
278 }
279 }
280 if (!found_substr)
281 return 0;
282 }
283 else if (expr2->expr_type != EXPR_ARRAY
284 && (expr2->expr_type != EXPR_OP
285 || expr2->value.op.op != INTRINSIC_CONCAT))
286 return 0;
287
288 if (!gfc_check_dependency (expr1, expr2, true))
289 return 0;
290
291 /* gfc_check_dependency doesn't always pick up identical expressions.
292 However, eliminating the above sends the compiler into an infinite
293 loop on valid expressions. Without this check, the gimplifier emits
294 an ICE for a = a, where a is deferred character length. */
295 if (!gfc_dep_compare_expr (expr1, expr2))
296 return 0;
297
298 current_code = c;
299 inserted_block = NULL;
300 changed_statement = NULL;
301 n = create_var (expr2, "realloc_string");
302 co->expr2 = n;
303 return 0;
304 }
305
306 /* Callback for each gfc_code node invoked through gfc_code_walker
307 from optimize_namespace. */
308
309 static int
310 optimize_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
311 void *data ATTRIBUTE_UNUSED)
312 {
313
314 gfc_exec_op op;
315
316 op = (*c)->op;
317
318 if (op == EXEC_CALL || op == EXEC_COMPCALL || op == EXEC_ASSIGN_CALL
319 || op == EXEC_CALL_PPC)
320 count_arglist = 1;
321 else
322 count_arglist = 0;
323
324 current_code = c;
325 inserted_block = NULL;
326 changed_statement = NULL;
327
328 if (op == EXEC_ASSIGN)
329 optimize_assignment (*c);
330 return 0;
331 }
332
333 /* Callback for each gfc_expr node invoked through gfc_code_walker
334 from optimize_namespace. */
335
336 static int
337 optimize_expr (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
338 void *data ATTRIBUTE_UNUSED)
339 {
340 bool function_expr;
341
342 if ((*e)->expr_type == EXPR_FUNCTION)
343 {
344 count_arglist ++;
345 function_expr = true;
346 }
347 else
348 function_expr = false;
349
350 if (optimize_trim (*e))
351 gfc_simplify_expr (*e, 0);
352
353 if (optimize_lexical_comparison (*e))
354 gfc_simplify_expr (*e, 0);
355
356 if ((*e)->expr_type == EXPR_OP && optimize_op (*e))
357 gfc_simplify_expr (*e, 0);
358
359 if ((*e)->expr_type == EXPR_FUNCTION && (*e)->value.function.isym)
360 switch ((*e)->value.function.isym->id)
361 {
362 case GFC_ISYM_MINLOC:
363 case GFC_ISYM_MAXLOC:
364 optimize_minmaxloc (e);
365 break;
366 default:
367 break;
368 }
369
370 if (function_expr)
371 count_arglist --;
372
373 return 0;
374 }
375
376 /* Auxiliary function to handle the arguments to reduction intrinsics. If the
377 function is a scalar, just copy it; otherwise returns the new element, the
378 old one can be freed. */
379
380 static gfc_expr *
381 copy_walk_reduction_arg (gfc_constructor *c, gfc_expr *fn)
382 {
383 gfc_expr *fcn, *e = c->expr;
384
385 fcn = gfc_copy_expr (e);
386 if (c->iterator)
387 {
388 gfc_constructor_base newbase;
389 gfc_expr *new_expr;
390 gfc_constructor *new_c;
391
392 newbase = NULL;
393 new_expr = gfc_get_expr ();
394 new_expr->expr_type = EXPR_ARRAY;
395 new_expr->ts = e->ts;
396 new_expr->where = e->where;
397 new_expr->rank = 1;
398 new_c = gfc_constructor_append_expr (&newbase, fcn, &(e->where));
399 new_c->iterator = c->iterator;
400 new_expr->value.constructor = newbase;
401 c->iterator = NULL;
402
403 fcn = new_expr;
404 }
405
406 if (fcn->rank != 0)
407 {
408 gfc_isym_id id = fn->value.function.isym->id;
409
410 if (id == GFC_ISYM_SUM || id == GFC_ISYM_PRODUCT)
411 fcn = gfc_build_intrinsic_call (current_ns, id,
412 fn->value.function.isym->name,
413 fn->where, 3, fcn, NULL, NULL);
414 else if (id == GFC_ISYM_ANY || id == GFC_ISYM_ALL)
415 fcn = gfc_build_intrinsic_call (current_ns, id,
416 fn->value.function.isym->name,
417 fn->where, 2, fcn, NULL);
418 else
419 gfc_internal_error ("Illegal id in copy_walk_reduction_arg");
420
421 fcn->symtree->n.sym->attr.access = ACCESS_PRIVATE;
422 }
423
424 return fcn;
425 }
426
427 /* Callback function for optimzation of reductions to scalars. Transform ANY
428 ([f1,f2,f3, ...]) to f1 .or. f2 .or. f3 .or. ..., with ANY, SUM and PRODUCT
429 correspondingly. Handly only the simple cases without MASK and DIM. */
430
431 static int
432 callback_reduction (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
433 void *data ATTRIBUTE_UNUSED)
434 {
435 gfc_expr *fn, *arg;
436 gfc_intrinsic_op op;
437 gfc_isym_id id;
438 gfc_actual_arglist *a;
439 gfc_actual_arglist *dim;
440 gfc_constructor *c;
441 gfc_expr *res, *new_expr;
442 gfc_actual_arglist *mask;
443
444 fn = *e;
445
446 if (fn->rank != 0 || fn->expr_type != EXPR_FUNCTION
447 || fn->value.function.isym == NULL)
448 return 0;
449
450 id = fn->value.function.isym->id;
451
452 if (id != GFC_ISYM_SUM && id != GFC_ISYM_PRODUCT
453 && id != GFC_ISYM_ANY && id != GFC_ISYM_ALL)
454 return 0;
455
456 a = fn->value.function.actual;
457
458 /* Don't handle MASK or DIM. */
459
460 dim = a->next;
461
462 if (dim->expr != NULL)
463 return 0;
464
465 if (id == GFC_ISYM_SUM || id == GFC_ISYM_PRODUCT)
466 {
467 mask = dim->next;
468 if ( mask->expr != NULL)
469 return 0;
470 }
471
472 arg = a->expr;
473
474 if (arg->expr_type != EXPR_ARRAY)
475 return 0;
476
477 switch (id)
478 {
479 case GFC_ISYM_SUM:
480 op = INTRINSIC_PLUS;
481 break;
482
483 case GFC_ISYM_PRODUCT:
484 op = INTRINSIC_TIMES;
485 break;
486
487 case GFC_ISYM_ANY:
488 op = INTRINSIC_OR;
489 break;
490
491 case GFC_ISYM_ALL:
492 op = INTRINSIC_AND;
493 break;
494
495 default:
496 return 0;
497 }
498
499 c = gfc_constructor_first (arg->value.constructor);
500
501 /* Don't do any simplififcation if we have
502 - no element in the constructor or
503 - only have a single element in the array which contains an
504 iterator. */
505
506 if (c == NULL)
507 return 0;
508
509 res = copy_walk_reduction_arg (c, fn);
510
511 c = gfc_constructor_next (c);
512 while (c)
513 {
514 new_expr = gfc_get_expr ();
515 new_expr->ts = fn->ts;
516 new_expr->expr_type = EXPR_OP;
517 new_expr->rank = fn->rank;
518 new_expr->where = fn->where;
519 new_expr->value.op.op = op;
520 new_expr->value.op.op1 = res;
521 new_expr->value.op.op2 = copy_walk_reduction_arg (c, fn);
522 res = new_expr;
523 c = gfc_constructor_next (c);
524 }
525
526 gfc_simplify_expr (res, 0);
527 *e = res;
528 gfc_free_expr (fn);
529
530 return 0;
531 }
532
533 /* Callback function for common function elimination, called from cfe_expr_0.
534 Put all eligible function expressions into expr_array. */
535
536 static int
537 cfe_register_funcs (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
538 void *data ATTRIBUTE_UNUSED)
539 {
540
541 if ((*e)->expr_type != EXPR_FUNCTION)
542 return 0;
543
544 /* We don't do character functions with unknown charlens. */
545 if ((*e)->ts.type == BT_CHARACTER
546 && ((*e)->ts.u.cl == NULL || (*e)->ts.u.cl->length == NULL
547 || (*e)->ts.u.cl->length->expr_type != EXPR_CONSTANT))
548 return 0;
549
550 /* We don't do function elimination within FORALL statements, it can
551 lead to wrong-code in certain circumstances. */
552
553 if (forall_level > 0)
554 return 0;
555
556 /* Function elimination inside an iterator could lead to functions which
557 depend on iterator variables being moved outside. FIXME: We should check
558 if the functions do indeed depend on the iterator variable. */
559
560 if (iterator_level > 0)
561 return 0;
562
563 /* If we don't know the shape at compile time, we create an allocatable
564 temporary variable to hold the intermediate result, but only if
565 allocation on assignment is active. */
566
567 if ((*e)->rank > 0 && (*e)->shape == NULL && !flag_realloc_lhs)
568 return 0;
569
570 /* Skip the test for pure functions if -faggressive-function-elimination
571 is specified. */
572 if ((*e)->value.function.esym)
573 {
574 /* Don't create an array temporary for elemental functions. */
575 if ((*e)->value.function.esym->attr.elemental && (*e)->rank > 0)
576 return 0;
577
578 /* Only eliminate potentially impure functions if the
579 user specifically requested it. */
580 if (!flag_aggressive_function_elimination
581 && !(*e)->value.function.esym->attr.pure
582 && !(*e)->value.function.esym->attr.implicit_pure)
583 return 0;
584 }
585
586 if ((*e)->value.function.isym)
587 {
588 /* Conversions are handled on the fly by the middle end,
589 transpose during trans-* stages and TRANSFER by the middle end. */
590 if ((*e)->value.function.isym->id == GFC_ISYM_CONVERSION
591 || (*e)->value.function.isym->id == GFC_ISYM_TRANSFER
592 || gfc_inline_intrinsic_function_p (*e))
593 return 0;
594
595 /* Don't create an array temporary for elemental functions,
596 as this would be wasteful of memory.
597 FIXME: Create a scalar temporary during scalarization. */
598 if ((*e)->value.function.isym->elemental && (*e)->rank > 0)
599 return 0;
600
601 if (!(*e)->value.function.isym->pure)
602 return 0;
603 }
604
605 expr_array.safe_push (e);
606 return 0;
607 }
608
609 /* Auxiliary function to check if an expression is a temporary created by
610 create var. */
611
612 static bool
613 is_fe_temp (gfc_expr *e)
614 {
615 if (e->expr_type != EXPR_VARIABLE)
616 return false;
617
618 return e->symtree->n.sym->attr.fe_temp;
619 }
620
621 /* Determine the length of a string, if it can be evaluated as a constant
622 expression. Return a newly allocated gfc_expr or NULL on failure.
623 If the user specified a substring which is potentially longer than
624 the string itself, the string will be padded with spaces, which
625 is harmless. */
626
627 static gfc_expr *
628 constant_string_length (gfc_expr *e)
629 {
630
631 gfc_expr *length;
632 gfc_ref *ref;
633 gfc_expr *res;
634 mpz_t value;
635
636 if (e->ts.u.cl)
637 {
638 length = e->ts.u.cl->length;
639 if (length && length->expr_type == EXPR_CONSTANT)
640 return gfc_copy_expr(length);
641 }
642
643 /* See if there is a substring. If it has a constant length, return
644 that and NULL otherwise. */
645 for (ref = e->ref; ref; ref = ref->next)
646 {
647 if (ref->type == REF_SUBSTRING)
648 {
649 if (gfc_dep_difference (ref->u.ss.end, ref->u.ss.start, &value))
650 {
651 res = gfc_get_constant_expr (BT_INTEGER, gfc_charlen_int_kind,
652 &e->where);
653
654 mpz_add_ui (res->value.integer, value, 1);
655 mpz_clear (value);
656 return res;
657 }
658 else
659 return NULL;
660 }
661 }
662
663 /* Return length of char symbol, if constant. */
664 if (e->symtree && e->symtree->n.sym->ts.u.cl
665 && e->symtree->n.sym->ts.u.cl->length
666 && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
667 return gfc_copy_expr (e->symtree->n.sym->ts.u.cl->length);
668
669 return NULL;
670
671 }
672
673 /* Insert a block at the current position unless it has already
674 been inserted; in this case use the one already there. */
675
676 static gfc_namespace*
677 insert_block ()
678 {
679 gfc_namespace *ns;
680
681 /* If the block hasn't already been created, do so. */
682 if (inserted_block == NULL)
683 {
684 inserted_block = XCNEW (gfc_code);
685 inserted_block->op = EXEC_BLOCK;
686 inserted_block->loc = (*current_code)->loc;
687 ns = gfc_build_block_ns (current_ns);
688 inserted_block->ext.block.ns = ns;
689 inserted_block->ext.block.assoc = NULL;
690
691 ns->code = *current_code;
692
693 /* If the statement has a label, make sure it is transferred to
694 the newly created block. */
695
696 if ((*current_code)->here)
697 {
698 inserted_block->here = (*current_code)->here;
699 (*current_code)->here = NULL;
700 }
701
702 inserted_block->next = (*current_code)->next;
703 changed_statement = &(inserted_block->ext.block.ns->code);
704 (*current_code)->next = NULL;
705 /* Insert the BLOCK at the right position. */
706 *current_code = inserted_block;
707 ns->parent = current_ns;
708 }
709 else
710 ns = inserted_block->ext.block.ns;
711
712 return ns;
713 }
714
715
716 /* Insert a call to the intrinsic len. Use a different name for
717 the symbol tree so we don't run into trouble when the user has
718 renamed len for some reason. */
719
720 static gfc_expr*
721 get_len_call (gfc_expr *str)
722 {
723 gfc_expr *fcn;
724 gfc_actual_arglist *actual_arglist;
725
726 fcn = gfc_get_expr ();
727 fcn->expr_type = EXPR_FUNCTION;
728 fcn->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_LEN);
729 actual_arglist = gfc_get_actual_arglist ();
730 actual_arglist->expr = str;
731
732 fcn->value.function.actual = actual_arglist;
733 fcn->where = str->where;
734 fcn->ts.type = BT_INTEGER;
735 fcn->ts.kind = gfc_charlen_int_kind;
736
737 gfc_get_sym_tree ("__internal_len", current_ns, &fcn->symtree, false);
738 fcn->symtree->n.sym->ts = fcn->ts;
739 fcn->symtree->n.sym->attr.flavor = FL_PROCEDURE;
740 fcn->symtree->n.sym->attr.function = 1;
741 fcn->symtree->n.sym->attr.elemental = 1;
742 fcn->symtree->n.sym->attr.referenced = 1;
743 fcn->symtree->n.sym->attr.access = ACCESS_PRIVATE;
744 gfc_commit_symbol (fcn->symtree->n.sym);
745
746 return fcn;
747 }
748
749
750 /* Returns a new expression (a variable) to be used in place of the old one,
751 with an optional assignment statement before the current statement to set
752 the value of the variable. Creates a new BLOCK for the statement if that
753 hasn't already been done and puts the statement, plus the newly created
754 variables, in that block. Special cases: If the expression is constant or
755 a temporary which has already been created, just copy it. */
756
757 static gfc_expr*
758 create_var (gfc_expr * e, const char *vname)
759 {
760 char name[GFC_MAX_SYMBOL_LEN +1];
761 gfc_symtree *symtree;
762 gfc_symbol *symbol;
763 gfc_expr *result;
764 gfc_code *n;
765 gfc_namespace *ns;
766 int i;
767 bool deferred;
768
769 if (e->expr_type == EXPR_CONSTANT || is_fe_temp (e))
770 return gfc_copy_expr (e);
771
772 /* Creation of an array of unknown size requires realloc on assignment.
773 If that is not possible, just return NULL. */
774 if (flag_realloc_lhs == 0 && e->rank > 0 && e->shape == NULL)
775 return NULL;
776
777 ns = insert_block ();
778
779 if (vname)
780 snprintf (name, GFC_MAX_SYMBOL_LEN, "__var_%d_%s", var_num++, vname);
781 else
782 snprintf (name, GFC_MAX_SYMBOL_LEN, "__var_%d", var_num++);
783
784 if (gfc_get_sym_tree (name, ns, &symtree, false) != 0)
785 gcc_unreachable ();
786
787 symbol = symtree->n.sym;
788 symbol->ts = e->ts;
789
790 if (e->rank > 0)
791 {
792 symbol->as = gfc_get_array_spec ();
793 symbol->as->rank = e->rank;
794
795 if (e->shape == NULL)
796 {
797 /* We don't know the shape at compile time, so we use an
798 allocatable. */
799 symbol->as->type = AS_DEFERRED;
800 symbol->attr.allocatable = 1;
801 }
802 else
803 {
804 symbol->as->type = AS_EXPLICIT;
805 /* Copy the shape. */
806 for (i=0; i<e->rank; i++)
807 {
808 gfc_expr *p, *q;
809
810 p = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
811 &(e->where));
812 mpz_set_si (p->value.integer, 1);
813 symbol->as->lower[i] = p;
814
815 q = gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
816 &(e->where));
817 mpz_set (q->value.integer, e->shape[i]);
818 symbol->as->upper[i] = q;
819 }
820 }
821 }
822
823 deferred = 0;
824 if (e->ts.type == BT_CHARACTER)
825 {
826 gfc_expr *length;
827
828 symbol->ts.u.cl = gfc_new_charlen (ns, NULL);
829 length = constant_string_length (e);
830 if (length)
831 symbol->ts.u.cl->length = length;
832 else if (e->expr_type == EXPR_VARIABLE
833 && e->symtree->n.sym->ts.type == BT_CHARACTER
834 && e->ts.u.cl->length)
835 symbol->ts.u.cl->length = get_len_call (gfc_copy_expr (e));
836 else
837 {
838 symbol->attr.allocatable = 1;
839 symbol->ts.u.cl->length = NULL;
840 symbol->ts.deferred = 1;
841 deferred = 1;
842 }
843 }
844
845 symbol->attr.flavor = FL_VARIABLE;
846 symbol->attr.referenced = 1;
847 symbol->attr.dimension = e->rank > 0;
848 symbol->attr.fe_temp = 1;
849 gfc_commit_symbol (symbol);
850
851 result = gfc_get_expr ();
852 result->expr_type = EXPR_VARIABLE;
853 result->ts = symbol->ts;
854 result->ts.deferred = deferred;
855 result->rank = e->rank;
856 result->shape = gfc_copy_shape (e->shape, e->rank);
857 result->symtree = symtree;
858 result->where = e->where;
859 if (e->rank > 0)
860 {
861 result->ref = gfc_get_ref ();
862 result->ref->type = REF_ARRAY;
863 result->ref->u.ar.type = AR_FULL;
864 result->ref->u.ar.where = e->where;
865 result->ref->u.ar.dimen = e->rank;
866 result->ref->u.ar.as = symbol->ts.type == BT_CLASS
867 ? CLASS_DATA (symbol)->as : symbol->as;
868 if (warn_array_temporaries)
869 gfc_warning (OPT_Warray_temporaries,
870 "Creating array temporary at %L", &(e->where));
871 }
872
873 /* Generate the new assignment. */
874 n = XCNEW (gfc_code);
875 n->op = EXEC_ASSIGN;
876 n->loc = (*current_code)->loc;
877 n->next = *changed_statement;
878 n->expr1 = gfc_copy_expr (result);
879 n->expr2 = e;
880 *changed_statement = n;
881 n_vars ++;
882
883 return result;
884 }
885
886 /* Warn about function elimination. */
887
888 static void
889 do_warn_function_elimination (gfc_expr *e)
890 {
891 const char *name;
892 if (e->expr_type == EXPR_FUNCTION
893 && !gfc_pure_function (e, &name) && !gfc_implicit_pure_function (e))
894 {
895 if (name)
896 gfc_warning (OPT_Wfunction_elimination,
897 "Removing call to impure function %qs at %L", name,
898 &(e->where));
899 else
900 gfc_warning (OPT_Wfunction_elimination,
901 "Removing call to impure function at %L",
902 &(e->where));
903 }
904 }
905
906
907 /* Callback function for the code walker for doing common function
908 elimination. This builds up the list of functions in the expression
909 and goes through them to detect duplicates, which it then replaces
910 by variables. */
911
912 static int
913 cfe_expr_0 (gfc_expr **e, int *walk_subtrees,
914 void *data ATTRIBUTE_UNUSED)
915 {
916 int i,j;
917 gfc_expr *newvar;
918 gfc_expr **ei, **ej;
919
920 /* Don't do this optimization within OMP workshare/atomic or ASSOC lists. */
921
922 if (in_omp_workshare || in_omp_atomic || in_assoc_list)
923 {
924 *walk_subtrees = 0;
925 return 0;
926 }
927
928 expr_array.release ();
929
930 gfc_expr_walker (e, cfe_register_funcs, NULL);
931
932 /* Walk through all the functions. */
933
934 FOR_EACH_VEC_ELT_FROM (expr_array, i, ei, 1)
935 {
936 /* Skip if the function has been replaced by a variable already. */
937 if ((*ei)->expr_type == EXPR_VARIABLE)
938 continue;
939
940 newvar = NULL;
941 for (j=0; j<i; j++)
942 {
943 ej = expr_array[j];
944 if (gfc_dep_compare_functions (*ei, *ej, true) == 0)
945 {
946 if (newvar == NULL)
947 newvar = create_var (*ei, "fcn");
948
949 if (warn_function_elimination)
950 do_warn_function_elimination (*ej);
951
952 free (*ej);
953 *ej = gfc_copy_expr (newvar);
954 }
955 }
956 if (newvar)
957 *ei = newvar;
958 }
959
960 /* We did all the necessary walking in this function. */
961 *walk_subtrees = 0;
962 return 0;
963 }
964
965 /* Callback function for common function elimination, called from
966 gfc_code_walker. This keeps track of the current code, in order
967 to insert statements as needed. */
968
969 static int
970 cfe_code (gfc_code **c, int *walk_subtrees, void *data ATTRIBUTE_UNUSED)
971 {
972 current_code = c;
973 inserted_block = NULL;
974 changed_statement = NULL;
975
976 /* Do not do anything inside a WHERE statement; scalar assignments, BLOCKs
977 and allocation on assigment are prohibited inside WHERE, and finally
978 masking an expression would lead to wrong-code when replacing
979
980 WHERE (a>0)
981 b = sum(foo(a) + foo(a))
982 END WHERE
983
984 with
985
986 WHERE (a > 0)
987 tmp = foo(a)
988 b = sum(tmp + tmp)
989 END WHERE
990 */
991
992 if ((*c)->op == EXEC_WHERE)
993 {
994 *walk_subtrees = 0;
995 return 0;
996 }
997
998
999 return 0;
1000 }
1001
1002 /* Dummy function for expression call back, for use when we
1003 really don't want to do any walking. */
1004
1005 static int
1006 dummy_expr_callback (gfc_expr **e ATTRIBUTE_UNUSED, int *walk_subtrees,
1007 void *data ATTRIBUTE_UNUSED)
1008 {
1009 *walk_subtrees = 0;
1010 return 0;
1011 }
1012
1013 /* Dummy function for code callback, for use when we really
1014 don't want to do anything. */
1015 int
1016 gfc_dummy_code_callback (gfc_code **e ATTRIBUTE_UNUSED,
1017 int *walk_subtrees ATTRIBUTE_UNUSED,
1018 void *data ATTRIBUTE_UNUSED)
1019 {
1020 return 0;
1021 }
1022
1023 /* Code callback function for converting
1024 do while(a)
1025 end do
1026 into the equivalent
1027 do
1028 if (.not. a) exit
1029 end do
1030 This is because common function elimination would otherwise place the
1031 temporary variables outside the loop. */
1032
1033 static int
1034 convert_do_while (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
1035 void *data ATTRIBUTE_UNUSED)
1036 {
1037 gfc_code *co = *c;
1038 gfc_code *c_if1, *c_if2, *c_exit;
1039 gfc_code *loopblock;
1040 gfc_expr *e_not, *e_cond;
1041
1042 if (co->op != EXEC_DO_WHILE)
1043 return 0;
1044
1045 if (co->expr1 == NULL || co->expr1->expr_type == EXPR_CONSTANT)
1046 return 0;
1047
1048 e_cond = co->expr1;
1049
1050 /* Generate the condition of the if statement, which is .not. the original
1051 statement. */
1052 e_not = gfc_get_expr ();
1053 e_not->ts = e_cond->ts;
1054 e_not->where = e_cond->where;
1055 e_not->expr_type = EXPR_OP;
1056 e_not->value.op.op = INTRINSIC_NOT;
1057 e_not->value.op.op1 = e_cond;
1058
1059 /* Generate the EXIT statement. */
1060 c_exit = XCNEW (gfc_code);
1061 c_exit->op = EXEC_EXIT;
1062 c_exit->ext.which_construct = co;
1063 c_exit->loc = co->loc;
1064
1065 /* Generate the IF statement. */
1066 c_if2 = XCNEW (gfc_code);
1067 c_if2->op = EXEC_IF;
1068 c_if2->expr1 = e_not;
1069 c_if2->next = c_exit;
1070 c_if2->loc = co->loc;
1071
1072 /* ... plus the one to chain it to. */
1073 c_if1 = XCNEW (gfc_code);
1074 c_if1->op = EXEC_IF;
1075 c_if1->block = c_if2;
1076 c_if1->loc = co->loc;
1077
1078 /* Make the DO WHILE loop into a DO block by replacing the condition
1079 with a true constant. */
1080 co->expr1 = gfc_get_logical_expr (gfc_default_integer_kind, &co->loc, true);
1081
1082 /* Hang the generated if statement into the loop body. */
1083
1084 loopblock = co->block->next;
1085 co->block->next = c_if1;
1086 c_if1->next = loopblock;
1087
1088 return 0;
1089 }
1090
1091 /* Code callback function for converting
1092 if (a) then
1093 ...
1094 else if (b) then
1095 end if
1096
1097 into
1098 if (a) then
1099 else
1100 if (b) then
1101 end if
1102 end if
1103
1104 because otherwise common function elimination would place the BLOCKs
1105 into the wrong place. */
1106
1107 static int
1108 convert_elseif (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
1109 void *data ATTRIBUTE_UNUSED)
1110 {
1111 gfc_code *co = *c;
1112 gfc_code *c_if1, *c_if2, *else_stmt;
1113
1114 if (co->op != EXEC_IF)
1115 return 0;
1116
1117 /* This loop starts out with the first ELSE statement. */
1118 else_stmt = co->block->block;
1119
1120 while (else_stmt != NULL)
1121 {
1122 gfc_code *next_else;
1123
1124 /* If there is no condition, we're done. */
1125 if (else_stmt->expr1 == NULL)
1126 break;
1127
1128 next_else = else_stmt->block;
1129
1130 /* Generate the new IF statement. */
1131 c_if2 = XCNEW (gfc_code);
1132 c_if2->op = EXEC_IF;
1133 c_if2->expr1 = else_stmt->expr1;
1134 c_if2->next = else_stmt->next;
1135 c_if2->loc = else_stmt->loc;
1136 c_if2->block = next_else;
1137
1138 /* ... plus the one to chain it to. */
1139 c_if1 = XCNEW (gfc_code);
1140 c_if1->op = EXEC_IF;
1141 c_if1->block = c_if2;
1142 c_if1->loc = else_stmt->loc;
1143
1144 /* Insert the new IF after the ELSE. */
1145 else_stmt->expr1 = NULL;
1146 else_stmt->next = c_if1;
1147 else_stmt->block = NULL;
1148
1149 else_stmt = next_else;
1150 }
1151 /* Don't walk subtrees. */
1152 return 0;
1153 }
1154
1155 /* Callback function to var_in_expr - return true if expr1 and
1156 expr2 are identical variables. */
1157 static int
1158 var_in_expr_callback (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
1159 void *data)
1160 {
1161 gfc_expr *expr1 = (gfc_expr *) data;
1162 gfc_expr *expr2 = *e;
1163
1164 if (expr2->expr_type != EXPR_VARIABLE)
1165 return 0;
1166
1167 return expr1->symtree->n.sym == expr2->symtree->n.sym;
1168 }
1169
1170 /* Return true if expr1 is found in expr2. */
1171
1172 static bool
1173 var_in_expr (gfc_expr *expr1, gfc_expr *expr2)
1174 {
1175 gcc_assert (expr1->expr_type == EXPR_VARIABLE);
1176
1177 return gfc_expr_walker (&expr2, var_in_expr_callback, (void *) expr1);
1178 }
1179
1180 struct do_stack
1181 {
1182 struct do_stack *prev;
1183 gfc_iterator *iter;
1184 gfc_code *code;
1185 } *stack_top;
1186
1187 /* Recursively traverse the block of a WRITE or READ statement, and maybe
1188 optimize by replacing do loops with their analog array slices. For
1189 example:
1190
1191 write (*,*) (a(i), i=1,4)
1192
1193 is replaced with
1194
1195 write (*,*) a(1:4:1) . */
1196
1197 static bool
1198 traverse_io_block (gfc_code *code, bool *has_reached, gfc_code *prev)
1199 {
1200 gfc_code *curr;
1201 gfc_expr *new_e, *expr, *start;
1202 gfc_ref *ref;
1203 struct do_stack ds_push;
1204 int i, future_rank = 0;
1205 gfc_iterator *iters[GFC_MAX_DIMENSIONS];
1206 gfc_expr *e;
1207
1208 /* Find the first transfer/do statement. */
1209 for (curr = code; curr; curr = curr->next)
1210 {
1211 if (curr->op == EXEC_DO || curr->op == EXEC_TRANSFER)
1212 break;
1213 }
1214
1215 /* Ensure it is the only transfer/do statement because cases like
1216
1217 write (*,*) (a(i), b(i), i=1,4)
1218
1219 cannot be optimized. */
1220
1221 if (!curr || curr->next)
1222 return false;
1223
1224 if (curr->op == EXEC_DO)
1225 {
1226 if (curr->ext.iterator->var->ref)
1227 return false;
1228 ds_push.prev = stack_top;
1229 ds_push.iter = curr->ext.iterator;
1230 ds_push.code = curr;
1231 stack_top = &ds_push;
1232 if (traverse_io_block (curr->block->next, has_reached, prev))
1233 {
1234 if (curr != stack_top->code && !*has_reached)
1235 {
1236 curr->block->next = NULL;
1237 gfc_free_statements (curr);
1238 }
1239 else
1240 *has_reached = true;
1241 return true;
1242 }
1243 return false;
1244 }
1245
1246 gcc_assert (curr->op == EXEC_TRANSFER);
1247
1248 e = curr->expr1;
1249 ref = e->ref;
1250 if (!ref || ref->type != REF_ARRAY || ref->u.ar.codimen != 0 || ref->next)
1251 return false;
1252
1253 /* Find the iterators belonging to each variable and check conditions. */
1254 for (i = 0; i < ref->u.ar.dimen; i++)
1255 {
1256 if (!ref->u.ar.start[i] || ref->u.ar.start[i]->ref
1257 || ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
1258 return false;
1259
1260 start = ref->u.ar.start[i];
1261 gfc_simplify_expr (start, 0);
1262 switch (start->expr_type)
1263 {
1264 case EXPR_VARIABLE:
1265
1266 /* write (*,*) (a(i), i=a%b,1) not handled yet. */
1267 if (start->ref)
1268 return false;
1269
1270 /* Check for (a(k), i=1,4) or ((a(j, i), i=1,4), j=1,4). */
1271 if (!stack_top || !stack_top->iter
1272 || stack_top->iter->var->symtree != start->symtree)
1273 {
1274 /* Check for (a(i,i), i=1,3). */
1275 int j;
1276
1277 for (j=0; j<i; j++)
1278 if (iters[j] && iters[j]->var->symtree == start->symtree)
1279 return false;
1280
1281 iters[i] = NULL;
1282 }
1283 else
1284 {
1285 iters[i] = stack_top->iter;
1286 stack_top = stack_top->prev;
1287 future_rank++;
1288 }
1289 break;
1290 case EXPR_CONSTANT:
1291 iters[i] = NULL;
1292 break;
1293 case EXPR_OP:
1294 switch (start->value.op.op)
1295 {
1296 case INTRINSIC_PLUS:
1297 case INTRINSIC_TIMES:
1298 if (start->value.op.op1->expr_type != EXPR_VARIABLE)
1299 std::swap (start->value.op.op1, start->value.op.op2);
1300 gcc_fallthrough ();
1301 case INTRINSIC_MINUS:
1302 if (start->value.op.op1->expr_type!= EXPR_VARIABLE
1303 || start->value.op.op2->expr_type != EXPR_CONSTANT
1304 || start->value.op.op1->ref)
1305 return false;
1306 if (!stack_top || !stack_top->iter
1307 || stack_top->iter->var->symtree
1308 != start->value.op.op1->symtree)
1309 return false;
1310 iters[i] = stack_top->iter;
1311 stack_top = stack_top->prev;
1312 break;
1313 default:
1314 return false;
1315 }
1316 future_rank++;
1317 break;
1318 default:
1319 return false;
1320 }
1321 }
1322
1323 /* Check for cases like ((a(i, j), i=1, j), j=1, 2). */
1324 for (int i = 1; i < ref->u.ar.dimen; i++)
1325 {
1326 if (iters[i])
1327 {
1328 gfc_expr *var = iters[i]->var;
1329 for (int j = i - 1; j < i; j++)
1330 {
1331 if (iters[j]
1332 && (var_in_expr (var, iters[j]->start)
1333 || var_in_expr (var, iters[j]->end)
1334 || var_in_expr (var, iters[j]->step)))
1335 return false;
1336 }
1337 }
1338 }
1339
1340 /* Create new expr. */
1341 new_e = gfc_copy_expr (curr->expr1);
1342 new_e->expr_type = EXPR_VARIABLE;
1343 new_e->rank = future_rank;
1344 if (curr->expr1->shape)
1345 new_e->shape = gfc_get_shape (new_e->rank);
1346
1347 /* Assign new starts, ends and strides if necessary. */
1348 for (i = 0; i < ref->u.ar.dimen; i++)
1349 {
1350 if (!iters[i])
1351 continue;
1352 start = ref->u.ar.start[i];
1353 switch (start->expr_type)
1354 {
1355 case EXPR_CONSTANT:
1356 gfc_internal_error ("bad expression");
1357 break;
1358 case EXPR_VARIABLE:
1359 new_e->ref->u.ar.dimen_type[i] = DIMEN_RANGE;
1360 new_e->ref->u.ar.type = AR_SECTION;
1361 gfc_free_expr (new_e->ref->u.ar.start[i]);
1362 new_e->ref->u.ar.start[i] = gfc_copy_expr (iters[i]->start);
1363 new_e->ref->u.ar.end[i] = gfc_copy_expr (iters[i]->end);
1364 new_e->ref->u.ar.stride[i] = gfc_copy_expr (iters[i]->step);
1365 break;
1366 case EXPR_OP:
1367 new_e->ref->u.ar.dimen_type[i] = DIMEN_RANGE;
1368 new_e->ref->u.ar.type = AR_SECTION;
1369 gfc_free_expr (new_e->ref->u.ar.start[i]);
1370 expr = gfc_copy_expr (start);
1371 expr->value.op.op1 = gfc_copy_expr (iters[i]->start);
1372 new_e->ref->u.ar.start[i] = expr;
1373 gfc_simplify_expr (new_e->ref->u.ar.start[i], 0);
1374 expr = gfc_copy_expr (start);
1375 expr->value.op.op1 = gfc_copy_expr (iters[i]->end);
1376 new_e->ref->u.ar.end[i] = expr;
1377 gfc_simplify_expr (new_e->ref->u.ar.end[i], 0);
1378 switch (start->value.op.op)
1379 {
1380 case INTRINSIC_MINUS:
1381 case INTRINSIC_PLUS:
1382 new_e->ref->u.ar.stride[i] = gfc_copy_expr (iters[i]->step);
1383 break;
1384 case INTRINSIC_TIMES:
1385 expr = gfc_copy_expr (start);
1386 expr->value.op.op1 = gfc_copy_expr (iters[i]->step);
1387 new_e->ref->u.ar.stride[i] = expr;
1388 gfc_simplify_expr (new_e->ref->u.ar.stride[i], 0);
1389 break;
1390 default:
1391 gfc_internal_error ("bad op");
1392 }
1393 break;
1394 default:
1395 gfc_internal_error ("bad expression");
1396 }
1397 }
1398 curr->expr1 = new_e;
1399
1400 /* Insert modified statement. Check whether the statement needs to be
1401 inserted at the lowest level. */
1402 if (!stack_top->iter)
1403 {
1404 if (prev)
1405 {
1406 curr->next = prev->next->next;
1407 prev->next = curr;
1408 }
1409 else
1410 {
1411 curr->next = stack_top->code->block->next->next->next;
1412 stack_top->code->block->next = curr;
1413 }
1414 }
1415 else
1416 stack_top->code->block->next = curr;
1417 return true;
1418 }
1419
1420 /* Function for the gfc_code_walker. If code is a READ or WRITE statement, it
1421 tries to optimize its block. */
1422
1423 static int
1424 simplify_io_impl_do (gfc_code **code, int *walk_subtrees,
1425 void *data ATTRIBUTE_UNUSED)
1426 {
1427 gfc_code **curr, *prev = NULL;
1428 struct do_stack write, first;
1429 bool b = false;
1430 *walk_subtrees = 1;
1431 if (!(*code)->block
1432 || ((*code)->block->op != EXEC_WRITE
1433 && (*code)->block->op != EXEC_READ))
1434 return 0;
1435
1436 *walk_subtrees = 0;
1437 write.prev = NULL;
1438 write.iter = NULL;
1439 write.code = *code;
1440
1441 for (curr = &(*code)->block; *curr; curr = &(*curr)->next)
1442 {
1443 if ((*curr)->op == EXEC_DO)
1444 {
1445 first.prev = &write;
1446 first.iter = (*curr)->ext.iterator;
1447 first.code = *curr;
1448 stack_top = &first;
1449 traverse_io_block ((*curr)->block->next, &b, prev);
1450 stack_top = NULL;
1451 }
1452 prev = *curr;
1453 }
1454 return 0;
1455 }
1456
1457 /* Optimize a namespace, including all contained namespaces.
1458 flag_frontend_optimize and flag_fronend_loop_interchange are
1459 handled separately. */
1460
1461 static void
1462 optimize_namespace (gfc_namespace *ns)
1463 {
1464 gfc_namespace *saved_ns = gfc_current_ns;
1465 current_ns = ns;
1466 gfc_current_ns = ns;
1467 forall_level = 0;
1468 iterator_level = 0;
1469 in_assoc_list = false;
1470 in_omp_workshare = false;
1471 in_omp_atomic = false;
1472
1473 if (flag_frontend_optimize)
1474 {
1475 gfc_code_walker (&ns->code, simplify_io_impl_do, dummy_expr_callback, NULL);
1476 gfc_code_walker (&ns->code, convert_do_while, dummy_expr_callback, NULL);
1477 gfc_code_walker (&ns->code, convert_elseif, dummy_expr_callback, NULL);
1478 gfc_code_walker (&ns->code, cfe_code, cfe_expr_0, NULL);
1479 gfc_code_walker (&ns->code, optimize_code, optimize_expr, NULL);
1480 if (flag_inline_matmul_limit != 0 || flag_external_blas)
1481 {
1482 bool found;
1483 do
1484 {
1485 found = false;
1486 gfc_code_walker (&ns->code, matmul_to_var_code, matmul_to_var_expr,
1487 (void *) &found);
1488 }
1489 while (found);
1490
1491 gfc_code_walker (&ns->code, matmul_temp_args, dummy_expr_callback,
1492 NULL);
1493 }
1494
1495 if (flag_external_blas)
1496 gfc_code_walker (&ns->code, call_external_blas, dummy_expr_callback,
1497 NULL);
1498
1499 if (flag_inline_matmul_limit != 0)
1500 gfc_code_walker (&ns->code, inline_matmul_assign, dummy_expr_callback,
1501 NULL);
1502 }
1503
1504 if (flag_frontend_loop_interchange)
1505 gfc_code_walker (&ns->code, index_interchange, dummy_expr_callback,
1506 NULL);
1507
1508 /* BLOCKs are handled in the expression walker below. */
1509 for (ns = ns->contained; ns; ns = ns->sibling)
1510 {
1511 if (ns->code == NULL || ns->code->op != EXEC_BLOCK)
1512 optimize_namespace (ns);
1513 }
1514 gfc_current_ns = saved_ns;
1515 }
1516
1517 /* Handle dependencies for allocatable strings which potentially redefine
1518 themselves in an assignment. */
1519
1520 static void
1521 realloc_strings (gfc_namespace *ns)
1522 {
1523 current_ns = ns;
1524 gfc_code_walker (&ns->code, realloc_string_callback, dummy_expr_callback, NULL);
1525
1526 for (ns = ns->contained; ns; ns = ns->sibling)
1527 {
1528 if (ns->code == NULL || ns->code->op != EXEC_BLOCK)
1529 realloc_strings (ns);
1530 }
1531
1532 }
1533
1534 static void
1535 optimize_reduction (gfc_namespace *ns)
1536 {
1537 current_ns = ns;
1538 gfc_code_walker (&ns->code, gfc_dummy_code_callback,
1539 callback_reduction, NULL);
1540
1541 /* BLOCKs are handled in the expression walker below. */
1542 for (ns = ns->contained; ns; ns = ns->sibling)
1543 {
1544 if (ns->code == NULL || ns->code->op != EXEC_BLOCK)
1545 optimize_reduction (ns);
1546 }
1547 }
1548
1549 /* Replace code like
1550 a = matmul(b,c) + d
1551 with
1552 a = matmul(b,c) ; a = a + d
1553 where the array function is not elemental and not allocatable
1554 and does not depend on the left-hand side.
1555 */
1556
1557 static bool
1558 optimize_binop_array_assignment (gfc_code *c, gfc_expr **rhs, bool seen_op)
1559 {
1560 gfc_expr *e;
1561
1562 if (!*rhs)
1563 return false;
1564
1565 e = *rhs;
1566 if (e->expr_type == EXPR_OP)
1567 {
1568 switch (e->value.op.op)
1569 {
1570 /* Unary operators and exponentiation: Only look at a single
1571 operand. */
1572 case INTRINSIC_NOT:
1573 case INTRINSIC_UPLUS:
1574 case INTRINSIC_UMINUS:
1575 case INTRINSIC_PARENTHESES:
1576 case INTRINSIC_POWER:
1577 if (optimize_binop_array_assignment (c, &e->value.op.op1, seen_op))
1578 return true;
1579 break;
1580
1581 case INTRINSIC_CONCAT:
1582 /* Do not do string concatenations. */
1583 break;
1584
1585 default:
1586 /* Binary operators. */
1587 if (optimize_binop_array_assignment (c, &e->value.op.op1, true))
1588 return true;
1589
1590 if (optimize_binop_array_assignment (c, &e->value.op.op2, true))
1591 return true;
1592
1593 break;
1594 }
1595 }
1596 else if (seen_op && e->expr_type == EXPR_FUNCTION && e->rank > 0
1597 && ! (e->value.function.esym
1598 && (e->value.function.esym->attr.elemental
1599 || e->value.function.esym->attr.allocatable
1600 || e->value.function.esym->ts.type != c->expr1->ts.type
1601 || e->value.function.esym->ts.kind != c->expr1->ts.kind))
1602 && ! (e->value.function.isym
1603 && (e->value.function.isym->elemental
1604 || e->ts.type != c->expr1->ts.type
1605 || e->ts.kind != c->expr1->ts.kind))
1606 && ! gfc_inline_intrinsic_function_p (e))
1607 {
1608
1609 gfc_code *n;
1610 gfc_expr *new_expr;
1611
1612 /* Insert a new assignment statement after the current one. */
1613 n = XCNEW (gfc_code);
1614 n->op = EXEC_ASSIGN;
1615 n->loc = c->loc;
1616 n->next = c->next;
1617 c->next = n;
1618
1619 n->expr1 = gfc_copy_expr (c->expr1);
1620 n->expr2 = c->expr2;
1621 new_expr = gfc_copy_expr (c->expr1);
1622 c->expr2 = e;
1623 *rhs = new_expr;
1624
1625 return true;
1626
1627 }
1628
1629 /* Nothing to optimize. */
1630 return false;
1631 }
1632
1633 /* Remove unneeded TRIMs at the end of expressions. */
1634
1635 static bool
1636 remove_trim (gfc_expr *rhs)
1637 {
1638 bool ret;
1639
1640 ret = false;
1641 if (!rhs)
1642 return ret;
1643
1644 /* Check for a // b // trim(c). Looping is probably not
1645 necessary because the parser usually generates
1646 (// (// a b ) trim(c) ) , but better safe than sorry. */
1647
1648 while (rhs->expr_type == EXPR_OP
1649 && rhs->value.op.op == INTRINSIC_CONCAT)
1650 rhs = rhs->value.op.op2;
1651
1652 while (rhs->expr_type == EXPR_FUNCTION && rhs->value.function.isym
1653 && rhs->value.function.isym->id == GFC_ISYM_TRIM)
1654 {
1655 strip_function_call (rhs);
1656 /* Recursive call to catch silly stuff like trim ( a // trim(b)). */
1657 remove_trim (rhs);
1658 ret = true;
1659 }
1660
1661 return ret;
1662 }
1663
1664 /* Optimizations for an assignment. */
1665
1666 static void
1667 optimize_assignment (gfc_code * c)
1668 {
1669 gfc_expr *lhs, *rhs;
1670
1671 lhs = c->expr1;
1672 rhs = c->expr2;
1673
1674 if (lhs->ts.type == BT_CHARACTER && !lhs->ts.deferred)
1675 {
1676 /* Optimize a = trim(b) to a = b. */
1677 remove_trim (rhs);
1678
1679 /* Replace a = ' ' by a = '' to optimize away a memcpy. */
1680 if (is_empty_string (rhs))
1681 rhs->value.character.length = 0;
1682 }
1683
1684 if (lhs->rank > 0 && gfc_check_dependency (lhs, rhs, true) == 0)
1685 optimize_binop_array_assignment (c, &rhs, false);
1686 }
1687
1688
1689 /* Remove an unneeded function call, modifying the expression.
1690 This replaces the function call with the value of its
1691 first argument. The rest of the argument list is freed. */
1692
1693 static void
1694 strip_function_call (gfc_expr *e)
1695 {
1696 gfc_expr *e1;
1697 gfc_actual_arglist *a;
1698
1699 a = e->value.function.actual;
1700
1701 /* We should have at least one argument. */
1702 gcc_assert (a->expr != NULL);
1703
1704 e1 = a->expr;
1705
1706 /* Free the remaining arglist, if any. */
1707 if (a->next)
1708 gfc_free_actual_arglist (a->next);
1709
1710 /* Graft the argument expression onto the original function. */
1711 *e = *e1;
1712 free (e1);
1713
1714 }
1715
1716 /* Optimization of lexical comparison functions. */
1717
1718 static bool
1719 optimize_lexical_comparison (gfc_expr *e)
1720 {
1721 if (e->expr_type != EXPR_FUNCTION || e->value.function.isym == NULL)
1722 return false;
1723
1724 switch (e->value.function.isym->id)
1725 {
1726 case GFC_ISYM_LLE:
1727 return optimize_comparison (e, INTRINSIC_LE);
1728
1729 case GFC_ISYM_LGE:
1730 return optimize_comparison (e, INTRINSIC_GE);
1731
1732 case GFC_ISYM_LGT:
1733 return optimize_comparison (e, INTRINSIC_GT);
1734
1735 case GFC_ISYM_LLT:
1736 return optimize_comparison (e, INTRINSIC_LT);
1737
1738 default:
1739 break;
1740 }
1741 return false;
1742 }
1743
1744 /* Combine stuff like [a]>b into [a>b], for easier optimization later. Do not
1745 do CHARACTER because of possible pessimization involving character
1746 lengths. */
1747
1748 static bool
1749 combine_array_constructor (gfc_expr *e)
1750 {
1751
1752 gfc_expr *op1, *op2;
1753 gfc_expr *scalar;
1754 gfc_expr *new_expr;
1755 gfc_constructor *c, *new_c;
1756 gfc_constructor_base oldbase, newbase;
1757 bool scalar_first;
1758 int n_elem;
1759 bool all_const;
1760
1761 /* Array constructors have rank one. */
1762 if (e->rank != 1)
1763 return false;
1764
1765 /* Don't try to combine association lists, this makes no sense
1766 and leads to an ICE. */
1767 if (in_assoc_list)
1768 return false;
1769
1770 /* With FORALL, the BLOCKS created by create_var will cause an ICE. */
1771 if (forall_level > 0)
1772 return false;
1773
1774 /* Inside an iterator, things can get hairy; we are likely to create
1775 an invalid temporary variable. */
1776 if (iterator_level > 0)
1777 return false;
1778
1779 /* WHERE also doesn't work. */
1780 if (in_where > 0)
1781 return false;
1782
1783 op1 = e->value.op.op1;
1784 op2 = e->value.op.op2;
1785
1786 if (!op1 || !op2)
1787 return false;
1788
1789 if (op1->expr_type == EXPR_ARRAY && op2->rank == 0)
1790 scalar_first = false;
1791 else if (op2->expr_type == EXPR_ARRAY && op1->rank == 0)
1792 {
1793 scalar_first = true;
1794 op1 = e->value.op.op2;
1795 op2 = e->value.op.op1;
1796 }
1797 else
1798 return false;
1799
1800 if (op2->ts.type == BT_CHARACTER)
1801 return false;
1802
1803 /* This might be an expanded constructor with very many constant values. If
1804 we perform the operation here, we might end up with a long compile time
1805 and actually longer execution time, so a length bound is in order here.
1806 If the constructor constains something which is not a constant, it did
1807 not come from an expansion, so leave it alone. */
1808
1809 #define CONSTR_LEN_MAX 4
1810
1811 oldbase = op1->value.constructor;
1812
1813 n_elem = 0;
1814 all_const = true;
1815 for (c = gfc_constructor_first (oldbase); c; c = gfc_constructor_next(c))
1816 {
1817 if (c->expr->expr_type != EXPR_CONSTANT)
1818 {
1819 all_const = false;
1820 break;
1821 }
1822 n_elem += 1;
1823 }
1824
1825 if (all_const && n_elem > CONSTR_LEN_MAX)
1826 return false;
1827
1828 #undef CONSTR_LEN_MAX
1829
1830 newbase = NULL;
1831 e->expr_type = EXPR_ARRAY;
1832
1833 scalar = create_var (gfc_copy_expr (op2), "constr");
1834
1835 for (c = gfc_constructor_first (oldbase); c;
1836 c = gfc_constructor_next (c))
1837 {
1838 new_expr = gfc_get_expr ();
1839 new_expr->ts = e->ts;
1840 new_expr->expr_type = EXPR_OP;
1841 new_expr->rank = c->expr->rank;
1842 new_expr->where = c->expr->where;
1843 new_expr->value.op.op = e->value.op.op;
1844
1845 if (scalar_first)
1846 {
1847 new_expr->value.op.op1 = gfc_copy_expr (scalar);
1848 new_expr->value.op.op2 = gfc_copy_expr (c->expr);
1849 }
1850 else
1851 {
1852 new_expr->value.op.op1 = gfc_copy_expr (c->expr);
1853 new_expr->value.op.op2 = gfc_copy_expr (scalar);
1854 }
1855
1856 new_c = gfc_constructor_append_expr (&newbase, new_expr, &(e->where));
1857 new_c->iterator = c->iterator;
1858 c->iterator = NULL;
1859 }
1860
1861 gfc_free_expr (op1);
1862 gfc_free_expr (op2);
1863 gfc_free_expr (scalar);
1864
1865 e->value.constructor = newbase;
1866 return true;
1867 }
1868
1869 /* Recursive optimization of operators. */
1870
1871 static bool
1872 optimize_op (gfc_expr *e)
1873 {
1874 bool changed;
1875
1876 gfc_intrinsic_op op = e->value.op.op;
1877
1878 changed = false;
1879
1880 /* Only use new-style comparisons. */
1881 switch(op)
1882 {
1883 case INTRINSIC_EQ_OS:
1884 op = INTRINSIC_EQ;
1885 break;
1886
1887 case INTRINSIC_GE_OS:
1888 op = INTRINSIC_GE;
1889 break;
1890
1891 case INTRINSIC_LE_OS:
1892 op = INTRINSIC_LE;
1893 break;
1894
1895 case INTRINSIC_NE_OS:
1896 op = INTRINSIC_NE;
1897 break;
1898
1899 case INTRINSIC_GT_OS:
1900 op = INTRINSIC_GT;
1901 break;
1902
1903 case INTRINSIC_LT_OS:
1904 op = INTRINSIC_LT;
1905 break;
1906
1907 default:
1908 break;
1909 }
1910
1911 switch (op)
1912 {
1913 case INTRINSIC_EQ:
1914 case INTRINSIC_GE:
1915 case INTRINSIC_LE:
1916 case INTRINSIC_NE:
1917 case INTRINSIC_GT:
1918 case INTRINSIC_LT:
1919 changed = optimize_comparison (e, op);
1920
1921 gcc_fallthrough ();
1922 /* Look at array constructors. */
1923 case INTRINSIC_PLUS:
1924 case INTRINSIC_MINUS:
1925 case INTRINSIC_TIMES:
1926 case INTRINSIC_DIVIDE:
1927 return combine_array_constructor (e) || changed;
1928
1929 default:
1930 break;
1931 }
1932
1933 return false;
1934 }
1935
1936
1937 /* Return true if a constant string contains only blanks. */
1938
1939 static bool
1940 is_empty_string (gfc_expr *e)
1941 {
1942 int i;
1943
1944 if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT)
1945 return false;
1946
1947 for (i=0; i < e->value.character.length; i++)
1948 {
1949 if (e->value.character.string[i] != ' ')
1950 return false;
1951 }
1952
1953 return true;
1954 }
1955
1956
1957 /* Insert a call to the intrinsic len_trim. Use a different name for
1958 the symbol tree so we don't run into trouble when the user has
1959 renamed len_trim for some reason. */
1960
1961 static gfc_expr*
1962 get_len_trim_call (gfc_expr *str, int kind)
1963 {
1964 gfc_expr *fcn;
1965 gfc_actual_arglist *actual_arglist, *next;
1966
1967 fcn = gfc_get_expr ();
1968 fcn->expr_type = EXPR_FUNCTION;
1969 fcn->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_LEN_TRIM);
1970 actual_arglist = gfc_get_actual_arglist ();
1971 actual_arglist->expr = str;
1972 next = gfc_get_actual_arglist ();
1973 next->expr = gfc_get_int_expr (gfc_default_integer_kind, NULL, kind);
1974 actual_arglist->next = next;
1975
1976 fcn->value.function.actual = actual_arglist;
1977 fcn->where = str->where;
1978 fcn->ts.type = BT_INTEGER;
1979 fcn->ts.kind = gfc_charlen_int_kind;
1980
1981 gfc_get_sym_tree ("__internal_len_trim", current_ns, &fcn->symtree, false);
1982 fcn->symtree->n.sym->ts = fcn->ts;
1983 fcn->symtree->n.sym->attr.flavor = FL_PROCEDURE;
1984 fcn->symtree->n.sym->attr.function = 1;
1985 fcn->symtree->n.sym->attr.elemental = 1;
1986 fcn->symtree->n.sym->attr.referenced = 1;
1987 fcn->symtree->n.sym->attr.access = ACCESS_PRIVATE;
1988 gfc_commit_symbol (fcn->symtree->n.sym);
1989
1990 return fcn;
1991 }
1992
1993
1994 /* Optimize expressions for equality. */
1995
1996 static bool
1997 optimize_comparison (gfc_expr *e, gfc_intrinsic_op op)
1998 {
1999 gfc_expr *op1, *op2;
2000 bool change;
2001 int eq;
2002 bool result;
2003 gfc_actual_arglist *firstarg, *secondarg;
2004
2005 if (e->expr_type == EXPR_OP)
2006 {
2007 firstarg = NULL;
2008 secondarg = NULL;
2009 op1 = e->value.op.op1;
2010 op2 = e->value.op.op2;
2011 }
2012 else if (e->expr_type == EXPR_FUNCTION)
2013 {
2014 /* One of the lexical comparison functions. */
2015 firstarg = e->value.function.actual;
2016 secondarg = firstarg->next;
2017 op1 = firstarg->expr;
2018 op2 = secondarg->expr;
2019 }
2020 else
2021 gcc_unreachable ();
2022
2023 /* Strip off unneeded TRIM calls from string comparisons. */
2024
2025 change = remove_trim (op1);
2026
2027 if (remove_trim (op2))
2028 change = true;
2029
2030 /* An expression of type EXPR_CONSTANT is only valid for scalars. */
2031 /* TODO: A scalar constant may be acceptable in some cases (the scalarizer
2032 handles them well). However, there are also cases that need a non-scalar
2033 argument. For example the any intrinsic. See PR 45380. */
2034 if (e->rank > 0)
2035 return change;
2036
2037 /* Replace a == '' with len_trim(a) == 0 and a /= '' with
2038 len_trim(a) != 0 */
2039 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
2040 && (op == INTRINSIC_EQ || op == INTRINSIC_NE))
2041 {
2042 bool empty_op1, empty_op2;
2043 empty_op1 = is_empty_string (op1);
2044 empty_op2 = is_empty_string (op2);
2045
2046 if (empty_op1 || empty_op2)
2047 {
2048 gfc_expr *fcn;
2049 gfc_expr *zero;
2050 gfc_expr *str;
2051
2052 /* This can only happen when an error for comparing
2053 characters of different kinds has already been issued. */
2054 if (empty_op1 && empty_op2)
2055 return false;
2056
2057 zero = gfc_get_int_expr (gfc_charlen_int_kind, &e->where, 0);
2058 str = empty_op1 ? op2 : op1;
2059
2060 fcn = get_len_trim_call (str, gfc_charlen_int_kind);
2061
2062
2063 if (empty_op1)
2064 gfc_free_expr (op1);
2065 else
2066 gfc_free_expr (op2);
2067
2068 op1 = fcn;
2069 op2 = zero;
2070 e->value.op.op1 = fcn;
2071 e->value.op.op2 = zero;
2072 }
2073 }
2074
2075
2076 /* Don't compare REAL or COMPLEX expressions when honoring NaNs. */
2077
2078 if (flag_finite_math_only
2079 || (op1->ts.type != BT_REAL && op2->ts.type != BT_REAL
2080 && op1->ts.type != BT_COMPLEX && op2->ts.type != BT_COMPLEX))
2081 {
2082 eq = gfc_dep_compare_expr (op1, op2);
2083 if (eq <= -2)
2084 {
2085 /* Replace A // B < A // C with B < C, and A // B < C // B
2086 with A < C. */
2087 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
2088 && op1->expr_type == EXPR_OP
2089 && op1->value.op.op == INTRINSIC_CONCAT
2090 && op2->expr_type == EXPR_OP
2091 && op2->value.op.op == INTRINSIC_CONCAT)
2092 {
2093 gfc_expr *op1_left = op1->value.op.op1;
2094 gfc_expr *op2_left = op2->value.op.op1;
2095 gfc_expr *op1_right = op1->value.op.op2;
2096 gfc_expr *op2_right = op2->value.op.op2;
2097
2098 if (gfc_dep_compare_expr (op1_left, op2_left) == 0)
2099 {
2100 /* Watch out for 'A ' // x vs. 'A' // x. */
2101
2102 if (op1_left->expr_type == EXPR_CONSTANT
2103 && op2_left->expr_type == EXPR_CONSTANT
2104 && op1_left->value.character.length
2105 != op2_left->value.character.length)
2106 return change;
2107 else
2108 {
2109 free (op1_left);
2110 free (op2_left);
2111 if (firstarg)
2112 {
2113 firstarg->expr = op1_right;
2114 secondarg->expr = op2_right;
2115 }
2116 else
2117 {
2118 e->value.op.op1 = op1_right;
2119 e->value.op.op2 = op2_right;
2120 }
2121 optimize_comparison (e, op);
2122 return true;
2123 }
2124 }
2125 if (gfc_dep_compare_expr (op1_right, op2_right) == 0)
2126 {
2127 free (op1_right);
2128 free (op2_right);
2129 if (firstarg)
2130 {
2131 firstarg->expr = op1_left;
2132 secondarg->expr = op2_left;
2133 }
2134 else
2135 {
2136 e->value.op.op1 = op1_left;
2137 e->value.op.op2 = op2_left;
2138 }
2139
2140 optimize_comparison (e, op);
2141 return true;
2142 }
2143 }
2144 }
2145 else
2146 {
2147 /* eq can only be -1, 0 or 1 at this point. */
2148 switch (op)
2149 {
2150 case INTRINSIC_EQ:
2151 result = eq == 0;
2152 break;
2153
2154 case INTRINSIC_GE:
2155 result = eq >= 0;
2156 break;
2157
2158 case INTRINSIC_LE:
2159 result = eq <= 0;
2160 break;
2161
2162 case INTRINSIC_NE:
2163 result = eq != 0;
2164 break;
2165
2166 case INTRINSIC_GT:
2167 result = eq > 0;
2168 break;
2169
2170 case INTRINSIC_LT:
2171 result = eq < 0;
2172 break;
2173
2174 default:
2175 gfc_internal_error ("illegal OP in optimize_comparison");
2176 break;
2177 }
2178
2179 /* Replace the expression by a constant expression. The typespec
2180 and where remains the way it is. */
2181 free (op1);
2182 free (op2);
2183 e->expr_type = EXPR_CONSTANT;
2184 e->value.logical = result;
2185 return true;
2186 }
2187 }
2188
2189 return change;
2190 }
2191
2192 /* Optimize a trim function by replacing it with an equivalent substring
2193 involving a call to len_trim. This only works for expressions where
2194 variables are trimmed. Return true if anything was modified. */
2195
2196 static bool
2197 optimize_trim (gfc_expr *e)
2198 {
2199 gfc_expr *a;
2200 gfc_ref *ref;
2201 gfc_expr *fcn;
2202 gfc_ref **rr = NULL;
2203
2204 /* Don't do this optimization within an argument list, because
2205 otherwise aliasing issues may occur. */
2206
2207 if (count_arglist != 1)
2208 return false;
2209
2210 if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_FUNCTION
2211 || e->value.function.isym == NULL
2212 || e->value.function.isym->id != GFC_ISYM_TRIM)
2213 return false;
2214
2215 a = e->value.function.actual->expr;
2216
2217 if (a->expr_type != EXPR_VARIABLE)
2218 return false;
2219
2220 /* This would pessimize the idiom a = trim(a) for reallocatable strings. */
2221
2222 if (a->symtree->n.sym->attr.allocatable)
2223 return false;
2224
2225 /* Follow all references to find the correct place to put the newly
2226 created reference. FIXME: Also handle substring references and
2227 array references. Array references cause strange regressions at
2228 the moment. */
2229
2230 if (a->ref)
2231 {
2232 for (rr = &(a->ref); *rr; rr = &((*rr)->next))
2233 {
2234 if ((*rr)->type == REF_SUBSTRING || (*rr)->type == REF_ARRAY)
2235 return false;
2236 }
2237 }
2238
2239 strip_function_call (e);
2240
2241 if (e->ref == NULL)
2242 rr = &(e->ref);
2243
2244 /* Create the reference. */
2245
2246 ref = gfc_get_ref ();
2247 ref->type = REF_SUBSTRING;
2248
2249 /* Set the start of the reference. */
2250
2251 ref->u.ss.start = gfc_get_int_expr (gfc_charlen_int_kind, NULL, 1);
2252
2253 /* Build the function call to len_trim(x, gfc_default_integer_kind). */
2254
2255 fcn = get_len_trim_call (gfc_copy_expr (e), gfc_charlen_int_kind);
2256
2257 /* Set the end of the reference to the call to len_trim. */
2258
2259 ref->u.ss.end = fcn;
2260 gcc_assert (rr != NULL && *rr == NULL);
2261 *rr = ref;
2262 return true;
2263 }
2264
2265 /* Optimize minloc(b), where b is rank 1 array, into
2266 (/ minloc(b, dim=1) /), and similarly for maxloc,
2267 as the latter forms are expanded inline. */
2268
2269 static void
2270 optimize_minmaxloc (gfc_expr **e)
2271 {
2272 gfc_expr *fn = *e;
2273 gfc_actual_arglist *a;
2274 char *name, *p;
2275
2276 if (fn->rank != 1
2277 || fn->value.function.actual == NULL
2278 || fn->value.function.actual->expr == NULL
2279 || fn->value.function.actual->expr->rank != 1)
2280 return;
2281
2282 *e = gfc_get_array_expr (fn->ts.type, fn->ts.kind, &fn->where);
2283 (*e)->shape = fn->shape;
2284 fn->rank = 0;
2285 fn->shape = NULL;
2286 gfc_constructor_append_expr (&(*e)->value.constructor, fn, &fn->where);
2287
2288 name = XALLOCAVEC (char, strlen (fn->value.function.name) + 1);
2289 strcpy (name, fn->value.function.name);
2290 p = strstr (name, "loc0");
2291 p[3] = '1';
2292 fn->value.function.name = gfc_get_string ("%s", name);
2293 if (fn->value.function.actual->next)
2294 {
2295 a = fn->value.function.actual->next;
2296 gcc_assert (a->expr == NULL);
2297 }
2298 else
2299 {
2300 a = gfc_get_actual_arglist ();
2301 fn->value.function.actual->next = a;
2302 }
2303 a->expr = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
2304 &fn->where);
2305 mpz_set_ui (a->expr->value.integer, 1);
2306 }
2307
2308 /* Data package to hand down for DO loop checks in a contained
2309 procedure. */
2310 typedef struct contained_info
2311 {
2312 gfc_symbol *do_var;
2313 gfc_symbol *procedure;
2314 locus where_do;
2315 } contained_info;
2316
2317 static enum gfc_exec_op last_io_op;
2318
2319 /* Callback function to check for INTENT(OUT) and INTENT(INOUT) in a
2320 contained function call. */
2321
2322 static int
2323 doloop_contained_function_call (gfc_expr **e,
2324 int *walk_subtrees ATTRIBUTE_UNUSED, void *data)
2325 {
2326 gfc_expr *expr = *e;
2327 gfc_formal_arglist *f;
2328 gfc_actual_arglist *a;
2329 gfc_symbol *sym, *do_var;
2330 contained_info *info;
2331
2332 if (expr->expr_type != EXPR_FUNCTION || expr->value.function.isym
2333 || expr->value.function.esym == NULL)
2334 return 0;
2335
2336 sym = expr->value.function.esym;
2337 f = gfc_sym_get_dummy_args (sym);
2338 if (f == NULL)
2339 return 0;
2340
2341 info = (contained_info *) data;
2342 do_var = info->do_var;
2343 a = expr->value.function.actual;
2344
2345 while (a && f)
2346 {
2347 if (a->expr && a->expr->symtree && a->expr->symtree->n.sym == do_var)
2348 {
2349 if (f->sym->attr.intent == INTENT_OUT)
2350 {
2351 gfc_error_now ("Index variable %qs set to undefined as "
2352 "INTENT(OUT) argument at %L in procedure %qs "
2353 "called from within DO loop at %L", do_var->name,
2354 &a->expr->where, info->procedure->name,
2355 &info->where_do);
2356 return 1;
2357 }
2358 else if (f->sym->attr.intent == INTENT_INOUT)
2359 {
2360 gfc_error_now ("Index variable %qs not definable as "
2361 "INTENT(INOUT) argument at %L in procedure %qs "
2362 "called from within DO loop at %L", do_var->name,
2363 &a->expr->where, info->procedure->name,
2364 &info->where_do);
2365 return 1;
2366 }
2367 }
2368 a = a->next;
2369 f = f->next;
2370 }
2371 return 0;
2372 }
2373
2374 /* Callback function that goes through the code in a contained
2375 procedure to make sure it does not change a variable in a DO
2376 loop. */
2377
2378 static int
2379 doloop_contained_procedure_code (gfc_code **c,
2380 int *walk_subtrees ATTRIBUTE_UNUSED,
2381 void *data)
2382 {
2383 gfc_code *co = *c;
2384 contained_info *info = (contained_info *) data;
2385 gfc_symbol *do_var = info->do_var;
2386 const char *errmsg = _("Index variable %qs redefined at %L in procedure %qs "
2387 "called from within DO loop at %L");
2388 static enum gfc_exec_op saved_io_op;
2389
2390 switch (co->op)
2391 {
2392 case EXEC_ASSIGN:
2393 if (co->expr1->symtree->n.sym == do_var)
2394 gfc_error_now (errmsg, do_var->name, &co->loc, info->procedure->name,
2395 &info->where_do);
2396 break;
2397
2398 case EXEC_DO:
2399 if (co->ext.iterator && co->ext.iterator->var
2400 && co->ext.iterator->var->symtree->n.sym == do_var)
2401 gfc_error (errmsg, do_var->name, &co->loc, info->procedure->name,
2402 &info->where_do);
2403 break;
2404
2405 case EXEC_READ:
2406 case EXEC_WRITE:
2407 case EXEC_INQUIRE:
2408 case EXEC_IOLENGTH:
2409 saved_io_op = last_io_op;
2410 last_io_op = co->op;
2411 break;
2412
2413 case EXEC_OPEN:
2414 if (co->ext.open->iostat
2415 && co->ext.open->iostat->symtree->n.sym == do_var)
2416 gfc_error_now (errmsg, do_var->name, &co->ext.open->iostat->where,
2417 info->procedure->name, &info->where_do);
2418 break;
2419
2420 case EXEC_CLOSE:
2421 if (co->ext.close->iostat
2422 && co->ext.close->iostat->symtree->n.sym == do_var)
2423 gfc_error_now (errmsg, do_var->name, &co->ext.close->iostat->where,
2424 info->procedure->name, &info->where_do);
2425 break;
2426
2427 case EXEC_TRANSFER:
2428 switch (last_io_op)
2429 {
2430
2431 case EXEC_INQUIRE:
2432 #define CHECK_INQ(a) do { if (co->ext.inquire->a && \
2433 co->ext.inquire->a->symtree->n.sym == do_var) \
2434 gfc_error_now (errmsg, do_var->name, \
2435 &co->ext.inquire->a->where, \
2436 info->procedure->name, \
2437 &info->where_do); \
2438 } while (0)
2439
2440 CHECK_INQ(iostat);
2441 CHECK_INQ(number);
2442 CHECK_INQ(position);
2443 CHECK_INQ(recl);
2444 CHECK_INQ(position);
2445 CHECK_INQ(iolength);
2446 CHECK_INQ(strm_pos);
2447 break;
2448 #undef CHECK_INQ
2449
2450 case EXEC_READ:
2451 if (co->expr1 && co->expr1->symtree->n.sym == do_var)
2452 gfc_error_now (errmsg, do_var->name, &co->expr1->where,
2453 info->procedure->name, &info->where_do);
2454
2455 /* Fallthrough. */
2456
2457 case EXEC_WRITE:
2458 if (co->ext.dt->iostat
2459 && co->ext.dt->iostat->symtree->n.sym == do_var)
2460 gfc_error_now (errmsg, do_var->name, &co->ext.dt->iostat->where,
2461 info->procedure->name, &info->where_do);
2462 break;
2463
2464 case EXEC_IOLENGTH:
2465 if (co->expr1 && co->expr1->symtree->n.sym == do_var)
2466 gfc_error_now (errmsg, do_var->name, &co->expr1->where,
2467 info->procedure->name, &info->where_do);
2468 break;
2469
2470 default:
2471 gcc_unreachable ();
2472 }
2473 break;
2474
2475 case EXEC_DT_END:
2476 last_io_op = saved_io_op;
2477 break;
2478
2479 case EXEC_CALL:
2480 gfc_formal_arglist *f;
2481 gfc_actual_arglist *a;
2482
2483 f = gfc_sym_get_dummy_args (co->resolved_sym);
2484 if (f == NULL)
2485 break;
2486 a = co->ext.actual;
2487 /* Slightly different error message here. If there is an error,
2488 return 1 to avoid an infinite loop. */
2489 while (a && f)
2490 {
2491 if (a->expr && a->expr->symtree && a->expr->symtree->n.sym == do_var)
2492 {
2493 if (f->sym->attr.intent == INTENT_OUT)
2494 {
2495 gfc_error_now ("Index variable %qs set to undefined as "
2496 "INTENT(OUT) argument at %L in subroutine %qs "
2497 "called from within DO loop at %L",
2498 do_var->name, &a->expr->where,
2499 info->procedure->name, &info->where_do);
2500 return 1;
2501 }
2502 else if (f->sym->attr.intent == INTENT_INOUT)
2503 {
2504 gfc_error_now ("Index variable %qs not definable as "
2505 "INTENT(INOUT) argument at %L in subroutine %qs "
2506 "called from within DO loop at %L", do_var->name,
2507 &a->expr->where, info->procedure->name,
2508 &info->where_do);
2509 return 1;
2510 }
2511 }
2512 a = a->next;
2513 f = f->next;
2514 }
2515 break;
2516 default:
2517 break;
2518 }
2519 return 0;
2520 }
2521
2522 /* Callback function for code checking that we do not pass a DO variable to an
2523 INTENT(OUT) or INTENT(INOUT) dummy variable. */
2524
2525 static int
2526 doloop_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
2527 void *data ATTRIBUTE_UNUSED)
2528 {
2529 gfc_code *co;
2530 int i;
2531 gfc_formal_arglist *f;
2532 gfc_actual_arglist *a;
2533 gfc_code *cl;
2534 do_t loop, *lp;
2535 bool seen_goto;
2536
2537 co = *c;
2538
2539 /* If the doloop_list grew, we have to truncate it here. */
2540
2541 if ((unsigned) doloop_level < doloop_list.length())
2542 doloop_list.truncate (doloop_level);
2543
2544 seen_goto = false;
2545 switch (co->op)
2546 {
2547 case EXEC_DO:
2548
2549 if (co->ext.iterator && co->ext.iterator->var)
2550 loop.c = co;
2551 else
2552 loop.c = NULL;
2553
2554 loop.branch_level = if_level + select_level;
2555 loop.seen_goto = false;
2556 doloop_list.safe_push (loop);
2557 break;
2558
2559 /* If anything could transfer control away from a suspicious
2560 subscript, make sure to set seen_goto in the current DO loop
2561 (if any). */
2562 case EXEC_GOTO:
2563 case EXEC_EXIT:
2564 case EXEC_STOP:
2565 case EXEC_ERROR_STOP:
2566 case EXEC_CYCLE:
2567 seen_goto = true;
2568 break;
2569
2570 case EXEC_OPEN:
2571 if (co->ext.open->err)
2572 seen_goto = true;
2573 break;
2574
2575 case EXEC_CLOSE:
2576 if (co->ext.close->err)
2577 seen_goto = true;
2578 break;
2579
2580 case EXEC_BACKSPACE:
2581 case EXEC_ENDFILE:
2582 case EXEC_REWIND:
2583 case EXEC_FLUSH:
2584
2585 if (co->ext.filepos->err)
2586 seen_goto = true;
2587 break;
2588
2589 case EXEC_INQUIRE:
2590 if (co->ext.filepos->err)
2591 seen_goto = true;
2592 break;
2593
2594 case EXEC_READ:
2595 case EXEC_WRITE:
2596 if (co->ext.dt->err || co->ext.dt->end || co->ext.dt->eor)
2597 seen_goto = true;
2598 break;
2599
2600 case EXEC_WAIT:
2601 if (co->ext.wait->err || co->ext.wait->end || co->ext.wait->eor)
2602 loop.seen_goto = true;
2603 break;
2604
2605 case EXEC_CALL:
2606 if (co->resolved_sym == NULL)
2607 break;
2608
2609 /* Test if somebody stealthily changes the DO variable from
2610 under us by changing it in a host-associated procedure. */
2611 if (co->resolved_sym->attr.contained)
2612 {
2613 FOR_EACH_VEC_ELT (doloop_list, i, lp)
2614 {
2615 gfc_symbol *sym = co->resolved_sym;
2616 contained_info info;
2617 gfc_namespace *ns;
2618
2619 cl = lp->c;
2620 info.do_var = cl->ext.iterator->var->symtree->n.sym;
2621 info.procedure = co->resolved_sym; /* sym? */
2622 info.where_do = co->loc;
2623 /* Look contained procedures under the namespace of the
2624 variable. */
2625 for (ns = info.do_var->ns->contained; ns; ns = ns->sibling)
2626 if (ns->proc_name && ns->proc_name == sym)
2627 gfc_code_walker (&ns->code, doloop_contained_procedure_code,
2628 doloop_contained_function_call, &info);
2629 }
2630 }
2631
2632 f = gfc_sym_get_dummy_args (co->resolved_sym);
2633
2634 /* Withot a formal arglist, there is only unknown INTENT,
2635 which we don't check for. */
2636 if (f == NULL)
2637 break;
2638
2639 a = co->ext.actual;
2640
2641 while (a && f)
2642 {
2643 FOR_EACH_VEC_ELT (doloop_list, i, lp)
2644 {
2645 gfc_symbol *do_sym;
2646 cl = lp->c;
2647
2648 if (cl == NULL)
2649 break;
2650
2651 do_sym = cl->ext.iterator->var->symtree->n.sym;
2652
2653 if (a->expr && a->expr->symtree
2654 && a->expr->symtree->n.sym == do_sym)
2655 {
2656 if (f->sym->attr.intent == INTENT_OUT)
2657 gfc_error_now ("Variable %qs at %L set to undefined "
2658 "value inside loop beginning at %L as "
2659 "INTENT(OUT) argument to subroutine %qs",
2660 do_sym->name, &a->expr->where,
2661 &(doloop_list[i].c->loc),
2662 co->symtree->n.sym->name);
2663 else if (f->sym->attr.intent == INTENT_INOUT)
2664 gfc_error_now ("Variable %qs at %L not definable inside "
2665 "loop beginning at %L as INTENT(INOUT) "
2666 "argument to subroutine %qs",
2667 do_sym->name, &a->expr->where,
2668 &(doloop_list[i].c->loc),
2669 co->symtree->n.sym->name);
2670 }
2671 }
2672 a = a->next;
2673 f = f->next;
2674 }
2675
2676 break;
2677
2678 default:
2679 break;
2680 }
2681 if (seen_goto && doloop_level > 0)
2682 doloop_list[doloop_level-1].seen_goto = true;
2683
2684 return 0;
2685 }
2686
2687 /* Callback function to warn about different things within DO loops. */
2688
2689 static int
2690 do_function (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
2691 void *data ATTRIBUTE_UNUSED)
2692 {
2693 do_t *last;
2694
2695 if (doloop_list.length () == 0)
2696 return 0;
2697
2698 if ((*e)->expr_type == EXPR_FUNCTION)
2699 do_intent (e);
2700
2701 last = &doloop_list.last();
2702 if (last->seen_goto && !warn_do_subscript)
2703 return 0;
2704
2705 if ((*e)->expr_type == EXPR_VARIABLE)
2706 do_subscript (e);
2707
2708 return 0;
2709 }
2710
2711 typedef struct
2712 {
2713 gfc_symbol *sym;
2714 mpz_t val;
2715 } insert_index_t;
2716
2717 /* Callback function - if the expression is the variable in data->sym,
2718 replace it with a constant from data->val. */
2719
2720 static int
2721 callback_insert_index (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
2722 void *data)
2723 {
2724 insert_index_t *d;
2725 gfc_expr *ex, *n;
2726
2727 ex = (*e);
2728 if (ex->expr_type != EXPR_VARIABLE)
2729 return 0;
2730
2731 d = (insert_index_t *) data;
2732 if (ex->symtree->n.sym != d->sym)
2733 return 0;
2734
2735 n = gfc_get_constant_expr (BT_INTEGER, ex->ts.kind, &ex->where);
2736 mpz_set (n->value.integer, d->val);
2737
2738 gfc_free_expr (ex);
2739 *e = n;
2740 return 0;
2741 }
2742
2743 /* In the expression e, replace occurrences of the variable sym with
2744 val. If this results in a constant expression, return true and
2745 return the value in ret. Return false if the expression already
2746 is a constant. Caller has to clear ret in that case. */
2747
2748 static bool
2749 insert_index (gfc_expr *e, gfc_symbol *sym, mpz_t val, mpz_t ret)
2750 {
2751 gfc_expr *n;
2752 insert_index_t data;
2753 bool rc;
2754
2755 if (e->expr_type == EXPR_CONSTANT)
2756 return false;
2757
2758 n = gfc_copy_expr (e);
2759 data.sym = sym;
2760 mpz_init_set (data.val, val);
2761 gfc_expr_walker (&n, callback_insert_index, (void *) &data);
2762
2763 /* Suppress errors here - we could get errors here such as an
2764 out of bounds access for arrays, see PR 90563. */
2765 gfc_push_suppress_errors ();
2766 gfc_simplify_expr (n, 0);
2767 gfc_pop_suppress_errors ();
2768
2769 if (n->expr_type == EXPR_CONSTANT)
2770 {
2771 rc = true;
2772 mpz_init_set (ret, n->value.integer);
2773 }
2774 else
2775 rc = false;
2776
2777 mpz_clear (data.val);
2778 gfc_free_expr (n);
2779 return rc;
2780
2781 }
2782
2783 /* Check array subscripts for possible out-of-bounds accesses in DO
2784 loops with constant bounds. */
2785
2786 static int
2787 do_subscript (gfc_expr **e)
2788 {
2789 gfc_expr *v;
2790 gfc_array_ref *ar;
2791 gfc_ref *ref;
2792 int i,j;
2793 gfc_code *dl;
2794 do_t *lp;
2795
2796 v = *e;
2797 /* Constants are already checked. */
2798 if (v->expr_type == EXPR_CONSTANT)
2799 return 0;
2800
2801 /* Wrong warnings will be generated in an associate list. */
2802 if (in_assoc_list)
2803 return 0;
2804
2805 /* We already warned about this. */
2806 if (v->do_not_warn)
2807 return 0;
2808
2809 v->do_not_warn = 1;
2810
2811 for (ref = v->ref; ref; ref = ref->next)
2812 {
2813 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT)
2814 {
2815 ar = & ref->u.ar;
2816 FOR_EACH_VEC_ELT (doloop_list, j, lp)
2817 {
2818 gfc_symbol *do_sym;
2819 mpz_t do_start, do_step, do_end;
2820 bool have_do_start, have_do_end;
2821 bool error_not_proven;
2822 int warn;
2823 int sgn;
2824
2825 dl = lp->c;
2826 if (dl == NULL)
2827 break;
2828
2829 /* If we are within a branch, or a goto or equivalent
2830 was seen in the DO loop before, then we cannot prove that
2831 this expression is actually evaluated. Don't do anything
2832 unless we want to see it all. */
2833 error_not_proven = lp->seen_goto
2834 || lp->branch_level < if_level + select_level;
2835
2836 if (error_not_proven && !warn_do_subscript)
2837 break;
2838
2839 if (error_not_proven)
2840 warn = OPT_Wdo_subscript;
2841 else
2842 warn = 0;
2843
2844 do_sym = dl->ext.iterator->var->symtree->n.sym;
2845 if (do_sym->ts.type != BT_INTEGER)
2846 continue;
2847
2848 /* If we do not know about the stepsize, the loop may be zero trip.
2849 Do not warn in this case. */
2850
2851 if (dl->ext.iterator->step->expr_type == EXPR_CONSTANT)
2852 {
2853 sgn = mpz_cmp_ui (dl->ext.iterator->step->value.integer, 0);
2854 /* This can happen, but then the error has been
2855 reported previously. */
2856 if (sgn == 0)
2857 continue;
2858
2859 mpz_init_set (do_step, dl->ext.iterator->step->value.integer);
2860 }
2861
2862 else
2863 continue;
2864
2865 if (dl->ext.iterator->start->expr_type == EXPR_CONSTANT)
2866 {
2867 have_do_start = true;
2868 mpz_init_set (do_start, dl->ext.iterator->start->value.integer);
2869 }
2870 else
2871 have_do_start = false;
2872
2873 if (dl->ext.iterator->end->expr_type == EXPR_CONSTANT)
2874 {
2875 have_do_end = true;
2876 mpz_init_set (do_end, dl->ext.iterator->end->value.integer);
2877 }
2878 else
2879 have_do_end = false;
2880
2881 if (!have_do_start && !have_do_end)
2882 return 0;
2883
2884 /* No warning inside a zero-trip loop. */
2885 if (have_do_start && have_do_end)
2886 {
2887 int cmp;
2888
2889 cmp = mpz_cmp (do_end, do_start);
2890 if ((sgn > 0 && cmp < 0) || (sgn < 0 && cmp > 0))
2891 break;
2892 }
2893
2894 /* May have to correct the end value if the step does not equal
2895 one. */
2896 if (have_do_start && have_do_end && mpz_cmp_ui (do_step, 1) != 0)
2897 {
2898 mpz_t diff, rem;
2899
2900 mpz_init (diff);
2901 mpz_init (rem);
2902 mpz_sub (diff, do_end, do_start);
2903 mpz_tdiv_r (rem, diff, do_step);
2904 mpz_sub (do_end, do_end, rem);
2905 mpz_clear (diff);
2906 mpz_clear (rem);
2907 }
2908
2909 for (i = 0; i< ar->dimen; i++)
2910 {
2911 mpz_t val;
2912 if (ar->dimen_type[i] == DIMEN_ELEMENT && have_do_start
2913 && insert_index (ar->start[i], do_sym, do_start, val))
2914 {
2915 if (ar->as->lower[i]
2916 && ar->as->lower[i]->expr_type == EXPR_CONSTANT
2917 && mpz_cmp (val, ar->as->lower[i]->value.integer) < 0)
2918 gfc_warning (warn, "Array reference at %L out of bounds "
2919 "(%ld < %ld) in loop beginning at %L",
2920 &ar->start[i]->where, mpz_get_si (val),
2921 mpz_get_si (ar->as->lower[i]->value.integer),
2922 &doloop_list[j].c->loc);
2923
2924 if (ar->as->upper[i]
2925 && ar->as->upper[i]->expr_type == EXPR_CONSTANT
2926 && mpz_cmp (val, ar->as->upper[i]->value.integer) > 0)
2927 gfc_warning (warn, "Array reference at %L out of bounds "
2928 "(%ld > %ld) in loop beginning at %L",
2929 &ar->start[i]->where, mpz_get_si (val),
2930 mpz_get_si (ar->as->upper[i]->value.integer),
2931 &doloop_list[j].c->loc);
2932
2933 mpz_clear (val);
2934 }
2935
2936 if (ar->dimen_type[i] == DIMEN_ELEMENT && have_do_end
2937 && insert_index (ar->start[i], do_sym, do_end, val))
2938 {
2939 if (ar->as->lower[i]
2940 && ar->as->lower[i]->expr_type == EXPR_CONSTANT
2941 && mpz_cmp (val, ar->as->lower[i]->value.integer) < 0)
2942 gfc_warning (warn, "Array reference at %L out of bounds "
2943 "(%ld < %ld) in loop beginning at %L",
2944 &ar->start[i]->where, mpz_get_si (val),
2945 mpz_get_si (ar->as->lower[i]->value.integer),
2946 &doloop_list[j].c->loc);
2947
2948 if (ar->as->upper[i]
2949 && ar->as->upper[i]->expr_type == EXPR_CONSTANT
2950 && mpz_cmp (val, ar->as->upper[i]->value.integer) > 0)
2951 gfc_warning (warn, "Array reference at %L out of bounds "
2952 "(%ld > %ld) in loop beginning at %L",
2953 &ar->start[i]->where, mpz_get_si (val),
2954 mpz_get_si (ar->as->upper[i]->value.integer),
2955 &doloop_list[j].c->loc);
2956
2957 mpz_clear (val);
2958 }
2959 }
2960 }
2961 }
2962 }
2963 return 0;
2964 }
2965 /* Function for functions checking that we do not pass a DO variable
2966 to an INTENT(OUT) or INTENT(INOUT) dummy variable. */
2967
2968 static int
2969 do_intent (gfc_expr **e)
2970 {
2971 gfc_formal_arglist *f;
2972 gfc_actual_arglist *a;
2973 gfc_expr *expr;
2974 gfc_code *dl;
2975 do_t *lp;
2976 int i;
2977 gfc_symbol *sym;
2978
2979 expr = *e;
2980 if (expr->expr_type != EXPR_FUNCTION)
2981 return 0;
2982
2983 /* Intrinsic functions don't modify their arguments. */
2984
2985 if (expr->value.function.isym)
2986 return 0;
2987
2988 sym = expr->value.function.esym;
2989 if (sym == NULL)
2990 return 0;
2991
2992 if (sym->attr.contained)
2993 {
2994 FOR_EACH_VEC_ELT (doloop_list, i, lp)
2995 {
2996 contained_info info;
2997 gfc_namespace *ns;
2998
2999 dl = lp->c;
3000 info.do_var = dl->ext.iterator->var->symtree->n.sym;
3001 info.procedure = sym;
3002 info.where_do = expr->where;
3003 /* Look contained procedures under the namespace of the
3004 variable. */
3005 for (ns = info.do_var->ns->contained; ns; ns = ns->sibling)
3006 if (ns->proc_name && ns->proc_name == sym)
3007 gfc_code_walker (&ns->code, doloop_contained_procedure_code,
3008 dummy_expr_callback, &info);
3009 }
3010 }
3011
3012 f = gfc_sym_get_dummy_args (sym);
3013
3014 /* Without a formal arglist, there is only unknown INTENT,
3015 which we don't check for. */
3016 if (f == NULL)
3017 return 0;
3018
3019 a = expr->value.function.actual;
3020
3021 while (a && f)
3022 {
3023 FOR_EACH_VEC_ELT (doloop_list, i, lp)
3024 {
3025 gfc_symbol *do_sym;
3026 dl = lp->c;
3027 if (dl == NULL)
3028 break;
3029
3030 do_sym = dl->ext.iterator->var->symtree->n.sym;
3031
3032 if (a->expr && a->expr->symtree
3033 && a->expr->symtree->n.sym == do_sym)
3034 {
3035 if (f->sym->attr.intent == INTENT_OUT)
3036 gfc_error_now ("Variable %qs at %L set to undefined value "
3037 "inside loop beginning at %L as INTENT(OUT) "
3038 "argument to function %qs", do_sym->name,
3039 &a->expr->where, &doloop_list[i].c->loc,
3040 expr->symtree->n.sym->name);
3041 else if (f->sym->attr.intent == INTENT_INOUT)
3042 gfc_error_now ("Variable %qs at %L not definable inside loop"
3043 " beginning at %L as INTENT(INOUT) argument to"
3044 " function %qs", do_sym->name,
3045 &a->expr->where, &doloop_list[i].c->loc,
3046 expr->symtree->n.sym->name);
3047 }
3048 }
3049 a = a->next;
3050 f = f->next;
3051 }
3052
3053 return 0;
3054 }
3055
3056 static void
3057 doloop_warn (gfc_namespace *ns)
3058 {
3059 gfc_code_walker (&ns->code, doloop_code, do_function, NULL);
3060
3061 for (ns = ns->contained; ns; ns = ns->sibling)
3062 {
3063 if (ns->code == NULL || ns->code->op != EXEC_BLOCK)
3064 doloop_warn (ns);
3065 }
3066 }
3067
3068 /* This selction deals with inlining calls to MATMUL. */
3069
3070 /* Replace calls to matmul outside of straight assignments with a temporary
3071 variable so that later inlining will work. */
3072
3073 static int
3074 matmul_to_var_expr (gfc_expr **ep, int *walk_subtrees ATTRIBUTE_UNUSED,
3075 void *data)
3076 {
3077 gfc_expr *e, *n;
3078 bool *found = (bool *) data;
3079
3080 e = *ep;
3081
3082 if (e->expr_type != EXPR_FUNCTION
3083 || e->value.function.isym == NULL
3084 || e->value.function.isym->id != GFC_ISYM_MATMUL)
3085 return 0;
3086
3087 if (forall_level > 0 || iterator_level > 0 || in_omp_workshare
3088 || in_omp_atomic || in_where || in_assoc_list)
3089 return 0;
3090
3091 /* Check if this is already in the form c = matmul(a,b). */
3092
3093 if ((*current_code)->expr2 == e)
3094 return 0;
3095
3096 n = create_var (e, "matmul");
3097
3098 /* If create_var is unable to create a variable (for example if
3099 -fno-realloc-lhs is in force with a variable that does not have bounds
3100 known at compile-time), just return. */
3101
3102 if (n == NULL)
3103 return 0;
3104
3105 *ep = n;
3106 *found = true;
3107 return 0;
3108 }
3109
3110 /* Set current_code and associated variables so that matmul_to_var_expr can
3111 work. */
3112
3113 static int
3114 matmul_to_var_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
3115 void *data ATTRIBUTE_UNUSED)
3116 {
3117 if (current_code != c)
3118 {
3119 current_code = c;
3120 inserted_block = NULL;
3121 changed_statement = NULL;
3122 }
3123
3124 return 0;
3125 }
3126
3127
3128 /* Take a statement of the shape c = matmul(a,b) and create temporaries
3129 for a and b if there is a dependency between the arguments and the
3130 result variable or if a or b are the result of calculations that cannot
3131 be handled by the inliner. */
3132
3133 static int
3134 matmul_temp_args (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
3135 void *data ATTRIBUTE_UNUSED)
3136 {
3137 gfc_expr *expr1, *expr2;
3138 gfc_code *co;
3139 gfc_actual_arglist *a, *b;
3140 bool a_tmp, b_tmp;
3141 gfc_expr *matrix_a, *matrix_b;
3142 bool conjg_a, conjg_b, transpose_a, transpose_b;
3143
3144 co = *c;
3145
3146 if (co->op != EXEC_ASSIGN)
3147 return 0;
3148
3149 if (forall_level > 0 || iterator_level > 0 || in_omp_workshare
3150 || in_omp_atomic || in_where)
3151 return 0;
3152
3153 /* This has some duplication with inline_matmul_assign. This
3154 is because the creation of temporary variables could still fail,
3155 and inline_matmul_assign still needs to be able to handle these
3156 cases. */
3157 expr1 = co->expr1;
3158 expr2 = co->expr2;
3159
3160 if (expr2->expr_type != EXPR_FUNCTION
3161 || expr2->value.function.isym == NULL
3162 || expr2->value.function.isym->id != GFC_ISYM_MATMUL)
3163 return 0;
3164
3165 a_tmp = false;
3166 a = expr2->value.function.actual;
3167 matrix_a = check_conjg_transpose_variable (a->expr, &conjg_a, &transpose_a);
3168 if (matrix_a != NULL)
3169 {
3170 if (matrix_a->expr_type == EXPR_VARIABLE
3171 && (gfc_check_dependency (matrix_a, expr1, true)
3172 || gfc_has_dimen_vector_ref (matrix_a)))
3173 a_tmp = true;
3174 }
3175 else
3176 a_tmp = true;
3177
3178 b_tmp = false;
3179 b = a->next;
3180 matrix_b = check_conjg_transpose_variable (b->expr, &conjg_b, &transpose_b);
3181 if (matrix_b != NULL)
3182 {
3183 if (matrix_b->expr_type == EXPR_VARIABLE
3184 && (gfc_check_dependency (matrix_b, expr1, true)
3185 || gfc_has_dimen_vector_ref (matrix_b)))
3186 b_tmp = true;
3187 }
3188 else
3189 b_tmp = true;
3190
3191 if (!a_tmp && !b_tmp)
3192 return 0;
3193
3194 current_code = c;
3195 inserted_block = NULL;
3196 changed_statement = NULL;
3197 if (a_tmp)
3198 {
3199 gfc_expr *at;
3200 at = create_var (a->expr,"mma");
3201 if (at)
3202 a->expr = at;
3203 }
3204 if (b_tmp)
3205 {
3206 gfc_expr *bt;
3207 bt = create_var (b->expr,"mmb");
3208 if (bt)
3209 b->expr = bt;
3210 }
3211 return 0;
3212 }
3213
3214 /* Auxiliary function to build and simplify an array inquiry function.
3215 dim is zero-based. */
3216
3217 static gfc_expr *
3218 get_array_inq_function (gfc_isym_id id, gfc_expr *e, int dim, int okind = 0)
3219 {
3220 gfc_expr *fcn;
3221 gfc_expr *dim_arg, *kind;
3222 const char *name;
3223 gfc_expr *ec;
3224
3225 switch (id)
3226 {
3227 case GFC_ISYM_LBOUND:
3228 name = "_gfortran_lbound";
3229 break;
3230
3231 case GFC_ISYM_UBOUND:
3232 name = "_gfortran_ubound";
3233 break;
3234
3235 case GFC_ISYM_SIZE:
3236 name = "_gfortran_size";
3237 break;
3238
3239 default:
3240 gcc_unreachable ();
3241 }
3242
3243 dim_arg = gfc_get_int_expr (gfc_default_integer_kind, &e->where, dim);
3244 if (okind != 0)
3245 kind = gfc_get_int_expr (gfc_default_integer_kind, &e->where,
3246 okind);
3247 else
3248 kind = gfc_get_int_expr (gfc_default_integer_kind, &e->where,
3249 gfc_index_integer_kind);
3250
3251 ec = gfc_copy_expr (e);
3252
3253 /* No bounds checking, this will be done before the loops if -fcheck=bounds
3254 is in effect. */
3255 ec->no_bounds_check = 1;
3256 fcn = gfc_build_intrinsic_call (current_ns, id, name, e->where, 3,
3257 ec, dim_arg, kind);
3258 gfc_simplify_expr (fcn, 0);
3259 fcn->no_bounds_check = 1;
3260 return fcn;
3261 }
3262
3263 /* Builds a logical expression. */
3264
3265 static gfc_expr*
3266 build_logical_expr (gfc_intrinsic_op op, gfc_expr *e1, gfc_expr *e2)
3267 {
3268 gfc_typespec ts;
3269 gfc_expr *res;
3270
3271 ts.type = BT_LOGICAL;
3272 ts.kind = gfc_default_logical_kind;
3273 res = gfc_get_expr ();
3274 res->where = e1->where;
3275 res->expr_type = EXPR_OP;
3276 res->value.op.op = op;
3277 res->value.op.op1 = e1;
3278 res->value.op.op2 = e2;
3279 res->ts = ts;
3280
3281 return res;
3282 }
3283
3284
3285 /* Return an operation of one two gfc_expr (one if e2 is NULL). This assumes
3286 compatible typespecs. */
3287
3288 static gfc_expr *
3289 get_operand (gfc_intrinsic_op op, gfc_expr *e1, gfc_expr *e2)
3290 {
3291 gfc_expr *res;
3292
3293 res = gfc_get_expr ();
3294 res->ts = e1->ts;
3295 res->where = e1->where;
3296 res->expr_type = EXPR_OP;
3297 res->value.op.op = op;
3298 res->value.op.op1 = e1;
3299 res->value.op.op2 = e2;
3300 gfc_simplify_expr (res, 0);
3301 return res;
3302 }
3303
3304 /* Generate the IF statement for a runtime check if we want to do inlining or
3305 not - putting in the code for both branches and putting it into the syntax
3306 tree is the caller's responsibility. For fixed array sizes, this should be
3307 removed by DCE. Only called for rank-two matrices A and B. */
3308
3309 static gfc_code *
3310 inline_limit_check (gfc_expr *a, gfc_expr *b, int limit, int rank_a)
3311 {
3312 gfc_expr *inline_limit;
3313 gfc_code *if_1, *if_2, *else_2;
3314 gfc_expr *b2, *a2, *a1, *m1, *m2;
3315 gfc_typespec ts;
3316 gfc_expr *cond;
3317
3318 gcc_assert (rank_a == 1 || rank_a == 2);
3319
3320 /* Calculation is done in real to avoid integer overflow. */
3321
3322 inline_limit = gfc_get_constant_expr (BT_REAL, gfc_default_real_kind,
3323 &a->where);
3324 mpfr_set_si (inline_limit->value.real, limit, GFC_RND_MODE);
3325
3326 /* Set the limit according to the rank. */
3327 mpfr_pow_ui (inline_limit->value.real, inline_limit->value.real, rank_a + 1,
3328 GFC_RND_MODE);
3329
3330 a1 = get_array_inq_function (GFC_ISYM_SIZE, a, 1);
3331
3332 /* For a_rank = 1, must use one as the size of a along the second
3333 dimension as to avoid too much code duplication. */
3334
3335 if (rank_a == 2)
3336 a2 = get_array_inq_function (GFC_ISYM_SIZE, a, 2);
3337 else
3338 a2 = gfc_get_int_expr (gfc_index_integer_kind, &a->where, 1);
3339
3340 b2 = get_array_inq_function (GFC_ISYM_SIZE, b, 2);
3341
3342 gfc_clear_ts (&ts);
3343 ts.type = BT_REAL;
3344 ts.kind = gfc_default_real_kind;
3345 gfc_convert_type_warn (a1, &ts, 2, 0);
3346 gfc_convert_type_warn (a2, &ts, 2, 0);
3347 gfc_convert_type_warn (b2, &ts, 2, 0);
3348
3349 m1 = get_operand (INTRINSIC_TIMES, a1, a2);
3350 m2 = get_operand (INTRINSIC_TIMES, m1, b2);
3351
3352 cond = build_logical_expr (INTRINSIC_LE, m2, inline_limit);
3353 gfc_simplify_expr (cond, 0);
3354
3355 else_2 = XCNEW (gfc_code);
3356 else_2->op = EXEC_IF;
3357 else_2->loc = a->where;
3358
3359 if_2 = XCNEW (gfc_code);
3360 if_2->op = EXEC_IF;
3361 if_2->expr1 = cond;
3362 if_2->loc = a->where;
3363 if_2->block = else_2;
3364
3365 if_1 = XCNEW (gfc_code);
3366 if_1->op = EXEC_IF;
3367 if_1->block = if_2;
3368 if_1->loc = a->where;
3369
3370 return if_1;
3371 }
3372
3373
3374 /* Insert code to issue a runtime error if the expressions are not equal. */
3375
3376 static gfc_code *
3377 runtime_error_ne (gfc_expr *e1, gfc_expr *e2, const char *msg)
3378 {
3379 gfc_expr *cond;
3380 gfc_code *if_1, *if_2;
3381 gfc_code *c;
3382 gfc_actual_arglist *a1, *a2, *a3;
3383
3384 gcc_assert (e1->where.lb);
3385 /* Build the call to runtime_error. */
3386 c = XCNEW (gfc_code);
3387 c->op = EXEC_CALL;
3388 c->loc = e1->where;
3389
3390 /* Get a null-terminated message string. */
3391
3392 a1 = gfc_get_actual_arglist ();
3393 a1->expr = gfc_get_character_expr (gfc_default_character_kind, &e1->where,
3394 msg, strlen(msg)+1);
3395 c->ext.actual = a1;
3396
3397 /* Pass the value of the first expression. */
3398 a2 = gfc_get_actual_arglist ();
3399 a2->expr = gfc_copy_expr (e1);
3400 a1->next = a2;
3401
3402 /* Pass the value of the second expression. */
3403 a3 = gfc_get_actual_arglist ();
3404 a3->expr = gfc_copy_expr (e2);
3405 a2->next = a3;
3406
3407 gfc_check_fe_runtime_error (c->ext.actual);
3408 gfc_resolve_fe_runtime_error (c);
3409
3410 if_2 = XCNEW (gfc_code);
3411 if_2->op = EXEC_IF;
3412 if_2->loc = e1->where;
3413 if_2->next = c;
3414
3415 if_1 = XCNEW (gfc_code);
3416 if_1->op = EXEC_IF;
3417 if_1->block = if_2;
3418 if_1->loc = e1->where;
3419
3420 cond = build_logical_expr (INTRINSIC_NE, e1, e2);
3421 gfc_simplify_expr (cond, 0);
3422 if_2->expr1 = cond;
3423
3424 return if_1;
3425 }
3426
3427 /* Handle matrix reallocation. Caller is responsible to insert into
3428 the code tree.
3429
3430 For the two-dimensional case, build
3431
3432 if (allocated(c)) then
3433 if (size(c,1) /= size(a,1) .or. size(c,2) /= size(b,2)) then
3434 deallocate(c)
3435 allocate (c(size(a,1), size(b,2)))
3436 end if
3437 else
3438 allocate (c(size(a,1),size(b,2)))
3439 end if
3440
3441 and for the other cases correspondingly.
3442 */
3443
3444 static gfc_code *
3445 matmul_lhs_realloc (gfc_expr *c, gfc_expr *a, gfc_expr *b,
3446 enum matrix_case m_case)
3447 {
3448
3449 gfc_expr *allocated, *alloc_expr;
3450 gfc_code *if_alloc_1, *if_alloc_2, *if_size_1, *if_size_2;
3451 gfc_code *else_alloc;
3452 gfc_code *deallocate, *allocate1, *allocate_else;
3453 gfc_array_ref *ar;
3454 gfc_expr *cond, *ne1, *ne2;
3455
3456 if (warn_realloc_lhs)
3457 gfc_warning (OPT_Wrealloc_lhs,
3458 "Code for reallocating the allocatable array at %L will "
3459 "be added", &c->where);
3460
3461 alloc_expr = gfc_copy_expr (c);
3462
3463 ar = gfc_find_array_ref (alloc_expr);
3464 gcc_assert (ar && ar->type == AR_FULL);
3465
3466 /* c comes in as a full ref. Change it into a copy and make it into an
3467 element ref so it has the right form for ALLOCATE. In the same
3468 switch statement, also generate the size comparison for the secod IF
3469 statement. */
3470
3471 ar->type = AR_ELEMENT;
3472
3473 switch (m_case)
3474 {
3475 case A2B2:
3476 ar->start[0] = get_array_inq_function (GFC_ISYM_SIZE, a, 1);
3477 ar->start[1] = get_array_inq_function (GFC_ISYM_SIZE, b, 2);
3478 ne1 = build_logical_expr (INTRINSIC_NE,
3479 get_array_inq_function (GFC_ISYM_SIZE, c, 1),
3480 get_array_inq_function (GFC_ISYM_SIZE, a, 1));
3481 ne2 = build_logical_expr (INTRINSIC_NE,
3482 get_array_inq_function (GFC_ISYM_SIZE, c, 2),
3483 get_array_inq_function (GFC_ISYM_SIZE, b, 2));
3484 cond = build_logical_expr (INTRINSIC_OR, ne1, ne2);
3485 break;
3486
3487 case A2B2T:
3488 ar->start[0] = get_array_inq_function (GFC_ISYM_SIZE, a, 1);
3489 ar->start[1] = get_array_inq_function (GFC_ISYM_SIZE, b, 1);
3490
3491 ne1 = build_logical_expr (INTRINSIC_NE,
3492 get_array_inq_function (GFC_ISYM_SIZE, c, 1),
3493 get_array_inq_function (GFC_ISYM_SIZE, a, 1));
3494 ne2 = build_logical_expr (INTRINSIC_NE,
3495 get_array_inq_function (GFC_ISYM_SIZE, c, 2),
3496 get_array_inq_function (GFC_ISYM_SIZE, b, 1));
3497 cond = build_logical_expr (INTRINSIC_OR, ne1, ne2);
3498 break;
3499
3500 case A2TB2:
3501
3502 ar->start[0] = get_array_inq_function (GFC_ISYM_SIZE, a, 2);
3503 ar->start[1] = get_array_inq_function (GFC_ISYM_SIZE, b, 2);
3504
3505 ne1 = build_logical_expr (INTRINSIC_NE,
3506 get_array_inq_function (GFC_ISYM_SIZE, c, 1),
3507 get_array_inq_function (GFC_ISYM_SIZE, a, 2));
3508 ne2 = build_logical_expr (INTRINSIC_NE,
3509 get_array_inq_function (GFC_ISYM_SIZE, c, 2),
3510 get_array_inq_function (GFC_ISYM_SIZE, b, 2));
3511 cond = build_logical_expr (INTRINSIC_OR, ne1, ne2);
3512 break;
3513
3514 case A2B1:
3515 ar->start[0] = get_array_inq_function (GFC_ISYM_SIZE, a, 1);
3516 cond = build_logical_expr (INTRINSIC_NE,
3517 get_array_inq_function (GFC_ISYM_SIZE, c, 1),
3518 get_array_inq_function (GFC_ISYM_SIZE, a, 2));
3519 break;
3520
3521 case A1B2:
3522 ar->start[0] = get_array_inq_function (GFC_ISYM_SIZE, b, 2);
3523 cond = build_logical_expr (INTRINSIC_NE,
3524 get_array_inq_function (GFC_ISYM_SIZE, c, 1),
3525 get_array_inq_function (GFC_ISYM_SIZE, b, 2));
3526 break;
3527
3528 case A2TB2T:
3529 /* This can only happen for BLAS, we do not handle that case in
3530 inline mamtul. */
3531 ar->start[0] = get_array_inq_function (GFC_ISYM_SIZE, a, 2);
3532 ar->start[1] = get_array_inq_function (GFC_ISYM_SIZE, b, 1);
3533
3534 ne1 = build_logical_expr (INTRINSIC_NE,
3535 get_array_inq_function (GFC_ISYM_SIZE, c, 1),
3536 get_array_inq_function (GFC_ISYM_SIZE, a, 2));
3537 ne2 = build_logical_expr (INTRINSIC_NE,
3538 get_array_inq_function (GFC_ISYM_SIZE, c, 2),
3539 get_array_inq_function (GFC_ISYM_SIZE, b, 1));
3540
3541 cond = build_logical_expr (INTRINSIC_OR, ne1, ne2);
3542 break;
3543
3544 default:
3545 gcc_unreachable();
3546
3547 }
3548
3549 gfc_simplify_expr (cond, 0);
3550
3551 /* We need two identical allocate statements in two
3552 branches of the IF statement. */
3553
3554 allocate1 = XCNEW (gfc_code);
3555 allocate1->op = EXEC_ALLOCATE;
3556 allocate1->ext.alloc.list = gfc_get_alloc ();
3557 allocate1->loc = c->where;
3558 allocate1->ext.alloc.list->expr = gfc_copy_expr (alloc_expr);
3559
3560 allocate_else = XCNEW (gfc_code);
3561 allocate_else->op = EXEC_ALLOCATE;
3562 allocate_else->ext.alloc.list = gfc_get_alloc ();
3563 allocate_else->loc = c->where;
3564 allocate_else->ext.alloc.list->expr = alloc_expr;
3565
3566 allocated = gfc_build_intrinsic_call (current_ns, GFC_ISYM_ALLOCATED,
3567 "_gfortran_allocated", c->where,
3568 1, gfc_copy_expr (c));
3569
3570 deallocate = XCNEW (gfc_code);
3571 deallocate->op = EXEC_DEALLOCATE;
3572 deallocate->ext.alloc.list = gfc_get_alloc ();
3573 deallocate->ext.alloc.list->expr = gfc_copy_expr (c);
3574 deallocate->next = allocate1;
3575 deallocate->loc = c->where;
3576
3577 if_size_2 = XCNEW (gfc_code);
3578 if_size_2->op = EXEC_IF;
3579 if_size_2->expr1 = cond;
3580 if_size_2->loc = c->where;
3581 if_size_2->next = deallocate;
3582
3583 if_size_1 = XCNEW (gfc_code);
3584 if_size_1->op = EXEC_IF;
3585 if_size_1->block = if_size_2;
3586 if_size_1->loc = c->where;
3587
3588 else_alloc = XCNEW (gfc_code);
3589 else_alloc->op = EXEC_IF;
3590 else_alloc->loc = c->where;
3591 else_alloc->next = allocate_else;
3592
3593 if_alloc_2 = XCNEW (gfc_code);
3594 if_alloc_2->op = EXEC_IF;
3595 if_alloc_2->expr1 = allocated;
3596 if_alloc_2->loc = c->where;
3597 if_alloc_2->next = if_size_1;
3598 if_alloc_2->block = else_alloc;
3599
3600 if_alloc_1 = XCNEW (gfc_code);
3601 if_alloc_1->op = EXEC_IF;
3602 if_alloc_1->block = if_alloc_2;
3603 if_alloc_1->loc = c->where;
3604
3605 return if_alloc_1;
3606 }
3607
3608 /* Callback function for has_function_or_op. */
3609
3610 static int
3611 is_function_or_op (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
3612 void *data ATTRIBUTE_UNUSED)
3613 {
3614 if ((*e) == 0)
3615 return 0;
3616 else
3617 return (*e)->expr_type == EXPR_FUNCTION
3618 || (*e)->expr_type == EXPR_OP;
3619 }
3620
3621 /* Returns true if the expression contains a function. */
3622
3623 static bool
3624 has_function_or_op (gfc_expr **e)
3625 {
3626 if (e == NULL)
3627 return false;
3628 else
3629 return gfc_expr_walker (e, is_function_or_op, NULL);
3630 }
3631
3632 /* Freeze (assign to a temporary variable) a single expression. */
3633
3634 static void
3635 freeze_expr (gfc_expr **ep)
3636 {
3637 gfc_expr *ne;
3638 if (has_function_or_op (ep))
3639 {
3640 ne = create_var (*ep, "freeze");
3641 *ep = ne;
3642 }
3643 }
3644
3645 /* Go through an expression's references and assign them to temporary
3646 variables if they contain functions. This is usually done prior to
3647 front-end scalarization to avoid multiple invocations of functions. */
3648
3649 static void
3650 freeze_references (gfc_expr *e)
3651 {
3652 gfc_ref *r;
3653 gfc_array_ref *ar;
3654 int i;
3655
3656 for (r=e->ref; r; r=r->next)
3657 {
3658 if (r->type == REF_SUBSTRING)
3659 {
3660 if (r->u.ss.start != NULL)
3661 freeze_expr (&r->u.ss.start);
3662
3663 if (r->u.ss.end != NULL)
3664 freeze_expr (&r->u.ss.end);
3665 }
3666 else if (r->type == REF_ARRAY)
3667 {
3668 ar = &r->u.ar;
3669 switch (ar->type)
3670 {
3671 case AR_FULL:
3672 break;
3673
3674 case AR_SECTION:
3675 for (i=0; i<ar->dimen; i++)
3676 {
3677 if (ar->dimen_type[i] == DIMEN_RANGE)
3678 {
3679 freeze_expr (&ar->start[i]);
3680 freeze_expr (&ar->end[i]);
3681 freeze_expr (&ar->stride[i]);
3682 }
3683 else if (ar->dimen_type[i] == DIMEN_ELEMENT)
3684 {
3685 freeze_expr (&ar->start[i]);
3686 }
3687 }
3688 break;
3689
3690 case AR_ELEMENT:
3691 for (i=0; i<ar->dimen; i++)
3692 freeze_expr (&ar->start[i]);
3693 break;
3694
3695 default:
3696 break;
3697 }
3698 }
3699 }
3700 }
3701
3702 /* Convert to gfc_index_integer_kind if needed, just do a copy otherwise. */
3703
3704 static gfc_expr *
3705 convert_to_index_kind (gfc_expr *e)
3706 {
3707 gfc_expr *res;
3708
3709 gcc_assert (e != NULL);
3710
3711 res = gfc_copy_expr (e);
3712
3713 gcc_assert (e->ts.type == BT_INTEGER);
3714
3715 if (res->ts.kind != gfc_index_integer_kind)
3716 {
3717 gfc_typespec ts;
3718 gfc_clear_ts (&ts);
3719 ts.type = BT_INTEGER;
3720 ts.kind = gfc_index_integer_kind;
3721
3722 gfc_convert_type_warn (e, &ts, 2, 0);
3723 }
3724
3725 return res;
3726 }
3727
3728 /* Function to create a DO loop including creation of the
3729 iteration variable. gfc_expr are copied.*/
3730
3731 static gfc_code *
3732 create_do_loop (gfc_expr *start, gfc_expr *end, gfc_expr *step, locus *where,
3733 gfc_namespace *ns, char *vname)
3734 {
3735
3736 char name[GFC_MAX_SYMBOL_LEN +1];
3737 gfc_symtree *symtree;
3738 gfc_symbol *symbol;
3739 gfc_expr *i;
3740 gfc_code *n, *n2;
3741
3742 /* Create an expression for the iteration variable. */
3743 if (vname)
3744 sprintf (name, "__var_%d_do_%s", var_num++, vname);
3745 else
3746 sprintf (name, "__var_%d_do", var_num++);
3747
3748
3749 if (gfc_get_sym_tree (name, ns, &symtree, false) != 0)
3750 gcc_unreachable ();
3751
3752 /* Create the loop variable. */
3753
3754 symbol = symtree->n.sym;
3755 symbol->ts.type = BT_INTEGER;
3756 symbol->ts.kind = gfc_index_integer_kind;
3757 symbol->attr.flavor = FL_VARIABLE;
3758 symbol->attr.referenced = 1;
3759 symbol->attr.dimension = 0;
3760 symbol->attr.fe_temp = 1;
3761 gfc_commit_symbol (symbol);
3762
3763 i = gfc_get_expr ();
3764 i->expr_type = EXPR_VARIABLE;
3765 i->ts = symbol->ts;
3766 i->rank = 0;
3767 i->where = *where;
3768 i->symtree = symtree;
3769
3770 /* ... and the nested DO statements. */
3771 n = XCNEW (gfc_code);
3772 n->op = EXEC_DO;
3773 n->loc = *where;
3774 n->ext.iterator = gfc_get_iterator ();
3775 n->ext.iterator->var = i;
3776 n->ext.iterator->start = convert_to_index_kind (start);
3777 n->ext.iterator->end = convert_to_index_kind (end);
3778 if (step)
3779 n->ext.iterator->step = convert_to_index_kind (step);
3780 else
3781 n->ext.iterator->step = gfc_get_int_expr (gfc_index_integer_kind,
3782 where, 1);
3783
3784 n2 = XCNEW (gfc_code);
3785 n2->op = EXEC_DO;
3786 n2->loc = *where;
3787 n2->next = NULL;
3788 n->block = n2;
3789 return n;
3790 }
3791
3792 /* Get the upper bound of the DO loops for matmul along a dimension. This
3793 is one-based. */
3794
3795 static gfc_expr*
3796 get_size_m1 (gfc_expr *e, int dimen)
3797 {
3798 mpz_t size;
3799 gfc_expr *res;
3800
3801 if (gfc_array_dimen_size (e, dimen - 1, &size))
3802 {
3803 res = gfc_get_constant_expr (BT_INTEGER,
3804 gfc_index_integer_kind, &e->where);
3805 mpz_sub_ui (res->value.integer, size, 1);
3806 mpz_clear (size);
3807 }
3808 else
3809 {
3810 res = get_operand (INTRINSIC_MINUS,
3811 get_array_inq_function (GFC_ISYM_SIZE, e, dimen),
3812 gfc_get_int_expr (gfc_index_integer_kind,
3813 &e->where, 1));
3814 gfc_simplify_expr (res, 0);
3815 }
3816
3817 return res;
3818 }
3819
3820 /* Function to return a scalarized expression. It is assumed that indices are
3821 zero based to make generation of DO loops easier. A zero as index will
3822 access the first element along a dimension. Single element references will
3823 be skipped. A NULL as an expression will be replaced by a full reference.
3824 This assumes that the index loops have gfc_index_integer_kind, and that all
3825 references have been frozen. */
3826
3827 static gfc_expr*
3828 scalarized_expr (gfc_expr *e_in, gfc_expr **index, int count_index)
3829 {
3830 gfc_array_ref *ar;
3831 int i;
3832 int rank;
3833 gfc_expr *e;
3834 int i_index;
3835 bool was_fullref;
3836
3837 e = gfc_copy_expr(e_in);
3838
3839 rank = e->rank;
3840
3841 ar = gfc_find_array_ref (e);
3842
3843 /* We scalarize count_index variables, reducing the rank by count_index. */
3844
3845 e->rank = rank - count_index;
3846
3847 was_fullref = ar->type == AR_FULL;
3848
3849 if (e->rank == 0)
3850 ar->type = AR_ELEMENT;
3851 else
3852 ar->type = AR_SECTION;
3853
3854 /* Loop over the indices. For each index, create the expression
3855 index * stride + lbound(e, dim). */
3856
3857 i_index = 0;
3858 for (i=0; i < ar->dimen; i++)
3859 {
3860 if (was_fullref || ar->dimen_type[i] == DIMEN_RANGE)
3861 {
3862 if (index[i_index] != NULL)
3863 {
3864 gfc_expr *lbound, *nindex;
3865 gfc_expr *loopvar;
3866
3867 loopvar = gfc_copy_expr (index[i_index]);
3868
3869 if (ar->stride[i])
3870 {
3871 gfc_expr *tmp;
3872
3873 tmp = gfc_copy_expr(ar->stride[i]);
3874 if (tmp->ts.kind != gfc_index_integer_kind)
3875 {
3876 gfc_typespec ts;
3877 gfc_clear_ts (&ts);
3878 ts.type = BT_INTEGER;
3879 ts.kind = gfc_index_integer_kind;
3880 gfc_convert_type (tmp, &ts, 2);
3881 }
3882 nindex = get_operand (INTRINSIC_TIMES, loopvar, tmp);
3883 }
3884 else
3885 nindex = loopvar;
3886
3887 /* Calculate the lower bound of the expression. */
3888 if (ar->start[i])
3889 {
3890 lbound = gfc_copy_expr (ar->start[i]);
3891 if (lbound->ts.kind != gfc_index_integer_kind)
3892 {
3893 gfc_typespec ts;
3894 gfc_clear_ts (&ts);
3895 ts.type = BT_INTEGER;
3896 ts.kind = gfc_index_integer_kind;
3897 gfc_convert_type (lbound, &ts, 2);
3898
3899 }
3900 }
3901 else
3902 {
3903 gfc_expr *lbound_e;
3904 gfc_ref *ref;
3905
3906 lbound_e = gfc_copy_expr (e_in);
3907
3908 for (ref = lbound_e->ref; ref; ref = ref->next)
3909 if (ref->type == REF_ARRAY
3910 && (ref->u.ar.type == AR_FULL
3911 || ref->u.ar.type == AR_SECTION))
3912 break;
3913
3914 if (ref->next)
3915 {
3916 gfc_free_ref_list (ref->next);
3917 ref->next = NULL;
3918 }
3919
3920 if (!was_fullref)
3921 {
3922 /* Look at full individual sections, like a(:). The first index
3923 is the lbound of a full ref. */
3924 int j;
3925 gfc_array_ref *ar;
3926 int to;
3927
3928 ar = &ref->u.ar;
3929
3930 /* For assumed size, we need to keep around the final
3931 reference in order not to get an error on resolution
3932 below, and we cannot use AR_FULL. */
3933
3934 if (ar->as->type == AS_ASSUMED_SIZE)
3935 {
3936 ar->type = AR_SECTION;
3937 to = ar->dimen - 1;
3938 }
3939 else
3940 {
3941 to = ar->dimen;
3942 ar->type = AR_FULL;
3943 }
3944
3945 for (j = 0; j < to; j++)
3946 {
3947 gfc_free_expr (ar->start[j]);
3948 ar->start[j] = NULL;
3949 gfc_free_expr (ar->end[j]);
3950 ar->end[j] = NULL;
3951 gfc_free_expr (ar->stride[j]);
3952 ar->stride[j] = NULL;
3953 }
3954
3955 /* We have to get rid of the shape, if there is one. Do
3956 so by freeing it and calling gfc_resolve to rebuild
3957 it, if necessary. */
3958
3959 if (lbound_e->shape)
3960 gfc_free_shape (&(lbound_e->shape), lbound_e->rank);
3961
3962 lbound_e->rank = ar->dimen;
3963 gfc_resolve_expr (lbound_e);
3964 }
3965 lbound = get_array_inq_function (GFC_ISYM_LBOUND, lbound_e,
3966 i + 1);
3967 gfc_free_expr (lbound_e);
3968 }
3969
3970 ar->dimen_type[i] = DIMEN_ELEMENT;
3971
3972 gfc_free_expr (ar->start[i]);
3973 ar->start[i] = get_operand (INTRINSIC_PLUS, nindex, lbound);
3974
3975 gfc_free_expr (ar->end[i]);
3976 ar->end[i] = NULL;
3977 gfc_free_expr (ar->stride[i]);
3978 ar->stride[i] = NULL;
3979 gfc_simplify_expr (ar->start[i], 0);
3980 }
3981 else if (was_fullref)
3982 {
3983 gfc_internal_error ("Scalarization using DIMEN_RANGE unimplemented");
3984 }
3985 i_index ++;
3986 }
3987 }
3988
3989 /* Bounds checking will be done before the loops if -fcheck=bounds
3990 is in effect. */
3991 e->no_bounds_check = 1;
3992 return e;
3993 }
3994
3995 /* Helper function to check for a dimen vector as subscript. */
3996
3997 bool
3998 gfc_has_dimen_vector_ref (gfc_expr *e)
3999 {
4000 gfc_array_ref *ar;
4001 int i;
4002
4003 ar = gfc_find_array_ref (e);
4004 gcc_assert (ar);
4005 if (ar->type == AR_FULL)
4006 return false;
4007
4008 for (i=0; i<ar->dimen; i++)
4009 if (ar->dimen_type[i] == DIMEN_VECTOR)
4010 return true;
4011
4012 return false;
4013 }
4014
4015 /* If handed an expression of the form
4016
4017 TRANSPOSE(CONJG(A))
4018
4019 check if A can be handled by matmul and return if there is an uneven number
4020 of CONJG calls. Return a pointer to the array when everything is OK, NULL
4021 otherwise. The caller has to check for the correct rank. */
4022
4023 static gfc_expr*
4024 check_conjg_transpose_variable (gfc_expr *e, bool *conjg, bool *transpose)
4025 {
4026 *conjg = false;
4027 *transpose = false;
4028
4029 do
4030 {
4031 if (e->expr_type == EXPR_VARIABLE)
4032 {
4033 gcc_assert (e->rank == 1 || e->rank == 2);
4034 return e;
4035 }
4036 else if (e->expr_type == EXPR_FUNCTION)
4037 {
4038 if (e->value.function.isym == NULL)
4039 return NULL;
4040
4041 if (e->value.function.isym->id == GFC_ISYM_CONJG)
4042 *conjg = !*conjg;
4043 else if (e->value.function.isym->id == GFC_ISYM_TRANSPOSE)
4044 *transpose = !*transpose;
4045 else return NULL;
4046 }
4047 else
4048 return NULL;
4049
4050 e = e->value.function.actual->expr;
4051 }
4052 while(1);
4053
4054 return NULL;
4055 }
4056
4057 /* Macros for unified error messages. */
4058
4059 #define B_ERROR_1 _("Incorrect extent in argument B in MATMUL intrinsic in " \
4060 "dimension 1: is %ld, should be %ld")
4061
4062 #define C_ERROR_1 _("Array bound mismatch for dimension 1 of array " \
4063 "(%ld/%ld)")
4064
4065 #define C_ERROR_2 _("Array bound mismatch for dimension 2 of array " \
4066 "(%ld/%ld)")
4067
4068
4069 /* Inline assignments of the form c = matmul(a,b).
4070 Handle only the cases currently where b and c are rank-two arrays.
4071
4072 This basically translates the code to
4073
4074 BLOCK
4075 integer i,j,k
4076 c = 0
4077 do j=0, size(b,2)-1
4078 do k=0, size(a, 2)-1
4079 do i=0, size(a, 1)-1
4080 c(i * stride(c,1) + lbound(c,1), j * stride(c,2) + lbound(c,2)) =
4081 c(i * stride(c,1) + lbound(c,1), j * stride(c,2) + lbound(c,2)) +
4082 a(i * stride(a,1) + lbound(a,1), k * stride(a,2) + lbound(a,2)) *
4083 b(k * stride(b,1) + lbound(b,1), j * stride(b,2) + lbound(b,2))
4084 end do
4085 end do
4086 end do
4087 END BLOCK
4088
4089 */
4090
4091 static int
4092 inline_matmul_assign (gfc_code **c, int *walk_subtrees,
4093 void *data ATTRIBUTE_UNUSED)
4094 {
4095 gfc_code *co = *c;
4096 gfc_expr *expr1, *expr2;
4097 gfc_expr *matrix_a, *matrix_b;
4098 gfc_actual_arglist *a, *b;
4099 gfc_code *do_1, *do_2, *do_3, *assign_zero, *assign_matmul;
4100 gfc_expr *zero_e;
4101 gfc_expr *u1, *u2, *u3;
4102 gfc_expr *list[2];
4103 gfc_expr *ascalar, *bscalar, *cscalar;
4104 gfc_expr *mult;
4105 gfc_expr *var_1, *var_2, *var_3;
4106 gfc_expr *zero;
4107 gfc_namespace *ns;
4108 gfc_intrinsic_op op_times, op_plus;
4109 enum matrix_case m_case;
4110 int i;
4111 gfc_code *if_limit = NULL;
4112 gfc_code **next_code_point;
4113 bool conjg_a, conjg_b, transpose_a, transpose_b;
4114 bool realloc_c;
4115
4116 if (co->op != EXEC_ASSIGN)
4117 return 0;
4118
4119 if (in_where || in_assoc_list)
4120 return 0;
4121
4122 /* The BLOCKS generated for the temporary variables and FORALL don't
4123 mix. */
4124 if (forall_level > 0)
4125 return 0;
4126
4127 /* For now don't do anything in OpenMP workshare, it confuses
4128 its translation, which expects only the allowed statements in there.
4129 We should figure out how to parallelize this eventually. */
4130 if (in_omp_workshare || in_omp_atomic)
4131 return 0;
4132
4133 expr1 = co->expr1;
4134 expr2 = co->expr2;
4135 if (expr2->expr_type != EXPR_FUNCTION
4136 || expr2->value.function.isym == NULL
4137 || expr2->value.function.isym->id != GFC_ISYM_MATMUL)
4138 return 0;
4139
4140 current_code = c;
4141 inserted_block = NULL;
4142 changed_statement = NULL;
4143
4144 a = expr2->value.function.actual;
4145 matrix_a = check_conjg_transpose_variable (a->expr, &conjg_a, &transpose_a);
4146 if (matrix_a == NULL)
4147 return 0;
4148
4149 b = a->next;
4150 matrix_b = check_conjg_transpose_variable (b->expr, &conjg_b, &transpose_b);
4151 if (matrix_b == NULL)
4152 return 0;
4153
4154 if (gfc_has_dimen_vector_ref (expr1) || gfc_has_dimen_vector_ref (matrix_a)
4155 || gfc_has_dimen_vector_ref (matrix_b))
4156 return 0;
4157
4158 /* We do not handle data dependencies yet. */
4159 if (gfc_check_dependency (expr1, matrix_a, true)
4160 || gfc_check_dependency (expr1, matrix_b, true))
4161 return 0;
4162
4163 m_case = none;
4164 if (matrix_a->rank == 2)
4165 {
4166 if (transpose_a)
4167 {
4168 if (matrix_b->rank == 2 && !transpose_b)
4169 m_case = A2TB2;
4170 }
4171 else
4172 {
4173 if (matrix_b->rank == 1)
4174 m_case = A2B1;
4175 else /* matrix_b->rank == 2 */
4176 {
4177 if (transpose_b)
4178 m_case = A2B2T;
4179 else
4180 m_case = A2B2;
4181 }
4182 }
4183 }
4184 else /* matrix_a->rank == 1 */
4185 {
4186 if (matrix_b->rank == 2)
4187 {
4188 if (!transpose_b)
4189 m_case = A1B2;
4190 }
4191 }
4192
4193 if (m_case == none)
4194 return 0;
4195
4196 /* We only handle assignment to numeric or logical variables. */
4197 switch(expr1->ts.type)
4198 {
4199 case BT_INTEGER:
4200 case BT_LOGICAL:
4201 case BT_REAL:
4202 case BT_COMPLEX:
4203 break;
4204
4205 default:
4206 return 0;
4207 }
4208
4209 ns = insert_block ();
4210
4211 /* Assign the type of the zero expression for initializing the resulting
4212 array, and the expression (+ and * for real, integer and complex;
4213 .and. and .or for logical. */
4214
4215 switch(expr1->ts.type)
4216 {
4217 case BT_INTEGER:
4218 zero_e = gfc_get_int_expr (expr1->ts.kind, &expr1->where, 0);
4219 op_times = INTRINSIC_TIMES;
4220 op_plus = INTRINSIC_PLUS;
4221 break;
4222
4223 case BT_LOGICAL:
4224 op_times = INTRINSIC_AND;
4225 op_plus = INTRINSIC_OR;
4226 zero_e = gfc_get_logical_expr (expr1->ts.kind, &expr1->where,
4227 0);
4228 break;
4229 case BT_REAL:
4230 zero_e = gfc_get_constant_expr (BT_REAL, expr1->ts.kind,
4231 &expr1->where);
4232 mpfr_set_si (zero_e->value.real, 0, GFC_RND_MODE);
4233 op_times = INTRINSIC_TIMES;
4234 op_plus = INTRINSIC_PLUS;
4235 break;
4236
4237 case BT_COMPLEX:
4238 zero_e = gfc_get_constant_expr (BT_COMPLEX, expr1->ts.kind,
4239 &expr1->where);
4240 mpc_set_si_si (zero_e->value.complex, 0, 0, GFC_RND_MODE);
4241 op_times = INTRINSIC_TIMES;
4242 op_plus = INTRINSIC_PLUS;
4243
4244 break;
4245
4246 default:
4247 gcc_unreachable();
4248 }
4249
4250 current_code = &ns->code;
4251
4252 /* Freeze the references, keeping track of how many temporary variables were
4253 created. */
4254 n_vars = 0;
4255 freeze_references (matrix_a);
4256 freeze_references (matrix_b);
4257 freeze_references (expr1);
4258
4259 if (n_vars == 0)
4260 next_code_point = current_code;
4261 else
4262 {
4263 next_code_point = &ns->code;
4264 for (i=0; i<n_vars; i++)
4265 next_code_point = &(*next_code_point)->next;
4266 }
4267
4268 /* Take care of the inline flag. If the limit check evaluates to a
4269 constant, dead code elimination will eliminate the unneeded branch. */
4270
4271 if (flag_inline_matmul_limit > 0
4272 && (matrix_a->rank == 1 || matrix_a->rank == 2)
4273 && matrix_b->rank == 2)
4274 {
4275 if_limit = inline_limit_check (matrix_a, matrix_b,
4276 flag_inline_matmul_limit,
4277 matrix_a->rank);
4278
4279 /* Insert the original statement into the else branch. */
4280 if_limit->block->block->next = co;
4281 co->next = NULL;
4282
4283 /* ... and the new ones go into the original one. */
4284 *next_code_point = if_limit;
4285 next_code_point = &if_limit->block->next;
4286 }
4287
4288 zero_e->no_bounds_check = 1;
4289
4290 assign_zero = XCNEW (gfc_code);
4291 assign_zero->op = EXEC_ASSIGN;
4292 assign_zero->loc = co->loc;
4293 assign_zero->expr1 = gfc_copy_expr (expr1);
4294 assign_zero->expr1->no_bounds_check = 1;
4295 assign_zero->expr2 = zero_e;
4296
4297 realloc_c = flag_realloc_lhs && gfc_is_reallocatable_lhs (expr1);
4298
4299 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
4300 {
4301 gfc_code *test;
4302 gfc_expr *a2, *b1, *c1, *c2, *a1, *b2;
4303
4304 switch (m_case)
4305 {
4306 case A2B1:
4307
4308 b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
4309 a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2);
4310 test = runtime_error_ne (b1, a2, B_ERROR_1);
4311 *next_code_point = test;
4312 next_code_point = &test->next;
4313
4314 if (!realloc_c)
4315 {
4316 c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1);
4317 a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1);
4318 test = runtime_error_ne (c1, a1, C_ERROR_1);
4319 *next_code_point = test;
4320 next_code_point = &test->next;
4321 }
4322 break;
4323
4324 case A1B2:
4325
4326 b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
4327 a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1);
4328 test = runtime_error_ne (b1, a1, B_ERROR_1);
4329 *next_code_point = test;
4330 next_code_point = &test->next;
4331
4332 if (!realloc_c)
4333 {
4334 c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1);
4335 b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2);
4336 test = runtime_error_ne (c1, b2, C_ERROR_1);
4337 *next_code_point = test;
4338 next_code_point = &test->next;
4339 }
4340 break;
4341
4342 case A2B2:
4343
4344 b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
4345 a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2);
4346 test = runtime_error_ne (b1, a2, B_ERROR_1);
4347 *next_code_point = test;
4348 next_code_point = &test->next;
4349
4350 if (!realloc_c)
4351 {
4352 c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1);
4353 a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1);
4354 test = runtime_error_ne (c1, a1, C_ERROR_1);
4355 *next_code_point = test;
4356 next_code_point = &test->next;
4357
4358 c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2);
4359 b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2);
4360 test = runtime_error_ne (c2, b2, C_ERROR_2);
4361 *next_code_point = test;
4362 next_code_point = &test->next;
4363 }
4364 break;
4365
4366 case A2B2T:
4367
4368 b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2);
4369 a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2);
4370 /* matrix_b is transposed, hence dimension 1 for the error message. */
4371 test = runtime_error_ne (b2, a2, B_ERROR_1);
4372 *next_code_point = test;
4373 next_code_point = &test->next;
4374
4375 if (!realloc_c)
4376 {
4377 c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1);
4378 a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1);
4379 test = runtime_error_ne (c1, a1, C_ERROR_1);
4380 *next_code_point = test;
4381 next_code_point = &test->next;
4382
4383 c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2);
4384 b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
4385 test = runtime_error_ne (c2, b1, C_ERROR_2);
4386 *next_code_point = test;
4387 next_code_point = &test->next;
4388 }
4389 break;
4390
4391 case A2TB2:
4392
4393 b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
4394 a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1);
4395 test = runtime_error_ne (b1, a1, B_ERROR_1);
4396 *next_code_point = test;
4397 next_code_point = &test->next;
4398
4399 if (!realloc_c)
4400 {
4401 c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1);
4402 a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2);
4403 test = runtime_error_ne (c1, a2, C_ERROR_1);
4404 *next_code_point = test;
4405 next_code_point = &test->next;
4406
4407 c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2);
4408 b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2);
4409 test = runtime_error_ne (c2, b2, C_ERROR_2);
4410 *next_code_point = test;
4411 next_code_point = &test->next;
4412 }
4413 break;
4414
4415 default:
4416 gcc_unreachable ();
4417 }
4418 }
4419
4420 /* Handle the reallocation, if needed. */
4421
4422 if (realloc_c)
4423 {
4424 gfc_code *lhs_alloc;
4425
4426 lhs_alloc = matmul_lhs_realloc (expr1, matrix_a, matrix_b, m_case);
4427
4428 *next_code_point = lhs_alloc;
4429 next_code_point = &lhs_alloc->next;
4430
4431 }
4432
4433 *next_code_point = assign_zero;
4434
4435 zero = gfc_get_int_expr (gfc_index_integer_kind, &co->loc, 0);
4436
4437 assign_matmul = XCNEW (gfc_code);
4438 assign_matmul->op = EXEC_ASSIGN;
4439 assign_matmul->loc = co->loc;
4440
4441 /* Get the bounds for the loops, create them and create the scalarized
4442 expressions. */
4443
4444 switch (m_case)
4445 {
4446 case A2B2:
4447
4448 u1 = get_size_m1 (matrix_b, 2);
4449 u2 = get_size_m1 (matrix_a, 2);
4450 u3 = get_size_m1 (matrix_a, 1);
4451
4452 do_1 = create_do_loop (gfc_copy_expr (zero), u1, NULL, &co->loc, ns);
4453 do_2 = create_do_loop (gfc_copy_expr (zero), u2, NULL, &co->loc, ns);
4454 do_3 = create_do_loop (gfc_copy_expr (zero), u3, NULL, &co->loc, ns);
4455
4456 do_1->block->next = do_2;
4457 do_2->block->next = do_3;
4458 do_3->block->next = assign_matmul;
4459
4460 var_1 = do_1->ext.iterator->var;
4461 var_2 = do_2->ext.iterator->var;
4462 var_3 = do_3->ext.iterator->var;
4463
4464 list[0] = var_3;
4465 list[1] = var_1;
4466 cscalar = scalarized_expr (co->expr1, list, 2);
4467
4468 list[0] = var_3;
4469 list[1] = var_2;
4470 ascalar = scalarized_expr (matrix_a, list, 2);
4471
4472 list[0] = var_2;
4473 list[1] = var_1;
4474 bscalar = scalarized_expr (matrix_b, list, 2);
4475
4476 break;
4477
4478 case A2B2T:
4479
4480 u1 = get_size_m1 (matrix_b, 1);
4481 u2 = get_size_m1 (matrix_a, 2);
4482 u3 = get_size_m1 (matrix_a, 1);
4483
4484 do_1 = create_do_loop (gfc_copy_expr (zero), u1, NULL, &co->loc, ns);
4485 do_2 = create_do_loop (gfc_copy_expr (zero), u2, NULL, &co->loc, ns);
4486 do_3 = create_do_loop (gfc_copy_expr (zero), u3, NULL, &co->loc, ns);
4487
4488 do_1->block->next = do_2;
4489 do_2->block->next = do_3;
4490 do_3->block->next = assign_matmul;
4491
4492 var_1 = do_1->ext.iterator->var;
4493 var_2 = do_2->ext.iterator->var;
4494 var_3 = do_3->ext.iterator->var;
4495
4496 list[0] = var_3;
4497 list[1] = var_1;
4498 cscalar = scalarized_expr (co->expr1, list, 2);
4499
4500 list[0] = var_3;
4501 list[1] = var_2;
4502 ascalar = scalarized_expr (matrix_a, list, 2);
4503
4504 list[0] = var_1;
4505 list[1] = var_2;
4506 bscalar = scalarized_expr (matrix_b, list, 2);
4507
4508 break;
4509
4510 case A2TB2:
4511
4512 u1 = get_size_m1 (matrix_a, 2);
4513 u2 = get_size_m1 (matrix_b, 2);
4514 u3 = get_size_m1 (matrix_a, 1);
4515
4516 do_1 = create_do_loop (gfc_copy_expr (zero), u1, NULL, &co->loc, ns);
4517 do_2 = create_do_loop (gfc_copy_expr (zero), u2, NULL, &co->loc, ns);
4518 do_3 = create_do_loop (gfc_copy_expr (zero), u3, NULL, &co->loc, ns);
4519
4520 do_1->block->next = do_2;
4521 do_2->block->next = do_3;
4522 do_3->block->next = assign_matmul;
4523
4524 var_1 = do_1->ext.iterator->var;
4525 var_2 = do_2->ext.iterator->var;
4526 var_3 = do_3->ext.iterator->var;
4527
4528 list[0] = var_1;
4529 list[1] = var_2;
4530 cscalar = scalarized_expr (co->expr1, list, 2);
4531
4532 list[0] = var_3;
4533 list[1] = var_1;
4534 ascalar = scalarized_expr (matrix_a, list, 2);
4535
4536 list[0] = var_3;
4537 list[1] = var_2;
4538 bscalar = scalarized_expr (matrix_b, list, 2);
4539
4540 break;
4541
4542 case A2B1:
4543 u1 = get_size_m1 (matrix_b, 1);
4544 u2 = get_size_m1 (matrix_a, 1);
4545
4546 do_1 = create_do_loop (gfc_copy_expr (zero), u1, NULL, &co->loc, ns);
4547 do_2 = create_do_loop (gfc_copy_expr (zero), u2, NULL, &co->loc, ns);
4548
4549 do_1->block->next = do_2;
4550 do_2->block->next = assign_matmul;
4551
4552 var_1 = do_1->ext.iterator->var;
4553 var_2 = do_2->ext.iterator->var;
4554
4555 list[0] = var_2;
4556 cscalar = scalarized_expr (co->expr1, list, 1);
4557
4558 list[0] = var_2;
4559 list[1] = var_1;
4560 ascalar = scalarized_expr (matrix_a, list, 2);
4561
4562 list[0] = var_1;
4563 bscalar = scalarized_expr (matrix_b, list, 1);
4564
4565 break;
4566
4567 case A1B2:
4568 u1 = get_size_m1 (matrix_b, 2);
4569 u2 = get_size_m1 (matrix_a, 1);
4570
4571 do_1 = create_do_loop (gfc_copy_expr (zero), u1, NULL, &co->loc, ns);
4572 do_2 = create_do_loop (gfc_copy_expr (zero), u2, NULL, &co->loc, ns);
4573
4574 do_1->block->next = do_2;
4575 do_2->block->next = assign_matmul;
4576
4577 var_1 = do_1->ext.iterator->var;
4578 var_2 = do_2->ext.iterator->var;
4579
4580 list[0] = var_1;
4581 cscalar = scalarized_expr (co->expr1, list, 1);
4582
4583 list[0] = var_2;
4584 ascalar = scalarized_expr (matrix_a, list, 1);
4585
4586 list[0] = var_2;
4587 list[1] = var_1;
4588 bscalar = scalarized_expr (matrix_b, list, 2);
4589
4590 break;
4591
4592 default:
4593 gcc_unreachable();
4594 }
4595
4596 /* Build the conjg call around the variables. Set the typespec manually
4597 because gfc_build_intrinsic_call sometimes gets this wrong. */
4598 if (conjg_a)
4599 {
4600 gfc_typespec ts;
4601 ts = matrix_a->ts;
4602 ascalar = gfc_build_intrinsic_call (ns, GFC_ISYM_CONJG, "conjg",
4603 matrix_a->where, 1, ascalar);
4604 ascalar->ts = ts;
4605 }
4606
4607 if (conjg_b)
4608 {
4609 gfc_typespec ts;
4610 ts = matrix_b->ts;
4611 bscalar = gfc_build_intrinsic_call (ns, GFC_ISYM_CONJG, "conjg",
4612 matrix_b->where, 1, bscalar);
4613 bscalar->ts = ts;
4614 }
4615 /* First loop comes after the zero assignment. */
4616 assign_zero->next = do_1;
4617
4618 /* Build the assignment expression in the loop. */
4619 assign_matmul->expr1 = gfc_copy_expr (cscalar);
4620
4621 mult = get_operand (op_times, ascalar, bscalar);
4622 assign_matmul->expr2 = get_operand (op_plus, cscalar, mult);
4623
4624 /* If we don't want to keep the original statement around in
4625 the else branch, we can free it. */
4626
4627 if (if_limit == NULL)
4628 gfc_free_statements(co);
4629 else
4630 co->next = NULL;
4631
4632 gfc_free_expr (zero);
4633 *walk_subtrees = 0;
4634 return 0;
4635 }
4636
4637 /* Change matmul function calls in the form of
4638
4639 c = matmul(a,b)
4640
4641 to the corresponding call to a BLAS routine, if applicable. */
4642
4643 static int
4644 call_external_blas (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
4645 void *data ATTRIBUTE_UNUSED)
4646 {
4647 gfc_code *co, *co_next;
4648 gfc_expr *expr1, *expr2;
4649 gfc_expr *matrix_a, *matrix_b;
4650 gfc_code *if_limit = NULL;
4651 gfc_actual_arglist *a, *b;
4652 bool conjg_a, conjg_b, transpose_a, transpose_b;
4653 gfc_code *call;
4654 const char *blas_name;
4655 const char *transa, *transb;
4656 gfc_expr *c1, *c2, *b1;
4657 gfc_actual_arglist *actual, *next;
4658 bt type;
4659 int kind;
4660 enum matrix_case m_case;
4661 bool realloc_c;
4662 gfc_code **next_code_point;
4663
4664 /* Many of the tests for inline matmul also apply here. */
4665
4666 co = *c;
4667
4668 if (co->op != EXEC_ASSIGN)
4669 return 0;
4670
4671 if (in_where || in_assoc_list)
4672 return 0;
4673
4674 /* The BLOCKS generated for the temporary variables and FORALL don't
4675 mix. */
4676 if (forall_level > 0)
4677 return 0;
4678
4679 /* For now don't do anything in OpenMP workshare, it confuses
4680 its translation, which expects only the allowed statements in there. */
4681
4682 if (in_omp_workshare || in_omp_atomic)
4683 return 0;
4684
4685 expr1 = co->expr1;
4686 expr2 = co->expr2;
4687 if (expr2->expr_type != EXPR_FUNCTION
4688 || expr2->value.function.isym == NULL
4689 || expr2->value.function.isym->id != GFC_ISYM_MATMUL)
4690 return 0;
4691
4692 type = expr2->ts.type;
4693 kind = expr2->ts.kind;
4694
4695 /* Guard against recursion. */
4696
4697 if (expr2->external_blas)
4698 return 0;
4699
4700 if (type != expr1->ts.type || kind != expr1->ts.kind)
4701 return 0;
4702
4703 if (type == BT_REAL)
4704 {
4705 if (kind == 4)
4706 blas_name = "sgemm";
4707 else if (kind == 8)
4708 blas_name = "dgemm";
4709 else
4710 return 0;
4711 }
4712 else if (type == BT_COMPLEX)
4713 {
4714 if (kind == 4)
4715 blas_name = "cgemm";
4716 else if (kind == 8)
4717 blas_name = "zgemm";
4718 else
4719 return 0;
4720 }
4721 else
4722 return 0;
4723
4724 a = expr2->value.function.actual;
4725 if (a->expr->rank != 2)
4726 return 0;
4727
4728 b = a->next;
4729 if (b->expr->rank != 2)
4730 return 0;
4731
4732 matrix_a = check_conjg_transpose_variable (a->expr, &conjg_a, &transpose_a);
4733 if (matrix_a == NULL)
4734 return 0;
4735
4736 if (transpose_a)
4737 {
4738 if (conjg_a)
4739 transa = "C";
4740 else
4741 transa = "T";
4742 }
4743 else
4744 transa = "N";
4745
4746 matrix_b = check_conjg_transpose_variable (b->expr, &conjg_b, &transpose_b);
4747 if (matrix_b == NULL)
4748 return 0;
4749
4750 if (transpose_b)
4751 {
4752 if (conjg_b)
4753 transb = "C";
4754 else
4755 transb = "T";
4756 }
4757 else
4758 transb = "N";
4759
4760 if (transpose_a)
4761 {
4762 if (transpose_b)
4763 m_case = A2TB2T;
4764 else
4765 m_case = A2TB2;
4766 }
4767 else
4768 {
4769 if (transpose_b)
4770 m_case = A2B2T;
4771 else
4772 m_case = A2B2;
4773 }
4774
4775 current_code = c;
4776 inserted_block = NULL;
4777 changed_statement = NULL;
4778
4779 expr2->external_blas = 1;
4780
4781 /* We do not handle data dependencies yet. */
4782 if (gfc_check_dependency (expr1, matrix_a, true)
4783 || gfc_check_dependency (expr1, matrix_b, true))
4784 return 0;
4785
4786 /* Generate the if statement and hang it into the tree. */
4787 if_limit = inline_limit_check (matrix_a, matrix_b, flag_blas_matmul_limit, 2);
4788 co_next = co->next;
4789 (*current_code) = if_limit;
4790 co->next = NULL;
4791 if_limit->block->next = co;
4792
4793 call = XCNEW (gfc_code);
4794 call->loc = co->loc;
4795
4796 /* Bounds checking - a bit simpler than for inlining since we only
4797 have to take care of two-dimensional arrays here. */
4798
4799 realloc_c = flag_realloc_lhs && gfc_is_reallocatable_lhs (expr1);
4800 next_code_point = &(if_limit->block->block->next);
4801
4802 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
4803 {
4804 gfc_code *test;
4805 // gfc_expr *a2, *b1, *c1, *c2, *a1, *b2;
4806 gfc_expr *c1, *a1, *c2, *b2, *a2;
4807 switch (m_case)
4808 {
4809 case A2B2:
4810 b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
4811 a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2);
4812 test = runtime_error_ne (b1, a2, B_ERROR_1);
4813 *next_code_point = test;
4814 next_code_point = &test->next;
4815
4816 if (!realloc_c)
4817 {
4818 c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1);
4819 a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1);
4820 test = runtime_error_ne (c1, a1, C_ERROR_1);
4821 *next_code_point = test;
4822 next_code_point = &test->next;
4823
4824 c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2);
4825 b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2);
4826 test = runtime_error_ne (c2, b2, C_ERROR_2);
4827 *next_code_point = test;
4828 next_code_point = &test->next;
4829 }
4830 break;
4831
4832 case A2B2T:
4833
4834 b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2);
4835 a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2);
4836 /* matrix_b is transposed, hence dimension 1 for the error message. */
4837 test = runtime_error_ne (b2, a2, B_ERROR_1);
4838 *next_code_point = test;
4839 next_code_point = &test->next;
4840
4841 if (!realloc_c)
4842 {
4843 c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1);
4844 a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1);
4845 test = runtime_error_ne (c1, a1, C_ERROR_1);
4846 *next_code_point = test;
4847 next_code_point = &test->next;
4848
4849 c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2);
4850 b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
4851 test = runtime_error_ne (c2, b1, C_ERROR_2);
4852 *next_code_point = test;
4853 next_code_point = &test->next;
4854 }
4855 break;
4856
4857 case A2TB2:
4858
4859 b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
4860 a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1);
4861 test = runtime_error_ne (b1, a1, B_ERROR_1);
4862 *next_code_point = test;
4863 next_code_point = &test->next;
4864
4865 if (!realloc_c)
4866 {
4867 c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1);
4868 a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2);
4869 test = runtime_error_ne (c1, a2, C_ERROR_1);
4870 *next_code_point = test;
4871 next_code_point = &test->next;
4872
4873 c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2);
4874 b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2);
4875 test = runtime_error_ne (c2, b2, C_ERROR_2);
4876 *next_code_point = test;
4877 next_code_point = &test->next;
4878 }
4879 break;
4880
4881 case A2TB2T:
4882 b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2);
4883 a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1);
4884 test = runtime_error_ne (b2, a1, B_ERROR_1);
4885 *next_code_point = test;
4886 next_code_point = &test->next;
4887
4888 if (!realloc_c)
4889 {
4890 c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1);
4891 a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2);
4892 test = runtime_error_ne (c1, a2, C_ERROR_1);
4893 *next_code_point = test;
4894 next_code_point = &test->next;
4895
4896 c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2);
4897 b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
4898 test = runtime_error_ne (c2, b1, C_ERROR_2);
4899 *next_code_point = test;
4900 next_code_point = &test->next;
4901 }
4902 break;
4903
4904 default:
4905 gcc_unreachable ();
4906 }
4907 }
4908
4909 /* Handle the reallocation, if needed. */
4910
4911 if (realloc_c)
4912 {
4913 gfc_code *lhs_alloc;
4914
4915 lhs_alloc = matmul_lhs_realloc (expr1, matrix_a, matrix_b, m_case);
4916 *next_code_point = lhs_alloc;
4917 next_code_point = &lhs_alloc->next;
4918 }
4919
4920 *next_code_point = call;
4921 if_limit->next = co_next;
4922
4923 /* Set up the BLAS call. */
4924
4925 call->op = EXEC_CALL;
4926
4927 gfc_get_sym_tree (blas_name, current_ns, &(call->symtree), true);
4928 call->symtree->n.sym->attr.subroutine = 1;
4929 call->symtree->n.sym->attr.procedure = 1;
4930 call->symtree->n.sym->attr.flavor = FL_PROCEDURE;
4931 call->resolved_sym = call->symtree->n.sym;
4932 gfc_commit_symbol (call->resolved_sym);
4933
4934 /* Argument TRANSA. */
4935 next = gfc_get_actual_arglist ();
4936 next->expr = gfc_get_character_expr (gfc_default_character_kind, &co->loc,
4937 transa, 1);
4938
4939 call->ext.actual = next;
4940
4941 /* Argument TRANSB. */
4942 actual = next;
4943 next = gfc_get_actual_arglist ();
4944 next->expr = gfc_get_character_expr (gfc_default_character_kind, &co->loc,
4945 transb, 1);
4946 actual->next = next;
4947
4948 c1 = get_array_inq_function (GFC_ISYM_SIZE, gfc_copy_expr (a->expr), 1,
4949 gfc_integer_4_kind);
4950 c2 = get_array_inq_function (GFC_ISYM_SIZE, gfc_copy_expr (b->expr), 2,
4951 gfc_integer_4_kind);
4952
4953 b1 = get_array_inq_function (GFC_ISYM_SIZE, gfc_copy_expr (b->expr), 1,
4954 gfc_integer_4_kind);
4955
4956 /* Argument M. */
4957 actual = next;
4958 next = gfc_get_actual_arglist ();
4959 next->expr = c1;
4960 actual->next = next;
4961
4962 /* Argument N. */
4963 actual = next;
4964 next = gfc_get_actual_arglist ();
4965 next->expr = c2;
4966 actual->next = next;
4967
4968 /* Argument K. */
4969 actual = next;
4970 next = gfc_get_actual_arglist ();
4971 next->expr = b1;
4972 actual->next = next;
4973
4974 /* Argument ALPHA - set to one. */
4975 actual = next;
4976 next = gfc_get_actual_arglist ();
4977 next->expr = gfc_get_constant_expr (type, kind, &co->loc);
4978 if (type == BT_REAL)
4979 mpfr_set_ui (next->expr->value.real, 1, GFC_RND_MODE);
4980 else
4981 mpc_set_ui (next->expr->value.complex, 1, GFC_MPC_RND_MODE);
4982 actual->next = next;
4983
4984 /* Argument A. */
4985 actual = next;
4986 next = gfc_get_actual_arglist ();
4987 next->expr = gfc_copy_expr (matrix_a);
4988 actual->next = next;
4989
4990 /* Argument LDA. */
4991 actual = next;
4992 next = gfc_get_actual_arglist ();
4993 next->expr = get_array_inq_function (GFC_ISYM_SIZE, gfc_copy_expr (matrix_a),
4994 1, gfc_integer_4_kind);
4995 actual->next = next;
4996
4997 /* Argument B. */
4998 actual = next;
4999 next = gfc_get_actual_arglist ();
5000 next->expr = gfc_copy_expr (matrix_b);
5001 actual->next = next;
5002
5003 /* Argument LDB. */
5004 actual = next;
5005 next = gfc_get_actual_arglist ();
5006 next->expr = get_array_inq_function (GFC_ISYM_SIZE, gfc_copy_expr (matrix_b),
5007 1, gfc_integer_4_kind);
5008 actual->next = next;
5009
5010 /* Argument BETA - set to zero. */
5011 actual = next;
5012 next = gfc_get_actual_arglist ();
5013 next->expr = gfc_get_constant_expr (type, kind, &co->loc);
5014 if (type == BT_REAL)
5015 mpfr_set_ui (next->expr->value.real, 0, GFC_RND_MODE);
5016 else
5017 mpc_set_ui (next->expr->value.complex, 0, GFC_MPC_RND_MODE);
5018 actual->next = next;
5019
5020 /* Argument C. */
5021
5022 actual = next;
5023 next = gfc_get_actual_arglist ();
5024 next->expr = gfc_copy_expr (expr1);
5025 actual->next = next;
5026
5027 /* Argument LDC. */
5028 actual = next;
5029 next = gfc_get_actual_arglist ();
5030 next->expr = get_array_inq_function (GFC_ISYM_SIZE, gfc_copy_expr (expr1),
5031 1, gfc_integer_4_kind);
5032 actual->next = next;
5033
5034 return 0;
5035 }
5036
5037
5038 /* Code for index interchange for loops which are grouped together in DO
5039 CONCURRENT or FORALL statements. This is currently only applied if the
5040 iterations are grouped together in a single statement.
5041
5042 For this transformation, it is assumed that memory access in strides is
5043 expensive, and that loops which access later indices (which access memory
5044 in bigger strides) should be moved to the first loops.
5045
5046 For this, a loop over all the statements is executed, counting the times
5047 that the loop iteration values are accessed in each index. The loop
5048 indices are then sorted to minimize access to later indices from inner
5049 loops. */
5050
5051 /* Type for holding index information. */
5052
5053 typedef struct {
5054 gfc_symbol *sym;
5055 gfc_forall_iterator *fa;
5056 int num;
5057 int n[GFC_MAX_DIMENSIONS];
5058 } ind_type;
5059
5060 /* Callback function to determine if an expression is the
5061 corresponding variable. */
5062
5063 static int
5064 has_var (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, void *data)
5065 {
5066 gfc_expr *expr = *e;
5067 gfc_symbol *sym;
5068
5069 if (expr->expr_type != EXPR_VARIABLE)
5070 return 0;
5071
5072 sym = (gfc_symbol *) data;
5073 return sym == expr->symtree->n.sym;
5074 }
5075
5076 /* Callback function to calculate the cost of a certain index. */
5077
5078 static int
5079 index_cost (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
5080 void *data)
5081 {
5082 ind_type *ind;
5083 gfc_expr *expr;
5084 gfc_array_ref *ar;
5085 gfc_ref *ref;
5086 int i,j;
5087
5088 expr = *e;
5089 if (expr->expr_type != EXPR_VARIABLE)
5090 return 0;
5091
5092 ar = NULL;
5093 for (ref = expr->ref; ref; ref = ref->next)
5094 {
5095 if (ref->type == REF_ARRAY)
5096 {
5097 ar = &ref->u.ar;
5098 break;
5099 }
5100 }
5101 if (ar == NULL || ar->type != AR_ELEMENT)
5102 return 0;
5103
5104 ind = (ind_type *) data;
5105 for (i = 0; i < ar->dimen; i++)
5106 {
5107 for (j=0; ind[j].sym != NULL; j++)
5108 {
5109 if (gfc_expr_walker (&ar->start[i], has_var, (void *) (ind[j].sym)))
5110 ind[j].n[i]++;
5111 }
5112 }
5113 return 0;
5114 }
5115
5116 /* Callback function for qsort, to sort the loop indices. */
5117
5118 static int
5119 loop_comp (const void *e1, const void *e2)
5120 {
5121 const ind_type *i1 = (const ind_type *) e1;
5122 const ind_type *i2 = (const ind_type *) e2;
5123 int i;
5124
5125 for (i=GFC_MAX_DIMENSIONS-1; i >= 0; i--)
5126 {
5127 if (i1->n[i] != i2->n[i])
5128 return i1->n[i] - i2->n[i];
5129 }
5130 /* All other things being equal, let's not change the ordering. */
5131 return i2->num - i1->num;
5132 }
5133
5134 /* Main function to do the index interchange. */
5135
5136 static int
5137 index_interchange (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
5138 void *data ATTRIBUTE_UNUSED)
5139 {
5140 gfc_code *co;
5141 co = *c;
5142 int n_iter;
5143 gfc_forall_iterator *fa;
5144 ind_type *ind;
5145 int i, j;
5146
5147 if (co->op != EXEC_FORALL && co->op != EXEC_DO_CONCURRENT)
5148 return 0;
5149
5150 n_iter = 0;
5151 for (fa = co->ext.forall_iterator; fa; fa = fa->next)
5152 n_iter ++;
5153
5154 /* Nothing to reorder. */
5155 if (n_iter < 2)
5156 return 0;
5157
5158 ind = XALLOCAVEC (ind_type, n_iter + 1);
5159
5160 i = 0;
5161 for (fa = co->ext.forall_iterator; fa; fa = fa->next)
5162 {
5163 ind[i].sym = fa->var->symtree->n.sym;
5164 ind[i].fa = fa;
5165 for (j=0; j<GFC_MAX_DIMENSIONS; j++)
5166 ind[i].n[j] = 0;
5167 ind[i].num = i;
5168 i++;
5169 }
5170 ind[n_iter].sym = NULL;
5171 ind[n_iter].fa = NULL;
5172
5173 gfc_code_walker (c, gfc_dummy_code_callback, index_cost, (void *) ind);
5174 qsort ((void *) ind, n_iter, sizeof (ind_type), loop_comp);
5175
5176 /* Do the actual index interchange. */
5177 co->ext.forall_iterator = fa = ind[0].fa;
5178 for (i=1; i<n_iter; i++)
5179 {
5180 fa->next = ind[i].fa;
5181 fa = fa->next;
5182 }
5183 fa->next = NULL;
5184
5185 if (flag_warn_frontend_loop_interchange)
5186 {
5187 for (i=1; i<n_iter; i++)
5188 {
5189 if (ind[i-1].num > ind[i].num)
5190 {
5191 gfc_warning (OPT_Wfrontend_loop_interchange,
5192 "Interchanging loops at %L", &co->loc);
5193 break;
5194 }
5195 }
5196 }
5197
5198 return 0;
5199 }
5200
5201 #define WALK_SUBEXPR(NODE) \
5202 do \
5203 { \
5204 result = gfc_expr_walker (&(NODE), exprfn, data); \
5205 if (result) \
5206 return result; \
5207 } \
5208 while (0)
5209 #define WALK_SUBEXPR_TAIL(NODE) e = &(NODE); continue
5210
5211 /* Walk expression *E, calling EXPRFN on each expression in it. */
5212
5213 int
5214 gfc_expr_walker (gfc_expr **e, walk_expr_fn_t exprfn, void *data)
5215 {
5216 while (*e)
5217 {
5218 int walk_subtrees = 1;
5219 gfc_actual_arglist *a;
5220 gfc_ref *r;
5221 gfc_constructor *c;
5222
5223 int result = exprfn (e, &walk_subtrees, data);
5224 if (result)
5225 return result;
5226 if (walk_subtrees)
5227 switch ((*e)->expr_type)
5228 {
5229 case EXPR_OP:
5230 WALK_SUBEXPR ((*e)->value.op.op1);
5231 WALK_SUBEXPR_TAIL ((*e)->value.op.op2);
5232 break;
5233 case EXPR_FUNCTION:
5234 for (a = (*e)->value.function.actual; a; a = a->next)
5235 WALK_SUBEXPR (a->expr);
5236 break;
5237 case EXPR_COMPCALL:
5238 case EXPR_PPC:
5239 WALK_SUBEXPR ((*e)->value.compcall.base_object);
5240 for (a = (*e)->value.compcall.actual; a; a = a->next)
5241 WALK_SUBEXPR (a->expr);
5242 break;
5243
5244 case EXPR_STRUCTURE:
5245 case EXPR_ARRAY:
5246 for (c = gfc_constructor_first ((*e)->value.constructor); c;
5247 c = gfc_constructor_next (c))
5248 {
5249 if (c->iterator == NULL)
5250 WALK_SUBEXPR (c->expr);
5251 else
5252 {
5253 iterator_level ++;
5254 WALK_SUBEXPR (c->expr);
5255 iterator_level --;
5256 WALK_SUBEXPR (c->iterator->var);
5257 WALK_SUBEXPR (c->iterator->start);
5258 WALK_SUBEXPR (c->iterator->end);
5259 WALK_SUBEXPR (c->iterator->step);
5260 }
5261 }
5262
5263 if ((*e)->expr_type != EXPR_ARRAY)
5264 break;
5265
5266 /* Fall through to the variable case in order to walk the
5267 reference. */
5268 gcc_fallthrough ();
5269
5270 case EXPR_SUBSTRING:
5271 case EXPR_VARIABLE:
5272 for (r = (*e)->ref; r; r = r->next)
5273 {
5274 gfc_array_ref *ar;
5275 int i;
5276
5277 switch (r->type)
5278 {
5279 case REF_ARRAY:
5280 ar = &r->u.ar;
5281 if (ar->type == AR_SECTION || ar->type == AR_ELEMENT)
5282 {
5283 for (i=0; i< ar->dimen; i++)
5284 {
5285 WALK_SUBEXPR (ar->start[i]);
5286 WALK_SUBEXPR (ar->end[i]);
5287 WALK_SUBEXPR (ar->stride[i]);
5288 }
5289 }
5290
5291 break;
5292
5293 case REF_SUBSTRING:
5294 WALK_SUBEXPR (r->u.ss.start);
5295 WALK_SUBEXPR (r->u.ss.end);
5296 break;
5297
5298 case REF_COMPONENT:
5299 case REF_INQUIRY:
5300 break;
5301 }
5302 }
5303
5304 default:
5305 break;
5306 }
5307 return 0;
5308 }
5309 return 0;
5310 }
5311
5312 #define WALK_SUBCODE(NODE) \
5313 do \
5314 { \
5315 result = gfc_code_walker (&(NODE), codefn, exprfn, data); \
5316 if (result) \
5317 return result; \
5318 } \
5319 while (0)
5320
5321 /* Walk code *C, calling CODEFN on each gfc_code node in it and calling EXPRFN
5322 on each expression in it. If any of the hooks returns non-zero, that
5323 value is immediately returned. If the hook sets *WALK_SUBTREES to 0,
5324 no subcodes or subexpressions are traversed. */
5325
5326 int
5327 gfc_code_walker (gfc_code **c, walk_code_fn_t codefn, walk_expr_fn_t exprfn,
5328 void *data)
5329 {
5330 for (; *c; c = &(*c)->next)
5331 {
5332 int walk_subtrees = 1;
5333 int result = codefn (c, &walk_subtrees, data);
5334 if (result)
5335 return result;
5336
5337 if (walk_subtrees)
5338 {
5339 gfc_code *b;
5340 gfc_actual_arglist *a;
5341 gfc_code *co;
5342 gfc_association_list *alist;
5343 bool saved_in_omp_workshare;
5344 bool saved_in_omp_atomic;
5345 bool saved_in_where;
5346
5347 /* There might be statement insertions before the current code,
5348 which must not affect the expression walker. */
5349
5350 co = *c;
5351 saved_in_omp_workshare = in_omp_workshare;
5352 saved_in_omp_atomic = in_omp_atomic;
5353 saved_in_where = in_where;
5354
5355 switch (co->op)
5356 {
5357
5358 case EXEC_BLOCK:
5359 WALK_SUBCODE (co->ext.block.ns->code);
5360 if (co->ext.block.assoc)
5361 {
5362 bool saved_in_assoc_list = in_assoc_list;
5363
5364 in_assoc_list = true;
5365 for (alist = co->ext.block.assoc; alist; alist = alist->next)
5366 WALK_SUBEXPR (alist->target);
5367
5368 in_assoc_list = saved_in_assoc_list;
5369 }
5370
5371 break;
5372
5373 case EXEC_DO:
5374 doloop_level ++;
5375 WALK_SUBEXPR (co->ext.iterator->var);
5376 WALK_SUBEXPR (co->ext.iterator->start);
5377 WALK_SUBEXPR (co->ext.iterator->end);
5378 WALK_SUBEXPR (co->ext.iterator->step);
5379 break;
5380
5381 case EXEC_IF:
5382 if_level ++;
5383 break;
5384
5385 case EXEC_WHERE:
5386 in_where = true;
5387 break;
5388
5389 case EXEC_CALL:
5390 case EXEC_ASSIGN_CALL:
5391 for (a = co->ext.actual; a; a = a->next)
5392 WALK_SUBEXPR (a->expr);
5393 break;
5394
5395 case EXEC_CALL_PPC:
5396 WALK_SUBEXPR (co->expr1);
5397 for (a = co->ext.actual; a; a = a->next)
5398 WALK_SUBEXPR (a->expr);
5399 break;
5400
5401 case EXEC_SELECT:
5402 WALK_SUBEXPR (co->expr1);
5403 select_level ++;
5404 for (b = co->block; b; b = b->block)
5405 {
5406 gfc_case *cp;
5407 for (cp = b->ext.block.case_list; cp; cp = cp->next)
5408 {
5409 WALK_SUBEXPR (cp->low);
5410 WALK_SUBEXPR (cp->high);
5411 }
5412 WALK_SUBCODE (b->next);
5413 }
5414 continue;
5415
5416 case EXEC_ALLOCATE:
5417 case EXEC_DEALLOCATE:
5418 {
5419 gfc_alloc *a;
5420 for (a = co->ext.alloc.list; a; a = a->next)
5421 WALK_SUBEXPR (a->expr);
5422 break;
5423 }
5424
5425 case EXEC_FORALL:
5426 case EXEC_DO_CONCURRENT:
5427 {
5428 gfc_forall_iterator *fa;
5429 for (fa = co->ext.forall_iterator; fa; fa = fa->next)
5430 {
5431 WALK_SUBEXPR (fa->var);
5432 WALK_SUBEXPR (fa->start);
5433 WALK_SUBEXPR (fa->end);
5434 WALK_SUBEXPR (fa->stride);
5435 }
5436 if (co->op == EXEC_FORALL)
5437 forall_level ++;
5438 break;
5439 }
5440
5441 case EXEC_OPEN:
5442 WALK_SUBEXPR (co->ext.open->unit);
5443 WALK_SUBEXPR (co->ext.open->file);
5444 WALK_SUBEXPR (co->ext.open->status);
5445 WALK_SUBEXPR (co->ext.open->access);
5446 WALK_SUBEXPR (co->ext.open->form);
5447 WALK_SUBEXPR (co->ext.open->recl);
5448 WALK_SUBEXPR (co->ext.open->blank);
5449 WALK_SUBEXPR (co->ext.open->position);
5450 WALK_SUBEXPR (co->ext.open->action);
5451 WALK_SUBEXPR (co->ext.open->delim);
5452 WALK_SUBEXPR (co->ext.open->pad);
5453 WALK_SUBEXPR (co->ext.open->iostat);
5454 WALK_SUBEXPR (co->ext.open->iomsg);
5455 WALK_SUBEXPR (co->ext.open->convert);
5456 WALK_SUBEXPR (co->ext.open->decimal);
5457 WALK_SUBEXPR (co->ext.open->encoding);
5458 WALK_SUBEXPR (co->ext.open->round);
5459 WALK_SUBEXPR (co->ext.open->sign);
5460 WALK_SUBEXPR (co->ext.open->asynchronous);
5461 WALK_SUBEXPR (co->ext.open->id);
5462 WALK_SUBEXPR (co->ext.open->newunit);
5463 WALK_SUBEXPR (co->ext.open->share);
5464 WALK_SUBEXPR (co->ext.open->cc);
5465 break;
5466
5467 case EXEC_CLOSE:
5468 WALK_SUBEXPR (co->ext.close->unit);
5469 WALK_SUBEXPR (co->ext.close->status);
5470 WALK_SUBEXPR (co->ext.close->iostat);
5471 WALK_SUBEXPR (co->ext.close->iomsg);
5472 break;
5473
5474 case EXEC_BACKSPACE:
5475 case EXEC_ENDFILE:
5476 case EXEC_REWIND:
5477 case EXEC_FLUSH:
5478 WALK_SUBEXPR (co->ext.filepos->unit);
5479 WALK_SUBEXPR (co->ext.filepos->iostat);
5480 WALK_SUBEXPR (co->ext.filepos->iomsg);
5481 break;
5482
5483 case EXEC_INQUIRE:
5484 WALK_SUBEXPR (co->ext.inquire->unit);
5485 WALK_SUBEXPR (co->ext.inquire->file);
5486 WALK_SUBEXPR (co->ext.inquire->iomsg);
5487 WALK_SUBEXPR (co->ext.inquire->iostat);
5488 WALK_SUBEXPR (co->ext.inquire->exist);
5489 WALK_SUBEXPR (co->ext.inquire->opened);
5490 WALK_SUBEXPR (co->ext.inquire->number);
5491 WALK_SUBEXPR (co->ext.inquire->named);
5492 WALK_SUBEXPR (co->ext.inquire->name);
5493 WALK_SUBEXPR (co->ext.inquire->access);
5494 WALK_SUBEXPR (co->ext.inquire->sequential);
5495 WALK_SUBEXPR (co->ext.inquire->direct);
5496 WALK_SUBEXPR (co->ext.inquire->form);
5497 WALK_SUBEXPR (co->ext.inquire->formatted);
5498 WALK_SUBEXPR (co->ext.inquire->unformatted);
5499 WALK_SUBEXPR (co->ext.inquire->recl);
5500 WALK_SUBEXPR (co->ext.inquire->nextrec);
5501 WALK_SUBEXPR (co->ext.inquire->blank);
5502 WALK_SUBEXPR (co->ext.inquire->position);
5503 WALK_SUBEXPR (co->ext.inquire->action);
5504 WALK_SUBEXPR (co->ext.inquire->read);
5505 WALK_SUBEXPR (co->ext.inquire->write);
5506 WALK_SUBEXPR (co->ext.inquire->readwrite);
5507 WALK_SUBEXPR (co->ext.inquire->delim);
5508 WALK_SUBEXPR (co->ext.inquire->encoding);
5509 WALK_SUBEXPR (co->ext.inquire->pad);
5510 WALK_SUBEXPR (co->ext.inquire->iolength);
5511 WALK_SUBEXPR (co->ext.inquire->convert);
5512 WALK_SUBEXPR (co->ext.inquire->strm_pos);
5513 WALK_SUBEXPR (co->ext.inquire->asynchronous);
5514 WALK_SUBEXPR (co->ext.inquire->decimal);
5515 WALK_SUBEXPR (co->ext.inquire->pending);
5516 WALK_SUBEXPR (co->ext.inquire->id);
5517 WALK_SUBEXPR (co->ext.inquire->sign);
5518 WALK_SUBEXPR (co->ext.inquire->size);
5519 WALK_SUBEXPR (co->ext.inquire->round);
5520 break;
5521
5522 case EXEC_WAIT:
5523 WALK_SUBEXPR (co->ext.wait->unit);
5524 WALK_SUBEXPR (co->ext.wait->iostat);
5525 WALK_SUBEXPR (co->ext.wait->iomsg);
5526 WALK_SUBEXPR (co->ext.wait->id);
5527 break;
5528
5529 case EXEC_READ:
5530 case EXEC_WRITE:
5531 WALK_SUBEXPR (co->ext.dt->io_unit);
5532 WALK_SUBEXPR (co->ext.dt->format_expr);
5533 WALK_SUBEXPR (co->ext.dt->rec);
5534 WALK_SUBEXPR (co->ext.dt->advance);
5535 WALK_SUBEXPR (co->ext.dt->iostat);
5536 WALK_SUBEXPR (co->ext.dt->size);
5537 WALK_SUBEXPR (co->ext.dt->iomsg);
5538 WALK_SUBEXPR (co->ext.dt->id);
5539 WALK_SUBEXPR (co->ext.dt->pos);
5540 WALK_SUBEXPR (co->ext.dt->asynchronous);
5541 WALK_SUBEXPR (co->ext.dt->blank);
5542 WALK_SUBEXPR (co->ext.dt->decimal);
5543 WALK_SUBEXPR (co->ext.dt->delim);
5544 WALK_SUBEXPR (co->ext.dt->pad);
5545 WALK_SUBEXPR (co->ext.dt->round);
5546 WALK_SUBEXPR (co->ext.dt->sign);
5547 WALK_SUBEXPR (co->ext.dt->extra_comma);
5548 break;
5549
5550 case EXEC_OACC_ATOMIC:
5551 case EXEC_OMP_ATOMIC:
5552 in_omp_atomic = true;
5553 break;
5554
5555 case EXEC_OMP_PARALLEL:
5556 case EXEC_OMP_PARALLEL_DO:
5557 case EXEC_OMP_PARALLEL_DO_SIMD:
5558 case EXEC_OMP_PARALLEL_LOOP:
5559 case EXEC_OMP_PARALLEL_MASTER:
5560 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
5561 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
5562 case EXEC_OMP_PARALLEL_SECTIONS:
5563
5564 in_omp_workshare = false;
5565
5566 /* This goto serves as a shortcut to avoid code
5567 duplication or a larger if or switch statement. */
5568 goto check_omp_clauses;
5569
5570 case EXEC_OMP_WORKSHARE:
5571 case EXEC_OMP_PARALLEL_WORKSHARE:
5572
5573 in_omp_workshare = true;
5574
5575 /* Fall through */
5576
5577 case EXEC_OMP_CRITICAL:
5578 case EXEC_OMP_DISTRIBUTE:
5579 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
5580 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
5581 case EXEC_OMP_DISTRIBUTE_SIMD:
5582 case EXEC_OMP_DO:
5583 case EXEC_OMP_DO_SIMD:
5584 case EXEC_OMP_LOOP:
5585 case EXEC_OMP_ORDERED:
5586 case EXEC_OMP_SECTIONS:
5587 case EXEC_OMP_SINGLE:
5588 case EXEC_OMP_END_SINGLE:
5589 case EXEC_OMP_SIMD:
5590 case EXEC_OMP_TASKLOOP:
5591 case EXEC_OMP_TASKLOOP_SIMD:
5592 case EXEC_OMP_TARGET:
5593 case EXEC_OMP_TARGET_DATA:
5594 case EXEC_OMP_TARGET_ENTER_DATA:
5595 case EXEC_OMP_TARGET_EXIT_DATA:
5596 case EXEC_OMP_TARGET_PARALLEL:
5597 case EXEC_OMP_TARGET_PARALLEL_DO:
5598 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
5599 case EXEC_OMP_TARGET_PARALLEL_LOOP:
5600 case EXEC_OMP_TARGET_SIMD:
5601 case EXEC_OMP_TARGET_TEAMS:
5602 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
5603 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
5604 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
5605 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
5606 case EXEC_OMP_TARGET_TEAMS_LOOP:
5607 case EXEC_OMP_TARGET_UPDATE:
5608 case EXEC_OMP_TASK:
5609 case EXEC_OMP_TEAMS:
5610 case EXEC_OMP_TEAMS_DISTRIBUTE:
5611 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
5612 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
5613 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
5614 case EXEC_OMP_TEAMS_LOOP:
5615
5616 /* Come to this label only from the
5617 EXEC_OMP_PARALLEL_* cases above. */
5618
5619 check_omp_clauses:
5620
5621 if (co->ext.omp_clauses)
5622 {
5623 gfc_omp_namelist *n;
5624 static int list_types[]
5625 = { OMP_LIST_ALIGNED, OMP_LIST_LINEAR, OMP_LIST_DEPEND,
5626 OMP_LIST_MAP, OMP_LIST_TO, OMP_LIST_FROM };
5627 size_t idx;
5628 WALK_SUBEXPR (co->ext.omp_clauses->if_expr);
5629 WALK_SUBEXPR (co->ext.omp_clauses->final_expr);
5630 WALK_SUBEXPR (co->ext.omp_clauses->num_threads);
5631 WALK_SUBEXPR (co->ext.omp_clauses->chunk_size);
5632 WALK_SUBEXPR (co->ext.omp_clauses->safelen_expr);
5633 WALK_SUBEXPR (co->ext.omp_clauses->simdlen_expr);
5634 WALK_SUBEXPR (co->ext.omp_clauses->num_teams);
5635 WALK_SUBEXPR (co->ext.omp_clauses->device);
5636 WALK_SUBEXPR (co->ext.omp_clauses->thread_limit);
5637 WALK_SUBEXPR (co->ext.omp_clauses->dist_chunk_size);
5638 WALK_SUBEXPR (co->ext.omp_clauses->grainsize);
5639 WALK_SUBEXPR (co->ext.omp_clauses->hint);
5640 WALK_SUBEXPR (co->ext.omp_clauses->num_tasks);
5641 WALK_SUBEXPR (co->ext.omp_clauses->priority);
5642 WALK_SUBEXPR (co->ext.omp_clauses->detach);
5643 for (idx = 0; idx < OMP_IF_LAST; idx++)
5644 WALK_SUBEXPR (co->ext.omp_clauses->if_exprs[idx]);
5645 for (idx = 0;
5646 idx < sizeof (list_types) / sizeof (list_types[0]);
5647 idx++)
5648 for (n = co->ext.omp_clauses->lists[list_types[idx]];
5649 n; n = n->next)
5650 WALK_SUBEXPR (n->expr);
5651 }
5652 break;
5653 default:
5654 break;
5655 }
5656
5657 WALK_SUBEXPR (co->expr1);
5658 WALK_SUBEXPR (co->expr2);
5659 WALK_SUBEXPR (co->expr3);
5660 WALK_SUBEXPR (co->expr4);
5661 for (b = co->block; b; b = b->block)
5662 {
5663 WALK_SUBEXPR (b->expr1);
5664 WALK_SUBEXPR (b->expr2);
5665 WALK_SUBCODE (b->next);
5666 }
5667
5668 if (co->op == EXEC_FORALL)
5669 forall_level --;
5670
5671 if (co->op == EXEC_DO)
5672 doloop_level --;
5673
5674 if (co->op == EXEC_IF)
5675 if_level --;
5676
5677 if (co->op == EXEC_SELECT)
5678 select_level --;
5679
5680 in_omp_workshare = saved_in_omp_workshare;
5681 in_omp_atomic = saved_in_omp_atomic;
5682 in_where = saved_in_where;
5683 }
5684 }
5685 return 0;
5686 }
5687
5688 /* As a post-resolution step, check that all global symbols which are
5689 not declared in the source file match in their call signatures.
5690 We do this by looping over the code (and expressions). The first call
5691 we happen to find is assumed to be canonical. */
5692
5693
5694 /* Common tests for argument checking for both functions and subroutines. */
5695
5696 static int
5697 check_externals_procedure (gfc_symbol *sym, locus *loc,
5698 gfc_actual_arglist *actual)
5699 {
5700 gfc_gsymbol *gsym;
5701 gfc_symbol *def_sym = NULL;
5702
5703 if (sym == NULL || sym->attr.is_bind_c)
5704 return 0;
5705
5706 if (sym->attr.proc != PROC_EXTERNAL && sym->attr.proc != PROC_UNKNOWN)
5707 return 0;
5708
5709 if (sym->attr.if_source == IFSRC_IFBODY || sym->attr.if_source == IFSRC_DECL)
5710 return 0;
5711
5712 gsym = gfc_find_gsymbol (gfc_gsym_root, sym->name);
5713 if (gsym == NULL)
5714 return 0;
5715
5716 if (gsym->ns)
5717 gfc_find_symbol (sym->name, gsym->ns, 0, &def_sym);
5718
5719 if (def_sym)
5720 {
5721 gfc_compare_actual_formal (&actual, def_sym->formal, 0, 0, 0, loc);
5722 return 0;
5723 }
5724
5725 /* First time we have seen this procedure called. Let's create an
5726 "interface" from the call and put it into a new namespace. */
5727 gfc_namespace *save_ns;
5728 gfc_symbol *new_sym;
5729
5730 gsym->where = *loc;
5731 save_ns = gfc_current_ns;
5732 gsym->ns = gfc_get_namespace (gfc_current_ns, 0);
5733 gsym->ns->proc_name = sym;
5734
5735 gfc_get_symbol (sym->name, gsym->ns, &new_sym);
5736 gcc_assert (new_sym);
5737 new_sym->attr = sym->attr;
5738 new_sym->attr.if_source = IFSRC_DECL;
5739 gfc_current_ns = gsym->ns;
5740
5741 gfc_get_formal_from_actual_arglist (new_sym, actual);
5742 new_sym->declared_at = *loc;
5743 gfc_current_ns = save_ns;
5744
5745 return 0;
5746
5747 }
5748
5749 /* Callback for calls of external routines. */
5750
5751 static int
5752 check_externals_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
5753 void *data ATTRIBUTE_UNUSED)
5754 {
5755 gfc_code *co = *c;
5756 gfc_symbol *sym;
5757 locus *loc;
5758 gfc_actual_arglist *actual;
5759
5760 if (co->op != EXEC_CALL)
5761 return 0;
5762
5763 sym = co->resolved_sym;
5764 loc = &co->loc;
5765 actual = co->ext.actual;
5766
5767 return check_externals_procedure (sym, loc, actual);
5768
5769 }
5770
5771 /* Callback for external functions. */
5772
5773 static int
5774 check_externals_expr (gfc_expr **ep, int *walk_subtrees ATTRIBUTE_UNUSED,
5775 void *data ATTRIBUTE_UNUSED)
5776 {
5777 gfc_expr *e = *ep;
5778 gfc_symbol *sym;
5779 locus *loc;
5780 gfc_actual_arglist *actual;
5781
5782 if (e->expr_type != EXPR_FUNCTION)
5783 return 0;
5784
5785 sym = e->value.function.esym;
5786 if (sym == NULL)
5787 return 0;
5788
5789 loc = &e->where;
5790 actual = e->value.function.actual;
5791
5792 return check_externals_procedure (sym, loc, actual);
5793 }
5794
5795 /* Function to check if any interface clashes with a global
5796 identifier, to be invoked via gfc_traverse_ns. */
5797
5798 static void
5799 check_against_globals (gfc_symbol *sym)
5800 {
5801 gfc_gsymbol *gsym;
5802 gfc_symbol *def_sym = NULL;
5803 const char *sym_name;
5804 char buf [200];
5805
5806 if (sym->attr.if_source != IFSRC_IFBODY || sym->attr.flavor != FL_PROCEDURE
5807 || sym->attr.generic || sym->error)
5808 return;
5809
5810 if (sym->binding_label)
5811 sym_name = sym->binding_label;
5812 else
5813 sym_name = sym->name;
5814
5815 gsym = gfc_find_gsymbol (gfc_gsym_root, sym_name);
5816 if (gsym && gsym->ns)
5817 gfc_find_symbol (sym->name, gsym->ns, 0, &def_sym);
5818
5819 if (!def_sym || def_sym->error || def_sym->attr.generic)
5820 return;
5821
5822 buf[0] = 0;
5823 gfc_compare_interfaces (sym, def_sym, sym->name, 0, 1, buf, sizeof(buf),
5824 NULL, NULL, NULL);
5825 if (buf[0] != 0)
5826 {
5827 gfc_warning (0, "%s between %L and %L", buf, &def_sym->declared_at,
5828 &sym->declared_at);
5829 sym->error = 1;
5830 def_sym->error = 1;
5831 }
5832
5833 }
5834
5835 /* Do the code-walkling part for gfc_check_externals. */
5836
5837 static void
5838 gfc_check_externals0 (gfc_namespace *ns)
5839 {
5840 gfc_code_walker (&ns->code, check_externals_code, check_externals_expr, NULL);
5841
5842 for (ns = ns->contained; ns; ns = ns->sibling)
5843 {
5844 if (ns->code == NULL || ns->code->op != EXEC_BLOCK)
5845 gfc_check_externals0 (ns);
5846 }
5847
5848 }
5849
5850 /* Called routine. */
5851
5852 void
5853 gfc_check_externals (gfc_namespace *ns)
5854 {
5855 gfc_clear_error ();
5856
5857 /* Turn errors into warnings if the user indicated this. */
5858
5859 if (!pedantic && flag_allow_argument_mismatch)
5860 gfc_errors_to_warnings (true);
5861
5862 gfc_check_externals0 (ns);
5863 gfc_traverse_ns (ns, check_against_globals);
5864
5865 gfc_errors_to_warnings (false);
5866 }
5867
5868 /* Callback function. If there is a call to a subroutine which is
5869 neither pure nor implicit_pure, unset the implicit_pure flag for
5870 the caller and return -1. */
5871
5872 static int
5873 implicit_pure_call (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
5874 void *sym_data)
5875 {
5876 gfc_code *co = *c;
5877 gfc_symbol *caller_sym;
5878 symbol_attribute *a;
5879
5880 if (co->op != EXEC_CALL || co->resolved_sym == NULL)
5881 return 0;
5882
5883 a = &co->resolved_sym->attr;
5884 if (a->intrinsic || a->pure || a->implicit_pure)
5885 return 0;
5886
5887 caller_sym = (gfc_symbol *) sym_data;
5888 gfc_unset_implicit_pure (caller_sym);
5889 return 1;
5890 }
5891
5892 /* Callback function. If there is a call to a function which is
5893 neither pure nor implicit_pure, unset the implicit_pure flag for
5894 the caller and return 1. */
5895
5896 static int
5897 implicit_pure_expr (gfc_expr **e, int *walk ATTRIBUTE_UNUSED, void *sym_data)
5898 {
5899 gfc_expr *expr = *e;
5900 gfc_symbol *caller_sym;
5901 gfc_symbol *sym;
5902 symbol_attribute *a;
5903
5904 if (expr->expr_type != EXPR_FUNCTION || expr->value.function.isym)
5905 return 0;
5906
5907 sym = expr->symtree->n.sym;
5908 a = &sym->attr;
5909 if (a->pure || a->implicit_pure)
5910 return 0;
5911
5912 caller_sym = (gfc_symbol *) sym_data;
5913 gfc_unset_implicit_pure (caller_sym);
5914 return 1;
5915 }
5916
5917 /* Go through all procedures in the namespace and unset the
5918 implicit_pure attribute for any procedure that calls something not
5919 pure or implicit pure. */
5920
5921 bool
5922 gfc_fix_implicit_pure (gfc_namespace *ns)
5923 {
5924 bool changed = false;
5925 gfc_symbol *proc = ns->proc_name;
5926
5927 if (proc && proc->attr.flavor == FL_PROCEDURE && proc->attr.implicit_pure
5928 && ns->code
5929 && gfc_code_walker (&ns->code, implicit_pure_call, implicit_pure_expr,
5930 (void *) ns->proc_name))
5931 changed = true;
5932
5933 for (ns = ns->contained; ns; ns = ns->sibling)
5934 {
5935 if (gfc_fix_implicit_pure (ns))
5936 changed = true;
5937 }
5938
5939 return changed;
5940 }
Mirror of the offical gcc git repository hosted at gcc.gnu.org