1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
|
From f90642b60dbe411df162174646348f4a7d5e1a63 Mon Sep 17 00:00:00 2001
From: pault <pault@138bc75d-0d04-0410-961f-82ee72b054a4>
Date: Sat, 30 Apr 2011 12:00:50 +0000
Subject: [PATCH] 2011-04-30 Paul Thomas <pault@gcc.gnu.org>
PR fortran/48462
PR fortran/48746
* trans-expr.c ( arrayfunc_assign_needs_temporary): Need a temp
if automatic reallocation on assignement is active, the lhs is a
target and the rhs an intrinsic function.
(realloc_lhs_bounds_for_intrinsic_call): Rename as next.
(fcncall_realloc_result): Renamed version of above function.
Free the original descriptor data after the function call.Set the bounds and the
offset so that the lbounds are one.
(gfc_trans_arrayfunc_assign): Call renamed function.
2011-04-30 Paul Thomas <pault@gcc.gnu.org>
PR fortran/48462
PR fortran/48746
* gfortran.dg/realloc_on_assign_7.f03: New test.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/branches/gcc-4_6-branch@173214 138bc75d-0d04-0410-961f-82ee72b054a4
index da7cfba..1d678e6 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -5444,9 +5444,12 @@ arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2)
return true;
/* If we have reached here with an intrinsic function, we do not
- need a temporary. */
+ need a temporary except in the particular case that reallocation
+ on assignment is active and the lhs is allocatable and a target. */
if (expr2->value.function.isym)
- return false;
+ return (gfc_option.flag_realloc_lhs
+ && sym->attr.allocatable
+ && sym->attr.target);
/* If the LHS is a dummy, we need a temporary if it is not
INTENT(OUT). */
@@ -5528,23 +5531,38 @@ realloc_lhs_loop_for_fcn_call (gfc_se *se, locus *where, gfc_ss **ss)
}
+/* For Assignment to a reallocatable lhs from intrinsic functions,
+ replace the se.expr (ie. the result) with a temporary descriptor.
+ Null the data field so that the library allocates space for the
+ result. Free the data of the original descriptor after the function,
+ in case it appears in an argument expression and transfer the
+ result to the original descriptor. */
+
static void
-realloc_lhs_bounds_for_intrinsic_call (gfc_se *se, int rank)
+fcncall_realloc_result (gfc_se *se, int rank)
{
tree desc;
+ tree res_desc;
tree tmp;
tree offset;
int n;
- /* Use the allocation done by the library. */
+ /* Use the allocation done by the library. Substitute the lhs
+ descriptor with a copy, whose data field is nulled.*/
desc = build_fold_indirect_ref_loc (input_location, se->expr);
- tmp = gfc_conv_descriptor_data_get (desc);
- tmp = gfc_call_free (fold_convert (pvoid_type_node, tmp));
- gfc_add_expr_to_block (&se->pre, tmp);
- gfc_conv_descriptor_data_set (&se->pre, desc, null_pointer_node);
/* Unallocated, the descriptor does not have a dtype. */
tmp = gfc_conv_descriptor_dtype (desc);
gfc_add_modify (&se->pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
+ res_desc = gfc_evaluate_now (desc, &se->pre);
+ gfc_conv_descriptor_data_set (&se->pre, res_desc, null_pointer_node);
+ se->expr = gfc_build_addr_expr (TREE_TYPE (se->expr), res_desc);
+
+ /* Free the lhs after the function call and copy the result to
+ the lhs descriptor. */
+ tmp = gfc_conv_descriptor_data_get (desc);
+ tmp = gfc_call_free (fold_convert (pvoid_type_node, tmp));
+ gfc_add_expr_to_block (&se->post, tmp);
+ gfc_add_modify (&se->post, desc, res_desc);
offset = gfc_index_zero_node;
tmp = gfc_index_one_node;
@@ -5580,7 +5598,6 @@ realloc_lhs_bounds_for_intrinsic_call (gfc_se *se, int rank)
}
-
/* Try to translate array(:) = func (...), where func is a transformational
array function, without using a temporary. Returns NULL if this isn't the
case. */
@@ -5645,7 +5662,7 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
ss->is_alloc_lhs = 1;
}
else
- realloc_lhs_bounds_for_intrinsic_call (&se, expr1->rank);
+ fcncall_realloc_result (&se, expr1->rank);
}
gfc_conv_function_expr (&se, expr2);
new file mode 100644
index 0000000..f871d27
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/realloc_on_assign_7.f03
@@ -0,0 +1,84 @@
+! { dg-do run }
+! Check the fix for PR48462 in which the assignments involving matmul
+! seg faulted because a was automatically freed before the assignment.
+! Since it is related, the test for the fix of PR48746 has been added
+! as a subroutine by that name.
+!
+! Contributed by John Nedney <ortp21@gmail.com>
+!
+program main
+ implicit none
+ integer, parameter :: dp = kind(0.0d0)
+ real(kind=dp), allocatable :: delta(:,:)
+ real(kind=dp), allocatable, target :: a(:,:)
+ real(kind=dp), pointer :: aptr(:,:)
+
+ allocate(a(3,3))
+ aptr => a
+
+ call foo
+ if (.not. associated (aptr, a)) call abort () ! reallocated to same size - remains associated
+ call bar
+ if (.not. associated (aptr, a)) call abort () ! reallocated to smaller size - remains associated
+ call foobar
+ if (associated (aptr, a)) call abort () ! reallocated to larger size - disassociates
+
+ call pr48746
+contains
+!
+! Original reduced version from comment #2
+ subroutine foo
+ implicit none
+ real(kind=dp), allocatable :: b(:,:)
+
+ allocate(b(3,3))
+ allocate(delta(3,3))
+
+ a = reshape ([1d0, 2d0, 3d0, 4d0, 5d0, 6d0, 7d0, 8d0, 9d0], [3,3])
+ b = reshape ([1d0, 0d0, 0d0, 0d0, 1d0, 0d0, 0d0, 0d0, 1d0], [3,3])
+
+ a = matmul( matmul( a, b ), b )
+ delta = (a - reshape ([1d0, 2d0, 3d0, 4d0, 5d0, 6d0, 7d0, 8d0, 9d0], [3,3]))**2
+ if (any (delta > 1d-12)) call abort
+ if (any (lbound (a) .ne. [1, 1])) call abort
+ end subroutine
+!
+! Check that all is well when the shape of 'a' changes.
+ subroutine bar
+ implicit none
+ real(kind=dp), allocatable :: a(:,:)
+ real(kind=dp), allocatable :: b(:,:)
+
+ b = reshape ([1d0, 1d0, 1d0], [3,1])
+ a = reshape ([1d0, 2d0, 3d0, 4d0, 5d0, 6d0, 7d0, 8d0, 9d0], [3,3])
+
+ a = matmul( a, matmul( a, b ) )
+
+ delta = (a - reshape ([198d0, 243d0, 288d0], [3,1]))**2
+ if (any (delta > 1d-12)) call abort
+ if (any (lbound (a) .ne. [1, 1])) call abort
+ end subroutine
+ subroutine foobar
+ integer :: i
+ a = reshape ([(real(i, dp), i = 1, 100)],[10,10])
+ end subroutine
+ subroutine pr48746
+! This is a further wrinkle on the original problem and came about
+! because the dtype field of the result argument, passed to matmul,
+! was not being set. This is needed by matmul for the rank.
+!
+! Contributed by Thomas Koenig <tkoenig@gcc.gnu.org>
+!
+ implicit none
+ integer, parameter :: m=10, n=12, count=4
+ real :: optmatmul(m, n)
+ real :: a(m, count), b(count, n), c(m, n)
+ real, dimension(:,:), allocatable :: tmp
+ call random_number(a)
+ call random_number(b)
+ tmp = matmul(a,b)
+ if (any (lbound (tmp) .ne. [1,1])) call abort
+ if (any (ubound (tmp) .ne. [10,12])) call abort
+ end subroutine
+end program main
+
--
1.7.0.4
|
