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