diff --git a/clang/include/clang/Driver/Options.td b/clang/include/clang/Driver/Options.td index 88862ae9edb29..5dad9dc120f52 100644 --- a/clang/include/clang/Driver/Options.td +++ b/clang/include/clang/Driver/Options.td @@ -3463,6 +3463,9 @@ defm diagnostics_show_line_numbers : BoolFOption<"diagnostics-show-line-numbers" NegFlag, PosFlag>; +def fno_realloc_lhs : Flag<["-"], "fno-realloc-lhs">, Group, + HelpText<"An allocatable left-hand side of an intrinsic assignment is assumed to be allocated and match the shape/type of the right-hand side">, + Visibility<[FlangOption, FC1Option]>; def fno_stack_protector : Flag<["-"], "fno-stack-protector">, Group, HelpText<"Disable the use of stack protectors">; def fno_strict_aliasing : Flag<["-"], "fno-strict-aliasing">, Group, @@ -4296,6 +4299,9 @@ defm stack_size_section : BoolFOption<"stack-size-section", PosFlag, NegFlag>; +def frealloc_lhs : Flag<["-"], "frealloc-lhs">, Group, + Visibility<[FlangOption, FC1Option]>, + HelpText<"If an allocatable left-hand side of an intrinsic assignment is unallocated or its shape/type does not match the right-hand side, then it is automatically (re)allocated">; def fstack_usage : Flag<["-"], "fstack-usage">, Group, HelpText<"Emit .su file containing information on function stack sizes">; def stack_usage_file : Separate<["-"], "stack-usage-file">, @@ -6775,7 +6781,6 @@ defm real_4_real_8 : BooleanFFlag<"real-4-real-8">, Group; defm real_8_real_10 : BooleanFFlag<"real-8-real-10">, Group; defm real_8_real_16 : BooleanFFlag<"real-8-real-16">, Group; defm real_8_real_4 : BooleanFFlag<"real-8-real-4">, Group; -defm realloc_lhs : BooleanFFlag<"realloc-lhs">, Group; defm recursive : BooleanFFlag<"recursive">, Group; defm repack_arrays : BooleanFFlag<"repack-arrays">, Group; defm second_underscore : BooleanFFlag<"second-underscore">, Group; diff --git a/clang/lib/Driver/ToolChains/Flang.cpp b/clang/lib/Driver/ToolChains/Flang.cpp index c98fdbd157bac..8cffa20c4a2d3 100644 --- a/clang/lib/Driver/ToolChains/Flang.cpp +++ b/clang/lib/Driver/ToolChains/Flang.cpp @@ -55,7 +55,9 @@ void Flang::addFortranDialectOptions(const ArgList &Args, options::OPT_fdefault_double_8, options::OPT_flarge_sizes, options::OPT_fno_automatic, - options::OPT_fhermetic_module_files}); + options::OPT_fhermetic_module_files, + options::OPT_frealloc_lhs, + options::OPT_fno_realloc_lhs}); } void Flang::addPreprocessingOptions(const ArgList &Args, diff --git a/flang/include/flang/Lower/LoweringOptions.def b/flang/include/flang/Lower/LoweringOptions.def index 0b22e54b648e9..5a6debfdffe03 100644 --- a/flang/include/flang/Lower/LoweringOptions.def +++ b/flang/include/flang/Lower/LoweringOptions.def @@ -38,5 +38,11 @@ ENUM_LOWERINGOPT(Underscoring, unsigned, 1, 1) /// (i.e. wraps around as two's complement). Off by default. ENUM_LOWERINGOPT(IntegerWrapAround, unsigned, 1, 0) +/// If true (default), follow Fortran 2003 rules for (re)allocating +/// the allocatable on the left side of the intrinsic assignment, +/// if LHS and RHS have mismatching shapes/types. +/// If false, assume that the shapes/types/allocation-status match. +ENUM_LOWERINGOPT(ReallocateLHS, unsigned, 1, 1) + #undef LOWERINGOPT #undef ENUM_LOWERINGOPT diff --git a/flang/lib/Frontend/CompilerInvocation.cpp b/flang/lib/Frontend/CompilerInvocation.cpp index 648b88e84051c..6ef4ee8721ee4 100644 --- a/flang/lib/Frontend/CompilerInvocation.cpp +++ b/flang/lib/Frontend/CompilerInvocation.cpp @@ -1378,6 +1378,11 @@ bool CompilerInvocation::createFromArgs( invoc.getDiagnosticOpts().Remarks.push_back(a->getValue()); } + // -frealloc-lhs is the default. + if (!args.hasFlag(clang::driver::options::OPT_frealloc_lhs, + clang::driver::options::OPT_fno_realloc_lhs, true)) + invoc.loweringOpts.setReallocateLHS(false); + success &= parseFrontendArgs(invoc.getFrontendOpts(), args, diags); parseTargetArgs(invoc.getTargetOpts(), args); parsePreprocessorArgs(invoc.getPreprocessorOpts(), args); diff --git a/flang/lib/Lower/Bridge.cpp b/flang/lib/Lower/Bridge.cpp index de2b941b688be..0650433dbaf39 100644 --- a/flang/lib/Lower/Bridge.cpp +++ b/flang/lib/Lower/Bridge.cpp @@ -4461,7 +4461,8 @@ class FirConverter : public Fortran::lower::AbstractConverter { // lowered. const bool isWholeAllocatableAssignment = !userDefinedAssignment && !isInsideHlfirWhere() && - Fortran::lower::isWholeAllocatable(assign.lhs); + Fortran::lower::isWholeAllocatable(assign.lhs) && + bridge.getLoweringOptions().getReallocateLHS(); const bool isUserDefAssignToPointerOrAllocatable = userDefinedAssignment && firstDummyIsPointerOrAllocatable(*userDefinedAssignment); diff --git a/flang/test/Driver/frealloc-lhs.f90 b/flang/test/Driver/frealloc-lhs.f90 new file mode 100644 index 0000000000000..b82b1565957aa --- /dev/null +++ b/flang/test/Driver/frealloc-lhs.f90 @@ -0,0 +1,11 @@ +! Check that the driver passes through -f[no-]realloc-lhs: +! RUN: %flang -### -S -frealloc-lhs %s -o - 2>&1 | FileCheck %s --check-prefix=ON +! RUN: %flang -### -S -fno-realloc-lhs %s -o - 2>&1 | FileCheck %s --check-prefix=OFF + +! Check that the compiler accepts -f[no-]realloc-lhs: +! RUN: %flang_fc1 -emit-hlfir -frealloc-lhs %s -o - +! RUN: %flang_fc1 -emit-hlfir -fno-realloc-lhs %s -o - + +! ON: "-fc1"{{.*}}"-frealloc-lhs" + +! OFF: "-fc1"{{.*}}"-fno-realloc-lhs" diff --git a/flang/test/Lower/reallocate-lhs.f90 b/flang/test/Lower/reallocate-lhs.f90 new file mode 100644 index 0000000000000..82a4edab787c7 --- /dev/null +++ b/flang/test/Lower/reallocate-lhs.f90 @@ -0,0 +1,32 @@ +! RUN: bbc %s -o - -emit-hlfir | FileCheck %s --check-prefixes=ALL,REALLOCLHS +! RUN: bbc %s -o - -emit-hlfir -frealloc-lhs | FileCheck %s --check-prefixes=ALL,REALLOCLHS +! RUN: bbc %s -o - -emit-hlfir -frealloc-lhs=false | FileCheck %s --check-prefixes=ALL,NOREALLOCLHS +! RUN: %flang_fc1 %s -o - -emit-hlfir | FileCheck %s --check-prefixes=ALL,REALLOCLHS +! RUN: %flang_fc1 %s -o - -emit-hlfir -frealloc-lhs | FileCheck %s --check-prefixes=ALL,REALLOCLHS +! RUN: %flang_fc1 %s -o - -emit-hlfir -fno-realloc-lhs | FileCheck %s --check-prefixes=ALL,NOREALLOCLHS + +subroutine test1(a, b) + integer, allocatable :: a(:), b(:) + a = b + 1 +end + +! ALL-LABEL: func.func @_QPtest1( +! ALL: %[[VAL_3:.*]]:2 = hlfir.declare{{.*}}{fortran_attrs = #fir.var_attrs, uniq_name = "_QFtest1Ea"} +! REALLOCLHS: hlfir.assign %{{.*}} to %[[VAL_3]]#0 realloc : !hlfir.expr, !fir.ref>>> + +! NOREALLOCLHS: %[[VAL_20:.*]] = fir.load %[[VAL_3]]#0 : !fir.ref>>> +! NOREALLOCLHS: hlfir.assign %{{.*}} to %[[VAL_20]] : !hlfir.expr, !fir.box>> + +subroutine test2(a, b) + character(len=*), allocatable :: a(:) + character(len=*) :: b(:) + a = b +end subroutine test2 + +! ALL-LABEL: func.func @_QPtest2( +! ALL: %[[VAL_3:.*]]:2 = hlfir.declare{{.*}}{fortran_attrs = #fir.var_attrs, uniq_name = "_QFtest2Ea"} +! REALLOCLHS: hlfir.assign %{{.*}} to %[[VAL_3]]#0 realloc keep_lhs_len : !fir.box>>, !fir.ref>>>> + +! NOREALLOCLHS: %[[VAL_7:.*]] = fir.load %[[VAL_3]]#0 : !fir.ref>>>> +! NOREALLOCLHS: hlfir.assign %{{.*}} to %[[VAL_7]] : !fir.box>>, !fir.box>>> + diff --git a/flang/tools/bbc/bbc.cpp b/flang/tools/bbc/bbc.cpp index 02ecd6a75ef7a..7efc460be8679 100644 --- a/flang/tools/bbc/bbc.cpp +++ b/flang/tools/bbc/bbc.cpp @@ -234,6 +234,12 @@ static llvm::cl::opt integerWrapAround( llvm::cl::desc("Treat signed integer overflow as two's complement"), llvm::cl::init(false)); +static llvm::cl::opt + reallocateLHS("frealloc-lhs", + llvm::cl::desc("Follow Fortran 2003 rules for (re)allocating " + "the LHS of the intrinsic assignment"), + llvm::cl::init(true)); + #define FLANG_EXCLUDE_CODEGEN #include "flang/Optimizer/Passes/CommandLineOpts.h" #include "flang/Optimizer/Passes/Pipelines.h" @@ -375,6 +381,7 @@ static llvm::LogicalResult convertFortranSourceToMLIR( loweringOptions.setNoPPCNativeVecElemOrder(enableNoPPCNativeVecElemOrder); loweringOptions.setLowerToHighLevelFIR(useHLFIR || emitHLFIR); loweringOptions.setIntegerWrapAround(integerWrapAround); + loweringOptions.setReallocateLHS(reallocateLHS); std::vector envDefaults = {}; Fortran::frontend::TargetOptions targetOpts; Fortran::frontend::CodeGenOptions cgOpts;