?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
ada: Fix infinite loop with multiple limited with clauses
[official-gcc.git] / gcc / fortran / frontend-passes.cc
blob136a292807d3ce44a82529e7247a71abc60270d2
1 /* Pass manager for Fortran front end.
2 Copyright (C) 2010-2023 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 optimization of reductions to scalars. Transform ANY
428 ([f1,f2,f3, ...]) to f1 .or. f2 .or. f3 .or. ..., with ANY, SUM and PRODUCT
429 correspondingly. Handle 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 assignment 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_frontend_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->ts.type == BT_CHARACTER
2280 || fn->value.function.actual->expr->rank != 1)
2281 return;
2282
2283 *e = gfc_get_array_expr (fn->ts.type, fn->ts.kind, &fn->where);
2284 (*e)->shape = fn->shape;
2285 fn->rank = 0;
2286 fn->shape = NULL;
2287 gfc_constructor_append_expr (&(*e)->value.constructor, fn, &fn->where);
2288
2289 name = XALLOCAVEC (char, strlen (fn->value.function.name) + 1);
2290 strcpy (name, fn->value.function.name);
2291 p = strstr (name, "loc0");
2292 p[3] = '1';
2293 fn->value.function.name = gfc_get_string ("%s", name);
2294 if (fn->value.function.actual->next)
2295 {
2296 a = fn->value.function.actual->next;
2297 gcc_assert (a->expr == NULL);
2298 }
2299 else
2300 {
2301 a = gfc_get_actual_arglist ();
2302 fn->value.function.actual->next = a;
2303 }
2304 a->expr = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
2305 &fn->where);
2306 mpz_set_ui (a->expr->value.integer, 1);
2307 }
2308
2309 /* Data package to hand down for DO loop checks in a contained
2310 procedure. */
2311 typedef struct contained_info
2312 {
2313 gfc_symbol *do_var;
2314 gfc_symbol *procedure;
2315 locus where_do;
2316 } contained_info;
2317
2318 static enum gfc_exec_op last_io_op;
2319
2320 /* Callback function to check for INTENT(OUT) and INTENT(INOUT) in a
2321 contained function call. */
2322
2323 static int
2324 doloop_contained_function_call (gfc_expr **e,
2325 int *walk_subtrees ATTRIBUTE_UNUSED, void *data)
2326 {
2327 gfc_expr *expr = *e;
2328 gfc_formal_arglist *f;
2329 gfc_actual_arglist *a;
2330 gfc_symbol *sym, *do_var;
2331 contained_info *info;
2332
2333 if (expr->expr_type != EXPR_FUNCTION || expr->value.function.isym
2334 || expr->value.function.esym == NULL)
2335 return 0;
2336
2337 sym = expr->value.function.esym;
2338 f = gfc_sym_get_dummy_args (sym);
2339 if (f == NULL)
2340 return 0;
2341
2342 info = (contained_info *) data;
2343 do_var = info->do_var;
2344 a = expr->value.function.actual;
2345
2346 while (a && f)
2347 {
2348 if (a->expr && a->expr->symtree && a->expr->symtree->n.sym == do_var)
2349 {
2350 if (f->sym->attr.intent == INTENT_OUT)
2351 {
2352 gfc_error_now ("Index variable %qs set to undefined as "
2353 "INTENT(OUT) argument at %L in procedure %qs "
2354 "called from within DO loop at %L", do_var->name,
2355 &a->expr->where, info->procedure->name,
2356 &info->where_do);
2357 return 1;
2358 }
2359 else if (f->sym->attr.intent == INTENT_INOUT)
2360 {
2361 gfc_error_now ("Index variable %qs not definable as "
2362 "INTENT(INOUT) argument at %L in procedure %qs "
2363 "called from within DO loop at %L", do_var->name,
2364 &a->expr->where, info->procedure->name,
2365 &info->where_do);
2366 return 1;
2367 }
2368 }
2369 a = a->next;
2370 f = f->next;
2371 }
2372 return 0;
2373 }
2374
2375 /* Callback function that goes through the code in a contained
2376 procedure to make sure it does not change a variable in a DO
2377 loop. */
2378
2379 static int
2380 doloop_contained_procedure_code (gfc_code **c,
2381 int *walk_subtrees ATTRIBUTE_UNUSED,
2382 void *data)
2383 {
2384 gfc_code *co = *c;
2385 contained_info *info = (contained_info *) data;
2386 gfc_symbol *do_var = info->do_var;
2387 const char *errmsg = _("Index variable %qs redefined at %L in procedure %qs "
2388 "called from within DO loop at %L");
2389 static enum gfc_exec_op saved_io_op;
2390
2391 switch (co->op)
2392 {
2393 case EXEC_ASSIGN:
2394 if (co->expr1->symtree && co->expr1->symtree->n.sym == do_var)
2395 gfc_error_now (errmsg, do_var->name, &co->loc, info->procedure->name,
2396 &info->where_do);
2397 break;
2398
2399 case EXEC_DO:
2400 if (co->ext.iterator && co->ext.iterator->var
2401 && co->ext.iterator->var->symtree->n.sym == do_var)
2402 gfc_error (errmsg, do_var->name, &co->loc, info->procedure->name,
2403 &info->where_do);
2404 break;
2405
2406 case EXEC_READ:
2407 case EXEC_WRITE:
2408 case EXEC_INQUIRE:
2409 case EXEC_IOLENGTH:
2410 saved_io_op = last_io_op;
2411 last_io_op = co->op;
2412 break;
2413
2414 case EXEC_OPEN:
2415 if (co->ext.open && co->ext.open->iostat
2416 && co->ext.open->iostat->symtree->n.sym == do_var)
2417 gfc_error_now (errmsg, do_var->name, &co->ext.open->iostat->where,
2418 info->procedure->name, &info->where_do);
2419 break;
2420
2421 case EXEC_CLOSE:
2422 if (co->ext.close && co->ext.close->iostat
2423 && co->ext.close->iostat->symtree->n.sym == do_var)
2424 gfc_error_now (errmsg, do_var->name, &co->ext.close->iostat->where,
2425 info->procedure->name, &info->where_do);
2426 break;
2427
2428 case EXEC_TRANSFER:
2429 switch (last_io_op)
2430 {
2431
2432 case EXEC_INQUIRE:
2433 #define CHECK_INQ(a) do { if (co->ext.inquire && \
2434 co->ext.inquire->a && \
2435 co->ext.inquire->a->symtree->n.sym == do_var) \
2436 gfc_error_now (errmsg, do_var->name, \
2437 &co->ext.inquire->a->where, \
2438 info->procedure->name, \
2439 &info->where_do); \
2440 } while (0)
2441
2442 CHECK_INQ(iostat);
2443 CHECK_INQ(number);
2444 CHECK_INQ(position);
2445 CHECK_INQ(recl);
2446 CHECK_INQ(position);
2447 CHECK_INQ(iolength);
2448 CHECK_INQ(strm_pos);
2449 break;
2450 #undef CHECK_INQ
2451
2452 case EXEC_READ:
2453 if (co->expr1 && co->expr1->symtree
2454 && co->expr1->symtree->n.sym == do_var)
2455 gfc_error_now (errmsg, do_var->name, &co->expr1->where,
2456 info->procedure->name, &info->where_do);
2457
2458 /* Fallthrough. */
2459
2460 case EXEC_WRITE:
2461 if (co->ext.dt && co->ext.dt->iostat && co->ext.dt->iostat->symtree
2462 && co->ext.dt->iostat->symtree->n.sym == do_var)
2463 gfc_error_now (errmsg, do_var->name, &co->ext.dt->iostat->where,
2464 info->procedure->name, &info->where_do);
2465 break;
2466
2467 case EXEC_IOLENGTH:
2468 if (co->expr1 && co->expr1->symtree
2469 && co->expr1->symtree->n.sym == do_var)
2470 gfc_error_now (errmsg, do_var->name, &co->expr1->where,
2471 info->procedure->name, &info->where_do);
2472 break;
2473
2474 default:
2475 gcc_unreachable ();
2476 }
2477 break;
2478
2479 case EXEC_DT_END:
2480 last_io_op = saved_io_op;
2481 break;
2482
2483 case EXEC_CALL:
2484 gfc_formal_arglist *f;
2485 gfc_actual_arglist *a;
2486
2487 f = gfc_sym_get_dummy_args (co->resolved_sym);
2488 if (f == NULL)
2489 break;
2490 a = co->ext.actual;
2491 /* Slightly different error message here. If there is an error,
2492 return 1 to avoid an infinite loop. */
2493 while (a && f)
2494 {
2495 if (a->expr && a->expr->symtree && a->expr->symtree->n.sym == do_var)
2496 {
2497 if (f->sym->attr.intent == INTENT_OUT)
2498 {
2499 gfc_error_now ("Index variable %qs set to undefined as "
2500 "INTENT(OUT) argument at %L in subroutine %qs "
2501 "called from within DO loop at %L",
2502 do_var->name, &a->expr->where,
2503 info->procedure->name, &info->where_do);
2504 return 1;
2505 }
2506 else if (f->sym->attr.intent == INTENT_INOUT)
2507 {
2508 gfc_error_now ("Index variable %qs not definable as "
2509 "INTENT(INOUT) argument at %L in subroutine %qs "
2510 "called from within DO loop at %L", do_var->name,
2511 &a->expr->where, info->procedure->name,
2512 &info->where_do);
2513 return 1;
2514 }
2515 }
2516 a = a->next;
2517 f = f->next;
2518 }
2519 break;
2520 default:
2521 break;
2522 }
2523 return 0;
2524 }
2525
2526 /* Callback function for code checking that we do not pass a DO variable to an
2527 INTENT(OUT) or INTENT(INOUT) dummy variable. */
2528
2529 static int
2530 doloop_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
2531 void *data ATTRIBUTE_UNUSED)
2532 {
2533 gfc_code *co;
2534 int i;
2535 gfc_formal_arglist *f;
2536 gfc_actual_arglist *a;
2537 gfc_code *cl;
2538 do_t loop, *lp;
2539 bool seen_goto;
2540
2541 co = *c;
2542
2543 /* If the doloop_list grew, we have to truncate it here. */
2544
2545 if ((unsigned) doloop_level < doloop_list.length())
2546 doloop_list.truncate (doloop_level);
2547
2548 seen_goto = false;
2549 switch (co->op)
2550 {
2551 case EXEC_DO:
2552
2553 if (co->ext.iterator && co->ext.iterator->var)
2554 loop.c = co;
2555 else
2556 loop.c = NULL;
2557
2558 loop.branch_level = if_level + select_level;
2559 loop.seen_goto = false;
2560 doloop_list.safe_push (loop);
2561 break;
2562
2563 /* If anything could transfer control away from a suspicious
2564 subscript, make sure to set seen_goto in the current DO loop
2565 (if any). */
2566 case EXEC_GOTO:
2567 case EXEC_EXIT:
2568 case EXEC_STOP:
2569 case EXEC_ERROR_STOP:
2570 case EXEC_CYCLE:
2571 seen_goto = true;
2572 break;
2573
2574 case EXEC_OPEN:
2575 if (co->ext.open->err)
2576 seen_goto = true;
2577 break;
2578
2579 case EXEC_CLOSE:
2580 if (co->ext.close->err)
2581 seen_goto = true;
2582 break;
2583
2584 case EXEC_BACKSPACE:
2585 case EXEC_ENDFILE:
2586 case EXEC_REWIND:
2587 case EXEC_FLUSH:
2588
2589 if (co->ext.filepos->err)
2590 seen_goto = true;
2591 break;
2592
2593 case EXEC_INQUIRE:
2594 if (co->ext.filepos->err)
2595 seen_goto = true;
2596 break;
2597
2598 case EXEC_READ:
2599 case EXEC_WRITE:
2600 if (co->ext.dt->err || co->ext.dt->end || co->ext.dt->eor)
2601 seen_goto = true;
2602 break;
2603
2604 case EXEC_WAIT:
2605 if (co->ext.wait->err || co->ext.wait->end || co->ext.wait->eor)
2606 loop.seen_goto = true;
2607 break;
2608
2609 case EXEC_CALL:
2610 if (co->resolved_sym == NULL)
2611 break;
2612
2613 /* Test if somebody stealthily changes the DO variable from
2614 under us by changing it in a host-associated procedure. */
2615 if (co->resolved_sym->attr.contained)
2616 {
2617 FOR_EACH_VEC_ELT (doloop_list, i, lp)
2618 {
2619 gfc_symbol *sym = co->resolved_sym;
2620 contained_info info;
2621 gfc_namespace *ns;
2622
2623 cl = lp->c;
2624 info.do_var = cl->ext.iterator->var->symtree->n.sym;
2625 info.procedure = co->resolved_sym; /* sym? */
2626 info.where_do = co->loc;
2627 /* Look contained procedures under the namespace of the
2628 variable. */
2629 for (ns = info.do_var->ns->contained; ns; ns = ns->sibling)
2630 if (ns->proc_name && ns->proc_name == sym)
2631 gfc_code_walker (&ns->code, doloop_contained_procedure_code,
2632 doloop_contained_function_call, &info);
2633 }
2634 }
2635
2636 f = gfc_sym_get_dummy_args (co->resolved_sym);
2637
2638 /* Withot a formal arglist, there is only unknown INTENT,
2639 which we don't check for. */
2640 if (f == NULL)
2641 break;
2642
2643 a = co->ext.actual;
2644
2645 while (a && f)
2646 {
2647 FOR_EACH_VEC_ELT (doloop_list, i, lp)
2648 {
2649 gfc_symbol *do_sym;
2650 cl = lp->c;
2651
2652 if (cl == NULL)
2653 break;
2654
2655 do_sym = cl->ext.iterator->var->symtree->n.sym;
2656
2657 if (a->expr && a->expr->symtree && f->sym
2658 && a->expr->symtree->n.sym == do_sym)
2659 {
2660 if (f->sym->attr.intent == INTENT_OUT)
2661 gfc_error_now ("Variable %qs at %L set to undefined "
2662 "value inside loop beginning at %L as "
2663 "INTENT(OUT) argument to subroutine %qs",
2664 do_sym->name, &a->expr->where,
2665 &(doloop_list[i].c->loc),
2666 co->symtree->n.sym->name);
2667 else if (f->sym->attr.intent == INTENT_INOUT)
2668 gfc_error_now ("Variable %qs at %L not definable inside "
2669 "loop beginning at %L as INTENT(INOUT) "
2670 "argument to subroutine %qs",
2671 do_sym->name, &a->expr->where,
2672 &(doloop_list[i].c->loc),
2673 co->symtree->n.sym->name);
2674 }
2675 }
2676 a = a->next;
2677 f = f->next;
2678 }
2679
2680 break;
2681
2682 default:
2683 break;
2684 }
2685 if (seen_goto && doloop_level > 0)
2686 doloop_list[doloop_level-1].seen_goto = true;
2687
2688 return 0;
2689 }
2690
2691 /* Callback function to warn about different things within DO loops. */
2692
2693 static int
2694 do_function (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
2695 void *data ATTRIBUTE_UNUSED)
2696 {
2697 do_t *last;
2698
2699 if (doloop_list.length () == 0)
2700 return 0;
2701
2702 if ((*e)->expr_type == EXPR_FUNCTION)
2703 do_intent (e);
2704
2705 last = &doloop_list.last();
2706 if (last->seen_goto && !warn_do_subscript)
2707 return 0;
2708
2709 if ((*e)->expr_type == EXPR_VARIABLE)
2710 do_subscript (e);
2711
2712 return 0;
2713 }
2714
2715 typedef struct
2716 {
2717 gfc_symbol *sym;
2718 mpz_t val;
2719 } insert_index_t;
2720
2721 /* Callback function - if the expression is the variable in data->sym,
2722 replace it with a constant from data->val. */
2723
2724 static int
2725 callback_insert_index (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
2726 void *data)
2727 {
2728 insert_index_t *d;
2729 gfc_expr *ex, *n;
2730
2731 ex = (*e);
2732 if (ex->expr_type != EXPR_VARIABLE)
2733 return 0;
2734
2735 d = (insert_index_t *) data;
2736 if (ex->symtree->n.sym != d->sym)
2737 return 0;
2738
2739 n = gfc_get_constant_expr (BT_INTEGER, ex->ts.kind, &ex->where);
2740 mpz_set (n->value.integer, d->val);
2741
2742 gfc_free_expr (ex);
2743 *e = n;
2744 return 0;
2745 }
2746
2747 /* In the expression e, replace occurrences of the variable sym with
2748 val. If this results in a constant expression, return true and
2749 return the value in ret. Return false if the expression already
2750 is a constant. Caller has to clear ret in that case. */
2751
2752 static bool
2753 insert_index (gfc_expr *e, gfc_symbol *sym, mpz_t val, mpz_t ret)
2754 {
2755 gfc_expr *n;
2756 insert_index_t data;
2757 bool rc;
2758
2759 if (e->expr_type == EXPR_CONSTANT)
2760 return false;
2761
2762 n = gfc_copy_expr (e);
2763 data.sym = sym;
2764 mpz_init_set (data.val, val);
2765 gfc_expr_walker (&n, callback_insert_index, (void *) &data);
2766
2767 /* Suppress errors here - we could get errors here such as an
2768 out of bounds access for arrays, see PR 90563. */
2769 gfc_push_suppress_errors ();
2770 gfc_simplify_expr (n, 0);
2771 gfc_pop_suppress_errors ();
2772
2773 if (n->expr_type == EXPR_CONSTANT)
2774 {
2775 rc = true;
2776 mpz_init_set (ret, n->value.integer);
2777 }
2778 else
2779 rc = false;
2780
2781 mpz_clear (data.val);
2782 gfc_free_expr (n);
2783 return rc;
2784
2785 }
2786
2787 /* Check array subscripts for possible out-of-bounds accesses in DO
2788 loops with constant bounds. */
2789
2790 static int
2791 do_subscript (gfc_expr **e)
2792 {
2793 gfc_expr *v;
2794 gfc_array_ref *ar;
2795 gfc_ref *ref;
2796 int i,j;
2797 gfc_code *dl;
2798 do_t *lp;
2799
2800 v = *e;
2801 /* Constants are already checked. */
2802 if (v->expr_type == EXPR_CONSTANT)
2803 return 0;
2804
2805 /* Wrong warnings will be generated in an associate list. */
2806 if (in_assoc_list)
2807 return 0;
2808
2809 /* We already warned about this. */
2810 if (v->do_not_warn)
2811 return 0;
2812
2813 v->do_not_warn = 1;
2814
2815 for (ref = v->ref; ref; ref = ref->next)
2816 {
2817 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT)
2818 {
2819 ar = & ref->u.ar;
2820 FOR_EACH_VEC_ELT (doloop_list, j, lp)
2821 {
2822 gfc_symbol *do_sym;
2823 mpz_t do_start, do_step, do_end;
2824 bool have_do_start, have_do_end;
2825 bool error_not_proven;
2826 int warn;
2827 int sgn;
2828
2829 dl = lp->c;
2830 if (dl == NULL)
2831 break;
2832
2833 /* If we are within a branch, or a goto or equivalent
2834 was seen in the DO loop before, then we cannot prove that
2835 this expression is actually evaluated. Don't do anything
2836 unless we want to see it all. */
2837 error_not_proven = lp->seen_goto
2838 || lp->branch_level < if_level + select_level;
2839
2840 if (error_not_proven && !warn_do_subscript)
2841 break;
2842
2843 if (error_not_proven)
2844 warn = OPT_Wdo_subscript;
2845 else
2846 warn = 0;
2847
2848 do_sym = dl->ext.iterator->var->symtree->n.sym;
2849 if (do_sym->ts.type != BT_INTEGER)
2850 continue;
2851
2852 /* If we do not know about the stepsize, the loop may be zero trip.
2853 Do not warn in this case. */
2854
2855 if (dl->ext.iterator->step->expr_type == EXPR_CONSTANT)
2856 {
2857 sgn = mpz_cmp_ui (dl->ext.iterator->step->value.integer, 0);
2858 /* This can happen, but then the error has been
2859 reported previously. */
2860 if (sgn == 0)
2861 continue;
2862
2863 mpz_init_set (do_step, dl->ext.iterator->step->value.integer);
2864 }
2865
2866 else
2867 continue;
2868
2869 if (dl->ext.iterator->start->expr_type == EXPR_CONSTANT)
2870 {
2871 have_do_start = true;
2872 mpz_init_set (do_start, dl->ext.iterator->start->value.integer);
2873 }
2874 else
2875 have_do_start = false;
2876
2877 if (dl->ext.iterator->end->expr_type == EXPR_CONSTANT)
2878 {
2879 have_do_end = true;
2880 mpz_init_set (do_end, dl->ext.iterator->end->value.integer);
2881 }
2882 else
2883 have_do_end = false;
2884
2885 if (!have_do_start && !have_do_end)
2886 {
2887 mpz_clear (do_step);
2888 return 0;
2889 }
2890
2891 /* No warning inside a zero-trip loop. */
2892 if (have_do_start && have_do_end)
2893 {
2894 int cmp;
2895
2896 cmp = mpz_cmp (do_end, do_start);
2897 if ((sgn > 0 && cmp < 0) || (sgn < 0 && cmp > 0))
2898 {
2899 mpz_clear (do_start);
2900 mpz_clear (do_end);
2901 mpz_clear (do_step);
2902 break;
2903 }
2904 }
2905
2906 /* May have to correct the end value if the step does not equal
2907 one. */
2908 if (have_do_start && have_do_end && mpz_cmp_ui (do_step, 1) != 0)
2909 {
2910 mpz_t diff, rem;
2911
2912 mpz_init (diff);
2913 mpz_init (rem);
2914 mpz_sub (diff, do_end, do_start);
2915 mpz_tdiv_r (rem, diff, do_step);
2916 mpz_sub (do_end, do_end, rem);
2917 mpz_clear (diff);
2918 mpz_clear (rem);
2919 }
2920
2921 for (i = 0; i< ar->dimen; i++)
2922 {
2923 mpz_t val;
2924 if (ar->dimen_type[i] == DIMEN_ELEMENT && have_do_start
2925 && insert_index (ar->start[i], do_sym, do_start, val))
2926 {
2927 if (ar->as->lower[i]
2928 && ar->as->lower[i]->expr_type == EXPR_CONSTANT
2929 && ar->as->lower[i]->ts.type == BT_INTEGER
2930 && mpz_cmp (val, ar->as->lower[i]->value.integer) < 0)
2931 gfc_warning (warn, "Array reference at %L out of bounds "
2932 "(%ld < %ld) in loop beginning at %L",
2933 &ar->start[i]->where, mpz_get_si (val),
2934 mpz_get_si (ar->as->lower[i]->value.integer),
2935 &doloop_list[j].c->loc);
2936
2937 if (ar->as->upper[i]
2938 && ar->as->upper[i]->expr_type == EXPR_CONSTANT
2939 && ar->as->upper[i]->ts.type == BT_INTEGER
2940 && mpz_cmp (val, ar->as->upper[i]->value.integer) > 0)
2941 gfc_warning (warn, "Array reference at %L out of bounds "
2942 "(%ld > %ld) in loop beginning at %L",
2943 &ar->start[i]->where, mpz_get_si (val),
2944 mpz_get_si (ar->as->upper[i]->value.integer),
2945 &doloop_list[j].c->loc);
2946
2947 mpz_clear (val);
2948 }
2949
2950 if (ar->dimen_type[i] == DIMEN_ELEMENT && have_do_end
2951 && insert_index (ar->start[i], do_sym, do_end, val))
2952 {
2953 if (ar->as->lower[i]
2954 && ar->as->lower[i]->expr_type == EXPR_CONSTANT
2955 && ar->as->lower[i]->ts.type == BT_INTEGER
2956 && mpz_cmp (val, ar->as->lower[i]->value.integer) < 0)
2957 gfc_warning (warn, "Array reference at %L out of bounds "
2958 "(%ld < %ld) in loop beginning at %L",
2959 &ar->start[i]->where, mpz_get_si (val),
2960 mpz_get_si (ar->as->lower[i]->value.integer),
2961 &doloop_list[j].c->loc);
2962
2963 if (ar->as->upper[i]
2964 && ar->as->upper[i]->expr_type == EXPR_CONSTANT
2965 && ar->as->upper[i]->ts.type == BT_INTEGER
2966 && mpz_cmp (val, ar->as->upper[i]->value.integer) > 0)
2967 gfc_warning (warn, "Array reference at %L out of bounds "
2968 "(%ld > %ld) in loop beginning at %L",
2969 &ar->start[i]->where, mpz_get_si (val),
2970 mpz_get_si (ar->as->upper[i]->value.integer),
2971 &doloop_list[j].c->loc);
2972
2973 mpz_clear (val);
2974 }
2975 }
2976
2977 if (have_do_start)
2978 mpz_clear (do_start);
2979 if (have_do_end)
2980 mpz_clear (do_end);
2981 mpz_clear (do_step);
2982 }
2983 }
2984 }
2985 return 0;
2986 }
2987 /* Function for functions checking that we do not pass a DO variable
2988 to an INTENT(OUT) or INTENT(INOUT) dummy variable. */
2989
2990 static int
2991 do_intent (gfc_expr **e)
2992 {
2993 gfc_formal_arglist *f;
2994 gfc_actual_arglist *a;
2995 gfc_expr *expr;
2996 gfc_code *dl;
2997 do_t *lp;
2998 int i;
2999 gfc_symbol *sym;
3000
3001 expr = *e;
3002 if (expr->expr_type != EXPR_FUNCTION)
3003 return 0;
3004
3005 /* Intrinsic functions don't modify their arguments. */
3006
3007 if (expr->value.function.isym)
3008 return 0;
3009
3010 sym = expr->value.function.esym;
3011 if (sym == NULL)
3012 return 0;
3013
3014 if (sym->attr.contained)
3015 {
3016 FOR_EACH_VEC_ELT (doloop_list, i, lp)
3017 {
3018 contained_info info;
3019 gfc_namespace *ns;
3020
3021 dl = lp->c;
3022 info.do_var = dl->ext.iterator->var->symtree->n.sym;
3023 info.procedure = sym;
3024 info.where_do = expr->where;
3025 /* Look contained procedures under the namespace of the
3026 variable. */
3027 for (ns = info.do_var->ns->contained; ns; ns = ns->sibling)
3028 if (ns->proc_name && ns->proc_name == sym)
3029 gfc_code_walker (&ns->code, doloop_contained_procedure_code,
3030 dummy_expr_callback, &info);
3031 }
3032 }
3033
3034 f = gfc_sym_get_dummy_args (sym);
3035
3036 /* Without a formal arglist, there is only unknown INTENT,
3037 which we don't check for. */
3038 if (f == NULL)
3039 return 0;
3040
3041 a = expr->value.function.actual;
3042
3043 while (a && f)
3044 {
3045 FOR_EACH_VEC_ELT (doloop_list, i, lp)
3046 {
3047 gfc_symbol *do_sym;
3048 dl = lp->c;
3049 if (dl == NULL)
3050 break;
3051
3052 do_sym = dl->ext.iterator->var->symtree->n.sym;
3053
3054 if (a->expr && a->expr->symtree
3055 && a->expr->symtree->n.sym == do_sym
3056 && f->sym)
3057 {
3058 if (f->sym->attr.intent == INTENT_OUT)
3059 gfc_error_now ("Variable %qs at %L set to undefined value "
3060 "inside loop beginning at %L as INTENT(OUT) "
3061 "argument to function %qs", do_sym->name,
3062 &a->expr->where, &doloop_list[i].c->loc,
3063 expr->symtree->n.sym->name);
3064 else if (f->sym->attr.intent == INTENT_INOUT)
3065 gfc_error_now ("Variable %qs at %L not definable inside loop"
3066 " beginning at %L as INTENT(INOUT) argument to"
3067 " function %qs", do_sym->name,
3068 &a->expr->where, &doloop_list[i].c->loc,
3069 expr->symtree->n.sym->name);
3070 }
3071 }
3072 a = a->next;
3073 f = f->next;
3074 }
3075
3076 return 0;
3077 }
3078
3079 static void
3080 doloop_warn (gfc_namespace *ns)
3081 {
3082 gfc_code_walker (&ns->code, doloop_code, do_function, NULL);
3083
3084 for (ns = ns->contained; ns; ns = ns->sibling)
3085 {
3086 if (ns->code == NULL || ns->code->op != EXEC_BLOCK)
3087 doloop_warn (ns);
3088 }
3089 }
3090
3091 /* This selction deals with inlining calls to MATMUL. */
3092
3093 /* Replace calls to matmul outside of straight assignments with a temporary
3094 variable so that later inlining will work. */
3095
3096 static int
3097 matmul_to_var_expr (gfc_expr **ep, int *walk_subtrees ATTRIBUTE_UNUSED,
3098 void *data)
3099 {
3100 gfc_expr *e, *n;
3101 bool *found = (bool *) data;
3102
3103 e = *ep;
3104
3105 if (e->expr_type != EXPR_FUNCTION
3106 || e->value.function.isym == NULL
3107 || e->value.function.isym->id != GFC_ISYM_MATMUL)
3108 return 0;
3109
3110 if (forall_level > 0 || iterator_level > 0 || in_omp_workshare
3111 || in_omp_atomic || in_where || in_assoc_list)
3112 return 0;
3113
3114 /* Check if this is already in the form c = matmul(a,b). */
3115
3116 if ((*current_code)->expr2 == e)
3117 return 0;
3118
3119 n = create_var (e, "matmul");
3120
3121 /* If create_var is unable to create a variable (for example if
3122 -fno-realloc-lhs is in force with a variable that does not have bounds
3123 known at compile-time), just return. */
3124
3125 if (n == NULL)
3126 return 0;
3127
3128 *ep = n;
3129 *found = true;
3130 return 0;
3131 }
3132
3133 /* Set current_code and associated variables so that matmul_to_var_expr can
3134 work. */
3135
3136 static int
3137 matmul_to_var_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
3138 void *data ATTRIBUTE_UNUSED)
3139 {
3140 if (current_code != c)
3141 {
3142 current_code = c;
3143 inserted_block = NULL;
3144 changed_statement = NULL;
3145 }
3146
3147 return 0;
3148 }
3149
3150
3151 /* Take a statement of the shape c = matmul(a,b) and create temporaries
3152 for a and b if there is a dependency between the arguments and the
3153 result variable or if a or b are the result of calculations that cannot
3154 be handled by the inliner. */
3155
3156 static int
3157 matmul_temp_args (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
3158 void *data ATTRIBUTE_UNUSED)
3159 {
3160 gfc_expr *expr1, *expr2;
3161 gfc_code *co;
3162 gfc_actual_arglist *a, *b;
3163 bool a_tmp, b_tmp;
3164 gfc_expr *matrix_a, *matrix_b;
3165 bool conjg_a, conjg_b, transpose_a, transpose_b;
3166
3167 co = *c;
3168
3169 if (co->op != EXEC_ASSIGN)
3170 return 0;
3171
3172 if (forall_level > 0 || iterator_level > 0 || in_omp_workshare
3173 || in_omp_atomic || in_where)
3174 return 0;
3175
3176 /* This has some duplication with inline_matmul_assign. This
3177 is because the creation of temporary variables could still fail,
3178 and inline_matmul_assign still needs to be able to handle these
3179 cases. */
3180 expr1 = co->expr1;
3181 expr2 = co->expr2;
3182
3183 if (expr2->expr_type != EXPR_FUNCTION
3184 || expr2->value.function.isym == NULL
3185 || expr2->value.function.isym->id != GFC_ISYM_MATMUL)
3186 return 0;
3187
3188 a_tmp = false;
3189 a = expr2->value.function.actual;
3190 matrix_a = check_conjg_transpose_variable (a->expr, &conjg_a, &transpose_a);
3191 if (matrix_a != NULL)
3192 {
3193 if (matrix_a->expr_type == EXPR_VARIABLE
3194 && (gfc_check_dependency (matrix_a, expr1, true)
3195 || gfc_has_dimen_vector_ref (matrix_a)))
3196 a_tmp = true;
3197 }
3198 else
3199 a_tmp = true;
3200
3201 b_tmp = false;
3202 b = a->next;
3203 matrix_b = check_conjg_transpose_variable (b->expr, &conjg_b, &transpose_b);
3204 if (matrix_b != NULL)
3205 {
3206 if (matrix_b->expr_type == EXPR_VARIABLE
3207 && (gfc_check_dependency (matrix_b, expr1, true)
3208 || gfc_has_dimen_vector_ref (matrix_b)))
3209 b_tmp = true;
3210 }
3211 else
3212 b_tmp = true;
3213
3214 if (!a_tmp && !b_tmp)
3215 return 0;
3216
3217 current_code = c;
3218 inserted_block = NULL;
3219 changed_statement = NULL;
3220 if (a_tmp)
3221 {
3222 gfc_expr *at;
3223 at = create_var (a->expr,"mma");
3224 if (at)
3225 a->expr = at;
3226 }
3227 if (b_tmp)
3228 {
3229 gfc_expr *bt;
3230 bt = create_var (b->expr,"mmb");
3231 if (bt)
3232 b->expr = bt;
3233 }
3234 return 0;
3235 }
3236
3237 /* Auxiliary function to build and simplify an array inquiry function.
3238 dim is zero-based. */
3239
3240 static gfc_expr *
3241 get_array_inq_function (gfc_isym_id id, gfc_expr *e, int dim, int okind = 0)
3242 {
3243 gfc_expr *fcn;
3244 gfc_expr *dim_arg, *kind;
3245 const char *name;
3246 gfc_expr *ec;
3247
3248 switch (id)
3249 {
3250 case GFC_ISYM_LBOUND:
3251 name = "_gfortran_lbound";
3252 break;
3253
3254 case GFC_ISYM_UBOUND:
3255 name = "_gfortran_ubound";
3256 break;
3257
3258 case GFC_ISYM_SIZE:
3259 name = "_gfortran_size";
3260 break;
3261
3262 default:
3263 gcc_unreachable ();
3264 }
3265
3266 dim_arg = gfc_get_int_expr (gfc_default_integer_kind, &e->where, dim);
3267 if (okind != 0)
3268 kind = gfc_get_int_expr (gfc_default_integer_kind, &e->where,
3269 okind);
3270 else
3271 kind = gfc_get_int_expr (gfc_default_integer_kind, &e->where,
3272 gfc_index_integer_kind);
3273
3274 ec = gfc_copy_expr (e);
3275
3276 /* No bounds checking, this will be done before the loops if -fcheck=bounds
3277 is in effect. */
3278 ec->no_bounds_check = 1;
3279 fcn = gfc_build_intrinsic_call (current_ns, id, name, e->where, 3,
3280 ec, dim_arg, kind);
3281 gfc_simplify_expr (fcn, 0);
3282 fcn->no_bounds_check = 1;
3283 return fcn;
3284 }
3285
3286 /* Builds a logical expression. */
3287
3288 static gfc_expr*
3289 build_logical_expr (gfc_intrinsic_op op, gfc_expr *e1, gfc_expr *e2)
3290 {
3291 gfc_typespec ts;
3292 gfc_expr *res;
3293
3294 ts.type = BT_LOGICAL;
3295 ts.kind = gfc_default_logical_kind;
3296 res = gfc_get_expr ();
3297 res->where = e1->where;
3298 res->expr_type = EXPR_OP;
3299 res->value.op.op = op;
3300 res->value.op.op1 = e1;
3301 res->value.op.op2 = e2;
3302 res->ts = ts;
3303
3304 return res;
3305 }
3306
3307
3308 /* Return an operation of one two gfc_expr (one if e2 is NULL). This assumes
3309 compatible typespecs. */
3310
3311 static gfc_expr *
3312 get_operand (gfc_intrinsic_op op, gfc_expr *e1, gfc_expr *e2)
3313 {
3314 gfc_expr *res;
3315
3316 res = gfc_get_expr ();
3317 res->ts = e1->ts;
3318 res->where = e1->where;
3319 res->expr_type = EXPR_OP;
3320 res->value.op.op = op;
3321 res->value.op.op1 = e1;
3322 res->value.op.op2 = e2;
3323 gfc_simplify_expr (res, 0);
3324 return res;
3325 }
3326
3327 /* Generate the IF statement for a runtime check if we want to do inlining or
3328 not - putting in the code for both branches and putting it into the syntax
3329 tree is the caller's responsibility. For fixed array sizes, this should be
3330 removed by DCE. Only called for rank-two matrices A and B. */
3331
3332 static gfc_code *
3333 inline_limit_check (gfc_expr *a, gfc_expr *b, int limit, int rank_a)
3334 {
3335 gfc_expr *inline_limit;
3336 gfc_code *if_1, *if_2, *else_2;
3337 gfc_expr *b2, *a2, *a1, *m1, *m2;
3338 gfc_typespec ts;
3339 gfc_expr *cond;
3340
3341 gcc_assert (rank_a == 1 || rank_a == 2);
3342
3343 /* Calculation is done in real to avoid integer overflow. */
3344
3345 inline_limit = gfc_get_constant_expr (BT_REAL, gfc_default_real_kind,
3346 &a->where);
3347 mpfr_set_si (inline_limit->value.real, limit, GFC_RND_MODE);
3348
3349 /* Set the limit according to the rank. */
3350 mpfr_pow_ui (inline_limit->value.real, inline_limit->value.real, rank_a + 1,
3351 GFC_RND_MODE);
3352
3353 a1 = get_array_inq_function (GFC_ISYM_SIZE, a, 1);
3354
3355 /* For a_rank = 1, must use one as the size of a along the second
3356 dimension as to avoid too much code duplication. */
3357
3358 if (rank_a == 2)
3359 a2 = get_array_inq_function (GFC_ISYM_SIZE, a, 2);
3360 else
3361 a2 = gfc_get_int_expr (gfc_index_integer_kind, &a->where, 1);
3362
3363 b2 = get_array_inq_function (GFC_ISYM_SIZE, b, 2);
3364
3365 gfc_clear_ts (&ts);
3366 ts.type = BT_REAL;
3367 ts.kind = gfc_default_real_kind;
3368 gfc_convert_type_warn (a1, &ts, 2, 0);
3369 gfc_convert_type_warn (a2, &ts, 2, 0);
3370 gfc_convert_type_warn (b2, &ts, 2, 0);
3371
3372 m1 = get_operand (INTRINSIC_TIMES, a1, a2);
3373 m2 = get_operand (INTRINSIC_TIMES, m1, b2);
3374
3375 cond = build_logical_expr (INTRINSIC_LE, m2, inline_limit);
3376 gfc_simplify_expr (cond, 0);
3377
3378 else_2 = XCNEW (gfc_code);
3379 else_2->op = EXEC_IF;
3380 else_2->loc = a->where;
3381
3382 if_2 = XCNEW (gfc_code);
3383 if_2->op = EXEC_IF;
3384 if_2->expr1 = cond;
3385 if_2->loc = a->where;
3386 if_2->block = else_2;
3387
3388 if_1 = XCNEW (gfc_code);
3389 if_1->op = EXEC_IF;
3390 if_1->block = if_2;
3391 if_1->loc = a->where;
3392
3393 return if_1;
3394 }
3395
3396
3397 /* Insert code to issue a runtime error if the expressions are not equal. */
3398
3399 static gfc_code *
3400 runtime_error_ne (gfc_expr *e1, gfc_expr *e2, const char *msg)
3401 {
3402 gfc_expr *cond;
3403 gfc_code *if_1, *if_2;
3404 gfc_code *c;
3405 gfc_actual_arglist *a1, *a2, *a3;
3406
3407 gcc_assert (e1->where.lb);
3408 /* Build the call to runtime_error. */
3409 c = XCNEW (gfc_code);
3410 c->op = EXEC_CALL;
3411 c->loc = e1->where;
3412
3413 /* Get a null-terminated message string. */
3414
3415 a1 = gfc_get_actual_arglist ();
3416 a1->expr = gfc_get_character_expr (gfc_default_character_kind, &e1->where,
3417 msg, strlen(msg)+1);
3418 c->ext.actual = a1;
3419
3420 /* Pass the value of the first expression. */
3421 a2 = gfc_get_actual_arglist ();
3422 a2->expr = gfc_copy_expr (e1);
3423 a1->next = a2;
3424
3425 /* Pass the value of the second expression. */
3426 a3 = gfc_get_actual_arglist ();
3427 a3->expr = gfc_copy_expr (e2);
3428 a2->next = a3;
3429
3430 gfc_check_fe_runtime_error (c->ext.actual);
3431 gfc_resolve_fe_runtime_error (c);
3432
3433 if_2 = XCNEW (gfc_code);
3434 if_2->op = EXEC_IF;
3435 if_2->loc = e1->where;
3436 if_2->next = c;
3437
3438 if_1 = XCNEW (gfc_code);
3439 if_1->op = EXEC_IF;
3440 if_1->block = if_2;
3441 if_1->loc = e1->where;
3442
3443 cond = build_logical_expr (INTRINSIC_NE, e1, e2);
3444 gfc_simplify_expr (cond, 0);
3445 if_2->expr1 = cond;
3446
3447 return if_1;
3448 }
3449
3450 /* Handle matrix reallocation. Caller is responsible to insert into
3451 the code tree.
3452
3453 For the two-dimensional case, build
3454
3455 if (allocated(c)) then
3456 if (size(c,1) /= size(a,1) .or. size(c,2) /= size(b,2)) then
3457 deallocate(c)
3458 allocate (c(size(a,1), size(b,2)))
3459 end if
3460 else
3461 allocate (c(size(a,1),size(b,2)))
3462 end if
3463
3464 and for the other cases correspondingly.
3465 */
3466
3467 static gfc_code *
3468 matmul_lhs_realloc (gfc_expr *c, gfc_expr *a, gfc_expr *b,
3469 enum matrix_case m_case)
3470 {
3471
3472 gfc_expr *allocated, *alloc_expr;
3473 gfc_code *if_alloc_1, *if_alloc_2, *if_size_1, *if_size_2;
3474 gfc_code *else_alloc;
3475 gfc_code *deallocate, *allocate1, *allocate_else;
3476 gfc_array_ref *ar;
3477 gfc_expr *cond, *ne1, *ne2;
3478
3479 if (warn_realloc_lhs)
3480 gfc_warning (OPT_Wrealloc_lhs,
3481 "Code for reallocating the allocatable array at %L will "
3482 "be added", &c->where);
3483
3484 alloc_expr = gfc_copy_expr (c);
3485
3486 ar = gfc_find_array_ref (alloc_expr);
3487 gcc_assert (ar && ar->type == AR_FULL);
3488
3489 /* c comes in as a full ref. Change it into a copy and make it into an
3490 element ref so it has the right form for ALLOCATE. In the same
3491 switch statement, also generate the size comparison for the secod IF
3492 statement. */
3493
3494 ar->type = AR_ELEMENT;
3495
3496 switch (m_case)
3497 {
3498 case A2B2:
3499 ar->start[0] = get_array_inq_function (GFC_ISYM_SIZE, a, 1);
3500 ar->start[1] = get_array_inq_function (GFC_ISYM_SIZE, b, 2);
3501 ne1 = build_logical_expr (INTRINSIC_NE,
3502 get_array_inq_function (GFC_ISYM_SIZE, c, 1),
3503 get_array_inq_function (GFC_ISYM_SIZE, a, 1));
3504 ne2 = build_logical_expr (INTRINSIC_NE,
3505 get_array_inq_function (GFC_ISYM_SIZE, c, 2),
3506 get_array_inq_function (GFC_ISYM_SIZE, b, 2));
3507 cond = build_logical_expr (INTRINSIC_OR, ne1, ne2);
3508 break;
3509
3510 case A2B2T:
3511 ar->start[0] = get_array_inq_function (GFC_ISYM_SIZE, a, 1);
3512 ar->start[1] = get_array_inq_function (GFC_ISYM_SIZE, b, 1);
3513
3514 ne1 = build_logical_expr (INTRINSIC_NE,
3515 get_array_inq_function (GFC_ISYM_SIZE, c, 1),
3516 get_array_inq_function (GFC_ISYM_SIZE, a, 1));
3517 ne2 = build_logical_expr (INTRINSIC_NE,
3518 get_array_inq_function (GFC_ISYM_SIZE, c, 2),
3519 get_array_inq_function (GFC_ISYM_SIZE, b, 1));
3520 cond = build_logical_expr (INTRINSIC_OR, ne1, ne2);
3521 break;
3522
3523 case A2TB2:
3524
3525 ar->start[0] = get_array_inq_function (GFC_ISYM_SIZE, a, 2);
3526 ar->start[1] = get_array_inq_function (GFC_ISYM_SIZE, b, 2);
3527
3528 ne1 = build_logical_expr (INTRINSIC_NE,
3529 get_array_inq_function (GFC_ISYM_SIZE, c, 1),
3530 get_array_inq_function (GFC_ISYM_SIZE, a, 2));
3531 ne2 = build_logical_expr (INTRINSIC_NE,
3532 get_array_inq_function (GFC_ISYM_SIZE, c, 2),
3533 get_array_inq_function (GFC_ISYM_SIZE, b, 2));
3534 cond = build_logical_expr (INTRINSIC_OR, ne1, ne2);
3535 break;
3536
3537 case A2B1:
3538 ar->start[0] = get_array_inq_function (GFC_ISYM_SIZE, a, 1);
3539 cond = build_logical_expr (INTRINSIC_NE,
3540 get_array_inq_function (GFC_ISYM_SIZE, c, 1),
3541 get_array_inq_function (GFC_ISYM_SIZE, a, 2));
3542 break;
3543
3544 case A1B2:
3545 ar->start[0] = get_array_inq_function (GFC_ISYM_SIZE, b, 2);
3546 cond = build_logical_expr (INTRINSIC_NE,
3547 get_array_inq_function (GFC_ISYM_SIZE, c, 1),
3548 get_array_inq_function (GFC_ISYM_SIZE, b, 2));
3549 break;
3550
3551 case A2TB2T:
3552 /* This can only happen for BLAS, we do not handle that case in
3553 inline mamtul. */
3554 ar->start[0] = get_array_inq_function (GFC_ISYM_SIZE, a, 2);
3555 ar->start[1] = get_array_inq_function (GFC_ISYM_SIZE, b, 1);
3556
3557 ne1 = build_logical_expr (INTRINSIC_NE,
3558 get_array_inq_function (GFC_ISYM_SIZE, c, 1),
3559 get_array_inq_function (GFC_ISYM_SIZE, a, 2));
3560 ne2 = build_logical_expr (INTRINSIC_NE,
3561 get_array_inq_function (GFC_ISYM_SIZE, c, 2),
3562 get_array_inq_function (GFC_ISYM_SIZE, b, 1));
3563
3564 cond = build_logical_expr (INTRINSIC_OR, ne1, ne2);
3565 break;
3566
3567 default:
3568 gcc_unreachable();
3569
3570 }
3571
3572 gfc_simplify_expr (cond, 0);
3573
3574 /* We need two identical allocate statements in two
3575 branches of the IF statement. */
3576
3577 allocate1 = XCNEW (gfc_code);
3578 allocate1->op = EXEC_ALLOCATE;
3579 allocate1->ext.alloc.list = gfc_get_alloc ();
3580 allocate1->loc = c->where;
3581 allocate1->ext.alloc.list->expr = gfc_copy_expr (alloc_expr);
3582
3583 allocate_else = XCNEW (gfc_code);
3584 allocate_else->op = EXEC_ALLOCATE;
3585 allocate_else->ext.alloc.list = gfc_get_alloc ();
3586 allocate_else->loc = c->where;
3587 allocate_else->ext.alloc.list->expr = alloc_expr;
3588
3589 allocated = gfc_build_intrinsic_call (current_ns, GFC_ISYM_ALLOCATED,
3590 "_gfortran_allocated", c->where,
3591 1, gfc_copy_expr (c));
3592
3593 deallocate = XCNEW (gfc_code);
3594 deallocate->op = EXEC_DEALLOCATE;
3595 deallocate->ext.alloc.list = gfc_get_alloc ();
3596 deallocate->ext.alloc.list->expr = gfc_copy_expr (c);
3597 deallocate->next = allocate1;
3598 deallocate->loc = c->where;
3599
3600 if_size_2 = XCNEW (gfc_code);
3601 if_size_2->op = EXEC_IF;
3602 if_size_2->expr1 = cond;
3603 if_size_2->loc = c->where;
3604 if_size_2->next = deallocate;
3605
3606 if_size_1 = XCNEW (gfc_code);
3607 if_size_1->op = EXEC_IF;
3608 if_size_1->block = if_size_2;
3609 if_size_1->loc = c->where;
3610
3611 else_alloc = XCNEW (gfc_code);
3612 else_alloc->op = EXEC_IF;
3613 else_alloc->loc = c->where;
3614 else_alloc->next = allocate_else;
3615
3616 if_alloc_2 = XCNEW (gfc_code);
3617 if_alloc_2->op = EXEC_IF;
3618 if_alloc_2->expr1 = allocated;
3619 if_alloc_2->loc = c->where;
3620 if_alloc_2->next = if_size_1;
3621 if_alloc_2->block = else_alloc;
3622
3623 if_alloc_1 = XCNEW (gfc_code);
3624 if_alloc_1->op = EXEC_IF;
3625 if_alloc_1->block = if_alloc_2;
3626 if_alloc_1->loc = c->where;
3627
3628 return if_alloc_1;
3629 }
3630
3631 /* Callback function for has_function_or_op. */
3632
3633 static int
3634 is_function_or_op (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
3635 void *data ATTRIBUTE_UNUSED)
3636 {
3637 if ((*e) == 0)
3638 return 0;
3639 else
3640 return (*e)->expr_type == EXPR_FUNCTION
3641 || (*e)->expr_type == EXPR_OP;
3642 }
3643
3644 /* Returns true if the expression contains a function. */
3645
3646 static bool
3647 has_function_or_op (gfc_expr **e)
3648 {
3649 if (e == NULL)
3650 return false;
3651 else
3652 return gfc_expr_walker (e, is_function_or_op, NULL);
3653 }
3654
3655 /* Freeze (assign to a temporary variable) a single expression. */
3656
3657 static void
3658 freeze_expr (gfc_expr **ep)
3659 {
3660 gfc_expr *ne;
3661 if (has_function_or_op (ep))
3662 {
3663 ne = create_var (*ep, "freeze");
3664 *ep = ne;
3665 }
3666 }
3667
3668 /* Go through an expression's references and assign them to temporary
3669 variables if they contain functions. This is usually done prior to
3670 front-end scalarization to avoid multiple invocations of functions. */
3671
3672 static void
3673 freeze_references (gfc_expr *e)
3674 {
3675 gfc_ref *r;
3676 gfc_array_ref *ar;
3677 int i;
3678
3679 for (r=e->ref; r; r=r->next)
3680 {
3681 if (r->type == REF_SUBSTRING)
3682 {
3683 if (r->u.ss.start != NULL)
3684 freeze_expr (&r->u.ss.start);
3685
3686 if (r->u.ss.end != NULL)
3687 freeze_expr (&r->u.ss.end);
3688 }
3689 else if (r->type == REF_ARRAY)
3690 {
3691 ar = &r->u.ar;
3692 switch (ar->type)
3693 {
3694 case AR_FULL:
3695 break;
3696
3697 case AR_SECTION:
3698 for (i=0; i<ar->dimen; i++)
3699 {
3700 if (ar->dimen_type[i] == DIMEN_RANGE)
3701 {
3702 freeze_expr (&ar->start[i]);
3703 freeze_expr (&ar->end[i]);
3704 freeze_expr (&ar->stride[i]);
3705 }
3706 else if (ar->dimen_type[i] == DIMEN_ELEMENT)
3707 {
3708 freeze_expr (&ar->start[i]);
3709 }
3710 }
3711 break;
3712
3713 case AR_ELEMENT:
3714 for (i=0; i<ar->dimen; i++)
3715 freeze_expr (&ar->start[i]);
3716 break;
3717
3718 default:
3719 break;
3720 }
3721 }
3722 }
3723 }
3724
3725 /* Convert to gfc_index_integer_kind if needed, just do a copy otherwise. */
3726
3727 static gfc_expr *
3728 convert_to_index_kind (gfc_expr *e)
3729 {
3730 gfc_expr *res;
3731
3732 gcc_assert (e != NULL);
3733
3734 res = gfc_copy_expr (e);
3735
3736 gcc_assert (e->ts.type == BT_INTEGER);
3737
3738 if (res->ts.kind != gfc_index_integer_kind)
3739 {
3740 gfc_typespec ts;
3741 gfc_clear_ts (&ts);
3742 ts.type = BT_INTEGER;
3743 ts.kind = gfc_index_integer_kind;
3744
3745 gfc_convert_type_warn (e, &ts, 2, 0);
3746 }
3747
3748 return res;
3749 }
3750
3751 /* Function to create a DO loop including creation of the
3752 iteration variable. gfc_expr are copied.*/
3753
3754 static gfc_code *
3755 create_do_loop (gfc_expr *start, gfc_expr *end, gfc_expr *step, locus *where,
3756 gfc_namespace *ns, char *vname)
3757 {
3758
3759 char name[GFC_MAX_SYMBOL_LEN +1];
3760 gfc_symtree *symtree;
3761 gfc_symbol *symbol;
3762 gfc_expr *i;
3763 gfc_code *n, *n2;
3764
3765 /* Create an expression for the iteration variable. */
3766 if (vname)
3767 sprintf (name, "__var_%d_do_%s", var_num++, vname);
3768 else
3769 sprintf (name, "__var_%d_do", var_num++);
3770
3771
3772 if (gfc_get_sym_tree (name, ns, &symtree, false) != 0)
3773 gcc_unreachable ();
3774
3775 /* Create the loop variable. */
3776
3777 symbol = symtree->n.sym;
3778 symbol->ts.type = BT_INTEGER;
3779 symbol->ts.kind = gfc_index_integer_kind;
3780 symbol->attr.flavor = FL_VARIABLE;
3781 symbol->attr.referenced = 1;
3782 symbol->attr.dimension = 0;
3783 symbol->attr.fe_temp = 1;
3784 gfc_commit_symbol (symbol);
3785
3786 i = gfc_get_expr ();
3787 i->expr_type = EXPR_VARIABLE;
3788 i->ts = symbol->ts;
3789 i->rank = 0;
3790 i->where = *where;
3791 i->symtree = symtree;
3792
3793 /* ... and the nested DO statements. */
3794 n = XCNEW (gfc_code);
3795 n->op = EXEC_DO;
3796 n->loc = *where;
3797 n->ext.iterator = gfc_get_iterator ();
3798 n->ext.iterator->var = i;
3799 n->ext.iterator->start = convert_to_index_kind (start);
3800 n->ext.iterator->end = convert_to_index_kind (end);
3801 if (step)
3802 n->ext.iterator->step = convert_to_index_kind (step);
3803 else
3804 n->ext.iterator->step = gfc_get_int_expr (gfc_index_integer_kind,
3805 where, 1);
3806
3807 n2 = XCNEW (gfc_code);
3808 n2->op = EXEC_DO;
3809 n2->loc = *where;
3810 n2->next = NULL;
3811 n->block = n2;
3812 return n;
3813 }
3814
3815 /* Get the upper bound of the DO loops for matmul along a dimension. This
3816 is one-based. */
3817
3818 static gfc_expr*
3819 get_size_m1 (gfc_expr *e, int dimen)
3820 {
3821 mpz_t size;
3822 gfc_expr *res;
3823
3824 if (gfc_array_dimen_size (e, dimen - 1, &size))
3825 {
3826 res = gfc_get_constant_expr (BT_INTEGER,
3827 gfc_index_integer_kind, &e->where);
3828 mpz_sub_ui (res->value.integer, size, 1);
3829 mpz_clear (size);
3830 }
3831 else
3832 {
3833 res = get_operand (INTRINSIC_MINUS,
3834 get_array_inq_function (GFC_ISYM_SIZE, e, dimen),
3835 gfc_get_int_expr (gfc_index_integer_kind,
3836 &e->where, 1));
3837 gfc_simplify_expr (res, 0);
3838 }
3839
3840 return res;
3841 }
3842
3843 /* Function to return a scalarized expression. It is assumed that indices are
3844 zero based to make generation of DO loops easier. A zero as index will
3845 access the first element along a dimension. Single element references will
3846 be skipped. A NULL as an expression will be replaced by a full reference.
3847 This assumes that the index loops have gfc_index_integer_kind, and that all
3848 references have been frozen. */
3849
3850 static gfc_expr*
3851 scalarized_expr (gfc_expr *e_in, gfc_expr **index, int count_index)
3852 {
3853 gfc_array_ref *ar;
3854 int i;
3855 int rank;
3856 gfc_expr *e;
3857 int i_index;
3858 bool was_fullref;
3859
3860 e = gfc_copy_expr(e_in);
3861
3862 rank = e->rank;
3863
3864 ar = gfc_find_array_ref (e);
3865
3866 /* We scalarize count_index variables, reducing the rank by count_index. */
3867
3868 e->rank = rank - count_index;
3869
3870 was_fullref = ar->type == AR_FULL;
3871
3872 if (e->rank == 0)
3873 ar->type = AR_ELEMENT;
3874 else
3875 ar->type = AR_SECTION;
3876
3877 /* Loop over the indices. For each index, create the expression
3878 index * stride + lbound(e, dim). */
3879
3880 i_index = 0;
3881 for (i=0; i < ar->dimen; i++)
3882 {
3883 if (was_fullref || ar->dimen_type[i] == DIMEN_RANGE)
3884 {
3885 if (index[i_index] != NULL)
3886 {
3887 gfc_expr *lbound, *nindex;
3888 gfc_expr *loopvar;
3889
3890 loopvar = gfc_copy_expr (index[i_index]);
3891
3892 if (ar->stride[i])
3893 {
3894 gfc_expr *tmp;
3895
3896 tmp = gfc_copy_expr(ar->stride[i]);
3897 if (tmp->ts.kind != gfc_index_integer_kind)
3898 {
3899 gfc_typespec ts;
3900 gfc_clear_ts (&ts);
3901 ts.type = BT_INTEGER;
3902 ts.kind = gfc_index_integer_kind;
3903 gfc_convert_type (tmp, &ts, 2);
3904 }
3905 nindex = get_operand (INTRINSIC_TIMES, loopvar, tmp);
3906 }
3907 else
3908 nindex = loopvar;
3909
3910 /* Calculate the lower bound of the expression. */
3911 if (ar->start[i])
3912 {
3913 lbound = gfc_copy_expr (ar->start[i]);
3914 if (lbound->ts.kind != gfc_index_integer_kind)
3915 {
3916 gfc_typespec ts;
3917 gfc_clear_ts (&ts);
3918 ts.type = BT_INTEGER;
3919 ts.kind = gfc_index_integer_kind;
3920 gfc_convert_type (lbound, &ts, 2);
3921
3922 }
3923 }
3924 else
3925 {
3926 gfc_expr *lbound_e;
3927 gfc_ref *ref;
3928
3929 lbound_e = gfc_copy_expr (e_in);
3930
3931 for (ref = lbound_e->ref; ref; ref = ref->next)
3932 if (ref->type == REF_ARRAY
3933 && (ref->u.ar.type == AR_FULL
3934 || ref->u.ar.type == AR_SECTION))
3935 break;
3936
3937 if (ref->next)
3938 {
3939 gfc_free_ref_list (ref->next);
3940 ref->next = NULL;
3941 }
3942
3943 if (!was_fullref)
3944 {
3945 /* Look at full individual sections, like a(:). The first index
3946 is the lbound of a full ref. */
3947 int j;
3948 gfc_array_ref *ar;
3949 int to;
3950
3951 ar = &ref->u.ar;
3952
3953 /* For assumed size, we need to keep around the final
3954 reference in order not to get an error on resolution
3955 below, and we cannot use AR_FULL. */
3956
3957 if (ar->as->type == AS_ASSUMED_SIZE)
3958 {
3959 ar->type = AR_SECTION;
3960 to = ar->dimen - 1;
3961 }
3962 else
3963 {
3964 to = ar->dimen;
3965 ar->type = AR_FULL;
3966 }
3967
3968 for (j = 0; j < to; j++)
3969 {
3970 gfc_free_expr (ar->start[j]);
3971 ar->start[j] = NULL;
3972 gfc_free_expr (ar->end[j]);
3973 ar->end[j] = NULL;
3974 gfc_free_expr (ar->stride[j]);
3975 ar->stride[j] = NULL;
3976 }
3977
3978 /* We have to get rid of the shape, if there is one. Do
3979 so by freeing it and calling gfc_resolve to rebuild
3980 it, if necessary. */
3981
3982 if (lbound_e->shape)
3983 gfc_free_shape (&(lbound_e->shape), lbound_e->rank);
3984
3985 lbound_e->rank = ar->dimen;
3986 gfc_resolve_expr (lbound_e);
3987 }
3988 lbound = get_array_inq_function (GFC_ISYM_LBOUND, lbound_e,
3989 i + 1);
3990 gfc_free_expr (lbound_e);
3991 }
3992
3993 ar->dimen_type[i] = DIMEN_ELEMENT;
3994
3995 gfc_free_expr (ar->start[i]);
3996 ar->start[i] = get_operand (INTRINSIC_PLUS, nindex, lbound);
3997
3998 gfc_free_expr (ar->end[i]);
3999 ar->end[i] = NULL;
4000 gfc_free_expr (ar->stride[i]);
4001 ar->stride[i] = NULL;
4002 gfc_simplify_expr (ar->start[i], 0);
4003 }
4004 else if (was_fullref)
4005 {
4006 gfc_internal_error ("Scalarization using DIMEN_RANGE unimplemented");
4007 }
4008 i_index ++;
4009 }
4010 }
4011
4012 /* Bounds checking will be done before the loops if -fcheck=bounds
4013 is in effect. */
4014 e->no_bounds_check = 1;
4015 return e;
4016 }
4017
4018 /* Helper function to check for a dimen vector as subscript. */
4019
4020 bool
4021 gfc_has_dimen_vector_ref (gfc_expr *e)
4022 {
4023 gfc_array_ref *ar;
4024 int i;
4025
4026 ar = gfc_find_array_ref (e);
4027 gcc_assert (ar);
4028 if (ar->type == AR_FULL)
4029 return false;
4030
4031 for (i=0; i<ar->dimen; i++)
4032 if (ar->dimen_type[i] == DIMEN_VECTOR)
4033 return true;
4034
4035 return false;
4036 }
4037
4038 /* If handed an expression of the form
4039
4040 TRANSPOSE(CONJG(A))
4041
4042 check if A can be handled by matmul and return if there is an uneven number
4043 of CONJG calls. Return a pointer to the array when everything is OK, NULL
4044 otherwise. The caller has to check for the correct rank. */
4045
4046 static gfc_expr*
4047 check_conjg_transpose_variable (gfc_expr *e, bool *conjg, bool *transpose)
4048 {
4049 *conjg = false;
4050 *transpose = false;
4051
4052 do
4053 {
4054 if (e->expr_type == EXPR_VARIABLE)
4055 {
4056 gcc_assert (e->rank == 1 || e->rank == 2);
4057 return e;
4058 }
4059 else if (e->expr_type == EXPR_FUNCTION)
4060 {
4061 if (e->value.function.isym == NULL)
4062 return NULL;
4063
4064 if (e->value.function.isym->id == GFC_ISYM_CONJG)
4065 *conjg = !*conjg;
4066 else if (e->value.function.isym->id == GFC_ISYM_TRANSPOSE)
4067 *transpose = !*transpose;
4068 else return NULL;
4069 }
4070 else
4071 return NULL;
4072
4073 e = e->value.function.actual->expr;
4074 }
4075 while(1);
4076
4077 return NULL;
4078 }
4079
4080 /* Macros for unified error messages. */
4081
4082 #define B_ERROR_1 _("Incorrect extent in argument B in MATMUL intrinsic in " \
4083 "dimension 1: is %ld, should be %ld")
4084
4085 #define C_ERROR_1 _("Array bound mismatch for dimension 1 of array " \
4086 "(%ld/%ld)")
4087
4088 #define C_ERROR_2 _("Array bound mismatch for dimension 2 of array " \
4089 "(%ld/%ld)")
4090
4091
4092 /* Inline assignments of the form c = matmul(a,b).
4093 Handle only the cases currently where b and c are rank-two arrays.
4094
4095 This basically translates the code to
4096
4097 BLOCK
4098 integer i,j,k
4099 c = 0
4100 do j=0, size(b,2)-1
4101 do k=0, size(a, 2)-1
4102 do i=0, size(a, 1)-1
4103 c(i * stride(c,1) + lbound(c,1), j * stride(c,2) + lbound(c,2)) =
4104 c(i * stride(c,1) + lbound(c,1), j * stride(c,2) + lbound(c,2)) +
4105 a(i * stride(a,1) + lbound(a,1), k * stride(a,2) + lbound(a,2)) *
4106 b(k * stride(b,1) + lbound(b,1), j * stride(b,2) + lbound(b,2))
4107 end do
4108 end do
4109 end do
4110 END BLOCK
4111
4112 */
4113
4114 static int
4115 inline_matmul_assign (gfc_code **c, int *walk_subtrees,
4116 void *data ATTRIBUTE_UNUSED)
4117 {
4118 gfc_code *co = *c;
4119 gfc_expr *expr1, *expr2;
4120 gfc_expr *matrix_a, *matrix_b;
4121 gfc_actual_arglist *a, *b;
4122 gfc_code *do_1, *do_2, *do_3, *assign_zero, *assign_matmul;
4123 gfc_expr *zero_e;
4124 gfc_expr *u1, *u2, *u3;
4125 gfc_expr *list[2];
4126 gfc_expr *ascalar, *bscalar, *cscalar;
4127 gfc_expr *mult;
4128 gfc_expr *var_1, *var_2, *var_3;
4129 gfc_expr *zero;
4130 gfc_namespace *ns;
4131 gfc_intrinsic_op op_times, op_plus;
4132 enum matrix_case m_case;
4133 int i;
4134 gfc_code *if_limit = NULL;
4135 gfc_code **next_code_point;
4136 bool conjg_a, conjg_b, transpose_a, transpose_b;
4137 bool realloc_c;
4138
4139 if (co->op != EXEC_ASSIGN)
4140 return 0;
4141
4142 if (in_where || in_assoc_list)
4143 return 0;
4144
4145 /* The BLOCKS generated for the temporary variables and FORALL don't
4146 mix. */
4147 if (forall_level > 0)
4148 return 0;
4149
4150 /* For now don't do anything in OpenMP workshare, it confuses
4151 its translation, which expects only the allowed statements in there.
4152 We should figure out how to parallelize this eventually. */
4153 if (in_omp_workshare || in_omp_atomic)
4154 return 0;
4155
4156 expr1 = co->expr1;
4157 expr2 = co->expr2;
4158 if (expr2->expr_type != EXPR_FUNCTION
4159 || expr2->value.function.isym == NULL
4160 || expr2->value.function.isym->id != GFC_ISYM_MATMUL)
4161 return 0;
4162
4163 current_code = c;
4164 inserted_block = NULL;
4165 changed_statement = NULL;
4166
4167 a = expr2->value.function.actual;
4168 matrix_a = check_conjg_transpose_variable (a->expr, &conjg_a, &transpose_a);
4169 if (matrix_a == NULL)
4170 return 0;
4171
4172 b = a->next;
4173 matrix_b = check_conjg_transpose_variable (b->expr, &conjg_b, &transpose_b);
4174 if (matrix_b == NULL)
4175 return 0;
4176
4177 if (gfc_has_dimen_vector_ref (expr1) || gfc_has_dimen_vector_ref (matrix_a)
4178 || gfc_has_dimen_vector_ref (matrix_b))
4179 return 0;
4180
4181 /* We do not handle data dependencies yet. */
4182 if (gfc_check_dependency (expr1, matrix_a, true)
4183 || gfc_check_dependency (expr1, matrix_b, true))
4184 return 0;
4185
4186 m_case = none;
4187 if (matrix_a->rank == 2)
4188 {
4189 if (transpose_a)
4190 {
4191 if (matrix_b->rank == 2 && !transpose_b)
4192 m_case = A2TB2;
4193 }
4194 else
4195 {
4196 if (matrix_b->rank == 1)
4197 m_case = A2B1;
4198 else /* matrix_b->rank == 2 */
4199 {
4200 if (transpose_b)
4201 m_case = A2B2T;
4202 else
4203 m_case = A2B2;
4204 }
4205 }
4206 }
4207 else /* matrix_a->rank == 1 */
4208 {
4209 if (matrix_b->rank == 2)
4210 {
4211 if (!transpose_b)
4212 m_case = A1B2;
4213 }
4214 }
4215
4216 if (m_case == none)
4217 return 0;
4218
4219 /* We only handle assignment to numeric or logical variables. */
4220 switch(expr1->ts.type)
4221 {
4222 case BT_INTEGER:
4223 case BT_LOGICAL:
4224 case BT_REAL:
4225 case BT_COMPLEX:
4226 break;
4227
4228 default:
4229 return 0;
4230 }
4231
4232 ns = insert_block ();
4233
4234 /* Assign the type of the zero expression for initializing the resulting
4235 array, and the expression (+ and * for real, integer and complex;
4236 .and. and .or for logical. */
4237
4238 switch(expr1->ts.type)
4239 {
4240 case BT_INTEGER:
4241 zero_e = gfc_get_int_expr (expr1->ts.kind, &expr1->where, 0);
4242 op_times = INTRINSIC_TIMES;
4243 op_plus = INTRINSIC_PLUS;
4244 break;
4245
4246 case BT_LOGICAL:
4247 op_times = INTRINSIC_AND;
4248 op_plus = INTRINSIC_OR;
4249 zero_e = gfc_get_logical_expr (expr1->ts.kind, &expr1->where,
4250 0);
4251 break;
4252 case BT_REAL:
4253 zero_e = gfc_get_constant_expr (BT_REAL, expr1->ts.kind,
4254 &expr1->where);
4255 mpfr_set_si (zero_e->value.real, 0, GFC_RND_MODE);
4256 op_times = INTRINSIC_TIMES;
4257 op_plus = INTRINSIC_PLUS;
4258 break;
4259
4260 case BT_COMPLEX:
4261 zero_e = gfc_get_constant_expr (BT_COMPLEX, expr1->ts.kind,
4262 &expr1->where);
4263 mpc_set_si_si (zero_e->value.complex, 0, 0, GFC_RND_MODE);
4264 op_times = INTRINSIC_TIMES;
4265 op_plus = INTRINSIC_PLUS;
4266
4267 break;
4268
4269 default:
4270 gcc_unreachable();
4271 }
4272
4273 current_code = &ns->code;
4274
4275 /* Freeze the references, keeping track of how many temporary variables were
4276 created. */
4277 n_vars = 0;
4278 freeze_references (matrix_a);
4279 freeze_references (matrix_b);
4280 freeze_references (expr1);
4281
4282 if (n_vars == 0)
4283 next_code_point = current_code;
4284 else
4285 {
4286 next_code_point = &ns->code;
4287 for (i=0; i<n_vars; i++)
4288 next_code_point = &(*next_code_point)->next;
4289 }
4290
4291 /* Take care of the inline flag. If the limit check evaluates to a
4292 constant, dead code elimination will eliminate the unneeded branch. */
4293
4294 if (flag_inline_matmul_limit > 0
4295 && (matrix_a->rank == 1 || matrix_a->rank == 2)
4296 && matrix_b->rank == 2)
4297 {
4298 if_limit = inline_limit_check (matrix_a, matrix_b,
4299 flag_inline_matmul_limit,
4300 matrix_a->rank);
4301
4302 /* Insert the original statement into the else branch. */
4303 if_limit->block->block->next = co;
4304 co->next = NULL;
4305
4306 /* ... and the new ones go into the original one. */
4307 *next_code_point = if_limit;
4308 next_code_point = &if_limit->block->next;
4309 }
4310
4311 zero_e->no_bounds_check = 1;
4312
4313 assign_zero = XCNEW (gfc_code);
4314 assign_zero->op = EXEC_ASSIGN;
4315 assign_zero->loc = co->loc;
4316 assign_zero->expr1 = gfc_copy_expr (expr1);
4317 assign_zero->expr1->no_bounds_check = 1;
4318 assign_zero->expr2 = zero_e;
4319
4320 realloc_c = flag_realloc_lhs && gfc_is_reallocatable_lhs (expr1);
4321
4322 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
4323 {
4324 gfc_code *test;
4325 gfc_expr *a2, *b1, *c1, *c2, *a1, *b2;
4326
4327 switch (m_case)
4328 {
4329 case A2B1:
4330
4331 b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
4332 a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2);
4333 test = runtime_error_ne (b1, a2, B_ERROR_1);
4334 *next_code_point = test;
4335 next_code_point = &test->next;
4336
4337 if (!realloc_c)
4338 {
4339 c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1);
4340 a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1);
4341 test = runtime_error_ne (c1, a1, C_ERROR_1);
4342 *next_code_point = test;
4343 next_code_point = &test->next;
4344 }
4345 break;
4346
4347 case A1B2:
4348
4349 b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
4350 a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1);
4351 test = runtime_error_ne (b1, a1, B_ERROR_1);
4352 *next_code_point = test;
4353 next_code_point = &test->next;
4354
4355 if (!realloc_c)
4356 {
4357 c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1);
4358 b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2);
4359 test = runtime_error_ne (c1, b2, C_ERROR_1);
4360 *next_code_point = test;
4361 next_code_point = &test->next;
4362 }
4363 break;
4364
4365 case A2B2:
4366
4367 b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
4368 a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2);
4369 test = runtime_error_ne (b1, a2, B_ERROR_1);
4370 *next_code_point = test;
4371 next_code_point = &test->next;
4372
4373 if (!realloc_c)
4374 {
4375 c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1);
4376 a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1);
4377 test = runtime_error_ne (c1, a1, C_ERROR_1);
4378 *next_code_point = test;
4379 next_code_point = &test->next;
4380
4381 c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2);
4382 b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2);
4383 test = runtime_error_ne (c2, b2, C_ERROR_2);
4384 *next_code_point = test;
4385 next_code_point = &test->next;
4386 }
4387 break;
4388
4389 case A2B2T:
4390
4391 b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2);
4392 a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2);
4393 /* matrix_b is transposed, hence dimension 1 for the error message. */
4394 test = runtime_error_ne (b2, a2, B_ERROR_1);
4395 *next_code_point = test;
4396 next_code_point = &test->next;
4397
4398 if (!realloc_c)
4399 {
4400 c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1);
4401 a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1);
4402 test = runtime_error_ne (c1, a1, C_ERROR_1);
4403 *next_code_point = test;
4404 next_code_point = &test->next;
4405
4406 c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2);
4407 b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
4408 test = runtime_error_ne (c2, b1, C_ERROR_2);
4409 *next_code_point = test;
4410 next_code_point = &test->next;
4411 }
4412 break;
4413
4414 case A2TB2:
4415
4416 b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
4417 a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1);
4418 test = runtime_error_ne (b1, a1, B_ERROR_1);
4419 *next_code_point = test;
4420 next_code_point = &test->next;
4421
4422 if (!realloc_c)
4423 {
4424 c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1);
4425 a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2);
4426 test = runtime_error_ne (c1, a2, C_ERROR_1);
4427 *next_code_point = test;
4428 next_code_point = &test->next;
4429
4430 c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2);
4431 b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2);
4432 test = runtime_error_ne (c2, b2, C_ERROR_2);
4433 *next_code_point = test;
4434 next_code_point = &test->next;
4435 }
4436 break;
4437
4438 default:
4439 gcc_unreachable ();
4440 }
4441 }
4442
4443 /* Handle the reallocation, if needed. */
4444
4445 if (realloc_c)
4446 {
4447 gfc_code *lhs_alloc;
4448
4449 lhs_alloc = matmul_lhs_realloc (expr1, matrix_a, matrix_b, m_case);
4450
4451 *next_code_point = lhs_alloc;
4452 next_code_point = &lhs_alloc->next;
4453
4454 }
4455
4456 *next_code_point = assign_zero;
4457
4458 zero = gfc_get_int_expr (gfc_index_integer_kind, &co->loc, 0);
4459
4460 assign_matmul = XCNEW (gfc_code);
4461 assign_matmul->op = EXEC_ASSIGN;
4462 assign_matmul->loc = co->loc;
4463
4464 /* Get the bounds for the loops, create them and create the scalarized
4465 expressions. */
4466
4467 switch (m_case)
4468 {
4469 case A2B2:
4470
4471 u1 = get_size_m1 (matrix_b, 2);
4472 u2 = get_size_m1 (matrix_a, 2);
4473 u3 = get_size_m1 (matrix_a, 1);
4474
4475 do_1 = create_do_loop (gfc_copy_expr (zero), u1, NULL, &co->loc, ns);
4476 do_2 = create_do_loop (gfc_copy_expr (zero), u2, NULL, &co->loc, ns);
4477 do_3 = create_do_loop (gfc_copy_expr (zero), u3, NULL, &co->loc, ns);
4478
4479 do_1->block->next = do_2;
4480 do_2->block->next = do_3;
4481 do_3->block->next = assign_matmul;
4482
4483 var_1 = do_1->ext.iterator->var;
4484 var_2 = do_2->ext.iterator->var;
4485 var_3 = do_3->ext.iterator->var;
4486
4487 list[0] = var_3;
4488 list[1] = var_1;
4489 cscalar = scalarized_expr (co->expr1, list, 2);
4490
4491 list[0] = var_3;
4492 list[1] = var_2;
4493 ascalar = scalarized_expr (matrix_a, list, 2);
4494
4495 list[0] = var_2;
4496 list[1] = var_1;
4497 bscalar = scalarized_expr (matrix_b, list, 2);
4498
4499 break;
4500
4501 case A2B2T:
4502
4503 u1 = get_size_m1 (matrix_b, 1);
4504 u2 = get_size_m1 (matrix_a, 2);
4505 u3 = get_size_m1 (matrix_a, 1);
4506
4507 do_1 = create_do_loop (gfc_copy_expr (zero), u1, NULL, &co->loc, ns);
4508 do_2 = create_do_loop (gfc_copy_expr (zero), u2, NULL, &co->loc, ns);
4509 do_3 = create_do_loop (gfc_copy_expr (zero), u3, NULL, &co->loc, ns);
4510
4511 do_1->block->next = do_2;
4512 do_2->block->next = do_3;
4513 do_3->block->next = assign_matmul;
4514
4515 var_1 = do_1->ext.iterator->var;
4516 var_2 = do_2->ext.iterator->var;
4517 var_3 = do_3->ext.iterator->var;
4518
4519 list[0] = var_3;
4520 list[1] = var_1;
4521 cscalar = scalarized_expr (co->expr1, list, 2);
4522
4523 list[0] = var_3;
4524 list[1] = var_2;
4525 ascalar = scalarized_expr (matrix_a, list, 2);
4526
4527 list[0] = var_1;
4528 list[1] = var_2;
4529 bscalar = scalarized_expr (matrix_b, list, 2);
4530
4531 break;
4532
4533 case A2TB2:
4534
4535 u1 = get_size_m1 (matrix_a, 2);
4536 u2 = get_size_m1 (matrix_b, 2);
4537 u3 = get_size_m1 (matrix_a, 1);
4538
4539 do_1 = create_do_loop (gfc_copy_expr (zero), u1, NULL, &co->loc, ns);
4540 do_2 = create_do_loop (gfc_copy_expr (zero), u2, NULL, &co->loc, ns);
4541 do_3 = create_do_loop (gfc_copy_expr (zero), u3, NULL, &co->loc, ns);
4542
4543 do_1->block->next = do_2;
4544 do_2->block->next = do_3;
4545 do_3->block->next = assign_matmul;
4546
4547 var_1 = do_1->ext.iterator->var;
4548 var_2 = do_2->ext.iterator->var;
4549 var_3 = do_3->ext.iterator->var;
4550
4551 list[0] = var_1;
4552 list[1] = var_2;
4553 cscalar = scalarized_expr (co->expr1, list, 2);
4554
4555 list[0] = var_3;
4556 list[1] = var_1;
4557 ascalar = scalarized_expr (matrix_a, list, 2);
4558
4559 list[0] = var_3;
4560 list[1] = var_2;
4561 bscalar = scalarized_expr (matrix_b, list, 2);
4562
4563 break;
4564
4565 case A2B1:
4566 u1 = get_size_m1 (matrix_b, 1);
4567 u2 = get_size_m1 (matrix_a, 1);
4568
4569 do_1 = create_do_loop (gfc_copy_expr (zero), u1, NULL, &co->loc, ns);
4570 do_2 = create_do_loop (gfc_copy_expr (zero), u2, NULL, &co->loc, ns);
4571
4572 do_1->block->next = do_2;
4573 do_2->block->next = assign_matmul;
4574
4575 var_1 = do_1->ext.iterator->var;
4576 var_2 = do_2->ext.iterator->var;
4577
4578 list[0] = var_2;
4579 cscalar = scalarized_expr (co->expr1, list, 1);
4580
4581 list[0] = var_2;
4582 list[1] = var_1;
4583 ascalar = scalarized_expr (matrix_a, list, 2);
4584
4585 list[0] = var_1;
4586 bscalar = scalarized_expr (matrix_b, list, 1);
4587
4588 break;
4589
4590 case A1B2:
4591 u1 = get_size_m1 (matrix_b, 2);
4592 u2 = get_size_m1 (matrix_a, 1);
4593
4594 do_1 = create_do_loop (gfc_copy_expr (zero), u1, NULL, &co->loc, ns);
4595 do_2 = create_do_loop (gfc_copy_expr (zero), u2, NULL, &co->loc, ns);
4596
4597 do_1->block->next = do_2;
4598 do_2->block->next = assign_matmul;
4599
4600 var_1 = do_1->ext.iterator->var;
4601 var_2 = do_2->ext.iterator->var;
4602
4603 list[0] = var_1;
4604 cscalar = scalarized_expr (co->expr1, list, 1);
4605
4606 list[0] = var_2;
4607 ascalar = scalarized_expr (matrix_a, list, 1);
4608
4609 list[0] = var_2;
4610 list[1] = var_1;
4611 bscalar = scalarized_expr (matrix_b, list, 2);
4612
4613 break;
4614
4615 default:
4616 gcc_unreachable();
4617 }
4618
4619 /* Build the conjg call around the variables. Set the typespec manually
4620 because gfc_build_intrinsic_call sometimes gets this wrong. */
4621 if (conjg_a)
4622 {
4623 gfc_typespec ts;
4624 ts = matrix_a->ts;
4625 ascalar = gfc_build_intrinsic_call (ns, GFC_ISYM_CONJG, "conjg",
4626 matrix_a->where, 1, ascalar);
4627 ascalar->ts = ts;
4628 }
4629
4630 if (conjg_b)
4631 {
4632 gfc_typespec ts;
4633 ts = matrix_b->ts;
4634 bscalar = gfc_build_intrinsic_call (ns, GFC_ISYM_CONJG, "conjg",
4635 matrix_b->where, 1, bscalar);
4636 bscalar->ts = ts;
4637 }
4638 /* First loop comes after the zero assignment. */
4639 assign_zero->next = do_1;
4640
4641 /* Build the assignment expression in the loop. */
4642 assign_matmul->expr1 = gfc_copy_expr (cscalar);
4643
4644 mult = get_operand (op_times, ascalar, bscalar);
4645 assign_matmul->expr2 = get_operand (op_plus, cscalar, mult);
4646
4647 /* If we don't want to keep the original statement around in
4648 the else branch, we can free it. */
4649
4650 if (if_limit == NULL)
4651 gfc_free_statements(co);
4652 else
4653 co->next = NULL;
4654
4655 gfc_free_expr (zero);
4656 *walk_subtrees = 0;
4657 return 0;
4658 }
4659
4660 /* Change matmul function calls in the form of
4661
4662 c = matmul(a,b)
4663
4664 to the corresponding call to a BLAS routine, if applicable. */
4665
4666 static int
4667 call_external_blas (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
4668 void *data ATTRIBUTE_UNUSED)
4669 {
4670 gfc_code *co, *co_next;
4671 gfc_expr *expr1, *expr2;
4672 gfc_expr *matrix_a, *matrix_b;
4673 gfc_code *if_limit = NULL;
4674 gfc_actual_arglist *a, *b;
4675 bool conjg_a, conjg_b, transpose_a, transpose_b;
4676 gfc_code *call;
4677 const char *blas_name;
4678 const char *transa, *transb;
4679 gfc_expr *c1, *c2, *b1;
4680 gfc_actual_arglist *actual, *next;
4681 bt type;
4682 int kind;
4683 enum matrix_case m_case;
4684 bool realloc_c;
4685 gfc_code **next_code_point;
4686
4687 /* Many of the tests for inline matmul also apply here. */
4688
4689 co = *c;
4690
4691 if (co->op != EXEC_ASSIGN)
4692 return 0;
4693
4694 if (in_where || in_assoc_list)
4695 return 0;
4696
4697 /* The BLOCKS generated for the temporary variables and FORALL don't
4698 mix. */
4699 if (forall_level > 0)
4700 return 0;
4701
4702 /* For now don't do anything in OpenMP workshare, it confuses
4703 its translation, which expects only the allowed statements in there. */
4704
4705 if (in_omp_workshare || in_omp_atomic)
4706 return 0;
4707
4708 expr1 = co->expr1;
4709 expr2 = co->expr2;
4710 if (expr2->expr_type != EXPR_FUNCTION
4711 || expr2->value.function.isym == NULL
4712 || expr2->value.function.isym->id != GFC_ISYM_MATMUL)
4713 return 0;
4714
4715 type = expr2->ts.type;
4716 kind = expr2->ts.kind;
4717
4718 /* Guard against recursion. */
4719
4720 if (expr2->external_blas)
4721 return 0;
4722
4723 if (type != expr1->ts.type || kind != expr1->ts.kind)
4724 return 0;
4725
4726 if (type == BT_REAL)
4727 {
4728 if (kind == 4)
4729 blas_name = "sgemm";
4730 else if (kind == 8)
4731 blas_name = "dgemm";
4732 else
4733 return 0;
4734 }
4735 else if (type == BT_COMPLEX)
4736 {
4737 if (kind == 4)
4738 blas_name = "cgemm";
4739 else if (kind == 8)
4740 blas_name = "zgemm";
4741 else
4742 return 0;
4743 }
4744 else
4745 return 0;
4746
4747 a = expr2->value.function.actual;
4748 if (a->expr->rank != 2)
4749 return 0;
4750
4751 b = a->next;
4752 if (b->expr->rank != 2)
4753 return 0;
4754
4755 matrix_a = check_conjg_transpose_variable (a->expr, &conjg_a, &transpose_a);
4756 if (matrix_a == NULL)
4757 return 0;
4758
4759 if (transpose_a)
4760 {
4761 if (conjg_a)
4762 transa = "C";
4763 else
4764 transa = "T";
4765 }
4766 else
4767 transa = "N";
4768
4769 matrix_b = check_conjg_transpose_variable (b->expr, &conjg_b, &transpose_b);
4770 if (matrix_b == NULL)
4771 return 0;
4772
4773 if (transpose_b)
4774 {
4775 if (conjg_b)
4776 transb = "C";
4777 else
4778 transb = "T";
4779 }
4780 else
4781 transb = "N";
4782
4783 if (transpose_a)
4784 {
4785 if (transpose_b)
4786 m_case = A2TB2T;
4787 else
4788 m_case = A2TB2;
4789 }
4790 else
4791 {
4792 if (transpose_b)
4793 m_case = A2B2T;
4794 else
4795 m_case = A2B2;
4796 }
4797
4798 current_code = c;
4799 inserted_block = NULL;
4800 changed_statement = NULL;
4801
4802 expr2->external_blas = 1;
4803
4804 /* We do not handle data dependencies yet. */
4805 if (gfc_check_dependency (expr1, matrix_a, true)
4806 || gfc_check_dependency (expr1, matrix_b, true))
4807 return 0;
4808
4809 /* Generate the if statement and hang it into the tree. */
4810 if_limit = inline_limit_check (matrix_a, matrix_b, flag_blas_matmul_limit, 2);
4811 co_next = co->next;
4812 (*current_code) = if_limit;
4813 co->next = NULL;
4814 if_limit->block->next = co;
4815
4816 call = XCNEW (gfc_code);
4817 call->loc = co->loc;
4818
4819 /* Bounds checking - a bit simpler than for inlining since we only
4820 have to take care of two-dimensional arrays here. */
4821
4822 realloc_c = flag_realloc_lhs && gfc_is_reallocatable_lhs (expr1);
4823 next_code_point = &(if_limit->block->block->next);
4824
4825 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
4826 {
4827 gfc_code *test;
4828 // gfc_expr *a2, *b1, *c1, *c2, *a1, *b2;
4829 gfc_expr *c1, *a1, *c2, *b2, *a2;
4830 switch (m_case)
4831 {
4832 case A2B2:
4833 b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
4834 a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2);
4835 test = runtime_error_ne (b1, a2, B_ERROR_1);
4836 *next_code_point = test;
4837 next_code_point = &test->next;
4838
4839 if (!realloc_c)
4840 {
4841 c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1);
4842 a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1);
4843 test = runtime_error_ne (c1, a1, C_ERROR_1);
4844 *next_code_point = test;
4845 next_code_point = &test->next;
4846
4847 c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2);
4848 b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2);
4849 test = runtime_error_ne (c2, b2, C_ERROR_2);
4850 *next_code_point = test;
4851 next_code_point = &test->next;
4852 }
4853 break;
4854
4855 case A2B2T:
4856
4857 b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2);
4858 a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2);
4859 /* matrix_b is transposed, hence dimension 1 for the error message. */
4860 test = runtime_error_ne (b2, a2, B_ERROR_1);
4861 *next_code_point = test;
4862 next_code_point = &test->next;
4863
4864 if (!realloc_c)
4865 {
4866 c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1);
4867 a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1);
4868 test = runtime_error_ne (c1, a1, C_ERROR_1);
4869 *next_code_point = test;
4870 next_code_point = &test->next;
4871
4872 c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2);
4873 b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
4874 test = runtime_error_ne (c2, b1, C_ERROR_2);
4875 *next_code_point = test;
4876 next_code_point = &test->next;
4877 }
4878 break;
4879
4880 case A2TB2:
4881
4882 b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
4883 a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1);
4884 test = runtime_error_ne (b1, 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 b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2);
4898 test = runtime_error_ne (c2, b2, C_ERROR_2);
4899 *next_code_point = test;
4900 next_code_point = &test->next;
4901 }
4902 break;
4903
4904 case A2TB2T:
4905 b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2);
4906 a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1);
4907 test = runtime_error_ne (b2, a1, B_ERROR_1);
4908 *next_code_point = test;
4909 next_code_point = &test->next;
4910
4911 if (!realloc_c)
4912 {
4913 c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1);
4914 a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2);
4915 test = runtime_error_ne (c1, a2, C_ERROR_1);
4916 *next_code_point = test;
4917 next_code_point = &test->next;
4918
4919 c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2);
4920 b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
4921 test = runtime_error_ne (c2, b1, C_ERROR_2);
4922 *next_code_point = test;
4923 next_code_point = &test->next;
4924 }
4925 break;
4926
4927 default:
4928 gcc_unreachable ();
4929 }
4930 }
4931
4932 /* Handle the reallocation, if needed. */
4933
4934 if (realloc_c)
4935 {
4936 gfc_code *lhs_alloc;
4937
4938 lhs_alloc = matmul_lhs_realloc (expr1, matrix_a, matrix_b, m_case);
4939 *next_code_point = lhs_alloc;
4940 next_code_point = &lhs_alloc->next;
4941 }
4942
4943 *next_code_point = call;
4944 if_limit->next = co_next;
4945
4946 /* Set up the BLAS call. */
4947
4948 call->op = EXEC_CALL;
4949
4950 gfc_get_sym_tree (blas_name, current_ns, &(call->symtree), true);
4951 call->symtree->n.sym->attr.subroutine = 1;
4952 call->symtree->n.sym->attr.procedure = 1;
4953 call->symtree->n.sym->attr.flavor = FL_PROCEDURE;
4954 call->resolved_sym = call->symtree->n.sym;
4955 gfc_commit_symbol (call->resolved_sym);
4956
4957 /* Argument TRANSA. */
4958 next = gfc_get_actual_arglist ();
4959 next->expr = gfc_get_character_expr (gfc_default_character_kind, &co->loc,
4960 transa, 1);
4961
4962 call->ext.actual = next;
4963
4964 /* Argument TRANSB. */
4965 actual = next;
4966 next = gfc_get_actual_arglist ();
4967 next->expr = gfc_get_character_expr (gfc_default_character_kind, &co->loc,
4968 transb, 1);
4969 actual->next = next;
4970
4971 c1 = get_array_inq_function (GFC_ISYM_SIZE, gfc_copy_expr (a->expr), 1,
4972 gfc_integer_4_kind);
4973 c2 = get_array_inq_function (GFC_ISYM_SIZE, gfc_copy_expr (b->expr), 2,
4974 gfc_integer_4_kind);
4975
4976 b1 = get_array_inq_function (GFC_ISYM_SIZE, gfc_copy_expr (b->expr), 1,
4977 gfc_integer_4_kind);
4978
4979 /* Argument M. */
4980 actual = next;
4981 next = gfc_get_actual_arglist ();
4982 next->expr = c1;
4983 actual->next = next;
4984
4985 /* Argument N. */
4986 actual = next;
4987 next = gfc_get_actual_arglist ();
4988 next->expr = c2;
4989 actual->next = next;
4990
4991 /* Argument K. */
4992 actual = next;
4993 next = gfc_get_actual_arglist ();
4994 next->expr = b1;
4995 actual->next = next;
4996
4997 /* Argument ALPHA - set to one. */
4998 actual = next;
4999 next = gfc_get_actual_arglist ();
5000 next->expr = gfc_get_constant_expr (type, kind, &co->loc);
5001 if (type == BT_REAL)
5002 mpfr_set_ui (next->expr->value.real, 1, GFC_RND_MODE);
5003 else
5004 mpc_set_ui (next->expr->value.complex, 1, GFC_MPC_RND_MODE);
5005 actual->next = next;
5006
5007 /* Argument A. */
5008 actual = next;
5009 next = gfc_get_actual_arglist ();
5010 next->expr = gfc_copy_expr (matrix_a);
5011 actual->next = next;
5012
5013 /* Argument LDA. */
5014 actual = next;
5015 next = gfc_get_actual_arglist ();
5016 next->expr = get_array_inq_function (GFC_ISYM_SIZE, gfc_copy_expr (matrix_a),
5017 1, gfc_integer_4_kind);
5018 actual->next = next;
5019
5020 /* Argument B. */
5021 actual = next;
5022 next = gfc_get_actual_arglist ();
5023 next->expr = gfc_copy_expr (matrix_b);
5024 actual->next = next;
5025
5026 /* Argument LDB. */
5027 actual = next;
5028 next = gfc_get_actual_arglist ();
5029 next->expr = get_array_inq_function (GFC_ISYM_SIZE, gfc_copy_expr (matrix_b),
5030 1, gfc_integer_4_kind);
5031 actual->next = next;
5032
5033 /* Argument BETA - set to zero. */
5034 actual = next;
5035 next = gfc_get_actual_arglist ();
5036 next->expr = gfc_get_constant_expr (type, kind, &co->loc);
5037 if (type == BT_REAL)
5038 mpfr_set_ui (next->expr->value.real, 0, GFC_RND_MODE);
5039 else
5040 mpc_set_ui (next->expr->value.complex, 0, GFC_MPC_RND_MODE);
5041 actual->next = next;
5042
5043 /* Argument C. */
5044
5045 actual = next;
5046 next = gfc_get_actual_arglist ();
5047 next->expr = gfc_copy_expr (expr1);
5048 actual->next = next;
5049
5050 /* Argument LDC. */
5051 actual = next;
5052 next = gfc_get_actual_arglist ();
5053 next->expr = get_array_inq_function (GFC_ISYM_SIZE, gfc_copy_expr (expr1),
5054 1, gfc_integer_4_kind);
5055 actual->next = next;
5056
5057 return 0;
5058 }
5059
5060
5061 /* Code for index interchange for loops which are grouped together in DO
5062 CONCURRENT or FORALL statements. This is currently only applied if the
5063 iterations are grouped together in a single statement.
5064
5065 For this transformation, it is assumed that memory access in strides is
5066 expensive, and that loops which access later indices (which access memory
5067 in bigger strides) should be moved to the first loops.
5068
5069 For this, a loop over all the statements is executed, counting the times
5070 that the loop iteration values are accessed in each index. The loop
5071 indices are then sorted to minimize access to later indices from inner
5072 loops. */
5073
5074 /* Type for holding index information. */
5075
5076 typedef struct {
5077 gfc_symbol *sym;
5078 gfc_forall_iterator *fa;
5079 int num;
5080 int n[GFC_MAX_DIMENSIONS];
5081 } ind_type;
5082
5083 /* Callback function to determine if an expression is the
5084 corresponding variable. */
5085
5086 static int
5087 has_var (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, void *data)
5088 {
5089 gfc_expr *expr = *e;
5090 gfc_symbol *sym;
5091
5092 if (expr->expr_type != EXPR_VARIABLE)
5093 return 0;
5094
5095 sym = (gfc_symbol *) data;
5096 return sym == expr->symtree->n.sym;
5097 }
5098
5099 /* Callback function to calculate the cost of a certain index. */
5100
5101 static int
5102 index_cost (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
5103 void *data)
5104 {
5105 ind_type *ind;
5106 gfc_expr *expr;
5107 gfc_array_ref *ar;
5108 gfc_ref *ref;
5109 int i,j;
5110
5111 expr = *e;
5112 if (expr->expr_type != EXPR_VARIABLE)
5113 return 0;
5114
5115 ar = NULL;
5116 for (ref = expr->ref; ref; ref = ref->next)
5117 {
5118 if (ref->type == REF_ARRAY)
5119 {
5120 ar = &ref->u.ar;
5121 break;
5122 }
5123 }
5124 if (ar == NULL || ar->type != AR_ELEMENT)
5125 return 0;
5126
5127 ind = (ind_type *) data;
5128 for (i = 0; i < ar->dimen; i++)
5129 {
5130 for (j=0; ind[j].sym != NULL; j++)
5131 {
5132 if (gfc_expr_walker (&ar->start[i], has_var, (void *) (ind[j].sym)))
5133 ind[j].n[i]++;
5134 }
5135 }
5136 return 0;
5137 }
5138
5139 /* Callback function for qsort, to sort the loop indices. */
5140
5141 static int
5142 loop_comp (const void *e1, const void *e2)
5143 {
5144 const ind_type *i1 = (const ind_type *) e1;
5145 const ind_type *i2 = (const ind_type *) e2;
5146 int i;
5147
5148 for (i=GFC_MAX_DIMENSIONS-1; i >= 0; i--)
5149 {
5150 if (i1->n[i] != i2->n[i])
5151 return i1->n[i] - i2->n[i];
5152 }
5153 /* All other things being equal, let's not change the ordering. */
5154 return i2->num - i1->num;
5155 }
5156
5157 /* Main function to do the index interchange. */
5158
5159 static int
5160 index_interchange (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
5161 void *data ATTRIBUTE_UNUSED)
5162 {
5163 gfc_code *co;
5164 co = *c;
5165 int n_iter;
5166 gfc_forall_iterator *fa;
5167 ind_type *ind;
5168 int i, j;
5169
5170 if (co->op != EXEC_FORALL && co->op != EXEC_DO_CONCURRENT)
5171 return 0;
5172
5173 n_iter = 0;
5174 for (fa = co->ext.forall_iterator; fa; fa = fa->next)
5175 n_iter ++;
5176
5177 /* Nothing to reorder. */
5178 if (n_iter < 2)
5179 return 0;
5180
5181 ind = XALLOCAVEC (ind_type, n_iter + 1);
5182
5183 i = 0;
5184 for (fa = co->ext.forall_iterator; fa; fa = fa->next)
5185 {
5186 ind[i].sym = fa->var->symtree->n.sym;
5187 ind[i].fa = fa;
5188 for (j=0; j<GFC_MAX_DIMENSIONS; j++)
5189 ind[i].n[j] = 0;
5190 ind[i].num = i;
5191 i++;
5192 }
5193 ind[n_iter].sym = NULL;
5194 ind[n_iter].fa = NULL;
5195
5196 gfc_code_walker (c, gfc_dummy_code_callback, index_cost, (void *) ind);
5197 qsort ((void *) ind, n_iter, sizeof (ind_type), loop_comp);
5198
5199 /* Do the actual index interchange. */
5200 co->ext.forall_iterator = fa = ind[0].fa;
5201 for (i=1; i<n_iter; i++)
5202 {
5203 fa->next = ind[i].fa;
5204 fa = fa->next;
5205 }
5206 fa->next = NULL;
5207
5208 if (flag_warn_frontend_loop_interchange)
5209 {
5210 for (i=1; i<n_iter; i++)
5211 {
5212 if (ind[i-1].num > ind[i].num)
5213 {
5214 gfc_warning (OPT_Wfrontend_loop_interchange,
5215 "Interchanging loops at %L", &co->loc);
5216 break;
5217 }
5218 }
5219 }
5220
5221 return 0;
5222 }
5223
5224 #define WALK_SUBEXPR(NODE) \
5225 do \
5226 { \
5227 result = gfc_expr_walker (&(NODE), exprfn, data); \
5228 if (result) \
5229 return result; \
5230 } \
5231 while (0)
5232 #define WALK_SUBEXPR_TAIL(NODE) e = &(NODE); continue
5233
5234 /* Walk expression *E, calling EXPRFN on each expression in it. */
5235
5236 int
5237 gfc_expr_walker (gfc_expr **e, walk_expr_fn_t exprfn, void *data)
5238 {
5239 while (*e)
5240 {
5241 int walk_subtrees = 1;
5242 gfc_actual_arglist *a;
5243 gfc_ref *r;
5244 gfc_constructor *c;
5245
5246 int result = exprfn (e, &walk_subtrees, data);
5247 if (result)
5248 return result;
5249 if (walk_subtrees)
5250 switch ((*e)->expr_type)
5251 {
5252 case EXPR_OP:
5253 WALK_SUBEXPR ((*e)->value.op.op1);
5254 WALK_SUBEXPR_TAIL ((*e)->value.op.op2);
5255 /* No fallthru because of the tail recursion above. */
5256 case EXPR_FUNCTION:
5257 for (a = (*e)->value.function.actual; a; a = a->next)
5258 WALK_SUBEXPR (a->expr);
5259 break;
5260 case EXPR_COMPCALL:
5261 case EXPR_PPC:
5262 WALK_SUBEXPR ((*e)->value.compcall.base_object);
5263 for (a = (*e)->value.compcall.actual; a; a = a->next)
5264 WALK_SUBEXPR (a->expr);
5265 break;
5266
5267 case EXPR_STRUCTURE:
5268 case EXPR_ARRAY:
5269 for (c = gfc_constructor_first ((*e)->value.constructor); c;
5270 c = gfc_constructor_next (c))
5271 {
5272 if (c->iterator == NULL)
5273 WALK_SUBEXPR (c->expr);
5274 else
5275 {
5276 iterator_level ++;
5277 WALK_SUBEXPR (c->expr);
5278 iterator_level --;
5279 WALK_SUBEXPR (c->iterator->var);
5280 WALK_SUBEXPR (c->iterator->start);
5281 WALK_SUBEXPR (c->iterator->end);
5282 WALK_SUBEXPR (c->iterator->step);
5283 }
5284 }
5285
5286 if ((*e)->expr_type != EXPR_ARRAY)
5287 break;
5288
5289 /* Fall through to the variable case in order to walk the
5290 reference. */
5291 gcc_fallthrough ();
5292
5293 case EXPR_SUBSTRING:
5294 case EXPR_VARIABLE:
5295 for (r = (*e)->ref; r; r = r->next)
5296 {
5297 gfc_array_ref *ar;
5298 int i;
5299
5300 switch (r->type)
5301 {
5302 case REF_ARRAY:
5303 ar = &r->u.ar;
5304 if (ar->type == AR_SECTION || ar->type == AR_ELEMENT)
5305 {
5306 for (i=0; i< ar->dimen; i++)
5307 {
5308 WALK_SUBEXPR (ar->start[i]);
5309 WALK_SUBEXPR (ar->end[i]);
5310 WALK_SUBEXPR (ar->stride[i]);
5311 }
5312 }
5313
5314 break;
5315
5316 case REF_SUBSTRING:
5317 WALK_SUBEXPR (r->u.ss.start);
5318 WALK_SUBEXPR (r->u.ss.end);
5319 break;
5320
5321 case REF_COMPONENT:
5322 case REF_INQUIRY:
5323 break;
5324 }
5325 }
5326
5327 default:
5328 break;
5329 }
5330 return 0;
5331 }
5332 return 0;
5333 }
5334
5335 #define WALK_SUBCODE(NODE) \
5336 do \
5337 { \
5338 result = gfc_code_walker (&(NODE), codefn, exprfn, data); \
5339 if (result) \
5340 return result; \
5341 } \
5342 while (0)
5343
5344 /* Walk code *C, calling CODEFN on each gfc_code node in it and calling EXPRFN
5345 on each expression in it. If any of the hooks returns non-zero, that
5346 value is immediately returned. If the hook sets *WALK_SUBTREES to 0,
5347 no subcodes or subexpressions are traversed. */
5348
5349 int
5350 gfc_code_walker (gfc_code **c, walk_code_fn_t codefn, walk_expr_fn_t exprfn,
5351 void *data)
5352 {
5353 for (; *c; c = &(*c)->next)
5354 {
5355 int walk_subtrees = 1;
5356 int result = codefn (c, &walk_subtrees, data);
5357 if (result)
5358 return result;
5359
5360 if (walk_subtrees)
5361 {
5362 gfc_code *b;
5363 gfc_actual_arglist *a;
5364 gfc_code *co;
5365 gfc_association_list *alist;
5366 bool saved_in_omp_workshare;
5367 bool saved_in_omp_atomic;
5368 bool saved_in_where;
5369
5370 /* There might be statement insertions before the current code,
5371 which must not affect the expression walker. */
5372
5373 co = *c;
5374 saved_in_omp_workshare = in_omp_workshare;
5375 saved_in_omp_atomic = in_omp_atomic;
5376 saved_in_where = in_where;
5377
5378 switch (co->op)
5379 {
5380
5381 case EXEC_BLOCK:
5382 WALK_SUBCODE (co->ext.block.ns->code);
5383 if (co->ext.block.assoc)
5384 {
5385 bool saved_in_assoc_list = in_assoc_list;
5386
5387 in_assoc_list = true;
5388 for (alist = co->ext.block.assoc; alist; alist = alist->next)
5389 WALK_SUBEXPR (alist->target);
5390
5391 in_assoc_list = saved_in_assoc_list;
5392 }
5393
5394 break;
5395
5396 case EXEC_DO:
5397 doloop_level ++;
5398 WALK_SUBEXPR (co->ext.iterator->var);
5399 WALK_SUBEXPR (co->ext.iterator->start);
5400 WALK_SUBEXPR (co->ext.iterator->end);
5401 WALK_SUBEXPR (co->ext.iterator->step);
5402 break;
5403
5404 case EXEC_IF:
5405 if_level ++;
5406 break;
5407
5408 case EXEC_WHERE:
5409 in_where = true;
5410 break;
5411
5412 case EXEC_CALL:
5413 case EXEC_ASSIGN_CALL:
5414 for (a = co->ext.actual; a; a = a->next)
5415 WALK_SUBEXPR (a->expr);
5416 break;
5417
5418 case EXEC_CALL_PPC:
5419 WALK_SUBEXPR (co->expr1);
5420 for (a = co->ext.actual; a; a = a->next)
5421 WALK_SUBEXPR (a->expr);
5422 break;
5423
5424 case EXEC_SELECT:
5425 WALK_SUBEXPR (co->expr1);
5426 select_level ++;
5427 for (b = co->block; b; b = b->block)
5428 {
5429 gfc_case *cp;
5430 for (cp = b->ext.block.case_list; cp; cp = cp->next)
5431 {
5432 WALK_SUBEXPR (cp->low);
5433 WALK_SUBEXPR (cp->high);
5434 }
5435 WALK_SUBCODE (b->next);
5436 }
5437 continue;
5438
5439 case EXEC_ALLOCATE:
5440 case EXEC_DEALLOCATE:
5441 {
5442 gfc_alloc *a;
5443 for (a = co->ext.alloc.list; a; a = a->next)
5444 WALK_SUBEXPR (a->expr);
5445 break;
5446 }
5447
5448 case EXEC_FORALL:
5449 case EXEC_DO_CONCURRENT:
5450 {
5451 gfc_forall_iterator *fa;
5452 for (fa = co->ext.forall_iterator; fa; fa = fa->next)
5453 {
5454 WALK_SUBEXPR (fa->var);
5455 WALK_SUBEXPR (fa->start);
5456 WALK_SUBEXPR (fa->end);
5457 WALK_SUBEXPR (fa->stride);
5458 }
5459 if (co->op == EXEC_FORALL)
5460 forall_level ++;
5461 break;
5462 }
5463
5464 case EXEC_OPEN:
5465 WALK_SUBEXPR (co->ext.open->unit);
5466 WALK_SUBEXPR (co->ext.open->file);
5467 WALK_SUBEXPR (co->ext.open->status);
5468 WALK_SUBEXPR (co->ext.open->access);
5469 WALK_SUBEXPR (co->ext.open->form);
5470 WALK_SUBEXPR (co->ext.open->recl);
5471 WALK_SUBEXPR (co->ext.open->blank);
5472 WALK_SUBEXPR (co->ext.open->position);
5473 WALK_SUBEXPR (co->ext.open->action);
5474 WALK_SUBEXPR (co->ext.open->delim);
5475 WALK_SUBEXPR (co->ext.open->pad);
5476 WALK_SUBEXPR (co->ext.open->iostat);
5477 WALK_SUBEXPR (co->ext.open->iomsg);
5478 WALK_SUBEXPR (co->ext.open->convert);
5479 WALK_SUBEXPR (co->ext.open->decimal);
5480 WALK_SUBEXPR (co->ext.open->encoding);
5481 WALK_SUBEXPR (co->ext.open->round);
5482 WALK_SUBEXPR (co->ext.open->sign);
5483 WALK_SUBEXPR (co->ext.open->asynchronous);
5484 WALK_SUBEXPR (co->ext.open->id);
5485 WALK_SUBEXPR (co->ext.open->newunit);
5486 WALK_SUBEXPR (co->ext.open->share);
5487 WALK_SUBEXPR (co->ext.open->cc);
5488 break;
5489
5490 case EXEC_CLOSE:
5491 WALK_SUBEXPR (co->ext.close->unit);
5492 WALK_SUBEXPR (co->ext.close->status);
5493 WALK_SUBEXPR (co->ext.close->iostat);
5494 WALK_SUBEXPR (co->ext.close->iomsg);
5495 break;
5496
5497 case EXEC_BACKSPACE:
5498 case EXEC_ENDFILE:
5499 case EXEC_REWIND:
5500 case EXEC_FLUSH:
5501 WALK_SUBEXPR (co->ext.filepos->unit);
5502 WALK_SUBEXPR (co->ext.filepos->iostat);
5503 WALK_SUBEXPR (co->ext.filepos->iomsg);
5504 break;
5505
5506 case EXEC_INQUIRE:
5507 WALK_SUBEXPR (co->ext.inquire->unit);
5508 WALK_SUBEXPR (co->ext.inquire->file);
5509 WALK_SUBEXPR (co->ext.inquire->iomsg);
5510 WALK_SUBEXPR (co->ext.inquire->iostat);
5511 WALK_SUBEXPR (co->ext.inquire->exist);
5512 WALK_SUBEXPR (co->ext.inquire->opened);
5513 WALK_SUBEXPR (co->ext.inquire->number);
5514 WALK_SUBEXPR (co->ext.inquire->named);
5515 WALK_SUBEXPR (co->ext.inquire->name);
5516 WALK_SUBEXPR (co->ext.inquire->access);
5517 WALK_SUBEXPR (co->ext.inquire->sequential);
5518 WALK_SUBEXPR (co->ext.inquire->direct);
5519 WALK_SUBEXPR (co->ext.inquire->form);
5520 WALK_SUBEXPR (co->ext.inquire->formatted);
5521 WALK_SUBEXPR (co->ext.inquire->unformatted);
5522 WALK_SUBEXPR (co->ext.inquire->recl);
5523 WALK_SUBEXPR (co->ext.inquire->nextrec);
5524 WALK_SUBEXPR (co->ext.inquire->blank);
5525 WALK_SUBEXPR (co->ext.inquire->position);
5526 WALK_SUBEXPR (co->ext.inquire->action);
5527 WALK_SUBEXPR (co->ext.inquire->read);
5528 WALK_SUBEXPR (co->ext.inquire->write);
5529 WALK_SUBEXPR (co->ext.inquire->readwrite);
5530 WALK_SUBEXPR (co->ext.inquire->delim);
5531 WALK_SUBEXPR (co->ext.inquire->encoding);
5532 WALK_SUBEXPR (co->ext.inquire->pad);
5533 WALK_SUBEXPR (co->ext.inquire->iolength);
5534 WALK_SUBEXPR (co->ext.inquire->convert);
5535 WALK_SUBEXPR (co->ext.inquire->strm_pos);
5536 WALK_SUBEXPR (co->ext.inquire->asynchronous);
5537 WALK_SUBEXPR (co->ext.inquire->decimal);
5538 WALK_SUBEXPR (co->ext.inquire->pending);
5539 WALK_SUBEXPR (co->ext.inquire->id);
5540 WALK_SUBEXPR (co->ext.inquire->sign);
5541 WALK_SUBEXPR (co->ext.inquire->size);
5542 WALK_SUBEXPR (co->ext.inquire->round);
5543 break;
5544
5545 case EXEC_WAIT:
5546 WALK_SUBEXPR (co->ext.wait->unit);
5547 WALK_SUBEXPR (co->ext.wait->iostat);
5548 WALK_SUBEXPR (co->ext.wait->iomsg);
5549 WALK_SUBEXPR (co->ext.wait->id);
5550 break;
5551
5552 case EXEC_READ:
5553 case EXEC_WRITE:
5554 WALK_SUBEXPR (co->ext.dt->io_unit);
5555 WALK_SUBEXPR (co->ext.dt->format_expr);
5556 WALK_SUBEXPR (co->ext.dt->rec);
5557 WALK_SUBEXPR (co->ext.dt->advance);
5558 WALK_SUBEXPR (co->ext.dt->iostat);
5559 WALK_SUBEXPR (co->ext.dt->size);
5560 WALK_SUBEXPR (co->ext.dt->iomsg);
5561 WALK_SUBEXPR (co->ext.dt->id);
5562 WALK_SUBEXPR (co->ext.dt->pos);
5563 WALK_SUBEXPR (co->ext.dt->asynchronous);
5564 WALK_SUBEXPR (co->ext.dt->blank);
5565 WALK_SUBEXPR (co->ext.dt->decimal);
5566 WALK_SUBEXPR (co->ext.dt->delim);
5567 WALK_SUBEXPR (co->ext.dt->pad);
5568 WALK_SUBEXPR (co->ext.dt->round);
5569 WALK_SUBEXPR (co->ext.dt->sign);
5570 WALK_SUBEXPR (co->ext.dt->extra_comma);
5571 break;
5572
5573 case EXEC_OACC_ATOMIC:
5574 case EXEC_OMP_ATOMIC:
5575 in_omp_atomic = true;
5576 break;
5577
5578 case EXEC_OMP_PARALLEL:
5579 case EXEC_OMP_PARALLEL_DO:
5580 case EXEC_OMP_PARALLEL_DO_SIMD:
5581 case EXEC_OMP_PARALLEL_LOOP:
5582 case EXEC_OMP_PARALLEL_MASKED:
5583 case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
5584 case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
5585 case EXEC_OMP_PARALLEL_MASTER:
5586 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
5587 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
5588 case EXEC_OMP_PARALLEL_SECTIONS:
5589
5590 in_omp_workshare = false;
5591
5592 /* This goto serves as a shortcut to avoid code
5593 duplication or a larger if or switch statement. */
5594 goto check_omp_clauses;
5595
5596 case EXEC_OMP_WORKSHARE:
5597 case EXEC_OMP_PARALLEL_WORKSHARE:
5598
5599 in_omp_workshare = true;
5600
5601 /* Fall through */
5602
5603 case EXEC_OMP_CRITICAL:
5604 case EXEC_OMP_DISTRIBUTE:
5605 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
5606 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
5607 case EXEC_OMP_DISTRIBUTE_SIMD:
5608 case EXEC_OMP_DO:
5609 case EXEC_OMP_DO_SIMD:
5610 case EXEC_OMP_LOOP:
5611 case EXEC_OMP_ORDERED:
5612 case EXEC_OMP_SECTIONS:
5613 case EXEC_OMP_SINGLE:
5614 case EXEC_OMP_END_SINGLE:
5615 case EXEC_OMP_SIMD:
5616 case EXEC_OMP_TASKLOOP:
5617 case EXEC_OMP_TASKLOOP_SIMD:
5618 case EXEC_OMP_TARGET:
5619 case EXEC_OMP_TARGET_DATA:
5620 case EXEC_OMP_TARGET_ENTER_DATA:
5621 case EXEC_OMP_TARGET_EXIT_DATA:
5622 case EXEC_OMP_TARGET_PARALLEL:
5623 case EXEC_OMP_TARGET_PARALLEL_DO:
5624 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
5625 case EXEC_OMP_TARGET_PARALLEL_LOOP:
5626 case EXEC_OMP_TARGET_SIMD:
5627 case EXEC_OMP_TARGET_TEAMS:
5628 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
5629 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
5630 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
5631 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
5632 case EXEC_OMP_TARGET_TEAMS_LOOP:
5633 case EXEC_OMP_TARGET_UPDATE:
5634 case EXEC_OMP_TASK:
5635 case EXEC_OMP_TEAMS:
5636 case EXEC_OMP_TEAMS_DISTRIBUTE:
5637 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
5638 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
5639 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
5640 case EXEC_OMP_TEAMS_LOOP:
5641
5642 /* Come to this label only from the
5643 EXEC_OMP_PARALLEL_* cases above. */
5644
5645 check_omp_clauses:
5646
5647 if (co->ext.omp_clauses)
5648 {
5649 gfc_omp_namelist *n;
5650 static int list_types[]
5651 = { OMP_LIST_ALIGNED, OMP_LIST_LINEAR, OMP_LIST_DEPEND,
5652 OMP_LIST_MAP, OMP_LIST_TO, OMP_LIST_FROM };
5653 size_t idx;
5654 WALK_SUBEXPR (co->ext.omp_clauses->if_expr);
5655 WALK_SUBEXPR (co->ext.omp_clauses->final_expr);
5656 WALK_SUBEXPR (co->ext.omp_clauses->num_threads);
5657 WALK_SUBEXPR (co->ext.omp_clauses->chunk_size);
5658 WALK_SUBEXPR (co->ext.omp_clauses->safelen_expr);
5659 WALK_SUBEXPR (co->ext.omp_clauses->simdlen_expr);
5660 WALK_SUBEXPR (co->ext.omp_clauses->num_teams_lower);
5661 WALK_SUBEXPR (co->ext.omp_clauses->num_teams_upper);
5662 WALK_SUBEXPR (co->ext.omp_clauses->device);
5663 WALK_SUBEXPR (co->ext.omp_clauses->thread_limit);
5664 WALK_SUBEXPR (co->ext.omp_clauses->dist_chunk_size);
5665 WALK_SUBEXPR (co->ext.omp_clauses->grainsize);
5666 WALK_SUBEXPR (co->ext.omp_clauses->hint);
5667 WALK_SUBEXPR (co->ext.omp_clauses->num_tasks);
5668 WALK_SUBEXPR (co->ext.omp_clauses->priority);
5669 WALK_SUBEXPR (co->ext.omp_clauses->detach);
5670 for (idx = 0; idx < OMP_IF_LAST; idx++)
5671 WALK_SUBEXPR (co->ext.omp_clauses->if_exprs[idx]);
5672 for (idx = 0; idx < ARRAY_SIZE (list_types); idx++)
5673 for (n = co->ext.omp_clauses->lists[list_types[idx]];
5674 n; n = n->next)
5675 WALK_SUBEXPR (n->expr);
5676 }
5677 break;
5678 default:
5679 break;
5680 }
5681
5682 WALK_SUBEXPR (co->expr1);
5683 WALK_SUBEXPR (co->expr2);
5684 WALK_SUBEXPR (co->expr3);
5685 WALK_SUBEXPR (co->expr4);
5686 for (b = co->block; b; b = b->block)
5687 {
5688 WALK_SUBEXPR (b->expr1);
5689 WALK_SUBEXPR (b->expr2);
5690 WALK_SUBCODE (b->next);
5691 }
5692
5693 if (co->op == EXEC_FORALL)
5694 forall_level --;
5695
5696 if (co->op == EXEC_DO)
5697 doloop_level --;
5698
5699 if (co->op == EXEC_IF)
5700 if_level --;
5701
5702 if (co->op == EXEC_SELECT)
5703 select_level --;
5704
5705 in_omp_workshare = saved_in_omp_workshare;
5706 in_omp_atomic = saved_in_omp_atomic;
5707 in_where = saved_in_where;
5708 }
5709 }
5710 return 0;
5711 }
5712
5713 /* As a post-resolution step, check that all global symbols which are
5714 not declared in the source file match in their call signatures.
5715 We do this by looping over the code (and expressions). The first call
5716 we happen to find is assumed to be canonical. */
5717
5718
5719 /* Common tests for argument checking for both functions and subroutines. */
5720
5721 static int
5722 check_externals_procedure (gfc_symbol *sym, locus *loc,
5723 gfc_actual_arglist *actual)
5724 {
5725 gfc_gsymbol *gsym;
5726 gfc_symbol *def_sym = NULL;
5727
5728 if (sym == NULL || sym->attr.is_bind_c)
5729 return 0;
5730
5731 if (sym->attr.proc != PROC_EXTERNAL && sym->attr.proc != PROC_UNKNOWN)
5732 return 0;
5733
5734 if (sym->attr.if_source == IFSRC_IFBODY || sym->attr.if_source == IFSRC_DECL)
5735 return 0;
5736
5737 gsym = gfc_find_gsymbol (gfc_gsym_root, sym->name);
5738 if (gsym == NULL)
5739 return 0;
5740
5741 if (gsym->ns)
5742 gfc_find_symbol (sym->name, gsym->ns, 0, &def_sym);
5743
5744 if (def_sym)
5745 {
5746 gfc_compare_actual_formal (&actual, def_sym->formal, 0, 0, 0, loc);
5747 return 0;
5748 }
5749
5750 /* First time we have seen this procedure called. Let's create an
5751 "interface" from the call and put it into a new namespace. */
5752 gfc_namespace *save_ns;
5753 gfc_symbol *new_sym;
5754
5755 gsym->where = *loc;
5756 save_ns = gfc_current_ns;
5757 gsym->ns = gfc_get_namespace (gfc_current_ns, 0);
5758 gsym->ns->proc_name = sym;
5759
5760 gfc_get_symbol (sym->name, gsym->ns, &new_sym);
5761 gcc_assert (new_sym);
5762 new_sym->attr = sym->attr;
5763 new_sym->attr.if_source = IFSRC_DECL;
5764 gfc_current_ns = gsym->ns;
5765
5766 gfc_get_formal_from_actual_arglist (new_sym, actual);
5767 new_sym->declared_at = *loc;
5768 gfc_current_ns = save_ns;
5769
5770 return 0;
5771
5772 }
5773
5774 /* Callback for calls of external routines. */
5775
5776 static int
5777 check_externals_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
5778 void *data ATTRIBUTE_UNUSED)
5779 {
5780 gfc_code *co = *c;
5781 gfc_symbol *sym;
5782 locus *loc;
5783 gfc_actual_arglist *actual;
5784
5785 if (co->op != EXEC_CALL)
5786 return 0;
5787
5788 sym = co->resolved_sym;
5789 loc = &co->loc;
5790 actual = co->ext.actual;
5791
5792 return check_externals_procedure (sym, loc, actual);
5793
5794 }
5795
5796 /* Callback for external functions. */
5797
5798 static int
5799 check_externals_expr (gfc_expr **ep, int *walk_subtrees ATTRIBUTE_UNUSED,
5800 void *data ATTRIBUTE_UNUSED)
5801 {
5802 gfc_expr *e = *ep;
5803 gfc_symbol *sym;
5804 locus *loc;
5805 gfc_actual_arglist *actual;
5806
5807 if (e->expr_type != EXPR_FUNCTION)
5808 return 0;
5809
5810 sym = e->value.function.esym;
5811 if (sym == NULL)
5812 return 0;
5813
5814 loc = &e->where;
5815 actual = e->value.function.actual;
5816
5817 return check_externals_procedure (sym, loc, actual);
5818 }
5819
5820 /* Function to check if any interface clashes with a global
5821 identifier, to be invoked via gfc_traverse_ns. */
5822
5823 static void
5824 check_against_globals (gfc_symbol *sym)
5825 {
5826 gfc_gsymbol *gsym;
5827 gfc_symbol *def_sym = NULL;
5828 const char *sym_name;
5829 char buf [200];
5830
5831 if (sym->attr.if_source != IFSRC_IFBODY || sym->attr.flavor != FL_PROCEDURE
5832 || sym->attr.generic || sym->error)
5833 return;
5834
5835 if (sym->binding_label)
5836 sym_name = sym->binding_label;
5837 else
5838 sym_name = sym->name;
5839
5840 gsym = gfc_find_gsymbol (gfc_gsym_root, sym_name);
5841 if (gsym && gsym->ns)
5842 gfc_find_symbol (sym->name, gsym->ns, 0, &def_sym);
5843
5844 if (!def_sym || def_sym->error || def_sym->attr.generic)
5845 return;
5846
5847 buf[0] = 0;
5848 gfc_compare_interfaces (sym, def_sym, sym->name, 0, 1, buf, sizeof(buf),
5849 NULL, NULL, NULL);
5850 if (buf[0] != 0)
5851 {
5852 gfc_warning (0, "%s between %L and %L", buf, &def_sym->declared_at,
5853 &sym->declared_at);
5854 sym->error = 1;
5855 def_sym->error = 1;
5856 }
5857
5858 }
5859
5860 /* Do the code-walkling part for gfc_check_externals. */
5861
5862 static void
5863 gfc_check_externals0 (gfc_namespace *ns)
5864 {
5865 gfc_code_walker (&ns->code, check_externals_code, check_externals_expr, NULL);
5866
5867 for (ns = ns->contained; ns; ns = ns->sibling)
5868 {
5869 if (ns->code == NULL || ns->code->op != EXEC_BLOCK)
5870 gfc_check_externals0 (ns);
5871 }
5872
5873 }
5874
5875 /* Called routine. */
5876
5877 void
5878 gfc_check_externals (gfc_namespace *ns)
5879 {
5880 gfc_clear_error ();
5881
5882 /* Turn errors into warnings if the user indicated this. */
5883
5884 if (!pedantic && flag_allow_argument_mismatch)
5885 gfc_errors_to_warnings (true);
5886
5887 gfc_check_externals0 (ns);
5888 gfc_traverse_ns (ns, check_against_globals);
5889
5890 gfc_errors_to_warnings (false);
5891 }
5892
5893 /* Callback function. If there is a call to a subroutine which is
5894 neither pure nor implicit_pure, unset the implicit_pure flag for
5895 the caller and return -1. */
5896
5897 static int
5898 implicit_pure_call (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
5899 void *sym_data)
5900 {
5901 gfc_code *co = *c;
5902 gfc_symbol *caller_sym;
5903 symbol_attribute *a;
5904
5905 if (co->op != EXEC_CALL || co->resolved_sym == NULL)
5906 return 0;
5907
5908 a = &co->resolved_sym->attr;
5909 if (a->intrinsic || 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 /* Callback function. If there is a call to a function which is
5918 neither pure nor implicit_pure, unset the implicit_pure flag for
5919 the caller and return 1. */
5920
5921 static int
5922 implicit_pure_expr (gfc_expr **e, int *walk ATTRIBUTE_UNUSED, void *sym_data)
5923 {
5924 gfc_expr *expr = *e;
5925 gfc_symbol *caller_sym;
5926 gfc_symbol *sym;
5927 symbol_attribute *a;
5928
5929 if (expr->expr_type != EXPR_FUNCTION || expr->value.function.isym)
5930 return 0;
5931
5932 sym = expr->symtree->n.sym;
5933 a = &sym->attr;
5934 if (a->pure || a->implicit_pure)
5935 return 0;
5936
5937 caller_sym = (gfc_symbol *) sym_data;
5938 gfc_unset_implicit_pure (caller_sym);
5939 return 1;
5940 }
5941
5942 /* Go through all procedures in the namespace and unset the
5943 implicit_pure attribute for any procedure that calls something not
5944 pure or implicit pure. */
5945
5946 bool
5947 gfc_fix_implicit_pure (gfc_namespace *ns)
5948 {
5949 bool changed = false;
5950 gfc_symbol *proc = ns->proc_name;
5951
5952 if (proc && proc->attr.flavor == FL_PROCEDURE && proc->attr.implicit_pure
5953 && ns->code
5954 && gfc_code_walker (&ns->code, implicit_pure_call, implicit_pure_expr,
5955 (void *) ns->proc_name))
5956 changed = true;
5957
5958 for (ns = ns->contained; ns; ns = ns->sibling)
5959 {
5960 if (gfc_fix_implicit_pure (ns))
5961 changed = true;
5962 }
5963
5964 return changed;
5965 }
Mirror of the offical gcc git repository hosted at gcc.gnu.org