]>
Commit | Line | Data |
---|---|---|
6de9cd9a | 1 | /* Statement translation -- generate GCC trees from gfc_code. |
681f47f2 TS |
2 | Copyright (C) 2002, 2003, 2004, 2005, 2006 Free Software Foundation, |
3 | Inc. | |
6de9cd9a DN |
4 | Contributed by Paul Brook <paul@nowt.org> |
5 | and Steven Bosscher <s.bosscher@student.tudelft.nl> | |
6 | ||
9fc4d79b | 7 | This file is part of GCC. |
6de9cd9a | 8 | |
9fc4d79b TS |
9 | GCC is free software; you can redistribute it and/or modify it under |
10 | the terms of the GNU General Public License as published by the Free | |
11 | Software Foundation; either version 2, or (at your option) any later | |
12 | version. | |
6de9cd9a | 13 | |
9fc4d79b TS |
14 | GCC is distributed in the hope that it will be useful, but WITHOUT ANY |
15 | WARRANTY; without even the implied warranty of MERCHANTABILITY or | |
16 | FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License | |
17 | for more details. | |
6de9cd9a DN |
18 | |
19 | You should have received a copy of the GNU General Public License | |
9fc4d79b | 20 | along with GCC; see the file COPYING. If not, write to the Free |
ab57747b KC |
21 | Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA |
22 | 02110-1301, USA. */ | |
6de9cd9a DN |
23 | |
24 | ||
25 | #include "config.h" | |
26 | #include "system.h" | |
27 | #include "coretypes.h" | |
28 | #include "tree.h" | |
eadf906f | 29 | #include "tree-gimple.h" |
6de9cd9a DN |
30 | #include "ggc.h" |
31 | #include "toplev.h" | |
32 | #include "real.h" | |
6de9cd9a | 33 | #include "gfortran.h" |
dd18a33b | 34 | #include "flags.h" |
6de9cd9a DN |
35 | #include "trans.h" |
36 | #include "trans-stmt.h" | |
37 | #include "trans-types.h" | |
38 | #include "trans-array.h" | |
39 | #include "trans-const.h" | |
40 | #include "arith.h" | |
3ded6210 | 41 | #include "dependency.h" |
6de9cd9a | 42 | |
6de9cd9a DN |
43 | typedef struct iter_info |
44 | { | |
45 | tree var; | |
46 | tree start; | |
47 | tree end; | |
48 | tree step; | |
49 | struct iter_info *next; | |
50 | } | |
51 | iter_info; | |
52 | ||
6de9cd9a DN |
53 | typedef struct forall_info |
54 | { | |
55 | iter_info *this_loop; | |
56 | tree mask; | |
57 | tree pmask; | |
58 | tree maskindex; | |
59 | int nvar; | |
60 | tree size; | |
61 | struct forall_info *outer; | |
62 | struct forall_info *next_nest; | |
63 | } | |
64 | forall_info; | |
65 | ||
011daa76 RS |
66 | static void gfc_trans_where_2 (gfc_code *, tree, bool, |
67 | forall_info *, stmtblock_t *); | |
6de9cd9a DN |
68 | |
69 | /* Translate a F95 label number to a LABEL_EXPR. */ | |
70 | ||
71 | tree | |
72 | gfc_trans_label_here (gfc_code * code) | |
73 | { | |
74 | return build1_v (LABEL_EXPR, gfc_get_label_decl (code->here)); | |
75 | } | |
76 | ||
ce2df7c6 FW |
77 | |
78 | /* Given a variable expression which has been ASSIGNed to, find the decl | |
79 | containing the auxiliary variables. For variables in common blocks this | |
80 | is a field_decl. */ | |
81 | ||
82 | void | |
83 | gfc_conv_label_variable (gfc_se * se, gfc_expr * expr) | |
84 | { | |
85 | gcc_assert (expr->symtree->n.sym->attr.assign == 1); | |
86 | gfc_conv_expr (se, expr); | |
87 | /* Deals with variable in common block. Get the field declaration. */ | |
88 | if (TREE_CODE (se->expr) == COMPONENT_REF) | |
89 | se->expr = TREE_OPERAND (se->expr, 1); | |
910450c1 FW |
90 | /* Deals with dummy argument. Get the parameter declaration. */ |
91 | else if (TREE_CODE (se->expr) == INDIRECT_REF) | |
92 | se->expr = TREE_OPERAND (se->expr, 0); | |
ce2df7c6 FW |
93 | } |
94 | ||
6de9cd9a | 95 | /* Translate a label assignment statement. */ |
ce2df7c6 | 96 | |
6de9cd9a DN |
97 | tree |
98 | gfc_trans_label_assign (gfc_code * code) | |
99 | { | |
100 | tree label_tree; | |
101 | gfc_se se; | |
102 | tree len; | |
103 | tree addr; | |
104 | tree len_tree; | |
105 | char *label_str; | |
106 | int label_len; | |
107 | ||
108 | /* Start a new block. */ | |
109 | gfc_init_se (&se, NULL); | |
110 | gfc_start_block (&se.pre); | |
ce2df7c6 FW |
111 | gfc_conv_label_variable (&se, code->expr); |
112 | ||
6de9cd9a DN |
113 | len = GFC_DECL_STRING_LEN (se.expr); |
114 | addr = GFC_DECL_ASSIGN_ADDR (se.expr); | |
115 | ||
116 | label_tree = gfc_get_label_decl (code->label); | |
117 | ||
118 | if (code->label->defined == ST_LABEL_TARGET) | |
119 | { | |
120 | label_tree = gfc_build_addr_expr (pvoid_type_node, label_tree); | |
121 | len_tree = integer_minus_one_node; | |
122 | } | |
123 | else | |
124 | { | |
125 | label_str = code->label->format->value.character.string; | |
126 | label_len = code->label->format->value.character.length; | |
7d60be94 | 127 | len_tree = build_int_cst (NULL_TREE, label_len); |
6de9cd9a | 128 | label_tree = gfc_build_string_const (label_len + 1, label_str); |
b078dfbf | 129 | label_tree = gfc_build_addr_expr (pvoid_type_node, label_tree); |
6de9cd9a DN |
130 | } |
131 | ||
132 | gfc_add_modify_expr (&se.pre, len, len_tree); | |
133 | gfc_add_modify_expr (&se.pre, addr, label_tree); | |
134 | ||
135 | return gfc_finish_block (&se.pre); | |
136 | } | |
137 | ||
138 | /* Translate a GOTO statement. */ | |
139 | ||
140 | tree | |
141 | gfc_trans_goto (gfc_code * code) | |
142 | { | |
dd18a33b | 143 | locus loc = code->loc; |
6de9cd9a DN |
144 | tree assigned_goto; |
145 | tree target; | |
146 | tree tmp; | |
6de9cd9a DN |
147 | gfc_se se; |
148 | ||
6de9cd9a DN |
149 | if (code->label != NULL) |
150 | return build1_v (GOTO_EXPR, gfc_get_label_decl (code->label)); | |
151 | ||
152 | /* ASSIGNED GOTO. */ | |
153 | gfc_init_se (&se, NULL); | |
154 | gfc_start_block (&se.pre); | |
ce2df7c6 | 155 | gfc_conv_label_variable (&se, code->expr); |
6de9cd9a | 156 | tmp = GFC_DECL_STRING_LEN (se.expr); |
3f2ec06a RG |
157 | tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp, |
158 | build_int_cst (TREE_TYPE (tmp), -1)); | |
dd18a33b FXC |
159 | gfc_trans_runtime_check (tmp, "Assigned label is not a target label", |
160 | &se.pre, &loc); | |
6de9cd9a DN |
161 | |
162 | assigned_goto = GFC_DECL_ASSIGN_ADDR (se.expr); | |
6de9cd9a DN |
163 | |
164 | code = code->block; | |
165 | if (code == NULL) | |
166 | { | |
75d2cf69 | 167 | target = build1 (GOTO_EXPR, void_type_node, assigned_goto); |
6de9cd9a DN |
168 | gfc_add_expr_to_block (&se.pre, target); |
169 | return gfc_finish_block (&se.pre); | |
170 | } | |
171 | ||
172 | /* Check the label list. */ | |
6de9cd9a DN |
173 | do |
174 | { | |
75d2cf69 SB |
175 | target = gfc_get_label_decl (code->label); |
176 | tmp = gfc_build_addr_expr (pvoid_type_node, target); | |
923ab88c | 177 | tmp = build2 (EQ_EXPR, boolean_type_node, tmp, assigned_goto); |
75d2cf69 SB |
178 | tmp = build3_v (COND_EXPR, tmp, |
179 | build1 (GOTO_EXPR, void_type_node, target), | |
180 | build_empty_stmt ()); | |
6de9cd9a DN |
181 | gfc_add_expr_to_block (&se.pre, tmp); |
182 | code = code->block; | |
183 | } | |
184 | while (code != NULL); | |
dd18a33b FXC |
185 | gfc_trans_runtime_check (boolean_true_node, |
186 | "Assigned label is not in the list", &se.pre, &loc); | |
187 | ||
6de9cd9a DN |
188 | return gfc_finish_block (&se.pre); |
189 | } | |
190 | ||
191 | ||
3d79abbd PB |
192 | /* Translate an ENTRY statement. Just adds a label for this entry point. */ |
193 | tree | |
194 | gfc_trans_entry (gfc_code * code) | |
195 | { | |
196 | return build1_v (LABEL_EXPR, code->ext.entry->label); | |
197 | } | |
198 | ||
199 | ||
476220e7 PT |
200 | /* Check for dependencies between INTENT(IN) and INTENT(OUT) arguments of |
201 | elemental subroutines. Make temporaries for output arguments if any such | |
202 | dependencies are found. Output arguments are chosen because internal_unpack | |
203 | can be used, as is, to copy the result back to the variable. */ | |
204 | static void | |
205 | gfc_conv_elemental_dependencies (gfc_se * se, gfc_se * loopse, | |
206 | gfc_symbol * sym, gfc_actual_arglist * arg) | |
207 | { | |
208 | gfc_actual_arglist *arg0; | |
209 | gfc_expr *e; | |
210 | gfc_formal_arglist *formal; | |
211 | gfc_loopinfo tmp_loop; | |
212 | gfc_se parmse; | |
213 | gfc_ss *ss; | |
214 | gfc_ss_info *info; | |
215 | gfc_symbol *fsym; | |
216 | int n; | |
217 | stmtblock_t block; | |
218 | tree data; | |
219 | tree offset; | |
220 | tree size; | |
221 | tree tmp; | |
222 | ||
223 | if (loopse->ss == NULL) | |
224 | return; | |
225 | ||
226 | ss = loopse->ss; | |
227 | arg0 = arg; | |
228 | formal = sym->formal; | |
229 | ||
230 | /* Loop over all the arguments testing for dependencies. */ | |
231 | for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL) | |
232 | { | |
233 | e = arg->expr; | |
234 | if (e == NULL) | |
235 | continue; | |
236 | ||
237 | /* Obtain the info structure for the current argument. */ | |
238 | info = NULL; | |
239 | for (ss = loopse->ss; ss && ss != gfc_ss_terminator; ss = ss->next) | |
240 | { | |
241 | if (ss->expr != e) | |
242 | continue; | |
243 | info = &ss->data.info; | |
244 | break; | |
245 | } | |
246 | ||
247 | /* If there is a dependency, create a temporary and use it | |
248 | instead of the variable. */ | |
249 | fsym = formal ? formal->sym : NULL; | |
250 | if (e->expr_type == EXPR_VARIABLE | |
251 | && e->rank && fsym | |
252 | && fsym->attr.intent == INTENT_OUT | |
253 | && gfc_check_fncall_dependency (e, INTENT_OUT, sym, arg0)) | |
254 | { | |
255 | /* Make a local loopinfo for the temporary creation, so that | |
256 | none of the other ss->info's have to be renormalized. */ | |
257 | gfc_init_loopinfo (&tmp_loop); | |
258 | for (n = 0; n < info->dimen; n++) | |
259 | { | |
260 | tmp_loop.to[n] = loopse->loop->to[n]; | |
261 | tmp_loop.from[n] = loopse->loop->from[n]; | |
262 | tmp_loop.order[n] = loopse->loop->order[n]; | |
263 | } | |
264 | ||
265 | /* Generate the temporary. Merge the block so that the | |
266 | declarations are put at the right binding level. */ | |
267 | size = gfc_create_var (gfc_array_index_type, NULL); | |
268 | data = gfc_create_var (pvoid_type_node, NULL); | |
269 | gfc_start_block (&block); | |
270 | tmp = gfc_typenode_for_spec (&e->ts); | |
271 | tmp = gfc_trans_create_temp_array (&se->pre, &se->post, | |
272 | &tmp_loop, info, tmp, | |
da4340a1 | 273 | false, true, false, false); |
476220e7 PT |
274 | gfc_add_modify_expr (&se->pre, size, tmp); |
275 | tmp = fold_convert (pvoid_type_node, info->data); | |
276 | gfc_add_modify_expr (&se->pre, data, tmp); | |
277 | gfc_merge_block_scope (&block); | |
278 | ||
279 | /* Obtain the argument descriptor for unpacking. */ | |
280 | gfc_init_se (&parmse, NULL); | |
281 | parmse.want_pointer = 1; | |
282 | gfc_conv_expr_descriptor (&parmse, e, gfc_walk_expr (e)); | |
283 | gfc_add_block_to_block (&se->pre, &parmse.pre); | |
284 | ||
285 | /* Calculate the offset for the temporary. */ | |
286 | offset = gfc_index_zero_node; | |
287 | for (n = 0; n < info->dimen; n++) | |
288 | { | |
289 | tmp = gfc_conv_descriptor_stride (info->descriptor, | |
290 | gfc_rank_cst[n]); | |
291 | tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, | |
292 | loopse->loop->from[n], tmp); | |
293 | offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, | |
294 | offset, tmp); | |
295 | } | |
296 | info->offset = gfc_create_var (gfc_array_index_type, NULL); | |
297 | gfc_add_modify_expr (&se->pre, info->offset, offset); | |
298 | ||
299 | /* Copy the result back using unpack. */ | |
300 | tmp = gfc_chainon_list (NULL_TREE, parmse.expr); | |
301 | tmp = gfc_chainon_list (tmp, data); | |
302 | tmp = build_function_call_expr (gfor_fndecl_in_unpack, tmp); | |
303 | gfc_add_expr_to_block (&se->post, tmp); | |
304 | ||
305 | gfc_add_block_to_block (&se->post, &parmse.post); | |
306 | } | |
307 | } | |
308 | } | |
309 | ||
310 | ||
6de9cd9a DN |
311 | /* Translate the CALL statement. Builds a call to an F95 subroutine. */ |
312 | ||
313 | tree | |
476220e7 | 314 | gfc_trans_call (gfc_code * code, bool dependency_check) |
6de9cd9a DN |
315 | { |
316 | gfc_se se; | |
48474141 | 317 | gfc_ss * ss; |
dda895f9 | 318 | int has_alternate_specifier; |
6de9cd9a DN |
319 | |
320 | /* A CALL starts a new block because the actual arguments may have to | |
321 | be evaluated first. */ | |
322 | gfc_init_se (&se, NULL); | |
323 | gfc_start_block (&se.pre); | |
324 | ||
6e45f57b | 325 | gcc_assert (code->resolved_sym); |
6de9cd9a | 326 | |
48474141 PT |
327 | ss = gfc_ss_terminator; |
328 | if (code->resolved_sym->attr.elemental) | |
329 | ss = gfc_walk_elemental_function_args (ss, code->ext.actual, GFC_SS_REFERENCE); | |
6de9cd9a | 330 | |
48474141 PT |
331 | /* Is not an elemental subroutine call with array valued arguments. */ |
332 | if (ss == gfc_ss_terminator) | |
6de9cd9a | 333 | { |
48474141 PT |
334 | |
335 | /* Translate the call. */ | |
336 | has_alternate_specifier | |
5a0aad31 FXC |
337 | = gfc_conv_function_call (&se, code->resolved_sym, code->ext.actual, |
338 | NULL_TREE); | |
48474141 PT |
339 | |
340 | /* A subroutine without side-effect, by definition, does nothing! */ | |
341 | TREE_SIDE_EFFECTS (se.expr) = 1; | |
342 | ||
343 | /* Chain the pieces together and return the block. */ | |
344 | if (has_alternate_specifier) | |
345 | { | |
346 | gfc_code *select_code; | |
347 | gfc_symbol *sym; | |
348 | select_code = code->next; | |
349 | gcc_assert(select_code->op == EXEC_SELECT); | |
350 | sym = select_code->expr->symtree->n.sym; | |
351 | se.expr = convert (gfc_typenode_for_spec (&sym->ts), se.expr); | |
352 | gfc_add_modify_expr (&se.pre, sym->backend_decl, se.expr); | |
353 | } | |
354 | else | |
355 | gfc_add_expr_to_block (&se.pre, se.expr); | |
356 | ||
357 | gfc_add_block_to_block (&se.pre, &se.post); | |
6de9cd9a | 358 | } |
48474141 | 359 | |
6de9cd9a | 360 | else |
48474141 PT |
361 | { |
362 | /* An elemental subroutine call with array valued arguments has | |
363 | to be scalarized. */ | |
364 | gfc_loopinfo loop; | |
365 | stmtblock_t body; | |
366 | stmtblock_t block; | |
367 | gfc_se loopse; | |
368 | ||
369 | /* gfc_walk_elemental_function_args renders the ss chain in the | |
370 | reverse order to the actual argument order. */ | |
371 | ss = gfc_reverse_ss (ss); | |
372 | ||
373 | /* Initialize the loop. */ | |
374 | gfc_init_se (&loopse, NULL); | |
375 | gfc_init_loopinfo (&loop); | |
376 | gfc_add_ss_to_loop (&loop, ss); | |
377 | ||
378 | gfc_conv_ss_startstride (&loop); | |
379 | gfc_conv_loop_setup (&loop); | |
380 | gfc_mark_ss_chain_used (ss, 1); | |
381 | ||
476220e7 PT |
382 | /* Convert the arguments, checking for dependencies. */ |
383 | gfc_copy_loopinfo_to_se (&loopse, &loop); | |
384 | loopse.ss = ss; | |
385 | ||
386 | /* For operator assignment, we need to do dependency checking. | |
387 | We also check the intent of the parameters. */ | |
388 | if (dependency_check) | |
389 | { | |
390 | gfc_symbol *sym; | |
391 | sym = code->resolved_sym; | |
392 | gcc_assert (sym->formal->sym->attr.intent = INTENT_OUT); | |
393 | gcc_assert (sym->formal->next->sym->attr.intent = INTENT_IN); | |
394 | gfc_conv_elemental_dependencies (&se, &loopse, sym, | |
395 | code->ext.actual); | |
396 | } | |
397 | ||
48474141 PT |
398 | /* Generate the loop body. */ |
399 | gfc_start_scalarized_body (&loop, &body); | |
400 | gfc_init_block (&block); | |
48474141 PT |
401 | |
402 | /* Add the subroutine call to the block. */ | |
5a0aad31 FXC |
403 | gfc_conv_function_call (&loopse, code->resolved_sym, code->ext.actual, |
404 | NULL_TREE); | |
48474141 PT |
405 | gfc_add_expr_to_block (&loopse.pre, loopse.expr); |
406 | ||
407 | gfc_add_block_to_block (&block, &loopse.pre); | |
408 | gfc_add_block_to_block (&block, &loopse.post); | |
409 | ||
410 | /* Finish up the loop block and the loop. */ | |
411 | gfc_add_expr_to_block (&body, gfc_finish_block (&block)); | |
412 | gfc_trans_scalarizing_loops (&loop, &body); | |
413 | gfc_add_block_to_block (&se.pre, &loop.pre); | |
414 | gfc_add_block_to_block (&se.pre, &loop.post); | |
476220e7 | 415 | gfc_add_block_to_block (&se.pre, &se.post); |
48474141 PT |
416 | gfc_cleanup_loop (&loop); |
417 | } | |
6de9cd9a | 418 | |
6de9cd9a DN |
419 | return gfc_finish_block (&se.pre); |
420 | } | |
421 | ||
422 | ||
423 | /* Translate the RETURN statement. */ | |
424 | ||
425 | tree | |
426 | gfc_trans_return (gfc_code * code ATTRIBUTE_UNUSED) | |
427 | { | |
428 | if (code->expr) | |
429 | { | |
430 | gfc_se se; | |
431 | tree tmp; | |
432 | tree result; | |
433 | ||
434 | /* if code->expr is not NULL, this return statement must appear | |
435 | in a subroutine and current_fake_result_decl has already | |
436 | been generated. */ | |
437 | ||
5f20c93a | 438 | result = gfc_get_fake_result_decl (NULL, 0); |
6de9cd9a DN |
439 | if (!result) |
440 | { | |
441 | gfc_warning ("An alternate return at %L without a * dummy argument", | |
442 | &code->expr->where); | |
443 | return build1_v (GOTO_EXPR, gfc_get_return_label ()); | |
444 | } | |
445 | ||
446 | /* Start a new block for this statement. */ | |
447 | gfc_init_se (&se, NULL); | |
448 | gfc_start_block (&se.pre); | |
449 | ||
450 | gfc_conv_expr (&se, code->expr); | |
451 | ||
923ab88c | 452 | tmp = build2 (MODIFY_EXPR, TREE_TYPE (result), result, se.expr); |
6de9cd9a DN |
453 | gfc_add_expr_to_block (&se.pre, tmp); |
454 | ||
455 | tmp = build1_v (GOTO_EXPR, gfc_get_return_label ()); | |
456 | gfc_add_expr_to_block (&se.pre, tmp); | |
457 | gfc_add_block_to_block (&se.pre, &se.post); | |
458 | return gfc_finish_block (&se.pre); | |
459 | } | |
460 | else | |
461 | return build1_v (GOTO_EXPR, gfc_get_return_label ()); | |
462 | } | |
463 | ||
464 | ||
465 | /* Translate the PAUSE statement. We have to translate this statement | |
466 | to a runtime library call. */ | |
467 | ||
468 | tree | |
469 | gfc_trans_pause (gfc_code * code) | |
470 | { | |
e2cad04b | 471 | tree gfc_int4_type_node = gfc_get_int_type (4); |
6de9cd9a DN |
472 | gfc_se se; |
473 | tree args; | |
474 | tree tmp; | |
475 | tree fndecl; | |
476 | ||
477 | /* Start a new block for this statement. */ | |
478 | gfc_init_se (&se, NULL); | |
479 | gfc_start_block (&se.pre); | |
480 | ||
481 | ||
482 | if (code->expr == NULL) | |
483 | { | |
7d60be94 | 484 | tmp = build_int_cst (gfc_int4_type_node, code->ext.stop_code); |
6de9cd9a DN |
485 | args = gfc_chainon_list (NULL_TREE, tmp); |
486 | fndecl = gfor_fndecl_pause_numeric; | |
487 | } | |
488 | else | |
489 | { | |
490 | gfc_conv_expr_reference (&se, code->expr); | |
491 | args = gfc_chainon_list (NULL_TREE, se.expr); | |
492 | args = gfc_chainon_list (args, se.string_length); | |
493 | fndecl = gfor_fndecl_pause_string; | |
494 | } | |
495 | ||
3380b802 | 496 | tmp = build_function_call_expr (fndecl, args); |
6de9cd9a DN |
497 | gfc_add_expr_to_block (&se.pre, tmp); |
498 | ||
499 | gfc_add_block_to_block (&se.pre, &se.post); | |
500 | ||
501 | return gfc_finish_block (&se.pre); | |
502 | } | |
503 | ||
504 | ||
505 | /* Translate the STOP statement. We have to translate this statement | |
506 | to a runtime library call. */ | |
507 | ||
508 | tree | |
509 | gfc_trans_stop (gfc_code * code) | |
510 | { | |
e2cad04b | 511 | tree gfc_int4_type_node = gfc_get_int_type (4); |
6de9cd9a DN |
512 | gfc_se se; |
513 | tree args; | |
514 | tree tmp; | |
515 | tree fndecl; | |
516 | ||
517 | /* Start a new block for this statement. */ | |
518 | gfc_init_se (&se, NULL); | |
519 | gfc_start_block (&se.pre); | |
520 | ||
521 | ||
522 | if (code->expr == NULL) | |
523 | { | |
7d60be94 | 524 | tmp = build_int_cst (gfc_int4_type_node, code->ext.stop_code); |
6de9cd9a DN |
525 | args = gfc_chainon_list (NULL_TREE, tmp); |
526 | fndecl = gfor_fndecl_stop_numeric; | |
527 | } | |
528 | else | |
529 | { | |
530 | gfc_conv_expr_reference (&se, code->expr); | |
531 | args = gfc_chainon_list (NULL_TREE, se.expr); | |
532 | args = gfc_chainon_list (args, se.string_length); | |
533 | fndecl = gfor_fndecl_stop_string; | |
534 | } | |
535 | ||
3380b802 | 536 | tmp = build_function_call_expr (fndecl, args); |
6de9cd9a DN |
537 | gfc_add_expr_to_block (&se.pre, tmp); |
538 | ||
539 | gfc_add_block_to_block (&se.pre, &se.post); | |
540 | ||
541 | return gfc_finish_block (&se.pre); | |
542 | } | |
543 | ||
544 | ||
545 | /* Generate GENERIC for the IF construct. This function also deals with | |
546 | the simple IF statement, because the front end translates the IF | |
547 | statement into an IF construct. | |
548 | ||
549 | We translate: | |
550 | ||
551 | IF (cond) THEN | |
552 | then_clause | |
553 | ELSEIF (cond2) | |
554 | elseif_clause | |
555 | ELSE | |
556 | else_clause | |
557 | ENDIF | |
558 | ||
559 | into: | |
560 | ||
561 | pre_cond_s; | |
562 | if (cond_s) | |
563 | { | |
564 | then_clause; | |
565 | } | |
566 | else | |
567 | { | |
568 | pre_cond_s | |
569 | if (cond_s) | |
570 | { | |
571 | elseif_clause | |
572 | } | |
573 | else | |
574 | { | |
575 | else_clause; | |
576 | } | |
577 | } | |
578 | ||
579 | where COND_S is the simplified version of the predicate. PRE_COND_S | |
580 | are the pre side-effects produced by the translation of the | |
581 | conditional. | |
582 | We need to build the chain recursively otherwise we run into | |
583 | problems with folding incomplete statements. */ | |
584 | ||
585 | static tree | |
586 | gfc_trans_if_1 (gfc_code * code) | |
587 | { | |
588 | gfc_se if_se; | |
589 | tree stmt, elsestmt; | |
590 | ||
591 | /* Check for an unconditional ELSE clause. */ | |
592 | if (!code->expr) | |
593 | return gfc_trans_code (code->next); | |
594 | ||
595 | /* Initialize a statement builder for each block. Puts in NULL_TREEs. */ | |
596 | gfc_init_se (&if_se, NULL); | |
597 | gfc_start_block (&if_se.pre); | |
598 | ||
599 | /* Calculate the IF condition expression. */ | |
600 | gfc_conv_expr_val (&if_se, code->expr); | |
601 | ||
602 | /* Translate the THEN clause. */ | |
603 | stmt = gfc_trans_code (code->next); | |
604 | ||
605 | /* Translate the ELSE clause. */ | |
606 | if (code->block) | |
607 | elsestmt = gfc_trans_if_1 (code->block); | |
608 | else | |
609 | elsestmt = build_empty_stmt (); | |
610 | ||
611 | /* Build the condition expression and add it to the condition block. */ | |
61ead135 | 612 | stmt = fold_build3 (COND_EXPR, void_type_node, if_se.expr, stmt, elsestmt); |
6de9cd9a DN |
613 | |
614 | gfc_add_expr_to_block (&if_se.pre, stmt); | |
615 | ||
616 | /* Finish off this statement. */ | |
617 | return gfc_finish_block (&if_se.pre); | |
618 | } | |
619 | ||
620 | tree | |
621 | gfc_trans_if (gfc_code * code) | |
622 | { | |
623 | /* Ignore the top EXEC_IF, it only announces an IF construct. The | |
624 | actual code we must translate is in code->block. */ | |
625 | ||
626 | return gfc_trans_if_1 (code->block); | |
627 | } | |
628 | ||
629 | ||
fa951694 | 630 | /* Translate an arithmetic IF expression. |
6de9cd9a DN |
631 | |
632 | IF (cond) label1, label2, label3 translates to | |
633 | ||
634 | if (cond <= 0) | |
635 | { | |
636 | if (cond < 0) | |
637 | goto label1; | |
638 | else // cond == 0 | |
639 | goto label2; | |
640 | } | |
641 | else // cond > 0 | |
642 | goto label3; | |
442c1644 CY |
643 | |
644 | An optimized version can be generated in case of equal labels. | |
645 | E.g., if label1 is equal to label2, we can translate it to | |
646 | ||
647 | if (cond <= 0) | |
648 | goto label1; | |
649 | else | |
650 | goto label3; | |
6de9cd9a DN |
651 | */ |
652 | ||
653 | tree | |
654 | gfc_trans_arithmetic_if (gfc_code * code) | |
655 | { | |
656 | gfc_se se; | |
657 | tree tmp; | |
658 | tree branch1; | |
659 | tree branch2; | |
660 | tree zero; | |
661 | ||
662 | /* Start a new block. */ | |
663 | gfc_init_se (&se, NULL); | |
664 | gfc_start_block (&se.pre); | |
665 | ||
666 | /* Pre-evaluate COND. */ | |
667 | gfc_conv_expr_val (&se, code->expr); | |
5ec1334b | 668 | se.expr = gfc_evaluate_now (se.expr, &se.pre); |
6de9cd9a DN |
669 | |
670 | /* Build something to compare with. */ | |
671 | zero = gfc_build_const (TREE_TYPE (se.expr), integer_zero_node); | |
672 | ||
442c1644 CY |
673 | if (code->label->value != code->label2->value) |
674 | { | |
675 | /* If (cond < 0) take branch1 else take branch2. | |
676 | First build jumps to the COND .LT. 0 and the COND .EQ. 0 cases. */ | |
677 | branch1 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label)); | |
678 | branch2 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label2)); | |
679 | ||
680 | if (code->label->value != code->label3->value) | |
61ead135 | 681 | tmp = fold_build2 (LT_EXPR, boolean_type_node, se.expr, zero); |
442c1644 | 682 | else |
61ead135 | 683 | tmp = fold_build2 (NE_EXPR, boolean_type_node, se.expr, zero); |
6de9cd9a | 684 | |
61ead135 | 685 | branch1 = fold_build3 (COND_EXPR, void_type_node, tmp, branch1, branch2); |
442c1644 CY |
686 | } |
687 | else | |
688 | branch1 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label)); | |
6de9cd9a | 689 | |
442c1644 CY |
690 | if (code->label->value != code->label3->value |
691 | && code->label2->value != code->label3->value) | |
692 | { | |
693 | /* if (cond <= 0) take branch1 else take branch2. */ | |
694 | branch2 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label3)); | |
61ead135 RG |
695 | tmp = fold_build2 (LE_EXPR, boolean_type_node, se.expr, zero); |
696 | branch1 = fold_build3 (COND_EXPR, void_type_node, tmp, branch1, branch2); | |
442c1644 | 697 | } |
6de9cd9a DN |
698 | |
699 | /* Append the COND_EXPR to the evaluation of COND, and return. */ | |
700 | gfc_add_expr_to_block (&se.pre, branch1); | |
701 | return gfc_finish_block (&se.pre); | |
702 | } | |
703 | ||
704 | ||
54c2d931 | 705 | /* Translate the simple DO construct. This is where the loop variable has |
fbdad37d PB |
706 | integer type and step +-1. We can't use this in the general case |
707 | because integer overflow and floating point errors could give incorrect | |
708 | results. | |
709 | We translate a do loop from: | |
710 | ||
711 | DO dovar = from, to, step | |
712 | body | |
713 | END DO | |
714 | ||
715 | to: | |
716 | ||
717 | [Evaluate loop bounds and step] | |
718 | dovar = from; | |
719 | if ((step > 0) ? (dovar <= to) : (dovar => to)) | |
720 | { | |
721 | for (;;) | |
722 | { | |
723 | body; | |
724 | cycle_label: | |
725 | cond = (dovar == to); | |
726 | dovar += step; | |
727 | if (cond) goto end_label; | |
728 | } | |
729 | } | |
730 | end_label: | |
731 | ||
732 | This helps the optimizers by avoiding the extra induction variable | |
733 | used in the general case. */ | |
734 | ||
735 | static tree | |
736 | gfc_trans_simple_do (gfc_code * code, stmtblock_t *pblock, tree dovar, | |
737 | tree from, tree to, tree step) | |
738 | { | |
739 | stmtblock_t body; | |
740 | tree type; | |
741 | tree cond; | |
742 | tree tmp; | |
743 | tree cycle_label; | |
744 | tree exit_label; | |
745 | ||
746 | type = TREE_TYPE (dovar); | |
747 | ||
748 | /* Initialize the DO variable: dovar = from. */ | |
749 | gfc_add_modify_expr (pblock, dovar, from); | |
750 | ||
751 | /* Cycle and exit statements are implemented with gotos. */ | |
752 | cycle_label = gfc_build_label_decl (NULL_TREE); | |
753 | exit_label = gfc_build_label_decl (NULL_TREE); | |
754 | ||
755 | /* Put the labels where they can be found later. See gfc_trans_do(). */ | |
756 | code->block->backend_decl = tree_cons (cycle_label, exit_label, NULL); | |
757 | ||
758 | /* Loop body. */ | |
759 | gfc_start_block (&body); | |
760 | ||
761 | /* Main loop body. */ | |
762 | tmp = gfc_trans_code (code->block->next); | |
763 | gfc_add_expr_to_block (&body, tmp); | |
764 | ||
765 | /* Label for cycle statements (if needed). */ | |
766 | if (TREE_USED (cycle_label)) | |
767 | { | |
768 | tmp = build1_v (LABEL_EXPR, cycle_label); | |
769 | gfc_add_expr_to_block (&body, tmp); | |
770 | } | |
771 | ||
772 | /* Evaluate the loop condition. */ | |
61ead135 | 773 | cond = fold_build2 (EQ_EXPR, boolean_type_node, dovar, to); |
fbdad37d PB |
774 | cond = gfc_evaluate_now (cond, &body); |
775 | ||
776 | /* Increment the loop variable. */ | |
61ead135 | 777 | tmp = fold_build2 (PLUS_EXPR, type, dovar, step); |
fbdad37d PB |
778 | gfc_add_modify_expr (&body, dovar, tmp); |
779 | ||
780 | /* The loop exit. */ | |
781 | tmp = build1_v (GOTO_EXPR, exit_label); | |
782 | TREE_USED (exit_label) = 1; | |
61ead135 RG |
783 | tmp = fold_build3 (COND_EXPR, void_type_node, |
784 | cond, tmp, build_empty_stmt ()); | |
fbdad37d PB |
785 | gfc_add_expr_to_block (&body, tmp); |
786 | ||
787 | /* Finish the loop body. */ | |
788 | tmp = gfc_finish_block (&body); | |
789 | tmp = build1_v (LOOP_EXPR, tmp); | |
790 | ||
791 | /* Only execute the loop if the number of iterations is positive. */ | |
792 | if (tree_int_cst_sgn (step) > 0) | |
10c7a96f | 793 | cond = fold_build2 (LE_EXPR, boolean_type_node, dovar, to); |
fbdad37d | 794 | else |
10c7a96f | 795 | cond = fold_build2 (GE_EXPR, boolean_type_node, dovar, to); |
61ead135 RG |
796 | tmp = fold_build3 (COND_EXPR, void_type_node, |
797 | cond, tmp, build_empty_stmt ()); | |
fbdad37d PB |
798 | gfc_add_expr_to_block (pblock, tmp); |
799 | ||
800 | /* Add the exit label. */ | |
801 | tmp = build1_v (LABEL_EXPR, exit_label); | |
802 | gfc_add_expr_to_block (pblock, tmp); | |
803 | ||
804 | return gfc_finish_block (pblock); | |
805 | } | |
806 | ||
6de9cd9a DN |
807 | /* Translate the DO construct. This obviously is one of the most |
808 | important ones to get right with any compiler, but especially | |
809 | so for Fortran. | |
810 | ||
fbdad37d PB |
811 | We special case some loop forms as described in gfc_trans_simple_do. |
812 | For other cases we implement them with a separate loop count, | |
813 | as described in the standard. | |
6de9cd9a DN |
814 | |
815 | We translate a do loop from: | |
816 | ||
817 | DO dovar = from, to, step | |
818 | body | |
819 | END DO | |
820 | ||
821 | to: | |
822 | ||
fbdad37d | 823 | [evaluate loop bounds and step] |
417ab240 | 824 | count = (to + step - from) / step; |
fbdad37d PB |
825 | dovar = from; |
826 | for (;;) | |
6de9cd9a DN |
827 | { |
828 | body; | |
829 | cycle_label: | |
fbdad37d PB |
830 | dovar += step |
831 | count--; | |
832 | if (count <=0) goto exit_label; | |
6de9cd9a DN |
833 | } |
834 | exit_label: | |
835 | ||
6de9cd9a | 836 | TODO: Large loop counts |
fbdad37d | 837 | The code above assumes the loop count fits into a signed integer kind, |
13795658 | 838 | i.e. Does not work for loop counts > 2^31 for integer(kind=4) variables |
8d5cfa27 | 839 | We must support the full range. */ |
6de9cd9a DN |
840 | |
841 | tree | |
842 | gfc_trans_do (gfc_code * code) | |
843 | { | |
844 | gfc_se se; | |
845 | tree dovar; | |
846 | tree from; | |
847 | tree to; | |
848 | tree step; | |
849 | tree count; | |
8d5cfa27 | 850 | tree count_one; |
6de9cd9a DN |
851 | tree type; |
852 | tree cond; | |
853 | tree cycle_label; | |
854 | tree exit_label; | |
855 | tree tmp; | |
856 | stmtblock_t block; | |
857 | stmtblock_t body; | |
858 | ||
859 | gfc_start_block (&block); | |
860 | ||
fbdad37d | 861 | /* Evaluate all the expressions in the iterator. */ |
6de9cd9a DN |
862 | gfc_init_se (&se, NULL); |
863 | gfc_conv_expr_lhs (&se, code->ext.iterator->var); | |
864 | gfc_add_block_to_block (&block, &se.pre); | |
865 | dovar = se.expr; | |
866 | type = TREE_TYPE (dovar); | |
867 | ||
868 | gfc_init_se (&se, NULL); | |
8d5cfa27 | 869 | gfc_conv_expr_val (&se, code->ext.iterator->start); |
6de9cd9a | 870 | gfc_add_block_to_block (&block, &se.pre); |
fbdad37d | 871 | from = gfc_evaluate_now (se.expr, &block); |
6de9cd9a DN |
872 | |
873 | gfc_init_se (&se, NULL); | |
8d5cfa27 | 874 | gfc_conv_expr_val (&se, code->ext.iterator->end); |
6de9cd9a | 875 | gfc_add_block_to_block (&block, &se.pre); |
fbdad37d | 876 | to = gfc_evaluate_now (se.expr, &block); |
6de9cd9a DN |
877 | |
878 | gfc_init_se (&se, NULL); | |
8d5cfa27 | 879 | gfc_conv_expr_val (&se, code->ext.iterator->step); |
6de9cd9a | 880 | gfc_add_block_to_block (&block, &se.pre); |
fbdad37d PB |
881 | step = gfc_evaluate_now (se.expr, &block); |
882 | ||
883 | /* Special case simple loops. */ | |
884 | if (TREE_CODE (type) == INTEGER_TYPE | |
885 | && (integer_onep (step) | |
886 | || tree_int_cst_equal (step, integer_minus_one_node))) | |
887 | return gfc_trans_simple_do (code, &block, dovar, from, to, step); | |
888 | ||
1f2959f0 | 889 | /* Initialize loop count. This code is executed before we enter the |
6de9cd9a DN |
890 | loop body. We generate: count = (to + step - from) / step. */ |
891 | ||
10c7a96f SB |
892 | tmp = fold_build2 (MINUS_EXPR, type, step, from); |
893 | tmp = fold_build2 (PLUS_EXPR, type, to, tmp); | |
8d5cfa27 SK |
894 | if (TREE_CODE (type) == INTEGER_TYPE) |
895 | { | |
10c7a96f | 896 | tmp = fold_build2 (TRUNC_DIV_EXPR, type, tmp, step); |
8d5cfa27 SK |
897 | count = gfc_create_var (type, "count"); |
898 | } | |
899 | else | |
900 | { | |
901 | /* TODO: We could use the same width as the real type. | |
902 | This would probably cause more problems that it solves | |
903 | when we implement "long double" types. */ | |
10c7a96f SB |
904 | tmp = fold_build2 (RDIV_EXPR, type, tmp, step); |
905 | tmp = fold_build1 (FIX_TRUNC_EXPR, gfc_array_index_type, tmp); | |
8d5cfa27 SK |
906 | count = gfc_create_var (gfc_array_index_type, "count"); |
907 | } | |
6de9cd9a DN |
908 | gfc_add_modify_expr (&block, count, tmp); |
909 | ||
c3238e32 | 910 | count_one = build_int_cst (TREE_TYPE (count), 1); |
8d5cfa27 | 911 | |
1f2959f0 | 912 | /* Initialize the DO variable: dovar = from. */ |
6de9cd9a DN |
913 | gfc_add_modify_expr (&block, dovar, from); |
914 | ||
915 | /* Loop body. */ | |
916 | gfc_start_block (&body); | |
917 | ||
918 | /* Cycle and exit statements are implemented with gotos. */ | |
919 | cycle_label = gfc_build_label_decl (NULL_TREE); | |
920 | exit_label = gfc_build_label_decl (NULL_TREE); | |
921 | ||
922 | /* Start with the loop condition. Loop until count <= 0. */ | |
61ead135 RG |
923 | cond = fold_build2 (LE_EXPR, boolean_type_node, count, |
924 | build_int_cst (TREE_TYPE (count), 0)); | |
6de9cd9a DN |
925 | tmp = build1_v (GOTO_EXPR, exit_label); |
926 | TREE_USED (exit_label) = 1; | |
61ead135 RG |
927 | tmp = fold_build3 (COND_EXPR, void_type_node, |
928 | cond, tmp, build_empty_stmt ()); | |
6de9cd9a DN |
929 | gfc_add_expr_to_block (&body, tmp); |
930 | ||
931 | /* Put these labels where they can be found later. We put the | |
932 | labels in a TREE_LIST node (because TREE_CHAIN is already | |
933 | used). cycle_label goes in TREE_PURPOSE (backend_decl), exit | |
934 | label in TREE_VALUE (backend_decl). */ | |
935 | ||
936 | code->block->backend_decl = tree_cons (cycle_label, exit_label, NULL); | |
937 | ||
938 | /* Main loop body. */ | |
939 | tmp = gfc_trans_code (code->block->next); | |
940 | gfc_add_expr_to_block (&body, tmp); | |
941 | ||
942 | /* Label for cycle statements (if needed). */ | |
943 | if (TREE_USED (cycle_label)) | |
944 | { | |
945 | tmp = build1_v (LABEL_EXPR, cycle_label); | |
946 | gfc_add_expr_to_block (&body, tmp); | |
947 | } | |
948 | ||
949 | /* Increment the loop variable. */ | |
923ab88c | 950 | tmp = build2 (PLUS_EXPR, type, dovar, step); |
6de9cd9a DN |
951 | gfc_add_modify_expr (&body, dovar, tmp); |
952 | ||
953 | /* Decrement the loop count. */ | |
8d5cfa27 | 954 | tmp = build2 (MINUS_EXPR, TREE_TYPE (count), count, count_one); |
6de9cd9a DN |
955 | gfc_add_modify_expr (&body, count, tmp); |
956 | ||
957 | /* End of loop body. */ | |
958 | tmp = gfc_finish_block (&body); | |
959 | ||
960 | /* The for loop itself. */ | |
923ab88c | 961 | tmp = build1_v (LOOP_EXPR, tmp); |
6de9cd9a DN |
962 | gfc_add_expr_to_block (&block, tmp); |
963 | ||
964 | /* Add the exit label. */ | |
965 | tmp = build1_v (LABEL_EXPR, exit_label); | |
966 | gfc_add_expr_to_block (&block, tmp); | |
967 | ||
968 | return gfc_finish_block (&block); | |
969 | } | |
970 | ||
971 | ||
972 | /* Translate the DO WHILE construct. | |
973 | ||
974 | We translate | |
975 | ||
976 | DO WHILE (cond) | |
977 | body | |
978 | END DO | |
979 | ||
980 | to: | |
981 | ||
982 | for ( ; ; ) | |
983 | { | |
984 | pre_cond; | |
985 | if (! cond) goto exit_label; | |
986 | body; | |
987 | cycle_label: | |
988 | } | |
989 | exit_label: | |
990 | ||
991 | Because the evaluation of the exit condition `cond' may have side | |
992 | effects, we can't do much for empty loop bodies. The backend optimizers | |
993 | should be smart enough to eliminate any dead loops. */ | |
994 | ||
995 | tree | |
996 | gfc_trans_do_while (gfc_code * code) | |
997 | { | |
998 | gfc_se cond; | |
999 | tree tmp; | |
1000 | tree cycle_label; | |
1001 | tree exit_label; | |
1002 | stmtblock_t block; | |
1003 | ||
1004 | /* Everything we build here is part of the loop body. */ | |
1005 | gfc_start_block (&block); | |
1006 | ||
1007 | /* Cycle and exit statements are implemented with gotos. */ | |
1008 | cycle_label = gfc_build_label_decl (NULL_TREE); | |
1009 | exit_label = gfc_build_label_decl (NULL_TREE); | |
1010 | ||
1011 | /* Put the labels where they can be found later. See gfc_trans_do(). */ | |
1012 | code->block->backend_decl = tree_cons (cycle_label, exit_label, NULL); | |
1013 | ||
1014 | /* Create a GIMPLE version of the exit condition. */ | |
1015 | gfc_init_se (&cond, NULL); | |
1016 | gfc_conv_expr_val (&cond, code->expr); | |
1017 | gfc_add_block_to_block (&block, &cond.pre); | |
10c7a96f | 1018 | cond.expr = fold_build1 (TRUTH_NOT_EXPR, boolean_type_node, cond.expr); |
6de9cd9a DN |
1019 | |
1020 | /* Build "IF (! cond) GOTO exit_label". */ | |
1021 | tmp = build1_v (GOTO_EXPR, exit_label); | |
1022 | TREE_USED (exit_label) = 1; | |
61ead135 RG |
1023 | tmp = fold_build3 (COND_EXPR, void_type_node, |
1024 | cond.expr, tmp, build_empty_stmt ()); | |
6de9cd9a DN |
1025 | gfc_add_expr_to_block (&block, tmp); |
1026 | ||
1027 | /* The main body of the loop. */ | |
1028 | tmp = gfc_trans_code (code->block->next); | |
1029 | gfc_add_expr_to_block (&block, tmp); | |
1030 | ||
1031 | /* Label for cycle statements (if needed). */ | |
1032 | if (TREE_USED (cycle_label)) | |
1033 | { | |
1034 | tmp = build1_v (LABEL_EXPR, cycle_label); | |
1035 | gfc_add_expr_to_block (&block, tmp); | |
1036 | } | |
1037 | ||
1038 | /* End of loop body. */ | |
1039 | tmp = gfc_finish_block (&block); | |
1040 | ||
1041 | gfc_init_block (&block); | |
1042 | /* Build the loop. */ | |
923ab88c | 1043 | tmp = build1_v (LOOP_EXPR, tmp); |
6de9cd9a DN |
1044 | gfc_add_expr_to_block (&block, tmp); |
1045 | ||
1046 | /* Add the exit label. */ | |
1047 | tmp = build1_v (LABEL_EXPR, exit_label); | |
1048 | gfc_add_expr_to_block (&block, tmp); | |
1049 | ||
1050 | return gfc_finish_block (&block); | |
1051 | } | |
1052 | ||
1053 | ||
1054 | /* Translate the SELECT CASE construct for INTEGER case expressions, | |
1055 | without killing all potential optimizations. The problem is that | |
1056 | Fortran allows unbounded cases, but the back-end does not, so we | |
1057 | need to intercept those before we enter the equivalent SWITCH_EXPR | |
1058 | we can build. | |
1059 | ||
1060 | For example, we translate this, | |
1061 | ||
1062 | SELECT CASE (expr) | |
1063 | CASE (:100,101,105:115) | |
1064 | block_1 | |
1065 | CASE (190:199,200:) | |
1066 | block_2 | |
1067 | CASE (300) | |
1068 | block_3 | |
1069 | CASE DEFAULT | |
1070 | block_4 | |
1071 | END SELECT | |
1072 | ||
1073 | to the GENERIC equivalent, | |
1074 | ||
1075 | switch (expr) | |
1076 | { | |
1077 | case (minimum value for typeof(expr) ... 100: | |
1078 | case 101: | |
1079 | case 105 ... 114: | |
1080 | block1: | |
1081 | goto end_label; | |
1082 | ||
1083 | case 200 ... (maximum value for typeof(expr): | |
1084 | case 190 ... 199: | |
1085 | block2; | |
1086 | goto end_label; | |
1087 | ||
1088 | case 300: | |
1089 | block_3; | |
1090 | goto end_label; | |
1091 | ||
1092 | default: | |
1093 | block_4; | |
1094 | goto end_label; | |
1095 | } | |
1096 | ||
1097 | end_label: */ | |
1098 | ||
1099 | static tree | |
1100 | gfc_trans_integer_select (gfc_code * code) | |
1101 | { | |
1102 | gfc_code *c; | |
1103 | gfc_case *cp; | |
1104 | tree end_label; | |
1105 | tree tmp; | |
1106 | gfc_se se; | |
1107 | stmtblock_t block; | |
1108 | stmtblock_t body; | |
1109 | ||
1110 | gfc_start_block (&block); | |
1111 | ||
1112 | /* Calculate the switch expression. */ | |
1113 | gfc_init_se (&se, NULL); | |
1114 | gfc_conv_expr_val (&se, code->expr); | |
1115 | gfc_add_block_to_block (&block, &se.pre); | |
1116 | ||
1117 | end_label = gfc_build_label_decl (NULL_TREE); | |
1118 | ||
1119 | gfc_init_block (&body); | |
1120 | ||
1121 | for (c = code->block; c; c = c->block) | |
1122 | { | |
1123 | for (cp = c->ext.case_list; cp; cp = cp->next) | |
1124 | { | |
1125 | tree low, high; | |
1126 | tree label; | |
1127 | ||
1128 | /* Assume it's the default case. */ | |
1129 | low = high = NULL_TREE; | |
1130 | ||
1131 | if (cp->low) | |
1132 | { | |
1133 | low = gfc_conv_constant_to_tree (cp->low); | |
1134 | ||
1135 | /* If there's only a lower bound, set the high bound to the | |
1136 | maximum value of the case expression. */ | |
1137 | if (!cp->high) | |
1138 | high = TYPE_MAX_VALUE (TREE_TYPE (se.expr)); | |
1139 | } | |
1140 | ||
1141 | if (cp->high) | |
1142 | { | |
1143 | /* Three cases are possible here: | |
1144 | ||
1145 | 1) There is no lower bound, e.g. CASE (:N). | |
1146 | 2) There is a lower bound .NE. high bound, that is | |
1147 | a case range, e.g. CASE (N:M) where M>N (we make | |
1148 | sure that M>N during type resolution). | |
1149 | 3) There is a lower bound, and it has the same value | |
1150 | as the high bound, e.g. CASE (N:N). This is our | |
1151 | internal representation of CASE(N). | |
1152 | ||
1153 | In the first and second case, we need to set a value for | |
e2ae1407 | 1154 | high. In the third case, we don't because the GCC middle |
6de9cd9a DN |
1155 | end represents a single case value by just letting high be |
1156 | a NULL_TREE. We can't do that because we need to be able | |
1157 | to represent unbounded cases. */ | |
1158 | ||
1159 | if (!cp->low | |
1160 | || (cp->low | |
1161 | && mpz_cmp (cp->low->value.integer, | |
1162 | cp->high->value.integer) != 0)) | |
1163 | high = gfc_conv_constant_to_tree (cp->high); | |
1164 | ||
1165 | /* Unbounded case. */ | |
1166 | if (!cp->low) | |
1167 | low = TYPE_MIN_VALUE (TREE_TYPE (se.expr)); | |
1168 | } | |
1169 | ||
1170 | /* Build a label. */ | |
c006df4e | 1171 | label = gfc_build_label_decl (NULL_TREE); |
6de9cd9a DN |
1172 | |
1173 | /* Add this case label. | |
1174 | Add parameter 'label', make it match GCC backend. */ | |
923ab88c | 1175 | tmp = build3 (CASE_LABEL_EXPR, void_type_node, low, high, label); |
6de9cd9a DN |
1176 | gfc_add_expr_to_block (&body, tmp); |
1177 | } | |
1178 | ||
1179 | /* Add the statements for this case. */ | |
1180 | tmp = gfc_trans_code (c->next); | |
1181 | gfc_add_expr_to_block (&body, tmp); | |
1182 | ||
1183 | /* Break to the end of the construct. */ | |
1184 | tmp = build1_v (GOTO_EXPR, end_label); | |
1185 | gfc_add_expr_to_block (&body, tmp); | |
1186 | } | |
1187 | ||
1188 | tmp = gfc_finish_block (&body); | |
923ab88c | 1189 | tmp = build3_v (SWITCH_EXPR, se.expr, tmp, NULL_TREE); |
6de9cd9a DN |
1190 | gfc_add_expr_to_block (&block, tmp); |
1191 | ||
1192 | tmp = build1_v (LABEL_EXPR, end_label); | |
1193 | gfc_add_expr_to_block (&block, tmp); | |
1194 | ||
1195 | return gfc_finish_block (&block); | |
1196 | } | |
1197 | ||
1198 | ||
1199 | /* Translate the SELECT CASE construct for LOGICAL case expressions. | |
1200 | ||
1201 | There are only two cases possible here, even though the standard | |
1202 | does allow three cases in a LOGICAL SELECT CASE construct: .TRUE., | |
1203 | .FALSE., and DEFAULT. | |
1204 | ||
1205 | We never generate more than two blocks here. Instead, we always | |
1206 | try to eliminate the DEFAULT case. This way, we can translate this | |
1207 | kind of SELECT construct to a simple | |
1208 | ||
1209 | if {} else {}; | |
1210 | ||
1211 | expression in GENERIC. */ | |
1212 | ||
1213 | static tree | |
1214 | gfc_trans_logical_select (gfc_code * code) | |
1215 | { | |
1216 | gfc_code *c; | |
1217 | gfc_code *t, *f, *d; | |
1218 | gfc_case *cp; | |
1219 | gfc_se se; | |
1220 | stmtblock_t block; | |
1221 | ||
1222 | /* Assume we don't have any cases at all. */ | |
1223 | t = f = d = NULL; | |
1224 | ||
1225 | /* Now see which ones we actually do have. We can have at most two | |
1226 | cases in a single case list: one for .TRUE. and one for .FALSE. | |
1227 | The default case is always separate. If the cases for .TRUE. and | |
1228 | .FALSE. are in the same case list, the block for that case list | |
1229 | always executed, and we don't generate code a COND_EXPR. */ | |
1230 | for (c = code->block; c; c = c->block) | |
1231 | { | |
1232 | for (cp = c->ext.case_list; cp; cp = cp->next) | |
1233 | { | |
1234 | if (cp->low) | |
1235 | { | |
1236 | if (cp->low->value.logical == 0) /* .FALSE. */ | |
1237 | f = c; | |
1238 | else /* if (cp->value.logical != 0), thus .TRUE. */ | |
1239 | t = c; | |
1240 | } | |
1241 | else | |
1242 | d = c; | |
1243 | } | |
1244 | } | |
1245 | ||
1246 | /* Start a new block. */ | |
1247 | gfc_start_block (&block); | |
1248 | ||
1249 | /* Calculate the switch expression. We always need to do this | |
1250 | because it may have side effects. */ | |
1251 | gfc_init_se (&se, NULL); | |
1252 | gfc_conv_expr_val (&se, code->expr); | |
1253 | gfc_add_block_to_block (&block, &se.pre); | |
1254 | ||
1255 | if (t == f && t != NULL) | |
1256 | { | |
1257 | /* Cases for .TRUE. and .FALSE. are in the same block. Just | |
1258 | translate the code for these cases, append it to the current | |
1259 | block. */ | |
1260 | gfc_add_expr_to_block (&block, gfc_trans_code (t->next)); | |
1261 | } | |
1262 | else | |
1263 | { | |
61ead135 | 1264 | tree true_tree, false_tree, stmt; |
6de9cd9a DN |
1265 | |
1266 | true_tree = build_empty_stmt (); | |
1267 | false_tree = build_empty_stmt (); | |
1268 | ||
1269 | /* If we have a case for .TRUE. and for .FALSE., discard the default case. | |
1270 | Otherwise, if .TRUE. or .FALSE. is missing and there is a default case, | |
1271 | make the missing case the default case. */ | |
1272 | if (t != NULL && f != NULL) | |
1273 | d = NULL; | |
1274 | else if (d != NULL) | |
1275 | { | |
1276 | if (t == NULL) | |
1277 | t = d; | |
1278 | else | |
1279 | f = d; | |
1280 | } | |
1281 | ||
1282 | /* Translate the code for each of these blocks, and append it to | |
1283 | the current block. */ | |
1284 | if (t != NULL) | |
1285 | true_tree = gfc_trans_code (t->next); | |
1286 | ||
1287 | if (f != NULL) | |
1288 | false_tree = gfc_trans_code (f->next); | |
1289 | ||
61ead135 RG |
1290 | stmt = fold_build3 (COND_EXPR, void_type_node, se.expr, |
1291 | true_tree, false_tree); | |
1292 | gfc_add_expr_to_block (&block, stmt); | |
6de9cd9a DN |
1293 | } |
1294 | ||
1295 | return gfc_finish_block (&block); | |
1296 | } | |
1297 | ||
1298 | ||
1299 | /* Translate the SELECT CASE construct for CHARACTER case expressions. | |
1300 | Instead of generating compares and jumps, it is far simpler to | |
1301 | generate a data structure describing the cases in order and call a | |
1302 | library subroutine that locates the right case. | |
1303 | This is particularly true because this is the only case where we | |
1304 | might have to dispose of a temporary. | |
1305 | The library subroutine returns a pointer to jump to or NULL if no | |
1306 | branches are to be taken. */ | |
1307 | ||
1308 | static tree | |
1309 | gfc_trans_character_select (gfc_code *code) | |
1310 | { | |
1311 | tree init, node, end_label, tmp, type, args, *labels; | |
dc6c7714 | 1312 | tree case_label; |
6de9cd9a DN |
1313 | stmtblock_t block, body; |
1314 | gfc_case *cp, *d; | |
1315 | gfc_code *c; | |
1316 | gfc_se se; | |
1317 | int i, n; | |
1318 | ||
1319 | static tree select_struct; | |
1320 | static tree ss_string1, ss_string1_len; | |
1321 | static tree ss_string2, ss_string2_len; | |
1322 | static tree ss_target; | |
1323 | ||
1324 | if (select_struct == NULL) | |
1325 | { | |
e2cad04b RH |
1326 | tree gfc_int4_type_node = gfc_get_int_type (4); |
1327 | ||
6de9cd9a DN |
1328 | select_struct = make_node (RECORD_TYPE); |
1329 | TYPE_NAME (select_struct) = get_identifier ("_jump_struct"); | |
1330 | ||
1331 | #undef ADD_FIELD | |
1332 | #define ADD_FIELD(NAME, TYPE) \ | |
1333 | ss_##NAME = gfc_add_field_to_struct \ | |
1334 | (&(TYPE_FIELDS (select_struct)), select_struct, \ | |
1335 | get_identifier (stringize(NAME)), TYPE) | |
1336 | ||
1337 | ADD_FIELD (string1, pchar_type_node); | |
1338 | ADD_FIELD (string1_len, gfc_int4_type_node); | |
1339 | ||
1340 | ADD_FIELD (string2, pchar_type_node); | |
1341 | ADD_FIELD (string2_len, gfc_int4_type_node); | |
1342 | ||
1343 | ADD_FIELD (target, pvoid_type_node); | |
1344 | #undef ADD_FIELD | |
1345 | ||
1346 | gfc_finish_type (select_struct); | |
1347 | } | |
1348 | ||
1349 | cp = code->block->ext.case_list; | |
1350 | while (cp->left != NULL) | |
1351 | cp = cp->left; | |
1352 | ||
1353 | n = 0; | |
1354 | for (d = cp; d; d = d->right) | |
1355 | d->n = n++; | |
1356 | ||
1357 | if (n != 0) | |
1358 | labels = gfc_getmem (n * sizeof (tree)); | |
1359 | else | |
1360 | labels = NULL; | |
1361 | ||
1362 | for(i = 0; i < n; i++) | |
1363 | { | |
1364 | labels[i] = gfc_build_label_decl (NULL_TREE); | |
1365 | TREE_USED (labels[i]) = 1; | |
1366 | /* TODO: The gimplifier should do this for us, but it has | |
1367 | inadequacies when dealing with static initializers. */ | |
1368 | FORCED_LABEL (labels[i]) = 1; | |
1369 | } | |
1370 | ||
1371 | end_label = gfc_build_label_decl (NULL_TREE); | |
1372 | ||
1373 | /* Generate the body */ | |
1374 | gfc_start_block (&block); | |
1375 | gfc_init_block (&body); | |
1376 | ||
1377 | for (c = code->block; c; c = c->block) | |
1378 | { | |
1379 | for (d = c->ext.case_list; d; d = d->next) | |
1380 | { | |
923ab88c | 1381 | tmp = build1_v (LABEL_EXPR, labels[d->n]); |
6de9cd9a DN |
1382 | gfc_add_expr_to_block (&body, tmp); |
1383 | } | |
1384 | ||
1385 | tmp = gfc_trans_code (c->next); | |
1386 | gfc_add_expr_to_block (&body, tmp); | |
1387 | ||
923ab88c | 1388 | tmp = build1_v (GOTO_EXPR, end_label); |
6de9cd9a DN |
1389 | gfc_add_expr_to_block (&body, tmp); |
1390 | } | |
1391 | ||
1392 | /* Generate the structure describing the branches */ | |
1393 | init = NULL_TREE; | |
1394 | i = 0; | |
1395 | ||
1396 | for(d = cp; d; d = d->right, i++) | |
1397 | { | |
1398 | node = NULL_TREE; | |
1399 | ||
1400 | gfc_init_se (&se, NULL); | |
1401 | ||
1402 | if (d->low == NULL) | |
1403 | { | |
1404 | node = tree_cons (ss_string1, null_pointer_node, node); | |
1405 | node = tree_cons (ss_string1_len, integer_zero_node, node); | |
1406 | } | |
1407 | else | |
1408 | { | |
1409 | gfc_conv_expr_reference (&se, d->low); | |
1410 | ||
1411 | node = tree_cons (ss_string1, se.expr, node); | |
1412 | node = tree_cons (ss_string1_len, se.string_length, node); | |
1413 | } | |
1414 | ||
1415 | if (d->high == NULL) | |
1416 | { | |
1417 | node = tree_cons (ss_string2, null_pointer_node, node); | |
1418 | node = tree_cons (ss_string2_len, integer_zero_node, node); | |
1419 | } | |
1420 | else | |
1421 | { | |
1422 | gfc_init_se (&se, NULL); | |
1423 | gfc_conv_expr_reference (&se, d->high); | |
1424 | ||
1425 | node = tree_cons (ss_string2, se.expr, node); | |
1426 | node = tree_cons (ss_string2_len, se.string_length, node); | |
1427 | } | |
1428 | ||
1429 | tmp = gfc_build_addr_expr (pvoid_type_node, labels[i]); | |
1430 | node = tree_cons (ss_target, tmp, node); | |
1431 | ||
4038c495 | 1432 | tmp = build_constructor_from_list (select_struct, nreverse (node)); |
6de9cd9a DN |
1433 | init = tree_cons (NULL_TREE, tmp, init); |
1434 | } | |
1435 | ||
4a90aeeb | 1436 | type = build_array_type (select_struct, build_index_type |
7d60be94 | 1437 | (build_int_cst (NULL_TREE, n - 1))); |
6de9cd9a | 1438 | |
4038c495 | 1439 | init = build_constructor_from_list (type, nreverse(init)); |
6de9cd9a DN |
1440 | TREE_CONSTANT (init) = 1; |
1441 | TREE_INVARIANT (init) = 1; | |
1442 | TREE_STATIC (init) = 1; | |
1443 | /* Create a static variable to hold the jump table. */ | |
1444 | tmp = gfc_create_var (type, "jumptable"); | |
1445 | TREE_CONSTANT (tmp) = 1; | |
1446 | TREE_INVARIANT (tmp) = 1; | |
1447 | TREE_STATIC (tmp) = 1; | |
1448 | DECL_INITIAL (tmp) = init; | |
1449 | init = tmp; | |
1450 | ||
1451 | /* Build an argument list for the library call */ | |
1452 | init = gfc_build_addr_expr (pvoid_type_node, init); | |
1453 | args = gfc_chainon_list (NULL_TREE, init); | |
1454 | ||
7d60be94 | 1455 | tmp = build_int_cst (NULL_TREE, n); |
6de9cd9a DN |
1456 | args = gfc_chainon_list (args, tmp); |
1457 | ||
1458 | tmp = gfc_build_addr_expr (pvoid_type_node, end_label); | |
1459 | args = gfc_chainon_list (args, tmp); | |
1460 | ||
1461 | gfc_init_se (&se, NULL); | |
1462 | gfc_conv_expr_reference (&se, code->expr); | |
1463 | ||
1464 | args = gfc_chainon_list (args, se.expr); | |
1465 | args = gfc_chainon_list (args, se.string_length); | |
1466 | ||
1467 | gfc_add_block_to_block (&block, &se.pre); | |
1468 | ||
3380b802 | 1469 | tmp = build_function_call_expr (gfor_fndecl_select_string, args); |
dc6c7714 PT |
1470 | case_label = gfc_create_var (TREE_TYPE (tmp), "case_label"); |
1471 | gfc_add_modify_expr (&block, case_label, tmp); | |
1472 | ||
1473 | gfc_add_block_to_block (&block, &se.post); | |
1474 | ||
1475 | tmp = build1 (GOTO_EXPR, void_type_node, case_label); | |
6de9cd9a DN |
1476 | gfc_add_expr_to_block (&block, tmp); |
1477 | ||
1478 | tmp = gfc_finish_block (&body); | |
1479 | gfc_add_expr_to_block (&block, tmp); | |
923ab88c | 1480 | tmp = build1_v (LABEL_EXPR, end_label); |
6de9cd9a DN |
1481 | gfc_add_expr_to_block (&block, tmp); |
1482 | ||
1483 | if (n != 0) | |
1484 | gfc_free (labels); | |
1485 | ||
1486 | return gfc_finish_block (&block); | |
1487 | } | |
1488 | ||
1489 | ||
1490 | /* Translate the three variants of the SELECT CASE construct. | |
1491 | ||
1492 | SELECT CASEs with INTEGER case expressions can be translated to an | |
1493 | equivalent GENERIC switch statement, and for LOGICAL case | |
1494 | expressions we build one or two if-else compares. | |
1495 | ||
1496 | SELECT CASEs with CHARACTER case expressions are a whole different | |
1497 | story, because they don't exist in GENERIC. So we sort them and | |
1498 | do a binary search at runtime. | |
1499 | ||
1500 | Fortran has no BREAK statement, and it does not allow jumps from | |
1501 | one case block to another. That makes things a lot easier for | |
1502 | the optimizers. */ | |
1503 | ||
1504 | tree | |
1505 | gfc_trans_select (gfc_code * code) | |
1506 | { | |
6e45f57b | 1507 | gcc_assert (code && code->expr); |
6de9cd9a DN |
1508 | |
1509 | /* Empty SELECT constructs are legal. */ | |
1510 | if (code->block == NULL) | |
1511 | return build_empty_stmt (); | |
1512 | ||
1513 | /* Select the correct translation function. */ | |
1514 | switch (code->expr->ts.type) | |
1515 | { | |
1516 | case BT_LOGICAL: return gfc_trans_logical_select (code); | |
1517 | case BT_INTEGER: return gfc_trans_integer_select (code); | |
1518 | case BT_CHARACTER: return gfc_trans_character_select (code); | |
1519 | default: | |
1520 | gfc_internal_error ("gfc_trans_select(): Bad type for case expr."); | |
1521 | /* Not reached */ | |
1522 | } | |
1523 | } | |
1524 | ||
1525 | ||
1526 | /* Generate the loops for a FORALL block. The normal loop format: | |
1527 | count = (end - start + step) / step | |
1528 | loopvar = start | |
1529 | while (1) | |
1530 | { | |
1531 | if (count <=0 ) | |
1532 | goto end_of_loop | |
1533 | <body> | |
1534 | loopvar += step | |
1535 | count -- | |
1536 | } | |
1537 | end_of_loop: */ | |
1538 | ||
1539 | static tree | |
1540 | gfc_trans_forall_loop (forall_info *forall_tmp, int nvar, tree body, int mask_flag) | |
1541 | { | |
1542 | int n; | |
1543 | tree tmp; | |
1544 | tree cond; | |
1545 | stmtblock_t block; | |
1546 | tree exit_label; | |
1547 | tree count; | |
fcf3be37 | 1548 | tree var, start, end, step; |
6de9cd9a DN |
1549 | iter_info *iter; |
1550 | ||
1551 | iter = forall_tmp->this_loop; | |
1552 | for (n = 0; n < nvar; n++) | |
1553 | { | |
1554 | var = iter->var; | |
1555 | start = iter->start; | |
1556 | end = iter->end; | |
1557 | step = iter->step; | |
1558 | ||
1559 | exit_label = gfc_build_label_decl (NULL_TREE); | |
1560 | TREE_USED (exit_label) = 1; | |
1561 | ||
1562 | /* The loop counter. */ | |
1563 | count = gfc_create_var (TREE_TYPE (var), "count"); | |
1564 | ||
1565 | /* The body of the loop. */ | |
1566 | gfc_init_block (&block); | |
1567 | ||
1568 | /* The exit condition. */ | |
61ead135 RG |
1569 | cond = fold_build2 (LE_EXPR, boolean_type_node, |
1570 | count, build_int_cst (TREE_TYPE (count), 0)); | |
6de9cd9a | 1571 | tmp = build1_v (GOTO_EXPR, exit_label); |
61ead135 RG |
1572 | tmp = fold_build3 (COND_EXPR, void_type_node, |
1573 | cond, tmp, build_empty_stmt ()); | |
6de9cd9a DN |
1574 | gfc_add_expr_to_block (&block, tmp); |
1575 | ||
1576 | /* The main loop body. */ | |
1577 | gfc_add_expr_to_block (&block, body); | |
1578 | ||
1579 | /* Increment the loop variable. */ | |
923ab88c | 1580 | tmp = build2 (PLUS_EXPR, TREE_TYPE (var), var, step); |
6de9cd9a DN |
1581 | gfc_add_modify_expr (&block, var, tmp); |
1582 | ||
a8e12e4d TS |
1583 | /* Advance to the next mask element. Only do this for the |
1584 | innermost loop. */ | |
fcf3be37 JJ |
1585 | if (n == 0 && mask_flag && forall_tmp->mask) |
1586 | { | |
1587 | tree maskindex = forall_tmp->maskindex; | |
1588 | tmp = build2 (PLUS_EXPR, gfc_array_index_type, | |
1589 | maskindex, gfc_index_one_node); | |
1590 | gfc_add_modify_expr (&block, maskindex, tmp); | |
1591 | } | |
1592 | ||
6de9cd9a | 1593 | /* Decrement the loop counter. */ |
923ab88c | 1594 | tmp = build2 (MINUS_EXPR, TREE_TYPE (var), count, gfc_index_one_node); |
6de9cd9a DN |
1595 | gfc_add_modify_expr (&block, count, tmp); |
1596 | ||
1597 | body = gfc_finish_block (&block); | |
1598 | ||
1599 | /* Loop var initialization. */ | |
1600 | gfc_init_block (&block); | |
1601 | gfc_add_modify_expr (&block, var, start); | |
1602 | ||
fcf3be37 JJ |
1603 | /* Initialize maskindex counter. Only do this before the |
1604 | outermost loop. */ | |
1605 | if (n == nvar - 1 && mask_flag && forall_tmp->mask) | |
1606 | gfc_add_modify_expr (&block, forall_tmp->maskindex, | |
1607 | gfc_index_zero_node); | |
1608 | ||
6de9cd9a | 1609 | /* Initialize the loop counter. */ |
10c7a96f SB |
1610 | tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (var), step, start); |
1611 | tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (var), end, tmp); | |
1612 | tmp = fold_build2 (TRUNC_DIV_EXPR, TREE_TYPE (var), tmp, step); | |
6de9cd9a DN |
1613 | gfc_add_modify_expr (&block, count, tmp); |
1614 | ||
1615 | /* The loop expression. */ | |
923ab88c | 1616 | tmp = build1_v (LOOP_EXPR, body); |
6de9cd9a DN |
1617 | gfc_add_expr_to_block (&block, tmp); |
1618 | ||
1619 | /* The exit label. */ | |
1620 | tmp = build1_v (LABEL_EXPR, exit_label); | |
1621 | gfc_add_expr_to_block (&block, tmp); | |
1622 | ||
1623 | body = gfc_finish_block (&block); | |
1624 | iter = iter->next; | |
1625 | } | |
1626 | return body; | |
1627 | } | |
1628 | ||
1629 | ||
1630 | /* Generate the body and loops according to MASK_FLAG and NEST_FLAG. | |
13795658 | 1631 | if MASK_FLAG is nonzero, the body is controlled by maskes in forall |
6de9cd9a | 1632 | nest, otherwise, the body is not controlled by maskes. |
13795658 | 1633 | if NEST_FLAG is nonzero, generate loops for nested forall, otherwise, |
6de9cd9a DN |
1634 | only generate loops for the current forall level. */ |
1635 | ||
1636 | static tree | |
1637 | gfc_trans_nested_forall_loop (forall_info * nested_forall_info, tree body, | |
1638 | int mask_flag, int nest_flag) | |
1639 | { | |
1640 | tree tmp; | |
1641 | int nvar; | |
1642 | forall_info *forall_tmp; | |
1643 | tree pmask, mask, maskindex; | |
1644 | ||
1645 | forall_tmp = nested_forall_info; | |
1646 | /* Generate loops for nested forall. */ | |
1647 | if (nest_flag) | |
1648 | { | |
1649 | while (forall_tmp->next_nest != NULL) | |
1650 | forall_tmp = forall_tmp->next_nest; | |
1651 | while (forall_tmp != NULL) | |
1652 | { | |
1653 | /* Generate body with masks' control. */ | |
1654 | if (mask_flag) | |
1655 | { | |
1656 | pmask = forall_tmp->pmask; | |
1657 | mask = forall_tmp->mask; | |
1658 | maskindex = forall_tmp->maskindex; | |
1659 | ||
1660 | if (mask) | |
1661 | { | |
1f2959f0 | 1662 | /* If a mask was specified make the assignment conditional. */ |
6de9cd9a | 1663 | if (pmask) |
38611275 | 1664 | tmp = build_fold_indirect_ref (mask); |
6de9cd9a DN |
1665 | else |
1666 | tmp = mask; | |
1667 | tmp = gfc_build_array_ref (tmp, maskindex); | |
1668 | ||
923ab88c | 1669 | body = build3_v (COND_EXPR, tmp, body, build_empty_stmt ()); |
6de9cd9a DN |
1670 | } |
1671 | } | |
1672 | nvar = forall_tmp->nvar; | |
1673 | body = gfc_trans_forall_loop (forall_tmp, nvar, body, mask_flag); | |
1674 | forall_tmp = forall_tmp->outer; | |
1675 | } | |
1676 | } | |
1677 | else | |
1678 | { | |
1679 | nvar = forall_tmp->nvar; | |
1680 | body = gfc_trans_forall_loop (forall_tmp, nvar, body, mask_flag); | |
1681 | } | |
1682 | ||
1683 | return body; | |
1684 | } | |
1685 | ||
1686 | ||
1687 | /* Allocate data for holding a temporary array. Returns either a local | |
1688 | temporary array or a pointer variable. */ | |
1689 | ||
1690 | static tree | |
1691 | gfc_do_allocate (tree bytesize, tree size, tree * pdata, stmtblock_t * pblock, | |
1692 | tree elem_type) | |
1693 | { | |
1694 | tree tmpvar; | |
1695 | tree type; | |
1696 | tree tmp; | |
1697 | tree args; | |
1698 | ||
1699 | if (INTEGER_CST_P (size)) | |
1700 | { | |
10c7a96f SB |
1701 | tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, size, |
1702 | gfc_index_one_node); | |
6de9cd9a DN |
1703 | } |
1704 | else | |
1705 | tmp = NULL_TREE; | |
1706 | ||
7ab92584 | 1707 | type = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp); |
6de9cd9a DN |
1708 | type = build_array_type (elem_type, type); |
1709 | if (gfc_can_put_var_on_stack (bytesize)) | |
1710 | { | |
6e45f57b | 1711 | gcc_assert (INTEGER_CST_P (size)); |
6de9cd9a DN |
1712 | tmpvar = gfc_create_var (type, "temp"); |
1713 | *pdata = NULL_TREE; | |
1714 | } | |
1715 | else | |
1716 | { | |
1717 | tmpvar = gfc_create_var (build_pointer_type (type), "temp"); | |
1718 | *pdata = convert (pvoid_type_node, tmpvar); | |
1719 | ||
1720 | args = gfc_chainon_list (NULL_TREE, bytesize); | |
1721 | if (gfc_index_integer_kind == 4) | |
1722 | tmp = gfor_fndecl_internal_malloc; | |
1723 | else if (gfc_index_integer_kind == 8) | |
1724 | tmp = gfor_fndecl_internal_malloc64; | |
1725 | else | |
6e45f57b | 1726 | gcc_unreachable (); |
3380b802 | 1727 | tmp = build_function_call_expr (tmp, args); |
6de9cd9a DN |
1728 | tmp = convert (TREE_TYPE (tmpvar), tmp); |
1729 | gfc_add_modify_expr (pblock, tmpvar, tmp); | |
1730 | } | |
1731 | return tmpvar; | |
1732 | } | |
1733 | ||
1734 | ||
1735 | /* Generate codes to copy the temporary to the actual lhs. */ | |
1736 | ||
1737 | static tree | |
8de1f441 | 1738 | generate_loop_for_temp_to_lhs (gfc_expr *expr, tree tmp1, tree count3, |
011daa76 | 1739 | tree count1, tree wheremask, bool invert) |
6de9cd9a DN |
1740 | { |
1741 | gfc_ss *lss; | |
1742 | gfc_se lse, rse; | |
1743 | stmtblock_t block, body; | |
1744 | gfc_loopinfo loop1; | |
011daa76 | 1745 | tree tmp; |
6de9cd9a DN |
1746 | tree wheremaskexpr; |
1747 | ||
1748 | /* Walk the lhs. */ | |
1749 | lss = gfc_walk_expr (expr); | |
1750 | ||
1751 | if (lss == gfc_ss_terminator) | |
1752 | { | |
1753 | gfc_start_block (&block); | |
1754 | ||
1755 | gfc_init_se (&lse, NULL); | |
1756 | ||
1757 | /* Translate the expression. */ | |
1758 | gfc_conv_expr (&lse, expr); | |
1759 | ||
1760 | /* Form the expression for the temporary. */ | |
1761 | tmp = gfc_build_array_ref (tmp1, count1); | |
1762 | ||
1763 | /* Use the scalar assignment as is. */ | |
1764 | gfc_add_block_to_block (&block, &lse.pre); | |
1765 | gfc_add_modify_expr (&block, lse.expr, tmp); | |
1766 | gfc_add_block_to_block (&block, &lse.post); | |
1767 | ||
1768 | /* Increment the count1. */ | |
8de1f441 JJ |
1769 | tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (count1), count1, |
1770 | gfc_index_one_node); | |
6de9cd9a | 1771 | gfc_add_modify_expr (&block, count1, tmp); |
8de1f441 | 1772 | |
6de9cd9a DN |
1773 | tmp = gfc_finish_block (&block); |
1774 | } | |
1775 | else | |
1776 | { | |
1777 | gfc_start_block (&block); | |
1778 | ||
1779 | gfc_init_loopinfo (&loop1); | |
1780 | gfc_init_se (&rse, NULL); | |
1781 | gfc_init_se (&lse, NULL); | |
1782 | ||
1783 | /* Associate the lss with the loop. */ | |
1784 | gfc_add_ss_to_loop (&loop1, lss); | |
1785 | ||
1786 | /* Calculate the bounds of the scalarization. */ | |
1787 | gfc_conv_ss_startstride (&loop1); | |
1788 | /* Setup the scalarizing loops. */ | |
1789 | gfc_conv_loop_setup (&loop1); | |
1790 | ||
1791 | gfc_mark_ss_chain_used (lss, 1); | |
6de9cd9a DN |
1792 | |
1793 | /* Start the scalarized loop body. */ | |
1794 | gfc_start_scalarized_body (&loop1, &body); | |
1795 | ||
1796 | /* Setup the gfc_se structures. */ | |
1797 | gfc_copy_loopinfo_to_se (&lse, &loop1); | |
1798 | lse.ss = lss; | |
1799 | ||
1800 | /* Form the expression of the temporary. */ | |
1801 | if (lss != gfc_ss_terminator) | |
8de1f441 | 1802 | rse.expr = gfc_build_array_ref (tmp1, count1); |
6de9cd9a DN |
1803 | /* Translate expr. */ |
1804 | gfc_conv_expr (&lse, expr); | |
1805 | ||
1806 | /* Use the scalar assignment. */ | |
5046aff5 PT |
1807 | rse.string_length = lse.string_length; |
1808 | tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false); | |
6de9cd9a | 1809 | |
011daa76 RS |
1810 | /* Form the mask expression according to the mask tree list. */ |
1811 | if (wheremask) | |
1812 | { | |
1813 | wheremaskexpr = gfc_build_array_ref (wheremask, count3); | |
1814 | if (invert) | |
1815 | wheremaskexpr = fold_build1 (TRUTH_NOT_EXPR, | |
1816 | TREE_TYPE (wheremaskexpr), | |
1817 | wheremaskexpr); | |
1818 | tmp = fold_build3 (COND_EXPR, void_type_node, | |
1819 | wheremaskexpr, tmp, build_empty_stmt ()); | |
6de9cd9a DN |
1820 | } |
1821 | ||
1822 | gfc_add_expr_to_block (&body, tmp); | |
1823 | ||
8de1f441 | 1824 | /* Increment count1. */ |
10c7a96f | 1825 | tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, |
8de1f441 JJ |
1826 | count1, gfc_index_one_node); |
1827 | gfc_add_modify_expr (&body, count1, tmp); | |
6de9cd9a DN |
1828 | |
1829 | /* Increment count3. */ | |
1830 | if (count3) | |
8de1f441 JJ |
1831 | { |
1832 | tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, | |
10c7a96f | 1833 | count3, gfc_index_one_node); |
8de1f441 JJ |
1834 | gfc_add_modify_expr (&body, count3, tmp); |
1835 | } | |
6de9cd9a DN |
1836 | |
1837 | /* Generate the copying loops. */ | |
1838 | gfc_trans_scalarizing_loops (&loop1, &body); | |
1839 | gfc_add_block_to_block (&block, &loop1.pre); | |
1840 | gfc_add_block_to_block (&block, &loop1.post); | |
1841 | gfc_cleanup_loop (&loop1); | |
1842 | ||
6de9cd9a DN |
1843 | tmp = gfc_finish_block (&block); |
1844 | } | |
1845 | return tmp; | |
1846 | } | |
1847 | ||
1848 | ||
011daa76 RS |
1849 | /* Generate codes to copy rhs to the temporary. TMP1 is the address of |
1850 | temporary, LSS and RSS are formed in function compute_inner_temp_size(), | |
1851 | and should not be freed. WHEREMASK is the conditional execution mask | |
1852 | whose sense may be inverted by INVERT. */ | |
6de9cd9a DN |
1853 | |
1854 | static tree | |
8de1f441 JJ |
1855 | generate_loop_for_rhs_to_temp (gfc_expr *expr2, tree tmp1, tree count3, |
1856 | tree count1, gfc_ss *lss, gfc_ss *rss, | |
011daa76 | 1857 | tree wheremask, bool invert) |
6de9cd9a DN |
1858 | { |
1859 | stmtblock_t block, body1; | |
1860 | gfc_loopinfo loop; | |
1861 | gfc_se lse; | |
1862 | gfc_se rse; | |
011daa76 | 1863 | tree tmp; |
6de9cd9a DN |
1864 | tree wheremaskexpr; |
1865 | ||
1866 | gfc_start_block (&block); | |
1867 | ||
1868 | gfc_init_se (&rse, NULL); | |
1869 | gfc_init_se (&lse, NULL); | |
1870 | ||
1871 | if (lss == gfc_ss_terminator) | |
1872 | { | |
1873 | gfc_init_block (&body1); | |
1874 | gfc_conv_expr (&rse, expr2); | |
1875 | lse.expr = gfc_build_array_ref (tmp1, count1); | |
1876 | } | |
1877 | else | |
1878 | { | |
1f2959f0 | 1879 | /* Initialize the loop. */ |
6de9cd9a DN |
1880 | gfc_init_loopinfo (&loop); |
1881 | ||
1882 | /* We may need LSS to determine the shape of the expression. */ | |
1883 | gfc_add_ss_to_loop (&loop, lss); | |
1884 | gfc_add_ss_to_loop (&loop, rss); | |
1885 | ||
1886 | gfc_conv_ss_startstride (&loop); | |
1887 | gfc_conv_loop_setup (&loop); | |
1888 | ||
1889 | gfc_mark_ss_chain_used (rss, 1); | |
1890 | /* Start the loop body. */ | |
1891 | gfc_start_scalarized_body (&loop, &body1); | |
1892 | ||
1893 | /* Translate the expression. */ | |
1894 | gfc_copy_loopinfo_to_se (&rse, &loop); | |
1895 | rse.ss = rss; | |
1896 | gfc_conv_expr (&rse, expr2); | |
1897 | ||
1898 | /* Form the expression of the temporary. */ | |
8de1f441 | 1899 | lse.expr = gfc_build_array_ref (tmp1, count1); |
6de9cd9a DN |
1900 | } |
1901 | ||
1902 | /* Use the scalar assignment. */ | |
5046aff5 PT |
1903 | lse.string_length = rse.string_length; |
1904 | tmp = gfc_trans_scalar_assign (&lse, &rse, expr2->ts, true, | |
1905 | expr2->expr_type == EXPR_VARIABLE); | |
6de9cd9a DN |
1906 | |
1907 | /* Form the mask expression according to the mask tree list. */ | |
1908 | if (wheremask) | |
1909 | { | |
1ac26262 | 1910 | wheremaskexpr = gfc_build_array_ref (wheremask, count3); |
011daa76 RS |
1911 | if (invert) |
1912 | wheremaskexpr = fold_build1 (TRUTH_NOT_EXPR, | |
1913 | TREE_TYPE (wheremaskexpr), | |
1914 | wheremaskexpr); | |
61ead135 RG |
1915 | tmp = fold_build3 (COND_EXPR, void_type_node, |
1916 | wheremaskexpr, tmp, build_empty_stmt ()); | |
6de9cd9a DN |
1917 | } |
1918 | ||
1919 | gfc_add_expr_to_block (&body1, tmp); | |
1920 | ||
1921 | if (lss == gfc_ss_terminator) | |
1922 | { | |
1923 | gfc_add_block_to_block (&block, &body1); | |
8de1f441 JJ |
1924 | |
1925 | /* Increment count1. */ | |
1926 | tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (count1), count1, | |
1927 | gfc_index_one_node); | |
1928 | gfc_add_modify_expr (&block, count1, tmp); | |
6de9cd9a DN |
1929 | } |
1930 | else | |
1931 | { | |
8de1f441 | 1932 | /* Increment count1. */ |
10c7a96f | 1933 | tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, |
8de1f441 JJ |
1934 | count1, gfc_index_one_node); |
1935 | gfc_add_modify_expr (&body1, count1, tmp); | |
6de9cd9a DN |
1936 | |
1937 | /* Increment count3. */ | |
1938 | if (count3) | |
8de1f441 JJ |
1939 | { |
1940 | tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, | |
10c7a96f | 1941 | count3, gfc_index_one_node); |
8de1f441 JJ |
1942 | gfc_add_modify_expr (&body1, count3, tmp); |
1943 | } | |
6de9cd9a DN |
1944 | |
1945 | /* Generate the copying loops. */ | |
1946 | gfc_trans_scalarizing_loops (&loop, &body1); | |
1947 | ||
1948 | gfc_add_block_to_block (&block, &loop.pre); | |
1949 | gfc_add_block_to_block (&block, &loop.post); | |
1950 | ||
1951 | gfc_cleanup_loop (&loop); | |
1952 | /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful | |
8de1f441 | 1953 | as tree nodes in SS may not be valid in different scope. */ |
6de9cd9a | 1954 | } |
6de9cd9a DN |
1955 | |
1956 | tmp = gfc_finish_block (&block); | |
1957 | return tmp; | |
1958 | } | |
1959 | ||
1960 | ||
1961 | /* Calculate the size of temporary needed in the assignment inside forall. | |
1962 | LSS and RSS are filled in this function. */ | |
1963 | ||
1964 | static tree | |
1965 | compute_inner_temp_size (gfc_expr *expr1, gfc_expr *expr2, | |
1966 | stmtblock_t * pblock, | |
1967 | gfc_ss **lss, gfc_ss **rss) | |
1968 | { | |
1969 | gfc_loopinfo loop; | |
1970 | tree size; | |
1971 | int i; | |
ca86ddcc | 1972 | int save_flag; |
6de9cd9a DN |
1973 | tree tmp; |
1974 | ||
1975 | *lss = gfc_walk_expr (expr1); | |
1976 | *rss = NULL; | |
1977 | ||
7ab92584 | 1978 | size = gfc_index_one_node; |
6de9cd9a DN |
1979 | if (*lss != gfc_ss_terminator) |
1980 | { | |
1981 | gfc_init_loopinfo (&loop); | |
1982 | ||
1983 | /* Walk the RHS of the expression. */ | |
1984 | *rss = gfc_walk_expr (expr2); | |
1985 | if (*rss == gfc_ss_terminator) | |
1986 | { | |
1987 | /* The rhs is scalar. Add a ss for the expression. */ | |
1988 | *rss = gfc_get_ss (); | |
1989 | (*rss)->next = gfc_ss_terminator; | |
1990 | (*rss)->type = GFC_SS_SCALAR; | |
1991 | (*rss)->expr = expr2; | |
1992 | } | |
1993 | ||
1994 | /* Associate the SS with the loop. */ | |
1995 | gfc_add_ss_to_loop (&loop, *lss); | |
1996 | /* We don't actually need to add the rhs at this point, but it might | |
1997 | make guessing the loop bounds a bit easier. */ | |
1998 | gfc_add_ss_to_loop (&loop, *rss); | |
1999 | ||
2000 | /* We only want the shape of the expression, not rest of the junk | |
2001 | generated by the scalarizer. */ | |
2002 | loop.array_parameter = 1; | |
2003 | ||
2004 | /* Calculate the bounds of the scalarization. */ | |
ca86ddcc FXC |
2005 | save_flag = flag_bounds_check; |
2006 | flag_bounds_check = 0; | |
6de9cd9a | 2007 | gfc_conv_ss_startstride (&loop); |
ca86ddcc | 2008 | flag_bounds_check = save_flag; |
6de9cd9a DN |
2009 | gfc_conv_loop_setup (&loop); |
2010 | ||
2011 | /* Figure out how many elements we need. */ | |
2012 | for (i = 0; i < loop.dimen; i++) | |
2013 | { | |
10c7a96f SB |
2014 | tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, |
2015 | gfc_index_one_node, loop.from[i]); | |
2016 | tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, | |
2017 | tmp, loop.to[i]); | |
2018 | size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp); | |
6de9cd9a DN |
2019 | } |
2020 | gfc_add_block_to_block (pblock, &loop.pre); | |
2021 | size = gfc_evaluate_now (size, pblock); | |
2022 | gfc_add_block_to_block (pblock, &loop.post); | |
2023 | ||
2024 | /* TODO: write a function that cleans up a loopinfo without freeing | |
2025 | the SS chains. Currently a NOP. */ | |
2026 | } | |
2027 | ||
2028 | return size; | |
2029 | } | |
2030 | ||
2031 | ||
2032 | /* Calculate the overall iterator number of the nested forall construct. */ | |
2033 | ||
2034 | static tree | |
2035 | compute_overall_iter_number (forall_info *nested_forall_info, tree inner_size, | |
8de1f441 | 2036 | stmtblock_t *inner_size_body, stmtblock_t *block) |
6de9cd9a DN |
2037 | { |
2038 | tree tmp, number; | |
2039 | stmtblock_t body; | |
2040 | ||
2041 | /* TODO: optimizing the computing process. */ | |
2042 | number = gfc_create_var (gfc_array_index_type, "num"); | |
7ab92584 | 2043 | gfc_add_modify_expr (block, number, gfc_index_zero_node); |
6de9cd9a DN |
2044 | |
2045 | gfc_start_block (&body); | |
8de1f441 JJ |
2046 | if (inner_size_body) |
2047 | gfc_add_block_to_block (&body, inner_size_body); | |
6de9cd9a | 2048 | if (nested_forall_info) |
923ab88c TS |
2049 | tmp = build2 (PLUS_EXPR, gfc_array_index_type, number, |
2050 | inner_size); | |
6de9cd9a DN |
2051 | else |
2052 | tmp = inner_size; | |
2053 | gfc_add_modify_expr (&body, number, tmp); | |
2054 | tmp = gfc_finish_block (&body); | |
2055 | ||
2056 | /* Generate loops. */ | |
2057 | if (nested_forall_info != NULL) | |
2058 | tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 0, 1); | |
2059 | ||
2060 | gfc_add_expr_to_block (block, tmp); | |
2061 | ||
2062 | return number; | |
2063 | } | |
2064 | ||
2065 | ||
8de1f441 JJ |
2066 | /* Allocate temporary for forall construct. SIZE is the size of temporary |
2067 | needed. PTEMP1 is returned for space free. */ | |
6de9cd9a DN |
2068 | |
2069 | static tree | |
8de1f441 JJ |
2070 | allocate_temp_for_forall_nest_1 (tree type, tree size, stmtblock_t * block, |
2071 | tree * ptemp1) | |
6de9cd9a DN |
2072 | { |
2073 | tree unit; | |
2074 | tree temp1; | |
2075 | tree tmp; | |
8de1f441 | 2076 | tree bytesize; |
6de9cd9a DN |
2077 | |
2078 | unit = TYPE_SIZE_UNIT (type); | |
10c7a96f | 2079 | bytesize = fold_build2 (MULT_EXPR, gfc_array_index_type, size, unit); |
6de9cd9a DN |
2080 | |
2081 | *ptemp1 = NULL; | |
2082 | temp1 = gfc_do_allocate (bytesize, size, ptemp1, block, type); | |
2083 | ||
2084 | if (*ptemp1) | |
38611275 | 2085 | tmp = build_fold_indirect_ref (temp1); |
6de9cd9a DN |
2086 | else |
2087 | tmp = temp1; | |
2088 | ||
2089 | return tmp; | |
2090 | } | |
2091 | ||
2092 | ||
8de1f441 JJ |
2093 | /* Allocate temporary for forall construct according to the information in |
2094 | nested_forall_info. INNER_SIZE is the size of temporary needed in the | |
2095 | assignment inside forall. PTEMP1 is returned for space free. */ | |
2096 | ||
2097 | static tree | |
2098 | allocate_temp_for_forall_nest (forall_info * nested_forall_info, tree type, | |
2099 | tree inner_size, stmtblock_t * inner_size_body, | |
2100 | stmtblock_t * block, tree * ptemp1) | |
2101 | { | |
2102 | tree size; | |
2103 | ||
2104 | /* Calculate the total size of temporary needed in forall construct. */ | |
2105 | size = compute_overall_iter_number (nested_forall_info, inner_size, | |
2106 | inner_size_body, block); | |
2107 | ||
2108 | return allocate_temp_for_forall_nest_1 (type, size, block, ptemp1); | |
2109 | } | |
2110 | ||
2111 | ||
2112 | /* Handle assignments inside forall which need temporary. | |
2113 | ||
2114 | forall (i=start:end:stride; maskexpr) | |
2115 | e<i> = f<i> | |
2116 | end forall | |
2117 | (where e,f<i> are arbitrary expressions possibly involving i | |
2118 | and there is a dependency between e<i> and f<i>) | |
2119 | Translates to: | |
2120 | masktmp(:) = maskexpr(:) | |
2121 | ||
2122 | maskindex = 0; | |
2123 | count1 = 0; | |
2124 | num = 0; | |
2125 | for (i = start; i <= end; i += stride) | |
2126 | num += SIZE (f<i>) | |
2127 | count1 = 0; | |
2128 | ALLOCATE (tmp(num)) | |
2129 | for (i = start; i <= end; i += stride) | |
2130 | { | |
2131 | if (masktmp[maskindex++]) | |
2132 | tmp[count1++] = f<i> | |
2133 | } | |
2134 | maskindex = 0; | |
2135 | count1 = 0; | |
2136 | for (i = start; i <= end; i += stride) | |
2137 | { | |
2138 | if (masktmp[maskindex++]) | |
2139 | e<i> = tmp[count1++] | |
2140 | } | |
2141 | DEALLOCATE (tmp) | |
2142 | */ | |
6de9cd9a | 2143 | static void |
011daa76 RS |
2144 | gfc_trans_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2, |
2145 | tree wheremask, bool invert, | |
6de9cd9a DN |
2146 | forall_info * nested_forall_info, |
2147 | stmtblock_t * block) | |
2148 | { | |
2149 | tree type; | |
2150 | tree inner_size; | |
2151 | gfc_ss *lss, *rss; | |
8de1f441 | 2152 | tree count, count1; |
6de9cd9a DN |
2153 | tree tmp, tmp1; |
2154 | tree ptemp1; | |
8de1f441 | 2155 | stmtblock_t inner_size_body; |
6de9cd9a | 2156 | |
8de1f441 JJ |
2157 | /* Create vars. count1 is the current iterator number of the nested |
2158 | forall. */ | |
6de9cd9a | 2159 | count1 = gfc_create_var (gfc_array_index_type, "count1"); |
6de9cd9a DN |
2160 | |
2161 | /* Count is the wheremask index. */ | |
2162 | if (wheremask) | |
2163 | { | |
2164 | count = gfc_create_var (gfc_array_index_type, "count"); | |
7ab92584 | 2165 | gfc_add_modify_expr (block, count, gfc_index_zero_node); |
6de9cd9a DN |
2166 | } |
2167 | else | |
2168 | count = NULL; | |
2169 | ||
2170 | /* Initialize count1. */ | |
7ab92584 | 2171 | gfc_add_modify_expr (block, count1, gfc_index_zero_node); |
6de9cd9a DN |
2172 | |
2173 | /* Calculate the size of temporary needed in the assignment. Return loop, lss | |
2174 | and rss which are used in function generate_loop_for_rhs_to_temp(). */ | |
8de1f441 JJ |
2175 | gfc_init_block (&inner_size_body); |
2176 | inner_size = compute_inner_temp_size (expr1, expr2, &inner_size_body, | |
2177 | &lss, &rss); | |
6de9cd9a DN |
2178 | |
2179 | /* The type of LHS. Used in function allocate_temp_for_forall_nest */ | |
2180 | type = gfc_typenode_for_spec (&expr1->ts); | |
2181 | ||
2182 | /* Allocate temporary for nested forall construct according to the | |
f7b529fa | 2183 | information in nested_forall_info and inner_size. */ |
8de1f441 JJ |
2184 | tmp1 = allocate_temp_for_forall_nest (nested_forall_info, type, inner_size, |
2185 | &inner_size_body, block, &ptemp1); | |
6de9cd9a | 2186 | |
6de9cd9a | 2187 | /* Generate codes to copy rhs to the temporary . */ |
8de1f441 | 2188 | tmp = generate_loop_for_rhs_to_temp (expr2, tmp1, count, count1, lss, rss, |
011daa76 | 2189 | wheremask, invert); |
6de9cd9a | 2190 | |
1f2959f0 | 2191 | /* Generate body and loops according to the information in |
6de9cd9a DN |
2192 | nested_forall_info. */ |
2193 | tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1, 1); | |
2194 | gfc_add_expr_to_block (block, tmp); | |
2195 | ||
2196 | /* Reset count1. */ | |
7ab92584 | 2197 | gfc_add_modify_expr (block, count1, gfc_index_zero_node); |
6de9cd9a | 2198 | |
6de9cd9a DN |
2199 | /* Reset count. */ |
2200 | if (wheremask) | |
7ab92584 | 2201 | gfc_add_modify_expr (block, count, gfc_index_zero_node); |
6de9cd9a DN |
2202 | |
2203 | /* Generate codes to copy the temporary to lhs. */ | |
011daa76 RS |
2204 | tmp = generate_loop_for_temp_to_lhs (expr1, tmp1, count, count1, |
2205 | wheremask, invert); | |
6de9cd9a | 2206 | |
1f2959f0 | 2207 | /* Generate body and loops according to the information in |
6de9cd9a DN |
2208 | nested_forall_info. */ |
2209 | tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1, 1); | |
2210 | gfc_add_expr_to_block (block, tmp); | |
2211 | ||
2212 | if (ptemp1) | |
2213 | { | |
2214 | /* Free the temporary. */ | |
2215 | tmp = gfc_chainon_list (NULL_TREE, ptemp1); | |
3380b802 | 2216 | tmp = build_function_call_expr (gfor_fndecl_internal_free, tmp); |
6de9cd9a DN |
2217 | gfc_add_expr_to_block (block, tmp); |
2218 | } | |
2219 | } | |
2220 | ||
2221 | ||
2222 | /* Translate pointer assignment inside FORALL which need temporary. */ | |
2223 | ||
2224 | static void | |
2225 | gfc_trans_pointer_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2, | |
2226 | forall_info * nested_forall_info, | |
2227 | stmtblock_t * block) | |
2228 | { | |
2229 | tree type; | |
2230 | tree inner_size; | |
2231 | gfc_ss *lss, *rss; | |
2232 | gfc_se lse; | |
2233 | gfc_se rse; | |
2234 | gfc_ss_info *info; | |
2235 | gfc_loopinfo loop; | |
2236 | tree desc; | |
2237 | tree parm; | |
2238 | tree parmtype; | |
2239 | stmtblock_t body; | |
2240 | tree count; | |
2241 | tree tmp, tmp1, ptemp1; | |
6de9cd9a DN |
2242 | |
2243 | count = gfc_create_var (gfc_array_index_type, "count"); | |
7ab92584 | 2244 | gfc_add_modify_expr (block, count, gfc_index_zero_node); |
6de9cd9a DN |
2245 | |
2246 | inner_size = integer_one_node; | |
2247 | lss = gfc_walk_expr (expr1); | |
2248 | rss = gfc_walk_expr (expr2); | |
2249 | if (lss == gfc_ss_terminator) | |
2250 | { | |
2251 | type = gfc_typenode_for_spec (&expr1->ts); | |
2252 | type = build_pointer_type (type); | |
2253 | ||
2254 | /* Allocate temporary for nested forall construct according to the | |
2255 | information in nested_forall_info and inner_size. */ | |
8de1f441 JJ |
2256 | tmp1 = allocate_temp_for_forall_nest (nested_forall_info, type, |
2257 | inner_size, NULL, block, &ptemp1); | |
6de9cd9a DN |
2258 | gfc_start_block (&body); |
2259 | gfc_init_se (&lse, NULL); | |
2260 | lse.expr = gfc_build_array_ref (tmp1, count); | |
2261 | gfc_init_se (&rse, NULL); | |
2262 | rse.want_pointer = 1; | |
2263 | gfc_conv_expr (&rse, expr2); | |
2264 | gfc_add_block_to_block (&body, &rse.pre); | |
cc2804f1 AP |
2265 | gfc_add_modify_expr (&body, lse.expr, |
2266 | fold_convert (TREE_TYPE (lse.expr), rse.expr)); | |
6de9cd9a DN |
2267 | gfc_add_block_to_block (&body, &rse.post); |
2268 | ||
2269 | /* Increment count. */ | |
10c7a96f SB |
2270 | tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, |
2271 | count, gfc_index_one_node); | |
6de9cd9a DN |
2272 | gfc_add_modify_expr (&body, count, tmp); |
2273 | ||
2274 | tmp = gfc_finish_block (&body); | |
2275 | ||
1f2959f0 | 2276 | /* Generate body and loops according to the information in |
6de9cd9a DN |
2277 | nested_forall_info. */ |
2278 | tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1, 1); | |
2279 | gfc_add_expr_to_block (block, tmp); | |
2280 | ||
2281 | /* Reset count. */ | |
7ab92584 | 2282 | gfc_add_modify_expr (block, count, gfc_index_zero_node); |
6de9cd9a | 2283 | |
6de9cd9a DN |
2284 | gfc_start_block (&body); |
2285 | gfc_init_se (&lse, NULL); | |
2286 | gfc_init_se (&rse, NULL); | |
2287 | rse.expr = gfc_build_array_ref (tmp1, count); | |
2288 | lse.want_pointer = 1; | |
2289 | gfc_conv_expr (&lse, expr1); | |
2290 | gfc_add_block_to_block (&body, &lse.pre); | |
2291 | gfc_add_modify_expr (&body, lse.expr, rse.expr); | |
2292 | gfc_add_block_to_block (&body, &lse.post); | |
2293 | /* Increment count. */ | |
10c7a96f SB |
2294 | tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, |
2295 | count, gfc_index_one_node); | |
6de9cd9a DN |
2296 | gfc_add_modify_expr (&body, count, tmp); |
2297 | tmp = gfc_finish_block (&body); | |
2298 | ||
1f2959f0 | 2299 | /* Generate body and loops according to the information in |
6de9cd9a DN |
2300 | nested_forall_info. */ |
2301 | tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1, 1); | |
2302 | gfc_add_expr_to_block (block, tmp); | |
2303 | } | |
2304 | else | |
2305 | { | |
2306 | gfc_init_loopinfo (&loop); | |
2307 | ||
2308 | /* Associate the SS with the loop. */ | |
2309 | gfc_add_ss_to_loop (&loop, rss); | |
2310 | ||
2311 | /* Setup the scalarizing loops and bounds. */ | |
2312 | gfc_conv_ss_startstride (&loop); | |
2313 | ||
2314 | gfc_conv_loop_setup (&loop); | |
2315 | ||
2316 | info = &rss->data.info; | |
2317 | desc = info->descriptor; | |
2318 | ||
2319 | /* Make a new descriptor. */ | |
2320 | parmtype = gfc_get_element_type (TREE_TYPE (desc)); | |
2321 | parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, | |
2322 | loop.from, loop.to, 1); | |
2323 | ||
2324 | /* Allocate temporary for nested forall construct. */ | |
2325 | tmp1 = allocate_temp_for_forall_nest (nested_forall_info, parmtype, | |
8de1f441 | 2326 | inner_size, NULL, block, &ptemp1); |
6de9cd9a DN |
2327 | gfc_start_block (&body); |
2328 | gfc_init_se (&lse, NULL); | |
2329 | lse.expr = gfc_build_array_ref (tmp1, count); | |
2330 | lse.direct_byref = 1; | |
2331 | rss = gfc_walk_expr (expr2); | |
2332 | gfc_conv_expr_descriptor (&lse, expr2, rss); | |
2333 | ||
2334 | gfc_add_block_to_block (&body, &lse.pre); | |
2335 | gfc_add_block_to_block (&body, &lse.post); | |
2336 | ||
2337 | /* Increment count. */ | |
10c7a96f SB |
2338 | tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, |
2339 | count, gfc_index_one_node); | |
6de9cd9a DN |
2340 | gfc_add_modify_expr (&body, count, tmp); |
2341 | ||
2342 | tmp = gfc_finish_block (&body); | |
2343 | ||
1f2959f0 | 2344 | /* Generate body and loops according to the information in |
6de9cd9a DN |
2345 | nested_forall_info. */ |
2346 | tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1, 1); | |
2347 | gfc_add_expr_to_block (block, tmp); | |
2348 | ||
2349 | /* Reset count. */ | |
7ab92584 | 2350 | gfc_add_modify_expr (block, count, gfc_index_zero_node); |
6de9cd9a | 2351 | |
6de9cd9a DN |
2352 | parm = gfc_build_array_ref (tmp1, count); |
2353 | lss = gfc_walk_expr (expr1); | |
2354 | gfc_init_se (&lse, NULL); | |
2355 | gfc_conv_expr_descriptor (&lse, expr1, lss); | |
2356 | gfc_add_modify_expr (&lse.pre, lse.expr, parm); | |
2357 | gfc_start_block (&body); | |
2358 | gfc_add_block_to_block (&body, &lse.pre); | |
2359 | gfc_add_block_to_block (&body, &lse.post); | |
2360 | ||
2361 | /* Increment count. */ | |
10c7a96f SB |
2362 | tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, |
2363 | count, gfc_index_one_node); | |
6de9cd9a DN |
2364 | gfc_add_modify_expr (&body, count, tmp); |
2365 | ||
2366 | tmp = gfc_finish_block (&body); | |
2367 | ||
2368 | tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1, 1); | |
2369 | gfc_add_expr_to_block (block, tmp); | |
2370 | } | |
2371 | /* Free the temporary. */ | |
2372 | if (ptemp1) | |
2373 | { | |
2374 | tmp = gfc_chainon_list (NULL_TREE, ptemp1); | |
3380b802 | 2375 | tmp = build_function_call_expr (gfor_fndecl_internal_free, tmp); |
6de9cd9a DN |
2376 | gfc_add_expr_to_block (block, tmp); |
2377 | } | |
2378 | } | |
2379 | ||
2380 | ||
2381 | /* FORALL and WHERE statements are really nasty, especially when you nest | |
2382 | them. All the rhs of a forall assignment must be evaluated before the | |
2383 | actual assignments are performed. Presumably this also applies to all the | |
2384 | assignments in an inner where statement. */ | |
2385 | ||
2386 | /* Generate code for a FORALL statement. Any temporaries are allocated as a | |
2387 | linear array, relying on the fact that we process in the same order in all | |
2388 | loops. | |
2389 | ||
2390 | forall (i=start:end:stride; maskexpr) | |
2391 | e<i> = f<i> | |
2392 | g<i> = h<i> | |
2393 | end forall | |
e7dc5b4f | 2394 | (where e,f,g,h<i> are arbitrary expressions possibly involving i) |
6de9cd9a | 2395 | Translates to: |
8de1f441 | 2396 | count = ((end + 1 - start) / stride) |
6de9cd9a DN |
2397 | masktmp(:) = maskexpr(:) |
2398 | ||
2399 | maskindex = 0; | |
2400 | for (i = start; i <= end; i += stride) | |
2401 | { | |
2402 | if (masktmp[maskindex++]) | |
2403 | e<i> = f<i> | |
2404 | } | |
2405 | maskindex = 0; | |
2406 | for (i = start; i <= end; i += stride) | |
2407 | { | |
2408 | if (masktmp[maskindex++]) | |
cafa34aa | 2409 | g<i> = h<i> |
6de9cd9a DN |
2410 | } |
2411 | ||
2412 | Note that this code only works when there are no dependencies. | |
2413 | Forall loop with array assignments and data dependencies are a real pain, | |
2414 | because the size of the temporary cannot always be determined before the | |
1f2959f0 | 2415 | loop is executed. This problem is compounded by the presence of nested |
6de9cd9a DN |
2416 | FORALL constructs. |
2417 | */ | |
2418 | ||
2419 | static tree | |
2420 | gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info) | |
2421 | { | |
2422 | stmtblock_t block; | |
2423 | stmtblock_t body; | |
2424 | tree *var; | |
2425 | tree *start; | |
2426 | tree *end; | |
2427 | tree *step; | |
2428 | gfc_expr **varexpr; | |
2429 | tree tmp; | |
2430 | tree assign; | |
2431 | tree size; | |
2432 | tree bytesize; | |
2433 | tree tmpvar; | |
2434 | tree sizevar; | |
2435 | tree lenvar; | |
2436 | tree maskindex; | |
2437 | tree mask; | |
2438 | tree pmask; | |
2439 | int n; | |
2440 | int nvar; | |
2441 | int need_temp; | |
2442 | gfc_forall_iterator *fa; | |
2443 | gfc_se se; | |
2444 | gfc_code *c; | |
7b5b57b7 | 2445 | gfc_saved_var *saved_vars; |
6de9cd9a DN |
2446 | iter_info *this_forall, *iter_tmp; |
2447 | forall_info *info, *forall_tmp; | |
6de9cd9a DN |
2448 | |
2449 | gfc_start_block (&block); | |
2450 | ||
2451 | n = 0; | |
2452 | /* Count the FORALL index number. */ | |
2453 | for (fa = code->ext.forall_iterator; fa; fa = fa->next) | |
2454 | n++; | |
2455 | nvar = n; | |
2456 | ||
2457 | /* Allocate the space for var, start, end, step, varexpr. */ | |
2458 | var = (tree *) gfc_getmem (nvar * sizeof (tree)); | |
2459 | start = (tree *) gfc_getmem (nvar * sizeof (tree)); | |
2460 | end = (tree *) gfc_getmem (nvar * sizeof (tree)); | |
2461 | step = (tree *) gfc_getmem (nvar * sizeof (tree)); | |
2462 | varexpr = (gfc_expr **) gfc_getmem (nvar * sizeof (gfc_expr *)); | |
7b5b57b7 | 2463 | saved_vars = (gfc_saved_var *) gfc_getmem (nvar * sizeof (gfc_saved_var)); |
6de9cd9a DN |
2464 | |
2465 | /* Allocate the space for info. */ | |
2466 | info = (forall_info *) gfc_getmem (sizeof (forall_info)); | |
2467 | n = 0; | |
2468 | for (fa = code->ext.forall_iterator; fa; fa = fa->next) | |
2469 | { | |
2470 | gfc_symbol *sym = fa->var->symtree->n.sym; | |
2471 | ||
2472 | /* allocate space for this_forall. */ | |
2473 | this_forall = (iter_info *) gfc_getmem (sizeof (iter_info)); | |
2474 | ||
6de9cd9a DN |
2475 | /* Create a temporary variable for the FORALL index. */ |
2476 | tmp = gfc_typenode_for_spec (&sym->ts); | |
2477 | var[n] = gfc_create_var (tmp, sym->name); | |
7b5b57b7 PB |
2478 | gfc_shadow_sym (sym, var[n], &saved_vars[n]); |
2479 | ||
6de9cd9a DN |
2480 | /* Record it in this_forall. */ |
2481 | this_forall->var = var[n]; | |
2482 | ||
2483 | /* Replace the index symbol's backend_decl with the temporary decl. */ | |
2484 | sym->backend_decl = var[n]; | |
2485 | ||
2486 | /* Work out the start, end and stride for the loop. */ | |
2487 | gfc_init_se (&se, NULL); | |
2488 | gfc_conv_expr_val (&se, fa->start); | |
2489 | /* Record it in this_forall. */ | |
2490 | this_forall->start = se.expr; | |
2491 | gfc_add_block_to_block (&block, &se.pre); | |
2492 | start[n] = se.expr; | |
2493 | ||
2494 | gfc_init_se (&se, NULL); | |
2495 | gfc_conv_expr_val (&se, fa->end); | |
2496 | /* Record it in this_forall. */ | |
2497 | this_forall->end = se.expr; | |
2498 | gfc_make_safe_expr (&se); | |
2499 | gfc_add_block_to_block (&block, &se.pre); | |
2500 | end[n] = se.expr; | |
2501 | ||
2502 | gfc_init_se (&se, NULL); | |
2503 | gfc_conv_expr_val (&se, fa->stride); | |
2504 | /* Record it in this_forall. */ | |
2505 | this_forall->step = se.expr; | |
2506 | gfc_make_safe_expr (&se); | |
2507 | gfc_add_block_to_block (&block, &se.pre); | |
2508 | step[n] = se.expr; | |
2509 | ||
2510 | /* Set the NEXT field of this_forall to NULL. */ | |
2511 | this_forall->next = NULL; | |
2512 | /* Link this_forall to the info construct. */ | |
2513 | if (info->this_loop == NULL) | |
2514 | info->this_loop = this_forall; | |
2515 | else | |
2516 | { | |
2517 | iter_tmp = info->this_loop; | |
2518 | while (iter_tmp->next != NULL) | |
2519 | iter_tmp = iter_tmp->next; | |
2520 | iter_tmp->next = this_forall; | |
2521 | } | |
2522 | ||
2523 | n++; | |
2524 | } | |
2525 | nvar = n; | |
2526 | ||
2527 | /* Work out the number of elements in the mask array. */ | |
2528 | tmpvar = NULL_TREE; | |
2529 | lenvar = NULL_TREE; | |
7ab92584 | 2530 | size = gfc_index_one_node; |
6de9cd9a DN |
2531 | sizevar = NULL_TREE; |
2532 | ||
2533 | for (n = 0; n < nvar; n++) | |
2534 | { | |
2535 | if (lenvar && TREE_TYPE (lenvar) != TREE_TYPE (start[n])) | |
2536 | lenvar = NULL_TREE; | |
2537 | ||
2538 | /* size = (end + step - start) / step. */ | |
10c7a96f SB |
2539 | tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (start[n]), |
2540 | step[n], start[n]); | |
2541 | tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (end[n]), end[n], tmp); | |
6de9cd9a | 2542 | |
10c7a96f | 2543 | tmp = fold_build2 (FLOOR_DIV_EXPR, TREE_TYPE (tmp), tmp, step[n]); |
6de9cd9a DN |
2544 | tmp = convert (gfc_array_index_type, tmp); |
2545 | ||
10c7a96f | 2546 | size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp); |
6de9cd9a DN |
2547 | } |
2548 | ||
2549 | /* Record the nvar and size of current forall level. */ | |
2550 | info->nvar = nvar; | |
2551 | info->size = size; | |
2552 | ||
2553 | /* Link the current forall level to nested_forall_info. */ | |
2554 | forall_tmp = nested_forall_info; | |
2555 | if (forall_tmp == NULL) | |
2556 | nested_forall_info = info; | |
2557 | else | |
2558 | { | |
2559 | while (forall_tmp->next_nest != NULL) | |
2560 | forall_tmp = forall_tmp->next_nest; | |
2561 | info->outer = forall_tmp; | |
2562 | forall_tmp->next_nest = info; | |
2563 | } | |
2564 | ||
2565 | /* Copy the mask into a temporary variable if required. | |
f7b529fa | 2566 | For now we assume a mask temporary is needed. */ |
6de9cd9a DN |
2567 | if (code->expr) |
2568 | { | |
7a1df4e2 JJ |
2569 | /* As the mask array can be very big, prefer compact |
2570 | boolean types. */ | |
2571 | tree smallest_boolean_type_node | |
2572 | = gfc_get_logical_type (gfc_logical_kinds[0].kind); | |
2573 | ||
6de9cd9a | 2574 | /* Allocate the mask temporary. */ |
10c7a96f | 2575 | bytesize = fold_build2 (MULT_EXPR, gfc_array_index_type, size, |
7a1df4e2 | 2576 | TYPE_SIZE_UNIT (smallest_boolean_type_node)); |
6de9cd9a | 2577 | |
7a1df4e2 JJ |
2578 | mask = gfc_do_allocate (bytesize, size, &pmask, &block, |
2579 | smallest_boolean_type_node); | |
6de9cd9a DN |
2580 | |
2581 | maskindex = gfc_create_var_np (gfc_array_index_type, "mi"); | |
2582 | /* Record them in the info structure. */ | |
2583 | info->pmask = pmask; | |
2584 | info->mask = mask; | |
2585 | info->maskindex = maskindex; | |
2586 | ||
7ab92584 | 2587 | gfc_add_modify_expr (&block, maskindex, gfc_index_zero_node); |
6de9cd9a DN |
2588 | |
2589 | /* Start of mask assignment loop body. */ | |
2590 | gfc_start_block (&body); | |
2591 | ||
2592 | /* Evaluate the mask expression. */ | |
2593 | gfc_init_se (&se, NULL); | |
2594 | gfc_conv_expr_val (&se, code->expr); | |
2595 | gfc_add_block_to_block (&body, &se.pre); | |
2596 | ||
2597 | /* Store the mask. */ | |
7a1df4e2 | 2598 | se.expr = convert (smallest_boolean_type_node, se.expr); |
6de9cd9a DN |
2599 | |
2600 | if (pmask) | |
38611275 | 2601 | tmp = build_fold_indirect_ref (mask); |
6de9cd9a DN |
2602 | else |
2603 | tmp = mask; | |
2604 | tmp = gfc_build_array_ref (tmp, maskindex); | |
2605 | gfc_add_modify_expr (&body, tmp, se.expr); | |
2606 | ||
2607 | /* Advance to the next mask element. */ | |
923ab88c | 2608 | tmp = build2 (PLUS_EXPR, gfc_array_index_type, |
7ab92584 | 2609 | maskindex, gfc_index_one_node); |
6de9cd9a DN |
2610 | gfc_add_modify_expr (&body, maskindex, tmp); |
2611 | ||
2612 | /* Generate the loops. */ | |
2613 | tmp = gfc_finish_block (&body); | |
2614 | tmp = gfc_trans_nested_forall_loop (info, tmp, 0, 0); | |
2615 | gfc_add_expr_to_block (&block, tmp); | |
2616 | } | |
2617 | else | |
2618 | { | |
2619 | /* No mask was specified. */ | |
2620 | maskindex = NULL_TREE; | |
2621 | mask = pmask = NULL_TREE; | |
2622 | } | |
2623 | ||
2624 | c = code->block->next; | |
2625 | ||
2626 | /* TODO: loop merging in FORALL statements. */ | |
2627 | /* Now that we've got a copy of the mask, generate the assignment loops. */ | |
2628 | while (c) | |
2629 | { | |
2630 | switch (c->op) | |
2631 | { | |
2632 | case EXEC_ASSIGN: | |
1f2959f0 | 2633 | /* A scalar or array assignment. */ |
3ded6210 | 2634 | need_temp = gfc_check_dependency (c->expr, c->expr2, 0); |
69de3b83 | 2635 | /* Temporaries due to array assignment data dependencies introduce |
6de9cd9a DN |
2636 | no end of problems. */ |
2637 | if (need_temp) | |
011daa76 | 2638 | gfc_trans_assign_need_temp (c->expr, c->expr2, NULL, false, |
6de9cd9a DN |
2639 | nested_forall_info, &block); |
2640 | else | |
2641 | { | |
2642 | /* Use the normal assignment copying routines. */ | |
6b591ec0 | 2643 | assign = gfc_trans_assignment (c->expr, c->expr2, false); |
6de9cd9a | 2644 | |
6de9cd9a DN |
2645 | /* Generate body and loops. */ |
2646 | tmp = gfc_trans_nested_forall_loop (nested_forall_info, assign, 1, 1); | |
2647 | gfc_add_expr_to_block (&block, tmp); | |
2648 | } | |
2649 | ||
2650 | break; | |
2651 | ||
2652 | case EXEC_WHERE: | |
6de9cd9a | 2653 | /* Translate WHERE or WHERE construct nested in FORALL. */ |
011daa76 | 2654 | gfc_trans_where_2 (c, NULL, false, nested_forall_info, &block); |
3891cee2 | 2655 | break; |
6de9cd9a DN |
2656 | |
2657 | /* Pointer assignment inside FORALL. */ | |
2658 | case EXEC_POINTER_ASSIGN: | |
3ded6210 | 2659 | need_temp = gfc_check_dependency (c->expr, c->expr2, 0); |
6de9cd9a DN |
2660 | if (need_temp) |
2661 | gfc_trans_pointer_assign_need_temp (c->expr, c->expr2, | |
2662 | nested_forall_info, &block); | |
2663 | else | |
2664 | { | |
2665 | /* Use the normal assignment copying routines. */ | |
2666 | assign = gfc_trans_pointer_assignment (c->expr, c->expr2); | |
2667 | ||
6de9cd9a DN |
2668 | /* Generate body and loops. */ |
2669 | tmp = gfc_trans_nested_forall_loop (nested_forall_info, assign, | |
2670 | 1, 1); | |
2671 | gfc_add_expr_to_block (&block, tmp); | |
2672 | } | |
2673 | break; | |
2674 | ||
2675 | case EXEC_FORALL: | |
2676 | tmp = gfc_trans_forall_1 (c, nested_forall_info); | |
2677 | gfc_add_expr_to_block (&block, tmp); | |
2678 | break; | |
2679 | ||
48474141 PT |
2680 | /* Explicit subroutine calls are prevented by the frontend but interface |
2681 | assignments can legitimately produce them. */ | |
476220e7 PT |
2682 | case EXEC_ASSIGN_CALL: |
2683 | assign = gfc_trans_call (c, true); | |
48474141 PT |
2684 | tmp = gfc_trans_nested_forall_loop (nested_forall_info, assign, 1, 1); |
2685 | gfc_add_expr_to_block (&block, tmp); | |
2686 | break; | |
2687 | ||
6de9cd9a | 2688 | default: |
6e45f57b | 2689 | gcc_unreachable (); |
6de9cd9a DN |
2690 | } |
2691 | ||
2692 | c = c->next; | |
2693 | } | |
2694 | ||
7b5b57b7 PB |
2695 | /* Restore the original index variables. */ |
2696 | for (fa = code->ext.forall_iterator, n = 0; fa; fa = fa->next, n++) | |
2697 | gfc_restore_sym (fa->var->symtree->n.sym, &saved_vars[n]); | |
6de9cd9a DN |
2698 | |
2699 | /* Free the space for var, start, end, step, varexpr. */ | |
2700 | gfc_free (var); | |
2701 | gfc_free (start); | |
2702 | gfc_free (end); | |
2703 | gfc_free (step); | |
2704 | gfc_free (varexpr); | |
7b5b57b7 | 2705 | gfc_free (saved_vars); |
6de9cd9a DN |
2706 | |
2707 | if (pmask) | |
2708 | { | |
2709 | /* Free the temporary for the mask. */ | |
2710 | tmp = gfc_chainon_list (NULL_TREE, pmask); | |
3380b802 | 2711 | tmp = build_function_call_expr (gfor_fndecl_internal_free, tmp); |
6de9cd9a DN |
2712 | gfc_add_expr_to_block (&block, tmp); |
2713 | } | |
2714 | if (maskindex) | |
2715 | pushdecl (maskindex); | |
2716 | ||
2717 | return gfc_finish_block (&block); | |
2718 | } | |
2719 | ||
2720 | ||
2721 | /* Translate the FORALL statement or construct. */ | |
2722 | ||
2723 | tree gfc_trans_forall (gfc_code * code) | |
2724 | { | |
2725 | return gfc_trans_forall_1 (code, NULL); | |
2726 | } | |
2727 | ||
2728 | ||
2729 | /* Evaluate the WHERE mask expression, copy its value to a temporary. | |
2730 | If the WHERE construct is nested in FORALL, compute the overall temporary | |
2731 | needed by the WHERE mask expression multiplied by the iterator number of | |
2732 | the nested forall. | |
2733 | ME is the WHERE mask expression. | |
011daa76 RS |
2734 | MASK is the current execution mask upon input, whose sense may or may |
2735 | not be inverted as specified by the INVERT argument. | |
3891cee2 RS |
2736 | CMASK is the updated execution mask on output, or NULL if not required. |
2737 | PMASK is the pending execution mask on output, or NULL if not required. | |
2738 | BLOCK is the block in which to place the condition evaluation loops. */ | |
6de9cd9a | 2739 | |
3891cee2 | 2740 | static void |
6de9cd9a | 2741 | gfc_evaluate_where_mask (gfc_expr * me, forall_info * nested_forall_info, |
011daa76 | 2742 | tree mask, bool invert, tree cmask, tree pmask, |
3891cee2 | 2743 | tree mask_type, stmtblock_t * block) |
6de9cd9a DN |
2744 | { |
2745 | tree tmp, tmp1; | |
2746 | gfc_ss *lss, *rss; | |
2747 | gfc_loopinfo loop; | |
3891cee2 RS |
2748 | stmtblock_t body, body1; |
2749 | tree count, cond, mtmp; | |
6de9cd9a | 2750 | gfc_se lse, rse; |
6de9cd9a DN |
2751 | |
2752 | gfc_init_loopinfo (&loop); | |
2753 | ||
3891cee2 RS |
2754 | lss = gfc_walk_expr (me); |
2755 | rss = gfc_walk_expr (me); | |
6de9cd9a DN |
2756 | |
2757 | /* Variable to index the temporary. */ | |
2758 | count = gfc_create_var (gfc_array_index_type, "count"); | |
1f2959f0 | 2759 | /* Initialize count. */ |
7ab92584 | 2760 | gfc_add_modify_expr (block, count, gfc_index_zero_node); |
6de9cd9a DN |
2761 | |
2762 | gfc_start_block (&body); | |
2763 | ||
2764 | gfc_init_se (&rse, NULL); | |
2765 | gfc_init_se (&lse, NULL); | |
2766 | ||
2767 | if (lss == gfc_ss_terminator) | |
2768 | { | |
2769 | gfc_init_block (&body1); | |
2770 | } | |
2771 | else | |
2772 | { | |
1f2959f0 | 2773 | /* Initialize the loop. */ |
6de9cd9a DN |
2774 | gfc_init_loopinfo (&loop); |
2775 | ||
2776 | /* We may need LSS to determine the shape of the expression. */ | |
2777 | gfc_add_ss_to_loop (&loop, lss); | |
2778 | gfc_add_ss_to_loop (&loop, rss); | |
2779 | ||
2780 | gfc_conv_ss_startstride (&loop); | |
2781 | gfc_conv_loop_setup (&loop); | |
2782 | ||
2783 | gfc_mark_ss_chain_used (rss, 1); | |
2784 | /* Start the loop body. */ | |
2785 | gfc_start_scalarized_body (&loop, &body1); | |
2786 | ||
2787 | /* Translate the expression. */ | |
2788 | gfc_copy_loopinfo_to_se (&rse, &loop); | |
2789 | rse.ss = rss; | |
2790 | gfc_conv_expr (&rse, me); | |
2791 | } | |
6de9cd9a | 2792 | |
b82feea5 | 2793 | /* Variable to evaluate mask condition. */ |
3891cee2 RS |
2794 | cond = gfc_create_var (mask_type, "cond"); |
2795 | if (mask && (cmask || pmask)) | |
2796 | mtmp = gfc_create_var (mask_type, "mask"); | |
2797 | else mtmp = NULL_TREE; | |
2798 | ||
2799 | gfc_add_block_to_block (&body1, &lse.pre); | |
2800 | gfc_add_block_to_block (&body1, &rse.pre); | |
6de9cd9a | 2801 | |
3891cee2 RS |
2802 | gfc_add_modify_expr (&body1, cond, fold_convert (mask_type, rse.expr)); |
2803 | ||
2804 | if (mask && (cmask || pmask)) | |
42e73749 | 2805 | { |
3891cee2 | 2806 | tmp = gfc_build_array_ref (mask, count); |
011daa76 RS |
2807 | if (invert) |
2808 | tmp = fold_build1 (TRUTH_NOT_EXPR, mask_type, tmp); | |
3891cee2 | 2809 | gfc_add_modify_expr (&body1, mtmp, tmp); |
42e73749 | 2810 | } |
6de9cd9a | 2811 | |
3891cee2 RS |
2812 | if (cmask) |
2813 | { | |
2814 | tmp1 = gfc_build_array_ref (cmask, count); | |
2815 | tmp = cond; | |
2816 | if (mask) | |
2817 | tmp = build2 (TRUTH_AND_EXPR, mask_type, mtmp, tmp); | |
2818 | gfc_add_modify_expr (&body1, tmp1, tmp); | |
2819 | } | |
2820 | ||
2821 | if (pmask) | |
2822 | { | |
2823 | tmp1 = gfc_build_array_ref (pmask, count); | |
2824 | tmp = build1 (TRUTH_NOT_EXPR, mask_type, cond); | |
2825 | if (mask) | |
2826 | tmp = build2 (TRUTH_AND_EXPR, mask_type, mtmp, tmp); | |
2827 | gfc_add_modify_expr (&body1, tmp1, tmp); | |
2828 | } | |
2829 | ||
2830 | gfc_add_block_to_block (&body1, &lse.post); | |
2831 | gfc_add_block_to_block (&body1, &rse.post); | |
2832 | ||
2833 | if (lss == gfc_ss_terminator) | |
6de9cd9a DN |
2834 | { |
2835 | gfc_add_block_to_block (&body, &body1); | |
2836 | } | |
2837 | else | |
2838 | { | |
2839 | /* Increment count. */ | |
10c7a96f SB |
2840 | tmp1 = fold_build2 (PLUS_EXPR, gfc_array_index_type, count, |
2841 | gfc_index_one_node); | |
6de9cd9a DN |
2842 | gfc_add_modify_expr (&body1, count, tmp1); |
2843 | ||
2844 | /* Generate the copying loops. */ | |
2845 | gfc_trans_scalarizing_loops (&loop, &body1); | |
2846 | ||
2847 | gfc_add_block_to_block (&body, &loop.pre); | |
2848 | gfc_add_block_to_block (&body, &loop.post); | |
2849 | ||
2850 | gfc_cleanup_loop (&loop); | |
2851 | /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful | |
2852 | as tree nodes in SS may not be valid in different scope. */ | |
2853 | } | |
2854 | ||
2855 | tmp1 = gfc_finish_block (&body); | |
2856 | /* If the WHERE construct is inside FORALL, fill the full temporary. */ | |
2857 | if (nested_forall_info != NULL) | |
fcf3be37 | 2858 | tmp1 = gfc_trans_nested_forall_loop (nested_forall_info, tmp1, 1, 1); |
6de9cd9a DN |
2859 | |
2860 | gfc_add_expr_to_block (block, tmp1); | |
6de9cd9a DN |
2861 | } |
2862 | ||
2863 | ||
2864 | /* Translate an assignment statement in a WHERE statement or construct | |
2865 | statement. The MASK expression is used to control which elements | |
011daa76 RS |
2866 | of EXPR1 shall be assigned. The sense of MASK is specified by |
2867 | INVERT. */ | |
6de9cd9a DN |
2868 | |
2869 | static tree | |
011daa76 RS |
2870 | gfc_trans_where_assign (gfc_expr *expr1, gfc_expr *expr2, |
2871 | tree mask, bool invert, | |
6de9cd9a DN |
2872 | tree count1, tree count2) |
2873 | { | |
2874 | gfc_se lse; | |
2875 | gfc_se rse; | |
2876 | gfc_ss *lss; | |
2877 | gfc_ss *lss_section; | |
2878 | gfc_ss *rss; | |
2879 | ||
2880 | gfc_loopinfo loop; | |
2881 | tree tmp; | |
2882 | stmtblock_t block; | |
2883 | stmtblock_t body; | |
3c90c9ae | 2884 | tree index, maskexpr; |
6de9cd9a DN |
2885 | |
2886 | #if 0 | |
2887 | /* TODO: handle this special case. | |
2888 | Special case a single function returning an array. */ | |
2889 | if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0) | |
2890 | { | |
2891 | tmp = gfc_trans_arrayfunc_assign (expr1, expr2); | |
2892 | if (tmp) | |
2893 | return tmp; | |
2894 | } | |
2895 | #endif | |
2896 | ||
2897 | /* Assignment of the form lhs = rhs. */ | |
2898 | gfc_start_block (&block); | |
2899 | ||
2900 | gfc_init_se (&lse, NULL); | |
2901 | gfc_init_se (&rse, NULL); | |
2902 | ||
2903 | /* Walk the lhs. */ | |
2904 | lss = gfc_walk_expr (expr1); | |
2905 | rss = NULL; | |
2906 | ||
2907 | /* In each where-assign-stmt, the mask-expr and the variable being | |
2908 | defined shall be arrays of the same shape. */ | |
6e45f57b | 2909 | gcc_assert (lss != gfc_ss_terminator); |
6de9cd9a DN |
2910 | |
2911 | /* The assignment needs scalarization. */ | |
2912 | lss_section = lss; | |
2913 | ||
2914 | /* Find a non-scalar SS from the lhs. */ | |
2915 | while (lss_section != gfc_ss_terminator | |
2916 | && lss_section->type != GFC_SS_SECTION) | |
2917 | lss_section = lss_section->next; | |
2918 | ||
6e45f57b | 2919 | gcc_assert (lss_section != gfc_ss_terminator); |
6de9cd9a DN |
2920 | |
2921 | /* Initialize the scalarizer. */ | |
2922 | gfc_init_loopinfo (&loop); | |
2923 | ||
2924 | /* Walk the rhs. */ | |
2925 | rss = gfc_walk_expr (expr2); | |
2926 | if (rss == gfc_ss_terminator) | |
2927 | { | |
2928 | /* The rhs is scalar. Add a ss for the expression. */ | |
2929 | rss = gfc_get_ss (); | |
2930 | rss->next = gfc_ss_terminator; | |
2931 | rss->type = GFC_SS_SCALAR; | |
2932 | rss->expr = expr2; | |
2933 | } | |
2934 | ||
2935 | /* Associate the SS with the loop. */ | |
2936 | gfc_add_ss_to_loop (&loop, lss); | |
2937 | gfc_add_ss_to_loop (&loop, rss); | |
2938 | ||
2939 | /* Calculate the bounds of the scalarization. */ | |
2940 | gfc_conv_ss_startstride (&loop); | |
2941 | ||
2942 | /* Resolve any data dependencies in the statement. */ | |
2943 | gfc_conv_resolve_dependencies (&loop, lss_section, rss); | |
2944 | ||
2945 | /* Setup the scalarizing loops. */ | |
2946 | gfc_conv_loop_setup (&loop); | |
2947 | ||
2948 | /* Setup the gfc_se structures. */ | |
2949 | gfc_copy_loopinfo_to_se (&lse, &loop); | |
2950 | gfc_copy_loopinfo_to_se (&rse, &loop); | |
2951 | ||
2952 | rse.ss = rss; | |
2953 | gfc_mark_ss_chain_used (rss, 1); | |
2954 | if (loop.temp_ss == NULL) | |
2955 | { | |
2956 | lse.ss = lss; | |
2957 | gfc_mark_ss_chain_used (lss, 1); | |
2958 | } | |
2959 | else | |
2960 | { | |
2961 | lse.ss = loop.temp_ss; | |
2962 | gfc_mark_ss_chain_used (lss, 3); | |
2963 | gfc_mark_ss_chain_used (loop.temp_ss, 3); | |
2964 | } | |
2965 | ||
2966 | /* Start the scalarized loop body. */ | |
2967 | gfc_start_scalarized_body (&loop, &body); | |
2968 | ||
2969 | /* Translate the expression. */ | |
2970 | gfc_conv_expr (&rse, expr2); | |
2971 | if (lss != gfc_ss_terminator && loop.temp_ss != NULL) | |
2972 | { | |
2973 | gfc_conv_tmp_array_ref (&lse); | |
2974 | gfc_advance_se_ss_chain (&lse); | |
2975 | } | |
2976 | else | |
2977 | gfc_conv_expr (&lse, expr1); | |
2978 | ||
3c90c9ae | 2979 | /* Form the mask expression according to the mask. */ |
6de9cd9a | 2980 | index = count1; |
3c90c9ae | 2981 | maskexpr = gfc_build_array_ref (mask, index); |
011daa76 RS |
2982 | if (invert) |
2983 | maskexpr = fold_build1 (TRUTH_NOT_EXPR, TREE_TYPE (maskexpr), maskexpr); | |
6de9cd9a | 2984 | |
6de9cd9a | 2985 | /* Use the scalar assignment as is. */ |
5046aff5 PT |
2986 | tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, |
2987 | loop.temp_ss != NULL, false); | |
923ab88c | 2988 | tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt ()); |
6de9cd9a DN |
2989 | |
2990 | gfc_add_expr_to_block (&body, tmp); | |
2991 | ||
2992 | if (lss == gfc_ss_terminator) | |
2993 | { | |
2994 | /* Increment count1. */ | |
10c7a96f SB |
2995 | tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, |
2996 | count1, gfc_index_one_node); | |
6de9cd9a DN |
2997 | gfc_add_modify_expr (&body, count1, tmp); |
2998 | ||
2999 | /* Use the scalar assignment as is. */ | |
3000 | gfc_add_block_to_block (&block, &body); | |
3001 | } | |
3002 | else | |
3003 | { | |
6e45f57b PB |
3004 | gcc_assert (lse.ss == gfc_ss_terminator |
3005 | && rse.ss == gfc_ss_terminator); | |
6de9cd9a DN |
3006 | |
3007 | if (loop.temp_ss != NULL) | |
3008 | { | |
3009 | /* Increment count1 before finish the main body of a scalarized | |
3010 | expression. */ | |
10c7a96f SB |
3011 | tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, |
3012 | count1, gfc_index_one_node); | |
6de9cd9a DN |
3013 | gfc_add_modify_expr (&body, count1, tmp); |
3014 | gfc_trans_scalarized_loop_boundary (&loop, &body); | |
3015 | ||
3016 | /* We need to copy the temporary to the actual lhs. */ | |
3017 | gfc_init_se (&lse, NULL); | |
3018 | gfc_init_se (&rse, NULL); | |
3019 | gfc_copy_loopinfo_to_se (&lse, &loop); | |
3020 | gfc_copy_loopinfo_to_se (&rse, &loop); | |
3021 | ||
3022 | rse.ss = loop.temp_ss; | |
3023 | lse.ss = lss; | |
3024 | ||
3025 | gfc_conv_tmp_array_ref (&rse); | |
3026 | gfc_advance_se_ss_chain (&rse); | |
3027 | gfc_conv_expr (&lse, expr1); | |
3028 | ||
6e45f57b PB |
3029 | gcc_assert (lse.ss == gfc_ss_terminator |
3030 | && rse.ss == gfc_ss_terminator); | |
6de9cd9a DN |
3031 | |
3032 | /* Form the mask expression according to the mask tree list. */ | |
3033 | index = count2; | |
3c90c9ae | 3034 | maskexpr = gfc_build_array_ref (mask, index); |
011daa76 RS |
3035 | if (invert) |
3036 | maskexpr = fold_build1 (TRUTH_NOT_EXPR, TREE_TYPE (maskexpr), | |
3037 | maskexpr); | |
6de9cd9a | 3038 | |
6de9cd9a | 3039 | /* Use the scalar assignment as is. */ |
5046aff5 | 3040 | tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, false, false); |
923ab88c | 3041 | tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt ()); |
6de9cd9a | 3042 | gfc_add_expr_to_block (&body, tmp); |
7ab92584 | 3043 | |
6de9cd9a | 3044 | /* Increment count2. */ |
10c7a96f SB |
3045 | tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, |
3046 | count2, gfc_index_one_node); | |
6de9cd9a DN |
3047 | gfc_add_modify_expr (&body, count2, tmp); |
3048 | } | |
3049 | else | |
3050 | { | |
3051 | /* Increment count1. */ | |
10c7a96f SB |
3052 | tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, |
3053 | count1, gfc_index_one_node); | |
6de9cd9a DN |
3054 | gfc_add_modify_expr (&body, count1, tmp); |
3055 | } | |
3056 | ||
3057 | /* Generate the copying loops. */ | |
3058 | gfc_trans_scalarizing_loops (&loop, &body); | |
3059 | ||
3060 | /* Wrap the whole thing up. */ | |
3061 | gfc_add_block_to_block (&block, &loop.pre); | |
3062 | gfc_add_block_to_block (&block, &loop.post); | |
3063 | gfc_cleanup_loop (&loop); | |
3064 | } | |
3065 | ||
3066 | return gfc_finish_block (&block); | |
3067 | } | |
3068 | ||
3069 | ||
3070 | /* Translate the WHERE construct or statement. | |
aa9c57ec | 3071 | This function can be called iteratively to translate the nested WHERE |
6de9cd9a | 3072 | construct or statement. |
3891cee2 | 3073 | MASK is the control mask. */ |
6de9cd9a DN |
3074 | |
3075 | static void | |
011daa76 | 3076 | gfc_trans_where_2 (gfc_code * code, tree mask, bool invert, |
3891cee2 | 3077 | forall_info * nested_forall_info, stmtblock_t * block) |
6de9cd9a | 3078 | { |
3891cee2 RS |
3079 | stmtblock_t inner_size_body; |
3080 | tree inner_size, size; | |
3081 | gfc_ss *lss, *rss; | |
3082 | tree mask_type; | |
6de9cd9a DN |
3083 | gfc_expr *expr1; |
3084 | gfc_expr *expr2; | |
3085 | gfc_code *cblock; | |
3086 | gfc_code *cnext; | |
3891cee2 | 3087 | tree tmp; |
6de9cd9a | 3088 | tree count1, count2; |
011daa76 RS |
3089 | bool need_cmask; |
3090 | bool need_pmask; | |
6de9cd9a | 3091 | int need_temp; |
3891cee2 RS |
3092 | tree pcmask = NULL_TREE; |
3093 | tree ppmask = NULL_TREE; | |
3094 | tree cmask = NULL_TREE; | |
3095 | tree pmask = NULL_TREE; | |
6de9cd9a DN |
3096 | |
3097 | /* the WHERE statement or the WHERE construct statement. */ | |
3098 | cblock = code->block; | |
3891cee2 | 3099 | |
3891cee2 RS |
3100 | /* As the mask array can be very big, prefer compact boolean types. */ |
3101 | mask_type = gfc_get_logical_type (gfc_logical_kinds[0].kind); | |
3102 | ||
011daa76 RS |
3103 | /* Determine which temporary masks are needed. */ |
3104 | if (!cblock->block) | |
90f58ec8 | 3105 | { |
011daa76 RS |
3106 | /* One clause: No ELSEWHEREs. */ |
3107 | need_cmask = (cblock->next != 0); | |
3108 | need_pmask = false; | |
90f58ec8 | 3109 | } |
011daa76 | 3110 | else if (cblock->block->block) |
90f58ec8 | 3111 | { |
011daa76 RS |
3112 | /* Three or more clauses: Conditional ELSEWHEREs. */ |
3113 | need_cmask = true; | |
3114 | need_pmask = true; | |
90f58ec8 | 3115 | } |
011daa76 RS |
3116 | else if (cblock->next) |
3117 | { | |
3118 | /* Two clauses, the first non-empty. */ | |
3119 | need_cmask = true; | |
3120 | need_pmask = (mask != NULL_TREE | |
3121 | && cblock->block->next != 0); | |
3122 | } | |
3123 | else if (!cblock->block->next) | |
3891cee2 | 3124 | { |
011daa76 RS |
3125 | /* Two clauses, both empty. */ |
3126 | need_cmask = false; | |
3127 | need_pmask = false; | |
3128 | } | |
3129 | /* Two clauses, the first empty, the second non-empty. */ | |
3130 | else if (mask) | |
3131 | { | |
3132 | need_cmask = (cblock->block->expr != 0); | |
3133 | need_pmask = true; | |
3891cee2 RS |
3134 | } |
3135 | else | |
3136 | { | |
011daa76 RS |
3137 | need_cmask = true; |
3138 | need_pmask = false; | |
3139 | } | |
3140 | ||
3141 | if (need_cmask || need_pmask) | |
3142 | { | |
3143 | /* Calculate the size of temporary needed by the mask-expr. */ | |
3144 | gfc_init_block (&inner_size_body); | |
3145 | inner_size = compute_inner_temp_size (cblock->expr, cblock->expr, | |
3146 | &inner_size_body, &lss, &rss); | |
3147 | ||
3148 | /* Calculate the total size of temporary needed. */ | |
3149 | size = compute_overall_iter_number (nested_forall_info, inner_size, | |
3150 | &inner_size_body, block); | |
3151 | ||
3152 | /* Allocate temporary for WHERE mask if needed. */ | |
3153 | if (need_cmask) | |
3154 | cmask = allocate_temp_for_forall_nest_1 (mask_type, size, block, | |
3155 | &pcmask); | |
3156 | ||
3157 | /* Allocate temporary for !mask if needed. */ | |
3158 | if (need_pmask) | |
3159 | pmask = allocate_temp_for_forall_nest_1 (mask_type, size, block, | |
3160 | &ppmask); | |
3891cee2 RS |
3161 | } |
3162 | ||
6de9cd9a DN |
3163 | while (cblock) |
3164 | { | |
011daa76 RS |
3165 | /* Each time around this loop, the where clause is conditional |
3166 | on the value of mask and invert, which are updated at the | |
3167 | bottom of the loop. */ | |
3168 | ||
6de9cd9a DN |
3169 | /* Has mask-expr. */ |
3170 | if (cblock->expr) | |
3171 | { | |
90f58ec8 RS |
3172 | /* Ensure that the WHERE mask will be evaluated exactly once. |
3173 | If there are no statements in this WHERE/ELSEWHERE clause, | |
3174 | then we don't need to update the control mask (cmask). | |
3175 | If this is the last clause of the WHERE construct, then | |
3891cee2 | 3176 | we don't need to update the pending control mask (pmask). */ |
011daa76 RS |
3177 | if (mask) |
3178 | gfc_evaluate_where_mask (cblock->expr, nested_forall_info, | |
3179 | mask, invert, | |
3180 | cblock->next ? cmask : NULL_TREE, | |
3181 | cblock->block ? pmask : NULL_TREE, | |
3182 | mask_type, block); | |
3183 | else | |
3184 | gfc_evaluate_where_mask (cblock->expr, nested_forall_info, | |
3185 | NULL_TREE, false, | |
3186 | (cblock->next || cblock->block) | |
3187 | ? cmask : NULL_TREE, | |
3188 | NULL_TREE, mask_type, block); | |
6de9cd9a | 3189 | |
011daa76 | 3190 | invert = false; |
6de9cd9a | 3191 | } |
90f58ec8 | 3192 | /* It's a final elsewhere-stmt. No mask-expr is present. */ |
6de9cd9a | 3193 | else |
3891cee2 | 3194 | cmask = mask; |
6de9cd9a | 3195 | |
011daa76 RS |
3196 | /* The body of this where clause are controlled by cmask with |
3197 | sense specified by invert. */ | |
3198 | ||
6de9cd9a DN |
3199 | /* Get the assignment statement of a WHERE statement, or the first |
3200 | statement in where-body-construct of a WHERE construct. */ | |
3201 | cnext = cblock->next; | |
3202 | while (cnext) | |
3203 | { | |
3204 | switch (cnext->op) | |
3205 | { | |
3206 | /* WHERE assignment statement. */ | |
3207 | case EXEC_ASSIGN: | |
3208 | expr1 = cnext->expr; | |
3209 | expr2 = cnext->expr2; | |
3210 | if (nested_forall_info != NULL) | |
3211 | { | |
3ded6210 | 3212 | need_temp = gfc_check_dependency (expr1, expr2, 0); |
6de9cd9a | 3213 | if (need_temp) |
011daa76 RS |
3214 | gfc_trans_assign_need_temp (expr1, expr2, |
3215 | cmask, invert, | |
6de9cd9a DN |
3216 | nested_forall_info, block); |
3217 | else | |
3218 | { | |
3219 | /* Variables to control maskexpr. */ | |
3220 | count1 = gfc_create_var (gfc_array_index_type, "count1"); | |
3221 | count2 = gfc_create_var (gfc_array_index_type, "count2"); | |
7ab92584 SB |
3222 | gfc_add_modify_expr (block, count1, gfc_index_zero_node); |
3223 | gfc_add_modify_expr (block, count2, gfc_index_zero_node); | |
6de9cd9a | 3224 | |
011daa76 RS |
3225 | tmp = gfc_trans_where_assign (expr1, expr2, |
3226 | cmask, invert, | |
3891cee2 | 3227 | count1, count2); |
8de1f441 | 3228 | |
6de9cd9a DN |
3229 | tmp = gfc_trans_nested_forall_loop (nested_forall_info, |
3230 | tmp, 1, 1); | |
3231 | gfc_add_expr_to_block (block, tmp); | |
3232 | } | |
3233 | } | |
3234 | else | |
3235 | { | |
3236 | /* Variables to control maskexpr. */ | |
3237 | count1 = gfc_create_var (gfc_array_index_type, "count1"); | |
3238 | count2 = gfc_create_var (gfc_array_index_type, "count2"); | |
7ab92584 SB |
3239 | gfc_add_modify_expr (block, count1, gfc_index_zero_node); |
3240 | gfc_add_modify_expr (block, count2, gfc_index_zero_node); | |
6de9cd9a | 3241 | |
011daa76 RS |
3242 | tmp = gfc_trans_where_assign (expr1, expr2, |
3243 | cmask, invert, | |
3891cee2 | 3244 | count1, count2); |
6de9cd9a DN |
3245 | gfc_add_expr_to_block (block, tmp); |
3246 | ||
3247 | } | |
3248 | break; | |
3249 | ||
3250 | /* WHERE or WHERE construct is part of a where-body-construct. */ | |
3251 | case EXEC_WHERE: | |
011daa76 RS |
3252 | gfc_trans_where_2 (cnext, cmask, invert, |
3253 | nested_forall_info, block); | |
3891cee2 | 3254 | break; |
6de9cd9a DN |
3255 | |
3256 | default: | |
6e45f57b | 3257 | gcc_unreachable (); |
6de9cd9a DN |
3258 | } |
3259 | ||
3260 | /* The next statement within the same where-body-construct. */ | |
3261 | cnext = cnext->next; | |
3262 | } | |
3263 | /* The next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt. */ | |
3264 | cblock = cblock->block; | |
011daa76 RS |
3265 | if (mask == NULL_TREE) |
3266 | { | |
3267 | /* If we're the initial WHERE, we can simply invert the sense | |
3268 | of the current mask to obtain the "mask" for the remaining | |
3269 | ELSEWHEREs. */ | |
3270 | invert = true; | |
3271 | mask = cmask; | |
3272 | } | |
3273 | else | |
3274 | { | |
3275 | /* Otherwise, for nested WHERE's we need to use the pending mask. */ | |
3276 | invert = false; | |
3277 | mask = pmask; | |
3278 | } | |
6de9cd9a | 3279 | } |
3891cee2 RS |
3280 | |
3281 | /* If we allocated a pending mask array, deallocate it now. */ | |
3282 | if (ppmask) | |
3283 | { | |
3284 | tree args = gfc_chainon_list (NULL_TREE, ppmask); | |
3285 | tmp = build_function_call_expr (gfor_fndecl_internal_free, args); | |
3286 | gfc_add_expr_to_block (block, tmp); | |
3287 | } | |
3288 | ||
3289 | /* If we allocated a current mask array, deallocate it now. */ | |
3290 | if (pcmask) | |
3291 | { | |
3292 | tree args = gfc_chainon_list (NULL_TREE, pcmask); | |
3293 | tmp = build_function_call_expr (gfor_fndecl_internal_free, args); | |
3294 | gfc_add_expr_to_block (block, tmp); | |
3295 | } | |
6de9cd9a DN |
3296 | } |
3297 | ||
3ded6210 RS |
3298 | /* Translate a simple WHERE construct or statement without dependencies. |
3299 | CBLOCK is the "then" clause of the WHERE statement, where CBLOCK->EXPR | |
3300 | is the mask condition, and EBLOCK if non-NULL is the "else" clause. | |
3301 | Currently both CBLOCK and EBLOCK are restricted to single assignments. */ | |
3302 | ||
3303 | static tree | |
3304 | gfc_trans_where_3 (gfc_code * cblock, gfc_code * eblock) | |
3305 | { | |
3306 | stmtblock_t block, body; | |
3307 | gfc_expr *cond, *tdst, *tsrc, *edst, *esrc; | |
3308 | tree tmp, cexpr, tstmt, estmt; | |
3309 | gfc_ss *css, *tdss, *tsss; | |
3310 | gfc_se cse, tdse, tsse, edse, esse; | |
3311 | gfc_loopinfo loop; | |
3312 | gfc_ss *edss = 0; | |
3313 | gfc_ss *esss = 0; | |
3314 | ||
3315 | cond = cblock->expr; | |
3316 | tdst = cblock->next->expr; | |
3317 | tsrc = cblock->next->expr2; | |
3318 | edst = eblock ? eblock->next->expr : NULL; | |
3319 | esrc = eblock ? eblock->next->expr2 : NULL; | |
3320 | ||
3321 | gfc_start_block (&block); | |
3322 | gfc_init_loopinfo (&loop); | |
3323 | ||
3324 | /* Handle the condition. */ | |
3325 | gfc_init_se (&cse, NULL); | |
3326 | css = gfc_walk_expr (cond); | |
3327 | gfc_add_ss_to_loop (&loop, css); | |
3328 | ||
3329 | /* Handle the then-clause. */ | |
3330 | gfc_init_se (&tdse, NULL); | |
3331 | gfc_init_se (&tsse, NULL); | |
3332 | tdss = gfc_walk_expr (tdst); | |
3333 | tsss = gfc_walk_expr (tsrc); | |
3334 | if (tsss == gfc_ss_terminator) | |
3335 | { | |
3336 | tsss = gfc_get_ss (); | |
3337 | tsss->next = gfc_ss_terminator; | |
3338 | tsss->type = GFC_SS_SCALAR; | |
3339 | tsss->expr = tsrc; | |
3340 | } | |
3341 | gfc_add_ss_to_loop (&loop, tdss); | |
3342 | gfc_add_ss_to_loop (&loop, tsss); | |
3343 | ||
3344 | if (eblock) | |
3345 | { | |
3346 | /* Handle the else clause. */ | |
3347 | gfc_init_se (&edse, NULL); | |
3348 | gfc_init_se (&esse, NULL); | |
3349 | edss = gfc_walk_expr (edst); | |
3350 | esss = gfc_walk_expr (esrc); | |
3351 | if (esss == gfc_ss_terminator) | |
3352 | { | |
3353 | esss = gfc_get_ss (); | |
3354 | esss->next = gfc_ss_terminator; | |
3355 | esss->type = GFC_SS_SCALAR; | |
3356 | esss->expr = esrc; | |
3357 | } | |
3358 | gfc_add_ss_to_loop (&loop, edss); | |
3359 | gfc_add_ss_to_loop (&loop, esss); | |
3360 | } | |
3361 | ||
3362 | gfc_conv_ss_startstride (&loop); | |
3363 | gfc_conv_loop_setup (&loop); | |
3364 | ||
3365 | gfc_mark_ss_chain_used (css, 1); | |
3366 | gfc_mark_ss_chain_used (tdss, 1); | |
3367 | gfc_mark_ss_chain_used (tsss, 1); | |
3368 | if (eblock) | |
3369 | { | |
3370 | gfc_mark_ss_chain_used (edss, 1); | |
3371 | gfc_mark_ss_chain_used (esss, 1); | |
3372 | } | |
3373 | ||
3374 | gfc_start_scalarized_body (&loop, &body); | |
3375 | ||
3376 | gfc_copy_loopinfo_to_se (&cse, &loop); | |
3377 | gfc_copy_loopinfo_to_se (&tdse, &loop); | |
3378 | gfc_copy_loopinfo_to_se (&tsse, &loop); | |
3379 | cse.ss = css; | |
3380 | tdse.ss = tdss; | |
3381 | tsse.ss = tsss; | |
3382 | if (eblock) | |
3383 | { | |
3384 | gfc_copy_loopinfo_to_se (&edse, &loop); | |
3385 | gfc_copy_loopinfo_to_se (&esse, &loop); | |
3386 | edse.ss = edss; | |
3387 | esse.ss = esss; | |
3388 | } | |
3389 | ||
3390 | gfc_conv_expr (&cse, cond); | |
3391 | gfc_add_block_to_block (&body, &cse.pre); | |
3392 | cexpr = cse.expr; | |
3393 | ||
3394 | gfc_conv_expr (&tsse, tsrc); | |
3395 | if (tdss != gfc_ss_terminator && loop.temp_ss != NULL) | |
3396 | { | |
3397 | gfc_conv_tmp_array_ref (&tdse); | |
3398 | gfc_advance_se_ss_chain (&tdse); | |
3399 | } | |
3400 | else | |
3401 | gfc_conv_expr (&tdse, tdst); | |
3402 | ||
3403 | if (eblock) | |
3404 | { | |
3405 | gfc_conv_expr (&esse, esrc); | |
3406 | if (edss != gfc_ss_terminator && loop.temp_ss != NULL) | |
3407 | { | |
3408 | gfc_conv_tmp_array_ref (&edse); | |
3409 | gfc_advance_se_ss_chain (&edse); | |
3410 | } | |
3411 | else | |
3412 | gfc_conv_expr (&edse, edst); | |
3413 | } | |
3414 | ||
5046aff5 PT |
3415 | tstmt = gfc_trans_scalar_assign (&tdse, &tsse, tdst->ts, false, false); |
3416 | estmt = eblock ? gfc_trans_scalar_assign (&edse, &esse, edst->ts, false, false) | |
3ded6210 RS |
3417 | : build_empty_stmt (); |
3418 | tmp = build3_v (COND_EXPR, cexpr, tstmt, estmt); | |
3419 | gfc_add_expr_to_block (&body, tmp); | |
3420 | gfc_add_block_to_block (&body, &cse.post); | |
3421 | ||
3422 | gfc_trans_scalarizing_loops (&loop, &body); | |
3423 | gfc_add_block_to_block (&block, &loop.pre); | |
3424 | gfc_add_block_to_block (&block, &loop.post); | |
3425 | gfc_cleanup_loop (&loop); | |
3426 | ||
3427 | return gfc_finish_block (&block); | |
3428 | } | |
6de9cd9a DN |
3429 | |
3430 | /* As the WHERE or WHERE construct statement can be nested, we call | |
3431 | gfc_trans_where_2 to do the translation, and pass the initial | |
f7b529fa | 3432 | NULL values for both the control mask and the pending control mask. */ |
6de9cd9a DN |
3433 | |
3434 | tree | |
3435 | gfc_trans_where (gfc_code * code) | |
3436 | { | |
3437 | stmtblock_t block; | |
3ded6210 RS |
3438 | gfc_code *cblock; |
3439 | gfc_code *eblock; | |
6de9cd9a | 3440 | |
3ded6210 RS |
3441 | cblock = code->block; |
3442 | if (cblock->next | |
3443 | && cblock->next->op == EXEC_ASSIGN | |
3444 | && !cblock->next->next) | |
3445 | { | |
3446 | eblock = cblock->block; | |
3447 | if (!eblock) | |
3448 | { | |
3449 | /* A simple "WHERE (cond) x = y" statement or block is | |
3450 | dependence free if cond is not dependent upon writing x, | |
3451 | and the source y is unaffected by the destination x. */ | |
3452 | if (!gfc_check_dependency (cblock->next->expr, | |
3453 | cblock->expr, 0) | |
3454 | && !gfc_check_dependency (cblock->next->expr, | |
3455 | cblock->next->expr2, 0)) | |
3456 | return gfc_trans_where_3 (cblock, NULL); | |
3457 | } | |
3458 | else if (!eblock->expr | |
3459 | && !eblock->block | |
3460 | && eblock->next | |
3461 | && eblock->next->op == EXEC_ASSIGN | |
3462 | && !eblock->next->next) | |
3463 | { | |
3464 | /* A simple "WHERE (cond) x1 = y1 ELSEWHERE x2 = y2 ENDWHERE" | |
3465 | block is dependence free if cond is not dependent on writes | |
3466 | to x1 and x2, y1 is not dependent on writes to x2, and y2 | |
3467 | is not dependent on writes to x1, and both y's are not | |
3468 | dependent upon their own x's. */ | |
3469 | if (!gfc_check_dependency(cblock->next->expr, | |
3470 | cblock->expr, 0) | |
3471 | && !gfc_check_dependency(eblock->next->expr, | |
3472 | cblock->expr, 0) | |
3473 | && !gfc_check_dependency(cblock->next->expr, | |
3474 | eblock->next->expr2, 0) | |
3475 | && !gfc_check_dependency(eblock->next->expr, | |
3476 | cblock->next->expr2, 0) | |
3477 | && !gfc_check_dependency(cblock->next->expr, | |
3478 | cblock->next->expr2, 0) | |
3479 | && !gfc_check_dependency(eblock->next->expr, | |
3480 | eblock->next->expr2, 0)) | |
3481 | return gfc_trans_where_3 (cblock, eblock); | |
3482 | } | |
3483 | } | |
3484 | ||
6de9cd9a | 3485 | gfc_start_block (&block); |
6de9cd9a | 3486 | |
011daa76 | 3487 | gfc_trans_where_2 (code, NULL, false, NULL, &block); |
6de9cd9a | 3488 | |
6de9cd9a DN |
3489 | return gfc_finish_block (&block); |
3490 | } | |
3491 | ||
3492 | ||
3493 | /* CYCLE a DO loop. The label decl has already been created by | |
3494 | gfc_trans_do(), it's in TREE_PURPOSE (backend_decl) of the gfc_code | |
3495 | node at the head of the loop. We must mark the label as used. */ | |
3496 | ||
3497 | tree | |
3498 | gfc_trans_cycle (gfc_code * code) | |
3499 | { | |
3500 | tree cycle_label; | |
3501 | ||
3502 | cycle_label = TREE_PURPOSE (code->ext.whichloop->backend_decl); | |
3503 | TREE_USED (cycle_label) = 1; | |
3504 | return build1_v (GOTO_EXPR, cycle_label); | |
3505 | } | |
3506 | ||
3507 | ||
e7dc5b4f | 3508 | /* EXIT a DO loop. Similar to CYCLE, but now the label is in |
6de9cd9a DN |
3509 | TREE_VALUE (backend_decl) of the gfc_code node at the head of the |
3510 | loop. */ | |
3511 | ||
3512 | tree | |
3513 | gfc_trans_exit (gfc_code * code) | |
3514 | { | |
3515 | tree exit_label; | |
3516 | ||
3517 | exit_label = TREE_VALUE (code->ext.whichloop->backend_decl); | |
3518 | TREE_USED (exit_label) = 1; | |
3519 | return build1_v (GOTO_EXPR, exit_label); | |
3520 | } | |
3521 | ||
3522 | ||
3523 | /* Translate the ALLOCATE statement. */ | |
3524 | ||
3525 | tree | |
3526 | gfc_trans_allocate (gfc_code * code) | |
3527 | { | |
3528 | gfc_alloc *al; | |
3529 | gfc_expr *expr; | |
3530 | gfc_se se; | |
3531 | tree tmp; | |
3532 | tree parm; | |
6de9cd9a DN |
3533 | tree stat; |
3534 | tree pstat; | |
3535 | tree error_label; | |
3536 | stmtblock_t block; | |
3537 | ||
3538 | if (!code->ext.alloc_list) | |
3539 | return NULL_TREE; | |
3540 | ||
3541 | gfc_start_block (&block); | |
3542 | ||
3543 | if (code->expr) | |
3544 | { | |
e2cad04b RH |
3545 | tree gfc_int4_type_node = gfc_get_int_type (4); |
3546 | ||
6de9cd9a | 3547 | stat = gfc_create_var (gfc_int4_type_node, "stat"); |
488ce07b | 3548 | pstat = build_fold_addr_expr (stat); |
6de9cd9a DN |
3549 | |
3550 | error_label = gfc_build_label_decl (NULL_TREE); | |
3551 | TREE_USED (error_label) = 1; | |
3552 | } | |
3553 | else | |
3554 | { | |
3555 | pstat = integer_zero_node; | |
3556 | stat = error_label = NULL_TREE; | |
3557 | } | |
3558 | ||
3559 | ||
3560 | for (al = code->ext.alloc_list; al != NULL; al = al->next) | |
3561 | { | |
3562 | expr = al->expr; | |
3563 | ||
3564 | gfc_init_se (&se, NULL); | |
3565 | gfc_start_block (&se.pre); | |
3566 | ||
3567 | se.want_pointer = 1; | |
3568 | se.descriptor_only = 1; | |
3569 | gfc_conv_expr (&se, expr); | |
3570 | ||
5b725b8d | 3571 | if (!gfc_array_allocate (&se, expr, pstat)) |
6de9cd9a DN |
3572 | { |
3573 | /* A scalar or derived type. */ | |
3574 | tree val; | |
3575 | ||
3576 | val = gfc_create_var (ppvoid_type_node, "ptr"); | |
3577 | tmp = gfc_build_addr_expr (ppvoid_type_node, se.expr); | |
3578 | gfc_add_modify_expr (&se.pre, val, tmp); | |
3579 | ||
3580 | tmp = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se.expr))); | |
c4bbc105 PT |
3581 | |
3582 | if (expr->ts.type == BT_CHARACTER && tmp == NULL_TREE) | |
3583 | tmp = se.string_length; | |
3584 | ||
6de9cd9a DN |
3585 | parm = gfc_chainon_list (NULL_TREE, val); |
3586 | parm = gfc_chainon_list (parm, tmp); | |
3587 | parm = gfc_chainon_list (parm, pstat); | |
3380b802 | 3588 | tmp = build_function_call_expr (gfor_fndecl_allocate, parm); |
6de9cd9a DN |
3589 | gfc_add_expr_to_block (&se.pre, tmp); |
3590 | ||
3591 | if (code->expr) | |
3592 | { | |
3593 | tmp = build1_v (GOTO_EXPR, error_label); | |
61ead135 RG |
3594 | parm = fold_build2 (NE_EXPR, boolean_type_node, |
3595 | stat, build_int_cst (TREE_TYPE (stat), 0)); | |
3596 | tmp = fold_build3 (COND_EXPR, void_type_node, | |
3597 | parm, tmp, build_empty_stmt ()); | |
6de9cd9a DN |
3598 | gfc_add_expr_to_block (&se.pre, tmp); |
3599 | } | |
5046aff5 PT |
3600 | |
3601 | if (expr->ts.type == BT_DERIVED && expr->ts.derived->attr.alloc_comp) | |
3602 | { | |
3603 | tmp = build_fold_indirect_ref (se.expr); | |
3604 | tmp = gfc_nullify_alloc_comp (expr->ts.derived, tmp, 0); | |
3605 | gfc_add_expr_to_block (&se.pre, tmp); | |
3606 | } | |
3607 | ||
6de9cd9a DN |
3608 | } |
3609 | ||
3610 | tmp = gfc_finish_block (&se.pre); | |
3611 | gfc_add_expr_to_block (&block, tmp); | |
3612 | } | |
3613 | ||
3614 | /* Assign the value to the status variable. */ | |
3615 | if (code->expr) | |
3616 | { | |
3617 | tmp = build1_v (LABEL_EXPR, error_label); | |
3618 | gfc_add_expr_to_block (&block, tmp); | |
3619 | ||
3620 | gfc_init_se (&se, NULL); | |
3621 | gfc_conv_expr_lhs (&se, code->expr); | |
3622 | tmp = convert (TREE_TYPE (se.expr), stat); | |
3623 | gfc_add_modify_expr (&block, se.expr, tmp); | |
3624 | } | |
3625 | ||
3626 | return gfc_finish_block (&block); | |
3627 | } | |
3628 | ||
3629 | ||
364667a1 SK |
3630 | /* Translate a DEALLOCATE statement. |
3631 | There are two cases within the for loop: | |
3632 | (1) deallocate(a1, a2, a3) is translated into the following sequence | |
3633 | _gfortran_deallocate(a1, 0B) | |
3634 | _gfortran_deallocate(a2, 0B) | |
3635 | _gfortran_deallocate(a3, 0B) | |
3636 | where the STAT= variable is passed a NULL pointer. | |
3637 | (2) deallocate(a1, a2, a3, stat=i) is translated into the following | |
3638 | astat = 0 | |
3639 | _gfortran_deallocate(a1, &stat) | |
3640 | astat = astat + stat | |
3641 | _gfortran_deallocate(a2, &stat) | |
3642 | astat = astat + stat | |
3643 | _gfortran_deallocate(a3, &stat) | |
3644 | astat = astat + stat | |
3645 | In case (1), we simply return at the end of the for loop. In case (2) | |
3646 | we set STAT= astat. */ | |
6de9cd9a DN |
3647 | tree |
3648 | gfc_trans_deallocate (gfc_code * code) | |
3649 | { | |
3650 | gfc_se se; | |
3651 | gfc_alloc *al; | |
3652 | gfc_expr *expr; | |
364667a1 | 3653 | tree apstat, astat, parm, pstat, stat, tmp, type, var; |
6de9cd9a DN |
3654 | stmtblock_t block; |
3655 | ||
3656 | gfc_start_block (&block); | |
3657 | ||
364667a1 SK |
3658 | /* Set up the optional STAT= */ |
3659 | if (code->expr) | |
3660 | { | |
3661 | tree gfc_int4_type_node = gfc_get_int_type (4); | |
3662 | ||
3663 | /* Variable used with the library call. */ | |
3664 | stat = gfc_create_var (gfc_int4_type_node, "stat"); | |
488ce07b | 3665 | pstat = build_fold_addr_expr (stat); |
364667a1 SK |
3666 | |
3667 | /* Running total of possible deallocation failures. */ | |
3668 | astat = gfc_create_var (gfc_int4_type_node, "astat"); | |
488ce07b | 3669 | apstat = build_fold_addr_expr (astat); |
364667a1 SK |
3670 | |
3671 | /* Initialize astat to 0. */ | |
3672 | gfc_add_modify_expr (&block, astat, build_int_cst (TREE_TYPE (astat), 0)); | |
3673 | } | |
3674 | else | |
3675 | { | |
3676 | pstat = apstat = null_pointer_node; | |
3677 | stat = astat = NULL_TREE; | |
3678 | } | |
3679 | ||
6de9cd9a DN |
3680 | for (al = code->ext.alloc_list; al != NULL; al = al->next) |
3681 | { | |
3682 | expr = al->expr; | |
6e45f57b | 3683 | gcc_assert (expr->expr_type == EXPR_VARIABLE); |
6de9cd9a DN |
3684 | |
3685 | gfc_init_se (&se, NULL); | |
3686 | gfc_start_block (&se.pre); | |
3687 | ||
3688 | se.want_pointer = 1; | |
3689 | se.descriptor_only = 1; | |
3690 | gfc_conv_expr (&se, expr); | |
3691 | ||
5046aff5 PT |
3692 | if (expr->ts.type == BT_DERIVED |
3693 | && expr->ts.derived->attr.alloc_comp) | |
3694 | { | |
3695 | gfc_ref *ref; | |
3696 | gfc_ref *last = NULL; | |
3697 | for (ref = expr->ref; ref; ref = ref->next) | |
3698 | if (ref->type == REF_COMPONENT) | |
3699 | last = ref; | |
3700 | ||
3701 | /* Do not deallocate the components of a derived type | |
3702 | ultimate pointer component. */ | |
3703 | if (!(last && last->u.c.component->pointer) | |
3704 | && !(!last && expr->symtree->n.sym->attr.pointer)) | |
3705 | { | |
3706 | tmp = gfc_deallocate_alloc_comp (expr->ts.derived, se.expr, | |
3707 | expr->rank); | |
3708 | gfc_add_expr_to_block (&se.pre, tmp); | |
3709 | } | |
3710 | } | |
3711 | ||
4c46bf2e | 3712 | if (expr->rank) |
364667a1 | 3713 | tmp = gfc_array_deallocate (se.expr, pstat); |
6de9cd9a DN |
3714 | else |
3715 | { | |
3716 | type = build_pointer_type (TREE_TYPE (se.expr)); | |
3717 | var = gfc_create_var (type, "ptr"); | |
3718 | tmp = gfc_build_addr_expr (type, se.expr); | |
3719 | gfc_add_modify_expr (&se.pre, var, tmp); | |
3720 | ||
364667a1 SK |
3721 | parm = gfc_chainon_list (NULL_TREE, var); |
3722 | parm = gfc_chainon_list (parm, pstat); | |
3380b802 | 3723 | tmp = build_function_call_expr (gfor_fndecl_deallocate, parm); |
6de9cd9a | 3724 | } |
364667a1 SK |
3725 | |
3726 | gfc_add_expr_to_block (&se.pre, tmp); | |
3727 | ||
3728 | /* Keep track of the number of failed deallocations by adding stat | |
3729 | of the last deallocation to the running total. */ | |
3730 | if (code->expr) | |
3731 | { | |
3732 | apstat = build2 (PLUS_EXPR, TREE_TYPE (stat), astat, stat); | |
3733 | gfc_add_modify_expr (&se.pre, astat, apstat); | |
3734 | } | |
3735 | ||
6de9cd9a DN |
3736 | tmp = gfc_finish_block (&se.pre); |
3737 | gfc_add_expr_to_block (&block, tmp); | |
364667a1 SK |
3738 | |
3739 | } | |
3740 | ||
3741 | /* Assign the value to the status variable. */ | |
3742 | if (code->expr) | |
3743 | { | |
3744 | gfc_init_se (&se, NULL); | |
3745 | gfc_conv_expr_lhs (&se, code->expr); | |
3746 | tmp = convert (TREE_TYPE (se.expr), astat); | |
3747 | gfc_add_modify_expr (&block, se.expr, tmp); | |
6de9cd9a DN |
3748 | } |
3749 | ||
3750 | return gfc_finish_block (&block); | |
3751 | } | |
3752 |