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