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 /* We only handle assignment to numeric or logical variables. */
3923 switch(expr1->ts.type)
3924 {
3925 case BT_INTEGER:
3926 case BT_LOGICAL:
3927 case BT_REAL:
3928 case BT_COMPLEX:
3929 break;
3930
3931 default:
3932 return 0;
3933 }
3934
3935 ns = insert_block ();
3936
3937 /* Assign the type of the zero expression for initializing the resulting
3938 array, and the expression (+ and * for real, integer and complex;
3939 .and. and .or for logical. */
3940
3941 switch(expr1->ts.type)
3942 {
3943 case BT_INTEGER:
3944 zero_e = gfc_get_int_expr (expr1->ts.kind, &expr1->where, 0);
3945 op_times = INTRINSIC_TIMES;
3946 op_plus = INTRINSIC_PLUS;
3947 break;
3948
3949 case BT_LOGICAL:
3950 op_times = INTRINSIC_AND;
3951 op_plus = INTRINSIC_OR;
3952 zero_e = gfc_get_logical_expr (expr1->ts.kind, &expr1->where,
3953 0);
3954 break;
3955 case BT_REAL:
3956 zero_e = gfc_get_constant_expr (BT_REAL, expr1->ts.kind,
3957 &expr1->where);
3958 mpfr_set_si (zero_e->value.real, 0, GFC_RND_MODE);
3959 op_times = INTRINSIC_TIMES;
3960 op_plus = INTRINSIC_PLUS;
3961 break;
3962
3963 case BT_COMPLEX:
3964 zero_e = gfc_get_constant_expr (BT_COMPLEX, expr1->ts.kind,
3965 &expr1->where);
3966 mpc_set_si_si (zero_e->value.complex, 0, 0, GFC_RND_MODE);
3967 op_times = INTRINSIC_TIMES;
3968 op_plus = INTRINSIC_PLUS;
3969
3970 break;
3971
3972 default:
3973 gcc_unreachable();
3974 }
3975
3976 current_code = &ns->code;
3977
3978 /* Freeze the references, keeping track of how many temporary variables were
3979 created. */
3980 n_vars = 0;
3981 freeze_references (matrix_a);
3982 freeze_references (matrix_b);
3983 freeze_references (expr1);
3984
3985 if (n_vars == 0)
3986 next_code_point = current_code;
3987 else
3988 {
3989 next_code_point = &ns->code;
3990 for (i=0; i<n_vars; i++)
3991 next_code_point = &(*next_code_point)->next;
3992 }
3993
3994 /* Take care of the inline flag. If the limit check evaluates to a
3995 constant, dead code elimination will eliminate the unneeded branch. */
3996
3997 if (flag_inline_matmul_limit > 0 && matrix_a->rank == 2
3998 && matrix_b->rank == 2)
3999 {
4000 if_limit = inline_limit_check (matrix_a, matrix_b,
4001 flag_inline_matmul_limit);
4002
4003 /* Insert the original statement into the else branch. */
4004 if_limit->block->block->next = co;
4005 co->next = NULL;
4006
4007 /* ... and the new ones go into the original one. */
4008 *next_code_point = if_limit;
4009 next_code_point = &if_limit->block->next;
4010 }
4011
4012 zero_e->no_bounds_check = 1;
4013
4014 assign_zero = XCNEW (gfc_code);
4015 assign_zero->op = EXEC_ASSIGN;
4016 assign_zero->loc = co->loc;
4017 assign_zero->expr1 = gfc_copy_expr (expr1);
4018 assign_zero->expr1->no_bounds_check = 1;
4019 assign_zero->expr2 = zero_e;
4020
4021 realloc_c = flag_realloc_lhs && gfc_is_reallocatable_lhs (expr1);
4022
4023 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
4024 {
4025 gfc_code *test;
4026 gfc_expr *a2, *b1, *c1, *c2, *a1, *b2;
4027
4028 switch (m_case)
4029 {
4030 case A2B1:
4031
4032 b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
4033 a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2);
4034 test = runtime_error_ne (b1, a2, B_ERROR_1);
4035 *next_code_point = test;
4036 next_code_point = &test->next;
4037
4038 if (!realloc_c)
4039 {
4040 c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1);
4041 a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1);
4042 test = runtime_error_ne (c1, a1, C_ERROR_1);
4043 *next_code_point = test;
4044 next_code_point = &test->next;
4045 }
4046 break;
4047
4048 case A1B2:
4049
4050 b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
4051 a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1);
4052 test = runtime_error_ne (b1, a1, B_ERROR_1);
4053 *next_code_point = test;
4054 next_code_point = &test->next;
4055
4056 if (!realloc_c)
4057 {
4058 c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1);
4059 b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2);
4060 test = runtime_error_ne (c1, b2, C_ERROR_1);
4061 *next_code_point = test;
4062 next_code_point = &test->next;
4063 }
4064 break;
4065
4066 case A2B2:
4067
4068 b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
4069 a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2);
4070 test = runtime_error_ne (b1, a2, B_ERROR_1);
4071 *next_code_point = test;
4072 next_code_point = &test->next;
4073
4074 if (!realloc_c)
4075 {
4076 c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1);
4077 a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1);
4078 test = runtime_error_ne (c1, a1, C_ERROR_1);
4079 *next_code_point = test;
4080 next_code_point = &test->next;
4081
4082 c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2);
4083 b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2);
4084 test = runtime_error_ne (c2, b2, C_ERROR_2);
4085 *next_code_point = test;
4086 next_code_point = &test->next;
4087 }
4088 break;
4089
4090 case A2B2T:
4091
4092 b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2);
4093 a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2);
4094 /* matrix_b is transposed, hence dimension 1 for the error message. */
4095 test = runtime_error_ne (b2, a2, B_ERROR_1);
4096 *next_code_point = test;
4097 next_code_point = &test->next;
4098
4099 if (!realloc_c)
4100 {
4101 c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1);
4102 a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1);
4103 test = runtime_error_ne (c1, a1, C_ERROR_1);
4104 *next_code_point = test;
4105 next_code_point = &test->next;
4106
4107 c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2);
4108 b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
4109 test = runtime_error_ne (c2, b1, C_ERROR_2);
4110 *next_code_point = test;
4111 next_code_point = &test->next;
4112 }
4113 break;
4114
4115 case A2TB2:
4116
4117 b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
4118 a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1);
4119 test = runtime_error_ne (b1, a1, B_ERROR_1);
4120 *next_code_point = test;
4121 next_code_point = &test->next;
4122
4123 if (!realloc_c)
4124 {
4125 c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1);
4126 a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2);
4127 test = runtime_error_ne (c1, a2, C_ERROR_1);
4128 *next_code_point = test;
4129 next_code_point = &test->next;
4130
4131 c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2);
4132 b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2);
4133 test = runtime_error_ne (c2, b2, C_ERROR_2);
4134 *next_code_point = test;
4135 next_code_point = &test->next;
4136 }
4137 break;
4138
4139 default:
4140 gcc_unreachable ();
4141 }
4142 }
4143
4144 /* Handle the reallocation, if needed. */
4145
4146 if (realloc_c)
4147 {
4148 gfc_code *lhs_alloc;
4149
4150 lhs_alloc = matmul_lhs_realloc (expr1, matrix_a, matrix_b, m_case);
4151
4152 *next_code_point = lhs_alloc;
4153 next_code_point = &lhs_alloc->next;
4154
4155 }
4156
4157 *next_code_point = assign_zero;
4158
4159 zero = gfc_get_int_expr (gfc_index_integer_kind, &co->loc, 0);
4160
4161 assign_matmul = XCNEW (gfc_code);
4162 assign_matmul->op = EXEC_ASSIGN;
4163 assign_matmul->loc = co->loc;
4164
4165 /* Get the bounds for the loops, create them and create the scalarized
4166 expressions. */
4167
4168 switch (m_case)
4169 {
4170 case A2B2:
4171
4172 u1 = get_size_m1 (matrix_b, 2);
4173 u2 = get_size_m1 (matrix_a, 2);
4174 u3 = get_size_m1 (matrix_a, 1);
4175
4176 do_1 = create_do_loop (gfc_copy_expr (zero), u1, NULL, &co->loc, ns);
4177 do_2 = create_do_loop (gfc_copy_expr (zero), u2, NULL, &co->loc, ns);
4178 do_3 = create_do_loop (gfc_copy_expr (zero), u3, NULL, &co->loc, ns);
4179
4180 do_1->block->next = do_2;
4181 do_2->block->next = do_3;
4182 do_3->block->next = assign_matmul;
4183
4184 var_1 = do_1->ext.iterator->var;
4185 var_2 = do_2->ext.iterator->var;
4186 var_3 = do_3->ext.iterator->var;
4187
4188 list[0] = var_3;
4189 list[1] = var_1;
4190 cscalar = scalarized_expr (co->expr1, list, 2);
4191
4192 list[0] = var_3;
4193 list[1] = var_2;
4194 ascalar = scalarized_expr (matrix_a, list, 2);
4195
4196 list[0] = var_2;
4197 list[1] = var_1;
4198 bscalar = scalarized_expr (matrix_b, list, 2);
4199
4200 break;
4201
4202 case A2B2T:
4203
4204 u1 = get_size_m1 (matrix_b, 1);
4205 u2 = get_size_m1 (matrix_a, 2);
4206 u3 = get_size_m1 (matrix_a, 1);
4207
4208 do_1 = create_do_loop (gfc_copy_expr (zero), u1, NULL, &co->loc, ns);
4209 do_2 = create_do_loop (gfc_copy_expr (zero), u2, NULL, &co->loc, ns);
4210 do_3 = create_do_loop (gfc_copy_expr (zero), u3, NULL, &co->loc, ns);
4211
4212 do_1->block->next = do_2;
4213 do_2->block->next = do_3;
4214 do_3->block->next = assign_matmul;
4215
4216 var_1 = do_1->ext.iterator->var;
4217 var_2 = do_2->ext.iterator->var;
4218 var_3 = do_3->ext.iterator->var;
4219
4220 list[0] = var_3;
4221 list[1] = var_1;
4222 cscalar = scalarized_expr (co->expr1, list, 2);
4223
4224 list[0] = var_3;
4225 list[1] = var_2;
4226 ascalar = scalarized_expr (matrix_a, list, 2);
4227
4228 list[0] = var_1;
4229 list[1] = var_2;
4230 bscalar = scalarized_expr (matrix_b, list, 2);
4231
4232 break;
4233
4234 case A2TB2:
4235
4236 u1 = get_size_m1 (matrix_a, 2);
4237 u2 = get_size_m1 (matrix_b, 2);
4238 u3 = get_size_m1 (matrix_a, 1);
4239
4240 do_1 = create_do_loop (gfc_copy_expr (zero), u1, NULL, &co->loc, ns);
4241 do_2 = create_do_loop (gfc_copy_expr (zero), u2, NULL, &co->loc, ns);
4242 do_3 = create_do_loop (gfc_copy_expr (zero), u3, NULL, &co->loc, ns);
4243
4244 do_1->block->next = do_2;
4245 do_2->block->next = do_3;
4246 do_3->block->next = assign_matmul;
4247
4248 var_1 = do_1->ext.iterator->var;
4249 var_2 = do_2->ext.iterator->var;
4250 var_3 = do_3->ext.iterator->var;
4251
4252 list[0] = var_1;
4253 list[1] = var_2;
4254 cscalar = scalarized_expr (co->expr1, list, 2);
4255
4256 list[0] = var_3;
4257 list[1] = var_1;
4258 ascalar = scalarized_expr (matrix_a, list, 2);
4259
4260 list[0] = var_3;
4261 list[1] = var_2;
4262 bscalar = scalarized_expr (matrix_b, list, 2);
4263
4264 break;
4265
4266 case A2B1:
4267 u1 = get_size_m1 (matrix_b, 1);
4268 u2 = get_size_m1 (matrix_a, 1);
4269
4270 do_1 = create_do_loop (gfc_copy_expr (zero), u1, NULL, &co->loc, ns);
4271 do_2 = create_do_loop (gfc_copy_expr (zero), u2, NULL, &co->loc, ns);
4272
4273 do_1->block->next = do_2;
4274 do_2->block->next = assign_matmul;
4275
4276 var_1 = do_1->ext.iterator->var;
4277 var_2 = do_2->ext.iterator->var;
4278
4279 list[0] = var_2;
4280 cscalar = scalarized_expr (co->expr1, list, 1);
4281
4282 list[0] = var_2;
4283 list[1] = var_1;
4284 ascalar = scalarized_expr (matrix_a, list, 2);
4285
4286 list[0] = var_1;
4287 bscalar = scalarized_expr (matrix_b, list, 1);
4288
4289 break;
4290
4291 case A1B2:
4292 u1 = get_size_m1 (matrix_b, 2);
4293 u2 = get_size_m1 (matrix_a, 1);
4294
4295 do_1 = create_do_loop (gfc_copy_expr (zero), u1, NULL, &co->loc, ns);
4296 do_2 = create_do_loop (gfc_copy_expr (zero), u2, NULL, &co->loc, ns);
4297
4298 do_1->block->next = do_2;
4299 do_2->block->next = assign_matmul;
4300
4301 var_1 = do_1->ext.iterator->var;
4302 var_2 = do_2->ext.iterator->var;
4303
4304 list[0] = var_1;
4305 cscalar = scalarized_expr (co->expr1, list, 1);
4306
4307 list[0] = var_2;
4308 ascalar = scalarized_expr (matrix_a, list, 1);
4309
4310 list[0] = var_2;
4311 list[1] = var_1;
4312 bscalar = scalarized_expr (matrix_b, list, 2);
4313
4314 break;
4315
4316 default:
4317 gcc_unreachable();
4318 }
4319
4320 /* Build the conjg call around the variables. Set the typespec manually
4321 because gfc_build_intrinsic_call sometimes gets this wrong. */
4322 if (conjg_a)
4323 {
4324 gfc_typespec ts;
4325 ts = matrix_a->ts;
4326 ascalar = gfc_build_intrinsic_call (ns, GFC_ISYM_CONJG, "conjg",
4327 matrix_a->where, 1, ascalar);
4328 ascalar->ts = ts;
4329 }
4330
4331 if (conjg_b)
4332 {
4333 gfc_typespec ts;
4334 ts = matrix_b->ts;
4335 bscalar = gfc_build_intrinsic_call (ns, GFC_ISYM_CONJG, "conjg",
4336 matrix_b->where, 1, bscalar);
4337 bscalar->ts = ts;
4338 }
4339 /* First loop comes after the zero assignment. */
4340 assign_zero->next = do_1;
4341
4342 /* Build the assignment expression in the loop. */
4343 assign_matmul->expr1 = gfc_copy_expr (cscalar);
4344
4345 mult = get_operand (op_times, ascalar, bscalar);
4346 assign_matmul->expr2 = get_operand (op_plus, cscalar, mult);
4347
4348 /* If we don't want to keep the original statement around in
4349 the else branch, we can free it. */
4350
4351 if (if_limit == NULL)
4352 gfc_free_statements(co);
4353 else
4354 co->next = NULL;
4355
4356 gfc_free_expr (zero);
4357 *walk_subtrees = 0;
4358 return 0;
4359 }
4360
4361 /* Change matmul function calls in the form of
4362
4363 c = matmul(a,b)
4364
4365 to the corresponding call to a BLAS routine, if applicable. */
4366
4367 static int
call_external_blas(gfc_code ** c,int * walk_subtrees ATTRIBUTE_UNUSED,void * data ATTRIBUTE_UNUSED)4368 call_external_blas (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
4369 void *data ATTRIBUTE_UNUSED)
4370 {
4371 gfc_code *co, *co_next;
4372 gfc_expr *expr1, *expr2;
4373 gfc_expr *matrix_a, *matrix_b;
4374 gfc_code *if_limit = NULL;
4375 gfc_actual_arglist *a, *b;
4376 bool conjg_a, conjg_b, transpose_a, transpose_b;
4377 gfc_code *call;
4378 const char *blas_name;
4379 const char *transa, *transb;
4380 gfc_expr *c1, *c2, *b1;
4381 gfc_actual_arglist *actual, *next;
4382 bt type;
4383 int kind;
4384 enum matrix_case m_case;
4385 bool realloc_c;
4386 gfc_code **next_code_point;
4387
4388 /* Many of the tests for inline matmul also apply here. */
4389
4390 co = *c;
4391
4392 if (co->op != EXEC_ASSIGN)
4393 return 0;
4394
4395 if (in_where || in_assoc_list)
4396 return 0;
4397
4398 /* The BLOCKS generated for the temporary variables and FORALL don't
4399 mix. */
4400 if (forall_level > 0)
4401 return 0;
4402
4403 /* For now don't do anything in OpenMP workshare, it confuses
4404 its translation, which expects only the allowed statements in there. */
4405
4406 if (in_omp_workshare || in_omp_atomic)
4407 return 0;
4408
4409 expr1 = co->expr1;
4410 expr2 = co->expr2;
4411 if (expr2->expr_type != EXPR_FUNCTION
4412 || expr2->value.function.isym == NULL
4413 || expr2->value.function.isym->id != GFC_ISYM_MATMUL)
4414 return 0;
4415
4416 type = expr2->ts.type;
4417 kind = expr2->ts.kind;
4418
4419 /* Guard against recursion. */
4420
4421 if (expr2->external_blas)
4422 return 0;
4423
4424 if (type != expr1->ts.type || kind != expr1->ts.kind)
4425 return 0;
4426
4427 if (type == BT_REAL)
4428 {
4429 if (kind == 4)
4430 blas_name = "sgemm";
4431 else if (kind == 8)
4432 blas_name = "dgemm";
4433 else
4434 return 0;
4435 }
4436 else if (type == BT_COMPLEX)
4437 {
4438 if (kind == 4)
4439 blas_name = "cgemm";
4440 else if (kind == 8)
4441 blas_name = "zgemm";
4442 else
4443 return 0;
4444 }
4445 else
4446 return 0;
4447
4448 a = expr2->value.function.actual;
4449 if (a->expr->rank != 2)
4450 return 0;
4451
4452 b = a->next;
4453 if (b->expr->rank != 2)
4454 return 0;
4455
4456 matrix_a = check_conjg_transpose_variable (a->expr, &conjg_a, &transpose_a);
4457 if (matrix_a == NULL)
4458 return 0;
4459
4460 if (transpose_a)
4461 {
4462 if (conjg_a)
4463 transa = "C";
4464 else
4465 transa = "T";
4466 }
4467 else
4468 transa = "N";
4469
4470 matrix_b = check_conjg_transpose_variable (b->expr, &conjg_b, &transpose_b);
4471 if (matrix_b == NULL)
4472 return 0;
4473
4474 if (transpose_b)
4475 {
4476 if (conjg_b)
4477 transb = "C";
4478 else
4479 transb = "T";
4480 }
4481 else
4482 transb = "N";
4483
4484 if (transpose_a)
4485 {
4486 if (transpose_b)
4487 m_case = A2TB2T;
4488 else
4489 m_case = A2TB2;
4490 }
4491 else
4492 {
4493 if (transpose_b)
4494 m_case = A2B2T;
4495 else
4496 m_case = A2B2;
4497 }
4498
4499 current_code = c;
4500 inserted_block = NULL;
4501 changed_statement = NULL;
4502
4503 expr2->external_blas = 1;
4504
4505 /* We do not handle data dependencies yet. */
4506 if (gfc_check_dependency (expr1, matrix_a, true)
4507 || gfc_check_dependency (expr1, matrix_b, true))
4508 return 0;
4509
4510 /* Generate the if statement and hang it into the tree. */
4511 if_limit = inline_limit_check (matrix_a, matrix_b, flag_blas_matmul_limit);
4512 co_next = co->next;
4513 (*current_code) = if_limit;
4514 co->next = NULL;
4515 if_limit->block->next = co;
4516
4517 call = XCNEW (gfc_code);
4518 call->loc = co->loc;
4519
4520 /* Bounds checking - a bit simpler than for inlining since we only
4521 have to take care of two-dimensional arrays here. */
4522
4523 realloc_c = flag_realloc_lhs && gfc_is_reallocatable_lhs (expr1);
4524 next_code_point = &(if_limit->block->block->next);
4525
4526 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
4527 {
4528 gfc_code *test;
4529 // gfc_expr *a2, *b1, *c1, *c2, *a1, *b2;
4530 gfc_expr *c1, *a1, *c2, *b2, *a2;
4531 switch (m_case)
4532 {
4533 case A2B2:
4534 b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
4535 a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2);
4536 test = runtime_error_ne (b1, a2, B_ERROR_1);
4537 *next_code_point = test;
4538 next_code_point = &test->next;
4539
4540 if (!realloc_c)
4541 {
4542 c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1);
4543 a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1);
4544 test = runtime_error_ne (c1, a1, C_ERROR_1);
4545 *next_code_point = test;
4546 next_code_point = &test->next;
4547
4548 c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2);
4549 b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2);
4550 test = runtime_error_ne (c2, b2, C_ERROR_2);
4551 *next_code_point = test;
4552 next_code_point = &test->next;
4553 }
4554 break;
4555
4556 case A2B2T:
4557
4558 b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2);
4559 a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2);
4560 /* matrix_b is transposed, hence dimension 1 for the error message. */
4561 test = runtime_error_ne (b2, a2, B_ERROR_1);
4562 *next_code_point = test;
4563 next_code_point = &test->next;
4564
4565 if (!realloc_c)
4566 {
4567 c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1);
4568 a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1);
4569 test = runtime_error_ne (c1, a1, C_ERROR_1);
4570 *next_code_point = test;
4571 next_code_point = &test->next;
4572
4573 c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2);
4574 b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
4575 test = runtime_error_ne (c2, b1, C_ERROR_2);
4576 *next_code_point = test;
4577 next_code_point = &test->next;
4578 }
4579 break;
4580
4581 case A2TB2:
4582
4583 b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
4584 a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1);
4585 test = runtime_error_ne (b1, a1, B_ERROR_1);
4586 *next_code_point = test;
4587 next_code_point = &test->next;
4588
4589 if (!realloc_c)
4590 {
4591 c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1);
4592 a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2);
4593 test = runtime_error_ne (c1, a2, C_ERROR_1);
4594 *next_code_point = test;
4595 next_code_point = &test->next;
4596
4597 c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2);
4598 b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2);
4599 test = runtime_error_ne (c2, b2, C_ERROR_2);
4600 *next_code_point = test;
4601 next_code_point = &test->next;
4602 }
4603 break;
4604
4605 case A2TB2T:
4606 b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2);
4607 a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1);
4608 test = runtime_error_ne (b2, a1, B_ERROR_1);
4609 *next_code_point = test;
4610 next_code_point = &test->next;
4611
4612 if (!realloc_c)
4613 {
4614 c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1);
4615 a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2);
4616 test = runtime_error_ne (c1, a2, C_ERROR_1);
4617 *next_code_point = test;
4618 next_code_point = &test->next;
4619
4620 c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2);
4621 b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
4622 test = runtime_error_ne (c2, b1, C_ERROR_2);
4623 *next_code_point = test;
4624 next_code_point = &test->next;
4625 }
4626 break;
4627
4628 default:
4629 gcc_unreachable ();
4630 }
4631 }
4632
4633 /* Handle the reallocation, if needed. */
4634
4635 if (realloc_c)
4636 {
4637 gfc_code *lhs_alloc;
4638
4639 lhs_alloc = matmul_lhs_realloc (expr1, matrix_a, matrix_b, m_case);
4640 *next_code_point = lhs_alloc;
4641 next_code_point = &lhs_alloc->next;
4642 }
4643
4644 *next_code_point = call;
4645 if_limit->next = co_next;
4646
4647 /* Set up the BLAS call. */
4648
4649 call->op = EXEC_CALL;
4650
4651 gfc_get_sym_tree (blas_name, current_ns, &(call->symtree), true);
4652 call->symtree->n.sym->attr.subroutine = 1;
4653 call->symtree->n.sym->attr.procedure = 1;
4654 call->symtree->n.sym->attr.flavor = FL_PROCEDURE;
4655 call->resolved_sym = call->symtree->n.sym;
4656 gfc_commit_symbol (call->resolved_sym);
4657
4658 /* Argument TRANSA. */
4659 next = gfc_get_actual_arglist ();
4660 next->expr = gfc_get_character_expr (gfc_default_character_kind, &co->loc,
4661 transa, 1);
4662
4663 call->ext.actual = next;
4664
4665 /* Argument TRANSB. */
4666 actual = next;
4667 next = gfc_get_actual_arglist ();
4668 next->expr = gfc_get_character_expr (gfc_default_character_kind, &co->loc,
4669 transb, 1);
4670 actual->next = next;
4671
4672 c1 = get_array_inq_function (GFC_ISYM_SIZE, gfc_copy_expr (a->expr), 1,
4673 gfc_integer_4_kind);
4674 c2 = get_array_inq_function (GFC_ISYM_SIZE, gfc_copy_expr (b->expr), 2,
4675 gfc_integer_4_kind);
4676
4677 b1 = get_array_inq_function (GFC_ISYM_SIZE, gfc_copy_expr (b->expr), 1,
4678 gfc_integer_4_kind);
4679
4680 /* Argument M. */
4681 actual = next;
4682 next = gfc_get_actual_arglist ();
4683 next->expr = c1;
4684 actual->next = next;
4685
4686 /* Argument N. */
4687 actual = next;
4688 next = gfc_get_actual_arglist ();
4689 next->expr = c2;
4690 actual->next = next;
4691
4692 /* Argument K. */
4693 actual = next;
4694 next = gfc_get_actual_arglist ();
4695 next->expr = b1;
4696 actual->next = next;
4697
4698 /* Argument ALPHA - set to one. */
4699 actual = next;
4700 next = gfc_get_actual_arglist ();
4701 next->expr = gfc_get_constant_expr (type, kind, &co->loc);
4702 if (type == BT_REAL)
4703 mpfr_set_ui (next->expr->value.real, 1, GFC_RND_MODE);
4704 else
4705 mpc_set_ui (next->expr->value.complex, 1, GFC_MPC_RND_MODE);
4706 actual->next = next;
4707
4708 /* Argument A. */
4709 actual = next;
4710 next = gfc_get_actual_arglist ();
4711 next->expr = gfc_copy_expr (matrix_a);
4712 actual->next = next;
4713
4714 /* Argument LDA. */
4715 actual = next;
4716 next = gfc_get_actual_arglist ();
4717 next->expr = get_array_inq_function (GFC_ISYM_SIZE, gfc_copy_expr (matrix_a),
4718 1, gfc_integer_4_kind);
4719 actual->next = next;
4720
4721 /* Argument B. */
4722 actual = next;
4723 next = gfc_get_actual_arglist ();
4724 next->expr = gfc_copy_expr (matrix_b);
4725 actual->next = next;
4726
4727 /* Argument LDB. */
4728 actual = next;
4729 next = gfc_get_actual_arglist ();
4730 next->expr = get_array_inq_function (GFC_ISYM_SIZE, gfc_copy_expr (matrix_b),
4731 1, gfc_integer_4_kind);
4732 actual->next = next;
4733
4734 /* Argument BETA - set to zero. */
4735 actual = next;
4736 next = gfc_get_actual_arglist ();
4737 next->expr = gfc_get_constant_expr (type, kind, &co->loc);
4738 if (type == BT_REAL)
4739 mpfr_set_ui (next->expr->value.real, 0, GFC_RND_MODE);
4740 else
4741 mpc_set_ui (next->expr->value.complex, 0, GFC_MPC_RND_MODE);
4742 actual->next = next;
4743
4744 /* Argument C. */
4745
4746 actual = next;
4747 next = gfc_get_actual_arglist ();
4748 next->expr = gfc_copy_expr (expr1);
4749 actual->next = next;
4750
4751 /* Argument LDC. */
4752 actual = next;
4753 next = gfc_get_actual_arglist ();
4754 next->expr = get_array_inq_function (GFC_ISYM_SIZE, gfc_copy_expr (expr1),
4755 1, gfc_integer_4_kind);
4756 actual->next = next;
4757
4758 return 0;
4759 }
4760
4761
4762 /* Code for index interchange for loops which are grouped together in DO
4763 CONCURRENT or FORALL statements. This is currently only applied if the
4764 iterations are grouped together in a single statement.
4765
4766 For this transformation, it is assumed that memory access in strides is
4767 expensive, and that loops which access later indices (which access memory
4768 in bigger strides) should be moved to the first loops.
4769
4770 For this, a loop over all the statements is executed, counting the times
4771 that the loop iteration values are accessed in each index. The loop
4772 indices are then sorted to minimize access to later indices from inner
4773 loops. */
4774
4775 /* Type for holding index information. */
4776
4777 typedef struct {
4778 gfc_symbol *sym;
4779 gfc_forall_iterator *fa;
4780 int num;
4781 int n[GFC_MAX_DIMENSIONS];
4782 } ind_type;
4783
4784 /* Callback function to determine if an expression is the
4785 corresponding variable. */
4786
4787 static int
has_var(gfc_expr ** e,int * walk_subtrees ATTRIBUTE_UNUSED,void * data)4788 has_var (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, void *data)
4789 {
4790 gfc_expr *expr = *e;
4791 gfc_symbol *sym;
4792
4793 if (expr->expr_type != EXPR_VARIABLE)
4794 return 0;
4795
4796 sym = (gfc_symbol *) data;
4797 return sym == expr->symtree->n.sym;
4798 }
4799
4800 /* Callback function to calculate the cost of a certain index. */
4801
4802 static int
index_cost(gfc_expr ** e,int * walk_subtrees ATTRIBUTE_UNUSED,void * data)4803 index_cost (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
4804 void *data)
4805 {
4806 ind_type *ind;
4807 gfc_expr *expr;
4808 gfc_array_ref *ar;
4809 gfc_ref *ref;
4810 int i,j;
4811
4812 expr = *e;
4813 if (expr->expr_type != EXPR_VARIABLE)
4814 return 0;
4815
4816 ar = NULL;
4817 for (ref = expr->ref; ref; ref = ref->next)
4818 {
4819 if (ref->type == REF_ARRAY)
4820 {
4821 ar = &ref->u.ar;
4822 break;
4823 }
4824 }
4825 if (ar == NULL || ar->type != AR_ELEMENT)
4826 return 0;
4827
4828 ind = (ind_type *) data;
4829 for (i = 0; i < ar->dimen; i++)
4830 {
4831 for (j=0; ind[j].sym != NULL; j++)
4832 {
4833 if (gfc_expr_walker (&ar->start[i], has_var, (void *) (ind[j].sym)))
4834 ind[j].n[i]++;
4835 }
4836 }
4837 return 0;
4838 }
4839
4840 /* Callback function for qsort, to sort the loop indices. */
4841
4842 static int
loop_comp(const void * e1,const void * e2)4843 loop_comp (const void *e1, const void *e2)
4844 {
4845 const ind_type *i1 = (const ind_type *) e1;
4846 const ind_type *i2 = (const ind_type *) e2;
4847 int i;
4848
4849 for (i=GFC_MAX_DIMENSIONS-1; i >= 0; i--)
4850 {
4851 if (i1->n[i] != i2->n[i])
4852 return i1->n[i] - i2->n[i];
4853 }
4854 /* All other things being equal, let's not change the ordering. */
4855 return i2->num - i1->num;
4856 }
4857
4858 /* Main function to do the index interchange. */
4859
4860 static int
index_interchange(gfc_code ** c,int * walk_subtrees ATTRIBUTE_UNUSED,void * data ATTRIBUTE_UNUSED)4861 index_interchange (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
4862 void *data ATTRIBUTE_UNUSED)
4863 {
4864 gfc_code *co;
4865 co = *c;
4866 int n_iter;
4867 gfc_forall_iterator *fa;
4868 ind_type *ind;
4869 int i, j;
4870
4871 if (co->op != EXEC_FORALL && co->op != EXEC_DO_CONCURRENT)
4872 return 0;
4873
4874 n_iter = 0;
4875 for (fa = co->ext.forall_iterator; fa; fa = fa->next)
4876 n_iter ++;
4877
4878 /* Nothing to reorder. */
4879 if (n_iter < 2)
4880 return 0;
4881
4882 ind = XALLOCAVEC (ind_type, n_iter + 1);
4883
4884 i = 0;
4885 for (fa = co->ext.forall_iterator; fa; fa = fa->next)
4886 {
4887 ind[i].sym = fa->var->symtree->n.sym;
4888 ind[i].fa = fa;
4889 for (j=0; j<GFC_MAX_DIMENSIONS; j++)
4890 ind[i].n[j] = 0;
4891 ind[i].num = i;
4892 i++;
4893 }
4894 ind[n_iter].sym = NULL;
4895 ind[n_iter].fa = NULL;
4896
4897 gfc_code_walker (c, gfc_dummy_code_callback, index_cost, (void *) ind);
4898 qsort ((void *) ind, n_iter, sizeof (ind_type), loop_comp);
4899
4900 /* Do the actual index interchange. */
4901 co->ext.forall_iterator = fa = ind[0].fa;
4902 for (i=1; i<n_iter; i++)
4903 {
4904 fa->next = ind[i].fa;
4905 fa = fa->next;
4906 }
4907 fa->next = NULL;
4908
4909 if (flag_warn_frontend_loop_interchange)
4910 {
4911 for (i=1; i<n_iter; i++)
4912 {
4913 if (ind[i-1].num > ind[i].num)
4914 {
4915 gfc_warning (OPT_Wfrontend_loop_interchange,
4916 "Interchanging loops at %L", &co->loc);
4917 break;
4918 }
4919 }
4920 }
4921
4922 return 0;
4923 }
4924
4925 #define WALK_SUBEXPR(NODE) \
4926 do \
4927 { \
4928 result = gfc_expr_walker (&(NODE), exprfn, data); \
4929 if (result) \
4930 return result; \
4931 } \
4932 while (0)
4933 #define WALK_SUBEXPR_TAIL(NODE) e = &(NODE); continue
4934
4935 /* Walk expression *E, calling EXPRFN on each expression in it. */
4936
4937 int
gfc_expr_walker(gfc_expr ** e,walk_expr_fn_t exprfn,void * data)4938 gfc_expr_walker (gfc_expr **e, walk_expr_fn_t exprfn, void *data)
4939 {
4940 while (*e)
4941 {
4942 int walk_subtrees = 1;
4943 gfc_actual_arglist *a;
4944 gfc_ref *r;
4945 gfc_constructor *c;
4946
4947 int result = exprfn (e, &walk_subtrees, data);
4948 if (result)
4949 return result;
4950 if (walk_subtrees)
4951 switch ((*e)->expr_type)
4952 {
4953 case EXPR_OP:
4954 WALK_SUBEXPR ((*e)->value.op.op1);
4955 WALK_SUBEXPR_TAIL ((*e)->value.op.op2);
4956 break;
4957 case EXPR_FUNCTION:
4958 for (a = (*e)->value.function.actual; a; a = a->next)
4959 WALK_SUBEXPR (a->expr);
4960 break;
4961 case EXPR_COMPCALL:
4962 case EXPR_PPC:
4963 WALK_SUBEXPR ((*e)->value.compcall.base_object);
4964 for (a = (*e)->value.compcall.actual; a; a = a->next)
4965 WALK_SUBEXPR (a->expr);
4966 break;
4967
4968 case EXPR_STRUCTURE:
4969 case EXPR_ARRAY:
4970 for (c = gfc_constructor_first ((*e)->value.constructor); c;
4971 c = gfc_constructor_next (c))
4972 {
4973 if (c->iterator == NULL)
4974 WALK_SUBEXPR (c->expr);
4975 else
4976 {
4977 iterator_level ++;
4978 WALK_SUBEXPR (c->expr);
4979 iterator_level --;
4980 WALK_SUBEXPR (c->iterator->var);
4981 WALK_SUBEXPR (c->iterator->start);
4982 WALK_SUBEXPR (c->iterator->end);
4983 WALK_SUBEXPR (c->iterator->step);
4984 }
4985 }
4986
4987 if ((*e)->expr_type != EXPR_ARRAY)
4988 break;
4989
4990 /* Fall through to the variable case in order to walk the
4991 reference. */
4992 gcc_fallthrough ();
4993
4994 case EXPR_SUBSTRING:
4995 case EXPR_VARIABLE:
4996 for (r = (*e)->ref; r; r = r->next)
4997 {
4998 gfc_array_ref *ar;
4999 int i;
5000
5001 switch (r->type)
5002 {
5003 case REF_ARRAY:
5004 ar = &r->u.ar;
5005 if (ar->type == AR_SECTION || ar->type == AR_ELEMENT)
5006 {
5007 for (i=0; i< ar->dimen; i++)
5008 {
5009 WALK_SUBEXPR (ar->start[i]);
5010 WALK_SUBEXPR (ar->end[i]);
5011 WALK_SUBEXPR (ar->stride[i]);
5012 }
5013 }
5014
5015 break;
5016
5017 case REF_SUBSTRING:
5018 WALK_SUBEXPR (r->u.ss.start);
5019 WALK_SUBEXPR (r->u.ss.end);
5020 break;
5021
5022 case REF_COMPONENT:
5023 case REF_INQUIRY:
5024 break;
5025 }
5026 }
5027
5028 default:
5029 break;
5030 }
5031 return 0;
5032 }
5033 return 0;
5034 }
5035
5036 #define WALK_SUBCODE(NODE) \
5037 do \
5038 { \
5039 result = gfc_code_walker (&(NODE), codefn, exprfn, data); \
5040 if (result) \
5041 return result; \
5042 } \
5043 while (0)
5044
5045 /* Walk code *C, calling CODEFN on each gfc_code node in it and calling EXPRFN
5046 on each expression in it. If any of the hooks returns non-zero, that
5047 value is immediately returned. If the hook sets *WALK_SUBTREES to 0,
5048 no subcodes or subexpressions are traversed. */
5049
5050 int
gfc_code_walker(gfc_code ** c,walk_code_fn_t codefn,walk_expr_fn_t exprfn,void * data)5051 gfc_code_walker (gfc_code **c, walk_code_fn_t codefn, walk_expr_fn_t exprfn,
5052 void *data)
5053 {
5054 for (; *c; c = &(*c)->next)
5055 {
5056 int walk_subtrees = 1;
5057 int result = codefn (c, &walk_subtrees, data);
5058 if (result)
5059 return result;
5060
5061 if (walk_subtrees)
5062 {
5063 gfc_code *b;
5064 gfc_actual_arglist *a;
5065 gfc_code *co;
5066 gfc_association_list *alist;
5067 bool saved_in_omp_workshare;
5068 bool saved_in_omp_atomic;
5069 bool saved_in_where;
5070
5071 /* There might be statement insertions before the current code,
5072 which must not affect the expression walker. */
5073
5074 co = *c;
5075 saved_in_omp_workshare = in_omp_workshare;
5076 saved_in_omp_atomic = in_omp_atomic;
5077 saved_in_where = in_where;
5078
5079 switch (co->op)
5080 {
5081
5082 case EXEC_BLOCK:
5083 WALK_SUBCODE (co->ext.block.ns->code);
5084 if (co->ext.block.assoc)
5085 {
5086 bool saved_in_assoc_list = in_assoc_list;
5087
5088 in_assoc_list = true;
5089 for (alist = co->ext.block.assoc; alist; alist = alist->next)
5090 WALK_SUBEXPR (alist->target);
5091
5092 in_assoc_list = saved_in_assoc_list;
5093 }
5094
5095 break;
5096
5097 case EXEC_DO:
5098 doloop_level ++;
5099 WALK_SUBEXPR (co->ext.iterator->var);
5100 WALK_SUBEXPR (co->ext.iterator->start);
5101 WALK_SUBEXPR (co->ext.iterator->end);
5102 WALK_SUBEXPR (co->ext.iterator->step);
5103 break;
5104
5105 case EXEC_IF:
5106 if_level ++;
5107 break;
5108
5109 case EXEC_WHERE:
5110 in_where = true;
5111 break;
5112
5113 case EXEC_CALL:
5114 case EXEC_ASSIGN_CALL:
5115 for (a = co->ext.actual; a; a = a->next)
5116 WALK_SUBEXPR (a->expr);
5117 break;
5118
5119 case EXEC_CALL_PPC:
5120 WALK_SUBEXPR (co->expr1);
5121 for (a = co->ext.actual; a; a = a->next)
5122 WALK_SUBEXPR (a->expr);
5123 break;
5124
5125 case EXEC_SELECT:
5126 WALK_SUBEXPR (co->expr1);
5127 select_level ++;
5128 for (b = co->block; b; b = b->block)
5129 {
5130 gfc_case *cp;
5131 for (cp = b->ext.block.case_list; cp; cp = cp->next)
5132 {
5133 WALK_SUBEXPR (cp->low);
5134 WALK_SUBEXPR (cp->high);
5135 }
5136 WALK_SUBCODE (b->next);
5137 }
5138 continue;
5139
5140 case EXEC_ALLOCATE:
5141 case EXEC_DEALLOCATE:
5142 {
5143 gfc_alloc *a;
5144 for (a = co->ext.alloc.list; a; a = a->next)
5145 WALK_SUBEXPR (a->expr);
5146 break;
5147 }
5148
5149 case EXEC_FORALL:
5150 case EXEC_DO_CONCURRENT:
5151 {
5152 gfc_forall_iterator *fa;
5153 for (fa = co->ext.forall_iterator; fa; fa = fa->next)
5154 {
5155 WALK_SUBEXPR (fa->var);
5156 WALK_SUBEXPR (fa->start);
5157 WALK_SUBEXPR (fa->end);
5158 WALK_SUBEXPR (fa->stride);
5159 }
5160 if (co->op == EXEC_FORALL)
5161 forall_level ++;
5162 break;
5163 }
5164
5165 case EXEC_OPEN:
5166 WALK_SUBEXPR (co->ext.open->unit);
5167 WALK_SUBEXPR (co->ext.open->file);
5168 WALK_SUBEXPR (co->ext.open->status);
5169 WALK_SUBEXPR (co->ext.open->access);
5170 WALK_SUBEXPR (co->ext.open->form);
5171 WALK_SUBEXPR (co->ext.open->recl);
5172 WALK_SUBEXPR (co->ext.open->blank);
5173 WALK_SUBEXPR (co->ext.open->position);
5174 WALK_SUBEXPR (co->ext.open->action);
5175 WALK_SUBEXPR (co->ext.open->delim);
5176 WALK_SUBEXPR (co->ext.open->pad);
5177 WALK_SUBEXPR (co->ext.open->iostat);
5178 WALK_SUBEXPR (co->ext.open->iomsg);
5179 WALK_SUBEXPR (co->ext.open->convert);
5180 WALK_SUBEXPR (co->ext.open->decimal);
5181 WALK_SUBEXPR (co->ext.open->encoding);
5182 WALK_SUBEXPR (co->ext.open->round);
5183 WALK_SUBEXPR (co->ext.open->sign);
5184 WALK_SUBEXPR (co->ext.open->asynchronous);
5185 WALK_SUBEXPR (co->ext.open->id);
5186 WALK_SUBEXPR (co->ext.open->newunit);
5187 WALK_SUBEXPR (co->ext.open->share);
5188 WALK_SUBEXPR (co->ext.open->cc);
5189 break;
5190
5191 case EXEC_CLOSE:
5192 WALK_SUBEXPR (co->ext.close->unit);
5193 WALK_SUBEXPR (co->ext.close->status);
5194 WALK_SUBEXPR (co->ext.close->iostat);
5195 WALK_SUBEXPR (co->ext.close->iomsg);
5196 break;
5197
5198 case EXEC_BACKSPACE:
5199 case EXEC_ENDFILE:
5200 case EXEC_REWIND:
5201 case EXEC_FLUSH:
5202 WALK_SUBEXPR (co->ext.filepos->unit);
5203 WALK_SUBEXPR (co->ext.filepos->iostat);
5204 WALK_SUBEXPR (co->ext.filepos->iomsg);
5205 break;
5206
5207 case EXEC_INQUIRE:
5208 WALK_SUBEXPR (co->ext.inquire->unit);
5209 WALK_SUBEXPR (co->ext.inquire->file);
5210 WALK_SUBEXPR (co->ext.inquire->iomsg);
5211 WALK_SUBEXPR (co->ext.inquire->iostat);
5212 WALK_SUBEXPR (co->ext.inquire->exist);
5213 WALK_SUBEXPR (co->ext.inquire->opened);
5214 WALK_SUBEXPR (co->ext.inquire->number);
5215 WALK_SUBEXPR (co->ext.inquire->named);
5216 WALK_SUBEXPR (co->ext.inquire->name);
5217 WALK_SUBEXPR (co->ext.inquire->access);
5218 WALK_SUBEXPR (co->ext.inquire->sequential);
5219 WALK_SUBEXPR (co->ext.inquire->direct);
5220 WALK_SUBEXPR (co->ext.inquire->form);
5221 WALK_SUBEXPR (co->ext.inquire->formatted);
5222 WALK_SUBEXPR (co->ext.inquire->unformatted);
5223 WALK_SUBEXPR (co->ext.inquire->recl);
5224 WALK_SUBEXPR (co->ext.inquire->nextrec);
5225 WALK_SUBEXPR (co->ext.inquire->blank);
5226 WALK_SUBEXPR (co->ext.inquire->position);
5227 WALK_SUBEXPR (co->ext.inquire->action);
5228 WALK_SUBEXPR (co->ext.inquire->read);
5229 WALK_SUBEXPR (co->ext.inquire->write);
5230 WALK_SUBEXPR (co->ext.inquire->readwrite);
5231 WALK_SUBEXPR (co->ext.inquire->delim);
5232 WALK_SUBEXPR (co->ext.inquire->encoding);
5233 WALK_SUBEXPR (co->ext.inquire->pad);
5234 WALK_SUBEXPR (co->ext.inquire->iolength);
5235 WALK_SUBEXPR (co->ext.inquire->convert);
5236 WALK_SUBEXPR (co->ext.inquire->strm_pos);
5237 WALK_SUBEXPR (co->ext.inquire->asynchronous);
5238 WALK_SUBEXPR (co->ext.inquire->decimal);
5239 WALK_SUBEXPR (co->ext.inquire->pending);
5240 WALK_SUBEXPR (co->ext.inquire->id);
5241 WALK_SUBEXPR (co->ext.inquire->sign);
5242 WALK_SUBEXPR (co->ext.inquire->size);
5243 WALK_SUBEXPR (co->ext.inquire->round);
5244 break;
5245
5246 case EXEC_WAIT:
5247 WALK_SUBEXPR (co->ext.wait->unit);
5248 WALK_SUBEXPR (co->ext.wait->iostat);
5249 WALK_SUBEXPR (co->ext.wait->iomsg);
5250 WALK_SUBEXPR (co->ext.wait->id);
5251 break;
5252
5253 case EXEC_READ:
5254 case EXEC_WRITE:
5255 WALK_SUBEXPR (co->ext.dt->io_unit);
5256 WALK_SUBEXPR (co->ext.dt->format_expr);
5257 WALK_SUBEXPR (co->ext.dt->rec);
5258 WALK_SUBEXPR (co->ext.dt->advance);
5259 WALK_SUBEXPR (co->ext.dt->iostat);
5260 WALK_SUBEXPR (co->ext.dt->size);
5261 WALK_SUBEXPR (co->ext.dt->iomsg);
5262 WALK_SUBEXPR (co->ext.dt->id);
5263 WALK_SUBEXPR (co->ext.dt->pos);
5264 WALK_SUBEXPR (co->ext.dt->asynchronous);
5265 WALK_SUBEXPR (co->ext.dt->blank);
5266 WALK_SUBEXPR (co->ext.dt->decimal);
5267 WALK_SUBEXPR (co->ext.dt->delim);
5268 WALK_SUBEXPR (co->ext.dt->pad);
5269 WALK_SUBEXPR (co->ext.dt->round);
5270 WALK_SUBEXPR (co->ext.dt->sign);
5271 WALK_SUBEXPR (co->ext.dt->extra_comma);
5272 break;
5273
5274 case EXEC_OACC_ATOMIC:
5275 case EXEC_OMP_ATOMIC:
5276 in_omp_atomic = true;
5277 break;
5278
5279 case EXEC_OMP_PARALLEL:
5280 case EXEC_OMP_PARALLEL_DO:
5281 case EXEC_OMP_PARALLEL_DO_SIMD:
5282 case EXEC_OMP_PARALLEL_SECTIONS:
5283
5284 in_omp_workshare = false;
5285
5286 /* This goto serves as a shortcut to avoid code
5287 duplication or a larger if or switch statement. */
5288 goto check_omp_clauses;
5289
5290 case EXEC_OMP_WORKSHARE:
5291 case EXEC_OMP_PARALLEL_WORKSHARE:
5292
5293 in_omp_workshare = true;
5294
5295 /* Fall through */
5296
5297 case EXEC_OMP_CRITICAL:
5298 case EXEC_OMP_DISTRIBUTE:
5299 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
5300 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
5301 case EXEC_OMP_DISTRIBUTE_SIMD:
5302 case EXEC_OMP_DO:
5303 case EXEC_OMP_DO_SIMD:
5304 case EXEC_OMP_ORDERED:
5305 case EXEC_OMP_SECTIONS:
5306 case EXEC_OMP_SINGLE:
5307 case EXEC_OMP_END_SINGLE:
5308 case EXEC_OMP_SIMD:
5309 case EXEC_OMP_TASKLOOP:
5310 case EXEC_OMP_TASKLOOP_SIMD:
5311 case EXEC_OMP_TARGET:
5312 case EXEC_OMP_TARGET_DATA:
5313 case EXEC_OMP_TARGET_ENTER_DATA:
5314 case EXEC_OMP_TARGET_EXIT_DATA:
5315 case EXEC_OMP_TARGET_PARALLEL:
5316 case EXEC_OMP_TARGET_PARALLEL_DO:
5317 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
5318 case EXEC_OMP_TARGET_SIMD:
5319 case EXEC_OMP_TARGET_TEAMS:
5320 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
5321 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
5322 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
5323 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
5324 case EXEC_OMP_TARGET_UPDATE:
5325 case EXEC_OMP_TASK:
5326 case EXEC_OMP_TEAMS:
5327 case EXEC_OMP_TEAMS_DISTRIBUTE:
5328 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
5329 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
5330 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
5331
5332 /* Come to this label only from the
5333 EXEC_OMP_PARALLEL_* cases above. */
5334
5335 check_omp_clauses:
5336
5337 if (co->ext.omp_clauses)
5338 {
5339 gfc_omp_namelist *n;
5340 static int list_types[]
5341 = { OMP_LIST_ALIGNED, OMP_LIST_LINEAR, OMP_LIST_DEPEND,
5342 OMP_LIST_MAP, OMP_LIST_TO, OMP_LIST_FROM };
5343 size_t idx;
5344 WALK_SUBEXPR (co->ext.omp_clauses->if_expr);
5345 WALK_SUBEXPR (co->ext.omp_clauses->final_expr);
5346 WALK_SUBEXPR (co->ext.omp_clauses->num_threads);
5347 WALK_SUBEXPR (co->ext.omp_clauses->chunk_size);
5348 WALK_SUBEXPR (co->ext.omp_clauses->safelen_expr);
5349 WALK_SUBEXPR (co->ext.omp_clauses->simdlen_expr);
5350 WALK_SUBEXPR (co->ext.omp_clauses->num_teams);
5351 WALK_SUBEXPR (co->ext.omp_clauses->device);
5352 WALK_SUBEXPR (co->ext.omp_clauses->thread_limit);
5353 WALK_SUBEXPR (co->ext.omp_clauses->dist_chunk_size);
5354 WALK_SUBEXPR (co->ext.omp_clauses->grainsize);
5355 WALK_SUBEXPR (co->ext.omp_clauses->hint);
5356 WALK_SUBEXPR (co->ext.omp_clauses->num_tasks);
5357 WALK_SUBEXPR (co->ext.omp_clauses->priority);
5358 for (idx = 0; idx < OMP_IF_LAST; idx++)
5359 WALK_SUBEXPR (co->ext.omp_clauses->if_exprs[idx]);
5360 for (idx = 0;
5361 idx < sizeof (list_types) / sizeof (list_types[0]);
5362 idx++)
5363 for (n = co->ext.omp_clauses->lists[list_types[idx]];
5364 n; n = n->next)
5365 WALK_SUBEXPR (n->expr);
5366 }
5367 break;
5368 default:
5369 break;
5370 }
5371
5372 WALK_SUBEXPR (co->expr1);
5373 WALK_SUBEXPR (co->expr2);
5374 WALK_SUBEXPR (co->expr3);
5375 WALK_SUBEXPR (co->expr4);
5376 for (b = co->block; b; b = b->block)
5377 {
5378 WALK_SUBEXPR (b->expr1);
5379 WALK_SUBEXPR (b->expr2);
5380 WALK_SUBCODE (b->next);
5381 }
5382
5383 if (co->op == EXEC_FORALL)
5384 forall_level --;
5385
5386 if (co->op == EXEC_DO)
5387 doloop_level --;
5388
5389 if (co->op == EXEC_IF)
5390 if_level --;
5391
5392 if (co->op == EXEC_SELECT)
5393 select_level --;
5394
5395 in_omp_workshare = saved_in_omp_workshare;
5396 in_omp_atomic = saved_in_omp_atomic;
5397 in_where = saved_in_where;
5398 }
5399 }
5400 return 0;
5401 }
5402
5403 /* As a post-resolution step, check that all global symbols which are
5404 not declared in the source file match in their call signatures.
5405 We do this by looping over the code (and expressions). The first call
5406 we happen to find is assumed to be canonical. */
5407
5408
5409 /* Common tests for argument checking for both functions and subroutines. */
5410
5411 static int
check_externals_procedure(gfc_symbol * sym,locus * loc,gfc_actual_arglist * actual)5412 check_externals_procedure (gfc_symbol *sym, locus *loc,
5413 gfc_actual_arglist *actual)
5414 {
5415 gfc_gsymbol *gsym;
5416 gfc_symbol *def_sym = NULL;
5417
5418 if (sym == NULL || sym->attr.is_bind_c)
5419 return 0;
5420
5421 if (sym->attr.proc != PROC_EXTERNAL && sym->attr.proc != PROC_UNKNOWN)
5422 return 0;
5423
5424 if (sym->attr.if_source == IFSRC_IFBODY || sym->attr.if_source == IFSRC_DECL)
5425 return 0;
5426
5427 gsym = gfc_find_gsymbol (gfc_gsym_root, sym->name);
5428 if (gsym == NULL)
5429 return 0;
5430
5431 if (gsym->ns)
5432 gfc_find_symbol (sym->name, gsym->ns, 0, &def_sym);
5433
5434 if (def_sym)
5435 {
5436 gfc_compare_actual_formal (&actual, def_sym->formal, 0, 0, 0, loc);
5437 return 0;
5438 }
5439
5440 /* First time we have seen this procedure called. Let's create an
5441 "interface" from the call and put it into a new namespace. */
5442 gfc_namespace *save_ns;
5443 gfc_symbol *new_sym;
5444
5445 gsym->where = *loc;
5446 save_ns = gfc_current_ns;
5447 gsym->ns = gfc_get_namespace (gfc_current_ns, 0);
5448 gsym->ns->proc_name = sym;
5449
5450 gfc_get_symbol (sym->name, gsym->ns, &new_sym);
5451 gcc_assert (new_sym);
5452 new_sym->attr = sym->attr;
5453 new_sym->attr.if_source = IFSRC_DECL;
5454 gfc_current_ns = gsym->ns;
5455
5456 gfc_get_formal_from_actual_arglist (new_sym, actual);
5457 gfc_current_ns = save_ns;
5458
5459 return 0;
5460
5461 }
5462
5463 /* Callback for calls of external routines. */
5464
5465 static int
check_externals_code(gfc_code ** c,int * walk_subtrees ATTRIBUTE_UNUSED,void * data ATTRIBUTE_UNUSED)5466 check_externals_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
5467 void *data ATTRIBUTE_UNUSED)
5468 {
5469 gfc_code *co = *c;
5470 gfc_symbol *sym;
5471 locus *loc;
5472 gfc_actual_arglist *actual;
5473
5474 if (co->op != EXEC_CALL)
5475 return 0;
5476
5477 sym = co->resolved_sym;
5478 loc = &co->loc;
5479 actual = co->ext.actual;
5480
5481 return check_externals_procedure (sym, loc, actual);
5482
5483 }
5484
5485 /* Callback for external functions. */
5486
5487 static int
check_externals_expr(gfc_expr ** ep,int * walk_subtrees ATTRIBUTE_UNUSED,void * data ATTRIBUTE_UNUSED)5488 check_externals_expr (gfc_expr **ep, int *walk_subtrees ATTRIBUTE_UNUSED,
5489 void *data ATTRIBUTE_UNUSED)
5490 {
5491 gfc_expr *e = *ep;
5492 gfc_symbol *sym;
5493 locus *loc;
5494 gfc_actual_arglist *actual;
5495
5496 if (e->expr_type != EXPR_FUNCTION)
5497 return 0;
5498
5499 sym = e->value.function.esym;
5500 if (sym == NULL)
5501 return 0;
5502
5503 loc = &e->where;
5504 actual = e->value.function.actual;
5505
5506 return check_externals_procedure (sym, loc, actual);
5507 }
5508
5509 /* Called routine. */
5510
5511 void
gfc_check_externals(gfc_namespace * ns)5512 gfc_check_externals (gfc_namespace *ns)
5513 {
5514
5515 gfc_clear_error ();
5516
5517 /* Turn errors into warnings if the user indicated this. */
5518
5519 if (!pedantic && flag_allow_argument_mismatch)
5520 gfc_errors_to_warnings (true);
5521
5522 gfc_code_walker (&ns->code, check_externals_code, check_externals_expr, NULL);
5523
5524 for (ns = ns->contained; ns; ns = ns->sibling)
5525 {
5526 if (ns->code == NULL || ns->code->op != EXEC_BLOCK)
5527 gfc_check_externals (ns);
5528 }
5529
5530 gfc_errors_to_warnings (false);
5531 }
5532
5533 /* Callback function. If there is a call to a subroutine which is
5534 neither pure nor implicit_pure, unset the implicit_pure flag for
5535 the caller and return -1. */
5536
5537 static int
implicit_pure_call(gfc_code ** c,int * walk_subtrees ATTRIBUTE_UNUSED,void * sym_data)5538 implicit_pure_call (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
5539 void *sym_data)
5540 {
5541 gfc_code *co = *c;
5542 gfc_symbol *caller_sym;
5543 symbol_attribute *a;
5544
5545 if (co->op != EXEC_CALL || co->resolved_sym == NULL)
5546 return 0;
5547
5548 a = &co->resolved_sym->attr;
5549 if (a->intrinsic || a->pure || a->implicit_pure)
5550 return 0;
5551
5552 caller_sym = (gfc_symbol *) sym_data;
5553 gfc_unset_implicit_pure (caller_sym);
5554 return 1;
5555 }
5556
5557 /* Callback function. If there is a call to a function which is
5558 neither pure nor implicit_pure, unset the implicit_pure flag for
5559 the caller and return 1. */
5560
5561 static int
implicit_pure_expr(gfc_expr ** e,int * walk ATTRIBUTE_UNUSED,void * sym_data)5562 implicit_pure_expr (gfc_expr **e, int *walk ATTRIBUTE_UNUSED, void *sym_data)
5563 {
5564 gfc_expr *expr = *e;
5565 gfc_symbol *caller_sym;
5566 gfc_symbol *sym;
5567 symbol_attribute *a;
5568
5569 if (expr->expr_type != EXPR_FUNCTION || expr->value.function.isym)
5570 return 0;
5571
5572 sym = expr->symtree->n.sym;
5573 a = &sym->attr;
5574 if (a->pure || a->implicit_pure)
5575 return 0;
5576
5577 caller_sym = (gfc_symbol *) sym_data;
5578 gfc_unset_implicit_pure (caller_sym);
5579 return 1;
5580 }
5581
5582 /* Go through all procedures in the namespace and unset the
5583 implicit_pure attribute for any procedure that calls something not
5584 pure or implicit pure. */
5585
5586 bool
gfc_fix_implicit_pure(gfc_namespace * ns)5587 gfc_fix_implicit_pure (gfc_namespace *ns)
5588 {
5589 bool changed = false;
5590 gfc_symbol *proc = ns->proc_name;
5591
5592 if (proc && proc->attr.flavor == FL_PROCEDURE && proc->attr.implicit_pure
5593 && ns->code
5594 && gfc_code_walker (&ns->code, implicit_pure_call, implicit_pure_expr,
5595 (void *) ns->proc_name))
5596 changed = true;
5597
5598 for (ns = ns->contained; ns; ns = ns->sibling)
5599 {
5600 if (gfc_fix_implicit_pure (ns))
5601 changed = true;
5602 }
5603
5604 return changed;
5605 }
5606