| /* Array translation routines |
| Copyright (C) 2002-2019 Free Software Foundation, Inc. |
| Contributed by Paul Brook <paul@nowt.org> |
| and Steven Bosscher <s.bosscher@student.tudelft.nl> |
| |
| This file is part of GCC. |
| |
| GCC is free software; you can redistribute it and/or modify it under |
| the terms of the GNU General Public License as published by the Free |
| Software Foundation; either version 3, or (at your option) any later |
| version. |
| |
| GCC is distributed in the hope that it will be useful, but WITHOUT ANY |
| WARRANTY; without even the implied warranty of MERCHANTABILITY or |
| FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License |
| for more details. |
| |
| You should have received a copy of the GNU General Public License |
| along with GCC; see the file COPYING3. If not see |
| <http://www.gnu.org/licenses/>. */ |
| |
| /* trans-array.c-- Various array related code, including scalarization, |
| allocation, initialization and other support routines. */ |
| |
| /* How the scalarizer works. |
| In gfortran, array expressions use the same core routines as scalar |
| expressions. |
| First, a Scalarization State (SS) chain is built. This is done by walking |
| the expression tree, and building a linear list of the terms in the |
| expression. As the tree is walked, scalar subexpressions are translated. |
| |
| The scalarization parameters are stored in a gfc_loopinfo structure. |
| First the start and stride of each term is calculated by |
| gfc_conv_ss_startstride. During this process the expressions for the array |
| descriptors and data pointers are also translated. |
| |
| If the expression is an assignment, we must then resolve any dependencies. |
| In Fortran all the rhs values of an assignment must be evaluated before |
| any assignments take place. This can require a temporary array to store the |
| values. We also require a temporary when we are passing array expressions |
| or vector subscripts as procedure parameters. |
| |
| Array sections are passed without copying to a temporary. These use the |
| scalarizer to determine the shape of the section. The flag |
| loop->array_parameter tells the scalarizer that the actual values and loop |
| variables will not be required. |
| |
| The function gfc_conv_loop_setup generates the scalarization setup code. |
| It determines the range of the scalarizing loop variables. If a temporary |
| is required, this is created and initialized. Code for scalar expressions |
| taken outside the loop is also generated at this time. Next the offset and |
| scaling required to translate from loop variables to array indices for each |
| term is calculated. |
| |
| A call to gfc_start_scalarized_body marks the start of the scalarized |
| expression. This creates a scope and declares the loop variables. Before |
| calling this gfc_make_ss_chain_used must be used to indicate which terms |
| will be used inside this loop. |
| |
| The scalar gfc_conv_* functions are then used to build the main body of the |
| scalarization loop. Scalarization loop variables and precalculated scalar |
| values are automatically substituted. Note that gfc_advance_se_ss_chain |
| must be used, rather than changing the se->ss directly. |
| |
| For assignment expressions requiring a temporary two sub loops are |
| generated. The first stores the result of the expression in the temporary, |
| the second copies it to the result. A call to |
| gfc_trans_scalarized_loop_boundary marks the end of the main loop code and |
| the start of the copying loop. The temporary may be less than full rank. |
| |
| Finally gfc_trans_scalarizing_loops is called to generate the implicit do |
| loops. The loops are added to the pre chain of the loopinfo. The post |
| chain may still contain cleanup code. |
| |
| After the loop code has been added into its parent scope gfc_cleanup_loop |
| is called to free all the SS allocated by the scalarizer. */ |
| |
| #include "config.h" |
| #include "system.h" |
| #include "coretypes.h" |
| #include "options.h" |
| #include "tree.h" |
| #include "gfortran.h" |
| #include "gimple-expr.h" |
| #include "trans.h" |
| #include "fold-const.h" |
| #include "constructor.h" |
| #include "trans-types.h" |
| #include "trans-array.h" |
| #include "trans-const.h" |
| #include "dependency.h" |
| |
| static bool gfc_get_array_constructor_size (mpz_t *, gfc_constructor_base); |
| |
| /* The contents of this structure aren't actually used, just the address. */ |
| static gfc_ss gfc_ss_terminator_var; |
| gfc_ss * const gfc_ss_terminator = &gfc_ss_terminator_var; |
| |
| |
| static tree |
| gfc_array_dataptr_type (tree desc) |
| { |
| return (GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc))); |
| } |
| |
| |
| /* Build expressions to access the members of an array descriptor. |
| It's surprisingly easy to mess up here, so never access |
| an array descriptor by "brute force", always use these |
| functions. This also avoids problems if we change the format |
| of an array descriptor. |
| |
| To understand these magic numbers, look at the comments |
| before gfc_build_array_type() in trans-types.c. |
| |
| The code within these defines should be the only code which knows the format |
| of an array descriptor. |
| |
| Any code just needing to read obtain the bounds of an array should use |
| gfc_conv_array_* rather than the following functions as these will return |
| know constant values, and work with arrays which do not have descriptors. |
| |
| Don't forget to #undef these! */ |
| |
| #define DATA_FIELD 0 |
| #define OFFSET_FIELD 1 |
| #define DTYPE_FIELD 2 |
| #define SPAN_FIELD 3 |
| #define DIMENSION_FIELD 4 |
| #define CAF_TOKEN_FIELD 5 |
| |
| #define STRIDE_SUBFIELD 0 |
| #define LBOUND_SUBFIELD 1 |
| #define UBOUND_SUBFIELD 2 |
| |
| /* This provides READ-ONLY access to the data field. The field itself |
| doesn't have the proper type. */ |
| |
| tree |
| gfc_conv_descriptor_data_get (tree desc) |
| { |
| tree field, type, t; |
| |
| type = TREE_TYPE (desc); |
| gcc_assert (GFC_DESCRIPTOR_TYPE_P (type)); |
| |
| field = TYPE_FIELDS (type); |
| gcc_assert (DATA_FIELD == 0); |
| |
| t = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), desc, |
| field, NULL_TREE); |
| t = fold_convert (GFC_TYPE_ARRAY_DATAPTR_TYPE (type), t); |
| |
| return t; |
| } |
| |
| /* This provides WRITE access to the data field. |
| |
| TUPLES_P is true if we are generating tuples. |
| |
| This function gets called through the following macros: |
| gfc_conv_descriptor_data_set |
| gfc_conv_descriptor_data_set. */ |
| |
| void |
| gfc_conv_descriptor_data_set (stmtblock_t *block, tree desc, tree value) |
| { |
| tree field, type, t; |
| |
| type = TREE_TYPE (desc); |
| gcc_assert (GFC_DESCRIPTOR_TYPE_P (type)); |
| |
| field = TYPE_FIELDS (type); |
| gcc_assert (DATA_FIELD == 0); |
| |
| t = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), desc, |
| field, NULL_TREE); |
| gfc_add_modify (block, t, fold_convert (TREE_TYPE (field), value)); |
| } |
| |
| |
| /* This provides address access to the data field. This should only be |
| used by array allocation, passing this on to the runtime. */ |
| |
| tree |
| gfc_conv_descriptor_data_addr (tree desc) |
| { |
| tree field, type, t; |
| |
| type = TREE_TYPE (desc); |
| gcc_assert (GFC_DESCRIPTOR_TYPE_P (type)); |
| |
| field = TYPE_FIELDS (type); |
| gcc_assert (DATA_FIELD == 0); |
| |
| t = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), desc, |
| field, NULL_TREE); |
| return gfc_build_addr_expr (NULL_TREE, t); |
| } |
| |
| static tree |
| gfc_conv_descriptor_offset (tree desc) |
| { |
| tree type; |
| tree field; |
| |
| type = TREE_TYPE (desc); |
| gcc_assert (GFC_DESCRIPTOR_TYPE_P (type)); |
| |
| field = gfc_advance_chain (TYPE_FIELDS (type), OFFSET_FIELD); |
| gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type); |
| |
| return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), |
| desc, field, NULL_TREE); |
| } |
| |
| tree |
| gfc_conv_descriptor_offset_get (tree desc) |
| { |
| return gfc_conv_descriptor_offset (desc); |
| } |
| |
| void |
| gfc_conv_descriptor_offset_set (stmtblock_t *block, tree desc, |
| tree value) |
| { |
| tree t = gfc_conv_descriptor_offset (desc); |
| gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value)); |
| } |
| |
| |
| tree |
| gfc_conv_descriptor_dtype (tree desc) |
| { |
| tree field; |
| tree type; |
| |
| type = TREE_TYPE (desc); |
| gcc_assert (GFC_DESCRIPTOR_TYPE_P (type)); |
| |
| field = gfc_advance_chain (TYPE_FIELDS (type), DTYPE_FIELD); |
| gcc_assert (field != NULL_TREE |
| && TREE_TYPE (field) == get_dtype_type_node ()); |
| |
| return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), |
| desc, field, NULL_TREE); |
| } |
| |
| static tree |
| gfc_conv_descriptor_span (tree desc) |
| { |
| tree type; |
| tree field; |
| |
| type = TREE_TYPE (desc); |
| gcc_assert (GFC_DESCRIPTOR_TYPE_P (type)); |
| |
| field = gfc_advance_chain (TYPE_FIELDS (type), SPAN_FIELD); |
| gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type); |
| |
| return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), |
| desc, field, NULL_TREE); |
| } |
| |
| tree |
| gfc_conv_descriptor_span_get (tree desc) |
| { |
| return gfc_conv_descriptor_span (desc); |
| } |
| |
| void |
| gfc_conv_descriptor_span_set (stmtblock_t *block, tree desc, |
| tree value) |
| { |
| tree t = gfc_conv_descriptor_span (desc); |
| gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value)); |
| } |
| |
| |
| tree |
| gfc_conv_descriptor_rank (tree desc) |
| { |
| tree tmp; |
| tree dtype; |
| |
| dtype = gfc_conv_descriptor_dtype (desc); |
| tmp = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype)), GFC_DTYPE_RANK); |
| gcc_assert (tmp != NULL_TREE |
| && TREE_TYPE (tmp) == signed_char_type_node); |
| return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp), |
| dtype, tmp, NULL_TREE); |
| } |
| |
| |
| /* Return the element length from the descriptor dtype field. */ |
| |
| tree |
| gfc_conv_descriptor_elem_len (tree desc) |
| { |
| tree tmp; |
| tree dtype; |
| |
| dtype = gfc_conv_descriptor_dtype (desc); |
| tmp = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype)), |
| GFC_DTYPE_ELEM_LEN); |
| gcc_assert (tmp != NULL_TREE |
| && TREE_TYPE (tmp) == size_type_node); |
| return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp), |
| dtype, tmp, NULL_TREE); |
| } |
| |
| |
| tree |
| gfc_conv_descriptor_attribute (tree desc) |
| { |
| tree tmp; |
| tree dtype; |
| |
| dtype = gfc_conv_descriptor_dtype (desc); |
| tmp = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype)), |
| GFC_DTYPE_ATTRIBUTE); |
| gcc_assert (tmp!= NULL_TREE |
| && TREE_TYPE (tmp) == short_integer_type_node); |
| return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp), |
| dtype, tmp, NULL_TREE); |
| } |
| |
| |
| tree |
| gfc_get_descriptor_dimension (tree desc) |
| { |
| tree type, field; |
| |
| type = TREE_TYPE (desc); |
| gcc_assert (GFC_DESCRIPTOR_TYPE_P (type)); |
| |
| field = gfc_advance_chain (TYPE_FIELDS (type), DIMENSION_FIELD); |
| gcc_assert (field != NULL_TREE |
| && TREE_CODE (TREE_TYPE (field)) == ARRAY_TYPE |
| && TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == RECORD_TYPE); |
| |
| return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), |
| desc, field, NULL_TREE); |
| } |
| |
| |
| static tree |
| gfc_conv_descriptor_dimension (tree desc, tree dim) |
| { |
| tree tmp; |
| |
| tmp = gfc_get_descriptor_dimension (desc); |
| |
| return gfc_build_array_ref (tmp, dim, NULL); |
| } |
| |
| |
| tree |
| gfc_conv_descriptor_token (tree desc) |
| { |
| tree type; |
| tree field; |
| |
| type = TREE_TYPE (desc); |
| gcc_assert (GFC_DESCRIPTOR_TYPE_P (type)); |
| gcc_assert (flag_coarray == GFC_FCOARRAY_LIB); |
| field = gfc_advance_chain (TYPE_FIELDS (type), CAF_TOKEN_FIELD); |
| |
| /* Should be a restricted pointer - except in the finalization wrapper. */ |
| gcc_assert (field != NULL_TREE |
| && (TREE_TYPE (field) == prvoid_type_node |
| || TREE_TYPE (field) == pvoid_type_node)); |
| |
| return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), |
| desc, field, NULL_TREE); |
| } |
| |
| |
| static tree |
| gfc_conv_descriptor_stride (tree desc, tree dim) |
| { |
| tree tmp; |
| tree field; |
| |
| tmp = gfc_conv_descriptor_dimension (desc, dim); |
| field = TYPE_FIELDS (TREE_TYPE (tmp)); |
| field = gfc_advance_chain (field, STRIDE_SUBFIELD); |
| gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type); |
| |
| tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), |
| tmp, field, NULL_TREE); |
| return tmp; |
| } |
| |
| tree |
| gfc_conv_descriptor_stride_get (tree desc, tree dim) |
| { |
| tree type = TREE_TYPE (desc); |
| gcc_assert (GFC_DESCRIPTOR_TYPE_P (type)); |
| if (integer_zerop (dim) |
| && (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE |
| ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT |
| ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK_CONT |
| ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT)) |
| return gfc_index_one_node; |
| |
| return gfc_conv_descriptor_stride (desc, dim); |
| } |
| |
| void |
| gfc_conv_descriptor_stride_set (stmtblock_t *block, tree desc, |
| tree dim, tree value) |
| { |
| tree t = gfc_conv_descriptor_stride (desc, dim); |
| gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value)); |
| } |
| |
| static tree |
| gfc_conv_descriptor_lbound (tree desc, tree dim) |
| { |
| tree tmp; |
| tree field; |
| |
| tmp = gfc_conv_descriptor_dimension (desc, dim); |
| field = TYPE_FIELDS (TREE_TYPE (tmp)); |
| field = gfc_advance_chain (field, LBOUND_SUBFIELD); |
| gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type); |
| |
| tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), |
| tmp, field, NULL_TREE); |
| return tmp; |
| } |
| |
| tree |
| gfc_conv_descriptor_lbound_get (tree desc, tree dim) |
| { |
| return gfc_conv_descriptor_lbound (desc, dim); |
| } |
| |
| void |
| gfc_conv_descriptor_lbound_set (stmtblock_t *block, tree desc, |
| tree dim, tree value) |
| { |
| tree t = gfc_conv_descriptor_lbound (desc, dim); |
| gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value)); |
| } |
| |
| static tree |
| gfc_conv_descriptor_ubound (tree desc, tree dim) |
| { |
| tree tmp; |
| tree field; |
| |
| tmp = gfc_conv_descriptor_dimension (desc, dim); |
| field = TYPE_FIELDS (TREE_TYPE (tmp)); |
| field = gfc_advance_chain (field, UBOUND_SUBFIELD); |
| gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type); |
| |
| tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), |
| tmp, field, NULL_TREE); |
| return tmp; |
| } |
| |
| tree |
| gfc_conv_descriptor_ubound_get (tree desc, tree dim) |
| { |
| return gfc_conv_descriptor_ubound (desc, dim); |
| } |
| |
| void |
| gfc_conv_descriptor_ubound_set (stmtblock_t *block, tree desc, |
| tree dim, tree value) |
| { |
| tree t = gfc_conv_descriptor_ubound (desc, dim); |
| gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value)); |
| } |
| |
| /* Build a null array descriptor constructor. */ |
| |
| tree |
| gfc_build_null_descriptor (tree type) |
| { |
| tree field; |
| tree tmp; |
| |
| gcc_assert (GFC_DESCRIPTOR_TYPE_P (type)); |
| gcc_assert (DATA_FIELD == 0); |
| field = TYPE_FIELDS (type); |
| |
| /* Set a NULL data pointer. */ |
| tmp = build_constructor_single (type, field, null_pointer_node); |
| TREE_CONSTANT (tmp) = 1; |
| /* All other fields are ignored. */ |
| |
| return tmp; |
| } |
| |
| |
| /* Modify a descriptor such that the lbound of a given dimension is the value |
| specified. This also updates ubound and offset accordingly. */ |
| |
| void |
| gfc_conv_shift_descriptor_lbound (stmtblock_t* block, tree desc, |
| int dim, tree new_lbound) |
| { |
| tree offs, ubound, lbound, stride; |
| tree diff, offs_diff; |
| |
| new_lbound = fold_convert (gfc_array_index_type, new_lbound); |
| |
| offs = gfc_conv_descriptor_offset_get (desc); |
| lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]); |
| ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]); |
| stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[dim]); |
| |
| /* Get difference (new - old) by which to shift stuff. */ |
| diff = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, |
| new_lbound, lbound); |
| |
| /* Shift ubound and offset accordingly. This has to be done before |
| updating the lbound, as they depend on the lbound expression! */ |
| ubound = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, |
| ubound, diff); |
| gfc_conv_descriptor_ubound_set (block, desc, gfc_rank_cst[dim], ubound); |
| offs_diff = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, |
| diff, stride); |
| offs = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, |
| offs, offs_diff); |
| gfc_conv_descriptor_offset_set (block, desc, offs); |
| |
| /* Finally set lbound to value we want. */ |
| gfc_conv_descriptor_lbound_set (block, desc, gfc_rank_cst[dim], new_lbound); |
| } |
| |
| |
| /* Obtain offsets for trans-types.c(gfc_get_array_descr_info). */ |
| |
| void |
| gfc_get_descriptor_offsets_for_info (const_tree desc_type, tree *data_off, |
| tree *dtype_off, tree *span_off, |
| tree *dim_off, tree *dim_size, |
| tree *stride_suboff, tree *lower_suboff, |
| tree *upper_suboff) |
| { |
| tree field; |
| tree type; |
| |
| type = TYPE_MAIN_VARIANT (desc_type); |
| field = gfc_advance_chain (TYPE_FIELDS (type), DATA_FIELD); |
| *data_off = byte_position (field); |
| field = gfc_advance_chain (TYPE_FIELDS (type), DTYPE_FIELD); |
| *dtype_off = byte_position (field); |
| field = gfc_advance_chain (TYPE_FIELDS (type), SPAN_FIELD); |
| *span_off = byte_position (field); |
| field = gfc_advance_chain (TYPE_FIELDS (type), DIMENSION_FIELD); |
| *dim_off = byte_position (field); |
| type = TREE_TYPE (TREE_TYPE (field)); |
| *dim_size = TYPE_SIZE_UNIT (type); |
| field = gfc_advance_chain (TYPE_FIELDS (type), STRIDE_SUBFIELD); |
| *stride_suboff = byte_position (field); |
| field = gfc_advance_chain (TYPE_FIELDS (type), LBOUND_SUBFIELD); |
| *lower_suboff = byte_position (field); |
| field = gfc_advance_chain (TYPE_FIELDS (type), UBOUND_SUBFIELD); |
| *upper_suboff = byte_position (field); |
| } |
| |
| |
| /* Cleanup those #defines. */ |
| |
| #undef DATA_FIELD |
| #undef OFFSET_FIELD |
| #undef DTYPE_FIELD |
| #undef SPAN_FIELD |
| #undef DIMENSION_FIELD |
| #undef CAF_TOKEN_FIELD |
| #undef STRIDE_SUBFIELD |
| #undef LBOUND_SUBFIELD |
| #undef UBOUND_SUBFIELD |
| |
| |
| /* Mark a SS chain as used. Flags specifies in which loops the SS is used. |
| flags & 1 = Main loop body. |
| flags & 2 = temp copy loop. */ |
| |
| void |
| gfc_mark_ss_chain_used (gfc_ss * ss, unsigned flags) |
| { |
| for (; ss != gfc_ss_terminator; ss = ss->next) |
| ss->info->useflags = flags; |
| } |
| |
| |
| /* Free a gfc_ss chain. */ |
| |
| void |
| gfc_free_ss_chain (gfc_ss * ss) |
| { |
| gfc_ss *next; |
| |
| while (ss != gfc_ss_terminator) |
| { |
| gcc_assert (ss != NULL); |
| next = ss->next; |
| gfc_free_ss (ss); |
| ss = next; |
| } |
| } |
| |
| |
| static void |
| free_ss_info (gfc_ss_info *ss_info) |
| { |
| int n; |
| |
| ss_info->refcount--; |
| if (ss_info->refcount > 0) |
| return; |
| |
| gcc_assert (ss_info->refcount == 0); |
| |
| switch (ss_info->type) |
| { |
| case GFC_SS_SECTION: |
| for (n = 0; n < GFC_MAX_DIMENSIONS; n++) |
| if (ss_info->data.array.subscript[n]) |
| gfc_free_ss_chain (ss_info->data.array.subscript[n]); |
| break; |
| |
| default: |
| break; |
| } |
| |
| free (ss_info); |
| } |
| |
| |
| /* Free a SS. */ |
| |
| void |
| gfc_free_ss (gfc_ss * ss) |
| { |
| free_ss_info (ss->info); |
| free (ss); |
| } |
| |
| |
| /* Creates and initializes an array type gfc_ss struct. */ |
| |
| gfc_ss * |
| gfc_get_array_ss (gfc_ss *next, gfc_expr *expr, int dimen, gfc_ss_type type) |
| { |
| gfc_ss *ss; |
| gfc_ss_info *ss_info; |
| int i; |
| |
| ss_info = gfc_get_ss_info (); |
| ss_info->refcount++; |
| ss_info->type = type; |
| ss_info->expr = expr; |
| |
| ss = gfc_get_ss (); |
| ss->info = ss_info; |
| ss->next = next; |
| ss->dimen = dimen; |
| for (i = 0; i < ss->dimen; i++) |
| ss->dim[i] = i; |
| |
| return ss; |
| } |
| |
| |
| /* Creates and initializes a temporary type gfc_ss struct. */ |
| |
| gfc_ss * |
| gfc_get_temp_ss (tree type, tree string_length, int dimen) |
| { |
| gfc_ss *ss; |
| gfc_ss_info *ss_info; |
| int i; |
| |
| ss_info = gfc_get_ss_info (); |
| ss_info->refcount++; |
| ss_info->type = GFC_SS_TEMP; |
| ss_info->string_length = string_length; |
| ss_info->data.temp.type = type; |
| |
| ss = gfc_get_ss (); |
| ss->info = ss_info; |
| ss->next = gfc_ss_terminator; |
| ss->dimen = dimen; |
| for (i = 0; i < ss->dimen; i++) |
| ss->dim[i] = i; |
| |
| return ss; |
| } |
| |
| |
| /* Creates and initializes a scalar type gfc_ss struct. */ |
| |
| gfc_ss * |
| gfc_get_scalar_ss (gfc_ss *next, gfc_expr *expr) |
| { |
| gfc_ss *ss; |
| gfc_ss_info *ss_info; |
| |
| ss_info = gfc_get_ss_info (); |
| ss_info->refcount++; |
| ss_info->type = GFC_SS_SCALAR; |
| ss_info->expr = expr; |
| |
| ss = gfc_get_ss (); |
| ss->info = ss_info; |
| ss->next = next; |
| |
| return ss; |
| } |
| |
| |
| /* Free all the SS associated with a loop. */ |
| |
| void |
| gfc_cleanup_loop (gfc_loopinfo * loop) |
| { |
| gfc_loopinfo *loop_next, **ploop; |
| gfc_ss *ss; |
| gfc_ss *next; |
| |
| ss = loop->ss; |
| while (ss != gfc_ss_terminator) |
| { |
| gcc_assert (ss != NULL); |
| next = ss->loop_chain; |
| gfc_free_ss (ss); |
| ss = next; |
| } |
| |
| /* Remove reference to self in the parent loop. */ |
| if (loop->parent) |
| for (ploop = &loop->parent->nested; *ploop; ploop = &(*ploop)->next) |
| if (*ploop == loop) |
| { |
| *ploop = loop->next; |
| break; |
| } |
| |
| /* Free non-freed nested loops. */ |
| for (loop = loop->nested; loop; loop = loop_next) |
| { |
| loop_next = loop->next; |
| gfc_cleanup_loop (loop); |
| free (loop); |
| } |
| } |
| |
| |
| static void |
| set_ss_loop (gfc_ss *ss, gfc_loopinfo *loop) |
| { |
| int n; |
| |
| for (; ss != gfc_ss_terminator; ss = ss->next) |
| { |
| ss->loop = loop; |
| |
| if (ss->info->type == GFC_SS_SCALAR |
| || ss->info->type == GFC_SS_REFERENCE |
| || ss->info->type == GFC_SS_TEMP) |
| continue; |
| |
| for (n = 0; n < GFC_MAX_DIMENSIONS; n++) |
| if (ss->info->data.array.subscript[n] != NULL) |
| set_ss_loop (ss->info->data.array.subscript[n], loop); |
| } |
| } |
| |
| |
| /* Associate a SS chain with a loop. */ |
| |
| void |
| gfc_add_ss_to_loop (gfc_loopinfo * loop, gfc_ss * head) |
| { |
| gfc_ss *ss; |
| gfc_loopinfo *nested_loop; |
| |
| if (head == gfc_ss_terminator) |
| return; |
| |
| set_ss_loop (head, loop); |
| |
| ss = head; |
| for (; ss && ss != gfc_ss_terminator; ss = ss->next) |
| { |
| if (ss->nested_ss) |
| { |
| nested_loop = ss->nested_ss->loop; |
| |
| /* More than one ss can belong to the same loop. Hence, we add the |
| loop to the chain only if it is different from the previously |
| added one, to avoid duplicate nested loops. */ |
| if (nested_loop != loop->nested) |
| { |
| gcc_assert (nested_loop->parent == NULL); |
| nested_loop->parent = loop; |
| |
| gcc_assert (nested_loop->next == NULL); |
| nested_loop->next = loop->nested; |
| loop->nested = nested_loop; |
| } |
| else |
| gcc_assert (nested_loop->parent == loop); |
| } |
| |
| if (ss->next == gfc_ss_terminator) |
| ss->loop_chain = loop->ss; |
| else |
| ss->loop_chain = ss->next; |
| } |
| gcc_assert (ss == gfc_ss_terminator); |
| loop->ss = head; |
| } |
| |
| |
| /* Returns true if the expression is an array pointer. */ |
| |
| static bool |
| is_pointer_array (tree expr) |
| { |
| if (expr == NULL_TREE |
| || !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (expr)) |
| || GFC_CLASS_TYPE_P (TREE_TYPE (expr))) |
| return false; |
| |
| if (TREE_CODE (expr) == VAR_DECL |
| && GFC_DECL_PTR_ARRAY_P (expr)) |
| return true; |
| |
| if (TREE_CODE (expr) == PARM_DECL |
| && GFC_DECL_PTR_ARRAY_P (expr)) |
| return true; |
| |
| if (TREE_CODE (expr) == INDIRECT_REF |
| && GFC_DECL_PTR_ARRAY_P (TREE_OPERAND (expr, 0))) |
| return true; |
| |
| /* The field declaration is marked as an pointer array. */ |
| if (TREE_CODE (expr) == COMPONENT_REF |
| && GFC_DECL_PTR_ARRAY_P (TREE_OPERAND (expr, 1)) |
| && !GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (expr, 1)))) |
| return true; |
| |
| return false; |
| } |
| |
| |
| /* If the symbol or expression reference a CFI descriptor, return the |
| pointer to the converted gfc descriptor. If an array reference is |
| present as the last argument, check that it is the one applied to |
| the CFI descriptor in the expression. Note that the CFI object is |
| always the symbol in the expression! */ |
| |
| static bool |
| get_CFI_desc (gfc_symbol *sym, gfc_expr *expr, |
| tree *desc, gfc_array_ref *ar) |
| { |
| tree tmp; |
| |
| if (!is_CFI_desc (sym, expr)) |
| return false; |
| |
| if (expr && ar) |
| { |
| if (!(expr->ref && expr->ref->type == REF_ARRAY) |
| || (&expr->ref->u.ar != ar)) |
| return false; |
| } |
| |
| if (sym == NULL) |
| tmp = expr->symtree->n.sym->backend_decl; |
| else |
| tmp = sym->backend_decl; |
| |
| if (tmp && DECL_LANG_SPECIFIC (tmp)) |
| tmp = GFC_DECL_SAVED_DESCRIPTOR (tmp); |
| |
| *desc = tmp; |
| return true; |
| } |
| |
| |
| /* Return the span of an array. */ |
| |
| tree |
| gfc_get_array_span (tree desc, gfc_expr *expr) |
| { |
| tree tmp; |
| |
| if (is_pointer_array (desc) || get_CFI_desc (NULL, expr, &desc, NULL)) |
| { |
| if (POINTER_TYPE_P (TREE_TYPE (desc))) |
| desc = build_fold_indirect_ref_loc (input_location, desc); |
| |
| /* This will have the span field set. */ |
| tmp = gfc_conv_descriptor_span_get (desc); |
| } |
| else if (TREE_CODE (desc) == COMPONENT_REF |
| && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)) |
| && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (desc, 0)))) |
| { |
| /* The descriptor is a class _data field and so use the vtable |
| size for the receiving span field. */ |
| tmp = gfc_get_vptr_from_expr (desc); |
| tmp = gfc_vptr_size_get (tmp); |
| } |
| else if (expr && expr->expr_type == EXPR_VARIABLE |
| && expr->symtree->n.sym->ts.type == BT_CLASS |
| && expr->ref->type == REF_COMPONENT |
| && expr->ref->next->type == REF_ARRAY |
| && expr->ref->next->next == NULL |
| && CLASS_DATA (expr->symtree->n.sym)->attr.dimension) |
| { |
| /* Dummys come in sometimes with the descriptor detached from |
| the class field or declaration. */ |
| tmp = gfc_class_vptr_get (expr->symtree->n.sym->backend_decl); |
| tmp = gfc_vptr_size_get (tmp); |
| } |
| else |
| { |
| /* If none of the fancy stuff works, the span is the element |
| size of the array. Attempt to deal with unbounded character |
| types if possible. Otherwise, return NULL_TREE. */ |
| tmp = gfc_get_element_type (TREE_TYPE (desc)); |
| if (tmp && TREE_CODE (tmp) == ARRAY_TYPE |
| && (TYPE_MAX_VALUE (TYPE_DOMAIN (tmp)) == NULL_TREE |
| || integer_zerop (TYPE_MAX_VALUE (TYPE_DOMAIN (tmp))))) |
| { |
| if (expr->expr_type == EXPR_VARIABLE |
| && expr->ts.type == BT_CHARACTER) |
| tmp = fold_convert (gfc_array_index_type, |
| gfc_get_expr_charlen (expr)); |
| else |
| tmp = NULL_TREE; |
| } |
| else |
| tmp = fold_convert (gfc_array_index_type, |
| size_in_bytes (tmp)); |
| } |
| return tmp; |
| } |
| |
| |
| /* Generate an initializer for a static pointer or allocatable array. */ |
| |
| void |
| gfc_trans_static_array_pointer (gfc_symbol * sym) |
| { |
| tree type; |
| |
| gcc_assert (TREE_STATIC (sym->backend_decl)); |
| /* Just zero the data member. */ |
| type = TREE_TYPE (sym->backend_decl); |
| DECL_INITIAL (sym->backend_decl) = gfc_build_null_descriptor (type); |
| } |
| |
| |
| /* If the bounds of SE's loop have not yet been set, see if they can be |
| determined from array spec AS, which is the array spec of a called |
| function. MAPPING maps the callee's dummy arguments to the values |
| that the caller is passing. Add any initialization and finalization |
| code to SE. */ |
| |
| void |
| gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping * mapping, |
| gfc_se * se, gfc_array_spec * as) |
| { |
| int n, dim, total_dim; |
| gfc_se tmpse; |
| gfc_ss *ss; |
| tree lower; |
| tree upper; |
| tree tmp; |
| |
| total_dim = 0; |
| |
| if (!as || as->type != AS_EXPLICIT) |
| return; |
| |
| for (ss = se->ss; ss; ss = ss->parent) |
| { |
| total_dim += ss->loop->dimen; |
| for (n = 0; n < ss->loop->dimen; n++) |
| { |
| /* The bound is known, nothing to do. */ |
| if (ss->loop->to[n] != NULL_TREE) |
| continue; |
| |
| dim = ss->dim[n]; |
| gcc_assert (dim < as->rank); |
| gcc_assert (ss->loop->dimen <= as->rank); |
| |
| /* Evaluate the lower bound. */ |
| gfc_init_se (&tmpse, NULL); |
| gfc_apply_interface_mapping (mapping, &tmpse, as->lower[dim]); |
| gfc_add_block_to_block (&se->pre, &tmpse.pre); |
| gfc_add_block_to_block (&se->post, &tmpse.post); |
| lower = fold_convert (gfc_array_index_type, tmpse.expr); |
| |
| /* ...and the upper bound. */ |
| gfc_init_se (&tmpse, NULL); |
| gfc_apply_interface_mapping (mapping, &tmpse, as->upper[dim]); |
| gfc_add_block_to_block (&se->pre, &tmpse.pre); |
| gfc_add_block_to_block (&se->post, &tmpse.post); |
| upper = fold_convert (gfc_array_index_type, tmpse.expr); |
| |
| /* Set the upper bound of the loop to UPPER - LOWER. */ |
| tmp = fold_build2_loc (input_location, MINUS_EXPR, |
| gfc_array_index_type, upper, lower); |
| tmp = gfc_evaluate_now (tmp, &se->pre); |
| ss->loop->to[n] = tmp; |
| } |
| } |
| |
| gcc_assert (total_dim == as->rank); |
| } |
| |
| |
| /* Generate code to allocate an array temporary, or create a variable to |
| hold the data. If size is NULL, zero the descriptor so that the |
| callee will allocate the array. If DEALLOC is true, also generate code to |
| free the array afterwards. |
| |
| If INITIAL is not NULL, it is packed using internal_pack and the result used |
| as data instead of allocating a fresh, unitialized area of memory. |
| |
| Initialization code is added to PRE and finalization code to POST. |
| DYNAMIC is true if the caller may want to extend the array later |
| using realloc. This prevents us from putting the array on the stack. */ |
| |
| static void |
| gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post, |
| gfc_array_info * info, tree size, tree nelem, |
| tree initial, bool dynamic, bool dealloc) |
| { |
| tree tmp; |
| tree desc; |
| bool onstack; |
| |
| desc = info->descriptor; |
| info->offset = gfc_index_zero_node; |
| if (size == NULL_TREE || integer_zerop (size)) |
| { |
| /* A callee allocated array. */ |
| gfc_conv_descriptor_data_set (pre, desc, null_pointer_node); |
| onstack = FALSE; |
| } |
| else |
| { |
| /* Allocate the temporary. */ |
| onstack = !dynamic && initial == NULL_TREE |
| && (flag_stack_arrays |
| || gfc_can_put_var_on_stack (size)); |
| |
| if (onstack) |
| { |
| /* Make a temporary variable to hold the data. */ |
| tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (nelem), |
| nelem, gfc_index_one_node); |
| tmp = gfc_evaluate_now (tmp, pre); |
| tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, |
| tmp); |
| tmp = build_array_type (gfc_get_element_type (TREE_TYPE (desc)), |
| tmp); |
| tmp = gfc_create_var (tmp, "A"); |
| /* If we're here only because of -fstack-arrays we have to |
| emit a DECL_EXPR to make the gimplifier emit alloca calls. */ |
| if (!gfc_can_put_var_on_stack (size)) |
| gfc_add_expr_to_block (pre, |
| fold_build1_loc (input_location, |
| DECL_EXPR, TREE_TYPE (tmp), |
| tmp)); |
| tmp = gfc_build_addr_expr (NULL_TREE, tmp); |
| gfc_conv_descriptor_data_set (pre, desc, tmp); |
| } |
| else |
| { |
| /* Allocate memory to hold the data or call internal_pack. */ |
| if (initial == NULL_TREE) |
| { |
| tmp = gfc_call_malloc (pre, NULL, size); |
| tmp = gfc_evaluate_now (tmp, pre); |
| } |
| else |
| { |
| tree packed; |
| tree source_data; |
| tree was_packed; |
| stmtblock_t do_copying; |
| |
| tmp = TREE_TYPE (initial); /* Pointer to descriptor. */ |
| gcc_assert (TREE_CODE (tmp) == POINTER_TYPE); |
| tmp = TREE_TYPE (tmp); /* The descriptor itself. */ |
| tmp = gfc_get_element_type (tmp); |
| gcc_assert (tmp == gfc_get_element_type (TREE_TYPE (desc))); |
| packed = gfc_create_var (build_pointer_type (tmp), "data"); |
| |
| tmp = build_call_expr_loc (input_location, |
| gfor_fndecl_in_pack, 1, initial); |
| tmp = fold_convert (TREE_TYPE (packed), tmp); |
| gfc_add_modify (pre, packed, tmp); |
| |
| tmp = build_fold_indirect_ref_loc (input_location, |
| initial); |
| source_data = gfc_conv_descriptor_data_get (tmp); |
| |
| /* internal_pack may return source->data without any allocation |
| or copying if it is already packed. If that's the case, we |
| need to allocate and copy manually. */ |
| |
| gfc_start_block (&do_copying); |
| tmp = gfc_call_malloc (&do_copying, NULL, size); |
| tmp = fold_convert (TREE_TYPE (packed), tmp); |
| gfc_add_modify (&do_copying, packed, tmp); |
| tmp = gfc_build_memcpy_call (packed, source_data, size); |
| gfc_add_expr_to_block (&do_copying, tmp); |
| |
| was_packed = fold_build2_loc (input_location, EQ_EXPR, |
| logical_type_node, packed, |
| source_data); |
| tmp = gfc_finish_block (&do_copying); |
| tmp = build3_v (COND_EXPR, was_packed, tmp, |
| build_empty_stmt (input_location)); |
| gfc_add_expr_to_block (pre, tmp); |
| |
| tmp = fold_convert (pvoid_type_node, packed); |
| } |
| |
| gfc_conv_descriptor_data_set (pre, desc, tmp); |
| } |
| } |
| info->data = gfc_conv_descriptor_data_get (desc); |
| |
| /* The offset is zero because we create temporaries with a zero |
| lower bound. */ |
| gfc_conv_descriptor_offset_set (pre, desc, gfc_index_zero_node); |
| |
| if (dealloc && !onstack) |
| { |
| /* Free the temporary. */ |
| tmp = gfc_conv_descriptor_data_get (desc); |
| tmp = gfc_call_free (tmp); |
| gfc_add_expr_to_block (post, tmp); |
| } |
| } |
| |
| |
| /* Get the scalarizer array dimension corresponding to actual array dimension |
| given by ARRAY_DIM. |
| |
| For example, if SS represents the array ref a(1,:,:,1), it is a |
| bidimensional scalarizer array, and the result would be 0 for ARRAY_DIM=1, |
| and 1 for ARRAY_DIM=2. |
| If SS represents transpose(a(:,1,1,:)), it is again a bidimensional |
| scalarizer array, and the result would be 1 for ARRAY_DIM=0 and 0 for |
| ARRAY_DIM=3. |
| If SS represents sum(a(:,:,:,1), dim=1), it is a 2+1-dimensional scalarizer |
| array. If called on the inner ss, the result would be respectively 0,1,2 for |
| ARRAY_DIM=0,1,2. If called on the outer ss, the result would be 0,1 |
| for ARRAY_DIM=1,2. */ |
| |
| static int |
| get_scalarizer_dim_for_array_dim (gfc_ss *ss, int array_dim) |
| { |
| int array_ref_dim; |
| int n; |
| |
| array_ref_dim = 0; |
| |
| for (; ss; ss = ss->parent) |
| for (n = 0; n < ss->dimen; n++) |
| if (ss->dim[n] < array_dim) |
| array_ref_dim++; |
| |
| return array_ref_dim; |
| } |
| |
| |
| static gfc_ss * |
| innermost_ss (gfc_ss *ss) |
| { |
| while (ss->nested_ss != NULL) |
| ss = ss->nested_ss; |
| |
| return ss; |
| } |
| |
| |
| |
| /* Get the array reference dimension corresponding to the given loop dimension. |
| It is different from the true array dimension given by the dim array in |
| the case of a partial array reference (i.e. a(:,:,1,:) for example) |
| It is different from the loop dimension in the case of a transposed array. |
| */ |
| |
| static int |
| get_array_ref_dim_for_loop_dim (gfc_ss *ss, int loop_dim) |
| { |
| return get_scalarizer_dim_for_array_dim (innermost_ss (ss), |
| ss->dim[loop_dim]); |
| } |
| |
| |
| /* Generate code to create and initialize the descriptor for a temporary |
| array. This is used for both temporaries needed by the scalarizer, and |
| functions returning arrays. Adjusts the loop variables to be |
| zero-based, and calculates the loop bounds for callee allocated arrays. |
| Allocate the array unless it's callee allocated (we have a callee |
| allocated array if 'callee_alloc' is true, or if loop->to[n] is |
| NULL_TREE for any n). Also fills in the descriptor, data and offset |
| fields of info if known. Returns the size of the array, or NULL for a |
| callee allocated array. |
| |
| 'eltype' == NULL signals that the temporary should be a class object. |
| The 'initial' expression is used to obtain the size of the dynamic |
| type; otherwise the allocation and initialization proceeds as for any |
| other expression |
| |
| PRE, POST, INITIAL, DYNAMIC and DEALLOC are as for |
| gfc_trans_allocate_array_storage. */ |
| |
| tree |
| gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss, |
| tree eltype, tree initial, bool dynamic, |
| bool dealloc, bool callee_alloc, locus * where) |
| { |
| gfc_loopinfo *loop; |
| gfc_ss *s; |
| gfc_array_info *info; |
| tree from[GFC_MAX_DIMENSIONS], to[GFC_MAX_DIMENSIONS]; |
| tree type; |
| tree desc; |
| tree tmp; |
| tree size; |
| tree nelem; |
| tree cond; |
| tree or_expr; |
| tree elemsize; |
| tree class_expr = NULL_TREE; |
| int n, dim, tmp_dim; |
| int total_dim = 0; |
| |
| /* This signals a class array for which we need the size of the |
| dynamic type. Generate an eltype and then the class expression. */ |
| if (eltype == NULL_TREE && initial) |
| { |
| gcc_assert (POINTER_TYPE_P (TREE_TYPE (initial))); |
| class_expr = build_fold_indirect_ref_loc (input_location, initial); |
| eltype = TREE_TYPE (class_expr); |
| eltype = gfc_get_element_type (eltype); |
| /* Obtain the structure (class) expression. */ |
| class_expr = TREE_OPERAND (class_expr, 0); |
| gcc_assert (class_expr); |
| } |
| |
| memset (from, 0, sizeof (from)); |
| memset (to, 0, sizeof (to)); |
| |
| info = &ss->info->data.array; |
| |
| gcc_assert (ss->dimen > 0); |
| gcc_assert (ss->loop->dimen == ss->dimen); |
| |
| if (warn_array_temporaries && where) |
| gfc_warning (OPT_Warray_temporaries, |
| "Creating array temporary at %L", where); |
| |
| /* Set the lower bound to zero. */ |
| for (s = ss; s; s = s->parent) |
| { |
| loop = s->loop; |
| |
| total_dim += loop->dimen; |
| for (n = 0; n < loop->dimen; n++) |
| { |
| dim = s->dim[n]; |
| |
| /* Callee allocated arrays may not have a known bound yet. */ |
| if (loop->to[n]) |
| loop->to[n] = gfc_evaluate_now ( |
| fold_build2_loc (input_location, MINUS_EXPR, |
| gfc_array_index_type, |
| loop->to[n], loop->from[n]), |
| pre); |
| loop->from[n] = gfc_index_zero_node; |
| |
| /* We have just changed the loop bounds, we must clear the |
| corresponding specloop, so that delta calculation is not skipped |
| later in gfc_set_delta. */ |
| loop->specloop[n] = NULL; |
| |
| /* We are constructing the temporary's descriptor based on the loop |
| dimensions. As the dimensions may be accessed in arbitrary order |
| (think of transpose) the size taken from the n'th loop may not map |
| to the n'th dimension of the array. We need to reconstruct loop |
| infos in the right order before using it to set the descriptor |
| bounds. */ |
| tmp_dim = get_scalarizer_dim_for_array_dim (ss, dim); |
| from[tmp_dim] = loop->from[n]; |
| to[tmp_dim] = loop->to[n]; |
| |
| info->delta[dim] = gfc_index_zero_node; |
| info->start[dim] = gfc_index_zero_node; |
| info->end[dim] = gfc_index_zero_node; |
| info->stride[dim] = gfc_index_one_node; |
| } |
| } |
| |
| /* Initialize the descriptor. */ |
| type = |
| gfc_get_array_type_bounds (eltype, total_dim, 0, from, to, 1, |
| GFC_ARRAY_UNKNOWN, true); |
| desc = gfc_create_var (type, "atmp"); |
| GFC_DECL_PACKED_ARRAY (desc) = 1; |
| |
| info->descriptor = desc; |
| size = gfc_index_one_node; |
| |
| /* Emit a DECL_EXPR for the variable sized array type in |
| GFC_TYPE_ARRAY_DATAPTR_TYPE so the gimplification of its type |
| sizes works correctly. */ |
| tree arraytype = TREE_TYPE (GFC_TYPE_ARRAY_DATAPTR_TYPE (type)); |
| if (! TYPE_NAME (arraytype)) |
| TYPE_NAME (arraytype) = build_decl (UNKNOWN_LOCATION, TYPE_DECL, |
| NULL_TREE, arraytype); |
| gfc_add_expr_to_block (pre, build1 (DECL_EXPR, |
| arraytype, TYPE_NAME (arraytype))); |
| |
| /* Fill in the array dtype. */ |
| tmp = gfc_conv_descriptor_dtype (desc); |
| gfc_add_modify (pre, tmp, gfc_get_dtype (TREE_TYPE (desc))); |
| |
| /* |
| Fill in the bounds and stride. This is a packed array, so: |
| |
| size = 1; |
| for (n = 0; n < rank; n++) |
| { |
| stride[n] = size |
| delta = ubound[n] + 1 - lbound[n]; |
| size = size * delta; |
| } |
| size = size * sizeof(element); |
| */ |
| |
| or_expr = NULL_TREE; |
| |
| /* If there is at least one null loop->to[n], it is a callee allocated |
| array. */ |
| for (n = 0; n < total_dim; n++) |
| if (to[n] == NULL_TREE) |
| { |
| size = NULL_TREE; |
| break; |
| } |
| |
| if (size == NULL_TREE) |
| for (s = ss; s; s = s->parent) |
| for (n = 0; n < s->loop->dimen; n++) |
| { |
| dim = get_scalarizer_dim_for_array_dim (ss, s->dim[n]); |
| |
| /* For a callee allocated array express the loop bounds in terms |
| of the descriptor fields. */ |
| tmp = fold_build2_loc (input_location, |
| MINUS_EXPR, gfc_array_index_type, |
| gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]), |
| gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim])); |
| s->loop->to[n] = tmp; |
| } |
| else |
| { |
| for (n = 0; n < total_dim; n++) |
| { |
| /* Store the stride and bound components in the descriptor. */ |
| gfc_conv_descriptor_stride_set (pre, desc, gfc_rank_cst[n], size); |
| |
| gfc_conv_descriptor_lbound_set (pre, desc, gfc_rank_cst[n], |
| gfc_index_zero_node); |
| |
| gfc_conv_descriptor_ubound_set (pre, desc, gfc_rank_cst[n], to[n]); |
| |
| tmp = fold_build2_loc (input_location, PLUS_EXPR, |
| gfc_array_index_type, |
| to[n], gfc_index_one_node); |
| |
| /* Check whether the size for this dimension is negative. */ |
| cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node, |
| tmp, gfc_index_zero_node); |
| cond = gfc_evaluate_now (cond, pre); |
| |
| if (n == 0) |
| or_expr = cond; |
| else |
| or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR, |
| logical_type_node, or_expr, cond); |
| |
| size = fold_build2_loc (input_location, MULT_EXPR, |
| gfc_array_index_type, size, tmp); |
| size = gfc_evaluate_now (size, pre); |
| } |
| } |
| |
| if (class_expr == NULL_TREE) |
| elemsize = fold_convert (gfc_array_index_type, |
| TYPE_SIZE_UNIT (gfc_get_element_type (type))); |
| else |
| elemsize = gfc_class_vtab_size_get (class_expr); |
| |
| /* Get the size of the array. */ |
| if (size && !callee_alloc) |
| { |
| /* If or_expr is true, then the extent in at least one |
| dimension is zero and the size is set to zero. */ |
| size = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type, |
| or_expr, gfc_index_zero_node, size); |
| |
| nelem = size; |
| size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, |
| size, elemsize); |
| } |
| else |
| { |
| nelem = size; |
| size = NULL_TREE; |
| } |
| |
| /* Set the span. */ |
| tmp = fold_convert (gfc_array_index_type, elemsize); |
| gfc_conv_descriptor_span_set (pre, desc, tmp); |
| |
| gfc_trans_allocate_array_storage (pre, post, info, size, nelem, initial, |
| dynamic, dealloc); |
| |
| while (ss->parent) |
| ss = ss->parent; |
| |
| if (ss->dimen > ss->loop->temp_dim) |
| ss->loop->temp_dim = ss->dimen; |
| |
| return size; |
| } |
| |
| |
| /* Return the number of iterations in a loop that starts at START, |
| ends at END, and has step STEP. */ |
| |
| static tree |
| gfc_get_iteration_count (tree start, tree end, tree step) |
| { |
| tree tmp; |
| tree type; |
| |
| type = TREE_TYPE (step); |
| tmp = fold_build2_loc (input_location, MINUS_EXPR, type, end, start); |
| tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR, type, tmp, step); |
| tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp, |
| build_int_cst (type, 1)); |
| tmp = fold_build2_loc (input_location, MAX_EXPR, type, tmp, |
| build_int_cst (type, 0)); |
| return fold_convert (gfc_array_index_type, tmp); |
| } |
| |
| |
| /* Extend the data in array DESC by EXTRA elements. */ |
| |
| static void |
| gfc_grow_array (stmtblock_t * pblock, tree desc, tree extra) |
| { |
| tree arg0, arg1; |
| tree tmp; |
| tree size; |
| tree ubound; |
| |
| if (integer_zerop (extra)) |
| return; |
| |
| ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[0]); |
| |
| /* Add EXTRA to the upper bound. */ |
| tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, |
| ubound, extra); |
| gfc_conv_descriptor_ubound_set (pblock, desc, gfc_rank_cst[0], tmp); |
| |
| /* Get the value of the current data pointer. */ |
| arg0 = gfc_conv_descriptor_data_get (desc); |
| |
| /* Calculate the new array size. */ |
| size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc))); |
| tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, |
| ubound, gfc_index_one_node); |
| arg1 = fold_build2_loc (input_location, MULT_EXPR, size_type_node, |
| fold_convert (size_type_node, tmp), |
| fold_convert (size_type_node, size)); |
| |
| /* Call the realloc() function. */ |
| tmp = gfc_call_realloc (pblock, arg0, arg1); |
| gfc_conv_descriptor_data_set (pblock, desc, tmp); |
| } |
| |
| |
| /* Return true if the bounds of iterator I can only be determined |
| at run time. */ |
| |
| static inline bool |
| gfc_iterator_has_dynamic_bounds (gfc_iterator * i) |
| { |
| return (i->start->expr_type != EXPR_CONSTANT |
| || i->end->expr_type != EXPR_CONSTANT |
| || i->step->expr_type != EXPR_CONSTANT); |
| } |
| |
| |
| /* Split the size of constructor element EXPR into the sum of two terms, |
| one of which can be determined at compile time and one of which must |
| be calculated at run time. Set *SIZE to the former and return true |
| if the latter might be nonzero. */ |
| |
| static bool |
| gfc_get_array_constructor_element_size (mpz_t * size, gfc_expr * expr) |
| { |
| if (expr->expr_type == EXPR_ARRAY) |
| return gfc_get_array_constructor_size (size, expr->value.constructor); |
| else if (expr->rank > 0) |
| { |
| /* Calculate everything at run time. */ |
| mpz_set_ui (*size, 0); |
| return true; |
| } |
| else |
| { |
| /* A single element. */ |
| mpz_set_ui (*size, 1); |
| return false; |
| } |
| } |
| |
| |
| /* Like gfc_get_array_constructor_element_size, but applied to the whole |
| of array constructor C. */ |
| |
| static bool |
| gfc_get_array_constructor_size (mpz_t * size, gfc_constructor_base base) |
| { |
| gfc_constructor *c; |
| gfc_iterator *i; |
| mpz_t val; |
| mpz_t len; |
| bool dynamic; |
| |
| mpz_set_ui (*size, 0); |
| mpz_init (len); |
| mpz_init (val); |
| |
| dynamic = false; |
| for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c)) |
| { |
| i = c->iterator; |
| if (i && gfc_iterator_has_dynamic_bounds (i)) |
| dynamic = true; |
| else |
| { |
| dynamic |= gfc_get_array_constructor_element_size (&len, c->expr); |
| if (i) |
| { |
| /* Multiply the static part of the element size by the |
| number of iterations. */ |
| mpz_sub (val, i->end->value.integer, i->start->value.integer); |
| mpz_fdiv_q (val, val, i->step->value.integer); |
| mpz_add_ui (val, val, 1); |
| if (mpz_sgn (val) > 0) |
| mpz_mul (len, len, val); |
| else |
| mpz_set_ui (len, 0); |
| } |
| mpz_add (*size, *size, len); |
| } |
| } |
| mpz_clear (len); |
| mpz_clear (val); |
| return dynamic; |
| } |
| |
| |
| /* Make sure offset is a variable. */ |
| |
| static void |
| gfc_put_offset_into_var (stmtblock_t * pblock, tree * poffset, |
| tree * offsetvar) |
| { |
| /* We should have already created the offset variable. We cannot |
| create it here because we may be in an inner scope. */ |
| gcc_assert (*offsetvar != NULL_TREE); |
| gfc_add_modify (pblock, *offsetvar, *poffset); |
| *poffset = *offsetvar; |
| TREE_USED (*offsetvar) = 1; |
| } |
| |
| |
| /* Variables needed for bounds-checking. */ |
| static bool first_len; |
| static tree first_len_val; |
| static bool typespec_chararray_ctor; |
| |
| static void |
| gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc, |
| tree offset, gfc_se * se, gfc_expr * expr) |
| { |
| tree tmp; |
| |
| gfc_conv_expr (se, expr); |
| |
| /* Store the value. */ |
| tmp = build_fold_indirect_ref_loc (input_location, |
| gfc_conv_descriptor_data_get (desc)); |
| tmp = gfc_build_array_ref (tmp, offset, NULL); |
| |
| if (expr->ts.type == BT_CHARACTER) |
| { |
| int i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false); |
| tree esize; |
| |
| esize = size_in_bytes (gfc_get_element_type (TREE_TYPE (desc))); |
| esize = fold_convert (gfc_charlen_type_node, esize); |
| esize = fold_build2_loc (input_location, TRUNC_DIV_EXPR, |
| TREE_TYPE (esize), esize, |
| build_int_cst (TREE_TYPE (esize), |
| gfc_character_kinds[i].bit_size / 8)); |
| |
| gfc_conv_string_parameter (se); |
| if (POINTER_TYPE_P (TREE_TYPE (tmp))) |
| { |
| /* The temporary is an array of pointers. */ |
| se->expr = fold_convert (TREE_TYPE (tmp), se->expr); |
| gfc_add_modify (&se->pre, tmp, se->expr); |
| } |
| else |
| { |
| /* The temporary is an array of string values. */ |
| tmp = gfc_build_addr_expr (gfc_get_pchar_type (expr->ts.kind), tmp); |
| /* We know the temporary and the value will be the same length, |
| so can use memcpy. */ |
| gfc_trans_string_copy (&se->pre, esize, tmp, expr->ts.kind, |
| se->string_length, se->expr, expr->ts.kind); |
| } |
| if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !typespec_chararray_ctor) |
| { |
| if (first_len) |
| { |
| gfc_add_modify (&se->pre, first_len_val, |
| fold_convert (TREE_TYPE (first_len_val), |
| se->string_length)); |
| first_len = false; |
| } |
| else |
| { |
| /* Verify that all constructor elements are of the same |
| length. */ |
| tree rhs = fold_convert (TREE_TYPE (first_len_val), |
| se->string_length); |
| tree cond = fold_build2_loc (input_location, NE_EXPR, |
| logical_type_node, first_len_val, |
| rhs); |
| gfc_trans_runtime_check |
| (true, false, cond, &se->pre, &expr->where, |
| "Different CHARACTER lengths (%ld/%ld) in array constructor", |
| fold_convert (long_integer_type_node, first_len_val), |
| fold_convert (long_integer_type_node, se->string_length)); |
| } |
| } |
| } |
| else if (GFC_CLASS_TYPE_P (TREE_TYPE (se->expr)) |
| && !GFC_CLASS_TYPE_P (gfc_get_element_type (TREE_TYPE (desc)))) |
| { |
| /* Assignment of a CLASS array constructor to a derived type array. */ |
| if (expr->expr_type == EXPR_FUNCTION) |
| se->expr = gfc_evaluate_now (se->expr, pblock); |
| se->expr = gfc_class_data_get (se->expr); |
| se->expr = build_fold_indirect_ref_loc (input_location, se->expr); |
| se->expr = fold_convert (TREE_TYPE (tmp), se->expr); |
| gfc_add_modify (&se->pre, tmp, se->expr); |
| } |
| else |
| { |
| /* TODO: Should the frontend already have done this conversion? */ |
| se->expr = fold_convert (TREE_TYPE (tmp), se->expr); |
| gfc_add_modify (&se->pre, tmp, se->expr); |
| } |
| |
| gfc_add_block_to_block (pblock, &se->pre); |
| gfc_add_block_to_block (pblock, &se->post); |
| } |
| |
| |
| /* Add the contents of an array to the constructor. DYNAMIC is as for |
| gfc_trans_array_constructor_value. */ |
| |
| static void |
| gfc_trans_array_constructor_subarray (stmtblock_t * pblock, |
| tree type ATTRIBUTE_UNUSED, |
| tree desc, gfc_expr * expr, |
| tree * poffset, tree * offsetvar, |
| bool dynamic) |
| { |
| gfc_se se; |
| gfc_ss *ss; |
| gfc_loopinfo loop; |
| stmtblock_t body; |
| tree tmp; |
| tree size; |
| int n; |
| |
| /* We need this to be a variable so we can increment it. */ |
| gfc_put_offset_into_var (pblock, poffset, offsetvar); |
| |
| gfc_init_se (&se, NULL); |
| |
| /* Walk the array expression. */ |
| ss = gfc_walk_expr (expr); |
| gcc_assert (ss != gfc_ss_terminator); |
| |
| /* Initialize the scalarizer. */ |
| gfc_init_loopinfo (&loop); |
| gfc_add_ss_to_loop (&loop, ss); |
| |
| /* Initialize the loop. */ |
| gfc_conv_ss_startstride (&loop); |
| gfc_conv_loop_setup (&loop, &expr->where); |
| |
| /* Make sure the constructed array has room for the new data. */ |
| if (dynamic) |
| { |
| /* Set SIZE to the total number of elements in the subarray. */ |
| size = gfc_index_one_node; |
| for (n = 0; n < loop.dimen; n++) |
| { |
| tmp = gfc_get_iteration_count (loop.from[n], loop.to[n], |
| gfc_index_one_node); |
| size = fold_build2_loc (input_location, MULT_EXPR, |
| gfc_array_index_type, size, tmp); |
| } |
| |
| /* Grow the constructed array by SIZE elements. */ |
| gfc_grow_array (&loop.pre, desc, size); |
| } |
| |
| /* Make the loop body. */ |
| gfc_mark_ss_chain_used (ss, 1); |
| gfc_start_scalarized_body (&loop, &body); |
| gfc_copy_loopinfo_to_se (&se, &loop); |
| se.ss = ss; |
| |
| gfc_trans_array_ctor_element (&body, desc, *poffset, &se, expr); |
| gcc_assert (se.ss == gfc_ss_terminator); |
| |
| /* Increment the offset. */ |
| tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, |
| *poffset, gfc_index_one_node); |
| gfc_add_modify (&body, *poffset, tmp); |
| |
| /* Finish the loop. */ |
| gfc_trans_scalarizing_loops (&loop, &body); |
| gfc_add_block_to_block (&loop.pre, &loop.post); |
| tmp = gfc_finish_block (&loop.pre); |
| gfc_add_expr_to_block (pblock, tmp); |
| |
| gfc_cleanup_loop (&loop); |
| } |
| |
| |
| /* Assign the values to the elements of an array constructor. DYNAMIC |
| is true if descriptor DESC only contains enough data for the static |
| size calculated by gfc_get_array_constructor_size. When true, memory |
| for the dynamic parts must be allocated using realloc. */ |
| |
| static void |
| gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type, |
| tree desc, gfc_constructor_base base, |
| tree * poffset, tree * offsetvar, |
| bool dynamic) |
| { |
| tree tmp; |
| tree start = NULL_TREE; |
| tree end = NULL_TREE; |
| tree step = NULL_TREE; |
| stmtblock_t body; |
| gfc_se se; |
| mpz_t size; |
| gfc_constructor *c; |
| |
| tree shadow_loopvar = NULL_TREE; |
| gfc_saved_var saved_loopvar; |
| |
| mpz_init (size); |
| for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c)) |
| { |
| /* If this is an iterator or an array, the offset must be a variable. */ |
| if ((c->iterator || c->expr->rank > 0) && INTEGER_CST_P (*poffset)) |
| gfc_put_offset_into_var (pblock, poffset, offsetvar); |
| |
| /* Shadowing the iterator avoids changing its value and saves us from |
| keeping track of it. Further, it makes sure that there's always a |
| backend-decl for the symbol, even if there wasn't one before, |
| e.g. in the case of an iterator that appears in a specification |
| expression in an interface mapping. */ |
| if (c->iterator) |
| { |
| gfc_symbol *sym; |
| tree type; |
| |
| /* Evaluate loop bounds before substituting the loop variable |
| in case they depend on it. Such a case is invalid, but it is |
| not more expensive to do the right thing here. |
| See PR 44354. */ |
| gfc_init_se (&se, NULL); |
| gfc_conv_expr_val (&se, c->iterator->start); |
| gfc_add_block_to_block (pblock, &se.pre); |
| start = gfc_evaluate_now (se.expr, pblock); |
| |
| gfc_init_se (&se, NULL); |
| gfc_conv_expr_val (&se, c->iterator->end); |
| gfc_add_block_to_block (pblock, &se.pre); |
| end = gfc_evaluate_now (se.expr, pblock); |
| |
| gfc_init_se (&se, NULL); |
| gfc_conv_expr_val (&se, c->iterator->step); |
| gfc_add_block_to_block (pblock, &se.pre); |
| step = gfc_evaluate_now (se.expr, pblock); |
| |
| sym = c->iterator->var->symtree->n.sym; |
| type = gfc_typenode_for_spec (&sym->ts); |
| |
| shadow_loopvar = gfc_create_var (type, "shadow_loopvar"); |
| gfc_shadow_sym (sym, shadow_loopvar, &saved_loopvar); |
| } |
| |
| gfc_start_block (&body); |
| |
| if (c->expr->expr_type == EXPR_ARRAY) |
| { |
| /* Array constructors can be nested. */ |
| gfc_trans_array_constructor_value (&body, type, desc, |
| c->expr->value.constructor, |
| poffset, offsetvar, dynamic); |
| } |
| else if (c->expr->rank > 0) |
| { |
| gfc_trans_array_constructor_subarray (&body, type, desc, c->expr, |
| poffset, offsetvar, dynamic); |
| } |
| else |
| { |
| /* This code really upsets the gimplifier so don't bother for now. */ |
| gfc_constructor *p; |
| HOST_WIDE_INT n; |
| HOST_WIDE_INT size; |
| |
| p = c; |
| n = 0; |
| while (p && !(p->iterator || p->expr->expr_type != EXPR_CONSTANT)) |
| { |
| p = gfc_constructor_next (p); |
| n++; |
| } |
| if (n < 4) |
| { |
| /* Scalar values. */ |
| gfc_init_se (&se, NULL); |
| gfc_trans_array_ctor_element (&body, desc, *poffset, |
| &se, c->expr); |
| |
| *poffset = fold_build2_loc (input_location, PLUS_EXPR, |
| gfc_array_index_type, |
| *poffset, gfc_index_one_node); |
| } |
| else |
| { |
| /* Collect multiple scalar constants into a constructor. */ |
| vec<constructor_elt, va_gc> *v = NULL; |
| tree init; |
| tree bound; |
| tree tmptype; |
| HOST_WIDE_INT idx = 0; |
| |
| p = c; |
| /* Count the number of consecutive scalar constants. */ |
| while (p && !(p->iterator |
| || p->expr->expr_type != EXPR_CONSTANT)) |
| { |
| gfc_init_se (&se, NULL); |
| gfc_conv_constant (&se, p->expr); |
| |
| if (c->expr->ts.type != BT_CHARACTER) |
| se.expr = fold_convert (type, se.expr); |
| /* For constant character array constructors we build |
| an array of pointers. */ |
| else if (POINTER_TYPE_P (type)) |
| se.expr = gfc_build_addr_expr |
| (gfc_get_pchar_type (p->expr->ts.kind), |
| se.expr); |
| |
| CONSTRUCTOR_APPEND_ELT (v, |
| build_int_cst (gfc_array_index_type, |
| idx++), |
| se.expr); |
| c = p; |
| p = gfc_constructor_next (p); |
| } |
| |
| bound = size_int (n - 1); |
| /* Create an array type to hold them. */ |
| tmptype = build_range_type (gfc_array_index_type, |
| gfc_index_zero_node, bound); |
| tmptype = build_array_type (type, tmptype); |
| |
| init = build_constructor (tmptype, v); |
| TREE_CONSTANT (init) = 1; |
| TREE_STATIC (init) = 1; |
| /* Create a static variable to hold the data. */ |
| tmp = gfc_create_var (tmptype, "data"); |
| TREE_STATIC (tmp) = 1; |
| TREE_CONSTANT (tmp) = 1; |
| TREE_READONLY (tmp) = 1; |
| DECL_INITIAL (tmp) = init; |
| init = tmp; |
| |
| /* Use BUILTIN_MEMCPY to assign the values. */ |
| tmp = gfc_conv_descriptor_data_get (desc); |
| tmp = build_fold_indirect_ref_loc (input_location, |
| tmp); |
| tmp = gfc_build_array_ref (tmp, *poffset, NULL); |
| tmp = gfc_build_addr_expr (NULL_TREE, tmp); |
| init = gfc_build_addr_expr (NULL_TREE, init); |
| |
| size = TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type)); |
| bound = build_int_cst (size_type_node, n * size); |
| tmp = build_call_expr_loc (input_location, |
| builtin_decl_explicit (BUILT_IN_MEMCPY), |
| 3, tmp, init, bound); |
| gfc_add_expr_to_block (&body, tmp); |
| |
| *poffset = fold_build2_loc (input_location, PLUS_EXPR, |
| gfc_array_index_type, *poffset, |
| build_int_cst (gfc_array_index_type, n)); |
| } |
| if (!INTEGER_CST_P (*poffset)) |
| { |
| gfc_add_modify (&body, *offsetvar, *poffset); |
| *poffset = *offsetvar; |
| } |
| } |
| |
| /* The frontend should already have done any expansions |
| at compile-time. */ |
| if (!c->iterator) |
| { |
| /* Pass the code as is. */ |
| tmp = gfc_finish_block (&body); |
| gfc_add_expr_to_block (pblock, tmp); |
| } |
| else |
| { |
| /* Build the implied do-loop. */ |
| stmtblock_t implied_do_block; |
| tree cond; |
| tree exit_label; |
| tree loopbody; |
| tree tmp2; |
| |
| loopbody = gfc_finish_block (&body); |
| |
| /* Create a new block that holds the implied-do loop. A temporary |
| loop-variable is used. */ |
| gfc_start_block(&implied_do_block); |
| |
| /* Initialize the loop. */ |
| gfc_add_modify (&implied_do_block, shadow_loopvar, start); |
| |
| /* If this array expands dynamically, and the number of iterations |
| is not constant, we won't have allocated space for the static |
| part of C->EXPR's size. Do that now. */ |
| if (dynamic && gfc_iterator_has_dynamic_bounds (c->iterator)) |
| { |
| /* Get the number of iterations. */ |
| tmp = gfc_get_iteration_count (shadow_loopvar, end, step); |
| |
| /* Get the static part of C->EXPR's size. */ |
| gfc_get_array_constructor_element_size (&size, c->expr); |
| tmp2 = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind); |
| |
| /* Grow the array by TMP * TMP2 elements. */ |
| tmp = fold_build2_loc (input_location, MULT_EXPR, |
| gfc_array_index_type, tmp, tmp2); |
| gfc_grow_array (&implied_do_block, desc, tmp); |
| } |
| |
| /* Generate the loop body. */ |
| exit_label = gfc_build_label_decl (NULL_TREE); |
| gfc_start_block (&body); |
| |
| /* Generate the exit condition. Depending on the sign of |
| the step variable we have to generate the correct |
| comparison. */ |
| tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node, |
| step, build_int_cst (TREE_TYPE (step), 0)); |
| cond = fold_build3_loc (input_location, COND_EXPR, |
| logical_type_node, tmp, |
| fold_build2_loc (input_location, GT_EXPR, |
| logical_type_node, shadow_loopvar, end), |
| fold_build2_loc (input_location, LT_EXPR, |
| logical_type_node, shadow_loopvar, end)); |
| tmp = build1_v (GOTO_EXPR, exit_label); |
| TREE_USED (exit_label) = 1; |
| tmp = build3_v (COND_EXPR, cond, tmp, |
| build_empty_stmt (input_location)); |
| gfc_add_expr_to_block (&body, tmp); |
| |
| /* The main loop body. */ |
| gfc_add_expr_to_block (&body, loopbody); |
| |
| /* Increase loop variable by step. */ |
| tmp = fold_build2_loc (input_location, PLUS_EXPR, |
| TREE_TYPE (shadow_loopvar), shadow_loopvar, |
| step); |
| gfc_add_modify (&body, shadow_loopvar, tmp); |
| |
| /* Finish the loop. */ |
| tmp = gfc_finish_block (&body); |
| tmp = build1_v (LOOP_EXPR, tmp); |
| gfc_add_expr_to_block (&implied_do_block, tmp); |
| |
| /* Add the exit label. */ |
| tmp = build1_v (LABEL_EXPR, exit_label); |
| gfc_add_expr_to_block (&implied_do_block, tmp); |
| |
| /* Finish the implied-do loop. */ |
| tmp = gfc_finish_block(&implied_do_block); |
| gfc_add_expr_to_block(pblock, tmp); |
| |
| gfc_restore_sym (c->iterator->var->symtree->n.sym, &saved_loopvar); |
| } |
| } |
| mpz_clear (size); |
| } |
| |
| |
| /* The array constructor code can create a string length with an operand |
| in the form of a temporary variable. This variable will retain its |
| context (current_function_decl). If we store this length tree in a |
| gfc_charlen structure which is shared by a variable in another |
| context, the resulting gfc_charlen structure with a variable in a |
| different context, we could trip the assertion in expand_expr_real_1 |
| when it sees that a variable has been created in one context and |
| referenced in another. |
| |
| If this might be the case, we create a new gfc_charlen structure and |
| link it into the current namespace. */ |
| |
| static void |
| store_backend_decl (gfc_charlen **clp, tree len, bool force_new_cl) |
| { |
| if (force_new_cl) |
| { |
| gfc_charlen *new_cl = gfc_new_charlen (gfc_current_ns, *clp); |
| *clp = new_cl; |
| } |
| (*clp)->backend_decl = len; |
| } |
| |
| /* A catch-all to obtain the string length for anything that is not |
| a substring of non-constant length, a constant, array or variable. */ |
| |
| static void |
| get_array_ctor_all_strlen (stmtblock_t *block, gfc_expr *e, tree *len) |
| { |
| gfc_se se; |
| |
| /* Don't bother if we already know the length is a constant. */ |
| if (*len && INTEGER_CST_P (*len)) |
| return; |
| |
| if (!e->ref && e->ts.u.cl && e->ts.u.cl->length |
| && e->ts.u.cl->length->expr_type == EXPR_CONSTANT) |
| { |
| /* This is easy. */ |
| gfc_conv_const_charlen (e->ts.u.cl); |
| *len = e->ts.u.cl->backend_decl; |
| } |
| else |
| { |
| /* Otherwise, be brutal even if inefficient. */ |
| gfc_init_se (&se, NULL); |
| |
| /* No function call, in case of side effects. */ |
| se.no_function_call = 1; |
| if (e->rank == 0) |
| gfc_conv_expr (&se, e); |
| else |
| gfc_conv_expr_descriptor (&se, e); |
| |
| /* Fix the value. */ |
| *len = gfc_evaluate_now (se.string_length, &se.pre); |
| |
| gfc_add_block_to_block (block, &se.pre); |
| gfc_add_block_to_block (block, &se.post); |
| |
| store_backend_decl (&e->ts.u.cl, *len, true); |
| } |
| } |
| |
| |
| /* Figure out the string length of a variable reference expression. |
| Used by get_array_ctor_strlen. */ |
| |
| static void |
| get_array_ctor_var_strlen (stmtblock_t *block, gfc_expr * expr, tree * len) |
| { |
| gfc_ref *ref; |
| gfc_typespec *ts; |
| mpz_t char_len; |
| |
| /* Don't bother if we already know the length is a constant. */ |
| if (*len && INTEGER_CST_P (*len)) |
| return; |
| |
| ts = &expr->symtree->n.sym->ts; |
| for (ref = expr->ref; ref; ref = ref->next) |
| { |
| switch (ref->type) |
| { |
| case REF_ARRAY: |
| /* Array references don't change the string length. */ |
| if (ts->deferred) |
| get_array_ctor_all_strlen (block, expr, len); |
| break; |
| |
| case REF_COMPONENT: |
| /* Use the length of the component. */ |
| ts = &ref->u.c.component->ts; |
| break; |
| |
| case REF_SUBSTRING: |
| if (ref->u.ss.end == NULL |
| || ref->u.ss.start->expr_type != EXPR_CONSTANT |
| || ref->u.ss.end->expr_type != EXPR_CONSTANT) |
| { |
| /* Note that this might evaluate expr. */ |
| get_array_ctor_all_strlen (block, expr, len); |
| return; |
| } |
| mpz_init_set_ui (char_len, 1); |
| mpz_add (char_len, char_len, ref->u.ss.end->value.integer); |
| mpz_sub (char_len, char_len, ref->u.ss.start->value.integer); |
| *len = gfc_conv_mpz_to_tree_type (char_len, gfc_charlen_type_node); |
| mpz_clear (char_len); |
| return; |
| |
| case REF_INQUIRY: |
| break; |
| |
| default: |
| gcc_unreachable (); |
| } |
| } |
| |
| *len = ts->u.cl->backend_decl; |
| } |
| |
| |
| /* Figure out the string length of a character array constructor. |
| If len is NULL, don't calculate the length; this happens for recursive calls |
| when a sub-array-constructor is an element but not at the first position, |
| so when we're not interested in the length. |
| Returns TRUE if all elements are character constants. */ |
| |
| bool |
| get_array_ctor_strlen (stmtblock_t *block, gfc_constructor_base base, tree * len) |
| { |
| gfc_constructor *c; |
| bool is_const; |
| |
| is_const = TRUE; |
| |
| if (gfc_constructor_first (base) == NULL) |
| { |
| if (len) |
| *len = build_int_cstu (gfc_charlen_type_node, 0); |
| return is_const; |
| } |
| |
| /* Loop over all constructor elements to find out is_const, but in len we |
| want to store the length of the first, not the last, element. We can |
| of course exit the loop as soon as is_const is found to be false. */ |
| for (c = gfc_constructor_first (base); |
| c && is_const; c = gfc_constructor_next (c)) |
| { |
| switch (c->expr->expr_type) |
| { |
| case EXPR_CONSTANT: |
| if (len && !(*len && INTEGER_CST_P (*len))) |
| *len = build_int_cstu (gfc_charlen_type_node, |
| c->expr->value.character.length); |
| break; |
| |
| case EXPR_ARRAY: |
| if (!get_array_ctor_strlen (block, c->expr->value.constructor, len)) |
| is_const = false; |
| break; |
| |
| case EXPR_VARIABLE: |
| is_const = false; |
| if (len) |
| get_array_ctor_var_strlen (block, c->expr, len); |
| break; |
| |
| default: |
| is_const = false; |
| if (len) |
| get_array_ctor_all_strlen (block, c->expr, len); |
| break; |
| } |
| |
| /* After the first iteration, we don't want the length modified. */ |
| len = NULL; |
| } |
| |
| return is_const; |
| } |
| |
| /* Check whether the array constructor C consists entirely of constant |
| elements, and if so returns the number of those elements, otherwise |
| return zero. Note, an empty or NULL array constructor returns zero. */ |
| |
| unsigned HOST_WIDE_INT |
| gfc_constant_array_constructor_p (gfc_constructor_base base) |
| { |
| unsigned HOST_WIDE_INT nelem = 0; |
| |
| gfc_constructor *c = gfc_constructor_first (base); |
| while (c) |
| { |
| if (c->iterator |
| || c->expr->rank > 0 |
| || c->expr->expr_type != EXPR_CONSTANT) |
| return 0; |
| c = gfc_constructor_next (c); |
| nelem++; |
| } |
| return nelem; |
| } |
| |
| |
| /* Given EXPR, the constant array constructor specified by an EXPR_ARRAY, |
| and the tree type of it's elements, TYPE, return a static constant |
| variable that is compile-time initialized. */ |
| |
| tree |
| gfc_build_constant_array_constructor (gfc_expr * expr, tree type) |
| { |
| tree tmptype, init, tmp; |
| HOST_WIDE_INT nelem; |
| gfc_constructor *c; |
| gfc_array_spec as; |
| gfc_se se; |
| int i; |
| vec<constructor_elt, va_gc> *v = NULL; |
| |
| /* First traverse the constructor list, converting the constants |
| to tree to build an initializer. */ |
| nelem = 0; |
| c = gfc_constructor_first (expr->value.constructor); |
| while (c) |
| { |
| gfc_init_se (&se, NULL); |
| gfc_conv_constant (&se, c->expr); |
| if (c->expr->ts.type != BT_CHARACTER) |
| se.expr = fold_convert (type, se.expr); |
| else if (POINTER_TYPE_P (type)) |
| se.expr = gfc_build_addr_expr (gfc_get_pchar_type (c->expr->ts.kind), |
| se.expr); |
| CONSTRUCTOR_APPEND_ELT (v, build_int_cst (gfc_array_index_type, nelem), |
| se.expr); |
| c = gfc_constructor_next (c); |
| nelem++; |
| } |
| |
| /* Next determine the tree type for the array. We use the gfortran |
| front-end's gfc_get_nodesc_array_type in order to create a suitable |
| GFC_ARRAY_TYPE_P that may be used by the scalarizer. */ |
| |
| memset (&as, 0, sizeof (gfc_array_spec)); |
| |
| as.rank = expr->rank; |
| as.type = AS_EXPLICIT; |
| if (!expr->shape) |
| { |
| as.lower[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0); |
| as.upper[0] = gfc_get_int_expr (gfc_default_integer_kind, |
| NULL, nelem - 1); |
| } |
| else |
| for (i = 0; i < expr->rank; i++) |
| { |
| int tmp = (int) mpz_get_si (expr->shape[i]); |
| as.lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0); |
| as.upper[i] = gfc_get_int_expr (gfc_default_integer_kind, |
| NULL, tmp - 1); |
| } |
| |
| tmptype = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC, true); |
| |
| /* as is not needed anymore. */ |
| for (i = 0; i < as.rank + as.corank; i++) |
| { |
| gfc_free_expr (as.lower[i]); |
| gfc_free_expr (as.upper[i]); |
| } |
| |
| init = build_constructor (tmptype, v); |
| |
| TREE_CONSTANT (init) = 1; |
| TREE_STATIC (init) = 1; |
| |
| tmp = build_decl (input_location, VAR_DECL, create_tmp_var_name ("A"), |
| tmptype); |
| DECL_ARTIFICIAL (tmp) = 1; |
| DECL_IGNORED_P (tmp) = 1; |
| TREE_STATIC (tmp) = 1; |
| TREE_CONSTANT (tmp) = 1; |
| TREE_READONLY (tmp) = 1; |
| DECL_INITIAL (tmp) = init; |
| pushdecl (tmp); |
| |
| return tmp; |
| } |
| |
| |
| /* Translate a constant EXPR_ARRAY array constructor for the scalarizer. |
| This mostly initializes the scalarizer state info structure with the |
| appropriate values to directly use the array created by the function |
| gfc_build_constant_array_constructor. */ |
| |
| static void |
| trans_constant_array_constructor (gfc_ss * ss, tree type) |
| { |
| gfc_array_info *info; |
| tree tmp; |
| int i; |
| |
| tmp = gfc_build_constant_array_constructor (ss->info->expr, type); |
| |
| info = &ss->info->data.array; |
| |
| info->descriptor = tmp; |
| info->data = gfc_build_addr_expr (NULL_TREE, tmp); |
| info->offset = gfc_index_zero_node; |
| |
| for (i = 0; i < ss->dimen; i++) |
| { |
| info->delta[i] = gfc_index_zero_node; |
| info->start[i] = gfc_index_zero_node; |
| info->end[i] = gfc_index_zero_node; |
| info->stride[i] = gfc_index_one_node; |
| } |
| } |
| |
| |
| static int |
| get_rank (gfc_loopinfo *loop) |
| { |
| int rank; |
| |
| rank = 0; |
| for (; loop; loop = loop->parent) |
| rank += loop->dimen; |
| |
| return rank; |
| } |
| |
| |
| /* Helper routine of gfc_trans_array_constructor to determine if the |
| bounds of the loop specified by LOOP are constant and simple enough |
| to use with trans_constant_array_constructor. Returns the |
| iteration count of the loop if suitable, and NULL_TREE otherwise. */ |
| |
| static tree |
| constant_array_constructor_loop_size (gfc_loopinfo * l) |
| { |
| gfc_loopinfo *loop; |
| tree size = gfc_index_one_node; |
| tree tmp; |
| int i, total_dim; |
| |
| total_dim = get_rank (l); |
| |
| for (loop = l; loop; loop = loop->parent) |
| { |
| for (i = 0; i < loop->dimen; i++) |
| { |
| /* If the bounds aren't constant, return NULL_TREE. */ |
| if (!INTEGER_CST_P (loop->from[i]) || !INTEGER_CST_P (loop->to[i])) |
| return NULL_TREE; |
| if (!integer_zerop (loop->from[i])) |
| { |
| /* Only allow nonzero "from" in one-dimensional arrays. */ |
| if (total_dim != 1) |
| return NULL_TREE; |
| tmp = fold_build2_loc (input_location, MINUS_EXPR, |
| gfc_array_index_type, |
| loop->to[i], loop->from[i]); |
| } |
| else |
| tmp = loop->to[i]; |
| tmp = fold_build2_loc (input_location, PLUS_EXPR, |
| gfc_array_index_type, tmp, gfc_index_one_node); |
| size = fold_build2_loc (input_location, MULT_EXPR, |
| gfc_array_index_type, size, tmp); |
| } |
| } |
| |
| return size; |
| } |
| |
| |
| static tree * |
| get_loop_upper_bound_for_array (gfc_ss *array, int array_dim) |
| { |
| gfc_ss *ss; |
| int n; |
| |
| gcc_assert (array->nested_ss == NULL); |
| |
| for (ss = array; ss; ss = ss->parent) |
| for (n = 0; n < ss->loop->dimen; n++) |
| if (array_dim == get_array_ref_dim_for_loop_dim (ss, n)) |
| return &(ss->loop->to[n]); |
| |
| gcc_unreachable (); |
| } |
| |
| |
| static gfc_loopinfo * |
| outermost_loop (gfc_loopinfo * loop) |
| { |
| while (loop->parent != NULL) |
| loop = loop->parent; |
| |
| return loop; |
| } |
| |
| |
| /* Array constructors are handled by constructing a temporary, then using that |
| within the scalarization loop. This is not optimal, but seems by far the |
| simplest method. */ |
| |
| static void |
| trans_array_constructor (gfc_ss * ss, locus * where) |
| { |
| gfc_constructor_base c; |
| tree offset; |
| tree offsetvar; |
| tree desc; |
| tree type; |
| tree tmp; |
| tree *loop_ubound0; |
| bool dynamic; |
| bool old_first_len, old_typespec_chararray_ctor; |
| tree old_first_len_val; |
| gfc_loopinfo *loop, *outer_loop; |
| gfc_ss_info *ss_info; |
| gfc_expr *expr; |
| gfc_ss *s; |
| tree neg_len; |
| char *msg; |
| |
| /* Save the old values for nested checking. */ |
| old_first_len = first_len; |
| old_first_len_val = first_len_val; |
| old_typespec_chararray_ctor = typespec_chararray_ctor; |
| |
| loop = ss->loop; |
| outer_loop = outermost_loop (loop); |
| ss_info = ss->info; |
| expr = ss_info->expr; |
| |
| /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no |
| typespec was given for the array constructor. */ |
| typespec_chararray_ctor = (expr->ts.type == BT_CHARACTER |
| && expr->ts.u.cl |
| && expr->ts.u.cl->length_from_typespec); |
| |
| if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) |
| && expr->ts.type == BT_CHARACTER && !typespec_chararray_ctor) |
| { |
| first_len_val = gfc_create_var (gfc_charlen_type_node, "len"); |
| first_len = true; |
| } |
| |
| gcc_assert (ss->dimen == ss->loop->dimen); |
| |
| c = expr->value.constructor; |
| if (expr->ts.type == BT_CHARACTER) |
| { |
| bool const_string; |
| bool force_new_cl = false; |
| |
| /* get_array_ctor_strlen walks the elements of the constructor, if a |
| typespec was given, we already know the string length and want the one |
| specified there. */ |
| if (typespec_chararray_ctor && expr->ts.u.cl->length |
| && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT) |
| { |
| gfc_se length_se; |
| |
| const_string = false; |
| gfc_init_se (&length_se, NULL); |
| gfc_conv_expr_type (&length_se, expr->ts.u.cl->length, |
| gfc_charlen_type_node); |
| ss_info->string_length = length_se.expr; |
| |
| /* Check if the character length is negative. If it is, then |
| set LEN = 0. */ |
| neg_len = fold_build2_loc (input_location, LT_EXPR, |
| logical_type_node, ss_info->string_length, |
| build_zero_cst (TREE_TYPE |
| (ss_info->string_length))); |
| /* Print a warning if bounds checking is enabled. */ |
| if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) |
| { |
| msg = xasprintf ("Negative character length treated as LEN = 0"); |
| gfc_trans_runtime_check (false, true, neg_len, &length_se.pre, |
| where, msg); |
| free (msg); |
| } |
| |
| ss_info->string_length |
| = fold_build3_loc (input_location, COND_EXPR, |
| gfc_charlen_type_node, neg_len, |
| build_zero_cst |
| (TREE_TYPE (ss_info->string_length)), |
| ss_info->string_length); |
| ss_info->string_length = gfc_evaluate_now (ss_info->string_length, |
| &length_se.pre); |
| gfc_add_block_to_block (&outer_loop->pre, &length_se.pre); |
| gfc_add_block_to_block (&outer_loop->post, &length_se.post); |
| } |
| else |
| { |
| const_string = get_array_ctor_strlen (&outer_loop->pre, c, |
| &ss_info->string_length); |
| force_new_cl = true; |
| } |
| |
| /* Complex character array constructors should have been taken care of |
| and not end up here. */ |
| gcc_assert (ss_info->string_length); |
| |
| store_backend_decl (&expr->ts.u.cl, ss_info->string_length, force_new_cl); |
| |
| type = gfc_get_character_type_len (expr->ts.kind, ss_info->string_length); |
| if (const_string) |
| type = build_pointer_type (type); |
| } |
| else |
| type = gfc_typenode_for_spec (expr->ts.type == BT_CLASS |
| ? &CLASS_DATA (expr)->ts : &expr->ts); |
| |
| /* See if the constructor determines the loop bounds. */ |
| dynamic = false; |
| |
| loop_ubound0 = get_loop_upper_bound_for_array (ss, 0); |
| |
| if (expr->shape && get_rank (loop) > 1 && *loop_ubound0 == NULL_TREE) |
| { |
| /* We have a multidimensional parameter. */ |
| for (s = ss; s; s = s->parent) |
| { |
| int n; |
| for (n = 0; n < s->loop->dimen; n++) |
| { |
| s->loop->from[n] = gfc_index_zero_node; |
| s->loop->to[n] = gfc_conv_mpz_to_tree (expr->shape[s->dim[n]], |
| gfc_index_integer_kind); |
| s->loop->to[n] = fold_build2_loc (input_location, MINUS_EXPR, |
| gfc_array_index_type, |
| s->loop->to[n], |
| gfc_index_one_node); |
| } |
| } |
| } |
| |
| if (*loop_ubound0 == NULL_TREE) |
| { |
| mpz_t size; |
| |
| /* We should have a 1-dimensional, zero-based loop. */ |
| gcc_assert (loop->parent == NULL && loop->nested == NULL); |
| gcc_assert (loop->dimen == 1); |
| gcc_assert (integer_zerop (loop->from[0])); |
| |
| /* Split the constructor size into a static part and a dynamic part. |
| Allocate the static size up-front and record whether the dynamic |
| size might be nonzero. */ |
| mpz_init (size); |
| dynamic = gfc_get_array_constructor_size (&size, c); |
| mpz_sub_ui (size, size, 1); |
| loop->to[0] = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind); |
| mpz_clear (size); |
| } |
| |
| /* Special case constant array constructors. */ |
| if (!dynamic) |
| { |
| unsigned HOST_WIDE_INT nelem = gfc_constant_array_constructor_p (c); |
| if (nelem > 0) |
| { |
| tree size = constant_array_constructor_loop_size (loop); |
| if (size && compare_tree_int (size, nelem) == 0) |
| { |
| trans_constant_array_constructor (ss, type); |
| goto finish; |
| } |
| } |
| } |
| |
| gfc_trans_create_temp_array (&outer_loop->pre, &outer_loop->post, ss, type, |
| NULL_TREE, dynamic, true, false, where); |
| |
| desc = ss_info->data.array.descriptor; |
| offset = gfc_index_zero_node; |
| offsetvar = gfc_create_var_np (gfc_array_index_type, "offset"); |
| TREE_NO_WARNING (offsetvar) = 1; |
| TREE_USED (offsetvar) = 0; |
| gfc_trans_array_constructor_value (&outer_loop->pre, type, desc, c, |
| &offset, &offsetvar, dynamic); |
| |
| /* If the array grows dynamically, the upper bound of the loop variable |
| is determined by the array's final upper bound. */ |
| if (dynamic) |
| { |
| tmp = fold_build2_loc (input_location, MINUS_EXPR, |
| gfc_array_index_type, |
| offsetvar, gfc_index_one_node); |
| tmp = gfc_evaluate_now (tmp, &outer_loop->pre); |
| gfc_conv_descriptor_ubound_set (&loop->pre, desc, gfc_rank_cst[0], tmp); |
| if (*loop_ubound0 && VAR_P (*loop_ubound0)) |
| gfc_add_modify (&outer_loop->pre, *loop_ubound0, tmp); |
| else |
| *loop_ubound0 = tmp; |
| } |
| |
| if (TREE_USED (offsetvar)) |
| pushdecl (offsetvar); |
| else |
| gcc_assert (INTEGER_CST_P (offset)); |
| |
| #if 0 |
| /* Disable bound checking for now because it's probably broken. */ |
| if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) |
| { |
| gcc_unreachable (); |
| } |
| #endif |
| |
| finish: |
| /* Restore old values of globals. */ |
| first_len = old_first_len; |
| first_len_val = old_first_len_val; |
| typespec_chararray_ctor = old_typespec_chararray_ctor; |
| } |
| |
| |
| /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is |
| called after evaluating all of INFO's vector dimensions. Go through |
| each such vector dimension and see if we can now fill in any missing |
| loop bounds. */ |
| |
| static void |
| set_vector_loop_bounds (gfc_ss * ss) |
| { |
| gfc_loopinfo *loop, *outer_loop; |
| gfc_array_info *info; |
| gfc_se se; |
| tree tmp; |
| tree desc; |
| tree zero; |
| int n; |
| int dim; |
| |
| outer_loop = outermost_loop (ss->loop); |
| |
| info = &ss->info->data.array; |
| |
| for (; ss; ss = ss->parent) |
| { |
| loop = ss->loop; |
| |
| for (n = 0; n < loop->dimen; n++) |
| { |
| dim = ss->dim[n]; |
| if (info->ref->u.ar.dimen_type[dim] != DIMEN_VECTOR |
| || loop->to[n] != NULL) |
| continue; |
| |
| /* Loop variable N indexes vector dimension DIM, and we don't |
| yet know the upper bound of loop variable N. Set it to the |
| difference between the vector's upper and lower bounds. */ |
| gcc_assert (loop->from[n] == gfc_index_zero_node); |
| gcc_assert (info->subscript[dim] |
| && info->subscript[dim]->info->type == GFC_SS_VECTOR); |
| |
| gfc_init_se (&se, NULL); |
| desc = info->subscript[dim]->info->data.array.descriptor; |
| zero = gfc_rank_cst[0]; |
| tmp = fold_build2_loc (input_location, MINUS_EXPR, |
| gfc_array_index_type, |
| gfc_conv_descriptor_ubound_get (desc, zero), |
| gfc_conv_descriptor_lbound_get (desc, zero)); |
| tmp = gfc_evaluate_now (tmp, &outer_loop->pre); |
| loop->to[n] = tmp; |
| } |
| } |
| } |
| |
| |
| /* Tells whether a scalar argument to an elemental procedure is saved out |
| of a scalarization loop as a value or as a reference. */ |
| |
| bool |
| gfc_scalar_elemental_arg_saved_as_reference (gfc_ss_info * ss_info) |
| { |
| if (ss_info->type != GFC_SS_REFERENCE) |
| return false; |
| |
| if (ss_info->data.scalar.needs_temporary) |
| return false; |
| |
| /* If the actual argument can be absent (in other words, it can |
| be a NULL reference), don't try to evaluate it; pass instead |
| the reference directly. */ |
| if (ss_info->can_be_null_ref) |
| return true; |
| |
| /* If the expression is of polymorphic type, it's actual size is not known, |
| so we avoid copying it anywhere. */ |
| if (ss_info->data.scalar.dummy_arg |
| && ss_info->data.scalar.dummy_arg->ts.type == BT_CLASS |
| && ss_info->expr->ts.type == BT_CLASS) |
| return true; |
| |
| /* If the expression is a data reference of aggregate type, |
| and the data reference is not used on the left hand side, |
| avoid a copy by saving a reference to the content. */ |
| if (!ss_info->data.scalar.needs_temporary |
| && (ss_info->expr->ts.type == BT_DERIVED |
| || ss_info->expr->ts.type == BT_CLASS) |
| && gfc_expr_is_variable (ss_info->expr)) |
| return true; |
| |
| /* Otherwise the expression is evaluated to a temporary variable before the |
| scalarization loop. */ |
| return false; |
| } |
| |
| |
| /* Add the pre and post chains for all the scalar expressions in a SS chain |
| to loop. This is called after the loop parameters have been calculated, |
| but before the actual scalarizing loops. */ |
| |
| static void |
| gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript, |
| locus * where) |
| { |
| gfc_loopinfo *nested_loop, *outer_loop; |
| gfc_se se; |
| gfc_ss_info *ss_info; |
| gfc_array_info *info; |
| gfc_expr *expr; |
| int n; |
| |
| /* Don't evaluate the arguments for realloc_lhs_loop_for_fcn_call; otherwise, |
| arguments could get evaluated multiple times. */ |
| if (ss->is_alloc_lhs) |
| return; |
| |
| outer_loop = outermost_loop (loop); |
| |
| /* TODO: This can generate bad code if there are ordering dependencies, |
| e.g., a callee allocated function and an unknown size constructor. */ |
| gcc_assert (ss != NULL); |
| |
| for (; ss != gfc_ss_terminator; ss = ss->loop_chain) |
| { |
| gcc_assert (ss); |
| |
| /* Cross loop arrays are handled from within the most nested loop. */ |
| if (ss->nested_ss != NULL) |
| continue; |
| |
| ss_info = ss->info; |
| expr = ss_info->expr; |
| info = &ss_info->data.array; |
| |
| switch (ss_info->type) |
| { |
| case GFC_SS_SCALAR: |
| /* Scalar expression. Evaluate this now. This includes elemental |
| dimension indices, but not array section bounds. */ |
| gfc_init_se (&se, NULL); |
| gfc_conv_expr (&se, expr); |
| gfc_add_block_to_block (&outer_loop->pre, &se.pre); |
| |
| if (expr->ts.type != BT_CHARACTER |
| && !gfc_is_alloc_class_scalar_function (expr)) |
| { |
| /* Move the evaluation of scalar expressions outside the |
| scalarization loop, except for WHERE assignments. */ |
| if (subscript) |
| se.expr = convert(gfc_array_index_type, se.expr); |
| if (!ss_info->where) |
| se.expr = gfc_evaluate_now (se.expr, &outer_loop->pre); |
| gfc_add_block_to_block (&outer_loop->pre, &se.post); |
| } |
| else |
| gfc_add_block_to_block (&outer_loop->post, &se.post); |
| |
| ss_info->data.scalar.value = se.expr; |
| ss_info->string_length = se.string_length; |
| break; |
| |
| case GFC_SS_REFERENCE: |
| /* Scalar argument to elemental procedure. */ |
| gfc_init_se (&se, NULL); |
| if (gfc_scalar_elemental_arg_saved_as_reference (ss_info)) |
| gfc_conv_expr_reference (&se, expr); |
| else |
| { |
| /* Evaluate the argument outside the loop and pass |
| a reference to the value. */ |
| gfc_conv_expr (&se, expr); |
| } |
| |
| /* Ensure that a pointer to the string is stored. */ |
| if (expr->ts.type == BT_CHARACTER) |
| gfc_conv_string_parameter (&se); |
| |
| gfc_add_block_to_block (&outer_loop->pre, &se.pre); |
| gfc_add_block_to_block (&outer_loop->post, &se.post); |
| if (gfc_is_class_scalar_expr (expr)) |
| /* This is necessary because the dynamic type will always be |
| large than the declared type. In consequence, assigning |
| the value to a temporary could segfault. |
| OOP-TODO: see if this is generally correct or is the value |
| has to be written to an allocated temporary, whose address |
| is passed via ss_info. */ |
| ss_info->data.scalar.value = se.expr; |
| else |
| ss_info->data.scalar.value = gfc_evaluate_now (se.expr, |
| &outer_loop->pre); |
| |
| ss_info->string_length = se.string_length; |
| break; |
| |
| case GFC_SS_SECTION: |
| /* Add the expressions for scalar and vector subscripts. */ |
| for (n = 0; n < GFC_MAX_DIMENSIONS; n++) |
| if (info->subscript[n]) |
| gfc_add_loop_ss_code (loop, info->subscript[n], true, where); |
| |
| set_vector_loop_bounds (ss); |
| break; |
| |
| case GFC_SS_VECTOR: |
| /* Get the vector's descriptor and store it in SS. */ |
| gfc_init_se (&se, NULL); |
| gfc_conv_expr_descriptor (&se, expr); |
| gfc_add_block_to_block (&outer_loop->pre, &se.pre); |
| gfc_add_block_to_block (&outer_loop->post, &se.post); |
| info->descriptor = se.expr; |
| break; |
| |
| case GFC_SS_INTRINSIC: |
| gfc_add_intrinsic_ss_code (loop, ss); |
| break; |
| |
| case GFC_SS_FUNCTION: |
| /* Array function return value. We call the function and save its |
| result in a temporary for use inside the loop. */ |
| gfc_init_se (&se, NULL); |
| se.loop = loop; |
| se.ss = ss; |
| if (gfc_is_class_array_function (expr)) |
| expr->must_finalize = 1; |
| gfc_conv_expr (&se, expr); |
| gfc_add_block_to_block (&outer_loop->pre, &se.pre); |
| gfc_add_block_to_block (&outer_loop->post, &se.post); |
| ss_info->string_length = se.string_length; |
| break; |
| |
| case GFC_SS_CONSTRUCTOR: |
| if (expr->ts.type == BT_CHARACTER |
| && ss_info->string_length == NULL |
| && expr->ts.u.cl |
| && expr->ts.u.cl->length |
| && expr->ts.u.cl->length->expr_type == EXPR_CONSTANT) |
| { |
| gfc_init_se (&se, NULL); |
| gfc_conv_expr_type (&se, expr->ts.u.cl->length, |
| gfc_charlen_type_node); |
| ss_info->string_length = se.expr; |
| gfc_add_block_to_block (&outer_loop->pre, &se.pre); |
| gfc_add_block_to_block (&outer_loop->post, &se.post); |
| } |
| trans_array_constructor (ss, where); |
| break; |
| |
| case GFC_SS_TEMP: |
| case GFC_SS_COMPONENT: |
| /* Do nothing. These are handled elsewhere. */ |
| break; |
| |
| default: |
| gcc_unreachable (); |
| } |
| } |
| |
| if (!subscript) |
| for (nested_loop = loop->nested; nested_loop; |
| nested_loop = nested_loop->next) |
| gfc_add_loop_ss_code (nested_loop, nested_loop->ss, subscript, where); |
| } |
| |
| |
| /* Translate expressions for the descriptor and data pointer of a SS. */ |
| /*GCC ARRAYS*/ |
| |
| static void |
| gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base) |
| { |
| gfc_se se; |
| gfc_ss_info *ss_info; |
| gfc_array_info *info; |
| tree tmp; |
| |
| ss_info = ss->info; |
| info = &ss_info->data.array; |
| |
| /* Get the descriptor for the array to be scalarized. */ |
| gcc_assert (ss_info->expr->expr_type == EXPR_VARIABLE); |
| gfc_init_se (&se, NULL); |
| se.descriptor_only = 1; |
| gfc_conv_expr_lhs (&se, ss_info->expr); |
| gfc_add_block_to_block (block, &se.pre); |
| info->descriptor = se.expr; |
| ss_info->string_length = se.string_length; |
| |
| if (base) |
| { |
| if (ss_info->expr->ts.type == BT_CHARACTER && !ss_info->expr->ts.deferred |
| && ss_info->expr->ts.u.cl->length == NULL) |
| { |
| /* Emit a DECL_EXPR for the variable sized array type in |
| GFC_TYPE_ARRAY_DATAPTR_TYPE so the gimplification of its type |
| sizes works correctly. */ |
| tree arraytype = TREE_TYPE ( |
| GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (info->descriptor))); |
| if (! TYPE_NAME (arraytype)) |
| TYPE_NAME (arraytype) = build_decl (UNKNOWN_LOCATION, TYPE_DECL, |
| NULL_TREE, arraytype); |
| gfc_add_expr_to_block (block, build1 (DECL_EXPR, arraytype, |
| TYPE_NAME (arraytype))); |
| } |
| /* Also the data pointer. */ |
| tmp = gfc_conv_array_data (se.expr); |
| /* If this is a variable or address of a variable we use it directly. |
| Otherwise we must evaluate it now to avoid breaking dependency |
| analysis by pulling the expressions for elemental array indices |
| inside the loop. */ |
| if (!(DECL_P (tmp) |
| || (TREE_CODE (tmp) == ADDR_EXPR |
| && DECL_P (TREE_OPERAND (tmp, 0))))) |
| tmp = gfc_evaluate_now (tmp, block); |
| info->data = tmp; |
| |
| tmp = gfc_conv_array_offset (se.expr); |
| info->offset = gfc_evaluate_now (tmp, block); |
| |
| /* Make absolutely sure that the saved_offset is indeed saved |
| so that the variable is still accessible after the loops |
| are translated. */ |
| info->saved_offset = info->offset; |
| } |
| } |
| |
| |
| /* Initialize a gfc_loopinfo structure. */ |
| |
| void |
| gfc_init_loopinfo (gfc_loopinfo * loop) |
| { |
| int n; |
| |
| memset (loop, 0, sizeof (gfc_loopinfo)); |
| gfc_init_block (&loop->pre); |
| gfc_init_block (&loop->post); |
| |
| /* Initially scalarize in order and default to no loop reversal. */ |
| for (n = 0; n < GFC_MAX_DIMENSIONS; n++) |
| { |
| loop->order[n] = n; |
| loop->reverse[n] = GFC_INHIBIT_REVERSE; |
| } |
| |
| loop->ss = gfc_ss_terminator; |
| } |
| |
| |
| /* Copies the loop variable info to a gfc_se structure. Does not copy the SS |
| chain. */ |
| |
| void |
| gfc_copy_loopinfo_to_se (gfc_se * se, gfc_loopinfo * loop) |
| { |
| se->loop = loop; |
| } |
| |
| |
| /* Return an expression for the data pointer of an array. */ |
| |
| tree |
| gfc_conv_array_data (tree descriptor) |
| { |
| tree type; |
| |
| type = TREE_TYPE (descriptor); |
| if (GFC_ARRAY_TYPE_P (type)) |
| { |
| if (TREE_CODE (type) == POINTER_TYPE) |
| return descriptor; |
| else |
| { |
| /* Descriptorless arrays. */ |
| return gfc_build_addr_expr (NULL_TREE, descriptor); |
| } |
| } |
| else |
| return gfc_conv_descriptor_data_get (descriptor); |
| } |
| |
| |
| /* Return an expression for the base offset of an array. */ |
| |
| tree |
| gfc_conv_array_offset (tree descriptor) |
| { |
| tree type; |
| |
| type = TREE_TYPE (descriptor); |
| if (GFC_ARRAY_TYPE_P (type)) |
| return GFC_TYPE_ARRAY_OFFSET (type); |
| else |
| return gfc_conv_descriptor_offset_get (descriptor); |
| } |
| |
| |
| /* Get an expression for the array stride. */ |
| |
| tree |
| gfc_conv_array_stride (tree descriptor, int dim) |
| { |
| tree tmp; |
| tree type; |
| |
| type = TREE_TYPE (descriptor); |
| |
| /* For descriptorless arrays use the array size. */ |
| tmp = GFC_TYPE_ARRAY_STRIDE (type, dim); |
| if (tmp != NULL_TREE) |
| return tmp; |
| |
| tmp = gfc_conv_descriptor_stride_get (descriptor, gfc_rank_cst[dim]); |
| return tmp; |
| } |
| |
| |
| /* Like gfc_conv_array_stride, but for the lower bound. */ |
| |
| tree |
| gfc_conv_array_lbound (tree descriptor, int dim) |
| { |
| tree tmp; |
| tree type; |
| |
| type = TREE_TYPE (descriptor); |
| |
| tmp = GFC_TYPE_ARRAY_LBOUND (type, dim); |
| if (tmp != NULL_TREE) |
| return tmp; |
| |
| tmp = gfc_conv_descriptor_lbound_get (descriptor, gfc_rank_cst[dim]); |
| return tmp; |
| } |
| |
| |
| /* Like gfc_conv_array_stride, but for the upper bound. */ |
| |
| tree |
| gfc_conv_array_ubound (tree descriptor, int dim) |
| { |
| tree tmp; |
| tree type; |
| |
| type = TREE_TYPE (descriptor); |
| |
| tmp = GFC_TYPE_ARRAY_UBOUND (type, dim); |
| if (tmp != NULL_TREE) |
| return tmp; |
| |
| /* This should only ever happen when passing an assumed shape array |
| as an actual parameter. The value will never be used. */ |
| if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor))) |
| return gfc_index_zero_node; |
| |
| tmp = gfc_conv_descriptor_ubound_get (descriptor, gfc_rank_cst[dim]); |
| return tmp; |
| } |
| |
| |
| /* Generate code to perform an array index bound check. */ |
| |
| static tree |
| trans_array_bound_check (gfc_se * se, gfc_ss *ss, tree index, int n, |
| locus * where, bool check_upper) |
| { |
| tree fault; |
| tree tmp_lo, tmp_up; |
| tree descriptor; |
| char *msg; |
| const char * name = NULL; |
| |
| if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)) |
| return index; |
| |
| descriptor = ss->info->data.array.descriptor; |
| |
| index = gfc_evaluate_now (index, &se->pre); |
| |
| /* We find a name for the error message. */ |
| name = ss->info->expr->symtree->n.sym->name; |
| gcc_assert (name != NULL); |
| |
| if (VAR_P (descriptor)) |
| name = IDENTIFIER_POINTER (DECL_NAME (descriptor)); |
| |
| /* If upper bound is present, include both bounds in the error message. */ |
| if (check_upper) |
| { |
| tmp_lo = gfc_conv_array_lbound (descriptor, n); |
| tmp_up = gfc_conv_array_ubound (descriptor, n); |
| |
| if (name) |
| msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' " |
| "outside of expected range (%%ld:%%ld)", n+1, name); |
| else |
| msg = xasprintf ("Index '%%ld' of dimension %d " |
| "outside of expected range (%%ld:%%ld)", n+1); |
| |
| fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node, |
| index, tmp_lo); |
| gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg, |
| fold_convert (long_integer_type_node, index), |
| fold_convert (long_integer_type_node, tmp_lo), |
| fold_convert (long_integer_type_node, tmp_up)); |
| fault = fold_build2_loc (input_location, GT_EXPR, logical_type_node, |
| index, tmp_up); |
| gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg, |
| fold_convert (long_integer_type_node, index), |
| fold_convert (long_integer_type_node, tmp_lo), |
| fold_convert (long_integer_type_node, tmp_up)); |
| free (msg); |
| } |
| else |
| { |
| tmp_lo = gfc_conv_array_lbound (descriptor, n); |
| |
| if (name) |
| msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' " |
| "below lower bound of %%ld", n+1, name); |
| else |
| msg = xasprintf ("Index '%%ld' of dimension %d " |
| "below lower bound of %%ld", n+1); |
| |
| fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node, |
| index, tmp_lo); |
| gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg, |
| fold_convert (long_integer_type_node, index), |
| fold_convert (long_integer_type_node, tmp_lo)); |
| free (msg); |
| } |
| |
| return index; |
| } |
| |
| |
| /* Return the offset for an index. Performs bound checking for elemental |
| dimensions. Single element references are processed separately. |
| DIM is the array dimension, I is the loop dimension. */ |
| |
| static tree |
| conv_array_index_offset (gfc_se * se, gfc_ss * ss, int dim, int i, |
| gfc_array_ref * ar, tree stride) |
| { |
|