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 314167 : gfc_run_passes (gfc_namespace *ns)
147 : {
148 :
149 : /* Warn about dubious DO loops where the index might
150 : change. */
151 :
152 314167 : doloop_level = 0;
153 314167 : if_level = 0;
154 314167 : select_level = 0;
155 314167 : doloop_warn (ns);
156 314167 : doloop_list.release ();
157 314167 : int w, e;
158 :
159 : #ifdef CHECKING_P
160 314167 : check_locus (ns);
161 : #endif
162 :
163 314167 : gfc_get_errors (&w, &e);
164 314167 : if (e > 0)
165 6000 : return;
166 :
167 308167 : if (flag_frontend_optimize || flag_frontend_loop_interchange)
168 260011 : optimize_namespace (ns);
169 :
170 308167 : if (flag_frontend_optimize)
171 : {
172 259995 : optimize_reduction (ns);
173 259995 : if (flag_dump_fortran_optimized)
174 0 : gfc_dump_parse_tree (ns, stdout);
175 :
176 259995 : expr_array.release ();
177 : }
178 :
179 308167 : if (flag_realloc_lhs)
180 308030 : 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 1245220 : check_locus_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
190 : void *data ATTRIBUTE_UNUSED)
191 : {
192 1245220 : current_code = c;
193 1245220 : if (c
194 1245220 : && *c
195 1245220 : && (((*c)->loc.nextc == NULL)
196 1245220 : || ((*c)->loc.nextc == (gfc_char_t *) -1
197 1417 : && (*c)->loc.u.location == UNKNOWN_LOCATION)
198 1245220 : || ((*c)->loc.nextc != (gfc_char_t *) -1
199 1243803 : && ((*c)->loc.u.lb == NULL))))
200 :
201 0 : gfc_warning_internal (0, "Inconsistent internal state: "
202 : "No location in statement");
203 :
204 1245220 : return 0;
205 : }
206 :
207 :
208 : /* Callback function: Warn if there is no location information in an
209 : expression. */
210 :
211 : static int
212 3803950 : check_locus_expr (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
213 : void *data ATTRIBUTE_UNUSED)
214 : {
215 :
216 3803950 : if (e
217 3803950 : && *e
218 3803950 : && (((*e)->where.nextc == NULL)
219 3803950 : || ((*e)->where.nextc == (gfc_char_t *) -1
220 391128 : && (*e)->where.u.location == UNKNOWN_LOCATION)
221 3803950 : || ((*e)->where.nextc != (gfc_char_t *) -1
222 3412822 : && ((*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 3803950 : return 0;
227 : }
228 :
229 : /* Run check for missing location information. */
230 :
231 : static void
232 363531 : check_locus (gfc_namespace *ns)
233 : {
234 363531 : gfc_code_walker (&ns->code, check_locus_code, check_locus_expr, NULL);
235 :
236 413937 : for (ns = ns->contained; ns; ns = ns->sibling)
237 : {
238 50406 : if (ns->code == NULL || ns->code->op != EXEC_BLOCK)
239 49364 : check_locus (ns);
240 : }
241 363531 : }
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 1230311 : realloc_string_callback (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
259 : void *data ATTRIBUTE_UNUSED)
260 : {
261 1230311 : gfc_expr *expr1, *expr2;
262 1230311 : gfc_code *co = *c;
263 1230311 : gfc_expr *n;
264 1230311 : gfc_ref *ref;
265 1230311 : bool found_substr;
266 :
267 1230311 : if (co->op != EXEC_ASSIGN)
268 : return 0;
269 :
270 320164 : expr1 = co->expr1;
271 320164 : if (expr1->ts.type != BT_CHARACTER
272 29763 : || !gfc_expr_attr(expr1).allocatable
273 323277 : || !expr1->ts.deferred)
274 317693 : return 0;
275 :
276 7315 : if (is_fe_temp (expr1))
277 : return 0;
278 :
279 2373 : expr2 = gfc_discard_nops (co->expr2);
280 :
281 2373 : 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 1863 : else if (expr2->expr_type != EXPR_ARRAY
296 1441 : && (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 1037554 : optimize_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
323 : void *data ATTRIBUTE_UNUSED)
324 : {
325 :
326 1037554 : gfc_exec_op op;
327 :
328 1037554 : op = (*c)->op;
329 :
330 1037554 : if (op == EXEC_CALL || op == EXEC_COMPCALL || op == EXEC_ASSIGN_CALL
331 1037554 : || op == EXEC_CALL_PPC)
332 73204 : count_arglist = 1;
333 : else
334 964350 : count_arglist = 0;
335 :
336 1037554 : current_code = c;
337 1037554 : inserted_block = NULL;
338 1037554 : changed_statement = NULL;
339 :
340 1037554 : if (op == EXEC_ASSIGN)
341 270306 : optimize_assignment (*c);
342 1037554 : 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 3184763 : optimize_expr (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
350 : void *data ATTRIBUTE_UNUSED)
351 : {
352 3184763 : bool function_expr;
353 :
354 3184763 : if ((*e)->expr_type == EXPR_FUNCTION)
355 : {
356 249260 : count_arglist ++;
357 249260 : function_expr = true;
358 : }
359 : else
360 : function_expr = false;
361 :
362 3184763 : if (optimize_trim (*e))
363 366 : gfc_simplify_expr (*e, 0);
364 :
365 3184763 : if (optimize_lexical_comparison (*e))
366 4 : gfc_simplify_expr (*e, 0);
367 :
368 3184763 : if ((*e)->expr_type == EXPR_OP && optimize_op (*e))
369 1211 : gfc_simplify_expr (*e, 0);
370 :
371 3184763 : if (function_expr)
372 249260 : count_arglist --;
373 :
374 3184763 : 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 3228237 : callback_reduction (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
434 : void *data ATTRIBUTE_UNUSED)
435 : {
436 3228237 : gfc_expr *fn, *arg;
437 3228237 : gfc_intrinsic_op op;
438 3228237 : gfc_isym_id id;
439 3228237 : gfc_actual_arglist *a;
440 3228237 : gfc_actual_arglist *dim;
441 3228237 : gfc_constructor *c;
442 3228237 : gfc_expr *res, *new_expr;
443 3228237 : gfc_actual_arglist *mask;
444 :
445 3228237 : fn = *e;
446 :
447 3228237 : if (fn->rank != 0 || fn->expr_type != EXPR_FUNCTION
448 215273 : || fn->value.function.isym == NULL)
449 : return 0;
450 :
451 175139 : id = fn->value.function.isym->id;
452 :
453 175139 : if (id != GFC_ISYM_SUM && id != GFC_ISYM_PRODUCT
454 173647 : && id != GFC_ISYM_ANY && id != GFC_ISYM_ALL)
455 : return 0;
456 :
457 35784 : a = fn->value.function.actual;
458 :
459 : /* Don't handle MASK or DIM. */
460 :
461 35784 : dim = a->next;
462 :
463 35784 : if (dim->expr != NULL)
464 : return 0;
465 :
466 35657 : if (id == GFC_ISYM_SUM || id == GFC_ISYM_PRODUCT)
467 : {
468 1366 : mask = dim->next;
469 1366 : if ( mask->expr != NULL)
470 : return 0;
471 : }
472 :
473 35533 : arg = a->expr;
474 :
475 35533 : 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 3159214 : cfe_register_funcs (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
540 : void *data ATTRIBUTE_UNUSED)
541 : {
542 :
543 3159214 : if ((*e)->expr_type != EXPR_FUNCTION)
544 : return 0;
545 :
546 : /* We don't do character functions with unknown charlens. */
547 248623 : if ((*e)->ts.type == BT_CHARACTER
548 9765 : && ((*e)->ts.u.cl == NULL || (*e)->ts.u.cl->length == NULL
549 6854 : || (*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 243929 : 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 242818 : 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 242439 : 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 242422 : if ((*e)->value.function.esym)
575 : {
576 : /* Don't create an array temporary for elemental functions. */
577 38431 : 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 37613 : if (!flag_aggressive_function_elimination
583 37597 : && !(*e)->value.function.esym->attr.pure
584 23217 : && !(*e)->value.function.esym->attr.implicit_pure)
585 : return 0;
586 : }
587 :
588 221992 : 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 201347 : if ((*e)->value.function.isym->id == GFC_ISYM_CONVERSION
593 173702 : || (*e)->value.function.isym->id == GFC_ISYM_TRANSFER
594 371769 : || gfc_inline_intrinsic_function_p (*e))
595 42348 : 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 158999 : if ((*e)->value.function.isym->elemental && (*e)->rank > 0)
601 : return 0;
602 :
603 154949 : if (!(*e)->value.function.isym->pure)
604 : return 0;
605 : }
606 :
607 168972 : expr_array.safe_push (e);
608 168972 : 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 3716 : is_fe_temp (gfc_expr *e)
616 : {
617 3716 : if (e->expr_type != EXPR_VARIABLE)
618 : return false;
619 :
620 2471 : 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 1917 : insert_block ()
680 : {
681 1917 : gfc_namespace *ns;
682 :
683 : /* If the block hasn't already been created, do so. */
684 1917 : if (inserted_block == NULL)
685 : {
686 1634 : inserted_block = XCNEW (gfc_code);
687 1634 : inserted_block->op = EXEC_BLOCK;
688 1634 : inserted_block->loc = (*current_code)->loc;
689 1634 : ns = gfc_build_block_ns (current_ns);
690 1634 : inserted_block->ext.block.ns = ns;
691 1634 : inserted_block->ext.block.assoc = NULL;
692 :
693 1634 : 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 1634 : if ((*current_code)->here)
699 : {
700 6 : inserted_block->here = (*current_code)->here;
701 6 : (*current_code)->here = NULL;
702 : }
703 :
704 1634 : inserted_block->next = (*current_code)->next;
705 1634 : changed_statement = &(inserted_block->ext.block.ns->code);
706 1634 : (*current_code)->next = NULL;
707 : /* Insert the BLOCK at the right position. */
708 1634 : *current_code = inserted_block;
709 1634 : ns->parent = current_ns;
710 : }
711 : else
712 283 : ns = inserted_block->ext.block.ns;
713 :
714 1917 : 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 1268 : create_var (gfc_expr * e, const char *vname)
761 : {
762 1268 : char name[GFC_MAX_SYMBOL_LEN +1];
763 1268 : gfc_symtree *symtree;
764 1268 : gfc_symbol *symbol;
765 1268 : gfc_expr *result;
766 1268 : gfc_code *n;
767 1268 : gfc_namespace *ns;
768 1268 : int i;
769 1268 : bool deferred;
770 :
771 1377 : 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 1245 : if (flag_realloc_lhs == 0 && e->rank > 0 && e->shape == NULL)
777 : return NULL;
778 :
779 1244 : ns = insert_block ();
780 :
781 1244 : if (vname)
782 1244 : 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 1244 : if (gfc_get_sym_tree (name, ns, &symtree, false) != 0)
787 0 : gcc_unreachable ();
788 :
789 1244 : symbol = symtree->n.sym;
790 1244 : symbol->ts = e->ts;
791 :
792 1244 : if (e->rank > 0)
793 : {
794 406 : symbol->as = gfc_get_array_spec ();
795 406 : symbol->as->rank = e->rank;
796 406 : symbol->as->corank = e->corank;
797 :
798 406 : if (e->shape == NULL)
799 : {
800 : /* We don't know the shape at compile time, so we use an
801 : allocatable. */
802 206 : symbol->as->type = AS_DEFERRED;
803 206 : symbol->attr.allocatable = 1;
804 : }
805 : else
806 : {
807 200 : symbol->as->type = AS_EXPLICIT;
808 : /* Copy the shape. */
809 538 : for (i=0; i<e->rank; i++)
810 : {
811 338 : gfc_expr *p, *q;
812 :
813 338 : p = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
814 : &(e->where));
815 338 : mpz_set_si (p->value.integer, 1);
816 338 : symbol->as->lower[i] = p;
817 :
818 338 : q = gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
819 : &(e->where));
820 338 : mpz_set (q->value.integer, e->shape[i]);
821 338 : symbol->as->upper[i] = q;
822 : }
823 : }
824 : }
825 :
826 1244 : deferred = 0;
827 1244 : 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 1244 : symbol->attr.flavor = FL_VARIABLE;
849 1244 : symbol->attr.referenced = 1;
850 1244 : symbol->attr.dimension = e->rank > 0;
851 1244 : symbol->attr.fe_temp = 1;
852 1244 : symbol->attr.automatic = 1;
853 1244 : gfc_commit_symbol (symbol);
854 :
855 1244 : result = gfc_get_expr ();
856 1244 : result->expr_type = EXPR_VARIABLE;
857 1244 : result->ts = symbol->ts;
858 1244 : result->ts.deferred = deferred;
859 1244 : result->rank = e->rank;
860 1244 : result->corank = e->corank;
861 1244 : result->shape = gfc_copy_shape (e->shape, e->rank);
862 1244 : result->symtree = symtree;
863 1244 : result->where = e->where;
864 1244 : if (e->rank > 0)
865 : {
866 406 : result->ref = gfc_get_ref ();
867 406 : result->ref->type = REF_ARRAY;
868 406 : result->ref->u.ar.type = AR_FULL;
869 406 : result->ref->u.ar.where = e->where;
870 406 : result->ref->u.ar.dimen = e->rank;
871 812 : result->ref->u.ar.as = symbol->ts.type == BT_CLASS
872 406 : ? CLASS_DATA (symbol)->as : symbol->as;
873 406 : 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 1244 : n = XCNEW (gfc_code);
880 1244 : n->op = EXEC_ASSIGN;
881 1244 : n->loc = (*current_code)->loc;
882 1244 : n->next = *changed_statement;
883 1244 : n->expr1 = gfc_copy_expr (result);
884 1244 : n->expr2 = e;
885 1244 : *changed_statement = n;
886 1244 : n_vars ++;
887 :
888 1244 : 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 1425024 : cfe_expr_0 (gfc_expr **e, int *walk_subtrees,
919 : void *data ATTRIBUTE_UNUSED)
920 : {
921 1425024 : int i,j;
922 1425024 : gfc_expr *newvar;
923 1425024 : gfc_expr **ei, **ej;
924 :
925 : /* Don't do this optimization within OMP workshare/atomic or ASSOC lists. */
926 :
927 1425024 : if (in_omp_workshare || in_omp_atomic || in_assoc_list)
928 : {
929 11396 : *walk_subtrees = 0;
930 11396 : return 0;
931 : }
932 :
933 1413628 : expr_array.release ();
934 :
935 1413628 : gfc_expr_walker (e, cfe_register_funcs, NULL);
936 :
937 : /* Walk through all the functions. */
938 :
939 2852343 : FOR_EACH_VEC_ELT_FROM (expr_array, i, ei, 1)
940 : {
941 : /* Skip if the function has been replaced by a variable already. */
942 25087 : if ((*ei)->expr_type == EXPR_VARIABLE)
943 0 : continue;
944 :
945 : newvar = NULL;
946 57844 : for (j=0; j<i; j++)
947 : {
948 32757 : ej = expr_array[j];
949 32757 : if (gfc_dep_compare_functions (*ei, *ej, true) == 0)
950 : {
951 541 : if (newvar == NULL)
952 541 : newvar = create_var (*ei, "fcn");
953 :
954 541 : if (warn_function_elimination)
955 6 : do_warn_function_elimination (*ej);
956 :
957 541 : free (*ej);
958 541 : *ej = gfc_copy_expr (newvar);
959 : }
960 : }
961 25087 : if (newvar)
962 541 : *ei = newvar;
963 : }
964 :
965 : /* We did all the necessary walking in this function. */
966 1413628 : *walk_subtrees = 0;
967 1413628 : 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 1035791 : cfe_code (gfc_code **c, int *walk_subtrees, void *data ATTRIBUTE_UNUSED)
976 : {
977 1035791 : current_code = c;
978 1035791 : inserted_block = NULL;
979 1035791 : 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 1035791 : 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 10199733 : dummy_expr_callback (gfc_expr **e ATTRIBUTE_UNUSED, int *walk_subtrees,
1012 : void *data ATTRIBUTE_UNUSED)
1013 : {
1014 10199733 : *walk_subtrees = 0;
1015 10199733 : 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 1199934 : gfc_dummy_code_callback (gfc_code **e ATTRIBUTE_UNUSED,
1022 : int *walk_subtrees ATTRIBUTE_UNUSED,
1023 : void *data ATTRIBUTE_UNUSED)
1024 : {
1025 1199934 : 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 1034722 : convert_do_while (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
1040 : void *data ATTRIBUTE_UNUSED)
1041 : {
1042 1034722 : gfc_code *co = *c;
1043 1034722 : gfc_code *c_if1, *c_if2, *c_exit;
1044 1034722 : gfc_code *loopblock;
1045 1034722 : gfc_expr *e_not, *e_cond;
1046 :
1047 1034722 : 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 1036445 : convert_elseif (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
1114 : void *data ATTRIBUTE_UNUSED)
1115 : {
1116 1036445 : gfc_code *co = *c;
1117 1036445 : gfc_code *c_if1, *c_if2, *else_stmt;
1118 :
1119 1036445 : if (co->op != EXEC_IF)
1120 : return 0;
1121 :
1122 : /* This loop starts out with the first ELSE statement. */
1123 211753 : else_stmt = co->block->block;
1124 :
1125 213476 : while (else_stmt != NULL)
1126 : {
1127 7440 : gfc_code *next_else;
1128 :
1129 : /* If there is no condition, we're done. */
1130 7440 : 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 966274 : simplify_io_impl_do (gfc_code **code, int *walk_subtrees,
1430 : void *data ATTRIBUTE_UNUSED)
1431 : {
1432 966274 : gfc_code **curr, *prev = NULL;
1433 966274 : struct do_stack write, first;
1434 966274 : bool b = false;
1435 966274 : *walk_subtrees = 1;
1436 966274 : if (!(*code)->block
1437 301055 : || ((*code)->block->op != EXEC_WRITE
1438 301055 : && (*code)->block->op != EXEC_READ))
1439 : return 0;
1440 :
1441 27804 : *walk_subtrees = 0;
1442 27804 : write.prev = NULL;
1443 27804 : write.iter = NULL;
1444 27804 : write.code = *code;
1445 :
1446 123316 : for (curr = &(*code)->block; *curr; curr = &(*curr)->next)
1447 : {
1448 95512 : 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 95512 : 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 300463 : optimize_namespace (gfc_namespace *ns)
1468 : {
1469 300463 : gfc_namespace *saved_ns = gfc_current_ns;
1470 300463 : current_ns = ns;
1471 300463 : gfc_current_ns = ns;
1472 300463 : forall_level = 0;
1473 300463 : iterator_level = 0;
1474 300463 : in_assoc_list = false;
1475 300463 : in_omp_workshare = false;
1476 300463 : in_omp_atomic = false;
1477 :
1478 300463 : if (flag_frontend_optimize)
1479 : {
1480 300438 : gfc_code_walker (&ns->code, simplify_io_impl_do, dummy_expr_callback, NULL);
1481 300438 : gfc_code_walker (&ns->code, convert_do_while, dummy_expr_callback, NULL);
1482 300438 : gfc_code_walker (&ns->code, convert_elseif, dummy_expr_callback, NULL);
1483 300438 : gfc_code_walker (&ns->code, cfe_code, cfe_expr_0, NULL);
1484 300438 : gfc_code_walker (&ns->code, optimize_code, optimize_expr, NULL);
1485 300438 : if (flag_inline_matmul_limit != 0 || flag_external_blas
1486 95 : || flag_external_blas64)
1487 : {
1488 300412 : bool found;
1489 300412 : do
1490 : {
1491 300412 : found = false;
1492 300412 : gfc_code_walker (&ns->code, matmul_to_var_code, matmul_to_var_expr,
1493 : (void *) &found);
1494 : }
1495 : while (found);
1496 :
1497 300343 : gfc_code_walker (&ns->code, matmul_temp_args, dummy_expr_callback,
1498 : NULL);
1499 : }
1500 :
1501 300438 : if (flag_external_blas || flag_external_blas64)
1502 38 : gfc_code_walker (&ns->code, call_external_blas, dummy_expr_callback,
1503 : NULL);
1504 :
1505 300438 : if (flag_inline_matmul_limit != 0)
1506 300342 : gfc_code_walker (&ns->code, inline_matmul_assign, dummy_expr_callback,
1507 : NULL);
1508 : }
1509 :
1510 300463 : if (flag_frontend_loop_interchange)
1511 300404 : gfc_code_walker (&ns->code, index_interchange, dummy_expr_callback,
1512 : NULL);
1513 :
1514 : /* BLOCKs are handled in the expression walker below. */
1515 341768 : for (ns = ns->contained; ns; ns = ns->sibling)
1516 : {
1517 41305 : if (ns->code == NULL || ns->code->op != EXEC_BLOCK)
1518 40452 : optimize_namespace (ns);
1519 : }
1520 300463 : gfc_current_ns = saved_ns;
1521 300463 : }
1522 :
1523 : /* Handle dependencies for allocatable strings which potentially redefine
1524 : themselves in an assignment. */
1525 :
1526 : static void
1527 355587 : realloc_strings (gfc_namespace *ns)
1528 : {
1529 355587 : current_ns = ns;
1530 355587 : gfc_code_walker (&ns->code, realloc_string_callback, dummy_expr_callback, NULL);
1531 :
1532 404212 : for (ns = ns->contained; ns; ns = ns->sibling)
1533 : {
1534 48625 : if (ns->code == NULL || ns->code->op != EXEC_BLOCK)
1535 47557 : realloc_strings (ns);
1536 : }
1537 :
1538 355587 : }
1539 :
1540 : static void
1541 300380 : optimize_reduction (gfc_namespace *ns)
1542 : {
1543 300380 : current_ns = ns;
1544 300380 : gfc_code_walker (&ns->code, gfc_dummy_code_callback,
1545 : callback_reduction, NULL);
1546 :
1547 : /* BLOCKs are handled in the expression walker below. */
1548 341676 : for (ns = ns->contained; ns; ns = ns->sibling)
1549 : {
1550 41296 : if (ns->code == NULL || ns->code->op != EXEC_BLOCK)
1551 40385 : optimize_reduction (ns);
1552 : }
1553 300380 : }
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 52636 : optimize_binop_array_assignment (gfc_code *c, gfc_expr **rhs, bool seen_op)
1565 : {
1566 52636 : gfc_expr *e;
1567 :
1568 52636 : if (!*rhs)
1569 : return false;
1570 :
1571 52634 : e = *rhs;
1572 52634 : if (e->expr_type == EXPR_OP)
1573 : {
1574 3392 : 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 3049 : default:
1592 : /* Binary operators. */
1593 3049 : if (optimize_binop_array_assignment (c, &e->value.op.op1, true))
1594 : return true;
1595 :
1596 3014 : if (optimize_binop_array_assignment (c, &e->value.op.op2, true))
1597 : return true;
1598 :
1599 : break;
1600 : }
1601 : }
1602 5777 : 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 49318 : && ! 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 442503 : remove_trim (gfc_expr *rhs)
1643 : {
1644 442503 : bool ret;
1645 :
1646 442503 : ret = false;
1647 442503 : 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 442917 : while (rhs->expr_type == EXPR_OP
1655 442917 : && rhs->value.op.op == INTRINSIC_CONCAT)
1656 414 : rhs = rhs->value.op.op2;
1657 :
1658 68335 : while (rhs->expr_type == EXPR_FUNCTION && rhs->value.function.isym
1659 498935 : && rhs->value.function.isym->id == GFC_ISYM_TRIM)
1660 : {
1661 1175 : strip_function_call (rhs);
1662 : /* Recursive call to catch silly stuff like trim ( a // trim(b)). */
1663 1175 : remove_trim (rhs);
1664 1175 : ret = true;
1665 : }
1666 :
1667 : return ret;
1668 : }
1669 :
1670 : /* Optimizations for an assignment. */
1671 :
1672 : static void
1673 270306 : optimize_assignment (gfc_code * c)
1674 : {
1675 270306 : gfc_expr *lhs, *rhs;
1676 :
1677 270306 : lhs = c->expr1;
1678 270306 : rhs = c->expr2;
1679 :
1680 270306 : if (lhs->ts.type == BT_CHARACTER && !lhs->ts.deferred)
1681 : {
1682 : /* Optimize a = trim(b) to a = b. */
1683 22784 : remove_trim (rhs);
1684 :
1685 : /* Replace a = ' ' by a = '' to optimize away a memcpy. */
1686 22784 : if (is_empty_string (rhs))
1687 1656 : rhs->value.character.length = 0;
1688 : }
1689 :
1690 270306 : if (lhs->rank > 0 && gfc_check_dependency (lhs, rhs, true) == 0)
1691 46257 : optimize_binop_array_assignment (c, &rhs, false);
1692 270306 : }
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 1541 : strip_function_call (gfc_expr *e)
1701 : {
1702 1541 : gfc_expr *e1;
1703 1541 : gfc_actual_arglist *a;
1704 :
1705 1541 : a = e->value.function.actual;
1706 :
1707 : /* We should have at least one argument. */
1708 1541 : gcc_assert (a->expr != NULL);
1709 :
1710 1541 : e1 = a->expr;
1711 :
1712 : /* Free the remaining arglist, if any. */
1713 1541 : if (a->next)
1714 0 : gfc_free_actual_arglist (a->next);
1715 :
1716 : /* Graft the argument expression onto the original function. */
1717 1541 : *e = *e1;
1718 1541 : free (e1);
1719 :
1720 1541 : }
1721 :
1722 : /* Optimization of lexical comparison functions. */
1723 :
1724 : static bool
1725 3184763 : optimize_lexical_comparison (gfc_expr *e)
1726 : {
1727 3184763 : if (e->expr_type != EXPR_FUNCTION || e->value.function.isym == NULL)
1728 : return false;
1729 :
1730 205642 : 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 310018 : combine_array_constructor (gfc_expr *e)
1756 : {
1757 :
1758 310018 : gfc_expr *op1, *op2;
1759 310018 : gfc_expr *scalar;
1760 310018 : gfc_expr *new_expr;
1761 310018 : gfc_constructor *c, *new_c;
1762 310018 : gfc_constructor_base oldbase, newbase;
1763 310018 : bool scalar_first;
1764 310018 : int n_elem;
1765 310018 : bool all_const;
1766 :
1767 : /* Array constructors have rank one. */
1768 310018 : 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 34232 : if (in_assoc_list)
1774 : return false;
1775 :
1776 : /* With FORALL, the BLOCKS created by create_var will cause an ICE. */
1777 34222 : 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 34135 : if (iterator_level > 0)
1783 : return false;
1784 :
1785 : /* WHERE also doesn't work. */
1786 34097 : if (in_where > 0)
1787 : return false;
1788 :
1789 33595 : op1 = e->value.op.op1;
1790 33595 : op2 = e->value.op.op2;
1791 :
1792 33595 : if (!op1 || !op2)
1793 : return false;
1794 :
1795 33594 : if (op1->expr_type == EXPR_ARRAY && op2->rank == 0)
1796 : scalar_first = false;
1797 33507 : 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 contains 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 446041 : optimize_op (gfc_expr *e)
1880 : {
1881 446041 : bool changed;
1882 :
1883 446041 : gfc_intrinsic_op op = e->value.op.op;
1884 :
1885 446041 : changed = false;
1886 :
1887 : /* Only use new-style comparisons. */
1888 446041 : 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 381773 : switch (op)
1919 : {
1920 209179 : case INTRINSIC_EQ:
1921 209179 : case INTRINSIC_GE:
1922 209179 : case INTRINSIC_LE:
1923 209179 : case INTRINSIC_NE:
1924 209179 : case INTRINSIC_GT:
1925 209179 : case INTRINSIC_LT:
1926 209179 : changed = optimize_comparison (e, op);
1927 :
1928 310018 : gcc_fallthrough ();
1929 : /* Look at array constructors. */
1930 310018 : case INTRINSIC_PLUS:
1931 310018 : case INTRINSIC_MINUS:
1932 310018 : case INTRINSIC_TIMES:
1933 310018 : case INTRINSIC_DIVIDE:
1934 310018 : 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 73568 : is_empty_string (gfc_expr *e)
1948 : {
1949 73568 : int i;
1950 :
1951 73568 : if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT)
1952 : return false;
1953 :
1954 46248 : for (i=0; i < e->value.character.length; i++)
1955 : {
1956 43836 : 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 1122 : get_len_trim_call (gfc_expr *str, int kind)
1970 : {
1971 1122 : gfc_expr *fcn;
1972 1122 : gfc_actual_arglist *actual_arglist, *next;
1973 :
1974 1122 : fcn = gfc_get_expr ();
1975 1122 : fcn->expr_type = EXPR_FUNCTION;
1976 1122 : fcn->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_LEN_TRIM);
1977 1122 : actual_arglist = gfc_get_actual_arglist ();
1978 1122 : actual_arglist->expr = str;
1979 1122 : next = gfc_get_actual_arglist ();
1980 1122 : next->expr = gfc_get_int_expr (gfc_default_integer_kind, NULL, kind);
1981 1122 : actual_arglist->next = next;
1982 :
1983 1122 : fcn->value.function.actual = actual_arglist;
1984 1122 : fcn->where = str->where;
1985 1122 : fcn->ts.type = BT_INTEGER;
1986 1122 : fcn->ts.kind = gfc_charlen_int_kind;
1987 :
1988 1122 : gfc_get_sym_tree ("__internal_len_trim", current_ns, &fcn->symtree, false);
1989 1122 : fcn->symtree->n.sym->ts = fcn->ts;
1990 1122 : fcn->symtree->n.sym->attr.flavor = FL_PROCEDURE;
1991 1122 : fcn->symtree->n.sym->attr.function = 1;
1992 1122 : fcn->symtree->n.sym->attr.elemental = 1;
1993 1122 : fcn->symtree->n.sym->attr.referenced = 1;
1994 1122 : fcn->symtree->n.sym->attr.access = ACCESS_PRIVATE;
1995 1122 : gfc_commit_symbol (fcn->symtree->n.sym);
1996 :
1997 1122 : return fcn;
1998 : }
1999 :
2000 :
2001 : /* Optimize expressions for equality. */
2002 :
2003 : static bool
2004 209272 : optimize_comparison (gfc_expr *e, gfc_intrinsic_op op)
2005 : {
2006 209272 : gfc_expr *op1, *op2;
2007 209272 : bool change;
2008 209272 : int eq;
2009 209272 : bool result;
2010 209272 : gfc_actual_arglist *firstarg, *secondarg;
2011 :
2012 209272 : if (e->expr_type == EXPR_OP)
2013 : {
2014 209181 : firstarg = NULL;
2015 209181 : secondarg = NULL;
2016 209181 : op1 = e->value.op.op1;
2017 209181 : 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 209272 : change = remove_trim (op1);
2033 :
2034 209272 : 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 209272 : 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 174151 : if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
2047 25839 : && (op == INTRINSIC_EQ || op == INTRINSIC_NE))
2048 : {
2049 25392 : bool empty_op1, empty_op2;
2050 25392 : empty_op1 = is_empty_string (op1);
2051 25392 : empty_op2 = is_empty_string (op2);
2052 :
2053 25392 : if (empty_op1 || empty_op2)
2054 : {
2055 756 : gfc_expr *fcn;
2056 756 : gfc_expr *zero;
2057 756 : gfc_expr *str;
2058 :
2059 : /* This can only happen when an error for comparing
2060 : characters of different kinds has already been issued. */
2061 756 : if (empty_op1 && empty_op2)
2062 : return false;
2063 :
2064 756 : zero = gfc_get_int_expr (gfc_charlen_int_kind, &e->where, 0);
2065 756 : str = empty_op1 ? op2 : op1;
2066 :
2067 756 : fcn = get_len_trim_call (str, gfc_charlen_int_kind);
2068 :
2069 :
2070 756 : if (empty_op1)
2071 0 : gfc_free_expr (op1);
2072 : else
2073 756 : gfc_free_expr (op2);
2074 :
2075 756 : op1 = fcn;
2076 756 : op2 = zero;
2077 756 : e->value.op.op1 = fcn;
2078 756 : e->value.op.op2 = zero;
2079 : }
2080 : }
2081 :
2082 :
2083 : /* Don't compare REAL or COMPLEX expressions when honoring NaNs. */
2084 :
2085 174151 : if (flag_finite_math_only
2086 174007 : || (op1->ts.type != BT_REAL && op2->ts.type != BT_REAL
2087 156420 : && op1->ts.type != BT_COMPLEX && op2->ts.type != BT_COMPLEX))
2088 : {
2089 155477 : eq = gfc_dep_compare_expr (op1, op2);
2090 155477 : if (eq <= -2)
2091 : {
2092 : /* Replace A // B < A // C with B < C, and A // B < C // B
2093 : with A < C. */
2094 155391 : if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
2095 25042 : && op1->expr_type == EXPR_OP
2096 47 : && op1->value.op.op == INTRINSIC_CONCAT
2097 47 : && 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 3184763 : optimize_trim (gfc_expr *e)
2205 : {
2206 3184763 : gfc_expr *a;
2207 3184763 : gfc_ref *ref;
2208 3184763 : gfc_expr *fcn;
2209 3184763 : gfc_ref **rr = NULL;
2210 :
2211 : /* Don't do this optimization within an argument list, because
2212 : otherwise aliasing issues may occur. */
2213 :
2214 3184763 : if (count_arglist != 1)
2215 : return false;
2216 :
2217 432108 : if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_FUNCTION
2218 7626 : || e->value.function.isym == NULL
2219 5257 : || 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 5956 : doloop_contained_function_call (gfc_expr **e,
2288 : int *walk_subtrees ATTRIBUTE_UNUSED, void *data)
2289 : {
2290 5956 : gfc_expr *expr = *e;
2291 5956 : gfc_formal_arglist *f;
2292 5956 : gfc_actual_arglist *a;
2293 5956 : gfc_symbol *sym, *do_var;
2294 5956 : contained_info *info;
2295 :
2296 5956 : 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 1245220 : doloop_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
2494 : void *data ATTRIBUTE_UNUSED)
2495 : {
2496 1245220 : gfc_code *co;
2497 1245220 : int i;
2498 1245220 : gfc_formal_arglist *f;
2499 1245220 : gfc_actual_arglist *a;
2500 1245220 : gfc_code *cl;
2501 1245220 : do_t loop, *lp;
2502 1245220 : bool seen_goto;
2503 :
2504 1245220 : co = *c;
2505 :
2506 : /* If the doloop_list grew, we have to truncate it here. */
2507 :
2508 1245220 : if ((unsigned) doloop_level < doloop_list.length())
2509 32234 : doloop_list.truncate (doloop_level);
2510 :
2511 1245220 : seen_goto = false;
2512 1245220 : switch (co->op)
2513 : {
2514 41857 : case EXEC_DO:
2515 :
2516 41857 : if (co->ext.iterator && co->ext.iterator->var)
2517 41857 : loop.c = co;
2518 : else
2519 0 : loop.c = NULL;
2520 :
2521 41857 : loop.branch_level = if_level + select_level;
2522 41857 : loop.seen_goto = false;
2523 41857 : doloop_list.safe_push (loop);
2524 41857 : 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 3955 : case EXEC_OPEN:
2538 3955 : if (co->ext.open->err)
2539 : seen_goto = true;
2540 : break;
2541 :
2542 3148 : case EXEC_CLOSE:
2543 3148 : if (co->ext.close->err)
2544 : seen_goto = true;
2545 : break;
2546 :
2547 2863 : case EXEC_BACKSPACE:
2548 2863 : case EXEC_ENDFILE:
2549 2863 : case EXEC_REWIND:
2550 2863 : case EXEC_FLUSH:
2551 :
2552 2863 : if (co->ext.filepos->err)
2553 : seen_goto = true;
2554 : break;
2555 :
2556 838 : case EXEC_INQUIRE:
2557 838 : if (co->ext.inquire->err)
2558 : seen_goto = true;
2559 : break;
2560 :
2561 34517 : case EXEC_READ:
2562 34517 : case EXEC_WRITE:
2563 34517 : 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 88366 : case EXEC_CALL:
2573 88366 : 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 88002 : if (co->resolved_sym->attr.contained)
2579 : {
2580 49993 : FOR_EACH_VEC_ELT (doloop_list, i, lp)
2581 : {
2582 4040 : gfc_symbol *sym = co->resolved_sym;
2583 4040 : contained_info info;
2584 4040 : gfc_namespace *ns;
2585 :
2586 4040 : cl = lp->c;
2587 4040 : info.do_var = cl->ext.iterator->var->symtree->n.sym;
2588 4040 : info.procedure = co->resolved_sym; /* sym? */
2589 4040 : info.where_do = co->loc;
2590 : /* Look contained procedures under the namespace of the
2591 : variable. */
2592 4716 : 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 88002 : f = gfc_sym_get_dummy_args (co->resolved_sym);
2600 :
2601 : /* Without a formal arglist, there is only unknown INTENT,
2602 : which we don't check for. */
2603 88002 : if (f == NULL)
2604 : break;
2605 :
2606 62344 : a = co->ext.actual;
2607 :
2608 219553 : while (a && f)
2609 : {
2610 175510 : FOR_EACH_VEC_ELT (doloop_list, i, lp)
2611 : {
2612 18301 : gfc_symbol *do_sym;
2613 18301 : cl = lp->c;
2614 :
2615 18301 : if (cl == NULL)
2616 : break;
2617 :
2618 18301 : do_sym = cl->ext.iterator->var->symtree->n.sym;
2619 :
2620 18301 : if (a->expr && a->expr->symtree && f->sym
2621 9347 : && 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 157209 : a = a->next;
2640 157209 : f = f->next;
2641 : }
2642 :
2643 : break;
2644 :
2645 : default:
2646 : break;
2647 : }
2648 272845 : if (seen_goto && doloop_level > 0)
2649 10421 : doloop_list[doloop_level-1].seen_goto = true;
2650 :
2651 1245220 : return 0;
2652 : }
2653 :
2654 : /* Callback function to warn about different things within DO loops. */
2655 :
2656 : static int
2657 3803950 : do_function (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
2658 : void *data ATTRIBUTE_UNUSED)
2659 : {
2660 3803950 : do_t *last;
2661 :
2662 3803950 : if (doloop_list.length () == 0)
2663 : return 0;
2664 :
2665 704091 : if ((*e)->expr_type == EXPR_FUNCTION)
2666 45368 : do_intent (e);
2667 :
2668 704091 : last = &doloop_list.last();
2669 704091 : if (last->seen_goto && !warn_do_subscript)
2670 : return 0;
2671 :
2672 656367 : if ((*e)->expr_type == EXPR_VARIABLE)
2673 323970 : 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 159495 : callback_insert_index (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
2689 : void *data)
2690 : {
2691 159495 : insert_index_t *d;
2692 159495 : gfc_expr *ex, *n;
2693 :
2694 159495 : ex = (*e);
2695 159495 : if (ex->expr_type != EXPR_VARIABLE)
2696 : return 0;
2697 :
2698 99179 : d = (insert_index_t *) data;
2699 99179 : if (ex->symtree->n.sym != d->sym)
2700 : return 0;
2701 :
2702 54673 : n = gfc_get_constant_expr (BT_INTEGER, ex->ts.kind, &ex->where);
2703 54673 : mpz_set (n->value.integer, d->val);
2704 :
2705 54673 : gfc_free_expr (ex);
2706 54673 : *e = n;
2707 54673 : 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 95072 : insert_index (gfc_expr *e, gfc_symbol *sym, mpz_t val, mpz_t ret)
2717 : {
2718 95072 : gfc_expr *n;
2719 95072 : insert_index_t data;
2720 95072 : bool rc;
2721 :
2722 95072 : if (e->expr_type == EXPR_CONSTANT)
2723 : return false;
2724 :
2725 91352 : n = gfc_copy_expr (e);
2726 91352 : data.sym = sym;
2727 91352 : mpz_init_set (data.val, val);
2728 91352 : 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 91352 : gfc_push_suppress_errors ();
2733 91352 : gfc_simplify_expr (n, 0);
2734 91352 : gfc_pop_suppress_errors ();
2735 :
2736 91352 : if (n->expr_type == EXPR_CONSTANT)
2737 : {
2738 50376 : rc = true;
2739 50376 : mpz_init_set (ret, n->value.integer);
2740 : }
2741 : else
2742 : rc = false;
2743 :
2744 91352 : mpz_clear (data.val);
2745 91352 : gfc_free_expr (n);
2746 91352 : return rc;
2747 :
2748 : }
2749 :
2750 : static bool
2751 95186 : evaluate_loop_bound (gfc_expr *e, gfc_symbol *sym, mpz_t val, mpz_t ret)
2752 : {
2753 95186 : if (e->expr_type == EXPR_CONSTANT)
2754 : {
2755 83502 : mpz_init_set (ret, e->value.integer);
2756 83502 : return true;
2757 : }
2758 :
2759 11684 : 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 71440 : inner_loop_may_be_skipped (int loop_index, gfc_symbol *outer_sym, mpz_t outer_val)
2768 : {
2769 71440 : int k;
2770 71440 : do_t *lp;
2771 :
2772 91943 : FOR_EACH_VEC_ELT_FROM (doloop_list, k, lp, loop_index + 1)
2773 : {
2774 31844 : gfc_code *loop = lp->c;
2775 31844 : int sgn, cmp;
2776 31844 : mpz_t do_start, do_end, do_step;
2777 :
2778 31844 : if (loop == NULL || loop->ext.iterator == NULL || loop->ext.iterator->var == NULL)
2779 11341 : return true;
2780 :
2781 31844 : if (loop->ext.iterator->var->symtree->n.sym->ts.type != BT_INTEGER)
2782 : return true;
2783 :
2784 31842 : if (!evaluate_loop_bound (loop->ext.iterator->step, outer_sym, outer_val, do_step))
2785 : return true;
2786 :
2787 31810 : sgn = mpz_cmp_ui (do_step, 0);
2788 31587 : if (sgn == 0)
2789 : {
2790 0 : mpz_clear (do_step);
2791 0 : return true;
2792 : }
2793 :
2794 31810 : if (!evaluate_loop_bound (loop->ext.iterator->start, outer_sym, outer_val, do_start)
2795 31810 : || !evaluate_loop_bound (loop->ext.iterator->end, outer_sym, outer_val, do_end))
2796 : {
2797 11247 : mpz_clear (do_step);
2798 11247 : return true;
2799 : }
2800 :
2801 20563 : cmp = mpz_cmp (do_end, do_start);
2802 20563 : mpz_clear (do_start);
2803 20563 : mpz_clear (do_end);
2804 20563 : mpz_clear (do_step);
2805 :
2806 20563 : if ((sgn > 0 && cmp < 0) || (sgn < 0 && cmp > 0))
2807 : return true;
2808 : }
2809 :
2810 : return false;
2811 : }
2812 :
2813 : /* Check array subscripts for possible out-of-bounds accesses in DO
2814 : loops with constant bounds. */
2815 :
2816 : static int
2817 323970 : do_subscript (gfc_expr **e)
2818 : {
2819 323970 : gfc_expr *v;
2820 323970 : gfc_array_ref *ar;
2821 323970 : gfc_ref *ref;
2822 323970 : int i,j;
2823 323970 : gfc_code *dl;
2824 323970 : do_t *lp;
2825 :
2826 323970 : v = *e;
2827 : /* Constants are already checked. */
2828 323970 : if (v->expr_type == EXPR_CONSTANT)
2829 : return 0;
2830 :
2831 : /* Wrong warnings will be generated in an associate list. */
2832 323970 : if (in_assoc_list)
2833 : return 0;
2834 :
2835 : /* We already warned about this. */
2836 323807 : if (v->do_not_warn)
2837 : return 0;
2838 :
2839 297791 : v->do_not_warn = 1;
2840 :
2841 382043 : for (ref = v->ref; ref; ref = ref->next)
2842 : {
2843 86687 : if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT)
2844 : {
2845 : ar = & ref->u.ar;
2846 193240 : FOR_EACH_VEC_ELT (doloop_list, j, lp)
2847 : {
2848 73916 : gfc_symbol *do_sym;
2849 73916 : mpz_t do_start, do_step, do_end;
2850 73916 : bool have_do_start, have_do_end;
2851 73916 : bool error_not_proven;
2852 73916 : int warn;
2853 73916 : int sgn;
2854 :
2855 73916 : dl = lp->c;
2856 73916 : if (dl == NULL)
2857 : break;
2858 :
2859 : /* If we are within a branch, or a goto or equivalent
2860 : was seen in the DO loop before, then we cannot prove that
2861 : this expression is actually evaluated. Don't do anything
2862 : unless we want to see it all. */
2863 73916 : error_not_proven = lp->seen_goto
2864 73916 : || lp->branch_level < if_level + select_level;
2865 :
2866 18908 : if (error_not_proven && !warn_do_subscript)
2867 : break;
2868 :
2869 : if (error_not_proven)
2870 : warn = OPT_Wdo_subscript;
2871 : else
2872 : warn = 0;
2873 :
2874 55014 : do_sym = dl->ext.iterator->var->symtree->n.sym;
2875 55014 : if (do_sym->ts.type != BT_INTEGER)
2876 715 : continue;
2877 :
2878 : /* If we do not know about the stepsize, the loop may be zero trip.
2879 : Do not warn in this case. */
2880 :
2881 55007 : if (dl->ext.iterator->step->expr_type == EXPR_CONSTANT)
2882 : {
2883 54300 : sgn = mpz_cmp_ui (dl->ext.iterator->step->value.integer, 0);
2884 : /* This can happen, but then the error has been
2885 : reported previously. */
2886 53863 : if (sgn == 0)
2887 1 : continue;
2888 :
2889 54299 : mpz_init_set (do_step, dl->ext.iterator->step->value.integer);
2890 : }
2891 :
2892 : else
2893 707 : continue;
2894 :
2895 54299 : if (dl->ext.iterator->start->expr_type == EXPR_CONSTANT)
2896 : {
2897 51757 : have_do_start = true;
2898 51757 : mpz_init_set (do_start, dl->ext.iterator->start->value.integer);
2899 : }
2900 : else
2901 : have_do_start = false;
2902 :
2903 54299 : if (dl->ext.iterator->end->expr_type == EXPR_CONSTANT)
2904 : {
2905 19733 : have_do_end = true;
2906 19733 : mpz_init_set (do_end, dl->ext.iterator->end->value.integer);
2907 : }
2908 : else
2909 : have_do_end = false;
2910 :
2911 54299 : if (!have_do_start && !have_do_end)
2912 : {
2913 2435 : mpz_clear (do_step);
2914 2435 : return 0;
2915 : }
2916 :
2917 : /* No warning inside a zero-trip loop. */
2918 51864 : if (have_do_start && have_do_end)
2919 : {
2920 19626 : int cmp;
2921 :
2922 19626 : cmp = mpz_cmp (do_end, do_start);
2923 19626 : if ((sgn > 0 && cmp < 0) || (sgn < 0 && cmp > 0))
2924 : {
2925 25 : mpz_clear (do_start);
2926 25 : mpz_clear (do_end);
2927 25 : mpz_clear (do_step);
2928 25 : break;
2929 : }
2930 : }
2931 :
2932 : /* May have to correct the end value if the step does not equal
2933 : one. */
2934 51839 : if (have_do_start && have_do_end && mpz_cmp_ui (do_step, 1) != 0)
2935 : {
2936 790 : mpz_t diff, rem;
2937 :
2938 790 : mpz_init (diff);
2939 790 : mpz_init (rem);
2940 790 : mpz_sub (diff, do_end, do_start);
2941 790 : mpz_tdiv_r (rem, diff, do_step);
2942 790 : mpz_sub (do_end, do_end, rem);
2943 790 : mpz_clear (diff);
2944 790 : mpz_clear (rem);
2945 : }
2946 :
2947 51839 : bool skip_start = have_do_start
2948 51839 : && inner_loop_may_be_skipped (j, do_sym, do_start);
2949 51839 : bool skip_end = have_do_end
2950 51839 : && inner_loop_may_be_skipped (j, do_sym, do_end);
2951 :
2952 121954 : for (i = 0; i< ar->dimen; i++)
2953 : {
2954 70115 : mpz_t val;
2955 70115 : if (ar->dimen_type[i] == DIMEN_ELEMENT && have_do_start && !skip_start
2956 124468 : && insert_index (ar->start[i], do_sym, do_start, val))
2957 : {
2958 35123 : if (ar->as->lower[i]
2959 30911 : && ar->as->lower[i]->expr_type == EXPR_CONSTANT
2960 30847 : && ar->as->lower[i]->ts.type == BT_INTEGER
2961 30847 : && mpz_cmp (val, ar->as->lower[i]->value.integer) < 0)
2962 14 : gfc_warning (warn, "Array reference at %L out of bounds "
2963 : "(%ld < %ld) in loop beginning at %L",
2964 7 : &ar->start[i]->where, mpz_get_si (val),
2965 : mpz_get_si (ar->as->lower[i]->value.integer),
2966 7 : &doloop_list[j].c->loc);
2967 :
2968 35123 : if (ar->as->upper[i]
2969 28713 : && ar->as->upper[i]->expr_type == EXPR_CONSTANT
2970 11157 : && ar->as->upper[i]->ts.type == BT_INTEGER
2971 11156 : && mpz_cmp (val, ar->as->upper[i]->value.integer) > 0)
2972 62 : gfc_warning (warn, "Array reference at %L out of bounds "
2973 : "(%ld > %ld) in loop beginning at %L",
2974 31 : &ar->start[i]->where, mpz_get_si (val),
2975 : mpz_get_si (ar->as->upper[i]->value.integer),
2976 31 : &doloop_list[j].c->loc);
2977 :
2978 35123 : mpz_clear (val);
2979 : }
2980 :
2981 70115 : if (ar->dimen_type[i] == DIMEN_ELEMENT && have_do_end && !skip_end
2982 99150 : && insert_index (ar->start[i], do_sym, do_end, val))
2983 : {
2984 14848 : if (ar->as->lower[i]
2985 12203 : && ar->as->lower[i]->expr_type == EXPR_CONSTANT
2986 12201 : && ar->as->lower[i]->ts.type == BT_INTEGER
2987 12201 : && mpz_cmp (val, ar->as->lower[i]->value.integer) < 0)
2988 4 : gfc_warning (warn, "Array reference at %L out of bounds "
2989 : "(%ld < %ld) in loop beginning at %L",
2990 2 : &ar->start[i]->where, mpz_get_si (val),
2991 : mpz_get_si (ar->as->lower[i]->value.integer),
2992 2 : &doloop_list[j].c->loc);
2993 :
2994 14848 : if (ar->as->upper[i]
2995 10794 : && ar->as->upper[i]->expr_type == EXPR_CONSTANT
2996 10160 : && ar->as->upper[i]->ts.type == BT_INTEGER
2997 10159 : && mpz_cmp (val, ar->as->upper[i]->value.integer) > 0)
2998 16 : gfc_warning (warn, "Array reference at %L out of bounds "
2999 : "(%ld > %ld) in loop beginning at %L",
3000 8 : &ar->start[i]->where, mpz_get_si (val),
3001 : mpz_get_si (ar->as->upper[i]->value.integer),
3002 8 : &doloop_list[j].c->loc);
3003 :
3004 14848 : mpz_clear (val);
3005 : }
3006 : }
3007 :
3008 51839 : if (have_do_start)
3009 51732 : mpz_clear (do_start);
3010 51839 : if (have_do_end)
3011 19708 : mpz_clear (do_end);
3012 51839 : mpz_clear (do_step);
3013 : }
3014 : }
3015 : }
3016 : return 0;
3017 : }
3018 : /* Function for functions checking that we do not pass a DO variable
3019 : to an INTENT(OUT) or INTENT(INOUT) dummy variable. */
3020 :
3021 : static int
3022 45368 : do_intent (gfc_expr **e)
3023 : {
3024 45368 : gfc_formal_arglist *f;
3025 45368 : gfc_actual_arglist *a;
3026 45368 : gfc_expr *expr;
3027 45368 : gfc_code *dl;
3028 45368 : do_t *lp;
3029 45368 : int i;
3030 45368 : gfc_symbol *sym;
3031 :
3032 45368 : expr = *e;
3033 45368 : if (expr->expr_type != EXPR_FUNCTION)
3034 : return 0;
3035 :
3036 : /* Intrinsic functions don't modify their arguments. */
3037 :
3038 45368 : if (expr->value.function.isym)
3039 : return 0;
3040 :
3041 2959 : sym = expr->value.function.esym;
3042 2959 : if (sym == NULL)
3043 : return 0;
3044 :
3045 2752 : if (sym->attr.contained)
3046 : {
3047 1034 : FOR_EACH_VEC_ELT (doloop_list, i, lp)
3048 : {
3049 621 : contained_info info;
3050 621 : gfc_namespace *ns;
3051 :
3052 621 : dl = lp->c;
3053 621 : info.do_var = dl->ext.iterator->var->symtree->n.sym;
3054 621 : info.procedure = sym;
3055 621 : info.where_do = expr->where;
3056 : /* Look contained procedures under the namespace of the
3057 : variable. */
3058 1006 : for (ns = info.do_var->ns->contained; ns; ns = ns->sibling)
3059 385 : if (ns->proc_name && ns->proc_name == sym)
3060 212 : gfc_code_walker (&ns->code, doloop_contained_procedure_code,
3061 : dummy_expr_callback, &info);
3062 : }
3063 : }
3064 :
3065 2752 : f = gfc_sym_get_dummy_args (sym);
3066 :
3067 : /* Without a formal arglist, there is only unknown INTENT,
3068 : which we don't check for. */
3069 2752 : if (f == NULL)
3070 : return 0;
3071 :
3072 1484 : a = expr->value.function.actual;
3073 :
3074 4011 : while (a && f)
3075 : {
3076 6308 : FOR_EACH_VEC_ELT (doloop_list, i, lp)
3077 : {
3078 3781 : gfc_symbol *do_sym;
3079 3781 : dl = lp->c;
3080 3781 : if (dl == NULL)
3081 : break;
3082 :
3083 3781 : do_sym = dl->ext.iterator->var->symtree->n.sym;
3084 :
3085 3781 : if (a->expr && a->expr->symtree
3086 2773 : && a->expr->symtree->n.sym == do_sym
3087 449 : && f->sym)
3088 : {
3089 448 : if (f->sym->attr.intent == INTENT_OUT)
3090 2 : gfc_error_now ("Variable %qs at %L set to undefined value "
3091 : "inside loop beginning at %L as INTENT(OUT) "
3092 : "argument to function %qs", do_sym->name,
3093 1 : &a->expr->where, &doloop_list[i].c->loc,
3094 1 : expr->symtree->n.sym->name);
3095 447 : else if (f->sym->attr.intent == INTENT_INOUT)
3096 2 : gfc_error_now ("Variable %qs at %L not definable inside loop"
3097 : " beginning at %L as INTENT(INOUT) argument to"
3098 : " function %qs", do_sym->name,
3099 1 : &a->expr->where, &doloop_list[i].c->loc,
3100 1 : expr->symtree->n.sym->name);
3101 : }
3102 : }
3103 2527 : a = a->next;
3104 2527 : f = f->next;
3105 : }
3106 :
3107 : return 0;
3108 : }
3109 :
3110 : static void
3111 363531 : doloop_warn (gfc_namespace *ns)
3112 : {
3113 363531 : gfc_code_walker (&ns->code, doloop_code, do_function, NULL);
3114 :
3115 413937 : for (ns = ns->contained; ns; ns = ns->sibling)
3116 : {
3117 50406 : if (ns->code == NULL || ns->code->op != EXEC_BLOCK)
3118 49364 : doloop_warn (ns);
3119 : }
3120 363531 : }
3121 :
3122 : /* This section deals with inlining calls to MATMUL. */
3123 :
3124 : /* Replace calls to matmul outside of straight assignments with a temporary
3125 : variable so that later inlining will work. */
3126 :
3127 : static int
3128 3184656 : matmul_to_var_expr (gfc_expr **ep, int *walk_subtrees ATTRIBUTE_UNUSED,
3129 : void *data)
3130 : {
3131 3184656 : gfc_expr *e, *n;
3132 3184656 : bool *found = (bool *) data;
3133 :
3134 3184656 : e = *ep;
3135 :
3136 3184656 : if (e->expr_type != EXPR_FUNCTION
3137 249115 : || e->value.function.isym == NULL
3138 205947 : || e->value.function.isym->id != GFC_ISYM_MATMUL)
3139 : return 0;
3140 :
3141 869 : if (forall_level > 0 || iterator_level > 0 || in_omp_workshare
3142 867 : || in_omp_atomic || in_where || in_assoc_list)
3143 : return 0;
3144 :
3145 : /* Check if this is already in the form c = matmul(a,b). */
3146 :
3147 863 : if ((*current_code)->expr2 == e)
3148 : return 0;
3149 :
3150 133 : n = create_var (e, "matmul");
3151 :
3152 : /* If create_var is unable to create a variable (for example if
3153 : -fno-realloc-lhs is in force with a variable that does not have bounds
3154 : known at compile-time), just return. */
3155 :
3156 133 : if (n == NULL)
3157 : return 0;
3158 :
3159 132 : *ep = n;
3160 132 : *found = true;
3161 132 : return 0;
3162 : }
3163 :
3164 : /* Set current_code and associated variables so that matmul_to_var_expr can
3165 : work. */
3166 :
3167 : static int
3168 1038288 : matmul_to_var_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
3169 : void *data ATTRIBUTE_UNUSED)
3170 : {
3171 1038288 : if (current_code != c)
3172 : {
3173 1024110 : current_code = c;
3174 1024110 : inserted_block = NULL;
3175 1024110 : changed_statement = NULL;
3176 : }
3177 :
3178 1038288 : return 0;
3179 : }
3180 :
3181 :
3182 : /* Take a statement of the shape c = matmul(a,b) and create temporaries
3183 : for a and b if there is a dependency between the arguments and the
3184 : result variable or if a or b are the result of calculations that cannot
3185 : be handled by the inliner. */
3186 :
3187 : static int
3188 1036319 : matmul_temp_args (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
3189 : void *data ATTRIBUTE_UNUSED)
3190 : {
3191 1036319 : gfc_expr *expr1, *expr2;
3192 1036319 : gfc_code *co;
3193 1036319 : gfc_actual_arglist *a, *b;
3194 1036319 : bool a_tmp, b_tmp;
3195 1036319 : gfc_expr *matrix_a, *matrix_b;
3196 1036319 : bool conjg_a, conjg_b, transpose_a, transpose_b;
3197 :
3198 1036319 : co = *c;
3199 :
3200 1036319 : if (co->op != EXEC_ASSIGN)
3201 : return 0;
3202 :
3203 270311 : if (forall_level > 0 || iterator_level > 0 || in_omp_workshare
3204 267916 : || in_omp_atomic || in_where)
3205 : return 0;
3206 :
3207 : /* This has some duplication with inline_matmul_assign. This
3208 : is because the creation of temporary variables could still fail,
3209 : and inline_matmul_assign still needs to be able to handle these
3210 : cases. */
3211 264678 : expr1 = co->expr1;
3212 264678 : expr2 = co->expr2;
3213 :
3214 264678 : if (expr2->expr_type != EXPR_FUNCTION
3215 37430 : || expr2->value.function.isym == NULL
3216 28485 : || expr2->value.function.isym->id != GFC_ISYM_MATMUL)
3217 : return 0;
3218 :
3219 849 : a_tmp = false;
3220 849 : a = expr2->value.function.actual;
3221 849 : matrix_a = check_conjg_transpose_variable (a->expr, &conjg_a, &transpose_a);
3222 849 : if (matrix_a != NULL)
3223 : {
3224 778 : if (matrix_a->expr_type == EXPR_VARIABLE
3225 778 : && (gfc_check_dependency (matrix_a, expr1, true)
3226 749 : || gfc_has_dimen_vector_ref (matrix_a)))
3227 : a_tmp = true;
3228 : }
3229 : else
3230 : a_tmp = true;
3231 :
3232 849 : b_tmp = false;
3233 849 : b = a->next;
3234 849 : matrix_b = check_conjg_transpose_variable (b->expr, &conjg_b, &transpose_b);
3235 849 : if (matrix_b != NULL)
3236 : {
3237 780 : if (matrix_b->expr_type == EXPR_VARIABLE
3238 780 : && (gfc_check_dependency (matrix_b, expr1, true)
3239 772 : || gfc_has_dimen_vector_ref (matrix_b)))
3240 : b_tmp = true;
3241 : }
3242 : else
3243 : b_tmp = true;
3244 :
3245 771 : if (!a_tmp && !b_tmp)
3246 : return 0;
3247 :
3248 156 : current_code = c;
3249 156 : inserted_block = NULL;
3250 156 : changed_statement = NULL;
3251 156 : if (a_tmp)
3252 : {
3253 102 : gfc_expr *at;
3254 102 : at = create_var (a->expr,"mma");
3255 102 : if (at)
3256 102 : a->expr = at;
3257 : }
3258 156 : if (b_tmp)
3259 : {
3260 78 : gfc_expr *bt;
3261 78 : bt = create_var (b->expr,"mmb");
3262 78 : if (bt)
3263 78 : b->expr = bt;
3264 : }
3265 : return 0;
3266 : }
3267 :
3268 : /* Auxiliary function to build and simplify an array inquiry function.
3269 : dim is zero-based. */
3270 :
3271 : static gfc_expr *
3272 7426 : get_array_inq_function (gfc_isym_id id, gfc_expr *e, int dim, int okind = 0)
3273 : {
3274 7426 : gfc_expr *fcn;
3275 7426 : gfc_expr *dim_arg, *kind;
3276 7426 : const char *name;
3277 7426 : gfc_expr *ec;
3278 :
3279 7426 : switch (id)
3280 : {
3281 : case GFC_ISYM_LBOUND:
3282 : name = "_gfortran_lbound";
3283 : break;
3284 :
3285 0 : case GFC_ISYM_UBOUND:
3286 0 : name = "_gfortran_ubound";
3287 0 : break;
3288 :
3289 4125 : case GFC_ISYM_SIZE:
3290 4125 : name = "_gfortran_size";
3291 4125 : break;
3292 :
3293 0 : default:
3294 0 : gcc_unreachable ();
3295 : }
3296 :
3297 7426 : dim_arg = gfc_get_int_expr (gfc_default_integer_kind, &e->where, dim);
3298 7426 : if (okind != 0)
3299 228 : kind = gfc_get_int_expr (gfc_default_integer_kind, &e->where,
3300 : okind);
3301 : else
3302 7198 : kind = gfc_get_int_expr (gfc_default_integer_kind, &e->where,
3303 : gfc_index_integer_kind);
3304 :
3305 7426 : ec = gfc_copy_expr (e);
3306 :
3307 : /* No bounds checking, this will be done before the loops if -fcheck=bounds
3308 : is in effect. */
3309 7426 : ec->no_bounds_check = 1;
3310 7426 : fcn = gfc_build_intrinsic_call (current_ns, id, name, e->where, 3,
3311 : ec, dim_arg, kind);
3312 7426 : gfc_simplify_expr (fcn, 0);
3313 7426 : fcn->no_bounds_check = 1;
3314 7426 : return fcn;
3315 : }
3316 :
3317 : /* Builds a logical expression. */
3318 :
3319 : static gfc_expr*
3320 1409 : build_logical_expr (gfc_intrinsic_op op, gfc_expr *e1, gfc_expr *e2)
3321 : {
3322 1409 : gfc_typespec ts;
3323 1409 : gfc_expr *res;
3324 :
3325 1409 : ts.type = BT_LOGICAL;
3326 1409 : ts.kind = gfc_default_logical_kind;
3327 1409 : res = gfc_get_expr ();
3328 1409 : res->where = e1->where;
3329 1409 : res->expr_type = EXPR_OP;
3330 1409 : res->value.op.op = op;
3331 1409 : res->value.op.op1 = e1;
3332 1409 : res->value.op.op2 = e2;
3333 1409 : res->ts = ts;
3334 :
3335 1409 : return res;
3336 : }
3337 :
3338 :
3339 : /* Return an operation of one two gfc_expr (one if e2 is NULL). This assumes
3340 : compatible typespecs. */
3341 :
3342 : static gfc_expr *
3343 6720 : get_operand (gfc_intrinsic_op op, gfc_expr *e1, gfc_expr *e2)
3344 : {
3345 6720 : gfc_expr *res;
3346 :
3347 6720 : res = gfc_get_expr ();
3348 6720 : res->ts = e1->ts;
3349 6720 : res->where = e1->where;
3350 6720 : res->expr_type = EXPR_OP;
3351 6720 : res->value.op.op = op;
3352 6720 : res->value.op.op1 = e1;
3353 6720 : res->value.op.op2 = e2;
3354 6720 : gfc_simplify_expr (res, 0);
3355 6720 : return res;
3356 : }
3357 :
3358 : /* Generate the IF statement for a runtime check if we want to do inlining or
3359 : not - putting in the code for both branches and putting it into the syntax
3360 : tree is the caller's responsibility. For fixed array sizes, this should be
3361 : removed by DCE. Only called for rank-two matrices A and B. */
3362 :
3363 : static gfc_code *
3364 591 : inline_limit_check (gfc_expr *a, gfc_expr *b, int limit, int rank_a)
3365 : {
3366 591 : gfc_expr *inline_limit;
3367 591 : gfc_code *if_1, *if_2, *else_2;
3368 591 : gfc_expr *b2, *a2, *a1, *m1, *m2;
3369 591 : gfc_typespec ts;
3370 591 : gfc_expr *cond;
3371 :
3372 591 : gcc_assert (rank_a == 1 || rank_a == 2);
3373 :
3374 : /* Calculation is done in real to avoid integer overflow. */
3375 :
3376 591 : inline_limit = gfc_get_constant_expr (BT_REAL, gfc_default_real_kind,
3377 : &a->where);
3378 591 : mpfr_set_si (inline_limit->value.real, limit, GFC_RND_MODE);
3379 :
3380 : /* Set the limit according to the rank. */
3381 591 : mpfr_pow_ui (inline_limit->value.real, inline_limit->value.real, rank_a + 1,
3382 : GFC_RND_MODE);
3383 :
3384 591 : a1 = get_array_inq_function (GFC_ISYM_SIZE, a, 1);
3385 :
3386 : /* For a_rank = 1, must use one as the size of a along the second
3387 : dimension as to avoid too much code duplication. */
3388 :
3389 591 : if (rank_a == 2)
3390 484 : a2 = get_array_inq_function (GFC_ISYM_SIZE, a, 2);
3391 : else
3392 107 : a2 = gfc_get_int_expr (gfc_index_integer_kind, &a->where, 1);
3393 :
3394 591 : b2 = get_array_inq_function (GFC_ISYM_SIZE, b, 2);
3395 :
3396 591 : gfc_clear_ts (&ts);
3397 591 : ts.type = BT_REAL;
3398 591 : ts.kind = gfc_default_real_kind;
3399 591 : gfc_convert_type_warn (a1, &ts, 2, 0);
3400 591 : gfc_convert_type_warn (a2, &ts, 2, 0);
3401 591 : gfc_convert_type_warn (b2, &ts, 2, 0);
3402 :
3403 591 : m1 = get_operand (INTRINSIC_TIMES, a1, a2);
3404 591 : m2 = get_operand (INTRINSIC_TIMES, m1, b2);
3405 :
3406 591 : cond = build_logical_expr (INTRINSIC_LE, m2, inline_limit);
3407 591 : gfc_simplify_expr (cond, 0);
3408 :
3409 591 : else_2 = XCNEW (gfc_code);
3410 591 : else_2->op = EXEC_IF;
3411 591 : else_2->loc = a->where;
3412 :
3413 591 : if_2 = XCNEW (gfc_code);
3414 591 : if_2->op = EXEC_IF;
3415 591 : if_2->expr1 = cond;
3416 591 : if_2->loc = a->where;
3417 591 : if_2->block = else_2;
3418 :
3419 591 : if_1 = XCNEW (gfc_code);
3420 591 : if_1->op = EXEC_IF;
3421 591 : if_1->block = if_2;
3422 591 : if_1->loc = a->where;
3423 :
3424 591 : return if_1;
3425 : }
3426 :
3427 :
3428 : /* Insert code to issue a runtime error if the expressions are not equal. */
3429 :
3430 : static gfc_code *
3431 393 : runtime_error_ne (gfc_expr *e1, gfc_expr *e2, const char *msg)
3432 : {
3433 393 : gfc_expr *cond;
3434 393 : gfc_code *if_1, *if_2;
3435 393 : gfc_code *c;
3436 393 : gfc_actual_arglist *a1, *a2, *a3;
3437 :
3438 393 : gcc_assert (GFC_LOCUS_IS_SET (e1->where));
3439 : /* Build the call to runtime_error. */
3440 393 : c = XCNEW (gfc_code);
3441 393 : c->op = EXEC_CALL;
3442 393 : c->loc = e1->where;
3443 :
3444 : /* Get a null-terminated message string. */
3445 :
3446 393 : a1 = gfc_get_actual_arglist ();
3447 786 : a1->expr = gfc_get_character_expr (gfc_default_character_kind, &e1->where,
3448 393 : msg, strlen(msg)+1);
3449 393 : c->ext.actual = a1;
3450 :
3451 : /* Pass the value of the first expression. */
3452 393 : a2 = gfc_get_actual_arglist ();
3453 393 : a2->expr = gfc_copy_expr (e1);
3454 393 : a1->next = a2;
3455 :
3456 : /* Pass the value of the second expression. */
3457 393 : a3 = gfc_get_actual_arglist ();
3458 393 : a3->expr = gfc_copy_expr (e2);
3459 393 : a2->next = a3;
3460 :
3461 393 : gfc_check_fe_runtime_error (c->ext.actual);
3462 393 : gfc_resolve_fe_runtime_error (c);
3463 :
3464 393 : if_2 = XCNEW (gfc_code);
3465 393 : if_2->op = EXEC_IF;
3466 393 : if_2->loc = e1->where;
3467 393 : if_2->next = c;
3468 :
3469 393 : if_1 = XCNEW (gfc_code);
3470 393 : if_1->op = EXEC_IF;
3471 393 : if_1->block = if_2;
3472 393 : if_1->loc = e1->where;
3473 :
3474 393 : cond = build_logical_expr (INTRINSIC_NE, e1, e2);
3475 393 : gfc_simplify_expr (cond, 0);
3476 393 : if_2->expr1 = cond;
3477 :
3478 393 : return if_1;
3479 : }
3480 :
3481 : /* Handle matrix reallocation. Caller is responsible to insert into
3482 : the code tree.
3483 :
3484 : For the two-dimensional case, build
3485 :
3486 : if (allocated(c)) then
3487 : if (size(c,1) /= size(a,1) .or. size(c,2) /= size(b,2)) then
3488 : deallocate(c)
3489 : allocate (c(size(a,1), size(b,2)))
3490 : end if
3491 : else
3492 : allocate (c(size(a,1),size(b,2)))
3493 : end if
3494 :
3495 : and for the other cases correspondingly.
3496 : */
3497 :
3498 : static gfc_code *
3499 181 : matmul_lhs_realloc (gfc_expr *c, gfc_expr *a, gfc_expr *b,
3500 : enum matrix_case m_case)
3501 : {
3502 :
3503 181 : gfc_expr *allocated, *alloc_expr;
3504 181 : gfc_code *if_alloc_1, *if_alloc_2, *if_size_1, *if_size_2;
3505 181 : gfc_code *else_alloc;
3506 181 : gfc_code *deallocate, *allocate1, *allocate_else;
3507 181 : gfc_array_ref *ar;
3508 181 : gfc_expr *cond, *ne1, *ne2;
3509 :
3510 181 : if (warn_realloc_lhs)
3511 23 : gfc_warning (OPT_Wrealloc_lhs,
3512 : "Code for reallocating the allocatable array at %L will "
3513 : "be added", &c->where);
3514 :
3515 181 : alloc_expr = gfc_copy_expr (c);
3516 :
3517 181 : ar = gfc_find_array_ref (alloc_expr);
3518 181 : gcc_assert (ar && ar->type == AR_FULL);
3519 :
3520 : /* c comes in as a full ref. Change it into a copy and make it into an
3521 : element ref so it has the right form for ALLOCATE. In the same
3522 : switch statement, also generate the size comparison for the second IF
3523 : statement. */
3524 :
3525 181 : ar->type = AR_ELEMENT;
3526 :
3527 181 : switch (m_case)
3528 : {
3529 101 : case A2B2:
3530 101 : ar->start[0] = get_array_inq_function (GFC_ISYM_SIZE, a, 1);
3531 101 : ar->start[1] = get_array_inq_function (GFC_ISYM_SIZE, b, 2);
3532 101 : ne1 = build_logical_expr (INTRINSIC_NE,
3533 : get_array_inq_function (GFC_ISYM_SIZE, c, 1),
3534 : get_array_inq_function (GFC_ISYM_SIZE, a, 1));
3535 101 : ne2 = build_logical_expr (INTRINSIC_NE,
3536 : get_array_inq_function (GFC_ISYM_SIZE, c, 2),
3537 : get_array_inq_function (GFC_ISYM_SIZE, b, 2));
3538 101 : cond = build_logical_expr (INTRINSIC_OR, ne1, ne2);
3539 101 : break;
3540 :
3541 17 : case A2B2T:
3542 17 : ar->start[0] = get_array_inq_function (GFC_ISYM_SIZE, a, 1);
3543 17 : ar->start[1] = get_array_inq_function (GFC_ISYM_SIZE, b, 1);
3544 :
3545 17 : ne1 = build_logical_expr (INTRINSIC_NE,
3546 : get_array_inq_function (GFC_ISYM_SIZE, c, 1),
3547 : get_array_inq_function (GFC_ISYM_SIZE, a, 1));
3548 17 : ne2 = build_logical_expr (INTRINSIC_NE,
3549 : get_array_inq_function (GFC_ISYM_SIZE, c, 2),
3550 : get_array_inq_function (GFC_ISYM_SIZE, b, 1));
3551 17 : cond = build_logical_expr (INTRINSIC_OR, ne1, ne2);
3552 17 : break;
3553 :
3554 4 : case A2TB2:
3555 :
3556 4 : ar->start[0] = get_array_inq_function (GFC_ISYM_SIZE, a, 2);
3557 4 : ar->start[1] = get_array_inq_function (GFC_ISYM_SIZE, b, 2);
3558 :
3559 4 : ne1 = build_logical_expr (INTRINSIC_NE,
3560 : get_array_inq_function (GFC_ISYM_SIZE, c, 1),
3561 : get_array_inq_function (GFC_ISYM_SIZE, a, 2));
3562 4 : ne2 = build_logical_expr (INTRINSIC_NE,
3563 : get_array_inq_function (GFC_ISYM_SIZE, c, 2),
3564 : get_array_inq_function (GFC_ISYM_SIZE, b, 2));
3565 4 : cond = build_logical_expr (INTRINSIC_OR, ne1, ne2);
3566 4 : break;
3567 :
3568 43 : case A2B1:
3569 43 : ar->start[0] = get_array_inq_function (GFC_ISYM_SIZE, a, 1);
3570 43 : cond = build_logical_expr (INTRINSIC_NE,
3571 : get_array_inq_function (GFC_ISYM_SIZE, c, 1),
3572 : get_array_inq_function (GFC_ISYM_SIZE, a, 1));
3573 43 : break;
3574 :
3575 16 : case A1B2:
3576 16 : ar->start[0] = get_array_inq_function (GFC_ISYM_SIZE, b, 2);
3577 16 : cond = build_logical_expr (INTRINSIC_NE,
3578 : get_array_inq_function (GFC_ISYM_SIZE, c, 1),
3579 : get_array_inq_function (GFC_ISYM_SIZE, b, 2));
3580 16 : break;
3581 :
3582 0 : case A2TB2T:
3583 : /* This can only happen for BLAS, we do not handle that case in
3584 : inline mamtul. */
3585 0 : ar->start[0] = get_array_inq_function (GFC_ISYM_SIZE, a, 2);
3586 0 : ar->start[1] = get_array_inq_function (GFC_ISYM_SIZE, b, 1);
3587 :
3588 0 : ne1 = build_logical_expr (INTRINSIC_NE,
3589 : get_array_inq_function (GFC_ISYM_SIZE, c, 1),
3590 : get_array_inq_function (GFC_ISYM_SIZE, a, 2));
3591 0 : ne2 = build_logical_expr (INTRINSIC_NE,
3592 : get_array_inq_function (GFC_ISYM_SIZE, c, 2),
3593 : get_array_inq_function (GFC_ISYM_SIZE, b, 1));
3594 :
3595 0 : cond = build_logical_expr (INTRINSIC_OR, ne1, ne2);
3596 0 : break;
3597 :
3598 0 : default:
3599 0 : gcc_unreachable();
3600 :
3601 : }
3602 :
3603 181 : gfc_simplify_expr (cond, 0);
3604 :
3605 : /* We need two identical allocate statements in two
3606 : branches of the IF statement. */
3607 :
3608 181 : allocate1 = XCNEW (gfc_code);
3609 181 : allocate1->op = EXEC_ALLOCATE;
3610 181 : allocate1->ext.alloc.list = gfc_get_alloc ();
3611 181 : allocate1->loc = c->where;
3612 181 : allocate1->ext.alloc.list->expr = gfc_copy_expr (alloc_expr);
3613 :
3614 181 : allocate_else = XCNEW (gfc_code);
3615 181 : allocate_else->op = EXEC_ALLOCATE;
3616 181 : allocate_else->ext.alloc.list = gfc_get_alloc ();
3617 181 : allocate_else->loc = c->where;
3618 181 : allocate_else->ext.alloc.list->expr = alloc_expr;
3619 :
3620 181 : allocated = gfc_build_intrinsic_call (current_ns, GFC_ISYM_ALLOCATED,
3621 : "_gfortran_allocated", c->where,
3622 : 1, gfc_copy_expr (c));
3623 :
3624 181 : deallocate = XCNEW (gfc_code);
3625 181 : deallocate->op = EXEC_DEALLOCATE;
3626 181 : deallocate->ext.alloc.list = gfc_get_alloc ();
3627 181 : deallocate->ext.alloc.list->expr = gfc_copy_expr (c);
3628 181 : deallocate->next = allocate1;
3629 181 : deallocate->loc = c->where;
3630 :
3631 181 : if_size_2 = XCNEW (gfc_code);
3632 181 : if_size_2->op = EXEC_IF;
3633 181 : if_size_2->expr1 = cond;
3634 181 : if_size_2->loc = c->where;
3635 181 : if_size_2->next = deallocate;
3636 :
3637 181 : if_size_1 = XCNEW (gfc_code);
3638 181 : if_size_1->op = EXEC_IF;
3639 181 : if_size_1->block = if_size_2;
3640 181 : if_size_1->loc = c->where;
3641 :
3642 181 : else_alloc = XCNEW (gfc_code);
3643 181 : else_alloc->op = EXEC_IF;
3644 181 : else_alloc->loc = c->where;
3645 181 : else_alloc->next = allocate_else;
3646 :
3647 181 : if_alloc_2 = XCNEW (gfc_code);
3648 181 : if_alloc_2->op = EXEC_IF;
3649 181 : if_alloc_2->expr1 = allocated;
3650 181 : if_alloc_2->loc = c->where;
3651 181 : if_alloc_2->next = if_size_1;
3652 181 : if_alloc_2->block = else_alloc;
3653 :
3654 181 : if_alloc_1 = XCNEW (gfc_code);
3655 181 : if_alloc_1->op = EXEC_IF;
3656 181 : if_alloc_1->block = if_alloc_2;
3657 181 : if_alloc_1->loc = c->where;
3658 :
3659 181 : return if_alloc_1;
3660 : }
3661 :
3662 : /* Callback function for has_function_or_op. */
3663 :
3664 : static int
3665 675 : is_function_or_op (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
3666 : void *data ATTRIBUTE_UNUSED)
3667 : {
3668 675 : if ((*e) == 0)
3669 : return 0;
3670 : else
3671 675 : return (*e)->expr_type == EXPR_FUNCTION
3672 675 : || (*e)->expr_type == EXPR_OP;
3673 : }
3674 :
3675 : /* Returns true if the expression contains a function. */
3676 :
3677 : static bool
3678 1306 : has_function_or_op (gfc_expr **e)
3679 : {
3680 1306 : if (e == NULL)
3681 : return false;
3682 : else
3683 1306 : return gfc_expr_walker (e, is_function_or_op, NULL);
3684 : }
3685 :
3686 : /* Freeze (assign to a temporary variable) a single expression. */
3687 :
3688 : static void
3689 1306 : freeze_expr (gfc_expr **ep)
3690 : {
3691 1306 : gfc_expr *ne;
3692 1306 : if (has_function_or_op (ep))
3693 : {
3694 195 : ne = create_var (*ep, "freeze");
3695 195 : *ep = ne;
3696 : }
3697 1306 : }
3698 :
3699 : /* Go through an expression's references and assign them to temporary
3700 : variables if they contain functions. This is usually done prior to
3701 : front-end scalarization to avoid multiple invocations of functions. */
3702 :
3703 : static void
3704 2019 : freeze_references (gfc_expr *e)
3705 : {
3706 2019 : gfc_ref *r;
3707 2019 : gfc_array_ref *ar;
3708 2019 : int i;
3709 :
3710 4043 : for (r=e->ref; r; r=r->next)
3711 : {
3712 2024 : if (r->type == REF_SUBSTRING)
3713 : {
3714 0 : if (r->u.ss.start != NULL)
3715 0 : freeze_expr (&r->u.ss.start);
3716 :
3717 0 : if (r->u.ss.end != NULL)
3718 0 : freeze_expr (&r->u.ss.end);
3719 : }
3720 2024 : else if (r->type == REF_ARRAY)
3721 : {
3722 2019 : ar = &r->u.ar;
3723 2019 : switch (ar->type)
3724 : {
3725 : case AR_FULL:
3726 : break;
3727 :
3728 : case AR_SECTION:
3729 700 : for (i=0; i<ar->dimen; i++)
3730 : {
3731 456 : if (ar->dimen_type[i] == DIMEN_RANGE)
3732 : {
3733 425 : freeze_expr (&ar->start[i]);
3734 425 : freeze_expr (&ar->end[i]);
3735 425 : freeze_expr (&ar->stride[i]);
3736 : }
3737 31 : else if (ar->dimen_type[i] == DIMEN_ELEMENT)
3738 : {
3739 31 : freeze_expr (&ar->start[i]);
3740 : }
3741 : }
3742 : break;
3743 :
3744 : case AR_ELEMENT:
3745 0 : for (i=0; i<ar->dimen; i++)
3746 0 : freeze_expr (&ar->start[i]);
3747 : break;
3748 :
3749 : default:
3750 : break;
3751 : }
3752 : }
3753 : }
3754 2019 : }
3755 :
3756 : /* Convert to gfc_index_integer_kind if needed, just do a copy otherwise. */
3757 :
3758 : static gfc_expr *
3759 3584 : convert_to_index_kind (gfc_expr *e)
3760 : {
3761 3584 : gfc_expr *res;
3762 :
3763 3584 : gcc_assert (e != NULL);
3764 :
3765 3584 : res = gfc_copy_expr (e);
3766 :
3767 3584 : gcc_assert (e->ts.type == BT_INTEGER);
3768 :
3769 3584 : if (res->ts.kind != gfc_index_integer_kind)
3770 : {
3771 0 : gfc_typespec ts;
3772 0 : gfc_clear_ts (&ts);
3773 0 : ts.type = BT_INTEGER;
3774 0 : ts.kind = gfc_index_integer_kind;
3775 :
3776 0 : gfc_convert_type_warn (e, &ts, 2, 0);
3777 : }
3778 :
3779 3584 : return res;
3780 : }
3781 :
3782 : /* Function to create a DO loop including creation of the
3783 : iteration variable. gfc_expr are copied.*/
3784 :
3785 : static gfc_code *
3786 1792 : create_do_loop (gfc_expr *start, gfc_expr *end, gfc_expr *step, locus *where,
3787 : gfc_namespace *ns, char *vname)
3788 : {
3789 :
3790 1792 : char name[GFC_MAX_SYMBOL_LEN +1];
3791 1792 : gfc_symtree *symtree;
3792 1792 : gfc_symbol *symbol;
3793 1792 : gfc_expr *i;
3794 1792 : gfc_code *n, *n2;
3795 :
3796 : /* Create an expression for the iteration variable. */
3797 1792 : if (vname)
3798 0 : sprintf (name, "__var_%d_do_%s", var_num++, vname);
3799 : else
3800 1792 : sprintf (name, "__var_%d_do", var_num++);
3801 :
3802 :
3803 1792 : if (gfc_get_sym_tree (name, ns, &symtree, false) != 0)
3804 0 : gcc_unreachable ();
3805 :
3806 : /* Create the loop variable. */
3807 :
3808 1792 : symbol = symtree->n.sym;
3809 1792 : symbol->ts.type = BT_INTEGER;
3810 1792 : symbol->ts.kind = gfc_index_integer_kind;
3811 1792 : symbol->attr.flavor = FL_VARIABLE;
3812 1792 : symbol->attr.referenced = 1;
3813 1792 : symbol->attr.dimension = 0;
3814 1792 : symbol->attr.fe_temp = 1;
3815 1792 : symbol->attr.automatic = 1;
3816 1792 : gfc_commit_symbol (symbol);
3817 :
3818 1792 : i = gfc_get_expr ();
3819 1792 : i->expr_type = EXPR_VARIABLE;
3820 1792 : i->ts = symbol->ts;
3821 1792 : i->rank = 0;
3822 1792 : i->where = *where;
3823 1792 : i->symtree = symtree;
3824 :
3825 : /* ... and the nested DO statements. */
3826 1792 : n = XCNEW (gfc_code);
3827 1792 : n->op = EXEC_DO;
3828 1792 : n->loc = *where;
3829 1792 : n->ext.iterator = gfc_get_iterator ();
3830 1792 : n->ext.iterator->var = i;
3831 1792 : n->ext.iterator->start = convert_to_index_kind (start);
3832 1792 : n->ext.iterator->end = convert_to_index_kind (end);
3833 1792 : if (step)
3834 0 : n->ext.iterator->step = convert_to_index_kind (step);
3835 : else
3836 1792 : n->ext.iterator->step = gfc_get_int_expr (gfc_index_integer_kind,
3837 : where, 1);
3838 :
3839 1792 : n2 = XCNEW (gfc_code);
3840 1792 : n2->op = EXEC_DO;
3841 1792 : n2->loc = *where;
3842 1792 : n2->next = NULL;
3843 1792 : n->block = n2;
3844 1792 : return n;
3845 : }
3846 :
3847 : /* Get the upper bound of the DO loops for matmul along a dimension. This
3848 : is one-based. */
3849 :
3850 : static gfc_expr*
3851 1792 : get_size_m1 (gfc_expr *e, int dimen)
3852 : {
3853 1792 : mpz_t size;
3854 1792 : gfc_expr *res;
3855 :
3856 1792 : if (gfc_array_dimen_size (e, dimen - 1, &size))
3857 : {
3858 1256 : res = gfc_get_constant_expr (BT_INTEGER,
3859 : gfc_index_integer_kind, &e->where);
3860 1256 : mpz_sub_ui (res->value.integer, size, 1);
3861 1256 : mpz_clear (size);
3862 : }
3863 : else
3864 : {
3865 536 : res = get_operand (INTRINSIC_MINUS,
3866 : get_array_inq_function (GFC_ISYM_SIZE, e, dimen),
3867 : gfc_get_int_expr (gfc_index_integer_kind,
3868 : &e->where, 1));
3869 536 : gfc_simplify_expr (res, 0);
3870 : }
3871 :
3872 1792 : return res;
3873 : }
3874 :
3875 : /* Function to return a scalarized expression. It is assumed that indices are
3876 : zero based to make generation of DO loops easier. A zero as index will
3877 : access the first element along a dimension. Single element references will
3878 : be skipped. A NULL as an expression will be replaced by a full reference.
3879 : This assumes that the index loops have gfc_index_integer_kind, and that all
3880 : references have been frozen. */
3881 :
3882 : static gfc_expr*
3883 2019 : scalarized_expr (gfc_expr *e_in, gfc_expr **index, int count_index)
3884 : {
3885 2019 : gfc_array_ref *ar;
3886 2019 : int i;
3887 2019 : int rank;
3888 2019 : gfc_expr *e;
3889 2019 : int i_index;
3890 2019 : bool was_fullref;
3891 :
3892 2019 : e = gfc_copy_expr(e_in);
3893 :
3894 2019 : rank = e->rank;
3895 :
3896 2019 : ar = gfc_find_array_ref (e);
3897 :
3898 : /* We scalarize count_index variables, reducing the rank by count_index. */
3899 :
3900 2019 : e->rank = rank - count_index;
3901 :
3902 2019 : was_fullref = ar->type == AR_FULL;
3903 :
3904 2019 : if (e->rank == 0)
3905 2019 : ar->type = AR_ELEMENT;
3906 : else
3907 0 : ar->type = AR_SECTION;
3908 :
3909 : /* Loop over the indices. For each index, create the expression
3910 : index * stride + lbound(e, dim). */
3911 :
3912 : i_index = 0;
3913 5634 : for (i=0; i < ar->dimen; i++)
3914 : {
3915 3615 : if (was_fullref || ar->dimen_type[i] == DIMEN_RANGE)
3916 : {
3917 3584 : if (index[i_index] != NULL)
3918 : {
3919 3584 : gfc_expr *lbound, *nindex;
3920 3584 : gfc_expr *loopvar;
3921 :
3922 3584 : loopvar = gfc_copy_expr (index[i_index]);
3923 :
3924 3584 : if (ar->stride[i])
3925 : {
3926 72 : gfc_expr *tmp;
3927 :
3928 72 : tmp = gfc_copy_expr(ar->stride[i]);
3929 72 : if (tmp->ts.kind != gfc_index_integer_kind)
3930 : {
3931 0 : gfc_typespec ts;
3932 0 : gfc_clear_ts (&ts);
3933 0 : ts.type = BT_INTEGER;
3934 0 : ts.kind = gfc_index_integer_kind;
3935 0 : gfc_convert_type (tmp, &ts, 2);
3936 : }
3937 72 : nindex = get_operand (INTRINSIC_TIMES, loopvar, tmp);
3938 : }
3939 : else
3940 : nindex = loopvar;
3941 :
3942 : /* Calculate the lower bound of the expression. */
3943 3584 : if (ar->start[i])
3944 : {
3945 283 : lbound = gfc_copy_expr (ar->start[i]);
3946 283 : if (lbound->ts.kind != gfc_index_integer_kind)
3947 : {
3948 283 : gfc_typespec ts;
3949 283 : gfc_clear_ts (&ts);
3950 283 : ts.type = BT_INTEGER;
3951 283 : ts.kind = gfc_index_integer_kind;
3952 283 : gfc_convert_type (lbound, &ts, 2);
3953 :
3954 : }
3955 : }
3956 : else
3957 : {
3958 3301 : gfc_expr *lbound_e;
3959 3301 : gfc_ref *ref;
3960 :
3961 3301 : lbound_e = gfc_copy_expr (e_in);
3962 :
3963 3301 : for (ref = lbound_e->ref; ref; ref = ref->next)
3964 3301 : if (ref->type == REF_ARRAY
3965 3301 : && (ref->u.ar.type == AR_FULL
3966 142 : || ref->u.ar.type == AR_SECTION))
3967 : break;
3968 :
3969 3301 : if (ref->next)
3970 : {
3971 9 : gfc_free_ref_list (ref->next);
3972 9 : ref->next = NULL;
3973 : }
3974 :
3975 3301 : if (!was_fullref)
3976 : {
3977 : /* Look at full individual sections, like a(:). The first index
3978 : is the lbound of a full ref. */
3979 142 : int j;
3980 142 : gfc_array_ref *ar;
3981 142 : int to;
3982 :
3983 142 : ar = &ref->u.ar;
3984 :
3985 : /* For assumed size, we need to keep around the final
3986 : reference in order not to get an error on resolution
3987 : below, and we cannot use AR_FULL. */
3988 :
3989 142 : if (ar->as->type == AS_ASSUMED_SIZE)
3990 : {
3991 2 : ar->type = AR_SECTION;
3992 2 : to = ar->dimen - 1;
3993 : }
3994 : else
3995 : {
3996 140 : to = ar->dimen;
3997 140 : ar->type = AR_FULL;
3998 : }
3999 :
4000 430 : for (j = 0; j < to; j++)
4001 : {
4002 288 : gfc_free_expr (ar->start[j]);
4003 288 : ar->start[j] = NULL;
4004 288 : gfc_free_expr (ar->end[j]);
4005 288 : ar->end[j] = NULL;
4006 288 : gfc_free_expr (ar->stride[j]);
4007 288 : ar->stride[j] = NULL;
4008 : }
4009 :
4010 : /* We have to get rid of the shape, if there is one. Do
4011 : so by freeing it and calling gfc_resolve to rebuild
4012 : it, if necessary. */
4013 :
4014 142 : if (lbound_e->shape)
4015 48 : gfc_free_shape (&(lbound_e->shape), lbound_e->rank);
4016 :
4017 142 : lbound_e->rank = ar->dimen;
4018 142 : gfc_resolve_expr (lbound_e);
4019 : }
4020 3301 : lbound = get_array_inq_function (GFC_ISYM_LBOUND, lbound_e,
4021 : i + 1);
4022 3301 : gfc_free_expr (lbound_e);
4023 : }
4024 :
4025 3584 : ar->dimen_type[i] = DIMEN_ELEMENT;
4026 :
4027 3584 : gfc_free_expr (ar->start[i]);
4028 3584 : ar->start[i] = get_operand (INTRINSIC_PLUS, nindex, lbound);
4029 :
4030 3584 : gfc_free_expr (ar->end[i]);
4031 3584 : ar->end[i] = NULL;
4032 3584 : gfc_free_expr (ar->stride[i]);
4033 3584 : ar->stride[i] = NULL;
4034 3584 : gfc_simplify_expr (ar->start[i], 0);
4035 : }
4036 0 : else if (was_fullref)
4037 : {
4038 0 : gfc_internal_error ("Scalarization using DIMEN_RANGE unimplemented");
4039 : }
4040 3584 : i_index ++;
4041 : }
4042 : }
4043 :
4044 : /* Bounds checking will be done before the loops if -fcheck=bounds
4045 : is in effect. */
4046 2019 : e->no_bounds_check = 1;
4047 2019 : return e;
4048 : }
4049 :
4050 : /* Helper function to check for a dimen vector as subscript. */
4051 :
4052 : bool
4053 3949 : gfc_has_dimen_vector_ref (gfc_expr *e)
4054 : {
4055 3949 : gfc_array_ref *ar;
4056 3949 : int i;
4057 :
4058 3949 : ar = gfc_find_array_ref (e);
4059 3949 : gcc_assert (ar);
4060 3949 : if (ar->type == AR_FULL)
4061 : return false;
4062 :
4063 1954 : for (i=0; i<ar->dimen; i++)
4064 1244 : if (ar->dimen_type[i] == DIMEN_VECTOR)
4065 : return true;
4066 :
4067 : return false;
4068 : }
4069 :
4070 : /* If handed an expression of the form
4071 :
4072 : TRANSPOSE(CONJG(A))
4073 :
4074 : check if A can be handled by matmul and return if there is an uneven number
4075 : of CONJG calls. Return a pointer to the array when everything is OK, NULL
4076 : otherwise. The caller has to check for the correct rank. */
4077 :
4078 : static gfc_expr*
4079 3158 : check_conjg_transpose_variable (gfc_expr *e, bool *conjg, bool *transpose)
4080 : {
4081 3158 : *conjg = false;
4082 3158 : *transpose = false;
4083 :
4084 3918 : do
4085 : {
4086 3538 : if (e->expr_type == EXPR_VARIABLE)
4087 : {
4088 3018 : gcc_assert (e->rank == 1 || e->rank == 2);
4089 : return e;
4090 : }
4091 520 : else if (e->expr_type == EXPR_FUNCTION)
4092 : {
4093 465 : if (e->value.function.isym == NULL)
4094 : return NULL;
4095 :
4096 442 : if (e->value.function.isym->id == GFC_ISYM_CONJG)
4097 68 : *conjg = !*conjg;
4098 374 : else if (e->value.function.isym->id == GFC_ISYM_TRANSPOSE)
4099 312 : *transpose = !*transpose;
4100 : else return NULL;
4101 : }
4102 : else
4103 : return NULL;
4104 :
4105 380 : e = e->value.function.actual->expr;
4106 : }
4107 : while(1);
4108 :
4109 : return NULL;
4110 : }
4111 :
4112 : /* Macros for unified error messages. */
4113 :
4114 : #define B_ERROR_1 _("Incorrect extent in argument B in MATMUL intrinsic in " \
4115 : "dimension 1: is %ld, should be %ld")
4116 :
4117 : #define C_ERROR_1 _("Array bound mismatch for dimension 1 of array " \
4118 : "(%ld/%ld)")
4119 :
4120 : #define C_ERROR_2 _("Array bound mismatch for dimension 2 of array " \
4121 : "(%ld/%ld)")
4122 :
4123 :
4124 : /* Inline assignments of the form c = matmul(a,b).
4125 : Handle only the cases currently where b and c are rank-two arrays.
4126 :
4127 : This basically translates the code to
4128 :
4129 : BLOCK
4130 : integer i,j,k
4131 : c = 0
4132 : do j=0, size(b,2)-1
4133 : do k=0, size(a, 2)-1
4134 : do i=0, size(a, 1)-1
4135 : c(i * stride(c,1) + lbound(c,1), j * stride(c,2) + lbound(c,2)) =
4136 : c(i * stride(c,1) + lbound(c,1), j * stride(c,2) + lbound(c,2)) +
4137 : a(i * stride(a,1) + lbound(a,1), k * stride(a,2) + lbound(a,2)) *
4138 : b(k * stride(b,1) + lbound(b,1), j * stride(b,2) + lbound(b,2))
4139 : end do
4140 : end do
4141 : end do
4142 : END BLOCK
4143 :
4144 : */
4145 :
4146 : static int
4147 1036603 : inline_matmul_assign (gfc_code **c, int *walk_subtrees,
4148 : void *data ATTRIBUTE_UNUSED)
4149 : {
4150 1036603 : gfc_code *co = *c;
4151 1036603 : gfc_expr *expr1, *expr2;
4152 1036603 : gfc_expr *matrix_a, *matrix_b;
4153 1036603 : gfc_actual_arglist *a, *b;
4154 1036603 : gfc_code *do_1, *do_2, *do_3, *assign_zero, *assign_matmul;
4155 1036603 : gfc_expr *zero_e;
4156 1036603 : gfc_expr *u1, *u2, *u3;
4157 1036603 : gfc_expr *list[2];
4158 1036603 : gfc_expr *ascalar, *bscalar, *cscalar;
4159 1036603 : gfc_expr *mult;
4160 1036603 : gfc_expr *var_1, *var_2, *var_3;
4161 1036603 : gfc_expr *zero;
4162 1036603 : gfc_namespace *ns;
4163 1036603 : gfc_intrinsic_op op_times, op_plus;
4164 1036603 : enum matrix_case m_case;
4165 1036603 : int i;
4166 1036603 : gfc_code *if_limit = NULL;
4167 1036603 : gfc_code **next_code_point;
4168 1036603 : bool conjg_a, conjg_b, transpose_a, transpose_b;
4169 1036603 : bool realloc_c;
4170 :
4171 1036603 : if (co->op != EXEC_ASSIGN)
4172 : return 0;
4173 :
4174 270152 : if (in_where || in_assoc_list)
4175 : return 0;
4176 :
4177 : /* The BLOCKS generated for the temporary variables and FORALL don't
4178 : mix. */
4179 269586 : if (forall_level > 0)
4180 : return 0;
4181 :
4182 : /* For now don't do anything in OpenMP workshare, it confuses
4183 : its translation, which expects only the allowed statements in there.
4184 : We should figure out how to parallelize this eventually. */
4185 267406 : if (in_omp_workshare || in_omp_atomic)
4186 : return 0;
4187 :
4188 264519 : expr1 = co->expr1;
4189 264519 : expr2 = co->expr2;
4190 264519 : if (expr2->expr_type != EXPR_FUNCTION
4191 37273 : || expr2->value.function.isym == NULL
4192 28328 : || expr2->value.function.isym->id != GFC_ISYM_MATMUL)
4193 : return 0;
4194 :
4195 692 : current_code = c;
4196 692 : inserted_block = NULL;
4197 692 : changed_statement = NULL;
4198 :
4199 692 : a = expr2->value.function.actual;
4200 692 : matrix_a = check_conjg_transpose_variable (a->expr, &conjg_a, &transpose_a);
4201 692 : if (matrix_a == NULL)
4202 : return 0;
4203 :
4204 692 : b = a->next;
4205 692 : matrix_b = check_conjg_transpose_variable (b->expr, &conjg_b, &transpose_b);
4206 692 : if (matrix_b == NULL)
4207 : return 0;
4208 :
4209 1382 : if (gfc_has_dimen_vector_ref (expr1) || gfc_has_dimen_vector_ref (matrix_a)
4210 1382 : || gfc_has_dimen_vector_ref (matrix_b))
4211 2 : return 0;
4212 :
4213 : /* We do not handle data dependencies yet. */
4214 690 : if (gfc_check_dependency (expr1, matrix_a, true)
4215 690 : || gfc_check_dependency (expr1, matrix_b, true))
4216 0 : return 0;
4217 :
4218 690 : m_case = none;
4219 690 : if (matrix_a->rank == 2)
4220 : {
4221 578 : if (transpose_a)
4222 : {
4223 43 : if (matrix_b->rank == 2 && !transpose_b)
4224 : m_case = A2TB2;
4225 : }
4226 : else
4227 : {
4228 535 : if (matrix_b->rank == 1)
4229 : m_case = A2B1;
4230 : else /* matrix_b->rank == 2 */
4231 : {
4232 415 : if (transpose_b)
4233 : m_case = A2B2T;
4234 : else
4235 339 : m_case = A2B2;
4236 : }
4237 : }
4238 : }
4239 : else /* matrix_a->rank == 1 */
4240 : {
4241 112 : if (matrix_b->rank == 2)
4242 : {
4243 112 : if (!transpose_b)
4244 : m_case = A1B2;
4245 : }
4246 : }
4247 :
4248 339 : if (m_case == none)
4249 : return 0;
4250 :
4251 : /* We only handle assignment to numeric or logical variables. */
4252 679 : switch(expr1->ts.type)
4253 : {
4254 673 : case BT_INTEGER:
4255 673 : case BT_LOGICAL:
4256 673 : case BT_REAL:
4257 673 : case BT_COMPLEX:
4258 673 : break;
4259 :
4260 : default:
4261 : return 0;
4262 : }
4263 :
4264 673 : ns = insert_block ();
4265 :
4266 : /* Assign the type of the zero expression for initializing the resulting
4267 : array, and the expression (+ and * for real, integer and complex;
4268 : .and. and .or for logical. */
4269 :
4270 673 : switch(expr1->ts.type)
4271 : {
4272 145 : case BT_INTEGER:
4273 145 : zero_e = gfc_get_int_expr (expr1->ts.kind, &expr1->where, 0);
4274 145 : op_times = INTRINSIC_TIMES;
4275 145 : op_plus = INTRINSIC_PLUS;
4276 145 : break;
4277 :
4278 15 : case BT_LOGICAL:
4279 15 : op_times = INTRINSIC_AND;
4280 15 : op_plus = INTRINSIC_OR;
4281 15 : zero_e = gfc_get_logical_expr (expr1->ts.kind, &expr1->where,
4282 : 0);
4283 15 : break;
4284 437 : case BT_REAL:
4285 437 : zero_e = gfc_get_constant_expr (BT_REAL, expr1->ts.kind,
4286 : &expr1->where);
4287 437 : mpfr_set_si (zero_e->value.real, 0, GFC_RND_MODE);
4288 437 : op_times = INTRINSIC_TIMES;
4289 437 : op_plus = INTRINSIC_PLUS;
4290 437 : break;
4291 :
4292 76 : case BT_COMPLEX:
4293 76 : zero_e = gfc_get_constant_expr (BT_COMPLEX, expr1->ts.kind,
4294 : &expr1->where);
4295 76 : mpc_set_si_si (zero_e->value.complex, 0, 0, GFC_RND_MODE);
4296 76 : op_times = INTRINSIC_TIMES;
4297 76 : op_plus = INTRINSIC_PLUS;
4298 :
4299 76 : break;
4300 :
4301 0 : default:
4302 0 : gcc_unreachable();
4303 : }
4304 :
4305 673 : current_code = &ns->code;
4306 :
4307 : /* Freeze the references, keeping track of how many temporary variables were
4308 : created. */
4309 673 : n_vars = 0;
4310 673 : freeze_references (matrix_a);
4311 673 : freeze_references (matrix_b);
4312 673 : freeze_references (expr1);
4313 :
4314 673 : if (n_vars == 0)
4315 604 : next_code_point = current_code;
4316 : else
4317 : {
4318 : next_code_point = &ns->code;
4319 264 : for (i=0; i<n_vars; i++)
4320 195 : next_code_point = &(*next_code_point)->next;
4321 : }
4322 :
4323 : /* Take care of the inline flag. If the limit check evaluates to a
4324 : constant, dead code elimination will eliminate the unneeded branch. */
4325 :
4326 673 : if (flag_inline_matmul_limit > 0
4327 673 : && (matrix_a->rank == 1 || matrix_a->rank == 2)
4328 673 : && matrix_b->rank == 2)
4329 : {
4330 553 : if_limit = inline_limit_check (matrix_a, matrix_b,
4331 : flag_inline_matmul_limit,
4332 : matrix_a->rank);
4333 :
4334 : /* Insert the original statement into the else branch. */
4335 553 : if_limit->block->block->next = co;
4336 553 : co->next = NULL;
4337 :
4338 : /* ... and the new ones go into the original one. */
4339 553 : *next_code_point = if_limit;
4340 553 : next_code_point = &if_limit->block->next;
4341 : }
4342 :
4343 673 : zero_e->no_bounds_check = 1;
4344 :
4345 673 : assign_zero = XCNEW (gfc_code);
4346 673 : assign_zero->op = EXEC_ASSIGN;
4347 673 : assign_zero->loc = co->loc;
4348 673 : assign_zero->expr1 = gfc_copy_expr (expr1);
4349 673 : assign_zero->expr1->no_bounds_check = 1;
4350 673 : assign_zero->expr2 = zero_e;
4351 :
4352 673 : realloc_c = flag_realloc_lhs && gfc_is_reallocatable_lhs (expr1);
4353 :
4354 673 : if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
4355 : {
4356 122 : gfc_code *test;
4357 122 : gfc_expr *a2, *b1, *c1, *c2, *a1, *b2;
4358 :
4359 122 : switch (m_case)
4360 : {
4361 15 : case A2B1:
4362 :
4363 15 : b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
4364 15 : a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2);
4365 15 : test = runtime_error_ne (b1, a2, B_ERROR_1);
4366 15 : *next_code_point = test;
4367 15 : next_code_point = &test->next;
4368 :
4369 15 : if (!realloc_c)
4370 : {
4371 11 : c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1);
4372 11 : a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1);
4373 11 : test = runtime_error_ne (c1, a1, C_ERROR_1);
4374 11 : *next_code_point = test;
4375 11 : next_code_point = &test->next;
4376 : }
4377 : break;
4378 :
4379 16 : case A1B2:
4380 :
4381 16 : b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
4382 16 : a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1);
4383 16 : test = runtime_error_ne (b1, a1, B_ERROR_1);
4384 16 : *next_code_point = test;
4385 16 : next_code_point = &test->next;
4386 :
4387 16 : if (!realloc_c)
4388 : {
4389 11 : c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1);
4390 11 : b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2);
4391 11 : test = runtime_error_ne (c1, b2, C_ERROR_1);
4392 11 : *next_code_point = test;
4393 11 : next_code_point = &test->next;
4394 : }
4395 : break;
4396 :
4397 34 : case A2B2:
4398 :
4399 34 : b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
4400 34 : a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2);
4401 34 : test = runtime_error_ne (b1, a2, B_ERROR_1);
4402 34 : *next_code_point = test;
4403 34 : next_code_point = &test->next;
4404 :
4405 34 : if (!realloc_c)
4406 : {
4407 27 : c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1);
4408 27 : a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1);
4409 27 : test = runtime_error_ne (c1, a1, C_ERROR_1);
4410 27 : *next_code_point = test;
4411 27 : next_code_point = &test->next;
4412 :
4413 27 : c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2);
4414 27 : b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2);
4415 27 : test = runtime_error_ne (c2, b2, C_ERROR_2);
4416 27 : *next_code_point = test;
4417 27 : next_code_point = &test->next;
4418 : }
4419 : break;
4420 :
4421 44 : case A2B2T:
4422 :
4423 44 : b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2);
4424 44 : a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2);
4425 : /* matrix_b is transposed, hence dimension 1 for the error message. */
4426 44 : test = runtime_error_ne (b2, a2, B_ERROR_1);
4427 44 : *next_code_point = test;
4428 44 : next_code_point = &test->next;
4429 :
4430 44 : if (!realloc_c)
4431 : {
4432 39 : c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1);
4433 39 : a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1);
4434 39 : test = runtime_error_ne (c1, a1, C_ERROR_1);
4435 39 : *next_code_point = test;
4436 39 : next_code_point = &test->next;
4437 :
4438 39 : c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2);
4439 39 : b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
4440 39 : test = runtime_error_ne (c2, b1, C_ERROR_2);
4441 39 : *next_code_point = test;
4442 39 : next_code_point = &test->next;
4443 : }
4444 : break;
4445 :
4446 13 : case A2TB2:
4447 :
4448 13 : b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
4449 13 : a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1);
4450 13 : test = runtime_error_ne (b1, a1, B_ERROR_1);
4451 13 : *next_code_point = test;
4452 13 : next_code_point = &test->next;
4453 :
4454 13 : if (!realloc_c)
4455 : {
4456 12 : c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1);
4457 12 : a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2);
4458 12 : test = runtime_error_ne (c1, a2, C_ERROR_1);
4459 12 : *next_code_point = test;
4460 12 : next_code_point = &test->next;
4461 :
4462 12 : c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2);
4463 12 : b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2);
4464 12 : test = runtime_error_ne (c2, b2, C_ERROR_2);
4465 12 : *next_code_point = test;
4466 12 : next_code_point = &test->next;
4467 : }
4468 : break;
4469 :
4470 : default:
4471 : gcc_unreachable ();
4472 : }
4473 : }
4474 :
4475 : /* Handle the reallocation, if needed. */
4476 :
4477 651 : if (realloc_c)
4478 : {
4479 175 : gfc_code *lhs_alloc;
4480 :
4481 175 : lhs_alloc = matmul_lhs_realloc (expr1, matrix_a, matrix_b, m_case);
4482 :
4483 175 : *next_code_point = lhs_alloc;
4484 175 : next_code_point = &lhs_alloc->next;
4485 :
4486 : }
4487 :
4488 673 : *next_code_point = assign_zero;
4489 :
4490 673 : zero = gfc_get_int_expr (gfc_index_integer_kind, &co->loc, 0);
4491 :
4492 673 : assign_matmul = XCNEW (gfc_code);
4493 673 : assign_matmul->op = EXEC_ASSIGN;
4494 673 : assign_matmul->loc = co->loc;
4495 :
4496 : /* Get the bounds for the loops, create them and create the scalarized
4497 : expressions. */
4498 :
4499 673 : switch (m_case)
4500 : {
4501 333 : case A2B2:
4502 :
4503 333 : u1 = get_size_m1 (matrix_b, 2);
4504 333 : u2 = get_size_m1 (matrix_a, 2);
4505 333 : u3 = get_size_m1 (matrix_a, 1);
4506 :
4507 333 : do_1 = create_do_loop (gfc_copy_expr (zero), u1, NULL, &co->loc, ns);
4508 333 : do_2 = create_do_loop (gfc_copy_expr (zero), u2, NULL, &co->loc, ns);
4509 333 : do_3 = create_do_loop (gfc_copy_expr (zero), u3, NULL, &co->loc, ns);
4510 :
4511 333 : do_1->block->next = do_2;
4512 333 : do_2->block->next = do_3;
4513 333 : do_3->block->next = assign_matmul;
4514 :
4515 333 : var_1 = do_1->ext.iterator->var;
4516 333 : var_2 = do_2->ext.iterator->var;
4517 333 : var_3 = do_3->ext.iterator->var;
4518 :
4519 333 : list[0] = var_3;
4520 333 : list[1] = var_1;
4521 333 : cscalar = scalarized_expr (co->expr1, list, 2);
4522 :
4523 333 : list[0] = var_3;
4524 333 : list[1] = var_2;
4525 333 : ascalar = scalarized_expr (matrix_a, list, 2);
4526 :
4527 333 : list[0] = var_2;
4528 333 : list[1] = var_1;
4529 333 : bscalar = scalarized_expr (matrix_b, list, 2);
4530 :
4531 333 : break;
4532 :
4533 76 : case A2B2T:
4534 :
4535 76 : u1 = get_size_m1 (matrix_b, 1);
4536 76 : u2 = get_size_m1 (matrix_a, 2);
4537 76 : u3 = get_size_m1 (matrix_a, 1);
4538 :
4539 76 : do_1 = create_do_loop (gfc_copy_expr (zero), u1, NULL, &co->loc, ns);
4540 76 : do_2 = create_do_loop (gfc_copy_expr (zero), u2, NULL, &co->loc, ns);
4541 76 : do_3 = create_do_loop (gfc_copy_expr (zero), u3, NULL, &co->loc, ns);
4542 :
4543 76 : do_1->block->next = do_2;
4544 76 : do_2->block->next = do_3;
4545 76 : do_3->block->next = assign_matmul;
4546 :
4547 76 : var_1 = do_1->ext.iterator->var;
4548 76 : var_2 = do_2->ext.iterator->var;
4549 76 : var_3 = do_3->ext.iterator->var;
4550 :
4551 76 : list[0] = var_3;
4552 76 : list[1] = var_1;
4553 76 : cscalar = scalarized_expr (co->expr1, list, 2);
4554 :
4555 76 : list[0] = var_3;
4556 76 : list[1] = var_2;
4557 76 : ascalar = scalarized_expr (matrix_a, list, 2);
4558 :
4559 76 : list[0] = var_1;
4560 76 : list[1] = var_2;
4561 76 : bscalar = scalarized_expr (matrix_b, list, 2);
4562 :
4563 76 : break;
4564 :
4565 37 : case A2TB2:
4566 :
4567 37 : u1 = get_size_m1 (matrix_a, 2);
4568 37 : u2 = get_size_m1 (matrix_b, 2);
4569 37 : u3 = get_size_m1 (matrix_a, 1);
4570 :
4571 37 : do_1 = create_do_loop (gfc_copy_expr (zero), u1, NULL, &co->loc, ns);
4572 37 : do_2 = create_do_loop (gfc_copy_expr (zero), u2, NULL, &co->loc, ns);
4573 37 : do_3 = create_do_loop (gfc_copy_expr (zero), u3, NULL, &co->loc, ns);
4574 :
4575 37 : do_1->block->next = do_2;
4576 37 : do_2->block->next = do_3;
4577 37 : do_3->block->next = assign_matmul;
4578 :
4579 37 : var_1 = do_1->ext.iterator->var;
4580 37 : var_2 = do_2->ext.iterator->var;
4581 37 : var_3 = do_3->ext.iterator->var;
4582 :
4583 37 : list[0] = var_1;
4584 37 : list[1] = var_2;
4585 37 : cscalar = scalarized_expr (co->expr1, list, 2);
4586 :
4587 37 : list[0] = var_3;
4588 37 : list[1] = var_1;
4589 37 : ascalar = scalarized_expr (matrix_a, list, 2);
4590 :
4591 37 : list[0] = var_3;
4592 37 : list[1] = var_2;
4593 37 : bscalar = scalarized_expr (matrix_b, list, 2);
4594 :
4595 37 : break;
4596 :
4597 120 : case A2B1:
4598 120 : u1 = get_size_m1 (matrix_b, 1);
4599 120 : u2 = get_size_m1 (matrix_a, 1);
4600 :
4601 120 : do_1 = create_do_loop (gfc_copy_expr (zero), u1, NULL, &co->loc, ns);
4602 120 : do_2 = create_do_loop (gfc_copy_expr (zero), u2, NULL, &co->loc, ns);
4603 :
4604 120 : do_1->block->next = do_2;
4605 120 : do_2->block->next = assign_matmul;
4606 :
4607 120 : var_1 = do_1->ext.iterator->var;
4608 120 : var_2 = do_2->ext.iterator->var;
4609 :
4610 120 : list[0] = var_2;
4611 120 : cscalar = scalarized_expr (co->expr1, list, 1);
4612 :
4613 120 : list[0] = var_2;
4614 120 : list[1] = var_1;
4615 120 : ascalar = scalarized_expr (matrix_a, list, 2);
4616 :
4617 120 : list[0] = var_1;
4618 120 : bscalar = scalarized_expr (matrix_b, list, 1);
4619 :
4620 120 : break;
4621 :
4622 107 : case A1B2:
4623 107 : u1 = get_size_m1 (matrix_b, 2);
4624 107 : u2 = get_size_m1 (matrix_a, 1);
4625 :
4626 107 : do_1 = create_do_loop (gfc_copy_expr (zero), u1, NULL, &co->loc, ns);
4627 107 : do_2 = create_do_loop (gfc_copy_expr (zero), u2, NULL, &co->loc, ns);
4628 :
4629 107 : do_1->block->next = do_2;
4630 107 : do_2->block->next = assign_matmul;
4631 :
4632 107 : var_1 = do_1->ext.iterator->var;
4633 107 : var_2 = do_2->ext.iterator->var;
4634 :
4635 107 : list[0] = var_1;
4636 107 : cscalar = scalarized_expr (co->expr1, list, 1);
4637 :
4638 107 : list[0] = var_2;
4639 107 : ascalar = scalarized_expr (matrix_a, list, 1);
4640 :
4641 107 : list[0] = var_2;
4642 107 : list[1] = var_1;
4643 107 : bscalar = scalarized_expr (matrix_b, list, 2);
4644 :
4645 107 : break;
4646 :
4647 : default:
4648 : gcc_unreachable();
4649 : }
4650 :
4651 : /* Build the conjg call around the variables. Set the typespec manually
4652 : because gfc_build_intrinsic_call sometimes gets this wrong. */
4653 673 : if (conjg_a)
4654 : {
4655 16 : gfc_typespec ts;
4656 16 : ts = matrix_a->ts;
4657 16 : ascalar = gfc_build_intrinsic_call (ns, GFC_ISYM_CONJG, "conjg",
4658 : matrix_a->where, 1, ascalar);
4659 16 : ascalar->ts = ts;
4660 : }
4661 :
4662 673 : if (conjg_b)
4663 : {
4664 8 : gfc_typespec ts;
4665 8 : ts = matrix_b->ts;
4666 8 : bscalar = gfc_build_intrinsic_call (ns, GFC_ISYM_CONJG, "conjg",
4667 : matrix_b->where, 1, bscalar);
4668 8 : bscalar->ts = ts;
4669 : }
4670 : /* First loop comes after the zero assignment. */
4671 673 : assign_zero->next = do_1;
4672 :
4673 : /* Build the assignment expression in the loop. */
4674 673 : assign_matmul->expr1 = gfc_copy_expr (cscalar);
4675 :
4676 673 : mult = get_operand (op_times, ascalar, bscalar);
4677 673 : assign_matmul->expr2 = get_operand (op_plus, cscalar, mult);
4678 :
4679 : /* If we don't want to keep the original statement around in
4680 : the else branch, we can free it. */
4681 :
4682 673 : if (if_limit == NULL)
4683 120 : gfc_free_statements(co);
4684 : else
4685 553 : co->next = NULL;
4686 :
4687 673 : gfc_free_expr (zero);
4688 673 : *walk_subtrees = 0;
4689 673 : return 0;
4690 : }
4691 :
4692 : /* Change matmul function calls in the form of
4693 :
4694 : c = matmul(a,b)
4695 :
4696 : to the corresponding call to a BLAS routine, if applicable. */
4697 :
4698 : static int
4699 2806 : call_external_blas (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
4700 : void *data ATTRIBUTE_UNUSED)
4701 : {
4702 2806 : gfc_code *co, *co_next;
4703 2806 : gfc_expr *expr1, *expr2;
4704 2806 : gfc_expr *matrix_a, *matrix_b;
4705 2806 : gfc_code *if_limit = NULL;
4706 2806 : gfc_actual_arglist *a, *b;
4707 2806 : bool conjg_a, conjg_b, transpose_a, transpose_b;
4708 2806 : gfc_code *call;
4709 2806 : const char *blas_name;
4710 2806 : const char *transa, *transb;
4711 2806 : gfc_expr *c1, *c2, *b1;
4712 2806 : gfc_actual_arglist *actual, *next;
4713 2806 : bt type;
4714 2806 : int kind;
4715 2806 : enum matrix_case m_case;
4716 2806 : bool realloc_c;
4717 2806 : gfc_code **next_code_point;
4718 2806 : int arg_kind;
4719 :
4720 : /* Many of the tests for inline matmul also apply here. */
4721 :
4722 2806 : co = *c;
4723 :
4724 2806 : if (co->op != EXEC_ASSIGN)
4725 : return 0;
4726 :
4727 910 : if (in_where || in_assoc_list)
4728 : return 0;
4729 :
4730 : /* The BLOCKS generated for the temporary variables and FORALL don't
4731 : mix. */
4732 910 : if (forall_level > 0)
4733 : return 0;
4734 :
4735 : /* For now don't do anything in OpenMP workshare, it confuses
4736 : its translation, which expects only the allowed statements in there. */
4737 :
4738 910 : if (in_omp_workshare || in_omp_atomic)
4739 : return 0;
4740 :
4741 910 : expr1 = co->expr1;
4742 910 : expr2 = co->expr2;
4743 910 : if (expr2->expr_type != EXPR_FUNCTION
4744 156 : || expr2->value.function.isym == NULL
4745 108 : || expr2->value.function.isym->id != GFC_ISYM_MATMUL)
4746 : return 0;
4747 :
4748 76 : type = expr2->ts.type;
4749 76 : kind = expr2->ts.kind;
4750 :
4751 : /* Guard against recursion. */
4752 :
4753 76 : if (expr2->external_blas)
4754 : return 0;
4755 :
4756 38 : if (type != expr1->ts.type || kind != expr1->ts.kind)
4757 : return 0;
4758 :
4759 38 : if (type == BT_REAL)
4760 : {
4761 18 : if (kind == 4)
4762 : blas_name = "sgemm";
4763 7 : else if (kind == 8)
4764 : blas_name = "dgemm";
4765 : else
4766 : return 0;
4767 : }
4768 20 : else if (type == BT_COMPLEX)
4769 : {
4770 20 : if (kind == 4)
4771 : blas_name = "cgemm";
4772 10 : else if (kind == 8)
4773 : blas_name = "zgemm";
4774 : else
4775 : return 0;
4776 : }
4777 : else
4778 : return 0;
4779 :
4780 38 : a = expr2->value.function.actual;
4781 38 : if (a->expr->rank != 2)
4782 : return 0;
4783 :
4784 38 : b = a->next;
4785 38 : if (b->expr->rank != 2)
4786 : return 0;
4787 :
4788 38 : matrix_a = check_conjg_transpose_variable (a->expr, &conjg_a, &transpose_a);
4789 38 : if (matrix_a == NULL)
4790 : return 0;
4791 :
4792 38 : if (transpose_a)
4793 : {
4794 13 : if (conjg_a)
4795 : transa = "C";
4796 : else
4797 9 : transa = "T";
4798 : }
4799 : else
4800 : transa = "N";
4801 :
4802 38 : matrix_b = check_conjg_transpose_variable (b->expr, &conjg_b, &transpose_b);
4803 38 : if (matrix_b == NULL)
4804 : return 0;
4805 :
4806 38 : if (transpose_b)
4807 : {
4808 12 : if (conjg_b)
4809 : transb = "C";
4810 : else
4811 8 : transb = "T";
4812 : }
4813 : else
4814 : transb = "N";
4815 :
4816 38 : if (transpose_a)
4817 : {
4818 13 : if (transpose_b)
4819 : m_case = A2TB2T;
4820 : else
4821 13 : m_case = A2TB2;
4822 : }
4823 : else
4824 : {
4825 25 : if (transpose_b)
4826 : m_case = A2B2T;
4827 : else
4828 13 : m_case = A2B2;
4829 : }
4830 :
4831 38 : current_code = c;
4832 38 : inserted_block = NULL;
4833 38 : changed_statement = NULL;
4834 :
4835 38 : expr2->external_blas = 1;
4836 :
4837 : /* We do not handle data dependencies yet. */
4838 38 : if (gfc_check_dependency (expr1, matrix_a, true)
4839 38 : || gfc_check_dependency (expr1, matrix_b, true))
4840 0 : return 0;
4841 :
4842 : /* Generate the if statement and hang it into the tree. */
4843 38 : if_limit = inline_limit_check (matrix_a, matrix_b, flag_blas_matmul_limit, 2);
4844 38 : co_next = co->next;
4845 38 : (*current_code) = if_limit;
4846 38 : co->next = NULL;
4847 38 : if_limit->block->next = co;
4848 :
4849 38 : call = XCNEW (gfc_code);
4850 38 : call->loc = co->loc;
4851 :
4852 : /* Bounds checking - a bit simpler than for inlining since we only
4853 : have to take care of two-dimensional arrays here. */
4854 :
4855 38 : realloc_c = flag_realloc_lhs && gfc_is_reallocatable_lhs (expr1);
4856 38 : next_code_point = &(if_limit->block->block->next);
4857 :
4858 38 : if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
4859 : {
4860 35 : gfc_code *test;
4861 : // gfc_expr *a2, *b1, *c1, *c2, *a1, *b2;
4862 35 : gfc_expr *c1, *a1, *c2, *b2, *a2;
4863 35 : switch (m_case)
4864 : {
4865 10 : case A2B2:
4866 10 : b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
4867 10 : a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2);
4868 10 : test = runtime_error_ne (b1, a2, B_ERROR_1);
4869 10 : *next_code_point = test;
4870 10 : next_code_point = &test->next;
4871 :
4872 10 : if (!realloc_c)
4873 : {
4874 5 : c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1);
4875 5 : a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1);
4876 5 : test = runtime_error_ne (c1, a1, C_ERROR_1);
4877 5 : *next_code_point = test;
4878 5 : next_code_point = &test->next;
4879 :
4880 5 : c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2);
4881 5 : b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2);
4882 5 : test = runtime_error_ne (c2, b2, C_ERROR_2);
4883 5 : *next_code_point = test;
4884 5 : next_code_point = &test->next;
4885 : }
4886 : break;
4887 :
4888 12 : case A2B2T:
4889 :
4890 12 : b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2);
4891 12 : a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2);
4892 : /* matrix_b is transposed, hence dimension 1 for the error message. */
4893 12 : test = runtime_error_ne (b2, a2, B_ERROR_1);
4894 12 : *next_code_point = test;
4895 12 : next_code_point = &test->next;
4896 :
4897 12 : if (!realloc_c)
4898 : {
4899 12 : c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1);
4900 12 : a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1);
4901 12 : test = runtime_error_ne (c1, a1, C_ERROR_1);
4902 12 : *next_code_point = test;
4903 12 : next_code_point = &test->next;
4904 :
4905 12 : c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2);
4906 12 : b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
4907 12 : test = runtime_error_ne (c2, b1, C_ERROR_2);
4908 12 : *next_code_point = test;
4909 12 : next_code_point = &test->next;
4910 : }
4911 : break;
4912 :
4913 13 : case A2TB2:
4914 :
4915 13 : b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
4916 13 : a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1);
4917 13 : test = runtime_error_ne (b1, a1, B_ERROR_1);
4918 13 : *next_code_point = test;
4919 13 : next_code_point = &test->next;
4920 :
4921 13 : if (!realloc_c)
4922 : {
4923 12 : c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1);
4924 12 : a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2);
4925 12 : test = runtime_error_ne (c1, a2, C_ERROR_1);
4926 12 : *next_code_point = test;
4927 12 : next_code_point = &test->next;
4928 :
4929 12 : c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2);
4930 12 : b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2);
4931 12 : test = runtime_error_ne (c2, b2, C_ERROR_2);
4932 12 : *next_code_point = test;
4933 12 : next_code_point = &test->next;
4934 : }
4935 : break;
4936 :
4937 0 : case A2TB2T:
4938 0 : b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2);
4939 0 : a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1);
4940 0 : test = runtime_error_ne (b2, a1, B_ERROR_1);
4941 0 : *next_code_point = test;
4942 0 : next_code_point = &test->next;
4943 :
4944 0 : if (!realloc_c)
4945 : {
4946 0 : c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1);
4947 0 : a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2);
4948 0 : test = runtime_error_ne (c1, a2, C_ERROR_1);
4949 0 : *next_code_point = test;
4950 0 : next_code_point = &test->next;
4951 :
4952 0 : c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2);
4953 0 : b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
4954 0 : test = runtime_error_ne (c2, b1, C_ERROR_2);
4955 0 : *next_code_point = test;
4956 0 : next_code_point = &test->next;
4957 : }
4958 : break;
4959 :
4960 0 : default:
4961 0 : gcc_unreachable ();
4962 : }
4963 : }
4964 :
4965 : /* Handle the reallocation, if needed. */
4966 :
4967 32 : if (realloc_c)
4968 : {
4969 6 : gfc_code *lhs_alloc;
4970 :
4971 6 : lhs_alloc = matmul_lhs_realloc (expr1, matrix_a, matrix_b, m_case);
4972 6 : *next_code_point = lhs_alloc;
4973 6 : next_code_point = &lhs_alloc->next;
4974 : }
4975 :
4976 38 : *next_code_point = call;
4977 38 : if_limit->next = co_next;
4978 :
4979 : /* Set up the BLAS call. */
4980 :
4981 38 : call->op = EXEC_CALL;
4982 :
4983 38 : gfc_get_sym_tree (blas_name, current_ns, &(call->symtree), true);
4984 38 : call->symtree->n.sym->attr.subroutine = 1;
4985 38 : call->symtree->n.sym->attr.procedure = 1;
4986 38 : call->symtree->n.sym->attr.flavor = FL_PROCEDURE;
4987 38 : call->resolved_sym = call->symtree->n.sym;
4988 38 : gfc_commit_symbol (call->resolved_sym);
4989 :
4990 : /* Argument TRANSA. */
4991 38 : next = gfc_get_actual_arglist ();
4992 38 : next->expr = gfc_get_character_expr (gfc_default_character_kind, &co->loc,
4993 : transa, 1);
4994 :
4995 38 : call->ext.actual = next;
4996 :
4997 : /* Argument TRANSB. */
4998 38 : actual = next;
4999 38 : next = gfc_get_actual_arglist ();
5000 38 : next->expr = gfc_get_character_expr (gfc_default_character_kind, &co->loc,
5001 : transb, 1);
5002 38 : actual->next = next;
5003 :
5004 38 : if (flag_external_blas)
5005 : arg_kind = gfc_integer_4_kind;
5006 : else
5007 : {
5008 1 : gcc_assert (flag_external_blas64);
5009 : arg_kind = gfc_integer_8_kind;
5010 : }
5011 :
5012 38 : c1 = get_array_inq_function (GFC_ISYM_SIZE, gfc_copy_expr (a->expr), 1,
5013 : arg_kind);
5014 38 : c2 = get_array_inq_function (GFC_ISYM_SIZE, gfc_copy_expr (b->expr), 2,
5015 : arg_kind);
5016 38 : b1 = get_array_inq_function (GFC_ISYM_SIZE, gfc_copy_expr (b->expr), 1,
5017 : arg_kind);
5018 :
5019 : /* Argument M. */
5020 38 : actual = next;
5021 38 : next = gfc_get_actual_arglist ();
5022 38 : next->expr = c1;
5023 38 : actual->next = next;
5024 :
5025 : /* Argument N. */
5026 38 : actual = next;
5027 38 : next = gfc_get_actual_arglist ();
5028 38 : next->expr = c2;
5029 38 : actual->next = next;
5030 :
5031 : /* Argument K. */
5032 38 : actual = next;
5033 38 : next = gfc_get_actual_arglist ();
5034 38 : next->expr = b1;
5035 38 : actual->next = next;
5036 :
5037 : /* Argument ALPHA - set to one. */
5038 38 : actual = next;
5039 38 : next = gfc_get_actual_arglist ();
5040 38 : next->expr = gfc_get_constant_expr (type, kind, &co->loc);
5041 38 : if (type == BT_REAL)
5042 18 : mpfr_set_ui (next->expr->value.real, 1, GFC_RND_MODE);
5043 : else
5044 20 : mpc_set_ui (next->expr->value.complex, 1, GFC_MPC_RND_MODE);
5045 38 : actual->next = next;
5046 :
5047 : /* Argument A. */
5048 38 : actual = next;
5049 38 : next = gfc_get_actual_arglist ();
5050 38 : next->expr = gfc_copy_expr (matrix_a);
5051 38 : actual->next = next;
5052 :
5053 : /* Argument LDA. */
5054 38 : actual = next;
5055 38 : next = gfc_get_actual_arglist ();
5056 38 : next->expr = get_array_inq_function (GFC_ISYM_SIZE, gfc_copy_expr (matrix_a),
5057 : 1, arg_kind);
5058 38 : actual->next = next;
5059 :
5060 : /* Argument B. */
5061 38 : actual = next;
5062 38 : next = gfc_get_actual_arglist ();
5063 38 : next->expr = gfc_copy_expr (matrix_b);
5064 38 : actual->next = next;
5065 :
5066 : /* Argument LDB. */
5067 38 : actual = next;
5068 38 : next = gfc_get_actual_arglist ();
5069 38 : next->expr = get_array_inq_function (GFC_ISYM_SIZE, gfc_copy_expr (matrix_b),
5070 : 1, arg_kind);
5071 38 : actual->next = next;
5072 :
5073 : /* Argument BETA - set to zero. */
5074 38 : actual = next;
5075 38 : next = gfc_get_actual_arglist ();
5076 38 : next->expr = gfc_get_constant_expr (type, kind, &co->loc);
5077 38 : if (type == BT_REAL)
5078 18 : mpfr_set_ui (next->expr->value.real, 0, GFC_RND_MODE);
5079 : else
5080 20 : mpc_set_ui (next->expr->value.complex, 0, GFC_MPC_RND_MODE);
5081 38 : actual->next = next;
5082 :
5083 : /* Argument C. */
5084 :
5085 38 : actual = next;
5086 38 : next = gfc_get_actual_arglist ();
5087 38 : next->expr = gfc_copy_expr (expr1);
5088 38 : actual->next = next;
5089 :
5090 : /* Argument LDC. */
5091 38 : actual = next;
5092 38 : next = gfc_get_actual_arglist ();
5093 38 : next->expr = get_array_inq_function (GFC_ISYM_SIZE, gfc_copy_expr (expr1),
5094 : 1, arg_kind);
5095 38 : actual->next = next;
5096 :
5097 38 : return 0;
5098 : }
5099 :
5100 :
5101 : /* Code for index interchange for loops which are grouped together in DO
5102 : CONCURRENT or FORALL statements. This is currently only applied if the
5103 : iterations are grouped together in a single statement.
5104 :
5105 : For this transformation, it is assumed that memory access in strides is
5106 : expensive, and that loops which access later indices (which access memory
5107 : in bigger strides) should be moved to the first loops.
5108 :
5109 : For this, a loop over all the statements is executed, counting the times
5110 : that the loop iteration values are accessed in each index. The loop
5111 : indices are then sorted to minimize access to later indices from inner
5112 : loops. */
5113 :
5114 : /* Type for holding index information. */
5115 :
5116 : typedef struct {
5117 : gfc_symbol *sym;
5118 : gfc_forall_iterator *fa;
5119 : int num;
5120 : int n[GFC_MAX_DIMENSIONS];
5121 : } ind_type;
5122 :
5123 : /* Callback function to determine if an expression is the
5124 : corresponding variable. */
5125 :
5126 : static int
5127 293806 : has_var (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, void *data)
5128 : {
5129 293806 : gfc_expr *expr = *e;
5130 293806 : gfc_symbol *sym;
5131 :
5132 293806 : if (expr->expr_type != EXPR_VARIABLE)
5133 : return 0;
5134 :
5135 224934 : sym = (gfc_symbol *) data;
5136 224934 : return sym == expr->symtree->n.sym;
5137 : }
5138 :
5139 : /* Callback function to calculate the cost of a certain index. */
5140 :
5141 : static int
5142 1119092 : index_cost (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
5143 : void *data)
5144 : {
5145 1119092 : ind_type *ind;
5146 1119092 : gfc_expr *expr;
5147 1119092 : gfc_array_ref *ar;
5148 1119092 : gfc_ref *ref;
5149 1119092 : int i,j;
5150 :
5151 1119092 : expr = *e;
5152 1119092 : if (expr->expr_type != EXPR_VARIABLE)
5153 : return 0;
5154 :
5155 474408 : ar = NULL;
5156 501198 : for (ref = expr->ref; ref; ref = ref->next)
5157 : {
5158 86561 : if (ref->type == REF_ARRAY)
5159 : {
5160 59771 : ar = &ref->u.ar;
5161 59771 : break;
5162 : }
5163 : }
5164 59771 : if (ar == NULL || ar->type != AR_ELEMENT)
5165 : return 0;
5166 :
5167 : ind = (ind_type *) data;
5168 128311 : for (i = 0; i < ar->dimen; i++)
5169 : {
5170 324142 : for (j=0; ind[j].sym != NULL; j++)
5171 : {
5172 232546 : if (gfc_expr_walker (&ar->start[i], has_var, (void *) (ind[j].sym)))
5173 75654 : ind[j].n[i]++;
5174 : }
5175 : }
5176 : return 0;
5177 : }
5178 :
5179 : /* Callback function for qsort, to sort the loop indices. */
5180 :
5181 : static int
5182 13502 : loop_comp (const void *e1, const void *e2)
5183 : {
5184 13502 : const ind_type *i1 = (const ind_type *) e1;
5185 13502 : const ind_type *i2 = (const ind_type *) e2;
5186 13502 : int i;
5187 :
5188 179826 : for (i=GFC_MAX_DIMENSIONS-1; i >= 0; i--)
5189 : {
5190 179262 : if (i1->n[i] != i2->n[i])
5191 12938 : return i1->n[i] - i2->n[i];
5192 : }
5193 : /* All other things being equal, let's not change the ordering. */
5194 564 : return i2->num - i1->num;
5195 : }
5196 :
5197 : /* Main function to do the index interchange. */
5198 :
5199 : static int
5200 1044117 : index_interchange (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
5201 : void *data ATTRIBUTE_UNUSED)
5202 : {
5203 1044117 : gfc_code *co;
5204 1044117 : co = *c;
5205 1044117 : int n_iter;
5206 1044117 : gfc_forall_iterator *fa;
5207 1044117 : ind_type *ind;
5208 1044117 : int i, j;
5209 :
5210 1044117 : if (co->op != EXEC_FORALL && co->op != EXEC_DO_CONCURRENT)
5211 : return 0;
5212 :
5213 2451 : n_iter = 0;
5214 7472 : for (fa = co->ext.concur.forall_iterator; fa; fa = fa->next)
5215 5021 : n_iter ++;
5216 :
5217 : /* Nothing to reorder. */
5218 2451 : if (n_iter < 2)
5219 : return 0;
5220 :
5221 1672 : ind = XALLOCAVEC (ind_type, n_iter + 1);
5222 :
5223 1672 : i = 0;
5224 5914 : for (fa = co->ext.concur.forall_iterator; fa; fa = fa->next)
5225 : {
5226 4242 : ind[i].sym = fa->var->symtree->n.sym;
5227 4242 : ind[i].fa = fa;
5228 67872 : for (j=0; j<GFC_MAX_DIMENSIONS; j++)
5229 63630 : ind[i].n[j] = 0;
5230 4242 : ind[i].num = i;
5231 4242 : i++;
5232 : }
5233 1672 : ind[n_iter].sym = NULL;
5234 1672 : ind[n_iter].fa = NULL;
5235 :
5236 1672 : gfc_code_walker (c, gfc_dummy_code_callback, index_cost, (void *) ind);
5237 1672 : qsort ((void *) ind, n_iter, sizeof (ind_type), loop_comp);
5238 :
5239 : /* Do the actual index interchange. */
5240 1672 : co->ext.concur.forall_iterator = fa = ind[0].fa;
5241 4242 : for (i=1; i<n_iter; i++)
5242 : {
5243 2570 : fa->next = ind[i].fa;
5244 2570 : fa = fa->next;
5245 : }
5246 1672 : fa->next = NULL;
5247 :
5248 1672 : if (flag_warn_frontend_loop_interchange)
5249 : {
5250 1 : for (i=1; i<n_iter; i++)
5251 : {
5252 1 : if (ind[i-1].num > ind[i].num)
5253 : {
5254 1 : gfc_warning (OPT_Wfrontend_loop_interchange,
5255 : "Interchanging loops at %L", &co->loc);
5256 1 : break;
5257 : }
5258 : }
5259 : }
5260 :
5261 : return 0;
5262 : }
5263 :
5264 : #define WALK_SUBEXPR(NODE) \
5265 : do \
5266 : { \
5267 : result = gfc_expr_walker (&(NODE), exprfn, data); \
5268 : if (result) \
5269 : return result; \
5270 : } \
5271 : while (0)
5272 : #define WALK_SUBEXPR_TAIL(NODE) e = &(NODE); continue
5273 :
5274 : /* Walk expression *E, calling EXPRFN on each expression in it. */
5275 :
5276 : int
5277 109743872 : gfc_expr_walker (gfc_expr **e, walk_expr_fn_t exprfn, void *data)
5278 : {
5279 113939457 : while (*e)
5280 : {
5281 41054684 : int walk_subtrees = 1;
5282 41054684 : gfc_actual_arglist *a;
5283 41054684 : gfc_ref *r;
5284 41054684 : gfc_constructor *c;
5285 :
5286 41054684 : int result = exprfn (e, &walk_subtrees, data);
5287 41054684 : if (result)
5288 36859099 : return result;
5289 40978636 : if (walk_subtrees)
5290 29309293 : switch ((*e)->expr_type)
5291 : {
5292 4208212 : case EXPR_OP:
5293 4208212 : WALK_SUBEXPR ((*e)->value.op.op1);
5294 4195585 : WALK_SUBEXPR_TAIL ((*e)->value.op.op2);
5295 : /* No fallthru because of the tail recursion above. */
5296 2186101 : case EXPR_FUNCTION:
5297 6385871 : for (a = (*e)->value.function.actual; a; a = a->next)
5298 4199891 : WALK_SUBEXPR (a->expr);
5299 : break;
5300 1279 : case EXPR_CONDITIONAL:
5301 1279 : WALK_SUBEXPR ((*e)->value.conditional.condition);
5302 1278 : WALK_SUBEXPR ((*e)->value.conditional.true_expr);
5303 1277 : WALK_SUBEXPR ((*e)->value.conditional.false_expr);
5304 : break;
5305 75 : case EXPR_COMPCALL:
5306 75 : case EXPR_PPC:
5307 75 : WALK_SUBEXPR ((*e)->value.compcall.base_object);
5308 89 : for (a = (*e)->value.compcall.actual; a; a = a->next)
5309 14 : WALK_SUBEXPR (a->expr);
5310 : break;
5311 :
5312 388719 : case EXPR_ARRAY:
5313 388719 : if ((*e)->ts.type == BT_CHARACTER)
5314 63669 : WALK_SUBEXPR ((*e)->ts.u.cl->length);
5315 :
5316 501811 : gcc_fallthrough ();
5317 :
5318 501811 : case EXPR_STRUCTURE:
5319 :
5320 3349042 : for (c = gfc_constructor_first ((*e)->value.constructor); c;
5321 2847231 : c = gfc_constructor_next (c))
5322 : {
5323 2847231 : if (c->iterator == NULL)
5324 2836087 : WALK_SUBEXPR (c->expr);
5325 : else
5326 : {
5327 11144 : iterator_level ++;
5328 11144 : WALK_SUBEXPR (c->expr);
5329 11144 : iterator_level --;
5330 11144 : WALK_SUBEXPR (c->iterator->var);
5331 11144 : WALK_SUBEXPR (c->iterator->start);
5332 11144 : WALK_SUBEXPR (c->iterator->end);
5333 2847231 : WALK_SUBEXPR (c->iterator->step);
5334 : }
5335 : }
5336 :
5337 501811 : if ((*e)->expr_type != EXPR_ARRAY)
5338 : break;
5339 :
5340 : /* Fall through to the variable case in order to walk the
5341 : reference. */
5342 11139946 : gcc_fallthrough ();
5343 :
5344 11139946 : case EXPR_SUBSTRING:
5345 11139946 : case EXPR_VARIABLE:
5346 15041215 : for (r = (*e)->ref; r; r = r->next)
5347 : {
5348 3901300 : gfc_array_ref *ar;
5349 3901300 : int i;
5350 :
5351 3901300 : switch (r->type)
5352 : {
5353 3139567 : case REF_ARRAY:
5354 3139567 : ar = &r->u.ar;
5355 3139567 : if (ar->type == AR_SECTION || ar->type == AR_ELEMENT)
5356 : {
5357 3030287 : for (i=0; i< ar->dimen; i++)
5358 : {
5359 1705251 : WALK_SUBEXPR (ar->start[i]);
5360 1705220 : WALK_SUBEXPR (ar->end[i]);
5361 1705220 : WALK_SUBEXPR (ar->stride[i]);
5362 : }
5363 : }
5364 :
5365 : break;
5366 :
5367 89088 : case REF_SUBSTRING:
5368 89088 : WALK_SUBEXPR (r->u.ss.start);
5369 89088 : WALK_SUBEXPR (r->u.ss.end);
5370 : break;
5371 :
5372 : case REF_COMPONENT:
5373 : case REF_INQUIRY:
5374 : break;
5375 : }
5376 : }
5377 :
5378 : default:
5379 : break;
5380 4195585 : }
5381 : return 0;
5382 : }
5383 : return 0;
5384 : }
5385 :
5386 : #define WALK_SUBCODE(NODE) \
5387 : do \
5388 : { \
5389 : result = gfc_code_walker (&(NODE), codefn, exprfn, data); \
5390 : if (result) \
5391 : return result; \
5392 : } \
5393 : while (0)
5394 :
5395 : /* Walk code *C, calling CODEFN on each gfc_code node in it and calling EXPRFN
5396 : on each expression in it. If any of the hooks returns non-zero, that
5397 : value is immediately returned. If the hook sets *WALK_SUBTREES to 0,
5398 : no subcodes or subexpressions are traversed. */
5399 :
5400 : int
5401 9010360 : gfc_code_walker (gfc_code **c, walk_code_fn_t codefn, walk_expr_fn_t exprfn,
5402 : void *data)
5403 : {
5404 24454245 : for (; *c; c = &(*c)->next)
5405 : {
5406 15444350 : int walk_subtrees = 1;
5407 15444350 : int result = codefn (c, &walk_subtrees, data);
5408 15444350 : if (result)
5409 465 : return result;
5410 :
5411 15443986 : if (walk_subtrees)
5412 : {
5413 15414159 : gfc_code *b;
5414 15414159 : gfc_actual_arglist *a;
5415 15414159 : gfc_code *co;
5416 15414159 : gfc_association_list *alist;
5417 15414159 : bool saved_in_omp_workshare;
5418 15414159 : bool saved_in_omp_atomic;
5419 15414159 : bool saved_in_where;
5420 :
5421 : /* There might be statement insertions before the current code,
5422 : which must not affect the expression walker. */
5423 :
5424 15414159 : co = *c;
5425 15414159 : saved_in_omp_workshare = in_omp_workshare;
5426 15414159 : saved_in_omp_atomic = in_omp_atomic;
5427 15414159 : saved_in_where = in_where;
5428 :
5429 15414159 : switch (co->op)
5430 : {
5431 :
5432 152583 : case EXEC_BLOCK:
5433 152583 : case EXEC_CHANGE_TEAM:
5434 152583 : WALK_SUBCODE (co->ext.block.ns->code);
5435 152577 : if (co->ext.block.assoc)
5436 : {
5437 76736 : bool saved_in_assoc_list = in_assoc_list;
5438 :
5439 76736 : in_assoc_list = true;
5440 155271 : for (alist = co->ext.block.assoc; alist; alist = alist->next)
5441 78535 : WALK_SUBEXPR (alist->target);
5442 :
5443 76736 : in_assoc_list = saved_in_assoc_list;
5444 : }
5445 :
5446 : break;
5447 :
5448 530889 : case EXEC_DO:
5449 530889 : doloop_level ++;
5450 530889 : WALK_SUBEXPR (co->ext.iterator->var);
5451 530889 : WALK_SUBEXPR (co->ext.iterator->start);
5452 530889 : WALK_SUBEXPR (co->ext.iterator->end);
5453 530888 : WALK_SUBEXPR (co->ext.iterator->step);
5454 : break;
5455 :
5456 3139985 : case EXEC_IF:
5457 3139985 : if_level ++;
5458 3139985 : break;
5459 :
5460 5404 : case EXEC_WHERE:
5461 5404 : in_where = true;
5462 5404 : break;
5463 :
5464 1112180 : case EXEC_CALL:
5465 1112180 : case EXEC_ASSIGN_CALL:
5466 3594711 : for (a = co->ext.actual; a; a = a->next)
5467 2482531 : WALK_SUBEXPR (a->expr);
5468 : break;
5469 :
5470 1459 : case EXEC_CALL_PPC:
5471 1459 : WALK_SUBEXPR (co->expr1);
5472 3454 : for (a = co->ext.actual; a; a = a->next)
5473 1995 : WALK_SUBEXPR (a->expr);
5474 : break;
5475 :
5476 14135 : case EXEC_SELECT:
5477 14135 : WALK_SUBEXPR (co->expr1);
5478 14135 : select_level ++;
5479 43544 : for (b = co->block; b; b = b->block)
5480 : {
5481 29409 : gfc_case *cp;
5482 61296 : for (cp = b->ext.block.case_list; cp; cp = cp->next)
5483 : {
5484 31887 : WALK_SUBEXPR (cp->low);
5485 31887 : WALK_SUBEXPR (cp->high);
5486 : }
5487 29409 : WALK_SUBCODE (b->next);
5488 : }
5489 14135 : continue;
5490 :
5491 184338 : case EXEC_ALLOCATE:
5492 184338 : if (co->ext.alloc.ts.type == BT_CHARACTER)
5493 6122 : WALK_SUBEXPR (co->ext.alloc.ts.u.cl->length);
5494 :
5495 297084 : gcc_fallthrough();
5496 :
5497 297084 : case EXEC_DEALLOCATE:
5498 297084 : {
5499 297084 : gfc_alloc *a;
5500 661318 : for (a = co->ext.alloc.list; a; a = a->next)
5501 364234 : WALK_SUBEXPR (a->expr);
5502 : break;
5503 : }
5504 :
5505 48870 : case EXEC_FORALL:
5506 48870 : case EXEC_DO_CONCURRENT:
5507 48870 : {
5508 48870 : gfc_forall_iterator *fa;
5509 154385 : for (fa = co->ext.concur.forall_iterator; fa; fa = fa->next)
5510 : {
5511 105515 : WALK_SUBEXPR (fa->var);
5512 105515 : WALK_SUBEXPR (fa->start);
5513 105515 : WALK_SUBEXPR (fa->end);
5514 105515 : WALK_SUBEXPR (fa->stride);
5515 : }
5516 48870 : if (co->op == EXEC_FORALL)
5517 46486 : forall_level ++;
5518 : break;
5519 : }
5520 :
5521 45657 : case EXEC_OPEN:
5522 45657 : WALK_SUBEXPR (co->ext.open->unit);
5523 45657 : WALK_SUBEXPR (co->ext.open->file);
5524 45657 : WALK_SUBEXPR (co->ext.open->status);
5525 45657 : WALK_SUBEXPR (co->ext.open->access);
5526 45657 : WALK_SUBEXPR (co->ext.open->form);
5527 45657 : WALK_SUBEXPR (co->ext.open->recl);
5528 45657 : WALK_SUBEXPR (co->ext.open->blank);
5529 45657 : WALK_SUBEXPR (co->ext.open->position);
5530 45657 : WALK_SUBEXPR (co->ext.open->action);
5531 45657 : WALK_SUBEXPR (co->ext.open->delim);
5532 45657 : WALK_SUBEXPR (co->ext.open->pad);
5533 45657 : WALK_SUBEXPR (co->ext.open->iostat);
5534 45657 : WALK_SUBEXPR (co->ext.open->iomsg);
5535 45657 : WALK_SUBEXPR (co->ext.open->convert);
5536 45657 : WALK_SUBEXPR (co->ext.open->decimal);
5537 45657 : WALK_SUBEXPR (co->ext.open->encoding);
5538 45657 : WALK_SUBEXPR (co->ext.open->round);
5539 45657 : WALK_SUBEXPR (co->ext.open->sign);
5540 45657 : WALK_SUBEXPR (co->ext.open->asynchronous);
5541 45657 : WALK_SUBEXPR (co->ext.open->id);
5542 45657 : WALK_SUBEXPR (co->ext.open->newunit);
5543 45657 : WALK_SUBEXPR (co->ext.open->share);
5544 45657 : WALK_SUBEXPR (co->ext.open->cc);
5545 : break;
5546 :
5547 38366 : case EXEC_CLOSE:
5548 38366 : WALK_SUBEXPR (co->ext.close->unit);
5549 38366 : WALK_SUBEXPR (co->ext.close->status);
5550 38366 : WALK_SUBEXPR (co->ext.close->iostat);
5551 38366 : WALK_SUBEXPR (co->ext.close->iomsg);
5552 : break;
5553 :
5554 34689 : case EXEC_BACKSPACE:
5555 34689 : case EXEC_ENDFILE:
5556 34689 : case EXEC_REWIND:
5557 34689 : case EXEC_FLUSH:
5558 34689 : WALK_SUBEXPR (co->ext.filepos->unit);
5559 34689 : WALK_SUBEXPR (co->ext.filepos->iostat);
5560 34689 : WALK_SUBEXPR (co->ext.filepos->iomsg);
5561 : break;
5562 :
5563 9734 : case EXEC_INQUIRE:
5564 9734 : WALK_SUBEXPR (co->ext.inquire->unit);
5565 9734 : WALK_SUBEXPR (co->ext.inquire->file);
5566 9734 : WALK_SUBEXPR (co->ext.inquire->iomsg);
5567 9734 : WALK_SUBEXPR (co->ext.inquire->iostat);
5568 9734 : WALK_SUBEXPR (co->ext.inquire->exist);
5569 9734 : WALK_SUBEXPR (co->ext.inquire->opened);
5570 9734 : WALK_SUBEXPR (co->ext.inquire->number);
5571 9734 : WALK_SUBEXPR (co->ext.inquire->named);
5572 9734 : WALK_SUBEXPR (co->ext.inquire->name);
5573 9734 : WALK_SUBEXPR (co->ext.inquire->access);
5574 9734 : WALK_SUBEXPR (co->ext.inquire->sequential);
5575 9734 : WALK_SUBEXPR (co->ext.inquire->direct);
5576 9734 : WALK_SUBEXPR (co->ext.inquire->form);
5577 9734 : WALK_SUBEXPR (co->ext.inquire->formatted);
5578 9734 : WALK_SUBEXPR (co->ext.inquire->unformatted);
5579 9734 : WALK_SUBEXPR (co->ext.inquire->recl);
5580 9734 : WALK_SUBEXPR (co->ext.inquire->nextrec);
5581 9734 : WALK_SUBEXPR (co->ext.inquire->blank);
5582 9734 : WALK_SUBEXPR (co->ext.inquire->position);
5583 9734 : WALK_SUBEXPR (co->ext.inquire->action);
5584 9734 : WALK_SUBEXPR (co->ext.inquire->read);
5585 9734 : WALK_SUBEXPR (co->ext.inquire->write);
5586 9734 : WALK_SUBEXPR (co->ext.inquire->readwrite);
5587 9734 : WALK_SUBEXPR (co->ext.inquire->delim);
5588 9734 : WALK_SUBEXPR (co->ext.inquire->encoding);
5589 9734 : WALK_SUBEXPR (co->ext.inquire->pad);
5590 9734 : WALK_SUBEXPR (co->ext.inquire->iolength);
5591 9734 : WALK_SUBEXPR (co->ext.inquire->convert);
5592 9734 : WALK_SUBEXPR (co->ext.inquire->strm_pos);
5593 9734 : WALK_SUBEXPR (co->ext.inquire->asynchronous);
5594 9734 : WALK_SUBEXPR (co->ext.inquire->decimal);
5595 9734 : WALK_SUBEXPR (co->ext.inquire->pending);
5596 9734 : WALK_SUBEXPR (co->ext.inquire->id);
5597 9734 : WALK_SUBEXPR (co->ext.inquire->sign);
5598 9734 : WALK_SUBEXPR (co->ext.inquire->size);
5599 9734 : WALK_SUBEXPR (co->ext.inquire->round);
5600 : break;
5601 :
5602 961 : case EXEC_WAIT:
5603 961 : WALK_SUBEXPR (co->ext.wait->unit);
5604 961 : WALK_SUBEXPR (co->ext.wait->iostat);
5605 961 : WALK_SUBEXPR (co->ext.wait->iomsg);
5606 961 : WALK_SUBEXPR (co->ext.wait->id);
5607 : break;
5608 :
5609 385500 : case EXEC_READ:
5610 385500 : case EXEC_WRITE:
5611 385500 : WALK_SUBEXPR (co->ext.dt->io_unit);
5612 385500 : WALK_SUBEXPR (co->ext.dt->format_expr);
5613 385500 : WALK_SUBEXPR (co->ext.dt->rec);
5614 385500 : WALK_SUBEXPR (co->ext.dt->advance);
5615 385500 : WALK_SUBEXPR (co->ext.dt->iostat);
5616 385500 : WALK_SUBEXPR (co->ext.dt->size);
5617 385500 : WALK_SUBEXPR (co->ext.dt->iomsg);
5618 385500 : WALK_SUBEXPR (co->ext.dt->id);
5619 385500 : WALK_SUBEXPR (co->ext.dt->pos);
5620 385500 : WALK_SUBEXPR (co->ext.dt->asynchronous);
5621 385500 : WALK_SUBEXPR (co->ext.dt->blank);
5622 385500 : WALK_SUBEXPR (co->ext.dt->decimal);
5623 385500 : WALK_SUBEXPR (co->ext.dt->delim);
5624 385500 : WALK_SUBEXPR (co->ext.dt->pad);
5625 385500 : WALK_SUBEXPR (co->ext.dt->round);
5626 385500 : WALK_SUBEXPR (co->ext.dt->sign);
5627 385500 : WALK_SUBEXPR (co->ext.dt->extra_comma);
5628 : break;
5629 :
5630 33842 : case EXEC_OACC_ATOMIC:
5631 33842 : case EXEC_OMP_ATOMIC:
5632 33842 : in_omp_atomic = true;
5633 33842 : break;
5634 :
5635 44557 : case EXEC_OMP_PARALLEL:
5636 44557 : case EXEC_OMP_PARALLEL_DO:
5637 44557 : case EXEC_OMP_PARALLEL_DO_SIMD:
5638 44557 : case EXEC_OMP_PARALLEL_LOOP:
5639 44557 : case EXEC_OMP_PARALLEL_MASKED:
5640 44557 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
5641 44557 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
5642 44557 : case EXEC_OMP_PARALLEL_MASTER:
5643 44557 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
5644 44557 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
5645 44557 : case EXEC_OMP_PARALLEL_SECTIONS:
5646 :
5647 44557 : in_omp_workshare = false;
5648 :
5649 : /* This goto serves as a shortcut to avoid code
5650 : duplication or a larger if or switch statement. */
5651 44557 : goto check_omp_clauses;
5652 :
5653 1139 : case EXEC_OMP_WORKSHARE:
5654 1139 : case EXEC_OMP_PARALLEL_WORKSHARE:
5655 :
5656 1139 : in_omp_workshare = true;
5657 :
5658 : /* Fall through */
5659 :
5660 193092 : case EXEC_OMP_CRITICAL:
5661 193092 : case EXEC_OMP_DISTRIBUTE:
5662 193092 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
5663 193092 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
5664 193092 : case EXEC_OMP_DISTRIBUTE_SIMD:
5665 193092 : case EXEC_OMP_DO:
5666 193092 : case EXEC_OMP_DO_SIMD:
5667 193092 : case EXEC_OMP_LOOP:
5668 193092 : case EXEC_OMP_ORDERED:
5669 193092 : case EXEC_OMP_SECTIONS:
5670 193092 : case EXEC_OMP_SINGLE:
5671 193092 : case EXEC_OMP_END_SINGLE:
5672 193092 : case EXEC_OMP_SIMD:
5673 193092 : case EXEC_OMP_TASKLOOP:
5674 193092 : case EXEC_OMP_TASKLOOP_SIMD:
5675 193092 : case EXEC_OMP_TARGET:
5676 193092 : case EXEC_OMP_TARGET_DATA:
5677 193092 : case EXEC_OMP_TARGET_ENTER_DATA:
5678 193092 : case EXEC_OMP_TARGET_EXIT_DATA:
5679 193092 : case EXEC_OMP_TARGET_PARALLEL:
5680 193092 : case EXEC_OMP_TARGET_PARALLEL_DO:
5681 193092 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
5682 193092 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
5683 193092 : case EXEC_OMP_TARGET_SIMD:
5684 193092 : case EXEC_OMP_TARGET_TEAMS:
5685 193092 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
5686 193092 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
5687 193092 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
5688 193092 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
5689 193092 : case EXEC_OMP_TARGET_TEAMS_LOOP:
5690 193092 : case EXEC_OMP_TARGET_UPDATE:
5691 193092 : case EXEC_OMP_TASK:
5692 193092 : case EXEC_OMP_TEAMS:
5693 193092 : case EXEC_OMP_TEAMS_DISTRIBUTE:
5694 193092 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
5695 193092 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
5696 193092 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
5697 193092 : case EXEC_OMP_TEAMS_LOOP:
5698 :
5699 : /* Come to this label only from the
5700 : EXEC_OMP_PARALLEL_* cases above. */
5701 :
5702 193092 : check_omp_clauses:
5703 :
5704 193092 : if (co->ext.omp_clauses)
5705 : {
5706 193092 : gfc_omp_namelist *n;
5707 193092 : static int list_types[]
5708 : = { OMP_LIST_ALIGNED, OMP_LIST_LINEAR, OMP_LIST_DEPEND,
5709 : OMP_LIST_MAP, OMP_LIST_TO, OMP_LIST_FROM };
5710 193092 : size_t idx;
5711 193092 : WALK_SUBEXPR (co->ext.omp_clauses->if_expr);
5712 2124012 : for (idx = 0; idx < OMP_IF_LAST; idx++)
5713 1930920 : WALK_SUBEXPR (co->ext.omp_clauses->if_exprs[idx]);
5714 193092 : WALK_SUBEXPR (co->ext.omp_clauses->final_expr);
5715 193092 : WALK_SUBEXPR (co->ext.omp_clauses->chunk_size);
5716 193092 : WALK_SUBEXPR (co->ext.omp_clauses->safelen_expr);
5717 193092 : WALK_SUBEXPR (co->ext.omp_clauses->simdlen_expr);
5718 193092 : WALK_SUBEXPR (co->ext.omp_clauses->device);
5719 193092 : WALK_SUBEXPR (co->ext.omp_clauses->dist_chunk_size);
5720 193092 : WALK_SUBEXPR (co->ext.omp_clauses->grainsize);
5721 193092 : WALK_SUBEXPR (co->ext.omp_clauses->hint);
5722 193092 : WALK_SUBEXPR (co->ext.omp_clauses->num_tasks);
5723 193092 : WALK_SUBEXPR (co->ext.omp_clauses->priority);
5724 193092 : WALK_SUBEXPR (co->ext.omp_clauses->detach);
5725 193092 : WALK_SUBEXPR (co->ext.omp_clauses->dyn_groupprivate);
5726 193092 : WALK_SUBEXPR (co->ext.omp_clauses->novariants);
5727 193092 : WALK_SUBEXPR (co->ext.omp_clauses->nocontext);
5728 193092 : gfc_expr_list *el = co->ext.omp_clauses->num_teams_list;
5729 195394 : for ( ; el; el = el->next)
5730 2302 : WALK_SUBEXPR (el->expr);
5731 193092 : el = co->ext.omp_clauses->thread_limit_list;
5732 194508 : for ( ; el; el = el->next)
5733 1416 : WALK_SUBEXPR (el->expr);
5734 193092 : el = co->ext.omp_clauses->num_threads_list;
5735 206143 : for ( ; el; el = el->next)
5736 13051 : WALK_SUBEXPR (el->expr);
5737 1351644 : for (idx = 0; idx < ARRAY_SIZE (list_types); idx++)
5738 1158552 : for (n = co->ext.omp_clauses->lists[list_types[idx]];
5739 1308687 : n; n = n->next)
5740 150135 : WALK_SUBEXPR (n->expr);
5741 : }
5742 : break;
5743 :
5744 4578 : case EXEC_OACC_INIT:
5745 4578 : case EXEC_OACC_SHUTDOWN:
5746 4578 : case EXEC_OACC_SET:
5747 4578 : if (co->ext.omp_clauses)
5748 4578 : WALK_SUBEXPR (co->ext.omp_clauses->device_num_expr);
5749 : break;
5750 :
5751 : default:
5752 : break;
5753 14135 : }
5754 :
5755 15400017 : WALK_SUBEXPR (co->expr1);
5756 15400005 : WALK_SUBEXPR (co->expr2);
5757 15399964 : WALK_SUBEXPR (co->expr3);
5758 15399957 : WALK_SUBEXPR (co->expr4);
5759 20022642 : for (b = co->block; b; b = b->block)
5760 : {
5761 4622719 : WALK_SUBEXPR (b->expr1);
5762 4622719 : WALK_SUBEXPR (b->expr2);
5763 4622719 : WALK_SUBCODE (b->next);
5764 : }
5765 :
5766 15399923 : if (co->op == EXEC_FORALL)
5767 46486 : forall_level --;
5768 :
5769 15399923 : if (co->op == EXEC_DO)
5770 530888 : doloop_level --;
5771 :
5772 15399923 : if (co->op == EXEC_IF)
5773 3139951 : if_level --;
5774 :
5775 15399923 : if (co->op == EXEC_SELECT)
5776 0 : select_level --;
5777 :
5778 15399923 : in_omp_workshare = saved_in_omp_workshare;
5779 15399923 : in_omp_atomic = saved_in_omp_atomic;
5780 15399923 : in_where = saved_in_where;
5781 : }
5782 : }
5783 : return 0;
5784 : }
5785 :
5786 : /* As a post-resolution step, check that all global symbols which are
5787 : not declared in the source file match in their call signatures.
5788 : We do this by looping over the code (and expressions). The first call
5789 : we happen to find is assumed to be canonical. */
5790 :
5791 :
5792 : /* Common tests for argument checking for both functions and subroutines. */
5793 :
5794 : static int
5795 132825 : check_externals_procedure (gfc_symbol *sym, locus *loc,
5796 : gfc_actual_arglist *actual)
5797 : {
5798 132825 : gfc_gsymbol *gsym;
5799 132825 : gfc_symbol *def_sym = NULL;
5800 :
5801 132825 : if (sym == NULL || sym->attr.is_bind_c)
5802 : return 0;
5803 :
5804 125746 : if (sym->attr.proc != PROC_EXTERNAL && sym->attr.proc != PROC_UNKNOWN)
5805 : return 0;
5806 :
5807 25997 : if (sym->attr.if_source == IFSRC_IFBODY || sym->attr.if_source == IFSRC_DECL)
5808 : return 0;
5809 :
5810 16490 : gsym = gfc_find_gsymbol (gfc_gsym_root, sym->name);
5811 16490 : if (gsym == NULL)
5812 : return 0;
5813 :
5814 15690 : if (gsym->ns)
5815 14502 : gfc_find_symbol (sym->name, gsym->ns, 0, &def_sym);
5816 :
5817 15690 : if (gsym->bind_c && def_sym && def_sym->binding_label == NULL)
5818 : return 0;
5819 :
5820 15689 : if (def_sym)
5821 : {
5822 14501 : gfc_compare_actual_formal (&actual, def_sym->formal, 0, 0, 0, loc);
5823 14501 : return 0;
5824 : }
5825 :
5826 : /* First time we have seen this procedure called. Let's create an
5827 : "interface" from the call and put it into a new namespace. */
5828 1188 : gfc_namespace *save_ns;
5829 1188 : gfc_symbol *new_sym;
5830 :
5831 1188 : gsym->where = *loc;
5832 1188 : save_ns = gfc_current_ns;
5833 1188 : gsym->ns = gfc_get_namespace (gfc_current_ns, 0);
5834 1188 : gsym->ns->proc_name = sym;
5835 :
5836 1188 : gfc_get_symbol (sym->name, gsym->ns, &new_sym);
5837 1188 : gcc_assert (new_sym);
5838 1188 : new_sym->attr = sym->attr;
5839 1188 : new_sym->attr.if_source = IFSRC_DECL;
5840 1188 : new_sym->ts = sym->ts;
5841 1188 : gfc_current_ns = gsym->ns;
5842 :
5843 1188 : gfc_get_formal_from_actual_arglist (new_sym, actual);
5844 1188 : new_sym->declared_at = *loc;
5845 1188 : gfc_current_ns = save_ns;
5846 :
5847 1188 : return 0;
5848 :
5849 : }
5850 :
5851 : /* Callback for calls of external routines. */
5852 :
5853 : static int
5854 1204014 : check_externals_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
5855 : void *data ATTRIBUTE_UNUSED)
5856 : {
5857 1204014 : gfc_code *co = *c;
5858 1204014 : gfc_symbol *sym;
5859 1204014 : locus *loc;
5860 1204014 : gfc_actual_arglist *actual;
5861 :
5862 1204014 : if (co->op != EXEC_CALL)
5863 : return 0;
5864 :
5865 85197 : sym = co->resolved_sym;
5866 85197 : loc = &co->loc;
5867 85197 : actual = co->ext.actual;
5868 :
5869 85197 : return check_externals_procedure (sym, loc, actual);
5870 :
5871 : }
5872 :
5873 : /* Callback for external functions. */
5874 :
5875 : static int
5876 3673017 : check_externals_expr (gfc_expr **ep, int *walk_subtrees ATTRIBUTE_UNUSED,
5877 : void *data ATTRIBUTE_UNUSED)
5878 : {
5879 3673017 : gfc_expr *e = *ep;
5880 3673017 : gfc_symbol *sym;
5881 3673017 : locus *loc;
5882 3673017 : gfc_actual_arglist *actual;
5883 :
5884 3673017 : if (e->expr_type != EXPR_FUNCTION)
5885 : return 0;
5886 :
5887 290211 : if (e->symtree && e->symtree->n.sym->attr.subroutine)
5888 : return 0;
5889 :
5890 288978 : sym = e->value.function.esym;
5891 288978 : if (sym == NULL)
5892 : return 0;
5893 :
5894 47628 : loc = &e->where;
5895 47628 : actual = e->value.function.actual;
5896 :
5897 47628 : return check_externals_procedure (sym, loc, actual);
5898 : }
5899 :
5900 : /* Function to check if any interface clashes with a global
5901 : identifier, to be invoked via gfc_traverse_ns. */
5902 :
5903 : static void
5904 902951 : check_against_globals (gfc_symbol *sym)
5905 : {
5906 902951 : gfc_gsymbol *gsym;
5907 902951 : gfc_symbol *def_sym = NULL;
5908 902951 : const char *sym_name;
5909 902951 : char buf [200];
5910 :
5911 902951 : if (sym->attr.if_source != IFSRC_IFBODY || sym->attr.flavor != FL_PROCEDURE
5912 171073 : || sym->attr.generic || sym->error || sym->attr.abstract
5913 156458 : || sym->attr.dummy)
5914 873631 : return;
5915 :
5916 156409 : if (sym->error)
5917 : return;
5918 :
5919 156409 : if (sym->binding_label)
5920 : sym_name = sym->binding_label;
5921 128943 : else if (sym->attr.use_rename
5922 39 : && sym->ns->use_stmts->rename
5923 39 : && sym->ns->use_stmts->rename->local_name[0] != '\0')
5924 6 : sym_name = sym->ns->use_stmts->rename->local_name;
5925 : else
5926 128937 : sym_name = sym->name;
5927 :
5928 156409 : gsym = gfc_find_gsymbol (gfc_gsym_root, sym_name);
5929 156409 : if (gsym && gsym->ns)
5930 29367 : gfc_find_symbol (sym->name, gsym->ns, 0, &def_sym);
5931 :
5932 156409 : if (!def_sym || def_sym->error || def_sym->attr.generic)
5933 : return;
5934 :
5935 29320 : buf[0] = 0;
5936 29320 : gfc_compare_interfaces (sym, def_sym, sym->name, 0, 1, buf, sizeof(buf),
5937 : NULL, NULL, NULL);
5938 29320 : if (buf[0] != 0)
5939 : {
5940 4 : gfc_warning (0, "%s between %L and %L", buf, &def_sym->declared_at,
5941 : &sym->declared_at);
5942 4 : sym->error = 1;
5943 4 : def_sym->error = 1;
5944 : }
5945 :
5946 : }
5947 :
5948 : /* Do the code-walkling part for gfc_check_externals. */
5949 :
5950 : static void
5951 100708 : gfc_check_externals0 (gfc_namespace *ns)
5952 : {
5953 100708 : gfc_code_walker (&ns->code, check_externals_code, check_externals_expr, NULL);
5954 :
5955 152627 : for (ns = ns->contained; ns; ns = ns->sibling)
5956 : {
5957 51919 : if (ns->code == NULL || ns->code->op != EXEC_BLOCK)
5958 50813 : gfc_check_externals0 (ns);
5959 : }
5960 :
5961 100708 : }
5962 :
5963 : /* Called routine. */
5964 :
5965 : void
5966 49895 : gfc_check_externals (gfc_namespace *ns)
5967 : {
5968 49895 : gfc_clear_error ();
5969 :
5970 : /* Turn errors into warnings if the user indicated this. */
5971 :
5972 49895 : if (!pedantic && flag_allow_argument_mismatch)
5973 1037 : gfc_errors_to_warnings (true);
5974 :
5975 49895 : gfc_check_externals0 (ns);
5976 49895 : gfc_traverse_ns (ns, check_against_globals);
5977 :
5978 49895 : gfc_errors_to_warnings (false);
5979 49895 : }
5980 :
5981 : /* Callback function. If there is a call to a subroutine which is
5982 : neither pure nor implicit_pure, unset the implicit_pure flag for
5983 : the caller and return -1. */
5984 :
5985 : static int
5986 27987 : implicit_pure_call (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
5987 : void *sym_data)
5988 : {
5989 27987 : gfc_code *co = *c;
5990 27987 : gfc_symbol *caller_sym;
5991 27987 : symbol_attribute *a;
5992 :
5993 27987 : if (co->op != EXEC_CALL || co->resolved_sym == NULL)
5994 : return 0;
5995 :
5996 102 : a = &co->resolved_sym->attr;
5997 102 : if (a->intrinsic || a->pure || a->implicit_pure)
5998 : return 0;
5999 :
6000 67 : caller_sym = (gfc_symbol *) sym_data;
6001 67 : gfc_unset_implicit_pure (caller_sym);
6002 67 : return 1;
6003 : }
6004 :
6005 : /* Callback function. If there is a call to a function which is
6006 : neither pure nor implicit_pure, unset the implicit_pure flag for
6007 : the caller and return 1. */
6008 :
6009 : static int
6010 58624 : implicit_pure_expr (gfc_expr **e, int *walk ATTRIBUTE_UNUSED, void *sym_data)
6011 : {
6012 58624 : gfc_expr *expr = *e;
6013 58624 : gfc_symbol *caller_sym;
6014 58624 : gfc_symbol *sym;
6015 58624 : symbol_attribute *a;
6016 :
6017 58624 : if (expr->expr_type != EXPR_FUNCTION || expr->value.function.isym)
6018 : return 0;
6019 :
6020 372 : sym = expr->symtree->n.sym;
6021 372 : a = &sym->attr;
6022 372 : if (a->pure || a->implicit_pure)
6023 : return 0;
6024 :
6025 59 : caller_sym = (gfc_symbol *) sym_data;
6026 59 : gfc_unset_implicit_pure (caller_sym);
6027 59 : return 1;
6028 : }
6029 :
6030 : /* Go through all procedures in the namespace and unset the
6031 : implicit_pure attribute for any procedure that calls something not
6032 : pure or implicit pure. */
6033 :
6034 : bool
6035 140883 : gfc_fix_implicit_pure (gfc_namespace *ns)
6036 : {
6037 140883 : bool changed = false;
6038 140883 : gfc_symbol *proc = ns->proc_name;
6039 :
6040 140834 : if (proc && proc->attr.flavor == FL_PROCEDURE && proc->attr.implicit_pure
6041 10817 : && ns->code
6042 151682 : && gfc_code_walker (&ns->code, implicit_pure_call, implicit_pure_expr,
6043 : (void *) ns->proc_name))
6044 : changed = true;
6045 :
6046 221496 : for (ns = ns->contained; ns; ns = ns->sibling)
6047 : {
6048 80613 : if (gfc_fix_implicit_pure (ns))
6049 127 : changed = true;
6050 : }
6051 :
6052 140883 : return changed;
6053 : }
|
