[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Factorisation initialisation dimension descripteur
https://gcc.gnu.org/g:3fa282684d0e60d53a06190429b9ee9d8ea15d55
commit 3fa282684d0e60d53a06190429b9ee9d8ea15d55
Author: Mikael Morin
Date: Sat Feb 8 21:37:49 2025 +0100
Factorisation initialisation dimension descripteur
Diff:
---
gcc/fortran/trans-array.cc | 87 +-
1 file changed, 48 insertions(+), 39 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 4d2d0378bea7..197f564146c3 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -1472,38 +1472,56 @@ gfc_build_null_descriptor (tree type)
}
-static tree
-set_descriptor_dimension (stmtblock_t *block, tree desc, int dim,
- tree lbound, tree ubound, tree stride, tree *offset)
+static void
+set_bounds_update_offset (stmtblock_t *block, tree desc, int dim,
+ tree lbound, tree ubound, tree stride, tree
lbound_diff,
+ tree *offset, tree *next_stride, bool
stride_unchanged)
{
- /* Set bounds in descriptor. */
+ /* Stabilize values in case the expressions depend on the existing bounds.
*/
lbound = fold_convert (gfc_array_index_type, lbound);
lbound = gfc_evaluate_now (lbound, block);
- gfc_conv_descriptor_lbound_set (block, desc,
- gfc_rank_cst[dim], lbound);
ubound = fold_convert (gfc_array_index_type, ubound);
ubound = gfc_evaluate_now (ubound, block);
- gfc_conv_descriptor_ubound_set (block, desc,
- gfc_rank_cst[dim], ubound);
- /* Set stride. */
stride = fold_convert (gfc_array_index_type, stride);
stride = gfc_evaluate_now (stride, block);
- gfc_conv_descriptor_stride_set (block, desc,
- gfc_rank_cst[dim], stride);
+
+ lbound_diff = fold_convert (gfc_array_index_type, lbound_diff);
+ lbound_diff = gfc_evaluate_now (lbound_diff, block);
+
+ gfc_conv_descriptor_lbound_set (block, desc,
+ gfc_rank_cst[dim], lbound);
+ gfc_conv_descriptor_ubound_set (block, desc,
+ gfc_rank_cst[dim], ubound);
+ if (!stride_unchanged)
+gfc_conv_descriptor_stride_set (block, desc,
+ gfc_rank_cst[dim], stride);
/* Update offset. */
tree tmp = fold_build2_loc (input_location, MULT_EXPR,
- gfc_array_index_type, lbound, stride);
- *offset = fold_build2_loc (input_location, MINUS_EXPR,
- gfc_array_index_type, *offset, tmp);
+ gfc_array_index_type, lbound_diff, stride);
+ tmp = fold_build2_loc (input_location, MINUS_EXPR,
+gfc_array_index_type, *offset, tmp);
+ *offset = gfc_evaluate_now (tmp, block);
+
+ if (!next_stride)
+return;
- /* Return stride for next dimension. */
+ /* Set stride for next dimension. */
tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
- stride = fold_build2_loc (input_location, MULT_EXPR,
- gfc_array_index_type, stride, tmp);
- return stride;
+ *next_stride = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, stride, tmp);
+}
+
+
+static void
+set_descriptor_dimension (stmtblock_t *block, tree desc, int dim,
+ tree lbound, tree ubound, tree stride, tree *offset,
+ tree *next_stride)
+{
+ set_bounds_update_offset (block, desc, dim, lbound, ubound, stride, lbound,
+ offset, next_stride, false);
}
@@ -1512,7 +1530,7 @@ set_descriptor_dimension (stmtblock_t *block, tree desc,
int dim,
static void
conv_shift_descriptor_lbound (stmtblock_t* block, tree from_desc, tree
to_desc, int dim,
- tree new_lbound, tree offset, bool zero_based)
+ tree new_lbound, tree *offset, bool zero_based)
{
new_lbound = fold_convert (gfc_array_index_type, new_lbound);
new_lbound = gfc_evaluate_now (new_lbound, block);
@@ -1536,18 +1554,9 @@ conv_shift_descriptor_lbound (stmtblock_t* block, tree
from_desc, tree to_desc,
updating the lbound, as they depend on the lbound expression! */
tree tmp1 = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
ubound, diff);
- gfc_conv_descriptor_ubound_set (block, to_desc, gfc_rank_cst[dim], tmp1);
- /* Set lbound to the value we want. */
- gfc_conv_descriptor_lbound_set (block, to_desc, gfc_rank_cst[dim],
new_lbound);
- tree offs_diff = fold_build2_loc (input_location, MULT_EXPR,
gfc_array_index_type,
- diff, stride);
- tree tmp2 = fold_build2_loc (input_location, MINUS_EXPR,
gfc_array_index_type,
- offset, offs_diff);
- gfc_add_modify (block, offset, tmp2);
-
- if (from_desc != to_desc)
-gfc_conv_descriptor_stride_set (block, to_desc, gfc_rank
[gcc r15-7446] ad target/118764: Fix a typo in doc/extend.texi.
https://gcc.gnu.org/g:0c7109abf215975f4b30a696c15541184f75d637
commit r15-7446-g0c7109abf215975f4b30a696c15541184f75d637
Author: Georg-Johann Lay
Date: Sat Feb 8 22:09:51 2025 +0100
ad target/118764: Fix a typo in doc/extend.texi.
gcc/
PR target/118764
* doc/invoke.texi (AVR Options): Fix typos.
Diff:
---
gcc/doc/invoke.texi | 6 +++---
1 file changed, 3 insertions(+), 3 deletions(-)
diff --git a/gcc/doc/invoke.texi b/gcc/doc/invoke.texi
index c33eb4425de5..0aef2abf05b9 100644
--- a/gcc/doc/invoke.texi
+++ b/gcc/doc/invoke.texi
@@ -24394,12 +24394,12 @@ Apart from providing a compact vector table, the
startup code will set bit
@code{CPUINT_CTRLA.CPUINT_CVT} which enables the CVT on the device.
When you do not want the startup code to set @code{CPUINT_CTRLA.CPUINT_CVT},
-then you can satisfy symbol @code{__do_cvt_init} so that the respective
+then you can satisfy symbol @code{__init_cvt} so that the respective
code is no more pulled in from @code{lib@var{mcu}.a}.
-For example, you can link with @code{-Wl,--defsym,__do_cvt_init=0}.
+For example, you can link with @code{-Wl,--defsym,__init_cvt=0}.
The CVT startup code is available since
-@w{@uref{https://github.com/avrdudes/avr-libc/issues/1010,AVR-LibC #1010}}.
+@w{@uref{https://github.com/avrdudes/avr-libc/issues/1010,AVR-LibC v2.3}}.
@opindex mfuse-add
@item -mfuse-add
[gcc r15-7448] [RISC-V][PR target/118146] Fix ICE for unsupported modes
https://gcc.gnu.org/g:9576353454e6c2a20a9742e2f29f17830766cd8a
commit r15-7448-g9576353454e6c2a20a9742e2f29f17830766cd8a
Author: Jeff Law
Date: Sat Feb 8 22:07:16 2025 -0700
[RISC-V][PR target/118146] Fix ICE for unsupported modes
There's some special case code in the risc-v move expander to try and
optimize
cases where the source is a subreg of a vector and the destination is a
scalar
mode.
The code works fine except when we have no support for the given mode. ie
HF or
BF when those extensions aren't enabled. We'll end up tripping an assert in
that case when we should have just let standard expansion do its thing.
Tested in my system for rv32 and rv64, but I'll wait for the pre-commit
tester
to render a verdict before moving forward.
PR target/118146
gcc/
* config/riscv/riscv.cc (riscv_legitimize_move): Handle subreg
of vector source better to avoid ICE.
gcc/testsuite
* gcc.target/riscv/pr118146-1.c: New test.
* gcc.target/riscv/pr118146-2.c: New test.
Diff:
---
gcc/config/riscv/riscv.cc | 9 +
gcc/testsuite/gcc.target/riscv/pr118146-1.c | 14 ++
gcc/testsuite/gcc.target/riscv/pr118146-2.c | 17 +
3 files changed, 36 insertions(+), 4 deletions(-)
diff --git a/gcc/config/riscv/riscv.cc b/gcc/config/riscv/riscv.cc
index 819e15387417..6e14126e3a4a 100644
--- a/gcc/config/riscv/riscv.cc
+++ b/gcc/config/riscv/riscv.cc
@@ -3587,6 +3587,9 @@ riscv_legitimize_move (machine_mode mode, rtx dest, rtx
src)
nunits = nunits * 2;
}
+ /* This test can fail if (for example) we want a HF and Z[v]fh is
+not enabled. In that case we just want to let the standard
+expansion path run. */
if (riscv_vector::get_vector_mode (smode, nunits).exists (&vmode))
{
rtx v = gen_lowpart (vmode, SUBREG_REG (src));
@@ -3636,12 +3639,10 @@ riscv_legitimize_move (machine_mode mode, rtx dest, rtx
src)
emit_move_insn (dest, gen_lowpart (GET_MODE (dest), int_reg));
else
emit_move_insn (dest, int_reg);
+ return true;
}
- else
- gcc_unreachable ();
-
- return true;
}
+
/* Expand
(set (reg:QI target) (mem:QI (address)))
to
diff --git a/gcc/testsuite/gcc.target/riscv/pr118146-1.c
b/gcc/testsuite/gcc.target/riscv/pr118146-1.c
new file mode 100644
index ..f3a7c4d96d84
--- /dev/null
+++ b/gcc/testsuite/gcc.target/riscv/pr118146-1.c
@@ -0,0 +1,14 @@
+/* { dg-do compile } */
+/* { dg-options "-march=rv64gcv -mabi=lp64d -O" { target { rv64 } } } */
+/* { dg-options "-march=rv32gcv -mabi=ilp32d -O" { target { rv32 } } } */
+
+
+
+typedef __attribute__((__vector_size__(sizeof(_Float16 short V;
+_Float16 f;
+
+void
+foo(V v)
+{
+ f -= *(_Float16 *)&v;
+}
diff --git a/gcc/testsuite/gcc.target/riscv/pr118146-2.c
b/gcc/testsuite/gcc.target/riscv/pr118146-2.c
new file mode 100644
index ..a37158abc18f
--- /dev/null
+++ b/gcc/testsuite/gcc.target/riscv/pr118146-2.c
@@ -0,0 +1,17 @@
+/* { dg-do compile } */
+/* { dg-options "-march=rv64gcv -mabi=lp64d -std=gnu23 -O2" { target { rv64 }
} } */
+/* { dg-options "-march=rv32gcv -mabi=ilp32d -std=gnu23 -O2" { target { rv32 }
} } */
+
+long print_halffloat_j;
+int *print_halffloat_block;
+void ftoastr(float);
+enum { BFLOATING_POINTvoid } print_halffloat() {
+ union {
+_Float16 x;
+char b[];
+ } u;
+ print_halffloat_j = 0;
+ for (; print_halffloat_j < sizeof(_Float16); print_halffloat_j++)
+u.b[print_halffloat_j] = print_halffloat_block[print_halffloat_j];
+ ftoastr(u.x);
+}
[gcc r15-7437] i386: Fix ICE with conditional QI/HI vector maxmin [PR118776]
https://gcc.gnu.org/g:64d8ea056a5c339700118a412dea1c44a57acf55
commit r15-7437-g64d8ea056a5c339700118a412dea1c44a57acf55
Author: Jakub Jelinek
Date: Sat Feb 8 08:54:31 2025 +0100
i386: Fix ICE with conditional QI/HI vector maxmin [PR118776]
The following testcase ICEs starting with GCC 12 since r12-4526
although the bug has been introduced already in r12-2751.
The problem was in the addition of cond_ define_expand
which uses nonimmediate_operand predicates for both maxmin operands
for all VI1248_AVX512VLBW modes. It works fine with
VI48_AVX512VL modes because the 3_mask VI48_AVX512VL
define_expand uses ix86_fixup_binary_operands_no_copy and the
*avx512f_3 VI48_AVX512VL define_insn uses
% in constraint and !(MEM_P && MEM_P) check in condition (and
3 define_expand with VI124_256_AVX512F_AVX512BW iterator
does that too), but eventhough the 8-bit and 16-bit element maxmin
is commutative too, the 3
define_insn with VI12_AVX512VL iterator didn't use % in constraint
to make it commutative. So, e.g. cond_umaxv32qi define_expand
allowed nonimmediate_operand for both umax operands, but used
gen_umaxv32qi_mask which wasn't commutative and only allowed
nonimmediate_operand for the second operand.
The following patch fixes it by keeping the 3
VI124_256_AVX512F_AVX512BW define_expand as is (it does
ix86_fixup_binary_operands_no_copy) but extending the
3_mask define_expand from VI48_AVX512VL to
VI1248_AVX512VLBW which keeps the current modes with their
ISA conditions and adds the VI12_AVX512VL modes under additional
TARGET_AVX512BW condition, and turning the actual define_insn
into an * prefixed name (which it was before just for the non-masked
case) and having the same commutative operand handling as in other
define_insns.
2025-02-08 Jakub Jelinek
PR target/118776
* config/i386/sse.md (3_mask): Use VI1248_AVX512VLBW
iterator rather than VI48_AVX512VL.
(3): Rename to ...
(*avx512bw_3): ... this. Use
nonimmediate_operand rather than register_operand predicate and %v
rather than v constraint for operand 1 and adjust condition to
reject
MEMs in both operand 1 and 2.
* gcc.target/i386/pr118776.c: New test.
Diff:
---
gcc/config/i386/sse.md | 18 +-
gcc/testsuite/gcc.target/i386/pr118776.c | 23 +++
2 files changed, 32 insertions(+), 9 deletions(-)
diff --git a/gcc/config/i386/sse.md b/gcc/config/i386/sse.md
index 9c495ffa40c6..7b39103d99f0 100644
--- a/gcc/config/i386/sse.md
+++ b/gcc/config/i386/sse.md
@@ -17703,12 +17703,12 @@
})
(define_expand "3_mask"
- [(set (match_operand:VI48_AVX512VL 0 "register_operand")
- (vec_merge:VI48_AVX512VL
- (maxmin:VI48_AVX512VL
- (match_operand:VI48_AVX512VL 1 "nonimmediate_operand")
- (match_operand:VI48_AVX512VL 2 "nonimmediate_operand"))
- (match_operand:VI48_AVX512VL 3 "nonimm_or_0_operand")
+ [(set (match_operand:VI1248_AVX512VLBW 0 "register_operand")
+ (vec_merge:VI1248_AVX512VLBW
+ (maxmin:VI1248_AVX512VLBW
+ (match_operand:VI1248_AVX512VLBW 1 "nonimmediate_operand")
+ (match_operand:VI1248_AVX512VLBW 2 "nonimmediate_operand"))
+ (match_operand:VI1248_AVX512VLBW 3 "nonimm_or_0_operand")
(match_operand: 4 "register_operand")))]
"TARGET_AVX512F"
"ix86_fixup_binary_operands_no_copy (, mode, operands);")
@@ -17724,12 +17724,12 @@
(set_attr "prefix" "maybe_evex")
(set_attr "mode" "")])
-(define_insn "3"
+(define_insn "*avx512bw_3"
[(set (match_operand:VI12_AVX512VL 0 "register_operand" "=v")
(maxmin:VI12_AVX512VL
- (match_operand:VI12_AVX512VL 1 "register_operand" "v")
+ (match_operand:VI12_AVX512VL 1 "nonimmediate_operand" "%v")
(match_operand:VI12_AVX512VL 2 "nonimmediate_operand" "vm")))]
- "TARGET_AVX512BW"
+ "TARGET_AVX512BW && !(MEM_P (operands[1]) && MEM_P (operands[2]))"
"vp\t{%2, %1,
%0|%0, %1, %2}"
[(set_attr "type" "sseiadd")
(set_attr "prefix" "evex")
diff --git a/gcc/testsuite/gcc.target/i386/pr118776.c
b/gcc/testsuite/gcc.target/i386/pr118776.c
new file mode 100644
index ..44c18caf8967
--- /dev/null
+++ b/gcc/testsuite/gcc.target/i386/pr118776.c
@@ -0,0 +1,23 @@
+/* PR target/118776 */
+/* { dg-do compile } */
+/* { dg-options "-O2 -mavx512bw -mavx512vl" } */
+
+void bar (unsigned char *);
+
+void
+foo (unsigned char *x)
+{
+ unsigned char b[32];
+ bar (b);
+ for (int i = 0; i < 32; i++)
+{
+ unsigned char c = 8;
+ if (i > 3)
+ {
+ unsigned char d = b[i];
+ d = 1 > d ? 1 : d;
+ c = d;
+ }
+ x[i] = c;
+}
+}
[gcc r15-7439] Clarify that effective-targets 'exceptions' and 'exceptions_enabled' are orthogonal
https://gcc.gnu.org/g:9f4feba699f3b3fef29bc8199db69a8eb7d64d07
commit r15-7439-g9f4feba699f3b3fef29bc8199db69a8eb7d64d07
Author: Thomas Schwinge
Date: Thu Feb 6 22:46:51 2025 +0100
Clarify that effective-targets 'exceptions' and 'exceptions_enabled' are
orthogonal
In Subversion r268025 (Git commit 3f21b8e3f7be32dd2b3624a2ece12f84bed545bb)
"Add dg-require-effective-target exceptions", effective-target 'exceptions'
was added, which "says that AMD GCN does not support [exception handling]".
In Subversion r279246 (Git commit a9046e9853024206bec092dd63e21e152cb5cbca)
"MSP430: Add -fno-exceptions multilib", effective-target
'exceptions_enabled'
was added "to check if the testing configuration supports exceptions".
Testing
"if exceptions are unsupported or disabled (e.g. by passing
-fno-exceptions)"
works as expected if exception handling is disabled at the front-end level
('-fno-exceptions'; the "exceptions are [...] disabled" case):
exceptions_enabled2066068.cc: In function ‘void foo()’:
exceptions_enabled2066068.cc:3:27: error: exception handling disabled,
use ‘-fexceptions’ to enable
However, effective-target 'exceptions_enabled' additionally assumes that
"If exceptions aren't supported [by the target], then they're not enabled".
This is not correct: it's not unlikely that, in presence of
explicit/implicit
'-fexceptions', exception handling code gets fully optimized away by the
compiler, and therefore effective-target 'exceptions_enabled' test cases may
PASS even for targets that don't support effective-target 'exceptions';
these
two effective-targets are orthogonal concepts.
(For completeness: code with trivial instances of C++ exception handling may
translate into simple '__cxa_allocate_exception', '__cxa_throw' function
calls
without requiring any back end-level "exceptions magic", and then trigger
unresolved symbols at link time, if these functions are not available.)
This change only affects GCN, as that one currently is the only target
declared
as not supporting effective-target 'exceptions'.
gcc/
* doc/sourcebuild.texi (Effective-Target Keywords): Clarify that
effective-target 'exceptions' and 'exceptions_enabled' are
orthogonal.
gcc/testsuite/
* lib/gcc-dg.exp (gcc-dg-prune): Clarify effective-target
'exceptions_enabled'.
* lib/target-supports.exp
(check_effective_target_exceptions_enabled): Don't consider
effective-target 'exceptions'.
libstdc++-v3/
* testsuite/lib/prune.exp (libstdc++-dg-prune): Clarify
effective-target 'exceptions_enabled'.
Diff:
---
gcc/doc/sourcebuild.texi | 7 ---
gcc/testsuite/lib/gcc-dg.exp | 3 +--
gcc/testsuite/lib/target-supports.exp | 30 ++
libstdc++-v3/testsuite/lib/prune.exp | 3 +--
4 files changed, 20 insertions(+), 23 deletions(-)
diff --git a/gcc/doc/sourcebuild.texi b/gcc/doc/sourcebuild.texi
index 98ede70f23c0..797775e90de9 100644
--- a/gcc/doc/sourcebuild.texi
+++ b/gcc/doc/sourcebuild.texi
@@ -2996,11 +2996,12 @@ Target uses @code{__cxa_atexit}.
Target has packed layout of structure members by default.
@item exceptions
-Target supports exceptions.
+Target supports exception handling.
+Note that this is orthogonal to effective-target @code{exceptions_enabled}.
@item exceptions_enabled
-Target supports exceptions and they are enabled in the current
-testing configuration.
+Testing configuration has exception handling enabled.
+Note that this is orthogonal to effective-target @code{exceptions}.
@item fgraphite
Target supports Graphite optimizations.
diff --git a/gcc/testsuite/lib/gcc-dg.exp b/gcc/testsuite/lib/gcc-dg.exp
index 65a5f3f1dbe5..07a996a44669 100644
--- a/gcc/testsuite/lib/gcc-dg.exp
+++ b/gcc/testsuite/lib/gcc-dg.exp
@@ -434,8 +434,7 @@ proc gcc-dg-prune { system text } {
return "::unsupported::large return values"
}
-# If exceptions are disabled, mark tests expecting exceptions to be enabled
-# as unsupported.
+# If exception handling is disabled, expectant tests are UNSUPPORTED.
if { ![check_effective_target_exceptions_enabled] } {
if [regexp "(^|\n)\[^\n\]*: error: exception handling disabled" $text] {
return "::unsupported::exception handling disabled"
diff --git a/gcc/testsuite/lib/target-supports.exp
b/gcc/testsuite/lib/target-supports.exp
index 60e24129bd58..aed2b79c4af7 100644
--- a/gcc/testsuite/lib/target-supports.exp
+++ b/gcc/testsuite/lib/target-supports.exp
@@ -12559,7 +12559,8 @@ proc check_effective_target_fenv_exceptions_long_double
{} {
} [add_options_for_ieee "-std=gnu99"]]
}
-# Return 1 if -fexceptions is supported.
+# Check whether the target supports exception handling.
+# Note that this is o
[gcc r15-7438] 'gcc.dg/pr88870.c': don't 'dg-require-effective-target nonlocal_goto'
https://gcc.gnu.org/g:0e602b2315f3cdf9a50441b28cabb8b204827492
commit r15-7438-g0e602b2315f3cdf9a50441b28cabb8b204827492
Author: Thomas Schwinge
Date: Thu Feb 6 16:14:27 2025 +0100
'gcc.dg/pr88870.c': don't 'dg-require-effective-target nonlocal_goto'
I confirm that back then, 'gcc.dg/pr88870.c' for nvptx failed due to
'sorry, unimplemented: target cannot support nonlocal goto', however at some
(indeterminate) point in time, that must've disappeared, and we now don't
have
to 'dg-require-effective-target nonlocal_goto' anymore, and therefore get:
[-UNSUPPORTED:-]{+PASS:+} gcc.dg/pr88870.c {+(test for excess errors)+}
(And, if ever necessary again, this nowadays probably should
'dg-require-effective-target exceptions' instead of 'nonlocal_goto'.)
gcc/testsuite/
* gcc.dg/pr88870.c: Don't 'dg-require-effective-target
nonlocal_goto'.
Diff:
---
gcc/testsuite/gcc.dg/pr88870.c | 1 -
1 file changed, 1 deletion(-)
diff --git a/gcc/testsuite/gcc.dg/pr88870.c b/gcc/testsuite/gcc.dg/pr88870.c
index 81f686bd972c..3f46f32f3ee9 100644
--- a/gcc/testsuite/gcc.dg/pr88870.c
+++ b/gcc/testsuite/gcc.dg/pr88870.c
@@ -1,6 +1,5 @@
/* PR rtl-optimization/88870 */
/* { dg-do compile } */
-/* { dg-require-effective-target nonlocal_goto } */
/* { dg-options "-O1 -fexceptions -fnon-call-exceptions -ftrapv
-fno-tree-dominator-opts" } */
int a, b;
[gcc r15-7442] For a few test cases, clarify dependance on effective-target 'nonlocal_goto' into 'exceptions'
https://gcc.gnu.org/g:7809aa1128250c9e90fde33a4fc0c88a733f8e1a
commit r15-7442-g7809aa1128250c9e90fde33a4fc0c88a733f8e1a
Author: Thomas Schwinge
Date: Thu Feb 6 16:20:50 2025 +0100
For a few test cases, clarify dependance on effective-target
'nonlocal_goto' into 'exceptions'
For example, for nvptx, these test cases currently indeed fail with
'sorry, unimplemented: target cannot support nonlocal goto'. However,
that's just an artefact of non-existing support for exception handling,
and these test cases already require effective-target 'exceptions'.
gcc/testsuite/
* gcc.dg/cleanup-12.c: Don't 'dg-skip-if "" { ! nonlocal_goto }'.
* gcc.dg/cleanup-13.c: Likewise.
* gcc.dg/cleanup-5.c: Likewise.
* gcc.dg/gimplefe-44.c: Don't
'dg-require-effective-target nonlocal_goto'.
Diff:
---
gcc/testsuite/gcc.dg/cleanup-12.c | 1 -
gcc/testsuite/gcc.dg/cleanup-13.c | 1 -
gcc/testsuite/gcc.dg/cleanup-5.c | 1 -
gcc/testsuite/gcc.dg/gimplefe-44.c | 1 -
4 files changed, 4 deletions(-)
diff --git a/gcc/testsuite/gcc.dg/cleanup-12.c
b/gcc/testsuite/gcc.dg/cleanup-12.c
index 2171e35de9da..5bc7216af673 100644
--- a/gcc/testsuite/gcc.dg/cleanup-12.c
+++ b/gcc/testsuite/gcc.dg/cleanup-12.c
@@ -3,7 +3,6 @@
/* { dg-do run } */
/* { dg-options "-O2 -fexceptions" } */
/* { dg-skip-if "" { "ia64-*-hpux11.*" } } */
-/* { dg-skip-if "" { ! nonlocal_goto } } */
/* { dg-require-effective-target exceptions } */
/* Verify unwind info in presence of alloca. */
diff --git a/gcc/testsuite/gcc.dg/cleanup-13.c
b/gcc/testsuite/gcc.dg/cleanup-13.c
index 86cfae09e77c..6d2adcac4300 100644
--- a/gcc/testsuite/gcc.dg/cleanup-13.c
+++ b/gcc/testsuite/gcc.dg/cleanup-13.c
@@ -6,7 +6,6 @@
/* { dg-do run } */
/* { dg-options "-fexceptions" } */
/* { dg-skip-if "" { "ia64-*-hpux11.*" } } */
-/* { dg-skip-if "" { ! nonlocal_goto } } */
/* { dg-require-effective-target exceptions } */
/* Verify DW_OP_* handling in the unwinder. */
diff --git a/gcc/testsuite/gcc.dg/cleanup-5.c b/gcc/testsuite/gcc.dg/cleanup-5.c
index 9ed2a7c95f5f..43e8686ab2bc 100644
--- a/gcc/testsuite/gcc.dg/cleanup-5.c
+++ b/gcc/testsuite/gcc.dg/cleanup-5.c
@@ -2,7 +2,6 @@
/* { dg-do run } */
/* { dg-options "-fexceptions" } */
/* { dg-skip-if "" { "ia64-*-hpux11.*" } } */
-/* { dg-skip-if "" { ! nonlocal_goto } } */
/* { dg-require-effective-target exceptions } */
/* Verify that cleanups work with exception handling. */
diff --git a/gcc/testsuite/gcc.dg/gimplefe-44.c
b/gcc/testsuite/gcc.dg/gimplefe-44.c
index 3c83d4946f27..a1e32ad69273 100644
--- a/gcc/testsuite/gcc.dg/gimplefe-44.c
+++ b/gcc/testsuite/gcc.dg/gimplefe-44.c
@@ -1,7 +1,6 @@
/* { dg-do compile } */
/* { dg-require-effective-target exceptions } */
/* { dg-options "-fexceptions -fgimple -fdump-tree-eh-eh" } */
-/* { dg-require-effective-target nonlocal_goto } */
void __GIMPLE foo()
{
[gcc r15-7443] GCN, nvptx: 'sorry, unimplemented: exception handling not supported'
https://gcc.gnu.org/g:6312165650091a4df34668d8e2aaa0bbc4008a66
commit r15-7443-g6312165650091a4df34668d8e2aaa0bbc4008a66
Author: Thomas Schwinge
Date: Tue Jan 28 14:57:21 2025 +0100
GCN, nvptx: 'sorry, unimplemented: exception handling not supported'
For GCN, this avoids ICEs further down the compilation pipeline. For nvptx,
there's effectively no change: in presence of exception handling constructs,
instead of 'sorry, unimplemented: target cannot support nonlocal goto', we
now emit 'sorry, unimplemented: exception handling not supported'.
Additionally, turn test cases into UNSUPPORTED if running into
'sorry, unimplemented: exception handling not supported'.
gcc/
* config/gcn/gcn.md (exception_receiver): 'define_expand'.
* config/nvptx/nvptx.md (exception_receiver): Likewise.
gcc/testsuite/
* lib/gcc-dg.exp (gcc-dg-prune): Turn
'sorry, unimplemented: exception handling not supported' into
UNSUPPORTED.
* gcc.dg/pr104464.c: Remove GCN XFAIL.
libstdc++-v3/
* testsuite/lib/prune.exp (libstdc++-dg-prune): Turn
'sorry, unimplemented: exception handling not supported' into
UNSUPPORTED.
Diff:
---
gcc/config/gcn/gcn.md| 7 +++
gcc/config/nvptx/nvptx.md| 7 +++
gcc/testsuite/gcc.dg/pr104464.c | 2 --
gcc/testsuite/lib/gcc-dg.exp | 7 +++
libstdc++-v3/testsuite/lib/prune.exp | 7 +++
5 files changed, 28 insertions(+), 2 deletions(-)
diff --git a/gcc/config/gcn/gcn.md b/gcc/config/gcn/gcn.md
index 9dddfca742b4..695656f692d6 100644
--- a/gcc/config/gcn/gcn.md
+++ b/gcc/config/gcn/gcn.md
@@ -1014,6 +1014,13 @@
[(set_attr "type" "sopp")
(set_attr "length" "4")])
+(define_expand "exception_receiver"
+ [(const_int 0)]
+ ""
+{
+ sorry ("exception handling not supported");
+})
+
;; }}}
;; {{{ Conditionals
diff --git a/gcc/config/nvptx/nvptx.md b/gcc/config/nvptx/nvptx.md
index a22a088fb3ac..d3d538070c0f 100644
--- a/gcc/config/nvptx/nvptx.md
+++ b/gcc/config/nvptx/nvptx.md
@@ -1640,6 +1640,13 @@
DONE;
})
+(define_expand "exception_receiver"
+ [(const_int 0)]
+ ""
+{
+ sorry ("exception handling not supported");
+})
+
(define_expand "nonlocal_goto"
[(match_operand 0 "" "")
(match_operand 1 "" "")
diff --git a/gcc/testsuite/gcc.dg/pr104464.c b/gcc/testsuite/gcc.dg/pr104464.c
index d36a28678cb6..ed6a22c39d5e 100644
--- a/gcc/testsuite/gcc.dg/pr104464.c
+++ b/gcc/testsuite/gcc.dg/pr104464.c
@@ -9,5 +9,3 @@ foo(void)
{
f += (F)(f != (F){}[0]);
}
-
-/* { dg-xfail-if "-fnon-call-exceptions unsupported" { amdgcn-*-* } } */
diff --git a/gcc/testsuite/lib/gcc-dg.exp b/gcc/testsuite/lib/gcc-dg.exp
index 07a996a44669..70be7a8d5fd1 100644
--- a/gcc/testsuite/lib/gcc-dg.exp
+++ b/gcc/testsuite/lib/gcc-dg.exp
@@ -434,6 +434,13 @@ proc gcc-dg-prune { system text } {
return "::unsupported::large return values"
}
+# If exception handling is not supported, expectant tests are UNSUPPORTED.
+if { ![check_effective_target_exceptions] } {
+ if [regexp "(^|\n)\[^\n\]*: sorry, unimplemented: exception handling
not supported" $text] {
+ return "::unsupported::exception handling not supported"
+ }
+}
+
# If exception handling is disabled, expectant tests are UNSUPPORTED.
if { ![check_effective_target_exceptions_enabled] } {
if [regexp "(^|\n)\[^\n\]*: error: exception handling disabled" $text] {
diff --git a/libstdc++-v3/testsuite/lib/prune.exp
b/libstdc++-v3/testsuite/lib/prune.exp
index 593b74985fbe..566572baa6da 100644
--- a/libstdc++-v3/testsuite/lib/prune.exp
+++ b/libstdc++-v3/testsuite/lib/prune.exp
@@ -89,6 +89,13 @@ proc libstdc++-dg-prune { system text } {
# the single uncapitalized "in function" line.
regsub -all "(^|\n)\[^\n\]*: in function\[^\n\]*" $text "" text
+# If exception handling is not supported, expectant tests are UNSUPPORTED.
+if { ![check_effective_target_exceptions] } {
+ if [regexp "(^|\n)\[^\n\]*: sorry, unimplemented: exception handling
not supported" $text] {
+ return "::unsupported::exception handling not supported"
+ }
+}
+
# If exception handling is disabled, expectant tests are UNSUPPORTED.
if { ![check_effective_target_exceptions_enabled] } {
if [regexp "(^|\n)\[^\n\]*: error: exception handling disabled" $text] {
[gcc r15-7440] BPF doesn't actually support effective-target 'exceptions' [PR118772]
https://gcc.gnu.org/g:e90276a4831553268f3dd4917d7b6ae9c08dbf0f
commit r15-7440-ge90276a4831553268f3dd4917d7b6ae9c08dbf0f
Author: Thomas Schwinge
Date: Thu Feb 6 16:31:38 2025 +0100
BPF doesn't actually support effective-target 'exceptions' [PR118772]
PR target/118772
gcc/testsuite/
* lib/target-supports.exp (check_effective_target_exceptions):
'return 0' for '[istarget bpf-*-*]'.
Diff:
---
gcc/testsuite/lib/target-supports.exp | 3 ++-
1 file changed, 2 insertions(+), 1 deletion(-)
diff --git a/gcc/testsuite/lib/target-supports.exp
b/gcc/testsuite/lib/target-supports.exp
index aed2b79c4af7..3ec2fef70c8b 100644
--- a/gcc/testsuite/lib/target-supports.exp
+++ b/gcc/testsuite/lib/target-supports.exp
@@ -12563,7 +12563,8 @@ proc check_effective_target_fenv_exceptions_long_double
{} {
# Note that this is orthogonal to effective-target 'exceptions_enabled'.
proc check_effective_target_exceptions {} {
-if { [istarget amdgcn*-*-*] } {
+if { [istarget amdgcn*-*-*]
+|| [istarget bpf-*-*] } {
return 0
}
return 1
[gcc r15-7441] nvptx doesn't actually support effective-target 'exceptions'
https://gcc.gnu.org/g:2466b0b4d9bcfe51c1a049c3d7f6a8043d68630e
commit r15-7441-g2466b0b4d9bcfe51c1a049c3d7f6a8043d68630e
Author: Thomas Schwinge
Date: Thu Feb 6 22:46:26 2025 +0100
nvptx doesn't actually support effective-target 'exceptions'
gcc/testsuite/
* lib/target-supports.exp (check_effective_target_exceptions):
'return 0' for '[istarget nvptx-*-*]'.
Diff:
---
gcc/testsuite/lib/target-supports.exp | 3 ++-
1 file changed, 2 insertions(+), 1 deletion(-)
diff --git a/gcc/testsuite/lib/target-supports.exp
b/gcc/testsuite/lib/target-supports.exp
index 3ec2fef70c8b..fe1eb34cf228 100644
--- a/gcc/testsuite/lib/target-supports.exp
+++ b/gcc/testsuite/lib/target-supports.exp
@@ -12564,7 +12564,8 @@ proc check_effective_target_fenv_exceptions_long_double
{} {
proc check_effective_target_exceptions {} {
if { [istarget amdgcn*-*-*]
-|| [istarget bpf-*-*] } {
+|| [istarget bpf-*-*]
+|| [istarget nvptx-*-*] } {
return 0
}
return 1
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Correction régression realloc_on_assign_10
https://gcc.gnu.org/g:007ca869933eb74b76398200ef0237219ba01cd8
commit 007ca869933eb74b76398200ef0237219ba01cd8
Author: Mikael Morin
Date: Sat Feb 8 14:35:14 2025 +0100
Correction régression realloc_on_assign_10
Diff:
---
gcc/fortran/trans-array.cc | 5 +++--
1 file changed, 3 insertions(+), 2 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index d0f0e8465743..9f10c2770d99 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -1667,11 +1667,12 @@ public:
tree
-cond_descr_lb::lower_bound (stmtblock_t *block ATTRIBUTE_UNUSED, int dim) const
+cond_descr_lb::lower_bound (stmtblock_t *block ATTRIBUTE_UNUSED,
+ int dim ATTRIBUTE_UNUSED) const
{
tree lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
lbound = fold_build3_loc (input_location, COND_EXPR,
- gfc_array_index_type, cond,
+ gfc_array_index_type, logical_true_node,
gfc_index_one_node, lbound);
return lbound;
}
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Correction régression realloc_on_assign_11.f90
https://gcc.gnu.org/g:24d3f6e286524ea4cedb331eb171c30ead0d63cd
commit 24d3f6e286524ea4cedb331eb171c30ead0d63cd
Author: Mikael Morin
Date: Sat Feb 8 17:34:20 2025 +0100
Correction régression realloc_on_assign_11.f90
Diff:
---
gcc/fortran/trans-array.cc | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index d0f0e8465743..4d2d0378bea7 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -1922,7 +1922,7 @@ gfc_conv_shift_descriptor (stmtblock_t *block, tree dest,
tree src,
int rank, tree zero_cond)
{
conv_shift_descriptor (block, src, dest, rank,
-cond_descr_lb (src, zero_cond));
+cond_descr_lb (dest, zero_cond));
}
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Revert "Correction régression realloc_on_assign_10"
https://gcc.gnu.org/g:4fe27ab156281eae41f8dfbe721fe93c4255b647
commit 4fe27ab156281eae41f8dfbe721fe93c4255b647
Author: Mikael Morin
Date: Sat Feb 8 17:23:07 2025 +0100
Revert "Correction régression realloc_on_assign_10"
This reverts commit 007ca869933eb74b76398200ef0237219ba01cd8.
Diff:
---
gcc/fortran/trans-array.cc | 5 ++---
1 file changed, 2 insertions(+), 3 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 9f10c2770d99..d0f0e8465743 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -1667,12 +1667,11 @@ public:
tree
-cond_descr_lb::lower_bound (stmtblock_t *block ATTRIBUTE_UNUSED,
- int dim ATTRIBUTE_UNUSED) const
+cond_descr_lb::lower_bound (stmtblock_t *block ATTRIBUTE_UNUSED, int dim) const
{
tree lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
lbound = fold_build3_loc (input_location, COND_EXPR,
- gfc_array_index_type, logical_true_node,
+ gfc_array_index_type, cond,
gfc_index_one_node, lbound);
return lbound;
}
[gcc r15-7444] libgcc: On FreeBSD use GCC's crt objects for static linking
https://gcc.gnu.org/g:06e5b0b4a244090abfea333d91fc5963292cb41d
commit r15-7444-g06e5b0b4a244090abfea333d91fc5963292cb41d
Author: Dimitry Andric
Date: Tue Jan 28 18:36:16 2025 +0100
libgcc: On FreeBSD use GCC's crt objects for static linking
Add crtbeginT.o to extra_parts on FreeBSD. This ensures we use GCC's
crt objects for static linking. Otherwise it could mix crtbeginT.o
from the base system with libgcc's crtend.o, possibly leading to
segfaults.
libgcc:
PR target/118685
* config.host (*-*-freebsd*): Add crtbeginT.o to extra_parts.
Signed-off-by: Dimitry Andric
Diff:
---
libgcc/config.host | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/libgcc/config.host b/libgcc/config.host
index 8930081069e5..6a88ee5a2dd0 100644
--- a/libgcc/config.host
+++ b/libgcc/config.host
@@ -292,7 +292,7 @@ case ${host} in
# machine-specific sections may refine and add to this
# configuration.
tmake_file="$tmake_file t-freebsd t-crtstuff-pic t-libgcc-pic t-eh-dw2-dip
t-slibgcc t-slibgcc-gld t-slibgcc-elf-ver"
- extra_parts="crtbegin.o crtend.o crtbeginS.o crtendS.o"
+ extra_parts="crtbegin.o crtend.o crtbeginS.o crtbeginT.o crtendS.o"
case ${target_thread_file} in
posix)
tmake_file="${tmake_file} t-freebsd-thread"
[gcc] Deleted branch 'mikael/heads/refactor_descriptor_v01' in namespace 'refs/users'
The branch 'mikael/heads/refactor_descriptor_v01' in namespace 'refs/users' was deleted. It previously pointed to: 24d3f6e28652... Correction régression realloc_on_assign_11.f90 Diff: !!! WARNING: THE FOLLOWING COMMITS ARE NO LONGER ACCESSIBLE (LOST): --- 24d3f6e... Correction régression realloc_on_assign_11.f90 4fe27ab... Revert "Correction régression realloc_on_assign_10" 007ca86... Correction régression realloc_on_assign_10 deac09f... Correction régression alloc_comp_constructor_1.f90 30a92f5... Factorisation set_descriptor_dimension 5f6c199... Factorisation gfc_conv_shift_descriptor 96c395b... Renseignement token par gfc_set_descriptor_from_scalar. cd99fad... Séparation motifs dump assumed_rank_12.f90 ac8ccbd... Annulation modif dump assumed_rank_12.f90 34baff5... Sauvegarde factorisation set_descriptor_from_scalar 47b6338... Déplacement gfc_set_gfc_from_cfi d292794... Déplacement gfc_copy_sequence_descriptor da0f060... Déplacement méthode set_descriptor_from_scalar 0aef327... Suppression code redondant 0838449... Update dump match count 01b40a5... Factorisation set_descriptor_from_scalar dans gfc_conv_scal c3d8cf0... Factorisation set_descriptor_from_scalar conv_derived_to_cl 60fb6b7... Factorisation set_descriptor_from_scalar dans conv_class_to 1392f13... Factorisation initialisation depuis cfi 84be5a4... utilisation booléen allocatable 57a9d25... Factorisation initialisation gfc depuis cfi 7d9a5b7... Refactoring gfc_conv_descriptor_sm_get. 55a2a10... Introduction gfc_conv_descriptor_extent_get c2ce739... Factorisation shift descriptor 41e3834... Factorisation initialisation subarray_descriptor c3a50c1... Factorisation set descriptor with shape b5834ef... Factorisation set_contiguous_array ccb2dcc... Factorisation set_contiguous_array bd3573d... Essai suppression unlimited_polymorphic a6d12d1... Refactor conv_shift_descriptor 7818e31... Factorisation shift descriptor 7421792... Factorisation shift descriptor d607595... Factorisation gfc_conv_expr_descriptor 82413c9... Factorisation copie gfc_conv_expr_descriptor ed6fee2... Extraction fonction fcncall_realloc_result 7ed0026... Factorisation gfc_conv_remap_descriptor 6d1a550... Introduction gfc_copy_sequence_descriptor b68e4d2... Utilisation de la méthode de nullification pour nullifier ecdc8da... Appel méthode shift descriptor dans gfc_trans_pointer_assi 063c001... Déplacement shift descriptor vers gfc_conv_array_parameter db8ddde... Utilisation gfc_clear_descriptor dans gfc_conv_derived_to_c e3de444... Sauvegarde modifs 3c45ca6... Creation méthode initialisation descripteur
[gcc r15-7445] [PATCH] OpenMP: Improve Fortran metadirective diagnostics [PR107067]
https://gcc.gnu.org/g:5753f459444fa61a93d23325cd59467dc1838eef
commit r15-7445-g5753f459444fa61a93d23325cd59467dc1838eef
Author: Sandra Loosemore
Date: Sat Feb 8 17:44:55 2025 +
[PATCH] OpenMP: Improve Fortran metadirective diagnostics [PR107067]
The Fortran front end was giving an ICE instead of a user-friendly
diagnostic when variants of a metadirective variant had different
statement associations. The particular test case reported in the issue
also involved invalid placement of the "omp end metadirective" which
was not being diagnosed either.
gcc/fortran/ChangeLog
PR middle-end/107067
* parse.cc (parse_omp_do): Diagnose missing "OMP END METADIRECTIVE"
after loop.
(parse_omp_structured_block): Likewise for strictly structured
block.
(parse_omp_metadirective_body): Use better test for variants ending
at different places. Issue a user diagnostic at the end if any
were inconsistent, instead of calling gcc_assert.
gcc/testsuite/ChangeLog
PR middle-end/107067
* gfortran.dg/gomp/metadirective-11.f90: Remove the dg-ice, update
for current behavior, and add more tests to exercise the new error
code.
Diff:
---
gcc/fortran/parse.cc | 62 +---
.../gfortran.dg/gomp/metadirective-11.f90 | 67 --
2 files changed, 114 insertions(+), 15 deletions(-)
diff --git a/gcc/fortran/parse.cc b/gcc/fortran/parse.cc
index 5094d9d3eadf..336ea89c5a9f 100644
--- a/gcc/fortran/parse.cc
+++ b/gcc/fortran/parse.cc
@@ -5804,9 +5804,20 @@ do_end:
/* If handling a metadirective variant, treat 'omp end metadirective'
as the expected end statement for the current construct. */
- if (st == ST_OMP_END_METADIRECTIVE
- && gfc_state_stack->state == COMP_OMP_BEGIN_METADIRECTIVE)
-st = omp_end_st;
+ if (gfc_state_stack->state == COMP_OMP_BEGIN_METADIRECTIVE)
+{
+ if (st == ST_OMP_END_METADIRECTIVE)
+ st = omp_end_st;
+ else
+ {
+ /* We have found some extra statements between the loop
+and the "end metadirective" which is required in a
+"begin metadirective" construct, or perhaps the
+"end metadirective" is missing entirely. */
+ gfc_error_now ("Expected OMP END METADIRECTIVE at %C");
+ return st;
+ }
+}
if (st == omp_end_st)
{
@@ -6294,6 +6305,14 @@ parse_omp_structured_block (gfc_statement omp_st, bool
workshare_stmts_only)
accept_statement (st);
st = next_statement ();
}
+ else if (omp_end_st == ST_OMP_END_METADIRECTIVE)
+ {
+ /* We have found some extra statements between the END BLOCK
+and the "end metadirective" which is required in a
+"begin metadirective" construct, or perhaps the
+"end metadirective" is missing entirely. */
+ gfc_error_now ("Expected OMP END METADIRECTIVE at %C");
+ }
return st;
}
else if (st != omp_end_st || block_construct)
@@ -6409,10 +6428,12 @@ parse_omp_metadirective_body (gfc_statement omp_st)
gfc_omp_variant *variant
= new_st.ext.omp_variants;
locus body_locus = gfc_current_locus;
+ bool saw_error = false;
accept_statement (omp_st);
gfc_statement next_st = ST_NONE;
+ locus next_loc;
while (variant)
{
@@ -6470,8 +6491,24 @@ parse_omp_metadirective_body (gfc_statement omp_st)
reject_statement ();
st = next_statement ();
}
+
finish:
+ /* Sanity-check that each variant finishes parsing at the same place. */
+ if (next_st == ST_NONE)
+ {
+ next_st = st;
+ next_loc = gfc_current_locus;
+ }
+ else if (st != next_st
+ || next_loc.nextc != gfc_current_locus.nextc
+ || next_loc.u.lb != gfc_current_locus.u.lb)
+ {
+ saw_error = true;
+ next_st = st;
+ next_loc = gfc_current_locus;
+ }
+
gfc_in_omp_metadirective_body = old_in_metadirective_body;
if (gfc_state_stack->head)
@@ -6483,15 +6520,22 @@ parse_omp_metadirective_body (gfc_statement omp_st)
if (variant->next)
gfc_clear_new_st ();
- /* Sanity-check that each variant finishes parsing at the same place. */
- if (next_st == ST_NONE)
- next_st = st;
- else
- gcc_assert (st == next_st);
-
variant = variant->next;
}
+ if (saw_error)
+{
+ if (omp_st == ST_OMP_METADIRECTIVE)
+ gfc_error_now ("Variants in a metadirective at %L have "
+ "different associations; "
+ "consider using a BLOCK construct "
+ "or BEGIN/END METADIRECTIVE", &body_locus);
+ else
+ gfc_error_now ("Variants in a metadirect
[gcc] Created branch 'mikael/heads/refactor_descriptor_v01' in namespace 'refs/users'
The branch 'mikael/heads/refactor_descriptor_v01' was created in namespace 'refs/users' pointing to: 89ff0d96ef8c... Factorisation set_descriptor_dimension
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Utilisation gfc_clear_descriptor dans gfc_conv_derived_to_class
https://gcc.gnu.org/g:db8dddefb7b3659f1307058b98421fc9edf2e6de
commit db8dddefb7b3659f1307058b98421fc9edf2e6de
Author: Mikael Morin
Date: Wed Dec 11 16:03:10 2024 +0100
Utilisation gfc_clear_descriptor dans gfc_conv_derived_to_class
essai suppression
Suppression fonction inutilisée
Sauvegarde compilation OK
Correction régression
Sauvegarde correction null_actual_6
Commentage fonction inutilisée
Correction bornes descripteur null
Diff:
---
gcc/fortran/trans-array.cc | 339 +++--
gcc/fortran/trans-array.h | 4 +-
gcc/fortran/trans-expr.cc | 87 ++--
3 files changed, 373 insertions(+), 57 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index d15576adde10..0370d10d9ebd 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -592,10 +592,10 @@ get_size_info (gfc_typespec &ts)
if (POINTER_TYPE_P (type))
type = TREE_TYPE (type);
gcc_assert (TREE_CODE (type) == ARRAY_TYPE);
- tree elt_type = TREE_TYPE (type);
+ tree char_type = TREE_TYPE (type);
tree len = ts.u.cl->backend_decl;
return fold_build2_loc (input_location, MULT_EXPR, size_type_node,
- size_in_bytes (elt_type),
+ size_in_bytes (char_type),
fold_convert (size_type_node, len));
}
@@ -613,8 +613,61 @@ get_size_info (gfc_typespec &ts)
}
+class init_info
+{
+public:
+ virtual bool initialize_data () const { return false; }
+ virtual tree get_data_value () const { return NULL_TREE; }
+ virtual gfc_typespec *get_type () const { return nullptr; }
+};
+
+
+class default_init : public init_info
+{
+private:
+ const symbol_attribute &attr;
+
+public:
+ default_init (const symbol_attribute &arg_attr) : attr(arg_attr) { }
+ virtual bool initialize_data () const { return !attr.pointer; }
+ virtual tree get_data_value () const {
+if (!initialize_data ())
+ return NULL_TREE;
+
+return null_pointer_node;
+ }
+};
+
+class nullification : public init_info
+{
+private:
+ gfc_typespec &ts;
+
+public:
+ nullification(gfc_typespec &arg_ts) : ts(arg_ts) { }
+ virtual bool initialize_data () const { return true; }
+ virtual tree get_data_value () const { return null_pointer_node; }
+ virtual gfc_typespec *get_type () const { return &ts; }
+};
+
+class scalar_value : public init_info
+{
+private:
+ gfc_typespec &ts;
+ tree value;
+
+public:
+ scalar_value(gfc_typespec &arg_ts, tree arg_value)
+: ts(arg_ts), value(arg_value) { }
+ virtual bool initialize_data () const { return true; }
+ virtual tree get_data_value () const { return value; }
+ virtual gfc_typespec *get_type () const { return &ts; }
+};
+
+
static tree
-build_dtype (gfc_typespec &ts, int rank, const symbol_attribute &)
+build_dtype (gfc_typespec &ts, int rank, const symbol_attribute &,
+const init_info &init)
{
vec *v = nullptr;
@@ -622,11 +675,17 @@ build_dtype (gfc_typespec &ts, int rank, const
symbol_attribute &)
tree fields = TYPE_FIELDS (type);
- if (ts.type != BT_CLASS)
+ gfc_typespec *type_info = init.get_type ();
+ if (type_info == nullptr)
+type_info = &ts;
+
+ if (!(type_info->type == BT_CLASS
+ || (type_info->type == BT_CHARACTER
+ && type_info->deferred)))
{
tree elem_len_field = gfc_advance_chain (fields, GFC_DTYPE_ELEM_LEN);
tree elem_len_val = fold_convert (TREE_TYPE (elem_len_field),
- get_size_info (ts));
+ get_size_info (*type_info));
CONSTRUCTOR_APPEND_ELT (v, elem_len_field, elem_len_val);
}
@@ -641,11 +700,11 @@ build_dtype (gfc_typespec &ts, int rank, const
symbol_attribute &)
CONSTRUCTOR_APPEND_ELT (v, rank_field, rank_val);
}
- if (ts.type != BT_CLASS)
+ if (type_info->type != BT_CLASS)
{
tree type_info_field = gfc_advance_chain (fields, GFC_DTYPE_TYPE);
tree type_info_val = build_int_cst (TREE_TYPE (type_info_field),
- get_type_info (ts));
+ get_type_info (*type_info));
CONSTRUCTOR_APPEND_ELT (v, type_info_field, type_info_val);
}
@@ -656,8 +715,8 @@ build_dtype (gfc_typespec &ts, int rank, const
symbol_attribute &)
/* Build a null array descriptor constructor. */
vec *
-get_default_descriptor_init (tree type, gfc_typespec &ts, int rank,
-const symbol_attribute &attr)
+get_descriptor_init (tree type, gfc_typespec &ts, int rank,
+const symbol_attribute &attr, const init_info &init)
{
vec *v = nullptr;
@@ -666,15 +725,15 @@ get_default_descriptor_init (tree type, gfc_typespec &ts,
int rank,
tree fields = TYPE_FIELDS (type);
/* Don't init pointers by default. */
- if
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Sauvegarde modifs
https://gcc.gnu.org/g:e3de44455296f04e014dad8c9efaef858384cfac
commit e3de44455296f04e014dad8c9efaef858384cfac
Author: Mikael Morin
Date: Sat Dec 7 22:22:10 2024 +0100
Sauvegarde modifs
Annulation suppression else
Correction assertions
Initialisation vptr
Non initialisation elem_len pour les conteneurs de classe
Mise à jour class_allocatable_14
Diff:
---
gcc/fortran/trans-array.cc | 52 ++
gcc/fortran/trans-array.h | 2 +
gcc/fortran/trans-decl.cc | 58 +
gcc/testsuite/gfortran.dg/class_allocate_14.f90 | 2 +-
4 files changed, 66 insertions(+), 48 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 268de211cd66..d15576adde10 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -734,6 +734,58 @@ gfc_build_null_descriptor (tree type, gfc_typespec &ts,
}
+tree
+gfc_build_default_class_descriptor (tree type, gfc_typespec &ts)
+{
+ vec *v = nullptr;
+
+ tree fields = TYPE_FIELDS (type);
+
+#define CLASS_DATA_FIELD 0
+#define CLASS_VPTR_FIELD 1
+
+ tree data_field = gfc_advance_chain (fields, CLASS_DATA_FIELD);
+ tree data_type = TREE_TYPE (data_field);
+
+ gcc_assert (ts.type == BT_CLASS);
+ tree data_value;
+ if (ts.u.derived->components->attr.dimension
+ || (ts.u.derived->components->attr.codimension
+ && flag_coarray != GFC_FCOARRAY_LIB))
+{
+ gcc_assert (GFC_DESCRIPTOR_TYPE_P (data_type));
+ data_value = gfc_build_null_descriptor (data_type,
+ ts,
+
ts.u.derived->components->as->rank,
+ ts.u.derived->components->attr);
+}
+ else
+{
+ gcc_assert (POINTER_TYPE_P (data_type));
+ data_value = fold_convert (data_type, null_pointer_node);
+}
+ CONSTRUCTOR_APPEND_ELT (v, data_field, data_value);
+
+ tree vptr_field = gfc_advance_chain (fields, CLASS_VPTR_FIELD);
+
+ tree vptr_value;
+ if (ts.u.derived->attr.unlimited_polymorphic)
+vptr_value = fold_convert (TREE_TYPE (vptr_field), null_pointer_node);
+ else
+{
+ gfc_symbol *vsym = gfc_find_derived_vtab (ts.u.derived);
+ tree vsym_decl = gfc_get_symbol_decl (vsym);
+ vptr_value = gfc_build_addr_expr (nullptr, vsym_decl);
+}
+ CONSTRUCTOR_APPEND_ELT (v, vptr_field, vptr_value);
+
+#undef CLASS_DATA_FIELD
+#undef CLASS_VPTR_FIELD
+
+ return build_constructor (type, v);
+}
+
+
void
gfc_clear_descriptor (gfc_expr *var_ref, gfc_se &var)
{
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 1bb3294b0749..63a77d562a7b 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -140,6 +140,8 @@ void gfc_set_delta (gfc_loopinfo *);
void gfc_conv_resolve_dependencies (gfc_loopinfo *, gfc_ss *, gfc_ss *);
/* Build a null array descriptor constructor. */
tree gfc_build_null_descriptor (tree);
+tree gfc_build_default_class_descriptor (tree, gfc_typespec &);
+void gfc_clear_descriptor (stmtblock_t *block, gfc_symbol *sym, tree
descriptor);
/* Get a single array element. */
void gfc_conv_array_ref (gfc_se *, gfc_array_ref *, gfc_expr *, locus *);
diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc
index 4ae22a5584d0..dad15858fa6a 100644
--- a/gcc/fortran/trans-decl.cc
+++ b/gcc/fortran/trans-decl.cc
@@ -4780,16 +4780,14 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym,
gfc_wrapped_block * block)
else if (proc_sym == proc_sym->result && IS_CLASS_ARRAY (proc_sym))
{
/* Nullify explicit return class arrays on entry. */
- tree type;
tmp = get_proc_result (proc_sym);
- if (tmp && GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
- {
- gfc_start_block (&init);
- tmp = gfc_class_data_get (tmp);
- type = TREE_TYPE (gfc_conv_descriptor_data_get (tmp));
- gfc_conv_descriptor_data_set (&init, tmp, build_int_cst (type, 0));
- gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
- }
+ if (tmp && GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
+ {
+ gfc_start_block (&init);
+ tmp = gfc_class_data_get (tmp);
+ gfc_clear_descriptor (&init, proc_sym, tmp);
+ gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
+ }
}
@@ -4931,48 +4929,13 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym,
gfc_wrapped_block * block)
}
}
- if (sym->attr.pointer && sym->attr.dimension
- && sym->attr.save == SAVE_NONE
- && !sym->attr.use_assoc
- && !sym->attr.host_assoc
- && !sym->attr.dummy
- && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (sym->backend_decl)))
- {
- gfc_init_block (&tmpblock);
- gfc_conv_descriptor_span_set (&tmpblock, sym->backend_decl,
-
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Creation méthode initialisation descripteur
https://gcc.gnu.org/g:3c45ca6ee9cb09354b7ede90cf410c13adeec82c
commit 3c45ca6ee9cb09354b7ede90cf410c13adeec82c
Author: Mikael Morin
Date: Thu Dec 5 20:30:08 2024 +0100
Creation méthode initialisation descripteur
Utilisation méthode initialisation descripteur gfc_trans_deferred_array
Correction variable inutilisée
Correction segmentation fault
Correction regression allocatable attribute
Ajout conversion elem_len
conversion type longueur chaine
Initialisation descripteur champ par champ
Silence uninitialized warning.
Diff:
---
gcc/fortran/expr.cc| 25 +++-
gcc/fortran/gfortran.h | 1 +
gcc/fortran/primary.cc | 84 +++-
gcc/fortran/trans-array.cc | 286 +
gcc/fortran/trans-intrinsic.cc | 2 +-
5 files changed, 333 insertions(+), 65 deletions(-)
diff --git a/gcc/fortran/expr.cc b/gcc/fortran/expr.cc
index 7f3f6c52fb54..e4829448f710 100644
--- a/gcc/fortran/expr.cc
+++ b/gcc/fortran/expr.cc
@@ -5411,27 +5411,38 @@ gfc_get_full_arrayspec_from_expr (gfc_expr *expr)
gfc_ref *ref;
if (expr->rank == 0)
-return NULL;
+return nullptr;
/* Follow any component references. */
if (expr->expr_type == EXPR_VARIABLE
|| expr->expr_type == EXPR_CONSTANT)
{
- if (expr->symtree)
- as = expr->symtree->n.sym->as;
+ gfc_symbol *sym = expr->symtree ? expr->symtree->n.sym : nullptr;
+ if (sym
+ && sym->ts.type == BT_CLASS)
+ as = CLASS_DATA (sym)->as;
+ else if (sym)
+ as = sym->as;
else
- as = NULL;
+ as = nullptr;
for (ref = expr->ref; ref; ref = ref->next)
{
switch (ref->type)
{
case REF_COMPONENT:
- as = ref->u.c.component->as;
+ {
+ gfc_component *comp = ref->u.c.component;
+ if (comp->ts.type == BT_CLASS)
+ as = CLASS_DATA (comp)->as;
+ else
+ as = comp->as;
+ }
continue;
case REF_SUBSTRING:
case REF_INQUIRY:
+ as = nullptr;
continue;
case REF_ARRAY:
@@ -5441,7 +5452,7 @@ gfc_get_full_arrayspec_from_expr (gfc_expr *expr)
case AR_ELEMENT:
case AR_SECTION:
case AR_UNKNOWN:
- as = NULL;
+ as = nullptr;
continue;
case AR_FULL:
@@ -5453,7 +5464,7 @@ gfc_get_full_arrayspec_from_expr (gfc_expr *expr)
}
}
else
-as = NULL;
+as = nullptr;
return as;
}
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 7367db8853c6..b14857132ed7 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -4049,6 +4049,7 @@ const char *gfc_dt_lower_string (const char *);
const char *gfc_dt_upper_string (const char *);
/* primary.cc */
+symbol_attribute gfc_symbol_attr (gfc_symbol *);
symbol_attribute gfc_variable_attr (gfc_expr *, gfc_typespec *);
symbol_attribute gfc_expr_attr (gfc_expr *);
symbol_attribute gfc_caf_attr (gfc_expr *, bool i = false, bool *r = NULL);
diff --git a/gcc/fortran/primary.cc b/gcc/fortran/primary.cc
index 8a38720422ec..c934841f4795 100644
--- a/gcc/fortran/primary.cc
+++ b/gcc/fortran/primary.cc
@@ -2867,42 +2867,14 @@ check_substring:
}
-/* Given an expression that is a variable, figure out what the
- ultimate variable's type and attribute is, traversing the reference
- structures if necessary.
-
- This subroutine is trickier than it looks. We start at the base
- symbol and store the attribute. Component references load a
- completely new attribute.
-
- A couple of rules come into play. Subobjects of targets are always
- targets themselves. If we see a component that goes through a
- pointer, then the expression must also be a target, since the
- pointer is associated with something (if it isn't core will soon be
- dumped). If we see a full part or section of an array, the
- expression is also an array.
-
- We can have at most one full array reference. */
-
symbol_attribute
-gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
+gfc_symbol_attr (gfc_symbol *sym)
{
- int dimension, codimension, pointer, allocatable, target, optional;
+ int dimension, codimension, pointer, allocatable, target;
symbol_attribute attr;
- gfc_ref *ref;
- gfc_symbol *sym;
- gfc_component *comp;
- bool has_inquiry_part;
-
- if (expr->expr_type != EXPR_VARIABLE
- && expr->expr_type != EXPR_FUNCTION
- && !(expr->expr_type == EXPR_NULL && expr->ts.type != BT_UNKNOWN))
-gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
- sym = expr->symtree->n.sym;
attr = sym->attr;
- optional = attr.optional;
if (sym->ts.type == BT_CLASS && sym->attr.class_ok && sym->ts.u.derived)
{
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Déplacement shift descriptor vers gfc_conv_array_parameter
https://gcc.gnu.org/g:063c0014407236e53fa5c3734cab2f3fec5fa03f
commit 063c0014407236e53fa5c3734cab2f3fec5fa03f
Author: Mikael Morin
Date: Tue Dec 17 17:27:24 2024 +0100
Déplacement shift descriptor vers gfc_conv_array_parameter
Suppression variables inutilisées
Diff:
---
gcc/fortran/trans-array.cc | 49 ++
gcc/fortran/trans-array.h | 2 +-
gcc/fortran/trans-expr.cc | 20 +--
3 files changed, 43 insertions(+), 28 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 0370d10d9ebd..2fdd15962e49 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -1151,6 +1151,43 @@ gfc_conv_shift_descriptor_lbound (stmtblock_t* block,
tree desc,
}
+static void
+conv_shift_descriptor (stmtblock_t* block, tree desc, int rank)
+{
+ /* Apply a shift of the lbound when supplied. */
+ for (int dim = 0; dim < rank; ++dim)
+gfc_conv_shift_descriptor_lbound (block, desc, dim,
+ gfc_index_one_node);
+}
+
+
+static bool
+keep_descriptor_lower_bound (gfc_expr *e)
+{
+ gfc_ref *ref;
+
+ /* Detect any array references with vector subscripts. */
+ for (ref = e->ref; ref; ref = ref->next)
+if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT
+ && ref->u.ar.type != AR_FULL)
+ {
+ int dim;
+ for (dim = 0; dim < ref->u.ar.dimen; dim++)
+ if (ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
+ break;
+ if (dim < ref->u.ar.dimen)
+ break;
+ }
+
+ /* Array references with vector subscripts and non-variable
+ expressions need be converted to a one-based descriptor. */
+ if (ref || e->expr_type != EXPR_VARIABLE)
+return false;
+
+ return true;
+}
+
+
/* Obtain offsets for trans-types.cc(gfc_get_array_descr_info). */
void
@@ -9454,7 +9491,7 @@ is_pointer (gfc_expr *e)
void
gfc_conv_array_parameter (gfc_se *se, gfc_expr *expr, bool g77,
const gfc_symbol *fsym, const char *proc_name,
- tree *size, tree *lbshift, tree *packed)
+ tree *size, bool maybe_shift, tree *packed)
{
tree ptr;
tree desc;
@@ -9690,13 +9727,9 @@ gfc_conv_array_parameter (gfc_se *se, gfc_expr *expr,
bool g77,
stmtblock_t block;
gfc_init_block (&block);
- if (lbshift && *lbshift)
- {
- /* Apply a shift of the lbound when supplied. */
- for (int dim = 0; dim < expr->rank; ++dim)
- gfc_conv_shift_descriptor_lbound (&block, se->expr, dim,
- *lbshift);
- }
+ if (maybe_shift && !keep_descriptor_lower_bound (expr))
+ conv_shift_descriptor (&block, se->expr, expr->rank);
+
tmp = gfc_class_data_get (ctree);
if (expr->rank > 1 && CLASS_DATA (fsym)->as->rank != expr->rank
&& CLASS_DATA (fsym)->as->type == AS_EXPLICIT && !no_pack)
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 78646275b4ec..17e3d08fdba0 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -158,7 +158,7 @@ tree gfc_get_array_span (tree, gfc_expr *);
void gfc_conv_expr_descriptor (gfc_se *, gfc_expr *);
/* Convert an array for passing as an actual function parameter. */
void gfc_conv_array_parameter (gfc_se *, gfc_expr *, bool, const gfc_symbol *,
- const char *, tree *, tree * = nullptr,
+ const char *, tree *, bool = false,
tree * = nullptr);
/* These work with both descriptors and descriptorless arrays. */
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 6978f83cdc8c..e8b229d853e3 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -991,8 +991,6 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
gfc_symbol *fsym,
stmtblock_t block;
gfc_init_block (&block);
gfc_ref *ref;
- int dim;
- tree lbshift = NULL_TREE;
/* Array refs with sections indicate, that a for a formal argument
expecting contiguous repacking needs to be done. */
@@ -1005,25 +1003,9 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
gfc_symbol *fsym,
&& (ref || e->rank != fsym->ts.u.derived->components->as->rank))
fsym->attr.contiguous = 1;
- /* Detect any array references with vector subscripts. */
- for (ref = e->ref; ref; ref = ref->next)
- if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT
- && ref->u.ar.type != AR_FULL)
- {
- for (dim = 0; dim < ref->u.ar.dimen; dim++)
- if (ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
- break;
- if (dim < ref->u.ar.dimen)
- break;
- }
-
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Appel méthode shift descriptor dans gfc_trans_pointer_assignment
https://gcc.gnu.org/g:ecdc8da68c9d5419d4c0e6ec9b1b3278076cbdf0
commit ecdc8da68c9d5419d4c0e6ec9b1b3278076cbdf0
Author: Mikael Morin
Date: Tue Dec 17 22:37:18 2024 +0100
Appel méthode shift descriptor dans gfc_trans_pointer_assignment
Diff:
---
gcc/fortran/trans-array.cc | 129 +++--
gcc/fortran/trans-array.h | 1 +
gcc/fortran/trans-expr.cc | 28 +-
3 files changed, 129 insertions(+), 29 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 2fdd15962e49..cdbff27d82ca 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -1151,13 +1151,136 @@ gfc_conv_shift_descriptor_lbound (stmtblock_t* block,
tree desc,
}
+class lb_info
+{
+public:
+ virtual gfc_expr *lower_bound (int dim) const = 0;
+};
+
+
+class unset_lb : public lb_info
+{
+public:
+ virtual gfc_expr *lower_bound (int) const { return nullptr; }
+};
+
+
+class defined_lb : public lb_info
+{
+ int rank;
+ gfc_expr * const * lower_bounds;
+
+public:
+ defined_lb (int arg_rank, gfc_expr * const
arg_lower_bounds[GFC_MAX_DIMENSIONS])
+: rank(arg_rank), lower_bounds(arg_lower_bounds) { }
+ virtual gfc_expr *lower_bound (int dim) const { return lower_bounds[dim]; }
+};
+
+
static void
-conv_shift_descriptor (stmtblock_t* block, tree desc, int rank)
+conv_shift_descriptor (stmtblock_t *block, tree desc, int rank,
+ const lb_info &info)
{
/* Apply a shift of the lbound when supplied. */
for (int dim = 0; dim < rank; ++dim)
-gfc_conv_shift_descriptor_lbound (block, desc, dim,
- gfc_index_one_node);
+{
+ gfc_expr *lb_expr = info.lower_bound(dim);
+
+ tree lower_bound;
+ if (lb_expr == nullptr)
+ lower_bound = gfc_index_one_node;
+ else
+ {
+ gfc_se lb_se;
+
+ gfc_init_se (&lb_se, nullptr);
+ gfc_conv_expr (&lb_se, lb_expr);
+
+ gfc_add_block_to_block (block, &lb_se.pre);
+ tree lb_var = gfc_create_var (TREE_TYPE (lb_se.expr), "lower_bound");
+ gfc_add_modify (block, lb_var, lb_se.expr);
+ gfc_add_block_to_block (block, &lb_se.post);
+
+ lower_bound = lb_var;
+ }
+
+ gfc_conv_shift_descriptor_lbound (block, desc, dim, lower_bound);
+}
+}
+
+
+static void
+conv_shift_descriptor (stmtblock_t* block, tree desc, int rank)
+{
+ conv_shift_descriptor (block, desc, rank, unset_lb ());
+}
+
+
+static void
+conv_shift_descriptor (stmtblock_t *block, tree desc, int rank,
+ gfc_expr * const lower_bounds[GFC_MAX_DIMENSIONS])
+{
+ conv_shift_descriptor (block, desc, rank, defined_lb (rank, lower_bounds));
+}
+
+
+static void
+conv_shift_descriptor (stmtblock_t *block, tree desc,
+ const gfc_array_spec &as)
+{
+ conv_shift_descriptor (block, desc, as.rank, as.lower);
+}
+
+
+static void
+set_type (array_type &type, array_type value)
+{
+ gcc_assert (type == AS_UNKNOWN || type == value);
+ type = value;
+}
+
+
+static void
+array_ref_to_array_spec (const gfc_array_ref &ref, gfc_array_spec &spec)
+{
+ spec.rank = ref.dimen;
+ spec.corank = ref.codimen;
+
+ spec.type = AS_UNKNOWN;
+ spec.cotype = AS_ASSUMED_SIZE;
+
+ for (int dim = 0; dim < spec.rank + spec.corank; dim++)
+switch (ref.dimen_type[dim])
+ {
+ case DIMEN_ELEMENT:
+ spec.upper[dim] = ref.start[dim];
+ set_type (spec.type, AS_EXPLICIT);
+ break;
+
+ case DIMEN_RANGE:
+ spec.lower[dim] = ref.start[dim];
+ spec.upper[dim] = ref.end[dim];
+ if (spec.upper[dim] == nullptr)
+ set_type (spec.type, AS_DEFERRED);
+ else
+ set_type (spec.type, AS_EXPLICIT);
+ break;
+
+ default:
+ break;
+ }
+}
+
+
+void
+gfc_conv_shift_descriptor (stmtblock_t *block, tree desc,
+ const gfc_array_ref &ar)
+{
+ gfc_array_spec as;
+
+ array_ref_to_array_spec (ar, as);
+
+ conv_shift_descriptor (block, desc, as);
}
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 17e3d08fdba0..3b05a2eb197a 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -214,6 +214,7 @@ tree gfc_get_cfi_dim_sm (tree, tree);
/* Shift lower bound of descriptor, updating ubound and offset. */
void gfc_conv_shift_descriptor_lbound (stmtblock_t*, tree, int, tree);
+void gfc_conv_shift_descriptor (stmtblock_t*, tree, const gfc_array_ref &);
/* Add pre-loop scalarization code for intrinsic functions which require
special handling. */
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index e8b229d853e3..1de4a73974d6 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -11180,32 +11180,8 @@ gfc_trans_pointer_assignment (gfc_expr * expr1,
gfc_expr * expr2)
}
}
else
- {
- /* Bounds remapping. Just shift the lower bounds. */
-
-
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Utilisation de la méthode de nullification pour nullifier un pointeur
https://gcc.gnu.org/g:b68e4d2ef22d8fe82d628a320c6577d1d0a946dd
commit b68e4d2ef22d8fe82d628a320c6577d1d0a946dd
Author: Mikael Morin
Date: Wed Dec 18 19:04:41 2024 +0100
Utilisation de la méthode de nullification pour nullifier un pointeur
Correction régression modifiable_p
Correction dump
Ajout assertion
Correction assertion même type
Diff:
---
gcc/fortran/trans-array.cc | 96 ++---
gcc/fortran/trans-array.h | 1 +
gcc/fortran/trans-expr.cc | 35 -
gcc/testsuite/gfortran.dg/class_allocate_14.f90 | 2 +-
4 files changed, 106 insertions(+), 28 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index cdbff27d82ca..4c237b561aa6 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -545,9 +545,9 @@ gfc_conv_descriptor_ubound_set (stmtblock_t *block, tree
desc,
static int
-get_type_info (const gfc_typespec &ts)
+get_type_info (const bt &type)
{
- switch (ts.type)
+ switch (type)
{
case BT_INTEGER:
case BT_LOGICAL:
@@ -558,7 +558,7 @@ get_type_info (const gfc_typespec &ts)
case BT_CLASS:
case BT_VOID:
case BT_UNSIGNED:
- return ts.type;
+ return type;
case BT_PROCEDURE:
case BT_ASSUMED:
@@ -613,11 +613,34 @@ get_size_info (gfc_typespec &ts)
}
-class init_info
+class modify_info
{
public:
+ virtual bool is_initialization () const { return false; }
virtual bool initialize_data () const { return false; }
virtual tree get_data_value () const { return NULL_TREE; }
+};
+
+class nullification : public modify_info
+{
+ virtual bool initialize_data () const { return true; }
+ virtual tree get_data_value () const { return null_pointer_node; }
+ /*
+private:
+ gfc_typespec &ts;
+
+public:
+ null_init(gfc_typespec &arg_ts) : ts(arg_ts) { }
+ virtual bool initialize_data () const { return true; }
+ virtual tree get_data_value () const { return null_pointer_node; }
+ virtual gfc_typespec *get_type () const { return &ts; }
+ */
+};
+
+class init_info : public modify_info
+{
+public:
+ virtual bool is_initialization () const { return true; }
virtual gfc_typespec *get_type () const { return nullptr; }
};
@@ -638,13 +661,13 @@ public:
}
};
-class nullification : public init_info
+class null_init : public init_info
{
private:
gfc_typespec &ts;
public:
- nullification(gfc_typespec &arg_ts) : ts(arg_ts) { }
+ null_init(gfc_typespec &arg_ts) : ts(arg_ts) { }
virtual bool initialize_data () const { return true; }
virtual tree get_data_value () const { return null_pointer_node; }
virtual gfc_typespec *get_type () const { return &ts; }
@@ -700,13 +723,12 @@ build_dtype (gfc_typespec &ts, int rank, const
symbol_attribute &,
CONSTRUCTOR_APPEND_ELT (v, rank_field, rank_val);
}
- if (type_info->type != BT_CLASS)
-{
- tree type_info_field = gfc_advance_chain (fields, GFC_DTYPE_TYPE);
- tree type_info_val = build_int_cst (TREE_TYPE (type_info_field),
- get_type_info (*type_info));
- CONSTRUCTOR_APPEND_ELT (v, type_info_field, type_info_val);
-}
+ tree type_info_field = gfc_advance_chain (fields, GFC_DTYPE_TYPE);
+ tree type_info_val = build_int_cst (TREE_TYPE (type_info_field),
+ get_type_info (type_info->type == BT_CLASS
+? BT_DERIVED
+: type_info->type));
+ CONSTRUCTOR_APPEND_ELT (v, type_info_field, type_info_val);
return build_constructor (type, v);
}
@@ -715,8 +737,8 @@ build_dtype (gfc_typespec &ts, int rank, const
symbol_attribute &,
/* Build a null array descriptor constructor. */
vec *
-get_descriptor_init (tree type, gfc_typespec &ts, int rank,
-const symbol_attribute &attr, const init_info &init)
+get_descriptor_init (tree type, gfc_typespec *ts, int rank,
+const symbol_attribute *attr, const modify_info &init)
{
vec *v = nullptr;
@@ -732,11 +754,15 @@ get_descriptor_init (tree type, gfc_typespec &ts, int
rank,
CONSTRUCTOR_APPEND_ELT (v, data_field, data_value);
}
- tree dtype_field = gfc_advance_chain (fields, DTYPE_FIELD);
- tree dtype_value = build_dtype (ts, rank, attr, init);
- CONSTRUCTOR_APPEND_ELT (v, dtype_field, dtype_value);
+ if (init.is_initialization ())
+{
+ tree dtype_field = gfc_advance_chain (fields, DTYPE_FIELD);
+ tree dtype_value = build_dtype (*ts, rank, *attr,
+ static_cast (init));
+ CONSTRUCTOR_APPEND_ELT (v, dtype_field, dtype_value);
+}
- if (flag_coarray == GFC_FCOARRAY_LIB && attr.codimension)
+ if (flag_coarray == GFC_FCOARRAY_LIB && attr->codimension)
{
/* Declare the variable static so its array descriptor stays present
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Introduction gfc_copy_sequence_descriptor
https://gcc.gnu.org/g:6d1a550acfb35381deea5afbd424a7e79852f5b1
commit 6d1a550acfb35381deea5afbd424a7e79852f5b1
Author: Mikael Morin
Date: Tue Dec 31 15:27:35 2024 +0100
Introduction gfc_copy_sequence_descriptor
Correction régression sizeof_6
Diff:
---
gcc/fortran/trans-array.cc | 39 ++-
gcc/fortran/trans-expr.cc | 44
gcc/fortran/trans.h| 1 +
3 files changed, 59 insertions(+), 25 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 4c237b561aa6..5d56a12ebf71 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -9901,32 +9901,21 @@ gfc_conv_array_parameter (gfc_se *se, gfc_expr *expr,
bool g77,
if (maybe_shift && !keep_descriptor_lower_bound (expr))
conv_shift_descriptor (&block, se->expr, expr->rank);
+ bool assumed_rank_fsym;
+ if (fsym
+ && ((fsym->ts.type == BT_CLASS
+ && CLASS_DATA (fsym)->as
+ && CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)
+ || (fsym->ts.type != BT_CLASS
+ && fsym->as
+ && fsym->as->type == AS_ASSUMED_RANK)))
+ assumed_rank_fsym = true;
+ else
+ assumed_rank_fsym = false;
+
tmp = gfc_class_data_get (ctree);
- if (expr->rank > 1 && CLASS_DATA (fsym)->as->rank != expr->rank
- && CLASS_DATA (fsym)->as->type == AS_EXPLICIT && !no_pack)
- {
- tree arr = gfc_create_var (TREE_TYPE (tmp), "parm");
- gfc_conv_descriptor_data_set (&block, arr,
- gfc_conv_descriptor_data_get (
- se->expr));
- gfc_conv_descriptor_lbound_set (&block, arr, gfc_index_zero_node,
- gfc_index_zero_node);
- gfc_conv_descriptor_ubound_set (
- &block, arr, gfc_index_zero_node,
- gfc_conv_descriptor_size (se->expr, expr->rank));
- gfc_conv_descriptor_stride_set (
- &block, arr, gfc_index_zero_node,
- gfc_conv_descriptor_stride_get (se->expr, gfc_index_zero_node));
- gfc_add_modify (&block, gfc_conv_descriptor_dtype (arr),
- gfc_conv_descriptor_dtype (se->expr));
- gfc_add_modify (&block, gfc_conv_descriptor_rank (arr),
- build_int_cst (signed_char_type_node, 1));
- gfc_conv_descriptor_span_set (&block, arr,
- gfc_conv_descriptor_span_get (arr));
- gfc_conv_descriptor_offset_set (&block, arr, gfc_index_zero_node);
- se->expr = arr;
- }
- gfc_class_array_data_assign (&block, tmp, se->expr, true);
+ gfc_copy_sequence_descriptor (block, tmp, se->expr,
+ assumed_rank_fsym);
/* Handle optional. */
if (fsym && fsym->attr.optional && sym && sym->attr.optional)
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 003754cdad6f..5dff9692f0ba 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -846,6 +846,50 @@ descriptor_rank (tree descriptor)
}
+void
+gfc_copy_sequence_descriptor (stmtblock_t &block, tree lhs_desc, tree rhs_desc,
+ bool assumed_rank_lhs)
+{
+ int lhs_rank = descriptor_rank (lhs_desc);
+ int rhs_rank = descriptor_rank (rhs_desc);
+ tree desc;
+
+ if (assumed_rank_lhs || lhs_rank == rhs_rank)
+desc = rhs_desc;
+ else
+{
+ tree arr = gfc_create_var (TREE_TYPE (lhs_desc), "parm");
+ gfc_conv_descriptor_data_set (&block, arr,
+ gfc_conv_descriptor_data_get (rhs_desc));
+ gfc_conv_descriptor_lbound_set (&block, arr, gfc_index_zero_node,
+ gfc_index_zero_node);
+ tree size = gfc_conv_descriptor_size (rhs_desc, rhs_rank);
+ gfc_conv_descriptor_ubound_set (&block, arr, gfc_index_zero_node, size);
+ gfc_conv_descriptor_stride_set (
+ &block, arr, gfc_index_zero_node,
+ gfc_conv_descriptor_stride_get (rhs_desc, gfc_index_zero_node));
+ for (int i = 1; i < lhs_rank; i++)
+ {
+ gfc_conv_descriptor_lbound_set (&block, arr, gfc_rank_cst[i],
+ gfc_index_zero_node);
+ gfc_conv_descriptor_ubound_set (&block, arr, gfc_rank_cst[i],
+ gfc_index_zero_node);
+ gfc_conv_descriptor_stride_set (&block, arr, gfc_rank_cst[i], size);
+ }
+ gfc_add_modify (&block, gfc_conv_descriptor_dtype (arr),
+ gfc_conv_descriptor_dtype (rhs_desc));
+ gfc_add_modify (&block, gfc_conv_descriptor_rank (arr),
+ build_int_cst (signed_cha
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Extraction fonction fcncall_realloc_result
https://gcc.gnu.org/g:ed6fee22d9c29ebee21ce323726fb14cfb8d6ed1
commit ed6fee22d9c29ebee21ce323726fb14cfb8d6ed1
Author: Mikael Morin
Date: Thu Jan 9 21:38:39 2025 +0100
Extraction fonction fcncall_realloc_result
Correction variable inutilisée
Correction régression coarray dummy_3
Correction régression dummy_3
Diff:
---
gcc/fortran/trans-array.cc | 64 ++
gcc/fortran/trans-array.h | 1 +
gcc/fortran/trans-expr.cc | 52 +++--
3 files changed, 80 insertions(+), 37 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 898930634ad1..7d43a8c000d3 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -1451,6 +1451,70 @@ gfc_conv_remap_descriptor (stmtblock_t *block, tree
dest, tree src,
}
+class conditional_lb
+{
+ tree cond;
+public:
+ conditional_lb (tree arg_cond)
+: cond (arg_cond) { }
+
+ tree lower_bound (tree src, int n) const {
+tree lbound = gfc_conv_descriptor_lbound_get (src, gfc_rank_cst[n]);
+lbound = fold_build3_loc (input_location, COND_EXPR,
+ gfc_array_index_type, cond,
+ gfc_index_one_node, lbound);
+return lbound;
+ }
+};
+
+
+static void
+gfc_conv_shift_descriptor (stmtblock_t *block, tree dest, tree src,
+ int rank, const conditional_lb &lb)
+{
+ tree tmp = gfc_conv_descriptor_data_get (src);
+ gfc_conv_descriptor_data_set (block, dest, tmp);
+
+ tree offset = gfc_index_zero_node;
+ for (int n = 0 ; n < rank; n++)
+{
+ tree lbound;
+
+ lbound = lb.lower_bound (dest, n);
+ lbound = gfc_evaluate_now (lbound, block);
+
+ tmp = gfc_conv_descriptor_ubound_get (src, gfc_rank_cst[n]);
+ tmp = fold_build2_loc (input_location, PLUS_EXPR,
+gfc_array_index_type, tmp, lbound);
+ gfc_conv_descriptor_lbound_set (block, dest,
+ gfc_rank_cst[n], lbound);
+ gfc_conv_descriptor_ubound_set (block, dest,
+ gfc_rank_cst[n], tmp);
+
+ /* Set stride and accumulate the offset. */
+ tmp = gfc_conv_descriptor_stride_get (src, gfc_rank_cst[n]);
+ gfc_conv_descriptor_stride_set (block, dest,
+ gfc_rank_cst[n], tmp);
+ tmp = fold_build2_loc (input_location, MULT_EXPR,
+gfc_array_index_type, lbound, tmp);
+ offset = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type, offset, tmp);
+ offset = gfc_evaluate_now (offset, block);
+}
+
+ gfc_conv_descriptor_offset_set (block, dest, offset);
+}
+
+
+void
+gfc_conv_shift_descriptor (stmtblock_t *block, tree dest, tree src,
+ int rank, tree zero_cond)
+{
+ gfc_conv_shift_descriptor (block, dest, src, rank,
+conditional_lb (zero_cond));
+}
+
+
static bool
keep_descriptor_lower_bound (gfc_expr *e)
{
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 8df55c2c00a5..571322ae11ff 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -216,6 +216,7 @@ tree gfc_get_cfi_dim_sm (tree, tree);
/* Shift lower bound of descriptor, updating ubound and offset. */
void gfc_conv_shift_descriptor_lbound (stmtblock_t*, tree, int, tree);
void gfc_conv_shift_descriptor (stmtblock_t*, tree, const gfc_array_ref &);
+void gfc_conv_shift_descriptor (stmtblock_t*, tree, tree, int, tree);
/* Add pre-loop scalarization code for intrinsic functions which require
special handling. */
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index c50b1e05cdbd..77e8a55af457 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -832,6 +832,9 @@ gfc_get_vptr_from_expr (tree expr)
int
gfc_descriptor_rank (tree descriptor)
{
+ if (TREE_TYPE (descriptor) != NULL_TREE)
+return GFC_TYPE_ARRAY_RANK (TREE_TYPE (descriptor));
+
tree dim = gfc_get_descriptor_dimension (descriptor);
tree dim_type = TREE_TYPE (dim);
gcc_assert (TREE_CODE (dim_type) == ARRAY_TYPE);
@@ -916,8 +919,17 @@ gfc_class_array_data_assign (stmtblock_t *block, tree
lhs_desc, tree rhs_desc,
type = TREE_TYPE (tmp);
else
{
- gcc_assert (TREE_TYPE (tmp) == TREE_TYPE (tmp2));
- type = TREE_TYPE (tmp);
+ int corank = GFC_TYPE_ARRAY_CORANK (TREE_TYPE (lhs_desc));
+ int corank2 = GFC_TYPE_ARRAY_CORANK (TREE_TYPE (rhs_desc));
+ if (corank > 0 && corank2 == 0)
+ type = TREE_TYPE (tmp2);
+ else if (corank2 > 0 && corank == 0)
+ type = TREE_TYPE (tmp);
+ else
+ {
+ gcc_assert (TREE_TYPE (tmp) == TREE_TYPE (tmp2));
+ type = TREE_TYPE (tmp);
+ }
}
tmp = build4_loc (input_location, ARRAY_RANGE_REF, type, tmp,
@@ -11595,7 +11607,6 @@ fcncall_realloc_result (g
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Factorisation gfc_conv_remap_descriptor
https://gcc.gnu.org/g:7ed00263a569c00bf6bf52ea343e677b873e0e2f
commit 7ed00263a569c00bf6bf52ea343e677b873e0e2f
Author: Mikael Morin
Date: Sat Jan 4 21:36:13 2025 +0100
Factorisation gfc_conv_remap_descriptor
Correction régression pointer_remapping_5
Diff:
---
gcc/fortran/trans-array.cc | 119 +++
gcc/fortran/trans-expr.cc | 124 +++--
gcc/fortran/trans.h| 2 +
3 files changed, 129 insertions(+), 116 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 5d56a12ebf71..898930634ad1 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -1332,6 +1332,125 @@ gfc_conv_shift_descriptor (stmtblock_t *block, tree
desc,
}
+void
+gfc_conv_remap_descriptor (stmtblock_t *block, tree dest, tree src,
+ int src_rank, const gfc_array_spec &as)
+{
+ int dest_rank = gfc_descriptor_rank (dest);
+
+ /* Set dtype. */
+ tree dtype = gfc_conv_descriptor_dtype (dest);
+ tree tmp = gfc_get_dtype (TREE_TYPE (src));
+ gfc_add_modify (block, dtype, tmp);
+
+ /* Copy data pointer. */
+ tree data = gfc_conv_descriptor_data_get (src);
+ gfc_conv_descriptor_data_set (block, dest, data);
+
+ /* Copy the span. */
+ tree span;
+ if (VAR_P (src)
+ && GFC_DECL_PTR_ARRAY_P (src))
+span = gfc_conv_descriptor_span_get (src);
+ else
+{
+ tmp = TREE_TYPE (src);
+ tmp = TYPE_SIZE_UNIT (gfc_get_element_type (tmp));
+ span = fold_convert (gfc_array_index_type, tmp);
+}
+ gfc_conv_descriptor_span_set (block, dest, span);
+
+ /* Copy offset but adjust it such that it would correspond
+ to a lbound of zero. */
+ if (src_rank == -1)
+gfc_conv_descriptor_offset_set (block, dest,
+ gfc_index_zero_node);
+ else
+{
+ tree offs = gfc_conv_descriptor_offset_get (src);
+ for (int dim = 0; dim < src_rank; ++dim)
+ {
+ tree stride = gfc_conv_descriptor_stride_get (src,
+ gfc_rank_cst[dim]);
+ tree lbound = gfc_conv_descriptor_lbound_get (src,
+ gfc_rank_cst[dim]);
+ tmp = fold_build2_loc (input_location, MULT_EXPR,
+gfc_array_index_type, stride,
+lbound);
+ offs = fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type, offs, tmp);
+ }
+ gfc_conv_descriptor_offset_set (block, dest, offs);
+}
+ /* Set the bounds as declared for the LHS and calculate strides as
+ well as another offset update accordingly. */
+ tree stride = gfc_conv_descriptor_stride_get (src,
+ gfc_rank_cst[0]);
+ for (int dim = 0; dim < dest_rank; ++dim)
+{
+ gfc_se lower_se;
+ gfc_se upper_se;
+
+ gcc_assert (as.lower[dim] && as.upper[dim]);
+
+ /* Convert declared bounds. */
+ gfc_init_se (&lower_se, NULL);
+ gfc_init_se (&upper_se, NULL);
+ gfc_conv_expr (&lower_se, as.lower[dim]);
+ gfc_conv_expr (&upper_se, as.upper[dim]);
+
+ gfc_add_block_to_block (block, &lower_se.pre);
+ gfc_add_block_to_block (block, &upper_se.pre);
+
+ tree lbound = fold_convert (gfc_array_index_type, lower_se.expr);
+ tree ubound = fold_convert (gfc_array_index_type, upper_se.expr);
+
+ lbound = gfc_evaluate_now (lbound, block);
+ ubound = gfc_evaluate_now (ubound, block);
+
+ gfc_add_block_to_block (block, &lower_se.post);
+ gfc_add_block_to_block (block, &upper_se.post);
+
+ /* Set bounds in descriptor. */
+ gfc_conv_descriptor_lbound_set (block, dest,
+ gfc_rank_cst[dim], lbound);
+ gfc_conv_descriptor_ubound_set (block, dest,
+ gfc_rank_cst[dim], ubound);
+
+ /* Set stride. */
+ stride = gfc_evaluate_now (stride, block);
+ gfc_conv_descriptor_stride_set (block, dest,
+ gfc_rank_cst[dim], stride);
+
+ /* Update offset. */
+ tree offs = gfc_conv_descriptor_offset_get (dest);
+ tmp = fold_build2_loc (input_location, MULT_EXPR,
+gfc_array_index_type, lbound, stride);
+ offs = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type, offs, tmp);
+ offs = gfc_evaluate_now (offs, block);
+ gfc_conv_descriptor_offset_set (block, dest, offs);
+
+ /* Update stride. */
+ tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
+ stride = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, stride, tmp);
+}
+}
+
+
+void
+gfc_conv_remap_descriptor (stmtblock_t *block, tree dest, tree src,
+ int src_rank, const gfc_array_ref &ar)
+{
+ g
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Factorisation copie gfc_conv_expr_descriptor
https://gcc.gnu.org/g:82413c99dc41ba8b632e751540ba26d97ea67ceb
commit 82413c99dc41ba8b632e751540ba26d97ea67ceb
Author: Mikael Morin
Date: Wed Jan 15 17:51:21 2025 +0100
Factorisation copie gfc_conv_expr_descriptor
Diff:
---
gcc/fortran/trans-array.cc | 37 ++---
1 file changed, 22 insertions(+), 15 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 7d43a8c000d3..097a9a0d860a 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -8989,6 +8989,26 @@ is_explicit_coarray (gfc_expr *expr)
return cas && cas->cotype == AS_EXPLICIT;
}
+
+static void
+copy_descriptor (stmtblock_t *block, tree dest, tree src,
+gfc_expr *src_expr, bool subref)
+{
+ /* Copy the descriptor for pointer assignments. */
+ gfc_add_modify (block, dest, src);
+
+ /* Add any offsets from subreferences. */
+ gfc_get_dataptr_offset (block, dest, src, NULL_TREE, subref, src_expr);
+
+ /* and set the span field. */
+ tree tmp;
+ if (src_expr->ts.type == BT_CHARACTER)
+tmp = gfc_conv_descriptor_span_get (src);
+ else
+tmp = gfc_get_array_span (src, src_expr);
+ gfc_conv_descriptor_span_set (block, dest, tmp);
+}
+
/* Convert an array for passing as an actual argument. Expressions and
vector subscripts are evaluated and stored in a temporary, which is then
passed. For whole arrays the descriptor is passed. For array sections
@@ -9123,21 +9143,8 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
if (full && !transposed_dims (ss))
{
if (se->direct_byref && !se->byref_noassign)
- {
- /* Copy the descriptor for pointer assignments. */
- gfc_add_modify (&se->pre, se->expr, desc);
-
- /* Add any offsets from subreferences. */
- gfc_get_dataptr_offset (&se->pre, se->expr, desc, NULL_TREE,
- subref_array_target, expr);
-
- /* and set the span field. */
- if (ss_info->expr->ts.type == BT_CHARACTER)
- tmp = gfc_conv_descriptor_span_get (desc);
- else
- tmp = gfc_get_array_span (desc, expr);
- gfc_conv_descriptor_span_set (&se->pre, se->expr, tmp);
- }
+ copy_descriptor (&se->pre, se->expr, desc, expr,
+subref_array_target);
else if (se->want_pointer)
{
/* We pass full arrays directly. This means that pointers and
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Factorisation gfc_conv_expr_descriptor
https://gcc.gnu.org/g:d607595f1f4f4566776000aeedfd4d0bb3ce4b9b
commit d607595f1f4f4566776000aeedfd4d0bb3ce4b9b
Author: Mikael Morin
Date: Thu Jan 16 14:00:20 2025 +0100
Factorisation gfc_conv_expr_descriptor
Diff:
---
gcc/fortran/trans-array.cc | 358 +++--
1 file changed, 186 insertions(+), 172 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 097a9a0d860a..ec0badd0dc33 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -1542,6 +1542,25 @@ keep_descriptor_lower_bound (gfc_expr *e)
}
+static void
+copy_descriptor (stmtblock_t *block, tree dest, tree src,
+gfc_expr *src_expr, bool subref)
+{
+ /* Copy the descriptor for pointer assignments. */
+ gfc_add_modify (block, dest, src);
+
+ /* Add any offsets from subreferences. */
+ gfc_get_dataptr_offset (block, dest, src, NULL_TREE, subref, src_expr);
+
+ /* and set the span field. */
+ tree tmp;
+ if (src_expr->ts.type == BT_CHARACTER)
+tmp = gfc_conv_descriptor_span_get (src);
+ else
+tmp = gfc_get_array_span (src, src_expr);
+ gfc_conv_descriptor_span_set (block, dest, tmp);
+}
+
/* Obtain offsets for trans-types.cc(gfc_get_array_descr_info). */
void
@@ -8991,24 +9010,175 @@ is_explicit_coarray (gfc_expr *expr)
static void
-copy_descriptor (stmtblock_t *block, tree dest, tree src,
-gfc_expr *src_expr, bool subref)
+set_descriptor (stmtblock_t *block, tree dest, tree src, gfc_expr *src_expr,
+ int rank, int corank, gfc_ss *ss, gfc_array_info *info,
+ tree lowers[GFC_MAX_DIMENSIONS],
+ tree uppers[GFC_MAX_DIMENSIONS],
+ bool unlimited_polymorphic, bool data_needed, bool subref)
{
- /* Copy the descriptor for pointer assignments. */
- gfc_add_modify (block, dest, src);
+ int ndim = info->ref ? info->ref->u.ar.dimen : rank;
- /* Add any offsets from subreferences. */
- gfc_get_dataptr_offset (block, dest, src, NULL_TREE, subref, src_expr);
-
- /* and set the span field. */
- tree tmp;
- if (src_expr->ts.type == BT_CHARACTER)
+ /* Set the span field. */
+ tree tmp = NULL_TREE;
+ if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src)))
tmp = gfc_conv_descriptor_span_get (src);
else
tmp = gfc_get_array_span (src, src_expr);
- gfc_conv_descriptor_span_set (block, dest, tmp);
+ if (tmp)
+gfc_conv_descriptor_span_set (block, dest, tmp);
+
+ /* The following can be somewhat confusing. We have two
+ descriptors, a new one and the original array.
+ {dest, parmtype, dim} refer to the new one.
+ {src, type, n, loop} refer to the original, which maybe
+ a descriptorless array.
+ The bounds of the scalarization are the bounds of the section.
+ We don't have to worry about numeric overflows when calculating
+ the offsets because all elements are within the array data. */
+
+ /* Set the dtype. */
+ tmp = gfc_conv_descriptor_dtype (dest);
+ tree dtype;
+ if (unlimited_polymorphic)
+dtype = gfc_get_dtype (TREE_TYPE (src), &rank);
+ else if (src_expr->ts.type == BT_ASSUMED)
+{
+ tree tmp2 = src;
+ if (DECL_LANG_SPECIFIC (tmp2) && GFC_DECL_SAVED_DESCRIPTOR (tmp2))
+ tmp2 = GFC_DECL_SAVED_DESCRIPTOR (tmp2);
+ if (POINTER_TYPE_P (TREE_TYPE (tmp2)))
+ tmp2 = build_fold_indirect_ref_loc (input_location, tmp2);
+ dtype = gfc_conv_descriptor_dtype (tmp2);
+}
+ else
+dtype = gfc_get_dtype (TREE_TYPE (dest));
+ gfc_add_modify (block, tmp, dtype);
+
+ /* The 1st element in the section. */
+ tree base = gfc_index_zero_node;
+ if (src_expr->ts.type == BT_CHARACTER && src_expr->rank == 0 && corank)
+base = gfc_index_one_node;
+
+ /* The offset from the 1st element in the section. */
+ tree offset = gfc_index_zero_node;
+
+ for (int n = 0; n < ndim; n++)
+{
+ tree stride = gfc_conv_array_stride (src, n);
+
+ /* Work out the 1st element in the section. */
+ tree start;
+ if (info->ref
+ && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
+ {
+ gcc_assert (info->subscript[n]
+ && info->subscript[n]->info->type == GFC_SS_SCALAR);
+ start = info->subscript[n]->info->data.scalar.value;
+ }
+ else
+ {
+ /* Evaluate and remember the start of the section. */
+ start = info->start[n];
+ stride = gfc_evaluate_now (stride, block);
+ }
+
+ tmp = gfc_conv_array_lbound (src, n);
+ tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp),
+start, tmp);
+ tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
+tmp, stride);
+ base = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
+ base, tmp);
+
+ if (info->ref
+ && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
+ {
+
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Factorisation shift descriptor
https://gcc.gnu.org/g:7421792ba1ee3c272b294ac19a85bc43ad73e3c7
commit 7421792ba1ee3c272b294ac19a85bc43ad73e3c7
Author: Mikael Morin
Date: Thu Jan 16 14:35:14 2025 +0100
Factorisation shift descriptor
Diff:
---
gcc/fortran/trans-array.cc | 6 +++---
gcc/fortran/trans-array.h | 1 +
gcc/fortran/trans-stmt.cc | 6 +-
3 files changed, 5 insertions(+), 8 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index ec0badd0dc33..ecdaad3f9575 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -1257,8 +1257,8 @@ conv_shift_descriptor (stmtblock_t *block, tree desc, int
rank,
}
-static void
-conv_shift_descriptor (stmtblock_t* block, tree desc, int rank)
+void
+gfc_conv_shift_descriptor (stmtblock_t* block, tree desc, int rank)
{
conv_shift_descriptor (block, desc, rank, unset_lb ());
}
@@ -10103,7 +10103,7 @@ gfc_conv_array_parameter (gfc_se *se, gfc_expr *expr,
bool g77,
gfc_init_block (&block);
if (maybe_shift && !keep_descriptor_lower_bound (expr))
- conv_shift_descriptor (&block, se->expr, expr->rank);
+ gfc_conv_shift_descriptor (&block, se->expr, expr->rank);
bool assumed_rank_fsym;
if (fsym
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 571322ae11ff..378afb9617a3 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -216,6 +216,7 @@ tree gfc_get_cfi_dim_sm (tree, tree);
/* Shift lower bound of descriptor, updating ubound and offset. */
void gfc_conv_shift_descriptor_lbound (stmtblock_t*, tree, int, tree);
void gfc_conv_shift_descriptor (stmtblock_t*, tree, const gfc_array_ref &);
+void gfc_conv_shift_descriptor (stmtblock_t*, tree, int);
void gfc_conv_shift_descriptor (stmtblock_t*, tree, tree, int, tree);
/* Add pre-loop scalarization code for intrinsic functions which require
diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc
index e7da8fea3b24..01fb8d91007f 100644
--- a/gcc/fortran/trans-stmt.cc
+++ b/gcc/fortran/trans-stmt.cc
@@ -2007,16 +2007,12 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block
*block)
if ((!sym->assoc->variable && !cst_array_ctor)
|| !whole_array)
{
- int dim;
-
if (whole_array)
gfc_add_modify (&se.pre, desc, se.expr);
/* The generated descriptor has lower bound zero (as array
temporary), shift bounds so we get lower bounds of 1. */
- for (dim = 0; dim < e->rank; ++dim)
- gfc_conv_shift_descriptor_lbound (&se.pre, desc,
- dim, gfc_index_one_node);
+ gfc_conv_shift_descriptor (&se.pre, desc, e->rank);
}
/* If this is a subreference array pointer associate name use the
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Factorisation shift descriptor
https://gcc.gnu.org/g:7818e31b1ca1ea4796040325332a850765ef9fdd
commit 7818e31b1ca1ea4796040325332a850765ef9fdd
Author: Mikael Morin
Date: Thu Jan 16 14:51:42 2025 +0100
Factorisation shift descriptor
Diff:
---
gcc/fortran/trans-expr.cc | 7 +--
1 file changed, 1 insertion(+), 6 deletions(-)
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 77e8a55af457..b7d1e3df0613 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -1219,7 +1219,6 @@ gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e,
tree ctree;
tree var;
tree tmp;
- int dim;
bool unlimited_poly;
unlimited_poly = class_ts.type == BT_CLASS
@@ -1287,11 +1286,7 @@ gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e,
/* Array references with vector subscripts and non-variable
expressions
need be converted to a one-based descriptor. */
if (e->expr_type != EXPR_VARIABLE)
- {
- for (dim = 0; dim < e->rank; ++dim)
- gfc_conv_shift_descriptor_lbound (&parmse->pre, parmse->expr,
- dim, gfc_index_one_node);
- }
+ gfc_conv_shift_descriptor (&parmse->pre, parmse->expr, e->rank);
if (class_ts.u.derived->components->as->rank != e->rank)
{
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Refactor conv_shift_descriptor
https://gcc.gnu.org/g:a6d12d1f09654a5d3038b6042e645dd9da4c84a5
commit a6d12d1f09654a5d3038b6042e645dd9da4c84a5
Author: Mikael Morin
Date: Thu Jan 16 15:28:38 2025 +0100
Refactor conv_shift_descriptor
Correction régressions
Correction régression gfc_conv_expr_descriptor
Diff:
---
gcc/fortran/trans-array.cc | 31 +--
gcc/fortran/trans-array.h | 1 -
2 files changed, 17 insertions(+), 15 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index ecdaad3f9575..bf11689cf3dd 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -1165,16 +1165,15 @@ gfc_build_null_descriptor (tree type)
/* 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)
+static void
+conv_shift_descriptor_lbound (stmtblock_t* block, tree desc, int dim,
+ tree new_lbound, tree offset)
{
- tree offs, ubound, lbound, stride;
+ tree 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]);
@@ -1190,9 +1189,9 @@ gfc_conv_shift_descriptor_lbound (stmtblock_t* block,
tree desc,
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);
+ tree tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+ offset, offs_diff);
+ gfc_add_modify (block, offset, tmp);
/* Finally set lbound to value we want. */
gfc_conv_descriptor_lbound_set (block, desc, gfc_rank_cst[dim], new_lbound);
@@ -1229,6 +1228,10 @@ static void
conv_shift_descriptor (stmtblock_t *block, tree desc, int rank,
const lb_info &info)
{
+ tree tmp = gfc_conv_descriptor_offset_get (desc);
+ tree offset_var = gfc_create_var (TREE_TYPE (tmp), "offset");
+ gfc_add_modify (block, offset_var, tmp);
+
/* Apply a shift of the lbound when supplied. */
for (int dim = 0; dim < rank; ++dim)
{
@@ -1252,8 +1255,10 @@ conv_shift_descriptor (stmtblock_t *block, tree desc,
int rank,
lower_bound = lb_var;
}
- gfc_conv_shift_descriptor_lbound (block, desc, dim, lower_bound);
+ conv_shift_descriptor_lbound (block, desc, dim, lower_bound, offset_var);
}
+
+ gfc_conv_descriptor_offset_set (block, desc, offset_var);
}
@@ -9225,7 +9230,6 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
bool subref_array_target = false;
bool deferred_array_component = false;
bool substr = false;
- bool unlimited_polymorphic = false;
gfc_expr *arg, *ss_expr;
if (se->want_coarray || expr->rank == 0)
@@ -9251,7 +9255,7 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
}
if (!se->direct_byref)
-unlimited_polymorphic = UNLIMITED_POLY (expr);
+se->unlimited_polymorphic = UNLIMITED_POLY (expr);
/* Special case things we know we can pass easily. */
switch (expr->expr_type)
@@ -9655,9 +9659,8 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
gfc_get_array_span (desc, expr)));
}
-
- set_descriptor (&se->pre, parm, desc, expr, loop.dimen, codim,
- ss, info, loop.from, loop.to, unlimited_polymorphic,
+ set_descriptor (&loop.pre, parm, desc, expr, loop.dimen, codim,
+ ss, info, loop.from, loop.to, se->unlimited_polymorphic,
!se->data_not_needed, subref_array_target);
desc = parm;
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 378afb9617a3..3f39845c898f 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -214,7 +214,6 @@ tree gfc_get_cfi_dim_sm (tree, tree);
/* Shift lower bound of descriptor, updating ubound and offset. */
-void gfc_conv_shift_descriptor_lbound (stmtblock_t*, tree, int, tree);
void gfc_conv_shift_descriptor (stmtblock_t*, tree, const gfc_array_ref &);
void gfc_conv_shift_descriptor (stmtblock_t*, tree, int);
void gfc_conv_shift_descriptor (stmtblock_t*, tree, tree, int, tree);
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Essai suppression unlimited_polymorphic
https://gcc.gnu.org/g:bd3573d2425487de1c1d165e86d63ff83037c584
commit bd3573d2425487de1c1d165e86d63ff83037c584
Author: Mikael Morin
Date: Thu Jan 16 20:45:34 2025 +0100
Essai suppression unlimited_polymorphic
Diff:
---
gcc/fortran/trans-array.cc | 13 -
gcc/fortran/trans.h| 3 ---
2 files changed, 4 insertions(+), 12 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index bf11689cf3dd..4f066680dff0 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -9019,7 +9019,7 @@ set_descriptor (stmtblock_t *block, tree dest, tree src,
gfc_expr *src_expr,
int rank, int corank, gfc_ss *ss, gfc_array_info *info,
tree lowers[GFC_MAX_DIMENSIONS],
tree uppers[GFC_MAX_DIMENSIONS],
- bool unlimited_polymorphic, bool data_needed, bool subref)
+ bool data_needed, bool subref)
{
int ndim = info->ref ? info->ref->u.ar.dimen : rank;
@@ -9044,9 +9044,7 @@ set_descriptor (stmtblock_t *block, tree dest, tree src,
gfc_expr *src_expr,
/* Set the dtype. */
tmp = gfc_conv_descriptor_dtype (dest);
tree dtype;
- if (unlimited_polymorphic)
-dtype = gfc_get_dtype (TREE_TYPE (src), &rank);
- else if (src_expr->ts.type == BT_ASSUMED)
+ if (src_expr->ts.type == BT_ASSUMED)
{
tree tmp2 = src;
if (DECL_LANG_SPECIFIC (tmp2) && GFC_DECL_SAVED_DESCRIPTOR (tmp2))
@@ -9056,7 +9054,7 @@ set_descriptor (stmtblock_t *block, tree dest, tree src,
gfc_expr *src_expr,
dtype = gfc_conv_descriptor_dtype (tmp2);
}
else
-dtype = gfc_get_dtype (TREE_TYPE (dest));
+dtype = gfc_get_dtype (TREE_TYPE (src), &rank);
gfc_add_modify (block, tmp, dtype);
/* The 1st element in the section. */
@@ -9254,9 +9252,6 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
expr = expr->value.function.actual->expr;
}
- if (!se->direct_byref)
-se->unlimited_polymorphic = UNLIMITED_POLY (expr);
-
/* Special case things we know we can pass easily. */
switch (expr->expr_type)
{
@@ -9660,7 +9655,7 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
}
set_descriptor (&loop.pre, parm, desc, expr, loop.dimen, codim,
- ss, info, loop.from, loop.to, se->unlimited_polymorphic,
+ ss, info, loop.from, loop.to,
!se->data_not_needed, subref_array_target);
desc = parm;
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 098fb07c1483..197dea0a18a6 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -61,9 +61,6 @@ typedef struct gfc_se
the reference to the class object here. */
tree class_container;
- /* Whether expr is a reference to an unlimited polymorphic object. */
- unsigned unlimited_polymorphic:1;
-
/* If set gfc_conv_variable will return an expression for the array
descriptor. When set, want_pointer should also be set.
If not set scalarizing variables will be substituted. */
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Factorisation set_contiguous_array
https://gcc.gnu.org/g:b5834effc49cacae162a35ff2deafe3a9bbc9d1c commit b5834effc49cacae162a35ff2deafe3a9bbc9d1c Author: Mikael Morin Date: Fri Jan 17 17:48:42 2025 +0100 Factorisation set_contiguous_array Diff: --- gcc/fortran/trans-array.cc | 13 + 1 file changed, 1 insertion(+), 12 deletions(-) diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc index 76668d8a3ef1..88a2509a5246 100644 --- a/gcc/fortran/trans-array.cc +++ b/gcc/fortran/trans-array.cc @@ -11148,21 +11148,10 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest, cdesc = gfc_create_var (cdesc, "cdesc"); DECL_ARTIFICIAL (cdesc) = 1; - gfc_add_modify (&dealloc_block, gfc_conv_descriptor_dtype (cdesc), - gfc_get_dtype_rank_type (1, tmp)); - gfc_conv_descriptor_lbound_set (&dealloc_block, cdesc, - gfc_index_zero_node, - gfc_index_one_node); - gfc_conv_descriptor_stride_set (&dealloc_block, cdesc, - gfc_index_zero_node, - gfc_index_one_node); - gfc_conv_descriptor_ubound_set (&dealloc_block, cdesc, - gfc_index_zero_node, ubound); - if (attr->dimension) comp = gfc_conv_descriptor_data_get (comp); - gfc_conv_descriptor_data_set (&dealloc_block, cdesc, comp); + set_contiguous_array (&dealloc_block, cdesc, ubound, comp); /* Now call the deallocator. */ vtab = gfc_find_vtab (&c->ts);
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Factorisation set_contiguous_array
https://gcc.gnu.org/g:ccb2dcc879e6c3debbd0e010cfc394cfde504fbc
commit ccb2dcc879e6c3debbd0e010cfc394cfde504fbc
Author: Mikael Morin
Date: Fri Jan 17 17:25:59 2025 +0100
Factorisation set_contiguous_array
Diff:
---
gcc/fortran/trans-array.cc | 57 +++---
1 file changed, 29 insertions(+), 28 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 4f066680dff0..76668d8a3ef1 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -10685,6 +10685,23 @@ gfc_caf_is_dealloc_only (int caf_mode)
}
+static void
+set_contiguous_array (stmtblock_t *block, tree desc, tree size, tree data_ptr)
+{
+ gfc_add_modify (block, gfc_conv_descriptor_dtype (desc),
+ gfc_get_dtype_rank_type (1, TREE_TYPE (desc)));
+ gfc_conv_descriptor_lbound_set (block, desc,
+ gfc_index_zero_node,
+ gfc_index_one_node);
+ gfc_conv_descriptor_stride_set (block, desc,
+ gfc_index_zero_node,
+ gfc_index_one_node);
+ gfc_conv_descriptor_ubound_set (block, desc,
+ gfc_index_zero_node, size);
+ gfc_conv_descriptor_data_set (block, desc, data_ptr);
+}
+
+
/* Recursively traverse an object of derived type, generating code to
deallocate, nullify or copy allocatable components. This is the work horse
function for the functions named in this enum. */
@@ -10945,32 +10962,6 @@ structure_alloc_comps (gfc_symbol * der_type, tree
decl, tree dest,
ubound = build_int_cst (gfc_array_index_type, 1);
}
- /* Treat strings like arrays. Or the other way around, do not
- * generate an additional array layer for scalar components. */
- if (attr->dimension || c->ts.type == BT_CHARACTER)
- {
- cdesc = gfc_get_array_type_bounds (tmp, 1, 0, &gfc_index_one_node,
-&ubound, 1,
-GFC_ARRAY_ALLOCATABLE, false);
-
- cdesc = gfc_create_var (cdesc, "cdesc");
- DECL_ARTIFICIAL (cdesc) = 1;
-
- gfc_add_modify (&tmpblock, gfc_conv_descriptor_dtype (cdesc),
- gfc_get_dtype_rank_type (1, tmp));
- gfc_conv_descriptor_lbound_set (&tmpblock, cdesc,
- gfc_index_zero_node,
- gfc_index_one_node);
- gfc_conv_descriptor_stride_set (&tmpblock, cdesc,
- gfc_index_zero_node,
- gfc_index_one_node);
- gfc_conv_descriptor_ubound_set (&tmpblock, cdesc,
- gfc_index_zero_node, ubound);
- }
- else
- /* Prevent warning. */
- cdesc = NULL_TREE;
-
if (attr->dimension)
{
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)))
@@ -10993,13 +10984,23 @@ structure_alloc_comps (gfc_symbol * der_type, tree
decl, tree dest,
gfc_add_block_to_block (&tmpblock, &se.pre);
}
+ /* Treat strings like arrays. Or the other way around, do not
+ * generate an additional array layer for scalar components. */
if (attr->dimension || c->ts.type == BT_CHARACTER)
- gfc_conv_descriptor_data_set (&tmpblock, cdesc, comp);
+ {
+ cdesc = gfc_get_array_type_bounds (tmp, 1, 0, &gfc_index_one_node,
+&ubound, 1,
+GFC_ARRAY_ALLOCATABLE, false);
+
+ cdesc = gfc_create_var (cdesc, "cdesc");
+ DECL_ARTIFICIAL (cdesc) = 1;
+
+ set_contiguous_array (&tmpblock, cdesc, ubound, comp);
+ }
else
cdesc = comp;
tree fndecl;
-
fndecl = build_call_expr_loc (input_location,
gfor_fndecl_co_broadcast, 5,
gfc_build_addr_expr
(pvoid_type_node,cdesc),
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Factorisation set descriptor with shape
https://gcc.gnu.org/g:c3a50c1a8cb83384345d3dc3530fbb9b830d6e85
commit c3a50c1a8cb83384345d3dc3530fbb9b830d6e85
Author: Mikael Morin
Date: Fri Jan 17 21:46:27 2025 +0100
Factorisation set descriptor with shape
Diff:
---
gcc/fortran/trans-array.cc | 78 ++
gcc/fortran/trans-array.h | 2 ++
gcc/fortran/trans-intrinsic.cc | 76 +++-
3 files changed, 85 insertions(+), 71 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 88a2509a5246..b05f69fdd874 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -1566,6 +1566,84 @@ copy_descriptor (stmtblock_t *block, tree dest, tree src,
gfc_conv_descriptor_span_set (block, dest, tmp);
}
+
+void
+gfc_set_descriptor_with_shape (stmtblock_t *block, tree desc,
+ tree ptr, gfc_expr *shape,
+ locus *where)
+{
+ /* Set the span field. */
+ tree tmp = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
+ tmp = fold_convert (gfc_array_index_type, tmp);
+ gfc_conv_descriptor_span_set (block, desc, tmp);
+
+ /* Set data value, dtype, and offset. */
+ tmp = GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc));
+ gfc_conv_descriptor_data_set (block, desc, fold_convert (tmp, ptr));
+ gfc_add_modify (block, gfc_conv_descriptor_dtype (desc),
+ gfc_get_dtype (TREE_TYPE (desc)));
+
+ /* Start scalarization of the bounds, using the shape argument. */
+
+ gfc_ss *shape_ss = gfc_walk_expr (shape);
+ gcc_assert (shape_ss != gfc_ss_terminator);
+ gfc_se shapese;
+ gfc_init_se (&shapese, NULL);
+
+ gfc_loopinfo loop;
+ gfc_init_loopinfo (&loop);
+ gfc_add_ss_to_loop (&loop, shape_ss);
+ gfc_conv_ss_startstride (&loop);
+ gfc_conv_loop_setup (&loop, where);
+ gfc_mark_ss_chain_used (shape_ss, 1);
+
+ gfc_copy_loopinfo_to_se (&shapese, &loop);
+ shapese.ss = shape_ss;
+
+ tree stride = gfc_create_var (gfc_array_index_type, "stride");
+ tree offset = gfc_create_var (gfc_array_index_type, "offset");
+ gfc_add_modify (block, stride, gfc_index_one_node);
+ gfc_add_modify (block, offset, gfc_index_zero_node);
+
+ /* Loop body. */
+ stmtblock_t body;
+ gfc_start_scalarized_body (&loop, &body);
+
+ tree dim = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+ loop.loopvar[0], loop.from[0]);
+
+ /* Set bounds and stride. */
+ gfc_conv_descriptor_lbound_set (&body, desc, dim, gfc_index_one_node);
+ gfc_conv_descriptor_stride_set (&body, desc, dim, stride);
+
+ gfc_conv_expr (&shapese, shape);
+ gfc_add_block_to_block (&body, &shapese.pre);
+ gfc_conv_descriptor_ubound_set (&body, desc, dim, shapese.expr);
+ gfc_add_block_to_block (&body, &shapese.post);
+
+ /* Calculate offset. */
+ gfc_add_modify (&body, offset,
+ fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type, offset, stride));
+ /* Update stride. */
+ gfc_add_modify (&body, stride,
+ fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, stride,
+ fold_convert (gfc_array_index_type,
+shapese.expr)));
+ /* Finish scalarization loop. */
+ gfc_trans_scalarizing_loops (&loop, &body);
+ gfc_add_block_to_block (block, &loop.pre);
+ gfc_add_block_to_block (block, &loop.post);
+ gfc_cleanup_loop (&loop);
+
+ gfc_add_modify (block, offset,
+ fold_build1_loc (input_location, NEGATE_EXPR,
+ gfc_array_index_type, offset));
+ gfc_conv_descriptor_offset_set (block, desc, offset);
+}
+
+
/* Obtain offsets for trans-types.cc(gfc_get_array_descr_info). */
void
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 3f39845c898f..05ea68d531ac 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -145,6 +145,8 @@ void gfc_clear_descriptor (stmtblock_t *block, gfc_symbol
*, tree);
void gfc_nullify_descriptor (stmtblock_t *block, gfc_expr *, tree);
void gfc_clear_descriptor (stmtblock_t *block, gfc_symbol *, gfc_expr *, tree);
void gfc_set_scalar_descriptor (stmtblock_t *block, tree, gfc_symbol *,
gfc_expr *, tree);
+void gfc_set_descriptor_with_shape (stmtblock_t *, tree, tree,
+ gfc_expr *, locus *);
/* Get a single array element. */
void gfc_conv_array_ref (gfc_se *, gfc_array_ref *, gfc_expr *, locus *);
diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc
index b6900d734afd..5d77f3d768a6 100644
--- a/gcc/fortran/trans-intrinsic.cc
+++ b/gcc/fortran/trans-intrinsic.cc
@@ -10482,11 +10482,8 @@ conv_isocbinding_subroutine (gfc_code *code)
gfc_se se;
gfc_se cptrse;
gfc_se fptrse;
- gfc_se shapese;
- gfc_ss *shape_ss;
- tree desc, dim, tmp, stride, offset;
- stmtbl
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Factorisation initialisation subarray_descriptor
https://gcc.gnu.org/g:41e38348a930505eacdc9386c9fce31a40bdbdb2
commit 41e38348a930505eacdc9386c9fce31a40bdbdb2
Author: Mikael Morin
Date: Tue Jan 21 18:44:41 2025 +0100
Factorisation initialisation subarray_descriptor
Diff:
---
gcc/fortran/trans-expr.cc | 151 --
1 file changed, 78 insertions(+), 73 deletions(-)
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index b7d1e3df0613..65b6cd8a4642 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -9418,17 +9418,90 @@ gfc_trans_subarray_assign (tree dest, gfc_component *
cm, gfc_expr * expr)
}
+static void
+set_subarray_descriptor (stmtblock_t *block, tree desc, tree value,
+gfc_expr *value_expr, gfc_expr *conv_arg)
+{
+ if (value_expr->expr_type != EXPR_VARIABLE)
+gfc_conv_descriptor_data_set (block, value,
+ null_pointer_node);
+
+ /* Obtain the array spec of full array references. */
+ gfc_array_spec *as;
+ if (conv_arg)
+as = gfc_get_full_arrayspec_from_expr (conv_arg);
+ else
+as = gfc_get_full_arrayspec_from_expr (value_expr);
+
+ /* Shift the lbound and ubound of temporaries to being unity,
+ rather than zero, based. Always calculate the offset. */
+ tree offset = gfc_conv_descriptor_offset_get (desc);
+ gfc_add_modify (block, offset, gfc_index_zero_node);
+ tree tmp2 = gfc_create_var (gfc_array_index_type, NULL);
+
+ for (int n = 0; n < value_expr->rank; n++)
+{
+ tree span;
+ tree lbound;
+
+ /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
+TODO It looks as if gfc_conv_expr_descriptor should return
+the correct bounds and that the following should not be
+necessary. This would simplify gfc_conv_intrinsic_bound
+as well. */
+ if (as && as->lower[n])
+ {
+ gfc_se lbse;
+ gfc_init_se (&lbse, NULL);
+ gfc_conv_expr (&lbse, as->lower[n]);
+ gfc_add_block_to_block (block, &lbse.pre);
+ lbound = gfc_evaluate_now (lbse.expr, block);
+ }
+ else if (as && conv_arg)
+ {
+ tree tmp = gfc_get_symbol_decl (conv_arg->symtree->n.sym);
+ lbound = gfc_conv_descriptor_lbound_get (tmp,
+ gfc_rank_cst[n]);
+ }
+ else if (as)
+ lbound = gfc_conv_descriptor_lbound_get (desc,
+ gfc_rank_cst[n]);
+ else
+ lbound = gfc_index_one_node;
+
+ lbound = fold_convert (gfc_array_index_type, lbound);
+
+ /* Shift the bounds and set the offset accordingly. */
+ tree tmp = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
+ span = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+ tmp, gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]));
+ tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+span, lbound);
+ gfc_conv_descriptor_ubound_set (block, desc,
+ gfc_rank_cst[n], tmp);
+ gfc_conv_descriptor_lbound_set (block, desc,
+ gfc_rank_cst[n], lbound);
+
+ tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+gfc_conv_descriptor_lbound_get (desc,
+gfc_rank_cst[n]),
+gfc_conv_descriptor_stride_get (desc,
+gfc_rank_cst[n]));
+ gfc_add_modify (block, tmp2, tmp);
+ tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+offset, tmp2);
+ gfc_conv_descriptor_offset_set (block, desc, tmp);
+}
+}
+
+
static tree
gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
gfc_expr * expr)
{
gfc_se se;
stmtblock_t block;
- tree offset;
- int n;
tree tmp;
- tree tmp2;
- gfc_array_spec *as;
gfc_expr *arg = NULL;
gfc_start_block (&block);
@@ -9489,10 +9562,6 @@ gfc_trans_alloc_subarray_assign (tree dest,
gfc_component * cm,
gfc_add_expr_to_block (&block, tmp);
gfc_add_block_to_block (&block, &se.post);
- if (expr->expr_type != EXPR_VARIABLE)
-gfc_conv_descriptor_data_set (&block, se.expr,
- null_pointer_node);
-
/* We need to know if the argument of a conversion function is a
variable, so that the correct lower bound can be used. */
if (expr->expr_type == EXPR_FUNCTION
@@ -9502,71 +9571,7 @@ gfc_trans_alloc_subarray_assign (tree dest,
gfc_component * cm,
&& expr->value.function.actual->expr->expr_type == EXPR_VARIABLE)
arg = expr->value.function.actual->expr;
- /* Obtain the array spec of full array references. */
- if (arg)
-as = gfc_get_full_arrayspec_from_expr (arg);
- else
-a
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Introduction gfc_conv_descriptor_extent_get
https://gcc.gnu.org/g:55a2a1029553f80b56f5a8c5ef8a5935c0dd1088
commit 55a2a1029553f80b56f5a8c5ef8a5935c0dd1088
Author: Mikael Morin
Date: Wed Jan 22 19:02:13 2025 +0100
Introduction gfc_conv_descriptor_extent_get
Diff:
---
gcc/fortran/trans-array.cc | 84 ++
gcc/fortran/trans-array.h | 1 +
gcc/fortran/trans-expr.cc | 6 +---
3 files changed, 50 insertions(+), 41 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 7afa29746e08..7357626be9a5 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -544,6 +544,51 @@ gfc_conv_descriptor_ubound_set (stmtblock_t *block, tree
desc,
}
+/* Calculate the size of a given array dimension from the bounds. This
+ is simply (ubound - lbound + 1) if this expression is positive
+ or 0 if it is negative (pick either one if it is zero). Optionally
+ (if or_expr is present) OR the (expression != 0) condition to it. */
+
+static tree
+conv_array_extent_dim (tree lbound, tree ubound, bool maybe_negative, tree*
or_expr)
+{
+ tree res;
+ tree cond;
+
+ /* Calculate (ubound - lbound + 1). */
+ res = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+ubound, lbound);
+ res = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, res,
+gfc_index_one_node);
+
+ /* Check whether the size for this dimension is negative. */
+ if (maybe_negative)
+{
+ cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node, res,
+ gfc_index_zero_node);
+ res = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
cond,
+gfc_index_zero_node, res);
+}
+
+ /* Build OR expression. */
+ if (maybe_negative && or_expr)
+*or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
+ logical_type_node, *or_expr, cond);
+
+ return res;
+}
+
+
+tree
+gfc_conv_descriptor_extent_get (tree desc, tree dim)
+{
+ tree ubound = gfc_conv_descriptor_ubound_get (desc, dim);
+ tree lbound = gfc_conv_descriptor_lbound_get (desc, dim);
+
+ return conv_array_extent_dim (lbound, ubound, false, NULL);
+}
+
+
static int
get_type_info (const bt &type)
{
@@ -7111,30 +7156,9 @@ gfc_set_delta (gfc_loopinfo *loop)
tree
gfc_conv_array_extent_dim (tree lbound, tree ubound, tree* or_expr)
{
- tree res;
- tree cond;
-
- /* Calculate (ubound - lbound + 1). */
- res = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
-ubound, lbound);
- res = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, res,
-gfc_index_one_node);
-
- /* Check whether the size for this dimension is negative. */
- cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node, res,
- gfc_index_zero_node);
- res = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type, cond,
-gfc_index_zero_node, res);
-
- /* Build OR expression. */
- if (or_expr)
-*or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
- logical_type_node, *or_expr, cond);
-
- return res;
+ return conv_array_extent_dim (lbound, ubound, true, or_expr);
}
-
/* For an array descriptor, get the total number of elements. This is just
the product of the extents along from_dim to to_dim. */
@@ -7148,14 +7172,7 @@ gfc_conv_descriptor_size_1 (tree desc, int from_dim, int
to_dim)
for (dim = from_dim; dim < to_dim; ++dim)
{
- tree lbound;
- tree ubound;
- tree extent;
-
- lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
- ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]);
-
- extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
+ tree extent = gfc_conv_descriptor_extent_get (desc, gfc_rank_cst[dim]);
res = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
res, extent);
}
@@ -10543,12 +10560,7 @@ gfc_full_array_size (stmtblock_t *block, tree decl,
int rank)
tree nelems;
tree tmp;
idx = gfc_rank_cst[rank - 1];
- nelems = gfc_conv_descriptor_ubound_get (decl, idx);
- tmp = gfc_conv_descriptor_lbound_get (decl, idx);
- tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
-nelems, tmp);
- tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
-tmp, gfc_index_one_node);
+ tmp = gfc_conv_descriptor_extent_get (decl, idx);
tmp = gfc_evaluate_now (tmp, block);
nelems = gfc_conv_descriptor_stride_get (decl, idx);
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index f9988a5fd109..1d694989b4c3 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -194,6 +194,7 @@ tree gfc_get_descriptor_
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Refactoring gfc_conv_descriptor_sm_get.
https://gcc.gnu.org/g:7d9a5b709d1f2400ea62c334bff7c9d4436a687c
commit 7d9a5b709d1f2400ea62c334bff7c9d4436a687c
Author: Mikael Morin
Date: Wed Jan 22 21:59:46 2025 +0100
Refactoring gfc_conv_descriptor_sm_get.
Diff:
---
gcc/fortran/trans-array.cc | 11 +++
gcc/fortran/trans-array.h | 1 +
gcc/fortran/trans-expr.cc | 4 +---
3 files changed, 13 insertions(+), 3 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 7357626be9a5..4d08a862c5be 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -589,6 +589,17 @@ gfc_conv_descriptor_extent_get (tree desc, tree dim)
}
+tree
+gfc_conv_descriptor_sm_get (tree desc, tree dim)
+{
+ tree stride = gfc_conv_descriptor_stride_get (desc, dim);
+ tree span = gfc_conv_descriptor_span_get (desc);
+
+ return fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+ stride, span);
+}
+
+
static int
get_type_info (const bt &type)
{
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 1d694989b4c3..296a8052dd73 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -195,6 +195,7 @@ tree gfc_conv_descriptor_stride_get (tree, tree);
tree gfc_conv_descriptor_lbound_get (tree, tree);
tree gfc_conv_descriptor_ubound_get (tree, tree);
tree gfc_conv_descriptor_extent_get (tree, tree);
+tree gfc_conv_descriptor_sm_get (tree, tree);
tree gfc_conv_descriptor_token (tree);
void gfc_conv_descriptor_data_set (stmtblock_t *, tree, tree);
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 84111f5e3d3d..6daa4a727f12 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -6262,9 +6262,7 @@ gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr
*e, gfc_symbol *fsym)
tmp = gfc_conv_descriptor_extent_get (gfc, idx);
gfc_add_modify (&loop_body, gfc_get_cfi_dim_extent (cfi, idx), tmp);
/* d->dim[n].sm = gfc->dim[i].stride * gfc->span); */
- tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
-gfc_conv_descriptor_stride_get (gfc, idx),
-gfc_conv_descriptor_span_get (gfc));
+ tmp = gfc_conv_descriptor_sm_get (gfc, idx);
gfc_add_modify (&loop_body, gfc_get_cfi_dim_sm (cfi, idx), tmp);
/* Generate loop. */
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Factorisation shift descriptor
https://gcc.gnu.org/g:c2ce7393ce79293896ae05dcfff402ffea2c9176
commit c2ce7393ce79293896ae05dcfff402ffea2c9176
Author: Mikael Morin
Date: Tue Jan 21 22:27:02 2025 +0100
Factorisation shift descriptor
Diff:
---
gcc/fortran/trans-array.cc | 117 -
gcc/fortran/trans-array.h | 1 +
gcc/fortran/trans-expr.cc | 82 ++-
3 files changed, 100 insertions(+), 100 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index b05f69fdd874..7afa29746e08 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -1198,16 +1198,52 @@ conv_shift_descriptor_lbound (stmtblock_t* block, tree
desc, int dim,
}
-class lb_info
+class lb_info_base
{
public:
+ virtual tree lower_bound (stmtblock_t *block, int dim) const = 0;
+};
+
+
+class lb_info : public lb_info_base
+{
+public:
+ using lb_info_base::lower_bound;
virtual gfc_expr *lower_bound (int dim) const = 0;
+ virtual tree lower_bound (stmtblock_t *block, int dim) const;
};
+tree
+lb_info::lower_bound (stmtblock_t *block, int dim) const
+{
+ gfc_expr *lb_expr = lower_bound(dim);
+
+ if (lb_expr == nullptr)
+return gfc_index_one_node;
+ else
+{
+ gfc_se lb_se;
+
+ gfc_init_se (&lb_se, nullptr);
+ gfc_conv_expr (&lb_se, lb_expr);
+
+ gfc_add_block_to_block (block, &lb_se.pre);
+ tree lb_var = gfc_create_var (gfc_array_index_type, "lower_bound");
+ gfc_add_modify (block, lb_var,
+ fold_convert (gfc_array_index_type, lb_se.expr));
+ gfc_add_block_to_block (block, &lb_se.post);
+
+ return lb_var;
+}
+}
+
+
+
class unset_lb : public lb_info
{
public:
+ using lb_info::lower_bound;
virtual gfc_expr *lower_bound (int) const { return nullptr; }
};
@@ -1218,6 +1254,7 @@ class defined_lb : public lb_info
gfc_expr * const * lower_bounds;
public:
+ using lb_info::lower_bound;
defined_lb (int arg_rank, gfc_expr * const
arg_lower_bounds[GFC_MAX_DIMENSIONS])
: rank(arg_rank), lower_bounds(arg_lower_bounds) { }
virtual gfc_expr *lower_bound (int dim) const { return lower_bounds[dim]; }
@@ -1226,7 +1263,7 @@ public:
static void
conv_shift_descriptor (stmtblock_t *block, tree desc, int rank,
- const lb_info &info)
+ const lb_info_base &info)
{
tree tmp = gfc_conv_descriptor_offset_get (desc);
tree offset_var = gfc_create_var (TREE_TYPE (tmp), "offset");
@@ -1235,26 +1272,7 @@ conv_shift_descriptor (stmtblock_t *block, tree desc,
int rank,
/* Apply a shift of the lbound when supplied. */
for (int dim = 0; dim < rank; ++dim)
{
- gfc_expr *lb_expr = info.lower_bound(dim);
-
- tree lower_bound;
- if (lb_expr == nullptr)
- lower_bound = gfc_index_one_node;
- else
- {
- gfc_se lb_se;
-
- gfc_init_se (&lb_se, nullptr);
- gfc_conv_expr (&lb_se, lb_expr);
-
- gfc_add_block_to_block (block, &lb_se.pre);
- tree lb_var = gfc_create_var (TREE_TYPE (lb_se.expr), "lower_bound");
- gfc_add_modify (block, lb_var, lb_se.expr);
- gfc_add_block_to_block (block, &lb_se.post);
-
- lower_bound = lb_var;
- }
-
+ tree lower_bound = info.lower_bound (block, dim);
conv_shift_descriptor_lbound (block, desc, dim, lower_bound, offset_var);
}
@@ -1337,6 +1355,61 @@ gfc_conv_shift_descriptor (stmtblock_t *block, tree desc,
}
+class dataref_lb : public lb_info_base
+{
+ gfc_array_spec *as;
+ gfc_expr *conv_arg;
+ tree desc;
+
+public:
+ dataref_lb (gfc_array_spec *arg_as, gfc_expr *arg_conv_arg, tree arg_desc)
+: as(arg_as), conv_arg (arg_conv_arg), desc (arg_desc)
+ {}
+ virtual tree lower_bound (stmtblock_t *block, int dim) const;
+};
+
+
+tree
+dataref_lb::lower_bound (stmtblock_t *block, int dim) const
+{
+ tree lbound;
+ if (as && as->lower[dim])
+{
+ gfc_se lbse;
+ gfc_init_se (&lbse, NULL);
+ gfc_conv_expr (&lbse, as->lower[dim]);
+ gfc_add_block_to_block (block, &lbse.pre);
+ lbound = gfc_evaluate_now (lbse.expr, block);
+}
+ else if (as && conv_arg)
+{
+ tree tmp = gfc_get_symbol_decl (conv_arg->symtree->n.sym);
+ lbound = gfc_conv_descriptor_lbound_get (tmp, gfc_rank_cst[dim]);
+}
+ else if (as)
+lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
+ else
+lbound = gfc_index_one_node;
+
+ return fold_convert (gfc_array_index_type, lbound);
+}
+
+
+void
+gfc_conv_shift_descriptor_subarray (stmtblock_t *block, tree desc,
+ gfc_expr *value_expr, gfc_expr *conv_arg)
+{
+ /* Obtain the array spec of full array references. */
+ gfc_array_spec *as;
+ if (conv_arg)
+as = gfc_get_full_arrayspec_from_expr (conv_arg);
+ else
+as = gfc_get_full_arrayspec_from_expr (value_expr);
+
+ conv_shift_descriptor (block, desc, value_expr->rank, dataref_lb (as,
conv
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Factorisation initialisation depuis cfi
https://gcc.gnu.org/g:1392f13442685eacd23ee09a10daccbaf00481ec
commit 1392f13442685eacd23ee09a10daccbaf00481ec
Author: Mikael Morin
Date: Fri Jan 24 16:01:58 2025 +0100
Factorisation initialisation depuis cfi
Correction régression contiguous-2.f90
Correction regression contiguous-2.f90
Correction régression bind-c-contiguous-1.f90
Diff:
---
gcc/fortran/trans-decl.cc | 220 --
gcc/fortran/trans-expr.cc | 209 ---
gcc/fortran/trans.h | 2 +
3 files changed, 194 insertions(+), 237 deletions(-)
diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc
index dad15858fa6a..baa36e88bf15 100644
--- a/gcc/fortran/trans-decl.cc
+++ b/gcc/fortran/trans-decl.cc
@@ -7009,7 +7009,7 @@ gfc_conv_cfi_to_gfc (stmtblock_t *init, stmtblock_t
*finally,
stmtblock_t block;
gfc_init_block (&block);
tree cfi = build_fold_indirect_ref_loc (input_location, cfi_desc);
- tree idx, etype, tmp, tmp2, size_var = NULL_TREE, rank = NULL_TREE;
+ tree idx, tmp, tmp2, size_var = NULL_TREE, rank = NULL_TREE;
bool do_copy_inout = false;
/* When allocatable + intent out, free the cfi descriptor. */
@@ -7201,106 +7201,10 @@ gfc_conv_cfi_to_gfc (stmtblock_t *init, stmtblock_t
*finally,
goto done;
}
- if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_desc)))
-{
- /* gfc->dtype = ... (from declaration, not from cfi). */
- etype = gfc_get_element_type (TREE_TYPE (gfc_desc));
- gfc_add_modify (&block, gfc_conv_descriptor_dtype (gfc_desc),
- gfc_get_dtype_rank_type (sym->as->rank, etype));
- /* gfc->data = cfi->base_addr. */
- gfc_conv_descriptor_data_set (&block, gfc_desc,
- gfc_get_cfi_desc_base_addr (cfi));
-}
-
- if (sym->ts.type == BT_ASSUMED)
-{
- /* For type(*), take elem_len + dtype.type from the actual argument. */
- gfc_add_modify (&block, gfc_conv_descriptor_elem_len (gfc_desc),
- gfc_get_cfi_desc_elem_len (cfi));
- tree cond;
- tree ctype = gfc_get_cfi_desc_type (cfi);
- ctype = fold_build2_loc (input_location, BIT_AND_EXPR, TREE_TYPE (ctype),
- ctype, build_int_cst (TREE_TYPE (ctype),
-CFI_type_mask));
- tree type = gfc_conv_descriptor_type (gfc_desc);
-
- /* if (CFI_type_cptr) BT_VOID else BT_UNKNOWN */
- /* Note: BT_VOID is could also be CFI_type_funcptr, but assume c_ptr. */
- cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
ctype,
- build_int_cst (TREE_TYPE (ctype), CFI_type_cptr));
- tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, type,
-build_int_cst (TREE_TYPE (type), BT_VOID));
- tmp2 = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
- type,
- build_int_cst (TREE_TYPE (type), BT_UNKNOWN));
- tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
- tmp, tmp2);
- /* if (CFI_type_struct) BT_DERIVED else < tmp2 > */
- cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
ctype,
- build_int_cst (TREE_TYPE (ctype),
-CFI_type_struct));
- tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, type,
-build_int_cst (TREE_TYPE (type), BT_DERIVED));
- tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
- tmp, tmp2);
- /* if (CFI_type_Character) BT_CHARACTER else < tmp2 > */
- /* Note: this is kind=1, CFI_type_ucs4_char is handled in the 'else if'
-before (see below, as generated bottom up). */
- cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
ctype,
- build_int_cst (TREE_TYPE (ctype),
- CFI_type_Character));
- tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, type,
-build_int_cst (TREE_TYPE (type), BT_CHARACTER));
- tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
- tmp, tmp2);
- /* if (CFI_type_ucs4_char) BT_CHARACTER else < tmp2 > */
- /* Note: gfc->elem_len = cfi->elem_len/4. */
- /* However, assuming that CFI_type_ucs4_char cannot be recovered, leave
-gfc->elem_len == cfi->elem_len, which helps with operations which use
-sizeof() in Fortran and cfi->elem_len in C. */
- tmp = gfc_get_cfi_desc_type (cfi);
- cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, tmp,
- build_int_cst (TREE_TYPE (tmp),
-
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] utilisation booléen allocatable
https://gcc.gnu.org/g:84be5a435f2a78f8a9ab0bdf5b693a1e0c6b6fd5
commit 84be5a435f2a78f8a9ab0bdf5b693a1e0c6b6fd5
Author: Mikael Morin
Date: Thu Jan 23 21:38:24 2025 +0100
utilisation booléen allocatable
Diff:
---
gcc/fortran/trans-expr.cc | 6 +++---
1 file changed, 3 insertions(+), 3 deletions(-)
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 95b168fe76a8..518a5a127cf0 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -5938,12 +5938,12 @@ set_dtype_for_unallocated (gfc_se *parmse, gfc_expr *e)
static void
set_gfc_from_cfi (stmtblock_t *block, tree gfc, tree cfi, tree rank,
- gfc_symbol *c_sym)
+ bool allocatable)
{
tree tmp = gfc_get_cfi_desc_base_addr (cfi);
gfc_conv_descriptor_data_set (block, gfc, tmp);
- if (c_sym->attr.allocatable)
+ if (allocatable)
{
/* gfc->span = cfi->elem_len. */
tmp = fold_convert (gfc_array_index_type,
@@ -6396,7 +6396,7 @@ done:
tmp = gfc_get_cfi_desc_base_addr (cfi);
gfc_conv_descriptor_data_set (&block, gfc, tmp);
- set_gfc_from_cfi (&block2, gfc, cfi, rank, fsym);
+ set_gfc_from_cfi (&block2, gfc, cfi, rank, fsym->attr.allocatable);
}
if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length)
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Factorisation initialisation gfc depuis cfi
https://gcc.gnu.org/g:57a9d2504fe45acda17cd2b7efa99495c276f4df
commit 57a9d2504fe45acda17cd2b7efa99495c276f4df
Author: Mikael Morin
Date: Thu Jan 23 20:46:59 2025 +0100
Factorisation initialisation gfc depuis cfi
Correction régression scalar descriptor
Diff:
---
gcc/fortran/trans-expr.cc | 132 +-
1 file changed, 72 insertions(+), 60 deletions(-)
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 6daa4a727f12..95b168fe76a8 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -5936,6 +5936,75 @@ set_dtype_for_unallocated (gfc_se *parmse, gfc_expr *e)
#endif
+static void
+set_gfc_from_cfi (stmtblock_t *block, tree gfc, tree cfi, tree rank,
+ gfc_symbol *c_sym)
+{
+ tree tmp = gfc_get_cfi_desc_base_addr (cfi);
+ gfc_conv_descriptor_data_set (block, gfc, tmp);
+
+ if (c_sym->attr.allocatable)
+{
+ /* gfc->span = cfi->elem_len. */
+ tmp = fold_convert (gfc_array_index_type,
+ gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]));
+}
+ else
+{
+ /* gfc->span = ((cfi->dim[0].sm % cfi->elem_len)
+ ? cfi->dim[0].sm : cfi->elem_len). */
+ tmp = gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]);
+ tree tmp2 = fold_convert (gfc_array_index_type,
+ gfc_get_cfi_desc_elem_len (cfi));
+ tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR,
+gfc_array_index_type, tmp, tmp2);
+ tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+tmp, gfc_index_zero_node);
+ tmp = build3_loc (input_location, COND_EXPR, gfc_array_index_type, tmp,
+ gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]), tmp2);
+}
+ gfc_conv_descriptor_span_set (block, gfc, tmp);
+
+ /* Calculate offset + set lbound, ubound and stride. */
+ gfc_conv_descriptor_offset_set (block, gfc, gfc_index_zero_node);
+ /* Loop: for (i = 0; i < rank; ++i). */
+ tree idx = gfc_create_var (TREE_TYPE (rank), "idx");
+ /* Loop body. */
+ stmtblock_t loop_body;
+ gfc_init_block (&loop_body);
+ /* gfc->dim[i].lbound = ... */
+ tmp = gfc_get_cfi_dim_lbound (cfi, idx);
+ gfc_conv_descriptor_lbound_set (&loop_body, gfc, idx, tmp);
+
+ /* gfc->dim[i].ubound = gfc->dim[i].lbound + cfi->dim[i].extent - 1. */
+ tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+gfc_conv_descriptor_lbound_get (gfc, idx),
+gfc_index_one_node);
+ tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+gfc_get_cfi_dim_extent (cfi, idx), tmp);
+ gfc_conv_descriptor_ubound_set (&loop_body, gfc, idx, tmp);
+
+ /* gfc->dim[i].stride = cfi->dim[i].sm / cfi>elem_len */
+ tmp = gfc_get_cfi_dim_sm (cfi, idx);
+ tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
+gfc_array_index_type, tmp,
+fold_convert (gfc_array_index_type,
+ gfc_get_cfi_desc_elem_len (cfi)));
+ gfc_conv_descriptor_stride_set (&loop_body, gfc, idx, tmp);
+
+ /* gfc->offset -= gfc->dim[i].stride * gfc->dim[i].lbound. */
+ tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+gfc_conv_descriptor_stride_get (gfc, idx),
+gfc_conv_descriptor_lbound_get (gfc, idx));
+ tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+gfc_conv_descriptor_offset_get (gfc), tmp);
+ gfc_conv_descriptor_offset_set (&loop_body, gfc, tmp);
+ /* Generate loop. */
+ gfc_simple_for_loop (block, idx, build_int_cst (TREE_TYPE (idx), 0),
+ rank, LT_EXPR, build_int_cst (TREE_TYPE (idx), 1),
+ gfc_finish_block (&loop_body));
+}
+
/* Provide an interface between gfortran array descriptors and the F2018:18.4
ISO_Fortran_binding array descriptors. */
@@ -6315,8 +6384,10 @@ done:
goto post_call;
gfc_init_block (&block2);
+
if (e->rank == 0)
{
+ gfc_init_block (&block2);
tmp = gfc_get_cfi_desc_base_addr (cfi);
gfc_add_modify (&block, gfc, fold_convert (TREE_TYPE (gfc), tmp));
}
@@ -6325,66 +6396,7 @@ done:
tmp = gfc_get_cfi_desc_base_addr (cfi);
gfc_conv_descriptor_data_set (&block, gfc, tmp);
- if (fsym->attr.allocatable)
- {
- /* gfc->span = cfi->elem_len. */
- tmp = fold_convert (gfc_array_index_type,
- gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]));
- }
- else
- {
- /* gfc->span = ((cfi->dim[0].sm % cfi->elem_len)
- ? cfi->dim[0].sm : cfi->elem_len). */
- tmp = gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]);
- tmp2 = fold_convert (gfc_array_index_type,
- gfc_get_cfi_desc_elem_len (cfi
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Factorisation set_descriptor_from_scalar dans conv_class_to_class
https://gcc.gnu.org/g:60fb6b7d916d2d309ca305c8848baefe06ae06c6
commit 60fb6b7d916d2d309ca305c8848baefe06ae06c6
Author: Mikael Morin
Date: Tue Jan 28 21:03:24 2025 +0100
Factorisation set_descriptor_from_scalar dans conv_class_to_class
Correction régression associate_66
Correction régression PR100040.f90
Diff:
---
gcc/fortran/trans-expr.cc | 34 ++
1 file changed, 22 insertions(+), 12 deletions(-)
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index a5cd0a452d81..6afb344245f2 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -172,6 +172,27 @@ gfc_conv_null_array_descriptor (gfc_se *se, gfc_symbol
*sym, gfc_expr *expr)
}
+void
+set_descriptor_from_scalar (stmtblock_t *block, tree desc, tree scalar,
+ gfc_expr *scalar_expr)
+{
+ tree type = get_scalar_to_descriptor_type (scalar,
+gfc_expr_attr (scalar_expr));
+ if (POINTER_TYPE_P (type))
+type = TREE_TYPE (type);
+
+ tree dtype_val = gfc_get_dtype (type);
+ tree dtype_ref = gfc_conv_descriptor_dtype (desc);
+ gfc_add_modify (block, dtype_ref, dtype_val);
+
+ tree tmp = gfc_class_data_get (scalar);
+ if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
+tmp = gfc_build_addr_expr (NULL_TREE, tmp);
+
+ gfc_conv_descriptor_data_set (block, desc, tmp);
+}
+
+
tree
gfc_conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr)
{
@@ -1434,18 +1455,7 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e,
gfc_typespec class_ts,
&& e->rank != class_ts.u.derived->components->as->rank)
{
if (e->rank == 0)
- {
- tree type = get_scalar_to_descriptor_type (parmse->expr,
-gfc_expr_attr (e));
- gfc_add_modify (&block, gfc_conv_descriptor_dtype (ctree),
- gfc_get_dtype (type));
-
- tmp = gfc_class_data_get (parmse->expr);
- if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
- tmp = gfc_build_addr_expr (NULL_TREE, tmp);
-
- gfc_conv_descriptor_data_set (&block, ctree, tmp);
- }
+ set_descriptor_from_scalar (&block, ctree, parmse->expr, e);
else
gfc_class_array_data_assign (&block, ctree, parmse->expr, false);
}
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Update dump match count
https://gcc.gnu.org/g:08384499e15f84f573c888267a125e6ae15cd904
commit 08384499e15f84f573c888267a125e6ae15cd904
Author: Mikael Morin
Date: Thu Jan 30 16:53:48 2025 +0100
Update dump match count
Diff:
---
gcc/testsuite/gfortran.dg/coarray_collectives_18.f90 | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/gcc/testsuite/gfortran.dg/coarray_collectives_18.f90
b/gcc/testsuite/gfortran.dg/coarray_collectives_18.f90
index c83899de0e5b..a1f2a76ff73e 100644
--- a/gcc/testsuite/gfortran.dg/coarray_collectives_18.f90
+++ b/gcc/testsuite/gfortran.dg/coarray_collectives_18.f90
@@ -33,5 +33,5 @@ end program
! This lead to access to non exsitant memory in opencoarrays.
! In single image mode just checking for reduced number of
! descriptors is possible, i.e., execute always works.
-! { dg-final { scan-tree-dump-times "desc\\.\[0-9\]+" 12 "original" } }
+! { dg-final { scan-tree-dump-times "desc\\.\[0-9\]+" 10 "original" } }
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Factorisation set_descriptor_from_scalar conv_derived_to_class
https://gcc.gnu.org/g:c3d8cf0e081de45c9a2f5d2d80ff8675f5e4614a
commit c3d8cf0e081de45c9a2f5d2d80ff8675f5e4614a
Author: Mikael Morin
Date: Wed Jan 29 18:22:29 2025 +0100
Factorisation set_descriptor_from_scalar conv_derived_to_class
Diff:
---
gcc/fortran/trans-expr.cc | 42 +++---
1 file changed, 23 insertions(+), 19 deletions(-)
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 6afb344245f2..091e1417faed 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -174,7 +174,8 @@ gfc_conv_null_array_descriptor (gfc_se *se, gfc_symbol
*sym, gfc_expr *expr)
void
set_descriptor_from_scalar (stmtblock_t *block, tree desc, tree scalar,
- gfc_expr *scalar_expr)
+ gfc_expr *scalar_expr, bool is_class,
+ tree cond_optional)
{
tree type = get_scalar_to_descriptor_type (scalar,
gfc_expr_attr (scalar_expr));
@@ -185,9 +186,22 @@ set_descriptor_from_scalar (stmtblock_t *block, tree desc,
tree scalar,
tree dtype_ref = gfc_conv_descriptor_dtype (desc);
gfc_add_modify (block, dtype_ref, dtype_val);
- tree tmp = gfc_class_data_get (scalar);
- if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
-tmp = gfc_build_addr_expr (NULL_TREE, tmp);
+ tree tmp;
+ if (is_class)
+{
+ tmp = gfc_class_data_get (scalar);
+ if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
+ tmp = gfc_build_addr_expr (NULL_TREE, tmp);
+}
+ else if (cond_optional)
+{
+ tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (scalar),
+ cond_optional, scalar,
+ fold_convert (TREE_TYPE (scalar),
+ null_pointer_node));
+}
+ else
+tmp = scalar;
gfc_conv_descriptor_data_set (block, desc, tmp);
}
@@ -1067,20 +1081,9 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
gfc_symbol *fsym,
/* Scalar to an assumed-rank array. */
if (fsym->ts.u.derived->components->as)
- {
- tree type;
- type = get_scalar_to_descriptor_type (parmse->expr,
- gfc_expr_attr (e));
- gfc_add_modify (&parmse->pre, gfc_conv_descriptor_dtype (ctree),
- gfc_get_dtype (type));
- if (optional)
- parmse->expr = build3_loc (input_location, COND_EXPR,
- TREE_TYPE (parmse->expr),
- cond_optional, parmse->expr,
- fold_convert (TREE_TYPE
(parmse->expr),
-null_pointer_node));
- gfc_conv_descriptor_data_set (&parmse->pre, ctree, parmse->expr);
- }
+ set_descriptor_from_scalar (&parmse->pre, ctree,
+ parmse->expr, e, false,
+ cond_optional);
else
{
tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
@@ -1455,7 +1458,8 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e,
gfc_typespec class_ts,
&& e->rank != class_ts.u.derived->components->as->rank)
{
if (e->rank == 0)
- set_descriptor_from_scalar (&block, ctree, parmse->expr, e);
+ set_descriptor_from_scalar (&block, ctree, parmse->expr, e,
+ true, NULL_TREE);
else
gfc_class_array_data_assign (&block, ctree, parmse->expr, false);
}
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Suppression code redondant
https://gcc.gnu.org/g:0aef3272bde76847317337411e9b7b75e74dc101
commit 0aef3272bde76847317337411e9b7b75e74dc101
Author: Mikael Morin
Date: Thu Jan 30 20:57:37 2025 +0100
Suppression code redondant
Diff:
---
gcc/fortran/trans-expr.cc | 8
1 file changed, 8 deletions(-)
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 860224066167..18d54d2a1f93 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -193,14 +193,6 @@ set_descriptor_from_scalar (stmtblock_t *block, tree desc,
tree scalar,
gfc_conv_descriptor_span_set (block, desc, integer_zero_node);
- if (CONSTANT_CLASS_P (scalar))
-{
- tree tmp;
- tmp = gfc_create_var (TREE_TYPE (scalar), "scalar");
- gfc_add_modify (block, tmp, scalar);
- scalar = tmp;
-}
-
tree tmp;
if (is_class)
tmp = gfc_class_data_get (scalar);
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Déplacement méthode set_descriptor_from_scalar
https://gcc.gnu.org/g:da0f06041ed11f41d66b165320f27973c71d8186
commit da0f06041ed11f41d66b165320f27973c71d8186
Author: Mikael Morin
Date: Thu Jan 30 21:07:15 2025 +0100
Déplacement méthode set_descriptor_from_scalar
Correction erreur compil'
Diff:
---
gcc/fortran/trans-array.cc | 63 +++
gcc/fortran/trans-array.h | 3 ++
gcc/fortran/trans-expr.cc | 83 +-
3 files changed, 75 insertions(+), 74 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 4d08a862c5be..a1fb41fc9354 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -1772,6 +1772,69 @@ gfc_set_descriptor_with_shape (stmtblock_t *block, tree
desc,
gfc_conv_descriptor_offset_set (block, desc, offset);
}
+/* Convert a scalar to an array descriptor. To be used for assumed-rank
+ arrays. */
+
+tree
+gfc_get_scalar_to_descriptor_type (tree scalar, symbol_attribute attr)
+{
+ enum gfc_array_kind akind;
+
+ if (attr.pointer)
+akind = GFC_ARRAY_POINTER_CONT;
+ else if (attr.allocatable)
+akind = GFC_ARRAY_ALLOCATABLE;
+ else
+akind = GFC_ARRAY_ASSUMED_SHAPE_CONT;
+
+ if (POINTER_TYPE_P (TREE_TYPE (scalar)))
+scalar = TREE_TYPE (scalar);
+ return gfc_get_array_type_bounds (TREE_TYPE (scalar), 0, 0, NULL, NULL, 1,
+ akind, !(attr.pointer || attr.target));
+}
+
+
+void
+gfc_set_descriptor_from_scalar (stmtblock_t *block, tree desc, tree scalar,
+ symbol_attribute scalar_attr, bool is_class,
+ tree cond_optional)
+{
+ tree type = gfc_get_scalar_to_descriptor_type (scalar, scalar_attr);
+ if (POINTER_TYPE_P (type))
+type = TREE_TYPE (type);
+
+ tree etype = gfc_get_element_type (type);
+ tree dtype_val;
+ if (etype == void_type_node)
+dtype_val = gfc_get_dtype_rank_type (0, TREE_TYPE (scalar));
+ else
+dtype_val = gfc_get_dtype (type);
+
+ tree dtype_ref = gfc_conv_descriptor_dtype (desc);
+ gfc_add_modify (block, dtype_ref, dtype_val);
+
+ gfc_conv_descriptor_span_set (block, desc, integer_zero_node);
+
+ tree tmp;
+ if (is_class)
+tmp = gfc_class_data_get (scalar);
+ else
+tmp = scalar;
+
+ if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
+tmp = gfc_build_addr_expr (NULL_TREE, tmp);
+
+ if (cond_optional)
+{
+ tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
+ cond_optional, tmp,
+ fold_convert (TREE_TYPE (scalar),
+ null_pointer_node));
+}
+
+ gfc_conv_descriptor_data_set (block, desc, tmp);
+}
+
/* Obtain offsets for trans-types.cc(gfc_get_array_descr_info). */
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 296a8052dd73..691231f66903 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -147,6 +147,9 @@ void gfc_clear_descriptor (stmtblock_t *block, gfc_symbol
*, gfc_expr *, tree);
void gfc_set_scalar_descriptor (stmtblock_t *block, tree, gfc_symbol *,
gfc_expr *, tree);
void gfc_set_descriptor_with_shape (stmtblock_t *, tree, tree,
gfc_expr *, locus *);
+tree gfc_get_scalar_to_descriptor_type (tree scalar, symbol_attribute attr);
+void gfc_set_descriptor_from_scalar (stmtblock_t *, tree, tree,
+symbol_attribute, bool, tree);
/* Get a single array element. */
void gfc_conv_array_ref (gfc_se *, gfc_array_ref *, gfc_expr *, locus *);
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 18d54d2a1f93..2ece9d369d80 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -83,34 +83,12 @@ gfc_get_character_len_in_bytes (tree type)
}
-/* Convert a scalar to an array descriptor. To be used for assumed-rank
- arrays. */
-
-static tree
-get_scalar_to_descriptor_type (tree scalar, symbol_attribute attr)
-{
- enum gfc_array_kind akind;
-
- if (attr.pointer)
-akind = GFC_ARRAY_POINTER_CONT;
- else if (attr.allocatable)
-akind = GFC_ARRAY_ALLOCATABLE;
- else
-akind = GFC_ARRAY_ASSUMED_SHAPE_CONT;
-
- if (POINTER_TYPE_P (TREE_TYPE (scalar)))
-scalar = TREE_TYPE (scalar);
- return gfc_get_array_type_bounds (TREE_TYPE (scalar), 0, 0, NULL, NULL, 1,
- akind, !(attr.pointer || attr.target));
-}
-
-
tree
gfc_conv_scalar_null_to_descriptor (gfc_se *se, gfc_symbol *sym, gfc_expr
*expr, tree scalar)
{
symbol_attribute attr = sym->attr;
- tree type = get_scalar_to_descriptor_type (scalar, attr);
+ tree type = gfc_get_scalar_to_descriptor_type (scalar, attr);
tree desc = gfc_create_var (type, "desc");
DECL_ARTIFICIAL (desc) = 1;
@@ -172,55 +150,12 @@ gfc_conv_null_array_descriptor (gfc_se *se, gfc_symbol
*sym, gfc_expr *expr)
}
-void
-set_descriptor_from_scalar (stmtblock_t *block, tree desc, tree scalar,
-
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Sauvegarde factorisation set_descriptor_from_scalar
https://gcc.gnu.org/g:34baff548d9dc0913b69f129deb42a51686257db
commit 34baff548d9dc0913b69f129deb42a51686257db
Author: Mikael Morin
Date: Tue Feb 4 11:16:32 2025 +0100
Sauvegarde factorisation set_descriptor_from_scalar
Correction régression allocate_with_source_15.f03
Nettoyage correction
Correction régression allocate_with_mold_3
Correction allocate_with_source_16.f90
Correction régression assumed_rank_21.f90
Correction coarray_allocate_8.f08
Correction régression pr86470.f90
Correction régression dummy_3.f90
Diff:
---
gcc/fortran/trans-array.cc | 204 +++--
gcc/fortran/trans-array.h | 2 +-
gcc/fortran/trans-expr.cc | 67 +--
gcc/fortran/trans-types.cc | 47 +++
gcc/fortran/trans-types.h | 1 +
gcc/fortran/trans.h| 1 +
6 files changed, 218 insertions(+), 104 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index d6e7c9829ff2..90eafe7ffe18 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -92,6 +92,7 @@ along with GCC; see the file COPYING3. If not see
#include "trans-array.h"
#include "trans-const.h"
#include "dependency.h"
+#include "gimplify.h"
static bool gfc_get_array_constructor_size (mpz_t *, gfc_constructor_base);
@@ -600,7 +601,7 @@ gfc_conv_descriptor_sm_get (tree desc, tree dim)
}
-static int
+static bt
get_type_info (const bt &type)
{
switch (type)
@@ -611,11 +612,13 @@ get_type_info (const bt &type)
case BT_COMPLEX:
case BT_DERIVED:
case BT_CHARACTER:
-case BT_CLASS:
case BT_VOID:
case BT_UNSIGNED:
return type;
+case BT_CLASS:
+ return BT_DERIVED;
+
case BT_PROCEDURE:
case BT_ASSUMED:
return BT_VOID;
@@ -672,9 +675,15 @@ get_size_info (gfc_typespec &ts)
class modify_info
{
public:
+ virtual bool set_dtype () const { return is_initialization (); }
+ virtual bool use_tree_type () const { return false; }
virtual bool is_initialization () const { return false; }
virtual bool initialize_data () const { return false; }
+ virtual bool set_span () const { return false; }
+ virtual bool set_token () const { return true; }
virtual tree get_data_value () const { return NULL_TREE; }
+ virtual bt get_type_type (const gfc_typespec &) const { return BT_UNKNOWN; }
+ virtual tree get_length (gfc_typespec *ts) const { return get_size_info
(*ts); }
};
class nullification : public modify_info
@@ -698,8 +707,14 @@ class init_info : public modify_info
public:
virtual bool is_initialization () const { return true; }
virtual gfc_typespec *get_type () const { return nullptr; }
+ virtual bt get_type_type (const gfc_typespec &) const;
};
+bt
+init_info::get_type_type (const gfc_typespec & type_info) const
+{
+ return get_type_info (type_info.type);
+}
class default_init : public init_info
{
@@ -729,23 +744,103 @@ public:
virtual gfc_typespec *get_type () const { return &ts; }
};
-class scalar_value : public init_info
+
+class scalar_value : public modify_info
{
private:
- gfc_typespec &ts;
+ bool initialisation;
+ gfc_typespec *ts;
tree value;
+ bool use_tree_type_;
+ bool clear_token;
+ tree get_elt_type () const;
public:
scalar_value(gfc_typespec &arg_ts, tree arg_value)
-: ts(arg_ts), value(arg_value) { }
+: initialisation(true), ts(&arg_ts), value(arg_value), use_tree_type_
(false), clear_token(true) { }
+ scalar_value(tree arg_value)
+: initialisation(true), ts(nullptr), value(arg_value), use_tree_type_
(true), clear_token(false) { }
+ virtual bool is_initialization () const { return initialisation; }
virtual bool initialize_data () const { return true; }
- virtual tree get_data_value () const { return value; }
- virtual gfc_typespec *get_type () const { return &ts; }
+ virtual tree get_data_value () const;
+ virtual gfc_typespec *get_type () const { return ts; }
+ virtual bool set_span () const { return true; }
+ virtual bool use_tree_type () const { return use_tree_type_; }
+ virtual bool set_token () const { return clear_token; }
+ virtual bt get_type_type (const gfc_typespec &) const;
+ virtual tree get_length (gfc_typespec *ts) const;
};
+tree
+scalar_value::get_data_value () const
+{
+ if (POINTER_TYPE_P (TREE_TYPE (value)))
+return value;
+ else
+return gfc_build_addr_expr (NULL_TREE, value);
+}
+
+tree
+scalar_value::get_elt_type () const
+{
+ tree tmp = value;
+
+ if (POINTER_TYPE_P (TREE_TYPE (tmp)))
+tmp = TREE_TYPE (tmp);
+
+ tree etype = TREE_TYPE (tmp);
+
+ /* For arrays, which are not scalar coarrays. */
+ if (TREE_CODE (etype) == ARRAY_TYPE && !TYPE_STRING_FLAG (etype))
+etype = TREE_TYPE (etype);
+
+ return etype;
+}
+
+bt
+scalar_value::get_type_type (const gfc_typespec & type_info) const
+{
+ bt n;
+ if (use_tree_type ())
+{
+ tree etype = get_elt_type ();
+ gf
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Déplacement gfc_copy_sequence_descriptor
https://gcc.gnu.org/g:d29279433aa2fbcd57c06a7a9ca84e09a35c5bba
commit d29279433aa2fbcd57c06a7a9ca84e09a35c5bba
Author: Mikael Morin
Date: Thu Jan 30 21:21:39 2025 +0100
Déplacement gfc_copy_sequence_descriptor
Correction erreur compil'
Diff:
---
gcc/fortran/trans-array.cc | 64 ++
gcc/fortran/trans-array.h | 1 +
gcc/fortran/trans-expr.cc | 64 --
gcc/fortran/trans.h| 1 -
4 files changed, 65 insertions(+), 65 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index a1fb41fc9354..455c9bcd76cc 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -1835,6 +1835,70 @@ gfc_set_descriptor_from_scalar (stmtblock_t *block, tree
desc, tree scalar,
gfc_conv_descriptor_data_set (block, desc, tmp);
}
+int
+gfc_descriptor_rank (tree descriptor)
+{
+ if (TREE_TYPE (descriptor) != NULL_TREE)
+return GFC_TYPE_ARRAY_RANK (TREE_TYPE (descriptor));
+
+ tree dim = gfc_get_descriptor_dimension (descriptor);
+ tree dim_type = TREE_TYPE (dim);
+ gcc_assert (TREE_CODE (dim_type) == ARRAY_TYPE);
+ tree idx_type = TYPE_DOMAIN (dim_type);
+ gcc_assert (TREE_CODE (idx_type) == INTEGER_TYPE);
+ gcc_assert (integer_zerop (TYPE_MIN_VALUE (idx_type)));
+ tree idx_max = TYPE_MAX_VALUE (idx_type);
+ if (idx_max == NULL_TREE)
+return GFC_MAX_DIMENSIONS;
+ wide_int max = wi::to_wide (idx_max);
+ return max.to_shwi () + 1;
+}
+
+
+void
+gfc_copy_sequence_descriptor (stmtblock_t &block, tree lhs_desc, tree rhs_desc,
+ bool assumed_rank_lhs)
+{
+ int lhs_rank = gfc_descriptor_rank (lhs_desc);
+ int rhs_rank = gfc_descriptor_rank (rhs_desc);
+ tree desc;
+
+ if (assumed_rank_lhs || lhs_rank == rhs_rank)
+desc = rhs_desc;
+ else
+{
+ tree arr = gfc_create_var (TREE_TYPE (lhs_desc), "parm");
+ gfc_conv_descriptor_data_set (&block, arr,
+ gfc_conv_descriptor_data_get (rhs_desc));
+ gfc_conv_descriptor_lbound_set (&block, arr, gfc_index_zero_node,
+ gfc_index_zero_node);
+ tree size = gfc_conv_descriptor_size (rhs_desc, rhs_rank);
+ gfc_conv_descriptor_ubound_set (&block, arr, gfc_index_zero_node, size);
+ gfc_conv_descriptor_stride_set (
+ &block, arr, gfc_index_zero_node,
+ gfc_conv_descriptor_stride_get (rhs_desc, gfc_index_zero_node));
+ for (int i = 1; i < lhs_rank; i++)
+ {
+ gfc_conv_descriptor_lbound_set (&block, arr, gfc_rank_cst[i],
+ gfc_index_zero_node);
+ gfc_conv_descriptor_ubound_set (&block, arr, gfc_rank_cst[i],
+ gfc_index_zero_node);
+ gfc_conv_descriptor_stride_set (&block, arr, gfc_rank_cst[i], size);
+ }
+ gfc_add_modify (&block, gfc_conv_descriptor_dtype (arr),
+ gfc_conv_descriptor_dtype (rhs_desc));
+ gfc_add_modify (&block, gfc_conv_descriptor_rank (arr),
+ build_int_cst (signed_char_type_node, lhs_rank));
+ gfc_conv_descriptor_span_set (&block, arr,
+ gfc_conv_descriptor_span_get (arr));
+ gfc_conv_descriptor_offset_set (&block, arr, gfc_index_zero_node);
+ desc = arr;
+}
+
+ gfc_class_array_data_assign (&block, lhs_desc, desc, true);
+}
+
+
/* Obtain offsets for trans-types.cc(gfc_get_array_descr_info). */
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 691231f66903..124020a53858 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -150,6 +150,7 @@ void gfc_set_descriptor_with_shape (stmtblock_t *, tree,
tree,
tree gfc_get_scalar_to_descriptor_type (tree scalar, symbol_attribute attr);
void gfc_set_descriptor_from_scalar (stmtblock_t *, tree, tree,
symbol_attribute, bool, tree);
+void gfc_copy_sequence_descriptor (stmtblock_t &, tree, tree, bool);
/* Get a single array element. */
void gfc_conv_array_ref (gfc_se *, gfc_array_ref *, gfc_expr *, locus *);
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 2ece9d369d80..205c49949626 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -800,70 +800,6 @@ gfc_get_vptr_from_expr (tree expr)
}
-int
-gfc_descriptor_rank (tree descriptor)
-{
- if (TREE_TYPE (descriptor) != NULL_TREE)
-return GFC_TYPE_ARRAY_RANK (TREE_TYPE (descriptor));
-
- tree dim = gfc_get_descriptor_dimension (descriptor);
- tree dim_type = TREE_TYPE (dim);
- gcc_assert (TREE_CODE (dim_type) == ARRAY_TYPE);
- tree idx_type = TYPE_DOMAIN (dim_type);
- gcc_assert (TREE_CODE (idx_type) == INTEGER_TYPE);
- gcc_assert (integer_zerop (TYPE_MIN_VALUE (idx_type)));
- tree idx_max = TYPE_MAX_VALUE (idx_type);
- if (idx_max == NULL_TREE)
-return GFC_MAX_DIMENSIONS;
- wide_int max = wi::to_wide
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Factorisation set_descriptor_from_scalar dans gfc_conv_scalar_to_descriptor
https://gcc.gnu.org/g:01b40a54c893abe13bf134397e2f1651e4088d58
commit 01b40a54c893abe13bf134397e2f1651e4088d58
Author: Mikael Morin
Date: Wed Jan 29 19:05:04 2025 +0100
Factorisation set_descriptor_from_scalar dans gfc_conv_scalar_to_descriptor
Correction régression pr49213.f90
Correction régression associated_assumed_rank.f90
Diff:
---
gcc/fortran/trans-expr.cc | 67 +++
1 file changed, 38 insertions(+), 29 deletions(-)
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 091e1417faed..860224066167 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -174,46 +174,61 @@ gfc_conv_null_array_descriptor (gfc_se *se, gfc_symbol
*sym, gfc_expr *expr)
void
set_descriptor_from_scalar (stmtblock_t *block, tree desc, tree scalar,
- gfc_expr *scalar_expr, bool is_class,
+ symbol_attribute scalar_attr, bool is_class,
tree cond_optional)
{
- tree type = get_scalar_to_descriptor_type (scalar,
-gfc_expr_attr (scalar_expr));
+ tree type = get_scalar_to_descriptor_type (scalar, scalar_attr);
if (POINTER_TYPE_P (type))
type = TREE_TYPE (type);
- tree dtype_val = gfc_get_dtype (type);
+ tree etype = gfc_get_element_type (type);
+ tree dtype_val;
+ if (etype == void_type_node)
+dtype_val = gfc_get_dtype_rank_type (0, TREE_TYPE (scalar));
+ else
+dtype_val = gfc_get_dtype (type);
+
tree dtype_ref = gfc_conv_descriptor_dtype (desc);
gfc_add_modify (block, dtype_ref, dtype_val);
- tree tmp;
- if (is_class)
+ gfc_conv_descriptor_span_set (block, desc, integer_zero_node);
+
+ if (CONSTANT_CLASS_P (scalar))
{
- tmp = gfc_class_data_get (scalar);
- if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
- tmp = gfc_build_addr_expr (NULL_TREE, tmp);
+ tree tmp;
+ tmp = gfc_create_var (TREE_TYPE (scalar), "scalar");
+ gfc_add_modify (block, tmp, scalar);
+ scalar = tmp;
}
- else if (cond_optional)
+
+ tree tmp;
+ if (is_class)
+tmp = gfc_class_data_get (scalar);
+ else
+tmp = scalar;
+
+ if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
+tmp = gfc_build_addr_expr (NULL_TREE, tmp);
+
+ if (cond_optional)
{
- tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (scalar),
- cond_optional, scalar,
+ tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
+ cond_optional, tmp,
fold_convert (TREE_TYPE (scalar),
null_pointer_node));
}
- else
-tmp = scalar;
gfc_conv_descriptor_data_set (block, desc, tmp);
}
+
tree
gfc_conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr)
{
- tree desc, type, etype;
+ tree desc, type;
type = get_scalar_to_descriptor_type (scalar, attr);
- etype = TREE_TYPE (scalar);
desc = gfc_create_var (type, "desc");
DECL_ARTIFICIAL (desc) = 1;
@@ -224,15 +239,9 @@ gfc_conv_scalar_to_descriptor (gfc_se *se, tree scalar,
symbol_attribute attr)
gfc_add_modify (&se->pre, tmp, scalar);
scalar = tmp;
}
- if (!POINTER_TYPE_P (TREE_TYPE (scalar)))
-scalar = gfc_build_addr_expr (NULL_TREE, scalar);
- else if (TREE_TYPE (etype) && TREE_CODE (TREE_TYPE (etype)) == ARRAY_TYPE)
-etype = TREE_TYPE (etype);
- gfc_add_modify (&se->pre, gfc_conv_descriptor_dtype (desc),
- gfc_get_dtype_rank_type (0, etype));
- gfc_conv_descriptor_data_set (&se->pre, desc, scalar);
- gfc_conv_descriptor_span_set (&se->pre, desc,
- gfc_conv_descriptor_elem_len (desc));
+
+ set_descriptor_from_scalar (&se->pre, desc, scalar, attr,
+ false, NULL_TREE);
/* Copy pointer address back - but only if it could have changed and
if the actual argument is a pointer and not, e.g., NULL(). */
@@ -1082,8 +1091,8 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
gfc_symbol *fsym,
/* Scalar to an assumed-rank array. */
if (fsym->ts.u.derived->components->as)
set_descriptor_from_scalar (&parmse->pre, ctree,
- parmse->expr, e, false,
- cond_optional);
+ parmse->expr, gfc_expr_attr (e),
+ false, cond_optional);
else
{
tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
@@ -1458,8 +1467,8 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e,
gfc_typespec class_ts,
&& e->rank != class_ts.u.derived->components->as->rank)
{
if (e->rank == 0)
- set_descriptor_from_scalar (&block, ctree, parmse->expr, e,
- true, NULL_TREE);
+ set_descriptor_from_scalar (&block, ctree, pa
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Annulation modif dump assumed_rank_12.f90
https://gcc.gnu.org/g:ac8ccbd19b684c86649d332a17e71a8d40ae6bbb
commit ac8ccbd19b684c86649d332a17e71a8d40ae6bbb
Author: Mikael Morin
Date: Wed Feb 5 11:45:00 2025 +0100
Annulation modif dump assumed_rank_12.f90
Diff:
---
gcc/fortran/trans-array.cc | 126 -
1 file changed, 124 insertions(+), 2 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 90eafe7ffe18..531281049646 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -1085,11 +1085,131 @@ field_count (tree type)
}
-bool
+#if 0
+static bool
complete_init_p (tree type, vec *init_values)
{
return (unsigned) field_count (type) == vec_safe_length (init_values);
}
+#endif
+
+
+static int
+cmp_wi (const void *x, const void *y)
+{
+ const offset_int *wix = (const offset_int *) x;
+ const offset_int *wiy = (const offset_int *) y;
+
+ return wi::cmpu (*wix, *wiy);
+}
+
+
+static offset_int
+get_offset_bits (tree field)
+{
+ offset_int field_offset = wi::to_offset (DECL_FIELD_OFFSET (field));
+ offset_int field_bit_offset = wi::to_offset (DECL_FIELD_BIT_OFFSET (field));
+ unsigned long offset_align = DECL_OFFSET_ALIGN (field);
+
+ return field_offset * offset_align + field_bit_offset;
+}
+
+
+static bool
+check_cleared_low_bits (const offset_int &val, int bitcount)
+{
+ if (bitcount == 0)
+return true;
+
+ offset_int mask = wi::mask (bitcount, false);
+ if ((val & mask) != 0)
+return false;
+
+ return true;
+}
+
+
+static bool
+right_shift_if_clear (const offset_int &val, int bitcount, offset_int *result)
+{
+ if (bitcount == 0)
+{
+ *result = val;
+ return true;
+}
+
+ if (!check_cleared_low_bits (val, bitcount))
+return false;
+
+ *result = val >> bitcount;
+ return true;
+}
+
+
+static bool
+contiguous_init_p (tree type, tree value)
+{
+ gcc_assert (TREE_CODE (value) == CONSTRUCTOR);
+ auto_vec field_offsets;
+ int count = field_count (type);
+ field_offsets.reserve (count);
+
+ tree field = TYPE_FIELDS (type);
+ offset_int expected_offset = 0;
+ while (field != NULL_TREE)
+{
+ offset_int field_offset_bits = get_offset_bits (field);
+ offset_int field_offset;
+ if (!right_shift_if_clear (field_offset_bits, 3, &field_offset))
+ return false;
+
+ offset_int type_size = wi::to_offset (TYPE_SIZE_UNIT (TREE_TYPE
(field)));
+ int align = wi::ctz (type_size);
+ if (!check_cleared_low_bits (field_offset, align))
+ return false;
+
+ if (field_offset != expected_offset)
+ return false;
+
+ expected_offset += type_size;
+ field_offsets.quick_push (field_offset);
+
+ field = DECL_CHAIN (field);
+}
+
+ auto_vec value_offsets;
+ value_offsets.reserve (count);
+
+ unsigned i;
+ tree field_init;
+ FOR_EACH_CONSTRUCTOR_ELT (CONSTRUCTOR_ELTS (value), i, field, field_init)
+{
+ if (TREE_TYPE (field) != TREE_TYPE (field_init))
+ return false;
+
+ offset_int field_offset_bits = get_offset_bits (field);
+ offset_int field_offset;
+ if (!right_shift_if_clear (field_offset_bits, 3, &field_offset))
+ return false;
+
+ value_offsets.quick_push (field_offset);
+}
+
+ value_offsets.qsort (cmp_wi);
+
+ unsigned idx = 0;
+ offset_int field_off, val_off;
+ while (field_offsets.iterate (idx, &field_off)
+&& value_offsets.iterate (idx, &val_off))
+{
+ if (val_off != field_off)
+ return false;
+
+ idx++;
+}
+
+ return true;
+}
static bool
@@ -1161,7 +1281,9 @@ init_struct (stmtblock_t *block, tree data_ref, init_kind
kind,
if (TREE_STATIC (data_ref)
|| !modifiable_p (data_ref))
DECL_INITIAL (data_ref) = value;
- else if (TREE_CODE (value) == CONSTRUCTOR)
+ else if (TREE_CODE (value) == CONSTRUCTOR
+ && !(TREE_CONSTANT (value)
+ && contiguous_init_p (type, value)))
{
unsigned i;
tree field, field_init;
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Déplacement gfc_set_gfc_from_cfi
https://gcc.gnu.org/g:47b6338824d5cf0658bd91e24bd956dcf2bfaca3
commit 47b6338824d5cf0658bd91e24bd956dcf2bfaca3
Author: Mikael Morin
Date: Thu Jan 30 21:27:40 2025 +0100
Déplacement gfc_set_gfc_from_cfi
Correction compil'
Diff:
---
gcc/fortran/trans-array.cc | 258 +
gcc/fortran/trans-array.h | 3 +
gcc/fortran/trans-expr.cc | 218 --
gcc/fortran/trans.h| 3 -
4 files changed, 241 insertions(+), 241 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 455c9bcd76cc..d6e7c9829ff2 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -1466,6 +1466,26 @@ gfc_conv_shift_descriptor_subarray (stmtblock_t *block,
tree desc,
}
+int
+gfc_descriptor_rank (tree descriptor)
+{
+ if (TREE_TYPE (descriptor) != NULL_TREE)
+return GFC_TYPE_ARRAY_RANK (TREE_TYPE (descriptor));
+
+ tree dim = gfc_get_descriptor_dimension (descriptor);
+ tree dim_type = TREE_TYPE (dim);
+ gcc_assert (TREE_CODE (dim_type) == ARRAY_TYPE);
+ tree idx_type = TYPE_DOMAIN (dim_type);
+ gcc_assert (TREE_CODE (idx_type) == INTEGER_TYPE);
+ gcc_assert (integer_zerop (TYPE_MIN_VALUE (idx_type)));
+ tree idx_max = TYPE_MAX_VALUE (idx_type);
+ if (idx_max == NULL_TREE)
+return GFC_MAX_DIMENSIONS;
+ wide_int max = wi::to_wide (idx_max);
+ return max.to_shwi () + 1;
+}
+
+
void
gfc_conv_remap_descriptor (stmtblock_t *block, tree dest, tree src,
int src_rank, const gfc_array_spec &as)
@@ -1835,26 +1855,6 @@ gfc_set_descriptor_from_scalar (stmtblock_t *block, tree
desc, tree scalar,
gfc_conv_descriptor_data_set (block, desc, tmp);
}
-int
-gfc_descriptor_rank (tree descriptor)
-{
- if (TREE_TYPE (descriptor) != NULL_TREE)
-return GFC_TYPE_ARRAY_RANK (TREE_TYPE (descriptor));
-
- tree dim = gfc_get_descriptor_dimension (descriptor);
- tree dim_type = TREE_TYPE (dim);
- gcc_assert (TREE_CODE (dim_type) == ARRAY_TYPE);
- tree idx_type = TYPE_DOMAIN (dim_type);
- gcc_assert (TREE_CODE (idx_type) == INTEGER_TYPE);
- gcc_assert (integer_zerop (TYPE_MIN_VALUE (idx_type)));
- tree idx_max = TYPE_MAX_VALUE (idx_type);
- if (idx_max == NULL_TREE)
-return GFC_MAX_DIMENSIONS;
- wide_int max = wi::to_wide (idx_max);
- return max.to_shwi () + 1;
-}
-
-
void
gfc_copy_sequence_descriptor (stmtblock_t &block, tree lhs_desc, tree rhs_desc,
bool assumed_rank_lhs)
@@ -1899,6 +1899,224 @@ gfc_copy_sequence_descriptor (stmtblock_t &block, tree
lhs_desc, tree rhs_desc,
}
+void
+gfc_set_gfc_from_cfi (stmtblock_t *unconditional_block,
+ stmtblock_t *conditional_block, tree gfc, tree cfi,
+ tree rank, gfc_symbol *gfc_sym,
+ bool init_static, bool contiguous_gfc, bool
contiguous_cfi)
+{
+ tree tmp = gfc_get_cfi_desc_base_addr (cfi);
+ gfc_conv_descriptor_data_set (unconditional_block, gfc, tmp);
+
+ if (init_static)
+{
+ /* gfc->dtype = ... (from declaration, not from cfi). */
+ tree etype = gfc_get_element_type (TREE_TYPE (gfc));
+ gfc_add_modify (unconditional_block, gfc_conv_descriptor_dtype (gfc),
+ gfc_get_dtype_rank_type (gfc_sym->as->rank, etype));
+
+ if (gfc_sym->as->type == AS_ASSUMED_RANK)
+ gfc_add_modify (unconditional_block,
+ gfc_conv_descriptor_rank (gfc), rank);
+}
+
+ if (gfc_sym && gfc_sym->ts.type == BT_ASSUMED)
+{
+ /* For type(*), take elem_len + dtype.type from the actual argument. */
+ gfc_add_modify (unconditional_block, gfc_conv_descriptor_elem_len (gfc),
+ gfc_get_cfi_desc_elem_len (cfi));
+ tree cond;
+ tree ctype = gfc_get_cfi_desc_type (cfi);
+ ctype = fold_build2_loc (input_location, BIT_AND_EXPR, TREE_TYPE (ctype),
+ ctype, build_int_cst (TREE_TYPE (ctype),
+CFI_type_mask));
+ tree type = gfc_conv_descriptor_type (gfc);
+
+ /* if (CFI_type_cptr) BT_VOID else BT_UNKNOWN */
+ /* Note: BT_VOID is could also be CFI_type_funcptr, but assume c_ptr. */
+ cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
ctype,
+ build_int_cst (TREE_TYPE (ctype), CFI_type_cptr));
+ tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, type,
+build_int_cst (TREE_TYPE (type), BT_VOID));
+ tree tmp2 = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
+ type,
+ build_int_cst (TREE_TYPE (type),
BT_UNKNOWN));
+ tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
+ tmp, tmp2);
+ /* if (CFI_type_struct) BT_DERIVED else < tmp2 > */
+ cond = fold_build2_loc (input_location, EQ_
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Séparation motifs dump assumed_rank_12.f90
https://gcc.gnu.org/g:cd99fadb64da650e93e666dbf2eb7c4b15a6dc5b
commit cd99fadb64da650e93e666dbf2eb7c4b15a6dc5b
Author: Mikael Morin
Date: Wed Feb 5 11:57:09 2025 +0100
Séparation motifs dump assumed_rank_12.f90
Diff:
---
gcc/testsuite/gfortran.dg/assumed_rank_12.f90 | 6 +-
1 file changed, 5 insertions(+), 1 deletion(-)
diff --git a/gcc/testsuite/gfortran.dg/assumed_rank_12.f90
b/gcc/testsuite/gfortran.dg/assumed_rank_12.f90
index 873498f82d76..cacfb7ed52af 100644
--- a/gcc/testsuite/gfortran.dg/assumed_rank_12.f90
+++ b/gcc/testsuite/gfortran.dg/assumed_rank_12.f90
@@ -16,5 +16,9 @@ function f() result(res)
end function f
end
-! { dg-final { scan-tree-dump " = f \\(\\);.*desc.0.dtype = .*;.*desc.0.data =
.void .. D.*;.*sub \\(&desc.0\\);.*D.*= .integer.kind=4. .. desc.0.data;"
"original" } }
+! { dg-final { scan-tree-dump " = f \\(\\);" "original" } }
+! { dg-final { scan-tree-dump "desc.0.dtype = .*;" "original" } }
+! { dg-final { scan-tree-dump "desc.0.data = .void .. D.*;" "original" } }
+! { dg-final { scan-tree-dump "sub \\(&desc.0\\);" "original" } }
+! { dg-final { scan-tree-dump "D.*= .integer.kind=4. .. desc.0.data;"
"original" } }
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Renseignement token par gfc_set_descriptor_from_scalar.
https://gcc.gnu.org/g:96c395b57efb83588e592fca055aac91794c0919
commit 96c395b57efb83588e592fca055aac91794c0919
Author: Mikael Morin
Date: Wed Feb 5 15:12:25 2025 +0100
Renseignement token par gfc_set_descriptor_from_scalar.
Diff:
---
gcc/fortran/trans-array.cc | 27 ---
gcc/fortran/trans-array.h | 2 +-
gcc/fortran/trans-expr.cc | 15 +++
3 files changed, 32 insertions(+), 12 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 531281049646..c09b9bdab155 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -682,6 +682,7 @@ public:
virtual bool set_span () const { return false; }
virtual bool set_token () const { return true; }
virtual tree get_data_value () const { return NULL_TREE; }
+ virtual tree get_caf_token () const { return null_pointer_node; }
virtual bt get_type_type (const gfc_typespec &) const { return BT_UNKNOWN; }
virtual tree get_length (gfc_typespec *ts) const { return get_size_info
(*ts); }
};
@@ -751,22 +752,24 @@ private:
bool initialisation;
gfc_typespec *ts;
tree value;
+ tree caf_token;
bool use_tree_type_;
bool clear_token;
tree get_elt_type () const;
public:
scalar_value(gfc_typespec &arg_ts, tree arg_value)
-: initialisation(true), ts(&arg_ts), value(arg_value), use_tree_type_
(false), clear_token(true) { }
- scalar_value(tree arg_value)
-: initialisation(true), ts(nullptr), value(arg_value), use_tree_type_
(true), clear_token(false) { }
+: initialisation(true), ts(&arg_ts), value(arg_value), caf_token
(NULL_TREE), use_tree_type_ (false), clear_token(true) { }
+ scalar_value(tree arg_value, tree arg_caf_token)
+: initialisation(true), ts(nullptr), value(arg_value), caf_token
(arg_caf_token), use_tree_type_ (true), clear_token(false) { }
virtual bool is_initialization () const { return initialisation; }
virtual bool initialize_data () const { return true; }
virtual tree get_data_value () const;
virtual gfc_typespec *get_type () const { return ts; }
virtual bool set_span () const { return true; }
virtual bool use_tree_type () const { return use_tree_type_; }
- virtual bool set_token () const { return clear_token; }
+ virtual bool set_token () const { return clear_token || caf_token !=
NULL_TREE; }
+ virtual tree get_caf_token () const;
virtual bt get_type_type (const gfc_typespec &) const;
virtual tree get_length (gfc_typespec *ts) const;
};
@@ -838,6 +841,16 @@ scalar_value::get_length (gfc_typespec * type_info) const
return size;
}
+tree
+scalar_value::get_caf_token () const
+{
+ if (set_token ()
+ && caf_token != NULL_TREE)
+return caf_token;
+ else
+return modify_info::get_caf_token ();
+}
+
static tree
build_dtype (gfc_typespec *ts, int rank, const symbol_attribute &,
@@ -933,7 +946,7 @@ get_descriptor_init (tree type, gfc_typespec *ts, int rank,
tree token_field = gfc_advance_chain (fields,
CAF_TOKEN_FIELD - (!dim_present));
tree token_value = fold_convert (TREE_TYPE (token_field),
- null_pointer_node);
+ init.get_caf_token ());
CONSTRUCTOR_APPEND_ELT (v, token_field, token_value);
}
@@ -1430,11 +1443,11 @@ gfc_set_scalar_descriptor (stmtblock_t *block, tree
descriptor,
void
gfc_set_descriptor_from_scalar (stmtblock_t *block, tree desc, tree scalar,
- symbol_attribute *attr)
+ symbol_attribute *attr, tree caf_token)
{
init_struct (block, desc,
get_descriptor_init (TREE_TYPE (desc), nullptr, 0, attr,
- scalar_value (scalar)));
+ scalar_value (scalar, caf_token)));
}
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 97cf7f8cb41f..2dad79aa9993 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -149,7 +149,7 @@ void gfc_set_descriptor_with_shape (stmtblock_t *, tree,
tree,
gfc_expr *, locus *);
tree gfc_get_scalar_to_descriptor_type (tree scalar, symbol_attribute attr);
void gfc_set_descriptor_from_scalar (stmtblock_t *, tree, tree,
-symbol_attribute *);
+symbol_attribute *, tree = NULL_TREE);
void gfc_copy_sequence_descriptor (stmtblock_t &, tree, tree, bool);
void gfc_set_gfc_from_cfi (stmtblock_t *, stmtblock_t *, tree, tree, tree,
gfc_symbol *, bool, bool, bool);
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 39bd7178c3c0..13a1ec1e8fe3 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -883,14 +883,20 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
gfc_symbol *fsym,
/* Now set the data field. */
ctree = gfc_
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Factorisation gfc_conv_shift_descriptor
https://gcc.gnu.org/g:b253d45bf123a85b56a823c07136d9d2bde8078d
commit b253d45bf123a85b56a823c07136d9d2bde8078d
Author: Mikael Morin
Date: Thu Feb 6 17:16:13 2025 +0100
Factorisation gfc_conv_shift_descriptor
Correction compil'
Correction régression allocated_4.f90
Factorisation gfc_conv_shift_descriptor.
Correction régression allocated_4.f90
Modifications mineures
Correction régression bound_10.f90
Correction régression alloc_comp_constructor_1.f90
Correction régression realloc_on_assign_10
Revert "Correction régression realloc_on_assign_10"
This reverts commit 007ca869933eb74b76398200ef0237219ba01cd8.
Correction régression realloc_on_assign_11.f90
Diff:
---
gcc/fortran/trans-array.cc | 165 ++---
gcc/fortran/trans-expr.cc | 15 -
2 files changed, 94 insertions(+), 86 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index c09b9bdab155..a33422efa55f 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -1476,35 +1476,43 @@ gfc_build_null_descriptor (tree type)
specified. This also updates ubound and offset accordingly. */
static void
-conv_shift_descriptor_lbound (stmtblock_t* block, tree desc, int dim,
- tree new_lbound, tree offset)
+conv_shift_descriptor_lbound (stmtblock_t* block, tree from_desc, tree
to_desc, int dim,
+ tree new_lbound, tree offset, bool zero_based)
{
- tree ubound, lbound, stride;
- tree diff, offs_diff;
-
new_lbound = fold_convert (gfc_array_index_type, new_lbound);
+ new_lbound = gfc_evaluate_now (new_lbound, block);
- 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]);
+ tree lbound = gfc_conv_descriptor_lbound_get (from_desc, gfc_rank_cst[dim]);
+ tree ubound = gfc_conv_descriptor_ubound_get (from_desc, gfc_rank_cst[dim]);
+ tree stride = gfc_conv_descriptor_stride_get (from_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);
+ tree diff;
+ if (zero_based)
+diff = new_lbound;
+ else
+{
+ /* Get difference (new - old) by which to shift stuff. */
+ diff = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+ new_lbound, lbound);
+ diff = gfc_evaluate_now (diff, block);
+}
/* 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);
- tree tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
- offset, offs_diff);
- gfc_add_modify (block, offset, tmp);
+ tree tmp1 = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+ ubound, diff);
+ gfc_conv_descriptor_ubound_set (block, to_desc, gfc_rank_cst[dim], tmp1);
+ /* Set lbound to the value we want. */
+ gfc_conv_descriptor_lbound_set (block, to_desc, gfc_rank_cst[dim],
new_lbound);
- /* Finally set lbound to value we want. */
- gfc_conv_descriptor_lbound_set (block, desc, gfc_rank_cst[dim], new_lbound);
+ tree offs_diff = fold_build2_loc (input_location, MULT_EXPR,
gfc_array_index_type,
+ diff, stride);
+ tree tmp2 = fold_build2_loc (input_location, MINUS_EXPR,
gfc_array_index_type,
+ offset, offs_diff);
+ gfc_add_modify (block, offset, tmp2);
+
+ if (from_desc != to_desc)
+gfc_conv_descriptor_stride_set (block, to_desc, gfc_rank_cst[dim], stride);
}
@@ -1512,6 +1520,7 @@ class lb_info_base
{
public:
virtual tree lower_bound (stmtblock_t *block, int dim) const = 0;
+ virtual bool zero_based_src () const { return false; }
};
@@ -1572,21 +1581,64 @@ public:
static void
-conv_shift_descriptor (stmtblock_t *block, tree desc, int rank,
+conv_shift_descriptor (stmtblock_t *block, tree src, tree dest, int rank,
const lb_info_base &info)
{
- tree tmp = gfc_conv_descriptor_offset_get (desc);
- tree offset_var = gfc_create_var (TREE_TYPE (tmp), "offset");
- gfc_add_modify (block, offset_var, tmp);
+ if (src != dest)
+{
+ tree tmp = gfc_conv_descriptor_data_get (src);
+ gfc_conv_descriptor_data_set (block, dest, tmp);
+}
+
+ tree offset_va
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Factorisation set_descriptor_dimension
https://gcc.gnu.org/g:89ff0d96ef8c7a0b33a8efc46ab32c7b2ee4df78
commit 89ff0d96ef8c7a0b33a8efc46ab32c7b2ee4df78
Author: Mikael Morin
Date: Fri Feb 7 12:07:36 2025 +0100
Factorisation set_descriptor_dimension
Correction compil'
Diff:
---
gcc/fortran/trans-array.cc | 82 +-
1 file changed, 44 insertions(+), 38 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index a33422efa55f..4d2d0378bea7 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -1472,6 +1472,41 @@ gfc_build_null_descriptor (tree type)
}
+static tree
+set_descriptor_dimension (stmtblock_t *block, tree desc, int dim,
+ tree lbound, tree ubound, tree stride, tree *offset)
+{
+ /* Set bounds in descriptor. */
+ lbound = fold_convert (gfc_array_index_type, lbound);
+ lbound = gfc_evaluate_now (lbound, block);
+ gfc_conv_descriptor_lbound_set (block, desc,
+ gfc_rank_cst[dim], lbound);
+
+ ubound = fold_convert (gfc_array_index_type, ubound);
+ ubound = gfc_evaluate_now (ubound, block);
+ gfc_conv_descriptor_ubound_set (block, desc,
+ gfc_rank_cst[dim], ubound);
+
+ /* Set stride. */
+ stride = fold_convert (gfc_array_index_type, stride);
+ stride = gfc_evaluate_now (stride, block);
+ gfc_conv_descriptor_stride_set (block, desc,
+ gfc_rank_cst[dim], stride);
+
+ /* Update offset. */
+ tree tmp = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, lbound, stride);
+ *offset = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type, *offset, tmp);
+
+ /* Return stride for next dimension. */
+ tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
+ stride = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, stride, tmp);
+ return stride;
+}
+
+
/* Modify a descriptor such that the lbound of a given dimension is the value
specified. This also updates ubound and offset accordingly. */
@@ -1822,9 +1857,9 @@ gfc_conv_remap_descriptor (stmtblock_t *block, tree dest,
tree src,
/* Copy offset but adjust it such that it would correspond
to a lbound of zero. */
+ tree offset;
if (src_rank == -1)
-gfc_conv_descriptor_offset_set (block, dest,
- gfc_index_zero_node);
+offset = gfc_index_zero_node;
else
{
tree offs = gfc_conv_descriptor_offset_get (src);
@@ -1840,7 +1875,7 @@ gfc_conv_remap_descriptor (stmtblock_t *block, tree dest,
tree src,
offs = fold_build2_loc (input_location, PLUS_EXPR,
gfc_array_index_type, offs, tmp);
}
- gfc_conv_descriptor_offset_set (block, dest, offs);
+ offset = offs;
}
/* Set the bounds as declared for the LHS and calculate strides as
well as another offset update accordingly. */
@@ -1856,46 +1891,17 @@ gfc_conv_remap_descriptor (stmtblock_t *block, tree
dest, tree src,
/* Convert declared bounds. */
gfc_init_se (&lower_se, NULL);
gfc_init_se (&upper_se, NULL);
- gfc_conv_expr (&lower_se, as.lower[dim]);
- gfc_conv_expr (&upper_se, as.upper[dim]);
+ gfc_conv_expr_val (&lower_se, as.lower[dim]);
+ gfc_conv_expr_val (&upper_se, as.upper[dim]);
gfc_add_block_to_block (block, &lower_se.pre);
gfc_add_block_to_block (block, &upper_se.pre);
- tree lbound = fold_convert (gfc_array_index_type, lower_se.expr);
- tree ubound = fold_convert (gfc_array_index_type, upper_se.expr);
-
- lbound = gfc_evaluate_now (lbound, block);
- ubound = gfc_evaluate_now (ubound, block);
-
- gfc_add_block_to_block (block, &lower_se.post);
- gfc_add_block_to_block (block, &upper_se.post);
-
- /* Set bounds in descriptor. */
- gfc_conv_descriptor_lbound_set (block, dest,
- gfc_rank_cst[dim], lbound);
- gfc_conv_descriptor_ubound_set (block, dest,
- gfc_rank_cst[dim], ubound);
-
- /* Set stride. */
- stride = gfc_evaluate_now (stride, block);
- gfc_conv_descriptor_stride_set (block, dest,
- gfc_rank_cst[dim], stride);
-
- /* Update offset. */
- tree offs = gfc_conv_descriptor_offset_get (dest);
- tmp = fold_build2_loc (input_location, MULT_EXPR,
-gfc_array_index_type, lbound, stride);
- offs = fold_build2_loc (input_location, MINUS_EXPR,
- gfc_array_index_type, offs, tmp);
- offs = gfc_evaluate_now (offs, block);
- gfc_conv_descriptor_offset_set (block, dest, offs);
-
- /* Update stride. */
- tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
- stride = fold_build2_loc (input_location, MULT_EX
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Correction régression realloc_on_assign_12.f90
https://gcc.gnu.org/g:ad8f09da81f5e1bbcda2cac32db41d959ecf027a commit ad8f09da81f5e1bbcda2cac32db41d959ecf027a Author: Mikael Morin Date: Sat Feb 8 22:23:41 2025 +0100 Correction régression realloc_on_assign_12.f90 Diff: --- gcc/fortran/trans-array.cc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc index 197f564146c3..e60204ae3ee2 100644 --- a/gcc/fortran/trans-array.cc +++ b/gcc/fortran/trans-array.cc @@ -1556,7 +1556,7 @@ conv_shift_descriptor_lbound (stmtblock_t* block, tree from_desc, tree to_desc, ubound, diff); set_bounds_update_offset (block, to_desc, dim, new_lbound, tmp1, stride, diff, - offset, nullptr, from_desc != to_desc); + offset, nullptr, from_desc == to_desc); }
