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