This is the mail archive of the
fortran@gcc.gnu.org
mailing list for the GNU Fortran project.
RFC: Revamp fortran array types
- From: Michael Matz <matz at suse dot de>
- To: gcc-patches at gcc dot gnu dot org, fortran at gcc dot gnu dot org
- Date: Tue, 11 Aug 2009 17:53:44 +0200 (CEST)
- Subject: RFC: Revamp fortran array types
Aloha,
now that richi revamped the middle-ends handling of restrict to properly
be reflected in the alias information we can put that to very good use in
fortran. The immediate cause to look into this was 459.GemsFDTD of
spec2006. One example loop that better be vectorized but isn't is (only
showing the interesting parts)
--------------------------------------------------------------------
real(kind=rfp), dimension(:,:,:), allocatable :: Dx_ilow, Dx_ihigh
...
real(kind=rfp), dimension(:), allocatable :: axe, aye, aze
real(kind=rfp) :: epsinv
...
SUBROUTINE UPMLupdateE(nx,ny,nz,Hx,Hy,Hz,Ex,Ey,Ez)
...
real(kind=rfp), intent(inout),
& dimension(xstart:xstop+1,ystart:ystop+1,zstart:zstop+1) :: Ex, Ey, Ez
...
do k=zstart+1,zstop
do j=ystart+1,ystop
do i=xstart+1,0
Dxold = Dx_ilow(i,j,k)
Dx_ilow(i,j,k) = aye(j) * Dx_ilow(i,j,k) +
& bye(j) * ((Hz(i,j,k )-Hz(i,j-1,k))*dyinv +
& (Hy(i,j,k-1)-Hy(i,j,k ))*dzinv)
Ex(i,j,k) = aze(k) * Ex(i,j,k) +
& bze(k) * (cxh(i)*Dx_ilow(i,j,k) - fxh(i)*Dxold) * epsinv
end do
end do
end do
-----------------------------------------------------------------
This loop shows many deficiencies in the current fortran types. We have
functions parameters of array type, global scalar variables and global
arrays. The loop isn't vectorizable because all of the various pointers
involved are not known to not alias, hence the array writes are thought to
alias the access to the global scalars (e.g. epsinv or dyinv), and to the
global array (e.g. aye) and parameter arrays (e.g. Ex).
The correct solution for all of this is for the fortran frontend to use
restrict pointers or references where ever possible. (The current
flag_argument_noalias hack doesn't help with globals and is inherently
broken anyway, at least if using the 'target' attribute). The alias
machinery in the middle-end will make sure that restrict pointers into the
same array all conflict with each other, and restrict pointers into
different arrays don't conflict. Non-restrict pointers conflict as usual
with restrict ones and with others.
So, this is what the patch implements. If we're building an array type we
try very hard to build a "void * restrict" or "real(kind=X) * restrict"
pointer as data pointer type, instead of an unrestricted variant. We can
do this as long as the symbol for which we're building the type isn't
marked with the 'target' attribute, as far as I understood the fortran
guys.
When I have a symbol I can simply look at its attr.target member, when I
don't have a symbol (temporary arrays) it depends on the situation. In
one case it seems to build an array descriptor to create a view of another
array, so I chose the safe side to not use a restrict type. In other
cases it allocates a fresh temp array, nobody else can point into this
one, so a restrict pointer is possible.
Now, that part solves the problems with arrays (global and argument
arrays). What's left is the problem with global scalars. We aren't
building pointers to them, instead we do direct accesses. So there's no
place to stash a restrict qualifier onto. But fortran still guarantess
that if a global isn't marked as 'target' then writes through other
globals or arrays, or anything, can't change that global. The correct way
to deal with this is to give that global its own alias set.
I implement the latter by building a new type for non-target scalar
globals, giving it a distinct alias set (which in particular doesn't
conflict with the normal alias set that e.g. a store to some array element
gets). This is what the nontarget_type thingy is about. In order not to
generate a zillion of new types (one per global) I cache the nontarget
variant of each type in TYPE_LANG_SPECIFIC (type). Which unfortunately
also means to allocate it for non-array types, but I do this only
on-demand.
Then there's one problem left, that is with scalar arguments. They are
passed by reference, hence would create similar problems to unrestricted
arrays, so I build a restricted reference type for arguments not marked as
target.
With all of this the flag_argument_noalias hack isn't required anymore and
in fact gets in our way, so the patch also removes it from
tree-ssa-structalias.c in addition to also fixing an ommission (when the
first field in a structure is restrict qualified the alias solver didn't
add the right constraints).
Variants of this patch bootstrapped without regressions, but currently I'm
not yet seeking approval (in fact I see that there're very few new
regressions due to some last changes, which I'll look at), which is also
why a ChangeLog entry is missing. What I'm more interested in is comments
about the actual implementation of passing around the non-target-ness of
symbols to be used in the type building routines.
FWIW: one variant of the patch which simply _always_ used restrict
qualified types produced no regressions in the fortran testsuite (actually
that's expected as otherwise similar errors would have shown with the
flag_argument_noalias hack).
Ohh, btw. with this patch 459.GemsFDTD and these options:
-O3 -g -ffast-math -funroll-loops -fpeel-loops -march=barcelona
behaves like this (base without patch, peak with):
base peak
runtime runtime
459.GemsFDTD 10610 1260 8.43 * 10610 1130 9.38 *
So, 10% improvement. Comments, advise?
Ciao,
Michael.
Index: tree-ssa-structalias.c
===================================================================
--- tree-ssa-structalias.c (revision 150523)
+++ tree-ssa-structalias.c (working copy)
@@ -4519,6 +4519,13 @@ create_variable_info_for (tree decl, con
vi->size = fo->size;
vi->offset = fo->offset;
vi->may_have_pointers = fo->may_have_pointers;
+ if (vi->is_global_var
+ && (!flag_whole_program || !in_ipa_mode)
+ && vi->may_have_pointers)
+ {
+ if (fo->only_restrict_pointers)
+ make_constraint_from_restrict (vi, "GLOBAL_RESTRICT");
+ }
for (i = VEC_length (fieldoff_s, fieldstack) - 1;
i >= 1 && VEC_iterate (fieldoff_s, fieldstack, i, fo);
i--)
@@ -4611,43 +4618,8 @@ intra_create_variable_infos (void)
if (!could_have_pointers (t))
continue;
- /* If flag_argument_noalias is set, then function pointer
- arguments are guaranteed not to point to each other. In that
- case, create an artificial variable PARM_NOALIAS and the
- constraint ARG = &PARM_NOALIAS. */
- if (POINTER_TYPE_P (TREE_TYPE (t)) && flag_argument_noalias > 0)
- {
- varinfo_t vi;
- var_ann_t ann;
-
- vi = make_constraint_from_heapvar (get_vi_for_tree (t),
- "PARM_NOALIAS");
- ann = get_var_ann (vi->decl);
- if (flag_argument_noalias == 1)
- {
- ann->noalias_state = NO_ALIAS;
- make_copy_constraint (vi, nonlocal_id);
- }
- else if (flag_argument_noalias == 2)
- {
- ann->noalias_state = NO_ALIAS_GLOBAL;
- make_constraint_from (vi, vi->id);
- }
- else if (flag_argument_noalias == 3)
- {
- ann->noalias_state = NO_ALIAS_ANYTHING;
- make_constraint_from (vi, vi->id);
- }
- else
- gcc_unreachable ();
- }
- else
- {
- varinfo_t arg_vi = get_vi_for_tree (t);
-
- for (p = arg_vi; p; p = p->next)
- make_constraint_from (p, nonlocal_id);
- }
+ for (p = get_vi_for_tree (t); p; p = p->next)
+ make_constraint_from (p, nonlocal_id);
if (POINTER_TYPE_P (TREE_TYPE (t))
&& TYPE_RESTRICT (TREE_TYPE (t)))
make_constraint_from_restrict (get_vi_for_tree (t), "PARM_RESTRICT");
Index: fortran/trans-array.c
===================================================================
--- fortran/trans-array.c (revision 150523)
+++ fortran/trans-array.c (working copy)
@@ -725,7 +725,7 @@ gfc_trans_create_temp_array (stmtblock_t
/* Initialize the descriptor. */
type =
gfc_get_array_type_bounds (eltype, info->dimen, loop->from, loop->to, 1,
- GFC_ARRAY_UNKNOWN);
+ GFC_ARRAY_UNKNOWN, true);
desc = gfc_create_var (type, "atmp");
GFC_DECL_PACKED_ARRAY (desc) = 1;
@@ -1715,7 +1715,7 @@ gfc_build_constant_array_constructor (gf
as.upper[i] = gfc_int_expr (tmp - 1);
}
- tmptype = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC);
+ tmptype = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC, true);
init = build_constructor_from_list (tmptype, nreverse (list));
@@ -5250,7 +5250,7 @@ gfc_conv_expr_descriptor (gfc_se * se, g
parmtype = gfc_get_element_type (TREE_TYPE (desc));
parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen,
loop.from, loop.to, 0,
- GFC_ARRAY_UNKNOWN);
+ GFC_ARRAY_UNKNOWN, false);
parm = gfc_create_var (parmtype, "parm");
}
Index: fortran/trans-expr.c
===================================================================
--- fortran/trans-expr.c (revision 150523)
+++ fortran/trans-expr.c (working copy)
@@ -1611,7 +1611,7 @@ gfc_get_interface_mapping_array (stmtblo
tree var;
type = gfc_typenode_for_spec (&sym->ts);
- type = gfc_get_nodesc_array_type (type, sym->as, packed);
+ type = gfc_get_nodesc_array_type (type, sym->as, packed, !sym->attr.target);
var = gfc_create_var (type, "ifm");
gfc_add_modify (block, var, fold_convert (type, data));
Index: fortran/trans-stmt.c
===================================================================
--- fortran/trans-stmt.c (revision 150523)
+++ fortran/trans-stmt.c (working copy)
@@ -2694,7 +2694,7 @@ gfc_trans_pointer_assign_need_temp (gfc_
parmtype = gfc_get_element_type (TREE_TYPE (desc));
parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen,
loop.from, loop.to, 1,
- GFC_ARRAY_UNKNOWN);
+ GFC_ARRAY_UNKNOWN, true);
/* Allocate temporary for nested forall construct. */
tmp1 = allocate_temp_for_forall_nest (nested_forall_info, parmtype,
Index: fortran/trans.c
===================================================================
--- fortran/trans.c (revision 150523)
+++ fortran/trans.c (working copy)
@@ -159,11 +159,21 @@ gfc_add_modify (stmtblock_t * pblock, tr
tree tmp;
#ifdef ENABLE_CHECKING
+ tree t1, t2;
+ t1 = TREE_TYPE (rhs);
+ t2 = TREE_TYPE (lhs);
+ /* XXX This is actually backwards, we should test the "base" type
+ from which the nontarget_type was copied, but we don't have this
+ backlink. This will do for now. */
+ if (TYPE_LANG_SPECIFIC (t1))
+ t1 = TYPE_LANG_SPECIFIC (t1)->nontarget_type;
+ if (TYPE_LANG_SPECIFIC (t2))
+ t2 = TYPE_LANG_SPECIFIC (t2)->nontarget_type;
/* Make sure that the types of the rhs and the lhs are the same
for scalar assignments. We should probably have something
similar for aggregates, but right now removing that check just
breaks everything. */
- gcc_assert (TREE_TYPE (rhs) == TREE_TYPE (lhs)
+ gcc_assert (t1 == t2
|| AGGREGATE_TYPE_P (TREE_TYPE (lhs)));
#endif
@@ -509,7 +519,7 @@ gfc_call_malloc (stmtblock_t * block, tr
size = fold_convert (size_type_node, size);
/* Create a variable to hold the result. */
- res = gfc_create_var (pvoid_type_node, NULL);
+ res = gfc_create_var (prvoid_type_node, NULL);
/* size < 0 ? */
negative = fold_build2 (LT_EXPR, boolean_type_node, size,
@@ -529,9 +539,9 @@ gfc_call_malloc (stmtblock_t * block, tr
build_int_cst (size_type_node, 1));
gfc_add_modify (&block2, res,
- build_call_expr_loc (input_location,
- built_in_decls[BUILT_IN_MALLOC], 1,
- size));
+ fold_convert (prvoid_type_node,
+ build_call_expr_loc (input_location,
+ built_in_decls[BUILT_IN_MALLOC], 1, size)));
null_result = fold_build2 (EQ_EXPR, boolean_type_node, res,
build_int_cst (pvoid_type_node, 0));
msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
@@ -601,7 +611,7 @@ gfc_allocate_with_status (stmtblock_t *
size = fold_convert (size_type_node, size);
/* Create a variable to hold the result. */
- res = gfc_create_var (pvoid_type_node, NULL);
+ res = gfc_create_var (prvoid_type_node, NULL);
/* Set the optional status variable to zero. */
if (status != NULL_TREE && !integer_zerop (status))
@@ -633,7 +643,7 @@ gfc_allocate_with_status (stmtblock_t *
fold_build1 (INDIRECT_REF, status_type, status),
build_int_cst (status_type, LIBERROR_ALLOCATION));
gfc_add_modify (&set_status_block, res,
- build_int_cst (pvoid_type_node, 0));
+ build_int_cst (prvoid_type_node, 0));
tmp = fold_build2 (EQ_EXPR, boolean_type_node, status,
build_int_cst (TREE_TYPE (status), 0));
@@ -644,11 +654,12 @@ gfc_allocate_with_status (stmtblock_t *
/* The allocation itself. */
gfc_start_block (&alloc_block);
gfc_add_modify (&alloc_block, res,
- build_call_expr_loc (input_location,
+ fold_convert (prvoid_type_node,
+ build_call_expr_loc (input_location,
built_in_decls[BUILT_IN_MALLOC], 1,
fold_build2 (MAX_EXPR, size_type_node,
size,
- build_int_cst (size_type_node, 1))));
+ build_int_cst (size_type_node, 1)))));
msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
("Out of memory"));
@@ -671,7 +682,7 @@ gfc_allocate_with_status (stmtblock_t *
tmp = fold_build3 (COND_EXPR, void_type_node,
fold_build2 (EQ_EXPR, boolean_type_node, res,
- build_int_cst (pvoid_type_node, 0)),
+ build_int_cst (prvoid_type_node, 0)),
tmp, build_empty_stmt (input_location));
gfc_add_expr_to_block (&alloc_block, tmp);
@@ -723,7 +734,7 @@ gfc_allocate_array_with_status (stmtbloc
size = fold_convert (size_type_node, size);
/* Create a variable to hold the result. */
- res = gfc_create_var (pvoid_type_node, NULL);
+ res = gfc_create_var (type, NULL);
null_mem = fold_build2 (EQ_EXPR, boolean_type_node, mem,
build_int_cst (type, 0));
Index: fortran/trans-types.c
===================================================================
--- fortran/trans-types.c (revision 150523)
+++ fortran/trans-types.c (working copy)
@@ -59,6 +59,7 @@ tree gfc_array_index_type;
tree gfc_array_range_type;
tree gfc_character1_type_node;
tree pvoid_type_node;
+tree prvoid_type_node;
tree ppvoid_type_node;
tree pchar_type_node;
tree pfunc_type_node;
@@ -67,7 +68,7 @@ tree gfc_charlen_type_node;
static GTY(()) tree gfc_desc_dim_type;
static GTY(()) tree gfc_max_array_element_size;
-static GTY(()) tree gfc_array_descriptor_base[GFC_MAX_DIMENSIONS];
+static GTY(()) tree gfc_array_descriptor_base[2 * GFC_MAX_DIMENSIONS];
/* Arrays for all integral and real kinds. We'll fill this in at runtime
after the target has a chance to process command-line options. */
@@ -866,6 +867,7 @@ gfc_init_types (void)
#undef PUSH_TYPE
pvoid_type_node = build_pointer_type (void_type_node);
+ prvoid_type_node = build_qualified_type (pvoid_type_node, TYPE_QUAL_RESTRICT);
ppvoid_type_node = build_pointer_type (pvoid_type_node);
pchar_type_node = build_pointer_type (gfc_character1_type_node);
pfunc_type_node
@@ -1202,7 +1204,7 @@ gfc_is_nodesc_array (gfc_symbol * sym)
static tree
gfc_build_array_type (tree type, gfc_array_spec * as,
- enum gfc_array_kind akind)
+ enum gfc_array_kind akind, bool nontarget)
{
tree lbound[GFC_MAX_DIMENSIONS];
tree ubound[GFC_MAX_DIMENSIONS];
@@ -1220,7 +1222,8 @@ gfc_build_array_type (tree type, gfc_arr
if (as->type == AS_ASSUMED_SHAPE)
akind = GFC_ARRAY_ASSUMED_SHAPE;
- return gfc_get_array_type_bounds (type, as->rank, lbound, ubound, 0, akind);
+ return gfc_get_array_type_bounds (type, as->rank, lbound, ubound, 0, akind,
+ nontarget);
}
/* Returns the struct descriptor_dimension type. */
@@ -1365,7 +1368,8 @@ gfc_get_dtype (tree type)
to the value of PACKED. */
tree
-gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, gfc_packed packed)
+gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, gfc_packed packed,
+ bool nontarget)
{
tree range;
tree type;
@@ -1474,6 +1478,10 @@ gfc_get_nodesc_array_type (tree etype, g
/* TODO: use main type if it is unbounded. */
GFC_TYPE_ARRAY_DATAPTR_TYPE (type) =
build_pointer_type (build_array_type (etype, range));
+ if (nontarget)
+ GFC_TYPE_ARRAY_DATAPTR_TYPE (type) =
+ build_qualified_type (GFC_TYPE_ARRAY_DATAPTR_TYPE (type),
+ TYPE_QUAL_RESTRICT);
if (known_stride)
{
@@ -1519,6 +1527,8 @@ gfc_get_nodesc_array_type (tree etype, g
/* For dummy arrays and automatic (heap allocated) arrays we
want a pointer to the array. */
type = build_pointer_type (type);
+ if (nontarget)
+ type = build_qualified_type (type, TYPE_QUAL_RESTRICT);
GFC_ARRAY_TYPE_P (type) = 1;
TYPE_LANG_SPECIFIC (type) = TYPE_LANG_SPECIFIC (TREE_TYPE (type));
}
@@ -1528,14 +1538,15 @@ gfc_get_nodesc_array_type (tree etype, g
/* Return or create the base type for an array descriptor. */
static tree
-gfc_get_array_descriptor_base (int dimen)
+gfc_get_array_descriptor_base (int dimen, bool nontarget)
{
tree fat_type, fieldlist, decl, arraytype;
char name[16 + GFC_RANK_DIGITS + 1];
+ int idx = 2 * (dimen - 1) + nontarget;
gcc_assert (dimen >= 1 && dimen <= GFC_MAX_DIMENSIONS);
- if (gfc_array_descriptor_base[dimen - 1])
- return gfc_array_descriptor_base[dimen - 1];
+ if (gfc_array_descriptor_base[idx])
+ return gfc_array_descriptor_base[idx];
/* Build the type node. */
fat_type = make_node (RECORD_TYPE);
@@ -1545,7 +1556,8 @@ gfc_get_array_descriptor_base (int dimen
/* Add the data member as the first element of the descriptor. */
decl = build_decl (input_location,
- FIELD_DECL, get_identifier ("data"), ptr_type_node);
+ FIELD_DECL, get_identifier ("data"),
+ nontarget ? prvoid_type_node : ptr_type_node);
DECL_CONTEXT (decl) = fat_type;
fieldlist = decl;
@@ -1585,7 +1597,7 @@ gfc_get_array_descriptor_base (int dimen
gfc_finish_type (fat_type);
TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (fat_type)) = 1;
- gfc_array_descriptor_base[dimen - 1] = fat_type;
+ gfc_array_descriptor_base[idx] = fat_type;
return fat_type;
}
@@ -1594,14 +1606,14 @@ gfc_get_array_descriptor_base (int dimen
tree
gfc_get_array_type_bounds (tree etype, int dimen, tree * lbound,
tree * ubound, int packed,
- enum gfc_array_kind akind)
+ enum gfc_array_kind akind, bool nontarget)
{
char name[8 + GFC_RANK_DIGITS + GFC_MAX_SYMBOL_LEN];
tree fat_type, base_type, arraytype, lower, upper, stride, tmp, rtype;
const char *type_name;
int n;
- base_type = gfc_get_array_descriptor_base (dimen);
+ base_type = gfc_get_array_descriptor_base (dimen, nontarget);
fat_type = build_distinct_type_copy (base_type);
TYPE_CANONICAL (fat_type) = base_type;
TYPE_STUB_DECL (fat_type) = TYPE_STUB_DECL (base_type);
@@ -1684,6 +1696,8 @@ gfc_get_array_type_bounds (tree etype, i
rtype = gfc_array_range_type;
arraytype = build_array_type (etype, rtype);
arraytype = build_pointer_type (arraytype);
+ if (nontarget)
+ arraytype = build_qualified_type (arraytype, TYPE_QUAL_RESTRICT);
GFC_TYPE_ARRAY_DATAPTR_TYPE (fat_type) = arraytype;
/* This will generate the base declarations we need to emit debug
@@ -1769,7 +1783,8 @@ gfc_sym_type (gfc_symbol * sym)
{
type = gfc_get_nodesc_array_type (type, sym->as,
byref ? PACKED_FULL
- : PACKED_STATIC);
+ : PACKED_STATIC,
+ !sym->attr.target);
byref = 0;
}
}
@@ -1780,7 +1795,7 @@ gfc_sym_type (gfc_symbol * sym)
akind = GFC_ARRAY_POINTER;
else if (sym->attr.allocatable)
akind = GFC_ARRAY_ALLOCATABLE;
- type = gfc_build_array_type (type, sym->as, akind);
+ type = gfc_build_array_type (type, sym->as, akind, !sym->attr.target);
}
}
else
@@ -1801,7 +1816,11 @@ gfc_sym_type (gfc_symbol * sym)
if (sym->attr.optional || sym->ns->proc_name->attr.entry_master)
type = build_pointer_type (type);
else
- type = build_reference_type (type);
+ {
+ type = build_reference_type (type);
+ if (!sym->attr.target)
+ type = build_qualified_type (type, TYPE_QUAL_RESTRICT);
+ }
}
return (type);
@@ -2096,11 +2115,13 @@ gfc_get_derived_type (gfc_symbol * deriv
akind = GFC_ARRAY_ALLOCATABLE;
/* Pointers to arrays aren't actually pointer types. The
descriptors are separate, but the data is common. */
- field_type = gfc_build_array_type (field_type, c->as, akind);
+ field_type = gfc_build_array_type (field_type, c->as, akind,
+ !c->attr.target);
}
else
field_type = gfc_get_nodesc_array_type (field_type, c->as,
- PACKED_STATIC);
+ PACKED_STATIC,
+ !c->attr.target);
}
else if (c->attr.pointer)
field_type = build_pointer_type (field_type);
Index: fortran/trans.h
===================================================================
--- fortran/trans.h (revision 150523)
+++ fortran/trans.h (working copy)
@@ -629,6 +629,7 @@ struct GTY(()) lang_type {
tree dataptr_type;
tree span;
tree base_decl[2];
+ tree nontarget_type;
};
struct GTY(()) lang_decl {
Index: fortran/trans-types.h
===================================================================
--- fortran/trans-types.h (revision 150523)
+++ fortran/trans-types.h (working copy)
@@ -29,6 +29,7 @@ extern GTY(()) tree gfc_array_range_type
extern GTY(()) tree gfc_character1_type_node;
extern GTY(()) tree ppvoid_type_node;
extern GTY(()) tree pvoid_type_node;
+extern GTY(()) tree prvoid_type_node;
extern GTY(()) tree pchar_type_node;
/* This is the type used to hold the lengths of character variables.
@@ -72,8 +73,8 @@ tree gfc_build_uint_type (int);
tree gfc_get_element_type (tree);
tree gfc_get_array_type_bounds (tree, int, tree *, tree *, int,
- enum gfc_array_kind);
-tree gfc_get_nodesc_array_type (tree, gfc_array_spec *, gfc_packed);
+ enum gfc_array_kind, bool);
+tree gfc_get_nodesc_array_type (tree, gfc_array_spec *, gfc_packed, bool);
/* Add a field of given name and type to a UNION_TYPE or RECORD_TYPE. */
tree gfc_add_field_to_struct (tree *, tree, tree, tree);
Index: fortran/trans-decl.c
===================================================================
--- fortran/trans-decl.c (revision 150523)
+++ fortran/trans-decl.c (working copy)
@@ -578,6 +578,28 @@ gfc_finish_var_decl (tree decl, gfc_symb
if (sym->attr.threadprivate
&& (TREE_STATIC (decl) || DECL_EXTERNAL (decl)))
DECL_TLS_MODEL (decl) = decl_default_tls_model (decl);
+
+ if (!sym->attr.target
+ && (TREE_PUBLIC (decl) || TREE_STATIC (decl))
+ /* For now, don't bother with aggregate types. We would need
+ to adjust DECL_CONTEXT of all field decls. */
+ && !AGGREGATE_TYPE_P (TREE_TYPE (decl)))
+ {
+ tree type = TREE_TYPE (decl);
+ if (!TYPE_LANG_SPECIFIC (type))
+ TYPE_LANG_SPECIFIC (type) = (struct lang_type *)
+ ggc_alloc_cleared (sizeof (struct lang_type));
+ if (!TYPE_LANG_SPECIFIC (type)->nontarget_type)
+ {
+ alias_set_type set = new_alias_set ();
+ type = build_distinct_type_copy (type);
+ TYPE_ALIAS_SET (type) = set;
+ TYPE_LANG_SPECIFIC (type)->nontarget_type = type;
+ }
+ else
+ type = TYPE_LANG_SPECIFIC (type)->nontarget_type;
+ TREE_TYPE (decl) = type;
+ }
}
@@ -840,7 +862,8 @@ gfc_build_dummy_array_decl (gfc_symbol *
}
type = gfc_typenode_for_spec (&sym->ts);
- type = gfc_get_nodesc_array_type (type, sym->as, packed);
+ type = gfc_get_nodesc_array_type (type, sym->as, packed,
+ !sym->attr.target);
}
else
{