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