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