From 900adb2b785cc961c70e9498fdcd43d567635f55 Mon Sep 17 00:00:00 2001 From: Yao Liu Date: Tue, 1 Jun 2021 17:38:35 +0800 Subject: [PATCH] Fix 2 errors of entry statement processing MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * Compiling error when return type of entry is complex/pointer. Main cause of this problem is that flang2 checks whether the return variable is used as a dummy argument only at the first entry point, so this patch fixes the problem by going through all entry points. In addition, because flang1 changes the storage class of a pointer dummy argument from `SC_DUMMY` to `SC_BASED`, this patch modifies the check for dummy argument in flang2 accordingly. * Inconsistent with Fortran 2008 standard, ISO/IEC JTC 1/SC 22/WG 5/N1830 section-12.6.2.6 (If the characteristics of the result of the function named in the ENTRY statement are the same as the characteristics of the result of the function named in the FUNCTION statement, their result variables identify the same variable, although their names need not be the same). Flang1 currently doesn’t handle functions that are converted to subroutines as the standard specifies, and all entry points simply use the same symbol for the return variable in the field `FVAL`. This patch takes into account all the symbols associated with the return variable, and performs symbol replacement in both the dummy argument list and the AST table. --- test/f90_correct/inc/en03.mk | 28 ++++++++ test/f90_correct/inc/en04.mk | 23 +++++++ test/f90_correct/lit/en03.sh | 9 +++ test/f90_correct/lit/en04.sh | 9 +++ test/f90_correct/src/en03.f90 | 59 +++++++++++++++++ test/f90_correct/src/en04.f90 | 91 ++++++++++++++++++++++++++ tools/flang1/flang1exe/lowersym.c | 104 +++++++++++++++++++++++++++++- tools/flang1/flang1exe/semfin.c | 5 +- tools/flang2/flang2exe/cgmain.cpp | 13 +++- tools/flang2/flang2exe/ll_ftn.cpp | 19 ++++-- 10 files changed, 351 insertions(+), 9 deletions(-) create mode 100644 test/f90_correct/inc/en03.mk create mode 100644 test/f90_correct/inc/en04.mk create mode 100644 test/f90_correct/lit/en03.sh create mode 100644 test/f90_correct/lit/en04.sh create mode 100644 test/f90_correct/src/en03.f90 create mode 100644 test/f90_correct/src/en04.f90 diff --git a/test/f90_correct/inc/en03.mk b/test/f90_correct/inc/en03.mk new file mode 100644 index 00000000000..11639b0ad39 --- /dev/null +++ b/test/f90_correct/inc/en03.mk @@ -0,0 +1,28 @@ +# +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +# + +########## Make rule for test en03 ######## + + +en03: run + + +build: $(SRC)/en03.f90 + -$(RM) en03.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/en03.f90 -o en03.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) en03.$(OBJX) check.$(OBJX) $(LIBS) -o en03.$(EXESUFFIX) + + +run: + @echo ------------------------------------ executing test en03 + en03.$(EXESUFFIX) + +verify: ; + +en03.run: run + diff --git a/test/f90_correct/inc/en04.mk b/test/f90_correct/inc/en04.mk new file mode 100644 index 00000000000..1f3026fbfb5 --- /dev/null +++ b/test/f90_correct/inc/en04.mk @@ -0,0 +1,23 @@ +# +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +# + +$(TEST): run + + +build: $(SRC)/$(TEST).f90 + -$(RM) $(TEST).$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/$(TEST).f90 -o $(TEST).$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) $(TEST).$(OBJX) check.$(OBJX) $(LIBS) -o $(TEST).$(EXESUFFIX) + + +run: + @echo ------------------------------------ executing test $(TEST) + $(TEST).$(EXESUFFIX) + +verify: ; + diff --git a/test/f90_correct/lit/en03.sh b/test/f90_correct/lit/en03.sh new file mode 100644 index 00000000000..3880a96ea63 --- /dev/null +++ b/test/f90_correct/lit/en03.sh @@ -0,0 +1,9 @@ +# +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f90_correct/lit/en04.sh b/test/f90_correct/lit/en04.sh new file mode 100644 index 00000000000..3880a96ea63 --- /dev/null +++ b/test/f90_correct/lit/en04.sh @@ -0,0 +1,9 @@ +# +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f90_correct/src/en03.f90 b/test/f90_correct/src/en03.f90 new file mode 100644 index 00000000000..390d808a524 --- /dev/null +++ b/test/f90_correct/src/en03.f90 @@ -0,0 +1,59 @@ +! +! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +! See https://llvm.org/LICENSE.txt for license information. +! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +! +! Test entry for cases: +! 1) Function return complex, entry return integer +! 2) All entries return pointer + +function f1() + complex :: f1 + integer :: e1 + f1 = (1, 1) + return +entry e1() + e1 = 2 + return +end function + +function f2() + integer, pointer :: f2, e2 + allocate(f2) + f2 = 3 + return +entry e2() + allocate(e2) + e2 = 4 + return +end function + +program test + interface + function f1() + complex :: f1 + end function + function e1() + integer :: e1 + end function + function f2() + integer, pointer :: f2 + end function + function e2() + integer, pointer :: e2 + end function + end interface + + integer, parameter :: n = 4 + integer :: rslts(n), expect(n) + + rslts = 0 + expect = 1 + + if(f1() .eq. (1, 1)) rslts(1) = 1 + if(e1() .eq. 2) rslts(2) = 1 + if(f2() .eq. 3) rslts(3) = 1 + if(e2() .eq. 4) rslts(4) = 1 + + call check(rslts, expect, n) +end program diff --git a/test/f90_correct/src/en04.f90 b/test/f90_correct/src/en04.f90 new file mode 100644 index 00000000000..3caf7df8506 --- /dev/null +++ b/test/f90_correct/src/en04.f90 @@ -0,0 +1,91 @@ +! +! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +! See https://llvm.org/LICENSE.txt for license information. +! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +! +! Test for all ENTRY points with the same return type identify the same variable + +function f1 () + integer :: f1, e1 +entry e1 () + e1 = 1 +end function + +function f2 () + complex :: f2, e2 +entry e2 () + e2 = (2, 2) +end function + +function f3 () + integer, pointer :: f3, e3 +entry e3 () + allocate(e3) + e3 = 3 +end function + +function f4 () + integer, dimension(4) :: f4, e4 +entry e4 () + e4 = (/1,2,3,4/) +end function + +function f5 () + integer, dimension(:), pointer :: f5, e5 +entry e5 () + allocate(e5(5)) + e5 = (/1,2,3,4,5/) +end function + +program test + interface + function f1 () + integer :: f1 + end function + function e1 () + integer :: e1 + end function + function f2 () + complex :: f2 + end function + function e2 () + complex :: e2 + end function + function f3 () + integer, pointer :: f3 + end function + function e3 () + integer, pointer :: e3 + end function + function f4 () + integer, dimension(4) :: f4 + end function + function e4 () + integer, dimension(4) :: e4 + end function + function f5 () + integer, dimension(:), pointer :: f5 + end function + function e5 () + integer, dimension(:), pointer :: e5 + end function + end interface + + integer, parameter :: n = 10 + integer :: rslts(n), expect(n) + + rslts = 0 + expect = 1 + if (f1() == 1) rslts(1) = 1 + if (e1() == 1) rslts(2) = 1 + if (f2() == (2, 2)) rslts(3) = 1 + if (e2() == (2, 2)) rslts(4) = 1 + if (f3() == 3) rslts(5) = 1 + if (e3() == 3) rslts(6) = 1 + if (all(f4() == (/1,2,3,4/))) rslts(7) = 1 + if (all(e4() == (/1,2,3,4/))) rslts(8) = 1 + if (all(f5() == (/1,2,3,4,5/))) rslts(9) = 1 + if (all(e5() == (/1,2,3,4,5/))) rslts(10) = 1 + + call check(rslts, expect, n) +end program diff --git a/tools/flang1/flang1exe/lowersym.c b/tools/flang1/flang1exe/lowersym.c index 17054470bb0..0a2c07bb21c 100644 --- a/tools/flang1/flang1exe/lowersym.c +++ b/tools/flang1/flang1exe/lowersym.c @@ -1221,6 +1221,101 @@ lower_pointer_init(void) } } /* lower_pointer_init */ +/* When prepend_func_result_as_first_arg(semfin.c) has been called for an + * entry, the FVAL symbol and its descriptor symbol if exist are referred in + * the entry's dummy arguments. + * When we are going to identify all result variables of same dtype from + * different entry points with a single symbol, here we traverse all the dummy + * arguments, and replace the FVAL symbol and its descriptor symbol with this + * single symbol and corresponding descriptor symbol. + */ +static void +replace_fval_in_params(SPTR entry, SPTR entrysame) +{ + SPTR fval, fvalsame, newdsc, newdscsame, newarg, newargsame; + int params, narg, i; + + fval = FVALG(entry); + fvalsame = FVALG(entrysame); + newdsc = NEWDSCG(fval); + newarg = NEWARGG(fval); + newdscsame = NEWDSCG(fvalsame); + newargsame = NEWARGG(fvalsame); + params = DPDSCG(entry); + narg = PARAMCTG(entry); + for (i = 0; i < narg; i++) { + int arg = aux.dpdsc_base[params + i]; + if (arg != 0 && arg == newarg) { + aux.dpdsc_base[params + i] = newargsame; + continue; + } + if (arg != 0 && arg == newdsc) { + aux.dpdsc_base[params + i] = newdscsame; + continue; + } + } +} + +/* replace the symbol used in the ast of type A_ID taking advantage of the hash + * in the AST table + */ +static void +replace_sptr_in_ast(SPTR sptr) +{ + SPTR newsptr; + int ast; + + if (sptr <= NOSYM) { + return; + } + newsptr = LOWER_SYMBOL_REPLACE(sptr); + if (newsptr <= NOSYM) { + return; + } + ast = mk_id(sptr); + A_SPTRP(ast, newsptr); +} + +static inline void +add_replace_map(SPTR sptr, SPTR newsptr) +{ + if (sptr <= NOSYM || newsptr <= NOSYM) { + return; + } + LOWER_SYMBOL_REPLACE(sptr) = newsptr; +} + +/* replace the fval symbol and associated symbols when the fval symbol is + * pointer or array + */ +static void +replace_fval_in_ast(SPTR fval, SPTR fvalsame) +{ + SPTR var, var_same; + + replace_sptr_in_ast(fval); + + var = MIDNUMG(fval); + var_same = MIDNUMG(fvalsame); + add_replace_map(var, var_same); + replace_sptr_in_ast(var); + + var = PTROFFG(fval); + var_same = PTROFFG(fvalsame); + add_replace_map(var, var_same); + replace_sptr_in_ast(var); + + var = DESCRG(fval); + var_same = DESCRG(fvalsame); + add_replace_map(var, var_same); + replace_sptr_in_ast(var); + + var = SDSCG(fval); + var_same = SDSCG(fvalsame); + add_replace_map(var, var_same); + replace_sptr_in_ast(var); +} + extern int pghpf_type_sptr; extern int pghpf_local_mode_sptr; @@ -1228,6 +1323,8 @@ void lower_init_sym(void) { int sym, dtype; + LOGICAL from_func; + lowersym.sc = SC_LOCAL; lowersym.parallel_depth = 0; lowersym.task_depth = 0; @@ -1353,9 +1450,10 @@ lower_init_sym(void) stack_size = 100; NEW(stack, int, stack_size); + from_func = gbl.rutype == RU_SUBR && gbl.entries > NOSYM && FVALG(gbl.entries); /* look for ENTRY points; make all ENTRY points with the same * return type use the same FVAL symbol */ - if (gbl.rutype == RU_FUNC) { + if (from_func || gbl.rutype == RU_FUNC) { int ent, esame; for (ent = gbl.entries; ent > NOSYM; ent = SYMLKG(ent)) { for (esame = gbl.entries; esame != ent; esame = SYMLKG(esame)) { @@ -1363,11 +1461,13 @@ lower_init_sym(void) fval = FVALG(ent); fvalsame = FVALG(esame); if (fval && fvalsame && fval != fvalsame && - DTYPEG(fval) == DTYPEG(fvalsame)) { + same_dtype(DTYPEG(fval), DTYPEG(fvalsame))) { /* esame is the earlier entry point, make ent use the * FVAL of esame */ LOWER_SYMBOL_REPLACE(fval) = fvalsame; + replace_fval_in_params(ent, esame); FVALP(ent, fvalsame); + replace_fval_in_ast(fval, fvalsame); break; /* leave inner loop */ } } diff --git a/tools/flang1/flang1exe/semfin.c b/tools/flang1/flang1exe/semfin.c index ebf119cd40e..1a8008d3fe7 100644 --- a/tools/flang1/flang1exe/semfin.c +++ b/tools/flang1/flang1exe/semfin.c @@ -467,10 +467,13 @@ semfin(void) error(45, 3, gbl.lineno, SYMNAME(sptr), SYMNAME(gbl.entries)); pointer_check: STYPEP(FVALG(sptr), ST_VAR); - if (POINTERG(sptr) || ALLOCATTRG(FVALG(sptr))) { + if (POINTERG(FVALG(sptr)) || ALLOCATTRG(FVALG(sptr))) { /* We convert a pointer-valued function into a subroutine whose * first dummy argument is the result now, really late in * semantic analysis. + * Check the attributes of fval instead of the attributes of entry, + * because only the first entry can get all attributes defined by + * fval through copy_type_to_entry(semant.c). */ prepend_func_result_as_first_arg(sptr); gbl.rutype = RU_SUBR; diff --git a/tools/flang2/flang2exe/cgmain.cpp b/tools/flang2/flang2exe/cgmain.cpp index 3c08aa2674d..1e221fdda5e 100644 --- a/tools/flang2/flang2exe/cgmain.cpp +++ b/tools/flang2/flang2exe/cgmain.cpp @@ -2844,6 +2844,8 @@ write_instructions(LL_Module *module) bool forceLabel = true; bool dbg_line_op_written; bool routine_label_written; + bool ret_scalar; + int entry; DBGTRACEIN("") @@ -3131,10 +3133,17 @@ write_instructions(LL_Module *module) /* -finstrument-functions */ write_profile_exit(); } + ret_scalar = false; + for (entry = gbl.currsub; entry > NOSYM; entry = SYMLKG(entry)) { + int fval = FVALG(entry); + if(fval && SCG(fval) != SC_DUMMY && SCG(fval) != SC_BASED) { + ret_scalar = true; + break; + } + } /* This is a way to return value for multiple entries with return type * pass as argument to the master/common routine */ - if (has_multiple_entries(gbl.currsub) && FVALG(gbl.currsub) && - SCG(FVALG(gbl.currsub)) != SC_DUMMY) { + if (has_multiple_entries(gbl.currsub) && ret_scalar) { /* (1) bitcast result(second argument) from i8* to type of p->ll_type * (2) store result into (1) * (3) return void. diff --git a/tools/flang2/flang2exe/ll_ftn.cpp b/tools/flang2/flang2exe/ll_ftn.cpp index 5598bdab8bf..f91a86b4ae3 100644 --- a/tools/flang2/flang2exe/ll_ftn.cpp +++ b/tools/flang2/flang2exe/ll_ftn.cpp @@ -904,6 +904,8 @@ get_entries_argnum(void) int fvaldt = 0; int found = 0; char name[100]; + bool ret_scalar; + int entry; if (SYMLKG(sptr) <= NOSYM) /* no Entry */ return 0; @@ -935,8 +937,16 @@ get_entries_argnum(void) aux.dpdsc_base[master_dpdsc] = opt; i = 1; + ret_scalar = false; + for (entry = gbl.currsub; entry > NOSYM ; entry = SYMLKG(entry)) { + int fval1 = FVALG(entry); + if(fval1 && SCG(fval1) != SC_DUMMY && SCG(fval1) != SC_BASED) { + ret_scalar = true; + break; + } + } /* Add second arg if the following is true */ - if (fval && SCG(fval) != SC_DUMMY) { + if (has_multiple_entries(gbl.currsub) && ret_scalar) { sprintf(name, "%s%d", "__master_entry_rslt", stb.stg_avail); opt = addnewsym(name); max_cnt++; @@ -1066,7 +1076,7 @@ write_dummy_as_local_in_entry(int sptr) } } - if (FVALG(sptr) && SCG(FVALG(sptr)) != SC_DUMMY) { + if (FVALG(sptr) && SCG(FVALG(sptr)) != SC_DUMMY && SCG(FVALG(sptr)) != SC_BASED) { DeclareSPtrAsLocal(FVALG(sptr), 1); } } @@ -1139,7 +1149,7 @@ print_entry_subroutine(LL_Module *module) } else { rettype = DT_NONE; } - if (fval && SCG(fval) != SC_DUMMY) { + if (fval && SCG(fval) != SC_DUMMY && SCG(fval) != SC_BASED) { /* Bitcast fval which is local variable to i8*. * We will pass this fval to master routine. */ @@ -1185,7 +1195,8 @@ print_entry_subroutine(LL_Module *module) write_type(dummy_type); print_space(1); print_tmp_name(tmp); - } else if (fval && SCG(fval) != SC_DUMMY && fval != FVALG(gbl.currsub)) { + } else if (fval && SCG(fval) != SC_DUMMY && SCG(fval) != SC_BASED && + fval != FVALG(gbl.currsub)) { TY_KIND ThisIsABug; // FIXME DTYPE ThisIsABug2; // FIXME /* If it is a dummy, it should already in the master dpdsc. */