Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 645 lines (453 sloc) 18.701 kB
4c6fcac 7/28
andyv authored
1
2 /* Array Scalarization
3 Copyright (C) 2000 - 2003 Free Software Foundation, Inc.
4 Contributed by Andy Vaught
5
6 This file is part of G95.
7
8 G95 is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 2, or (at your option)
11 any later version.
12
13 G95 is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
17
18 You should have received a copy of the GNU General Public License
19 along with G95; see the file COPYING. If not, write to
20 the Free Software Foundation, 59 Temple Place - Suite 330,
21 Boston, MA 02111-1307, USA. */
22
23 #include "g95.h"
24
25 /* Scalarization is the process of converting a single vector
26 * expression to multiple scalar expressions. The process works by
27 * traversing all code nodes, examining expressions within these
28 * nodes. A single code node can be expanded to multiple code nodes
29 * depending on the expressions it contains. New nodes are inserted
30 * before and after the original node.
31 *
32 * There are three cases that we have to deal with:
33 * Vector subexpressions inside scalar expressions
34 * Assigning a scalar to a vector
35 * Assigning a vector to a vector
36 *
37 * Vector subexpressions within scalar expressions can only happen as
38 * actual arguments. The back end handles cases of passing whole
39 * arrays or sections. We transform a general array expression into
40 * an assignment to a temporary then pass the full array.
41 *
42 * Assigning a scalar to a vector amounts to computing the RHS to a
43 * temporary, then looping over the array and assigning the scalar.
44 *
45 * The vector to vector assignment is more involved and has several
46 * subcases. */
47
48
49 /* When nodes are inserted prior to the current node, the current node
50 * has to be moved. This pointer points to the node being scalarized
51 * and can change during the process. */
52
53 static g95_code *current_code;
54
55 #ifdef IN_GCC
56
57 static void scalarize_scalar_expr(g95_expr *);
58 static void traverse_code(g95_code *);
59
60
61
62
63 /* scalarize_actual_arg()-- Given an actual argument, see if it is an
64 * array expression that can be passed directly or not. If not,
65 * generate the assignment to a temporary, pass the temporary and
66 * generate any cleanup code. The temporary assignment is scalarized
67 * separately. */
68
69 static void scalarize_actual_arg(g95_expr *arg) {
70
71 if (arg == NULL || arg->rank == 0) return;
72
73 /*TODO */
74
75 /* scalarize_vector_assignment(); */
76 }
77
78
79
80
81 /* get_variable_expr()-- Given a symbol, create an expression node with that
82 * symbol as a variable. */
83
84 static g95_expr *get_variable_expr(g95_symbol *var) {
85 g95_expr *e;
86
87 e = g95_get_expr();
88 e->type = EXPR_VARIABLE;
89 e->symbol = var;
90
91 e->rank = (var->as == NULL) ? 0 : var->as->rank;
92 e->ts = var->ts;
93
94 return e;
95 }
96
97
98
99
100 /* bound_expr()-- Given an array, a dimension and a upper/lower flag,
101 * generate an expression that is the upper or lower bound intrinsic
102 * for that dimension. */
103
104 static g95_expr *bound_expr(g95_expr *array, int dimension, int upper_flag) {
105 g95_actual_arglist *b;
106 g95_expr *c;
107
108 c = g95_get_expr();
109 c->type = EXPR_FUNCTION;
110 c->value.function.isym = g95_find_function(upper_flag ? "ubound" : "lbound");
111 c->value.function.name = c->value.function.isym->name;
112
113 c->value.function.actual = b = g95_get_actual_arglist();
114 b->type = FULL_ARRAY;
115 b->u.expr = array;
116 /* a->pointer = ??? */
117
118 b->next = g95_get_actual_arglist();
119 b = b->next;
120
121 b->type = EXPR;
122 b->u.expr = g95_int_expr(dimension+1);
123
124 return c;
125 }
126
127
128
129
130 /* scalarize_actual_arglist()-- Given an actual argument list, go
131 * through it and replace vector expressions (besides full array
132 * references) with a precalculated temporary. */
133
134 static void scalarize_actual_arglist(g95_actual_arglist *actual) {
135
136 for(; actual; actual=actual->next)
137 if (actual->type != EXPR)
138 scalarize_actual_arg(actual->u.expr);
139 }
140
141
142 /* scalarize_scalar_ref()-- Scalarize a variable reference. */
143
144
145
146 /* full_array()-- Given an expression, return the full array part of
147 * the reference. The expression node is a variable node with a set
148 * of reference structures. We keep everything up to the array
149 * section reference. */
150
151 static g95_expr *full_array(g95_expr *c) {
152 g95_ref *ref, *b;
153
154 c = g95_copy_expr(c);
155
156 if (c->ref->type == REF_ARRAY &&
157 (c->ref->u.ar.type == AR_SECTION ||
158 c->ref->u.ar.type == AR_FULL)) {
159 ref = c->ref;
160 c->ref = NULL;
161 } else {
162 b = c->ref;
163 while(b->next->type != REF_ARRAY ||
164 (b->u.ar.type != AR_SECTION && b->u.ar.type != AR_FULL))
165 b = b->next;
166
167 ref = b->next;
168 b->next = NULL;
169 }
170
171 g95_free_ref_list(ref);
172 return c;
173 }
174
175
176
177
178 static void scalarize_scalar_ref(g95_ref *reference) {
179 int p;
180
181 for(; reference; reference=reference->next) {
182 switch(reference->type) {
183 case REF_ARRAY:
184 for(p=0; p<reference->u.ar.dimen; p++) {
185 scalarize_scalar_expr(reference->u.ar.start[p]);
186 scalarize_scalar_expr(reference->u.ar.end[p]);
187 scalarize_scalar_expr(reference->u.ar.stride[p]);
188 }
189
190 break;
191
192 case REF_COMPONENT:
193 break;
194
195 case REF_SUBSTRING:
196 scalarize_scalar_expr(reference->u.ss.start);
197 scalarize_scalar_expr(reference->u.ss.end);
198 break;
199 }
200 }
201 }
202
203
204
205
206 /* insert_code_node()-- Given a code node, insert it into the current
207 * list. If pre is nonzero, the node is inserted before the current
208 * node, otherwise it is inserted after the current node. */
209
210 static void insert_code_node(g95_code *new, int pre) {
211 g95_code temp;
212
213 if (pre) {
214 temp = *current_code;
215 *current_code = *new;
216 *new = temp;
217
218 current_code->next = new;
219 current_code = new;
220 } else {
221 new->next = current_code->next;
222 current_code->next = new;
223 }
224 }
225
226
227
228
229 /* get_temporary()-- Creates a temporary symbol which is a
230 * variable of a particular type and rank. If the variable has
231 * nonzero rank, it is marked as allocatable with a deferred array
232 * specification. */
233
234 static g95_symbol *get_temporary(g95_typespec *ts, int rank) {
235 char name[G95_MAX_SYMBOL_LEN+1];
236 static int serial = 0;
237 g95_array_spec *as;
238 g95_symtree *st;
239 g95_symbol *symbol;
240
241 sprintf(name, "SC.%d", serial++);
242 symbol = g95_new_symbol(name, g95_current_ns);
243
244 symbol->ts = *ts;
245 symbol->attr.flavor = FL_VARIABLE;
246 symbol->attr.used = 1;
247 symbol->refs = 1;
248
249 if (rank > 0) {
250 as = symbol->as = g95_get_array_spec();
251 as->rank = rank;
252 as->type = AS_DEFERRED;
253
254 symbol->attr.allocatable = 1;
255 }
256
257 st = g95_new_symtree(&g95_current_ns->sym_root, name);
258 st->n.sym = symbol;
259
260 return symbol;
261 }
262
263
264
265
266 /* scalarize_scalar_expr()-- Scalarize an expression that is
267 * ultimately scalar. The only way an array expression can appear in
268 * these expressions is inside an actual argument. */
269
270 static void scalarize_scalar_expr(g95_expr *q) {
271
272 if (q == NULL) return;
273
274 switch(q->type) {
275 case EXPR_SUBSTRING:
276 case EXPR_OP:
277 scalarize_scalar_expr(q->op1);
278 scalarize_scalar_expr(q->op2);
279 break;
280
281 case EXPR_FUNCTION:
282 scalarize_actual_arglist(q->value.function.actual);
283 break;
284
285 case EXPR_VARIABLE:
286 scalarize_scalar_ref(q->ref);
287 break;
288
289 default:
290 break;
291 }
292 }
293
294
295
296
297 /* get_loopvar()-- Allocate an integer loop variable */
298
299 static g95_symbol *get_loopvar(void) {
300 g95_typespec ts;
301
302 ts.type = BT_INTEGER;
303 ts.kind = g95_default_integer_kind();
304
305 return get_temporary(&ts, 0);
306 }
307
308
309
310
311 /* transform_range()-- Given an array reference structure and a
312 * dimension of that structure which is a DIMEN_RANGE, replace the
313 * range with the equivalent loop. Returns a code node corresponding
314 * to the loop. */
315
316 static g95_code *transform_range(g95_array_ref *ar, int dimension) {
317 g95_symbol *loop_var;
318 g95_iterator *iter;
319 g95_expr *array;
320 g95_code *v;
321
322 loop_var = get_loopvar();
323
324 iter = g95_get_iterator();
325 iter->var = get_variable_expr(loop_var);
326
327 v = g95_get_code();
328 v->type = EXEC_DO;
329 v->ext.iterator = iter;
330
331 if (ar->start[dimension] == NULL) {
332 array = full_array(current_code->expr);
333 iter->start = bound_expr(array, dimension, 0);
334 } else {
335 iter->start = ar->start[dimension];
336 ar->start[dimension] = NULL;
337 }
338
339 if (ar->end[dimension] == NULL) {
340 array = full_array(current_code->expr);
341 iter->end = bound_expr(array, dimension, 1);
342 } else {
343 iter->end = ar->end[dimension];
344 ar->end[dimension] = NULL;
345 }
346
347 if (ar->stride[dimension] == NULL)
348 iter->step = g95_int_expr(1);
349 else {
350 iter->step = ar->stride[dimension];
351 ar->stride[dimension] = NULL;
352 }
353
354 ar->dimen_type[dimension] = DIMEN_ELEMENT;
355 ar->start[dimension] = get_variable_expr(loop_var);
356
357 return v;
358 }
359
360
361
362 /*@static void scalarize_vector_assignment*/
363
364 static void scalarize_vector_assignment(void) { }
365
366
367
368
369 /* scalarize_scalar_assignment()-- Scalarize an assignment statement
370 * that assigns a scalar to an array. */
371
372 static void scalarize_scalar_assignment(void) {
373 g95_code *p, *s, *loops;
374 g95_symbol *temp_var;
375 g95_ref *reference;
376 int rank, v;
377
378 temp_var = get_temporary(&current_code->expr2->ts, 0);
379 rank = current_code->expr->rank;
380
381 p = g95_get_code();
382 p->type = EXEC_ASSIGN;
383 p->expr = get_variable_expr(temp_var);
384 p->expr2 = current_code->expr2;
385
386 insert_code_node(p, 1);
387
388 p = g95_get_code();
389 p->type = EXEC_ASSIGN;
390 p->expr = current_code->expr;
391 p->expr2 = get_variable_expr(temp_var);
392 p->expr->rank = 0;
393
394 /* Find the section specification. */
395
396 reference = current_code->expr->ref;
397 while(reference->type != REF_ARRAY && reference->u.ar.type != AR_SECTION)
398 reference = reference->next;
399
400 loops = NULL;
401
402 switch(reference->u.ar.type) {
403 case AR_SECTION:
404 rank = reference->u.ar.dimen;
405
406 for(v=0; v<rank; v++)
407 switch(reference->u.ar.dimen_type[v]) {
408 case DIMEN_ELEMENT:
409 break; /* Do nothing */
410
411 case DIMEN_RANGE:
412 s = transform_range(&reference->u.ar, v);
413 s->block = (loops == NULL) ? p : loops;
414 loops = s;
415 break;
416
417 case DIMEN_VECTOR:
418 g95_internal_error("Can't do array subscripts yet");
419
420 default:
421 g95_internal_error("scalarize_scalar_assignment(): Bad dimension");
422 }
423
424 break;
425
426 case AR_FULL:
427 reference->u.ar.dimen = rank;
428
429 for(v=0; v<rank; v++) {
430 s = transform_range(&reference->u.ar, v);
431 s->block = (loops == NULL) ? p : loops;
432 loops = s;
433 }
434
435 break;
436
437 default:
438 g95_internal_error("scalarize_scalar_assignment(): Bad ref");
439 }
440
441 reference->u.ar.type = AR_ELEMENT;
442
443 /* Now graft the top loop where the original expression is */
444
445 loops->next = current_code->next;
446 *current_code = *loops;
447
448 g95_free(loops);
449 }
450
451
452
453
454 /* g95_scalarize()-- Scalarize a namepace, it's child and siblings
455 * namespaces */
456
457 void g95_scalarize(g95_namespace *ns) {
458 g95_namespace *save;
459
460 if (ns == NULL) return;
461
462 save = g95_current_ns;
463 g95_current_ns = ns;
464 traverse_code(ns->code);
465
466 for(ns=ns->contained; ns; ns=ns->sibling)
467 g95_scalarize(ns);
468
469 g95_current_ns = save;
470 }
471
472
473
474 /* scalarize_code()-- Scalarize a single code node. */
475
476 static void scalarize_code(g95_code *code) {
477 g95_alloc *y;
478
479 if (code == NULL) return;
480
481 current_code = code;
482
483 /* Vector expressions here are in assignment nodes and are taken
484 * care of elsewhere. */
485
486 if (code->expr != NULL && code->expr->rank == 0)
487 scalarize_scalar_expr(code->expr);
488
489 if (code->expr2 != NULL && code->expr2->rank == 0)
490 scalarize_scalar_expr(code->expr2);
491
492 switch(code->type) {
493 case EXEC_CALL:
494 scalarize_actual_arglist(code->ext.actual);
495 break;
496
497 case EXEC_DO:
498 scalarize_scalar_expr(code->ext.iterator->start);
499 scalarize_scalar_expr(code->ext.iterator->end);
500 scalarize_scalar_expr(code->ext.iterator->step);
501 break;
502
503 case EXEC_ASSIGN:
504 if (code->expr->rank == 0) { /* Scalar on the left */
505 if (code->expr2->rank)
506 g95_internal_error("scalarize_code(): scalar <- array assignment");
507
508 break; /* scalar <- scalar assignment */
509 }
510
511 /* Array expression on the left */
512
513 if (code->expr2->rank == 0)
514 scalarize_scalar_assignment();
515 else
516 scalarize_vector_assignment();
517
518 break;
519
520 case EXEC_IF:
521 traverse_code(code->block);
522 traverse_code(code->ext.block);
523 break;
524
525 case EXEC_DO_WHILE:
526 traverse_code(code->block);
527 break;
528
529 case EXEC_SELECT:
530 for(; code; code=code->block)
531 traverse_code(code->next);
532
533 break;
534
535 case EXEC_WHERE:
536 case EXEC_FORALL:
537 traverse_code(code->block);
538 break;
539
540 case EXEC_ALLOCATE:
541 case EXEC_DEALLOCATE:
542 for(y=code->ext.alloc_list; y; y=y->next)
543 scalarize_scalar_expr(y->expr);
544
545 break;
546
547 case EXEC_OPEN:
548 scalarize_scalar_expr(code->ext.open->unit);
549 scalarize_scalar_expr(code->ext.open->file);
550 scalarize_scalar_expr(code->ext.open->status);
551 scalarize_scalar_expr(code->ext.open->access);
552 scalarize_scalar_expr(code->ext.open->form);
553 scalarize_scalar_expr(code->ext.open->recl);
554 scalarize_scalar_expr(code->ext.open->blank);
555 scalarize_scalar_expr(code->ext.open->position);
556 scalarize_scalar_expr(code->ext.open->action);
557 scalarize_scalar_expr(code->ext.open->delim);
558 scalarize_scalar_expr(code->ext.open->pad);
559 scalarize_scalar_expr(code->ext.open->iostat);
560 break;
561
562 case EXEC_CLOSE:
563 scalarize_scalar_expr(code->ext.close->unit);
564 scalarize_scalar_expr(code->ext.close->status);
565 scalarize_scalar_expr(code->ext.close->iostat);
566 break;
567
568 case EXEC_BACKSPACE:
569 case EXEC_ENDFILE:
570 case EXEC_REWIND:
571 scalarize_scalar_expr(code->ext.filepos->unit);
572 scalarize_scalar_expr(code->ext.filepos->iostat);
573 break;
574
575 case EXEC_READ:
576 case EXEC_WRITE:
577 scalarize_scalar_expr(code->ext.dt->io_unit);
578 scalarize_scalar_expr(code->ext.dt->format_expr);
579 scalarize_scalar_expr(code->ext.dt->rec);
580 scalarize_scalar_expr(code->ext.dt->advance);
581 scalarize_scalar_expr(code->ext.dt->iostat);
582 scalarize_scalar_expr(code->ext.dt->size);
583 break;
584
585 case EXEC_INQUIRE:
586 scalarize_scalar_expr(code->ext.inquire->unit);
587 scalarize_scalar_expr(code->ext.inquire->file);
588 scalarize_scalar_expr(code->ext.inquire->iostat);
589 scalarize_scalar_expr(code->ext.inquire->exist);
590 scalarize_scalar_expr(code->ext.inquire->opened);
591 scalarize_scalar_expr(code->ext.inquire->number);
592 scalarize_scalar_expr(code->ext.inquire->named);
593 scalarize_scalar_expr(code->ext.inquire->name);
594 scalarize_scalar_expr(code->ext.inquire->access);
595 scalarize_scalar_expr(code->ext.inquire->sequential);
596 scalarize_scalar_expr(code->ext.inquire->direct);
597 scalarize_scalar_expr(code->ext.inquire->form);
598 scalarize_scalar_expr(code->ext.inquire->formatted);
599 scalarize_scalar_expr(code->ext.inquire->unformatted);
600 scalarize_scalar_expr(code->ext.inquire->recl);
601 scalarize_scalar_expr(code->ext.inquire->nextrec);
602 scalarize_scalar_expr(code->ext.inquire->blank);
603 scalarize_scalar_expr(code->ext.inquire->position);
604 scalarize_scalar_expr(code->ext.inquire->action);
605 scalarize_scalar_expr(code->ext.inquire->read);
606 scalarize_scalar_expr(code->ext.inquire->write);
607 scalarize_scalar_expr(code->ext.inquire->readwrite);
608 scalarize_scalar_expr(code->ext.inquire->delim);
609 scalarize_scalar_expr(code->ext.inquire->pad);
610 scalarize_scalar_expr(code->ext.inquire->iolength);
611 break;
612
613 default:
614 break;
615 }
616 }
617
618
619
620
621 /* traverse_code()-- Traverse the code tree, scalarizing as we go.
622 * The 'next' member can change if scalarize_code() generates new
623 * nodes. */
624
625 static void traverse_code(g95_code *code) {
626 g95_code *next;
627
628 while(code != NULL) {
629 scalarize_code(code->block);
630
631 next = code->next;
632 scalarize_code(code);
633
634 code = next;
635 }
636 }
637
638
639
640
641 #else
642 void g95_scalarize(g95_namespace *ns) {}
643
644 #endif
Something went wrong with that request. Please try again.