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