1 /* Array translation routines
2 Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4 and Steven Bosscher <s.bosscher@student.tudelft.nl>
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 2, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING. If not, write to the Free
20 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
23 /* trans-array.c-- Various array related code, including scalarization,
24 allocation, initialization and other support routines. */
26 /* How the scalarizer works.
27 In gfortran, array expressions use the same core routines as scalar
29 First, a Scalarization State (SS) chain is built. This is done by walking
30 the expression tree, and building a linear list of the terms in the
31 expression. As the tree is walked, scalar subexpressions are translated.
33 The scalarization parameters are stored in a gfc_loopinfo structure.
34 First the start and stride of each term is calculated by
35 gfc_conv_ss_startstride. During this process the expressions for the array
36 descriptors and data pointers are also translated.
38 If the expression is an assignment, we must then resolve any dependencies.
39 In fortran all the rhs values of an assignment must be evaluated before
40 any assignments take place. This can require a temporary array to store the
41 values. We also require a temporary when we are passing array expressions
42 or vector subecripts as procedure parameters.
44 Array sections are passed without copying to a temporary. These use the
45 scalarizer to determine the shape of the section. The flag
46 loop->array_parameter tells the scalarizer that the actual values and loop
47 variables will not be required.
49 The function gfc_conv_loop_setup generates the scalarization setup code.
50 It determines the range of the scalarizing loop variables. If a temporary
51 is required, this is created and initialized. Code for scalar expressions
52 taken outside the loop is also generated at this time. Next the offset and
53 scaling required to translate from loop variables to array indices for each
56 A call to gfc_start_scalarized_body marks the start of the scalarized
57 expression. This creates a scope and declares the loop variables. Before
58 calling this gfc_make_ss_chain_used must be used to indicate which terms
59 will be used inside this loop.
61 The scalar gfc_conv_* functions are then used to build the main body of the
62 scalarization loop. Scalarization loop variables and precalculated scalar
63 values are automatically substituted. Note that gfc_advance_se_ss_chain
64 must be used, rather than changing the se->ss directly.
66 For assignment expressions requiring a temporary two sub loops are
67 generated. The first stores the result of the expression in the temporary,
68 the second copies it to the result. A call to
69 gfc_trans_scalarized_loop_boundary marks the end of the main loop code and
70 the start of the copying loop. The temporary may be less than full rank.
72 Finally gfc_trans_scalarizing_loops is called to generate the implicit do
73 loops. The loops are added to the pre chain of the loopinfo. The post
74 chain may still contain cleanup code.
76 After the loop code has been added into its parent scope gfc_cleanup_loop
77 is called to free all the SS allocated by the scalarizer. */
81 #include "coretypes.h"
83 #include "tree-gimple.h"
90 #include "trans-stmt.h"
91 #include "trans-types.h"
92 #include "trans-array.h"
93 #include "trans-const.h"
94 #include "dependency.h"
96 static gfc_ss
*gfc_walk_subexpr (gfc_ss
*, gfc_expr
*);
97 static bool gfc_get_array_constructor_size (mpz_t
*, gfc_constructor
*);
99 /* The contents of this structure aren't actually used, just the address. */
100 static gfc_ss gfc_ss_terminator_var
;
101 gfc_ss
* const gfc_ss_terminator
= &gfc_ss_terminator_var
;
105 gfc_array_dataptr_type (tree desc
)
107 return (GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc
)));
111 /* Build expressions to access the members of an array descriptor.
112 It's surprisingly easy to mess up here, so never access
113 an array descriptor by "brute force", always use these
114 functions. This also avoids problems if we change the format
115 of an array descriptor.
117 To understand these magic numbers, look at the comments
118 before gfc_build_array_type() in trans-types.c.
120 The code within these defines should be the only code which knows the format
121 of an array descriptor.
123 Any code just needing to read obtain the bounds of an array should use
124 gfc_conv_array_* rather than the following functions as these will return
125 know constant values, and work with arrays which do not have descriptors.
127 Don't forget to #undef these! */
130 #define OFFSET_FIELD 1
131 #define DTYPE_FIELD 2
132 #define DIMENSION_FIELD 3
134 #define STRIDE_SUBFIELD 0
135 #define LBOUND_SUBFIELD 1
136 #define UBOUND_SUBFIELD 2
138 /* This provides READ-ONLY access to the data field. The field itself
139 doesn't have the proper type. */
142 gfc_conv_descriptor_data_get (tree desc
)
146 type
= TREE_TYPE (desc
);
147 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
149 field
= TYPE_FIELDS (type
);
150 gcc_assert (DATA_FIELD
== 0);
152 t
= build3 (COMPONENT_REF
, TREE_TYPE (field
), desc
, field
, NULL_TREE
);
153 t
= fold_convert (GFC_TYPE_ARRAY_DATAPTR_TYPE (type
), t
);
158 /* This provides WRITE access to the data field. */
161 gfc_conv_descriptor_data_set (stmtblock_t
*block
, tree desc
, tree value
)
165 type
= TREE_TYPE (desc
);
166 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
168 field
= TYPE_FIELDS (type
);
169 gcc_assert (DATA_FIELD
== 0);
171 t
= build3 (COMPONENT_REF
, TREE_TYPE (field
), desc
, field
, NULL_TREE
);
172 gfc_add_modify_expr (block
, t
, fold_convert (TREE_TYPE (field
), value
));
176 /* This provides address access to the data field. This should only be
177 used by array allocation, passing this on to the runtime. */
180 gfc_conv_descriptor_data_addr (tree desc
)
184 type
= TREE_TYPE (desc
);
185 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
187 field
= TYPE_FIELDS (type
);
188 gcc_assert (DATA_FIELD
== 0);
190 t
= build3 (COMPONENT_REF
, TREE_TYPE (field
), desc
, field
, NULL_TREE
);
191 return gfc_build_addr_expr (NULL
, t
);
195 gfc_conv_descriptor_offset (tree desc
)
200 type
= TREE_TYPE (desc
);
201 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
203 field
= gfc_advance_chain (TYPE_FIELDS (type
), OFFSET_FIELD
);
204 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
206 return build3 (COMPONENT_REF
, TREE_TYPE (field
), desc
, field
, NULL_TREE
);
210 gfc_conv_descriptor_dtype (tree desc
)
215 type
= TREE_TYPE (desc
);
216 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
218 field
= gfc_advance_chain (TYPE_FIELDS (type
), DTYPE_FIELD
);
219 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
221 return build3 (COMPONENT_REF
, TREE_TYPE (field
), desc
, field
, NULL_TREE
);
225 gfc_conv_descriptor_dimension (tree desc
, tree dim
)
231 type
= TREE_TYPE (desc
);
232 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
234 field
= gfc_advance_chain (TYPE_FIELDS (type
), DIMENSION_FIELD
);
235 gcc_assert (field
!= NULL_TREE
236 && TREE_CODE (TREE_TYPE (field
)) == ARRAY_TYPE
237 && TREE_CODE (TREE_TYPE (TREE_TYPE (field
))) == RECORD_TYPE
);
239 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (field
), desc
, field
, NULL_TREE
);
240 tmp
= gfc_build_array_ref (tmp
, dim
);
245 gfc_conv_descriptor_stride (tree desc
, tree dim
)
250 tmp
= gfc_conv_descriptor_dimension (desc
, dim
);
251 field
= TYPE_FIELDS (TREE_TYPE (tmp
));
252 field
= gfc_advance_chain (field
, STRIDE_SUBFIELD
);
253 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
255 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (field
), tmp
, field
, NULL_TREE
);
260 gfc_conv_descriptor_lbound (tree desc
, tree dim
)
265 tmp
= gfc_conv_descriptor_dimension (desc
, dim
);
266 field
= TYPE_FIELDS (TREE_TYPE (tmp
));
267 field
= gfc_advance_chain (field
, LBOUND_SUBFIELD
);
268 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
270 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (field
), tmp
, field
, NULL_TREE
);
275 gfc_conv_descriptor_ubound (tree desc
, tree dim
)
280 tmp
= gfc_conv_descriptor_dimension (desc
, dim
);
281 field
= TYPE_FIELDS (TREE_TYPE (tmp
));
282 field
= gfc_advance_chain (field
, UBOUND_SUBFIELD
);
283 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
285 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (field
), tmp
, field
, NULL_TREE
);
290 /* Build a null array descriptor constructor. */
293 gfc_build_null_descriptor (tree type
)
298 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
299 gcc_assert (DATA_FIELD
== 0);
300 field
= TYPE_FIELDS (type
);
302 /* Set a NULL data pointer. */
303 tmp
= build_constructor_single (type
, field
, null_pointer_node
);
304 TREE_CONSTANT (tmp
) = 1;
305 TREE_INVARIANT (tmp
) = 1;
306 /* All other fields are ignored. */
312 /* Cleanup those #defines. */
317 #undef DIMENSION_FIELD
318 #undef STRIDE_SUBFIELD
319 #undef LBOUND_SUBFIELD
320 #undef UBOUND_SUBFIELD
323 /* Mark a SS chain as used. Flags specifies in which loops the SS is used.
324 flags & 1 = Main loop body.
325 flags & 2 = temp copy loop. */
328 gfc_mark_ss_chain_used (gfc_ss
* ss
, unsigned flags
)
330 for (; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
331 ss
->useflags
= flags
;
334 static void gfc_free_ss (gfc_ss
*);
337 /* Free a gfc_ss chain. */
340 gfc_free_ss_chain (gfc_ss
* ss
)
344 while (ss
!= gfc_ss_terminator
)
346 gcc_assert (ss
!= NULL
);
357 gfc_free_ss (gfc_ss
* ss
)
364 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
366 if (ss
->data
.info
.subscript
[n
])
367 gfc_free_ss_chain (ss
->data
.info
.subscript
[n
]);
379 /* Free all the SS associated with a loop. */
382 gfc_cleanup_loop (gfc_loopinfo
* loop
)
388 while (ss
!= gfc_ss_terminator
)
390 gcc_assert (ss
!= NULL
);
391 next
= ss
->loop_chain
;
398 /* Associate a SS chain with a loop. */
401 gfc_add_ss_to_loop (gfc_loopinfo
* loop
, gfc_ss
* head
)
405 if (head
== gfc_ss_terminator
)
409 for (; ss
&& ss
!= gfc_ss_terminator
; ss
= ss
->next
)
411 if (ss
->next
== gfc_ss_terminator
)
412 ss
->loop_chain
= loop
->ss
;
414 ss
->loop_chain
= ss
->next
;
416 gcc_assert (ss
== gfc_ss_terminator
);
421 /* Generate an initializer for a static pointer or allocatable array. */
424 gfc_trans_static_array_pointer (gfc_symbol
* sym
)
428 gcc_assert (TREE_STATIC (sym
->backend_decl
));
429 /* Just zero the data member. */
430 type
= TREE_TYPE (sym
->backend_decl
);
431 DECL_INITIAL (sym
->backend_decl
) = gfc_build_null_descriptor (type
);
435 /* If the bounds of SE's loop have not yet been set, see if they can be
436 determined from array spec AS, which is the array spec of a called
437 function. MAPPING maps the callee's dummy arguments to the values
438 that the caller is passing. Add any initialization and finalization
442 gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping
* mapping
,
443 gfc_se
* se
, gfc_array_spec
* as
)
451 if (as
&& as
->type
== AS_EXPLICIT
)
452 for (dim
= 0; dim
< se
->loop
->dimen
; dim
++)
454 n
= se
->loop
->order
[dim
];
455 if (se
->loop
->to
[n
] == NULL_TREE
)
457 /* Evaluate the lower bound. */
458 gfc_init_se (&tmpse
, NULL
);
459 gfc_apply_interface_mapping (mapping
, &tmpse
, as
->lower
[dim
]);
460 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
461 gfc_add_block_to_block (&se
->post
, &tmpse
.post
);
464 /* ...and the upper bound. */
465 gfc_init_se (&tmpse
, NULL
);
466 gfc_apply_interface_mapping (mapping
, &tmpse
, as
->upper
[dim
]);
467 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
468 gfc_add_block_to_block (&se
->post
, &tmpse
.post
);
471 /* Set the upper bound of the loop to UPPER - LOWER. */
472 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, upper
, lower
);
473 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
474 se
->loop
->to
[n
] = tmp
;
480 /* Generate code to allocate an array temporary, or create a variable to
481 hold the data. If size is NULL zero the descriptor so that so that the
482 callee will allocate the array. Also generates code to free the array
485 Initialization code is added to PRE and finalization code to POST.
486 DYNAMIC is true if the caller may want to extend the array later
487 using realloc. This prevents us from putting the array on the stack. */
490 gfc_trans_allocate_array_storage (stmtblock_t
* pre
, stmtblock_t
* post
,
491 gfc_ss_info
* info
, tree size
, tree nelem
,
499 desc
= info
->descriptor
;
500 info
->offset
= gfc_index_zero_node
;
501 if (size
== NULL_TREE
|| integer_zerop (size
))
503 /* A callee allocated array. */
504 gfc_conv_descriptor_data_set (pre
, desc
, null_pointer_node
);
509 /* Allocate the temporary. */
510 onstack
= !dynamic
&& gfc_can_put_var_on_stack (size
);
514 /* Make a temporary variable to hold the data. */
515 tmp
= fold_build2 (MINUS_EXPR
, TREE_TYPE (nelem
), nelem
,
517 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
,
519 tmp
= build_array_type (gfc_get_element_type (TREE_TYPE (desc
)),
521 tmp
= gfc_create_var (tmp
, "A");
522 tmp
= gfc_build_addr_expr (NULL
, tmp
);
523 gfc_conv_descriptor_data_set (pre
, desc
, tmp
);
527 /* Allocate memory to hold the data. */
528 args
= gfc_chainon_list (NULL_TREE
, size
);
530 if (gfc_index_integer_kind
== 4)
531 tmp
= gfor_fndecl_internal_malloc
;
532 else if (gfc_index_integer_kind
== 8)
533 tmp
= gfor_fndecl_internal_malloc64
;
536 tmp
= gfc_build_function_call (tmp
, args
);
537 tmp
= gfc_evaluate_now (tmp
, pre
);
538 gfc_conv_descriptor_data_set (pre
, desc
, tmp
);
541 info
->data
= gfc_conv_descriptor_data_get (desc
);
543 /* The offset is zero because we create temporaries with a zero
545 tmp
= gfc_conv_descriptor_offset (desc
);
546 gfc_add_modify_expr (pre
, tmp
, gfc_index_zero_node
);
550 /* Free the temporary. */
551 tmp
= gfc_conv_descriptor_data_get (desc
);
552 tmp
= fold_convert (pvoid_type_node
, tmp
);
553 tmp
= gfc_chainon_list (NULL_TREE
, tmp
);
554 tmp
= gfc_build_function_call (gfor_fndecl_internal_free
, tmp
);
555 gfc_add_expr_to_block (post
, tmp
);
560 /* Generate code to allocate and initialize the descriptor for a temporary
561 array. This is used for both temporaries needed by the scalarizer, and
562 functions returning arrays. Adjusts the loop variables to be zero-based,
563 and calculates the loop bounds for callee allocated arrays.
564 Also fills in the descriptor, data and offset fields of info if known.
565 Returns the size of the array, or NULL for a callee allocated array.
567 PRE, POST and DYNAMIC are as for gfc_trans_allocate_array_storage. */
570 gfc_trans_allocate_temp_array (stmtblock_t
* pre
, stmtblock_t
* post
,
571 gfc_loopinfo
* loop
, gfc_ss_info
* info
,
572 tree eltype
, bool dynamic
)
582 gcc_assert (info
->dimen
> 0);
583 /* Set the lower bound to zero. */
584 for (dim
= 0; dim
< info
->dimen
; dim
++)
586 n
= loop
->order
[dim
];
587 if (n
< loop
->temp_dim
)
588 gcc_assert (integer_zerop (loop
->from
[n
]));
591 /* Callee allocated arrays may not have a known bound yet. */
593 loop
->to
[n
] = fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
594 loop
->to
[n
], loop
->from
[n
]);
595 loop
->from
[n
] = gfc_index_zero_node
;
598 info
->delta
[dim
] = gfc_index_zero_node
;
599 info
->start
[dim
] = gfc_index_zero_node
;
600 info
->stride
[dim
] = gfc_index_one_node
;
601 info
->dim
[dim
] = dim
;
604 /* Initialize the descriptor. */
606 gfc_get_array_type_bounds (eltype
, info
->dimen
, loop
->from
, loop
->to
, 1);
607 desc
= gfc_create_var (type
, "atmp");
608 GFC_DECL_PACKED_ARRAY (desc
) = 1;
610 info
->descriptor
= desc
;
611 size
= gfc_index_one_node
;
613 /* Fill in the array dtype. */
614 tmp
= gfc_conv_descriptor_dtype (desc
);
615 gfc_add_modify_expr (pre
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
618 Fill in the bounds and stride. This is a packed array, so:
621 for (n = 0; n < rank; n++)
624 delta = ubound[n] + 1 - lbound[n];
627 size = size * sizeof(element);
630 for (n
= 0; n
< info
->dimen
; n
++)
632 if (loop
->to
[n
] == NULL_TREE
)
634 /* For a callee allocated array express the loop bounds in terms
635 of the descriptor fields. */
636 tmp
= build2 (MINUS_EXPR
, gfc_array_index_type
,
637 gfc_conv_descriptor_ubound (desc
, gfc_rank_cst
[n
]),
638 gfc_conv_descriptor_lbound (desc
, gfc_rank_cst
[n
]));
644 /* Store the stride and bound components in the descriptor. */
645 tmp
= gfc_conv_descriptor_stride (desc
, gfc_rank_cst
[n
]);
646 gfc_add_modify_expr (pre
, tmp
, size
);
648 tmp
= gfc_conv_descriptor_lbound (desc
, gfc_rank_cst
[n
]);
649 gfc_add_modify_expr (pre
, tmp
, gfc_index_zero_node
);
651 tmp
= gfc_conv_descriptor_ubound (desc
, gfc_rank_cst
[n
]);
652 gfc_add_modify_expr (pre
, tmp
, loop
->to
[n
]);
654 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
655 loop
->to
[n
], gfc_index_one_node
);
657 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
, tmp
);
658 size
= gfc_evaluate_now (size
, pre
);
661 /* Get the size of the array. */
664 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
,
665 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
667 gfc_trans_allocate_array_storage (pre
, post
, info
, size
, nelem
, dynamic
);
669 if (info
->dimen
> loop
->temp_dim
)
670 loop
->temp_dim
= info
->dimen
;
676 /* Return the number of iterations in a loop that starts at START,
677 ends at END, and has step STEP. */
680 gfc_get_iteration_count (tree start
, tree end
, tree step
)
685 type
= TREE_TYPE (step
);
686 tmp
= fold_build2 (MINUS_EXPR
, type
, end
, start
);
687 tmp
= fold_build2 (FLOOR_DIV_EXPR
, type
, tmp
, step
);
688 tmp
= fold_build2 (PLUS_EXPR
, type
, tmp
, build_int_cst (type
, 1));
689 tmp
= fold_build2 (MAX_EXPR
, type
, tmp
, build_int_cst (type
, 0));
690 return fold_convert (gfc_array_index_type
, tmp
);
694 /* Extend the data in array DESC by EXTRA elements. */
697 gfc_grow_array (stmtblock_t
* pblock
, tree desc
, tree extra
)
704 if (integer_zerop (extra
))
707 ubound
= gfc_conv_descriptor_ubound (desc
, gfc_rank_cst
[0]);
709 /* Add EXTRA to the upper bound. */
710 tmp
= build2 (PLUS_EXPR
, gfc_array_index_type
, ubound
, extra
);
711 gfc_add_modify_expr (pblock
, ubound
, tmp
);
713 /* Get the value of the current data pointer. */
714 tmp
= gfc_conv_descriptor_data_get (desc
);
715 args
= gfc_chainon_list (NULL_TREE
, tmp
);
717 /* Calculate the new array size. */
718 size
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc
)));
719 tmp
= build2 (PLUS_EXPR
, gfc_array_index_type
, ubound
, gfc_index_one_node
);
720 tmp
= build2 (MULT_EXPR
, gfc_array_index_type
, tmp
, size
);
721 args
= gfc_chainon_list (args
, tmp
);
723 /* Pick the appropriate realloc function. */
724 if (gfc_index_integer_kind
== 4)
725 tmp
= gfor_fndecl_internal_realloc
;
726 else if (gfc_index_integer_kind
== 8)
727 tmp
= gfor_fndecl_internal_realloc64
;
731 /* Set the new data pointer. */
732 tmp
= gfc_build_function_call (tmp
, args
);
733 gfc_conv_descriptor_data_set (pblock
, desc
, tmp
);
737 /* Return true if the bounds of iterator I can only be determined
741 gfc_iterator_has_dynamic_bounds (gfc_iterator
* i
)
743 return (i
->start
->expr_type
!= EXPR_CONSTANT
744 || i
->end
->expr_type
!= EXPR_CONSTANT
745 || i
->step
->expr_type
!= EXPR_CONSTANT
);
749 /* Split the size of constructor element EXPR into the sum of two terms,
750 one of which can be determined at compile time and one of which must
751 be calculated at run time. Set *SIZE to the former and return true
752 if the latter might be nonzero. */
755 gfc_get_array_constructor_element_size (mpz_t
* size
, gfc_expr
* expr
)
757 if (expr
->expr_type
== EXPR_ARRAY
)
758 return gfc_get_array_constructor_size (size
, expr
->value
.constructor
);
759 else if (expr
->rank
> 0)
761 /* Calculate everything at run time. */
762 mpz_set_ui (*size
, 0);
767 /* A single element. */
768 mpz_set_ui (*size
, 1);
774 /* Like gfc_get_array_constructor_element_size, but applied to the whole
775 of array constructor C. */
778 gfc_get_array_constructor_size (mpz_t
* size
, gfc_constructor
* c
)
785 mpz_set_ui (*size
, 0);
790 for (; c
; c
= c
->next
)
793 if (i
&& gfc_iterator_has_dynamic_bounds (i
))
797 dynamic
|= gfc_get_array_constructor_element_size (&len
, c
->expr
);
800 /* Multiply the static part of the element size by the
801 number of iterations. */
802 mpz_sub (val
, i
->end
->value
.integer
, i
->start
->value
.integer
);
803 mpz_fdiv_q (val
, val
, i
->step
->value
.integer
);
804 mpz_add_ui (val
, val
, 1);
805 if (mpz_sgn (val
) > 0)
806 mpz_mul (len
, len
, val
);
810 mpz_add (*size
, *size
, len
);
819 /* Make sure offset is a variable. */
822 gfc_put_offset_into_var (stmtblock_t
* pblock
, tree
* poffset
,
825 /* We should have already created the offset variable. We cannot
826 create it here because we may be in an inner scope. */
827 gcc_assert (*offsetvar
!= NULL_TREE
);
828 gfc_add_modify_expr (pblock
, *offsetvar
, *poffset
);
829 *poffset
= *offsetvar
;
830 TREE_USED (*offsetvar
) = 1;
834 /* Assign an element of an array constructor. */
837 gfc_trans_array_ctor_element (stmtblock_t
* pblock
, tree desc
,
838 tree offset
, gfc_se
* se
, gfc_expr
* expr
)
843 gfc_conv_expr (se
, expr
);
845 /* Store the value. */
846 tmp
= gfc_build_indirect_ref (gfc_conv_descriptor_data_get (desc
));
847 tmp
= gfc_build_array_ref (tmp
, offset
);
848 if (expr
->ts
.type
== BT_CHARACTER
)
850 gfc_conv_string_parameter (se
);
851 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
853 /* The temporary is an array of pointers. */
854 se
->expr
= fold_convert (TREE_TYPE (tmp
), se
->expr
);
855 gfc_add_modify_expr (&se
->pre
, tmp
, se
->expr
);
859 /* The temporary is an array of string values. */
860 tmp
= gfc_build_addr_expr (pchar_type_node
, tmp
);
861 /* We know the temporary and the value will be the same length,
862 so can use memcpy. */
863 args
= gfc_chainon_list (NULL_TREE
, tmp
);
864 args
= gfc_chainon_list (args
, se
->expr
);
865 args
= gfc_chainon_list (args
, se
->string_length
);
866 tmp
= built_in_decls
[BUILT_IN_MEMCPY
];
867 tmp
= gfc_build_function_call (tmp
, args
);
868 gfc_add_expr_to_block (&se
->pre
, tmp
);
873 /* TODO: Should the frontend already have done this conversion? */
874 se
->expr
= fold_convert (TREE_TYPE (tmp
), se
->expr
);
875 gfc_add_modify_expr (&se
->pre
, tmp
, se
->expr
);
878 gfc_add_block_to_block (pblock
, &se
->pre
);
879 gfc_add_block_to_block (pblock
, &se
->post
);
883 /* Add the contents of an array to the constructor. DYNAMIC is as for
884 gfc_trans_array_constructor_value. */
887 gfc_trans_array_constructor_subarray (stmtblock_t
* pblock
,
888 tree type ATTRIBUTE_UNUSED
,
889 tree desc
, gfc_expr
* expr
,
890 tree
* poffset
, tree
* offsetvar
,
901 /* We need this to be a variable so we can increment it. */
902 gfc_put_offset_into_var (pblock
, poffset
, offsetvar
);
904 gfc_init_se (&se
, NULL
);
906 /* Walk the array expression. */
907 ss
= gfc_walk_expr (expr
);
908 gcc_assert (ss
!= gfc_ss_terminator
);
910 /* Initialize the scalarizer. */
911 gfc_init_loopinfo (&loop
);
912 gfc_add_ss_to_loop (&loop
, ss
);
914 /* Initialize the loop. */
915 gfc_conv_ss_startstride (&loop
);
916 gfc_conv_loop_setup (&loop
);
918 /* Make sure the constructed array has room for the new data. */
921 /* Set SIZE to the total number of elements in the subarray. */
922 size
= gfc_index_one_node
;
923 for (n
= 0; n
< loop
.dimen
; n
++)
925 tmp
= gfc_get_iteration_count (loop
.from
[n
], loop
.to
[n
],
927 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
, tmp
);
930 /* Grow the constructed array by SIZE elements. */
931 gfc_grow_array (&loop
.pre
, desc
, size
);
934 /* Make the loop body. */
935 gfc_mark_ss_chain_used (ss
, 1);
936 gfc_start_scalarized_body (&loop
, &body
);
937 gfc_copy_loopinfo_to_se (&se
, &loop
);
940 if (expr
->ts
.type
== BT_CHARACTER
)
941 gfc_todo_error ("character arrays in constructors");
943 gfc_trans_array_ctor_element (&body
, desc
, *poffset
, &se
, expr
);
944 gcc_assert (se
.ss
== gfc_ss_terminator
);
946 /* Increment the offset. */
947 tmp
= build2 (PLUS_EXPR
, gfc_array_index_type
, *poffset
, gfc_index_one_node
);
948 gfc_add_modify_expr (&body
, *poffset
, tmp
);
950 /* Finish the loop. */
951 gfc_trans_scalarizing_loops (&loop
, &body
);
952 gfc_add_block_to_block (&loop
.pre
, &loop
.post
);
953 tmp
= gfc_finish_block (&loop
.pre
);
954 gfc_add_expr_to_block (pblock
, tmp
);
956 gfc_cleanup_loop (&loop
);
960 /* Assign the values to the elements of an array constructor. DYNAMIC
961 is true if descriptor DESC only contains enough data for the static
962 size calculated by gfc_get_array_constructor_size. When true, memory
963 for the dynamic parts must be allocated using realloc. */
966 gfc_trans_array_constructor_value (stmtblock_t
* pblock
, tree type
,
967 tree desc
, gfc_constructor
* c
,
968 tree
* poffset
, tree
* offsetvar
,
977 for (; c
; c
= c
->next
)
979 /* If this is an iterator or an array, the offset must be a variable. */
980 if ((c
->iterator
|| c
->expr
->rank
> 0) && INTEGER_CST_P (*poffset
))
981 gfc_put_offset_into_var (pblock
, poffset
, offsetvar
);
983 gfc_start_block (&body
);
985 if (c
->expr
->expr_type
== EXPR_ARRAY
)
987 /* Array constructors can be nested. */
988 gfc_trans_array_constructor_value (&body
, type
, desc
,
989 c
->expr
->value
.constructor
,
990 poffset
, offsetvar
, dynamic
);
992 else if (c
->expr
->rank
> 0)
994 gfc_trans_array_constructor_subarray (&body
, type
, desc
, c
->expr
,
995 poffset
, offsetvar
, dynamic
);
999 /* This code really upsets the gimplifier so don't bother for now. */
1006 while (p
&& !(p
->iterator
|| p
->expr
->expr_type
!= EXPR_CONSTANT
))
1013 /* Scalar values. */
1014 gfc_init_se (&se
, NULL
);
1015 gfc_trans_array_ctor_element (&body
, desc
, *poffset
,
1018 *poffset
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1019 *poffset
, gfc_index_one_node
);
1023 /* Collect multiple scalar constants into a constructor. */
1031 /* Count the number of consecutive scalar constants. */
1032 while (p
&& !(p
->iterator
1033 || p
->expr
->expr_type
!= EXPR_CONSTANT
))
1035 gfc_init_se (&se
, NULL
);
1036 gfc_conv_constant (&se
, p
->expr
);
1037 if (p
->expr
->ts
.type
== BT_CHARACTER
1038 && POINTER_TYPE_P (type
))
1040 /* For constant character array constructors we build
1041 an array of pointers. */
1042 se
.expr
= gfc_build_addr_expr (pchar_type_node
,
1046 list
= tree_cons (NULL_TREE
, se
.expr
, list
);
1051 bound
= build_int_cst (NULL_TREE
, n
- 1);
1052 /* Create an array type to hold them. */
1053 tmptype
= build_range_type (gfc_array_index_type
,
1054 gfc_index_zero_node
, bound
);
1055 tmptype
= build_array_type (type
, tmptype
);
1057 init
= build_constructor_from_list (tmptype
, nreverse (list
));
1058 TREE_CONSTANT (init
) = 1;
1059 TREE_INVARIANT (init
) = 1;
1060 TREE_STATIC (init
) = 1;
1061 /* Create a static variable to hold the data. */
1062 tmp
= gfc_create_var (tmptype
, "data");
1063 TREE_STATIC (tmp
) = 1;
1064 TREE_CONSTANT (tmp
) = 1;
1065 TREE_INVARIANT (tmp
) = 1;
1066 DECL_INITIAL (tmp
) = init
;
1069 /* Use BUILTIN_MEMCPY to assign the values. */
1070 tmp
= gfc_conv_descriptor_data_get (desc
);
1071 tmp
= gfc_build_indirect_ref (tmp
);
1072 tmp
= gfc_build_array_ref (tmp
, *poffset
);
1073 tmp
= gfc_build_addr_expr (NULL
, tmp
);
1074 init
= gfc_build_addr_expr (NULL
, init
);
1076 size
= TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type
));
1077 bound
= build_int_cst (NULL_TREE
, n
* size
);
1078 tmp
= gfc_chainon_list (NULL_TREE
, tmp
);
1079 tmp
= gfc_chainon_list (tmp
, init
);
1080 tmp
= gfc_chainon_list (tmp
, bound
);
1081 tmp
= gfc_build_function_call (built_in_decls
[BUILT_IN_MEMCPY
],
1083 gfc_add_expr_to_block (&body
, tmp
);
1085 *poffset
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1086 *poffset
, build_int_cst (NULL_TREE
, n
));
1088 if (!INTEGER_CST_P (*poffset
))
1090 gfc_add_modify_expr (&body
, *offsetvar
, *poffset
);
1091 *poffset
= *offsetvar
;
1095 /* The frontend should already have done any expansions possible
1099 /* Pass the code as is. */
1100 tmp
= gfc_finish_block (&body
);
1101 gfc_add_expr_to_block (pblock
, tmp
);
1105 /* Build the implied do-loop. */
1114 loopbody
= gfc_finish_block (&body
);
1116 gfc_init_se (&se
, NULL
);
1117 gfc_conv_expr (&se
, c
->iterator
->var
);
1118 gfc_add_block_to_block (pblock
, &se
.pre
);
1121 /* Initialize the loop. */
1122 gfc_init_se (&se
, NULL
);
1123 gfc_conv_expr_val (&se
, c
->iterator
->start
);
1124 gfc_add_block_to_block (pblock
, &se
.pre
);
1125 gfc_add_modify_expr (pblock
, loopvar
, se
.expr
);
1127 gfc_init_se (&se
, NULL
);
1128 gfc_conv_expr_val (&se
, c
->iterator
->end
);
1129 gfc_add_block_to_block (pblock
, &se
.pre
);
1130 end
= gfc_evaluate_now (se
.expr
, pblock
);
1132 gfc_init_se (&se
, NULL
);
1133 gfc_conv_expr_val (&se
, c
->iterator
->step
);
1134 gfc_add_block_to_block (pblock
, &se
.pre
);
1135 step
= gfc_evaluate_now (se
.expr
, pblock
);
1137 /* If this array expands dynamically, and the number of iterations
1138 is not constant, we won't have allocated space for the static
1139 part of C->EXPR's size. Do that now. */
1140 if (dynamic
&& gfc_iterator_has_dynamic_bounds (c
->iterator
))
1142 /* Get the number of iterations. */
1143 tmp
= gfc_get_iteration_count (loopvar
, end
, step
);
1145 /* Get the static part of C->EXPR's size. */
1146 gfc_get_array_constructor_element_size (&size
, c
->expr
);
1147 tmp2
= gfc_conv_mpz_to_tree (size
, gfc_index_integer_kind
);
1149 /* Grow the array by TMP * TMP2 elements. */
1150 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, tmp
, tmp2
);
1151 gfc_grow_array (pblock
, desc
, tmp
);
1154 /* Generate the loop body. */
1155 exit_label
= gfc_build_label_decl (NULL_TREE
);
1156 gfc_start_block (&body
);
1158 /* Generate the exit condition. Depending on the sign of
1159 the step variable we have to generate the correct
1161 tmp
= fold_build2 (GT_EXPR
, boolean_type_node
, step
,
1162 build_int_cst (TREE_TYPE (step
), 0));
1163 cond
= fold_build3 (COND_EXPR
, boolean_type_node
, tmp
,
1164 build2 (GT_EXPR
, boolean_type_node
,
1166 build2 (LT_EXPR
, boolean_type_node
,
1168 tmp
= build1_v (GOTO_EXPR
, exit_label
);
1169 TREE_USED (exit_label
) = 1;
1170 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt ());
1171 gfc_add_expr_to_block (&body
, tmp
);
1173 /* The main loop body. */
1174 gfc_add_expr_to_block (&body
, loopbody
);
1176 /* Increase loop variable by step. */
1177 tmp
= build2 (PLUS_EXPR
, TREE_TYPE (loopvar
), loopvar
, step
);
1178 gfc_add_modify_expr (&body
, loopvar
, tmp
);
1180 /* Finish the loop. */
1181 tmp
= gfc_finish_block (&body
);
1182 tmp
= build1_v (LOOP_EXPR
, tmp
);
1183 gfc_add_expr_to_block (pblock
, tmp
);
1185 /* Add the exit label. */
1186 tmp
= build1_v (LABEL_EXPR
, exit_label
);
1187 gfc_add_expr_to_block (pblock
, tmp
);
1194 /* Figure out the string length of a variable reference expression.
1195 Used by get_array_ctor_strlen. */
1198 get_array_ctor_var_strlen (gfc_expr
* expr
, tree
* len
)
1203 /* Don't bother if we already know the length is a constant. */
1204 if (*len
&& INTEGER_CST_P (*len
))
1207 ts
= &expr
->symtree
->n
.sym
->ts
;
1208 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1213 /* Array references don't change the string length. */
1217 /* Use the length of the component. */
1218 ts
= &ref
->u
.c
.component
->ts
;
1222 /* TODO: Substrings are tricky because we can't evaluate the
1223 expression more than once. For now we just give up, and hope
1224 we can figure it out elsewhere. */
1229 *len
= ts
->cl
->backend_decl
;
1233 /* Figure out the string length of a character array constructor.
1234 Returns TRUE if all elements are character constants. */
1237 get_array_ctor_strlen (gfc_constructor
* c
, tree
* len
)
1242 for (; c
; c
= c
->next
)
1244 switch (c
->expr
->expr_type
)
1247 if (!(*len
&& INTEGER_CST_P (*len
)))
1248 *len
= build_int_cstu (gfc_charlen_type_node
,
1249 c
->expr
->value
.character
.length
);
1253 if (!get_array_ctor_strlen (c
->expr
->value
.constructor
, len
))
1259 get_array_ctor_var_strlen (c
->expr
, len
);
1264 /* TODO: For now we just ignore anything we don't know how to
1265 handle, and hope we can figure it out a different way. */
1274 /* Array constructors are handled by constructing a temporary, then using that
1275 within the scalarization loop. This is not optimal, but seems by far the
1279 gfc_trans_array_constructor (gfc_loopinfo
* loop
, gfc_ss
* ss
)
1289 ss
->data
.info
.dimen
= loop
->dimen
;
1291 c
= ss
->expr
->value
.constructor
;
1292 if (ss
->expr
->ts
.type
== BT_CHARACTER
)
1294 const_string
= get_array_ctor_strlen (c
, &ss
->string_length
);
1295 if (!ss
->string_length
)
1296 gfc_todo_error ("complex character array constructors");
1298 type
= gfc_get_character_type_len (ss
->expr
->ts
.kind
, ss
->string_length
);
1300 type
= build_pointer_type (type
);
1304 const_string
= TRUE
;
1305 type
= gfc_typenode_for_spec (&ss
->expr
->ts
);
1308 /* See if the constructor determines the loop bounds. */
1310 if (loop
->to
[0] == NULL_TREE
)
1314 /* We should have a 1-dimensional, zero-based loop. */
1315 gcc_assert (loop
->dimen
== 1);
1316 gcc_assert (integer_zerop (loop
->from
[0]));
1318 /* Split the constructor size into a static part and a dynamic part.
1319 Allocate the static size up-front and record whether the dynamic
1320 size might be nonzero. */
1322 dynamic
= gfc_get_array_constructor_size (&size
, c
);
1323 mpz_sub_ui (size
, size
, 1);
1324 loop
->to
[0] = gfc_conv_mpz_to_tree (size
, gfc_index_integer_kind
);
1328 gfc_trans_allocate_temp_array (&loop
->pre
, &loop
->post
, loop
,
1329 &ss
->data
.info
, type
, dynamic
);
1331 desc
= ss
->data
.info
.descriptor
;
1332 offset
= gfc_index_zero_node
;
1333 offsetvar
= gfc_create_var_np (gfc_array_index_type
, "offset");
1334 TREE_USED (offsetvar
) = 0;
1335 gfc_trans_array_constructor_value (&loop
->pre
, type
, desc
, c
,
1336 &offset
, &offsetvar
, dynamic
);
1338 /* If the array grows dynamically, the upper bound of the loop variable
1339 is determined by the array's final upper bound. */
1341 loop
->to
[0] = gfc_conv_descriptor_ubound (desc
, gfc_rank_cst
[0]);
1343 if (TREE_USED (offsetvar
))
1344 pushdecl (offsetvar
);
1346 gcc_assert (INTEGER_CST_P (offset
));
1348 /* Disable bound checking for now because it's probably broken. */
1349 if (flag_bounds_check
)
1357 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
1358 called after evaluating all of INFO's vector dimensions. Go through
1359 each such vector dimension and see if we can now fill in any missing
1363 gfc_set_vector_loop_bounds (gfc_loopinfo
* loop
, gfc_ss_info
* info
)
1372 for (n
= 0; n
< loop
->dimen
; n
++)
1375 if (info
->ref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
1376 && loop
->to
[n
] == NULL
)
1378 /* Loop variable N indexes vector dimension DIM, and we don't
1379 yet know the upper bound of loop variable N. Set it to the
1380 difference between the vector's upper and lower bounds. */
1381 gcc_assert (loop
->from
[n
] == gfc_index_zero_node
);
1382 gcc_assert (info
->subscript
[dim
]
1383 && info
->subscript
[dim
]->type
== GFC_SS_VECTOR
);
1385 gfc_init_se (&se
, NULL
);
1386 desc
= info
->subscript
[dim
]->data
.info
.descriptor
;
1387 zero
= gfc_rank_cst
[0];
1388 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1389 gfc_conv_descriptor_ubound (desc
, zero
),
1390 gfc_conv_descriptor_lbound (desc
, zero
));
1391 tmp
= gfc_evaluate_now (tmp
, &loop
->pre
);
1398 /* Add the pre and post chains for all the scalar expressions in a SS chain
1399 to loop. This is called after the loop parameters have been calculated,
1400 but before the actual scalarizing loops. */
1403 gfc_add_loop_ss_code (gfc_loopinfo
* loop
, gfc_ss
* ss
, bool subscript
)
1408 /* TODO: This can generate bad code if there are ordering dependencies.
1409 eg. a callee allocated function and an unknown size constructor. */
1410 gcc_assert (ss
!= NULL
);
1412 for (; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
1419 /* Scalar expression. Evaluate this now. This includes elemental
1420 dimension indices, but not array section bounds. */
1421 gfc_init_se (&se
, NULL
);
1422 gfc_conv_expr (&se
, ss
->expr
);
1423 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
1425 if (ss
->expr
->ts
.type
!= BT_CHARACTER
)
1427 /* Move the evaluation of scalar expressions outside the
1428 scalarization loop. */
1430 se
.expr
= convert(gfc_array_index_type
, se
.expr
);
1431 se
.expr
= gfc_evaluate_now (se
.expr
, &loop
->pre
);
1432 gfc_add_block_to_block (&loop
->pre
, &se
.post
);
1435 gfc_add_block_to_block (&loop
->post
, &se
.post
);
1437 ss
->data
.scalar
.expr
= se
.expr
;
1438 ss
->string_length
= se
.string_length
;
1441 case GFC_SS_REFERENCE
:
1442 /* Scalar reference. Evaluate this now. */
1443 gfc_init_se (&se
, NULL
);
1444 gfc_conv_expr_reference (&se
, ss
->expr
);
1445 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
1446 gfc_add_block_to_block (&loop
->post
, &se
.post
);
1448 ss
->data
.scalar
.expr
= gfc_evaluate_now (se
.expr
, &loop
->pre
);
1449 ss
->string_length
= se
.string_length
;
1452 case GFC_SS_SECTION
:
1453 /* Add the expressions for scalar and vector subscripts. */
1454 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
1455 if (ss
->data
.info
.subscript
[n
])
1456 gfc_add_loop_ss_code (loop
, ss
->data
.info
.subscript
[n
], true);
1458 gfc_set_vector_loop_bounds (loop
, &ss
->data
.info
);
1462 /* Get the vector's descriptor and store it in SS. */
1463 gfc_init_se (&se
, NULL
);
1464 gfc_conv_expr_descriptor (&se
, ss
->expr
, gfc_walk_expr (ss
->expr
));
1465 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
1466 gfc_add_block_to_block (&loop
->post
, &se
.post
);
1467 ss
->data
.info
.descriptor
= se
.expr
;
1470 case GFC_SS_INTRINSIC
:
1471 gfc_add_intrinsic_ss_code (loop
, ss
);
1474 case GFC_SS_FUNCTION
:
1475 /* Array function return value. We call the function and save its
1476 result in a temporary for use inside the loop. */
1477 gfc_init_se (&se
, NULL
);
1480 gfc_conv_expr (&se
, ss
->expr
);
1481 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
1482 gfc_add_block_to_block (&loop
->post
, &se
.post
);
1483 ss
->string_length
= se
.string_length
;
1486 case GFC_SS_CONSTRUCTOR
:
1487 gfc_trans_array_constructor (loop
, ss
);
1491 case GFC_SS_COMPONENT
:
1492 /* Do nothing. These are handled elsewhere. */
1502 /* Translate expressions for the descriptor and data pointer of a SS. */
1506 gfc_conv_ss_descriptor (stmtblock_t
* block
, gfc_ss
* ss
, int base
)
1511 /* Get the descriptor for the array to be scalarized. */
1512 gcc_assert (ss
->expr
->expr_type
== EXPR_VARIABLE
);
1513 gfc_init_se (&se
, NULL
);
1514 se
.descriptor_only
= 1;
1515 gfc_conv_expr_lhs (&se
, ss
->expr
);
1516 gfc_add_block_to_block (block
, &se
.pre
);
1517 ss
->data
.info
.descriptor
= se
.expr
;
1518 ss
->string_length
= se
.string_length
;
1522 /* Also the data pointer. */
1523 tmp
= gfc_conv_array_data (se
.expr
);
1524 /* If this is a variable or address of a variable we use it directly.
1525 Otherwise we must evaluate it now to avoid breaking dependency
1526 analysis by pulling the expressions for elemental array indices
1529 || (TREE_CODE (tmp
) == ADDR_EXPR
1530 && DECL_P (TREE_OPERAND (tmp
, 0)))))
1531 tmp
= gfc_evaluate_now (tmp
, block
);
1532 ss
->data
.info
.data
= tmp
;
1534 tmp
= gfc_conv_array_offset (se
.expr
);
1535 ss
->data
.info
.offset
= gfc_evaluate_now (tmp
, block
);
1540 /* Initialize a gfc_loopinfo structure. */
1543 gfc_init_loopinfo (gfc_loopinfo
* loop
)
1547 memset (loop
, 0, sizeof (gfc_loopinfo
));
1548 gfc_init_block (&loop
->pre
);
1549 gfc_init_block (&loop
->post
);
1551 /* Initially scalarize in order. */
1552 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
1555 loop
->ss
= gfc_ss_terminator
;
1559 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
1563 gfc_copy_loopinfo_to_se (gfc_se
* se
, gfc_loopinfo
* loop
)
1569 /* Return an expression for the data pointer of an array. */
1572 gfc_conv_array_data (tree descriptor
)
1576 type
= TREE_TYPE (descriptor
);
1577 if (GFC_ARRAY_TYPE_P (type
))
1579 if (TREE_CODE (type
) == POINTER_TYPE
)
1583 /* Descriptorless arrays. */
1584 return gfc_build_addr_expr (NULL
, descriptor
);
1588 return gfc_conv_descriptor_data_get (descriptor
);
1592 /* Return an expression for the base offset of an array. */
1595 gfc_conv_array_offset (tree descriptor
)
1599 type
= TREE_TYPE (descriptor
);
1600 if (GFC_ARRAY_TYPE_P (type
))
1601 return GFC_TYPE_ARRAY_OFFSET (type
);
1603 return gfc_conv_descriptor_offset (descriptor
);
1607 /* Get an expression for the array stride. */
1610 gfc_conv_array_stride (tree descriptor
, int dim
)
1615 type
= TREE_TYPE (descriptor
);
1617 /* For descriptorless arrays use the array size. */
1618 tmp
= GFC_TYPE_ARRAY_STRIDE (type
, dim
);
1619 if (tmp
!= NULL_TREE
)
1622 tmp
= gfc_conv_descriptor_stride (descriptor
, gfc_rank_cst
[dim
]);
1627 /* Like gfc_conv_array_stride, but for the lower bound. */
1630 gfc_conv_array_lbound (tree descriptor
, int dim
)
1635 type
= TREE_TYPE (descriptor
);
1637 tmp
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
1638 if (tmp
!= NULL_TREE
)
1641 tmp
= gfc_conv_descriptor_lbound (descriptor
, gfc_rank_cst
[dim
]);
1646 /* Like gfc_conv_array_stride, but for the upper bound. */
1649 gfc_conv_array_ubound (tree descriptor
, int dim
)
1654 type
= TREE_TYPE (descriptor
);
1656 tmp
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
1657 if (tmp
!= NULL_TREE
)
1660 /* This should only ever happen when passing an assumed shape array
1661 as an actual parameter. The value will never be used. */
1662 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor
)))
1663 return gfc_index_zero_node
;
1665 tmp
= gfc_conv_descriptor_ubound (descriptor
, gfc_rank_cst
[dim
]);
1670 /* Generate code to perform an array index bound check. */
1673 gfc_trans_array_bound_check (gfc_se
* se
, tree descriptor
, tree index
, int n
)
1679 if (!flag_bounds_check
)
1682 index
= gfc_evaluate_now (index
, &se
->pre
);
1683 /* Check lower bound. */
1684 tmp
= gfc_conv_array_lbound (descriptor
, n
);
1685 fault
= fold_build2 (LT_EXPR
, boolean_type_node
, index
, tmp
);
1686 /* Check upper bound. */
1687 tmp
= gfc_conv_array_ubound (descriptor
, n
);
1688 cond
= fold_build2 (GT_EXPR
, boolean_type_node
, index
, tmp
);
1689 fault
= fold_build2 (TRUTH_OR_EXPR
, boolean_type_node
, fault
, cond
);
1691 gfc_trans_runtime_check (fault
, gfc_strconst_fault
, &se
->pre
);
1697 /* Return the offset for an index. Performs bound checking for elemental
1698 dimensions. Single element references are processed separately. */
1701 gfc_conv_array_index_offset (gfc_se
* se
, gfc_ss_info
* info
, int dim
, int i
,
1702 gfc_array_ref
* ar
, tree stride
)
1708 /* Get the index into the array for this dimension. */
1711 gcc_assert (ar
->type
!= AR_ELEMENT
);
1712 switch (ar
->dimen_type
[dim
])
1715 gcc_assert (i
== -1);
1716 /* Elemental dimension. */
1717 gcc_assert (info
->subscript
[dim
]
1718 && info
->subscript
[dim
]->type
== GFC_SS_SCALAR
);
1719 /* We've already translated this value outside the loop. */
1720 index
= info
->subscript
[dim
]->data
.scalar
.expr
;
1723 gfc_trans_array_bound_check (se
, info
->descriptor
, index
, dim
);
1727 gcc_assert (info
&& se
->loop
);
1728 gcc_assert (info
->subscript
[dim
]
1729 && info
->subscript
[dim
]->type
== GFC_SS_VECTOR
);
1730 desc
= info
->subscript
[dim
]->data
.info
.descriptor
;
1732 /* Get a zero-based index into the vector. */
1733 index
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1734 se
->loop
->loopvar
[i
], se
->loop
->from
[i
]);
1736 /* Multiply the index by the stride. */
1737 index
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
1738 index
, gfc_conv_array_stride (desc
, 0));
1740 /* Read the vector to get an index into info->descriptor. */
1741 data
= gfc_build_indirect_ref (gfc_conv_array_data (desc
));
1742 index
= gfc_build_array_ref (data
, index
);
1743 index
= gfc_evaluate_now (index
, &se
->pre
);
1745 /* Do any bounds checking on the final info->descriptor index. */
1746 index
= gfc_trans_array_bound_check (se
, info
->descriptor
,
1751 /* Scalarized dimension. */
1752 gcc_assert (info
&& se
->loop
);
1754 /* Multiply the loop variable by the stride and delta. */
1755 index
= se
->loop
->loopvar
[i
];
1756 index
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, index
,
1758 index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, index
,
1768 /* Temporary array or derived type component. */
1769 gcc_assert (se
->loop
);
1770 index
= se
->loop
->loopvar
[se
->loop
->order
[i
]];
1771 if (!integer_zerop (info
->delta
[i
]))
1772 index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1773 index
, info
->delta
[i
]);
1776 /* Multiply by the stride. */
1777 index
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, index
, stride
);
1783 /* Build a scalarized reference to an array. */
1786 gfc_conv_scalarized_array_ref (gfc_se
* se
, gfc_array_ref
* ar
)
1793 info
= &se
->ss
->data
.info
;
1795 n
= se
->loop
->order
[0];
1799 index
= gfc_conv_array_index_offset (se
, info
, info
->dim
[n
], n
, ar
,
1801 /* Add the offset for this dimension to the stored offset for all other
1803 index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, index
, info
->offset
);
1805 tmp
= gfc_build_indirect_ref (info
->data
);
1806 se
->expr
= gfc_build_array_ref (tmp
, index
);
1810 /* Translate access of temporary array. */
1813 gfc_conv_tmp_array_ref (gfc_se
* se
)
1815 se
->string_length
= se
->ss
->string_length
;
1816 gfc_conv_scalarized_array_ref (se
, NULL
);
1820 /* Build an array reference. se->expr already holds the array descriptor.
1821 This should be either a variable, indirect variable reference or component
1822 reference. For arrays which do not have a descriptor, se->expr will be
1824 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
1827 gfc_conv_array_ref (gfc_se
* se
, gfc_array_ref
* ar
)
1836 /* Handle scalarized references separately. */
1837 if (ar
->type
!= AR_ELEMENT
)
1839 gfc_conv_scalarized_array_ref (se
, ar
);
1840 gfc_advance_se_ss_chain (se
);
1844 index
= gfc_index_zero_node
;
1846 fault
= gfc_index_zero_node
;
1848 /* Calculate the offsets from all the dimensions. */
1849 for (n
= 0; n
< ar
->dimen
; n
++)
1851 /* Calculate the index for this dimension. */
1852 gfc_init_se (&indexse
, se
);
1853 gfc_conv_expr_type (&indexse
, ar
->start
[n
], gfc_array_index_type
);
1854 gfc_add_block_to_block (&se
->pre
, &indexse
.pre
);
1856 if (flag_bounds_check
)
1858 /* Check array bounds. */
1861 indexse
.expr
= gfc_evaluate_now (indexse
.expr
, &se
->pre
);
1863 tmp
= gfc_conv_array_lbound (se
->expr
, n
);
1864 cond
= fold_build2 (LT_EXPR
, boolean_type_node
,
1867 fold_build2 (TRUTH_OR_EXPR
, boolean_type_node
, fault
, cond
);
1869 tmp
= gfc_conv_array_ubound (se
->expr
, n
);
1870 cond
= fold_build2 (GT_EXPR
, boolean_type_node
,
1873 fold_build2 (TRUTH_OR_EXPR
, boolean_type_node
, fault
, cond
);
1876 /* Multiply the index by the stride. */
1877 stride
= gfc_conv_array_stride (se
->expr
, n
);
1878 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, indexse
.expr
,
1881 /* And add it to the total. */
1882 index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, index
, tmp
);
1885 if (flag_bounds_check
)
1886 gfc_trans_runtime_check (fault
, gfc_strconst_fault
, &se
->pre
);
1888 tmp
= gfc_conv_array_offset (se
->expr
);
1889 if (!integer_zerop (tmp
))
1890 index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, index
, tmp
);
1892 /* Access the calculated element. */
1893 tmp
= gfc_conv_array_data (se
->expr
);
1894 tmp
= gfc_build_indirect_ref (tmp
);
1895 se
->expr
= gfc_build_array_ref (tmp
, index
);
1899 /* Generate the code to be executed immediately before entering a
1900 scalarization loop. */
1903 gfc_trans_preloop_setup (gfc_loopinfo
* loop
, int dim
, int flag
,
1904 stmtblock_t
* pblock
)
1913 /* This code will be executed before entering the scalarization loop
1914 for this dimension. */
1915 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
1917 if ((ss
->useflags
& flag
) == 0)
1920 if (ss
->type
!= GFC_SS_SECTION
1921 && ss
->type
!= GFC_SS_FUNCTION
&& ss
->type
!= GFC_SS_CONSTRUCTOR
1922 && ss
->type
!= GFC_SS_COMPONENT
)
1925 info
= &ss
->data
.info
;
1927 if (dim
>= info
->dimen
)
1930 if (dim
== info
->dimen
- 1)
1932 /* For the outermost loop calculate the offset due to any
1933 elemental dimensions. It will have been initialized with the
1934 base offset of the array. */
1937 for (i
= 0; i
< info
->ref
->u
.ar
.dimen
; i
++)
1939 if (info
->ref
->u
.ar
.dimen_type
[i
] != DIMEN_ELEMENT
)
1942 gfc_init_se (&se
, NULL
);
1944 se
.expr
= info
->descriptor
;
1945 stride
= gfc_conv_array_stride (info
->descriptor
, i
);
1946 index
= gfc_conv_array_index_offset (&se
, info
, i
, -1,
1949 gfc_add_block_to_block (pblock
, &se
.pre
);
1951 info
->offset
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1952 info
->offset
, index
);
1953 info
->offset
= gfc_evaluate_now (info
->offset
, pblock
);
1957 stride
= gfc_conv_array_stride (info
->descriptor
, info
->dim
[i
]);
1960 stride
= gfc_conv_array_stride (info
->descriptor
, 0);
1962 /* Calculate the stride of the innermost loop. Hopefully this will
1963 allow the backend optimizers to do their stuff more effectively.
1965 info
->stride0
= gfc_evaluate_now (stride
, pblock
);
1969 /* Add the offset for the previous loop dimension. */
1974 ar
= &info
->ref
->u
.ar
;
1975 i
= loop
->order
[dim
+ 1];
1983 gfc_init_se (&se
, NULL
);
1985 se
.expr
= info
->descriptor
;
1986 stride
= gfc_conv_array_stride (info
->descriptor
, info
->dim
[i
]);
1987 index
= gfc_conv_array_index_offset (&se
, info
, info
->dim
[i
], i
,
1989 gfc_add_block_to_block (pblock
, &se
.pre
);
1990 info
->offset
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1991 info
->offset
, index
);
1992 info
->offset
= gfc_evaluate_now (info
->offset
, pblock
);
1995 /* Remember this offset for the second loop. */
1996 if (dim
== loop
->temp_dim
- 1)
1997 info
->saved_offset
= info
->offset
;
2002 /* Start a scalarized expression. Creates a scope and declares loop
2006 gfc_start_scalarized_body (gfc_loopinfo
* loop
, stmtblock_t
* pbody
)
2012 gcc_assert (!loop
->array_parameter
);
2014 for (dim
= loop
->dimen
- 1; dim
>= 0; dim
--)
2016 n
= loop
->order
[dim
];
2018 gfc_start_block (&loop
->code
[n
]);
2020 /* Create the loop variable. */
2021 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "S");
2023 if (dim
< loop
->temp_dim
)
2027 /* Calculate values that will be constant within this loop. */
2028 gfc_trans_preloop_setup (loop
, dim
, flags
, &loop
->code
[n
]);
2030 gfc_start_block (pbody
);
2034 /* Generates the actual loop code for a scalarization loop. */
2037 gfc_trans_scalarized_loop_end (gfc_loopinfo
* loop
, int n
,
2038 stmtblock_t
* pbody
)
2046 loopbody
= gfc_finish_block (pbody
);
2048 /* Initialize the loopvar. */
2049 gfc_add_modify_expr (&loop
->code
[n
], loop
->loopvar
[n
], loop
->from
[n
]);
2051 exit_label
= gfc_build_label_decl (NULL_TREE
);
2053 /* Generate the loop body. */
2054 gfc_init_block (&block
);
2056 /* The exit condition. */
2057 cond
= build2 (GT_EXPR
, boolean_type_node
, loop
->loopvar
[n
], loop
->to
[n
]);
2058 tmp
= build1_v (GOTO_EXPR
, exit_label
);
2059 TREE_USED (exit_label
) = 1;
2060 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt ());
2061 gfc_add_expr_to_block (&block
, tmp
);
2063 /* The main body. */
2064 gfc_add_expr_to_block (&block
, loopbody
);
2066 /* Increment the loopvar. */
2067 tmp
= build2 (PLUS_EXPR
, gfc_array_index_type
,
2068 loop
->loopvar
[n
], gfc_index_one_node
);
2069 gfc_add_modify_expr (&block
, loop
->loopvar
[n
], tmp
);
2071 /* Build the loop. */
2072 tmp
= gfc_finish_block (&block
);
2073 tmp
= build1_v (LOOP_EXPR
, tmp
);
2074 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
2076 /* Add the exit label. */
2077 tmp
= build1_v (LABEL_EXPR
, exit_label
);
2078 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
2082 /* Finishes and generates the loops for a scalarized expression. */
2085 gfc_trans_scalarizing_loops (gfc_loopinfo
* loop
, stmtblock_t
* body
)
2090 stmtblock_t
*pblock
;
2094 /* Generate the loops. */
2095 for (dim
= 0; dim
< loop
->dimen
; dim
++)
2097 n
= loop
->order
[dim
];
2098 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
2099 loop
->loopvar
[n
] = NULL_TREE
;
2100 pblock
= &loop
->code
[n
];
2103 tmp
= gfc_finish_block (pblock
);
2104 gfc_add_expr_to_block (&loop
->pre
, tmp
);
2106 /* Clear all the used flags. */
2107 for (ss
= loop
->ss
; ss
; ss
= ss
->loop_chain
)
2112 /* Finish the main body of a scalarized expression, and start the secondary
2116 gfc_trans_scalarized_loop_boundary (gfc_loopinfo
* loop
, stmtblock_t
* body
)
2120 stmtblock_t
*pblock
;
2124 /* We finish as many loops as are used by the temporary. */
2125 for (dim
= 0; dim
< loop
->temp_dim
- 1; dim
++)
2127 n
= loop
->order
[dim
];
2128 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
2129 loop
->loopvar
[n
] = NULL_TREE
;
2130 pblock
= &loop
->code
[n
];
2133 /* We don't want to finish the outermost loop entirely. */
2134 n
= loop
->order
[loop
->temp_dim
- 1];
2135 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
2137 /* Restore the initial offsets. */
2138 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2140 if ((ss
->useflags
& 2) == 0)
2143 if (ss
->type
!= GFC_SS_SECTION
2144 && ss
->type
!= GFC_SS_FUNCTION
&& ss
->type
!= GFC_SS_CONSTRUCTOR
2145 && ss
->type
!= GFC_SS_COMPONENT
)
2148 ss
->data
.info
.offset
= ss
->data
.info
.saved_offset
;
2151 /* Restart all the inner loops we just finished. */
2152 for (dim
= loop
->temp_dim
- 2; dim
>= 0; dim
--)
2154 n
= loop
->order
[dim
];
2156 gfc_start_block (&loop
->code
[n
]);
2158 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "Q");
2160 gfc_trans_preloop_setup (loop
, dim
, 2, &loop
->code
[n
]);
2163 /* Start a block for the secondary copying code. */
2164 gfc_start_block (body
);
2168 /* Calculate the upper bound of an array section. */
2171 gfc_conv_section_upper_bound (gfc_ss
* ss
, int n
, stmtblock_t
* pblock
)
2180 gcc_assert (ss
->type
== GFC_SS_SECTION
);
2182 info
= &ss
->data
.info
;
2185 if (info
->ref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
2186 /* We'll calculate the upper bound once we have access to the
2187 vector's descriptor. */
2190 gcc_assert (info
->ref
->u
.ar
.dimen_type
[dim
] == DIMEN_RANGE
);
2191 desc
= info
->descriptor
;
2192 end
= info
->ref
->u
.ar
.end
[dim
];
2196 /* The upper bound was specified. */
2197 gfc_init_se (&se
, NULL
);
2198 gfc_conv_expr_type (&se
, end
, gfc_array_index_type
);
2199 gfc_add_block_to_block (pblock
, &se
.pre
);
2204 /* No upper bound was specified, so use the bound of the array. */
2205 bound
= gfc_conv_array_ubound (desc
, dim
);
2212 /* Calculate the lower bound of an array section. */
2215 gfc_conv_section_startstride (gfc_loopinfo
* loop
, gfc_ss
* ss
, int n
)
2224 gcc_assert (ss
->type
== GFC_SS_SECTION
);
2226 info
= &ss
->data
.info
;
2229 if (info
->ref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
2231 /* We use a zero-based index to access the vector. */
2232 info
->start
[n
] = gfc_index_zero_node
;
2233 info
->stride
[n
] = gfc_index_one_node
;
2237 gcc_assert (info
->ref
->u
.ar
.dimen_type
[dim
] == DIMEN_RANGE
);
2238 desc
= info
->descriptor
;
2239 start
= info
->ref
->u
.ar
.start
[dim
];
2240 stride
= info
->ref
->u
.ar
.stride
[dim
];
2242 /* Calculate the start of the range. For vector subscripts this will
2243 be the range of the vector. */
2246 /* Specified section start. */
2247 gfc_init_se (&se
, NULL
);
2248 gfc_conv_expr_type (&se
, start
, gfc_array_index_type
);
2249 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
2250 info
->start
[n
] = se
.expr
;
2254 /* No lower bound specified so use the bound of the array. */
2255 info
->start
[n
] = gfc_conv_array_lbound (desc
, dim
);
2257 info
->start
[n
] = gfc_evaluate_now (info
->start
[n
], &loop
->pre
);
2259 /* Calculate the stride. */
2261 info
->stride
[n
] = gfc_index_one_node
;
2264 gfc_init_se (&se
, NULL
);
2265 gfc_conv_expr_type (&se
, stride
, gfc_array_index_type
);
2266 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
2267 info
->stride
[n
] = gfc_evaluate_now (se
.expr
, &loop
->pre
);
2272 /* Calculates the range start and stride for a SS chain. Also gets the
2273 descriptor and data pointer. The range of vector subscripts is the size
2274 of the vector. Array bounds are also checked. */
2277 gfc_conv_ss_startstride (gfc_loopinfo
* loop
)
2285 /* Determine the rank of the loop. */
2287 ss
!= gfc_ss_terminator
&& loop
->dimen
== 0; ss
= ss
->loop_chain
)
2291 case GFC_SS_SECTION
:
2292 case GFC_SS_CONSTRUCTOR
:
2293 case GFC_SS_FUNCTION
:
2294 case GFC_SS_COMPONENT
:
2295 loop
->dimen
= ss
->data
.info
.dimen
;
2303 if (loop
->dimen
== 0)
2304 gfc_todo_error ("Unable to determine rank of expression");
2307 /* Loop over all the SS in the chain. */
2308 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2310 if (ss
->expr
&& ss
->expr
->shape
&& !ss
->shape
)
2311 ss
->shape
= ss
->expr
->shape
;
2315 case GFC_SS_SECTION
:
2316 /* Get the descriptor for the array. */
2317 gfc_conv_ss_descriptor (&loop
->pre
, ss
, !loop
->array_parameter
);
2319 for (n
= 0; n
< ss
->data
.info
.dimen
; n
++)
2320 gfc_conv_section_startstride (loop
, ss
, n
);
2323 case GFC_SS_CONSTRUCTOR
:
2324 case GFC_SS_FUNCTION
:
2325 for (n
= 0; n
< ss
->data
.info
.dimen
; n
++)
2327 ss
->data
.info
.start
[n
] = gfc_index_zero_node
;
2328 ss
->data
.info
.stride
[n
] = gfc_index_one_node
;
2337 /* The rest is just runtime bound checking. */
2338 if (flag_bounds_check
)
2344 tree size
[GFC_MAX_DIMENSIONS
];
2348 gfc_start_block (&block
);
2350 fault
= integer_zero_node
;
2351 for (n
= 0; n
< loop
->dimen
; n
++)
2352 size
[n
] = NULL_TREE
;
2354 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2356 if (ss
->type
!= GFC_SS_SECTION
)
2359 /* TODO: range checking for mapped dimensions. */
2360 info
= &ss
->data
.info
;
2362 /* This code only checks ranges. Elemental and vector
2363 dimensions are checked later. */
2364 for (n
= 0; n
< loop
->dimen
; n
++)
2367 if (info
->ref
->u
.ar
.dimen_type
[dim
] != DIMEN_RANGE
)
2370 desc
= ss
->data
.info
.descriptor
;
2372 /* Check lower bound. */
2373 bound
= gfc_conv_array_lbound (desc
, dim
);
2374 tmp
= info
->start
[n
];
2375 tmp
= fold_build2 (LT_EXPR
, boolean_type_node
, tmp
, bound
);
2376 fault
= fold_build2 (TRUTH_OR_EXPR
, boolean_type_node
, fault
,
2379 /* Check the upper bound. */
2380 bound
= gfc_conv_array_ubound (desc
, dim
);
2381 end
= gfc_conv_section_upper_bound (ss
, n
, &block
);
2382 tmp
= fold_build2 (GT_EXPR
, boolean_type_node
, end
, bound
);
2383 fault
= fold_build2 (TRUTH_OR_EXPR
, boolean_type_node
, fault
,
2386 /* Check the section sizes match. */
2387 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, end
,
2389 tmp
= fold_build2 (FLOOR_DIV_EXPR
, gfc_array_index_type
, tmp
,
2391 /* We remember the size of the first section, and check all the
2392 others against this. */
2396 fold_build2 (NE_EXPR
, boolean_type_node
, tmp
, size
[n
]);
2398 build2 (TRUTH_OR_EXPR
, boolean_type_node
, fault
, tmp
);
2401 size
[n
] = gfc_evaluate_now (tmp
, &block
);
2404 gfc_trans_runtime_check (fault
, gfc_strconst_bounds
, &block
);
2406 tmp
= gfc_finish_block (&block
);
2407 gfc_add_expr_to_block (&loop
->pre
, tmp
);
2412 /* Return true if the two SS could be aliased, i.e. both point to the same data
2414 /* TODO: resolve aliases based on frontend expressions. */
2417 gfc_could_be_alias (gfc_ss
* lss
, gfc_ss
* rss
)
2424 lsym
= lss
->expr
->symtree
->n
.sym
;
2425 rsym
= rss
->expr
->symtree
->n
.sym
;
2426 if (gfc_symbols_could_alias (lsym
, rsym
))
2429 if (rsym
->ts
.type
!= BT_DERIVED
2430 && lsym
->ts
.type
!= BT_DERIVED
)
2433 /* For derived types we must check all the component types. We can ignore
2434 array references as these will have the same base type as the previous
2436 for (lref
= lss
->expr
->ref
; lref
!= lss
->data
.info
.ref
; lref
= lref
->next
)
2438 if (lref
->type
!= REF_COMPONENT
)
2441 if (gfc_symbols_could_alias (lref
->u
.c
.sym
, rsym
))
2444 for (rref
= rss
->expr
->ref
; rref
!= rss
->data
.info
.ref
;
2447 if (rref
->type
!= REF_COMPONENT
)
2450 if (gfc_symbols_could_alias (lref
->u
.c
.sym
, rref
->u
.c
.sym
))
2455 for (rref
= rss
->expr
->ref
; rref
!= rss
->data
.info
.ref
; rref
= rref
->next
)
2457 if (rref
->type
!= REF_COMPONENT
)
2460 if (gfc_symbols_could_alias (rref
->u
.c
.sym
, lsym
))
2468 /* Resolve array data dependencies. Creates a temporary if required. */
2469 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
2473 gfc_conv_resolve_dependencies (gfc_loopinfo
* loop
, gfc_ss
* dest
,
2483 loop
->temp_ss
= NULL
;
2484 aref
= dest
->data
.info
.ref
;
2487 for (ss
= rss
; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
2489 if (ss
->type
!= GFC_SS_SECTION
)
2492 if (gfc_could_be_alias (dest
, ss
))
2498 if (dest
->expr
->symtree
->n
.sym
== ss
->expr
->symtree
->n
.sym
)
2500 lref
= dest
->expr
->ref
;
2501 rref
= ss
->expr
->ref
;
2503 nDepend
= gfc_dep_resolver (lref
, rref
);
2505 /* TODO : loop shifting. */
2508 /* Mark the dimensions for LOOP SHIFTING */
2509 for (n
= 0; n
< loop
->dimen
; n
++)
2511 int dim
= dest
->data
.info
.dim
[n
];
2513 if (lref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
2515 else if (! gfc_is_same_range (&lref
->u
.ar
,
2516 &rref
->u
.ar
, dim
, 0))
2520 /* Put all the dimensions with dependencies in the
2523 for (n
= 0; n
< loop
->dimen
; n
++)
2525 gcc_assert (loop
->order
[n
] == n
);
2527 loop
->order
[dim
++] = n
;
2530 for (n
= 0; n
< loop
->dimen
; n
++)
2533 loop
->order
[dim
++] = n
;
2536 gcc_assert (dim
== loop
->dimen
);
2545 loop
->temp_ss
= gfc_get_ss ();
2546 loop
->temp_ss
->type
= GFC_SS_TEMP
;
2547 loop
->temp_ss
->data
.temp
.type
=
2548 gfc_get_element_type (TREE_TYPE (dest
->data
.info
.descriptor
));
2549 loop
->temp_ss
->string_length
= dest
->string_length
;
2550 loop
->temp_ss
->data
.temp
.dimen
= loop
->dimen
;
2551 loop
->temp_ss
->next
= gfc_ss_terminator
;
2552 gfc_add_ss_to_loop (loop
, loop
->temp_ss
);
2555 loop
->temp_ss
= NULL
;
2559 /* Initialize the scalarization loop. Creates the loop variables. Determines
2560 the range of the loop variables. Creates a temporary if required.
2561 Calculates how to transform from loop variables to array indices for each
2562 expression. Also generates code for scalar expressions which have been
2563 moved outside the loop. */
2566 gfc_conv_loop_setup (gfc_loopinfo
* loop
)
2571 gfc_ss_info
*specinfo
;
2575 gfc_ss
*loopspec
[GFC_MAX_DIMENSIONS
];
2576 bool dynamic
[GFC_MAX_DIMENSIONS
];
2582 for (n
= 0; n
< loop
->dimen
; n
++)
2586 /* We use one SS term, and use that to determine the bounds of the
2587 loop for this dimension. We try to pick the simplest term. */
2588 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2592 /* The frontend has worked out the size for us. */
2597 if (ss
->type
== GFC_SS_CONSTRUCTOR
)
2599 /* An unknown size constructor will always be rank one.
2600 Higher rank constructors will either have known shape,
2601 or still be wrapped in a call to reshape. */
2602 gcc_assert (loop
->dimen
== 1);
2604 /* Always prefer to use the constructor bounds if the size
2605 can be determined at compile time. Prefer not to otherwise,
2606 since the general case involves realloc, and it's better to
2607 avoid that overhead if possible. */
2608 c
= ss
->expr
->value
.constructor
;
2609 dynamic
[n
] = gfc_get_array_constructor_size (&i
, c
);
2610 if (!dynamic
[n
] || !loopspec
[n
])
2615 /* TODO: Pick the best bound if we have a choice between a
2616 function and something else. */
2617 if (ss
->type
== GFC_SS_FUNCTION
)
2623 if (ss
->type
!= GFC_SS_SECTION
)
2627 specinfo
= &loopspec
[n
]->data
.info
;
2630 info
= &ss
->data
.info
;
2634 /* Criteria for choosing a loop specifier (most important first):
2635 doesn't need realloc
2641 else if (loopspec
[n
]->type
== GFC_SS_CONSTRUCTOR
&& dynamic
[n
])
2643 else if (integer_onep (info
->stride
[n
])
2644 && !integer_onep (specinfo
->stride
[n
]))
2646 else if (INTEGER_CST_P (info
->stride
[n
])
2647 && !INTEGER_CST_P (specinfo
->stride
[n
]))
2649 else if (INTEGER_CST_P (info
->start
[n
])
2650 && !INTEGER_CST_P (specinfo
->start
[n
]))
2652 /* We don't work out the upper bound.
2653 else if (INTEGER_CST_P (info->finish[n])
2654 && ! INTEGER_CST_P (specinfo->finish[n]))
2655 loopspec[n] = ss; */
2659 gfc_todo_error ("Unable to find scalarization loop specifier");
2661 info
= &loopspec
[n
]->data
.info
;
2663 /* Set the extents of this range. */
2664 cshape
= loopspec
[n
]->shape
;
2665 if (cshape
&& INTEGER_CST_P (info
->start
[n
])
2666 && INTEGER_CST_P (info
->stride
[n
]))
2668 loop
->from
[n
] = info
->start
[n
];
2669 mpz_set (i
, cshape
[n
]);
2670 mpz_sub_ui (i
, i
, 1);
2671 /* To = from + (size - 1) * stride. */
2672 tmp
= gfc_conv_mpz_to_tree (i
, gfc_index_integer_kind
);
2673 if (!integer_onep (info
->stride
[n
]))
2674 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
2675 tmp
, info
->stride
[n
]);
2676 loop
->to
[n
] = fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2677 loop
->from
[n
], tmp
);
2681 loop
->from
[n
] = info
->start
[n
];
2682 switch (loopspec
[n
]->type
)
2684 case GFC_SS_CONSTRUCTOR
:
2685 /* The upper bound is calculated when we expand the
2687 gcc_assert (loop
->to
[n
] == NULL_TREE
);
2690 case GFC_SS_SECTION
:
2691 loop
->to
[n
] = gfc_conv_section_upper_bound (loopspec
[n
], n
,
2695 case GFC_SS_FUNCTION
:
2696 /* The loop bound will be set when we generate the call. */
2697 gcc_assert (loop
->to
[n
] == NULL_TREE
);
2705 /* Transform everything so we have a simple incrementing variable. */
2706 if (integer_onep (info
->stride
[n
]))
2707 info
->delta
[n
] = gfc_index_zero_node
;
2710 /* Set the delta for this section. */
2711 info
->delta
[n
] = gfc_evaluate_now (loop
->from
[n
], &loop
->pre
);
2712 /* Number of iterations is (end - start + step) / step.
2713 with start = 0, this simplifies to
2715 for (i = 0; i<=last; i++){...}; */
2716 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
2717 loop
->to
[n
], loop
->from
[n
]);
2718 tmp
= fold_build2 (TRUNC_DIV_EXPR
, gfc_array_index_type
,
2719 tmp
, info
->stride
[n
]);
2720 loop
->to
[n
] = gfc_evaluate_now (tmp
, &loop
->pre
);
2721 /* Make the loop variable start at 0. */
2722 loop
->from
[n
] = gfc_index_zero_node
;
2726 /* Add all the scalar code that can be taken out of the loops.
2727 This may include calculating the loop bounds, so do it before
2728 allocating the temporary. */
2729 gfc_add_loop_ss_code (loop
, loop
->ss
, false);
2731 /* If we want a temporary then create it. */
2732 if (loop
->temp_ss
!= NULL
)
2734 gcc_assert (loop
->temp_ss
->type
== GFC_SS_TEMP
);
2735 tmp
= loop
->temp_ss
->data
.temp
.type
;
2736 len
= loop
->temp_ss
->string_length
;
2737 n
= loop
->temp_ss
->data
.temp
.dimen
;
2738 memset (&loop
->temp_ss
->data
.info
, 0, sizeof (gfc_ss_info
));
2739 loop
->temp_ss
->type
= GFC_SS_SECTION
;
2740 loop
->temp_ss
->data
.info
.dimen
= n
;
2741 gfc_trans_allocate_temp_array (&loop
->pre
, &loop
->post
, loop
,
2742 &loop
->temp_ss
->data
.info
, tmp
, false);
2745 for (n
= 0; n
< loop
->temp_dim
; n
++)
2746 loopspec
[loop
->order
[n
]] = NULL
;
2750 /* For array parameters we don't have loop variables, so don't calculate the
2752 if (loop
->array_parameter
)
2755 /* Calculate the translation from loop variables to array indices. */
2756 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2758 if (ss
->type
!= GFC_SS_SECTION
&& ss
->type
!= GFC_SS_COMPONENT
)
2761 info
= &ss
->data
.info
;
2763 for (n
= 0; n
< info
->dimen
; n
++)
2767 /* If we are specifying the range the delta is already set. */
2768 if (loopspec
[n
] != ss
)
2770 /* Calculate the offset relative to the loop variable.
2771 First multiply by the stride. */
2772 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
2773 loop
->from
[n
], info
->stride
[n
]);
2775 /* Then subtract this from our starting value. */
2776 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
2777 info
->start
[n
], tmp
);
2779 info
->delta
[n
] = gfc_evaluate_now (tmp
, &loop
->pre
);
2786 /* Fills in an array descriptor, and returns the size of the array. The size
2787 will be a simple_val, ie a variable or a constant. Also calculates the
2788 offset of the base. Returns the size of the array.
2792 for (n = 0; n < rank; n++)
2794 a.lbound[n] = specified_lower_bound;
2795 offset = offset + a.lbond[n] * stride;
2797 a.ubound[n] = specified_upper_bound;
2798 a.stride[n] = stride;
2799 size = ubound + size; //size = ubound + 1 - lbound
2800 stride = stride * size;
2807 gfc_array_init_size (tree descriptor
, int rank
, tree
* poffset
,
2808 gfc_expr
** lower
, gfc_expr
** upper
,
2809 stmtblock_t
* pblock
)
2820 type
= TREE_TYPE (descriptor
);
2822 stride
= gfc_index_one_node
;
2823 offset
= gfc_index_zero_node
;
2825 /* Set the dtype. */
2826 tmp
= gfc_conv_descriptor_dtype (descriptor
);
2827 gfc_add_modify_expr (pblock
, tmp
, gfc_get_dtype (TREE_TYPE (descriptor
)));
2829 for (n
= 0; n
< rank
; n
++)
2831 /* We have 3 possibilities for determining the size of the array:
2832 lower == NULL => lbound = 1, ubound = upper[n]
2833 upper[n] = NULL => lbound = 1, ubound = lower[n]
2834 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
2837 /* Set lower bound. */
2838 gfc_init_se (&se
, NULL
);
2840 se
.expr
= gfc_index_one_node
;
2843 gcc_assert (lower
[n
]);
2846 gfc_conv_expr_type (&se
, lower
[n
], gfc_array_index_type
);
2847 gfc_add_block_to_block (pblock
, &se
.pre
);
2851 se
.expr
= gfc_index_one_node
;
2855 tmp
= gfc_conv_descriptor_lbound (descriptor
, gfc_rank_cst
[n
]);
2856 gfc_add_modify_expr (pblock
, tmp
, se
.expr
);
2858 /* Work out the offset for this component. */
2859 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, se
.expr
, stride
);
2860 offset
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp
);
2862 /* Start the calculation for the size of this dimension. */
2863 size
= build2 (MINUS_EXPR
, gfc_array_index_type
,
2864 gfc_index_one_node
, se
.expr
);
2866 /* Set upper bound. */
2867 gfc_init_se (&se
, NULL
);
2868 gcc_assert (ubound
);
2869 gfc_conv_expr_type (&se
, ubound
, gfc_array_index_type
);
2870 gfc_add_block_to_block (pblock
, &se
.pre
);
2872 tmp
= gfc_conv_descriptor_ubound (descriptor
, gfc_rank_cst
[n
]);
2873 gfc_add_modify_expr (pblock
, tmp
, se
.expr
);
2875 /* Store the stride. */
2876 tmp
= gfc_conv_descriptor_stride (descriptor
, gfc_rank_cst
[n
]);
2877 gfc_add_modify_expr (pblock
, tmp
, stride
);
2879 /* Calculate the size of this dimension. */
2880 size
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, se
.expr
, size
);
2882 /* Multiply the stride by the number of elements in this dimension. */
2883 stride
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, stride
, size
);
2884 stride
= gfc_evaluate_now (stride
, pblock
);
2887 /* The stride is the number of elements in the array, so multiply by the
2888 size of an element to get the total size. */
2889 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
2890 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, stride
, tmp
);
2892 if (poffset
!= NULL
)
2894 offset
= gfc_evaluate_now (offset
, pblock
);
2898 size
= gfc_evaluate_now (size
, pblock
);
2903 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
2904 the work for an ALLOCATE statement. */
2908 gfc_array_allocate (gfc_se
* se
, gfc_ref
* ref
, tree pstat
)
2918 /* Figure out the size of the array. */
2919 switch (ref
->u
.ar
.type
)
2923 upper
= ref
->u
.ar
.start
;
2927 gcc_assert (ref
->u
.ar
.as
->type
== AS_EXPLICIT
);
2929 lower
= ref
->u
.ar
.as
->lower
;
2930 upper
= ref
->u
.ar
.as
->upper
;
2934 lower
= ref
->u
.ar
.start
;
2935 upper
= ref
->u
.ar
.end
;
2943 size
= gfc_array_init_size (se
->expr
, ref
->u
.ar
.as
->rank
, &offset
,
2944 lower
, upper
, &se
->pre
);
2946 /* Allocate memory to store the data. */
2947 tmp
= gfc_conv_descriptor_data_addr (se
->expr
);
2948 pointer
= gfc_evaluate_now (tmp
, &se
->pre
);
2950 if (TYPE_PRECISION (gfc_array_index_type
) == 32)
2951 allocate
= gfor_fndecl_allocate
;
2952 else if (TYPE_PRECISION (gfc_array_index_type
) == 64)
2953 allocate
= gfor_fndecl_allocate64
;
2957 tmp
= gfc_chainon_list (NULL_TREE
, pointer
);
2958 tmp
= gfc_chainon_list (tmp
, size
);
2959 tmp
= gfc_chainon_list (tmp
, pstat
);
2960 tmp
= gfc_build_function_call (allocate
, tmp
);
2961 gfc_add_expr_to_block (&se
->pre
, tmp
);
2963 tmp
= gfc_conv_descriptor_offset (se
->expr
);
2964 gfc_add_modify_expr (&se
->pre
, tmp
, offset
);
2968 /* Deallocate an array variable. Also used when an allocated variable goes
2973 gfc_array_deallocate (tree descriptor
, tree pstat
)
2979 gfc_start_block (&block
);
2980 /* Get a pointer to the data. */
2981 tmp
= gfc_conv_descriptor_data_addr (descriptor
);
2982 var
= gfc_evaluate_now (tmp
, &block
);
2984 /* Parameter is the address of the data component. */
2985 tmp
= gfc_chainon_list (NULL_TREE
, var
);
2986 tmp
= gfc_chainon_list (tmp
, pstat
);
2987 tmp
= gfc_build_function_call (gfor_fndecl_deallocate
, tmp
);
2988 gfc_add_expr_to_block (&block
, tmp
);
2990 return gfc_finish_block (&block
);
2994 /* Create an array constructor from an initialization expression.
2995 We assume the frontend already did any expansions and conversions. */
2998 gfc_conv_array_initializer (tree type
, gfc_expr
* expr
)
3005 unsigned HOST_WIDE_INT lo
;
3007 VEC(constructor_elt
,gc
) *v
= NULL
;
3009 switch (expr
->expr_type
)
3012 case EXPR_STRUCTURE
:
3013 /* A single scalar or derived type value. Create an array with all
3014 elements equal to that value. */
3015 gfc_init_se (&se
, NULL
);
3017 if (expr
->expr_type
== EXPR_CONSTANT
)
3018 gfc_conv_constant (&se
, expr
);
3020 gfc_conv_structure (&se
, expr
, 1);
3022 tmp
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
3023 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
3024 hi
= TREE_INT_CST_HIGH (tmp
);
3025 lo
= TREE_INT_CST_LOW (tmp
);
3029 /* This will probably eat buckets of memory for large arrays. */
3030 while (hi
!= 0 || lo
!= 0)
3032 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
, se
.expr
);
3040 /* Create a vector of all the elements. */
3041 for (c
= expr
->value
.constructor
; c
; c
= c
->next
)
3045 /* Problems occur when we get something like
3046 integer :: a(lots) = (/(i, i=1,lots)/) */
3047 /* TODO: Unexpanded array initializers. */
3049 ("Possible frontend bug: array constructor not expanded");
3051 if (mpz_cmp_si (c
->n
.offset
, 0) != 0)
3052 index
= gfc_conv_mpz_to_tree (c
->n
.offset
, gfc_index_integer_kind
);
3056 if (mpz_cmp_si (c
->repeat
, 0) != 0)
3060 mpz_set (maxval
, c
->repeat
);
3061 mpz_add (maxval
, c
->n
.offset
, maxval
);
3062 mpz_sub_ui (maxval
, maxval
, 1);
3063 tmp2
= gfc_conv_mpz_to_tree (maxval
, gfc_index_integer_kind
);
3064 if (mpz_cmp_si (c
->n
.offset
, 0) != 0)
3066 mpz_add_ui (maxval
, c
->n
.offset
, 1);
3067 tmp1
= gfc_conv_mpz_to_tree (maxval
, gfc_index_integer_kind
);
3070 tmp1
= gfc_conv_mpz_to_tree (c
->n
.offset
, gfc_index_integer_kind
);
3072 range
= build2 (RANGE_EXPR
, integer_type_node
, tmp1
, tmp2
);
3078 gfc_init_se (&se
, NULL
);
3079 switch (c
->expr
->expr_type
)
3082 gfc_conv_constant (&se
, c
->expr
);
3083 if (range
== NULL_TREE
)
3084 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
3087 if (index
!= NULL_TREE
)
3088 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
3089 CONSTRUCTOR_APPEND_ELT (v
, range
, se
.expr
);
3093 case EXPR_STRUCTURE
:
3094 gfc_conv_structure (&se
, c
->expr
, 1);
3095 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
3108 /* Create a constructor from the list of elements. */
3109 tmp
= build_constructor (type
, v
);
3110 TREE_CONSTANT (tmp
) = 1;
3111 TREE_INVARIANT (tmp
) = 1;
3116 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
3117 returns the size (in elements) of the array. */
3120 gfc_trans_array_bounds (tree type
, gfc_symbol
* sym
, tree
* poffset
,
3121 stmtblock_t
* pblock
)
3136 size
= gfc_index_one_node
;
3137 offset
= gfc_index_zero_node
;
3138 for (dim
= 0; dim
< as
->rank
; dim
++)
3140 /* Evaluate non-constant array bound expressions. */
3141 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
3142 if (as
->lower
[dim
] && !INTEGER_CST_P (lbound
))
3144 gfc_init_se (&se
, NULL
);
3145 gfc_conv_expr_type (&se
, as
->lower
[dim
], gfc_array_index_type
);
3146 gfc_add_block_to_block (pblock
, &se
.pre
);
3147 gfc_add_modify_expr (pblock
, lbound
, se
.expr
);
3149 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
3150 if (as
->upper
[dim
] && !INTEGER_CST_P (ubound
))
3152 gfc_init_se (&se
, NULL
);
3153 gfc_conv_expr_type (&se
, as
->upper
[dim
], gfc_array_index_type
);
3154 gfc_add_block_to_block (pblock
, &se
.pre
);
3155 gfc_add_modify_expr (pblock
, ubound
, se
.expr
);
3157 /* The offset of this dimension. offset = offset - lbound * stride. */
3158 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, lbound
, size
);
3159 offset
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp
);
3161 /* The size of this dimension, and the stride of the next. */
3162 if (dim
+ 1 < as
->rank
)
3163 stride
= GFC_TYPE_ARRAY_STRIDE (type
, dim
+ 1);
3167 if (ubound
!= NULL_TREE
&& !(stride
&& INTEGER_CST_P (stride
)))
3169 /* Calculate stride = size * (ubound + 1 - lbound). */
3170 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
3171 gfc_index_one_node
, lbound
);
3172 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, ubound
, tmp
);
3173 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
, tmp
);
3175 gfc_add_modify_expr (pblock
, stride
, tmp
);
3177 stride
= gfc_evaluate_now (tmp
, pblock
);
3188 /* Generate code to initialize/allocate an array variable. */
3191 gfc_trans_auto_array_allocation (tree decl
, gfc_symbol
* sym
, tree fnbody
)
3201 gcc_assert (!(sym
->attr
.pointer
|| sym
->attr
.allocatable
));
3203 /* Do nothing for USEd variables. */
3204 if (sym
->attr
.use_assoc
)
3207 type
= TREE_TYPE (decl
);
3208 gcc_assert (GFC_ARRAY_TYPE_P (type
));
3209 onstack
= TREE_CODE (type
) != POINTER_TYPE
;
3211 gfc_start_block (&block
);
3213 /* Evaluate character string length. */
3214 if (sym
->ts
.type
== BT_CHARACTER
3215 && onstack
&& !INTEGER_CST_P (sym
->ts
.cl
->backend_decl
))
3217 gfc_trans_init_string_length (sym
->ts
.cl
, &block
);
3219 /* Emit a DECL_EXPR for this variable, which will cause the
3220 gimplifier to allocate storage, and all that good stuff. */
3221 tmp
= build1 (DECL_EXPR
, TREE_TYPE (decl
), decl
);
3222 gfc_add_expr_to_block (&block
, tmp
);
3227 gfc_add_expr_to_block (&block
, fnbody
);
3228 return gfc_finish_block (&block
);
3231 type
= TREE_TYPE (type
);
3233 gcc_assert (!sym
->attr
.use_assoc
);
3234 gcc_assert (!TREE_STATIC (decl
));
3235 gcc_assert (!sym
->module
);
3237 if (sym
->ts
.type
== BT_CHARACTER
3238 && !INTEGER_CST_P (sym
->ts
.cl
->backend_decl
))
3239 gfc_trans_init_string_length (sym
->ts
.cl
, &block
);
3241 size
= gfc_trans_array_bounds (type
, sym
, &offset
, &block
);
3243 /* Don't actually allocate space for Cray Pointees. */
3244 if (sym
->attr
.cray_pointee
)
3246 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
3247 gfc_add_modify_expr (&block
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
3248 gfc_add_expr_to_block (&block
, fnbody
);
3249 return gfc_finish_block (&block
);
3252 /* The size is the number of elements in the array, so multiply by the
3253 size of an element to get the total size. */
3254 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
3255 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
, tmp
);
3257 /* Allocate memory to hold the data. */
3258 tmp
= gfc_chainon_list (NULL_TREE
, size
);
3260 if (gfc_index_integer_kind
== 4)
3261 fndecl
= gfor_fndecl_internal_malloc
;
3262 else if (gfc_index_integer_kind
== 8)
3263 fndecl
= gfor_fndecl_internal_malloc64
;
3266 tmp
= gfc_build_function_call (fndecl
, tmp
);
3267 tmp
= fold (convert (TREE_TYPE (decl
), tmp
));
3268 gfc_add_modify_expr (&block
, decl
, tmp
);
3270 /* Set offset of the array. */
3271 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
3272 gfc_add_modify_expr (&block
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
3275 /* Automatic arrays should not have initializers. */
3276 gcc_assert (!sym
->value
);
3278 gfc_add_expr_to_block (&block
, fnbody
);
3280 /* Free the temporary. */
3281 tmp
= convert (pvoid_type_node
, decl
);
3282 tmp
= gfc_chainon_list (NULL_TREE
, tmp
);
3283 tmp
= gfc_build_function_call (gfor_fndecl_internal_free
, tmp
);
3284 gfc_add_expr_to_block (&block
, tmp
);
3286 return gfc_finish_block (&block
);
3290 /* Generate entry and exit code for g77 calling convention arrays. */
3293 gfc_trans_g77_array (gfc_symbol
* sym
, tree body
)
3302 gfc_get_backend_locus (&loc
);
3303 gfc_set_backend_locus (&sym
->declared_at
);
3305 /* Descriptor type. */
3306 parm
= sym
->backend_decl
;
3307 type
= TREE_TYPE (parm
);
3308 gcc_assert (GFC_ARRAY_TYPE_P (type
));
3310 gfc_start_block (&block
);
3312 if (sym
->ts
.type
== BT_CHARACTER
3313 && TREE_CODE (sym
->ts
.cl
->backend_decl
) == VAR_DECL
)
3314 gfc_trans_init_string_length (sym
->ts
.cl
, &block
);
3316 /* Evaluate the bounds of the array. */
3317 gfc_trans_array_bounds (type
, sym
, &offset
, &block
);
3319 /* Set the offset. */
3320 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
3321 gfc_add_modify_expr (&block
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
3323 /* Set the pointer itself if we aren't using the parameter directly. */
3324 if (TREE_CODE (parm
) != PARM_DECL
)
3326 tmp
= convert (TREE_TYPE (parm
), GFC_DECL_SAVED_DESCRIPTOR (parm
));
3327 gfc_add_modify_expr (&block
, parm
, tmp
);
3329 tmp
= gfc_finish_block (&block
);
3331 gfc_set_backend_locus (&loc
);
3333 gfc_start_block (&block
);
3334 /* Add the initialization code to the start of the function. */
3335 gfc_add_expr_to_block (&block
, tmp
);
3336 gfc_add_expr_to_block (&block
, body
);
3338 return gfc_finish_block (&block
);
3342 /* Modify the descriptor of an array parameter so that it has the
3343 correct lower bound. Also move the upper bound accordingly.
3344 If the array is not packed, it will be copied into a temporary.
3345 For each dimension we set the new lower and upper bounds. Then we copy the
3346 stride and calculate the offset for this dimension. We also work out
3347 what the stride of a packed array would be, and see it the two match.
3348 If the array need repacking, we set the stride to the values we just
3349 calculated, recalculate the offset and copy the array data.
3350 Code is also added to copy the data back at the end of the function.
3354 gfc_trans_dummy_array_bias (gfc_symbol
* sym
, tree tmpdesc
, tree body
)
3361 stmtblock_t cleanup
;
3379 /* Do nothing for pointer and allocatable arrays. */
3380 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
3383 if (sym
->attr
.dummy
&& gfc_is_nodesc_array (sym
))
3384 return gfc_trans_g77_array (sym
, body
);
3386 gfc_get_backend_locus (&loc
);
3387 gfc_set_backend_locus (&sym
->declared_at
);
3389 /* Descriptor type. */
3390 type
= TREE_TYPE (tmpdesc
);
3391 gcc_assert (GFC_ARRAY_TYPE_P (type
));
3392 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
3393 dumdesc
= gfc_build_indirect_ref (dumdesc
);
3394 gfc_start_block (&block
);
3396 if (sym
->ts
.type
== BT_CHARACTER
3397 && TREE_CODE (sym
->ts
.cl
->backend_decl
) == VAR_DECL
)
3398 gfc_trans_init_string_length (sym
->ts
.cl
, &block
);
3400 checkparm
= (sym
->as
->type
== AS_EXPLICIT
&& flag_bounds_check
);
3402 no_repack
= !(GFC_DECL_PACKED_ARRAY (tmpdesc
)
3403 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
));
3405 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
))
3407 /* For non-constant shape arrays we only check if the first dimension
3408 is contiguous. Repacking higher dimensions wouldn't gain us
3409 anything as we still don't know the array stride. */
3410 partial
= gfc_create_var (boolean_type_node
, "partial");
3411 TREE_USED (partial
) = 1;
3412 tmp
= gfc_conv_descriptor_stride (dumdesc
, gfc_rank_cst
[0]);
3413 tmp
= fold_build2 (EQ_EXPR
, boolean_type_node
, tmp
, integer_one_node
);
3414 gfc_add_modify_expr (&block
, partial
, tmp
);
3418 partial
= NULL_TREE
;
3421 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
3422 here, however I think it does the right thing. */
3425 /* Set the first stride. */
3426 stride
= gfc_conv_descriptor_stride (dumdesc
, gfc_rank_cst
[0]);
3427 stride
= gfc_evaluate_now (stride
, &block
);
3429 tmp
= build2 (EQ_EXPR
, boolean_type_node
, stride
, integer_zero_node
);
3430 tmp
= build3 (COND_EXPR
, gfc_array_index_type
, tmp
,
3431 gfc_index_one_node
, stride
);
3432 stride
= GFC_TYPE_ARRAY_STRIDE (type
, 0);
3433 gfc_add_modify_expr (&block
, stride
, tmp
);
3435 /* Allow the user to disable array repacking. */
3436 stmt_unpacked
= NULL_TREE
;
3440 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type
, 0)));
3441 /* A library call to repack the array if necessary. */
3442 tmp
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
3443 tmp
= gfc_chainon_list (NULL_TREE
, tmp
);
3444 stmt_unpacked
= gfc_build_function_call (gfor_fndecl_in_pack
, tmp
);
3446 stride
= gfc_index_one_node
;
3449 /* This is for the case where the array data is used directly without
3450 calling the repack function. */
3451 if (no_repack
|| partial
!= NULL_TREE
)
3452 stmt_packed
= gfc_conv_descriptor_data_get (dumdesc
);
3454 stmt_packed
= NULL_TREE
;
3456 /* Assign the data pointer. */
3457 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
3459 /* Don't repack unknown shape arrays when the first stride is 1. */
3460 tmp
= build3 (COND_EXPR
, TREE_TYPE (stmt_packed
), partial
,
3461 stmt_packed
, stmt_unpacked
);
3464 tmp
= stmt_packed
!= NULL_TREE
? stmt_packed
: stmt_unpacked
;
3465 gfc_add_modify_expr (&block
, tmpdesc
, fold_convert (type
, tmp
));
3467 offset
= gfc_index_zero_node
;
3468 size
= gfc_index_one_node
;
3470 /* Evaluate the bounds of the array. */
3471 for (n
= 0; n
< sym
->as
->rank
; n
++)
3473 if (checkparm
|| !sym
->as
->upper
[n
])
3475 /* Get the bounds of the actual parameter. */
3476 dubound
= gfc_conv_descriptor_ubound (dumdesc
, gfc_rank_cst
[n
]);
3477 dlbound
= gfc_conv_descriptor_lbound (dumdesc
, gfc_rank_cst
[n
]);
3481 dubound
= NULL_TREE
;
3482 dlbound
= NULL_TREE
;
3485 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, n
);
3486 if (!INTEGER_CST_P (lbound
))
3488 gfc_init_se (&se
, NULL
);
3489 gfc_conv_expr_type (&se
, sym
->as
->lower
[n
],
3490 gfc_array_index_type
);
3491 gfc_add_block_to_block (&block
, &se
.pre
);
3492 gfc_add_modify_expr (&block
, lbound
, se
.expr
);
3495 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, n
);
3496 /* Set the desired upper bound. */
3497 if (sym
->as
->upper
[n
])
3499 /* We know what we want the upper bound to be. */
3500 if (!INTEGER_CST_P (ubound
))
3502 gfc_init_se (&se
, NULL
);
3503 gfc_conv_expr_type (&se
, sym
->as
->upper
[n
],
3504 gfc_array_index_type
);
3505 gfc_add_block_to_block (&block
, &se
.pre
);
3506 gfc_add_modify_expr (&block
, ubound
, se
.expr
);
3509 /* Check the sizes match. */
3512 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
3514 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
3516 stride
= build2 (MINUS_EXPR
, gfc_array_index_type
,
3518 tmp
= fold_build2 (NE_EXPR
, gfc_array_index_type
, tmp
, stride
);
3519 gfc_trans_runtime_check (tmp
, gfc_strconst_bounds
, &block
);
3524 /* For assumed shape arrays move the upper bound by the same amount
3525 as the lower bound. */
3526 tmp
= build2 (MINUS_EXPR
, gfc_array_index_type
, dubound
, dlbound
);
3527 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, tmp
, lbound
);
3528 gfc_add_modify_expr (&block
, ubound
, tmp
);
3530 /* The offset of this dimension. offset = offset - lbound * stride. */
3531 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, lbound
, stride
);
3532 offset
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp
);
3534 /* The size of this dimension, and the stride of the next. */
3535 if (n
+ 1 < sym
->as
->rank
)
3537 stride
= GFC_TYPE_ARRAY_STRIDE (type
, n
+ 1);
3539 if (no_repack
|| partial
!= NULL_TREE
)
3542 gfc_conv_descriptor_stride (dumdesc
, gfc_rank_cst
[n
+1]);
3545 /* Figure out the stride if not a known constant. */
3546 if (!INTEGER_CST_P (stride
))
3549 stmt_packed
= NULL_TREE
;
3552 /* Calculate stride = size * (ubound + 1 - lbound). */
3553 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
3554 gfc_index_one_node
, lbound
);
3555 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
3557 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
3562 /* Assign the stride. */
3563 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
3564 tmp
= build3 (COND_EXPR
, gfc_array_index_type
, partial
,
3565 stmt_unpacked
, stmt_packed
);
3567 tmp
= (stmt_packed
!= NULL_TREE
) ? stmt_packed
: stmt_unpacked
;
3568 gfc_add_modify_expr (&block
, stride
, tmp
);
3573 /* Set the offset. */
3574 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
3575 gfc_add_modify_expr (&block
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
3577 stmt
= gfc_finish_block (&block
);
3579 gfc_start_block (&block
);
3581 /* Only do the entry/initialization code if the arg is present. */
3582 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
3583 optional_arg
= (sym
->attr
.optional
3584 || (sym
->ns
->proc_name
->attr
.entry_master
3585 && sym
->attr
.dummy
));
3588 tmp
= gfc_conv_expr_present (sym
);
3589 stmt
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt ());
3591 gfc_add_expr_to_block (&block
, stmt
);
3593 /* Add the main function body. */
3594 gfc_add_expr_to_block (&block
, body
);
3599 gfc_start_block (&cleanup
);
3601 if (sym
->attr
.intent
!= INTENT_IN
)
3603 /* Copy the data back. */
3604 tmp
= gfc_chainon_list (NULL_TREE
, dumdesc
);
3605 tmp
= gfc_chainon_list (tmp
, tmpdesc
);
3606 tmp
= gfc_build_function_call (gfor_fndecl_in_unpack
, tmp
);
3607 gfc_add_expr_to_block (&cleanup
, tmp
);
3610 /* Free the temporary. */
3611 tmp
= gfc_chainon_list (NULL_TREE
, tmpdesc
);
3612 tmp
= gfc_build_function_call (gfor_fndecl_internal_free
, tmp
);
3613 gfc_add_expr_to_block (&cleanup
, tmp
);
3615 stmt
= gfc_finish_block (&cleanup
);
3617 /* Only do the cleanup if the array was repacked. */
3618 tmp
= gfc_build_indirect_ref (dumdesc
);
3619 tmp
= gfc_conv_descriptor_data_get (tmp
);
3620 tmp
= build2 (NE_EXPR
, boolean_type_node
, tmp
, tmpdesc
);
3621 stmt
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt ());
3625 tmp
= gfc_conv_expr_present (sym
);
3626 stmt
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt ());
3628 gfc_add_expr_to_block (&block
, stmt
);
3630 /* We don't need to free any memory allocated by internal_pack as it will
3631 be freed at the end of the function by pop_context. */
3632 return gfc_finish_block (&block
);
3636 /* Convert an array for passing as an actual argument. Expressions and
3637 vector subscripts are evaluated and stored in a temporary, which is then
3638 passed. For whole arrays the descriptor is passed. For array sections
3639 a modified copy of the descriptor is passed, but using the original data.
3641 This function is also used for array pointer assignments, and there
3644 - want_pointer && !se->direct_byref
3645 EXPR is an actual argument. On exit, se->expr contains a
3646 pointer to the array descriptor.
3648 - !want_pointer && !se->direct_byref
3649 EXPR is an actual argument to an intrinsic function or the
3650 left-hand side of a pointer assignment. On exit, se->expr
3651 contains the descriptor for EXPR.
3653 - !want_pointer && se->direct_byref
3654 EXPR is the right-hand side of a pointer assignment and
3655 se->expr is the descriptor for the previously-evaluated
3656 left-hand side. The function creates an assignment from
3657 EXPR to se->expr. */
3660 gfc_conv_expr_descriptor (gfc_se
* se
, gfc_expr
* expr
, gfc_ss
* ss
)
3675 gcc_assert (ss
!= gfc_ss_terminator
);
3677 /* TODO: Pass constant array constructors without a temporary. */
3678 /* Special case things we know we can pass easily. */
3679 switch (expr
->expr_type
)
3682 /* If we have a linear array section, we can pass it directly.
3683 Otherwise we need to copy it into a temporary. */
3685 /* Find the SS for the array section. */
3687 while (secss
!= gfc_ss_terminator
&& secss
->type
!= GFC_SS_SECTION
)
3688 secss
= secss
->next
;
3690 gcc_assert (secss
!= gfc_ss_terminator
);
3691 info
= &secss
->data
.info
;
3693 /* Get the descriptor for the array. */
3694 gfc_conv_ss_descriptor (&se
->pre
, secss
, 0);
3695 desc
= info
->descriptor
;
3697 need_tmp
= gfc_ref_needs_temporary_p (expr
->ref
);
3700 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
3702 /* Create a new descriptor if the array doesn't have one. */
3705 else if (info
->ref
->u
.ar
.type
== AR_FULL
)
3707 else if (se
->direct_byref
)
3712 gcc_assert (ref
->u
.ar
.type
== AR_SECTION
);
3715 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
3717 /* Detect passing the full array as a section. This could do
3718 even more checking, but it doesn't seem worth it. */
3719 if (ref
->u
.ar
.start
[n
]
3721 || (ref
->u
.ar
.stride
[n
]
3722 && !gfc_expr_is_one (ref
->u
.ar
.stride
[n
], 0)))
3732 if (se
->direct_byref
)
3734 /* Copy the descriptor for pointer assignments. */
3735 gfc_add_modify_expr (&se
->pre
, se
->expr
, desc
);
3737 else if (se
->want_pointer
)
3739 /* We pass full arrays directly. This means that pointers and
3740 allocatable arrays should also work. */
3741 se
->expr
= gfc_build_addr_expr (NULL_TREE
, desc
);
3748 if (expr
->ts
.type
== BT_CHARACTER
)
3749 se
->string_length
= gfc_get_expr_charlen (expr
);
3756 /* A transformational function return value will be a temporary
3757 array descriptor. We still need to go through the scalarizer
3758 to create the descriptor. Elemental functions ar handled as
3759 arbitrary expressions, i.e. copy to a temporary. */
3761 /* Look for the SS for this function. */
3762 while (secss
!= gfc_ss_terminator
3763 && (secss
->type
!= GFC_SS_FUNCTION
|| secss
->expr
!= expr
))
3764 secss
= secss
->next
;
3766 if (se
->direct_byref
)
3768 gcc_assert (secss
!= gfc_ss_terminator
);
3770 /* For pointer assignments pass the descriptor directly. */
3772 se
->expr
= gfc_build_addr_expr (NULL
, se
->expr
);
3773 gfc_conv_expr (se
, expr
);
3777 if (secss
== gfc_ss_terminator
)
3779 /* Elemental function. */
3785 /* Transformational function. */
3786 info
= &secss
->data
.info
;
3792 /* Something complicated. Copy it into a temporary. */
3800 gfc_init_loopinfo (&loop
);
3802 /* Associate the SS with the loop. */
3803 gfc_add_ss_to_loop (&loop
, ss
);
3805 /* Tell the scalarizer not to bother creating loop variables, etc. */
3807 loop
.array_parameter
= 1;
3809 /* The right-hand side of a pointer assignment mustn't use a temporary. */
3810 gcc_assert (!se
->direct_byref
);
3812 /* Setup the scalarizing loops and bounds. */
3813 gfc_conv_ss_startstride (&loop
);
3817 /* Tell the scalarizer to make a temporary. */
3818 loop
.temp_ss
= gfc_get_ss ();
3819 loop
.temp_ss
->type
= GFC_SS_TEMP
;
3820 loop
.temp_ss
->next
= gfc_ss_terminator
;
3821 if (expr
->ts
.type
== BT_CHARACTER
)
3823 gcc_assert (expr
->ts
.cl
&& expr
->ts
.cl
->length
3824 && expr
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
);
3825 loop
.temp_ss
->string_length
= gfc_conv_mpz_to_tree
3826 (expr
->ts
.cl
->length
->value
.integer
,
3827 expr
->ts
.cl
->length
->ts
.kind
);
3828 expr
->ts
.cl
->backend_decl
= loop
.temp_ss
->string_length
;
3830 loop
.temp_ss
->data
.temp
.type
= gfc_typenode_for_spec (&expr
->ts
);
3832 /* ... which can hold our string, if present. */
3833 if (expr
->ts
.type
== BT_CHARACTER
)
3835 loop
.temp_ss
->string_length
= TYPE_SIZE_UNIT (loop
.temp_ss
->data
.temp
.type
);
3836 se
->string_length
= loop
.temp_ss
->string_length
;
3839 loop
.temp_ss
->string_length
= NULL
;
3840 loop
.temp_ss
->data
.temp
.dimen
= loop
.dimen
;
3841 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
3844 gfc_conv_loop_setup (&loop
);
3848 /* Copy into a temporary and pass that. We don't need to copy the data
3849 back because expressions and vector subscripts must be INTENT_IN. */
3850 /* TODO: Optimize passing function return values. */
3854 /* Start the copying loops. */
3855 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
3856 gfc_mark_ss_chain_used (ss
, 1);
3857 gfc_start_scalarized_body (&loop
, &block
);
3859 /* Copy each data element. */
3860 gfc_init_se (&lse
, NULL
);
3861 gfc_copy_loopinfo_to_se (&lse
, &loop
);
3862 gfc_init_se (&rse
, NULL
);
3863 gfc_copy_loopinfo_to_se (&rse
, &loop
);
3865 lse
.ss
= loop
.temp_ss
;
3868 gfc_conv_scalarized_array_ref (&lse
, NULL
);
3869 if (expr
->ts
.type
== BT_CHARACTER
)
3871 gfc_conv_expr (&rse
, expr
);
3872 rse
.expr
= gfc_build_indirect_ref (rse
.expr
);
3875 gfc_conv_expr_val (&rse
, expr
);
3877 gfc_add_block_to_block (&block
, &rse
.pre
);
3878 gfc_add_block_to_block (&block
, &lse
.pre
);
3880 gfc_add_modify_expr (&block
, lse
.expr
, rse
.expr
);
3882 /* Finish the copying loops. */
3883 gfc_trans_scalarizing_loops (&loop
, &block
);
3885 /* Set the first stride component to zero to indicate a temporary. */
3886 desc
= loop
.temp_ss
->data
.info
.descriptor
;
3887 tmp
= gfc_conv_descriptor_stride (desc
, gfc_rank_cst
[0]);
3888 gfc_add_modify_expr (&loop
.pre
, tmp
, gfc_index_zero_node
);
3890 gcc_assert (is_gimple_lvalue (desc
));
3892 else if (expr
->expr_type
== EXPR_FUNCTION
)
3894 desc
= info
->descriptor
;
3895 se
->string_length
= ss
->string_length
;
3899 /* We pass sections without copying to a temporary. Make a new
3900 descriptor and point it at the section we want. The loop variable
3901 limits will be the limits of the section.
3902 A function may decide to repack the array to speed up access, but
3903 we're not bothered about that here. */
3912 /* Set the string_length for a character array. */
3913 if (expr
->ts
.type
== BT_CHARACTER
)
3914 se
->string_length
= gfc_get_expr_charlen (expr
);
3916 desc
= info
->descriptor
;
3917 gcc_assert (secss
&& secss
!= gfc_ss_terminator
);
3918 if (se
->direct_byref
)
3920 /* For pointer assignments we fill in the destination. */
3922 parmtype
= TREE_TYPE (parm
);
3926 /* Otherwise make a new one. */
3927 parmtype
= gfc_get_element_type (TREE_TYPE (desc
));
3928 parmtype
= gfc_get_array_type_bounds (parmtype
, loop
.dimen
,
3929 loop
.from
, loop
.to
, 0);
3930 parm
= gfc_create_var (parmtype
, "parm");
3933 offset
= gfc_index_zero_node
;
3936 /* The following can be somewhat confusing. We have two
3937 descriptors, a new one and the original array.
3938 {parm, parmtype, dim} refer to the new one.
3939 {desc, type, n, secss, loop} refer to the original, which maybe
3940 a descriptorless array.
3941 The bounds of the scalarization are the bounds of the section.
3942 We don't have to worry about numeric overflows when calculating
3943 the offsets because all elements are within the array data. */
3945 /* Set the dtype. */
3946 tmp
= gfc_conv_descriptor_dtype (parm
);
3947 gfc_add_modify_expr (&loop
.pre
, tmp
, gfc_get_dtype (parmtype
));
3949 if (se
->direct_byref
)
3950 base
= gfc_index_zero_node
;
3954 for (n
= 0; n
< info
->ref
->u
.ar
.dimen
; n
++)
3956 stride
= gfc_conv_array_stride (desc
, n
);
3958 /* Work out the offset. */
3959 if (info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
3961 gcc_assert (info
->subscript
[n
]
3962 && info
->subscript
[n
]->type
== GFC_SS_SCALAR
);
3963 start
= info
->subscript
[n
]->data
.scalar
.expr
;
3967 /* Check we haven't somehow got out of sync. */
3968 gcc_assert (info
->dim
[dim
] == n
);
3970 /* Evaluate and remember the start of the section. */
3971 start
= info
->start
[dim
];
3972 stride
= gfc_evaluate_now (stride
, &loop
.pre
);
3975 tmp
= gfc_conv_array_lbound (desc
, n
);
3976 tmp
= fold_build2 (MINUS_EXPR
, TREE_TYPE (tmp
), start
, tmp
);
3978 tmp
= fold_build2 (MULT_EXPR
, TREE_TYPE (tmp
), tmp
, stride
);
3979 offset
= fold_build2 (PLUS_EXPR
, TREE_TYPE (tmp
), offset
, tmp
);
3981 if (info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
3983 /* For elemental dimensions, we only need the offset. */
3987 /* Vector subscripts need copying and are handled elsewhere. */
3988 gcc_assert (info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
);
3990 /* Set the new lower bound. */
3991 from
= loop
.from
[dim
];
3994 /* If we have an array section or are assigning to a pointer,
3995 make sure that the lower bound is 1. References to the full
3996 array should otherwise keep the original bounds. */
3997 if ((info
->ref
->u
.ar
.type
!= AR_FULL
|| se
->direct_byref
)
3998 && !integer_onep (from
))
4000 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
4001 gfc_index_one_node
, from
);
4002 to
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, to
, tmp
);
4003 from
= gfc_index_one_node
;
4005 tmp
= gfc_conv_descriptor_lbound (parm
, gfc_rank_cst
[dim
]);
4006 gfc_add_modify_expr (&loop
.pre
, tmp
, from
);
4008 /* Set the new upper bound. */
4009 tmp
= gfc_conv_descriptor_ubound (parm
, gfc_rank_cst
[dim
]);
4010 gfc_add_modify_expr (&loop
.pre
, tmp
, to
);
4012 /* Multiply the stride by the section stride to get the
4014 stride
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
4015 stride
, info
->stride
[dim
]);
4017 if (se
->direct_byref
)
4018 base
= fold_build2 (MINUS_EXPR
, TREE_TYPE (base
),
4021 /* Store the new stride. */
4022 tmp
= gfc_conv_descriptor_stride (parm
, gfc_rank_cst
[dim
]);
4023 gfc_add_modify_expr (&loop
.pre
, tmp
, stride
);
4028 /* Point the data pointer at the first element in the section. */
4029 tmp
= gfc_conv_array_data (desc
);
4030 tmp
= gfc_build_indirect_ref (tmp
);
4031 tmp
= gfc_build_array_ref (tmp
, offset
);
4032 offset
= gfc_build_addr_expr (gfc_array_dataptr_type (desc
), tmp
);
4033 gfc_conv_descriptor_data_set (&loop
.pre
, parm
, offset
);
4035 if (se
->direct_byref
)
4037 /* Set the offset. */
4038 tmp
= gfc_conv_descriptor_offset (parm
);
4039 gfc_add_modify_expr (&loop
.pre
, tmp
, base
);
4043 /* Only the callee knows what the correct offset it, so just set
4045 tmp
= gfc_conv_descriptor_offset (parm
);
4046 gfc_add_modify_expr (&loop
.pre
, tmp
, gfc_index_zero_node
);
4051 if (!se
->direct_byref
)
4053 /* Get a pointer to the new descriptor. */
4054 if (se
->want_pointer
)
4055 se
->expr
= gfc_build_addr_expr (NULL
, desc
);
4060 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
4061 gfc_add_block_to_block (&se
->post
, &loop
.post
);
4063 /* Cleanup the scalarizer. */
4064 gfc_cleanup_loop (&loop
);
4068 /* Convert an array for passing as an actual parameter. */
4069 /* TODO: Optimize passing g77 arrays. */
4072 gfc_conv_array_parameter (gfc_se
* se
, gfc_expr
* expr
, gfc_ss
* ss
, int g77
)
4081 /* Passing address of the array if it is not pointer or assumed-shape. */
4082 if (expr
->expr_type
== EXPR_VARIABLE
4083 && expr
->ref
->u
.ar
.type
== AR_FULL
&& g77
)
4085 sym
= expr
->symtree
->n
.sym
;
4087 /* Check to see if we're dealing with a Cray Pointee. */
4088 if (sym
->attr
.cray_pointee
)
4089 tmp
= gfc_conv_cray_pointee (sym
);
4091 tmp
= gfc_get_symbol_decl (sym
);
4093 if (sym
->ts
.type
== BT_CHARACTER
)
4094 se
->string_length
= sym
->ts
.cl
->backend_decl
;
4095 if (!sym
->attr
.pointer
&& sym
->as
->type
!= AS_ASSUMED_SHAPE
4096 && !sym
->attr
.allocatable
)
4098 /* Some variables are declared directly, others are declared as
4099 pointers and allocated on the heap. */
4100 if (sym
->attr
.dummy
|| POINTER_TYPE_P (TREE_TYPE (tmp
)))
4103 se
->expr
= gfc_build_addr_expr (NULL
, tmp
);
4106 if (sym
->attr
.allocatable
)
4108 se
->expr
= gfc_conv_array_data (tmp
);
4113 se
->want_pointer
= 1;
4114 gfc_conv_expr_descriptor (se
, expr
, ss
);
4119 /* Repack the array. */
4120 tmp
= gfc_chainon_list (NULL_TREE
, desc
);
4121 ptr
= gfc_build_function_call (gfor_fndecl_in_pack
, tmp
);
4122 ptr
= gfc_evaluate_now (ptr
, &se
->pre
);
4125 gfc_start_block (&block
);
4127 /* Copy the data back. */
4128 tmp
= gfc_chainon_list (NULL_TREE
, desc
);
4129 tmp
= gfc_chainon_list (tmp
, ptr
);
4130 tmp
= gfc_build_function_call (gfor_fndecl_in_unpack
, tmp
);
4131 gfc_add_expr_to_block (&block
, tmp
);
4133 /* Free the temporary. */
4134 tmp
= convert (pvoid_type_node
, ptr
);
4135 tmp
= gfc_chainon_list (NULL_TREE
, tmp
);
4136 tmp
= gfc_build_function_call (gfor_fndecl_internal_free
, tmp
);
4137 gfc_add_expr_to_block (&block
, tmp
);
4139 stmt
= gfc_finish_block (&block
);
4141 gfc_init_block (&block
);
4142 /* Only if it was repacked. This code needs to be executed before the
4143 loop cleanup code. */
4144 tmp
= gfc_build_indirect_ref (desc
);
4145 tmp
= gfc_conv_array_data (tmp
);
4146 tmp
= build2 (NE_EXPR
, boolean_type_node
, ptr
, tmp
);
4147 tmp
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt ());
4149 gfc_add_expr_to_block (&block
, tmp
);
4150 gfc_add_block_to_block (&block
, &se
->post
);
4152 gfc_init_block (&se
->post
);
4153 gfc_add_block_to_block (&se
->post
, &block
);
4158 /* NULLIFY an allocatable/pointer array on function entry, free it on exit. */
4161 gfc_trans_deferred_array (gfc_symbol
* sym
, tree body
)
4168 stmtblock_t fnblock
;
4171 /* Make sure the frontend gets these right. */
4172 if (!(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
4174 ("Possible frontend bug: Deferred array size without pointer or allocatable attribute.");
4176 gfc_init_block (&fnblock
);
4178 gcc_assert (TREE_CODE (sym
->backend_decl
) == VAR_DECL
);
4179 if (sym
->ts
.type
== BT_CHARACTER
4180 && !INTEGER_CST_P (sym
->ts
.cl
->backend_decl
))
4181 gfc_trans_init_string_length (sym
->ts
.cl
, &fnblock
);
4183 /* Dummy and use associated variables don't need anything special. */
4184 if (sym
->attr
.dummy
|| sym
->attr
.use_assoc
)
4186 gfc_add_expr_to_block (&fnblock
, body
);
4188 return gfc_finish_block (&fnblock
);
4191 gfc_get_backend_locus (&loc
);
4192 gfc_set_backend_locus (&sym
->declared_at
);
4193 descriptor
= sym
->backend_decl
;
4195 if (TREE_STATIC (descriptor
))
4197 /* SAVEd variables are not freed on exit. */
4198 gfc_trans_static_array_pointer (sym
);
4202 /* Get the descriptor type. */
4203 type
= TREE_TYPE (sym
->backend_decl
);
4204 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
4206 /* NULLIFY the data pointer. */
4207 gfc_conv_descriptor_data_set (&fnblock
, descriptor
, null_pointer_node
);
4209 gfc_add_expr_to_block (&fnblock
, body
);
4211 gfc_set_backend_locus (&loc
);
4212 /* Allocatable arrays need to be freed when they go out of scope. */
4213 if (sym
->attr
.allocatable
)
4215 gfc_start_block (&block
);
4217 /* Deallocate if still allocated at the end of the procedure. */
4218 deallocate
= gfc_array_deallocate (descriptor
, null_pointer_node
);
4220 tmp
= gfc_conv_descriptor_data_get (descriptor
);
4221 tmp
= build2 (NE_EXPR
, boolean_type_node
, tmp
,
4222 build_int_cst (TREE_TYPE (tmp
), 0));
4223 tmp
= build3_v (COND_EXPR
, tmp
, deallocate
, build_empty_stmt ());
4224 gfc_add_expr_to_block (&block
, tmp
);
4226 tmp
= gfc_finish_block (&block
);
4227 gfc_add_expr_to_block (&fnblock
, tmp
);
4230 return gfc_finish_block (&fnblock
);
4233 /************ Expression Walking Functions ******************/
4235 /* Walk a variable reference.
4237 Possible extension - multiple component subscripts.
4238 x(:,:) = foo%a(:)%b(:)
4240 forall (i=..., j=...)
4241 x(i,j) = foo%a(j)%b(i)
4243 This adds a fair amout of complexity because you need to deal with more
4244 than one ref. Maybe handle in a similar manner to vector subscripts.
4245 Maybe not worth the effort. */
4249 gfc_walk_variable_expr (gfc_ss
* ss
, gfc_expr
* expr
)
4257 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4258 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
4261 for (; ref
; ref
= ref
->next
)
4263 if (ref
->type
== REF_SUBSTRING
)
4265 newss
= gfc_get_ss ();
4266 newss
->type
= GFC_SS_SCALAR
;
4267 newss
->expr
= ref
->u
.ss
.start
;
4271 newss
= gfc_get_ss ();
4272 newss
->type
= GFC_SS_SCALAR
;
4273 newss
->expr
= ref
->u
.ss
.end
;
4278 /* We're only interested in array sections from now on. */
4279 if (ref
->type
!= REF_ARRAY
)
4286 for (n
= 0; n
< ar
->dimen
; n
++)
4288 newss
= gfc_get_ss ();
4289 newss
->type
= GFC_SS_SCALAR
;
4290 newss
->expr
= ar
->start
[n
];
4297 newss
= gfc_get_ss ();
4298 newss
->type
= GFC_SS_SECTION
;
4301 newss
->data
.info
.dimen
= ar
->as
->rank
;
4302 newss
->data
.info
.ref
= ref
;
4304 /* Make sure array is the same as array(:,:), this way
4305 we don't need to special case all the time. */
4306 ar
->dimen
= ar
->as
->rank
;
4307 for (n
= 0; n
< ar
->dimen
; n
++)
4309 newss
->data
.info
.dim
[n
] = n
;
4310 ar
->dimen_type
[n
] = DIMEN_RANGE
;
4312 gcc_assert (ar
->start
[n
] == NULL
);
4313 gcc_assert (ar
->end
[n
] == NULL
);
4314 gcc_assert (ar
->stride
[n
] == NULL
);
4320 newss
= gfc_get_ss ();
4321 newss
->type
= GFC_SS_SECTION
;
4324 newss
->data
.info
.dimen
= 0;
4325 newss
->data
.info
.ref
= ref
;
4329 /* We add SS chains for all the subscripts in the section. */
4330 for (n
= 0; n
< ar
->dimen
; n
++)
4334 switch (ar
->dimen_type
[n
])
4337 /* Add SS for elemental (scalar) subscripts. */
4338 gcc_assert (ar
->start
[n
]);
4339 indexss
= gfc_get_ss ();
4340 indexss
->type
= GFC_SS_SCALAR
;
4341 indexss
->expr
= ar
->start
[n
];
4342 indexss
->next
= gfc_ss_terminator
;
4343 indexss
->loop_chain
= gfc_ss_terminator
;
4344 newss
->data
.info
.subscript
[n
] = indexss
;
4348 /* We don't add anything for sections, just remember this
4349 dimension for later. */
4350 newss
->data
.info
.dim
[newss
->data
.info
.dimen
] = n
;
4351 newss
->data
.info
.dimen
++;
4355 /* Create a GFC_SS_VECTOR index in which we can store
4356 the vector's descriptor. */
4357 indexss
= gfc_get_ss ();
4358 indexss
->type
= GFC_SS_VECTOR
;
4359 indexss
->expr
= ar
->start
[n
];
4360 indexss
->next
= gfc_ss_terminator
;
4361 indexss
->loop_chain
= gfc_ss_terminator
;
4362 newss
->data
.info
.subscript
[n
] = indexss
;
4363 newss
->data
.info
.dim
[newss
->data
.info
.dimen
] = n
;
4364 newss
->data
.info
.dimen
++;
4368 /* We should know what sort of section it is by now. */
4372 /* We should have at least one non-elemental dimension. */
4373 gcc_assert (newss
->data
.info
.dimen
> 0);
4378 /* We should know what sort of section it is by now. */
4387 /* Walk an expression operator. If only one operand of a binary expression is
4388 scalar, we must also add the scalar term to the SS chain. */
4391 gfc_walk_op_expr (gfc_ss
* ss
, gfc_expr
* expr
)
4397 head
= gfc_walk_subexpr (ss
, expr
->value
.op
.op1
);
4398 if (expr
->value
.op
.op2
== NULL
)
4401 head2
= gfc_walk_subexpr (head
, expr
->value
.op
.op2
);
4403 /* All operands are scalar. Pass back and let the caller deal with it. */
4407 /* All operands require scalarization. */
4408 if (head
!= ss
&& (expr
->value
.op
.op2
== NULL
|| head2
!= head
))
4411 /* One of the operands needs scalarization, the other is scalar.
4412 Create a gfc_ss for the scalar expression. */
4413 newss
= gfc_get_ss ();
4414 newss
->type
= GFC_SS_SCALAR
;
4417 /* First operand is scalar. We build the chain in reverse order, so
4418 add the scarar SS after the second operand. */
4420 while (head
&& head
->next
!= ss
)
4422 /* Check we haven't somehow broken the chain. */
4426 newss
->expr
= expr
->value
.op
.op1
;
4428 else /* head2 == head */
4430 gcc_assert (head2
== head
);
4431 /* Second operand is scalar. */
4432 newss
->next
= head2
;
4434 newss
->expr
= expr
->value
.op
.op2
;
4441 /* Reverse a SS chain. */
4444 gfc_reverse_ss (gfc_ss
* ss
)
4449 gcc_assert (ss
!= NULL
);
4451 head
= gfc_ss_terminator
;
4452 while (ss
!= gfc_ss_terminator
)
4455 /* Check we didn't somehow break the chain. */
4456 gcc_assert (next
!= NULL
);
4466 /* Walk the arguments of an elemental function. */
4469 gfc_walk_elemental_function_args (gfc_ss
* ss
, gfc_expr
* expr
,
4472 gfc_actual_arglist
*arg
;
4478 head
= gfc_ss_terminator
;
4481 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
4486 newss
= gfc_walk_subexpr (head
, arg
->expr
);
4489 /* Scalar argument. */
4490 newss
= gfc_get_ss ();
4492 newss
->expr
= arg
->expr
;
4502 while (tail
->next
!= gfc_ss_terminator
)
4509 /* If all the arguments are scalar we don't need the argument SS. */
4510 gfc_free_ss_chain (head
);
4515 /* Add it onto the existing chain. */
4521 /* Walk a function call. Scalar functions are passed back, and taken out of
4522 scalarization loops. For elemental functions we walk their arguments.
4523 The result of functions returning arrays is stored in a temporary outside
4524 the loop, so that the function is only called once. Hence we do not need
4525 to walk their arguments. */
4528 gfc_walk_function_expr (gfc_ss
* ss
, gfc_expr
* expr
)
4531 gfc_intrinsic_sym
*isym
;
4534 isym
= expr
->value
.function
.isym
;
4536 /* Handle intrinsic functions separately. */
4538 return gfc_walk_intrinsic_function (ss
, expr
, isym
);
4540 sym
= expr
->value
.function
.esym
;
4542 sym
= expr
->symtree
->n
.sym
;
4544 /* A function that returns arrays. */
4545 if (gfc_return_by_reference (sym
) && sym
->result
->attr
.dimension
)
4547 newss
= gfc_get_ss ();
4548 newss
->type
= GFC_SS_FUNCTION
;
4551 newss
->data
.info
.dimen
= expr
->rank
;
4555 /* Walk the parameters of an elemental function. For now we always pass
4557 if (sym
->attr
.elemental
)
4558 return gfc_walk_elemental_function_args (ss
, expr
, GFC_SS_REFERENCE
);
4560 /* Scalar functions are OK as these are evaluated outside the scalarization
4561 loop. Pass back and let the caller deal with it. */
4566 /* An array temporary is constructed for array constructors. */
4569 gfc_walk_array_constructor (gfc_ss
* ss
, gfc_expr
* expr
)
4574 newss
= gfc_get_ss ();
4575 newss
->type
= GFC_SS_CONSTRUCTOR
;
4578 newss
->data
.info
.dimen
= expr
->rank
;
4579 for (n
= 0; n
< expr
->rank
; n
++)
4580 newss
->data
.info
.dim
[n
] = n
;
4586 /* Walk an expression. Add walked expressions to the head of the SS chain.
4587 A wholly scalar expression will not be added. */
4590 gfc_walk_subexpr (gfc_ss
* ss
, gfc_expr
* expr
)
4594 switch (expr
->expr_type
)
4597 head
= gfc_walk_variable_expr (ss
, expr
);
4601 head
= gfc_walk_op_expr (ss
, expr
);
4605 head
= gfc_walk_function_expr (ss
, expr
);
4610 case EXPR_STRUCTURE
:
4611 /* Pass back and let the caller deal with it. */
4615 head
= gfc_walk_array_constructor (ss
, expr
);
4618 case EXPR_SUBSTRING
:
4619 /* Pass back and let the caller deal with it. */
4623 internal_error ("bad expression type during walk (%d)",
4630 /* Entry point for expression walking.
4631 A return value equal to the passed chain means this is
4632 a scalar expression. It is up to the caller to take whatever action is
4633 necessary to translate these. */
4636 gfc_walk_expr (gfc_expr
* expr
)
4640 res
= gfc_walk_subexpr (gfc_ss_terminator
, expr
);
4641 return gfc_reverse_ss (res
);