This is the mail archive of the
fortran@gcc.gnu.org
mailing list for the GNU Fortran project.
A preview of the subreference array pointer patch
- From: Paul Thomas <paulthomas2 at wanadoo dot fr>
- To: Fortran List <fortran at gcc dot gnu dot org>
- Date: Sun, 09 Sep 2007 00:35:28 +0200
- Subject: A preview of the subreference array pointer patch
Dear All,
Just so that you have some idea of what is coming, please find attached
a patch that fixes this test case:
type :: t
real :: r
integer :: i
character(3) :: chr
end type t
type(t), target :: tar1(2) = (/t(1.0, 2, "abc"), t(3.0, 4, "efg")/)
character(4), target :: tar2(2) = (/"abcd","efgh"/)
integer, target :: tar3(2) = (/7, 8/)
integer, pointer :: ptr(:)
character(2), pointer :: ptr2(:)
ptr => tar1%i
ptr = ptr + 1
print *, ptr
print *, ptr(1), ptr(2)
print *, tar1
ptr2 => tar2(:)(2:3)
ptr2 = ptr2(:)(2:2)//"z"
print *, ptr2
print *, ptr2(1), ptr2(2)
print *, tar2
end
I will try to locate as many obvious applications of this feature as
possible but will not have time to do such things as where/forall
expressions. I also need to do some cleaning up and to make use of
GFC_DECL_SUBREF_ARRAY_P as an identification of these pointers.
Cheers
Paul
Index: gcc/fortran/trans-array.c
===================================================================
*** gcc/fortran/trans-array.c (revision 128135)
--- gcc/fortran/trans-array.c (working copy)
*************** gfc_conv_scalarized_array_ref (gfc_se *
*** 2236,2243 ****
if (!integer_zerop (info->offset))
index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, info->offset);
! tmp = build_fold_indirect_ref (info->data);
! se->expr = gfc_build_array_ref (tmp, index);
}
--- 2236,2254 ----
if (!integer_zerop (info->offset))
index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, info->offset);
! if (se->ss->expr
! && is_subref_array (se->ss->expr)
! && !integer_zerop (GFC_DECL_SPAN(se->ss->expr->symtree->n.sym->backend_decl)))
! {
! tmp = GFC_DECL_SPAN(se->ss->expr->symtree->n.sym->backend_decl);
! index = fold_build2 (MULT_EXPR, gfc_array_index_type, index, tmp);
! se->expr = gfc_build_array_ref_bytes (build_fold_indirect_ref (info->data), index);
! }
! else
! {
! tmp = build_fold_indirect_ref (info->data);
! se->expr = gfc_build_array_ref (tmp, index);
! }
}
*************** gfc_conv_array_ref (gfc_se * se, gfc_arr
*** 2338,2348 ****
tmp = gfc_conv_array_offset (se->expr);
if (!integer_zerop (tmp))
index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
!
/* Access the calculated element. */
tmp = gfc_conv_array_data (se->expr);
! tmp = build_fold_indirect_ref (tmp);
! se->expr = gfc_build_array_ref (tmp, index);
}
--- 2349,2370 ----
tmp = gfc_conv_array_offset (se->expr);
if (!integer_zerop (tmp))
index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
!
/* Access the calculated element. */
tmp = gfc_conv_array_data (se->expr);
!
! if (sym->attr.subref_array_pointer
! && !integer_zerop (GFC_DECL_SPAN(sym->backend_decl)))
! {
! index = fold_build2 (MULT_EXPR, gfc_array_index_type, index,
! GFC_DECL_SPAN(sym->backend_decl));
! se->expr = gfc_build_array_ref_bytes (build_fold_indirect_ref (tmp), index);
! }
! else
! {
! tmp = build_fold_indirect_ref (tmp);
! se->expr = gfc_build_array_ref (tmp, index);
! }
}
*************** gfc_conv_expr_descriptor (gfc_se * se, g
*** 4373,4378 ****
--- 4395,4401 ----
tree start;
tree offset;
int full;
+ bool subref_array_target = false;
gcc_assert (ss != gfc_ss_terminator);
*************** gfc_conv_expr_descriptor (gfc_se * se, g
*** 4395,4401 ****
gfc_conv_ss_descriptor (&se->pre, secss, 0);
desc = info->descriptor;
! need_tmp = gfc_ref_needs_temporary_p (expr->ref);
if (need_tmp)
full = 0;
else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
--- 4418,4427 ----
gfc_conv_ss_descriptor (&se->pre, secss, 0);
desc = info->descriptor;
! subref_array_target = se->direct_byref && is_subref_array (expr);
! need_tmp = gfc_ref_needs_temporary_p (expr->ref)
! && !subref_array_target;
!
if (need_tmp)
full = 0;
else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
*************** gfc_conv_expr_descriptor (gfc_se * se, g
*** 4747,4752 ****
--- 4773,4820 ----
tmp = gfc_conv_array_data (desc);
tmp = build_fold_indirect_ref (tmp);
tmp = gfc_build_array_ref (tmp, offset);
+
+ /* Offset the data pointer for pointer assignments from arrays with
+ subreferences; eg. my_integer => my_type(:)%integer_component. */
+ if (subref_array_target)
+ {
+ gfc_ref *tmp_ref;
+ tree field;
+ gfc_se start;
+
+ /* Go past the array reference. */
+ for (tmp_ref = expr->ref; tmp_ref; tmp_ref = tmp_ref->next)
+ if (tmp_ref->type == REF_ARRAY)
+ {
+ tmp_ref = tmp_ref->next;
+ break;
+ }
+
+ /* Calculate the offset for each subreference. */
+ for (tmp_ref = expr->ref; tmp_ref; tmp_ref = tmp_ref->next)
+ {
+ switch (tmp_ref->type)
+ {
+ case REF_COMPONENT:
+ field = tmp_ref->u.c.component->backend_decl;
+ gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
+ tmp = build3 (COMPONENT_REF, TREE_TYPE (field), tmp, field, NULL_TREE);
+ break;
+
+ case REF_SUBSTRING:
+ gfc_init_se (&start, se);
+ gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
+ gfc_conv_expr_type (&start, tmp_ref->u.ss.start, gfc_charlen_type_node);
+ gfc_add_block_to_block (&se->pre, &start.pre);
+ tmp = gfc_build_array_ref (tmp, start.expr);
+ break;
+
+ default:
+ break;
+ }
+ }
+ }
+
offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
gfc_conv_descriptor_data_set (&loop.pre, parm, offset);
}
Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c (revision 128135)
--- gcc/fortran/trans-expr.c (working copy)
*************** gfc_get_expr_charlen (gfc_expr *e)
*** 206,212 ****
default:
/* We should never got substring references here. These will be
broken down by the scalarizer. */
! gcc_unreachable ();
}
}
--- 206,213 ----
default:
/* We should never got substring references here. These will be
broken down by the scalarizer. */
! length = e->symtree->n.sym->ts.cl->backend_decl;
! break;
}
}
*************** gfc_apply_interface_mapping (gfc_interfa
*** 1782,1796 ****
gfc_free_expr (expr);
}
/* Returns a reference to a temporary array into which a component of
an actual argument derived type array is copied and then returned
! after the function call.
! TODO Get rid of this kludge, when array descriptors are capable of
! handling arrays with a bigger stride in bytes than size. */
!
void
! gfc_conv_aliased_arg (gfc_se * parmse, gfc_expr * expr,
! int g77, sym_intent intent)
{
gfc_se lse;
gfc_se rse;
--- 1783,1795 ----
gfc_free_expr (expr);
}
+
/* Returns a reference to a temporary array into which a component of
an actual argument derived type array is copied and then returned
! after the function call. */
void
! gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr,
! int g77, sym_intent intent)
{
gfc_se lse;
gfc_se rse;
*************** gfc_conv_aliased_arg (gfc_se * parmse, g
*** 2005,2032 ****
return;
}
- /* Is true if an array reference is followed by a component or substring
- reference. */
-
- bool
- is_aliased_array (gfc_expr * e)
- {
- gfc_ref * ref;
- bool seen_array;
-
- seen_array = false;
- for (ref = e->ref; ref; ref = ref->next)
- {
- if (ref->type == REF_ARRAY
- && ref->u.ar.type != AR_ELEMENT)
- seen_array = true;
-
- if (seen_array
- && ref->type != REF_ARRAY)
- return seen_array;
- }
- return false;
- }
/* Generate the code for argument list functions. */
--- 2004,2009 ----
*************** gfc_conv_function_call (gfc_se * se, gfc
*** 2256,2267 ****
f = f || !sym->attr.always_explicit;
if (e->expr_type == EXPR_VARIABLE
! && is_aliased_array (e))
/* The actual argument is a component reference to an
array of derived types. In this case, the argument
is converted to a temporary, which is passed and then
written back after the procedure call. */
! gfc_conv_aliased_arg (&parmse, e, f,
fsym ? fsym->attr.intent : INTENT_INOUT);
else
gfc_conv_array_parameter (&parmse, e, argss, f);
--- 2233,2244 ----
f = f || !sym->attr.always_explicit;
if (e->expr_type == EXPR_VARIABLE
! && is_subref_array (e))
/* The actual argument is a component reference to an
array of derived types. In this case, the argument
is converted to a temporary, which is passed and then
written back after the procedure call. */
! gfc_conv_subref_array_arg (&parmse, e, f,
fsym ? fsym->attr.intent : INTENT_INOUT);
else
gfc_conv_array_parameter (&parmse, e, argss, f);
*************** gfc_trans_pointer_assignment (gfc_expr *
*** 3485,3490 ****
--- 3462,3485 ----
/* Assign directly to the pointer's descriptor. */
lse.direct_byref = 1;
gfc_conv_expr_descriptor (&lse, expr2, rss);
+ if (is_subref_array (expr2))
+ {
+ tree edecl, etmp;
+ if (expr2->ts.type == BT_CHARACTER)
+ {
+ edecl = expr2->symtree->n.sym->ts.cl->backend_decl;
+ etmp = fold_convert (gfc_array_index_type, edecl);
+ }
+ else
+ {
+ edecl = expr2->symtree->n.sym->backend_decl;
+ etmp = fold_convert (gfc_array_index_type,
+ size_in_bytes (gfc_get_element_type (TREE_TYPE (edecl))));
+ }
+
+ edecl = expr1->symtree->n.sym->backend_decl;
+ gfc_add_modify_expr (&lse.post, GFC_DECL_SPAN(edecl), etmp);
+ }
break;
default:
Index: gcc/fortran/gfortran.h
===================================================================
*** gcc/fortran/gfortran.h (revision 128135)
--- gcc/fortran/gfortran.h (working copy)
*************** typedef struct
*** 578,584 ****
unsigned allocatable:1, dimension:1, external:1, intrinsic:1,
optional:1, pointer:1, target:1, value:1, volatile_:1,
dummy:1, result:1, assign:1, threadprivate:1, not_always_present:1,
! implied_index:1;
ENUM_BITFIELD (save_state) save:2;
--- 578,584 ----
unsigned allocatable:1, dimension:1, external:1, intrinsic:1,
optional:1, pointer:1, target:1, value:1, volatile_:1,
dummy:1, result:1, assign:1, threadprivate:1, not_always_present:1,
! implied_index:1, subref_array_pointer:1;
ENUM_BITFIELD (save_state) save:2;
*************** void gfc_free_actual_arglist (gfc_actual
*** 2166,2171 ****
--- 2166,2172 ----
gfc_actual_arglist *gfc_copy_actual_arglist (gfc_actual_arglist *);
const char *gfc_extract_int (gfc_expr *, int *);
gfc_expr *gfc_expr_to_initialize (gfc_expr *);
+ bool is_subref_array (gfc_expr *);
gfc_expr *gfc_build_conversion (gfc_expr *);
void gfc_free_ref_list (gfc_ref *);
Index: gcc/fortran/expr.c
===================================================================
*** gcc/fortran/expr.c (revision 128135)
--- gcc/fortran/expr.c (working copy)
*************** gfc_is_constant_expr (gfc_expr *e)
*** 792,797 ****
--- 792,826 ----
}
+ /* Is true if an array reference is followed by a component or substring
+ reference. */
+ bool
+ is_subref_array (gfc_expr * e)
+ {
+ gfc_ref * ref;
+ bool seen_array;
+
+ if (e->expr_type != EXPR_VARIABLE)
+ return false;
+
+ if (e->symtree->n.sym->attr.subref_array_pointer)
+ return true;
+
+ seen_array = false;
+ for (ref = e->ref; ref; ref = ref->next)
+ {
+ if (ref->type == REF_ARRAY
+ && ref->u.ar.type != AR_ELEMENT)
+ seen_array = true;
+
+ if (seen_array
+ && ref->type != REF_ARRAY)
+ return seen_array;
+ }
+ return false;
+ }
+
+
/* Try to collapse intrinsic expressions. */
static try
*************** gfc_check_pointer_assign (gfc_expr *lval
*** 2802,2807 ****
--- 2831,2839 ----
return FAILURE;
}
+ if (rvalue->expr_type == EXPR_VARIABLE && is_subref_array (rvalue))
+ lvalue->symtree->n.sym->attr.subref_array_pointer = 1;
+
attr = gfc_expr_attr (rvalue);
if (!attr.target && !attr.pointer)
{
Index: gcc/fortran/trans.c
===================================================================
*** gcc/fortran/trans.c (revision 128135)
--- gcc/fortran/trans.c (working copy)
*************** gfc_build_array_ref (tree base, tree off
*** 325,330 ****
--- 325,354 ----
}
+ /* Build an ARRAY_REF with an offset in bytes. */
+
+ tree
+ gfc_build_array_ref_bytes (tree base, tree offset)
+ {
+ tree type, tmp;
+
+ type = TREE_TYPE (base);
+ gcc_assert (TREE_CODE (type) == ARRAY_TYPE);
+ type = TREE_TYPE (type);
+
+ /* Strip NON_LVALUE_EXPR nodes. */
+ STRIP_TYPE_NOPS (offset);
+
+ tmp = gfc_build_addr_expr (pvoid_type_node, base);
+ tmp = fold_build2 (POINTER_PLUS_EXPR, pvoid_type_node, tmp,
+ fold_convert (sizetype, offset));
+ tmp = fold_convert (build_pointer_type (type), tmp);
+ if (!TYPE_STRING_FLAG (type))
+ tmp = build_fold_indirect_ref (tmp);
+ return tmp;
+ }
+
+
/* Generate a runtime error if COND is true. */
void
Index: gcc/fortran/trans.h
===================================================================
*** gcc/fortran/trans.h (revision 128135)
--- gcc/fortran/trans.h (working copy)
*************** tree gfc_conv_operator_assign (gfc_se *,
*** 316,323 ****
int gfc_conv_function_call (gfc_se *, gfc_symbol *, gfc_actual_arglist *,
tree);
! void gfc_conv_aliased_arg (gfc_se *, gfc_expr *, int, sym_intent);
! bool is_aliased_array (gfc_expr *);
/* gfc_trans_* shouldn't call push/poplevel, use gfc_push/pop_scope */
--- 316,322 ----
int gfc_conv_function_call (gfc_se *, gfc_symbol *, gfc_actual_arglist *,
tree);
! void gfc_conv_subref_array_arg (gfc_se *, gfc_expr *, int, sym_intent);
/* gfc_trans_* shouldn't call push/poplevel, use gfc_push/pop_scope */
*************** tree gfc_build_addr_expr (tree, tree);
*** 380,385 ****
--- 379,385 ----
/* Build an ARRAY_REF. */
tree gfc_build_array_ref (tree, tree);
+ tree gfc_build_array_ref_bytes (tree, tree);
/* Creates a label. Decl is artificial if label_id == NULL_TREE. */
tree gfc_build_label_decl (tree);
*************** struct lang_decl GTY(())
*** 593,603 ****
--- 593,605 ----
address of target label. */
tree stringlen;
tree addr;
+ tree span;
};
#define GFC_DECL_ASSIGN_ADDR(node) DECL_LANG_SPECIFIC(node)->addr
#define GFC_DECL_STRING_LEN(node) DECL_LANG_SPECIFIC(node)->stringlen
+ #define GFC_DECL_SPAN(node) DECL_LANG_SPECIFIC(node)->span
#define GFC_DECL_SAVED_DESCRIPTOR(node) \
(DECL_LANG_SPECIFIC(node)->saved_descriptor)
#define GFC_DECL_PACKED_ARRAY(node) DECL_LANG_FLAG_0(node)
*************** struct lang_decl GTY(())
*** 606,611 ****
--- 608,614 ----
#define GFC_DECL_COMMON_OR_EQUIV(node) DECL_LANG_FLAG_3(node)
#define GFC_DECL_CRAY_POINTEE(node) DECL_LANG_FLAG_4(node)
#define GFC_DECL_RESULT(node) DECL_LANG_FLAG_5(node)
+ #define GFC_DECL_SUBREF_ARRAY_P(node) DECL_LANG_FLAG_6(node)
/* An array descriptor. */
#define GFC_DESCRIPTOR_TYPE_P(node) TYPE_LANG_FLAG_1(node)
Index: gcc/fortran/trans-decl.c
===================================================================
*** gcc/fortran/trans-decl.c (revision 128135)
--- gcc/fortran/trans-decl.c (working copy)
*************** gfc_get_symbol_decl (gfc_symbol * sym)
*** 1016,1021 ****
--- 1016,1040 ----
gcc_assert (!sym->value);
}
}
+ else if (sym->attr.subref_array_pointer)
+ {
+ /* We need the span for these beasts. */
+ gfc_allocate_lang_decl (decl);
+ }
+
+ if (sym->attr.subref_array_pointer)
+ {
+ tree span;
+ GFC_DECL_SUBREF_ARRAY_P (decl) = 1;
+ span = build_decl (VAR_DECL, create_tmp_var_name ("span"),
+ gfc_array_index_type);
+ gfc_finish_var_decl (span, sym);
+ TREE_STATIC (span) = 1;
+ DECL_INITIAL (span) = build_int_cst (NULL_TREE, 0);
+
+ GFC_DECL_SPAN (decl) = span;
+ }
+
sym->backend_decl = decl;
if (sym->attr.assign)
Index: gcc/fortran/trans-io.c
===================================================================
*** gcc/fortran/trans-io.c (revision 128135)
--- gcc/fortran/trans-io.c (working copy)
*************** set_internal_unit (stmtblock_t * block,
*** 724,734 ****
{
se.ss = gfc_walk_expr (e);
! if (is_aliased_array (e))
{
/* Use a temporary for components of arrays of derived types
or substring array references. */
! gfc_conv_aliased_arg (&se, e, 0,
last_dt == READ ? INTENT_IN : INTENT_OUT);
tmp = build_fold_indirect_ref (se.expr);
se.expr = gfc_build_addr_expr (pchar_type_node, tmp);
--- 724,734 ----
{
se.ss = gfc_walk_expr (e);
! if (is_subref_array (e))
{
/* Use a temporary for components of arrays of derived types
or substring array references. */
! gfc_conv_subref_array_arg (&se, e, 0,
last_dt == READ ? INTENT_IN : INTENT_OUT);
tmp = build_fold_indirect_ref (se.expr);
se.expr = gfc_build_addr_expr (pchar_type_node, tmp);
*************** gfc_trans_transfer (gfc_code * code)
*** 1964,1970 ****
gcc_assert (ref->type == REF_ARRAY);
}
! if (expr->ts.type != BT_DERIVED && ref && ref->next == NULL)
{
/* Get the descriptor. */
gfc_conv_expr_descriptor (&se, expr, ss);
--- 1964,1972 ----
gcc_assert (ref->type == REF_ARRAY);
}
! if (expr->ts.type != BT_DERIVED
! && ref && ref->next == NULL
! && !is_subref_array (expr))
{
/* Get the descriptor. */
gfc_conv_expr_descriptor (&se, expr, ss);