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