diff --git a/clang/lib/CodeGen/CGStmtOpenMP.cpp b/clang/lib/CodeGen/CGStmtOpenMP.cpp index 344fa90253ec3d..0d693afc85d99c 100644 --- a/clang/lib/CodeGen/CGStmtOpenMP.cpp +++ b/clang/lib/CodeGen/CGStmtOpenMP.cpp @@ -3594,7 +3594,8 @@ void CodeGenFunction::EmitOMPForDirective(const OMPForDirective &S) { CGM.getOpenMPRuntime().getOMPBuilder(); llvm::OpenMPIRBuilder::InsertPointTy AllocaIP( AllocaInsertPt->getParent(), AllocaInsertPt->getIterator()); - OMPBuilder.createWorkshareLoop(Builder, CLI, AllocaIP, NeedsBarrier); + OMPBuilder.applyWorkshareLoop(Builder.getCurrentDebugLocation(), CLI, + AllocaIP, NeedsBarrier); return; } diff --git a/flang/.clang-tidy b/flang/.clang-tidy index be9a2b704edd0e..ee3a0ab2201bf3 100644 --- a/flang/.clang-tidy +++ b/flang/.clang-tidy @@ -1 +1,2 @@ -Checks: '-*,llvm-*,-llvm-include-order,misc-*,-misc-no-recursion,-misc-unused-parameters,-misc-non-private-member-variables-in-classes' +Checks: '-llvm-include-order,readability-braces-around-statements,-readability-identifier-naming,-clang-diagnostic-*' +InheritParentConfig: true diff --git a/flang/CMakeLists.txt b/flang/CMakeLists.txt index 009092247c001c..a83b24d59b1c9b 100644 --- a/flang/CMakeLists.txt +++ b/flang/CMakeLists.txt @@ -2,6 +2,8 @@ cmake_minimum_required(VERSION 3.13.4) set(CMAKE_BUILD_WITH_INSTALL_NAME_DIR ON) +option(FLANG_BUILD_NEW_DRIVER "Build the flang compiler driver" OFF) + # Flang requires C++17. set(CMAKE_CXX_STANDARD 17) set(CMAKE_CXX_STANDARD_REQUIRED TRUE) @@ -17,7 +19,13 @@ if (CMAKE_SOURCE_DIR STREQUAL CMAKE_BINARY_DIR AND NOT MSVC_IDE) `CMakeFiles'. Please delete them.") endif() -option(FLANG_ENABLE_WERROR "Fail and stop building flang if a warning is triggered." OFF) +if (MSVC) + set(_FLANG_ENABLE_WERROR_DEFAULT OFF) +else () + set(_FLANG_ENABLE_WERROR_DEFAULT "${LLVM_ENABLE_WERROR}") +endif() +option(FLANG_ENABLE_WERROR "Fail and stop building flang if a warning is triggered." + "${_FLANG_ENABLE_WERROR_DEFAULT}") # Check for a standalone build and configure as appropriate from # there. @@ -26,11 +34,6 @@ if (CMAKE_SOURCE_DIR STREQUAL CMAKE_CURRENT_SOURCE_DIR) project(Flang) set(FLANG_STANDALONE_BUILD ON) - # For in-tree builds, this variable is inherited from - # llvm-project/llvm/CMakeLists.txt. For out-of-tree builds, we need a - # separate definition. - option(FLANG_BUILD_NEW_DRIVER "Build the flang compiler driver" ON) - set(FLANG_BINARY_DIR ${CMAKE_CURRENT_BINARY_DIR}) if (NOT MSVC_IDE) set(LLVM_ENABLE_ASSERTIONS ${ENABLE_ASSERTIONS} @@ -39,7 +42,7 @@ if (CMAKE_SOURCE_DIR STREQUAL CMAKE_CURRENT_SOURCE_DIR) mark_as_advanced(LLVM_ENABLE_ASSERTIONS) endif() - # We need a pre-built/installed version of LLVM. + # We need a pre-built/installed version of LLVM and MLIR. find_package(LLVM REQUIRED HINTS "${LLVM_CMAKE_PATH}") # If the user specifies a relative path to LLVM_DIR, the calls to include # LLVM modules fail. Append the absolute path to LLVM_DIR instead. @@ -47,33 +50,23 @@ if (CMAKE_SOURCE_DIR STREQUAL CMAKE_CURRENT_SOURCE_DIR) list(APPEND CMAKE_MODULE_PATH ${LLVM_DIR_ABSOLUTE}) if(FLANG_BUILD_NEW_DRIVER) - # Users might specify a path to CLANG_DIR that's: - # * a full path, or - # * a path relative to the path of this script. - # Append the absolute path to CLANG_DIR so that find_package works in both - # cases. - get_filename_component( - CLANG_DIR_ABSOLUTE - ${CLANG_DIR} - REALPATH - ${CMAKE_CURRENT_SOURCE_DIR}) - list(APPEND CMAKE_MODULE_PATH ${CLANG_DIR_ABSOLUTE}) - # TODO: Remove when libclangDriver is lifted out of Clang - find_package(Clang REQUIRED PATHS "${CLANG_DIR_ABSOLUTE}" NO_DEFAULT_PATH) - if (NOT Clang_FOUND) - message(FATAL_ERROR "Failed to find Clang") - endif() + list(APPEND CMAKE_MODULE_PATH ${CLANG_DIR}) + find_package(Clang REQUIRED HINTS "${CLANG_DIR}") endif() + find_package(MLIR REQUIRED HINTS "${MLIR_CMAKE_PATH}") + list(APPEND CMAKE_MODULE_PATH ${MLIR_DIR}) + # If LLVM links to zlib we need the imported targets so we can too. if(LLVM_ENABLE_ZLIB) find_package(ZLIB REQUIRED) endif() option(LLVM_ENABLE_PEDANTIC "Compile with pedantic enabled." ON) - if(CMAKE_COMPILER_IS_GNUCXX) - set(USE_NO_MAYBE_UNINITIALIZED 1) - endif() + + # They are used as destination of target generators. + set(LLVM_RUNTIME_OUTPUT_INTDIR ${CMAKE_CURRENT_BINARY_DIR}/${CMAKE_CFG_INTDIR}/bin) + set(LLVM_LIBRARY_OUTPUT_INTDIR ${CMAKE_CURRENT_BINARY_DIR}/${CMAKE_CFG_INTDIR}/lib${LLVM_LIBDIR_SUFFIX}) include(CMakeParseArguments) include(AddLLVM) @@ -111,6 +104,8 @@ if (CMAKE_SOURCE_DIR STREQUAL CMAKE_CURRENT_SOURCE_DIR) # should not be suppressed). include_directories(SYSTEM ${LLVM_INCLUDE_DIRS}) add_definitions(${LLVM_DEFINITIONS}) + include_directories(SYSTEM ${MLIR_INCLUDE_DIRS}) + add_definitions(${MLIR_DEFINITIONS}) # LLVM's cmake configuration files currently sneak in a c++11 flag. # We look for it here and remove it from Flang's compile flags to @@ -189,12 +184,7 @@ else() ${LLVM_INCLUDE_TESTS}) set(FLANG_GTEST_AVAIL 1) - if(FLANG_STANDALONE_BUILD) - set(FLANG_BINARY_DIR ${CMAKE_BINARY_DIR}/tools/flang) - else() - set(FLANG_BINARY_DIR ${CMAKE_CURRENT_BINARY_DIR}) - endif() - + set(FLANG_BINARY_DIR ${CMAKE_BINARY_DIR}/tools/flang) set(BACKEND_PACKAGE_STRING "${PACKAGE_STRING}") set(MLIR_MAIN_SRC_DIR ${LLVM_MAIN_SRC_DIR}/../mlir/include ) # --src-root set(MLIR_INCLUDE_DIR ${LLVM_MAIN_SRC_DIR}/../mlir/include ) # --includedir @@ -203,8 +193,8 @@ else() include_directories(SYSTEM ${MLIR_INCLUDE_DIR}) include_directories(SYSTEM ${MLIR_TABLEGEN_OUTPUT_DIR}) endif() -set(FLANG_INTRINSIC_MODULES_DIR ${CMAKE_BINARY_DIR}/include/flang) set(FLANG_INCLUDE_DIR ${FLANG_BINARY_DIR}/include) +set(FLANG_INTRINSIC_MODULES_DIR ${CMAKE_BINARY_DIR}/include/flang) if(FLANG_BUILD_NEW_DRIVER) # TODO: Remove when libclangDriver is lifted out of Clang @@ -221,22 +211,36 @@ if(FLANG_BUILD_NEW_DRIVER) include_directories(SYSTEM ${CLANG_INCLUDE_DIR}) endif() -# tco tool and FIR lib output directories -if(FLANG_STANDALONE_BUILD) - set(LLVM_RUNTIME_OUTPUT_INTDIR ${CMAKE_BINARY_DIR}/bin) - set(LLVM_LIBRARY_OUTPUT_INTDIR ${CMAKE_BINARY_DIR}/lib) -endif() -# Always build tco tool -set(LLVM_BUILD_TOOLS ON) - include_directories(BEFORE ${FLANG_BINARY_DIR}/include ${FLANG_SOURCE_DIR}/include) +if(MLIR_SOURCE_DIR) + include_directories(BEFORE + ${FLANG_BINARY_DIR}/include + ${FLANG_SOURCE_DIR}/include + ${MLIR_BINARY_DIR}/include + ${MLIR_SOURCE_DIR}/include + ) + set(MLIR_MAIN_SRC_DIR ${MLIR_SOURCE_DIR}) + set(MLIR_INCLUDE_DIR ${MLIR_SOURCE_DIR}/include) +else() + include_directories(BEFORE + ${FLANG_BINARY_DIR}/include + ${FLANG_SOURCE_DIR}/include + ${MLIR_BINARY_DIR}/include + ) + set(MLIR_MAIN_SRC_DIR ${MLIR_BINARY_DIR}) + set(MLIR_INCLUDE_DIR ${MLIR_BINARY_DIR}/include) +endif() + +set(MLIR_TABLEGEN_EXE mlir-tblgen) + # Add Flang-centric modules to cmake path. list(APPEND CMAKE_MODULE_PATH "${CMAKE_CURRENT_SOURCE_DIR}/cmake/modules") include(AddFlang) + if (NOT DEFAULT_SYSROOT) set(DEFAULT_SYSROOT "" CACHE PATH "The to use for the system root for all compiler invocations (--sysroot=).") @@ -322,6 +326,9 @@ if (FLANG_ENABLE_WERROR) append("-Werror" CMAKE_C_FLAGS CMAKE_CXX_FLAGS) append("-Wno-error" CMAKE_REQUIRED_FLAGS) endif( LLVM_COMPILER_IS_GCC_COMPATIBLE ) + if (NOT LLVM_ENABLE_WERROR) + message(WARNING "FLANG_ENABLE_WERROR setting is different from LLVM_ENABLE_WERROR.") + endif() endif() # Builtin check_cxx_compiler_flag doesn't seem to work correctly @@ -358,6 +365,10 @@ if (LLVM_COMPILER_IS_GCC_COMPATIBLE) set(CMAKE_CXX_FLAGS_DEBUG "${CMAKE_CXX_FLAGS_DEBUG} -DDEBUGF18") set(CMAKE_CXX_FLAGS_MINSIZEREL "${CMAKE_CXX_FLAGS_MINSIZEREL} -DCHECK=\"(void)\"") + if (GCC) + set(CMAKE_CXX_FLAGS "${CMAKE_CXX_FLAGS} --gcc-toolchain=${GCC}") + endif() + # Building shared libraries is bad for performance with GCC by default # due to the need to preserve the right to override external entry points if (BUILD_SHARED_LIBS AND NOT (CMAKE_CXX_COMPILER_ID MATCHES "Clang")) @@ -403,12 +414,18 @@ endif() add_subdirectory(runtime) if (FLANG_INCLUDE_TESTS) + enable_testing() add_subdirectory(test) if (FLANG_GTEST_AVAIL) add_subdirectory(unittests) endif () endif() +option(FLANG_INCLUDE_TESTS + "Generate build targets for the Flang unit tests." + ON) +enable_testing() + option(FLANG_INCLUDE_DOCS "Generate build targets for the Flang docs." ${LLVM_INCLUDE_DOCS}) if (FLANG_INCLUDE_DOCS) @@ -447,7 +464,8 @@ if (NOT LLVM_INSTALL_TOOLCHAIN_ONLY) PATTERN "*.td" PATTERN "config.h" EXCLUDE PATTERN ".git" EXCLUDE - PATTERN "CMakeFiles" EXCLUDE) + PATTERN "CMakeFiles" EXCLUDE + PATTERN "*") install(DIRECTORY ${FLANG_INCLUDE_DIR}/flang DESTINATION include diff --git a/flang/README.md b/flang/README.md index 326505eb1ee3b5..a8a5080d3ab2cf 100644 --- a/flang/README.md +++ b/flang/README.md @@ -1,26 +1,13 @@ -# Flang -Flang is a ground-up implementation of a Fortran front end written in modern -C++. It started off as the f18 project (https://github.com/flang-compiler/f18) -with an aim to replace the previous flang project -(https://github.com/flang-compiler/flang) and address its various deficiencies. -F18 was subsequently accepted into the LLVM project and rechristened as Flang. +# FIR -## Getting Started +This file should not be upstreamed to llvm-project. -Read more about flang in the [docs directory](docs). -Start with the [compiler overview](docs/Overview.md). +## Monorepo now contains Flang! -To better understand Fortran as a language -and the specific grammar accepted by flang, -read [Fortran For C Programmers](docs/FortranForCProgrammers.md) -and -flang's specifications of the [Fortran grammar](docs/f2018-grammar.md) -and -the [OpenMP grammar](docs/OpenMP-4.5-grammar.md). +### In-tree build -Treatment of language extensions is covered -in [this document](docs/Extensions.md). +1. Get the stuff. To understand the compilers handling of intrinsics, see the [discussion of intrinsics](docs/Intrinsics.md). @@ -36,122 +23,105 @@ also review [how flang uses modern C++ features](docs/C++17.md). If you are interested in writing new documentation, follow [markdown style guide from LLVM](https://github.com/llvm/llvm-project/blob/main/llvm/docs/MarkdownQuickstartTemplate.md). -## Supported C++ compilers +2. Get "on" the right branches. -Flang is written in C++17. +``` + (cd f18-llvm-project ; git checkout fir-dev) +``` -The code has been compiled and tested with -GCC versions from 7.2.0 to 9.3.0. +3. (not needed!) + +4. Create a build space for cmake and make (or ninja) -The code has been compiled and tested with -clang version 7.0, 8.0, 9.0 and 10.0 -using either GNU's libstdc++ or LLVM's libc++. +``` + mkdir build + cd build + cmake ../f18-llvm-project/llvm -DCMAKE_BUILD_TYPE=RelWithDebInfo -DLLVM_TARGETS_TO_BUILD=X86 -DLLVM_ENABLE_PROJECTS="flang;mlir" -DCMAKE_CXX_STANDARD=17 -DLLVM_BUILD_TOOLS=On -DLLVM_INSTALL_UTILS=On +``` -The code has been compiled on -AArch64, x86\_64 and ppc64le servers -with CentOS7, Ubuntu18.04, Rhel, MacOs, Mojave, XCode and -Apple Clang version 10.0.1. +5. Build everything -The code does not compile with Windows and a compiler that does not have -support for C++17. +``` + make + make check-flang + make install +``` -## Building Flang out of tree -These instructions are for building Flang separately from LLVM; if you are -building Flang alongside LLVM then follow the standard LLVM build instructions -and add flang to `LLVM_ENABLE_PROJECTS` instead, as detailed there. +### Out-of-tree build -### LLVM dependency +Assuming someone was nice enough to build MLIR and LLVM libraries and +install them in a convenient place for you, then you may want to do a +standalone build. -The instructions to build LLVM can be found at -https://llvm.org/docs/GettingStarted.html. If you are building flang as part -of LLVM, follow those instructions and add flang to `LLVM_ENABLE_PROJECTS`. +1. Get the stuff is the same as above. Get the code from the same repos. -We highly recommend using the same compiler to compile both llvm and flang. +2. Get on the right branches. Again, same as above. -The flang CMakeList.txt file uses -* `LLVM_DIR` to find the installed LLVM components -* `MLIR_DIR` to find the installed MLIR components -* `CLANG_DIR` to find the installed Clang components +3. Create a build space for cmake and make (or ninja) -To get the correct LLVM, MLIR and Clang libraries included in your flang build, -define `LLVM_DIR`, `MLIR_DIR` and `CLANG_DIR` on the cmake command line. ``` -LLVM=/lib/cmake/llvm \ -MLIR=/lib/cmake/mlir \ -CLANG=/lib/cmake/clang \ -cmake -DLLVM_DIR=$LLVM -DMLIR_DIR=$MLIR -DCLANG_DIR=$CLANG ... + mkdir build + cd build + export CC= + export CXX= + cmake -GNinja ../f18-llvm-project/llvm -DCMAKE_BUILD_TYPE=Release -DLLVM_TARGETS_TO_BUILD=X86 -DLLVM_ENABLE_PROJECTS=mlir -DCMAKE_CXX_STANDARD=17 -DLLVM_BUILD_TOOLS=On -DLLVM_INSTALL_UTILS=On -DCMAKE_INSTALL_PREFIX= ``` -where `LLVM_BUILD_DIR` is -the top-level directory where LLVM was built. - -### Building flang with GCC - -By default, -cmake will search for g++ on your PATH. -The g++ version must be one of the supported versions -in order to build flang. -Or, cmake will use the variable CXX to find the C++ compiler. CXX should include -the full path to the compiler or a name that will be found on your PATH, e.g. -g++-8.3, assuming g++-8.3 is on your PATH. +5. Build and install ``` -export CXX=g++-8.3 + ninja + ninja install ``` -or + +6. Add the new installation to your PATH + ``` -CXX=/opt/gcc-8.3/bin/g++-8.3 cmake ... + PATH=/bin:$PATH ``` -### Building flang with clang - -To build flang with clang, -cmake needs to know how to find clang++ -and the GCC library and tools that were used to build clang++. +7. Create a build space for another round of cmake and make (or ninja) -CXX should include the full path to clang++ -or clang++ should be found on your PATH. ``` -export CXX=clang++ + mkdir build-flang + cd build-flang + cmake -GNinja ../f18 -DLLVM_DIR= -DCMAKE_BUILD_TYPE=RelWithDebInfo -DLLVM_TARGETS_TO_BUILD=X86 -DCMAKE_CXX_STANDARD=17 -DLLVM_BUILD_TOOLS=On -DCMAKE_INSTALL_PREFIX= ``` +Note: if you plan on running lit regression tests, you should either: +- Use `-DLLVM_DIR=` instead of `-DLLVM_DIR=` +- Or, keep `-DLLVM_DIR=` but add `-DLLVM_EXTERNAL_LIT=`. +A valid `llvm-lit` path is `/bin/llvm-lit`. +Note that LLVM must also have been built with `-DLLVM_INSTALL_UTILS=On` so that tools required by tests like `FileCheck` are available in ``. -### Installation Directory +8. Build and install -To specify a custom install location, -add -`-DCMAKE_INSTALL_PREFIX=` -to the cmake command -where `` -is the path where flang should be installed. - -### Build Types +``` + ninja + ninja check-flang + ninja install +``` -To create a debug build, -add -`-DCMAKE_BUILD_TYPE=Debug` -to the cmake command. -Debug builds execute slowly. +### Running regression tests -To create a release build, -add -`-DCMAKE_BUILD_TYPE=Release` -to the cmake command. -Release builds execute quickly. +Inside `build` for in-tree builds or inside `build-flang` for out-of-tree builds: -### Build Flang out of tree ``` -cd ~/flang/build -cmake -DLLVM_DIR=$LLVM -DMLIR_DIR=$MLIR -DCLANG_DIR=$CLANG ~/flang/src -make + ninja check-flang ``` -### Disable The New Flang Driver -The new Flang compiler driver, `flang-new`, is implemented in terms of -`clangDriver` and hence it introduces a dependency on Clang. This dependency is -otherwise not required. If you do not require the new driver, you can disable -it by adding `-DFLANG_BUILD_NEW_DRIVER=OFF` to your CMake invocation. With the -new driver disabled, you no longer need to add `clang` to -`LLVM_ENABLE_PROJECTS` (or to specify `CLANG_DIR` when building out-of-tree). +### Build The New Flang Driver +The new Flang driver, `flang-new`, is currently under active development and +should be considered as an experimental feature. For this reason it is disabled +by default. This will change once the new driver replaces the _throwaway_ +driver, `flang`. + +In order to build the new driver, add `-DFLANG_BUILD_NEW_DRIVER=ON` to your +CMake invocation line. Additionally, when building out-of-tree, use `CLANG_DIR` +(similarly to `LLVM_DIR` and `MLIR_DIR`) to find the installed Clang +components. + +**Note:** `CLANG_DIR` is only required when building the new Flang driver, +which currently depends on Clang. # How to Run Tests @@ -212,7 +182,7 @@ make check-flang # How to Generate Documentation ## Generate FIR Documentation -If flang was built with `-DLINK_WITH_FIR=On` (`On` by default), it is possible to +It is possible to generate FIR language documentation by running `make flang-doc`. This will create `docs/Dialect/FIRLangRef.md` in flang build directory. diff --git a/flang/cmake/modules/AddFlang.cmake b/flang/cmake/modules/AddFlang.cmake index 5da58a59ed1211..82a31424269d2b 100644 --- a/flang/cmake/modules/AddFlang.cmake +++ b/flang/cmake/modules/AddFlang.cmake @@ -17,7 +17,7 @@ endmacro() macro(add_flang_library name) cmake_parse_arguments(ARG - "SHARED" + "SHARED;STATIC" "" "ADDITIONAL_HEADERS" ${ARGN}) @@ -52,7 +52,7 @@ macro(add_flang_library name) else() # llvm_add_library ignores BUILD_SHARED_LIBS if STATIC is explicitly set, # so we need to handle it here. - if (BUILD_SHARED_LIBS) + if (BUILD_SHARED_LIBS AND NOT ARG_STATIC) set(LIBTYPE SHARED OBJECT) else() set(LIBTYPE STATIC OBJECT) diff --git a/flang/cmake/modules/FlangConfig.cmake.in b/flang/cmake/modules/FlangConfig.cmake.in index 7893cb64b93657..ff140bc69ae9f4 100644 --- a/flang/cmake/modules/FlangConfig.cmake.in +++ b/flang/cmake/modules/FlangConfig.cmake.in @@ -5,6 +5,9 @@ find_package(LLVM REQUIRED CONFIG HINTS "@FLANG_CONFIG_LLVM_CMAKE_DIR@") +find_package(MLIR REQUIRED CONFIG + HINTS "@FLANG_CONFIG_MLIR_CMAKE_DIR@") + set(FLANG_EXPORTED_TARGETS "@FLANG_EXPORTS@") set(FLANG_CMAKE_DIR "@FLANG_CONFIG_CMAKE_DIR@") set(FLANG_INCLUDE_DIRS "@FLANG_CONFIG_INCLUDE_DIRS@") diff --git a/flang/docs/C++style.md b/flang/docs/C++style.md index fb11e641161413..16d0b1bc474427 100644 --- a/flang/docs/C++style.md +++ b/flang/docs/C++style.md @@ -115,7 +115,10 @@ Don't try to make columns of variable names or comments align vertically -- they are maintenance problems. Always wrap the bodies of `if()`, `else`, `while()`, `for()`, `do`, &c. -with braces, even when the body is a single statement or empty. The +with braces, even when the body is a single statement or empty. Note that this +diverges from the LLVM coding style. In parts of the codebase that make heavy +use of LLVM or MLIR APIs (e.g. the Lower and Optimizer libraries), use the +LLVM style instead. The opening `{` goes on the end of the line, not on the next line. Functions also put the opening `{` after the formal arguments or new-style result type, not on the next diff --git a/flang/docs/Extensions.md b/flang/docs/Extensions.md index 89fca93d20820e..49855b25e85567 100644 --- a/flang/docs/Extensions.md +++ b/flang/docs/Extensions.md @@ -35,6 +35,34 @@ accepted if enabled by command-line options. * We are not strict on the contents of `BLOCK DATA` subprograms so long as they contain no executable code, no internal subprograms, and allocate no storage outside a named `COMMON` block. (C1415) +* Delimited list-directed (and NAMELIST) character output is required + to emit contiguous doubled instances of the delimiter character + when it appears in the output value. When fixed-size records + are being emitted, as is the case with internal output, this + is not possible when the problematic character falls on the last + position of a record. No two other Fortran compilers do the same + thing in this situation so there is no good precedent to follow. + Because it seems least wrong, we emit one copy of the delimiter as + the last character of the current record and another as the first + character of the next record. (The second-least-wrong alternative + might be to flag a runtime error, but that seems harsh since it's + not an explicit error in the standard, and the output may not have + to be usable later as input anyway.) + Consequently, the output is not suitable for use as list-directed or + NAMELIST input. If a later standard were to clarify this case, this + behavior will change as needed to conform. +``` +character(11) :: buffer(3) +character(10) :: quotes = '""""""""""' +write(buffer,*,delim="QUOTE") quotes +print "('>',a10,'<')", buffer +end +``` +* The name of the control variable in an implied DO loop in an array + constructor or DATA statement has a scope over the value-list only, + not the bounds of the implied DO loop. It is not advisable to use + an object of the same name as the index variable in a bounds + expression, but it will work, instead of being needlessly undefined. ## Extensions, deletions, and legacy features supported by default @@ -93,8 +121,10 @@ accepted if enabled by command-line options. * BOZ literals can be used as INTEGER values in contexts where the type is unambiguous: the right hand sides of assigments and initializations of INTEGER entities, and as actual arguments to a few intrinsic functions - (ACHAR, BTEST, CHAR). But they cannot be used if the type would not - be known (e.g., `IAND(X'1',X'2')`). + (ACHAR, BTEST, CHAR). BOZ literals are interpreted as default INTEGER + when they appear as the first items of array constructors with no + explicit type. Otherwise, they generally cannot be used if the type would + not be known (e.g., `IAND(X'1',X'2')`). * BOZ literals can also be used as REAL values in some contexts where the type is unambiguous, such as initializations of REAL parameters. * EQUIVALENCE of numeric and character sequences (a ubiquitous extension) @@ -108,6 +138,7 @@ accepted if enabled by command-line options. the arguments as if they were operands to an intrinsic `+` operator, and defining the result type accordingly. * DOUBLE COMPLEX intrinsics DREAL, DCMPLX, DCONJG, and DIMAG. +* The DFLOAT intrinsic function. * INT_PTR_KIND intrinsic returns the kind of c_intptr_t. * Restricted specific conversion intrinsics FLOAT, SNGL, IDINT, IFIX, DREAL, and DCMPLX accept arguments of any kind instead of only the default kind or @@ -221,3 +252,13 @@ accepted if enabled by command-line options. from `COS(3.14159)`, for example. f18 will complain when a generic intrinsic function's inferred result type does not match an explicit declaration. This message is a warning. + +## Standard features that might as well not be + +* f18 supports designators with constant expressions, properly + constrained, as initial data targets for data pointers in + initializers of variable and component declarations and in + `DATA` statements; e.g., `REAL, POINTER :: P => T(1:10:2)`. + This Fortran 2008 feature might as well be viewed like an + extension; no other compiler that we've tested can handle + it yet. diff --git a/flang/docs/FortranLLVMTestSuite.md b/flang/docs/FortranLLVMTestSuite.md new file mode 100644 index 00000000000000..46a8fe4f634245 --- /dev/null +++ b/flang/docs/FortranLLVMTestSuite.md @@ -0,0 +1,60 @@ +# Fortran Tests in the LLVM Test Suite + +```eval_rst +.. contents:: + :local: +``` + +The [LLVM Test Suite](https://github.com/llvm/llvm-test-suite) is a +separate git repo from the main LLVM project. We recommend that +first-time users read through [LLVM Test Suite +Guide](https://llvm.org/docs/TestSuiteGuide.html) which describes the +organizational structure of the test suite and how to run it. + +Although the Flang driver is unable to generate code at this time, we +are neverthelesss incrementally adding Fortran tests into the LLVM +Test Suite. We are currently testing against GFortran while we make +progress towards completing the new Flang driver with full +code-generation capabilities. + +## Running the LLVM test-suite with Fortran + +Fortran support can be enabled by setting the following CMake variables: +``` +cmake -G "Ninja" -DCMAKE_C_COMPILER= \ + -DCMAKE_CXX_COMPILER= \ + -DCMAKE_Fortran_COMPILER= \ + -DTEST_SUITE_COLLECT_CODE_SIZE:STRING=OFF \ + -DTEST_SUITE_SUBDIRS:STRING="Fortran" \ + -DTEST_SUITE_FORTRAN:STRING=ON .. +``` + +This will configure the test-suite to run only the Fortran tests which +are found in the Fortran subdirectory. To run the C/C++ tests +alongside the Fortran tests omit the `-DTEST_SUITE_SUBDIRS` CMake +variable. + + +## Running the SPEC CPU 2017 + +We recently added CMake hooks into the LLVM Test Suite to support +Fortran tests from [SPEC CPU 2017](https://www.spec.org/cpu2017/). We +strongly encourage the use of the CMake Ninja (1.10 or later) generator +due to better support for Fortran module dependency detection. Some of +the SPEC CPU 2017 Fortran tests, those that are derived from climate +codes, require support for little-endian/big-endian byte swapping +capabilities which we automatically detect at CMake configuration +time. Note that a copy of SPEC CPU 2017 must be purchased by your +home institution and is not provided by LLVM. + + +Here is an example of how to build SPEC CPU 2017 with GCC + +``` +cmake -G "Ninja" -DCMAKE_C_COMPILER=gcc -DCMAKE_CXX_COMPILER=g++ \ + -DCMAKE_Fortran_COMPILER=gfortran \ + -DTEST_SUITE_COLLECT_CODE_SIZE:STRING=OFF \ + -DTEST_SUITE_SUBDIRS:STRING="External/SPEC" \ + -DTEST_SUITE_FORTRAN:STRING=ON \ + -DTEST_SUITE_SPEC2017_ROOT= .. +``` diff --git a/flang/docs/GettingInvolved.md b/flang/docs/GettingInvolved.md index d001ce16685d4b..650e174e48cbcc 100644 --- a/flang/docs/GettingInvolved.md +++ b/flang/docs/GettingInvolved.md @@ -45,7 +45,7 @@ To understand the status of various developments in Flang please join the respec ### Flang Community Biweekly Call - General updates on the Flang Project, both LLVM Flang and current Flang. -- Join [Flang Community Biweekly Call](https://lanl-us.webex.com/lanl-us/j.php?MTID=m44f29d1fa15eab5cbedc54a5df6c12ae) +- Join [Flang Community Biweekly Call](https://lanl-us.webex.com/lanl-us/j.php?MTID=mdce13c9bd55202e8071d8128fb953614) - Time: On Wednesdays 8:30 Pacific Time, on the weeks alternating with regular Flang Community Technical Biweekly Call. - Meeting minutes are available in this [Google Doc](https://docs.google.com/document/d/10T-S2J3GrahpG4Ooif93NSTz2zBW0MQc_RlwHi0-afY/edit?usp=sharing). If you can not access the Google Doc, please send an email to Alexis Perry-Holby at aperry@lanl.gov requesting to be added to the access list. diff --git a/flang/docs/index.md b/flang/docs/index.md index dc56c387afdc49..d1ea4dc2af953a 100644 --- a/flang/docs/index.md +++ b/flang/docs/index.md @@ -53,6 +53,7 @@ Flang is LLVM's Fortran frontend ArrayComposition BijectiveInternalNameUniquing DoConcurrent + FortranLLVMTestSuite ``` # Indices and tables diff --git a/flang/docs/tutorials/addingIntrinsics.md b/flang/docs/tutorials/addingIntrinsics.md new file mode 100644 index 00000000000000..68750df38cdd0d --- /dev/null +++ b/flang/docs/tutorials/addingIntrinsics.md @@ -0,0 +1,450 @@ +# Adding and Implementing an Intrinsic Procedure in f18 +This document first describes where and how to implement an intrinsic and to write tests +at the four different stages listed below. It then illustrates this with the example of +the TRIM intrinsic. + +The first step should be to be sure to have a copy of the standard and have +read the requirements for the intrinsic to be implemented. +In Fortran 2018, these are listed in section 16.9. +Writing some end-to-end Fortran test cases and running them with existing compilers is +a good way to get familiar with the intrinsic, and will be useful to write regression tests later. + +To add a completely new intrinsic to f18, up to 4 steps might be needed: + +- Adding support in name resolution and semantic checking +- Adding support in front-end folding (only if intrinsic can be in constant expressions) +- Adding support in the runtime (if runtime is the chosen way to implement the intrinsic) +- Adding support in lowering + +For most of the Fortran 2018 intrinsics, the support in the first two steps (front-end), +has been completed. It is very likely only lowering and runtime support is missing. +Readers that only need to implement these last two steps can focus on the runtime and lowering +related sections of this document and skip the front-end related sections. + + +## Quickly checking the status of an intrinsic. +The front-end support can be easily tested by running `f18 -funparse` on a test using the +intrinsic and using an explicit INTRINSIC attribute statement to declare it. If an +error about unknown intrinsic is raised, the front-end support is missing. Otherwise, +name resolution is done. + +To test constant folding in the front-end, if applicable, the intrinsic can be used in the initialization +of a PARAMETER. With the `f18 -funparse`, it should be observed that the parameter +initialization has been folded. If an error is thrown, the front-end folding support +is missing. + +To test lowering, `bbc -emit-fir` should raise no error about missing intrinsics on the test +case. Note that if the test case uses modern Fortran features, it is likely that it will +currently hit other TODOs. So it is better to keep the test cases simple at first (using F77 features +when possible). + +To test the runtime support, it will be needed to try to compile and link the test program with the runtime. +There is no official end-to-end driver for now, so this test is a bit more cumbersome. +Have a look at `test/Examples/hello.f90` for a possible flow to do this end-to-end compilation. +Also, if the runtime is implemented but lowering support is not there, this test will also fail, +so it might just be easier to search the runtime headers in `lib/runtime` for a function that would +contain the intrinsic name, and see if it has an actual implementation in one of the `.cpp` files. + +## Adding intrinsics in the front-end +### Name resolution and semantic checking +- See: `lib/Evaluate/intrinsics.cpp`. +- Where to submit patch: llvm repository through Phabricator. + +#### Implementation +There is a table in this file, and intrinsics must be defined there with +their interface and argument constraints. + +#### Testing +Be sure to add some error tests in the semantics regression tests. +See `test/Semantics/reshape.f90` for a good example. + +### Front-end folding +- See: `lib/Evaluate/fold.cpp`, and `lib/Evaluate/fold-[type].cpp`. +- Where to submit patch: llvm repository through Phabricator. + +#### Implementation +If the intrinsic that is being added is allowed in constant expressions, then an +implementation operating on `Fortran::evaluate::Expr` must be added to the +front-end. Otherwise, this step can be skipped. In Fortran 2018 standard, section +10.1.12 rules which intrinsic functions are allowed in constant expressions. + +In each of those files, there is a big `if` statement switching on the +intrinsic names. Chose the file according to the intrinsic result types. If the +intrinsic may return several types and would have a similar implementation, the +implementation should be done in `lib/Evaluate/fold.cpp`. +Add the name of the intrinsics in the if-chain, and plug the implementation there. +See other implementations for examples. + +Front-end folding operates on `Fortran::evaluate::Expr`, and in particular, with the +`Fortran::evaluate::Constant` variant of expressions. You will need to be +familiar with them to do anything. Look at the defining header in `include/Evaluate` +to get started. Note that `Fortran::evaluate::Expr` has `Dump` and `AsFortran` +methods that can be used to see what it contains. + +#### Tests +To add regression tests for front-end folding, `test_folding.sh` can be used as a test driver. +It checks that every parameter prefixed by `test_` is folded to `.true.`. +`test/Evaluate/folding06.f90` is a good example for it. + +## Adding intrinsics to the runtime and lowering + +It is first needed to decide whether some runtime is needed or not. If the intrinsic can +be implemented with a simple sequence of FIR operations, it might be worth to implement it inline. +Otherwise, if it involves more advanced control flow and dynamic allocations, a runtime implementation +might be sounder. + +### Runtime +- See: `lib/runtime` folder +- Where to submit patch: llvm repository through Phabricator. + +#### Implementation +A runtime interface must be designed for the intrinsic. +The runtime interface is simply the declaration of the runtime function for which lowering must insert calls, +as well as a small description of what the function is doing (e.g. comments above the declaration). +Before starting to implement anything, it is best to submit this interface for review. Having the interface +already submitted can also allow the implementation of the lowering part in parallel of the runtime implementation. +See `lib/runtime/character.h` for examples of runtime interfaces. + +The design must decide if one or more functions should form the runtime interface. +It may make sense to have simple entry points for easy cases, and a more complex entry points +with descriptors to cover all the other cases. When in doubt, it is best to start with a single +entry point that cover all cases, and leave entry point specialization for later, based on a measurable +performance gain on actual programs. + +The implementation is done in C++, but there is a hard requirement in not depending on +the C++ runtime library. That is because it is undesirable that Fortran runtime depends +upon libstdc++ or other C++ runtime libraries. This means that templates and classes +are OK, `#include ` should be OK, but any other includes should be avoided +unless proven they do not bring C++ runtime in. +Trying to link the runtime (libFortranRuntime.a) and a test program with a C compiler will +leads to linking failure if there is a dependency on libsdtc++. This can be used to test +that the Fortran runtime remains independent of the C++ runtime. + +The implementation is done in a related `.cpp` file in the same folder. See +`lib/runtime/character.cpp` for an example. + +#### Tests +To be defined. Ideally, we would want end-to-end tests from Fortran, but it is +not yet clear where to put them in llvm. Unit tests can also be defined. See +`unittests/Runtime/character.cpp` for an example. + +### Lowering +- See: `lib/Lower/IntrinsicCall.cpp` +- Where to submit patch: fir-dev branch of https://github.com/flang-compiler/f18-llvm-project. + +#### Implementation +Lowering of intrinsics is driven by the `IntrinsicLibrary` class. Its member function +`gen{intrinsic name}` lowers "intrinsic name". These functions have standardized interfaces. +There is a table in this file that maps an intrinsic name to the function that lowers it. +To add support for an intrinsic, a new member function containing the lowering implementation +must be created and mapped into the table. + +The lowering implementation can be inlined if it can easily be implemented in a few fir or +builtin mlir dialect operations. Otherwise, the lowering implementation should generate code +that emits a call to the runtime implementing the intrinsic. + +There are three standardized interfaces to choose from for implementation member functions: +- `mlir::Value genXXX(mlir::Type, llvm::ArrayRef)` +- `fir::ExtendedValue genXXX(mlir::Type, llvm::ArrayRef)` +- `void genXXX(llvm::ArrayRef)` + +The first interface is to be used for elemental numerical and logical intrinsic functions, +see `genAbs` for an example. +The second interface is to be used for other intrinsic functions, see `genTrim` for an example. +The third interface is to be used for intrinsic subroutines, see `genDateAndTime` for an example. + +It is worth being familiar with `fir::ExtendedValue`. It describes an entity (symbol, +or evaluated expression) with all its associated dynamic properties (length, extents, lower bounds...). +A `fir::ExtendedValue` is a variant of different SSA value containers that describes a particular category of entities. +The categories are: +- `fir::Unboxed` for scalar numericals, logicals, and non-polymorphic derived types without length parameters, +- `fir::CharBoxValue` for scalar characters. +- `fir::ArrayBoxValue` for contiguous arrays of numerical, logical, and non-polymorphic derived types without length parameters. +- `fir::CharArrayBoxValue` contiguous character arrays. +- `fir::MutableBoxValue` for allocatable and pointers of all types. +- `fir::ProcBoxValue` for procedure pointers. +- `fir::BoxValue` for all the rest (e.g. non-contiguous arrays, polymorphic or parametrized derived types). +See `include/flang/Support/BoxValue.h` for more details. + +If the intrinsic has a runtime implementation, the actual binding should be done in another helper function called +`gen{Runtime function name}`. For instance character runtime bindings are implemented in `lib/Optimizer/Builder/Runtime/Character.cpp` +See `genTrim` for an example of such runtime binding helper. +Non character related runtime binding should be added to `lib/Optimizer/Builder/Runtime/Xxx.cpp` +(for runtime API declared in `runtime/xxx.cpp`). + +Note: Numerical elemental intrinsics that have libm/libnvmath implementations are automatically mapped and +do not follow the above patterns (this includes intrinsics like `acos`, `bessel_j`...). + +#### Tests +LLVM FileCheck regression tests are used in lowering. See +`test/Lower/intrinsic-procedures/` for examples. To get familiar with FileCheck +tests, it is worth having a look at +`https://llvm.org/docs/CommandGuide/FileCheck.html`. A few test cases must be +added in `test/Lower/intrinsic-procedures` to test that the fir output looks +like what is expected. We normally create a dedicated test file for every +intrinsic. To do quick eye checking during development, the FIR produced for a +Fortran file can be dumped with `bbc -emit-fir`. The `-emit-fir` option stops +`bbc` immediately after lowering the PFT to FIR and precludes bbc from running +any subsequent lowering transformations or optimizations on the FIR. + +## Tips + +Be sure to respect alphabetical order when adding a new intrinsic in one of the tables or +if statements. They are usually sorted according to intrinsic names. + +## An End-to-End example: TRIM +TRIM is a transformational intrinsic operating on characters. +It takes a scalar character and returns a scalar character. See Fortran standard for more details about it. +### TRIM name resolution and semantic checking +In lib/Evaluate/intrinsics.cpp, the table contains a line: +```c++ + {"trim", {{"string", SameChar, Rank::scalar}}, SameChar, Rank::scalar, IntrinsicClass::transformationalFunction} +``` +This defines a transformational intrinsic named "trim" that takes a scalar character argument +named "string" and returns a scalar character of the same kind as the argument. +There is nothing more needed for name resolution and semantic checking. + +### TRIM front-end folding +TRIM can appear in constant expressions, as per Fortran 2018 section 10.1.12 point 1 sub-point (6). + +In `lib/Evaluate/fold-character.cpp`, there is case to fold trim that looks like: +```c++ + } else if (name == "trim") { // not elemental + if (auto scalar{ + GetScalarConstantArguments(context, funcRef.arguments())}) { + return Expr{Constant{ + CharacterUtils::TRIM(std::get>(*scalar))}}; + } + } +``` +It uses a helper function operating on the `Scalar` abstract representation. When T is a character kind 1, `Scalar` +are simply `std::string`, so `CharacterUtils<1>::TRIM` actually simply implements TRIM on `std::string`. +The folding code above mainly tries to extract a constant from the argument, and if successful, repackages the result +of the helper in a new typed expression representation (`Expr`). + +Regression tests for TRIM can be found in `test/Evaluate/folding05.f90` and look like: + +```fortran +logical, parameter :: test_c1_trim2 = trim('ab ') .eq. 'ab' +``` + +A test script is running the front-end on the test file and checking that `test_c1_trim2` has been +folded to `.true.` in the unparsed output. To add a new test case, add a new logical parameter +that must fold to `.true.` with a name prefixed by `test_`. + +### TRIM runtime +TRIM runtime API is defined in `runtime/character.h` as: + +```c++ +void RTNAME(Trim)(Descriptor &result, const Descriptor &string, + const char *sourceFile = nullptr, int sourceLine = 0); +``` + +The `RTNAME` macro adds some mangling to the runtime to avoid collision with user symbols and handles +runtime library versioning. Here, it only matters to know that it must be used in all function +declarations the runtime API. + +TRIM runtime takes a descriptor for the result that it will allocate, and a constant descriptor for the string argument. +On top of that, it takes optional source file and line arguments, that are here to print source location if the runtime +was to reach a critical error (e.g., if the provided descriptor is actually not describing a character scalar). +Note that C++ runtime optional arguments must still be created explicitly in lowering. They are only indications +of what the runtime expects as default values. Here, if no source location were available, lowering code would have to +generate `nullptr` and `0` and pass them explicitly in FIR. + +It is rather simple and follows the standard definition of TRIM in the argument naming. In general, it is best to stick +to the intrinsic interface in terms of argument names and order if possible. + +The actual implementation is in `runtime/character.cpp` and is not copied here. Have a look at it. A notable point is that it +is not using `std::string` anywhere, because that would bring the C++ runtime as a dependency. + +It is using some of the `Descriptor` member functions such as `string.OffsetElement<>`, +`result.Establish()`, `result.Allocate()`, or `string.ElementBytes()`. It is worth having a look at +`flang/runtime/descriptor.h` to understand more about the descriptor format and the tools available for it. + +The error handling in the runtime is done with the `Terminator` class. See the `terminator.Crash()` +and `RUNTIME_CHECK` macro. `terminator.Crash` causes an unconditional crash, while `RUNTIME_CHECK` +will cause a crash if the boolean provided to it is not true. The runtime should always crash rather +than reach undefined states. + +The last notable point is that it is using LEN_TRIM implementation rather than re-implementing it locally. +It is always a good idea to share parts of implementations that are similar between related intrinsics. +It is OK to define internal helper functions, classes or to use templates to achieve this. + + +### TRIM Lowering + +In the table in `lib/Lower/IntrinsicCall.cpp`, there is a line: +```c++ +{"trim", &I::genTrim, {{{"string", asAddr}}}, /*isElemental=*/false} +``` + +It defines that when presented with a call to an intrinsic named "trim", +that is not elemental, lowering must lower its `string` argument in memory, and pass this lowered +argument to a function called `genTrim` that implements the actual lowering of TRIM. + +Pass by value is the default argument passing scheme. If all arguments are passed by value, then you do not need to specify any arguments in this table. If at least one argument is not passed by value, then it is good practice to specify all the arguments. For example, consider the genScan entry: +```c++ +{"scan", &I::genScan, {{ {"string", asAddr}, {"set", asAddr}, + {"back", asValue}, {"kind", asValue} }}, + /*isElemental=*/true} +``` + +The `genTrim` function looks like: +```c++ +// TRIM +fir::ExtendedValue +IntrinsicLibrary::genTrim(mlir::Type resultType, + llvm::ArrayRef args) { + // Have a look at the implementation in lib/Lower/IntrinsicCall.cpp directly +} +``` + +It provides the result type and the lowered arguments as inputs, and expects the evaluated +result to be returned. Given the argument and result types are scalar characters, the related +`fir::Extended` must be `fir::CharBoxValue`, which is simply a container over two SSA values: one +for the address, one for the length. + +The choice here was to implement TRIM with the help of runtime. So this code is only preparing the arguments +according to the runtime interface. TRIM runtime is described in the next section. +It takes a `Descriptor&` for the result, and a `const Descriptor&` for the argument. The result can be seen +as a temporary allocatable that the runtime will allocate. +The code here is creating a `fir::MutableBoxValue`, which is a class used to deal with allocatables in lowering. +It also creates a descriptor for the argument with `builder.createBox()`. Note that the two descriptors are created +differently because we expect the first one to be modified, but not the second one. This difference preserves SSA +semantics in the IR (An SSA value cannot change). + +The actual runtime call is generated by `Fortran::lower::genTrim` defined in `lib/Optimizer/Builder/Runtime/Character.cpp` +After the runtime call, the result descriptor is read to build the resulting `fir::CharBoxValue` +with the result address and length. Since the result address was allocated, it is added to a clean-up list so that +it can be deallocated after the statement. + +The implementation of the runtime call in lowering looks like: + +```c++ +void fir::runtime::genTrim(fir::FirOpBuilder &builder, + mlir::Location loc, mlir::Value resultBox, + mlir::Value stringBox) { + auto trimFunc = fir::runtime::getRuntimeFunc(loc, builder); + auto fTy = trimFunc.getType(); + auto sourceFile = fir::factory::locationToFilename(builder, loc); + auto sourceLine = + fir::factory::locationToLineNo(builder, loc, fTy.getInput(3)); + + llvm::SmallVector args; + args.emplace_back(builder.createConvert(loc, fTy.getInput(0), resultBox)); + args.emplace_back(builder.createConvert(loc, fTy.getInput(1), stringBox)); + args.emplace_back(builder.createConvert(loc, fTy.getInput(2), sourceFile)); + args.emplace_back(builder.createConvert(loc, fTy.getInput(3), sourceLine)); + builder.create(loc, trimFunc, args); +} +``` + +The key point is `getRuntimeFunc(loc, builder)` that builds the FIR signature for the runtime +function automatically. The name passed to `mkRTKey` must be the same as the one inside `RTNAME` when declaring +the function in the runtime headers. The runtime header must be included in the current file to use `getRuntimeFunc<>` +(note the `#include "flang/Runtime/character.h"` at the top of the file). So at least the runtime API must be designed before adding +the support in lowering. + +Then, the source file name and line number are lowered from the current location so that they can be passed to the runtime. +In general, runtime calls that may fail (like here if the allocation were to fail) takes source file information. + +Last, before making the call, all SSA values that were lowered from the arguments are converted to the exact type required by +the runtime. There are two reasons for this. The first is that the runtime uses a single opaque type for descriptors, +but fir descriptor are strongly typed. So all descriptors must be cast to this opaque type (this will be a no-op at runtime). +The second reason is that when intrinsics take integer arguments, the actual integer type can be of any kind, but the runtime usually will take +a simple `std::int64_t` argument to cover all cases (assuming in these cases that bigger integer values would not be +semantically valid.). So an actual truncation/extension might be required. Therefore, casts are systematically inserted for +runtime arguments to simplify interfaces. + +That is it. Here is the fir output of TRIM lowering for a simple Fortran program: +```fortran + character(42) :: c + call bar(trim(c)) + end +``` + +``` +func @_QQmain() { + // Allocation of the descriptor for the temporary result of TRIM. + // This was generated by the `createTempMutableBox` call + %0 = fir.alloca !fir.box>> + + // Getting the address of c. This was actually generated when lowering the + // program scope, not by TRIM intrinsic lowering. It is the address in the fir::CharBoxValue argument. + %1 = fir.address_of(@_QEc) : !fir.ref> + + // Creating a descriptor for c. This was generated by the `createBox()` call. + // Note that the descriptor allocation is not visible in FIR because this is a read-only + // descriptor that cannot be modified after its creation. + %2 = fir.embox %1 : (!fir.ref>) -> !fir.box> + + // These ops are initializing the result descriptor to an unallocted descriptor + // of character type. They were also generated by `createTempMutableBox`. + %3 = fir.zero_bits !fir.heap> + %c0 = constant 0 : index + %4 = fir.embox %3 typeparams %c0 : (!fir.heap>, index) -> !fir.box>> + fir.store %4 to %0 : !fir.ref>>> + + // This is the address of the global constant with the file name. It was generated by `locationToFilename`. + %5 = fir.address_of(@_QQcl.2E2F7472696D2E66393000) : !fir.ref> + // This is the line number. It was generated by `locationToLineNo` + %c2_i32 = constant 2 : i32 + + // These are the argument casts generated in `Fortran::lower::genTrim`. + %6 = fir.convert %0 : (!fir.ref>>>) -> !fir.ref> + %7 = fir.convert %2 : (!fir.box>) -> !fir.box + %8 = fir.convert %5 : (!fir.ref>) -> !fir.ref + + // This is the runtime call generated in `Fortran::lower::genTrim`. + %9 = fir.call @_FortranATrim(%6, %7, %8, %c2_i32) : (!fir.ref>, !fir.box, !fir.ref, i32) -> none + + // This is reading the result address and length from the result descriptor, generated by `genMutableBoxRead`. + %10 = fir.load %0 : !fir.ref>>> + %11 = fir.box_elesize %10 : (!fir.box>>) -> index + %12 = fir.box_addr %10 : (!fir.box>>) -> !fir.heap> + + // This is the call to bar. fir.boxchar represent the F77 way of passing characters. This + // is generated in lowering based on the fir::ExtendedValue that was returned by `genTrim`. + %13 = fir.convert %12 : (!fir.heap>) -> !fir.ref> + %14 = fir.emboxchar %13, %11 : (!fir.ref>, index) -> !fir.boxchar<1> + fir.call @_QPbar(%14) : (!fir.boxchar<1>) -> () + + // After bar, the address of the temporary TRIM result is freed. This was indirectly generated by + // `addCleanUpForTemp` in `genTrim`. It registered code to be generated at the end of the statement. + fir.freemem %12 : !fir.heap> + return +} +``` + + +Regression tests for TRIM lowering are in `test/Lower/intrinsic-procedures/TRIM.f90` and look like: + +```fortran +! TRIM +! CHECK-LABEL: trim_test +! CHECK-SAME: (%[[arg0:.*]]: !fir.boxchar<1>) +subroutine trim_test(c) + character(*) :: c + ! CHECK: %[[tmpBox:.*]] = fir.alloca !fir.box>> + ! CHECK-DAG: %[[c:.*]]:2 = fir.unboxchar %[[arg0]] : (!fir.boxchar<1>) -> (!fir.ref>, index) + ! CHECK-DAG: %[[cBox:.*]] = fir.embox %[[c]]#0 typeparams %[[c]]#1 : (!fir.ref>, index) -> !fir.box> + ! CHECK-DAG: %[[cBoxNone:.*]] = fir.convert %[[cBox]] : (!fir.box>) -> !fir.box + ! CHECK-DAG: %[[resBox:.*]] = fir.convert %[[tmpBox]] : (!fir.ref>>>) -> !fir.ref> + ! CHECK: fir.call @{{.*}}Trim(%[[resBox]], %[[cBoxNone]], {{.*}}) : (!fir.ref>, !fir.box, !fir.ref, i32) -> none + ! CHECK-DAG: %[[tmpAddr:.*]] = fir.box_addr + ! CHECK-DAG: fir.box_elesize + ! CHECK: fir.call @{{.*}}bar_trim_test + call bar_trim_test(trim(c)) + ! CHECK: fir.freemem %[[tmpAddr]] : !fir.heap> + return +end subroutine +``` + +The `CHECK-XXX` are checking for patterns in the FIR dumped after lowering of a Fortran function using TRIM. The `[[xxx:.*]]` +are capturing SSA value definitions and the `[[xxx]]` are checking for their uses. See FileCheck documentation for more information. +To write such regression tests, start from a FIR dump that was manually verified to match with what is expected to be produced by lowering. +Keep the most relevant operations for the intrinsic, and replace the SSA value names with FileCheck pattern matching. +Note the usage of `CHECK-DAG` in places where the exact order of what SSA value is produced first does not matter. +Here, we do not want to make it a requirement that `resBox` value must be produced after `cBoxNone` SSA value. +It does not really matter in which order the intrinsic runtime arguments are lowered, someone should be able to +change that without breaking the test. diff --git a/flang/documentation/BurnsideToFIR.md b/flang/documentation/BurnsideToFIR.md new file mode 100644 index 00000000000000..9bd2e6337c0870 --- /dev/null +++ b/flang/documentation/BurnsideToFIR.md @@ -0,0 +1,823 @@ +## Burnside: The Bridge from the Fortran front-end to FIR + +This document sketches the translation of various Fortran snippets from +their syntactic level to how they ought to be represented in FIR. These +translations are representative and written in pseudo-code. + +This document shows examples of how Fortran fragments might be lowered into +FIR fragments. The style used throughout the document is to first show the +Fortran code fragment above a line and the FIR code fragment below the +line. + +### Program Units (PROGRAM, MODULE, and SUBMODULE) + +FIR has one flat global namespace. The global namespace can be populated +by Ops that represent code (functions), data (variables, constants), and +auxiliary structures (dispatch tables). + +Name collisions and scoping will be handled by a name mangling scheme. This +scheme ought to be a bijection from the tree of Fortran syntactic symbols +to and from the set of mangled names. + +A `PROGRAM` will necessarily have its executable definition wrapped in a +FIR `func` like a `SUBROUTINE`. Again, it is assumed the name mangling +scheme will provide a mapping to a distinct name. + +### Procedures (FUNCTION and SUBROUTINE) + +```fortran + FUNCTION foo (arg1, arg2) RESULT retval + + SUBROUTINE bar (arg1, arg2) +``` +---- +```mlir + func @foo(!fir.ref, !fir.ref) -> !TR + func @bar(!fir.ref, !fir.ref) +``` + +MLIR is strongly typed, so the types of the arguments and return value(s), +if any, must be explicitly specified. (Here, `arg1`, `arg2`, and `retval` +have the types `!T1`, `!T2`, and `!TR`, resp.) Also reflected is the +default calling convention: Fortran passes arguments by reference. + +#### Internal subprograms + +These will be lowered as any other `SUBROUTINE`. The difference will be +that they may take an extra `tuple` reference argument to refer to +variables in the host context. Host associated variables must be bundled +and passed explicitly on the FIR side. An example will be detailed below. + +#### Statement functions + +These are very simple internal subroutines, in a sense. They will be +lowered in the same way. + +### Non-executable statements + +#### Data + +Some non-executable statements may create constant (`PARAMETER`) or +variable data. This information should be lowered. + +##### Constants + +```fortran + INTEGER, PARAMETER :: x = 1 + CHARACTER (LEN = 10), PARAMETER :: DIGITS = "0123456789" +``` +---- +```mlir + %0 = constant 1 : i32 + + fir.global @_QG_digits constant : !fir.array<10:!fir.char<1>> { + constant '0' : !fir.char<1> + ... + constant '9' : !fir.char<1> + } +``` + +##### Local Variable + +```fortran + CHARACTER (LEN = 1) :: digit + INTEGER :: i +``` +---- +```mlir + %len = constant 1 : i32 + %digit = fir.alloca !fir.char<1>, %len : !fir.ref> + %i = fir.alloca i32 : !fir.ref +``` + +Note that in MLIR, the `%` sigil denotes an ssa-value, the `@` sigil +denotes a global symbol, and the `!` sigil denotes a type. + +##### Process lifetime variable + +```fortran + COMMON /X/ A(10),B(10) + + MODULE mymod + INTEGER a + + SUBROUTINE subr() + REAL, SAVE :: s + DATA s/12.0/ +``` +---- +```mlir + fir.global @common_x : tuple, !fir.array<10 : f32>> {} + + fir.global @mymod_a : i32 {} + + fir.global @subr_s : f32 { + constant 12.0 : f32 + } +``` + +The empty initializer region could mean these variables are placed in the +`.bss` section. + +#### Other non-executable statements + +These statements will define other properties of how the Fortran gets +lowered. For example, a variable in a `COMMON` block needs to reside in a +`fir.global`, or the structure of a derived type (user-defined record), +which would be reflected in a `!fir.type`. + +#### A note on TYPEs + +A FIR type is an synthesis of the Fortran concepts of type, attributes, and +type parameters. + +##### Intrinsic types + +For Fortran intrinsic types, there is a direct translation to a FIR type. + +```fortran + REAL(4) a + COMPLEX(8) b + CHARACTER(1,LEN=4) c + LOGICAL(1) d + INTEGER(4) e + + CHARACTER(1,LEN=*) f +``` +---- +```mlir + %a = ... : !fir.real<4> + %b = ... : !fir.complex<8> + %c = ... : !fir.array<4:!fir.char<1>> + %d = ... : !fir.logical<1> + %e = ... : !fir.int<4> + + %f_data = ... : !fir.ref>> + %f_len = ... : i32 + %f = fir.emboxchar %f_data, %f_len : !fir.boxchar<1> +``` + +The bridge will have a mapping of what the front-end kind value must map to +in the internal representation. For example, the f18 front-end maps kind +values for integers to the size in bytes of the integer representation. +Such mappings must be provided for all intrinsic type kind values. + +The Fortran `CHARACTER` variable, `f`, is a bit more complicated as there +is both a reference to a buffer (that contains the characters) and an +extra, assumed length, `LEN` type parameter to keep track of the length of +the buffer. The buffer is a sequence of `!fir.char<1>` values in memory. +The pair, `(buffer, len)`, may be boxed in a `!fir.boxchar<1>` type +object. + +##### Derived types + +Fortran also has derived types and these are supported with a more +elaborate record syntax. + +```fortran + TYPE :: person + CHARACTER(LEN=20) :: name + INTEGER :: age + END TYPE + + TYPE(person) :: george +``` +---- +```mlir + %george = ... : !fir.type>, age : i32}> +``` + +Fortran allows the compiler to reorder the fields in the derived type. +`SEQUENCE` can be used to disable reordering. (Name mangling can provide a +compile-time distinction, as needed.) + +Fortran allows a derived type to have type parameters. There are `KIND` +type parameters and `LEN` type parameters. A `KIND` type parameter is a +compile-time known constant. As such, it is possible for the compiler +implementation to create a distinct type for each set of `KIND` type +parameters (by name mangling, for instance). + +The `LEN` type parameters are runtime constant and not necessarily known at +compile-time. These values must be provided when constructing a value of +derived type in FIR, just as regular fields must be provided. (That does +not preclude an optimizer from eliminating unused `LEN` parameters.) + +Because of Fortran's `LEN` type parameters, an implementation is allowed to +defer the size and layout of an entity of derived type until runtime. + +Lowering may also exploit ad hoc product types created as needed. This can +be done using the standard dialect `tuple` type. + +##### Arrays + +An entity with type _T_ and a `DIMENSION` attribute is an array with +elements of type _T_ in Fortran. + +```fortran + INTEGER arr + DIMENSION arr(10,20) +``` +---- +```mlir + %arr = ... : !fir.array<10x20 : i32> +``` + +A FIR array is laid out in column-major order exactly like a Fortran array. + +##### Pointer and reference types + +The attribute `POINTER` can be used similarly to create a pointer entity. +The `ALLOCATABLE` attribute is another Fortran attribute that can be used +to indicate an entity's storage is to be allocated at runtime. As mentiond +previosuly, Fortran uses pass-by-reference calling semantics too. + +```fortran + INTEGER, POINTER :: ptr + REAL, ALLOCATABLE, DIMENSION(1000) :: al + + INTERFACE + SUBROUTINE fun(ptr, al) + INTEGER, POINTER :: p + REAL, ALLOCATABLE :: a + END SUBROUTINE + END INTERFACE +``` +---- +```mlir + %ptr = ... : !fir.ptr + %al = ... : !fir.heap> + + func @fun(!fir.ref>, !fir.ref>) +``` + +Note that references to pointers and heap allocatables are +allowed. However, a pointer/heap cannot point directly to a pointer/heap. + +```mlir + %err1 = ... : !fir.ptr> // Invalid type + %err2 = ... : !fir.heap> // Invalid type +``` + +Note that a value of function type is also considered a reference. + +```mlir + %fun = ... : (i32, f64) -> i1 // %fun is a reference to a func object +``` + +##### Boxed types + +Boxed types are reference types. A boxed entity is implicitly located in +memory. The only way to construct a boxed value is by providing a memory +reference type, discussed above. Any reference can be emboxed. + +There are additionally, two special-purpose box types. A `!fir.boxchar` +value is a `CHARACTER` variable (in memory) including both a pointer to the +buffer and the `LEN` type parameter. `boxchar` was discussed above. + +The second special case is the `!fir.boxproc` type. A Fortran internal +procedure can reference variables in its host's scope. Fortran also allows +pointers to procedures. A value of type `!fir.boxproc` then is a pair of +references, one for the procedure pointer and the other a pointer to a +tuple of host associated values. + +```fortran + SUBROUTINE host + REAL X + PROCEDURE(), POINTER :: procptr + ... + procptr => intern + ... + CALL procptr + CONTAINS + SUBROUTINE intern + X = ... +``` +---- +```mlir + func @host() { + %x = ... : !fir.ref + ... + %bag_val = fir.insert_value %b, %x, %0 : ... -> tuple, ...> + %bag = ... : !fir.ref, ...>> + fir.store %bag_val to %bag : !fir.ref, ...>> + %procptr = fir.emboxproc @intern, %bag : ... -> !fir.boxproc<() -> ()> + ... + fir.call %procptr() : () -> () +``` + +Here, the call to the boxed procedure implicitly passes the extra argument, the +reference to `%bag`, which contains the value of the variable `x`. + +##### Miscellaneous types + +Fortran uses triple notation to describe array sections, strided views of +multidimensional arrays. These sections can be captured using the +`fir.gendims` instruction which produces a value of type `!fir.dims`. + +```fortran + DIMENSION (10,10) a + ... a(2:6:2,1:7:4) ... +``` +---- +```mlir + // the following line is pseudocode + %1 = fir.gendims 2,6,2, 1,7,4 : !fir.dims<2> +``` + +Fortran also allows the implementation to reorder fields in a derived +type. Furthermore, the sizes of these fields and the layout may be left up +to the runtime. This could mean that the backend needs to generate runtime +calls to determine the offsets and sizes of fields. + +```fortran + TYPE ding(k) + ... + TYPE(T(k)) :: field_name +``` +---- +```mlir + %2 = fir.field("field_name") : !fir.field +``` + +When lowering a boxed value, the compiler may need to test what the exact +type of the value is at runtime. (For example, when generating code for +`SELECT TYPE`.) + +```fortran + CLASS(*) :: x + SELECT TYPE (x) + ... +``` +---- +```mlir + %1 = fir.box_tdesc %x : (!fir.box) -> !fir.tdesc +``` + +The `none` type is used when the entity has unlimited polymorphic type. See +below for a larger example of `SELECT TYPE`. + +### Executable statements + +The main purpose of lowering is to lower all the executable statements from +Fortran into FIR in a semantics preserving way. + +#### Substrings + +```fortran + ID(4:9) +``` +---- +```mlir + %id = ... : !fir.ref>> + %1 = fir.coordinate_of %id, %c3 : ... -> !fir.ref> + %2 = fir.emboxchar %1, %c5 : ... -> !fir.boxchar<1> +``` + +#### Structure components + +```fortran + scalar_parent%scalar_field +``` +---- +```mlir + %sf = fir.field("scalar_field") : !fir.field + %1 = fir.coordinate_of %scalar_parent, %sf : ... -> !fir.ref +``` + +#### Type parameters + +```fortran + TYPE ding(dim) + INTEGER, LEN :: dim + REAL :: values(dim) + END TYPE ding + + ding(x) :: a_ding + ... a_ding%dim ... +``` +---- +```mlir + %1 = fir.len_param_index("dim") : !fir.field + %2 = fir.coordinate_of %a_ding, %1 : ... -> !fir.ref + %3 = fir.load %2 : !fir.ref +``` + +#### Arrays + +```fortran + ... A ... ! whole array + ... B(4) ... ! array element + ... C(1:10) ... ! array section + ... D(1:10:2) ... ! array section with stride + INTEGER, DIMENSION :: V(4) + ... E(V) ... ! array section with vector subscript +``` +---- +```mlir + %1 = fir.load %a : !fir.ref> + + %2 = fir.extract_element %b, %c4 : (!fir.array, i32) -> f32 + + %3 = fir.coordinate_of %c, %c1 : (!fir.ref>, i32) -> !fir.ref + %4 = fir.convert %3 : (!fir.ref) -> !fir.ref> + %5 = fir.load %4 : (!fir.ref>) -> !fir.array<10:f32> + + %6 = fir.gendims %c1, %c10, %c2 : (i32, i32, i32) -> !fir.dims<1> + %7 = fir.embox %d, %6 : (!fir.ref>, !fir.dims<1>) -> !fir.embox> + + // create a temporary to hold E(V) + %v = ... : !fir.array<4:i32> + %8 = fir.alloca !fir.array<4:f32> : !fir.ref> + fir.do_loop %i = %c1 to %c4 unordered { + %9 = fir.extract_value %v, %i : (!fir.array<4:i32>, index) -> i32 + %10 = fir.extract_value %e, %9 : (!fir.array, i32) -> f32 + %11 = fir.coordinate_of %8, %i : (!fir.ref>, index) -> !fir.ref + fir.store %10 to %11 : !fir.ref + } +``` + +In the fourth case, lowering could also create a temporary and copy the +values from the section `D(1:10:2)` into it, but the preference should be +to defer copying data until it is necessary (as in the fifth non-affine +case, `E(V)`). + +#### Image selector + +```fortran + REAL :: A(10)[5,*] + + ... A(:)[1,4] ... ! selects image 16 (if available) +``` +---- +```mlir + %1 = fir.call @runtime_fetch_array(%a, %c_1, %c_4, ...) : (!fir.box>, i32, i32, ...) -> !fir.ref> +``` + +#### Dynamic association + +```fortran + ALLOCATE (x(n), b(-3:m, 0:9)) + + NULLIFY (p) + + DEALLOCATE (x, b) +``` +---- +```mlir + %x = fir.allocmem f32, %n : !fir.heap> + + %c4 = constant 4 : i32 + %1 = addi %m, %c4 : i32 + %2 = constant 10 : i32 + %b = fir.allocmem f32, %1, %2 : !fir.heap> + + %zero = constant 0 : i64 + %null = fir.convert %zero : (i64) -> !fir.ptr + fir.store %null to %p : !fir.ref> + + fir.freemem %x : !fir.heap> + fir.freemem %b : !fir.heap> +``` + +#### Basic operators + +Operators like `**`, `*`, `/`, etc. will be lowered into standard dialect +operations or runtime calls as needed. + +```fortran + a * b + c .LE. d +``` +---- +```mlir + %0 = mulf %a, %b : f32 + %1 = cmp "le" %c, %d : (f32, f32) -> i1 +``` + +#### Calls + +```fortran + CALL foo(v1) + ... func(v2, v3) ... + + pp => bar + CALL pp(v4) + + CALL object%method(arg) +``` +---- +```mlir + fir.call @foo(%v1) : (!fir.ref) -> () + %1 = fir.call @func(%v2, %v3) : (!fir.ref) -> i64 + + %pp = fir.address_of(@bar) : ((!fir.ref) -> ()) -> !fir.ref<(!fir.ref) -> ()> + fir.icall %pp(%v4) : (!fir.ref) -> () + + fir.dispatch "method"(%object, %arg) : (!fir.box>, !fir.ref) -> () +``` + +There are two modes of argument passing in Fortran: calls that are "Fortran +77" style and use an implicit interface, and calls that require an +interface. In FIR, this translates to passing a simple reference to an +entity's data versus passing a boxed reference value. The following calls +illustrate this distinction. + +```fortran + SUBROUTINE sub1(a) + INTEGER :: a(10,10) ! F77 style + ... + INTERFACE + SUBROUTINE sub2(a) + INTEGER :: a(:,:) ! assumed shape + ... + PROGRAM p + INTEGER :: a(10,10) + CALL sub1(a) + CALL sub2(a) +``` +---- +```mlir + func @sub1(!fir.ref>) -> () + func @sub1(!fir.box>) -> () + + func @_QP_p() { + %c1 = constant 1 : i32 + %c10 = constant 10 : i32 + %a1 = fir.alloca !fir.array<10x10:i32> : !fir.ref> + fir.call @sub1(%a1) : (!fir.ref>) -> () + %1 = fir.gendims %c1, %c10, %c1, %c1, %c10, %c1 : (i32,i32,i32,i32,i32,i32) -> !fir.dims<2> + %a2 = fir.embox %a1, %1 : (!fir.ref>, !fir.dims<2>) -> !fir.box> + fir.call @sub2(%a2) : (!fir.box>) -> () +``` + +When lowering into FIR, the bridge must explicitly perform any allocation, +copying, deallocation, and finalization on temporary entities as required +by the Fortran standard, preserving the copy-in copy-out calling +convention. + +#### Parentheses (10.1.8) + +```fortran + (a + b) + (a + c) ! cannot rewrite as (2 * a) + b + c +``` +---- +```mlir + %1 = addf %a, %b : f32 + %2 = fir.no_reassoc %1 : f32 // to prevent reassociation + %3 = addf %a, %c : f32 + %4 = fir.no_reassoc %3 : f32 + %5 = addf %2, %4 : f32 +``` + +One must also specify to LLVM that these operations will not be reassociated. + +#### Assignment + +```fortran + scalar = e1 ! intrinsic scalar assignment + array = e2 ! intrinsic array assignment + object = e3 ! defined assignment + pntr => e4 ! pointer assignment + pproc => func ! procedure pointer assignment +``` +---- +```mlir + %e1 = ... : f32 + fir.store %e1 to %scalar : !fir.ref + + %e2 = ... : !fir.array<10x10 : i32> + fir.store %e2 to %array : !fir.ref> + + %e3 = ... !fir.ref + %object = ... !fir.ref + fir.call @defd_assn(%object, %e3) : ... -> () + + %e4 = ... : !fir.ptr + %pntr = ... : !fir.ref> + fir.store %e4 to %pntr : !fir.ref> + + @func(i32, i32) -> i32 + %fn = fir.address_of(@func) : ((i32, i32) -> i32) -> !fir.ptr<(i32, i32) -> i32> + %pproc = ... : !fir.ref i32>> + fir.store %fn to %pproc : !fir.ref i32>> +``` + +#### Masked assignment + +```fortran + WHERE (arr < threshold) + arr = arr + increment + ELSEWHERE + arr = threshold + END WHILE +``` +---- +```mlir + %arr = ... : !fir.array + %threshold = ... : !fir.array + fir.do_loop %i = %c1 to %size { + %arr_i = fir.extract_value %arr, %i : ... -> !T + %threshold_i = fir.extract_value %threshold, %i : ... -> !T + %1 = cmp "lt" %arr_i, %threshold_i : ... -> i1 + fir.where %1 { + %2 = addf %arr_i, %increment : !T + %3 = fir.coordinate_of %arr, %i : ... -> !fir.ref + fir.store %2 to %3 : !fir.ref + } otherwise { + %4 = fir.coordinate_of %arr, %i : ... -> !fir.ref + fir.store %threshold_i to %4 + } + } +``` + +#### FORALL + +```fortran + FORALL (i = 1:100) + a(i) = b(i) / c(i) + END FORALL +``` +---- +```mlir + fir.do_loop %i = %c1 to %c100 unordered { + %1 = fir.extract_value %b, %i : (!fir.array, index) -> f32 + %2 = fir.extract_value %c, %i : (!fir.array, index) -> f32 + %3 = divf %1, %2 : f32 + %4 = fir.coordinate_of %a, %i : (!fir.ref>, index) -> !fir.ref + fir.store %3 to %4 : !fir.ref + } +``` + +#### ASSOCIATE construct + +```fortran + ASSOCIATE (z => EXP(-(x**2+y**2)) * COS(theta)) + CALL foo(z) + END ASSOCIATE +``` +---- +```mlir + %1 = ... : f32 + %2 = fir.call @exp(%1) : (f32) -> f32 + %3 = fir.load %theta : !fir.ref + %4 = fir.call @cos(%3) : (f32) -> f32 + %5 = mulf %2, %4 : f32 + fir.store %5 to %z : !fir.ref + fir.call @foo(%z) : (!fir.ref) -> () +``` + +#### DO construct + +```fortran + DIMENSION a(10,10,10), b(10,10,10) + + DO i = 1, m + DO j = 1, n + c(i,j) = dot_prod(a(i,j,:), b(:,i,j)) + END DO + END DO +``` +---- +```mlir + %c1 = constant 1 : index + %c10 = constant 10 : index + %c100 = constant 100 : index + %c1000 = constant 1000 : index + %1 = fir.gendims %c1, %c1000, %c100 : !fir.dims<1> + %2 = fir.gendims %c1, %c10, %c1 : !fir.dims<1> + + fir.do_loop %i = %c1 to %m { + fir.do_loop %i = %c1 to %n { + %13 = fir.coordinate_of %a, %i, %j : !fir.ref> + %14 = fir.embox %13, %1 : (!fir.ref>, !fir.dims<1>) -> !fir.box> + %15 = fir.coordinate_of %b, %c1, %i, %j : !fir.ref + %16 = fir.convert %15 : (!fir.ref) -> !fir.ref> + %17 = fir.embox %16, %2 : (!fir.ref>, !fir.dims<1>) -> !fir.box> + %18 = fir.call @dot_prod(%14, %17) : (!fir.box>, !fir.box>) -> f32 + %19 = fir.coordinate_of %c, %i, %j : (!fir.box>, index, index) -> !fir.ref + fir.store %18 to %19 : !fir.ref + } + } +``` + +In this lowering, the array sections from the arrays `a` and `b` are _not_ +copied to a temporary memory buffer, but are instead captured in boxed +values (`%14` and `%17`). + +#### IF construct + +```fortran + IF (a > 0) THEN + ... + ELSE + ... + END IF +``` +---- +```mlir + %1 = ... : i1 + cond_br %1, ^bb1(%2:i32), ^bb2(%3:i32) +``` + +#### SELECT CASE construct + +```fortran + SELECT CASE (p) + CASE (1, 3:5) + ... + CASE (:-1) + ... + CASE (10:) + ... + CASE DEFAULT + ... + END SELECT CASE +``` +---- +```mlir + fir.select_case %p : i32 [#fir.point,%c1,^bb1, #fir.interval,%c3,%c5,^bb1, #fir.upper,%cn1,^bb2, #fir.lower,%c10,^bb3, unit,^bb4] +``` + +#### SELECT RANK construct + +```fortran + SELECT RANK (p) + RANK (2) + ... + RANK (*) + ... + RANK DEFAULT + ... + END SELECT RANK +``` +---- +```mlir + fir.select_rank %p : i32 [2,^bb1(%1:f32), -1,^bb2, unit,^bb3(%2:f32,%3:i32)] +``` + +#### SELECT TYPE construct + +```fortran + SELECT TYPE (p) + TYPE IS (type_a) + ... + CLASS IS (super_b) + ... + CLASS DEFAULT + ... + END SELECT TYPE +``` +---- +```mlir + fir.select_type %p : !fir.box [#fir.instance>,^bb_1(%1:i32,%2:i64), #fir.subsumed>,^bb_2(%3:f32,%4:f64,%5:i32), unit,^bb_3] +``` +---- +```mlir + %type_a_desc = fir.gentypedesc !fir.type : !fir.tdesc> + %super_b_desc = fir.gentypedesc !fir.type : !fir.tdesc> + %11 = fir.box_tdesc %p : (!fir.box) -> !fir.tdesc + %12 = cmp "eq" %11, %type_a_desc : (!fir.tdesc, !fir.tdesc>) -> i1 + cond_br %2, ^bb1(%1:i32,%2:i64), ^bb1b(%3:f32,%4:f64,%5:i32) + ^bb1(%a1,%a2 : i32,i64): + ... + ^bb1b(%b1,%b2,%b3 : f32,f64,i32): + %13 = fir.call @is_subtype_of(%11, %super_b_desc) : ... -> i1 + cond_br %13, ^bb2(%b1,%b2,%b3), ^bb3 + ^bb2(%b1,%b2,%b3 : f32,f64,i32): + ... + ^bb3: + ... +``` + +#### Jumping statements + +```fortran + STOP + ERROR STOP + FAIL IMAGE + CONTINUE loop + EXIT a_construct + GOTO label1 + GOTO (label2,label3,label4), i +``` +---- +```mlir + fir.call @stop() + fir.unreachable + + fir.call @error_stop() + fir.unreachable + + fir.call @fail_image() + fir.unreachable + + br ^bb_continue + + br ^bb_exit + + br ^bb_label1 + + fir.select %i : i32 [1,^bb_label2(%1:i32), 2,^bb_label3, 3,^bb_label4, unit,^fallthru] + ^fallthru: +``` + diff --git a/flang/include/flang/Common/Fortran-features.h b/flang/include/flang/Common/Fortran-features.h index 9fed37d641b24a..0a304913dfc5fb 100644 --- a/flang/include/flang/Common/Fortran-features.h +++ b/flang/include/flang/Common/Fortran-features.h @@ -30,7 +30,7 @@ ENUM_CLASS(LanguageFeature, BackslashEscapes, OldDebugLines, EquivalenceNumericWithCharacter, AdditionalIntrinsics, AnonymousParents, OldLabelDoEndStatements, LogicalIntegerAssignment, EmptySourceFile, ProgramReturn, ImplicitNoneTypeNever, ImplicitNoneTypeAlways, - ForwardRefDummyImplicitNone, OpenAccessAppend) + ForwardRefDummyImplicitNone, OpenAccessAppend, BOZAsDefaultInteger) using LanguageFeatures = EnumSet; diff --git a/flang/include/flang/Common/format.h b/flang/include/flang/Common/format.h index 99b8cbe41d7cf8..e38ea6b0dfedf9 100644 --- a/flang/include/flang/Common/format.h +++ b/flang/include/flang/Common/format.h @@ -136,11 +136,11 @@ template class FormatValidator { const CHAR *cursor_{}; // current location in format_ const CHAR *laCursor_{}; // lookahead cursor Token token_{}; // current token + TokenKind previousTokenKind_{TokenKind::None}; int64_t integerValue_{-1}; // value of UnsignedInteger token Token knrToken_{}; // k, n, or r UnsignedInteger token int64_t knrValue_{-1}; // -1 ==> not present int64_t wValue_{-1}; - bool previousTokenWasInt_{false}; char argString_[3]{}; // 1-2 character msg arg; usually edit descriptor name bool formatHasErrors_{false}; bool unterminatedFormatError_{false}; @@ -179,7 +179,7 @@ template void FormatValidator::NextToken() { // At entry, cursor_ points before the start of the next token. // At exit, cursor_ points to last CHAR of token_. - previousTokenWasInt_ = token_.kind() == TokenKind::UnsignedInteger; + previousTokenKind_ = token_.kind(); CHAR c{NextChar()}; token_.set_kind(TokenKind::None); token_.set_offset(cursor_ - format_); @@ -416,7 +416,8 @@ template void FormatValidator::NextToken() { } } SetLength(); - if (stmt_ == IoStmtKind::Read) { // 13.3.2p6 + if (stmt_ == IoStmtKind::Read && + previousTokenKind_ != TokenKind::DT) { // 13.3.2p6 ReportError("String edit descriptor in READ format expression"); } else if (token_.kind() != TokenKind::String) { ReportError("Unterminated string"); @@ -829,7 +830,8 @@ template bool FormatValidator::Check() { // Possible first token of the next format item; token not yet processed. if (commaRequired) { const char *s{"Expected ',' or ')' in format expression"}; // C1302 - if (previousTokenWasInt_ && itemsWithLeadingInts_.test(token_.kind())) { + if (previousTokenKind_ == TokenKind::UnsignedInteger && + itemsWithLeadingInts_.test(token_.kind())) { ReportError(s); } else { ReportWarning(s); diff --git a/flang/include/flang/Evaluate/call.h b/flang/include/flang/Evaluate/call.h index e74e82d86f87a4..7cf509c14a1f1e 100644 --- a/flang/include/flang/Evaluate/call.h +++ b/flang/include/flang/Evaluate/call.h @@ -218,6 +218,22 @@ class ProcedureRef { int Rank() const; bool IsElemental() const { return proc_.IsElemental(); } bool hasAlternateReturns() const { return hasAlternateReturns_; } + + Expr *UnwrapArgExpr(int n) { + if (static_cast(n) < arguments_.size() && arguments_[n]) { + return arguments_[n]->UnwrapExpr(); + } else { + return nullptr; + } + } + const Expr *UnwrapArgExpr(int n) const { + if (static_cast(n) < arguments_.size() && arguments_[n]) { + return arguments_[n]->UnwrapExpr(); + } else { + return nullptr; + } + } + bool operator==(const ProcedureRef &) const; llvm::raw_ostream &AsFortran(llvm::raw_ostream &) const; diff --git a/flang/include/flang/Evaluate/characteristics.h b/flang/include/flang/Evaluate/characteristics.h index e9fed59e393a32..619f3c96b4076f 100644 --- a/flang/include/flang/Evaluate/characteristics.h +++ b/flang/include/flang/Evaluate/characteristics.h @@ -144,8 +144,8 @@ class TypeAndShape { int Rank() const { return GetRank(shape_); } bool IsCompatibleWith(parser::ContextualMessages &, const TypeAndShape &that, const char *thisIs = "pointer", const char *thatIs = "target", - bool isElemental = false, bool thisIsDeferredShape = false, - bool thatIsDeferredShape = false) const; + bool isElemental = false, + enum CheckConformanceFlags::Flags = CheckConformanceFlags::None) const; std::optional> MeasureElementSizeInBytes( FoldingContext &, bool align) const; std::optional> MeasureSizeInBytes( @@ -295,11 +295,11 @@ struct Procedure { bool operator==(const Procedure &) const; bool operator!=(const Procedure &that) const { return !(*this == that); } - // Characterizes the procedure represented by a symbol, which may be an + // Characterizes a procedure. If a Symbol, it may be an // "unrestricted specific intrinsic function". + // Error messages are produced when a procedure cannot be characterized. static std::optional Characterize( const semantics::Symbol &, FoldingContext &); - // This function is the initial point of entry for characterizing procedure static std::optional Characterize( const ProcedureDesignator &, FoldingContext &); static std::optional Characterize( diff --git a/flang/include/flang/Evaluate/expression.h b/flang/include/flang/Evaluate/expression.h index 8fdeb45024d8fe..1c6251b562759e 100644 --- a/flang/include/flang/Evaluate/expression.h +++ b/flang/include/flang/Evaluate/expression.h @@ -26,6 +26,7 @@ #include "flang/Common/indirection.h" #include "flang/Common/template.h" #include "flang/Parser/char-block.h" +#include "llvm/Support/Compiler.h" #include #include #include @@ -93,6 +94,7 @@ template class ExpressionBase { std::optional GetType() const; int Rank() const; std::string AsFortran() const; + LLVM_DUMP_METHOD void dump() const; llvm::raw_ostream &AsFortran(llvm::raw_ostream &) const; static Derived Rewrite(FoldingContext &, Derived &&); }; @@ -129,8 +131,8 @@ class Operation { public: CLASS_BOILERPLATE(Operation) - explicit Operation(const Expr &...x) : operand_{x...} {} - explicit Operation(Expr &&...x) : operand_{std::move(x)...} {} + explicit Operation(const Expr &... x) : operand_{x...} {} + explicit Operation(Expr &&... x) : operand_{std::move(x)...} {} Derived &derived() { return *static_cast(this); } const Derived &derived() const { return *static_cast(this); } diff --git a/flang/include/flang/Evaluate/fold.h b/flang/include/flang/Evaluate/fold.h index 3a2258dfc1105e..e7081a06dddb25 100644 --- a/flang/include/flang/Evaluate/fold.h +++ b/flang/include/flang/Evaluate/fold.h @@ -69,7 +69,8 @@ auto UnwrapConstantValue(EXPR &expr) -> common::Constify, EXPR> * { // GetScalarConstantValue() extracts the known scalar constant value of // an expression, if it has one. The value can be parenthesized. template -auto GetScalarConstantValue(const EXPR &expr) -> std::optional> { +constexpr auto GetScalarConstantValue(const EXPR &expr) + -> std::optional> { if (const Constant *constant{UnwrapConstantValue(expr)}) { return constant->GetScalarValue(); } else { @@ -81,7 +82,7 @@ auto GetScalarConstantValue(const EXPR &expr) -> std::optional> { // Ensure that the expression has been folded beforehand when folding might // be required. template -std::optional ToInt64( +constexpr std::optional ToInt64( const Expr> &expr) { if (auto scalar{ GetScalarConstantValue>(expr)}) { diff --git a/flang/include/flang/Evaluate/initial-image.h b/flang/include/flang/Evaluate/initial-image.h index c2cf12e377e056..596b1f77d17900 100644 --- a/flang/include/flang/Evaluate/initial-image.h +++ b/flang/include/flang/Evaluate/initial-image.h @@ -30,6 +30,7 @@ class InitialImage { }; explicit InitialImage(std::size_t bytes) : data_(bytes) {} + InitialImage(InitialImage &&that) = default; std::size_t size() const { return data_.size(); } @@ -93,19 +94,17 @@ class InitialImage { void AddPointer(ConstantSubscript, const Expr &); - void Incorporate(ConstantSubscript, const InitialImage &); + void Incorporate(ConstantSubscript toOffset, const InitialImage &from, + ConstantSubscript fromOffset, ConstantSubscript bytes); // Conversions to constant initializers std::optional> AsConstant(FoldingContext &, const DynamicType &, const ConstantSubscripts &, ConstantSubscript offset = 0) const; - std::optional> AsConstantDataPointer( - const DynamicType &, ConstantSubscript offset = 0) const; - const ProcedureDesignator &AsConstantProcPointer( + std::optional> AsConstantPointer( ConstantSubscript offset = 0) const; friend class AsConstantHelper; - friend class AsConstantDataPointerHelper; private: std::vector data_; diff --git a/flang/include/flang/Evaluate/integer.h b/flang/include/flang/Evaluate/integer.h index 35b42239ca751f..6a129bf62c19d6 100644 --- a/flang/include/flang/Evaluate/integer.h +++ b/flang/include/flang/Evaluate/integer.h @@ -358,6 +358,7 @@ class Integer { static constexpr int DIGITS{bits - 1}; // don't count the sign bit static constexpr Integer HUGE() { return MASKR(bits - 1); } + static constexpr Integer Least() { return MASKL(1); } static constexpr int RANGE{// in the sense of SELECTED_INT_KIND // This magic value is LOG10(2.)*1E12. static_cast(((bits - 1) * 301029995664) / 1000000000000)}; diff --git a/flang/runtime/pgmath.h.inc b/flang/include/flang/Evaluate/pgmath.h.inc similarity index 68% rename from flang/runtime/pgmath.h.inc rename to flang/include/flang/Evaluate/pgmath.h.inc index 4985005bb68bfb..51c81ebf004ecf 100644 --- a/flang/runtime/pgmath.h.inc +++ b/flang/include/flang/Evaluate/pgmath.h.inc @@ -1,4 +1,4 @@ -//===-- runtime/pgmath.h.inc -------------------------------===// +//===-- include/flang/Evaluate/pgmath.h.inc -------------------------------===// // // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. // See https://llvm.org/LICENSE.txt for license information. @@ -22,6 +22,7 @@ // Control Macros #ifdef PGMATH_DECLARE #undef PGMATH_DECLARE +#define DEFINE_C_COMPLEX_TYPES #define PGMATH_DECLARE(x) extern "C" x; #define PGMATH_FAST #define PGMATH_PRECISE @@ -33,6 +34,8 @@ #ifdef PGMATH_USE_ALL_TYPES #define PGMATH_USE_S(name, func) PGMATH_USE_ALL_TYPES(name, func) #define PGMATH_USE_D(name, func) PGMATH_USE_ALL_TYPES(name, func) +#define PGMATH_USE_C(name, func) PGMATH_USE_ALL_TYPES(name, func) +#define PGMATH_USE_Z(name, func) PGMATH_USE_ALL_TYPES(name, func) #define PGMATH_USE_OTHER(name, func) PGMATH_USE_ALL_TYPES(name, func) #endif @@ -56,14 +59,53 @@ #define PGMATH_USE_OTHER(name, x) #endif +// Handle the C99 _Complex vs C++ std::complex call interface issue. +// _Complex and std::complex are layout compatible (they are the same when +// in memory), but they are not guaranteed to be compatible in call interface +// (they may be passed/returned differently). For instance on X86 32 bits, +// float _complex is returned in a pair of register, but std::complex +// is returned in memory. +// Pgmath is defined in C using _Complex (and windows _Fcomplex/_DComplex +// equivalents). Since this file defines the call interface with the runtime +// for both folding and code generation (through template introspection), it +// is crucial to make a difference between std::complex and _Complex here. +// Unfortunately, _Complex support is not standard in C++. +// Reserve pgmath usage at compile time (folding) when _Complex is available +// (cmake is responsible to detect this). +// For code generation, define type c_float_complex_t that can be used in +// introspection to indicate that the C99 _Complex ABI has to be used for the +// related value. +#ifdef DEFINE_C_COMPLEX_TYPES +#ifdef PGMATH_LINKING +#ifdef _WIN32 +using c_float_complex_t = _Fcomplex; +using c_double_complex_t = _Dcomplex; +#else +using c_float_complex_t = float _Complex; +using c_double_complex_t = double _Complex; +#endif +#else +struct c_float_complex_t {}; +struct c_double_complex_t {}; +#endif +#endif + #define PGMATH_REAL_IMPL(impl, func) \ PGMATH_DECLARE(float __##impl##s_##func##_1(float)) \ PGMATH_DECLARE(double __##impl##d_##func##_1(double)) \ PGMATH_USE_S(func, __##impl##s_##func##_1) \ PGMATH_USE_D(func, __##impl##d_##func##_1) +#define PGMATH_COMPLEX_IMPL(impl, func) \ + PGMATH_DECLARE(c_float_complex_t __##impl##c_##func##_1(c_float_complex_t)) \ + PGMATH_DECLARE( \ + c_double_complex_t __##impl##z_##func##_1(c_double_complex_t)) \ + PGMATH_USE_C(func, __##impl##c_##func##_1) \ + PGMATH_USE_Z(func, __##impl##z_##func##_1) + #define PGMATH_ALL_FP_IMPL(impl, func) \ PGMATH_REAL_IMPL(impl, func) \ + PGMATH_FAST_COMPLEX_IMPL(impl, func) #define PGMATH_REAL2_IMPL(impl, func) \ PGMATH_DECLARE(float __##impl##s_##func##_1(float, float)) \ @@ -71,8 +113,17 @@ PGMATH_USE_S(func, __##impl##s_##func##_1) \ PGMATH_USE_D(func, __##impl##d_##func##_1) +#define PGMATH_COMPLEX2_IMPL(impl, func) \ + PGMATH_DECLARE(c_float_complex_t __##impl##c_##func##_1( \ + c_float_complex_t, c_float_complex_t)) \ + PGMATH_DECLARE(c_double_complex_t __##impl##z_##func##_1( \ + c_double_complex_t, c_double_complex_t)) \ + PGMATH_USE_C(func, __##impl##c_##func##_1) \ + PGMATH_USE_Z(func, __##impl##z_##func##_1) + #define PGMATH_ALL_FP2_IMPL(impl, func) \ PGMATH_REAL2_IMPL(func) \ + PGMATH_COMPLEX2_IMPL(func) #undef PGMATH_FAST_REAL #undef PGMATH_FAST_COMPLEX @@ -82,8 +133,10 @@ #undef PGMATH_FAST_ALL_FP2 #ifdef PGMATH_FAST #define PGMATH_FAST_REAL(func) PGMATH_REAL_IMPL(f, func) +#define PGMATH_FAST_COMPLEX(func) PGMATH_COMPLEX_IMPL(f, func) #define PGMATH_FAST_ALL_FP(func) PGMATH_ALL_IMPL(f, func) #define PGMATH_FAST_REAL2(func) PGMATH_REAL2_IMPL(f, func) +#define PGMATH_FAST_COMPLEX2(func) PGMATH_COMPLEX2_IMPL(f, func) #define PGMATH_FAST_ALL_FP2(func) PGMATH_ALL_FP2_IMPL(f, func) #else #define PGMATH_FAST_REAL(func) @@ -102,8 +155,10 @@ #undef PGMATH_RELAXED_ALL_FP2 #ifdef PGMATH_RELAXED #define PGMATH_RELAXED_REAL(func) PGMATH_REAL_IMPL(r, func) +#define PGMATH_RELAXED_COMPLEX(func) PGMATH_COMPLEX_IMPL(r, func) #define PGMATH_RELAXED_ALL_FP(func) PGMATH_ALL_IMPL(r, func) #define PGMATH_RELAXED_REAL2(func) PGMATH_REAL2_IMPL(r, func) +#define PGMATH_RELAXED_COMPLEX2(func) PGMATH_COMPLEX2_IMPL(r, func) #define PGMATH_RELAXED_ALL_FP2(func) PGMATH_ALL_FP2_IMPL(r, func) #else #define PGMATH_RELAXED_REAL(func) @@ -122,8 +177,10 @@ #undef PGMATH_PRECISE_ALL_FP2 #ifdef PGMATH_PRECISE #define PGMATH_PRECISE_REAL(func) PGMATH_REAL_IMPL(p, func) +#define PGMATH_PRECISE_COMPLEX(func) PGMATH_COMPLEX_IMPL(p, func) #define PGMATH_PRECISE_ALL_FP(func) PGMATH_ALL_IMPL(p, func) #define PGMATH_PRECISE_REAL2(func) PGMATH_REAL2_IMPL(p, func) +#define PGMATH_PRECISE_COMPLEX2(func) PGMATH_COMPLEX2_IMPL(p, func) #define PGMATH_PRECISE_ALL_FP2(func) PGMATH_ALL_FP2_IMPL(p, func) #else #define PGMATH_PRECISE_REAL(func) @@ -139,16 +196,28 @@ PGMATH_PRECISE_REAL(func) \ PGMATH_RELAXED_REAL(func) +#define PGMATH_COMPLEX(func) \ + PGMATH_FAST_COMPLEX(func) \ + PGMATH_PRECISE_COMPLEX(func) \ + PGMATH_RELAXED_COMPLEX(func) + #define PGMATH_ALL(func) \ PGMATH_REAL(func) \ + PGMATH_COMPLEX(func) #define PGMATH_REAL2(func) \ PGMATH_FAST_REAL2(func) \ PGMATH_PRECISE_REAL2(func) \ PGMATH_RELAXED_REAL2(func) +#define PGMATH_COMPLEX2(func) \ + PGMATH_FAST_COMPLEX2(func) \ + PGMATH_PRECISE_COMPLEX2(func) \ + PGMATH_RELAXED_COMPLEX2(func) + #define PGMATH_ALL2(func) \ PGMATH_REAL2(func) \ + PGMATH_COMPLEX2(func) // Marcos to declare __mth_i libpgmath variants #define PGMATH_MTH_VERSION_REAL(func) \ @@ -207,12 +276,19 @@ PGMATH_ALL2(pow) #define PGMATH_DELCARE_POW(impl) \ PGMATH_DECLARE(float __##impl##s_powi_1(float, int)) \ PGMATH_DECLARE(double __##impl##d_powi_1(double, int)) \ + PGMATH_DECLARE(c_float_complex_t __##impl##c_powi_1(c_float_complex_t, int)) \ + PGMATH_DECLARE( \ + c_double_complex_t __##impl##z_powi_1(c_double_complex_t, int)) \ PGMATH_USE_S(pow, __##impl##s_powi_1) \ PGMATH_USE_D(pow, __##impl##d_powi_1) \ PGMATH_USE_C(pow, __##impl##c_powi_1) \ PGMATH_USE_Z(pow, __##impl##z_powi_1) \ PGMATH_DECLARE(float __##impl##s_powk_1(float, int64_t)) \ PGMATH_DECLARE(double __##impl##d_powk_1(double, int64_t)) \ + PGMATH_DECLARE( \ + c_float_complex_t __##impl##c_powk_1(c_float_complex_t, int64_t)) \ + PGMATH_DECLARE( \ + c_double_complex_t __##impl##z_powk_1(c_double_complex_t, int64_t)) \ PGMATH_USE_S(pow, __##impl##s_powk_1) \ PGMATH_USE_D(pow, __##impl##d_powk_1) \ PGMATH_USE_C(pow, __##impl##c_powk_1) \ @@ -237,6 +313,7 @@ PGMATH_USE_OTHER(pow, __mth_i_kpowk) PGMATH_ALL(sin) PGMATH_ALL(sinh) PGMATH_MTH_VERSION_REAL(sqrt) +PGMATH_COMPLEX(sqrt) // real versions are __mth_i... PGMATH_ALL(tan) PGMATH_ALL(tanh) @@ -250,3 +327,5 @@ PGMATH_ALL(tanh) #undef PGMATH_USE_Z #undef PGMATH_USE_OTHER #undef PGMATH_USE_ALL_TYPES +#undef PGMATH_LINKING +#undef DEFINE_C_COMPLEX_TYPES diff --git a/flang/include/flang/Evaluate/real.h b/flang/include/flang/Evaluate/real.h index 85928e8d1f8eae..9cd6f8305bd5cd 100644 --- a/flang/include/flang/Evaluate/real.h +++ b/flang/include/flang/Evaluate/real.h @@ -55,6 +55,7 @@ class Real : public common::RealDetails { constexpr Real() {} // +0.0 constexpr Real(const Real &) = default; + constexpr Real(Real &&) = default; constexpr Real(const Word &bits) : word_{bits} {} constexpr Real &operator=(const Real &) = default; constexpr Real &operator=(Real &&) = default; diff --git a/flang/include/flang/Evaluate/shape.h b/flang/include/flang/Evaluate/shape.h index 507a710f380c67..4f5a06ccd3712f 100644 --- a/flang/include/flang/Evaluate/shape.h +++ b/flang/include/flang/Evaluate/shape.h @@ -48,6 +48,8 @@ Constant AsConstantShape(const ConstantSubscripts &); ConstantSubscripts AsConstantExtents(const Constant &); std::optional AsConstantExtents( FoldingContext &, const Shape &); +Shape AsShape(const ConstantSubscripts &); +std::optional AsShape(const std::optional &); inline int GetRank(const Shape &s) { return static_cast(s.size()); } @@ -89,6 +91,7 @@ MaybeExtentExpr CountTrips( // Computes SIZE() == PRODUCT(shape) MaybeExtentExpr GetSize(Shape &&); +ConstantSubscript GetSize(const ConstantSubscripts &); // Utility predicate: does an expression reference any implied DO index? bool ContainsAnyImpliedDoIndex(const ExtentExpr &); @@ -239,12 +242,30 @@ std::optional GetConstantExtents( } // Compilation-time shape conformance checking, when corresponding extents -// are known. -bool CheckConformance(parser::ContextualMessages &, const Shape &left, - const Shape &right, const char *leftIs = "left operand", - const char *rightIs = "right operand", bool leftScalarExpandable = true, - bool rightScalarExpandable = true, bool leftIsDeferredShape = false, - bool rightIsDeferredShape = false); +// are or should be known. The result is an optional Boolean: +// - nullopt: no error found or reported, but conformance cannot +// be guaranteed during compilation; this result is possible only +// when one or both arrays are allowed to have deferred shape +// - true: no error found or reported, arrays conform +// - false: errors found and reported +// Use "CheckConformance(...).value_or()" to specify a default result +// when you don't care whether messages have been emitted. +struct CheckConformanceFlags { + enum Flags { + None = 0, + LeftScalarExpandable = 1, + RightScalarExpandable = 2, + LeftIsDeferredShape = 4, + RightIsDeferredShape = 8, + EitherScalarExpandable = LeftScalarExpandable | RightScalarExpandable, + BothDeferredShape = LeftIsDeferredShape | RightIsDeferredShape, + RightIsExpandableDeferred = RightScalarExpandable | RightIsDeferredShape, + }; +}; +std::optional CheckConformance(parser::ContextualMessages &, + const Shape &left, const Shape &right, + CheckConformanceFlags::Flags flags = CheckConformanceFlags::None, + const char *leftIs = "left operand", const char *rightIs = "right operand"); // Increments one-based subscripts in element order (first varies fastest) // and returns true when they remain in range; resets them all to one and diff --git a/flang/include/flang/Evaluate/tools.h b/flang/include/flang/Evaluate/tools.h index 6adfe043a26c2a..a70f5f2b2f8475 100644 --- a/flang/include/flang/Evaluate/tools.h +++ b/flang/include/flang/Evaluate/tools.h @@ -460,6 +460,10 @@ template Expr ConvertToType(BOZLiteralConstant &&x) { } } +template bool IsBOZLiteral(const Expr &expr) { + return std::holds_alternative(expr.u); +} + // Conversions to dynamic types std::optional> ConvertToType( const DynamicType &, Expr &&); @@ -644,6 +648,16 @@ std::optional> Negation( std::optional> Relate(parser::ContextualMessages &, RelationalOperator, Expr &&, Expr &&); +// Create a relational operation between two identically-typed operands +// and wrap it up in an Expr. +template +Expr PackageRelation( + RelationalOperator opr, Expr &&x, Expr &&y) { + static_assert(IsSpecificIntrinsicType); + return Expr{ + Relational{Relational{opr, std::move(x), std::move(y)}}}; +} + template Expr> LogicalNegation( Expr> &&x) { @@ -978,6 +992,23 @@ class ScalarConstantExpander { std::optional lbounds_; }; +// Given a collection of element values, package them as a Constant. +// If the type is Character or a derived type, take the length or type +// (resp.) from a another Constant. +template +Constant PackageConstant(std::vector> &&elements, + const Constant &reference, const ConstantSubscripts &shape) { + if constexpr (T::category == TypeCategory::Character) { + return Constant{ + reference.LEN(), std::move(elements), ConstantSubscripts{shape}}; + } else if constexpr (T::category == TypeCategory::Derived) { + return Constant{reference.GetType().GetDerivedTypeSpec(), + std::move(elements), ConstantSubscripts{shape}}; + } else { + return Constant{std::move(elements), ConstantSubscripts{shape}}; + } +} + } // namespace Fortran::evaluate namespace Fortran::semantics { diff --git a/flang/include/flang/Evaluate/type.h b/flang/include/flang/Evaluate/type.h index f2d84b6d819dd7..a57d8107b7e331 100644 --- a/flang/include/flang/Evaluate/type.h +++ b/flang/include/flang/Evaluate/type.h @@ -81,15 +81,16 @@ static constexpr bool IsValidKindOfIntrinsicType( // directly hold anything requiring a destructor, such as an arbitrary // CHARACTER length type parameter expression. Those must be derived // via LEN() member functions, packaged elsewhere (e.g. as in -// ArrayConstructor), or copied from a parameter spec in the symbol table -// if one is supplied. +// ArrayConstructor), copied from a parameter spec in the symbol table +// if one is supplied, or a known integer value. class DynamicType { public: constexpr DynamicType(TypeCategory cat, int k) : category_{cat}, kind_{k} { CHECK(IsValidKindOfIntrinsicType(category_, kind_)); } - constexpr DynamicType(int k, const semantics::ParamValue &pv) - : category_{TypeCategory::Character}, kind_{k}, charLength_{&pv} { + DynamicType(int charKind, const semantics::ParamValue &len); + constexpr DynamicType(int k, std::int64_t len) + : category_{TypeCategory::Character}, kind_{k}, knownLength_{len} { CHECK(IsValidKindOfIntrinsicType(category_, kind_)); } explicit constexpr DynamicType( @@ -137,8 +138,16 @@ class DynamicType { CHECK(kind_ > 0); return kind_; } - constexpr const semantics::ParamValue *charLength() const { - return charLength_; + constexpr const semantics::ParamValue *charLengthParamValue() const { + return charLengthParamValue_; + } + constexpr std::optional knownLength() const { +#if defined(_GLIBCXX_RELEASE) && _GLIBCXX_RELEASE == 7 + if (knownLength_ < 0) { + return std::nullopt; + } +#endif + return knownLength_; } std::optional> GetCharLength() const; @@ -212,7 +221,13 @@ class DynamicType { TypeCategory category_{TypeCategory::Derived}; // overridable default int kind_{0}; - const semantics::ParamValue *charLength_{nullptr}; + const semantics::ParamValue *charLengthParamValue_{nullptr}; +#if defined(_GLIBCXX_RELEASE) && _GLIBCXX_RELEASE == 7 + // GCC 7's optional<> lacks a constexpr operator= + std::int64_t knownLength_{-1}; +#else + std::optional knownLength_; +#endif const semantics::DerivedTypeSpec *derived_{nullptr}; // TYPE(T), CLASS(T) }; diff --git a/flang/include/flang/Lower/.clang-tidy b/flang/include/flang/Lower/.clang-tidy index 87ec2ff53af6e8..9cc942b8870a2e 100644 --- a/flang/include/flang/Lower/.clang-tidy +++ b/flang/include/flang/Lower/.clang-tidy @@ -1,5 +1,5 @@ -# Almost identical to the top-level .clang-tidy, except that {Member,Parameter,Variable}Case use camelBack. -Checks: '-*,clang-diagnostic-*,llvm-*,misc-*,-misc-unused-parameters,-misc-non-private-member-variables-in-classes,readability-identifier-naming' +Checks: '-readability-braces-around-statements,readability-identifier-naming,llvm-include-order,clang-diagnostic-*' +InheritParentConfig: true CheckOptions: - key: readability-identifier-naming.ClassCase value: CamelCase diff --git a/flang/include/flang/Lower/AbstractConverter.h b/flang/include/flang/Lower/AbstractConverter.h index 4fcf0f5cd3cc8e..42e350e9d3f6d7 100644 --- a/flang/include/flang/Lower/AbstractConverter.h +++ b/flang/include/flang/Lower/AbstractConverter.h @@ -5,20 +5,31 @@ // SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception // //===----------------------------------------------------------------------===// +// +// Coding style: https://mlir.llvm.org/getting_started/DeveloperGuide/ +// +//===----------------------------------------------------------------------===// #ifndef FORTRAN_LOWER_ABSTRACTCONVERTER_H #define FORTRAN_LOWER_ABSTRACTCONVERTER_H #include "flang/Common/Fortran.h" +#include "flang/Lower/PFTDefs.h" +#include "flang/Optimizer/Builder/BoxValue.h" #include "mlir/IR/BuiltinOps.h" +#include "llvm/ADT/ArrayRef.h" +namespace fir { +class KindMapping; +class FirOpBuilder; +} // namespace fir namespace Fortran { namespace common { template class Reference; } + namespace evaluate { -struct DataRef; template class Expr; class FoldingContext; @@ -30,7 +41,8 @@ class CharBlock; } namespace semantics { class Symbol; -} +class DerivedTypeSpec; +} // namespace semantics namespace lower { namespace pft { @@ -39,7 +51,7 @@ struct Variable; using SomeExpr = Fortran::evaluate::Expr; using SymbolRef = Fortran::common::Reference; -class FirOpBuilder; +class StatementContext; //===----------------------------------------------------------------------===// // AbstractConverter interface @@ -57,44 +69,97 @@ class AbstractConverter { /// Get the mlir instance of a symbol. virtual mlir::Value getSymbolAddress(SymbolRef sym) = 0; + /// Get the binding of an implied do variable by name. + virtual mlir::Value impliedDoBinding(llvm::StringRef name) = 0; + + /// Copy the binding of src to target symbol. + virtual void copySymbolBinding(SymbolRef src, SymbolRef target) = 0; + + /// Binds the symbol to an fir extended value and returns true if the symbol + /// has no existing binding. If there is an existing binding this function + /// does nothing and returns false. + virtual bool bindSymbol(const SymbolRef sym, + const fir::ExtendedValue &exval) = 0; + + /// Get the label set associated with a symbol. + virtual bool lookupLabelSet(SymbolRef sym, pft::LabelSet &labelSet) = 0; + + /// Get the code defined by a label + virtual pft::Evaluation *lookupLabel(pft::Label label) = 0; + + /// For a give symbol which is host-associated, create a clone using + /// parameters from the host-associated symbol. + virtual bool + createHostAssociateVarClone(const Fortran::semantics::Symbol &sym) = 0; + //===--------------------------------------------------------------------===// // Expressions //===--------------------------------------------------------------------===// + /// Generate the address of the location holding the expression, someExpr. + /// If SomeExpr is a Designator that is not compile time contiguous, the + /// address returned is the one of a contiguous temporary storage holding the + /// expression value. The clean-up for this temporary is added to the + /// StatementContext. + virtual fir::ExtendedValue genExprAddr(const SomeExpr &, StatementContext &, + mlir::Location *loc = nullptr) = 0; /// Generate the address of the location holding the expression, someExpr - virtual mlir::Value genExprAddr(const SomeExpr &, - mlir::Location *loc = nullptr) = 0; - /// Generate the address of the location holding the expression, someExpr - mlir::Value genExprAddr(const SomeExpr *someExpr, mlir::Location loc) { - return genExprAddr(*someExpr, &loc); + fir::ExtendedValue genExprAddr(const SomeExpr *someExpr, + StatementContext &stmtCtx, + mlir::Location loc) { + return genExprAddr(*someExpr, stmtCtx, &loc); } /// Generate the computations of the expression to produce a value - virtual mlir::Value genExprValue(const SomeExpr &, - mlir::Location *loc = nullptr) = 0; + virtual fir::ExtendedValue genExprValue(const SomeExpr &, StatementContext &, + mlir::Location *loc = nullptr) = 0; /// Generate the computations of the expression, someExpr, to produce a value - mlir::Value genExprValue(const SomeExpr *someExpr, mlir::Location loc) { - return genExprValue(*someExpr, &loc); + fir::ExtendedValue genExprValue(const SomeExpr *someExpr, + StatementContext &stmtCtx, + mlir::Location loc) { + return genExprValue(*someExpr, stmtCtx, &loc); } + /// Generate or get a fir.box describing the expression. If SomeExpr is + /// a Designator, the fir.box describes an entity over the Designator base + /// storage without making a temporary. + virtual fir::ExtendedValue genExprBox(const SomeExpr &, StatementContext &, + mlir::Location) = 0; + + /// Generate the address of the box describing the variable designated + /// by the expression. The expression must be an allocatable or pointer + /// designator. + virtual fir::MutableBoxValue genExprMutableBox(mlir::Location loc, + const SomeExpr &) = 0; + /// Get FoldingContext that is required for some expression /// analysis. virtual Fortran::evaluate::FoldingContext &getFoldingContext() = 0; + /// Host associated variables are grouped as a tuple. This returns that value, + /// which is itself a reference. Use bindTuple() to set this value. + virtual mlir::Value hostAssocTupleValue() = 0; + + /// Record a binding for the ssa-value of the host assoications tuple for this + /// function. + virtual void bindHostAssocTuple(mlir::Value val) = 0; + //===--------------------------------------------------------------------===// // Types //===--------------------------------------------------------------------===// - /// Generate the type of a DataRef - virtual mlir::Type genType(const Fortran::evaluate::DataRef &) = 0; /// Generate the type of an Expr virtual mlir::Type genType(const SomeExpr &) = 0; /// Generate the type of a Symbol virtual mlir::Type genType(SymbolRef) = 0; /// Generate the type from a category virtual mlir::Type genType(Fortran::common::TypeCategory tc) = 0; - /// Generate the type from a category and kind - virtual mlir::Type genType(Fortran::common::TypeCategory tc, int kind) = 0; + /// Generate the type from a category and kind and length parameters. + virtual mlir::Type + genType(Fortran::common::TypeCategory tc, int kind, + llvm::ArrayRef lenParameters = llvm::None) = 0; + /// Generate the type from a DerivedTypeSpec. + virtual mlir::Type genType(const Fortran::semantics::DerivedTypeSpec &) = 0; /// Generate the type from a Variable virtual mlir::Type genType(const pft::Variable &) = 0; @@ -114,17 +179,15 @@ class AbstractConverter { //===--------------------------------------------------------------------===// /// Get the OpBuilder - virtual Fortran::lower::FirOpBuilder &getFirOpBuilder() = 0; + virtual fir::FirOpBuilder &getFirOpBuilder() = 0; /// Get the ModuleOp virtual mlir::ModuleOp &getModuleOp() = 0; /// Get the MLIRContext virtual mlir::MLIRContext &getMLIRContext() = 0; /// Unique a symbol virtual std::string mangleName(const Fortran::semantics::Symbol &) = 0; - /// Unique a compiler generated identifier. A short prefix should be provided - /// to hint at the origin of the identifier. - virtual std::string uniqueCGIdent(llvm::StringRef prefix, - llvm::StringRef name) = 0; + /// Get the KindMap. + virtual fir::KindMapping &getKindMap() = 0; virtual ~AbstractConverter() = default; }; diff --git a/flang/include/flang/Lower/Allocatable.h b/flang/include/flang/Lower/Allocatable.h new file mode 100644 index 00000000000000..4fd73ed8ce2ae7 --- /dev/null +++ b/flang/include/flang/Lower/Allocatable.h @@ -0,0 +1,80 @@ +//===-- Allocatable.h -- Allocatable statements lowering ------------------===// +// +// 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 +// +//===----------------------------------------------------------------------===// +// +// Coding style: https://mlir.llvm.org/getting_started/DeveloperGuide/ +// +//===----------------------------------------------------------------------===// + +#ifndef FORTRAN_LOWER_ALLOCATABLE_H +#define FORTRAN_LOWER_ALLOCATABLE_H + +#include "flang/Optimizer/Builder/MutableBox.h" +#include "llvm/ADT/StringRef.h" + +namespace mlir { +class Value; +class ValueRange; +class Location; +} // namespace mlir + +namespace fir { +class MutableBoxValue; +class ExtendedValue; +class FirOpBuilder; +} // namespace fir + +namespace Fortran::parser { +struct AllocateStmt; +struct DeallocateStmt; +} // namespace Fortran::parser + +namespace Fortran::evaluate { +template +class Expr; +struct SomeType; +} // namespace Fortran::evaluate + +namespace Fortran::lower { +struct SymbolBox; +class AbstractConverter; +class StatementContext; + +namespace pft { +struct Variable; +} + +/// Lower an allocate statement to fir. +void genAllocateStmt(Fortran::lower::AbstractConverter &, + const Fortran::parser::AllocateStmt &, mlir::Location); + +/// Lower a deallocate statement to fir. +void genDeallocateStmt(Fortran::lower::AbstractConverter &, + const Fortran::parser::DeallocateStmt &, mlir::Location); + +/// Create a MutableBoxValue for an allocatable or pointer entity. +/// If the variables is a local variable that is not a dummy, it will be +/// initialized to unallocated/diassociated status. +fir::MutableBoxValue createMutableBox(Fortran::lower::AbstractConverter &, + mlir::Location, + const Fortran::lower::pft::Variable &var, + mlir::Value boxAddr, + mlir::ValueRange nonDeferredParams); + +/// Update a MutableBoxValue to describe the entity designated by the expression +/// \p source. This version takes care of \p source lowering. +/// If \lbounds is not empty, it is used to defined the MutableBoxValue +/// lower bounds, otherwise, the lower bounds from \p source are used. +void associateMutableBox( + Fortran::lower::AbstractConverter &, mlir::Location, + const fir::MutableBoxValue &, + const Fortran::evaluate::Expr &source, + mlir::ValueRange lbounds, Fortran::lower::StatementContext &); + +} // namespace Fortran::lower + +#endif // FORTRAN_LOWER_ALLOCATABLE_H diff --git a/flang/include/flang/Lower/Bridge.h b/flang/include/flang/Lower/Bridge.h index 28ce992fb49a5f..ef27096921a45b 100644 --- a/flang/include/flang/Lower/Bridge.h +++ b/flang/include/flang/Lower/Bridge.h @@ -5,13 +5,9 @@ // SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception // //===----------------------------------------------------------------------===// -/// -/// \file -/// Implements lowering. Convert Fortran source to -/// [MLIR](https://github.com/tensorflow/mlir). -/// -/// [Coding style](https://llvm.org/docs/CodingStandards.html) -/// +// +// Coding style: https://mlir.llvm.org/getting_started/DeveloperGuide/ +// //===----------------------------------------------------------------------===// #ifndef FORTRAN_LOWER_BRIDGE_H @@ -49,17 +45,20 @@ class LoweringBridge { public: /// Create a lowering bridge instance. static LoweringBridge - create(const Fortran::common::IntrinsicTypeDefaultKinds &defaultKinds, + create(mlir::MLIRContext &ctx, + const Fortran::common::IntrinsicTypeDefaultKinds &defaultKinds, const Fortran::evaluate::IntrinsicProcTable &intrinsics, - const Fortran::parser::AllCookedSources &allCooked) { - return LoweringBridge{defaultKinds, intrinsics, allCooked}; + const Fortran::parser::AllCookedSources &allCooked, + llvm::StringRef triple, fir::KindMapping &kindMap) { + return LoweringBridge(ctx, defaultKinds, intrinsics, allCooked, triple, + kindMap); } //===--------------------------------------------------------------------===// // Getters //===--------------------------------------------------------------------===// - mlir::MLIRContext &getMLIRContext() { return *context.get(); } + mlir::MLIRContext &getMLIRContext() { return context; } mlir::ModuleOp &getModule() { return *module.get(); } const Fortran::common::IntrinsicTypeDefaultKinds &getDefaultKinds() const { return defaultKinds; @@ -91,20 +90,24 @@ class LoweringBridge { void lower(const Fortran::parser::Program &program, const Fortran::semantics::SemanticsContext &semanticsContext); + fir::KindMapping &getKindMap() { return kindMap; } + private: explicit LoweringBridge( + mlir::MLIRContext &ctx, const Fortran::common::IntrinsicTypeDefaultKinds &defaultKinds, const Fortran::evaluate::IntrinsicProcTable &intrinsics, - const Fortran::parser::AllCookedSources &); + const Fortran::parser::AllCookedSources &cooked, llvm::StringRef triple, + fir::KindMapping &kindMap); LoweringBridge() = delete; LoweringBridge(const LoweringBridge &) = delete; const Fortran::common::IntrinsicTypeDefaultKinds &defaultKinds; const Fortran::evaluate::IntrinsicProcTable &intrinsics; const Fortran::parser::AllCookedSources *cooked; - std::unique_ptr context; + mlir::MLIRContext &context; std::unique_ptr module; - fir::KindMapping kindMap; + fir::KindMapping &kindMap; }; } // namespace lower diff --git a/flang/include/flang/Lower/CallInterface.h b/flang/include/flang/Lower/CallInterface.h new file mode 100644 index 00000000000000..78a99219d8bb8e --- /dev/null +++ b/flang/include/flang/Lower/CallInterface.h @@ -0,0 +1,391 @@ +//===-- Lower/CallInterface.h -- Procedure call interface ------*- C++ -*-===// +// +// 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 +// +//===----------------------------------------------------------------------===// +// +// Coding style: https://mlir.llvm.org/getting_started/DeveloperGuide/ +// +//===----------------------------------------------------------------------===// +// +// Utility that defines fir call interface for procedure both on caller and +// and callee side and get the related FuncOp. +// It does not emit any FIR code but for the created mlir::FuncOp, instead it +// provides back a container of Symbol (callee side)/ActualArgument (caller +// side) with additional information for each element describing how it must be +// plugged with the mlir::FuncOp. +// It handles the fact that hidden arguments may be inserted for the result. +// while lowering. +// +// This utility uses the characteristic of Fortran procedures to operate, which +// is a term and concept used in Fortran to refer to the signature of a function +// or subroutine. +//===----------------------------------------------------------------------===// + +#ifndef FORTRAN_LOWER_CALLINTERFACE_H +#define FORTRAN_LOWER_CALLINTERFACE_H + +#include "flang/Common/reference.h" +#include "flang/Evaluate/characteristics.h" +#include "mlir/IR/BuiltinOps.h" +#include +#include + +namespace Fortran::semantics { +class Symbol; +} + +namespace mlir { +class Location; +} + +namespace Fortran::lower { +class AbstractConverter; +class SymMap; +class HostAssociations; +namespace pft { +struct FunctionLikeUnit; +} + +/// PassedEntityTypes helps abstract whether CallInterface is mapping a +/// Symbol to mlir::Value (callee side) or an ActualArgument to a position +/// inside the input vector for the CallOp (caller side. It will be up to the +/// CallInterface user to produce the mlir::Value that will go in this input +/// vector). +class CallerInterface; +class CalleeInterface; +template +struct PassedEntityTypes {}; +template <> +struct PassedEntityTypes { + using FortranEntity = const Fortran::evaluate::ActualArgument *; + using FirValue = int; +}; +template <> +struct PassedEntityTypes { + using FortranEntity = + std::optional>; + using FirValue = mlir::Value; +}; + +/// Implementation helper +template +class CallInterfaceImpl; + +/// CallInterface defines all the logic to determine FIR function interfaces +/// from a characteristic, build the mlir::FuncOp and describe back the argument +/// mapping to its user. +/// The logic is shared between the callee and caller sides that it accepts as +/// a curiously recursive template to handle the few things that cannot be +/// shared between both sides (getting characteristics, mangled name, location). +/// It maps FIR arguments to front-end Symbol (callee side) or ActualArgument +/// (caller side) with the same code using the abstract FortranEntity type that +/// can be either a Symbol or an ActualArgument. +/// It works in two passes: a first pass over the characteristics that decides +/// how the interface must be. Then, the funcOp is created for it. Then a simple +/// pass over fir arguments finalize the interface information that must be +/// passed back to the user (and may require having the funcOp). All this +/// passes are driven from the CallInterface constructor. +template +class CallInterface { + friend CallInterfaceImpl; + +public: + /// Enum the different ways an entity can be passed-by + enum class PassEntityBy { + BaseAddress, + BoxChar, + // passing a read-only descriptor + Box, + // passing a writable descriptor + MutableBox, + AddressAndLength, + /// Value means passed by value at the mlir level, it is not necessarily + /// implied by Fortran Value attribute. + Value, + /// ValueAttribute means dummy has the the Fortran VALUE attribute. + BaseAddressValueAttribute, + CharBoxValueAttribute // BoxChar with VALUE + }; + /// Different properties of an entity that can be passed/returned. + /// One-to-One mapping with PassEntityBy but for + /// PassEntityBy::AddressAndLength that has two properties. + enum class Property { + BaseAddress, + BoxChar, + CharAddress, + CharLength, + Box, + MutableBox, + Value + }; + + using FortranEntity = typename PassedEntityTypes::FortranEntity; + using FirValue = typename PassedEntityTypes::FirValue; + + /// FirPlaceHolder are place holders for the mlir inputs and outputs that are + /// created during the first pass before the mlir::FuncOp is created. + struct FirPlaceHolder { + FirPlaceHolder(mlir::Type t, int passedPosition, Property p, + llvm::ArrayRef attrs) + : type{t}, passedEntityPosition{passedPosition}, property{p}, + attributes{attrs.begin(), attrs.end()} {} + /// Type for this input/output + mlir::Type type; + /// Position of related passedEntity in passedArguments. + /// (passedEntity is the passedResult this value is resultEntityPosition. + int passedEntityPosition; + static constexpr int resultEntityPosition = -1; + /// Indicate property of the entity passedEntityPosition that must be passed + /// through this argument. + Property property; + /// MLIR attributes for this argument + llvm::SmallVector attributes; + }; + + /// PassedEntity is what is provided back to the CallInterface user. + /// It describe how the entity is plugged in the interface + struct PassedEntity { + /// Is the dummy argument optional ? + bool isOptional() const; + /// Can the argument be modified by the callee ? + bool mayBeModifiedByCall() const; + /// Can the argument be read by the callee ? + bool mayBeReadByCall() const; + /// How entity is passed by. + PassEntityBy passBy; + /// What is the entity (SymbolRef for callee/ActualArgument* for caller) + /// What is the related mlir::FuncOp argument(s) (mlir::Value for callee / + /// index for the caller). + FortranEntity entity; + FirValue firArgument; + FirValue firLength; /* only for AddressAndLength */ + + /// Pointer to the argument characteristics. Nullptr for results. + const Fortran::evaluate::characteristics::DummyArgument *characteristics = + nullptr; + }; + + /// Return the mlir::FuncOp. Note that front block is added by this + /// utility if callee side. + mlir::FuncOp getFuncOp() const { return func; } + /// Number of MLIR inputs/outputs of the created FuncOp. + std::size_t getNumFIRArguments() const { return inputs.size(); } + std::size_t getNumFIRResults() const { return outputs.size(); } + /// Return the MLIR output types. + llvm::SmallVector getResultType() const; + + /// Return a container of Symbol/ActualArgument* and how they must + /// be plugged with the mlir::FuncOp. + llvm::ArrayRef getPassedArguments() const { + return passedArguments; + } + /// In case the result must be passed by the caller, indicate how. + /// nullopt if the result is not passed by the caller. + std::optional getPassedResult() const { return passedResult; } + /// Returns the mlir function type + mlir::FunctionType genFunctionType(); + + /// determineInterface is the entry point of the first pass that defines the + /// interface and is required to get the mlir::FuncOp. + void + determineInterface(bool isImplicit, + const Fortran::evaluate::characteristics::Procedure &); + + /// Does the caller need to allocate storage for the result ? + bool callerAllocateResult() const { + return mustPassResult() || mustSaveResult(); + } + + /// Is the Fortran result passed as an extra MLIR argument ? + bool mustPassResult() const { return passedResult.has_value(); } + /// Must the MLIR result be saved with a fir.save_result ? + bool mustSaveResult() const { return saveResult; } + +protected: + CallInterface(Fortran::lower::AbstractConverter &c) : converter{c} {} + /// CRTP handle. + T &side() { return *static_cast(this); } + /// Entry point to be called by child ctor to analyze the signature and + /// create/find the mlir::FuncOp. Child needs to be initialized first. + void declare(); + /// Second pass entry point, once the mlir::FuncOp is created. + /// Nothing is done if it was already called. + void mapPassedEntities(); + void mapBackInputToPassedEntity(const FirPlaceHolder &, FirValue); + + llvm::SmallVector outputs; + llvm::SmallVector inputs; + mlir::FuncOp func; + llvm::SmallVector passedArguments; + std::optional passedResult; + bool saveResult = false; + + Fortran::lower::AbstractConverter &converter; + /// Store characteristic once created, it is required for further information + /// (e.g. getting the length of character result) + std::optional characteristic = + std::nullopt; +}; + +//===----------------------------------------------------------------------===// +// Caller side interface +//===----------------------------------------------------------------------===// + +/// The CallerInterface provides the helpers needed by CallInterface +/// (getting the characteristic...) and a safe way for the user to +/// place the mlir::Value arguments into the input vector +/// once they are lowered. +class CallerInterface : public CallInterface { +public: + CallerInterface(const Fortran::evaluate::ProcedureRef &p, + Fortran::lower::AbstractConverter &c) + : CallInterface{c}, procRef{p} { + declare(); + mapPassedEntities(); + actualInputs.resize(getNumFIRArguments()); + } + + using ExprVisitor = std::function)>; + + /// CRTP callbacks + bool hasAlternateReturns() const; + std::string getMangledName() const; + mlir::Location getCalleeLocation() const; + Fortran::evaluate::characteristics::Procedure characterize() const; + + const Fortran::evaluate::ProcedureRef &getCallDescription() const { + return procRef; + } + + bool isMainProgram() const { return false; } + + /// Returns true if this is a call to a procedure pointer of a dummy + /// procedure. + bool isIndirectCall() const; + + /// Return the procedure symbol if this is a call to a user defined + /// procedure. + const Fortran::semantics::Symbol *getProcedureSymbol() const; + + /// Helpers to place the lowered arguments at the right place once they + /// have been lowered. + void placeInput(const PassedEntity &passedEntity, mlir::Value arg); + void placeAddressAndLengthInput(const PassedEntity &passedEntity, + mlir::Value addr, mlir::Value len); + + /// If this is a call to a procedure pointer or dummy, returns the related + /// symbol. Nullptr otherwise. + const Fortran::semantics::Symbol *getIfIndirectCallSymbol() const; + + /// Get the input vector once it is complete. + llvm::ArrayRef getInputs() const { + if (!verifyActualInputs()) + llvm::report_fatal_error("lowered arguments are incomplete"); + return actualInputs; + } + + /// Does the caller must map function interface symbols in order to evaluate + /// the result specification expressions (extents and lengths) ? If needed, + /// this mapping must be done after argument lowering, and before the call + /// itself. + bool mustMapInterfaceSymbols() const; + + /// Walk the result non-deferred extent specification expressions. + void walkResultExtents(ExprVisitor) const; + + /// Walk the result non-deferred length specification expressions. + void walkResultLengths(ExprVisitor) const; + + /// Get the mlir::Value that is passed as argument \p sym of the function + /// being called. The arguments must have been placed before calling this + /// function. + mlir::Value getArgumentValue(const semantics::Symbol &sym) const; + + /// Returns the symbol for the result in the explicit interface. If this is + /// called on an intrinsic or function without explicit interface, this will + /// crash. + const Fortran::semantics::Symbol &getResultSymbol() const; + + /// If some storage needs to be allocated for the result, + /// returns the storage type. + mlir::Type getResultStorageType() const; + + // Copy of base implementation. + static constexpr bool hasHostAssociated() { return false; } + mlir::Type getHostAssociatedTy() const { + llvm_unreachable("getting host associated type in CallerInterface"); + } + +private: + /// Check that the input vector is complete. + bool verifyActualInputs() const; + const Fortran::evaluate::ProcedureRef &procRef; + llvm::SmallVector actualInputs; +}; + +//===----------------------------------------------------------------------===// +// Callee side interface +//===----------------------------------------------------------------------===// + +/// CalleeInterface only provides the helpers needed by CallInterface +/// to abstract the specificities of the callee side. +class CalleeInterface : public CallInterface { +public: + CalleeInterface(Fortran::lower::pft::FunctionLikeUnit &f, + Fortran::lower::AbstractConverter &c) + : CallInterface{c}, funit{f} { + declare(); + } + + bool hasAlternateReturns() const; + std::string getMangledName() const; + mlir::Location getCalleeLocation() const; + Fortran::evaluate::characteristics::Procedure characterize() const; + bool isMainProgram() const; + + Fortran::lower::pft::FunctionLikeUnit &getCallDescription() const { + return funit; + } + + /// On the callee side it does not matter whether the procedure is + /// called through pointers or not. + bool isIndirectCall() const { return false; } + + /// Return the procedure symbol if this is a call to a user defined + /// procedure. + const Fortran::semantics::Symbol *getProcedureSymbol() const; + + /// Add mlir::FuncOp entry block and map fir block arguments to Fortran dummy + /// argument symbols. + mlir::FuncOp addEntryBlockAndMapArguments(); + + bool hasHostAssociated() const; + mlir::Type getHostAssociatedTy() const; + mlir::Value getHostAssociatedTuple() const; + +private: + Fortran::lower::pft::FunctionLikeUnit &funit; +}; + +/// Translate a procedure characteristics to an mlir::FunctionType signature. +mlir::FunctionType +translateSignature(const Fortran::evaluate::ProcedureDesignator &, + Fortran::lower::AbstractConverter &); + +/// Declare or find the mlir::FuncOp named \p name. If the mlir::FuncOp does +/// not exist yet, declare it with the signature translated from the +/// ProcedureDesignator argument. +/// Due to Fortran implicit function typing rules, the returned FuncOp is not +/// guaranteed to have the signature from ProcedureDesignator if the FuncOp was +/// already declared. +mlir::FuncOp +getOrDeclareFunction(llvm::StringRef name, + const Fortran::evaluate::ProcedureDesignator &, + Fortran::lower::AbstractConverter &); + +} // namespace Fortran::lower + +#endif // FORTRAN_LOWER_FIRBUILDER_H diff --git a/flang/include/flang/Lower/CharacterExpr.h b/flang/include/flang/Lower/CharacterExpr.h deleted file mode 100644 index 6f75448a5dbbfe..00000000000000 --- a/flang/include/flang/Lower/CharacterExpr.h +++ /dev/null @@ -1,153 +0,0 @@ -//===-- Lower/CharacterExpr.h -- lowering of characters ---------*- C++ -*-===// -// -// 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 -// -//===----------------------------------------------------------------------===// - -#ifndef FORTRAN_LOWER_CHARACTEREXPR_H -#define FORTRAN_LOWER_CHARACTEREXPR_H - -#include "flang/Lower/FIRBuilder.h" -#include "flang/Lower/Support/BoxValue.h" - -namespace Fortran::lower { - -/// Helper to facilitate lowering of CHARACTER in FIR. -class CharacterExprHelper { -public: - /// Constructor. - explicit CharacterExprHelper(FirOpBuilder &builder, mlir::Location loc) - : builder{builder}, loc{loc} {} - CharacterExprHelper(const CharacterExprHelper &) = delete; - - /// Unless otherwise stated, all mlir::Value inputs of these pseudo-fir ops - /// must be of type: - /// - fir.boxchar (dynamic length character), - /// - fir.ref>> (character with compile time - /// constant length), - /// - fir.array> (compile time constant character) - - /// Copy the \p count first characters of \p src into \p dest. - /// \p count can have any integer type. - void createCopy(mlir::Value dest, mlir::Value src, mlir::Value count); - - /// Set characters of \p str at position [\p lower, \p upper) to blanks. - /// \p lower and \upper bounds are zero based. - /// If \p upper <= \p lower, no padding is done. - /// \p upper and \p lower can have any integer type. - void createPadding(mlir::Value str, mlir::Value lower, mlir::Value upper); - - /// Create str(lb:ub), lower bounds must always be specified, upper - /// bound is optional. - mlir::Value createSubstring(mlir::Value str, - llvm::ArrayRef bounds); - - /// Return blank character of given \p type !fir.char - mlir::Value createBlankConstant(fir::CharacterType type); - - /// Lower \p lhs = \p rhs where \p lhs and \p rhs are scalar characters. - /// It handles cases where \p lhs and \p rhs may overlap. - void createAssign(mlir::Value lhs, mlir::Value rhs); - - /// Lower an assignment where the buffer and LEN parameter are known and do - /// not need to be unboxed. - void createAssign(mlir::Value lptr, mlir::Value llen, mlir::Value rptr, - mlir::Value rlen); - - /// Create lhs // rhs in temp obtained with fir.alloca - mlir::Value createConcatenate(mlir::Value lhs, mlir::Value rhs); - - /// LEN_TRIM intrinsic. - mlir::Value createLenTrim(mlir::Value str); - - /// Embox \p addr and \p len and return fir.boxchar. - /// Take care of type conversions before emboxing. - /// \p len is converted to the integer type for character lengths if needed. - mlir::Value createEmboxChar(mlir::Value addr, mlir::Value len); - - /// Unbox \p boxchar into (fir.ref>, getLengthType()). - std::pair createUnboxChar(mlir::Value boxChar); - - /// Allocate a temp of fir::CharacterType type and length len. - /// Returns related fir.ref>. - mlir::Value createCharacterTemp(mlir::Type type, mlir::Value len); - - /// Allocate a temp of compile time constant length. - /// Returns related fir.ref>>. - mlir::Value createCharacterTemp(mlir::Type type, int len) { - return createTemp(type, len); - } - - /// Return buffer/length pair of character str, if str is a constant, - /// it is allocated into a temp, otherwise, its memory reference is - /// returned as the buffer. - /// The buffer type of str is of type: - /// - fir.ref>> if str has compile time - /// constant length. - /// - fir.ref> if str has dynamic length. - std::pair materializeCharacter(mlir::Value str); - - /// Return true if \p type is a character literal type (is - /// fir.array>).; - static bool isCharacterLiteral(mlir::Type type); - - /// Return true if \p type is one of the following type - /// - fir.boxchar - /// - fir.ref>> - /// - fir.array> - static bool isCharacter(mlir::Type type); - - /// Extract the kind of a character type - static int getCharacterKind(mlir::Type type); - - /// Return the integer type that must be used to manipulate - /// Character lengths. TODO: move this to FirOpBuilder? - mlir::Type getLengthType() { return builder.getIndexType(); } - - /// Create an extended value from: - /// - fir.boxchar - /// - fir.ref>> - /// - fir.array> - /// - fir.char - /// - fir.ref> - /// If the no length is passed, it is attempted to be extracted from \p - /// character (or its type). This will crash if this is not possible. - /// The returned value is a CharBoxValue if \p character is a scalar, - /// otherwise it is a CharArrayBoxValue. - fir::ExtendedValue toExtendedValue(mlir::Value character, - mlir::Value len = {}); - -private: - fir::CharBoxValue materializeValue(const fir::CharBoxValue &str); - fir::CharBoxValue toDataLengthPair(mlir::Value character); - mlir::Type getReferenceType(const fir::CharBoxValue &c) const; - mlir::Value createEmbox(const fir::CharBoxValue &str); - mlir::Value createLoadCharAt(const fir::CharBoxValue &str, mlir::Value index); - void createStoreCharAt(const fir::CharBoxValue &str, mlir::Value index, - mlir::Value c); - void createCopy(const fir::CharBoxValue &dest, const fir::CharBoxValue &src, - mlir::Value count); - void createPadding(const fir::CharBoxValue &str, mlir::Value lower, - mlir::Value upper); - fir::CharBoxValue createTemp(mlir::Type type, mlir::Value len); - void createLengthOneAssign(const fir::CharBoxValue &lhs, - const fir::CharBoxValue &rhs); - void createAssign(const fir::CharBoxValue &lhs, const fir::CharBoxValue &rhs); - fir::CharBoxValue createConcatenate(const fir::CharBoxValue &lhs, - const fir::CharBoxValue &rhs); - fir::CharBoxValue createSubstring(const fir::CharBoxValue &str, - llvm::ArrayRef bounds); - mlir::Value createLenTrim(const fir::CharBoxValue &str); - mlir::Value createTemp(mlir::Type type, int len); - mlir::Value createBlankConstantCode(fir::CharacterType type); - -private: - FirOpBuilder &builder; - mlir::Location loc; -}; - -} // namespace Fortran::lower - -#endif // FORTRAN_LOWER_CHARACTEREXPR_H diff --git a/flang/include/flang/Lower/CharacterRuntime.h b/flang/include/flang/Lower/CharacterRuntime.h deleted file mode 100644 index d2992f76406ae7..00000000000000 --- a/flang/include/flang/Lower/CharacterRuntime.h +++ /dev/null @@ -1,36 +0,0 @@ -//===-- Lower/CharacterRuntime.h -- lower CHARACTER operations --*- C++ -*-===// -// -// 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 -// -//===----------------------------------------------------------------------===// - -#ifndef FORTRAN_LOWER_CHARACTERRUNTIME_H -#define FORTRAN_LOWER_CHARACTERRUNTIME_H - -#include "mlir/Dialect/StandardOps/IR/Ops.h" - -namespace Fortran { -namespace lower { -class AbstractConverter; - -/// Generate call to a character comparison for two ssa-values of type -/// `boxchar`. -mlir::Value genBoxCharCompare(AbstractConverter &converter, mlir::Location loc, - mlir::CmpIPredicate cmp, mlir::Value lhs, - mlir::Value rhs); - -/// Generate call to a character comparison op for two unboxed variables. There -/// are 4 arguments, 2 for the lhs and 2 for the rhs. Each CHARACTER must pass a -/// reference to its buffer (`ref>`) and its LEN type parameter (some -/// integral type). -mlir::Value genRawCharCompare(AbstractConverter &converter, mlir::Location loc, - mlir::CmpIPredicate cmp, mlir::Value lhsBuff, - mlir::Value lhsLen, mlir::Value rhsBuff, - mlir::Value rhsLen); - -} // namespace lower -} // namespace Fortran - -#endif // FORTRAN_LOWER_CHARACTERRUNTIME_H diff --git a/flang/include/flang/Lower/Coarray.h b/flang/include/flang/Lower/Coarray.h index e32c82d36e55ee..76d6a37b0bd61d 100644 --- a/flang/include/flang/Lower/Coarray.h +++ b/flang/include/flang/Lower/Coarray.h @@ -10,7 +10,7 @@ #define FORTRAN_LOWER_COARRAY_H #include "flang/Lower/AbstractConverter.h" -#include "flang/Lower/Support/BoxValue.h" +#include "flang/Optimizer/Builder/BoxValue.h" namespace Fortran { diff --git a/flang/include/flang/Lower/ConvertExpr.h b/flang/include/flang/Lower/ConvertExpr.h new file mode 100644 index 00000000000000..26dcfaed62b60d --- /dev/null +++ b/flang/include/flang/Lower/ConvertExpr.h @@ -0,0 +1,209 @@ +//===-- Lower/ConvertExpr.h -- lowering of expressions ----------*- C++ -*-===// +// +// 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 +// +//===----------------------------------------------------------------------===// +// +// Coding style: https://mlir.llvm.org/getting_started/DeveloperGuide/ +// +//===----------------------------------------------------------------------===// +/// +/// Implements the conversion from Fortran::evaluate::Expr trees to FIR. +/// +//===----------------------------------------------------------------------===// + +#ifndef FORTRAN_LOWER_CONVERTEXPR_H +#define FORTRAN_LOWER_CONVERTEXPR_H + +#include "flang/Evaluate/shape.h" +#include "flang/Optimizer/Builder/BoxValue.h" +#include "flang/Optimizer/Builder/FIRBuilder.h" + +namespace mlir { +class Location; +class Value; +} // namespace mlir + +namespace fir { +class AllocMemOp; +class ArrayLoadOp; +class ShapeOp; +} // namespace fir + +namespace Fortran::lower { + +class AbstractConverter; +class ExplicitIterSpace; +class ImplicitIterSpace; +class StatementContext; +class SymMap; + +/// Create an extended expression value. +fir::ExtendedValue +createSomeExtendedExpression(mlir::Location loc, AbstractConverter &converter, + const evaluate::Expr &expr, + SymMap &symMap, StatementContext &stmtCtx); + +fir::ExtendedValue +createSomeInitializerExpression(mlir::Location loc, + AbstractConverter &converter, + const evaluate::Expr &expr, + SymMap &symMap, StatementContext &stmtCtx); + +/// Create an extended expression address. +fir::ExtendedValue +createSomeExtendedAddress(mlir::Location loc, AbstractConverter &converter, + const evaluate::Expr &expr, + SymMap &symMap, StatementContext &stmtCtx); + +/// Create the address of the box. +/// \p expr must be the designator of an allocatable/pointer entity. +fir::MutableBoxValue +createMutableBox(mlir::Location loc, AbstractConverter &converter, + const evaluate::Expr &expr, + SymMap &symMap); + +/// Lower an array assignment expression. +/// +/// 1. Evaluate the lhs to determine the rank and how to form the ArrayLoad +/// (e.g., if there is a slicing op). +/// 2. Scan the rhs, creating the ArrayLoads and evaluate the scalar subparts to +/// be added to the map. +/// 3. Create the loop nest and evaluate the elemental expression, threading the +/// results. +/// 4. Copy the resulting array back with ArrayMergeStore to the lhs as +/// determined per step 1. +void createSomeArrayAssignment(AbstractConverter &converter, + const evaluate::Expr &lhs, + const evaluate::Expr &rhs, + SymMap &symMap, StatementContext &stmtCtx); + +/// Lower an array assignment expression with a pre-evaluated left hand side. +/// +/// 1. Scan the rhs, creating the ArrayLoads and evaluate the scalar subparts to +/// be added to the map. +/// 2. Create the loop nest and evaluate the elemental expression, threading the +/// results. +/// 3. Copy the resulting array back with ArrayMergeStore to the lhs as +/// determined per step 1. +void createSomeArrayAssignment(AbstractConverter &converter, + const fir::ExtendedValue &lhs, + const evaluate::Expr &rhs, + SymMap &symMap, StatementContext &stmtCtx); + +/// Lower an array assignment expression with pre-evaluated left and right +/// hand sides. This implements an array copy taking into account +/// non-contiguity and potential overlaps. +void createSomeArrayAssignment(AbstractConverter &converter, + const fir::ExtendedValue &lhs, + const fir::ExtendedValue &rhs, SymMap &symMap, + StatementContext &stmtCtx); + +/// Common entry point for both explicit iteration spaces and implicit iteration +/// spaces with masks. +/// +/// For an implicit iteration space with masking, lowers an array assignment +/// expression with masking expression(s). +/// +/// 1. Evaluate the lhs to determine the rank and how to form the ArrayLoad +/// (e.g., if there is a slicing op). +/// 2. Scan the rhs, creating the ArrayLoads and evaluate the scalar subparts to +/// be added to the map. +/// 3. Create the loop nest. +/// 4. Create the masking condition. Step 5 is conditionally executed only when +/// the mask condition evaluates to true. +/// 5. Evaluate the elemental expression, threading the results. +/// 6. Copy the resulting array back with ArrayMergeStore to the lhs as +/// determined per step 1. +/// +/// For an explicit iteration space, lower a scalar or array assignment +/// expression with a user-defined iteration space and possibly with masking +/// expression(s). +/// +/// If the expression is scalar, then the assignment is an array assignment but +/// the array accesses are explicitly defined by the user and not implied for +/// each element in the array. Mask expressions are optional. +/// +/// If the expression has rank, then the assignment has a combined user-defined +/// iteration space as well as a inner (subordinate) implied iteration +/// space. The implied iteration space may include WHERE conditions, `masks`. +void createAnyMaskedArrayAssignment( + AbstractConverter &converter, const evaluate::Expr &lhs, + const evaluate::Expr &rhs, + ExplicitIterSpace &explicitIterSpace, ImplicitIterSpace &implicitIterSpace, + SymMap &symMap, StatementContext &stmtCtx); + +/// In the context of a FORALL, a pointer assignment is allowed. The pointer +/// assignment can be elementwise on an array of pointers. The bounds +/// expressions as well as the component path may contain references to the +/// concurrent control variables. The explicit iteration space must be defined. +void createAnyArrayPointerAssignment( + AbstractConverter &converter, const evaluate::Expr &lhs, + const evaluate::Expr &rhs, + const evaluate::Assignment::BoundsSpec &bounds, + ExplicitIterSpace &explicitIterSpace, ImplicitIterSpace &implicitIterSpace, + SymMap &symMap); +/// Support the bounds remapping flavor of pointer assignment. +void createAnyArrayPointerAssignment( + AbstractConverter &converter, const evaluate::Expr &lhs, + const evaluate::Expr &rhs, + const evaluate::Assignment::BoundsRemapping &bounds, + ExplicitIterSpace &explicitIterSpace, ImplicitIterSpace &implicitIterSpace, + SymMap &symMap); + +/// Lower an assignment to an allocatable array, allocating the array if +/// it is not allocated yet or reallocation it if it does not conform +/// with the right hand side. +void createAllocatableArrayAssignment( + AbstractConverter &converter, const evaluate::Expr &lhs, + const evaluate::Expr &rhs, + ExplicitIterSpace &explicitIterSpace, ImplicitIterSpace &implicitIterSpace, + SymMap &symMap, StatementContext &stmtCtx); + +/// Lower an array expression with "parallel" semantics. Such a rhs expression +/// is fully evaluated prior to being assigned back to a temporary array. +fir::ExtendedValue +createSomeArrayTempValue(AbstractConverter &converter, + const std::optional &shape, + const evaluate::Expr &expr, + SymMap &symMap, StatementContext &stmtCtx); + +/// Like createSomeArrayTempValue, but the temporary buffer is allocated lazily +/// (inside the loops instead of before the loops). This can be useful if a +/// loop's bounds are functions of other loop indices, for example. +fir::ExtendedValue +createLazyArrayTempValue(AbstractConverter &converter, + const evaluate::Expr &expr, + mlir::Value var, mlir::Value shapeBuffer, + SymMap &symMap, StatementContext &stmtCtx); + +/// Lower an array expression to a value of type box. The expression must be a +/// variable. +fir::ExtendedValue +createSomeArrayBox(AbstractConverter &converter, + const evaluate::Expr &expr, + SymMap &symMap, StatementContext &stmtCtx); + +/// Lower a subroutine call. This handles both elemental and non elemental +/// subroutines. \p isUserDefAssignment must be set if this is called in the +/// context of a user defined assignment. For subroutines with alternate +/// returns, the returned value indicates which label the code should jump to. +/// The returned value is null otherwise. +mlir::Value createSubroutineCall(AbstractConverter &converter, + const evaluate::Expr &call, + SymMap &symMap, StatementContext &stmtCtx, + bool isUserDefAssignment); + +// Attribute for an alloca that is a trivial adaptor for converting a value to +// pass-by-ref semantics for a VALUE parameter. The optimizer may be able to +// eliminate these. +inline mlir::NamedAttribute getAdaptToByRefAttr(fir::FirOpBuilder &builder) { + return {mlir::Identifier::get("adapt.valuebyref", builder.getContext()), + builder.getUnitAttr()}; +} + +} // namespace Fortran::lower + +#endif // FORTRAN_LOWER_CONVERTEXPR_H diff --git a/flang/include/flang/Lower/ConvertType.h b/flang/include/flang/Lower/ConvertType.h index b807d620381869..df5f2e3376ba96 100644 --- a/flang/include/flang/Lower/ConvertType.h +++ b/flang/include/flang/Lower/ConvertType.h @@ -4,7 +4,11 @@ // See https://llvm.org/LICENSE.txt for license information. // SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception // -//----------------------------------------------------------------------------// +//===----------------------------------------------------------------------===// +// +// Coding style: https://mlir.llvm.org/getting_started/DeveloperGuide/ +// +//===----------------------------------------------------------------------===// /// /// Conversion of front-end TYPE, KIND, ATTRIBUTE (TKA) information to FIR/MLIR. /// This is meant to be the single point of truth (SPOT) for all type @@ -12,15 +16,14 @@ /// tree TKA to the FIR type system. If one is converting front-end types and /// not using one of the routines provided here, it's being done wrong. /// -/// [Coding style](https://llvm.org/docs/CodingStandards.html) -/// -//----------------------------------------------------------------------------// +//===----------------------------------------------------------------------===// #ifndef FORTRAN_LOWER_CONVERT_TYPE_H #define FORTRAN_LOWER_CONVERT_TYPE_H #include "flang/Common/Fortran.h" -#include "mlir/IR/Types.h" +#include "mlir/IR/BuiltinTypes.h" +#include "llvm/ADT/ArrayRef.h" namespace mlir { class Location; @@ -30,29 +33,23 @@ class Type; namespace Fortran { namespace common { -class IntrinsicTypeDefaultKinds; template class Reference; } // namespace common namespace evaluate { -struct DataRef; -template -class Designator; template class Expr; -template -struct SomeKind; struct SomeType; -template -class Type; } // namespace evaluate namespace semantics { class Symbol; +class DerivedTypeSpec; } // namespace semantics namespace lower { +class AbstractConverter; namespace pft { struct Variable; } @@ -60,66 +57,33 @@ struct Variable; using SomeExpr = evaluate::Expr; using SymbolRef = common::Reference; -/// Get a FIR type based on a category and kind. -mlir::Type getFIRType(mlir::MLIRContext *ctxt, - common::IntrinsicTypeDefaultKinds const &defaults, - common::TypeCategory tc, int kind); +// Type for compile time constant length type parameters. +using LenParameterTy = std::int64_t; -/// Get a FIR type based on a category. -mlir::Type getFIRType(mlir::MLIRContext *ctxt, - common::IntrinsicTypeDefaultKinds const &defaults, - common::TypeCategory tc); +/// Get a FIR type based on a category and kind. +mlir::Type getFIRType(mlir::MLIRContext *ctxt, common::TypeCategory tc, + int kind, llvm::ArrayRef); -/// Translate a Fortran::evaluate::DataRef to an mlir::Type. +/// Get a FIR type for a derived type mlir::Type -translateDataRefToFIRType(mlir::MLIRContext *ctxt, - common::IntrinsicTypeDefaultKinds const &defaults, - const evaluate::DataRef &dataRef); - -/// Translate a Fortran::evaluate::Designator<> to an mlir::Type. -template -inline mlir::Type translateDesignatorToFIRType( - mlir::MLIRContext *ctxt, common::IntrinsicTypeDefaultKinds const &defaults, - const evaluate::Designator> &) { - return getFIRType(ctxt, defaults, TC, KIND); -} - -/// Translate a Fortran::evaluate::Designator<> to an mlir::Type. -template -inline mlir::Type translateDesignatorToFIRType( - mlir::MLIRContext *ctxt, common::IntrinsicTypeDefaultKinds const &defaults, - const evaluate::Designator> &) { - return getFIRType(ctxt, defaults, TC); -} +translateDerivedTypeToFIRType(Fortran::lower::AbstractConverter &, + const Fortran::semantics::DerivedTypeSpec &); /// Translate a SomeExpr to an mlir::Type. -mlir::Type -translateSomeExprToFIRType(mlir::MLIRContext *ctxt, - common::IntrinsicTypeDefaultKinds const &defaults, - const SomeExpr *expr); +mlir::Type translateSomeExprToFIRType(Fortran::lower::AbstractConverter &, + const SomeExpr &expr); /// Translate a Fortran::semantics::Symbol to an mlir::Type. -mlir::Type -translateSymbolToFIRType(mlir::MLIRContext *ctxt, - common::IntrinsicTypeDefaultKinds const &defaults, - const SymbolRef symbol); +mlir::Type translateSymbolToFIRType(Fortran::lower::AbstractConverter &, + const SymbolRef symbol); /// Translate a Fortran::lower::pft::Variable to an mlir::Type. -mlir::Type -translateVariableToFIRType(mlir::MLIRContext *ctxt, - common::IntrinsicTypeDefaultKinds const &defaults, - const pft::Variable &variable); +mlir::Type translateVariableToFIRType(Fortran::lower::AbstractConverter &, + const pft::Variable &variable); /// Translate a REAL of KIND to the mlir::Type. mlir::Type convertReal(mlir::MLIRContext *ctxt, int KIND); -// Given a ReferenceType of a base type, returns the ReferenceType to -// the SequenceType of this base type. -// The created SequenceType has one dimension of unknown extent. -// This is useful to do pointer arithmetic using fir::CoordinateOp that requires -// a memory reference to a sequence type. -mlir::Type getSequenceRefType(mlir::Type referenceType); - } // namespace lower } // namespace Fortran diff --git a/flang/include/flang/Lower/FIRBuilder.h b/flang/include/flang/Lower/FIRBuilder.h deleted file mode 100644 index fe56fe68e46283..00000000000000 --- a/flang/include/flang/Lower/FIRBuilder.h +++ /dev/null @@ -1,197 +0,0 @@ -//===-- Lower/FirBuilder.h -- FIR operation builder -------------*- C++ -*-===// -// -// 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 -// -//===----------------------------------------------------------------------===// -// -// Builder routines for constructing the FIR dialect of MLIR. As FIR is a -// dialect of MLIR, it makes extensive use of MLIR interfaces and MLIR's coding -// style (https://mlir.llvm.org/getting_started/DeveloperGuide/) is used in this -// module. -// -//===----------------------------------------------------------------------===// - -#ifndef FORTRAN_LOWER_FIRBUILDER_H -#define FORTRAN_LOWER_FIRBUILDER_H - -#include "flang/Common/reference.h" -#include "flang/Optimizer/Dialect/FIROps.h" -#include "flang/Optimizer/Dialect/FIRType.h" -#include "flang/Optimizer/Support/KindMapping.h" -#include "mlir/IR/Builders.h" -#include "mlir/IR/BuiltinOps.h" -#include "llvm/ADT/DenseMap.h" -#include "llvm/ADT/Optional.h" - -namespace Fortran::lower { - -class AbstractConverter; - -//===----------------------------------------------------------------------===// -// FirOpBuilder -//===----------------------------------------------------------------------===// - -/// Extends the MLIR OpBuilder to provide methods for building common FIR -/// patterns. -class FirOpBuilder : public mlir::OpBuilder { -public: - explicit FirOpBuilder(mlir::Operation *op, const fir::KindMapping &kindMap) - : OpBuilder{op}, kindMap{kindMap} {} - - /// Get the current Region of the insertion point. - mlir::Region &getRegion() { return *getBlock()->getParent(); } - - /// Get the current Module - mlir::ModuleOp getModule() { - return getRegion().getParentOfType(); - } - - /// Get the current Function - mlir::FuncOp getFunction() { - return getRegion().getParentOfType(); - } - - /// Get a reference to the kind map. - const fir::KindMapping &getKindMap() { return kindMap; } - - /// The LHS and RHS are not always in agreement in terms of - /// type. In some cases, the disagreement is between COMPLEX and other scalar - /// types. In that case, the conversion must insert/extract out of a COMPLEX - /// value to have the proper semantics and be strongly typed. - mlir::Value convertWithSemantics(mlir::Location loc, mlir::Type toTy, - mlir::Value val); - - /// Get the entry block of the current Function - mlir::Block *getEntryBlock() { return &getFunction().front(); } - - /// Safely create a reference type to the type `eleTy`. - mlir::Type getRefType(mlir::Type eleTy); - - /// Create a null constant of type RefType and value 0. Need to pass in the - /// Location information. - mlir::Value createNullConstant(mlir::Location loc); - - /// Create an integer constant of type \p type and value \p i. - mlir::Value createIntegerConstant(mlir::Location loc, mlir::Type integerType, - std::int64_t i); - - mlir::Value createRealConstant(mlir::Location loc, mlir::Type realType, - const llvm::APFloat &val); - /// Create a real constant of type \p realType with a value zero. - mlir::Value createRealZeroConstant(mlir::Location loc, mlir::Type realType); - - /// Create a slot for a local on the stack. Besides the variable's type and - /// shape, it may be given name or target attributes. - mlir::Value allocateLocal(mlir::Location loc, mlir::Type ty, - llvm::StringRef nm, - llvm::ArrayRef shape, - bool asTarget = false); - - /// Create a temporary. A temp is allocated using `fir.alloca` and can be read - /// and written using `fir.load` and `fir.store`, resp. The temporary can be - /// given a name via a front-end `Symbol` or a `StringRef`. - mlir::Value createTemporary(mlir::Location loc, mlir::Type type, - llvm::StringRef name = {}, - llvm::ArrayRef shape = {}); - - /// Create an unnamed and untracked temporary on the stack. - mlir::Value createTemporary(mlir::Location loc, mlir::Type type, - llvm::ArrayRef shape) { - return createTemporary(loc, type, llvm::StringRef{}, shape); - } - - /// Create a global value. - fir::GlobalOp createGlobal(mlir::Location loc, mlir::Type type, - llvm::StringRef name, - mlir::StringAttr linkage = {}, - mlir::Attribute value = {}, bool isConst = false); - - fir::GlobalOp createGlobal(mlir::Location loc, mlir::Type type, - llvm::StringRef name, bool isConst, - std::function bodyBuilder, - mlir::StringAttr linkage = {}); - - /// Create a global constant (read-only) value. - fir::GlobalOp createGlobalConstant(mlir::Location loc, mlir::Type type, - llvm::StringRef name, - mlir::StringAttr linkage = {}, - mlir::Attribute value = {}) { - return createGlobal(loc, type, name, linkage, value, /*isConst=*/true); - } - - fir::GlobalOp - createGlobalConstant(mlir::Location loc, mlir::Type type, - llvm::StringRef name, - std::function bodyBuilder, - mlir::StringAttr linkage = {}) { - return createGlobal(loc, type, name, /*isConst=*/true, bodyBuilder, - linkage); - } - - /// Convert a StringRef string into a fir::StringLitOp. - fir::StringLitOp createStringLit(mlir::Location loc, mlir::Type eleTy, - llvm::StringRef string); - - /// Get a function by name. If the function exists in the current module, it - /// is returned. Otherwise, a null FuncOp is returned. - mlir::FuncOp getNamedFunction(llvm::StringRef name) { - return getNamedFunction(getModule(), name); - } - - static mlir::FuncOp getNamedFunction(mlir::ModuleOp module, - llvm::StringRef name); - - fir::GlobalOp getNamedGlobal(llvm::StringRef name) { - return getNamedGlobal(getModule(), name); - } - - static fir::GlobalOp getNamedGlobal(mlir::ModuleOp module, - llvm::StringRef name); - - /// Lazy creation of fir.convert op. - mlir::Value createConvert(mlir::Location loc, mlir::Type toTy, - mlir::Value val); - - /// Create a new FuncOp. If the function may have already been created, use - /// `addNamedFunction` instead. - mlir::FuncOp createFunction(mlir::Location loc, llvm::StringRef name, - mlir::FunctionType ty) { - return createFunction(loc, getModule(), name, ty); - } - - static mlir::FuncOp createFunction(mlir::Location loc, mlir::ModuleOp module, - llvm::StringRef name, - mlir::FunctionType ty); - - /// Determine if the named function is already in the module. Return the - /// instance if found, otherwise add a new named function to the module. - mlir::FuncOp addNamedFunction(mlir::Location loc, llvm::StringRef name, - mlir::FunctionType ty) { - if (auto func = getNamedFunction(name)) - return func; - return createFunction(loc, name, ty); - } - - static mlir::FuncOp addNamedFunction(mlir::Location loc, - mlir::ModuleOp module, - llvm::StringRef name, - mlir::FunctionType ty) { - if (auto func = getNamedFunction(module, name)) - return func; - return createFunction(loc, module, name, ty); - } - - /// Cast the input value to IndexType. - mlir::Value convertToIndexType(mlir::Location loc, mlir::Value val) { - return createConvert(loc, getIndexType(), val); - } - -private: - const fir::KindMapping &kindMap; -}; - -} // namespace Fortran::lower - -#endif // FORTRAN_LOWER_FIRBUILDER_H diff --git a/flang/include/flang/Lower/HostAssociations.h b/flang/include/flang/Lower/HostAssociations.h new file mode 100644 index 00000000000000..a0013f6f2a8c86 --- /dev/null +++ b/flang/include/flang/Lower/HostAssociations.h @@ -0,0 +1,63 @@ +//===-- Lower/HostAssociations.h --------------------------------*- C++ -*-===// +// +// 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 +// +//===----------------------------------------------------------------------===// + +#ifndef FORTRAN_LOWER_HOSTASSOCIATIONS_H +#define FORTRAN_LOWER_HOSTASSOCIATIONS_H + +#include "mlir/IR/Location.h" +#include "mlir/IR/Types.h" +#include "mlir/IR/Value.h" +#include "llvm/ADT/SetVector.h" + +namespace Fortran { +namespace semantics { +class Symbol; +} + +namespace lower { +class AbstractConverter; +class SymMap; + +/// Internal procedures in Fortran may access variables declared in the host +/// procedure directly. We bundle these variables together in a tuple and pass +/// them as an extra argument. +class HostAssociations { +public: + /// Returns true iff there are no host associations. + bool empty() const { return symbols.empty(); } + + /// Adds a set of Symbols that will be the host associated bindings for this + /// host procedure. + void addSymbolsToBind( + const llvm::SetVector &s) { + assert(empty() && "symbol set must be initially empty"); + symbols = s; + } + + /// Code gen the FIR for the local bindings for the host associated symbols + /// for the host (parent) procedure using `builder`. + void hostProcedureBindings(AbstractConverter &converter, SymMap &symMap); + + /// Code gen the FIR for the local bindings for the host associated symbols + /// for an internal (child) procedure using `builder`. + void internalProcedureBindings(AbstractConverter &converter, SymMap &symMap); + + /// Return the type of the extra argument to add to each internal procedure. + mlir::Type getArgumentType(AbstractConverter &convert); + +private: + /// Canonical vector of host associated symbols. + llvm::SetVector symbols; + + /// The type of the extra argument to be added to each internal procedure. + mlir::Type argType; +}; +} // namespace lower +} // namespace Fortran + +#endif // FORTRAN_LOWER_HOSTASSOCIATIONS_H diff --git a/flang/include/flang/Lower/IO.h b/flang/include/flang/Lower/IO.h index cbfd6dffaed76b..6e9e59038776bd 100644 --- a/flang/include/flang/Lower/IO.h +++ b/flang/include/flang/Lower/IO.h @@ -1,18 +1,19 @@ -//===-- Lower/IO.h -- lower I/O statements ----------------------*- C++ -*-===// +//===-- Lower/IO.h -- lower IO statements -----------------------*- C++ -*-===// // // 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 // //===----------------------------------------------------------------------===// +// +// Coding style: https://mlir.llvm.org/getting_started/DeveloperGuide/ +// +//===----------------------------------------------------------------------===// #ifndef FORTRAN_LOWER_IO_H #define FORTRAN_LOWER_IO_H -#include "flang/Common/reference.h" -#include "flang/Semantics/symbol.h" -#include "llvm/ADT/DenseMap.h" -#include "llvm/ADT/SmallSet.h" +#include namespace mlir { class Value; @@ -37,15 +38,6 @@ struct WriteStmt; namespace lower { class AbstractConverter; -class BridgeImpl; - -namespace pft { -struct Evaluation; -using LabelEvalMap = llvm::DenseMap; -using SymbolRef = Fortran::common::Reference; -using LabelSet = llvm::SmallSet; -using SymbolLabelMap = llvm::DenseMap; -} // namespace pft /// Generate IO call(s) for BACKSPACE; return the IOSTAT code mlir::Value genBackspaceStatement(AbstractConverter &, @@ -70,15 +62,11 @@ mlir::Value genOpenStatement(AbstractConverter &, const parser::OpenStmt &); /// Generate IO call(s) for PRINT void genPrintStatement(AbstractConverter &converter, - const parser::PrintStmt &stmt, - pft::LabelEvalMap &labelMap, - pft::SymbolLabelMap &assignMap); + const parser::PrintStmt &stmt); /// Generate IO call(s) for READ; return the IOSTAT code mlir::Value genReadStatement(AbstractConverter &converter, - const parser::ReadStmt &stmt, - pft::LabelEvalMap &labelMap, - pft::SymbolLabelMap &assignMap); + const parser::ReadStmt &stmt); /// Generate IO call(s) for REWIND; return the IOSTAT code mlir::Value genRewindStatement(AbstractConverter &, const parser::RewindStmt &); @@ -88,9 +76,7 @@ mlir::Value genWaitStatement(AbstractConverter &, const parser::WaitStmt &); /// Generate IO call(s) for WRITE; return the IOSTAT code mlir::Value genWriteStatement(AbstractConverter &converter, - const parser::WriteStmt &stmt, - pft::LabelEvalMap &labelMap, - pft::SymbolLabelMap &assignMap); + const parser::WriteStmt &stmt); } // namespace lower } // namespace Fortran diff --git a/flang/include/flang/Lower/IntrinsicCall.h b/flang/include/flang/Lower/IntrinsicCall.h index 2db1bda335b538..f02573604d3ec4 100644 --- a/flang/include/flang/Lower/IntrinsicCall.h +++ b/flang/include/flang/Lower/IntrinsicCall.h @@ -9,7 +9,8 @@ #ifndef FORTRAN_LOWER_INTRINSICCALL_H #define FORTRAN_LOWER_INTRINSICCALL_H -#include "flang/Lower/FIRBuilder.h" +#include "flang/Optimizer/Builder/FIRBuilder.h" +#include "llvm/ADT/Optional.h" namespace fir { class ExtendedValue; @@ -17,29 +18,60 @@ class ExtendedValue; namespace Fortran::lower { -// TODO: Expose interface to get specific intrinsic function address. -// TODO: Handle intrinsic subroutine. -// TODO: Intrinsics that do not require their arguments to be defined -// (e.g shape inquiries) might not fit in the current interface that -// requires mlir::Value to be provided. +class StatementContext; + // TODO: Error handling interface ? // TODO: Implementation is incomplete. Many intrinsics to tbd. -/// Helper for building calls to intrinsic functions in the runtime support -/// libraries. - /// Generate the FIR+MLIR operations for the generic intrinsic \p name /// with arguments \p args and expected result type \p resultType. /// Returned mlir::Value is the returned Fortran intrinsic value. -fir::ExtendedValue genIntrinsicCall(FirOpBuilder &, mlir::Location, - llvm::StringRef name, mlir::Type resultType, - llvm::ArrayRef args); +/// If the result is an allocated temporary, its clean-up is added to the +/// StatementContext. +fir::ExtendedValue genIntrinsicCall(fir::FirOpBuilder &, mlir::Location, + llvm::StringRef name, + llvm::Optional resultType, + llvm::ArrayRef args, + StatementContext &); + +/// Enum specifying how intrinsic argument evaluate::Expr should be +/// lowered to fir::ExtendedValue to be passed to genIntrinsicCall. +enum class LowerIntrinsicArgAs { + /// Lower argument to a value. Mainly intended for scalar arguments. + Value, + /// Lower argument to an address. Only valid when the argument properties are + /// fully defined (e.g. allocatable is allocated...). + Addr, + /// Lower argument to a box. + Box, + /// Lower argument without assuming that the argument is fully defined. + /// It can be used on unallocated allocatable, disassociated pointer, + /// or absent optional. This is meant for inquiry intrinsic arguments. + Inquired +}; + +/// Opaque class defining the argument lowering rules for an intrinsic. +struct IntrinsicArgumentLoweringRules; + +/// Return argument lowering rules for an intrinsic. +/// Returns a nullptr if all the intrinsic arguments should be lowered by value. +const IntrinsicArgumentLoweringRules * +getIntrinsicArgumentLowering(llvm::StringRef intrinsicName); + +/// Return how argument \p argName should be lowered given the rules for the +/// intrinsic function. The argument names are the one defined by the standard. +LowerIntrinsicArgAs +lowerIntrinsicArgumentAs(mlir::Location, const IntrinsicArgumentLoweringRules &, + llvm::StringRef argName); + +/// Return place-holder for absent intrinsic arguments. +fir::ExtendedValue getAbsentIntrinsicArgument(); /// Get SymbolRefAttr of runtime (or wrapper function containing inlined // implementation) of an unrestricted intrinsic (defined by its signature // and generic name) mlir::SymbolRefAttr -getUnrestrictedIntrinsicSymbolRefAttr(FirOpBuilder &, mlir::Location, +getUnrestrictedIntrinsicSymbolRefAttr(fir::FirOpBuilder &, mlir::Location, llvm::StringRef name, mlir::FunctionType signature); @@ -50,16 +82,16 @@ getUnrestrictedIntrinsicSymbolRefAttr(FirOpBuilder &, mlir::Location, /// Generate maximum. There must be at least one argument and all arguments /// must have the same type. -mlir::Value genMax(FirOpBuilder &, mlir::Location, +mlir::Value genMax(fir::FirOpBuilder &, mlir::Location, llvm::ArrayRef args); /// Generate minimum. Same constraints as genMax. -mlir::Value genMin(FirOpBuilder &, mlir::Location, +mlir::Value genMin(fir::FirOpBuilder &, mlir::Location, llvm::ArrayRef args); /// Generate power function x**y with given the expected /// result type. -mlir::Value genPow(FirOpBuilder &, mlir::Location, mlir::Type resultType, +mlir::Value genPow(fir::FirOpBuilder &, mlir::Location, mlir::Type resultType, mlir::Value x, mlir::Value y); } // namespace Fortran::lower diff --git a/flang/include/flang/Lower/Mangler.h b/flang/include/flang/Lower/Mangler.h index d82fdb0ed99ab1..1c59eda9917685 100644 --- a/flang/include/flang/Lower/Mangler.h +++ b/flang/include/flang/Lower/Mangler.h @@ -13,6 +13,7 @@ #ifndef FORTRAN_LOWER_MANGLER_H #define FORTRAN_LOWER_MANGLER_H +#include "flang/Evaluate/expression.h" #include "mlir/IR/BuiltinTypes.h" #include "llvm/ADT/StringRef.h" #include @@ -58,6 +59,38 @@ std::string mangleName(const semantics::DerivedTypeSpec &); /// Recover the bare name of the original symbol from an internal name. std::string demangleName(llvm::StringRef name); +std::string +mangleArrayLiteral(const uint8_t *addr, size_t size, + const Fortran::evaluate::ConstantSubscripts &shape, + Fortran::common::TypeCategory cat, int kind = 0, + Fortran::common::ConstantSubscript charLen = -1); + +template +std::string mangleArrayLiteral( + const Fortran::evaluate::Constant> &x) { + return mangleArrayLiteral( + reinterpret_cast(x.values().data()), + x.values().size() * sizeof(x.values()[0]), x.shape(), TC, KIND); +} + +template +std::string +mangleArrayLiteral(const Fortran::evaluate::Constant> &x) { + return mangleArrayLiteral( + reinterpret_cast(x.values().data()), + x.values().size() * sizeof(x.values()[0]), x.shape(), + Fortran::common::TypeCategory::Character, KIND, x.LEN()); +} + +inline std::string mangleArrayLiteral( + const Fortran::evaluate::Constant &x) { + return mangleArrayLiteral( + reinterpret_cast(x.values().data()), + x.values().size() * sizeof(x.values()[0]), x.shape(), + Fortran::common::TypeCategory::Derived); +} + } // namespace lower::mangle } // namespace Fortran diff --git a/flang/include/flang/Lower/OpenMP.h b/flang/include/flang/Lower/OpenMP.h index a056443aeda317..57cc15741ce524 100644 --- a/flang/include/flang/Lower/OpenMP.h +++ b/flang/include/flang/Lower/OpenMP.h @@ -13,9 +13,13 @@ #ifndef FORTRAN_LOWER_OPENMP_H #define FORTRAN_LOWER_OPENMP_H +#include + namespace Fortran { namespace parser { struct OpenMPConstruct; +struct OmpEndLoopDirective; +struct OmpClauseList; } // namespace parser namespace lower { @@ -29,6 +33,8 @@ struct Evaluation; void genOpenMPConstruct(AbstractConverter &, pft::Evaluation &, const parser::OpenMPConstruct &); +int64_t getCollapseValue(const Fortran::parser::OmpClauseList &clauseList); + } // namespace lower } // namespace Fortran diff --git a/flang/include/flang/Lower/PFTBuilder.h b/flang/include/flang/Lower/PFTBuilder.h index 16abf6bc8f3a42..33b312beb6d766 100644 --- a/flang/include/flang/Lower/PFTBuilder.h +++ b/flang/include/flang/Lower/PFTBuilder.h @@ -19,6 +19,7 @@ #include "flang/Common/reference.h" #include "flang/Common/template.h" +#include "flang/Lower/HostAssociations.h" #include "flang/Lower/PFTDefs.h" #include "flang/Parser/parse-tree.h" #include "flang/Semantics/attr.h" @@ -106,8 +107,7 @@ using ActionStmts = std::tuple< parser::ComputedGotoStmt, parser::ForallStmt, parser::ArithmeticIfStmt, parser::AssignStmt, parser::AssignedGotoStmt, parser::PauseStmt>; -using OtherStmts = - std::tuple; +using OtherStmts = std::tuple; using ConstructStmts = std::tuple< parser::AssociateStmt, parser::EndAssociateStmt, parser::BlockStmt, @@ -392,32 +392,49 @@ struct Variable { std::size_t aliasOffset{}; }; + /// pair using Interval = std::tuple; /// An interval of storage is a contiguous block of memory to be allocated or /// mapped onto another variable. Aliasing variables will be pointers into /// interval stores and may overlap each other. struct AggregateStore { - AggregateStore(Interval &&interval, const Fortran::semantics::Scope &scope, - bool isDeclaration = false) - : interval{std::move(interval)}, scope{&scope}, isDecl{isDeclaration} {} - AggregateStore(Interval &&interval, const Fortran::semantics::Scope &scope, - const llvm::SmallVector &vars, - bool isDeclaration = false) - : interval{std::move(interval)}, scope{&scope}, vars{vars}, - isDecl{isDeclaration} {} - - bool isGlobal() const { return vars.size() > 0; } + AggregateStore(Interval &&interval, + const Fortran::semantics::Symbol &namingSym, + bool isDeclaration = false, bool isGlobal = false) + : interval{std::move(interval)}, namingSymbol{&namingSym}, + isDecl{isDeclaration}, isGlobalAggregate{isGlobal} {} + AggregateStore(const semantics::Symbol &initialValueSym, + const semantics::Symbol &namingSym, + bool isDeclaration = false, bool isGlobal = false) + : interval{initialValueSym.offset(), initialValueSym.size()}, + namingSymbol{&namingSym}, initialValueSymbol{&initialValueSym}, + isDecl{isDeclaration}, isGlobalAggregate{isGlobal} {}; + + bool isGlobal() const { return isGlobalAggregate; } bool isDeclaration() const { return isDecl; } /// Get offset of the aggregate inside its scope. std::size_t getOffset() const { return std::get<0>(interval); } - + /// Returns symbols holding the aggregate initial value if any. + const semantics::Symbol *getInitialValueSymbol() const { + return initialValueSymbol; + } + /// Returns the symbol that gives its name to the aggregate. + const semantics::Symbol &getNamingSymbol() const { return *namingSymbol; } + /// Scope to which the aggregates belongs to. + const semantics::Scope &getOwningScope() const { + return getNamingSymbol().owner(); + } + /// of the aggregate in its scope. Interval interval{}; - /// scope in which the interval is. - const Fortran::semantics::Scope *scope; - llvm::SmallVector vars{}; + /// Symbol that gives its name to the aggregate. Always set by constructor. + const semantics::Symbol *namingSymbol; + /// Compiler generated symbol with the aggregate initial value if any. + const semantics::Symbol *initialValueSymbol = nullptr; /// Is this a declaration of a storage defined in another scope ? bool isDecl; + /// Is this a global aggregate ? + bool isGlobalAggregate; }; explicit Variable(const Fortran::semantics::Symbol &sym, bool global = false, @@ -465,22 +482,22 @@ struct Variable { return std::visit( common::visitors{ [](const Nominal &x) { return &x.symbol->GetUltimate().owner(); }, - [](const AggregateStore &agg) { return agg.scope; }}, + [](const AggregateStore &agg) { return &agg.getOwningScope(); }}, var); } bool isHeapAlloc() const { - if (const auto *s = std::get_if(&var)) + if (auto *s = std::get_if(&var)) return s->heapAlloc; return false; } bool isPointer() const { - if (const auto *s = std::get_if(&var)) + if (auto *s = std::get_if(&var)) return s->pointer; return false; } bool isTarget() const { - if (const auto *s = std::get_if(&var)) + if (auto *s = std::get_if(&var)) return s->target; return false; } @@ -488,7 +505,7 @@ struct Variable { /// An alias(er) is a variable that is part of a EQUIVALENCE that is allocated /// locally on the stack. bool isAlias() const { - if (const auto *s = std::get_if(&var)) + if (auto *s = std::get_if(&var)) return s->aliaser; return false; } @@ -527,7 +544,7 @@ struct Variable { /// The depth is recorded for nominal variables as a debugging aid. int getDepth() const { - if (const auto *s = std::get_if(&var)) + if (auto *s = std::get_if(&var)) return s->depth; return 0; } @@ -585,13 +602,7 @@ struct FunctionLikeUnit : public ProgramUnit { } /// Get the starting source location for this function like unit - parser::CharBlock getStartingSourceLoc() { - if (beginStmt) - return stmtSourceLoc(*beginStmt); - if (!evaluationList.empty()) - return evaluationList.front().position; - return stmtSourceLoc(endStmt); - } + parser::CharBlock getStartingSourceLoc() const; void setActiveEntry(int entryIndex) { assert(entryIndex >= 0 && entryIndex < (int)entryPointList.size() && @@ -603,7 +614,7 @@ struct FunctionLikeUnit : public ProgramUnit { /// This should not be called if the FunctionLikeUnit is the main program /// since anonymous main programs do not have a symbol. const semantics::Symbol &getSubprogramSymbol() const { - const auto *symbol = entryPointList[activeEntry].first; + auto *symbol = entryPointList[activeEntry].first; if (!symbol) llvm::report_fatal_error( "not inside a procedure; do not call on main program."); @@ -616,11 +627,27 @@ struct FunctionLikeUnit : public ProgramUnit { return entryPointList[activeEntry].second; } - /// Helper to get location from FunctionLikeUnit begin/end statements. - static parser::CharBlock stmtSourceLoc(const FunctionStatement &stmt) { - return stmt.visit(common::visitors{[](const auto &x) { return x.source; }}); + //===--------------------------------------------------------------------===// + // Host associations + //===--------------------------------------------------------------------===// + + void setHostAssociatedSymbols( + const llvm::SetVector &symbols) { + hostAssociations.addSymbolsToBind(symbols); } + /// Return the host associations, if any, from the parent (host) procedure. + /// Crashes if the parent is not a procedure. + HostAssociations &parentHostAssoc(); + + /// Return true iff the parent is a procedure and the parent has a non-empty + /// set of host associations. + bool parentHasHostAssoc(); + + /// Return the host associations for this function like unit. The list of host + /// associations are kept in the host procedure. + HostAssociations &getHostAssoc() { return hostAssociations; } + LLVM_DUMP_METHOD void dump() const; /// Anonymous programs do not have a begin statement @@ -640,13 +667,14 @@ struct FunctionLikeUnit : public ProgramUnit { /// Current index into entryPointList. Index 0 is the primary entry point. int activeEntry = 0; /// Dummy arguments that are not universal across entry points. - llvm::SmallVector nonUniversalDummyArguments; + llvm::SmallVector nonUniversalDummyArguments; /// Primary result for function subprograms with alternate entries. This /// is one of the largest result values, not necessarily the first one. const semantics::Symbol *primaryResult{nullptr}; /// Terminal basic block (if any) mlir::Block *finalBlock{}; std::vector> varList; + HostAssociations hostAssociations; }; /// Module-like units contain a list of function-like units. @@ -668,6 +696,9 @@ struct ModuleLikeUnit : public ProgramUnit { std::vector getOrderedSymbolTable() { return varList[0]; } + /// Get the starting source location for this module like unit. + parser::CharBlock getStartingSourceLoc() const; + ModuleStatement beginStmt; ModuleStatement endStmt; std::list nestedFunctions; @@ -715,6 +746,28 @@ struct Program { std::list units; }; +/// Return the list of variables that appears in the specification expressions +/// of a function result. +std::vector +buildFuncResultDependencyList(const Fortran::semantics::Symbol &); + +/// Helper to get location from FunctionLikeUnit/ModuleLikeUnit begin/end +/// statements. +template +static parser::CharBlock stmtSourceLoc(const T &stmt) { + return stmt.visit(common::visitors{[](const auto &x) { return x.source; }}); +} + +/// Get the first PFT ancestor node that has type ParentType. +template +ParentType *getAncestor(A &node) { + if (auto *seekedParent = node.parent.template getIf()) + return seekedParent; + return node.parent.visit(common::visitors{ + [](Program &p) -> ParentType * { return nullptr; }, + [](auto &p) -> ParentType * { return getAncestor(p); }}); +} + } // namespace Fortran::lower::pft namespace Fortran::lower { @@ -732,7 +785,6 @@ createPFT(const parser::Program &root, /// Dumper for displaying a PFT. void dumpPFT(llvm::raw_ostream &outputStream, const pft::Program &pft); - } // namespace Fortran::lower #endif // FORTRAN_LOWER_PFTBUILDER_H diff --git a/flang/include/flang/Lower/PFTDefs.h b/flang/include/flang/Lower/PFTDefs.h index 4dc31756ea4af4..194f1020da57ca 100644 --- a/flang/include/flang/Lower/PFTDefs.h +++ b/flang/include/flang/Lower/PFTDefs.h @@ -42,6 +42,7 @@ class Reference; namespace lower { bool definedInCommonBlock(const semantics::Symbol &sym); +bool symbolIsGlobal(const semantics::Symbol &sym); bool defaultRecursiveFunctionSetting(); namespace pft { diff --git a/flang/include/flang/Lower/Runtime.h b/flang/include/flang/Lower/Runtime.h index dcfce8ff63c311..d89b5f5e637586 100644 --- a/flang/include/flang/Lower/Runtime.h +++ b/flang/include/flang/Lower/Runtime.h @@ -6,6 +6,10 @@ // //===----------------------------------------------------------------------===// // +// Coding style: https://mlir.llvm.org/getting_started/DeveloperGuide/ +// +//===----------------------------------------------------------------------===// +// // Builder routines for constructing the FIR dialect of MLIR. As FIR is a // dialect of MLIR, it makes extensive use of MLIR interfaces and MLIR's coding // style (https://mlir.llvm.org/getting_started/DeveloperGuide/) is used in this @@ -16,6 +20,21 @@ #ifndef FORTRAN_LOWER_RUNTIME_H #define FORTRAN_LOWER_RUNTIME_H +namespace llvm { +template +class Optional; +} + +namespace mlir { +class Location; +class Value; +} // namespace mlir + +namespace fir { +class CharBoxValue; +class FirOpBuilder; +} // namespace fir + namespace Fortran { namespace parser { @@ -51,6 +70,36 @@ void genSyncTeamStatement(AbstractConverter &, const parser::SyncTeamStmt &); void genUnlockStatement(AbstractConverter &, const parser::UnlockStmt &); void genPauseStatement(AbstractConverter &, const parser::PauseStmt &); +mlir::Value genAssociated(fir::FirOpBuilder &, mlir::Location, + mlir::Value pointer, mlir::Value target); + +mlir::Value genCpuTime(fir::FirOpBuilder &, mlir::Location); +void genDateAndTime(fir::FirOpBuilder &, mlir::Location, + llvm::Optional date, + llvm::Optional time, + llvm::Optional zone, mlir::Value values); + +void genRandomInit(fir::FirOpBuilder &, mlir::Location, mlir::Value repeatable, + mlir::Value imageDistinct); +void genRandomNumber(fir::FirOpBuilder &, mlir::Location, mlir::Value harvest); +void genRandomSeed(fir::FirOpBuilder &, mlir::Location, int argIndex, + mlir::Value argBox); + +/// generate runtime call to transfer intrinsic with no size argument +void genTransfer(fir::FirOpBuilder &builder, mlir::Location loc, + mlir::Value resultBox, mlir::Value sourceBox, + mlir::Value moldBox); + +/// generate runtime call to transfer intrinsic with size argument +void genTransferSize(fir::FirOpBuilder &builder, mlir::Location loc, + mlir::Value resultBox, mlir::Value sourceBox, + mlir::Value moldBox, mlir::Value size); + +/// generate system_clock runtime call/s +/// all intrinsic arguments are optional and may appear here as mlir::Value{} +void genSystemClock(fir::FirOpBuilder &, mlir::Location, mlir::Value count, + mlir::Value rate, mlir::Value max); + } // namespace lower } // namespace Fortran diff --git a/flang/include/flang/Lower/Support/BoxValue.h b/flang/include/flang/Lower/Support/BoxValue.h deleted file mode 100644 index 0d5dec97ef097e..00000000000000 --- a/flang/include/flang/Lower/Support/BoxValue.h +++ /dev/null @@ -1,238 +0,0 @@ -//===-- Lower/Support/BoxValue.h -- internal box values ---------*- C++ -*-===// -// -// 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 -// -//===----------------------------------------------------------------------===// - -#ifndef LOWER_SUPPORT_BOXVALUE_H -#define LOWER_SUPPORT_BOXVALUE_H - -#include "mlir/IR/Value.h" -#include "llvm/ADT/SmallVector.h" -#include "llvm/Support/Compiler.h" -#include "llvm/Support/raw_ostream.h" -#include -#include - -namespace fir { -class CharBoxValue; -class ArrayBoxValue; -class CharArrayBoxValue; -class BoxValue; -class ProcBoxValue; - -llvm::raw_ostream &operator<<(llvm::raw_ostream &, const CharBoxValue &); -llvm::raw_ostream &operator<<(llvm::raw_ostream &, const ArrayBoxValue &); -llvm::raw_ostream &operator<<(llvm::raw_ostream &, const CharArrayBoxValue &); -llvm::raw_ostream &operator<<(llvm::raw_ostream &, const BoxValue &); -llvm::raw_ostream &operator<<(llvm::raw_ostream &, const ProcBoxValue &); - -//===----------------------------------------------------------------------===// -// -// Boxed values -// -// Define a set of containers used internally by the lowering bridge to keep -// track of extended values associated with a Fortran subexpression. These -// associations are maintained during the construction of FIR. -// -//===----------------------------------------------------------------------===// - -/// Most expressions of intrinsic type can be passed unboxed. Their properties -/// are known statically. -using UnboxedValue = mlir::Value; - -/// Abstract base class. -class AbstractBox { -public: - AbstractBox() = delete; - AbstractBox(mlir::Value addr) : addr{addr} {} - mlir::Value getAddr() const { return addr; } - -protected: - mlir::Value addr; -}; - -/// Expressions of CHARACTER type have an associated, possibly dynamic LEN -/// value. -class CharBoxValue : public AbstractBox { -public: - CharBoxValue(mlir::Value addr, mlir::Value len) - : AbstractBox{addr}, len{len} {} - - CharBoxValue clone(mlir::Value newBase) const { return {newBase, len}; } - - mlir::Value getLen() const { return len; } - mlir::Value getBuffer() const { return getAddr(); } - - friend llvm::raw_ostream &operator<<(llvm::raw_ostream &, - const CharBoxValue &); - LLVM_DUMP_METHOD void dump() const { llvm::errs() << *this; } - -protected: - mlir::Value len; -}; - -/// Abstract base class. -/// Expressions of type array have at minimum a shape. These expressions may -/// have lbound attributes (dynamic values) that affect the interpretation of -/// indexing expressions. -class AbstractArrayBox { -public: - AbstractArrayBox() = default; - AbstractArrayBox(llvm::ArrayRef extents, - llvm::ArrayRef lbounds) - : extents{extents.begin(), extents.end()}, lbounds{lbounds.begin(), - lbounds.end()} {} - - // Every array has extents that describe its shape. - const llvm::SmallVectorImpl &getExtents() const { - return extents; - } - - // An array expression may have user-defined lower bound values. - // If this vector is empty, the default in all dimensions in `1`. - const llvm::SmallVectorImpl &getLBounds() const { - return lbounds; - } - - bool lboundsAllOne() const { return lbounds.empty(); } - -protected: - llvm::SmallVector extents; - llvm::SmallVector lbounds; -}; - -/// Expressions with rank > 0 have extents. They may also have lbounds that are -/// not 1. -class ArrayBoxValue : public AbstractBox, public AbstractArrayBox { -public: - ArrayBoxValue(mlir::Value addr, llvm::ArrayRef extents, - llvm::ArrayRef lbounds = {}) - : AbstractBox{addr}, AbstractArrayBox{extents, lbounds} {} - - ArrayBoxValue clone(mlir::Value newBase) const { - return {newBase, extents, lbounds}; - } - - friend llvm::raw_ostream &operator<<(llvm::raw_ostream &, - const ArrayBoxValue &); - LLVM_DUMP_METHOD void dump() const { operator<<(llvm::errs(), *this); } -}; - -/// Expressions of type CHARACTER and with rank > 0. -class CharArrayBoxValue : public CharBoxValue, public AbstractArrayBox { -public: - CharArrayBoxValue(mlir::Value addr, mlir::Value len, - llvm::ArrayRef extents, - llvm::ArrayRef lbounds = {}) - : CharBoxValue{addr, len}, AbstractArrayBox{extents, lbounds} {} - - CharArrayBoxValue clone(mlir::Value newBase) const { - return {newBase, len, extents, lbounds}; - } - - friend llvm::raw_ostream &operator<<(llvm::raw_ostream &, - const CharArrayBoxValue &); - LLVM_DUMP_METHOD void dump() const { operator<<(llvm::errs(), *this); } -}; - -/// Expressions that are procedure POINTERs may need a set of references to -/// variables in the host scope. -class ProcBoxValue : public AbstractBox { -public: - ProcBoxValue(mlir::Value addr, mlir::Value context) - : AbstractBox{addr}, hostContext{context} {} - - ProcBoxValue clone(mlir::Value newBase) const { - return {newBase, hostContext}; - } - - mlir::Value getHostContext() const { return hostContext; } - - friend llvm::raw_ostream &operator<<(llvm::raw_ostream &, - const ProcBoxValue &); - LLVM_DUMP_METHOD void dump() const { operator<<(llvm::errs(), *this); } - -protected: - mlir::Value hostContext; -}; - -/// In the generalized form, a boxed value can have a dynamic size, be an array -/// with dynamic extents and lbounds, and take dynamic type parameters. -class BoxValue : public AbstractBox, public AbstractArrayBox { -public: - BoxValue(mlir::Value addr) : AbstractBox{addr}, AbstractArrayBox{} {} - BoxValue(mlir::Value addr, mlir::Value len) - : AbstractBox{addr}, AbstractArrayBox{}, len{len} {} - BoxValue(mlir::Value addr, llvm::ArrayRef extents, - llvm::ArrayRef lbounds = {}) - : AbstractBox{addr}, AbstractArrayBox{extents, lbounds} {} - BoxValue(mlir::Value addr, mlir::Value len, - llvm::ArrayRef params, - llvm::ArrayRef extents, - llvm::ArrayRef lbounds = {}) - : AbstractBox{addr}, AbstractArrayBox{extents, lbounds}, len{len}, - params{params.begin(), params.end()} {} - - BoxValue clone(mlir::Value newBase) const { - return {newBase, len, params, extents, lbounds}; - } - - mlir::Value getLen() const { return len; } - const llvm::SmallVectorImpl &getLenTypeParams() const { - return params; - } - - friend llvm::raw_ostream &operator<<(llvm::raw_ostream &, const BoxValue &); - LLVM_DUMP_METHOD void dump() const { operator<<(llvm::errs(), *this); } - -protected: - mlir::Value len; - llvm::SmallVector params; -}; - -/// Used for triple notation (array slices) -using RangeBoxValue = std::tuple; - -class ExtendedValue; - -mlir::Value getBase(const ExtendedValue &exv); -llvm::raw_ostream &operator<<(llvm::raw_ostream &, const ExtendedValue &); -ExtendedValue substBase(const ExtendedValue &exv, mlir::Value base); - -/// An extended value is a box of values pertaining to a discrete entity. It is -/// used in lowering to track all the runtime values related to an entity. For -/// example, an entity may have an address in memory that contains its value(s) -/// as well as various attribute values that describe the shape and starting -/// indices if it is an array entity. -class ExtendedValue { -public: - template - constexpr ExtendedValue(A &&box) : box{std::forward(box)} {} - - constexpr const CharBoxValue *getCharBox() const { - return std::get_if(&box); - } - - constexpr const UnboxedValue *getUnboxed() const { - return std::get_if(&box); - } - - /// LLVM style debugging of extended values - LLVM_DUMP_METHOD void dump() const { llvm::errs() << *this << '\n'; } - - friend llvm::raw_ostream &operator<<(llvm::raw_ostream &, - const ExtendedValue &); - friend mlir::Value getBase(const ExtendedValue &exv); - friend ExtendedValue substBase(const ExtendedValue &exv, mlir::Value base); - -private: - std::variant - box; -}; -} // namespace fir - -#endif // LOWER_SUPPORT_BOXVALUE_H diff --git a/flang/include/flang/Lower/Support/Utils.h b/flang/include/flang/Lower/Support/Utils.h index 7884634d6607b5..2b339ea2bb7a43 100644 --- a/flang/include/flang/Lower/Support/Utils.h +++ b/flang/include/flang/Lower/Support/Utils.h @@ -14,11 +14,10 @@ #define FORTRAN_LOWER_SUPPORT_UTILS_H #include "flang/Common/indirection.h" +#include "flang/Optimizer/Support/Utils.h" #include "flang/Parser/char-block.h" -#include "mlir/Dialect/StandardOps/IR/Ops.h" -#include "mlir/IR/BuiltinAttributes.h" +#include "flang/Semantics/tools.h" #include "llvm/ADT/StringRef.h" -#include //===----------------------------------------------------------------------===// // Small inline helper functions to deal with repetitive, clumsy conversions. @@ -29,13 +28,6 @@ inline llvm::StringRef toStringRef(const Fortran::parser::CharBlock &cb) { return {cb.begin(), cb.size()}; } -namespace fir { -/// Return the integer value of a ConstantOp. -inline std::int64_t toInt(mlir::ConstantOp cop) { - return cop.getValue().cast().getValue().getSExtValue(); -} -} // namespace fir - /// Template helper to remove Fortran::common::Indirection wrappers. template const A &removeIndirection(const A &a) { @@ -46,4 +38,32 @@ const A &removeIndirection(const Fortran::common::Indirection &a) { return a.value(); } +/// Clone subexpression and wrap it as a generic `Fortran::evaluate::Expr`. +template +static Fortran::evaluate::Expr +toEvExpr(const A &x) { + return Fortran::evaluate::AsGenericExpr(Fortran::common::Clone(x)); +} + +template +static Fortran::evaluate::Expr ignoreEvConvert( + const Fortran::evaluate::Convert< + Fortran::evaluate::Type, + FROM> &x) { + return toEvExpr(x.left()); +} +template +static Fortran::evaluate::Expr +ignoreEvConvert(const A &x) { + return toEvExpr(x); +} +/// A vector subscript expression may be wrapped with a cast to INTEGER*8. +/// Get rid of it here so the vector can be loaded. Add it back when +/// generating the elemental evaluation (inside the loop nest). +inline Fortran::evaluate::Expr +ignoreEvConvert(const Fortran::evaluate::Expr> &x) { + return std::visit([](const auto &v) { return ignoreEvConvert(v); }, x.u); +} + #endif // FORTRAN_LOWER_SUPPORT_UTILS_H diff --git a/flang/include/flang/Lower/Support/Verifier.h b/flang/include/flang/Lower/Support/Verifier.h new file mode 100644 index 00000000000000..26f837029da1e2 --- /dev/null +++ b/flang/include/flang/Lower/Support/Verifier.h @@ -0,0 +1,34 @@ +//===-- Lower/Support/Verifier.h -- verify pass for lowering ----*- C++ -*-===// +// +// 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 +// +//===----------------------------------------------------------------------===// +// +// Coding style: https://mlir.llvm.org/getting_started/DeveloperGuide/ +// +//===----------------------------------------------------------------------===// + +#ifndef FORTRAN_LOWER_SUPPORT_VERIFIER_H +#define FORTRAN_LOWER_SUPPORT_VERIFIER_H + +#include "mlir/IR/Verifier.h" +#include "mlir/Pass/Pass.h" + +namespace Fortran::lower { + +/// A verification pass to verify the output from the bridge. This provides a +/// little bit of glue to run a verifier pass directly. +class VerifierPass + : public mlir::PassWrapper> { + void runOnOperation() override final { + if (mlir::failed(mlir::verify(getOperation()))) + signalPassFailure(); + markAllAnalysesPreserved(); + } +}; + +} // namespace Fortran::lower + +#endif // FORTRAN_LOWER_SUPPORT_VERIFIER_H diff --git a/flang/include/flang/Lower/Todo.h b/flang/include/flang/Lower/Todo.h index e18bab4ea31fc1..734ae453c78f3a 100644 --- a/flang/include/flang/Lower/Todo.h +++ b/flang/include/flang/Lower/Todo.h @@ -56,7 +56,7 @@ #define TODO_NOLOCDEFN(ToDoMsg, ToDoFile, ToDoLine) \ do { \ llvm::report_fatal_error( \ - __FILE__ ":" TODOQUOTE(__LINE__) ": not yet implemented " ToDoMsg); \ + ToDoFile ":" TODOQUOTE(ToDoLine) ": not yet implemented " ToDoMsg); \ } while (false) #define TODO_NOLOC(ToDoMsg) TODO_NOLOCDEFN(ToDoMsg, __FILE__, __LINE__) diff --git a/flang/include/flang/Lower/Utils.h b/flang/include/flang/Lower/Utils.h deleted file mode 100644 index d7c7b565dbc6aa..00000000000000 --- a/flang/include/flang/Lower/Utils.h +++ /dev/null @@ -1,31 +0,0 @@ -//===-- Lower/Utils.h -- utilities ------------------------------*- C++ -*-===// -// -// 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 -// -//===----------------------------------------------------------------------===// - -#ifndef FORTRAN_LOWER_UTILS_H -#define FORTRAN_LOWER_UTILS_H - -#include "flang/Common/indirection.h" -#include "flang/Parser/char-block.h" -#include "llvm/ADT/StringRef.h" - -/// Convert an F18 CharBlock to an LLVM StringRef -inline llvm::StringRef toStringRef(const Fortran::parser::CharBlock &cb) { - return {cb.begin(), cb.size()}; -} - -/// Template helper to remove Fortran::common::Indirection wrappers. -template -const A &removeIndirection(const A &a) { - return a; -} -template -const A &removeIndirection(const Fortran::common::Indirection &a) { - return a.value(); -} - -#endif // FORTRAN_LOWER_UTILS_H diff --git a/flang/include/flang/Lower/VectorSubscripts.h b/flang/include/flang/Lower/VectorSubscripts.h new file mode 100644 index 00000000000000..5533ca4469df0d --- /dev/null +++ b/flang/include/flang/Lower/VectorSubscripts.h @@ -0,0 +1,152 @@ +//===-- VectorSubscripts.h -- vector subscripts tools -----------*- C++ -*-===// +// +// 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 +// +//===----------------------------------------------------------------------===// +/// +/// \file +/// \brief Defines a compiler internal representation for lowered designators +/// containing vector subscripts. This representation allows working on such +/// designators in custom ways while ensuring the designator subscripts are +/// only evaluated once. It is mainly intended for cases that do not fit in +/// the array expression lowering framework like input IO in presence of +/// vector subscripts. +/// +//===----------------------------------------------------------------------===// + +#ifndef FORTRAN_LOWER_VECTORSUBSCRIPTS_H +#define FORTRAN_LOWER_VECTORSUBSCRIPTS_H + +#include "flang/Optimizer/Builder/BoxValue.h" + +namespace fir { +class FirOpBuilder; +} + +namespace Fortran { + +namespace evaluate { +template +class Expr; +struct SomeType; +} // namespace evaluate + +namespace lower { + +class AbstractConverter; +class StatementContext; + +/// VectorSubscriptBox is a lowered representation for any Designator that +/// contain at least one vector subscript. +/// +/// A designator `x%a(i,j)%b(1:foo():1, vector, k)%c%d(m)%e1 +/// Is lowered into: +/// - an ExtendedValue for ranked base (x%a(i,j)%b) +/// - mlir:Values and ExtendedValues for the triplet, vector subscript and +/// scalar subscripts of the ranked array reference (1:foo():1, vector, k) +/// - a list of fir.field_index and scalar integers mlir::Value for the +/// component +/// path at the right of the ranked array ref (%c%d(m)%e). +/// +/// This representation allows later creating loops over the designator elements +/// and fir.array_coor to get the element addresses without re-evaluating any +/// sub-expressions. +class VectorSubscriptBox { +public: + /// Type of the callbacks that can be passed to work with the element + /// addresses. + using ElementalGenerator = std::function; + using ElementalGeneratorWithBoolReturn = + std::function; + struct LoweredVectorSubscript { + fir::ExtendedValue vector; + // Vector size, guaranteed to be of indexType. + mlir::Value size; + }; + struct LoweredTriplet { + // Triplets value, guaranteed to be of indexType. + mlir::Value lb; + mlir::Value ub; + mlir::Value stride; + }; + using LoweredSubscript = + std::variant; + using MaybeSubstring = llvm::SmallVector; + VectorSubscriptBox( + fir::ExtendedValue &&loweredBase, + llvm::SmallVector &&loweredSubscripts, + llvm::SmallVector &&componentPath, + MaybeSubstring substringBounds, mlir::Type elementType) + : loweredBase{std::move(loweredBase)}, loweredSubscripts{std::move( + loweredSubscripts)}, + componentPath{std::move(componentPath)}, + substringBounds{substringBounds}, elementType{elementType} {}; + + /// Loop over the elements described by the VectorSubscriptBox, and call + /// \p elementalGenerator inside the loops with the element addresses. + void loopOverElements(fir::FirOpBuilder &builder, mlir::Location loc, + const ElementalGenerator &elementalGenerator); + + /// Loop over the elements described by the VectorSubscriptBox while a + /// condition is true, and call \p elementalGenerator inside the loops with + /// the element addresses. The initial condition value is \p initialCondition, + /// and then it is the result of \p elementalGenerator. The value of the + /// condition after the loops is returned. + mlir::Value loopOverElementsWhile( + fir::FirOpBuilder &builder, mlir::Location loc, + const ElementalGeneratorWithBoolReturn &elementalGenerator, + mlir::Value initialCondition); + + /// Return the type of the elements of the array section. + mlir::Type getElementType() { return elementType; } + +private: + /// Common implementation for DoLoop and IterWhile loop creations. + template + mlir::Value loopOverElementsBase(fir::FirOpBuilder &builder, + mlir::Location loc, + const Generator &elementalGenerator, + mlir::Value initialCondition); + /// Create sliceOp for the designator. + mlir::Value createSlice(fir::FirOpBuilder &builder, mlir::Location loc); + + /// Create ExtendedValue the element inside the loop. + fir::ExtendedValue getElementAt(fir::FirOpBuilder &builder, + mlir::Location loc, mlir::Value shape, + mlir::Value slice, + mlir::ValueRange inductionVariables); + + /// Generate the [lb, ub, step] to loop over the section (in loop order, not + /// Fortran dimension order). + llvm::SmallVector> + genLoopBounds(fir::FirOpBuilder &builder, mlir::Location loc); + + /// Lowered base of the ranked array ref. + fir::ExtendedValue loweredBase; + /// Subscripts values of the rank arrayRef part. + llvm::SmallVector loweredSubscripts; + /// Scalar subscripts and components at the right of the ranked + /// array ref part of any. + llvm::SmallVector componentPath; + /// List of substring bounds if this is a substring (only the lower bound if + /// the upper is implicit). + MaybeSubstring substringBounds; + /// Type of the elements described by this array section. + mlir::Type elementType; +}; + +/// Lower \p expr, that must be an designator containing vector subscripts, to a +/// VectorSubscriptBox representation. This causes evaluation of all the +/// subscripts. Any required clean-ups from subscript expression are added to \p +/// stmtCtx. +VectorSubscriptBox genVectorSubscriptBox( + mlir::Location loc, Fortran::lower::AbstractConverter &converter, + Fortran::lower::StatementContext &stmtCtx, + const Fortran::evaluate::Expr &expr); + +} // namespace lower +} // namespace Fortran + +#endif // FORTRAN_LOWER_VECTORSUBSCRIPTS_H diff --git a/flang/include/flang/Optimizer/.clang-tidy b/flang/include/flang/Optimizer/.clang-tidy index 87ec2ff53af6e8..9cc942b8870a2e 100644 --- a/flang/include/flang/Optimizer/.clang-tidy +++ b/flang/include/flang/Optimizer/.clang-tidy @@ -1,5 +1,5 @@ -# Almost identical to the top-level .clang-tidy, except that {Member,Parameter,Variable}Case use camelBack. -Checks: '-*,clang-diagnostic-*,llvm-*,misc-*,-misc-unused-parameters,-misc-non-private-member-variables-in-classes,readability-identifier-naming' +Checks: '-readability-braces-around-statements,readability-identifier-naming,llvm-include-order,clang-diagnostic-*' +InheritParentConfig: true CheckOptions: - key: readability-identifier-naming.ClassCase value: CamelCase diff --git a/flang/include/flang/Optimizer/Analysis/IteratedDominanceFrontier.h b/flang/include/flang/Optimizer/Analysis/IteratedDominanceFrontier.h new file mode 100644 index 00000000000000..392dfbc130cfd6 --- /dev/null +++ b/flang/include/flang/Optimizer/Analysis/IteratedDominanceFrontier.h @@ -0,0 +1,95 @@ +//===- IteratedDominanceFrontier.h - Calculate IDF --------------*- C++ -*-===// +// +// 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 +// +//===----------------------------------------------------------------------===// +/// \file +/// Compute iterated dominance frontiers using a linear time algorithm. +/// +/// The algorithm used here is based on: +/// +/// Sreedhar and Gao. A linear time algorithm for placing phi-nodes. +/// In Proceedings of the 22nd ACM SIGPLAN-SIGACT Symposium on Principles of +/// Programming Languages +/// POPL '95. ACM, New York, NY, 62-73. +/// +/// It has been modified to not explicitly use the DJ graph data structure and +/// to directly compute pruned SSA using per-variable liveness information. +// +//===----------------------------------------------------------------------===// + +#ifndef FORTRAN_OPTIMIZER_ANALYSIS_ITERATEDDOMINANCEFRONTIER_H +#define FORTRAN_OPTIMIZER_ANALYSIS_ITERATEDDOMINANCEFRONTIER_H + +#include "mlir/Support/LLVM.h" + +namespace mlir { +class Block; +class DominanceInfo; +} // namespace mlir + +namespace fir { + +/// Determine the iterated dominance frontier, given a set of defining +/// blocks, and optionally, a set of live-in blocks. +/// +/// In turn, the results can be used to place phi nodes. +/// +/// This algorithm is a linear time computation of Iterated Dominance Frontiers, +/// pruned using the live-in set. +/// By default, liveness is not used to prune the IDF computation. +/// The template parameters should be either BasicBlock* or Inverse, depending on if you want the forward or reverse IDF. +template +class IDFCalculator { +public: + IDFCalculator(mlir::DominanceInfo &DT) : DT(DT), useLiveIn(false) {} + + /// Give the IDF calculator the set of blocks in which the value is + /// defined. This is equivalent to the set of starting blocks it should be + /// calculating the IDF for (though later gets pruned based on liveness). + /// + /// Note: This set *must* live for the entire lifetime of the IDF calculator. + void setDefiningBlocks(const llvm::SmallPtrSetImpl &Blocks) { + DefBlocks = &Blocks; + } + + /// Give the IDF calculator the set of blocks in which the value is + /// live on entry to the block. This is used to prune the IDF calculation to + /// not include blocks where any phi insertion would be dead. + /// + /// Note: This set *must* live for the entire lifetime of the IDF calculator. + void setLiveInBlocks(const llvm::SmallPtrSetImpl &Blocks) { + LiveInBlocks = &Blocks; + useLiveIn = true; + } + + /// Reset the live-in block set to be empty, and tell the IDF + /// calculator to not use liveness anymore. + void resetLiveInBlocks() { + LiveInBlocks = nullptr; + useLiveIn = false; + } + + /// Calculate iterated dominance frontiers + /// + /// This uses the linear-time phi algorithm based on DJ-graphs mentioned in + /// the file-level comment. It performs DF->IDF pruning using the live-in + /// set, to avoid computing the IDF for blocks where an inserted PHI node + /// would be dead. + void calculate(llvm::SmallVectorImpl &IDFBlocks); + +private: + mlir::DominanceInfo &DT; + bool useLiveIn; + const llvm::SmallPtrSetImpl *LiveInBlocks; + const llvm::SmallPtrSetImpl *DefBlocks; +}; + +typedef IDFCalculator ForwardIDFCalculator; + +} // namespace fir + +#endif // FORTRAN_OPTIMIZER_ANALYSIS_ITERATEDDOMINANCEFRONTIER_H diff --git a/flang/include/flang/Optimizer/Builder/BoxValue.h b/flang/include/flang/Optimizer/Builder/BoxValue.h new file mode 100644 index 00000000000000..bdaaefd80ea514 --- /dev/null +++ b/flang/include/flang/Optimizer/Builder/BoxValue.h @@ -0,0 +1,472 @@ +//===-- BoxValue.h -- internal box values -----------------------*- C++ -*-===// +// +// 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 +// +//===----------------------------------------------------------------------===// +// +// Coding style: https://mlir.llvm.org/getting_started/DeveloperGuide/ +// +//===----------------------------------------------------------------------===// + +#ifndef FORTRAN_OPTIMIZER_BUILDER_BOXVALUE_H +#define FORTRAN_OPTIMIZER_BUILDER_BOXVALUE_H + +#include "flang/Optimizer/Dialect/FIRType.h" +#include "flang/Optimizer/Support/FatalError.h" +#include "flang/Optimizer/Support/Matcher.h" +#include "mlir/IR/OperationSupport.h" +#include "mlir/IR/Value.h" +#include "llvm/ADT/SmallVector.h" +#include "llvm/Support/Compiler.h" +#include "llvm/Support/raw_ostream.h" +#include + +namespace fir { +class CharBoxValue; +class ArrayBoxValue; +class CharArrayBoxValue; +class ProcBoxValue; +class MutableBoxValue; +class BoxValue; + +llvm::raw_ostream &operator<<(llvm::raw_ostream &, const CharBoxValue &); +llvm::raw_ostream &operator<<(llvm::raw_ostream &, const ArrayBoxValue &); +llvm::raw_ostream &operator<<(llvm::raw_ostream &, const CharArrayBoxValue &); +llvm::raw_ostream &operator<<(llvm::raw_ostream &, const ProcBoxValue &); +llvm::raw_ostream &operator<<(llvm::raw_ostream &, const MutableBoxValue &); +llvm::raw_ostream &operator<<(llvm::raw_ostream &, const BoxValue &); + +//===----------------------------------------------------------------------===// +// +// Boxed values +// +// Define a set of containers used internally by the lowering bridge to keep +// track of extended values associated with a Fortran subexpression. These +// associations are maintained during the construction of FIR. +// +//===----------------------------------------------------------------------===// + +/// Most expressions of intrinsic type can be passed unboxed. Their properties +/// are known statically. +using UnboxedValue = mlir::Value; + +/// Abstract base class. +class AbstractBox { +public: + AbstractBox() = delete; + AbstractBox(mlir::Value addr) : addr{addr} {} + + /// FIXME: this comment is not true anymore since genLoad + /// is loading constant length characters. What is the impact /// ? + /// An abstract box always contains a memory reference to a value. + mlir::Value getAddr() const { return addr; } + +protected: + mlir::Value addr; +}; + +/// Expressions of CHARACTER type have an associated, possibly dynamic LEN +/// value. +class CharBoxValue : public AbstractBox { +public: + CharBoxValue(mlir::Value addr, mlir::Value len) + : AbstractBox{addr}, len{len} { + if (addr && addr.getType().template isa()) + fir::emitFatalError(addr.getLoc(), + "BoxChar should not be in CharBoxValue"); + } + + CharBoxValue clone(mlir::Value newBase) const { return {newBase, len}; } + + /// Convenience alias to get the memory reference to the buffer. + mlir::Value getBuffer() const { return getAddr(); } + + mlir::Value getLen() const { return len; } + friend llvm::raw_ostream &operator<<(llvm::raw_ostream &, + const CharBoxValue &); + LLVM_DUMP_METHOD void dump() const { llvm::errs() << *this; } + +protected: + mlir::Value len; +}; + +/// Abstract base class. +/// Expressions of type array have at minimum a shape. These expressions may +/// have lbound attributes (dynamic values) that affect the interpretation of +/// indexing expressions. +class AbstractArrayBox { +public: + AbstractArrayBox() = default; + AbstractArrayBox(llvm::ArrayRef extents, + llvm::ArrayRef lbounds) + : extents{extents.begin(), extents.end()}, lbounds{lbounds.begin(), + lbounds.end()} {} + + // Every array has extents that describe its shape. + const llvm::SmallVectorImpl &getExtents() const { + return extents; + } + + // An array expression may have user-defined lower bound values. + // If this vector is empty, the default in all dimensions in `1`. + const llvm::SmallVectorImpl &getLBounds() const { + return lbounds; + } + + bool lboundsAllOne() const { return lbounds.empty(); } + std::size_t rank() const { return extents.size(); } + +protected: + llvm::SmallVector extents; + llvm::SmallVector lbounds; +}; + +/// Expressions with rank > 0 have extents. They may also have lbounds that are +/// not 1. +class ArrayBoxValue : public AbstractBox, public AbstractArrayBox { +public: + ArrayBoxValue(mlir::Value addr, llvm::ArrayRef extents, + llvm::ArrayRef lbounds = {}) + : AbstractBox{addr}, AbstractArrayBox{extents, lbounds} {} + + ArrayBoxValue clone(mlir::Value newBase) const { + return {newBase, extents, lbounds}; + } + + friend llvm::raw_ostream &operator<<(llvm::raw_ostream &, + const ArrayBoxValue &); + LLVM_DUMP_METHOD void dump() const { llvm::errs() << *this; } +}; + +/// Expressions of type CHARACTER and with rank > 0. +class CharArrayBoxValue : public CharBoxValue, public AbstractArrayBox { +public: + CharArrayBoxValue(mlir::Value addr, mlir::Value len, + llvm::ArrayRef extents, + llvm::ArrayRef lbounds = {}) + : CharBoxValue{addr, len}, AbstractArrayBox{extents, lbounds} {} + + CharArrayBoxValue clone(mlir::Value newBase) const { + return {newBase, len, extents, lbounds}; + } + + CharBoxValue cloneElement(mlir::Value newBase) const { + return {newBase, len}; + } + + friend llvm::raw_ostream &operator<<(llvm::raw_ostream &, + const CharArrayBoxValue &); + LLVM_DUMP_METHOD void dump() const { llvm::errs() << *this; } +}; + +/// Expressions that are procedure POINTERs may need a set of references to +/// variables in the host scope. +class ProcBoxValue : public AbstractBox { +public: + ProcBoxValue(mlir::Value addr, mlir::Value context) + : AbstractBox{addr}, hostContext{context} {} + + ProcBoxValue clone(mlir::Value newBase) const { + return {newBase, hostContext}; + } + + mlir::Value getHostContext() const { return hostContext; } + + friend llvm::raw_ostream &operator<<(llvm::raw_ostream &, + const ProcBoxValue &); + LLVM_DUMP_METHOD void dump() const { llvm::errs() << *this; } + +protected: + mlir::Value hostContext; +}; + +/// Base class for values associated to a fir.box or fir.ref. +class AbstractIrBox : public AbstractBox, public AbstractArrayBox { +public: + AbstractIrBox(mlir::Value addr) : AbstractBox{addr} {} + AbstractIrBox(mlir::Value addr, llvm::ArrayRef lbounds, + llvm::ArrayRef extents) + : AbstractBox{addr}, AbstractArrayBox(extents, lbounds) {} + /// Get the fir.box part of the address type. + fir::BoxType getBoxTy() const { + auto type = getAddr().getType(); + if (auto pointedTy = fir::dyn_cast_ptrEleTy(type)) + type = pointedTy; + return type.cast(); + } + /// Return the part of the address type after memory and box types. That is + /// the element type, maybe wrapped in a fir.array type. + mlir::Type getBaseTy() const { + return fir::dyn_cast_ptrOrBoxEleTy(getBoxTy()); + } + + /// Return the memory type of the data address inside the box: + /// - for fir.box>, return fir.ptr + /// - for fir.box>, return fir.heap + /// - for fir.box, return fir.ref + mlir::Type getMemTy() const { + auto ty = getBoxTy().getEleTy(); + if (fir::isa_ref_type(ty)) + return ty; + return fir::ReferenceType::get(ty); + } + + /// Get the scalar type related to the described entity + mlir::Type getEleTy() const { + auto type = getBaseTy(); + if (auto seqTy = type.dyn_cast()) + return seqTy.getEleTy(); + return type; + } + + /// Is the entity an array or an assumed rank ? + bool hasRank() const { return getBaseTy().isa(); } + /// Is this an assumed rank ? + bool hasAssumedRank() const { + auto seqTy = getBaseTy().dyn_cast(); + return seqTy && seqTy.hasUnknownShape(); + } + /// Returns the rank of the entity. Beware that zero will be returned for + /// both scalars and assumed rank. + unsigned rank() const { + if (auto seqTy = getBaseTy().dyn_cast()) + return seqTy.getDimension(); + return 0; + } + /// Is this a character entity ? + bool isCharacter() const { return fir::isa_char(getEleTy()); }; + /// Is this a derived type entity ? + bool isDerived() const { return getEleTy().isa(); }; + + bool isDerivedWithLengthParameters() const { + auto record = getEleTy().dyn_cast(); + return record && record.getNumLenParams() != 0; + }; + /// Is this a CLASS(*)/TYPE(*) ? + bool isUnlimitedPolymorphic() const { + return getEleTy().isa(); + } +}; + +/// An entity described by a fir.box value that cannot be read into +/// another ExtendedValue category, either because the fir.box may be an +/// absent optional and we need to wait until the user is referencing it +/// to read it, or because it contains important information that cannot +/// be exposed in FIR (e.g. non contiguous byte stride). +/// It may also store explicit bounds or length parameters that were specified +/// for the entity. +class BoxValue : public AbstractIrBox { +public: + BoxValue(mlir::Value addr) : AbstractIrBox{addr} { assert(verify()); } + BoxValue(mlir::Value addr, llvm::ArrayRef lbounds, + llvm::ArrayRef explicitParams, + llvm::ArrayRef explicitExtents = {}) + : AbstractIrBox{addr, lbounds, explicitExtents}, + explicitParams{explicitParams.begin(), explicitParams.end()} { + assert(verify()); + } + // TODO: check contiguous attribute of addr + bool isContiguous() const { return false; } + + friend llvm::raw_ostream &operator<<(llvm::raw_ostream &, const BoxValue &); + LLVM_DUMP_METHOD void dump() const { llvm::errs() << *this; } + + llvm::ArrayRef getLBounds() const { return lbounds; } + + // The extents member is not guaranteed to be field for arrays. It is only + // guaranteed to be field for explicit shape arrays. In general, + // explicit-shape will not come as descriptors, so this field will be empty in + // most cases. The exception are derived types with length parameters and + // polymorphic dummy argument arrays. It may be possible for the explicit + // extents to conflict with the shape information that is in the box according + // to 15.5.2.11 sequence association rules. + llvm::ArrayRef getExplicitExtents() const { return extents; } + + llvm::ArrayRef getExplicitParameters() const { + return explicitParams; + } + +protected: + // Verify constructor invariants. + bool verify() const; + + // Only field when the BoxValue has explicit length parameters. + // Otherwise, the length parameters are in the fir.box. + llvm::SmallVector explicitParams; +}; + +/// Set of variables (addresses) holding the allocatable properties. These may +/// be empty in case it is not deemed safe to duplicate the descriptor +/// information locally (For instance, a volatile allocatable will always be +/// lowered to a descriptor to preserve the integrity of the entity and its +/// associated properties. As such, all references to the entity and its +/// property will go through the descriptor explicitly.). +class MutableProperties { +public: + bool isEmpty() const { return !addr; } + mlir::Value addr; + llvm::SmallVector extents; + llvm::SmallVector lbounds; + /// Only keep track of the deferred length parameters through variables, since + /// they are the only ones that can change as per the deferred type parameters + /// definition in F2018 standard section 3.147.12.2. + /// Non-deferred values are returned by + /// MutableBoxValue.nonDeferredLenParams(). + llvm::SmallVector deferredParams; +}; + +/// MutableBoxValue is used for entities that are represented by the address of +/// a box. This is intended to be used for entities whose base address, shape +/// and type are not constant in the entity lifetime (e.g Allocatables and +/// Pointers). +class MutableBoxValue : public AbstractIrBox { +public: + /// Create MutableBoxValue given the address \p addr of the box and the non + /// deferred length parameters \p lenParameters. The non deferred length + /// parameters must always be provided, even if they are constant and already + /// reflected in the address type. + MutableBoxValue(mlir::Value addr, mlir::ValueRange lenParameters, + MutableProperties mutableProperties) + : AbstractIrBox(addr), lenParams{lenParameters.begin(), + lenParameters.end()}, + mutableProperties{mutableProperties} { + // Currently only accepts fir.(ref/ptr/heap)> mlir::Value for + // the address. This may change if we accept + // fir.(ref/ptr/heap)> for scalar without length parameters. + assert(verify() && + "MutableBoxValue requires mem ref to fir.box>"); + } + /// Is this a Fortran pointer ? + bool isPointer() const { + return getBoxTy().getEleTy().isa(); + } + /// Is this an allocatable ? + bool isAllocatable() const { + return getBoxTy().getEleTy().isa(); + } + /// Does this entity has any non deferred length parameters ? + bool hasNonDeferredLenParams() const { return !lenParams.empty(); } + /// Return the non deferred length parameters. + llvm::ArrayRef nonDeferredLenParams() const { return lenParams; } + friend llvm::raw_ostream &operator<<(llvm::raw_ostream &, + const MutableBoxValue &); + LLVM_DUMP_METHOD void dump() const { llvm::errs() << *this; } + + /// Set of variable is used instead of a descriptor to hold the entity + /// properties instead of a fir.ref>. + bool isDescribedByVariables() const { return !mutableProperties.isEmpty(); } + + const MutableProperties &getMutableProperties() const { + return mutableProperties; + } + +protected: + /// Validate the address type form in the constructor. + bool verify() const; + /// Hold the non-deferred length parameter values (both for characters and + /// derived). Non-deferred length parameters cannot change dynamically, as + /// opposed to deferred type parameters (3.147.12.2). + llvm::SmallVector lenParams; + /// Set of variables holding the extents, lower bounds and + /// base address when it is deemed safe to work with these variables rather + /// than directly with a descriptor. + MutableProperties mutableProperties; +}; + +class ExtendedValue; + +/// Get the base value of an extended value. Every type of extended value has a +/// base value or is null. +mlir::Value getBase(const ExtendedValue &exv); + +/// Get the LEN property value of an extended value. CHARACTER values have a LEN +/// property. +mlir::Value getLen(const ExtendedValue &exv); + +/// Pretty-print an extended value. +llvm::raw_ostream &operator<<(llvm::raw_ostream &, const ExtendedValue &); + +/// Return a clone of the extended value `exv` with the base value `base` +/// substituted. +ExtendedValue substBase(const ExtendedValue &exv, mlir::Value base); + +/// Is the extended value `exv` an array? +bool isArray(const ExtendedValue &exv); + +/// Get the type parameters for `exv`. +llvm::SmallVector getTypeParams(const ExtendedValue &exv); + +/// An extended value is a box of values pertaining to a discrete entity. It is +/// used in lowering to track all the runtime values related to an entity. For +/// example, an entity may have an address in memory that contains its value(s) +/// as well as various attribute values that describe the shape and starting +/// indices if it is an array entity. +class ExtendedValue : public details::matcher { +public: + using VT = + std::variant; + + ExtendedValue() : box{UnboxedValue{}} {} + template , ExtendedValue>>> + constexpr ExtendedValue(A &&a) : box{std::forward(a)} { + if (auto b = getUnboxed()) { + if (*b) { + auto type = b->getType(); + if (type.template isa()) + fir::emitFatalError(b->getLoc(), "BoxChar should be unboxed"); + if (auto refType = type.template dyn_cast()) + type = refType.getEleTy(); + if (auto seqType = type.template dyn_cast()) + type = seqType.getEleTy(); + if (fir::isa_char(type)) + fir::emitFatalError(b->getLoc(), + "character buffer should be in CharBoxValue"); + } + } + } + + template + constexpr const A *getBoxOf() const { + return std::get_if(&box); + } + + constexpr const CharBoxValue *getCharBox() const { + return getBoxOf(); + } + + constexpr const UnboxedValue *getUnboxed() const { + return getBoxOf(); + } + + unsigned rank() const { + return match([](const fir::UnboxedValue &box) -> unsigned { return 0; }, + [](const fir::CharBoxValue &box) -> unsigned { return 0; }, + [](const fir::ProcBoxValue &box) -> unsigned { return 0; }, + [](const auto &box) -> unsigned { return box.rank(); }); + } + + /// LLVM style debugging of extended values + LLVM_DUMP_METHOD void dump() const { llvm::errs() << *this << '\n'; } + + friend llvm::raw_ostream &operator<<(llvm::raw_ostream &, + const ExtendedValue &); + + const VT &matchee() const { return box; } + +private: + VT box; +}; + +/// Is the extended value `exv` unboxed and non-null? +inline bool isUnboxedValue(const ExtendedValue &exv) { + return exv.match( + [](const fir::UnboxedValue &box) { return box ? true : false; }, + [](const auto &) { return false; }); +} +} // namespace fir + +#endif // FORTRAN_OPTIMIZER_BUILDER_BOXVALUE_H diff --git a/flang/include/flang/Optimizer/Builder/Character.h b/flang/include/flang/Optimizer/Builder/Character.h new file mode 100644 index 00000000000000..cad0a0d53f2a82 --- /dev/null +++ b/flang/include/flang/Optimizer/Builder/Character.h @@ -0,0 +1,187 @@ +//===-- Character.h -- lowering of characters -------------------*- C++ -*-===// +// +// 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 +// +//===----------------------------------------------------------------------===// +// +// Coding style: https://mlir.llvm.org/getting_started/DeveloperGuide/ +// +//===----------------------------------------------------------------------===// + +#ifndef FORTRAN_OPTIMIZER_BUILDER_CHARACTER_H +#define FORTRAN_OPTIMIZER_BUILDER_CHARACTER_H + +#include "flang/Optimizer/Builder/BoxValue.h" +#include "flang/Optimizer/Builder/FIRBuilder.h" + +namespace fir::factory { + +/// Helper to facilitate lowering of CHARACTER in FIR. +class CharacterExprHelper { +public: + /// Constructor. + explicit CharacterExprHelper(FirOpBuilder &builder, mlir::Location loc) + : builder{builder}, loc{loc} {} + CharacterExprHelper(const CharacterExprHelper &) = delete; + + /// Copy the \p count first characters of \p src into \p dest. + /// \p count can have any integer type. + void createCopy(const fir::CharBoxValue &dest, const fir::CharBoxValue &src, + mlir::Value count); + + /// Set characters of \p str at position [\p lower, \p upper) to blanks. + /// \p lower and \upper bounds are zero based. + /// If \p upper <= \p lower, no padding is done. + /// \p upper and \p lower can have any integer type. + void createPadding(const fir::CharBoxValue &str, mlir::Value lower, + mlir::Value upper); + + /// Create str(lb:ub), lower bounds must always be specified, upper + /// bound is optional. + fir::CharBoxValue createSubstring(const fir::CharBoxValue &str, + llvm::ArrayRef bounds); + + /// Return blank character of given \p type !fir.char + mlir::Value createBlankConstant(fir::CharacterType type); + + /// Lower \p lhs = \p rhs where \p lhs and \p rhs are scalar characters. + /// It handles cases where \p lhs and \p rhs may overlap. + void createAssign(const fir::ExtendedValue &lhs, + const fir::ExtendedValue &rhs); + + /// Create lhs // rhs in temp obtained with fir.alloca + fir::CharBoxValue createConcatenate(const fir::CharBoxValue &lhs, + const fir::CharBoxValue &rhs); + + /// LEN_TRIM intrinsic. + mlir::Value createLenTrim(const fir::CharBoxValue &str); + + /// Embox \p addr and \p len and return fir.boxchar. + /// Take care of type conversions before emboxing. + /// \p len is converted to the integer type for character lengths if needed. + mlir::Value createEmboxChar(mlir::Value addr, mlir::Value len); + /// Create a fir.boxchar for \p str. If \p str is not in memory, a temp is + /// allocated to create the fir.boxchar. + mlir::Value createEmbox(const fir::CharBoxValue &str); + /// Embox a string array. Note that the size/shape of the array is not + /// retrievable from the resulting mlir::Value. + mlir::Value createEmbox(const fir::CharArrayBoxValue &str); + + /// Convert character array to a scalar by reducing the extents into the + /// length. Will fail if call on non reference like base. + fir::CharBoxValue toScalarCharacter(const fir::CharArrayBoxValue &); + + /// Unbox \p boxchar into (fir.ref>, character length type). + std::pair createUnboxChar(mlir::Value boxChar); + + /// Allocate a temp of fir::CharacterType type and length len. + /// Returns related fir.ref>>. + fir::CharBoxValue createCharacterTemp(mlir::Type type, mlir::Value len); + + /// Allocate a temp of compile time constant length. + /// Returns related fir.ref>>. + fir::CharBoxValue createCharacterTemp(mlir::Type type, int len); + + /// Create a temporary with the same kind, length, and value as source. + fir::CharBoxValue createTempFrom(const fir::ExtendedValue &source); + + /// Return true if \p type is a character literal type (is + /// `fir.array>`).; + static bool isCharacterLiteral(mlir::Type type); + + /// Return true if \p type is one of the following type + /// - fir.boxchar + /// - fir.ref> + /// - fir.char + static bool isCharacterScalar(mlir::Type type); + + /// Does this extended value base type is fir.char + /// where len is not the unknown extent ? + static bool hasConstantLengthInType(const fir::ExtendedValue &); + + /// Extract the kind of a character type + static fir::KindTy getCharacterKind(mlir::Type type); + + /// Extract the kind of a character or array of character type. + static fir::KindTy getCharacterOrSequenceKind(mlir::Type type); + + /// Determine the base character type + static fir::CharacterType getCharacterType(mlir::Type type); + static fir::CharacterType getCharacterType(const fir::CharBoxValue &box); + static fir::CharacterType getCharacterType(mlir::Value str); + + /// Create an extended value from a value of type: + /// - fir.boxchar + /// - fir.ref> + /// - fir.char + /// or the array versions: + /// - fir.ref>> + /// - fir.array> + /// + /// Does the heavy lifting of converting the value \p character (along with an + /// optional \p len value) to an extended value. If \p len is null, a length + /// value is extracted from \p character (or its type). This will produce an + /// error if it's not possible. The returned value is a CharBoxValue if \p + /// character is a scalar, otherwise it is a CharArrayBoxValue. + fir::ExtendedValue toExtendedValue(mlir::Value character, + mlir::Value len = {}); + + /// Is `type` a sequence (array) of CHARACTER type? Return true for any of the + /// following cases: + /// - !fir.array> + /// - !fir.ref where T is either of the first case + /// - !fir.box where T is either of the first case + /// + /// In certain contexts, Fortran allows an array of CHARACTERs to be treated + /// as if it were one longer CHARACTER scalar, each element append to the + /// previous. + static bool isArray(mlir::Type type); + + /// Temporary helper to help migrating towards properties of + /// ExtendedValue containing characters. + /// Mainly, this ensure that characters are always CharArrayBoxValue, + /// CharBoxValue, or BoxValue and that the base address is not a boxchar. + /// Return the argument if this is not a character. + /// TODO: Create and propagate ExtendedValue according to properties listed + /// above instead of fixing it when needed. + fir::ExtendedValue cleanUpCharacterExtendedValue(const fir::ExtendedValue &); + + /// Create fir.char singleton from \p code integer value. + mlir::Value createSingletonFromCode(mlir::Value code, int kind); + /// Returns integer value held in a character singleton. + mlir::Value extractCodeFromSingleton(mlir::Value singleton); + + /// Compute length given a fir.box describing a character entity. + /// It adjusts the length from the number of bytes per the descriptor + /// to the number of characters per the Fortran KIND. + mlir::Value readLengthFromBox(mlir::Value box); + +private: + /// FIXME: the implementation also needs a clean-up now that + /// CharBoxValue are better propagated. + fir::CharBoxValue materializeValue(mlir::Value str); + mlir::Value getCharBoxBuffer(const fir::CharBoxValue &box); + mlir::Value createElementAddr(mlir::Value buffer, mlir::Value index); + mlir::Value createLoadCharAt(mlir::Value buff, mlir::Value index); + void createStoreCharAt(mlir::Value str, mlir::Value index, mlir::Value c); + void createLengthOneAssign(const fir::CharBoxValue &lhs, + const fir::CharBoxValue &rhs); + void createAssign(const fir::CharBoxValue &lhs, const fir::CharBoxValue &rhs); + mlir::Value createBlankConstantCode(fir::CharacterType type); + +private: + FirOpBuilder &builder; + mlir::Location loc; +}; + +// FIXME: Move these to Optimizer +mlir::FuncOp getLlvmMemcpy(FirOpBuilder &builder); +mlir::FuncOp getLlvmMemmove(FirOpBuilder &builder); +mlir::FuncOp getLlvmMemset(FirOpBuilder &builder); +mlir::FuncOp getRealloc(FirOpBuilder &builder); + +} // namespace fir::factory + +#endif // FORTRAN_OPTIMIZER_BUILDER_CHARACTER_H diff --git a/flang/include/flang/Lower/ComplexExpr.h b/flang/include/flang/Optimizer/Builder/Complex.h similarity index 84% rename from flang/include/flang/Lower/ComplexExpr.h rename to flang/include/flang/Optimizer/Builder/Complex.h index d3600a0cda6a5e..1fefa91552286b 100644 --- a/flang/include/flang/Lower/ComplexExpr.h +++ b/flang/include/flang/Optimizer/Builder/Complex.h @@ -1,17 +1,21 @@ -//===-- Lower/ComplexExpr.h -- lowering of complex values -------*- C++ -*-===// +//===-- Complex.h -- lowering of complex values -----------------*- C++ -*-===// // // 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 // //===----------------------------------------------------------------------===// +// +// Coding style: https://mlir.llvm.org/getting_started/DeveloperGuide/ +// +//===----------------------------------------------------------------------===// -#ifndef FORTRAN_LOWER_COMPLEXEXPR_H -#define FORTRAN_LOWER_COMPLEXEXPR_H +#ifndef FORTRAN_OPTIMIZER_BUILDER_COMPLEX_H +#define FORTRAN_OPTIMIZER_BUILDER_COMPLEX_H -#include "flang/Lower/FIRBuilder.h" +#include "flang/Optimizer/Builder/FIRBuilder.h" -namespace Fortran::lower { +namespace fir::factory { /// Helper to facilitate lowering of COMPLEX manipulations in FIR. class ComplexExprHelper { @@ -51,9 +55,6 @@ class ComplexExprHelper { : insert(cplx, part); } - mlir::Value createComplexCompare(mlir::Value cplx1, mlir::Value cplx2, - bool eq); - protected: template mlir::Value extract(mlir::Value cplx) { @@ -78,6 +79,6 @@ class ComplexExprHelper { mlir::Location loc; }; -} // namespace Fortran::lower +} // namespace fir::factory -#endif // FORTRAN_LOWER_COMPLEXEXPR_H +#endif // FORTRAN_OPTIMIZER_BUILDER_COMPLEX_H diff --git a/flang/include/flang/Lower/DoLoopHelper.h b/flang/include/flang/Optimizer/Builder/DoLoopHelper.h similarity index 61% rename from flang/include/flang/Lower/DoLoopHelper.h rename to flang/include/flang/Optimizer/Builder/DoLoopHelper.h index 12901e9eb7a6d4..9390a099c800bd 100644 --- a/flang/include/flang/Lower/DoLoopHelper.h +++ b/flang/include/flang/Optimizer/Builder/DoLoopHelper.h @@ -1,27 +1,31 @@ -//===-- Lower/DoLoopHelper.h -- gen fir.do_loop ops -------------*- C++ -*-===// +//===-- DoLoopHelper.h -- gen fir.do_loop ops -------------------*- C++ -*-===// // // 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 // //===----------------------------------------------------------------------===// +// +// Coding style: https://mlir.llvm.org/getting_started/DeveloperGuide/ +// +//===----------------------------------------------------------------------===// -#ifndef FORTRAN_LOWER_DOLOOPHELPER_H -#define FORTRAN_LOWER_DOLOOPHELPER_H +#ifndef FORTRAN_OPTIMIZER_BUILDER_DOLOOPHELPER_H +#define FORTRAN_OPTIMIZER_BUILDER_DOLOOPHELPER_H -#include "flang/Lower/FIRBuilder.h" +#include "flang/Optimizer/Builder/FIRBuilder.h" -namespace Fortran::lower { +namespace fir::factory { /// Helper to build fir.do_loop Ops. class DoLoopHelper { public: - explicit DoLoopHelper(FirOpBuilder &builder, mlir::Location loc) + explicit DoLoopHelper(fir::FirOpBuilder &builder, mlir::Location loc) : builder(builder), loc(loc) {} DoLoopHelper(const DoLoopHelper &) = delete; /// Type of a callback to generate the loop body. - using BodyGenerator = std::function; + using BodyGenerator = std::function; /// Build loop [\p lb, \p ub] with step \p step. /// If \p step is an empty value, 1 is used for the step. @@ -36,10 +40,10 @@ class DoLoopHelper { void createLoop(mlir::Value count, const BodyGenerator &bodyGenerator); private: - FirOpBuilder &builder; + fir::FirOpBuilder &builder; mlir::Location loc; }; -} // namespace Fortran::lower +} // namespace fir::factory -#endif // FORTRAN_LOWER_DOLOOPHELPER_H +#endif // FORTRAN_OPTIMIZER_BUILDER_DOLOOPHELPER_H diff --git a/flang/include/flang/Optimizer/Builder/FIRBuilder.h b/flang/include/flang/Optimizer/Builder/FIRBuilder.h new file mode 100644 index 00000000000000..979e128d55c468 --- /dev/null +++ b/flang/include/flang/Optimizer/Builder/FIRBuilder.h @@ -0,0 +1,464 @@ +//===-- FirBuilder.h -- FIR operation builder -------------------*- C++ -*-===// +// +// 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 +// +//===----------------------------------------------------------------------===// +// +// Builder routines for constructing the FIR dialect of MLIR. As FIR is a +// dialect of MLIR, it makes extensive use of MLIR interfaces and MLIR's coding +// style (https://mlir.llvm.org/getting_started/DeveloperGuide/) is used in this +// module. +// +//===----------------------------------------------------------------------===// + +#ifndef FORTRAN_OPTIMIZER_BUILDER_FIRBUILDER_H +#define FORTRAN_OPTIMIZER_BUILDER_FIRBUILDER_H + +#include "flang/Optimizer/Dialect/FIROps.h" +#include "flang/Optimizer/Dialect/FIRType.h" +#include "flang/Optimizer/Support/KindMapping.h" +#include "mlir/IR/Builders.h" +#include "mlir/IR/BuiltinOps.h" +#include "llvm/ADT/DenseMap.h" +#include "llvm/ADT/Optional.h" + +namespace fir { +class AbstractArrayBox; +class ExtendedValue; +class BoxValue; + +//===----------------------------------------------------------------------===// +// FirOpBuilder +//===----------------------------------------------------------------------===// + +/// Extends the MLIR OpBuilder to provide methods for building common FIR +/// patterns. +class FirOpBuilder : public mlir::OpBuilder { +public: + explicit FirOpBuilder(mlir::Operation *op, const fir::KindMapping &kindMap) + : OpBuilder{op}, kindMap{kindMap} {} + explicit FirOpBuilder(mlir::OpBuilder &builder, + const fir::KindMapping &kindMap) + : OpBuilder{builder}, kindMap{kindMap} {} + + /// Get the current Region of the insertion point. + mlir::Region &getRegion() { return *getBlock()->getParent(); } + + /// Get the current Module + mlir::ModuleOp getModule() { + return getRegion().getParentOfType(); + } + + /// Get the current Function + mlir::FuncOp getFunction() { + return getRegion().getParentOfType(); + } + + /// Get a reference to the kind map. + const fir::KindMapping &getKindMap() { return kindMap; } + + /// The LHS and RHS are not always in agreement in terms of + /// type. In some cases, the disagreement is between COMPLEX and other scalar + /// types. In that case, the conversion must insert/extract out of a COMPLEX + /// value to have the proper semantics and be strongly typed. + mlir::Value convertWithSemantics(mlir::Location loc, mlir::Type toTy, + mlir::Value val); + + /// Get the entry block of the current Function + mlir::Block *getEntryBlock() { return &getFunction().front(); } + + /// Get the block for adding Allocas. If OpenMP is enabled then get the + /// the alloca block from an Operation which can be Outlined. Otherwise + /// use the entry block of the current Function + mlir::Block *getAllocaBlock(); + + /// Safely create a reference type to the type `eleTy`. + mlir::Type getRefType(mlir::Type eleTy); + + /// Create a sequence of `eleTy` with `rank` dimensions of unknown size. + mlir::Type getVarLenSeqTy(mlir::Type eleTy, unsigned rank = 1); + + /// Get character length type + mlir::Type getCharacterLengthType() { return getIndexType(); } + + /// Get the integer type whose bit width corresponds to the width of pointer + /// types, or is bigger. + mlir::Type getIntPtrType() { + // TODO: Delay the need of such type until codegen or find a way to use + // llvm::DataLayout::getPointerSizeInBits here. + return getI64Type(); + } + + /// Get the mlir real type that implements fortran REAL(kind). + mlir::Type getRealType(int kind); + + /// Create a null constant memory reference of type \p ptrType. + /// If \p ptrType is not provided, !fir.ref type will be used. + mlir::Value createNullConstant(mlir::Location loc, mlir::Type ptrType = {}); + + /// Create an integer constant of type \p type and value \p i. + mlir::Value createIntegerConstant(mlir::Location loc, mlir::Type integerType, + std::int64_t i); + + /// Create a real constant from an integer value. + mlir::Value createRealConstant(mlir::Location loc, mlir::Type realType, + llvm::APFloat::integerPart val); + + /// Create a real constant from an APFloat value. + mlir::Value createRealConstant(mlir::Location loc, mlir::Type realType, + const llvm::APFloat &val); + + /// Create a real constant of type \p realType with a value zero. + mlir::Value createRealZeroConstant(mlir::Location loc, mlir::Type realType) { + return createRealConstant(loc, realType, 0u); + } + + /// Create a slot for a local on the stack. Besides the variable's type and + /// shape, it may be given name or target attributes. + mlir::Value allocateLocal(mlir::Location loc, mlir::Type ty, + llvm::StringRef uniqName, llvm::StringRef name, + llvm::ArrayRef shape, + llvm::ArrayRef lenParams, + bool asTarget = false); + + /// Create a temporary. A temp is allocated using `fir.alloca` and can be read + /// and written using `fir.load` and `fir.store`, resp. The temporary can be + /// given a name via a front-end `Symbol` or a `StringRef`. + mlir::Value createTemporary(mlir::Location loc, mlir::Type type, + llvm::StringRef name = {}, + mlir::ValueRange shape = {}, + mlir::ValueRange lenParams = {}, + llvm::ArrayRef attrs = {}); + + /// Create an unnamed and untracked temporary on the stack. + mlir::Value createTemporary(mlir::Location loc, mlir::Type type, + mlir::ValueRange shape) { + return createTemporary(loc, type, llvm::StringRef{}, shape); + } + + mlir::Value createTemporary(mlir::Location loc, mlir::Type type, + llvm::ArrayRef attrs) { + return createTemporary(loc, type, llvm::StringRef{}, {}, {}, attrs); + } + + mlir::Value createTemporary(mlir::Location loc, mlir::Type type, + llvm::StringRef name, + llvm::ArrayRef attrs) { + return createTemporary(loc, type, name, {}, {}, attrs); + } + + /// Create a global value. + fir::GlobalOp createGlobal(mlir::Location loc, mlir::Type type, + llvm::StringRef name, + mlir::StringAttr linkage = {}, + mlir::Attribute value = {}, bool isConst = false); + + fir::GlobalOp createGlobal(mlir::Location loc, mlir::Type type, + llvm::StringRef name, bool isConst, + std::function bodyBuilder, + mlir::StringAttr linkage = {}); + + /// Create a global constant (read-only) value. + fir::GlobalOp createGlobalConstant(mlir::Location loc, mlir::Type type, + llvm::StringRef name, + mlir::StringAttr linkage = {}, + mlir::Attribute value = {}) { + return createGlobal(loc, type, name, linkage, value, /*isConst=*/true); + } + + fir::GlobalOp + createGlobalConstant(mlir::Location loc, mlir::Type type, + llvm::StringRef name, + std::function bodyBuilder, + mlir::StringAttr linkage = {}) { + return createGlobal(loc, type, name, /*isConst=*/true, bodyBuilder, + linkage); + } + + /// Convert a StringRef string into a fir::StringLitOp. + fir::StringLitOp createStringLitOp(mlir::Location loc, + llvm::StringRef string); + + //===--------------------------------------------------------------------===// + // Linkage helpers (inline). The default linkage is external. + //===--------------------------------------------------------------------===// + + mlir::StringAttr createCommonLinkage() { return getStringAttr("common"); } + + mlir::StringAttr createInternalLinkage() { return getStringAttr("internal"); } + + mlir::StringAttr createLinkOnceLinkage() { return getStringAttr("linkonce"); } + + mlir::StringAttr createWeakLinkage() { return getStringAttr("weak"); } + + /// Get a function by name. If the function exists in the current module, it + /// is returned. Otherwise, a null FuncOp is returned. + mlir::FuncOp getNamedFunction(llvm::StringRef name) { + return getNamedFunction(getModule(), name); + } + + static mlir::FuncOp getNamedFunction(mlir::ModuleOp module, + llvm::StringRef name); + + fir::GlobalOp getNamedGlobal(llvm::StringRef name) { + return getNamedGlobal(getModule(), name); + } + + static fir::GlobalOp getNamedGlobal(mlir::ModuleOp module, + llvm::StringRef name); + + /// Lazy creation of fir.convert op. + mlir::Value createConvert(mlir::Location loc, mlir::Type toTy, + mlir::Value val); + + /// Create a new FuncOp. If the function may have already been created, use + /// `addNamedFunction` instead. + mlir::FuncOp createFunction(mlir::Location loc, llvm::StringRef name, + mlir::FunctionType ty) { + return createFunction(loc, getModule(), name, ty); + } + + static mlir::FuncOp createFunction(mlir::Location loc, mlir::ModuleOp module, + llvm::StringRef name, + mlir::FunctionType ty); + + /// Determine if the named function is already in the module. Return the + /// instance if found, otherwise add a new named function to the module. + mlir::FuncOp addNamedFunction(mlir::Location loc, llvm::StringRef name, + mlir::FunctionType ty) { + if (auto func = getNamedFunction(name)) + return func; + return createFunction(loc, name, ty); + } + + static mlir::FuncOp addNamedFunction(mlir::Location loc, + mlir::ModuleOp module, + llvm::StringRef name, + mlir::FunctionType ty) { + if (auto func = getNamedFunction(module, name)) + return func; + return createFunction(loc, module, name, ty); + } + + /// Cast the input value to IndexType. + mlir::Value convertToIndexType(mlir::Location loc, mlir::Value val) { + return createConvert(loc, getIndexType(), val); + } + + /// Construct one of the two forms of shape op from an array box. + mlir::Value genShape(mlir::Location loc, const fir::AbstractArrayBox &arr); + mlir::Value genShape(mlir::Location loc, llvm::ArrayRef shift, + llvm::ArrayRef exts); + mlir::Value genShape(mlir::Location loc, llvm::ArrayRef exts); + + /// Create one of the shape ops given an extended value. For a boxed value, + /// this may create a `fir.shift` op. + mlir::Value createShape(mlir::Location loc, const fir::ExtendedValue &exv); + + /// Create a slice op extended value. The value to be sliced, `exv`, must be + /// an array. + mlir::Value createSlice(mlir::Location loc, const fir::ExtendedValue &exv, + mlir::ValueRange triples, mlir::ValueRange path); + + /// Create a boxed value (Fortran descriptor) to be passed to the runtime. + /// \p exv is an extended value holding a memory reference to the object that + /// must be boxed. This function will crash if provided something that is not + /// a memory reference type. + /// Array entities are boxed with a shape and character with their length. + mlir::Value createBox(mlir::Location loc, const fir::ExtendedValue &exv); + + /// Create constant i1 with value 1. if \p b is true or 0. otherwise + mlir::Value createBool(mlir::Location loc, bool b) { + return createIntegerConstant(loc, getIntegerType(1), b ? 1 : 0); + } + + //===--------------------------------------------------------------------===// + // If-Then-Else generation helper + //===--------------------------------------------------------------------===// + + /// Helper class to create if-then-else in a structured way: + /// Usage: genIfOp().then([&](){...}).else([&](){...}).end(); + /// Alternatively, getResults() can be used instead of end() to end the ifOp + /// and get the ifOp results. + class IfBuilder { + public: + IfBuilder(fir::IfOp ifOp, FirOpBuilder &builder) + : ifOp{ifOp}, builder{builder} {} + template + IfBuilder &genThen(CC func) { + builder.setInsertionPointToStart(&ifOp.thenRegion().front()); + func(); + return *this; + } + template + IfBuilder &genElse(CC func) { + assert(!ifOp.elseRegion().empty() && "must have else region"); + builder.setInsertionPointToStart(&ifOp.elseRegion().front()); + func(); + return *this; + } + void end() { builder.setInsertionPointAfter(ifOp); } + + /// End the IfOp and return the results if any. + mlir::Operation::result_range getResults() { + end(); + return ifOp.getResults(); + } + + private: + fir::IfOp ifOp; + FirOpBuilder &builder; + }; + + /// Create an IfOp and returns an IfBuilder that can generate the else/then + /// bodies. + IfBuilder genIfOp(mlir::Location loc, mlir::TypeRange results, + mlir::Value cdt, bool withElseRegion) { + auto op = create(loc, results, cdt, withElseRegion); + return IfBuilder(op, *this); + } + + /// Create an IfOp with no "else" region, and no result values. + /// Usage: genIfThen(loc, cdt).genThen(lambda).end(); + IfBuilder genIfThen(mlir::Location loc, mlir::Value cdt) { + auto op = create(loc, llvm::None, cdt, false); + return IfBuilder(op, *this); + } + + /// Create an IfOp with an "else" region, and no result values. + /// Usage: genIfThenElse(loc, cdt).genThen(lambda).genElse(lambda).end(); + IfBuilder genIfThenElse(mlir::Location loc, mlir::Value cdt) { + auto op = create(loc, llvm::None, cdt, true); + return IfBuilder(op, *this); + } + + /// Generate code testing \p addr is not a null address. + mlir::Value genIsNotNull(mlir::Location loc, mlir::Value addr); + + /// Generate code testing \p addr is a null address. + mlir::Value genIsNull(mlir::Location loc, mlir::Value addr); + +private: + const KindMapping &kindMap; +}; + +} // namespace fir + +namespace fir::factory { + +//===--------------------------------------------------------------------===// +// ExtendedValue inquiry helpers +//===--------------------------------------------------------------------===// + +/// Read or get character length from \p box that must contain a character +/// entity. If the length value is contained in the ExtendedValue, this will +/// not generate any code, otherwise this will generate a read of the fir.box +/// describing the entity. +mlir::Value readCharLen(fir::FirOpBuilder &builder, mlir::Location loc, + const fir::ExtendedValue &box); + +/// Read or get the extent in dimension \p dim of the array described by \p box. +mlir::Value readExtent(fir::FirOpBuilder &builder, mlir::Location loc, + const fir::ExtendedValue &box, unsigned dim); + +/// Read or get the lower bound in dimension \p dim of the array described by +/// \p box. If the lower bound is left default in the ExtendedValue, +/// \p defaultValue will be returned. +mlir::Value readLowerBound(fir::FirOpBuilder &builder, mlir::Location loc, + const fir::ExtendedValue &box, unsigned dim, + mlir::Value defaultValue); + +/// Read extents from \p box. +llvm::SmallVector readExtents(fir::FirOpBuilder &builder, + mlir::Location loc, + const fir::BoxValue &box); + +/// Get extents from \p box. For fir::BoxValue and +/// fir::MutableBoxValue, this will generate code to read the extents. +llvm::SmallVector getExtents(fir::FirOpBuilder &builder, + mlir::Location loc, + const fir::ExtendedValue &box); + +/// Read a fir::BoxValue into an fir::UnboxValue, a fir::ArrayBoxValue or a +/// fir::CharArrayBoxValue. This should only be called if the fir::BoxValue is +/// known to be contiguous given the context (or if the resulting address will +/// not be used). If the value is polymorphic, its dynamic type will be lost. +/// This must not be used on unlimited polymorphic and assumed rank entities. +fir::ExtendedValue readBoxValue(fir::FirOpBuilder &builder, mlir::Location loc, + const fir::BoxValue &box); + +//===--------------------------------------------------------------------===// +// String literal helper helpers +//===--------------------------------------------------------------------===// + +/// Create a !fir.char<1> string literal global and returns a +/// fir::CharBoxValue with its address en length. +fir::ExtendedValue createStringLiteral(fir::FirOpBuilder &, mlir::Location, + llvm::StringRef string); + +/// Unique a compiler generated identifier. A short prefix should be provided +/// to hint at the origin of the identifier. +std::string uniqueCGIdent(llvm::StringRef prefix, llvm::StringRef name); + +/// Lowers the extents from the sequence type to Values. +/// Any unknown extents are lowered to undefined values. +llvm::SmallVector createExtents(fir::FirOpBuilder &builder, + mlir::Location loc, + fir::SequenceType seqTy); + +//===--------------------------------------------------------------------===// +// Location helpers +//===--------------------------------------------------------------------===// + +/// Generate a string literal containing the file name and return its address +mlir::Value locationToFilename(fir::FirOpBuilder &, mlir::Location); +/// Generate a constant of the given type with the location line number +mlir::Value locationToLineNo(fir::FirOpBuilder &, mlir::Location, mlir::Type); + +//===--------------------------------------------------------------------===// +// ExtendedValue helpers +//===--------------------------------------------------------------------===// + +/// Return the extended value for a component of a derived type instance given +/// the extended value \p obj of the derived type instance and the address of +/// the component. +fir::ExtendedValue componentToExtendedValue(fir::FirOpBuilder &builder, + mlir::Location loc, + mlir::Value component); + +/// Given the address of an array element and the ExtendedValue describing the +/// array, returns the ExtendedValue describing the array element. The purpose +/// is to propagate the length parameters of the array to the element. +/// This can be used for elements of `array` or `array(i:j:k)`. If \p element +/// belongs to an array section `array%x` whose base is \p array, +/// arraySectionElementToExtendedValue must be used instead. +fir::ExtendedValue arrayElementToExtendedValue(fir::FirOpBuilder &builder, + mlir::Location loc, + const fir::ExtendedValue &array, + mlir::Value element); + +/// Build the ExtendedValue for \p element that is an element of an array or +/// array section with \p array base (`array` or `array(i:j:k)%x%y`). +/// If it is an array section, \p slice must be provided and be a fir::SliceOp +/// that describes the section. +fir::ExtendedValue arraySectionElementToExtendedValue( + fir::FirOpBuilder &builder, mlir::Location loc, + const fir::ExtendedValue &array, mlir::Value element, mlir::Value slice); + +/// Assign \p rhs to \p lhs. Both \p rhs and \p lhs must be scalar derived +/// types. The assignment follows Fortran intrinsic assignment semantic for +/// derived types (10.2.1.3 point 13). +void genRecordAssignment(fir::FirOpBuilder &builder, mlir::Location loc, + const fir::ExtendedValue &lhs, + const fir::ExtendedValue &rhs); + +/// Compute the extent of (lb:ub:step) as max((ub-lb+step)/step, 0). See Fortran +/// 2018 9.5.3.3.2 section for more details. +mlir::Value computeTripletExtent(fir::FirOpBuilder &builder, mlir::Location loc, + mlir::Value lb, mlir::Value ub, + mlir::Value step, mlir::Type type); +} // namespace fir::factory + +#endif // FORTRAN_OPTIMIZER_BUILDER_FIRBUILDER_H diff --git a/flang/include/flang/Optimizer/Builder/MutableBox.h b/flang/include/flang/Optimizer/Builder/MutableBox.h new file mode 100644 index 00000000000000..4fc71b1db487c8 --- /dev/null +++ b/flang/include/flang/Optimizer/Builder/MutableBox.h @@ -0,0 +1,138 @@ +//===-- MutableBox.h -- MutableBox utilities -----------------------------===// +// +// 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 +// +//===----------------------------------------------------------------------===// +// +// Coding style: https://mlir.llvm.org/getting_started/DeveloperGuide/ +// +//===----------------------------------------------------------------------===// + +#ifndef FORTRAN_OPTIMIZER_BUILDER_MUTABLEBOX_H +#define FORTRAN_OPTIMIZER_BUILDER_MUTABLEBOX_H + +#include "llvm/ADT/StringRef.h" + +namespace mlir { +class Value; +class ValueRange; +class Type; +class Location; +} // namespace mlir + +namespace fir { +class FirOpBuilder; +class MutableBoxValue; +class ExtendedValue; +} // namespace fir + +namespace fir::factory { + +/// Create a fir.box of type \p boxType that can be used to initialize an +/// allocatable variable. Initialization of such variable has to be done at the +/// beginning of the variable lifetime by storing the created box in the memory +/// for the variable box. +/// \p nonDeferredParams must provide the non deferred length parameters so that +/// they can already be placed in the unallocated box (inquiries about these +/// parameters are legal even in unallocated state). +mlir::Value createUnallocatedBox(fir::FirOpBuilder &builder, mlir::Location loc, + mlir::Type boxType, + mlir::ValueRange nonDeferredParams); + +/// Create a MutableBoxValue for a temporary allocatable. +/// The created MutableBoxValue wraps a fir.ref>> and is +/// initialized to unallocated/diassociated status. An optional name can be +/// given to the created !fir.ref. +fir::MutableBoxValue createTempMutableBox(fir::FirOpBuilder &builder, + mlir::Location loc, mlir::Type type, + llvm::StringRef name = {}); + +/// Update a MutableBoxValue to describe entity \p source (that must be in +/// memory). If \lbounds is not empty, it is used to defined the MutableBoxValue +/// lower bounds, otherwise, the lower bounds from \p source are used. +void associateMutableBox(fir::FirOpBuilder &builder, mlir::Location loc, + const fir::MutableBoxValue &box, + const fir::ExtendedValue &source, + mlir::ValueRange lbounds); + +/// Update a MutableBoxValue to describe entity \p source (that must be in +/// memory) with a new array layout given by \p lbounds and \p ubounds. +/// \p source must be known to be contiguous at compile time, or it must have +/// rank 1 (constraint from Fortran 2018 standard 10.2.2.3 point 9). +void associateMutableBoxWithRemap(fir::FirOpBuilder &builder, + mlir::Location loc, + const fir::MutableBoxValue &box, + const fir::ExtendedValue &source, + mlir::ValueRange lbounds, + mlir::ValueRange ubounds); + +/// Set the association status of a MutableBoxValue to +/// disassociated/unallocated. Nothing is done with the entity that was +/// previously associated/allocated. The function generates code that sets the +/// address field of the MutableBoxValue to zero. +void disassociateMutableBox(fir::FirOpBuilder &builder, mlir::Location loc, + const fir::MutableBoxValue &box); + +/// Generate code to conditionally reallocate a MutableBoxValue with a new +/// shape, lower bounds, and length parameters if it is unallocated or if its +/// current shape or deferred length parameters do not match the provided ones. +/// Lower bounds are only used if the entity needs to be allocated, otherwise, +/// the MutableBoxValue will keep its current lower bounds. +/// If the MutableBoxValue is an array, the provided shape can be empty, in +/// which case the MutableBoxValue must already be allocated at runtime and its +/// shape and lower bounds will be kept. If \p shape is empty, only a length +/// parameter mismatch can trigger a reallocation. See Fortran 10.2.1.3 point 3 +/// that this function is implementing for more details. The polymorphic +/// requirements are not yet covered by this function. +void genReallocIfNeeded(fir::FirOpBuilder &builder, mlir::Location loc, + const fir::MutableBoxValue &box, + mlir::ValueRange lbounds, mlir::ValueRange shape, + mlir::ValueRange lengthParams); + +/// Finalize a mutable box if it is allocated or associated. This includes both +/// calling the finalizer, if any, and deallocating the storage. +void genFinalization(fir::FirOpBuilder &builder, mlir::Location loc, + const fir::MutableBoxValue &box); + +void genInlinedAllocation(fir::FirOpBuilder &builder, mlir::Location loc, + const fir::MutableBoxValue &box, + mlir::ValueRange lbounds, mlir::ValueRange extents, + mlir::ValueRange lenParams, + llvm::StringRef allocName); + +void genInlinedDeallocate(fir::FirOpBuilder &builder, mlir::Location loc, + const fir::MutableBoxValue &box); + +/// When the MutableBoxValue was passed as a fir.ref to a call that may +/// have modified it, update the MutableBoxValue according to the +/// fir.ref value. +void syncMutableBoxFromIRBox(fir::FirOpBuilder &builder, mlir::Location loc, + const fir::MutableBoxValue &box); + +/// Read all mutable properties into a normal symbol box. +/// It is OK to call this on unassociated/unallocated boxes but any use of the +/// resulting values will be undefined (only the base address will be guaranteed +/// to be null). +fir::ExtendedValue genMutableBoxRead(fir::FirOpBuilder &builder, + mlir::Location loc, + const fir::MutableBoxValue &box, + bool mayBePolymorphic = true); + +/// Returns the fir.ref> of a MutableBoxValue filled with the current +/// association / allocation properties. If the fir.ref already exists +/// and is-up to date, this is a no-op, otherwise, code will be generated to +/// fill the it. +mlir::Value getMutableIRBox(fir::FirOpBuilder &builder, mlir::Location loc, + const fir::MutableBoxValue &box); + +/// Generate allocation or association status test and returns the resulting +/// i1. This is testing this for a valid/non-null base address value. +mlir::Value genIsAllocatedOrAssociatedTest(fir::FirOpBuilder &builder, + mlir::Location loc, + const fir::MutableBoxValue &box); + +} // namespace fir::factory + +#endif // FORTRAN_OPTIMIZER_BUILDER_MUTABLEBOX_H diff --git a/flang/include/flang/Optimizer/Builder/Runtime/Assign.h b/flang/include/flang/Optimizer/Builder/Runtime/Assign.h new file mode 100644 index 00000000000000..ccec7feb6b8cf7 --- /dev/null +++ b/flang/include/flang/Optimizer/Builder/Runtime/Assign.h @@ -0,0 +1,32 @@ +//===-- Assign.h - generate assignment runtime API calls ----*- C++ -*-===// +// +// 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 +// +//===----------------------------------------------------------------------===// + +#ifndef FORTRAN_OPTIMIZER_BUILDER_RUNTIME_ASSIGN_H +#define FORTRAN_OPTIMIZER_BUILDER_RUNTIME_ASSIGN_H + +namespace mlir { +class Value; +class Location; +} // namespace mlir + +namespace fir { +class FirOpBuilder; +} + +namespace fir::runtime { + +/// Generate runtime call to assign \p sourceBox to \p destBox. +/// \p destBox must be a fir.ref> and \p sourceBox a fir.box. +/// \p destBox Fortran descriptor may be modified if destBox is an allocatable +/// according to Fortran allocatable assignment rules, otherwise it is not +/// modified. +void genAssign(fir::FirOpBuilder &builder, mlir::Location loc, + mlir::Value destBox, mlir::Value sourceBox); + +} // namespace fir::runtime +#endif // FORTRAN_OPTIMIZER_BUILDER_RUNTIME_ASSIGN_H diff --git a/flang/include/flang/Optimizer/Builder/Runtime/Character.h b/flang/include/flang/Optimizer/Builder/Runtime/Character.h new file mode 100644 index 00000000000000..9ea77b5f5609b4 --- /dev/null +++ b/flang/include/flang/Optimizer/Builder/Runtime/Character.h @@ -0,0 +1,134 @@ +//===-- Character.h -- generate calls to character runtime API --*- C++ -*-===// +// +// 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 +// +//===----------------------------------------------------------------------===// + +#ifndef FORTRAN_OPTIMIZER_BUILDER_RUNTIME_CHARACTER_H +#define FORTRAN_OPTIMIZER_BUILDER_RUNTIME_CHARACTER_H + +#include "mlir/Dialect/StandardOps/IR/Ops.h" + +namespace fir { +class ExtendedValue; +class FirOpBuilder; +} // namespace fir + +namespace fir::runtime { + +/// Generate a call to the ADJUSTL runtime. +/// This calls the simple runtime entry point that then calls into the more +/// complex runtime cases handling left or right adjustments. +/// +/// \p resultBox must be an unallocated allocatable used for the temporary +/// result. \p StringBox must be a fir.box describing the adjustl string +/// argument. Note that the \p genAdjust() helper is called to do the majority +/// of the lowering work. +void genAdjustL(fir::FirOpBuilder &builder, mlir::Location loc, + mlir::Value resultBox, mlir::Value stringBox); + +/// Generate a call to the ADJUSTR runtime. +/// This calls the simple runtime entry point that then calls into the more +/// complex runtime cases handling left or right adjustments. +/// +/// \p resultBox must be an unallocated allocatable used for the temporary +/// result. \p StringBox must be a fir.box describing the adjustr string +/// argument. Note that the \p genAdjust() helper is called to do the majority +/// of the lowering work. +void genAdjustR(fir::FirOpBuilder &builder, mlir::Location loc, + mlir::Value resultBox, mlir::Value stringBox); + +/// Generate a call to the ADJUST[L|R] runtime. +/// +/// \p resultBox must be an unallocated allocatable used for the temporary +/// result. \p StringBox must be a fir.box describing the adjustr string +/// argument. The \p adjustFunc should be a mlir::FuncOp for the appropriate +/// runtime entry function. +void genAdjust(fir::FirOpBuilder &builder, mlir::Location loc, + mlir::Value resultBox, mlir::Value stringBox, + mlir::FuncOp &adjustFunc); + +/// Generate call to a character comparison for two ssa-values of type +/// `boxchar`. +mlir::Value genCharCompare(fir::FirOpBuilder &builder, mlir::Location loc, + mlir::CmpIPredicate cmp, + const fir::ExtendedValue &lhs, + const fir::ExtendedValue &rhs); + +/// Generate call to a character comparison op for two unboxed variables. There +/// are 4 arguments, 2 for the lhs and 2 for the rhs. Each CHARACTER must pass a +/// reference to its buffer (`ref>`) and its LEN type parameter (some +/// integral type). +mlir::Value genCharCompare(fir::FirOpBuilder &builder, mlir::Location loc, + mlir::CmpIPredicate cmp, mlir::Value lhsBuff, + mlir::Value lhsLen, mlir::Value rhsBuff, + mlir::Value rhsLen); + +/// Generate call to INDEX runtime. +/// This calls the simple runtime entry points based on the KIND of the string. +/// No descriptors are used. +mlir::Value genIndex(fir::FirOpBuilder &builder, mlir::Location loc, int kind, + mlir::Value stringBase, mlir::Value stringLen, + mlir::Value substringBase, mlir::Value substringLen, + mlir::Value back); + +/// Generate call to INDEX runtime. +/// This calls the descriptor based runtime call implementation for the index +/// intrinsic. +void genIndexDescriptor(fir::FirOpBuilder &builder, mlir::Location loc, + mlir::Value resultBox, mlir::Value stringBox, + mlir::Value substringBox, mlir::Value backOpt, + mlir::Value kind); + +/// Generate call to repeat runtime. +/// \p resultBox must be an unallocated allocatable used for the temporary +/// result. \p stringBox must be a fir.box describing repeat string argument. +/// \p ncopies must be a value representing the number of copies. +/// The runtime will always allocate the resultBox. +void genRepeat(fir::FirOpBuilder &builder, mlir::Location loc, + mlir::Value resultBox, mlir::Value stringBox, + mlir::Value ncopies); + +/// Generate call to trim runtime. +/// \p resultBox must be an unallocated allocatable used for the temporary +/// result. \p stringBox must be a fir.box describing trim string argument. +/// The runtime will always allocate the resultBox. +void genTrim(fir::FirOpBuilder &builder, mlir::Location loc, + mlir::Value resultBox, mlir::Value stringBox); + +/// Generate call to scan runtime. +/// This calls the descriptor based runtime call implementation of the scan +/// intrinsics. +void genScanDescriptor(fir::FirOpBuilder &builder, mlir::Location loc, + mlir::Value resultBox, mlir::Value stringBox, + mlir::Value setBox, mlir::Value backBox, + mlir::Value kind); + +/// Generate call to the scan runtime routine that is specialized on +/// \param kind. +/// The \param kind represents the kind of the elements in the strings. +mlir::Value genScan(fir::FirOpBuilder &builder, mlir::Location loc, int kind, + mlir::Value stringBase, mlir::Value stringLen, + mlir::Value setBase, mlir::Value setLen, mlir::Value back); + +/// Generate call to verify runtime. +/// This calls the descriptor based runtime call implementation of the scan +/// intrinsics. +void genVerifyDescriptor(fir::FirOpBuilder &builder, mlir::Location loc, + mlir::Value resultBox, mlir::Value stringBox, + mlir::Value setBox, mlir::Value backBox, + mlir::Value kind); + +/// Generate call to the verify runtime routine that is specialized on +/// \param kind. +/// The \param kind represents the kind of the elements in the strings. +mlir::Value genVerify(fir::FirOpBuilder &builder, mlir::Location loc, int kind, + mlir::Value stringBase, mlir::Value stringLen, + mlir::Value setBase, mlir::Value setLen, + mlir::Value back); + +} // namespace fir::runtime + +#endif // FORTRAN_OPTIMIZER_BUILDER_RUNTIME_CHARACTER_H diff --git a/flang/include/flang/Optimizer/Builder/Runtime/Coarray.h b/flang/include/flang/Optimizer/Builder/Runtime/Coarray.h new file mode 100644 index 00000000000000..06bcab6805d627 --- /dev/null +++ b/flang/include/flang/Optimizer/Builder/Runtime/Coarray.h @@ -0,0 +1,28 @@ +//===-- Coarray.h -- generate calls to coarray runtime API ------*- C++ -*-===// +// +// 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 +// +//===----------------------------------------------------------------------===// + +#ifndef FORTRAN_OPTIMIZER_BUILDER_RUNTIME_COARRAY_H +#define FORTRAN_OPTIMIZER_BUILDER_RUNTIME_COARRAY_H + +#include "mlir/Dialect/StandardOps/IR/Ops.h" + +namespace fir { +class ExtendedValue; +class FirOpBuilder; +} // namespace fir + +namespace fir::runtime { + +/// Generate call to num_images runtime. +/// \p teamBox must be a fir.box describing the team_number argument. +mlir::Value genNumImages(fir::FirOpBuilder &builder, mlir::Location loc, + mlir::Value teamBox); + +} // namespace fir::runtime + +#endif // FORTRAN_OPTIMIZER_BUILDER_RUNTIME_COARRAY_H diff --git a/flang/include/flang/Optimizer/Builder/Runtime/Derived.h b/flang/include/flang/Optimizer/Builder/Runtime/Derived.h new file mode 100644 index 00000000000000..c0c82062b6c5a6 --- /dev/null +++ b/flang/include/flang/Optimizer/Builder/Runtime/Derived.h @@ -0,0 +1,39 @@ +//===-- Derived.h - generate derived type runtime API calls -*- C++ -----*-===// +// +// 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 +// +//===----------------------------------------------------------------------===// + +#ifndef FORTRAN_OPTIMIZER_BUILDER_RUNTIME_DERIVED_H +#define FORTRAN_OPTIMIZER_BUILDER_RUNTIME_DERIVED_H + +namespace mlir { +class Value; +class Location; +} // namespace mlir + +namespace fir { +class FirOpBuilder; +} + +namespace fir::runtime { + +/// Generate call to derived type initialization runtime routine to +/// default initialize \p box. +void genDerivedTypeInitialize(fir::FirOpBuilder &builder, mlir::Location loc, + mlir::Value box); + +/// Generate call to derived type destruction runtime routine to +/// destroy \p box. +void genDerivedTypeDestroy(fir::FirOpBuilder &builder, mlir::Location loc, + mlir::Value box); + +/// Generate call to derived type assignment runtime routine to +/// assign \p sourceBox to \p destinationBox. +void genDerivedTypeAssign(fir::FirOpBuilder &builder, mlir::Location loc, + mlir::Value destinationBox, mlir::Value sourceBox); + +} // namespace fir::runtime +#endif // FORTRAN_OPTIMIZER_BUILDER_RUNTIME_DERIVED_H diff --git a/flang/include/flang/Optimizer/Builder/Runtime/Numeric.h b/flang/include/flang/Optimizer/Builder/Runtime/Numeric.h new file mode 100644 index 00000000000000..323cc2ce6d49ae --- /dev/null +++ b/flang/include/flang/Optimizer/Builder/Runtime/Numeric.h @@ -0,0 +1,50 @@ +//===-- Numeric.h -- generate numeric intrinsics runtime calls --*- C++ -*-===// +// +// 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 +// +//===----------------------------------------------------------------------===// + +#ifndef FORTRAN_OPTIMIZER_BUILDER_RUNTIME_NUMERIC_H +#define FORTRAN_OPTIMIZER_BUILDER_RUNTIME_NUMERIC_H + +#include "mlir/Dialect/StandardOps/IR/Ops.h" + +namespace fir { +class ExtendedValue; +class FirOpBuilder; +} // namespace fir + +namespace fir::runtime { + +/// Generate call to Exponent intrinsic runtime routine. +mlir::Value genExponent(fir::FirOpBuilder &builder, mlir::Location loc, + mlir::Type resultType, mlir::Value x); + +/// Generate call to Fraction intrinsic runtime routine. +mlir::Value genFraction(fir::FirOpBuilder &builder, mlir::Location loc, + mlir::Value x); + +/// Generate call to Nearest intrinsic runtime routine. +mlir::Value genNearest(fir::FirOpBuilder &builder, mlir::Location loc, + mlir::Value x, mlir::Value s); + +/// Generate call to RRSpacing intrinsic runtime routine. +mlir::Value genRRSpacing(fir::FirOpBuilder &builder, mlir::Location loc, + mlir::Value x); + +/// Generate call to Scale intrinsic runtime routine. +mlir::Value genScale(fir::FirOpBuilder &builder, mlir::Location loc, + mlir::Value x, mlir::Value i); + +/// Generate call to Set_exponent intrinsic runtime routine. +mlir::Value genSetExponent(fir::FirOpBuilder &builder, mlir::Location loc, + mlir::Value x, mlir::Value i); + +/// Generate call to Spacing intrinsic runtime routine. +mlir::Value genSpacing(fir::FirOpBuilder &builder, mlir::Location loc, + mlir::Value x); + +} // namespace fir::runtime +#endif // FORTRAN_OPTIMIZER_BUILDER_RUNTIME_NUMERIC_H diff --git a/flang/lib/Lower/RTBuilder.h b/flang/include/flang/Optimizer/Builder/Runtime/RTBuilder.h similarity index 59% rename from flang/lib/Lower/RTBuilder.h rename to flang/include/flang/Optimizer/Builder/Runtime/RTBuilder.h index 38dfa6034bdd32..4d373ebe1364af 100644 --- a/flang/lib/Lower/RTBuilder.h +++ b/flang/include/flang/Optimizer/Builder/Runtime/RTBuilder.h @@ -14,20 +14,29 @@ /// //===----------------------------------------------------------------------===// -#ifndef FORTRAN_LOWER_RTBUILDER_H -#define FORTRAN_LOWER_RTBUILDER_H +#ifndef FORTRAN_OPTIMIZER_BUILDER_RUNTIME_RTBUILDER_H +#define FORTRAN_OPTIMIZER_BUILDER_RUNTIME_RTBUILDER_H -#include "flang/Lower/ConvertType.h" +#include "flang/Common/Fortran.h" +#include "flang/Optimizer/Builder/FIRBuilder.h" #include "flang/Optimizer/Dialect/FIRType.h" #include "mlir/IR/BuiltinTypes.h" #include "mlir/IR/MLIRContext.h" #include "llvm/ADT/SmallVector.h" #include -// List the runtime headers we want to be able to dissect -#include "../../runtime/io-api.h" +// Incomplete type indicating C99 complex ABI in interfaces. Beware, _Complex +// and std::complex are layout compatible, but not compatible in all ABI call +// interface (e.g. X86 32 bits). _Complex is not standard C++, so do not use +// it here. +struct c_float_complex_t; +struct c_double_complex_t; -namespace Fortran::lower { +namespace Fortran::runtime { +class Descriptor; +} + +namespace fir::runtime { using TypeBuilderFunc = mlir::Type (*)(mlir::MLIRContext *); using FuncTypeBuilderFunc = mlir::FunctionType (*)(mlir::MLIRContext *); @@ -36,6 +45,9 @@ using FuncTypeBuilderFunc = mlir::FunctionType (*)(mlir::MLIRContext *); // Type builder models //===----------------------------------------------------------------------===// +// TODO: all usages of sizeof in this file assume build == host == target. +// This will need to be re-visited for cross compilation. + /// Return a function that returns the type signature model for the type `T` /// when provided an MLIRContext*. This allows one to translate C(++) function /// signatures from runtime header files to MLIR signatures into a static table @@ -46,6 +58,12 @@ using FuncTypeBuilderFunc = mlir::FunctionType (*)(mlir::MLIRContext *); template static constexpr TypeBuilderFunc getModel(); template <> +constexpr TypeBuilderFunc getModel() { + return [](mlir::MLIRContext *context) -> mlir::Type { + return mlir::IntegerType::get(context, 8 * sizeof(short int)); + }; +} +template <> constexpr TypeBuilderFunc getModel() { return [](mlir::MLIRContext *context) -> mlir::Type { return mlir::IntegerType::get(context, 8 * sizeof(int)); @@ -59,13 +77,6 @@ constexpr TypeBuilderFunc getModel() { }; } template <> -constexpr TypeBuilderFunc getModel() { - return [](mlir::MLIRContext *context) -> mlir::Type { - return mlir::IntegerType::get(context, - 8 * sizeof(Fortran::runtime::io::Iostat)); - }; -} -template <> constexpr TypeBuilderFunc getModel() { return [](mlir::MLIRContext *context) -> mlir::Type { return fir::ReferenceType::get(mlir::IntegerType::get(context, 8)); @@ -88,6 +99,12 @@ constexpr TypeBuilderFunc getModel() { }; } template <> +constexpr TypeBuilderFunc getModel() { + return [](mlir::MLIRContext *context) -> mlir::Type { + return mlir::IntegerType::get(context, 8 * sizeof(signed char)); + }; +} +template <> constexpr TypeBuilderFunc getModel() { return [](mlir::MLIRContext *context) -> mlir::Type { return fir::ReferenceType::get( @@ -95,27 +112,42 @@ constexpr TypeBuilderFunc getModel() { }; } template <> -constexpr TypeBuilderFunc getModel() { +constexpr TypeBuilderFunc getModel() { return [](mlir::MLIRContext *context) -> mlir::Type { - return mlir::IntegerType::get(context, 64); + return mlir::IntegerType::get(context, 8 * sizeof(long)); }; } template <> -constexpr TypeBuilderFunc getModel() { +constexpr TypeBuilderFunc getModel() { return [](mlir::MLIRContext *context) -> mlir::Type { - TypeBuilderFunc f{getModel()}; + TypeBuilderFunc f{getModel()}; return fir::ReferenceType::get(f(context)); }; } template <> -constexpr TypeBuilderFunc getModel() { +constexpr TypeBuilderFunc getModel() { return [](mlir::MLIRContext *context) -> mlir::Type { return mlir::IntegerType::get(context, 8 * sizeof(std::size_t)); }; } template <> -constexpr TypeBuilderFunc getModel() { - return getModel(); +constexpr TypeBuilderFunc getModel() { + return [](mlir::MLIRContext *context) -> mlir::Type { + TypeBuilderFunc f{getModel()}; + return fir::ReferenceType::get(f(context)); + }; +} +template <> +constexpr TypeBuilderFunc getModel() { + return [](mlir::MLIRContext *context) -> mlir::Type { + return mlir::IntegerType::get(context, 8 * sizeof(unsigned long)); + }; +} +template <> +constexpr TypeBuilderFunc getModel() { + return [](mlir::MLIRContext *context) -> mlir::Type { + return mlir::IntegerType::get(context, 8 * sizeof(unsigned long long)); + }; } template <> constexpr TypeBuilderFunc getModel() { @@ -131,6 +163,10 @@ constexpr TypeBuilderFunc getModel() { }; } template <> +constexpr TypeBuilderFunc getModel() { + return getModel(); +} +template <> constexpr TypeBuilderFunc getModel() { return [](mlir::MLIRContext *context) -> mlir::Type { return mlir::FloatType::getF32(context); @@ -144,6 +180,10 @@ constexpr TypeBuilderFunc getModel() { }; } template <> +constexpr TypeBuilderFunc getModel() { + return getModel(); +} +template <> constexpr TypeBuilderFunc getModel() { return [](mlir::MLIRContext *context) -> mlir::Type { return mlir::IntegerType::get(context, 1); @@ -156,7 +196,32 @@ constexpr TypeBuilderFunc getModel() { return fir::ReferenceType::get(f(context)); }; } - +template <> +constexpr TypeBuilderFunc getModel &>() { + return [](mlir::MLIRContext *context) -> mlir::Type { + auto ty = mlir::ComplexType::get(mlir::FloatType::getF32(context)); + return fir::ReferenceType::get(ty); + }; +} +template <> +constexpr TypeBuilderFunc getModel &>() { + return [](mlir::MLIRContext *context) -> mlir::Type { + auto ty = mlir::ComplexType::get(mlir::FloatType::getF64(context)); + return fir::ReferenceType::get(ty); + }; +} +template <> +constexpr TypeBuilderFunc getModel() { + return [](mlir::MLIRContext *context) -> mlir::Type { + return fir::ComplexType::get(context, sizeof(float)); + }; +} +template <> +constexpr TypeBuilderFunc getModel() { + return [](mlir::MLIRContext *context) -> mlir::Type { + return fir::ComplexType::get(context, sizeof(double)); + }; +} template <> constexpr TypeBuilderFunc getModel() { return [](mlir::MLIRContext *context) -> mlir::Type { @@ -164,12 +229,25 @@ constexpr TypeBuilderFunc getModel() { }; } template <> -constexpr TypeBuilderFunc -getModel() { +constexpr TypeBuilderFunc getModel() { return [](mlir::MLIRContext *context) -> mlir::Type { - // FIXME: a namelist group must be some well-defined data structure, use a - // tuple as a proxy for the moment - return mlir::TupleType::get(context); + return fir::ReferenceType::get( + fir::BoxType::get(mlir::NoneType::get(context))); + }; +} +template <> +constexpr TypeBuilderFunc getModel() { + return getModel(); +} +template <> +constexpr TypeBuilderFunc getModel() { + return getModel(); +} +template <> +constexpr TypeBuilderFunc getModel() { + return [](mlir::MLIRContext *context) -> mlir::Type { + return mlir::IntegerType::get(context, + sizeof(Fortran::common::TypeCategory) * 8); }; } template <> @@ -249,6 +327,7 @@ struct RuntimeTableEntry, RuntimeIdentifier> { #undef E #define E(L, I) (I < sizeof(L) / sizeof(*L) ? L[I] : 0) #define QuoteKey(X) #X +#define ExpandAndQuoteKey(X) QuoteKey(X) #define MacroExpandKey(X) \ E(X, 0), E(X, 1), E(X, 2), E(X, 3), E(X, 4), E(X, 5), E(X, 6), E(X, 7), \ E(X, 8), E(X, 9), E(X, 10), E(X, 11), E(X, 12), E(X, 13), E(X, 14), \ @@ -259,11 +338,56 @@ struct RuntimeTableEntry, RuntimeIdentifier> { E(X, 43), E(X, 44), E(X, 45), E(X, 46), E(X, 47), E(X, 48), E(X, 49) #define ExpandKey(X) MacroExpandKey(QuoteKey(X)) #define FullSeq(X) std::integer_sequence -#define AsSequence(X) decltype(Fortran::lower::details::filter(FullSeq(X){})) +#define AsSequence(X) decltype(fir::runtime::details::filter(FullSeq(X){})) #define mkKey(X) \ - Fortran::lower::RuntimeTableEntry< \ - Fortran::lower::RuntimeTableKey, AsSequence(X)> + fir::runtime::RuntimeTableEntry, \ + AsSequence(X)> +#define mkRTKey(X) mkKey(RTNAME(X)) + +/// Get (or generate) the MLIR FuncOp for a given runtime function. Its template +/// argument is intended to be of the form: +/// Clients should add "using namespace Fortran::runtime" +/// in order to use this function. +template +static mlir::FuncOp getRuntimeFunc(mlir::Location loc, + fir::FirOpBuilder &builder) { + auto name = RuntimeEntry::name; + auto func = builder.getNamedFunction(name); + if (func) + return func; + auto funTy = RuntimeEntry::getTypeModel()(builder.getContext()); + func = builder.createFunction(loc, name, funTy); + func->setAttr("fir.runtime", builder.getUnitAttr()); + return func; +} + +namespace helper { +template +void createArguments(llvm::SmallVectorImpl &result, + fir::FirOpBuilder &builder, mlir::Location loc, + mlir::FunctionType fTy, A arg) { + result.emplace_back(builder.createConvert(loc, fTy.getInput(N), arg)); +} + +template +void createArguments(llvm::SmallVectorImpl &result, + fir::FirOpBuilder &builder, mlir::Location loc, + mlir::FunctionType fTy, A arg, As... args) { + result.emplace_back(builder.createConvert(loc, fTy.getInput(N), arg)); + createArguments(result, builder, loc, fTy, args...); +} +} // namespace helper + +/// Create a SmallVector of arguments for a runtime call. +template +llvm::SmallVector +createArguments(fir::FirOpBuilder &builder, mlir::Location loc, + mlir::FunctionType fTy, As... args) { + llvm::SmallVector result; + helper::createArguments<0>(result, builder, loc, fTy, args...); + return result; +} -} // namespace Fortran::lower +} // namespace fir::runtime -#endif // FORTRAN_LOWER_RTBUILDER_H +#endif // FORTRAN_OPTIMIZER_BUILDER_RUNTIME_RTBUILDER_H diff --git a/flang/include/flang/Optimizer/Builder/Runtime/Reduction.h b/flang/include/flang/Optimizer/Builder/Runtime/Reduction.h new file mode 100644 index 00000000000000..d06b34f1b5118b --- /dev/null +++ b/flang/include/flang/Optimizer/Builder/Runtime/Reduction.h @@ -0,0 +1,148 @@ +//===-- Reduction.h -- generate calls to reduction runtime API --*- C++ -*-===// +// +// 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 +// +//===----------------------------------------------------------------------===// + +#ifndef FORTRAN_OPTIMIZER_BUILDER_RUNTIME_REDUCTION_H +#define FORTRAN_OPTIMIZER_BUILDER_RUNTIME_REDUCTION_H + +#include "mlir/Dialect/StandardOps/IR/Ops.h" + +namespace fir { +class ExtendedValue; +class FirOpBuilder; +} // namespace fir + +namespace fir::runtime { + +/// Generate call to all runtime routine. +/// This calls the descriptor based runtime call implementation of the all +/// intrinsic. +void genAllDescriptor(fir::FirOpBuilder &builder, mlir::Location loc, + mlir::Value resultBox, mlir::Value maskBox, + mlir::Value dim); + +/// Generate call to any runtime routine. +/// This calls the descriptor based runtime call implementation of the any +/// intrinsic. +void genAnyDescriptor(fir::FirOpBuilder &builder, mlir::Location loc, + mlir::Value resultBox, mlir::Value maskBox, + mlir::Value dim); + +/// Generate call to all runtime routine. This version of all is specialized +/// for rank 1 mask arguments. +/// This calls the version that returns a scalar logical value. +mlir::Value genAll(fir::FirOpBuilder &builder, mlir::Location loc, + mlir::Value maskBox, mlir::Value dim); + +/// Generate call to any runtime routine. This version of any is specialized +/// for rank 1 mask arguments. +/// This calls the version that returns a scalar logical value. +mlir::Value genAny(fir::FirOpBuilder &builder, mlir::Location loc, + mlir::Value maskBox, mlir::Value dim); + +/// Generate call to Count runtime routine. This routine is a specialized +/// version when mask is a rank one array or the dim argument is not +/// specified by the user. +mlir::Value genCount(fir::FirOpBuilder &builder, mlir::Location loc, + mlir::Value maskBox, mlir::Value dim); + +/// Generate call to general CountDim runtime routine. This routine has a +/// descriptor result. +void genCountDim(fir::FirOpBuilder &builder, mlir::Location loc, + mlir::Value resultBox, mlir::Value maskBox, mlir::Value dim, + mlir::Value kind); + +/// Generate call to DotProduct intrinsic runtime routine. +mlir::Value genDotProduct(fir::FirOpBuilder &builder, mlir::Location loc, + mlir::Value vectorABox, mlir::Value vectorBBox, + mlir::Value resultBox); + +/// Generate call to Maxloc intrinsic runtime routine. This is the version +/// that does not take a dim argument. +void genMaxloc(fir::FirOpBuilder &builder, mlir::Location loc, + mlir::Value resultBox, mlir::Value arrayBox, mlir::Value maskBox, + mlir::Value kind, mlir::Value back); + +/// Generate call to Maxloc intrinsic runtime routine. This is the version +/// that takes a dim argument. +void genMaxlocDim(fir::FirOpBuilder &builder, mlir::Location loc, + mlir::Value resultBox, mlir::Value arrayBox, mlir::Value dim, + mlir::Value maskBox, mlir::Value kind, mlir::Value back); + +/// Generate call to Minloc intrinsic runtime routine. This is the version +/// that does not take a dim argument. +void genMinloc(fir::FirOpBuilder &builder, mlir::Location loc, + mlir::Value resultBox, mlir::Value arrayBox, mlir::Value maskBox, + mlir::Value kind, mlir::Value back); + +/// Generate call to Minloc intrinsic runtime routine. This is the version +/// that takes a dim argument. +void genMinlocDim(fir::FirOpBuilder &builder, mlir::Location loc, + mlir::Value resultBox, mlir::Value arrayBox, mlir::Value dim, + mlir::Value maskBox, mlir::Value kind, mlir::Value back); + +/// Generate call to Maxval intrinsic runtime routine. This is the version +/// that does not take a dim argument. +mlir::Value genMaxval(fir::FirOpBuilder &builder, mlir::Location loc, + mlir::Value arrayBox, mlir::Value maskBox); + +/// Generate call to Maxval intrinsic runtime routine. This is the version +/// that that handles 1 dimensional character arrays with no DIM argument. +void genMaxvalChar(fir::FirOpBuilder &builder, mlir::Location loc, + mlir::Value resultBox, mlir::Value arrayBox, + mlir::Value maskBox); + +/// Generate call to Maxval intrinsic runtime routine. This is the version +/// that takes arrays of any rank with a dim argument specified. +void genMaxvalDim(fir::FirOpBuilder &builder, mlir::Location loc, + mlir::Value resultBox, mlir::Value arrayBox, mlir::Value dim, + mlir::Value maskBox); + +/// Generate call to Minval intrinsic runtime routine. This is the version +/// that does not take a dim argument. +mlir::Value genMinval(fir::FirOpBuilder &builder, mlir::Location loc, + mlir::Value arrayBox, mlir::Value maskBox); + +/// Generate call to Minval intrinsic runtime routine. This is the version +/// that that handles 1 dimensional character arrays with no DIM argument. +void genMinvalChar(fir::FirOpBuilder &builder, mlir::Location loc, + mlir::Value resultBox, mlir::Value arrayBox, + mlir::Value maskBox); + +/// Generate call to Minval intrinsic runtime routine. This is the version +/// that takes arrays of any rank with a dim argument specified. +void genMinvalDim(fir::FirOpBuilder &builder, mlir::Location loc, + mlir::Value resultBox, mlir::Value arrayBox, mlir::Value dim, + mlir::Value maskBox); + +/// Generate call to Product intrinsic runtime routine. This is the version +/// that does not take a dim argument. +mlir::Value genProduct(fir::FirOpBuilder &builder, mlir::Location loc, + mlir::Value arrayBox, mlir::Value maskBox, + mlir::Value resultBox); + +/// Generate call to Product intrinsic runtime routine. This is the version +/// that takes arrays of any rank with a dim argument specified. +void genProductDim(fir::FirOpBuilder &builder, mlir::Location loc, + mlir::Value resultBox, mlir::Value arrayBox, mlir::Value dim, + mlir::Value maskBox); + +/// Generate call to Sum intrinsic runtime routine. This is the version +/// that does not take a dim argument. +mlir::Value genSum(fir::FirOpBuilder &builder, mlir::Location loc, + mlir::Value arrayBox, mlir::Value maskBox, + mlir::Value resultBox); + +/// Generate call to Sum intrinsic runtime routine. This is the version +/// that takes arrays of any rank with a dim argument specified. +void genSumDim(fir::FirOpBuilder &builder, mlir::Location loc, + mlir::Value resultBox, mlir::Value arrayBox, mlir::Value dim, + mlir::Value maskBox); + +} // namespace fir::runtime + +#endif // FORTRAN_OPTIMIZER_BUILDER_RUNTIME_REDUCTION_H diff --git a/flang/include/flang/Optimizer/Builder/Runtime/Transformational.h b/flang/include/flang/Optimizer/Builder/Runtime/Transformational.h new file mode 100644 index 00000000000000..5f1f28b78656e8 --- /dev/null +++ b/flang/include/flang/Optimizer/Builder/Runtime/Transformational.h @@ -0,0 +1,63 @@ +//===-- Transformational.h --------------------------------------*- C++ -*-===// +// Generate transformational intrinsic runtime API calls. +// +// 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 +// +//===----------------------------------------------------------------------===// + +#ifndef FORTRAN_OPTIMIZER_BUILDER_RUNTIME_TRANSFORMATIONAL_H +#define FORTRAN_OPTIMIZER_BUILDER_RUNTIME_TRANSFORMATIONAL_H + +#include "mlir/Dialect/StandardOps/IR/Ops.h" + +namespace fir { +class ExtendedValue; +class FirOpBuilder; +} // namespace fir + +namespace fir::runtime { + +void genCshift(fir::FirOpBuilder &builder, mlir::Location loc, + mlir::Value resultBox, mlir::Value arrayBox, + mlir::Value shiftBox, mlir::Value dimBox); + +void genCshiftVector(fir::FirOpBuilder &builder, mlir::Location loc, + mlir::Value resultBox, mlir::Value arrayBox, + mlir::Value shiftBox); + +void genEoshift(fir::FirOpBuilder &builder, mlir::Location loc, + mlir::Value resultBox, mlir::Value arrayBox, + mlir::Value shiftBox, mlir::Value boundBox, mlir::Value dimBox); + +void genEoshiftVector(fir::FirOpBuilder &builder, mlir::Location loc, + mlir::Value resultBox, mlir::Value arrayBox, + mlir::Value shiftBox, mlir::Value boundBox); + +void genMatmul(fir::FirOpBuilder &builder, mlir::Location loc, + mlir::Value matrixABox, mlir::Value matrixBBox, + mlir::Value resultBox); + +void genPack(fir::FirOpBuilder &builder, mlir::Location loc, + mlir::Value resultBox, mlir::Value arrayBox, mlir::Value maskBox, + mlir::Value vectorBox); + +void genReshape(fir::FirOpBuilder &builder, mlir::Location loc, + mlir::Value resultBox, mlir::Value sourceBox, + mlir::Value shapeBox, mlir::Value padBox, mlir::Value orderBox); + +void genSpread(fir::FirOpBuilder &builder, mlir::Location loc, + mlir::Value resultBox, mlir::Value sourceBox, mlir::Value dim, + mlir::Value ncopies); + +void genTranspose(fir::FirOpBuilder &builder, mlir::Location loc, + mlir::Value resultBox, mlir::Value sourceBox); + +void genUnpack(fir::FirOpBuilder &builder, mlir::Location loc, + mlir::Value resultBox, mlir::Value vectorBox, + mlir::Value maskBox, mlir::Value fieldBox); + +} // namespace fir::runtime + +#endif // FORTRAN_OPTIMIZER_BUILDER_RUNTIME_TRANSFORMATIONAL_H diff --git a/flang/include/flang/Optimizer/CodeGen/CGOps.td b/flang/include/flang/Optimizer/CodeGen/CGOps.td index 9ebda32825a635..7db1c193db655b 100644 --- a/flang/include/flang/Optimizer/CodeGen/CGOps.td +++ b/flang/include/flang/Optimizer/CodeGen/CGOps.td @@ -122,6 +122,11 @@ def fircg_XReboxOp : fircg_Op<"ext_rebox", [AttrSizedOperandSegments]> { unsigned getRank(); // The rank of the result box unsigned getOutRank(); + + unsigned shapeOffset() { return 1; } + unsigned shiftOffset() { return shapeOffset() + shape().size(); } + unsigned sliceOffset() { return shiftOffset() + shift().size(); } + unsigned subcomponentOffset() { return sliceOffset() + slice().size(); } }]; } @@ -171,6 +176,16 @@ def fircg_XArrayCoorOp : fircg_Op<"ext_array_coor", [AttrSizedOperandSegments]> let extraClassDeclaration = [{ unsigned getRank(); + + // Shape is optional, but if it exists, it will be at offset 1. + unsigned shapeOffset() { return 1; } + unsigned shiftOffset() { return shapeOffset() + shape().size(); } + unsigned sliceOffset() { return shiftOffset() + shift().size(); } + unsigned subcomponentOffset() { return sliceOffset() + slice().size(); } + unsigned indicesOffset() { + return subcomponentOffset() + subcomponent().size(); + } + unsigned lenParamsOffset() { return indicesOffset() + indices().size(); } }]; } diff --git a/flang/include/flang/Optimizer/CodeGen/CGPasses.td b/flang/include/flang/Optimizer/CodeGen/CGPasses.td index ffe829644d1aab..15398c983462d4 100644 --- a/flang/include/flang/Optimizer/CodeGen/CGPasses.td +++ b/flang/include/flang/Optimizer/CodeGen/CGPasses.td @@ -16,19 +16,49 @@ include "mlir/Pass/PassBase.td" -def CodeGenRewrite : Pass<"cg-rewrite"> { - let summary = "Rewrite some FIR ops into their code-gen forms."; +def FIRToLLVMLowering : Pass<"fir-to-llvm-ir", "mlir::ModuleOp"> { + let summary = "Convert FIR dialect to LLVM-IR dialect"; let description = [{ - Fuse specific subgraphs into single Ops for code generation. + Convert the FIR dialect to the LLVM-IR dialect of MLIR. This conversion + will also convert ops in the standard and FIRCG dialects. }]; - let constructor = "fir::createFirCodeGenRewritePass()"; + let constructor = "::fir::createFIRToLLVMPass()"; let dependentDialects = [ "fir::FIROpsDialect", "fir::FIRCodeGenDialect", "mlir::BuiltinDialect", "mlir::LLVM::LLVMDialect", "mlir::omp::OpenMPDialect" ]; +} + +def CodeGenRewrite : Pass<"cg-rewrite", "mlir::ModuleOp"> { + let summary = "Rewrite some FIR ops into their code-gen forms."; + let description = [{ + Fuse specific subgraphs into single Ops for code generation. + }]; + let constructor = "::fir::createFirCodeGenRewritePass()"; + let dependentDialects = [ + "fir::FIROpsDialect", "fir::FIRCodeGenDialect" + ]; let statistics = [ Statistic<"numDCE", "num-dce'd", "Number of operations eliminated"> ]; } +def TargetRewrite : Pass<"target-rewrite", "mlir::ModuleOp"> { + let summary = "Rewrite some FIR dialect into target specific forms."; + let description = [{ + Certain abstractions in the FIR dialect need to be rewritten to reflect + representations that may differ based on the target machine. + }]; + let constructor = "::fir::createFirTargetRewritePass()"; + let dependentDialects = [ "fir::FIROpsDialect" ]; + let options = [ + Option<"noCharacterConversion", "no-character-conversion", + "bool", /*default=*/"false", + "Disable target-specific conversion of CHARACTER.">, + Option<"noComplexConversion", "no-complex-conversion", + "bool", /*default=*/"false", + "Disable target-specific conversion of COMPLEX."> + ]; +} + #endif // FORTRAN_OPTIMIZER_CODEGEN_FIR_PASSES diff --git a/flang/include/flang/Optimizer/CodeGen/CodeGen.h b/flang/include/flang/Optimizer/CodeGen/CodeGen.h index d8635458828382..ed8355bb2fddd4 100644 --- a/flang/include/flang/Optimizer/CodeGen/CodeGen.h +++ b/flang/include/flang/Optimizer/CodeGen/CodeGen.h @@ -6,12 +6,14 @@ // //===----------------------------------------------------------------------===// -#ifndef OPTIMIZER_CODEGEN_CODEGEN_H -#define OPTIMIZER_CODEGEN_CODEGEN_H +#ifndef FORTRAN_OPTIMIZER_CODEGEN_CODEGEN_H +#define FORTRAN_OPTIMIZER_CODEGEN_CODEGEN_H #include "mlir/IR/BuiltinOps.h" #include "mlir/Pass/Pass.h" #include "mlir/Pass/PassRegistry.h" +#include "llvm/IR/Module.h" +#include "llvm/Support/raw_ostream.h" #include namespace fir { @@ -22,12 +24,27 @@ struct NameUniquer; /// the code gen (to LLVM-IR dialect) conversion. std::unique_ptr createFirCodeGenRewritePass(); +/// FirTargetRewritePass options. +struct TargetRewriteOptions { + bool noCharacterConversion{}; + bool noComplexConversion{}; +}; + +/// Prerequiste pass for code gen. Perform intermediate rewrites to tailor the +/// IR for the chosen target. +std::unique_ptr> createFirTargetRewritePass( + const TargetRewriteOptions &options = TargetRewriteOptions()); + /// Convert FIR to the LLVM IR dialect std::unique_ptr createFIRToLLVMPass(); +using LLVMIRLoweringPrinter = + std::function; /// Convert the LLVM IR dialect to LLVM-IR proper -std::unique_ptr -createLLVMDialectToLLVMPass(llvm::raw_ostream &output); +std::unique_ptr createLLVMDialectToLLVMPass( + llvm::raw_ostream &output, + LLVMIRLoweringPrinter printer = + [](llvm::Module &M, llvm::raw_ostream &out) { M.print(out, nullptr); }); // declarative passes #define GEN_PASS_REGISTRATION @@ -35,4 +52,4 @@ createLLVMDialectToLLVMPass(llvm::raw_ostream &output); } // namespace fir -#endif // OPTIMIZER_CODEGEN_CODEGEN_H +#endif // FORTRAN_OPTIMIZER_CODEGEN_CODEGEN_H diff --git a/flang/include/flang/Optimizer/Dialect/FIROps.h b/flang/include/flang/Optimizer/Dialect/FIROps.h index b9fe04a8af985c..41f5d9e30e2bbc 100644 --- a/flang/include/flang/Optimizer/Dialect/FIROps.h +++ b/flang/include/flang/Optimizer/Dialect/FIROps.h @@ -22,9 +22,6 @@ class FirEndOp; class DoLoopOp; class RealAttr; -void buildCmpFOp(mlir::OpBuilder &builder, mlir::OperationState &result, - mlir::CmpFPredicate predicate, mlir::Value lhs, - mlir::Value rhs); void buildCmpCOp(mlir::OpBuilder &builder, mlir::OperationState &result, mlir::CmpFPredicate predicate, mlir::Value lhs, mlir::Value rhs); @@ -33,8 +30,6 @@ unsigned getCaseArgumentOffset(llvm::ArrayRef cases, DoLoopOp getForInductionVarOwner(mlir::Value val); bool isReferenceLike(mlir::Type type); mlir::ParseResult isValidCaseAttr(mlir::Attribute attr); -mlir::ParseResult parseCmpfOp(mlir::OpAsmParser &parser, - mlir::OperationState &result); mlir::ParseResult parseCmpcOp(mlir::OpAsmParser &parser, mlir::OperationState &result); mlir::ParseResult parseSelector(mlir::OpAsmParser &parser, diff --git a/flang/include/flang/Optimizer/Dialect/FIROps.td b/flang/include/flang/Optimizer/Dialect/FIROps.td index a38630b2a04f0c..b17ba3f92bb38f 100644 --- a/flang/include/flang/Optimizer/Dialect/FIROps.td +++ b/flang/include/flang/Optimizer/Dialect/FIROps.td @@ -35,34 +35,6 @@ class fir_SimpleOp traits> }]; } -// Base builder for allocate operations -def fir_AllocateOpBuilder : OpBuilder<(ins - "mlir::Type":$inType, - CArg<"mlir::ValueRange", "{}">:$lenParams, - CArg<"mlir::ValueRange", "{}">:$sizes, - CArg<"llvm::ArrayRef", "{}">:$attributes), - [{ - $_state.addTypes(getRefTy(inType)); - $_state.addAttribute("in_type", TypeAttr::get(inType)); - $_state.addOperands(sizes); - $_state.addAttributes(attributes); - }]>; - -def fir_NamedAllocateOpBuilder : OpBuilder<(ins - "mlir::Type":$inType, - "llvm::StringRef":$name, - CArg<"mlir::ValueRange", "{}">:$lenParams, - CArg<"mlir::ValueRange","{}">:$sizes, - CArg<"llvm::ArrayRef", "{}">:$attributes), - [{ - $_state.addTypes(getRefTy(inType)); - $_state.addAttribute("in_type", TypeAttr::get(inType)); - if (!name.empty()) - $_state.addAttribute("name", $_builder.getStringAttr(name)); - $_state.addOperands(sizes); - $_state.addAttributes(attributes); - }]>; - def fir_OneResultOpBuilder : OpBuilder<(ins "mlir::Type":$resultType, "mlir::ValueRange":$operands, @@ -86,134 +58,12 @@ class fir_SimpleOneResultOp traits = []> : let builders = [fir_OneResultOpBuilder]; } -class fir_TwoBuilders { - list builders = [b1, b2]; -} - -class fir_AllocatableBaseOp traits = []> : - fir_Op, Results<(outs fir_Type:$res)> { - let arguments = (ins - OptionalAttr:$name, - OptionalAttr:$target - ); -} - -class fir_AllocatableOp traits = []> : - fir_AllocatableBaseOp]>])>, - fir_TwoBuilders, - Arguments<(ins TypeAttr:$in_type, Variadic:$args)> { - - let parser = [{ - mlir::Type intype; - if (parser.parseType(intype)) - return mlir::failure(); - auto &builder = parser.getBuilder(); - result.addAttribute(inType(), mlir::TypeAttr::get(intype)); - llvm::SmallVector operands; - llvm::SmallVector typeVec; - bool hasOperands = false; - if (!parser.parseOptionalLParen()) { - // parse the LEN params of the derived type. ( : ) - if (parser.parseOperandList(operands, - mlir::OpAsmParser::Delimiter::None) || - parser.parseColonTypeList(typeVec) || - parser.parseRParen()) - return mlir::failure(); - auto lens = builder.getI32IntegerAttr(operands.size()); - result.addAttribute(lenpName(), lens); - hasOperands = true; - } - if (!parser.parseOptionalComma()) { - // parse size to scale by, vector of n dimensions of type index - auto opSize = operands.size(); - if (parser.parseOperandList(operands, mlir::OpAsmParser::Delimiter::None)) - return mlir::failure(); - for (auto i = opSize, end = operands.size(); i != end; ++i) - typeVec.push_back(builder.getIndexType()); - hasOperands = true; - } - if (hasOperands && - parser.resolveOperands(operands, typeVec, parser.getNameLoc(), - result.operands)) - return mlir::failure(); - mlir::Type restype = wrapResultType(intype); - if (!restype) { - parser.emitError(parser.getNameLoc(), "invalid allocate type: ") - << intype; - return mlir::failure(); - } - if (parser.parseOptionalAttrDict(result.attributes) || - parser.addTypeToList(restype, result.types)) - return mlir::failure(); - return mlir::success(); - }]; - - let printer = [{ - p << getOperationName() << ' ' << (*this)->getAttr(inType()); - if (hasLenParams()) { - // print the LEN parameters to a derived type in parens - p << '(' << getLenParams() << " : " << getLenParams().getTypes() << ')'; - } - // print the shape of the allocation (if any); all must be index type - for (auto sh : getShapeOperands()) { - p << ", "; - p.printOperand(sh); - } - p.printOptionalAttrDict((*this)->getAttrs(), {inType(), lenpName()}); - }]; - - string extraAllocClassDeclaration = [{ - static constexpr llvm::StringRef inType() { return "in_type"; } - static constexpr llvm::StringRef lenpName() { return "len_param_count"; } - mlir::Type getAllocatedType(); - - bool hasLenParams() { return bool{(*this)->getAttr(lenpName())}; } - bool hasShapeOperands() { return numShapeOperands() > 0; } - - unsigned numLenParams() { - if (auto val = (*this)->getAttrOfType(lenpName())) - return val.getInt(); - return 0; - } - - operand_range getLenParams() { - return {operand_begin(), operand_begin() + numLenParams()}; - } - - unsigned numShapeOperands() { - return operand_end() - operand_begin() + numLenParams(); - } - - operand_range getShapeOperands() { - return {operand_begin() + numLenParams(), operand_end()}; - } - - static mlir::Type getRefTy(mlir::Type ty); - - /// Get the input type of the allocation - mlir::Type getInType() { - return (*this)->getAttrOfType(inType()).getValue(); - } - }]; - - // Verify checks common to all allocation operations - string allocVerify = [{ - llvm::SmallVector visited; - if (verifyInType(getInType(), visited, numShapeOperands())) - return emitOpError("invalid type for allocation"); - if (verifyRecordLenParams(getInType(), numLenParams())) - return emitOpError("LEN params do not correspond to type"); - }]; -} - //===----------------------------------------------------------------------===// // Memory SSA operations //===----------------------------------------------------------------------===// -def fir_AllocaOp : - fir_AllocatableOp<"alloca", AutomaticAllocationScopeResource> { +def fir_AllocaOp : fir_Op<"alloca", [AttrSizedOperandSegments, + MemoryEffects<[MemAlloc]>]> { let summary = "allocate storage for a temporary on the stack given a type"; let description = [{ This primitive operation is used to allocate an object on the stack. A @@ -275,9 +125,38 @@ def fir_AllocaOp : whether the procedure is recursive or not. }]; + let arguments = (ins + TypeAttr:$in_type, + OptionalAttr:$uniq_name, + OptionalAttr:$bindc_name, + Variadic:$typeparams, + Variadic:$shape + ); let results = (outs fir_ReferenceType); - let verifier = allocVerify#[{ + let parser = "return parseAlloca(parser, result);"; + let printer = "printAlloca(p, *this);"; + + let builders = [ + OpBuilder<(ins "mlir::Type":$in_type, "llvm::StringRef":$uniq_name, + "llvm::StringRef":$bindc_name, CArg<"mlir::ValueRange", "{}">:$typeparams, + CArg<"mlir::ValueRange", "{}">:$shape, + CArg<"llvm::ArrayRef", "{}">:$attributes)>, + OpBuilder<(ins "mlir::Type":$in_type, "llvm::StringRef":$uniq_name, + CArg<"mlir::ValueRange", "{}">:$typeparams, + CArg<"mlir::ValueRange", "{}">:$shape, + CArg<"llvm::ArrayRef", "{}">:$attributes)>, + OpBuilder<(ins "mlir::Type":$in_type, + CArg<"mlir::ValueRange", "{}">:$typeparams, + CArg<"mlir::ValueRange", "{}">:$shape, + CArg<"llvm::ArrayRef", "{}">:$attributes)>]; + + let verifier = [{ + llvm::SmallVector visited; + if (verifyInType(getInType(), visited, numShapeOperands())) + return emitOpError("invalid type for allocation"); + if (verifyTypeParamCount(getInType(), numLenParams())) + return emitOpError("LEN params do not correspond to type"); mlir::Type outType = getType(); if (!outType.isa()) return emitOpError("must be a !fir.ref type"); @@ -286,11 +165,110 @@ def fir_AllocaOp : return mlir::success(); }]; - let extraClassDeclaration = extraAllocClassDeclaration#[{ - static mlir::Type wrapResultType(mlir::Type intype); + let extraClassDeclaration = [{ + mlir::Type getAllocatedType(); + bool hasLenParams() { return !typeparams().empty(); } + bool hasShapeOperands() { return !shape().empty(); } + unsigned numLenParams() { return typeparams().size(); } + operand_range getLenParams() { return typeparams(); } + unsigned numShapeOperands() { return shape().size(); } + operand_range getShapeOperands() { return shape(); } + static mlir::Type getRefTy(mlir::Type ty); + mlir::Type getInType() { return in_type(); } }]; } +def fir_AllocMemOp : fir_Op<"allocmem", + [MemoryEffects<[MemAlloc]>, AttrSizedOperandSegments]> { + let summary = "allocate storage on the heap for an object of a given type"; + + let description = [{ + Creates a heap memory reference suitable for storing a value of the + given type, T. The heap refernce returned has type `!fir.heap`. + The memory object is in an undefined state. `allocmem` operations must + be paired with `freemem` operations to avoid memory leaks. + + ```mlir + %0 = fir.allocmem !fir.array<10 x f32> + fir.freemem %0 : !fir.heap> + ``` + }]; + + let arguments = (ins + TypeAttr:$in_type, + OptionalAttr:$uniq_name, + OptionalAttr:$bindc_name, + Variadic:$typeparams, + Variadic:$shape + ); + let results = (outs fir_HeapType); + + let parser = "return parseAllocMem(parser, result);"; + let printer = "printAllocMem(p, *this);"; + + let builders = [ + OpBuilder<(ins "mlir::Type":$in_type, "llvm::StringRef":$uniq_name, + "llvm::StringRef":$bindc_name, CArg<"mlir::ValueRange", "{}">:$typeparams, + CArg<"mlir::ValueRange", "{}">:$shape, + CArg<"llvm::ArrayRef", "{}">:$attributes)>, + OpBuilder<(ins "mlir::Type":$in_type, "llvm::StringRef":$uniq_name, + CArg<"mlir::ValueRange", "{}">:$typeparams, + CArg<"mlir::ValueRange", "{}">:$shape, + CArg<"llvm::ArrayRef", "{}">:$attributes)>, + OpBuilder<(ins "mlir::Type":$in_type, + CArg<"mlir::ValueRange", "{}">:$typeparams, + CArg<"mlir::ValueRange", "{}">:$shape, + CArg<"llvm::ArrayRef", "{}">:$attributes)>]; + + let verifier = [{ + llvm::SmallVector visited; + if (verifyInType(getInType(), visited, numShapeOperands())) + return emitOpError("invalid type for allocation"); + if (verifyTypeParamCount(getInType(), numLenParams())) + return emitOpError("LEN params do not correspond to type"); + mlir::Type outType = getType(); + if (!outType.dyn_cast()) + return emitOpError("must be a !fir.heap type"); + if (fir::isa_unknown_size_box(fir::dyn_cast_ptrEleTy(outType))) + return emitOpError("cannot allocate !fir.box of unknown rank or type"); + return mlir::success(); + }]; + + let extraClassDeclaration = [{ + mlir::Type getAllocatedType(); + bool hasLenParams() { return !typeparams().empty(); } + bool hasShapeOperands() { return !shape().empty(); } + unsigned numLenParams() { return typeparams().size(); } + operand_range getLenParams() { return typeparams(); } + unsigned numShapeOperands() { return shape().size(); } + operand_range getShapeOperands() { return shape(); } + static mlir::Type getRefTy(mlir::Type ty); + mlir::Type getInType() { return in_type(); } + }]; +} + +def fir_FreeMemOp : fir_Op<"freemem", [MemoryEffects<[MemFree]>]> { + let summary = "free a heap object"; + + let description = [{ + Deallocates a heap memory reference that was allocated by an `allocmem`. + The memory object that is deallocated is placed in an undefined state + after `fir.freemem`. Optimizations may treat the loading of an object + in the undefined state as undefined behavior. This includes aliasing + references, such as the result of an `fir.embox`. + + ```mlir + %21 = fir.allocmem !fir.type + ... + fir.freemem %21 : !fir.heap> + ``` + }]; + + let arguments = (ins Arg:$heapref); + + let assemblyFormat = "$heapref attr-dict `:` type($heapref)"; +} + def fir_LoadOp : fir_OneResultOp<"load"> { let summary = "load a value from a memory reference"; let description = [{ @@ -412,6 +390,94 @@ def fir_StoreOp : fir_Op<"store", []> { }]; } +def fir_SaveResultOp : fir_Op<"save_result", [AttrSizedOperandSegments]> { + let summary = [{ + save an array, box, or record function result SSA-value to a memory location + }]; + + let description = [{ + Save the result of a function returning an array, box, or record type value + into a memory location given the shape and length parameters of the result. + + Function results of type fir.box, fir.array, or fir.rec are abstract values + that require a storage to be manipulated on the caller side. This operation + allows associating such abstract result to a storage. In later lowering of + the function interfaces, this storage might be used to pass the result in + memory. + + For arrays, result, it is required to provide the shape of the result. For + character arrays and derived types with length parameters, the length + parameter values must be provided. + + The fir.save_result associated to a function call must immediately follow + the call and be in the same block. + + ```mlir + %buffer = fir.alloca fir.array, %c100 + %shape = fir.shape %c100 + %array_result = fir.call @foo() : () -> fir.array + fir.save_result %array_result to %buffer(%shape) + %coor = fir.array_coor %buffer%(%shape), %c5 + %fifth_element = fir.load %coor : f32 + ``` + + The above fir.save_result allows saving a fir.array function result into + a buffer to later access its 5th element. + + }]; + + let arguments = (ins AnyType:$value, + Arg:$memref, + Optional:$shape, + Variadic:$typeparams); + + let assemblyFormat = [{ + $value `to` $memref (`(` $shape^ `)`)? (`typeparams` $typeparams^)? + attr-dict `:` type(operands) + }]; + + let verifier = [{ return ::verify(*this); }]; +} + +def fir_CharConvertOp : fir_Op<"char_convert", []> { + let summary = [{ + Primitive to convert an entity of type CHARACTER from one KIND to a + different KIND. + }]; + + let description = [{ + Copy a CHARACTER (must be in memory) of KIND _k1_ to a CHARACTER (also must + be in memory) of KIND _k2_ where _k1_ != _k2_ and the buffers do not + overlap. This latter restriction is unchecked, as the Fortran language + definition eliminates the overlapping in memory case. + + The number of code points copied is specified explicitly as the second + argument. The length of the !fir.char type is ignored. + + ```mlir + fir.char_convert %1 for %2 to %3 : !fir.ref>, i32, !fir.ref> + ``` + + Should future support for encodings other than ASCII be supported, codegen + can generate a call to a runtime helper routine which will map the code + points from UTF-8 to UCS-2, for example. Such remappings may not always + be possible as they may involve the creation of more code points than the + `count` limit. These details are left as future to-dos. + }]; + + let arguments = (ins + Arg:$from, + AnyIntegerType:$count, + Arg:$to + ); + + let assemblyFormat = [{ + $from `for` $count `to` $to attr-dict `:` type(operands) + }]; + + let verifier = [{ return ::verify(*this); }]; +} + def fir_UndefOp : fir_OneResultOp<"undefined", [NoSideEffect]> { let summary = "explicit undefined value of some type"; let description = [{ @@ -455,59 +521,6 @@ def fir_ZeroOp : fir_OneResultOp<"zero_bits", [NoSideEffect]> { let assemblyFormat = "type($intype) attr-dict"; } -def fir_AllocMemOp : fir_AllocatableOp<"allocmem", DefaultResource> { - let summary = "allocate storage on the heap for an object of a given type"; - - let description = [{ - Creates a heap memory reference suitable for storing a value of the - given type, T. The heap refernce returned has type `!fir.heap`. - The memory object is in an undefined state. `allocmem` operations must - be paired with `freemem` operations to avoid memory leaks. - - ```mlir - %0 = fir.allocmem !fir.array<10 x f32> - fir.freemem %0 : !fir.heap> - ``` - }]; - - let results = (outs fir_HeapType); - - let verifier = allocVerify#[{ - mlir::Type outType = getType(); - if (!outType.dyn_cast()) - return emitOpError("must be a !fir.heap type"); - if (fir::isa_unknown_size_box(fir::dyn_cast_ptrEleTy(outType))) - return emitOpError("cannot allocate !fir.box of unknown rank or type"); - return mlir::success(); - }]; - - let extraClassDeclaration = extraAllocClassDeclaration#[{ - static mlir::Type wrapResultType(mlir::Type intype); - }]; -} - -def fir_FreeMemOp : fir_Op<"freemem", [MemoryEffects<[MemFree]>]> { - let summary = "free a heap object"; - - let description = [{ - Deallocates a heap memory reference that was allocated by an `allocmem`. - The memory object that is deallocated is placed in an undefined state - after `fir.freemem`. Optimizations may treat the loading of an object - in the undefined state as undefined behavior. This includes aliasing - references, such as the result of an `fir.embox`. - - ```mlir - %21 = fir.allocmem !fir.type - ... - fir.freemem %21 : !fir.heap> - ``` - }]; - - let arguments = (ins Arg:$heapref); - - let assemblyFormat = "$heapref attr-dict `:` type($heapref)"; -} - //===----------------------------------------------------------------------===// // Terminator operations //===----------------------------------------------------------------------===// @@ -578,7 +591,7 @@ class fir_IntegralSwitchTerminatorOp", "{}">:$attributes), [{ $_state.addOperands(selector); - llvm::SmallVector ivalues; + llvm::SmallVector ivalues; for (auto iv : compareOperands) ivalues.push_back($_builder.getI64IntegerAttr(iv)); ivalues.push_back($_builder.getUnitAttr()); @@ -587,7 +600,7 @@ class fir_IntegralSwitchTerminatorOp argOffs; + llvm::SmallVector argOffs; int32_t sumArgs = 0; for (std::remove_const_t i = 0; i != count; ++i) { if (i < opCount) { @@ -613,13 +626,13 @@ class fir_IntegralSwitchTerminatorOp ivalues; - llvm::SmallVector dests; - llvm::SmallVector, 8> destArgs; + llvm::SmallVector ivalues; + llvm::SmallVector dests; + llvm::SmallVector> destArgs; while (true) { mlir::Attribute ivalue; // Integer or Unit mlir::Block *dest; - llvm::SmallVector destArg; + llvm::SmallVector destArg; mlir::NamedAttrList temp; if (parser.parseAttribute(ivalue, "i", temp) || parser.parseComma() || @@ -635,7 +648,7 @@ class fir_IntegralSwitchTerminatorOp argOffs; + llvm::SmallVector argOffs; int32_t sumArgs = 0; const auto count = dests.size(); for (std::remove_const_t i = 0; i != count; ++i) { @@ -655,7 +668,8 @@ class fir_IntegralSwitchTerminatorOpgetAttrOfType(getCasesAttr()).getValue(); + auto cases = + (*this)->getAttrOfType(getCasesAttr()).getValue(); auto count = getNumConditions(); for (decltype(count) i = 0; i != count; ++i) { if (i) @@ -669,8 +683,9 @@ class fir_IntegralSwitchTerminatorOpgetAttrs(), {getCasesAttr(), getCompareOffsetAttr(), - getTargetOffsetAttr(), getOperandSegmentSizeAttr()}); + p.printOptionalAttrDict((*this)->getAttrs(), {getCasesAttr(), + getCompareOffsetAttr(), getTargetOffsetAttr(), + getOperandSegmentSizeAttr()}); }]; let verifier = [{ @@ -869,7 +884,7 @@ def fir_SelectTypeOp : fir_SwitchTerminatorOp<"select_type"> { for (auto d : destinations) $_state.addSuccessors(d); const auto opCount = destOperands.size(); - llvm::SmallVector argOffs; + llvm::SmallVector argOffs; int32_t sumArgs = 0; for (std::remove_const_t i = 0; i != count; ++i) { if (i < opCount) { @@ -1012,7 +1027,7 @@ def fir_EmboxOp : fir_Op<"embox", [NoSideEffect, AttrSizedOperandSegments]> { - shape: emboxing an array may require shape information (an array's lower bounds and extents may not be known until runtime), - slice: an array section can be described with a slice triple, - - lenParams: for emboxing a derived type with LEN type parameters, + - typeparams: for emboxing a derived type with LEN type parameters, - accessMap: unused/experimental. }]; @@ -1020,7 +1035,7 @@ def fir_EmboxOp : fir_Op<"embox", [NoSideEffect, AttrSizedOperandSegments]> { AnyReferenceLike:$memref, Optional:$shape, Optional:$slice, - Variadic:$lenParams, + Variadic:$typeparams, OptionalAttr:$accessMap ); @@ -1030,13 +1045,13 @@ def fir_EmboxOp : fir_Op<"embox", [NoSideEffect, AttrSizedOperandSegments]> { OpBuilder<(ins "llvm::ArrayRef":$resultTypes, "mlir::Value":$memref, CArg<"mlir::Value", "{}">:$shape, CArg<"mlir::Value", "{}">:$slice, - CArg<"mlir::ValueRange", "{}">:$lenParams), + CArg<"mlir::ValueRange", "{}">:$typeparams), [{ return build($_builder, $_state, resultTypes, memref, shape, slice, - lenParams, mlir::AffineMapAttr{}); }]> + typeparams, mlir::AffineMapAttr{}); }]> ]; let assemblyFormat = [{ - $memref (`(` $shape^ `)`)? (`[` $slice^ `]`)? (`typeparams` $lenParams^)? + $memref (`(` $shape^ `)`)? (`[` $slice^ `]`)? (`typeparams` $typeparams^)? (`map` $accessMap^)? attr-dict `:` functional-type(operands, results) }]; @@ -1045,8 +1060,8 @@ def fir_EmboxOp : fir_Op<"embox", [NoSideEffect, AttrSizedOperandSegments]> { let extraClassDeclaration = [{ mlir::Value getShape() { return shape(); } mlir::Value getSlice() { return slice(); } - bool hasLenParams() { return !lenParams().empty(); } - unsigned numLenParams() { return lenParams().size(); } + bool hasLenParams() { return !typeparams().empty(); } + unsigned numLenParams() { return typeparams().size(); } }]; } @@ -1132,8 +1147,8 @@ def fir_EmboxCharOp : fir_Op<"emboxchar", [NoSideEffect]> { }]; let verifier = [{ - auto eleTy = elementTypeOf(memref().getType()); - if (!eleTy.dyn_cast()) + auto eleTy = fir::dyn_cast_ptrEleTy(memref().getType()); + if (!eleTy.dyn_cast_or_null()) return mlir::failure(); return mlir::success(); }]; @@ -1523,6 +1538,43 @@ def fir_BoxTypeDescOp : fir_SimpleOneResultOp<"box_tdesc", [NoSideEffect]> { // Array value operations //===----------------------------------------------------------------------===// +// Array value operations are used to capture the semantics of +// Fortran's array expressions in FIR. An abstract array expression is +// evaluated in the following way. +// +// 1. Determination of the iteration space under which the assignment +// expression is to be evaluated. The iteration space may be implicit +// (from the shape of the result array) or explicit (defined by the user). +// 2. If there are masking expressions, evaluate (and cache) the +// masking expression for the iteration space (from 1). +// 3. The rhs of the assignment is evaluated for the iteration space. If +// masking expressions were present then the rhs is only evaluated where +// the mask was computed to be true. The entire rhs is completely evaluated +// before any results are stored to the lhs. +// 4. Each of the result values computed in the previous step are merged back +// to the lhs array's storage. +// +// The model (in pseudo-code) is thus: +// +// !- Load the arrays in the expression +// %10 = array_load A +// %11 = array_load B +// !- optional: compute mask values +// %masks = allocmem array +// do_loop_nest %i = ... { +// %masks[i] = ... +// } +// !- Compute every element value "A = B ..." +// do_loop_nest %i = ... { +// if (%masks[i]) { +// array_fetch %11, ... !- B(...) +// %20 = ... !- element-by-element computation +// array_update %10, %20, ... !- A(...) = ... +// } +// } +// !- Merge the new and old values into the memory for "A" +// array_merge_store to + def fir_ArrayLoadOp : fir_Op<"array_load", [AttrSizedOperandSegments]> { let summary = "Load an array as a value."; @@ -1555,13 +1607,14 @@ def fir_ArrayLoadOp : fir_Op<"array_load", [AttrSizedOperandSegments]> { Arg:$memref, Optional:$shape, Optional:$slice, - Variadic:$lenParams + Variadic:$typeparams ); let results = (outs fir_SequenceType); let assemblyFormat = [{ - $memref (`(`$shape^`)`)? (`[`$slice^`]`)? (`typeparams` $lenParams^)? attr-dict `:` functional-type(operands, results) + $memref (`(`$shape^`)`)? (`[`$slice^`]`)? (`typeparams` $typeparams^)? + attr-dict `:` functional-type(operands, results) }]; let verifier = [{ return ::verify(*this); }]; @@ -1571,8 +1624,8 @@ def fir_ArrayLoadOp : fir_Op<"array_load", [AttrSizedOperandSegments]> { }]; } -def fir_ArrayFetchOp : fir_Op<"array_fetch", [NoSideEffect]> { - +def fir_ArrayFetchOp : fir_Op<"array_fetch", [AttrSizedOperandSegments, + NoSideEffect]> { let summary = "Fetch the value of an element of an array value"; let description = [{ @@ -1602,29 +1655,22 @@ def fir_ArrayFetchOp : fir_Op<"array_fetch", [NoSideEffect]> { let arguments = (ins fir_SequenceType:$sequence, - Variadic:$indices + Variadic:$indices, + Variadic:$typeparams ); let results = (outs AnyType:$element); let assemblyFormat = [{ - $sequence `,` $indices attr-dict `:` functional-type(operands, results) + $sequence `,` $indices (`typeparams` $typeparams^)? attr-dict `:` + functional-type(operands, results) }]; - let verifier = [{ - auto arrTy = sequence().getType().cast(); - if (indices().size() != arrTy.getDimension()) - return emitOpError("number of indices != dimension of array"); - if (element().getType() != arrTy.getEleTy()) - return emitOpError("return type does not match array"); - if (!isa(sequence().getDefiningOp())) - return emitOpError("argument #0 must be result of fir.array_load"); - return mlir::success(); - }]; + let verifier = [{ return ::verify(*this); }]; } -def fir_ArrayUpdateOp : fir_Op<"array_update", [NoSideEffect]> { - +def fir_ArrayUpdateOp : fir_Op<"array_update", [AttrSizedOperandSegments, + NoSideEffect]> { let summary = "Update the value of an element of an array value"; let description = [{ @@ -1660,33 +1706,22 @@ def fir_ArrayUpdateOp : fir_Op<"array_update", [NoSideEffect]> { let arguments = (ins fir_SequenceType:$sequence, AnyType:$merge, - Variadic:$indices + Variadic:$indices, + Variadic:$typeparams ); let results = (outs fir_SequenceType); let assemblyFormat = [{ - $sequence `,` $merge `,` $indices attr-dict `:` functional-type(operands, results) + $sequence `,` $merge `,` $indices (`typeparams` $typeparams^)? attr-dict + `:` functional-type(operands, results) }]; - let verifier = [{ - auto arrTy = sequence().getType().cast(); - if (merge().getType() != arrTy.getEleTy()) - return emitOpError("merged value does not have element type"); - if (indices().size() != arrTy.getDimension()) - return emitOpError("number of indices != dimension of array"); - return mlir::success(); - }]; + let verifier = [{ return ::verify(*this); }]; } -def fir_ArrayMergeStoreOp : fir_Op<"array_merge_store", [ - TypesMatchWith<"type of 'original' matches element type of 'memref'", - "memref", "original", - "fir::dyn_cast_ptrOrBoxEleTy($_self)">, - TypesMatchWith<"type of 'sequence' matches element type of 'memref'", - "memref", "sequence", - "fir::dyn_cast_ptrOrBoxEleTy($_self)">]> { - +def fir_ArrayMergeStoreOp : fir_Op<"array_merge_store", + [AttrSizedOperandSegments]> { let summary = "Store merged array value to memory."; let description = [{ @@ -1714,16 +1749,17 @@ def fir_ArrayMergeStoreOp : fir_Op<"array_merge_store", [ let arguments = (ins fir_SequenceType:$original, fir_SequenceType:$sequence, - Arg:$memref + Arg:$memref, + Optional:$slice, + Variadic:$typeparams ); - let assemblyFormat = "$original `,` $sequence `to` $memref attr-dict `:` type($memref)"; - - let verifier = [{ - if (!isa(original().getDefiningOp())) - return emitOpError("operand #0 must be result of a fir.array_load op"); - return mlir::success(); + let assemblyFormat = [{ + $original `,` $sequence `to` $memref (`[` $slice^ `]`)? (`typeparams` + $typeparams^)? attr-dict `:` type(operands) }]; + + let verifier = "return ::verify(*this);"; } //===----------------------------------------------------------------------===// @@ -1762,13 +1798,14 @@ def fir_ArrayCoorOp : fir_Op<"array_coor", Optional:$shape, Optional:$slice, Variadic:$indices, - Variadic:$lenParams + Variadic:$typeparams ); let results = (outs fir_ReferenceType); let assemblyFormat = [{ - $memref (`(`$shape^`)`)? (`[`$slice^`]`)? $indices (`typeparams` $lenParams^)? attr-dict `:` functional-type(operands, results) + $memref (`(`$shape^`)`)? (`[`$slice^`]`)? $indices (`typeparams` + $typeparams^)? attr-dict `:` functional-type(operands, results) }]; let verifier = [{ return ::verify(*this); }]; @@ -1805,7 +1842,7 @@ def fir_CoordinateOp : fir_Op<"coordinate_of", [NoSideEffect]> { TypeAttr:$baseType ); - let results = (outs fir_ReferenceType); + let results = (outs RefOrLLVMPtr); let parser = [{ return parseCoordinateCustom(parser, result); }]; let printer = [{ ::print(p, *this); }]; @@ -1846,12 +1883,17 @@ def fir_ExtractValueOp : fir_OneResultOp<"extract_value", [NoSideEffect]> { let arguments = (ins AnyCompositeLike:$adt, - Variadic:$coor + ArrayAttr:$coor ); let assemblyFormat = [{ $adt `,` $coor attr-dict `:` functional-type(operands, results) }]; + + let builders = [ + OpBuilder<(ins "mlir::Type":$rty, "mlir::Value":$adt, + "llvm::ArrayRef":$vcoor)> + ]; } def fir_FieldIndexOp : fir_OneResultOp<"field_index", [NoSideEffect]> { @@ -1873,7 +1915,7 @@ def fir_FieldIndexOp : fir_OneResultOp<"field_index", [NoSideEffect]> { let arguments = (ins StrAttr:$field_id, TypeAttr:$on_type, - Variadic:$lenparams + Variadic:$typeparams ); let parser = [{ @@ -1889,8 +1931,8 @@ def fir_FieldIndexOp : fir_OneResultOp<"field_index", [NoSideEffect]> { return mlir::failure(); result.addAttribute(typeAttrName(), mlir::TypeAttr::get(recty)); if (!parser.parseOptionalLParen()) { - llvm::SmallVector operands; - llvm::SmallVector types; + llvm::SmallVector operands; + llvm::SmallVector types; auto loc = parser.getNameLoc(); if (parser.parseOperandList(operands, mlir::OpAsmParser::Delimiter::None) || @@ -1911,9 +1953,9 @@ def fir_FieldIndexOp : fir_OneResultOp<"field_index", [NoSideEffect]> { << ", " << (*this)->getAttr(typeAttrName()); if (getNumOperands()) { p << '('; - p.printOperands(lenparams()); + p.printOperands(typeparams()); auto sep = ") : "; - for (auto op : lenparams()) { + for (auto op : typeparams()) { p << sep; if (op) p.printType(op.getType()); @@ -2161,14 +2203,18 @@ def fir_InsertValueOp : fir_OneResultOp<"insert_value", [NoSideEffect]> { ``` }]; - let arguments = (ins AnyCompositeLike:$adt, AnyType:$val, - Variadic:$coor); + let arguments = (ins AnyCompositeLike:$adt, AnyType:$val, ArrayAttr:$coor); let results = (outs AnyCompositeLike); let assemblyFormat = [{ - operands attr-dict `:` functional-type(operands, results) + $adt `,` $val `,` $coor attr-dict `:` functional-type(operands, results) }]; + let builders = [ + OpBuilder<(ins "mlir::Type":$rty, "mlir::Value":$adt, "mlir::Value":$val, + "llvm::ArrayRef":$vcoor)> + ]; + let hasCanonicalizer = 1; } @@ -2176,18 +2222,35 @@ def fir_InsertOnRangeOp : fir_OneResultOp<"insert_on_range", [NoSideEffect]> { let summary = "insert sub-value into a range on an existing sequence"; let description = [{ - Insert a constant value into an entity with an array type. Returns a - new ssa value where the range of offsets from the original array have been - replaced with the constant. The result is an array type entity. + Insert copies of a value into an entity with an array type. + Returns a new ssa value with the same type as the original entity. + The values are inserted at a contiguous range of indices in Fortran + row-to-column element order as specified by lower and upper bound + coordinates. + + ```mlir + %a = fir.undefined !fir.array<10x10xf32> + %c = constant 3.0 : f32 + %1 = fir.insert_on_range %a, %c, [0 : index, 7 : index, 0 : index, 2 : index] : (!fir.array<10x10xf32>, f32) -> !fir.array<10x10xf32> + ``` + + The first 28 elements of %1, with coordinates from (0,0) to (7,2), have + the value 3.0. }]; - let arguments = (ins fir_SequenceType:$seq, AnyType:$val, - Variadic:$coor); + let arguments = (ins fir_SequenceType:$seq, AnyType:$val, ArrayAttr:$coor); let results = (outs fir_SequenceType); let assemblyFormat = [{ - operands attr-dict `:` functional-type(operands, results) + $seq `,` $val `,` $coor attr-dict `:` functional-type(operands, results) }]; + + let builders = [ + OpBuilder<(ins "mlir::Type":$rty, "mlir::Value":$adt, "mlir::Value":$val, + "llvm::ArrayRef":$vcoor)> + ]; + + let verifier = [{ return ::verify(*this); }]; } def fir_LenParamIndexOp : fir_OneResultOp<"len_param_index", [NoSideEffect]> { @@ -2622,7 +2685,7 @@ def fir_DispatchOp : fir_Op<"dispatch", []> { let parser = [{ mlir::FunctionType calleeType; - llvm::SmallVector operands; + llvm::SmallVector operands; auto calleeLoc = parser.getNameLoc(); llvm::StringRef calleeName; if (failed(parser.parseOptionalKeyword(&calleeName))) { @@ -2730,6 +2793,20 @@ def fir_StringLitOp : fir_Op<"string_lit", [NoSideEffect]> { p.printType(getType()); }]; + let builders = [ + OpBuilder<(ins "fir::CharacterType":$in_type, + "llvm::StringRef":$value, + CArg<"llvm::Optional", "{}">:$len)>, + OpBuilder<(ins "fir::CharacterType":$in_type, + "llvm::ArrayRef":$xlist, + CArg<"llvm::Optional", "{}">:$len)>, + OpBuilder<(ins "fir::CharacterType":$in_type, + "llvm::ArrayRef":$xlist, + CArg<"llvm::Optional", "{}">:$len)>, + OpBuilder<(ins "fir::CharacterType":$in_type, + "llvm::ArrayRef":$xlist, + CArg<"llvm::Optional", "{}">:$len)>]; + let verifier = [{ if (getSize().cast().getValue().isNegative()) return emitOpError("size must be non-negative"); @@ -2785,53 +2862,6 @@ class fir_UnaryArithmeticOp traits = []> : let printer = [{ return printUnaryOp(this->getOperation(), p); }]; } -class RealUnaryArithmeticOp traits = []> : - fir_UnaryArithmeticOp, - Arguments<(ins AnyRealLike:$operand)>; - -def fir_NegfOp : RealUnaryArithmeticOp<"negf">; - -class RealArithmeticOp traits = []> : - fir_ArithmeticOp, - Arguments<(ins AnyRealLike:$lhs, AnyRealLike:$rhs)>; - -def fir_ModfOp : RealArithmeticOp<"modf">; - -def fir_CmpfOp : fir_Op<"cmpf", - [NoSideEffect, SameTypeOperands, SameOperandsAndResultShape]> { - let summary = "floating-point comparison operator"; - - let description = [{ - Extends the standard floating-point comparison to handle the extended - floating-point types found in FIR. - }]; - - let arguments = (ins AnyRealLike:$lhs, AnyRealLike:$rhs); - - let results = (outs AnyLogicalLike); - - let builders = [OpBuilder<(ins "mlir::CmpFPredicate":$predicate, - "mlir::Value":$lhs, "mlir::Value":$rhs), [{ - buildCmpFOp($_builder, $_state, predicate, lhs, rhs); - }]>]; - - let parser = [{ return parseCmpfOp(parser, result); }]; - - let printer = [{ printCmpfOp(p, *this); }]; - - let extraClassDeclaration = [{ - static constexpr llvm::StringRef getPredicateAttrName() { - return "predicate"; - } - static CmpFPredicate getPredicateByName(llvm::StringRef name); - - CmpFPredicate getPredicate() { - return (CmpFPredicate)(*this)->getAttrOfType( - getPredicateAttrName()).getInt(); - } - }]; -} - def fir_ConstcOp : fir_Op<"constc", [NoSideEffect]> { let summary = "create a complex constant"; @@ -2932,6 +2962,8 @@ def fir_CmpcOp : fir_Op<"cmpc", return (CmpFPredicate)(*this)->getAttrOfType( getPredicateAttrName()).getInt(); } + + static CmpFPredicate getPredicateByName(llvm::StringRef name); }]; } @@ -3188,9 +3220,7 @@ def fir_GlobalOp : fir_Op<"global", [IsolatedFromAbove, Symbol]> { } /// The semantic type of the global - mlir::Type resultType() { - return fir::AllocaOp::wrapResultType(getType()); - } + mlir::Type resultType(); /// Return the initializer attribute if it exists, or a null attribute. Attribute getValueOrNull() { return initVal().getValueOr(Attribute()); } @@ -3280,7 +3310,7 @@ def fir_DispatchTableOp : fir_Op<"dispatch_table", A dispatch table is an untyped symbol that contains a list of associations between method identifiers and corresponding `FuncOp` symbols. - The ordering of associations in the map is determined by the front-end. + The ordering of associations in the map is determined by the front end. ```mlir fir.dispatch_table @_QDTMquuzTfoo { diff --git a/flang/include/flang/Optimizer/Dialect/FIROpsSupport.h b/flang/include/flang/Optimizer/Dialect/FIROpsSupport.h index dcca1ab55ee0d7..2f6e3c12fd321e 100644 --- a/flang/include/flang/Optimizer/Dialect/FIROpsSupport.h +++ b/flang/include/flang/Optimizer/Dialect/FIROpsSupport.h @@ -60,9 +60,25 @@ fir::GlobalOp createGlobalOp(mlir::Location loc, mlir::ModuleOp module, llvm::ArrayRef attrs = {}); /// Attribute to mark Fortran entities with the CONTIGUOUS attribute. -constexpr llvm::StringRef getContiguousAttrName() { return "fir.contiguous"; } +static constexpr llvm::StringRef getContiguousAttrName() { + return "fir.contiguous"; +} + /// Attribute to mark Fortran entities with the OPTIONAL attribute. -constexpr llvm::StringRef getOptionalAttrName() { return "fir.optional"; } +static constexpr llvm::StringRef getOptionalAttrName() { + return "fir.optional"; +} + +/// Attribute to mark Fortran entities with the TARGET attribute. +static constexpr llvm::StringRef getTargetAttrName() { return "fir.target"; } + +/// Attribute to keep track of Fortran scoping information for a symbol. +static constexpr llvm::StringRef getSymbolAttrName() { return "fir.sym_name"; } + +/// Attribute to mark a function that takes a host associations argument. +static constexpr llvm::StringRef getHostAssocAttrName() { + return "fir.host_assoc"; +} /// Tell if \p value is: /// - a function argument that has attribute \p attributeName @@ -74,6 +90,11 @@ constexpr llvm::StringRef getOptionalAttrName() { return "fir.optional"; } /// previous cases. bool valueHasFirAttribute(mlir::Value value, llvm::StringRef attributeName); +/// Scan the arguments of a FuncOp to determine if any arguments have the +/// attribute `attr` placed on them. This can be used to determine if the +/// function has any host associations, for example. +bool anyFuncArgsHaveAttr(mlir::FuncOp func, llvm::StringRef attr); + } // namespace fir #endif // FORTRAN_OPTIMIZER_DIALECT_FIROPSSUPPORT_H diff --git a/flang/include/flang/Optimizer/Dialect/FIRType.h b/flang/include/flang/Optimizer/Dialect/FIRType.h index ca0dddd2a2c710..f5b29c6df85f82 100644 --- a/flang/include/flang/Optimizer/Dialect/FIRType.h +++ b/flang/include/flang/Optimizer/Dialect/FIRType.h @@ -33,6 +33,7 @@ class DialectAsmParser; class DialectAsmPrinter; class ComplexType; class FloatType; +class ValueRange; } // namespace mlir namespace fir { @@ -65,7 +66,9 @@ bool isa_ref_type(mlir::Type t); bool isa_passbyref_type(mlir::Type t); /// Is `t` a boxed type? -bool isa_box_type(mlir::Type t); +inline bool isa_box_type(mlir::Type t) { + return t.isa() || t.isa() || t.isa(); +} /// Is `t` a type that can conform to be pass-by-reference? Depending on the /// context, these types may simply demote to pass-by-reference or a reference @@ -74,8 +77,14 @@ inline bool conformsWithPassByRef(mlir::Type t) { return isa_ref_type(t) || isa_box_type(t); } +/// Is `t` a derived (record) type? +inline bool isa_derived(mlir::Type t) { return t.isa(); } + /// Is `t` a FIR dialect aggregate type? -bool isa_aggregate(mlir::Type t); +inline bool isa_aggregate(mlir::Type t) { + return t.isa() || fir::isa_derived(t) || + t.isa(); +} /// Extract the `Type` pointed to from a FIR memory reference type. If `t` is /// not a memory reference type, then returns a null `Type`. @@ -109,17 +118,65 @@ inline bool isa_complex(mlir::Type t) { return t.isa() || t.isa(); } +/// Is `t` a CHARACTER type? Does not check the length. +inline bool isa_char(mlir::Type t) { return t.isa(); } + +/// Is `t` a trivial intrinsic type? CHARACTER is excluded because it +/// is a dependent type. +inline bool isa_trivial(mlir::Type t) { + return isa_integer(t) || isa_real(t) || isa_complex(t) || + t.isa(); +} + +/// Is `t` a CHARACTER type with a LEN other than 1? inline bool isa_char_string(mlir::Type t) { if (auto ct = t.dyn_cast_or_null()) return ct.getLen() != fir::CharacterType::singleton(); return false; } -/// Is `t` a box type for which it is not possible to deduce the box size. +/// Is `t` a box type for which it is not possible to deduce the box size? /// It is not possible to deduce the size of a box that describes an entity /// of unknown rank or type. bool isa_unknown_size_box(mlir::Type t); +/// Returns true iff `t` is a fir.char type and has an unknown length. +inline bool characterWithDynamicLen(mlir::Type t) { + if (auto charTy = t.dyn_cast()) + return charTy.hasDynamicLen(); + return false; +} + +/// Returns true iff `seqTy` has either an unknown shape or a non-constant shape +/// (where rank > 0). +inline bool sequenceWithNonConstantShape(fir::SequenceType seqTy) { + return seqTy.hasUnknownShape() || !seqTy.hasConstantShape(); +} + +/// Returns true iff the type `t` does not have a constant size. +bool hasDynamicSize(mlir::Type t); + +/// If `t` is a SequenceType return its element type, otherwise return `t`. +inline mlir::Type unwrapSequenceType(mlir::Type t) { + if (auto seqTy = t.dyn_cast()) + return seqTy.getEleTy(); + return t; +} + +inline mlir::Type unwrapRefType(mlir::Type t) { + if (auto eleTy = dyn_cast_ptrEleTy(t)) + return eleTy; + return t; +} + +/// If `t` conforms with a pass-by-reference type (box, ref, ptr, etc.) then +/// return the element type of `t`. Otherwise, return `t`. +inline mlir::Type unwrapPassByRefType(mlir::Type t) { + if (auto eleTy = dyn_cast_ptrOrBoxEleTy(t)) + return eleTy; + return t; +} + #ifndef NDEBUG // !fir.ptr and !fir.heap where X is !fir.ptr, !fir.heap, or !fir.ref // is undefined and disallowed. @@ -128,6 +185,32 @@ inline bool singleIndirectionLevel(mlir::Type ty) { } #endif +/// Return true iff `ty` is the type of a POINTER entity or value. +/// `isa_ref_type()` can be used to distinguish. +bool isPointerType(mlir::Type ty); + +/// Return true iff `ty` is the type of an ALLOCATABLE entity or value. +bool isAllocatableType(mlir::Type ty); + +/// Return true iff `ty` is the type of an unlimited polymorphic entity or +/// value. +bool isUnlimitedPolymorphicType(mlir::Type ty); + +/// Return true iff `ty` is a RecordType with members that are allocatable. +bool isRecordWithAllocatableMember(mlir::Type ty); + +/// Return true iff `ty` is a RecordType with type parameters. +inline bool isRecordWithTypeParameters(mlir::Type ty) { + if (auto recTy = ty.dyn_cast_or_null()) + return recTy.getNumLenParams() != 0; + return false; +} + +/// Apply the components specified by `path` to `rootTy` to determine the type +/// of the resulting component element. `rootTy` should be an aggregate type. +/// Returns null on error. +mlir::Type applyPathToType(mlir::Type rootTy, mlir::ValueRange path); + } // namespace fir #endif // FORTRAN_OPTIMIZER_DIALECT_FIRTYPE_H diff --git a/flang/include/flang/Optimizer/Dialect/FIRTypes.td b/flang/include/flang/Optimizer/Dialect/FIRTypes.td index b1df67186ae91d..e6286a38374760 100644 --- a/flang/include/flang/Optimizer/Dialect/FIRTypes.td +++ b/flang/include/flang/Optimizer/Dialect/FIRTypes.td @@ -224,6 +224,28 @@ def fir_LogicalType : FIR_Type<"Logical", "logical"> { }]; } +def fir_LLVMPointerType : FIR_Type<"LLVMPointer", "llvm_ptr"> { + let summary = "Like LLVM pointer type"; + + let description = [{ + A pointer type that does not have any of the constraints and semantics + of other FIR pointer types and that translates to llvm pointer types. + It is meant to implement indirection that cannot be expressed directly + in Fortran, but are needed to implement some Fortran features (e.g, + double indirections). + }]; + + let parameters = (ins "mlir::Type":$eleTy); + + let skipDefaultBuilders = 1; + + let builders = [ + TypeBuilderWithInferredContext<(ins "mlir::Type":$elementType), [{ + return Base::get(elementType.getContext(), elementType); + }]>, + ]; +} + def fir_PointerType : FIR_Type<"Pointer", "ptr"> { let summary = "Reference to a POINTER attribute type"; @@ -401,11 +423,17 @@ def fir_SequenceType : FIR_Type<"Sequence", "array"> { "mlir::Type":$eleTy), [{ return get(eleTy.getContext(), shape, eleTy, {}); }]>, + TypeBuilderWithInferredContext<(ins + "mlir::Type":$eleTy, + "size_t":$dimensions), [{ + llvm::SmallVector shape(dimensions, getUnknownExtent()); + return get(eleTy.getContext(), shape, eleTy, {}); + }]> ]; let extraClassDeclaration = [{ using Extent = int64_t; - using Shape = llvm::SmallVector; + using Shape = llvm::SmallVector; using ShapeRef = llvm::ArrayRef; unsigned getConstantRows() const; @@ -419,7 +447,9 @@ def fir_SequenceType : FIR_Type<"Sequence", "array"> { bool hasConstantInterior() const; // Is the shape of the sequence constant? - bool hasConstantShape() const { return getConstantRows() == getDimension(); } + bool hasConstantShape() const { + return getConstantRows() == getDimension(); + } // Does the sequence have unknown shape? (`array<* x T>`) bool hasUnknownShape() const { return getShape().empty(); } @@ -511,7 +541,11 @@ def AnyCompositeLike : TypeConstraint, "any reference">; + fir_HeapType.predicate, fir_PointerType.predicate, + fir_LLVMPointerType.predicate]>, "any reference">; + +def RefOrLLVMPtr : TypeConstraint, "fir.ref or fir.llvm_ptr">; def AnyBoxLike : TypeConstraint, "any box">; diff --git a/flang/include/flang/Optimizer/Support/FatalError.h b/flang/include/flang/Optimizer/Support/FatalError.h index 602045346587ca..8450b16a5baf44 100644 --- a/flang/include/flang/Optimizer/Support/FatalError.h +++ b/flang/include/flang/Optimizer/Support/FatalError.h @@ -20,8 +20,8 @@ namespace fir { /// Fatal error reporting helper. Report a fatal error with a source location /// and immediately abort flang. -LLVM_ATTRIBUTE_NORETURN inline void emitFatalError(mlir::Location loc, - const llvm::Twine &message) { +[[noreturn]] inline void emitFatalError(mlir::Location loc, + const llvm::Twine &message) { mlir::emitError(loc, message); llvm::report_fatal_error("aborting"); } diff --git a/flang/include/flang/Optimizer/Support/InitFIR.h b/flang/include/flang/Optimizer/Support/InitFIR.h index 194d42a41a1c3c..d3244a6db46ddd 100644 --- a/flang/include/flang/Optimizer/Support/InitFIR.h +++ b/flang/include/flang/Optimizer/Support/InitFIR.h @@ -21,22 +21,31 @@ #include "mlir/Pass/PassRegistry.h" #include "mlir/Transforms/LocationSnapshot.h" #include "mlir/Transforms/Passes.h" -#include "flang/Optimizer/CodeGen/CodeGen.h" namespace fir::support { -// The definitive list of dialects used by flang. -#define FLANG_DIALECT_LIST \ - mlir::AffineDialect, FIROpsDialect, FIRCodeGenDialect, \ - mlir::LLVM::LLVMDialect, mlir::acc::OpenACCDialect, \ +#define FLANG_NONCODEGEN_DIALECT_LIST \ + mlir::AffineDialect, FIROpsDialect, mlir::acc::OpenACCDialect, \ mlir::omp::OpenMPDialect, mlir::scf::SCFDialect, \ mlir::StandardOpsDialect, mlir::vector::VectorDialect +// The definitive list of dialects used by flang. +#define FLANG_DIALECT_LIST \ + FLANG_NONCODEGEN_DIALECT_LIST, FIRCodeGenDialect, mlir::LLVM::LLVMDialect + +inline void registerNonCodegenDialects(mlir::DialectRegistry ®istry) { + registry.insert(); +} + /// Register all the dialects used by flang. inline void registerDialects(mlir::DialectRegistry ®istry) { registry.insert(); } +inline void loadNonCodegenDialects(mlir::MLIRContext &context) { + context.loadDialect(); +} + /// Forced load of all the dialects used by flang. Lowering is not an MLIR /// pass, but a producer of FIR and MLIR. It is therefore a requirement that the /// dialects be preloaded to be able to build the IR. @@ -70,11 +79,11 @@ inline void registerMLIRPassesForFortranTools() { mlir::registerAffineDataCopyGenerationPass(); mlir::registerConvertAffineToStandardPass(); - - // Flang passes - fir::registerOptCodeGenPasses(); } +/// Register the interfaces needed to lower to LLVM IR. +void registerLLVMTranslation(mlir::MLIRContext &context); + } // namespace fir::support #endif // FORTRAN_OPTIMIZER_SUPPORT_INITFIR_H diff --git a/flang/include/flang/Optimizer/Support/InternalNames.h b/flang/include/flang/Optimizer/Support/InternalNames.h index fa98cc2a8e490c..c5961b196ef639 100644 --- a/flang/include/flang/Optimizer/Support/InternalNames.h +++ b/flang/include/flang/Optimizer/Support/InternalNames.h @@ -53,10 +53,10 @@ struct NameUniquer { : modules{modules.begin(), modules.end()}, host{host}, name{name}, kinds{kinds.begin(), kinds.end()} {} - llvm::SmallVector modules; + llvm::SmallVector modules; llvm::Optional host; std::string name; - llvm::SmallVector kinds; + llvm::SmallVector kinds; }; /// Unique a common block name @@ -112,6 +112,11 @@ struct NameUniquer { llvm::Optional host, llvm::StringRef name); + /// Unique a namelist group name + static std::string doNamelistGroup(llvm::ArrayRef modules, + llvm::Optional host, + llvm::StringRef name); + /// Entry point for the PROGRAM (called by the runtime) /// Can be overridden with the `--main-entry-name=` option. static llvm::StringRef doProgramEntry(); @@ -120,6 +125,13 @@ struct NameUniquer { static std::pair deconstruct(llvm::StringRef uniquedName); + /// Check if the name is an external facing name. + static bool isExternalFacingUniquedName( + const std::pair &deconstructResult); + + /// Check whether the name should be re-mangle with external ABI convention. + static bool needExternalNameMangling(llvm::StringRef uniquedName); + private: static std::string intAsString(std::int64_t i); static std::string doKind(std::int64_t kind); diff --git a/flang/include/flang/Optimizer/Support/Matcher.h b/flang/include/flang/Optimizer/Support/Matcher.h new file mode 100644 index 00000000000000..da1d7c21f42c4a --- /dev/null +++ b/flang/include/flang/Optimizer/Support/Matcher.h @@ -0,0 +1,35 @@ +//===-- Optimizer/Support/Matcher.h -----------------------------*- C++ -*-===// +// +// 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 +// +//===----------------------------------------------------------------------===// +// +// Coding style: https://mlir.llvm.org/getting_started/DeveloperGuide/ +// +//===----------------------------------------------------------------------===// + +#ifndef FORTRAN_OPTIMIZER_SUPPORT_MATCHER_H +#define FORTRAN_OPTIMIZER_SUPPORT_MATCHER_H + +#include + +// Boilerplate CRTP class for a simplified type-casing syntactic sugar. This +// lets one write pattern matchers using a more compact syntax. +namespace fir::details { +// clang-format off +template struct matches : Ts... { using Ts::operator()...; }; +template matches(Ts...) -> matches; +template struct matcher { + template auto match(Ts... ts) { + return std::visit(matches{ts...}, static_cast(this)->matchee()); + } + template auto match(Ts... ts) const { + return std::visit(matches{ts...}, static_cast(this)->matchee()); + } +}; +// clang-format on +} // namespace fir::details + +#endif // FORTRAN_OPTIMIZER_SUPPORT_MATCHER_H diff --git a/flang/include/flang/Optimizer/Support/TypeCode.h b/flang/include/flang/Optimizer/Support/TypeCode.h new file mode 100644 index 00000000000000..6eabdf438e5c8f --- /dev/null +++ b/flang/include/flang/Optimizer/Support/TypeCode.h @@ -0,0 +1,92 @@ +//===-- Optimizer/Support/TypeCode.h ----------------------------*- C++ -*-===// +// +// 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 +// +//===----------------------------------------------------------------------===// +// +// Coding style: https://mlir.llvm.org/getting_started/DeveloperGuide/ +// +//===----------------------------------------------------------------------===// + +#ifndef FORTRAN_OPTIMIZER_SUPPORT_TYPECODE_H +#define FORTRAN_OPTIMIZER_SUPPORT_TYPECODE_H + +#include "flang/ISO_Fortran_binding.h" +#include "llvm/Support/ErrorHandling.h" + +namespace fir { + +//===----------------------------------------------------------------------===// +// Translations of category and bitwidths to the type codes defined in flang's +// ISO_Fortran_binding.h. +//===----------------------------------------------------------------------===// + +inline int characterBitsToTypeCode(unsigned bits) { + // clang-format off + switch (bits) { + case 8: return CFI_type_char; + case 16: return CFI_type_char16_t; + case 32: return CFI_type_char32_t; + default: llvm_unreachable("unsupported character size"); + } + // clang-format on +} + +inline int complexBitsToTypeCode(unsigned bits) { + // clang-format off + switch (bits) { + case 32: return CFI_type_float_Complex; + case 64: return CFI_type_double_Complex; + case 80: + case 128: return CFI_type_long_double_Complex; + default: llvm_unreachable("unsupported complex size"); + } + // clang-format on +} + +inline int integerBitsToTypeCode(unsigned bits) { + // clang-format off + switch (bits) { + case 8: return CFI_type_int8_t; + case 16: return CFI_type_int16_t; + case 32: return CFI_type_int32_t; + case 64: return CFI_type_int64_t; + case 128: return CFI_type_int128_t; + default: llvm_unreachable("unsupported integer size"); + } + // clang-format on +} + +inline int logicalBitsToTypeCode(unsigned bits) { + // clang-format off + switch (bits) { + case 8: return CFI_type_Bool; + case 16: return CFI_type_int_least16_t; + case 32: return CFI_type_int_least32_t; + case 64: return CFI_type_int_least64_t; + default: llvm_unreachable("unsupported logical size"); + } + // clang-format on +} + +inline int realBitsToTypeCode(unsigned bits) { + // clang-format off + switch (bits) { + case 32: return CFI_type_float; + case 64: return CFI_type_double; + case 80: + case 128: return CFI_type_long_double; + default: llvm_unreachable("unsupported real size"); + } + // clang-format on +} + +static constexpr int derivedToTypeCode() { + return CFI_type_struct; +} + +} // namespace fir + +#endif // FORTRAN_OPTIMIZER_SUPPORT_TYPECODE_H diff --git a/flang/include/flang/Optimizer/Support/Utils.h b/flang/include/flang/Optimizer/Support/Utils.h new file mode 100644 index 00000000000000..edb14db370a3df --- /dev/null +++ b/flang/include/flang/Optimizer/Support/Utils.h @@ -0,0 +1,26 @@ +//===-- Optimizer/Support/Utils.h -------------------------------*- C++ -*-===// +// +// 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 +// +//===----------------------------------------------------------------------===// +// +// Coding style: https://mlir.llvm.org/getting_started/DeveloperGuide/ +// +//===----------------------------------------------------------------------===// + +#ifndef FORTRAN_OPTIMIZER_SUPPORT_UTILS_H +#define FORTRAN_OPTIMIZER_SUPPORT_UTILS_H + +#include "mlir/Dialect/StandardOps/IR/Ops.h" +#include "mlir/IR/BuiltinAttributes.h" + +namespace fir { +/// Return the integer value of a ConstantOp. +inline std::int64_t toInt(mlir::ConstantOp cop) { + return cop.getValue().cast().getValue().getSExtValue(); +} +} // namespace fir + +#endif // FORTRAN_OPTIMIZER_SUPPORT_UTILS_H diff --git a/flang/include/flang/Optimizer/Transforms/CMakeLists.txt b/flang/include/flang/Optimizer/Transforms/CMakeLists.txt index 37096bff40b69c..033349ec5e367d 100644 --- a/flang/include/flang/Optimizer/Transforms/CMakeLists.txt +++ b/flang/include/flang/Optimizer/Transforms/CMakeLists.txt @@ -1,4 +1,8 @@ +set(LLVM_TARGET_DEFINITIONS RewritePatterns.td) +mlir_tablegen(RewritePatterns.inc -gen-rewriters) +add_public_tablegen_target(RewritePatternsIncGen) + set(LLVM_TARGET_DEFINITIONS Passes.td) mlir_tablegen(Passes.h.inc -gen-pass-decls -name OptTransform) add_public_tablegen_target(FIROptTransformsPassIncGen) diff --git a/flang/include/flang/Optimizer/Transforms/Factory.h b/flang/include/flang/Optimizer/Transforms/Factory.h new file mode 100644 index 00000000000000..ea0e621b2b220f --- /dev/null +++ b/flang/include/flang/Optimizer/Transforms/Factory.h @@ -0,0 +1,256 @@ +//===-- Optimizer/Transforms/Factory.h --------------------------*- C++ -*-===// +// +// 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 +// +//===----------------------------------------------------------------------===// +// +// Templates to generate more complex code patterns in transformation passes. +// In transformation passes, front-end information such as is available in +// lowering is not available. +// +//===----------------------------------------------------------------------===// + +#ifndef FORTRAN_OPTIMIZER_TRANSFORMS_FACTORY_H +#define FORTRAN_OPTIMIZER_TRANSFORMS_FACTORY_H + +#include "flang/Optimizer/Dialect/FIROps.h" +#include "flang/Optimizer/Dialect/FIRType.h" +#include "mlir/Dialect/StandardOps/IR/Ops.h" +#include "llvm/ADT/iterator_range.h" + +namespace mlir { +class Location; +class Value; +} // namespace mlir + +namespace fir::factory { + +constexpr llvm::StringRef attrFortranArrayOffsets() { + return "Fortran.offsets"; +} + +/// Generate a character copy with optimized forms. +/// +/// If the lengths are constant and equal, use load/store rather than a loop. +/// Otherwise, if the lengths are constant and the input is longer than the +/// output, generate a loop to move a truncated portion of the source to the +/// destination. Finally, if the lengths are runtime values or the destination +/// is longer than the source, move the entire source character and pad the +/// destination with spaces as needed. +template +void genCharacterCopy(mlir::Value src, mlir::Value srcLen, mlir::Value dst, + mlir::Value dstLen, B &builder, mlir::Location loc) { + auto srcTy = + fir::dyn_cast_ptrEleTy(src.getType()).template cast(); + auto dstTy = + fir::dyn_cast_ptrEleTy(dst.getType()).template cast(); + if (!srcLen && !dstLen && srcTy.getFKind() == dstTy.getFKind() && + srcTy.getLen() == dstTy.getLen()) { + // same size, so just use load and store + auto load = builder.template create(loc, src); + builder.template create(loc, load, dst); + return; + } + auto zero = builder.template create(loc, 0); + auto one = builder.template create(loc, 1); + auto toArrayTy = [&](fir::CharacterType ty) { + return fir::ReferenceType::get(fir::SequenceType::get( + fir::SequenceType::ShapeRef{fir::SequenceType::getUnknownExtent()}, + fir::CharacterType::getSingleton(ty.getContext(), ty.getFKind()))); + }; + auto toEleTy = [&](fir::ReferenceType ty) { + auto seqTy = ty.getEleTy().cast(); + return seqTy.getEleTy().cast(); + }; + auto toCoorTy = [&](fir::ReferenceType ty) { + return fir::ReferenceType::get(toEleTy(ty)); + }; + if (!srcLen && !dstLen && srcTy.getLen() >= dstTy.getLen()) { + auto upper = + builder.template create(loc, dstTy.getLen() - 1); + auto loop = builder.template create(loc, zero, upper, one); + auto insPt = builder.saveInsertionPoint(); + builder.setInsertionPointToStart(loop.getBody()); + auto csrcTy = toArrayTy(srcTy); + auto csrc = builder.template create(loc, csrcTy, src); + auto in = builder.template create( + loc, toCoorTy(csrcTy), csrc, loop.getInductionVar()); + auto load = builder.template create(loc, in); + auto cdstTy = toArrayTy(dstTy); + auto cdst = builder.template create(loc, cdstTy, dst); + auto out = builder.template create( + loc, toCoorTy(cdstTy), cdst, loop.getInductionVar()); + mlir::Value cast = + srcTy.getFKind() == dstTy.getFKind() + ? load.getResult() + : builder + .template create(loc, toEleTy(cdstTy), load) + .getResult(); + builder.template create(loc, cast, out); + builder.restoreInsertionPoint(insPt); + return; + } + auto minusOne = [&](mlir::Value v) -> mlir::Value { + return builder.template create( + loc, builder.template create(loc, one.getType(), v), + one); + }; + mlir::Value len = + dstLen + ? minusOne(dstLen) + : builder + .template create(loc, dstTy.getLen() - 1) + .getResult(); + auto loop = builder.template create(loc, zero, len, one); + auto insPt = builder.saveInsertionPoint(); + builder.setInsertionPointToStart(loop.getBody()); + mlir::Value slen = + srcLen + ? builder.template create(loc, one.getType(), srcLen) + .getResult() + : builder.template create(loc, srcTy.getLen()) + .getResult(); + auto cond = builder.template create( + loc, mlir::CmpIPredicate::slt, loop.getInductionVar(), slen); + auto ifOp = builder.template create(loc, cond, /*withElse=*/true); + builder.setInsertionPointToStart(&ifOp.thenRegion().front()); + auto csrcTy = toArrayTy(srcTy); + auto csrc = builder.template create(loc, csrcTy, src); + auto in = builder.template create( + loc, toCoorTy(csrcTy), csrc, loop.getInductionVar()); + auto load = builder.template create(loc, in); + auto cdstTy = toArrayTy(dstTy); + auto cdst = builder.template create(loc, cdstTy, dst); + auto out = builder.template create( + loc, toCoorTy(cdstTy), cdst, loop.getInductionVar()); + mlir::Value cast = + srcTy.getFKind() == dstTy.getFKind() + ? load.getResult() + : builder.template create(loc, toEleTy(cdstTy), load) + .getResult(); + builder.template create(loc, cast, out); + builder.setInsertionPointToStart(&ifOp.elseRegion().front()); + auto space = builder.template create( + loc, toEleTy(cdstTy), llvm::ArrayRef{' '}); + auto cdst2 = builder.template create(loc, cdstTy, dst); + auto out2 = builder.template create( + loc, toCoorTy(cdstTy), cdst2, loop.getInductionVar()); + builder.template create(loc, space, out2); + builder.restoreInsertionPoint(insPt); +} + +/// Get extents from fir.shape/fir.shape_shift op. Empty result if +/// \p shapeVal is empty or is a fir.shift. +inline std::vector getExtents(mlir::Value shapeVal) { + if (shapeVal) + if (auto *shapeOp = shapeVal.getDefiningOp()) { + if (auto shOp = mlir::dyn_cast(shapeOp)) + return shOp.getExtents(); + if (auto shOp = mlir::dyn_cast(shapeOp)) + return shOp.getExtents(); + } + return {}; +} + +/// Get origins from fir.shape_shift/fir.shift op. Empty result if +/// \p shapeVal is empty or is a fir.shape. +inline std::vector getOrigins(mlir::Value shapeVal) { + if (shapeVal) + if (auto *shapeOp = shapeVal.getDefiningOp()) { + if (auto shOp = mlir::dyn_cast(shapeOp)) + return shOp.getOrigins(); + if (auto shOp = mlir::dyn_cast(shapeOp)) + return shOp.getOrigins(); + } + return {}; +} + +/// Convert the normalized indices on array_fetch and array_update to the +/// dynamic (and non-zero) origin required by array_coor. +/// Do not adjust any trailing components in the path as they specify a +/// particular path into the array value and must already correspond to the +/// structure of an element. +template +llvm::SmallVector +originateIndices(mlir::Location loc, B &builder, mlir::Type memTy, + mlir::Value shapeVal, mlir::ValueRange indices) { + llvm::SmallVector result; + auto origins = getOrigins(shapeVal); + if (origins.empty()) { + assert(!shapeVal || mlir::isa(shapeVal.getDefiningOp())); + auto ty = fir::dyn_cast_ptrOrBoxEleTy(memTy); + assert(ty && ty.isa()); + auto seqTy = ty.cast(); + auto one = builder.template create(loc, 1); + const auto dimension = seqTy.getDimension(); + if (shapeVal) { + assert(dimension == mlir::cast(shapeVal.getDefiningOp()) + .getType() + .getRank()); + } + for (auto i : llvm::enumerate(indices)) { + if (i.index() < dimension) { + assert(fir::isa_integer(i.value().getType())); + result.push_back( + builder.template create(loc, i.value(), one)); + } else { + result.push_back(i.value()); + } + } + return result; + } + const auto dimension = origins.size(); + unsigned origOff = 0; + for (auto i : llvm::enumerate(indices)) { + if (i.index() < dimension) + result.push_back(builder.template create( + loc, i.value(), origins[origOff++])); + else + result.push_back(i.value()); + } + return result; +} + +template +llvm::SmallVector createLoopNest( + mlir::Location loc, B &builder, llvm::iterator_range lows, + llvm::iterator_range highs, llvm::iterator_range steps, + llvm::ArrayRef threadedVals, bool unordered = false) { + llvm::SmallVector loops; + llvm::SmallVector inners(threadedVals.begin(), + threadedVals.end()); + for (auto iter0 = lows.begin(), iter1 = highs.begin(), iter2 = steps.begin(); + iter1 != highs.end(); ++iter0, ++iter1, ++iter2) { + auto lp = builder.template create( + loc, *iter0, *iter1, *iter2, unordered, + /*finalCount=*/false, inners); + loops.push_back(lp); + inners.assign(lp.getRegionIterArgs().begin(), lp.getRegionIterArgs().end()); + builder.setInsertionPointToStart(lp.getBody()); + } + auto numLoops = loops.size(); + for (decltype(numLoops) i = 0; i + 1 < numLoops; ++i) { + builder.setInsertionPointToEnd(loops[i].getBody()); + builder.template create(loc, loops[i + 1].getResults()); + } + builder.setInsertionPointAfter(loops[0]); + llvm::errs() << loops[0] << '\n'; + return loops; +} + +template +llvm::SmallVector createLoopNest( + mlir::Location loc, B &builder, llvm::ArrayRef lows, + llvm::ArrayRef highs, llvm::ArrayRef steps, + llvm::ArrayRef threadedVals, bool unordered = false) { + return createLoopNest( + loc, builder, llvm::make_range(lows.begin(), lows.end()), + llvm::make_range(highs.begin(), highs.end()), + llvm::make_range(steps.begin(), steps.end()), threadedVals, unordered); +} + +} // namespace fir::factory + +#endif // FORTRAN_OPTIMIZER_TRANSFORMS_FACTORY_H diff --git a/flang/include/flang/Optimizer/Transforms/Passes.h b/flang/include/flang/Optimizer/Transforms/Passes.h index 5e71995736e6ae..536a23f55212e4 100644 --- a/flang/include/flang/Optimizer/Transforms/Passes.h +++ b/flang/include/flang/Optimizer/Transforms/Passes.h @@ -6,8 +6,8 @@ // //===----------------------------------------------------------------------===// -#ifndef OPTIMIZER_TRANSFORMS_PASSES_H -#define OPTIMIZER_TRANSFORMS_PASSES_H +#ifndef FORTRAN_OPTIMIZER_TRANSFORMS_PASSES_H +#define FORTRAN_OPTIMIZER_TRANSFORMS_PASSES_H #include "mlir/Pass/Pass.h" #include "mlir/Pass/PassRegistry.h" @@ -16,35 +16,41 @@ namespace mlir { class BlockAndValueMapping; class Operation; -class Pass; class Region; } // namespace mlir namespace fir { -/// Convert fir.select_type to the standard dialect -std::unique_ptr createControlFlowLoweringPass(); +//===----------------------------------------------------------------------===// +// Passes defined in Passes.td +//===----------------------------------------------------------------------===// -/// Effects aware CSE pass +std::unique_ptr createControlFlowLoweringPass(); std::unique_ptr createCSEPass(); - -/// Convert FIR loop constructs to the Affine dialect std::unique_ptr createPromoteToAffinePass(); - -/// Convert `fir.do_loop` and `fir.if` to a CFG. This -/// conversion enables the `createLowerToCFGPass` to transform these to CFG -/// form. +std::unique_ptr createAffineDemotionPass(); +std::unique_ptr createFirLoopResultOptPass(); +std::unique_ptr createMemDataFlowOptPass(); std::unique_ptr createFirToCfgPass(); - -/// A pass to convert the FIR dialect from "Mem-SSA" form to "Reg-SSA" -/// form. This pass is a port of LLVM's mem2reg pass, but modified for the FIR -/// dialect as well as the restructuring of MLIR's representation to present PHI -/// nodes as block arguments. +std::unique_ptr createArrayValueCopyPass(); +std::unique_ptr createAbstractResultOptPass(); +std::unique_ptr createCharacterConversionPass(); +std::unique_ptr createExternalNameConversionPass(); + +/// A pass to convert the FIR dialect from "Mem-SSA" form to "Reg-SSA" form. +/// This pass is a port of LLVM's mem2reg pass, but modified for the FIR dialect +/// as well as the restructuring of MLIR's representation to present PHI nodes +/// as block arguments. +/// TODO: This pass needs some additional work. std::unique_ptr createMemToRegPass(); /// Support for inlining on FIR. -bool canLegallyInline(mlir::Operation *op, mlir::Region *reg, +bool canLegallyInline(mlir::Operation *op, mlir::Region *reg, bool, mlir::BlockAndValueMapping &map); +bool canLegallyInline(mlir::Operation *, mlir::Operation *, bool); + +/// Optionally force the body of a DO to execute at least once. +bool isAlwaysExecuteLoopBody(); // declarative passes #define GEN_PASS_REGISTRATION @@ -52,4 +58,4 @@ bool canLegallyInline(mlir::Operation *op, mlir::Region *reg, } // namespace fir -#endif // OPTIMIZER_TRANSFORMS_PASSES_H +#endif // FORTRAN_OPTIMIZER_TRANSFORMS_PASSES_H diff --git a/flang/include/flang/Optimizer/Transforms/Passes.td b/flang/include/flang/Optimizer/Transforms/Passes.td index cfa7e34bf8077f..46ac7a9498dd9f 100644 --- a/flang/include/flang/Optimizer/Transforms/Passes.td +++ b/flang/include/flang/Optimizer/Transforms/Passes.td @@ -11,41 +11,184 @@ // //===----------------------------------------------------------------------===// -#ifndef FLANG_OPTIMIZER_TRANSFORMS_PASSES -#define FLANG_OPTIMIZER_TRANSFORMS_PASSES +#ifndef FORTRAN_OPTIMIZER_TRANSFORMS_FIR_PASSES +#define FORTRAN_OPTIMIZER_TRANSFORMS_FIR_PASSES include "mlir/Pass/PassBase.td" def AffineDialectPromotion : FunctionPass<"promote-to-affine"> { - let summary = "Promotes fir.do_loop and fir.where to affine.for and affine.if where possible"; + let summary = "Promotes `fir.{do_loop,if}` to `affine.{for,if}`."; let description = [{ - TODO + Convert fir operations which satisfy affine constraints to the affine + dialect. + + `fir.do_loop` will be converted to `affine.for` if the loops inside the body + can be converted and the indices for memory loads and stores satisfy + `affine.apply` criteria for symbols and dimensions. + + `fir.if` will be converted to `affine.if` where possible. `affine.if`'s + condition uses an integer set (==, >=) and an analysis is done to determine + the fir condition's parent operations to construct the integer set. + + `fir.load` (`fir.store`) will be converted to `affine.load` (`affine.store`) + where possible. This conversion includes adding a dummy `fir.convert` cast + to adapt values of type `!fir.ref` to `memref`. This is done + because the affine dialect presently only understands the `memref` type. + }]; + let constructor = "::fir::createPromoteToAffinePass()"; + let dependentDialects = [ + "fir::FIROpsDialect", "mlir::StandardOpsDialect", "mlir::AffineDialect" + ]; +} + +def AffineDialectDemotion : FunctionPass<"demote-affine"> { + let summary = "Converts `affine.{load,store}` back to fir operations"; + let description = [{ + Affine dialect's default lowering for loads and stores is different from + fir as it uses the `memref` type. The `memref` type is not compatible with + the Fortran runtime. Therefore, conversion of memory operations back to + `fir.load` and `fir.store` with `!fir.ref` types is required. + }]; + let constructor = "::fir::createAffineDemotionPass()"; + let dependentDialects = [ + "fir::FIROpsDialect", "mlir::StandardOpsDialect", "mlir::AffineDialect" + ]; +} + +def FirLoopResultOpt : FunctionPass<"fir-loop-result-opt"> { + let summary = + "Optimizes `fir.do_loop` by removing unused final iteration values."; + let description = [{ + TODO - do we need this if we overhaul fir.do_loop a bit? }]; - let constructor = "fir::createPromoteToAffinePass()"; + let constructor = "::fir::createFirLoopResultOptPass()"; + let dependentDialects = [ + "fir::FIROpsDialect", "mlir::StandardOpsDialect", "mlir::AffineDialect" + ]; +} + +def MemRefDataFlowOpt : FunctionPass<"fir-memref-dataflow-opt"> { + let summary = + "Perform store/load forwarding and potentially removing dead stores."; + let description = [{ + This pass performs store to load forwarding to eliminate memory accesses and + potentially the entire allocation if all the accesses are forwarded. + }]; + let constructor = "::fir::createMemDataFlowOptPass()"; + let dependentDialects = [ + "fir::FIROpsDialect", "mlir::StandardOpsDialect", "mlir::AffineDialect" + ]; } def BasicCSE : FunctionPass<"basic-cse"> { - let summary = "Basic common sub-expression elimination"; + let summary = "Basic common sub-expression elimination."; let description = [{ - TODO + Perform common subexpression elimination on FIR operations. This pass + differs from the MLIR CSE pass in that it is FIR/Fortran semantics aware. }]; - let constructor = "fir::createCSEPass()"; + let constructor = "::fir::createCSEPass()"; + let dependentDialects = [ + "fir::FIROpsDialect", "mlir::StandardOpsDialect" + ]; } def ControlFlowLowering : FunctionPass<"lower-control-flow"> { - let summary = "Convert affine dialect, fir.select_type to standard dialect"; + let summary = "Convert affine dialect, fir.select_type to standard dialect."; let description = [{ - TODO + This converts the affine dialect back to standard dialect. It also converts + `fir.select_type` to more primitive operations. This pass is required before + code gen to the LLVM IR dialect. + + TODO: Should the affine rewriting by moved to AffineDialectDemotion? }]; - let constructor = "fir::createControlFlowLoweringPass()"; + let constructor = "::fir::createControlFlowLoweringPass()"; + let dependentDialects = [ + "fir::FIROpsDialect", "mlir::StandardOpsDialect" + ]; } def CFGConversion : FunctionPass<"cfg-conversion"> { let summary = "Convert FIR structured control flow ops to CFG ops."; let description = [{ - TODO + Transform the `fir.do_loop`, `fir.if`, and `fir.iterate_while` ops into + plain old test and branch operations. Removing the high-level control + structures can enable other optimizations. + + This pass is required before code gen to the LLVM IR dialect. + }]; + let constructor = "::fir::createFirToCfgPass()"; + let dependentDialects = [ + "fir::FIROpsDialect", "mlir::StandardOpsDialect" + ]; +} + +def ArrayValueCopy : FunctionPass<"array-value-copy"> { + let summary = "Convert array value operations to memory operations."; + let description = [{ + Transform the set of array value primitives to a memory-based array + representation. + + The Ops `array_load`, `array_store`, `array_fetch`, and `array_update` are + used to manage abstract aggregate array values. A simple analysis is done + to determine if there are potential dependences between these operations. + If not, these array operations can be lowered to work directly on the memory + representation. If there is a potential conflict, a temporary is created + along with appropriate copy-in/copy-out operations. Here, a more refined + analysis might be deployed, such as using the affine framework. + + This pass is required before code gen to the LLVM IR dialect. + }]; + let constructor = "::fir::createArrayValueCopyPass()"; + let dependentDialects = [ + "fir::FIROpsDialect", "mlir::StandardOpsDialect" + ]; +} + +def AbstractResultOpt : Pass<"abstract-result-opt", "mlir::FuncOp"> { + let summary = "Convert fir.array, fir.box and fir.rec function result to function argument"; + let description = [{ + This passed is required before code gen to the LLVM IR dialect, including the pre-cg rewrite pass. + }]; + let constructor = "::fir::createAbstractResultOptPass()"; + let dependentDialects = [ + "fir::FIROpsDialect", "mlir::StandardOpsDialect" + ]; + let options = [ + Option<"passResultAsBox", "abstract-result-as-box", + "bool", /*default=*/"false", + "Pass fir.array result as fir.box> argument instead" + " of fir.ref>."> + ]; +} + +def CharacterConversion : Pass<"character-conversion"> { + let summary = "Convert CHARACTER entities with different KINDs"; + let description = [{ + Translates entities of one CHARACTER KIND to another. + + By default the translation is to naively zero-extend or truncate a code + point to fit the destination size. + }]; + let constructor = "::fir::createCharacterConversionPass()"; + let dependentDialects = [ "fir::FIROpsDialect" ]; + let options = [ + Option<"useRuntimeCalls", "use-runtime-calls", + "std::string", /*default=*/"std::string{}", + "Generate runtime calls to a named set of conversion routines. " + "By default, the conversions may produce unexpected results."> + ]; +} + +def ExternalNameConversion : Pass<"external-name-interop", "mlir::ModuleOp"> { + let summary = "Convert name for external interoperability"; + let description = [{ + Demangle FIR internal name and mangle them for external interoperability. }]; - let constructor = "fir::createFirToCfgPass()"; + let constructor = "::fir::createExternalNameConversionPass()"; + let dependentDialects = [ + "fir::FIROpsDialect", "mlir::LLVM::LLVMDialect", + "mlir::acc::OpenACCDialect", "mlir::omp::OpenMPDialect" + ]; } -#endif // FLANG_OPTIMIZER_TRANSFORMS_PASSES +#endif // FORTRAN_OPTIMIZER_TRANSFORMS_FIR_PASSES diff --git a/flang/include/flang/Optimizer/Transforms/RewritePatterns.td b/flang/include/flang/Optimizer/Transforms/RewritePatterns.td new file mode 100644 index 00000000000000..5ececcf3f4e48e --- /dev/null +++ b/flang/include/flang/Optimizer/Transforms/RewritePatterns.td @@ -0,0 +1,59 @@ +//===-- RewritePatterns.td - FIR Rewrite Patterns -----------*- tablegen -*-===// +// +// 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 +// +//===----------------------------------------------------------------------===// +/// +/// \file +/// Defines pattern rewrites for fir optimizations +/// +//===----------------------------------------------------------------------===// + +#ifndef FORTRAN_FIR_REWRITE_PATTERNS +#define FORTRAN_FIR_REWRITE_PATTERNS + +include "mlir/IR/OpBase.td" +include "mlir/Dialect/StandardOps/IR/Ops.td" +include "flang/Optimizer/Dialect/FIROps.td" + +def IdenticalTypePred : Constraint>; +def IntegerTypePred : Constraint>; +def IndexTypePred : Constraint()">>; + +def SmallerWidthPred + : Constraint>; + +def ConvertConvertOptPattern + : Pat<(fir_ConvertOp (fir_ConvertOp $arg)), + (fir_ConvertOp $arg), + [(IntegerTypePred $arg)]>; + +def RedundantConvertOptPattern + : Pat<(fir_ConvertOp:$res $arg), + (replaceWithValue $arg), + [(IdenticalTypePred $res, $arg) + ,(IntegerTypePred $arg)]>; + +def CombineConvertOptPattern + : Pat<(fir_ConvertOp:$res(fir_ConvertOp:$irm $arg)), + (replaceWithValue $arg), + [(IdenticalTypePred $res, $arg) + ,(IntegerTypePred $arg) + ,(IntegerTypePred $irm) + ,(SmallerWidthPred $arg, $irm)]>; + +def createConstantOp + : NativeCodeCall<"$_builder.create" + "($_loc, $_builder.getIndexType(), " + "rewriter.getIndexAttr($1.dyn_cast().getInt()))">; + +def ForwardConstantConvertPattern + : Pat<(fir_ConvertOp:$res (ConstantOp:$cnt $attr)), + (createConstantOp $res, $attr), + [(IndexTypePred $res) + ,(IntegerTypePred $cnt)]>; + +#endif // FORTRAN_FIR_REWRITE_PATTERNS diff --git a/flang/include/flang/Parser/parse-tree.h b/flang/include/flang/Parser/parse-tree.h index 1fbe1160324ae9..5ce6a110c1e654 100644 --- a/flang/include/flang/Parser/parse-tree.h +++ b/flang/include/flang/Parser/parse-tree.h @@ -1779,7 +1779,7 @@ struct Designator { struct Variable { UNION_CLASS_BOILERPLATE(Variable); mutable TypedExpr typedExpr; - parser::CharBlock GetSource() const; + CharBlock GetSource() const; std::variant, common::Indirection> u; diff --git a/flang/runtime/allocatable.h b/flang/include/flang/Runtime/allocatable.h similarity index 88% rename from flang/runtime/allocatable.h rename to flang/include/flang/Runtime/allocatable.h index 85334cbfb0bc6f..cce803534d6842 100644 --- a/flang/runtime/allocatable.h +++ b/flang/include/flang/Runtime/allocatable.h @@ -1,4 +1,4 @@ -//===-- runtime/allocatable.h -----------------------------------*- C++ -*-===// +//===-- include/flang/Runtime/allocatable.h ---------------------*- C++ -*-===// // // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. // See https://llvm.org/LICENSE.txt for license information. @@ -10,14 +10,12 @@ // to manipulate and query allocatable variables, dummy arguments, & components. #ifndef FORTRAN_RUNTIME_ALLOCATABLE_H_ #define FORTRAN_RUNTIME_ALLOCATABLE_H_ -#include "descriptor.h" -#include "entry-names.h" -namespace Fortran::runtime::typeInfo { -class DerivedType; -} +#include "flang/Runtime/descriptor.h" +#include "flang/Runtime/entry-names.h" namespace Fortran::runtime { + extern "C" { // Initializes the descriptor for an allocatable of intrinsic or derived type. @@ -55,7 +53,7 @@ void RTNAME(AllocatableApplyMold)(Descriptor &, const Descriptor &mold); void RTNAME(AllocatableSetBounds)( Descriptor &, int zeroBasedDim, SubscriptValue lower, SubscriptValue upper); -// The upper bound is ignored for the last codimension. +// The upper cobound is ignored for the last codimension. void RTNAME(AllocatableSetCoBounds)(Descriptor &, int zeroBasedCoDim, SubscriptValue lower, SubscriptValue upper = 0); @@ -91,15 +89,6 @@ int RTNAME(AllocatableAllocateSource)(Descriptor &, const Descriptor &source, bool hasStat = false, const Descriptor *errMsg = nullptr, const char *sourceFile = nullptr, int sourceLine = 0); -// Assigns to a whole allocatable, with automatic (re)allocation when the -// destination is unallocated or nonconforming (Fortran 2003 semantics). -// The descriptor must be initialized. -// Recursively assigns components with (re)allocation as necessary. -// TODO: Consider renaming to a more general name that will work for -// assignments to pointers, dummy arguments, and anything else with a -// descriptor. -void RTNAME(AllocatableAssign)(Descriptor &to, const Descriptor &from); - // Implements the intrinsic subroutine MOVE_ALLOC (16.9.137 in F'2018, // but note the order of first two arguments is reversed for consistency // with the other APIs for allocatables.) The destination descriptor @@ -114,6 +103,10 @@ int RTNAME(MoveAlloc)(Descriptor &to, const Descriptor &from, int RTNAME(AllocatableDeallocate)(Descriptor &, bool hasStat = false, const Descriptor *errMsg = nullptr, const char *sourceFile = nullptr, int sourceLine = 0); -} + +// Variant of above that does not finalize; for intermediate results +void RTNAME(AllocatableDeallocateNoFinal)( + Descriptor &, const char *sourceFile = nullptr, int sourceLine = 0); +} // extern "C" } // namespace Fortran::runtime #endif // FORTRAN_RUNTIME_ALLOCATABLE_H_ diff --git a/flang/include/flang/Runtime/assign.h b/flang/include/flang/Runtime/assign.h new file mode 100644 index 00000000000000..141a0b62c54c21 --- /dev/null +++ b/flang/include/flang/Runtime/assign.h @@ -0,0 +1,45 @@ +//===-- include/flang/Runtime/assign.h --------------------------*- C++ -*-===// +// +// 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 +// +//===----------------------------------------------------------------------===// + +// External and internal APIs for data assignment (both intrinsic assignment +// and TBP defined generic ASSIGNMENT(=)). Should be called by lowering +// for any assignments possibly needing special handling. Intrinsic assignment +// to non-allocatable variables whose types are intrinsic need not come through +// here (though they may do so). Assignments to allocatables, and assignments +// whose types may be polymorphic or are monomorphic and of derived types with +// finalization, allocatable components, or components with type-bound defined +// assignments, in the original type or the types of its non-pointer components +// (recursively) must arrive here. +// +// Non-type-bound generic INTERFACE ASSIGNMENT(=) is resolved in semantics and +// need not be handled here in the runtime; ditto for type conversions on +// intrinsic assignments. + +#ifndef FORTRAN_RUNTIME_ASSIGN_H_ +#define FORTRAN_RUNTIME_ASSIGN_H_ + +#include "flang/Runtime/entry-names.h" + +namespace Fortran::runtime { +class Descriptor; +class Terminator; + +// Assigns one object to another via intrinsic assignment (F'2018 10.2.1.3) or +// type-bound (only!) defined assignment (10.2.1.4), as appropriate. Performs +// finalization, scalar expansion, & allocatable (re)allocation as needed. +// Does not perform intrinsic assignment implicit type conversion. Both +// descriptors must be initialized. Recurses as needed to handle components. +void Assign(Descriptor &, const Descriptor &, Terminator &); + +extern "C" { +// API for lowering assignment +void RTNAME(Assign)(Descriptor &to, const Descriptor &from, + const char *sourceFile = nullptr, int sourceLine = 0); +} // extern "C" +} // namespace Fortran::runtime +#endif // FORTRAN_RUNTIME_ASSIGN_H_ diff --git a/flang/runtime/c-or-cpp.h b/flang/include/flang/Runtime/c-or-cpp.h similarity index 92% rename from flang/runtime/c-or-cpp.h rename to flang/include/flang/Runtime/c-or-cpp.h index 016bce07956db8..4babd885cad32f 100644 --- a/flang/runtime/c-or-cpp.h +++ b/flang/include/flang/Runtime/c-or-cpp.h @@ -1,4 +1,4 @@ -//===-- runtime/c-or-cpp.h --------------------------------------*- C++ -*-===// +//===-- include/flang/Runtime/c-or-cpp.h ------------------------*- C++ -*-===// // // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. // See https://llvm.org/LICENSE.txt for license information. diff --git a/flang/runtime/character.h b/flang/include/flang/Runtime/character.h similarity index 98% rename from flang/runtime/character.h rename to flang/include/flang/Runtime/character.h index 622fbca17cf6b5..441faf2c363331 100644 --- a/flang/runtime/character.h +++ b/flang/include/flang/Runtime/character.h @@ -1,4 +1,4 @@ -//===-- runtime/character.h -------------------------------------*- C++ -*-===// +//===-- include/flang/Runtime/character.h -----------------------*- C++ -*-===// // // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. // See https://llvm.org/LICENSE.txt for license information. @@ -11,7 +11,7 @@ #ifndef FORTRAN_RUNTIME_CHARACTER_H_ #define FORTRAN_RUNTIME_CHARACTER_H_ -#include "entry-names.h" +#include "flang/Runtime/entry-names.h" #include namespace Fortran::runtime { diff --git a/flang/include/flang/Runtime/coarray.h b/flang/include/flang/Runtime/coarray.h new file mode 100644 index 00000000000000..1a326f0f3b7cea --- /dev/null +++ b/flang/include/flang/Runtime/coarray.h @@ -0,0 +1,32 @@ +//===-- include/flang/Runtime/coarray.h -------------------------*- C++ -*-===// +// +// 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 +// +//===----------------------------------------------------------------------===// + +#ifndef FORTRAN_RUNTIME_COARRAY_H_ +#define FORTRAN_RUNTIME_COARRAY_H_ + +// Defines API between compiled code and the coarray +// support functions in the runtime library. + +#include "flang/Runtime/entry-names.h" + +namespace Fortran::runtime { + +extern "C" { +// 16.9.145 NUM_IMAGES +// The default value team_number=0 is not a valid team number and thus chosen +// when NUM_IMAGES is called with no actual arguments, see: +// 1. 9.6 paragraph 3: TEAM_NUMBER shall be from a FORM TEAM statement or +// the initial team. +// 2. 16.9.189 TEAM_NUMBER paragraph 5: initial team shall have the value -1. +// 3. 11.6.9 FORM TEAM statement: TEAM_NUMBER shall be greater than 0. +int RTNAME(NumImages)( + int team_number = 0, const char *sourceFile = nullptr, int sourceLine = 0); +} +} // namespace Fortran::runtime + +#endif // FORTRAN_RUNTIME_COARRAY_H_ diff --git a/flang/include/flang/Runtime/command.h b/flang/include/flang/Runtime/command.h new file mode 100644 index 00000000000000..5e98b410729182 --- /dev/null +++ b/flang/include/flang/Runtime/command.h @@ -0,0 +1,42 @@ +//===-- include/flang/Runtime/command.h -------------------------*- C++ -*-===// +// +// 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 +// +//===----------------------------------------------------------------------===// + +#ifndef FORTRAN_RUNTIME_COMMAND_H_ +#define FORTRAN_RUNTIME_COMMAND_H_ + +#include "flang/Runtime/cpp-type.h" +#include "flang/Runtime/entry-names.h" + +namespace Fortran::runtime { +class Descriptor; + +extern "C" { +// 16.9.51 COMMAND_ARGUMENT_COUNT +// +// Lowering may need to cast the result to match the precision of the default +// integer kind. +CppTypeFor RTNAME(ArgumentCount)(); + +// 16.9.83 GET_COMMAND_ARGUMENT +// We're breaking up the interface into several different functions, since most +// of the parameters are optional. + +// Try to get the value of the n'th argument. +// Returns a STATUS as described in the standard. +CppTypeFor RTNAME(ArgumentValue)( + CppTypeFor n, const Descriptor *value, + const Descriptor *errmsg); + +// Try to get the significant length of the n'th argument. +// Returns 0 if it doesn't manage. +CppTypeFor RTNAME(ArgumentLength)( + CppTypeFor n); +} +} // namespace Fortran::runtime + +#endif // FORTRAN_RUNTIME_COMMAND_H_ diff --git a/flang/runtime/cpp-type.h b/flang/include/flang/Runtime/cpp-type.h similarity index 96% rename from flang/runtime/cpp-type.h rename to flang/include/flang/Runtime/cpp-type.h index 613df974656c82..38a8cf7e7e6cb6 100644 --- a/flang/runtime/cpp-type.h +++ b/flang/include/flang/Runtime/cpp-type.h @@ -1,4 +1,4 @@ -//===-- runtime/cpp-type.h --------------------------------------*- C++ -*-===// +//===-- include/flang/Runtime/cpp-type.h ------------------------*- C++ -*-===// // // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. // See https://llvm.org/LICENSE.txt for license information. diff --git a/flang/include/flang/Runtime/derived-api.h b/flang/include/flang/Runtime/derived-api.h new file mode 100644 index 00000000000000..515905d6c22cf7 --- /dev/null +++ b/flang/include/flang/Runtime/derived-api.h @@ -0,0 +1,43 @@ +//===-- include/flang/Runtime/derived-api.h ---------------------*- C++ -*-===// +// +// 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 +// +//===----------------------------------------------------------------------===// + +// API for lowering to use for operations on derived type objects. +// Initialiaztion and finalization are implied for pointer and allocatable +// ALLOCATE()/DEALLOCATE() respectively, so these APIs should be used only for +// local variables. Whole allocatable assignment should use AllocatableAssign() +// instead of this Assign(). + +#ifndef FORTRAN_RUNTIME_DERIVED_API_H_ +#define FORTRAN_RUNTIME_DERIVED_API_H_ + +#include "flang/Runtime/entry-names.h" + +namespace Fortran::runtime { +class Descriptor; + +extern "C" { + +// Initializes and allocates an object's components, if it has a derived type +// with any default component initialization or automatic components. +// The descriptor must be initialized and non-null. +void RTNAME(Initialize)( + const Descriptor &, const char *sourceFile = nullptr, int sourceLine = 0); + +// Finalizes an object and its components. Deallocates any +// allocatable/automatic components. Does not deallocate the descriptor's +// storage. +void RTNAME(Destroy)(const Descriptor &); + +// Intrinsic or defined assignment, with scalar expansion but not type +// conversion. +void RTNAME(Assign)(const Descriptor &, const Descriptor &, + const char *sourceFile = nullptr, int sourceLine = 0); + +} // extern "C" +} // namespace Fortran::runtime +#endif // FORTRAN_RUNTIME_DERIVED_API_H_ diff --git a/flang/runtime/descriptor.h b/flang/include/flang/Runtime/descriptor.h similarity index 90% rename from flang/runtime/descriptor.h rename to flang/include/flang/Runtime/descriptor.h index 5e03ad05b253be..2b927df3bcd292 100644 --- a/flang/runtime/descriptor.h +++ b/flang/include/flang/Runtime/descriptor.h @@ -1,4 +1,4 @@ -//===-- runtime/descriptor.h ------------------------------------*- C++ -*-===// +//===-- include/flang/Runtime/descriptor.h ----------------------*- C++ -*-===// // // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. // See https://llvm.org/LICENSE.txt for license information. @@ -18,9 +18,9 @@ // User C code is welcome to depend on that ISO_Fortran_binding.h file, // but should never reference this internal header. -#include "memory.h" -#include "type-code.h" #include "flang/ISO_Fortran_binding.h" +#include "flang/Runtime/memory.h" +#include "flang/Runtime/type-code.h" #include #include #include @@ -83,16 +83,8 @@ class Dimension { // array is determined by derivedType_->LenParameters(). class DescriptorAddendum { public: - enum Flags { - StaticDescriptor = 0x001, - ImplicitAllocatable = 0x002, // compiler-created allocatable - DoNotFinalize = 0x004, // compiler temporary - Target = 0x008, // TARGET attribute - }; - - explicit DescriptorAddendum( - const typeInfo::DerivedType *dt = nullptr, std::uint64_t flags = 0) - : derivedType_{dt}, flags_{flags} {} + explicit DescriptorAddendum(const typeInfo::DerivedType *dt = nullptr) + : derivedType_{dt} {} DescriptorAddendum &operator=(const DescriptorAddendum &); const typeInfo::DerivedType *derivedType() const { return derivedType_; } @@ -100,8 +92,6 @@ class DescriptorAddendum { derivedType_ = dt; return *this; } - std::uint64_t &flags() { return flags_; } - const std::uint64_t &flags() const { return flags_; } std::size_t LenParameters() const; @@ -109,8 +99,9 @@ class DescriptorAddendum { return len_[which]; } static constexpr std::size_t SizeInBytes(int lenParameters) { - return sizeof(DescriptorAddendum) - sizeof(typeInfo::TypeParameterValue) + - lenParameters * sizeof(typeInfo::TypeParameterValue); + // TODO: Don't waste that last word if lenParameters == 0 + return sizeof(DescriptorAddendum) + + std::max(lenParameters - 1, 0) * sizeof(typeInfo::TypeParameterValue); } std::size_t SizeInBytes() const; @@ -122,7 +113,6 @@ class DescriptorAddendum { private: const typeInfo::DerivedType *derivedType_; - std::uint64_t flags_{0}; typeInfo::TypeParameterValue len_[1]; // must be the last component // The LEN type parameter values can also include captured values of // specification expressions that were used for bounds and for LEN type @@ -144,14 +134,7 @@ class Descriptor { // Create() static member functions otherwise to dynamically allocate a // descriptor. - Descriptor() { - // Minimal initialization to prevent the destructor from running amuck - // later if the descriptor is never established. - raw_.base_addr = nullptr; - raw_.f18Addendum = false; - } Descriptor(const Descriptor &); - ~Descriptor(); Descriptor &operator=(const Descriptor &); static constexpr std::size_t BytesFor(TypeCategory category, int kind) { @@ -304,11 +287,20 @@ class Descriptor { std::size_t Elements() const; - // TODO: SOURCE= and MOLD= + // Allocate() assumes Elements() and ElementBytes() work; + // define the extents of the dimensions and the element length + // before calling. It (re)computes the byte strides after + // allocation. Does not allocate automatic components or + // perform default component initialization. int Allocate(); - int Allocate(const SubscriptValue lb[], const SubscriptValue ub[]); - int Deallocate(bool finalize = true); - void Destroy(bool finalize = true) const; + + // Deallocates storage; does not call FINAL subroutines or + // deallocate allocatable/automatic components. + int Deallocate(); + + // Deallocates storage, including allocatable and automatic + // components. Optionally invokes FINAL subroutines. + int Destroy(bool finalize = false); bool IsContiguous(int leadingDimensions = maxRank) const { auto bytes{static_cast(ElementBytes())}; @@ -355,10 +347,6 @@ class alignas(Descriptor) StaticDescriptor { static constexpr std::size_t byteSize{ Descriptor::SizeInBytes(maxRank, hasAddendum, maxLengthTypeParameters)}; - StaticDescriptor() { new (storage_) Descriptor{}; } - - ~StaticDescriptor() { descriptor().~Descriptor(); } - Descriptor &descriptor() { return *reinterpret_cast(storage_); } const Descriptor &descriptor() const { return *reinterpret_cast(storage_); @@ -378,7 +366,7 @@ class alignas(Descriptor) StaticDescriptor { } private: - char storage_[byteSize]; + char storage_[byteSize]{}; }; } // namespace Fortran::runtime #endif // FORTRAN_RUNTIME_DESCRIPTOR_H_ diff --git a/flang/runtime/entry-names.h b/flang/include/flang/Runtime/entry-names.h similarity index 92% rename from flang/runtime/entry-names.h rename to flang/include/flang/Runtime/entry-names.h index 4b669bdf495d9c..c2d68f0c0dc3f1 100644 --- a/flang/runtime/entry-names.h +++ b/flang/include/flang/Runtime/entry-names.h @@ -1,4 +1,4 @@ -/*===-- runtime/entry-names.h ---------------------------------------*- C -*-=== +/*===-- include/flang/Runtime/entry-names.h -------------------------*- C -*-=// * * Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. * See https://llvm.org/LICENSE.txt for license information. diff --git a/flang/runtime/io-api.h b/flang/include/flang/Runtime/io-api.h similarity index 98% rename from flang/runtime/io-api.h rename to flang/include/flang/Runtime/io-api.h index 13254ce6f66e77..564f1d8df78672 100644 --- a/flang/runtime/io-api.h +++ b/flang/include/flang/Runtime/io-api.h @@ -1,4 +1,4 @@ -//===-- runtime/io-api.h ----------------------------------------*- C++ -*-===// +//===-- include/flang/Runtime/io-api.h --------------------------*- C++ -*-===// // // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. // See https://llvm.org/LICENSE.txt for license information. @@ -11,8 +11,8 @@ #ifndef FORTRAN_RUNTIME_IO_API_H_ #define FORTRAN_RUNTIME_IO_API_H_ -#include "entry-names.h" -#include "iostat.h" +#include "flang/Runtime/entry-names.h" +#include "flang/Runtime/iostat.h" #include #include @@ -28,6 +28,9 @@ using Cookie = IoStatementState *; using ExternalUnit = int; using AsynchronousId = int; static constexpr ExternalUnit DefaultUnit{-1}; // READ(*), WRITE(*), PRINT +} // namespace Fortran::runtime::io + +namespace Fortran::runtime::io { // INQUIRE specifiers are encoded as simple base-26 packings of // the spellings of their keywords. @@ -316,4 +319,5 @@ enum Iostat IONAME(EndIoStatement)(Cookie); } // extern "C" } // namespace Fortran::runtime::io + #endif diff --git a/flang/runtime/iostat.h b/flang/include/flang/Runtime/iostat.h similarity index 95% rename from flang/runtime/iostat.h rename to flang/include/flang/Runtime/iostat.h index f51636d5f7d079..ec1c2399819d48 100644 --- a/flang/runtime/iostat.h +++ b/flang/include/flang/Runtime/iostat.h @@ -1,4 +1,4 @@ -//===-- runtime/iostat.h ----------------------------------------*- C++ -*-===// +//===-- include/flang/Runtime/iostat.h --------------------------*- C++ -*-===// // // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. // See https://llvm.org/LICENSE.txt for license information. @@ -11,7 +11,7 @@ #ifndef FORTRAN_RUNTIME_IOSTAT_H_ #define FORTRAN_RUNTIME_IOSTAT_H_ -#include "magic-numbers.h" +#include "flang/Runtime/magic-numbers.h" namespace Fortran::runtime::io { // The value of IOSTAT= is zero when no error, end-of-record, diff --git a/flang/runtime/magic-numbers.h b/flang/include/flang/Runtime/magic-numbers.h similarity index 94% rename from flang/runtime/magic-numbers.h rename to flang/include/flang/Runtime/magic-numbers.h index 388ee8a281a525..4ca8f90caba9dd 100644 --- a/flang/runtime/magic-numbers.h +++ b/flang/include/flang/Runtime/magic-numbers.h @@ -1,10 +1,10 @@ -#if 0 /*===-- runtime/magic-numbers.h -----------------------------------===*/ +#if 0 /*===-- include/flang/Runtime/magic-numbers.h -----------------------===*/ /* * 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 * - *===--------------------------------------------------------------------===*/ + *===----------------------------------------------------------------------===*/ #endif #if 0 This header can be included into both Fortran and C. diff --git a/flang/runtime/main.h b/flang/include/flang/Runtime/main.h similarity index 80% rename from flang/runtime/main.h rename to flang/include/flang/Runtime/main.h index a69eead6bb96c8..50bc46e2e8ee96 100644 --- a/flang/runtime/main.h +++ b/flang/include/flang/Runtime/main.h @@ -1,4 +1,4 @@ -//===-- runtime/main.h ------------------------------------------*- C++ -*-===// +//===-- include/flang/Runtime/main.h ----------------------------*- C++ -*-===// // // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. // See https://llvm.org/LICENSE.txt for license information. @@ -9,8 +9,8 @@ #ifndef FORTRAN_RUNTIME_MAIN_H_ #define FORTRAN_RUNTIME_MAIN_H_ -#include "c-or-cpp.h" -#include "entry-names.h" +#include "flang/Runtime/c-or-cpp.h" +#include "flang/Runtime/entry-names.h" FORTRAN_EXTERN_C_BEGIN void RTNAME(ProgramStart)(int, const char *[], const char *[]); diff --git a/flang/runtime/matmul.h b/flang/include/flang/Runtime/matmul.h similarity index 91% rename from flang/runtime/matmul.h rename to flang/include/flang/Runtime/matmul.h index 8334d6670a1b04..4598c487a12ca1 100644 --- a/flang/runtime/matmul.h +++ b/flang/include/flang/Runtime/matmul.h @@ -1,4 +1,4 @@ -//===-- runtime/matmul.h ----------------------------------------*- C++ -*-===// +//===-- include/flang/Runtime/matmul.h --------------------------*- C++ -*-===// // // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. // See https://llvm.org/LICENSE.txt for license information. @@ -10,7 +10,7 @@ #ifndef FORTRAN_RUNTIME_MATMUL_H_ #define FORTRAN_RUNTIME_MATMUL_H_ -#include "entry-names.h" +#include "flang/Runtime/entry-names.h" namespace Fortran::runtime { class Descriptor; extern "C" { diff --git a/flang/runtime/memory.h b/flang/include/flang/Runtime/memory.h similarity index 97% rename from flang/runtime/memory.h rename to flang/include/flang/Runtime/memory.h index 4b09fe80772ed8..0afe5250169d0b 100644 --- a/flang/runtime/memory.h +++ b/flang/include/flang/Runtime/memory.h @@ -1,4 +1,4 @@ -//===-- runtime/memory.h ----------------------------------------*- C++ -*-===// +//===-- include/flang/Runtime/memory.h --------------------------*- C++ -*-===// // // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. // See https://llvm.org/LICENSE.txt for license information. diff --git a/flang/runtime/misc-intrinsic.h b/flang/include/flang/Runtime/misc-intrinsic.h similarity index 89% rename from flang/runtime/misc-intrinsic.h rename to flang/include/flang/Runtime/misc-intrinsic.h index 16fa355cee2d88..d4c20539532d4b 100644 --- a/flang/runtime/misc-intrinsic.h +++ b/flang/include/flang/Runtime/misc-intrinsic.h @@ -1,4 +1,4 @@ -//===-- runtime/misc-intrinsic.h --------------------------------*- C++ -*-===// +//===-- include/flang/Runtime/misc-intrinsic.h ------------------*- C++ -*-===// // // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. // See https://llvm.org/LICENSE.txt for license information. @@ -11,7 +11,7 @@ #ifndef FORTRAN_RUNTIME_MISC_INTRINSIC_H_ #define FORTRAN_RUNTIME_MISC_INTRINSIC_H_ -#include "entry-names.h" +#include "flang/Runtime/entry-names.h" #include namespace Fortran::runtime { diff --git a/flang/runtime/numeric.h b/flang/include/flang/Runtime/numeric.h similarity index 99% rename from flang/runtime/numeric.h rename to flang/include/flang/Runtime/numeric.h index e18ee3631e1de6..6130a25e401c3c 100644 --- a/flang/runtime/numeric.h +++ b/flang/include/flang/Runtime/numeric.h @@ -1,4 +1,4 @@ -//===-- runtime/numeric.h ---------------------------------------*- C++ -*-===// +//===-- include/flang/Runtime/numeric.h -------------------------*- C++ -*-===// // // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. // See https://llvm.org/LICENSE.txt for license information. @@ -12,8 +12,8 @@ #ifndef FORTRAN_RUNTIME_NUMERIC_H_ #define FORTRAN_RUNTIME_NUMERIC_H_ -#include "cpp-type.h" -#include "entry-names.h" +#include "flang/Runtime/cpp-type.h" +#include "flang/Runtime/entry-names.h" namespace Fortran::runtime { extern "C" { diff --git a/flang/include/flang/Runtime/pointer.h b/flang/include/flang/Runtime/pointer.h new file mode 100644 index 00000000000000..ea3e5b7558dad6 --- /dev/null +++ b/flang/include/flang/Runtime/pointer.h @@ -0,0 +1,112 @@ +//===-- include/flang/Runtime/pointer.h -------------------------*- C++ -*-===// +// +// 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 +// +//===----------------------------------------------------------------------===// + +// Defines APIs for Fortran runtime library support of code generated +// to manipulate and query data pointers. + +#ifndef FORTRAN_RUNTIME_POINTER_H_ +#define FORTRAN_RUNTIME_POINTER_H_ + +#include "flang/Runtime/descriptor.h" +#include "flang/Runtime/entry-names.h" + +namespace Fortran::runtime { +extern "C" { + +// Data pointer initialization for NULLIFY(), "p=>NULL()`, & for ALLOCATE(). + +// Initializes a pointer to a disassociated state for NULLIFY() or "p=>NULL()". +void RTNAME(PointerNullifyIntrinsic)( + Descriptor &, TypeCategory, int kind, int rank = 0, int corank = 0); +void RTNAME(PointerNullifyCharacter)(Descriptor &, SubscriptValue length = 0, + int kind = 1, int rank = 0, int corank = 0); +void RTNAME(PointerNullifyDerived)( + Descriptor &, const typeInfo::DerivedType &, int rank = 0, int corank = 0); + +// Explicitly sets the bounds of an initialized disassociated pointer. +// The upper cobound is ignored for the last codimension. +void RTNAME(PointerSetBounds)( + Descriptor &, int zeroBasedDim, SubscriptValue lower, SubscriptValue upper); +void RTNAME(PointerSetCoBounds)(Descriptor &, int zeroBasedCoDim, + SubscriptValue lower, SubscriptValue upper = 0); + +// Length type parameters are indexed in declaration order; i.e., 0 is the +// first length type parameter in the deepest base type. (Not for use +// with CHARACTER; see above.) +void RTNAME(PointerSetDerivedLength)(Descriptor &, int which, SubscriptValue); + +// For MOLD= allocation: acquires information from another descriptor +// to initialize a null data pointer. +void RTNAME(PointerApplyMold)(Descriptor &, const Descriptor &mold); + +// Data pointer association for "p=>TARGET" + +// Associates a scalar pointer with a simple scalar target. +void RTNAME(PointerAssociateScalar)(Descriptor &, void *); + +// Associates a pointer with a target of the same rank, possibly with new lower +// bounds, which are passed in a vector whose length must equal the rank. +void RTNAME(PointerAssociate)(Descriptor &, const Descriptor &target); +void RTNAME(PointerAssociateLowerBounds)( + Descriptor &, const Descriptor &target, const Descriptor &lowerBounds); + +// Associates a pointer with a target with bounds remapping. The target must be +// simply contiguous &/or of rank 1. The bounds constitute a [2,newRank] +// integer array whose columns are [lower bound, upper bound] on each dimension. +void RTNAME(PointerAssociateRemapping)(Descriptor &, const Descriptor &target, + const Descriptor &bounds, const char *sourceFile = nullptr, + int sourceLine = 0); + +// Data pointer allocation and deallocation + +// When an explicit type-spec appears in an ALLOCATE statement for an +// pointer with an explicit (non-deferred) length type paramater for +// a derived type or CHARACTER value, the explicit value has to match +// the length type parameter's value. This API checks that requirement. +// Returns 0 for success, or the STAT= value on failure with hasStat==true. +int RTNAME(PointerCheckLengthParameter)(Descriptor &, + int which /* 0 for CHARACTER length */, SubscriptValue other, + bool hasStat = false, const Descriptor *errMsg = nullptr, + const char *sourceFile = nullptr, int sourceLine = 0); + +// Allocates a data pointer. Its descriptor must have been initialized +// and its bounds and length type parameters set. It need not be disassociated. +// On failure, if hasStat is true, returns a nonzero error code for +// STAT= and (if present) fills in errMsg; if hasStat is false, the +// image is terminated. On success, leaves errMsg alone and returns zero. +// Successfully allocated memory is initialized if the pointer has a +// derived type, and is always initialized by PointerAllocateSource(). +// Performs all necessary coarray synchronization and validation actions. +int RTNAME(PointerAllocate)(Descriptor &, bool hasStat = false, + const Descriptor *errMsg = nullptr, const char *sourceFile = nullptr, + int sourceLine = 0); +int RTNAME(PointerAllocateSource)(Descriptor &, const Descriptor &source, + bool hasStat = false, const Descriptor *errMsg = nullptr, + const char *sourceFile = nullptr, int sourceLine = 0); + +// Deallocates a data pointer, which must have been allocated by +// PointerAllocate(), possibly copied with PointerAssociate(). +// Finalizes elements &/or components as needed. The pointer is left +// in an initialized disassociated state suitable for reallocation +// with the same bounds, cobounds, and length type parameters. +int RTNAME(PointerDeallocate)(Descriptor &, bool hasStat = false, + const Descriptor *errMsg = nullptr, const char *sourceFile = nullptr, + int sourceLine = 0); + +// Association inquiries for ASSOCIATED() + +// True when the pointer is not disassociated. +bool RTNAME(PointerIsAssociated)(const Descriptor &); + +// True when the pointer is associated with a specific target. +bool RTNAME(PointerIsAssociatedWith)( + const Descriptor &, const Descriptor &target); + +} // extern "C" +} // namespace Fortran::runtime +#endif // FORTRAN_RUNTIME_POINTER_H_ diff --git a/flang/runtime/random.h b/flang/include/flang/Runtime/random.h similarity index 89% rename from flang/runtime/random.h rename to flang/include/flang/Runtime/random.h index 5a8488f8059be6..388a58973b53ff 100644 --- a/flang/runtime/random.h +++ b/flang/include/flang/Runtime/random.h @@ -1,4 +1,4 @@ -//===-- runtime/random.h --------------------------------------------------===// +//===-- include/flang/Runtime/random.h --------------------------*- C++ -*-===// // // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. // See https://llvm.org/LICENSE.txt for license information. @@ -8,7 +8,7 @@ // Intrinsic subroutines RANDOM_INIT, RANDOM_NUMBER, and RANDOM_SEED. -#include "entry-names.h" +#include "flang/Runtime/entry-names.h" #include namespace Fortran::runtime { diff --git a/flang/runtime/reduction.h b/flang/include/flang/Runtime/reduction.h similarity index 89% rename from flang/runtime/reduction.h rename to flang/include/flang/Runtime/reduction.h index 379fcb85cd1c54..d70bb0df10a9a7 100644 --- a/flang/runtime/reduction.h +++ b/flang/include/flang/Runtime/reduction.h @@ -1,4 +1,4 @@ -//===-- runtime/reduction.h -------------------------------------*- C++ -*-===// +//===-- include/flang/Runtime/reduction.h -----------------------*- C++ -*-===// // // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. // See https://llvm.org/LICENSE.txt for license information. @@ -11,9 +11,9 @@ #ifndef FORTRAN_RUNTIME_REDUCTION_H_ #define FORTRAN_RUNTIME_REDUCTION_H_ -#include "descriptor.h" -#include "entry-names.h" #include "flang/Common/uint128.h" +#include "flang/Runtime/descriptor.h" +#include "flang/Runtime/entry-names.h" #include #include @@ -141,7 +141,37 @@ void RTNAME(CppProductComplex16)(std::complex &, void RTNAME(ProductDim)(Descriptor &result, const Descriptor &array, int dim, const char *source, int line, const Descriptor *mask = nullptr); -// IPARITY() +// IALL, IANY, IPARITY +std::int8_t RTNAME(IAll1)(const Descriptor &, const char *source, int line, + int dim = 0, const Descriptor *mask = nullptr); +std::int16_t RTNAME(IAll2)(const Descriptor &, const char *source, int line, + int dim = 0, const Descriptor *mask = nullptr); +std::int32_t RTNAME(IAll4)(const Descriptor &, const char *source, int line, + int dim = 0, const Descriptor *mask = nullptr); +std::int64_t RTNAME(IAll8)(const Descriptor &, const char *source, int line, + int dim = 0, const Descriptor *mask = nullptr); +#ifdef __SIZEOF_INT128__ +common::int128_t RTNAME(IAll16)(const Descriptor &, const char *source, + int line, int dim = 0, const Descriptor *mask = nullptr); +#endif +void RTNAME(IAllDim)(Descriptor &result, const Descriptor &array, int dim, + const char *source, int line, const Descriptor *mask = nullptr); + +std::int8_t RTNAME(IAny1)(const Descriptor &, const char *source, int line, + int dim = 0, const Descriptor *mask = nullptr); +std::int16_t RTNAME(IAny2)(const Descriptor &, const char *source, int line, + int dim = 0, const Descriptor *mask = nullptr); +std::int32_t RTNAME(IAny4)(const Descriptor &, const char *source, int line, + int dim = 0, const Descriptor *mask = nullptr); +std::int64_t RTNAME(IAny8)(const Descriptor &, const char *source, int line, + int dim = 0, const Descriptor *mask = nullptr); +#ifdef __SIZEOF_INT128__ +common::int128_t RTNAME(IAny16)(const Descriptor &, const char *source, + int line, int dim = 0, const Descriptor *mask = nullptr); +#endif +void RTNAME(IAnyDim)(Descriptor &result, const Descriptor &array, int dim, + const char *source, int line, const Descriptor *mask = nullptr); + std::int8_t RTNAME(IParity1)(const Descriptor &, const char *source, int line, int dim = 0, const Descriptor *mask = nullptr); std::int16_t RTNAME(IParity2)(const Descriptor &, const char *source, int line, @@ -214,10 +244,10 @@ std::int16_t RTNAME(MinvalInteger2)(const Descriptor &, const char *source, int line, int dim = 0, const Descriptor *mask = nullptr); std::int32_t RTNAME(MinvalInteger4)(const Descriptor &, const char *source, int line, int dim = 0, const Descriptor *mask = nullptr); -std::int64_t RTNAME(MivalInteger8)(const Descriptor &, const char *source, +std::int64_t RTNAME(MinvalInteger8)(const Descriptor &, const char *source, int line, int dim = 0, const Descriptor *mask = nullptr); #ifdef __SIZEOF_INT128__ -common::int128_t RTNAME(MivalInteger16)(const Descriptor &, const char *source, +common::int128_t RTNAME(MinvalInteger16)(const Descriptor &, const char *source, int line, int dim = 0, const Descriptor *mask = nullptr); #endif float RTNAME(MinvalReal2)(const Descriptor &, const char *source, int line, diff --git a/flang/runtime/stop.h b/flang/include/flang/Runtime/stop.h similarity index 88% rename from flang/runtime/stop.h rename to flang/include/flang/Runtime/stop.h index 638fa179edd3d9..19c7814a646cd5 100644 --- a/flang/runtime/stop.h +++ b/flang/include/flang/Runtime/stop.h @@ -1,4 +1,4 @@ -//===-- runtime/stop.h ------------------------------------------*- C++ -*-===// +//===-- include/flang/Runtime/stop.h ----------------------------*- C++ -*-===// // // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. // See https://llvm.org/LICENSE.txt for license information. @@ -9,8 +9,8 @@ #ifndef FORTRAN_RUNTIME_STOP_H_ #define FORTRAN_RUNTIME_STOP_H_ -#include "c-or-cpp.h" -#include "entry-names.h" +#include "flang/Runtime/c-or-cpp.h" +#include "flang/Runtime/entry-names.h" #include FORTRAN_EXTERN_C_BEGIN diff --git a/flang/include/flang/Runtime/time-intrinsic.h b/flang/include/flang/Runtime/time-intrinsic.h new file mode 100644 index 00000000000000..c48e9614c8fe05 --- /dev/null +++ b/flang/include/flang/Runtime/time-intrinsic.h @@ -0,0 +1,43 @@ +//===-- include/flang/Runtime/time-intrinsic.h ------------------*- C++ -*-===// +// +// 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 +// +//===----------------------------------------------------------------------===// + +// Defines the API between compiled code and the implementations of time-related +// intrinsic subroutines in the runtime library. + +#ifndef FORTRAN_RUNTIME_TIME_INTRINSIC_H_ +#define FORTRAN_RUNTIME_TIME_INTRINSIC_H_ + +#include "flang/Runtime/cpp-type.h" +#include "flang/Runtime/entry-names.h" + +namespace Fortran::runtime { + +class Descriptor; + +extern "C" { + +// Lowering may need to cast this result to match the precision of the default +// real kind. +double RTNAME(CpuTime)(); + +// Interface for the SYSTEM_CLOCK intrinsic. We break it up into 3 distinct +// function calls, one for each of SYSTEM_CLOCK's optional output arguments. +// Lowering will have to cast the results to whatever type it prefers. +CppTypeFor RTNAME(SystemClockCount)(); +CppTypeFor RTNAME(SystemClockCountRate)(); +CppTypeFor RTNAME(SystemClockCountMax)(); + +// Interface for DATE_AND_TIME intrinsic. +void RTNAME(DateAndTime)(char *date, std::size_t dateChars, char *time, + std::size_t timeChars, char *zone, std::size_t zoneChars, + const char *source = nullptr, int line = 0, + const Descriptor *values = nullptr); + +} // extern "C" +} // namespace Fortran::runtime +#endif // FORTRAN_RUNTIME_TIME_INTRINSIC_H_ diff --git a/flang/runtime/transformational.h b/flang/include/flang/Runtime/transformational.h similarity index 91% rename from flang/runtime/transformational.h rename to flang/include/flang/Runtime/transformational.h index 97d5664b16cb50..ad17d48096c948 100644 --- a/flang/runtime/transformational.h +++ b/flang/include/flang/Runtime/transformational.h @@ -1,4 +1,4 @@ -//===-- runtime/transformational.h ------------------------------*- C++ -*-===// +//===-- include/flang/Runtime/transformational.h ----------------*- C++ -*-===// // // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. // See https://llvm.org/LICENSE.txt for license information. @@ -17,20 +17,19 @@ #ifndef FORTRAN_RUNTIME_TRANSFORMATIONAL_H_ #define FORTRAN_RUNTIME_TRANSFORMATIONAL_H_ -#include "descriptor.h" -#include "entry-names.h" -#include "memory.h" +#include "flang/Runtime/descriptor.h" +#include "flang/Runtime/entry-names.h" +#include "flang/Runtime/memory.h" namespace Fortran::runtime { -// TODO: redo API, put under extern "C" -OwningPtr RTNAME(Reshape)(const Descriptor &source, +extern "C" { + +void RTNAME(Reshape)(Descriptor &result, const Descriptor &source, const Descriptor &shape, const Descriptor *pad = nullptr, const Descriptor *order = nullptr, const char *sourceFile = nullptr, int line = 0); -extern "C" { - void RTNAME(Cshift)(Descriptor &result, const Descriptor &source, const Descriptor &shift, int dim = 1, const char *sourceFile = nullptr, int line = 0); diff --git a/flang/runtime/type-code.h b/flang/include/flang/Runtime/type-code.h similarity index 96% rename from flang/runtime/type-code.h rename to flang/include/flang/Runtime/type-code.h index c859edecd40f92..b64167e0b67af1 100644 --- a/flang/runtime/type-code.h +++ b/flang/include/flang/Runtime/type-code.h @@ -1,4 +1,4 @@ -//===-- runtime/type-code.h -------------------------------------*- C++ -*-===// +//===-- include/flang/Runtime/type-code.h -----------------------*- C++ -*-===// // // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. // See https://llvm.org/LICENSE.txt for license information. diff --git a/flang/include/flang/Semantics/expression.h b/flang/include/flang/Semantics/expression.h index 79c35b2d7b93ee..16386cf5c16ff3 100644 --- a/flang/include/flang/Semantics/expression.h +++ b/flang/include/flang/Semantics/expression.h @@ -154,6 +154,7 @@ class ExpressionAnalyzer { MaybeExpr Analyze(const parser::Expr &); MaybeExpr Analyze(const parser::Variable &); + MaybeExpr Analyze(const parser::Selector &); MaybeExpr Analyze(const parser::Designator &); MaybeExpr Analyze(const parser::DataStmtValue &); MaybeExpr Analyze(const parser::AllocateObject &); @@ -295,30 +296,6 @@ class ExpressionAnalyzer { template MaybeExpr Analyze(const std::variant &u) { return std::visit( [&](const auto &x) { - using Ty = std::decay_t; - // Function references might turn out to be misparsed structure - // constructors; we have to try generic procedure resolution - // first to be sure. - if constexpr (common::IsTypeInList) { - std::optional ctor; - MaybeExpr result; - if constexpr (std::is_same_v>) { - result = Analyze(x.value(), &ctor); - } else if constexpr (std::is_same_v) { - result = Analyze(x, &ctor); - } else { - return Analyze(x); - } - if (ctor) { - // A misparsed function reference is really a structure - // constructor. Repair the parse tree in situ. - const_cast &>(u) = std::move(*ctor); - } - return result; - } return Analyze(x); }, u); @@ -413,7 +390,7 @@ void ConformabilityCheck( namespace Fortran::semantics { -// Semantic analysis of one expression, variable, or designator. +// Semantic analysis of one expression, variable, selector, designator, &c. template std::optional> AnalyzeExpr( SemanticsContext &context, const A &expr) { @@ -449,6 +426,10 @@ class ExprChecker { exprAnalyzer_.Analyze(x); return false; } + bool Pre(const parser::Selector &x) { + exprAnalyzer_.Analyze(x); + return false; + } bool Pre(const parser::DataStmtValue &x) { exprAnalyzer_.Analyze(x); return false; diff --git a/flang/include/flang/Semantics/runtime-type-info.h b/flang/include/flang/Semantics/runtime-type-info.h index 71b5cac58eb5b3..7521a93ea71f5b 100644 --- a/flang/include/flang/Semantics/runtime-type-info.h +++ b/flang/include/flang/Semantics/runtime-type-info.h @@ -33,6 +33,5 @@ struct RuntimeDerivedTypeTables { RuntimeDerivedTypeTables BuildRuntimeDerivedTypeTables(SemanticsContext &); -void Dump(llvm::raw_ostream &, const RuntimeDerivedTypeTables &); } // namespace Fortran::semantics #endif // FORTRAN_SEMANTICS_RUNTIME_TYPE_INFO_H_ diff --git a/flang/include/flang/Semantics/scope.h b/flang/include/flang/Semantics/scope.h index f1d5b0c87d48ad..6c6ee5956f4909 100644 --- a/flang/include/flang/Semantics/scope.h +++ b/flang/include/flang/Semantics/scope.h @@ -41,6 +41,8 @@ struct EquivalenceObject { std::optional substringStart, parser::CharBlock source) : symbol{symbol}, subscripts{subscripts}, substringStart{substringStart}, source{source} {} + explicit EquivalenceObject(Symbol &symbol) + : symbol{symbol}, source{symbol.name()} {} bool operator==(const EquivalenceObject &) const; bool operator<(const EquivalenceObject &) const; diff --git a/flang/include/flang/Semantics/semantics.h b/flang/include/flang/Semantics/semantics.h index 3ef0cafa872aaf..c49672ea036677 100644 --- a/flang/include/flang/Semantics/semantics.h +++ b/flang/include/flang/Semantics/semantics.h @@ -207,10 +207,9 @@ class SemanticsContext { class Semantics { public: explicit Semantics(SemanticsContext &context, parser::Program &program, - parser::CharBlock charBlock, bool debugModuleWriter = false) + bool debugModuleWriter = false) : context_{context}, program_{program} { context.set_debugModuleWriter(debugModuleWriter); - context.globalScope().AddSourceRange(charBlock); } SemanticsContext &context() const { return context_; } diff --git a/flang/include/flang/Semantics/symbol.h b/flang/include/flang/Semantics/symbol.h index 309a1558480a0c..9ad4efbb90ef63 100644 --- a/flang/include/flang/Semantics/symbol.h +++ b/flang/include/flang/Semantics/symbol.h @@ -76,6 +76,8 @@ class SubprogramDetails : public WithBindName { bool isFunction() const { return result_ != nullptr; } bool isInterface() const { return isInterface_; } void set_isInterface(bool value = true) { isInterface_ = value; } + bool isDummy() const { return isDummy_; } + void set_isDummy(bool value = true) { isDummy_ = value; } Scope *entryScope() { return entryScope_; } const Scope *entryScope() const { return entryScope_; } void set_entryScope(Scope &scope) { entryScope_ = &scope; } @@ -95,6 +97,7 @@ class SubprogramDetails : public WithBindName { private: bool isInterface_{false}; // true if this represents an interface-body + bool isDummy_{false}; // true when interface of dummy procedure std::vector dummyArgs_; // nullptr -> alternate return indicator Symbol *result_{nullptr}; Scope *entryScope_{nullptr}; // if ENTRY, points to subprogram's scope @@ -259,7 +262,7 @@ class DerivedTypeDetails { void add_paramDecl(const Symbol &symbol) { paramDecls_.push_back(symbol); } void add_component(const Symbol &); void set_sequence(bool x = true) { sequence_ = x; } - void set_isForwardReferenced() { isForwardReferenced_ = true; } + void set_isForwardReferenced(bool value) { isForwardReferenced_ = value; } const std::list &componentNames() const { return componentNames_; } @@ -494,6 +497,7 @@ class Symbol { LocalityShared, // named in SHARED locality-spec InDataStmt, // initialized in a DATA statement InNamelist, // flag is set if the symbol is in Namelist statement + CompilerCreated, // OpenACC data-sharing attribute AccPrivate, AccFirstPrivate, AccShared, // OpenACC data-mapping attribute @@ -508,9 +512,9 @@ class Symbol { OmpCopyIn, OmpCopyPrivate, // OpenMP miscellaneous flags OmpCommonBlock, OmpReduction, OmpAligned, OmpAllocate, - OmpAllocateDirective, OmpDeclareSimd, OmpDeclareTarget, OmpThreadprivate, - OmpDeclareReduction, OmpFlushed, OmpCriticalLock, OmpIfSpecified, OmpNone, - OmpPreDetermined); + OmpDeclarativeAllocateDirective, OmpExecutableAllocateDirective, + OmpDeclareSimd, OmpDeclareTarget, OmpThreadprivate, OmpDeclareReduction, + OmpFlushed, OmpCriticalLock, OmpIfSpecified, OmpNone, OmpPreDetermined); using Flags = common::EnumSet; const Scope &owner() const { return *owner_; } @@ -653,6 +657,9 @@ class Symbol { const DerivedTypeSpec *GetParentTypeSpec(const Scope * = nullptr) const; SemanticsContext &GetSemanticsContext() const; +#if !defined(NDEBUG) || defined(LLVM_ENABLE_DUMP) + LLVM_DUMP_METHOD void dump() const; +#endif private: const Scope *owner_; @@ -776,7 +783,7 @@ struct SymbolAddressCompare { } }; -// Symbol comparison is based on the order of cooked source +// Symbol comparison is usually based on the order of cooked source // stream creation and, when both are from the same cooked source, // their positions in that cooked source stream. // Don't use this comparator or OrderedSymbolSet to hold @@ -788,12 +795,17 @@ struct SymbolSourcePositionCompare { bool operator()(const MutableSymbolRef &, const MutableSymbolRef &) const; }; +struct SymbolOffsetCompare { + bool operator()(const SymbolRef &, const SymbolRef &) const; + bool operator()(const MutableSymbolRef &, const MutableSymbolRef &) const; +}; + using UnorderedSymbolSet = std::set; -using OrderedSymbolSet = std::set; +using SourceOrderedSymbolSet = std::set; template -OrderedSymbolSet OrderBySourcePosition(const A &container) { - OrderedSymbolSet result; +SourceOrderedSymbolSet OrderBySourcePosition(const A &container) { + SourceOrderedSymbolSet result; for (SymbolRef x : container) { result.emplace(x); } diff --git a/flang/include/flang/Semantics/tools.h b/flang/include/flang/Semantics/tools.h index bb7d0b6009ddbe..d969dc914b0377 100644 --- a/flang/include/flang/Semantics/tools.h +++ b/flang/include/flang/Semantics/tools.h @@ -56,6 +56,8 @@ const DeclTypeSpec *FindParentTypeSpec(const DeclTypeSpec &); const DeclTypeSpec *FindParentTypeSpec(const Scope &); const DeclTypeSpec *FindParentTypeSpec(const Symbol &); +const EquivalenceSet *FindEquivalenceSet(const Symbol &); + enum class Tristate { No, Yes, Maybe }; inline Tristate ToTristate(bool x) { return x ? Tristate::Yes : Tristate::No; } @@ -105,14 +107,15 @@ bool IsEventTypeOrLockType(const DerivedTypeSpec *); bool IsOrContainsEventOrLockComponent(const Symbol &); bool CanBeTypeBoundProc(const Symbol *); // Does a non-PARAMETER symbol have explicit initialization with =value or -// =>target in its declaration, or optionally in a DATA statement? (Being +// =>target in its declaration (but not in a DATA statement)? (Being // ALLOCATABLE or having a derived type with default component initialization // doesn't count; it must be a variable initialization that implies the SAVE // attribute, or a derived type component default value.) -bool IsStaticallyInitialized(const Symbol &, bool ignoreDATAstatements = false); +bool HasDeclarationInitializer(const Symbol &); // Is the symbol explicitly or implicitly initialized in any way? -bool IsInitialized(const Symbol &, bool ignoreDATAstatements = false, - const Symbol *derivedType = nullptr); +bool IsInitialized(const Symbol &, bool ignoreDATAstatements = false); +// Is the symbol a component subject to deallocation or finalization? +bool IsDestructible(const Symbol &, const Symbol *derivedType = nullptr); bool HasIntrinsicTypeName(const Symbol &); bool IsSeparateModuleProcedureInterface(const Symbol *); bool IsAutomatic(const Symbol &); @@ -140,6 +143,9 @@ inline bool IsAllocatable(const Symbol &symbol) { inline bool IsAllocatableOrPointer(const Symbol &symbol) { return IsPointer(symbol) || IsAllocatable(symbol); } +inline bool IsSave(const Symbol &symbol) { + return symbol.attrs().test(Attr::SAVE); +} inline bool IsNamedConstant(const Symbol &symbol) { return symbol.attrs().test(Attr::PARAMETER); } @@ -161,8 +167,10 @@ inline bool IsProtected(const Symbol &symbol) { inline bool IsImpliedDoIndex(const Symbol &symbol) { return symbol.owner().kind() == Scope::Kind::ImpliedDos; } -bool IsFinalizable(const Symbol &); -bool IsFinalizable(const DerivedTypeSpec &); +bool IsFinalizable( + const Symbol &, std::set * = nullptr); +bool IsFinalizable( + const DerivedTypeSpec &, std::set * = nullptr); bool HasImpureFinal(const DerivedTypeSpec &); bool IsCoarray(const Symbol &); bool IsInBlankCommon(const Symbol &); @@ -249,6 +257,10 @@ const Symbol *FindExternallyVisibleObject( expr.u); } +// Apply GetUltimate(), then if the symbol is a generic procedure shadowing a +// specific procedure of the same name, return it instead. +const Symbol &BypassGeneric(const Symbol &); + using SomeExpr = evaluate::Expr; bool ExprHasTypeCategory( @@ -319,6 +331,13 @@ enum class ProcedureDefinitionClass { ProcedureDefinitionClass ClassifyProcedure(const Symbol &); +// Returns a list of storage associations due to EQUIVALENCE in a +// scope; each storage association is a list of symbol references +// in ascending order of scope offset. Note that the scope may have +// more EquivalenceSets than this function's result has storage +// associations; these are closures over equivalences. +std::list> GetStorageAssociations(const Scope &); + // Derived type component iterator that provides a C++ LegacyForwardIterator // iterator over the Ordered, Direct, Ultimate or Potential components of a // DerivedTypeSpec. These iterators can be used with STL algorithms diff --git a/flang/include/flang/Semantics/type.h b/flang/include/flang/Semantics/type.h index 764b65941c1212..09ba75fcd9562b 100644 --- a/flang/include/flang/Semantics/type.h +++ b/flang/include/flang/Semantics/type.h @@ -257,6 +257,8 @@ class DerivedTypeSpec { bool MightBeParameterized() const; bool IsForwardReferenced() const; bool HasDefaultInitialization() const; + bool HasDestruction() const; + bool HasFinalization() const; // The "raw" type parameter list is a simple transcription from the // parameter list in the parse tree, built by calling AddRawParamValue(). @@ -286,6 +288,9 @@ class DerivedTypeSpec { bool operator==(const DerivedTypeSpec &that) const { return RawEquals(that) && parameters_ == that.parameters_; } + bool operator!=(const DerivedTypeSpec &that) const { + return !(*this == that); + } std::string AsFortran() const; private: diff --git a/flang/include/flang/Tools/CLOptions.inc b/flang/include/flang/Tools/CLOptions.inc new file mode 100644 index 00000000000000..4a7a847cfa301f --- /dev/null +++ b/flang/include/flang/Tools/CLOptions.inc @@ -0,0 +1,77 @@ +//===-- CLOptions.inc -- command line options -------------------*- C++ -*-===// +// +// 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 +// +//===----------------------------------------------------------------------===// + +// This file defines some shared command-line options that can be used when +// debugging the test tools. This file must be included into the tool. + +#define DisableOption(DOName, DOOption, DODescription) \ + static llvm::cl::opt disable##DOName("disable-" DOOption, \ + llvm::cl::desc("disable " DODescription " pass"), llvm::cl::init(false), \ + llvm::cl::Hidden) + +namespace { +// Optimizer Passes +DisableOption(FirCse, "fir-cse", "CSE for FIR dialect"); + +// CodeGen Passes +#if !defined(FLANG_EXCLUDE_CODEGEN) +DisableOption(CodeGenRewrite, "codegen-rewrite", "rewrite FIR for codegen"); +DisableOption(TargetRewrite, "target-rewrite", "rewrite FIR for target"); +DisableOption(FirToLlvmIr, "fir-to-llvmir", "FIR to LLVM-IR dialect"); +DisableOption(LlvmIrToLlvm, "llvm", "conversion to LLVM"); +#endif + +// Generic for adding a pass to the pass manager if it is not disabled. +template +void addPassConditionally( + mlir::PassManager &pm, llvm::cl::opt &disabled, F ctor) { + if (!disabled) + pm.addPass(ctor()); +} + +template +void addNestedPassConditionally( + mlir::PassManager &pm, llvm::cl::opt &disabled, F ctor) { + if (!disabled) + pm.addNestedPass(ctor()); +} + +} // namespace + +namespace fir { + +inline void addCSE(mlir::PassManager &pm) { + addNestedPassConditionally( + pm, disableFirCse, fir::createCSEPass); +} + +#if !defined(FLANG_EXCLUDE_CODEGEN) +inline void addCodeGenRewritePass(mlir::PassManager &pm) { + addPassConditionally( + pm, disableCodeGenRewrite, fir::createFirCodeGenRewritePass); +} + +inline void addTargetRewritePass(mlir::PassManager &pm) { + addPassConditionally(pm, disableTargetRewrite, []() { + return fir::createFirTargetRewritePass(fir::TargetRewriteOptions{}); + }); +} + +inline void addFIRToLLVMPass(mlir::PassManager &pm) { + addPassConditionally(pm, disableFirToLlvmIr, fir::createFIRToLLVMPass); +} + +inline void addLLVMDialectToLLVMPass( + mlir::PassManager &pm, llvm::raw_ostream &output) { + addPassConditionally(pm, disableLlvmIrToLlvm, + [&]() { return fir::createLLVMDialectToLLVMPass(output); }); +} +#undef FLANG_EXCLUDE_CODEGEN +#endif + +} // namespace fir diff --git a/flang/include/flang/Version.h b/flang/include/flang/Version.h new file mode 100644 index 00000000000000..e1d78eca58d06c --- /dev/null +++ b/flang/include/flang/Version.h @@ -0,0 +1,61 @@ +//===- Version.h - Flang Version Number -------------------------*- C++ -*-===// +// +// 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 +// +//===----------------------------------------------------------------------===// +/// +/// \file +/// Defines version macros and version-related utility functions +/// for Flang. +/// +//===----------------------------------------------------------------------===// + +#ifndef LLVM_FLANG_VERSION_H +#define LLVM_FLANG_VERSION_H + +#include "flang/Version.inc" +#include "llvm/ADT/StringRef.h" + +namespace flang { + /// Retrieves the repository path (e.g., Subversion path) that + /// identifies the particular Flang branch, tag, or trunk from which this + /// Flang was built. + std::string getFlangRepositoryPath(); + + /// Retrieves the repository path from which LLVM was built. + /// + /// This supports LLVM residing in a separate repository from flang. + std::string getLLVMRepositoryPath(); + + /// Retrieves the repository revision number (or identifier) from which + /// this Flang was built. + std::string getFlangRevision(); + + /// Retrieves the repository revision number (or identifier) from which + /// LLVM was built. + /// + /// If Flang and LLVM are in the same repository, this returns the same + /// string as getFlangRevision. + std::string getLLVMRevision(); + + /// Retrieves the full repository version that is an amalgamation of + /// the information in getFlangRepositoryPath() and getFlangRevision(). + std::string getFlangFullRepositoryVersion(); + + /// Retrieves a string representing the complete flang version, + /// which includes the flang version number, the repository version, + /// and the vendor tag. + std::string getFlangFullVersion(); + + /// Like getFlangFullVersion(), but with a custom tool name. + std::string getFlangToolFullVersion(llvm::StringRef ToolName); + + /// Retrieves a string representing the complete flang version suitable + /// for use in the CPP __VERSION__ macro, which includes the flang version + /// number, the repository version, and the vendor tag. + std::string getFlangFullCPPVersion(); +} + +#endif // LLVM_FLANG_VERSION_H diff --git a/flang/lib/CMakeLists.txt b/flang/lib/CMakeLists.txt index 9ebb9f6a72ca53..28602d8fbc1dda 100644 --- a/flang/lib/CMakeLists.txt +++ b/flang/lib/CMakeLists.txt @@ -1,13 +1,18 @@ +if ((CMAKE_CXX_COMPILER_ID MATCHES "Clang")) + if (APPLE) + set(CMAKE_CXX_FLAGS "${CMAKE_CXX_FLAGS} -Wno-string-conversion -Wno-covered-switch-default") + endif() +endif() + add_subdirectory(Common) add_subdirectory(Evaluate) add_subdirectory(Decimal) add_subdirectory(Lower) add_subdirectory(Parser) +add_subdirectory(Optimizer) add_subdirectory(Semantics) if(FLANG_BUILD_NEW_DRIVER) add_subdirectory(Frontend) add_subdirectory(FrontendTool) endif() - -add_subdirectory(Optimizer) diff --git a/flang/lib/Decimal/binary-to-decimal.cpp b/flang/lib/Decimal/binary-to-decimal.cpp index 68ee345b89352d..c9efb3485798d3 100644 --- a/flang/lib/Decimal/binary-to-decimal.cpp +++ b/flang/lib/Decimal/binary-to-decimal.cpp @@ -310,7 +310,6 @@ ConversionToDecimalResult ConvertToDecimal(char *buffer, std::size_t size, more.Next(); } number.Minimize(Big{less, rounding}, Big{more, rounding}); - } else { } return number.ConvertToDecimal(buffer, size, flags, digits); } diff --git a/flang/lib/Evaluate/CMakeLists.txt b/flang/lib/Evaluate/CMakeLists.txt index a2fdc10896b43d..dbf04d62b6076d 100644 --- a/flang/lib/Evaluate/CMakeLists.txt +++ b/flang/lib/Evaluate/CMakeLists.txt @@ -2,8 +2,18 @@ if (LIBPGMATH_DIR) # If pgmath library is found, it can be used for constant folding. find_library(LIBPGMATH pgmath PATHS ${LIBPGMATH_DIR}) if(LIBPGMATH) - add_compile_definitions(LINK_WITH_LIBPGMATH) - message(STATUS "Found libpgmath: ${LIBPGMATH}") + # pgmath uses _Complex, so only enable linking pgmath with flang in environments + # that support it (MSVC is OK, pgmath uses _Fcomplex/_Dcomplex there). + if (CMAKE_CXX_COMPILER_ID MATCHES "Clang|GNU|MSVC") + check_cxx_compiler_flag("-Werror -Wc99-extensions" HAS_WC99_EXTENSIONS_FLAG) + if (HAS_WC99_EXTENSIONS_FLAG) + set(CMAKE_CXX_FLAGS "${CMAKE_CXX_FLAGS} -Wno-c99-extensions") + endif() + add_compile_definitions(LINK_WITH_LIBPGMATH) + message(STATUS "Found libpgmath: ${LIBPGMATH}") + else() + message(STATUS "Libpgmath will not be used because C99 complex is not supported.") + endif() else() message(STATUS "Libpgmath not found in: ${LIBPGMATH_DIR}") endif() @@ -50,5 +60,6 @@ add_flang_library(FortranEvaluate DEPENDS acc_gen omp_gen + acc_gen ) diff --git a/flang/lib/Evaluate/call.cpp b/flang/lib/Evaluate/call.cpp index 395751acabda97..18d51a2b652a53 100644 --- a/flang/lib/Evaluate/call.cpp +++ b/flang/lib/Evaluate/call.cpp @@ -123,6 +123,8 @@ const Symbol *ProcedureDesignator::GetInterfaceSymbol() const { } else if (const auto *binding{ ultimate.detailsIf()}) { return &binding->symbol(); + } else if (ultimate.has()) { + return &ultimate; } } return nullptr; diff --git a/flang/lib/Evaluate/characteristics.cpp b/flang/lib/Evaluate/characteristics.cpp index c6d6afeb81d18b..3fd0025dc83f24 100644 --- a/flang/lib/Evaluate/characteristics.cpp +++ b/flang/lib/Evaluate/characteristics.cpp @@ -71,18 +71,6 @@ std::optional TypeAndShape::Characterize( const auto &ultimate{symbol.GetUltimate()}; return std::visit( common::visitors{ - [&](const semantics::ObjectEntityDetails &object) - -> std::optional { - if (auto type{DynamicType::From(object.type())}) { - TypeAndShape result{ - std::move(*type), GetShape(context, ultimate)}; - result.AcquireAttrs(ultimate); - result.AcquireLEN(ultimate); - return std::move(result.Rewrite(context)); - } else { - return std::nullopt; - } - }, [&](const semantics::ProcEntityDetails &proc) { const semantics::ProcInterface &interface{proc.interface()}; if (interface.type()) { @@ -93,20 +81,29 @@ std::optional TypeAndShape::Characterize( return std::optional{}; } }, - [&](const semantics::TypeParamDetails &tp) { - if (auto type{DynamicType::From(tp.type())}) { - return std::optional{std::move(*type)}; - } else { - return std::optional{}; - } - }, [&](const semantics::AssocEntityDetails &assoc) { return Characterize(assoc, context); }, [&](const semantics::ProcBindingDetails &binding) { return Characterize(binding.symbol(), context); }, - [](const auto &) { return std::optional{}; }, + [&](const auto &x) -> std::optional { + using Ty = std::decay_t; + if constexpr (std::is_same_v || + std::is_same_v || + std::is_same_v) { + if (const semantics::DeclTypeSpec * type{ultimate.GetType()}) { + if (auto dyType{DynamicType::From(*type)}) { + TypeAndShape result{ + std::move(*dyType), GetShape(context, ultimate)}; + result.AcquireAttrs(ultimate); + result.AcquireLEN(ultimate); + return std::move(result.Rewrite(context)); + } + } + } + return std::nullopt; + }, }, // GetUltimate() used here, not ResolveAssociations(), because // we need the type/rank of an associate entity from TYPE IS, @@ -152,8 +149,7 @@ std::optional TypeAndShape::Characterize( bool TypeAndShape::IsCompatibleWith(parser::ContextualMessages &messages, const TypeAndShape &that, const char *thisIs, const char *thatIs, - bool isElemental, bool thisIsDeferredShape, - bool thatIsDeferredShape) const { + bool isElemental, enum CheckConformanceFlags::Flags flags) const { if (!type_.IsTkCompatibleWith(that.type_)) { messages.Say( "%1$s type '%2$s' is not compatible with %3$s type '%4$s'"_err_en_US, @@ -161,9 +157,8 @@ bool TypeAndShape::IsCompatibleWith(parser::ContextualMessages &messages, return false; } return isElemental || - CheckConformance(messages, shape_, that.shape_, thisIs, thatIs, false, - false /* no scalar expansion */, thisIsDeferredShape, - thatIsDeferredShape); + CheckConformance(messages, shape_, that.shape_, flags, thisIs, thatIs) + .value_or(true /*fail only when nonconformance is known now*/); } std::optional> TypeAndShape::MeasureElementSizeInBytes( @@ -216,12 +211,8 @@ void TypeAndShape::AcquireAttrs(const semantics::Symbol &symbol) { } void TypeAndShape::AcquireLEN() { - if (type_.category() == TypeCategory::Character) { - if (const auto *param{type_.charLength()}) { - if (const auto &intExpr{param->GetExplicit()}) { - LEN_ = ConvertToType(common::Clone(*intExpr)); - } - } + if (auto len{type_.GetCharLength()}) { + LEN_ = std::move(len); } } @@ -276,7 +267,8 @@ static common::Intent GetIntent(const semantics::Attrs &attrs) { std::optional DummyDataObject::Characterize( const semantics::Symbol &symbol, FoldingContext &context) { - if (symbol.has()) { + if (symbol.has() || + symbol.has()) { if (auto type{TypeAndShape::Characterize(symbol, context)}) { std::optional result{std::move(*type)}; using semantics::Attr; @@ -367,7 +359,7 @@ static std::optional CharacterizeProcedure( const semantics::Symbol &original, FoldingContext &context, semantics::UnorderedSymbolSet &seenProcs) { Procedure result; - const auto &symbol{original.GetUltimate()}; + const auto &symbol{ResolveAssociations(original)}; if (seenProcs.find(symbol) != seenProcs.end()) { std::string procsList{GetSeenProcs(seenProcs)}; context.messages().Say(symbol.name(), @@ -403,7 +395,11 @@ static std::optional CharacterizeProcedure( } for (const semantics::Symbol *arg : subp.dummyArgs()) { if (!arg) { - result.dummyArguments.emplace_back(AlternateReturn{}); + if (subp.isFunction()) { + return std::nullopt; + } else { + result.dummyArguments.emplace_back(AlternateReturn{}); + } } else if (auto argCharacteristics{CharacterizeDummyArgument( *arg, context, seenProcs)}) { result.dummyArguments.emplace_back( @@ -417,6 +413,11 @@ static std::optional CharacterizeProcedure( [&](const semantics::ProcEntityDetails &proc) -> std::optional { if (symbol.attrs().test(semantics::Attr::INTRINSIC)) { + // Fails when the intrinsic is not a specific intrinsic function + // from F'2018 table 16.2. In order to handle forward references, + // attempts to use impermissible intrinsic procedures as the + // interfaces of procedure pointers are caught and flagged in + // declaration checking in Semantics. return context.intrinsics().IsSpecificIntrinsicFunction( symbol.name().ToString()); } @@ -467,7 +468,23 @@ static std::optional CharacterizeProcedure( [&](const semantics::HostAssocDetails &assoc) { return CharacterizeProcedure(assoc.symbol(), context, seenProcs); }, - [](const auto &) { return std::optional{}; }, + [&](const semantics::EntityDetails &) { + context.messages().Say( + "Procedure '%s' is referenced before being sufficiently defined in a context where it must be so"_err_en_US, + symbol.name()); + return std::optional{}; + }, + [&](const semantics::SubprogramNameDetails &) { + context.messages().Say( + "Procedure '%s' is referenced before being sufficiently defined in a context where it must be so"_err_en_US, + symbol.name()); + return std::optional{}; + }, + [&](const auto &) { + context.messages().Say( + "'%s' is not a procedure"_err_en_US, symbol.name()); + return std::optional{}; + }, }, symbol.details()); } @@ -517,7 +534,8 @@ static std::optional CharacterizeDummyArgument( const semantics::Symbol &symbol, FoldingContext &context, semantics::UnorderedSymbolSet &seenProcs) { auto name{symbol.name().ToString()}; - if (symbol.has()) { + if (symbol.has() || + symbol.has()) { if (auto obj{DummyDataObject::Characterize(symbol, context)}) { return DummyArgument{std::move(name), std::move(obj.value())}; } @@ -611,7 +629,7 @@ common::Intent DummyArgument::GetIntent() const { [](const DummyDataObject &data) { return data.intent; }, [](const DummyProcedure &proc) { return proc.intent; }, [](const AlternateReturn &) -> common::Intent { - DIE("Alternate return have no intent"); + DIE("Alternate returns have no intent"); }, }, u); @@ -689,7 +707,9 @@ bool FunctionResult::CanBeReturnedViaImplicitInterface() const { const DynamicType &type{typeAndShape->type()}; switch (type.category()) { case TypeCategory::Character: - if (const auto *param{type.charLength()}) { + if (type.knownLength()) { + return true; + } else if (const auto *param{type.charLengthParamValue()}) { if (const auto &expr{param->GetExplicit()}) { return IsConstantExpr(*expr); // 15.4.2.2(4)(c) } else if (param->isAssumed()) { @@ -786,7 +806,7 @@ std::optional Procedure::Characterize( const ProcedureDesignator &proc, FoldingContext &context) { if (const auto *symbol{proc.GetSymbol()}) { if (auto result{characteristics::Procedure::Characterize( - symbol->GetUltimate(), context)}) { + ResolveAssociations(*symbol), context)}) { return result; } } else if (const auto *intrinsic{proc.GetSpecificIntrinsic()}) { diff --git a/flang/lib/Evaluate/check-expression.cpp b/flang/lib/Evaluate/check-expression.cpp index 418d1610536573..570aad66364436 100644 --- a/flang/lib/Evaluate/check-expression.cpp +++ b/flang/lib/Evaluate/check-expression.cpp @@ -301,7 +301,9 @@ bool IsInitialProcedureTarget(const semantics::Symbol &symbol) { const auto &ultimate{symbol.GetUltimate()}; return std::visit( common::visitors{ - [](const semantics::SubprogramDetails &) { return true; }, + [](const semantics::SubprogramDetails &subp) { + return !subp.isDummy(); + }, [](const semantics::SubprogramNameDetails &) { return true; }, [&](const semantics::ProcEntityDetails &proc) { return !semantics::IsPointer(ultimate) && !proc.isDummy(); @@ -390,8 +392,9 @@ std::optional> NonPointerInitializationExpr(const Symbol &symbol, .Expand(std::move(folded)); } else if (auto resultShape{GetShape(context, folded)}) { if (CheckConformance(context.messages(), symTS->shape(), - *resultShape, "initialized object", - "initialization expression", false, false)) { + *resultShape, CheckConformanceFlags::None, + "initialized object", "initialization expression") + .value_or(false /*fail if not known now to conform*/)) { // make a constant array with adjusted lower bounds return ArrayConstantBoundChanger{ std::move(*AsConstantExtents( @@ -631,7 +634,7 @@ class IsSimplyContiguousHelper Result operator()(const ArrayRef &x) const { const auto &symbol{x.GetLastSymbol()}; - if (!(*this)(symbol)) { + if (!(*this)(symbol).has_value()) { return false; } else if (auto rank{CheckSubscripts(x.subscript())}) { // a(:)%b(1,1) is not contiguous; a(1)%b(:,:) is @@ -644,7 +647,7 @@ class IsSimplyContiguousHelper return CheckSubscripts(x.subscript()).has_value(); } Result operator()(const Component &x) const { - return x.base().Rank() == 0 && (*this)(x.GetLastSymbol()); + return x.base().Rank() == 0 && (*this)(x.GetLastSymbol()).value_or(false); } Result operator()(const ComplexPart &) const { return false; } Result operator()(const Substring &) const { return false; } diff --git a/flang/lib/Evaluate/expression.cpp b/flang/lib/Evaluate/expression.cpp index 7f8c9eb32f3f23..4322b4e70bc27a 100644 --- a/flang/lib/Evaluate/expression.cpp +++ b/flang/lib/Evaluate/expression.cpp @@ -107,6 +107,9 @@ template int ExpressionBase::Rank() const { derived().u); } +template LLVM_DUMP_METHOD void ExpressionBase::dump() const { + llvm::errs() << "Ev::Expr is <{" << AsFortran() << "}>\n"; +} // Equality testing bool ImpliedDoIndex::operator==(const ImpliedDoIndex &that) const { diff --git a/flang/lib/Evaluate/fold-character.cpp b/flang/lib/Evaluate/fold-character.cpp index 1eac58213f2081..4fc37aa8e2d3dc 100644 --- a/flang/lib/Evaluate/fold-character.cpp +++ b/flang/lib/Evaluate/fold-character.cpp @@ -7,14 +7,49 @@ //===----------------------------------------------------------------------===// #include "fold-implementation.h" +#include "fold-reduction.h" namespace Fortran::evaluate { +static std::optional GetConstantLength( + FoldingContext &context, Expr &&expr) { + expr = Fold(context, std::move(expr)); + if (auto *chExpr{UnwrapExpr>(expr)}) { + if (auto len{chExpr->LEN()}) { + return ToInt64(*len); + } + } + return std::nullopt; +} + +template +static std::optional GetConstantLength( + FoldingContext &context, FunctionRef &funcRef, int zeroBasedArg) { + if (auto *expr{funcRef.UnwrapArgExpr(zeroBasedArg)}) { + return GetConstantLength(context, std::move(*expr)); + } else { + return std::nullopt; + } +} + +template +static std::optional> Identity( + Scalar str, std::optional len) { + if (len) { + return CharacterUtils::REPEAT( + str, std::max(*len, 0)); + } else { + return std::nullopt; + } +} + template Expr> FoldIntrinsicFunction( FoldingContext &context, FunctionRef> &&funcRef) { using T = Type; + using StringType = Scalar; // std::string or larger + using SingleCharType = typename StringType::value_type; // char &c. auto *intrinsic{std::get_if(&funcRef.proc().u)}; CHECK(intrinsic); std::string name{intrinsic->name}; @@ -32,10 +67,25 @@ Expr> FoldIntrinsicFunction( context, std::move(funcRef), CharacterUtils::ADJUSTR); } else if (name == "max") { return FoldMINorMAX(context, std::move(funcRef), Ordering::Greater); + } else if (name == "maxval") { + SingleCharType least{0}; + if (auto identity{Identity( + StringType{least}, GetConstantLength(context, funcRef, 0))}) { + return FoldMaxvalMinval( + context, std::move(funcRef), RelationalOperator::GT, *identity); + } } else if (name == "merge") { return FoldMerge(context, std::move(funcRef)); } else if (name == "min") { return FoldMINorMAX(context, std::move(funcRef), Ordering::Less); + } else if (name == "minval") { + // Collating sequences correspond to positive integers (3.31) + SingleCharType most{0x7fffffff >> (8 * (4 - KIND))}; + if (auto identity{Identity( + StringType{most}, GetConstantLength(context, funcRef, 0))}) { + return FoldMaxvalMinval( + context, std::move(funcRef), RelationalOperator::LT, *identity); + } } else if (name == "new_line") { return Expr{Constant{CharacterUtils::NEW_LINE()}}; } else if (name == "repeat") { // not elemental @@ -52,8 +102,7 @@ Expr> FoldIntrinsicFunction( CharacterUtils::TRIM(std::get>(*scalar))}}; } } - // TODO: cshift, eoshift, maxval, minval, pack, reduce, - // spread, transfer, transpose, unpack + // TODO: findloc, maxloc, minloc, transfer return Expr{std::move(funcRef)}; } diff --git a/flang/lib/Evaluate/fold-complex.cpp b/flang/lib/Evaluate/fold-complex.cpp index de541e1ead573a..d259561739db26 100644 --- a/flang/lib/Evaluate/fold-complex.cpp +++ b/flang/lib/Evaluate/fold-complex.cpp @@ -7,6 +7,7 @@ //===----------------------------------------------------------------------===// #include "fold-implementation.h" +#include "fold-reduction.h" namespace Fortran::evaluate { @@ -15,6 +16,7 @@ Expr> FoldIntrinsicFunction( FoldingContext &context, FunctionRef> &&funcRef) { using T = Type; + using Part = typename T::Part; ActualArguments &args{funcRef.arguments()}; auto *intrinsic{std::get_if(&funcRef.proc().u)}; CHECK(intrinsic); @@ -34,30 +36,31 @@ Expr> FoldIntrinsicFunction( return FoldElementalIntrinsic( context, std::move(funcRef), &Scalar::CONJG); } else if (name == "cmplx") { - using Part = typename T::Part; - if (args.size() == 2) { // CMPLX(X, [KIND]) + if (args.size() > 0 && args[0].has_value()) { if (auto *x{UnwrapExpr>(args[0])}) { + // CMPLX(X [, KIND]) with complex X return Fold(context, ConvertToType(std::move(*x))); + } else { + // CMPLX(X [, Y [, KIND]]) with non-complex X + Expr re{std::move(*args[0].value().UnwrapExpr())}; + Expr im{args.size() >= 2 && args[1].has_value() + ? std::move(*args[1]->UnwrapExpr()) + : AsGenericExpr(Constant{Scalar{}})}; + return Fold(context, + Expr{ + ComplexConstructor{ToReal(context, std::move(re)), + ToReal(context, std::move(im))}}); } - Expr re{std::move(*args[0].value().UnwrapExpr())}; - Expr im{AsGenericExpr(Constant{Scalar{}})}; - return Fold(context, - Expr{ComplexConstructor{ToReal(context, std::move(re)), - ToReal(context, std::move(im))}}); } - // CMPLX(X, [Y, KIND]) - CHECK(args.size() == 3); - Expr re{std::move(*args[0].value().UnwrapExpr())}; - Expr im{args[1] ? std::move(*args[1].value().UnwrapExpr()) - : AsGenericExpr(Constant{Scalar{}})}; - return Fold(context, - Expr{ComplexConstructor{ToReal(context, std::move(re)), - ToReal(context, std::move(im))}}); } else if (name == "merge") { return FoldMerge(context, std::move(funcRef)); + } else if (name == "product") { + auto one{Scalar::FromInteger(value::Integer<8>{1}).value}; + return FoldProduct(context, std::move(funcRef), Scalar{one}); + } else if (name == "sum") { + return FoldSum(context, std::move(funcRef)); } - // TODO: cshift, dot_product, eoshift, matmul, pack, product, - // reduce, spread, sum, transfer, transpose, unpack + // TODO: dot_product, matmul, transfer return Expr{std::move(funcRef)}; } diff --git a/flang/lib/Evaluate/fold-implementation.h b/flang/lib/Evaluate/fold-implementation.h index 94cef9bd4ba99b..f68e2ea0acd4db 100644 --- a/flang/lib/Evaluate/fold-implementation.h +++ b/flang/lib/Evaluate/fold-implementation.h @@ -60,7 +60,13 @@ template class Folder { std::optional> Folding(ArrayRef &); Expr Folding(Designator &&); Constant *Folding(std::optional &); - Expr Reshape(FunctionRef &&); + + Expr CSHIFT(FunctionRef &&); + Expr EOSHIFT(FunctionRef &&); + Expr PACK(FunctionRef &&); + Expr RESHAPE(FunctionRef &&); + Expr TRANSPOSE(FunctionRef &&); + Expr UNPACK(FunctionRef &&); private: FoldingContext &context_; @@ -546,7 +552,259 @@ template Expr MakeInvalidIntrinsic(FunctionRef &&funcRef) { ActualArguments{std::move(funcRef.arguments())}}}; } -template Expr Folder::Reshape(FunctionRef &&funcRef) { +template Expr Folder::CSHIFT(FunctionRef &&funcRef) { + auto args{funcRef.arguments()}; + CHECK(args.size() == 3); + const auto *array{UnwrapConstantValue(args[0])}; + const auto *shiftExpr{UnwrapExpr>(args[1])}; + auto dim{GetInt64ArgOr(args[2], 1)}; + if (!array || !shiftExpr || !dim) { + return Expr{std::move(funcRef)}; + } + auto convertedShift{Fold(context_, + ConvertToType(Expr{*shiftExpr}))}; + const auto *shift{UnwrapConstantValue(convertedShift)}; + if (!shift) { + return Expr{std::move(funcRef)}; + } + // Arguments are constant + if (*dim < 1 || *dim > array->Rank()) { + context_.messages().Say("Invalid 'dim=' argument (%jd) in CSHIFT"_err_en_US, + static_cast(*dim)); + } else if (shift->Rank() > 0 && shift->Rank() != array->Rank() - 1) { + // message already emitted from intrinsic look-up + } else { + int rank{array->Rank()}; + int zbDim{static_cast(*dim) - 1}; + bool ok{true}; + if (shift->Rank() > 0) { + int k{0}; + for (int j{0}; j < rank; ++j) { + if (j != zbDim) { + if (array->shape()[j] != shift->shape()[k]) { + context_.messages().Say( + "Invalid 'shift=' argument in CSHIFT: extent on dimension %d is %jd but must be %jd"_err_en_US, + k + 1, static_cast(shift->shape()[k]), + static_cast(array->shape()[j])); + ok = false; + } + ++k; + } + } + } + if (ok) { + std::vector> resultElements; + ConstantSubscripts arrayAt{array->lbounds()}; + ConstantSubscript dimLB{arrayAt[zbDim]}; + ConstantSubscript dimExtent{array->shape()[zbDim]}; + ConstantSubscripts shiftAt{shift->lbounds()}; + for (auto n{GetSize(array->shape())}; n > 0; n -= dimExtent) { + ConstantSubscript shiftCount{shift->At(shiftAt).ToInt64()}; + ConstantSubscript zbDimIndex{shiftCount % dimExtent}; + if (zbDimIndex < 0) { + zbDimIndex += dimExtent; + } + for (ConstantSubscript j{0}; j < dimExtent; ++j) { + arrayAt[zbDim] = dimLB + zbDimIndex; + resultElements.push_back(array->At(arrayAt)); + if (++zbDimIndex == dimExtent) { + zbDimIndex = 0; + } + } + arrayAt[zbDim] = dimLB + dimExtent - 1; + array->IncrementSubscripts(arrayAt); + shift->IncrementSubscripts(shiftAt); + } + return Expr{PackageConstant( + std::move(resultElements), *array, array->shape())}; + } + } + // Invalid, prevent re-folding + return MakeInvalidIntrinsic(std::move(funcRef)); +} + +template Expr Folder::EOSHIFT(FunctionRef &&funcRef) { + auto args{funcRef.arguments()}; + CHECK(args.size() == 4); + const auto *array{UnwrapConstantValue(args[0])}; + const auto *shiftExpr{UnwrapExpr>(args[1])}; + auto dim{GetInt64ArgOr(args[3], 1)}; + if (!array || !shiftExpr || !dim) { + return Expr{std::move(funcRef)}; + } + // Apply type conversions to the shift= and boundary= arguments. + auto convertedShift{Fold(context_, + ConvertToType(Expr{*shiftExpr}))}; + const auto *shift{UnwrapConstantValue(convertedShift)}; + if (!shift) { + return Expr{std::move(funcRef)}; + } + const Constant *boundary{nullptr}; + std::optional> convertedBoundary; + if (const auto *boundaryExpr{UnwrapExpr>(args[2])}) { + convertedBoundary = Fold(context_, + ConvertToType(array->GetType(), Expr{*boundaryExpr})); + boundary = UnwrapExpr>(convertedBoundary); + if (!boundary) { + return Expr{std::move(funcRef)}; + } + } + // Arguments are constant + if (*dim < 1 || *dim > array->Rank()) { + context_.messages().Say( + "Invalid 'dim=' argument (%jd) in EOSHIFT"_err_en_US, + static_cast(*dim)); + } else if (shift->Rank() > 0 && shift->Rank() != array->Rank() - 1) { + // message already emitted from intrinsic look-up + } else if (boundary && boundary->Rank() > 0 && + boundary->Rank() != array->Rank() - 1) { + // ditto + } else { + int rank{array->Rank()}; + int zbDim{static_cast(*dim) - 1}; + bool ok{true}; + if (shift->Rank() > 0) { + int k{0}; + for (int j{0}; j < rank; ++j) { + if (j != zbDim) { + if (array->shape()[j] != shift->shape()[k]) { + context_.messages().Say( + "Invalid 'shift=' argument in EOSHIFT: extent on dimension %d is %jd but must be %jd"_err_en_US, + k + 1, static_cast(shift->shape()[k]), + static_cast(array->shape()[j])); + ok = false; + } + ++k; + } + } + } + if (boundary && boundary->Rank() > 0) { + int k{0}; + for (int j{0}; j < rank; ++j) { + if (j != zbDim) { + if (array->shape()[j] != boundary->shape()[k]) { + context_.messages().Say( + "Invalid 'boundary=' argument in EOSHIFT: extent on dimension %d is %jd but must be %jd"_err_en_US, + k + 1, static_cast(boundary->shape()[k]), + static_cast(array->shape()[j])); + ok = false; + } + ++k; + } + } + } + if (ok) { + std::vector> resultElements; + ConstantSubscripts arrayAt{array->lbounds()}; + ConstantSubscript dimLB{arrayAt[zbDim]}; + ConstantSubscript dimExtent{array->shape()[zbDim]}; + ConstantSubscripts shiftAt{shift->lbounds()}; + ConstantSubscripts boundaryAt; + if (boundary) { + boundaryAt = boundary->lbounds(); + } + for (auto n{GetSize(array->shape())}; n > 0; n -= dimExtent) { + ConstantSubscript shiftCount{shift->At(shiftAt).ToInt64()}; + for (ConstantSubscript j{0}; j < dimExtent; ++j) { + ConstantSubscript zbAt{shiftCount + j}; + if (zbAt >= 0 && zbAt < dimExtent) { + arrayAt[zbDim] = dimLB + zbAt; + resultElements.push_back(array->At(arrayAt)); + } else if (boundary) { + resultElements.push_back(boundary->At(boundaryAt)); + } else if constexpr (T::category == TypeCategory::Integer || + T::category == TypeCategory::Real || + T::category == TypeCategory::Complex || + T::category == TypeCategory::Logical) { + resultElements.emplace_back(); + } else if constexpr (T::category == TypeCategory::Character) { + auto len{static_cast(array->LEN())}; + typename Scalar::value_type space{' '}; + resultElements.emplace_back(len, space); + } else { + DIE("no derived type boundary"); + } + } + arrayAt[zbDim] = dimLB + dimExtent - 1; + array->IncrementSubscripts(arrayAt); + shift->IncrementSubscripts(shiftAt); + if (boundary) { + boundary->IncrementSubscripts(boundaryAt); + } + } + return Expr{PackageConstant( + std::move(resultElements), *array, array->shape())}; + } + } + // Invalid, prevent re-folding + return MakeInvalidIntrinsic(std::move(funcRef)); +} + +template Expr Folder::PACK(FunctionRef &&funcRef) { + auto args{funcRef.arguments()}; + CHECK(args.size() == 3); + const auto *array{UnwrapConstantValue(args[0])}; + const auto *vector{UnwrapConstantValue(args[2])}; + auto convertedMask{Fold(context_, + ConvertToType( + Expr{DEREF(UnwrapExpr>(args[1]))}))}; + const auto *mask{UnwrapConstantValue(convertedMask)}; + if (!array || !mask || (args[2] && !vector)) { + return Expr{std::move(funcRef)}; + } + // Arguments are constant. + ConstantSubscript arrayElements{GetSize(array->shape())}; + ConstantSubscript truths{0}; + ConstantSubscripts maskAt{mask->lbounds()}; + if (mask->Rank() == 0) { + if (mask->At(maskAt).IsTrue()) { + truths = arrayElements; + } + } else if (array->shape() != mask->shape()) { + // Error already emitted from intrinsic processing + return MakeInvalidIntrinsic(std::move(funcRef)); + } else { + for (ConstantSubscript j{0}; j < arrayElements; + ++j, mask->IncrementSubscripts(maskAt)) { + if (mask->At(maskAt).IsTrue()) { + ++truths; + } + } + } + std::vector> resultElements; + ConstantSubscripts arrayAt{array->lbounds()}; + ConstantSubscript resultSize{truths}; + if (vector) { + resultSize = vector->shape().at(0); + if (resultSize < truths) { + context_.messages().Say( + "Invalid 'vector=' argument in PACK: the 'mask=' argument has %jd true elements, but the vector has only %jd elements"_err_en_US, + static_cast(truths), + static_cast(resultSize)); + return MakeInvalidIntrinsic(std::move(funcRef)); + } + } + for (ConstantSubscript j{0}; j < truths;) { + if (mask->At(maskAt).IsTrue()) { + resultElements.push_back(array->At(arrayAt)); + ++j; + } + array->IncrementSubscripts(arrayAt); + mask->IncrementSubscripts(maskAt); + } + if (vector) { + ConstantSubscripts vectorAt{vector->lbounds()}; + vectorAt.at(0) += truths; + for (ConstantSubscript j{truths}; j < resultSize; ++j) { + resultElements.push_back(vector->At(vectorAt)); + ++vectorAt[0]; + } + } + return Expr{PackageConstant(std::move(resultElements), *array, + ConstantSubscripts{static_cast(resultSize)})}; +} + +template Expr Folder::RESHAPE(FunctionRef &&funcRef) { auto args{funcRef.arguments()}; CHECK(args.size() == 4); const auto *source{UnwrapConstantValue(args[0])}; @@ -597,9 +855,84 @@ template Expr Folder::Reshape(FunctionRef &&funcRef) { return MakeInvalidIntrinsic(std::move(funcRef)); } +template Expr Folder::TRANSPOSE(FunctionRef &&funcRef) { + auto args{funcRef.arguments()}; + CHECK(args.size() == 1); + const auto *matrix{UnwrapConstantValue(args[0])}; + if (!matrix) { + return Expr{std::move(funcRef)}; + } + // Argument is constant. Traverse its elements in transposed order. + std::vector> resultElements; + ConstantSubscripts at(2); + for (ConstantSubscript j{0}; j < matrix->shape()[0]; ++j) { + at[0] = matrix->lbounds()[0] + j; + for (ConstantSubscript k{0}; k < matrix->shape()[1]; ++k) { + at[1] = matrix->lbounds()[1] + k; + resultElements.push_back(matrix->At(at)); + } + } + at = matrix->shape(); + std::swap(at[0], at[1]); + return Expr{PackageConstant(std::move(resultElements), *matrix, at)}; +} + +template Expr Folder::UNPACK(FunctionRef &&funcRef) { + auto args{funcRef.arguments()}; + CHECK(args.size() == 3); + const auto *vector{UnwrapConstantValue(args[0])}; + auto convertedMask{Fold(context_, + ConvertToType( + Expr{DEREF(UnwrapExpr>(args[1]))}))}; + const auto *mask{UnwrapConstantValue(convertedMask)}; + const auto *field{UnwrapConstantValue(args[2])}; + if (!vector || !mask || !field) { + return Expr{std::move(funcRef)}; + } + // Arguments are constant. + if (field->Rank() > 0 && field->shape() != mask->shape()) { + // Error already emitted from intrinsic processing + return MakeInvalidIntrinsic(std::move(funcRef)); + } + ConstantSubscript maskElements{GetSize(mask->shape())}; + ConstantSubscript truths{0}; + ConstantSubscripts maskAt{mask->lbounds()}; + for (ConstantSubscript j{0}; j < maskElements; + ++j, mask->IncrementSubscripts(maskAt)) { + if (mask->At(maskAt).IsTrue()) { + ++truths; + } + } + if (truths > GetSize(vector->shape())) { + context_.messages().Say( + "Invalid 'vector=' argument in UNPACK: the 'mask=' argument has %jd true elements, but the vector has only %jd elements"_err_en_US, + static_cast(truths), + static_cast(GetSize(vector->shape()))); + return MakeInvalidIntrinsic(std::move(funcRef)); + } + std::vector> resultElements; + ConstantSubscripts vectorAt{vector->lbounds()}; + ConstantSubscripts fieldAt{field->lbounds()}; + for (ConstantSubscript j{0}; j < maskElements; ++j) { + if (mask->At(maskAt).IsTrue()) { + resultElements.push_back(vector->At(vectorAt)); + vector->IncrementSubscripts(vectorAt); + } else { + resultElements.push_back(field->At(fieldAt)); + } + mask->IncrementSubscripts(maskAt); + field->IncrementSubscripts(fieldAt); + } + return Expr{ + PackageConstant(std::move(resultElements), *vector, mask->shape())}; +} + template Expr FoldMINorMAX( FoldingContext &context, FunctionRef &&funcRef, Ordering order) { + static_assert(T::category == TypeCategory::Integer || + T::category == TypeCategory::Real || + T::category == TypeCategory::Character); std::vector *> constantArgs; // Call Folding on all arguments, even if some are not constant, // to make operand promotion explicit. @@ -608,8 +941,9 @@ Expr FoldMINorMAX( constantArgs.push_back(cst); } } - if (constantArgs.size() != funcRef.arguments().size()) + if (constantArgs.size() != funcRef.arguments().size()) { return Expr(std::move(funcRef)); + } CHECK(constantArgs.size() > 0); Expr result{std::move(*constantArgs[0])}; for (std::size_t i{1}; i < constantArgs.size(); ++i) { @@ -675,10 +1009,21 @@ Expr FoldOperation(FoldingContext &context, FunctionRef &&funcRef) { } if (auto *intrinsic{std::get_if(&funcRef.proc().u)}) { const std::string name{intrinsic->name}; - if (name == "reshape") { - return Folder{context}.Reshape(std::move(funcRef)); + if (name == "cshift") { + return Folder{context}.CSHIFT(std::move(funcRef)); + } else if (name == "eoshift") { + return Folder{context}.EOSHIFT(std::move(funcRef)); + } else if (name == "pack") { + return Folder{context}.PACK(std::move(funcRef)); + } else if (name == "reshape") { + return Folder{context}.RESHAPE(std::move(funcRef)); + } else if (name == "transpose") { + return Folder{context}.TRANSPOSE(std::move(funcRef)); + } else if (name == "unpack") { + return Folder{context}.UNPACK(std::move(funcRef)); } - // TODO: other type independent transformationals + // TODO: spread + // TODO: extends_type_of, same_type_as if constexpr (!std::is_same_v) { return FoldIntrinsicFunction(context, std::move(funcRef)); } @@ -894,12 +1239,24 @@ Expr MapOperation(FoldingContext &context, context, std::move(result), AsConstantExtents(context, shape)); } +template +ArrayConstructor ArrayConstructorFromMold( + const A &prototype, std::optional> &&length) { + if constexpr (RESULT::category == TypeCategory::Character) { + return ArrayConstructor{ + std::move(length.value()), ArrayConstructorValues{}}; + } else { + return ArrayConstructor{prototype}; + } +} + // array * array case template Expr MapOperation(FoldingContext &context, std::function(Expr &&, Expr &&)> &&f, - const Shape &shape, Expr &&leftValues, Expr &&rightValues) { - ArrayConstructor result{leftValues}; + const Shape &shape, std::optional> &&length, + Expr &&leftValues, Expr &&rightValues) { + auto result{ArrayConstructorFromMold(leftValues, std::move(length))}; auto &leftArrConst{std::get>(leftValues.u)}; if constexpr (common::HasMember) { std::visit( @@ -938,9 +1295,9 @@ Expr MapOperation(FoldingContext &context, template Expr MapOperation(FoldingContext &context, std::function(Expr &&, Expr &&)> &&f, - const Shape &shape, Expr &&leftValues, - const Expr &rightScalar) { - ArrayConstructor result{leftValues}; + const Shape &shape, std::optional> &&length, + Expr &&leftValues, const Expr &rightScalar) { + auto result{ArrayConstructorFromMold(leftValues, std::move(length))}; auto &leftArrConst{std::get>(leftValues.u)}; for (auto &leftValue : leftArrConst) { auto &leftScalar{std::get>(leftValue.u)}; @@ -955,9 +1312,9 @@ Expr MapOperation(FoldingContext &context, template Expr MapOperation(FoldingContext &context, std::function(Expr &&, Expr &&)> &&f, - const Shape &shape, const Expr &leftScalar, - Expr &&rightValues) { - ArrayConstructor result{leftScalar}; + const Shape &shape, std::optional> &&length, + const Expr &leftScalar, Expr &&rightValues) { + auto result{ArrayConstructorFromMold(leftScalar, std::move(length))}; if constexpr (common::HasMember) { std::visit( [&](auto &&kindExpr) { @@ -983,6 +1340,15 @@ Expr MapOperation(FoldingContext &context, context, std::move(result), AsConstantExtents(context, shape)); } +template +std::optional> ComputeResultLength( + Operation &operation) { + if constexpr (RESULT::category == TypeCategory::Character) { + return Expr{operation.derived()}.LEN(); + } + return std::nullopt; +} + // ApplyElementwise() recursively folds the operand expression(s) of an // operation, then attempts to apply the operation to the (corresponding) // scalar element(s) of those operands. Returns std::nullopt for scalars @@ -1020,6 +1386,7 @@ auto ApplyElementwise(FoldingContext &context, Operation &operation, std::function(Expr &&, Expr &&)> &&f) -> std::optional> { + auto resultLength{ComputeResultLength(operation)}; auto &leftExpr{operation.left()}; leftExpr = Fold(context, std::move(leftExpr)); auto &rightExpr{operation.right()}; @@ -1030,28 +1397,30 @@ auto ApplyElementwise(FoldingContext &context, if (rightExpr.Rank() > 0) { if (std::optional rightShape{GetShape(context, rightExpr)}) { if (auto right{AsFlatArrayConstructor(rightExpr)}) { - if (CheckConformance( - context.messages(), *leftShape, *rightShape)) { + if (CheckConformance(context.messages(), *leftShape, *rightShape, + CheckConformanceFlags::EitherScalarExpandable) + .value_or(false /*fail if not known now to conform*/)) { return MapOperation(context, std::move(f), *leftShape, - std::move(*left), std::move(*right)); + std::move(resultLength), std::move(*left), + std::move(*right)); } else { return std::nullopt; } return MapOperation(context, std::move(f), *leftShape, - std::move(*left), std::move(*right)); + std::move(resultLength), std::move(*left), std::move(*right)); } } } else if (IsExpandableScalar(rightExpr)) { - return MapOperation( - context, std::move(f), *leftShape, std::move(*left), rightExpr); + return MapOperation(context, std::move(f), *leftShape, + std::move(resultLength), std::move(*left), rightExpr); } } } } else if (rightExpr.Rank() > 0 && IsExpandableScalar(leftExpr)) { if (std::optional shape{GetShape(context, rightExpr)}) { if (auto right{AsFlatArrayConstructor(rightExpr)}) { - return MapOperation( - context, std::move(f), *shape, leftExpr, std::move(*right)); + return MapOperation(context, std::move(f), *shape, + std::move(resultLength), leftExpr, std::move(*right)); } } } diff --git a/flang/lib/Evaluate/fold-integer.cpp b/flang/lib/Evaluate/fold-integer.cpp index fbbbbf40fa627d..032e0da273d18b 100644 --- a/flang/lib/Evaluate/fold-integer.cpp +++ b/flang/lib/Evaluate/fold-integer.cpp @@ -7,6 +7,7 @@ //===----------------------------------------------------------------------===// #include "fold-implementation.h" +#include "fold-reduction.h" #include "flang/Evaluate/check-expression.h" namespace Fortran::evaluate { @@ -173,6 +174,25 @@ Expr> UBOUND(FoldingContext &context, return Expr{std::move(funcRef)}; } +// for IALL, IANY, & IPARITY +template +static Expr FoldBitReduction(FoldingContext &context, FunctionRef &&ref, + Scalar (Scalar::*operation)(const Scalar &) const, + Scalar identity) { + static_assert(T::category == TypeCategory::Integer); + using Element = Scalar; + std::optional dim; + if (std::optional> array{ + ProcessReductionArgs(context, ref.arguments(), dim, identity, + /*ARRAY=*/0, /*DIM=*/1, /*MASK=*/2)}) { + auto accumulator{[&](Element &element, const ConstantSubscripts &at) { + element = (element.*operation)(array->At(at)); + }}; + return Expr{DoReduction(*array, dim, identity, accumulator)}; + } + return Expr{std::move(ref)}; +} + template Expr> FoldIntrinsicFunction( FoldingContext &context, @@ -310,6 +330,12 @@ Expr> FoldIntrinsicFunction( } return FoldElementalIntrinsic( context, std::move(funcRef), ScalarFunc(fptr)); + } else if (name == "iall") { + return FoldBitReduction( + context, std::move(funcRef), &Scalar::IAND, Scalar{}.NOT()); + } else if (name == "iany") { + return FoldBitReduction( + context, std::move(funcRef), &Scalar::IOR, Scalar{}); } else if (name == "ibclr" || name == "ibset" || name == "ishft" || name == "shifta" || name == "shiftr" || name == "shiftl") { // Second argument can be of any kind. However, it must be smaller or @@ -392,6 +418,9 @@ Expr> FoldIntrinsicFunction( } else { DIE("kind() result not integral"); } + } else if (name == "iparity") { + return FoldBitReduction( + context, std::move(funcRef), &Scalar::IEOR, Scalar{}); } else if (name == "lbound") { return LBOUND(context, std::move(funcRef)); } else if (name == "leadz" || name == "trailz" || name == "poppar" || @@ -474,6 +503,9 @@ Expr> FoldIntrinsicFunction( }, sx->u); } + } else if (name == "maxval") { + return FoldMaxvalMinval(context, std::move(funcRef), + RelationalOperator::GT, T::Scalar::Least()); } else if (name == "merge") { return FoldMerge(context, std::move(funcRef)); } else if (name == "merge_bits") { @@ -492,6 +524,9 @@ Expr> FoldIntrinsicFunction( return FoldMINorMAX(context, std::move(funcRef), Ordering::Less); } else if (name == "min0" || name == "min1") { return RewriteSpecificMINorMAX(context, std::move(funcRef)); + } else if (name == "minval") { + return FoldMaxvalMinval( + context, std::move(funcRef), RelationalOperator::LT, T::Scalar::HUGE()); } else if (name == "mod") { return FoldElementalIntrinsic(context, std::move(funcRef), ScalarFuncWithContext( @@ -516,6 +551,9 @@ Expr> FoldIntrinsicFunction( } return result.value; })); + } else if (name == "not") { + return FoldElementalIntrinsic( + context, std::move(funcRef), &Scalar::NOT); } else if (name == "precision") { if (const auto *cx{UnwrapExpr>(args[0])}) { return Expr{std::visit( @@ -530,6 +568,8 @@ Expr> FoldIntrinsicFunction( }, cx->u)}; } + } else if (name == "product") { + return FoldProduct(context, std::move(funcRef), Scalar{1}); } else if (name == "radix") { return Expr{2}; } else if (name == "range") { @@ -644,15 +684,13 @@ Expr> FoldIntrinsicFunction( Fold(context, Expr{8} * ConvertToType(std::move(*bytes)))}; } } + } else if (name == "sum") { + return FoldSum(context, std::move(funcRef)); } else if (name == "ubound") { return UBOUND(context, std::move(funcRef)); } - // TODO: - // cshift, dot_product, eoshift, - // findloc, iall, iany, iparity, ibits, image_status, ishftc, - // matmul, maxloc, maxval, - // minloc, minval, not, pack, product, reduce, - // sign, spread, sum, transfer, transpose, unpack + // TODO: count(w/ dim), dot_product, findloc, ibits, image_status, ishftc, + // matmul, maxloc, minloc, sign, transfer return Expr{std::move(funcRef)}; } diff --git a/flang/lib/Evaluate/fold-logical.cpp b/flang/lib/Evaluate/fold-logical.cpp index ca6dcdbcafe88e..27a2f0c36b0f03 100644 --- a/flang/lib/Evaluate/fold-logical.cpp +++ b/flang/lib/Evaluate/fold-logical.cpp @@ -7,10 +7,30 @@ //===----------------------------------------------------------------------===// #include "fold-implementation.h" +#include "fold-reduction.h" #include "flang/Evaluate/check-expression.h" namespace Fortran::evaluate { +// for ALL & ANY +template +static Expr FoldAllAny(FoldingContext &context, FunctionRef &&ref, + Scalar (Scalar::*operation)(const Scalar &) const, + Scalar identity) { + static_assert(T::category == TypeCategory::Logical); + using Element = Scalar; + std::optional dim; + if (std::optional> array{ + ProcessReductionArgs(context, ref.arguments(), dim, identity, + /*ARRAY(MASK)=*/0, /*DIM=*/1)}) { + auto accumulator{[&](Element &element, const ConstantSubscripts &at) { + element = (element.*operation)(array->At(at)); + }}; + return Expr{DoReduction(*array, dim, identity, accumulator)}; + } + return Expr{std::move(ref)}; +} + template Expr> FoldIntrinsicFunction( FoldingContext &context, @@ -21,31 +41,11 @@ Expr> FoldIntrinsicFunction( CHECK(intrinsic); std::string name{intrinsic->name}; if (name == "all") { - if (!args[1]) { // TODO: ALL(x,DIM=d) - if (const auto *constant{UnwrapConstantValue(args[0])}) { - bool result{true}; - for (const auto &element : constant->values()) { - if (!element.IsTrue()) { - result = false; - break; - } - } - return Expr{result}; - } - } + return FoldAllAny( + context, std::move(funcRef), &Scalar::AND, Scalar{true}); } else if (name == "any") { - if (!args[1]) { // TODO: ANY(x,DIM=d) - if (const auto *constant{UnwrapConstantValue(args[0])}) { - bool result{false}; - for (const auto &element : constant->values()) { - if (element.IsTrue()) { - result = true; - break; - } - } - return Expr{result}; - } - } + return FoldAllAny( + context, std::move(funcRef), &Scalar::OR, Scalar{false}); } else if (name == "associated") { bool gotConstant{true}; const Expr *firstArgExpr{args[0]->UnwrapExpr()}; @@ -125,10 +125,9 @@ Expr> FoldIntrinsicFunction( name == "__builtin_ieee_support_underflow_control") { return Expr{true}; } - // TODO: btest, cshift, dot_product, eoshift, is_iostat_end, + // TODO: btest, dot_product, is_iostat_end, // is_iostat_eor, lge, lgt, lle, llt, logical, matmul, out_of_range, - // pack, parity, reduce, spread, transfer, transpose, unpack, - // extends_type_of, same_type_as + // parity, transfer return Expr{std::move(funcRef)}; } diff --git a/flang/lib/Evaluate/fold-real.cpp b/flang/lib/Evaluate/fold-real.cpp index d1c75e46178ebc..0ee465536a2a64 100644 --- a/flang/lib/Evaluate/fold-real.cpp +++ b/flang/lib/Evaluate/fold-real.cpp @@ -7,6 +7,7 @@ //===----------------------------------------------------------------------===// #include "fold-implementation.h" +#include "fold-reduction.h" namespace Fortran::evaluate { @@ -109,10 +110,19 @@ Expr> FoldIntrinsicFunction( return Expr{Scalar::HUGE()}; } else if (name == "max") { return FoldMINorMAX(context, std::move(funcRef), Ordering::Greater); + } else if (name == "maxval") { + return FoldMaxvalMinval(context, std::move(funcRef), + RelationalOperator::GT, T::Scalar::HUGE().Negate()); } else if (name == "merge") { return FoldMerge(context, std::move(funcRef)); } else if (name == "min") { return FoldMINorMAX(context, std::move(funcRef), Ordering::Less); + } else if (name == "minval") { + return FoldMaxvalMinval( + context, std::move(funcRef), RelationalOperator::LT, T::Scalar::HUGE()); + } else if (name == "product") { + auto one{Scalar::FromInteger(value::Integer<8>{1}).value}; + return FoldProduct(context, std::move(funcRef), one); } else if (name == "real") { if (auto *expr{args[0].value().UnwrapExpr()}) { return ToReal(context, std::move(*expr)); @@ -120,14 +130,15 @@ Expr> FoldIntrinsicFunction( } else if (name == "sign") { return FoldElementalIntrinsic( context, std::move(funcRef), &Scalar::SIGN); + } else if (name == "sum") { + return FoldSum(context, std::move(funcRef)); } else if (name == "tiny") { return Expr{Scalar::TINY()}; } - // TODO: cshift, dim, dot_product, eoshift, fraction, matmul, - // maxval, minval, modulo, nearest, norm2, pack, product, - // reduce, rrspacing, scale, set_exponent, spacing, spread, - // sum, transfer, transpose, unpack, bessel_jn (transformational) and - // bessel_yn (transformational) + // TODO: dim, dot_product, fraction, matmul, + // maxloc, minloc, modulo, nearest, norm2, rrspacing, scale, + // set_exponent, spacing, transfer, + // bessel_jn (transformational) and bessel_yn (transformational) return Expr{std::move(funcRef)}; } diff --git a/flang/lib/Evaluate/fold-reduction.h b/flang/lib/Evaluate/fold-reduction.h new file mode 100644 index 00000000000000..4b265ecf4716a8 --- /dev/null +++ b/flang/lib/Evaluate/fold-reduction.h @@ -0,0 +1,236 @@ +//===-- lib/Evaluate/fold-reduction.h -------------------------------------===// +// +// 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 +// +//===----------------------------------------------------------------------===// + +// TODO: ALL, ANY, COUNT, DOT_PRODUCT, FINDLOC, IALL, IANY, IPARITY, +// NORM2, MAXLOC, MINLOC, PARITY, PRODUCT, SUM + +#ifndef FORTRAN_EVALUATE_FOLD_REDUCTION_H_ +#define FORTRAN_EVALUATE_FOLD_REDUCTION_H_ + +#include "fold-implementation.h" + +namespace Fortran::evaluate { + +// Common preprocessing for reduction transformational intrinsic function +// folding. If the intrinsic can have DIM= &/or MASK= arguments, extract +// and check them. If a MASK= is present, apply it to the array data and +// substitute identity values for elements corresponding to .FALSE. in +// the mask. If the result is present, the intrinsic call can be folded. +template +static std::optional> ProcessReductionArgs(FoldingContext &context, + ActualArguments &arg, std::optional &dim, + const Scalar &identity, int arrayIndex, + std::optional dimIndex = std::nullopt, + std::optional maskIndex = std::nullopt) { + if (arg.empty()) { + return std::nullopt; + } + Constant *folded{Folder{context}.Folding(arg[arrayIndex])}; + if (!folded || folded->Rank() < 1) { + return std::nullopt; + } + if (dimIndex && arg.size() >= *dimIndex + 1 && arg[*dimIndex]) { + if (auto *dimConst{ + Folder{context}.Folding(arg[*dimIndex])}) { + if (auto dimScalar{dimConst->GetScalarValue()}) { + dim.emplace(dimScalar->ToInt64()); + if (*dim < 1 || *dim > folded->Rank()) { + context.messages().Say( + "DIM=%jd is not valid for an array of rank %d"_err_en_US, + static_cast(*dim), folded->Rank()); + dim.reset(); + } + } + } + if (!dim) { + return std::nullopt; + } + } + if (maskIndex && arg.size() >= *maskIndex + 1 && arg[*maskIndex]) { + if (Constant * + mask{Folder{context}.Folding(arg[*maskIndex])}) { + if (CheckConformance(context.messages(), AsShape(folded->shape()), + AsShape(mask->shape()), + CheckConformanceFlags::RightScalarExpandable, "ARRAY=", "MASK=") + .value_or(false)) { + // Apply the mask in place to the array + std::size_t n{folded->size()}; + std::vector::Element> elements; + if (auto scalarMask{mask->GetScalarValue()}) { + if (scalarMask->IsTrue()) { + return Constant{*folded}; + } else { // MASK=.FALSE. + elements = std::vector::Element>(n, identity); + } + } else { // mask is an array; test its elements + elements = std::vector::Element>(n, identity); + ConstantSubscripts at{folded->lbounds()}; + for (std::size_t j{0}; j < n; ++j, folded->IncrementSubscripts(at)) { + if (mask->values()[j].IsTrue()) { + elements[j] = folded->At(at); + } + } + } + if constexpr (T::category == TypeCategory::Character) { + return Constant{static_cast(identity.size()), + std::move(elements), ConstantSubscripts{folded->shape()}}; + } else { + return Constant{ + std::move(elements), ConstantSubscripts{folded->shape()}}; + } + } else { + return std::nullopt; + } + } else { + return std::nullopt; + } + } else { + return Constant{*folded}; + } +} + +// Generalized reduction to an array of one dimension fewer (w/ DIM=) +// or to a scalar (w/o DIM=). +template +static Constant DoReduction(const Constant &array, + std::optional &dim, const Scalar &identity, + ACCUMULATOR &accumulator) { + ConstantSubscripts at{array.lbounds()}; + std::vector::Element> elements; + ConstantSubscripts resultShape; // empty -> scalar + if (dim) { // DIM= is present, so result is an array + resultShape = array.shape(); + resultShape.erase(resultShape.begin() + (*dim - 1)); + ConstantSubscript dimExtent{array.shape().at(*dim - 1)}; + ConstantSubscript &dimAt{at[*dim - 1]}; + ConstantSubscript dimLbound{dimAt}; + for (auto n{GetSize(resultShape)}; n-- > 0; + IncrementSubscripts(at, array.shape())) { + dimAt = dimLbound; + elements.push_back(identity); + for (ConstantSubscript j{0}; j < dimExtent; ++j, ++dimAt) { + accumulator(elements.back(), at); + } + } + } else { // no DIM=, result is scalar + elements.push_back(identity); + for (auto n{array.size()}; n-- > 0; + IncrementSubscripts(at, array.shape())) { + accumulator(elements.back(), at); + } + } + if constexpr (T::category == TypeCategory::Character) { + return {static_cast(identity.size()), + std::move(elements), std::move(resultShape)}; + } else { + return {std::move(elements), std::move(resultShape)}; + } +} + +// MAXVAL & MINVAL +template +static Expr FoldMaxvalMinval(FoldingContext &context, FunctionRef &&ref, + RelationalOperator opr, const Scalar &identity) { + static_assert(T::category == TypeCategory::Integer || + T::category == TypeCategory::Real || + T::category == TypeCategory::Character); + using Element = Scalar; + std::optional dim; + if (std::optional> array{ + ProcessReductionArgs(context, ref.arguments(), dim, identity, + /*ARRAY=*/0, /*DIM=*/1, /*MASK=*/2)}) { + auto accumulator{[&](Element &element, const ConstantSubscripts &at) { + Expr test{PackageRelation(opr, + Expr{Constant{array->At(at)}}, Expr{Constant{element}})}; + auto folded{GetScalarConstantValue( + test.Rewrite(context, std::move(test)))}; + CHECK(folded.has_value()); + if (folded->IsTrue()) { + element = array->At(at); + } + }}; + return Expr{DoReduction(*array, dim, identity, accumulator)}; + } + return Expr{std::move(ref)}; +} + +// PRODUCT +template +static Expr FoldProduct( + FoldingContext &context, FunctionRef &&ref, Scalar identity) { + static_assert(T::category == TypeCategory::Integer || + T::category == TypeCategory::Real || + T::category == TypeCategory::Complex); + using Element = typename Constant::Element; + std::optional dim; + if (std::optional> array{ + ProcessReductionArgs(context, ref.arguments(), dim, identity, + /*ARRAY=*/0, /*DIM=*/1, /*MASK=*/2)}) { + bool overflow{false}; + auto accumulator{[&](Element &element, const ConstantSubscripts &at) { + if constexpr (T::category == TypeCategory::Integer) { + auto prod{element.MultiplySigned(array->At(at))}; + overflow |= prod.SignedMultiplicationOverflowed(); + element = prod.lower; + } else { // Real & Complex + auto prod{element.Multiply(array->At(at))}; + overflow |= prod.flags.test(RealFlag::Overflow); + element = prod.value; + } + }}; + if (overflow) { + context.messages().Say( + "PRODUCT() of %s data overflowed"_en_US, T::AsFortran()); + } else { + return Expr{DoReduction(*array, dim, identity, accumulator)}; + } + } + return Expr{std::move(ref)}; +} + +// SUM +template +static Expr FoldSum(FoldingContext &context, FunctionRef &&ref) { + static_assert(T::category == TypeCategory::Integer || + T::category == TypeCategory::Real || + T::category == TypeCategory::Complex); + using Element = typename Constant::Element; + std::optional dim; + Element identity{}, correction{}; + if (std::optional> array{ + ProcessReductionArgs(context, ref.arguments(), dim, identity, + /*ARRAY=*/0, /*DIM=*/1, /*MASK=*/2)}) { + bool overflow{false}; + auto accumulator{[&](Element &element, const ConstantSubscripts &at) { + if constexpr (T::category == TypeCategory::Integer) { + auto sum{element.AddSigned(array->At(at))}; + overflow |= sum.overflow; + element = sum.value; + } else { // Real & Complex: use Kahan summation + auto next{array->At(at).Add(correction)}; + overflow |= next.flags.test(RealFlag::Overflow); + auto sum{element.Add(next.value)}; + overflow |= sum.flags.test(RealFlag::Overflow); + // correction = (sum - element) - next; algebraically zero + correction = + sum.value.Subtract(element).value.Subtract(next.value).value; + element = sum.value; + } + }}; + if (overflow) { + context.messages().Say( + "SUM() of %s data overflowed"_en_US, T::AsFortran()); + } else { + return Expr{DoReduction(*array, dim, identity, accumulator)}; + } + } + return Expr{std::move(ref)}; +} + +} // namespace Fortran::evaluate +#endif // FORTRAN_EVALUATE_FOLD_REDUCTION_H_ diff --git a/flang/lib/Evaluate/formatting.cpp b/flang/lib/Evaluate/formatting.cpp index f7cfaa3e6dff3a..5b5ae258d8b0bd 100644 --- a/flang/lib/Evaluate/formatting.cpp +++ b/flang/lib/Evaluate/formatting.cpp @@ -475,13 +475,15 @@ std::string DynamicType::AsFortran() const { if (derived_) { CHECK(category_ == TypeCategory::Derived); return DerivedTypeSpecAsFortran(*derived_); - } else if (charLength_) { + } else if (charLengthParamValue_ || knownLength()) { std::string result{"CHARACTER(KIND="s + std::to_string(kind_) + ",LEN="}; - if (charLength_->isAssumed()) { + if (knownLength()) { + result += std::to_string(*knownLength()) + "_8"; + } else if (charLengthParamValue_->isAssumed()) { result += '*'; - } else if (charLength_->isDeferred()) { + } else if (charLengthParamValue_->isDeferred()) { result += ':'; - } else if (const auto &length{charLength_->GetExplicit()}) { + } else if (const auto &length{charLengthParamValue_->GetExplicit()}) { result += length->AsFortran(); } return result + ')'; diff --git a/flang/lib/Evaluate/initial-image.cpp b/flang/lib/Evaluate/initial-image.cpp index 35be2238af1ad8..6abca5704fbb64 100644 --- a/flang/lib/Evaluate/initial-image.cpp +++ b/flang/lib/Evaluate/initial-image.cpp @@ -54,11 +54,14 @@ void InitialImage::AddPointer( pointers_.emplace(offset, pointer); } -void InitialImage::Incorporate( - ConstantSubscript offset, const InitialImage &that) { - CHECK(that.pointers_.empty()); // pointers are not allowed in EQUIVALENCE - CHECK(offset + that.size() <= size()); - std::memcpy(&data_[offset], &that.data_[0], that.size()); +void InitialImage::Incorporate(ConstantSubscript toOffset, + const InitialImage &from, ConstantSubscript fromOffset, + ConstantSubscript bytes) { + CHECK(from.pointers_.empty()); // pointers are not allowed in EQUIVALENCE + CHECK(fromOffset >= 0 && bytes >= 0 && + static_cast(fromOffset + bytes) <= from.size()); + CHECK(static_cast(toOffset + bytes) <= size()); + std::memcpy(&data_[toOffset], &from.data_[fromOffset], bytes); } // Classes used with common::SearchTypes() to (re)construct Constant<> values @@ -97,26 +100,31 @@ class AsConstantHelper { const semantics::DerivedTypeSpec &derived{type_.GetDerivedTypeSpec()}; for (auto iter : DEREF(derived.scope())) { const Symbol &component{*iter.second}; - bool isPointer{IsPointer(component)}; - if (component.has() || - component.has()) { - auto componentType{DynamicType::From(component)}; - CHECK(componentType); + bool isProcPtr{IsProcedurePointer(component)}; + if (isProcPtr || component.has()) { auto at{offset_ + component.offset()}; - if (isPointer) { + if (isProcPtr) { for (std::size_t j{0}; j < elements; ++j, at += stride) { - Result value{image_.AsConstantDataPointer(*componentType, at)}; - CHECK(value); - typedValue[j].emplace(component, std::move(*value)); + if (Result value{image_.AsConstantPointer(at)}) { + typedValue[j].emplace(component, std::move(*value)); + } + } + } else if (IsPointer(component)) { + for (std::size_t j{0}; j < elements; ++j, at += stride) { + if (Result value{image_.AsConstantPointer(at)}) { + typedValue[j].emplace(component, std::move(*value)); + } } } else { + auto componentType{DynamicType::From(component)}; + CHECK(componentType.has_value()); auto componentExtents{GetConstantExtents(context_, component)}; - CHECK(componentExtents); + CHECK(componentExtents.has_value()); for (std::size_t j{0}; j < elements; ++j, at += stride) { - Result value{image_.AsConstant( - context_, *componentType, *componentExtents, at)}; - CHECK(value); - typedValue[j].emplace(component, std::move(*value)); + if (Result value{image_.AsConstant( + context_, *componentType, *componentExtents, at)}) { + typedValue[j].emplace(component, std::move(*value)); + } } } } @@ -159,45 +167,11 @@ std::optional> InitialImage::AsConstant(FoldingContext &context, AsConstantHelper{context, type, extents, *this, offset}); } -class AsConstantDataPointerHelper { -public: - using Result = std::optional>; - using Types = AllTypes; - AsConstantDataPointerHelper(const DynamicType &type, - const InitialImage &image, ConstantSubscript offset = 0) - : type_{type}, image_{image}, offset_{offset} {} - template Result Test() { - if (T::category != type_.category()) { - return std::nullopt; - } - if constexpr (T::category != TypeCategory::Derived) { - if (T::kind != type_.kind()) { - return std::nullopt; - } - } - auto iter{image_.pointers_.find(offset_)}; - if (iter == image_.pointers_.end()) { - return AsGenericExpr(NullPointer{}); - } - return iter->second; - } - -private: - const DynamicType &type_; - const InitialImage &image_; - ConstantSubscript offset_; -}; - -std::optional> InitialImage::AsConstantDataPointer( - const DynamicType &type, ConstantSubscript offset) const { - return common::SearchTypes(AsConstantDataPointerHelper{type, *this, offset}); -} - -const ProcedureDesignator &InitialImage::AsConstantProcPointer( +std::optional> InitialImage::AsConstantPointer( ConstantSubscript offset) const { - auto iter{pointers_.find(0)}; - CHECK(iter != pointers_.end()); - return DEREF(std::get_if(&iter->second.u)); + auto iter{pointers_.find(offset)}; + return iter == pointers_.end() ? std::optional>{} + : iter->second; } } // namespace Fortran::evaluate diff --git a/flang/lib/Evaluate/intrinsics-library.cpp b/flang/lib/Evaluate/intrinsics-library.cpp index 1023590fd18ebe..2aef9f701f0f7a 100644 --- a/flang/lib/Evaluate/intrinsics-library.cpp +++ b/flang/lib/Evaluate/intrinsics-library.cpp @@ -287,7 +287,7 @@ struct HostRuntimeLibrary, LibraryVersion::Libm> { // First declare all libpgmaths functions #define PGMATH_LINKING #define PGMATH_DECLARE -#include "../runtime/pgmath.h.inc" +#include "flang/Evaluate/pgmath.h.inc" #define REAL_FOLDER(name, func) \ FolderFactory::Create(#name) @@ -295,7 +295,7 @@ template <> struct HostRuntimeLibrary { static constexpr HostRuntimeFunction table[]{ #define PGMATH_FAST #define PGMATH_USE_S(name, func) REAL_FOLDER(name, func), -#include "../runtime/pgmath.h.inc" +#include "flang/Evaluate/pgmath.h.inc" }; static constexpr HostRuntimeMap map{table}; static_assert(map.Verify(), "map must be sorted"); @@ -304,7 +304,7 @@ template <> struct HostRuntimeLibrary { static constexpr HostRuntimeFunction table[]{ #define PGMATH_FAST #define PGMATH_USE_D(name, func) REAL_FOLDER(name, func), -#include "../runtime/pgmath.h.inc" +#include "flang/Evaluate/pgmath.h.inc" }; static constexpr HostRuntimeMap map{table}; static_assert(map.Verify(), "map must be sorted"); @@ -313,7 +313,7 @@ template <> struct HostRuntimeLibrary { static constexpr HostRuntimeFunction table[]{ #define PGMATH_RELAXED #define PGMATH_USE_S(name, func) REAL_FOLDER(name, func), -#include "../runtime/pgmath.h.inc" +#include "flang/Evaluate/pgmath.h.inc" }; static constexpr HostRuntimeMap map{table}; static_assert(map.Verify(), "map must be sorted"); @@ -322,7 +322,7 @@ template <> struct HostRuntimeLibrary { static constexpr HostRuntimeFunction table[]{ #define PGMATH_RELAXED #define PGMATH_USE_D(name, func) REAL_FOLDER(name, func), -#include "../runtime/pgmath.h.inc" +#include "flang/Evaluate/pgmath.h.inc" }; static constexpr HostRuntimeMap map{table}; static_assert(map.Verify(), "map must be sorted"); @@ -331,7 +331,7 @@ template <> struct HostRuntimeLibrary { static constexpr HostRuntimeFunction table[]{ #define PGMATH_PRECISE #define PGMATH_USE_S(name, func) REAL_FOLDER(name, func), -#include "../runtime/pgmath.h.inc" +#include "flang/Evaluate/pgmath.h.inc" }; static constexpr HostRuntimeMap map{table}; static_assert(map.Verify(), "map must be sorted"); @@ -340,7 +340,7 @@ template <> struct HostRuntimeLibrary { static constexpr HostRuntimeFunction table[]{ #define PGMATH_PRECISE #define PGMATH_USE_D(name, func) REAL_FOLDER(name, func), -#include "../runtime/pgmath.h.inc" +#include "flang/Evaluate/pgmath.h.inc" }; static constexpr HostRuntimeMap map{table}; static_assert(map.Verify(), "map must be sorted"); diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp index a068241a21bbd7..15421a205d3d78 100644 --- a/flang/lib/Evaluate/intrinsics.cpp +++ b/flang/lib/Evaluate/intrinsics.cpp @@ -385,15 +385,17 @@ static const IntrinsicInterface genericIntrinsicFunction[]{ {"eoshift", {{"array", SameIntrinsic, Rank::array}, {"shift", AnyInt, Rank::dimRemovedOrScalar}, - {"boundary", SameIntrinsic, Rank::dimReduced, + {"boundary", SameIntrinsic, Rank::dimRemovedOrScalar, Optionality::optional}, OptionalDIM}, SameIntrinsic, Rank::conformable, IntrinsicClass::transformationalFunction}, {"eoshift", {{"array", SameDerivedType, Rank::array}, - {"shift", AnyInt, Rank::dimReduced}, - {"boundary", SameDerivedType, Rank::dimReduced}, OptionalDIM}, + {"shift", AnyInt, Rank::dimRemovedOrScalar}, + // BOUNDARY= is not optional for derived types + {"boundary", SameDerivedType, Rank::dimRemovedOrScalar}, + OptionalDIM}, SameDerivedType, Rank::conformable, IntrinsicClass::transformationalFunction}, {"epsilon", {{"x", SameReal, Rank::anyOrAssumedRank}}, SameReal, @@ -817,7 +819,7 @@ static const IntrinsicInterface genericIntrinsicFunction[]{ // TODO: Non-standard intrinsic functions // AND, OR, XOR, LSHIFT, RSHIFT, SHIFT, ZEXT, IZEXT, // COMPL, EQV, NEQV, INT8, JINT, JNINT, KNINT, -// QCMPLX, DFLOAT, QEXT, QFLOAT, QREAL, DNUM, +// QCMPLX, QEXT, QFLOAT, QREAL, DNUM, // INUM, JNUM, KNUM, QNUM, RNUM, RAN, RANF, ILEN, // MCLOCK, SECNDS, COTAN, IBCHNG, ISHA, ISHC, ISHL, IXOR // IARG, IARGC, NARGS, NUMARG, BADDRESS, IADDR, CACHESIZE, @@ -924,6 +926,7 @@ static const SpecificIntrinsicInterface specificIntrinsicFunction[]{ {"y", AnyIntOrReal, Rank::elementalOrBOZ, Optionality::optional}}, DoublePrecisionComplex}, "cmplx", true}, + {{"dfloat", {{"i", AnyInt}}, DoublePrecision}, "real", true}, {{"dreal", {{"a", AnyComplex}}, DoublePrecision}, "real", true}, {{"dconjg", {{"a", DoublePrecisionComplex}}, DoublePrecisionComplex}, "conjg"}, @@ -1102,9 +1105,7 @@ static const IntrinsicInterface intrinsicSubroutine[]{ {"put", DefaultInt, Rank::vector, Optionality::optional}, {"get", DefaultInt, Rank::vector, Optionality::optional, common::Intent::Out}}, - {}, Rank::elemental, - IntrinsicClass::impureSubroutine}, // TODO: at most one argument can be - // present + {}, Rank::elemental, IntrinsicClass::impureSubroutine}, {"system_clock", {{"count", AnyInt, Rank::scalar, Optionality::optional, common::Intent::Out}, @@ -1249,7 +1250,7 @@ std::optional IntrinsicInterface::Match( if (!type) { CHECK(arg->Rank() == 0); const Expr &expr{DEREF(arg->UnwrapExpr())}; - if (std::holds_alternative(expr.u)) { + if (IsBOZLiteral(expr)) { if (d.typePattern.kindCode == KindCode::typeless || d.rank == Rank::elementalOrBOZ) { continue; @@ -1357,6 +1358,7 @@ std::optional IntrinsicInterface::Match( // Check the ranks of the arguments against the intrinsic's interface. const ActualArgument *arrayArg{nullptr}; + const char *arrayArgName{nullptr}; const ActualArgument *knownArg{nullptr}; std::optional shapeArgSize; int elementalRank{0}; @@ -1413,6 +1415,7 @@ std::optional IntrinsicInterface::Match( argOk = rank > 0; if (!arrayArg) { arrayArg = arg; + arrayArgName = d.keyword; } else { argOk &= rank == arrayArg->Rank(); } @@ -1426,9 +1429,22 @@ std::optional IntrinsicInterface::Match( case Rank::anyOrAssumedRank: argOk = true; break; - case Rank::conformable: + case Rank::conformable: // arg must be conformable with previous arrayArg CHECK(arrayArg); - argOk = rank == 0 || rank == arrayArg->Rank(); + CHECK(arrayArgName); + if (const std::optional &arrayArgShape{ + GetShape(context, *arrayArg)}) { + if (const std::optional &argShape{GetShape(context, *arg)}) { + std::string arrayArgMsg{"'"}; + arrayArgMsg = arrayArgMsg + arrayArgName + "='" + " argument"; + std::string argMsg{"'"}; + argMsg = argMsg + d.keyword + "='" + " argument"; + CheckConformance(context.messages(), *arrayArgShape, *argShape, + CheckConformanceFlags::RightScalarExpandable, + arrayArgMsg.c_str(), argMsg.c_str()); + } + } + argOk = true; // Avoid an additional error message break; case Rank::dimReduced: case Rank::dimRemovedOrScalar: @@ -1481,12 +1497,6 @@ std::optional IntrinsicInterface::Match( CHECK(FloatingType.test(*category)); resultType = DynamicType{*category, defaults.doublePrecisionKind()}; break; - case KindCode::defaultCharKind: - CHECK(result.categorySet == CharType); - CHECK(*category == TypeCategory::Character); - resultType = DynamicType{TypeCategory::Character, - defaults.GetDefaultKind(TypeCategory::Character)}; - break; case KindCode::defaultLogicalKind: CHECK(result.categorySet == LogicalType); CHECK(*category == TypeCategory::Logical); @@ -1516,7 +1526,11 @@ std::optional IntrinsicInterface::Match( CHECK(expr->Rank() == 0); if (auto code{ToInt64(*expr)}) { if (IsValidKindOfIntrinsicType(*category, *code)) { - resultType = DynamicType{*category, static_cast(*code)}; + if (*category == TypeCategory::Character) { // ACHAR & CHAR + resultType = DynamicType{static_cast(*code), 1}; + } else { + resultType = DynamicType{*category, static_cast(*code)}; + } break; } } @@ -1535,7 +1549,12 @@ std::optional IntrinsicInterface::Match( } else { CHECK(kindDummyArg->optionality == Optionality::defaultsToDefaultForResult); - resultType = DynamicType{*category, defaults.GetDefaultKind(*category)}; + int kind{defaults.GetDefaultKind(*category)}; + if (*category == TypeCategory::Character) { // ACHAR & CHAR + resultType = DynamicType{kind, 1}; + } else { + resultType = DynamicType{*category, kind}; + } } break; case KindCode::likeMultiply: @@ -1557,6 +1576,7 @@ std::optional IntrinsicInterface::Match( resultType = DynamicType{TypeCategory::Integer, defaults.sizeIntegerKind()}; break; + case KindCode::defaultCharKind: case KindCode::typeless: case KindCode::teamType: case KindCode::any: @@ -1861,8 +1881,9 @@ SpecificCall IntrinsicProcTable::Implementation::HandleNull( // MOLD= procedure pointer const Symbol *last{GetLastSymbol(*mold)}; CHECK(last); - auto procPointer{ - characteristics::Procedure::Characterize(*last, context)}; + auto procPointer{IsProcedure(*last) + ? characteristics::Procedure::Characterize(*last, context) + : std::nullopt}; // procPointer is null if there was an error with the analysis // associated with the procedure pointer if (procPointer) { @@ -1998,12 +2019,9 @@ static bool CheckAssociated(SpecificCall &call, FoldingContext &context) { "POINTER"_err_en_US), *pointerSymbol); } else { - const auto pointerProc{characteristics::Procedure::Characterize( - *pointerSymbol, context)}; if (const auto &targetArg{call.arguments[1]}) { if (const auto *targetExpr{targetArg->UnwrapExpr()}) { - std::optional targetProc{ - std::nullopt}; + std::optional pointerProc, targetProc; const Symbol *targetSymbol{GetLastSymbol(*targetExpr)}; bool isCall{false}; std::string targetName; @@ -2016,13 +2034,18 @@ static bool CheckAssociated(SpecificCall &call, FoldingContext &context) { targetName = targetProcRef->proc().GetName() + "()"; isCall = true; } - } else if (targetSymbol && !targetProc) { + } else if (targetSymbol) { // proc that's not a call - targetProc = characteristics::Procedure::Characterize( - *targetSymbol, context); + if (IsProcedure(*targetSymbol)) { + targetProc = characteristics::Procedure::Characterize( + *targetSymbol, context); + } targetName = targetSymbol->name().ToString(); } - + if (IsProcedure(*pointerSymbol)) { + pointerProc = characteristics::Procedure::Characterize( + *pointerSymbol, context); + } if (pointerProc) { if (targetProc) { // procedure pointer and procedure target @@ -2163,15 +2186,18 @@ std::optional IntrinsicProcTable::Implementation::Probe( FoldingContext &context, const IntrinsicProcTable &intrinsics) const { // All special cases handled here before the table probes below must - // also be recognized as special names in IsIntrinsic(). + // also be recognized as special names in IsIntrinsicSubroutine(). if (call.isSubroutineCall) { if (call.name == "__builtin_c_f_pointer") { return HandleC_F_Pointer(arguments, context); + } else if (call.name == "random_seed") { + if (arguments.size() != 0 && arguments.size() != 1) { + context.messages().Say( + "RANDOM_SEED must have either 1 or no arguments"_err_en_US); + } } - } else { - if (call.name == "null") { - return HandleNull(arguments, context); - } + } else if (call.name == "null") { + return HandleNull(arguments, context); } if (call.isSubroutineCall) { @@ -2329,7 +2355,11 @@ DynamicType IntrinsicProcTable::Implementation::GetSpecificType( const CategorySet &set{pattern.categorySet}; CHECK(set.count() == 1); TypeCategory category{set.LeastElement().value()}; - return DynamicType{category, defaults_.GetDefaultKind(category)}; + if (pattern.kindCode == KindCode::doublePrecision) { + return DynamicType{category, defaults_.doublePrecisionKind()}; + } else { + return DynamicType{category, defaults_.GetDefaultKind(category)}; + } } IntrinsicProcTable::~IntrinsicProcTable() = default; diff --git a/flang/lib/Evaluate/real.cpp b/flang/lib/Evaluate/real.cpp index 1428d52db0905c..2146789049bea0 100644 --- a/flang/lib/Evaluate/real.cpp +++ b/flang/lib/Evaluate/real.cpp @@ -439,7 +439,7 @@ ValueWithRealFlags> Real::Read( template std::string Real::DumpHexadecimal() const { if (IsNotANumber()) { - return "NaN 0x"s + word_.Hexadecimal(); + return "NaN0x"s + word_.Hexadecimal(); } else if (IsNegative()) { return "-"s + Negate().DumpHexadecimal(); } else if (IsInfinite()) { diff --git a/flang/lib/Evaluate/shape.cpp b/flang/lib/Evaluate/shape.cpp index 217270ec8b9f9b..7c5f517b92dbc6 100644 --- a/flang/lib/Evaluate/shape.cpp +++ b/flang/lib/Evaluate/shape.cpp @@ -132,6 +132,22 @@ std::optional AsConstantExtents( } } +Shape AsShape(const ConstantSubscripts &shape) { + Shape result; + for (const auto &extent : shape) { + result.emplace_back(ExtentExpr{extent}); + } + return result; +} + +std::optional AsShape(const std::optional &shape) { + if (shape) { + return AsShape(*shape); + } else { + return std::nullopt; + } +} + Shape Fold(FoldingContext &context, Shape &&shape) { for (auto &dim : shape) { dim = Fold(context, std::move(dim)); @@ -190,6 +206,14 @@ MaybeExtentExpr GetSize(Shape &&shape) { return extent; } +ConstantSubscript GetSize(const ConstantSubscripts &shape) { + ConstantSubscript size{1}; + for (auto dim : std::move(shape)) { + size *= dim; + } + return size; +} + bool ContainsAnyImpliedDoIndex(const ExtentExpr &expr) { struct MyVisitor : public AnyTraverse { using Base = AnyTraverse; @@ -202,7 +226,7 @@ bool ContainsAnyImpliedDoIndex(const ExtentExpr &expr) { // Determines lower bound on a dimension. This can be other than 1 only // for a reference to a whole array object or component. (See LBOUND, 16.9.109). -// ASSOCIATE construct entities may require tranversal of their referents. +// ASSOCIATE construct entities may require traversal of their referents. class GetLowerBoundHelper : public Traverse { public: using Result = ExtentExpr; @@ -292,6 +316,26 @@ Shape GetLowerBounds(FoldingContext &context, const NamedEntity &base) { return result; } +// If the upper and lower bounds are constant, return a constant expression for +// the extent. In particular, if the upper bound is less than the lower bound, +// return zero. +static MaybeExtentExpr GetNonNegativeExtent( + const semantics::ShapeSpec &shapeSpec) { + const auto &ubound{shapeSpec.ubound().GetExplicit()}; + const auto &lbound{shapeSpec.lbound().GetExplicit()}; + std::optional uval{ToInt64(ubound)}; + std::optional lval{ToInt64(lbound)}; + if (uval && lval) { + if (*uval < *lval) { + return ExtentExpr{0}; + } else { + return ExtentExpr{*uval - *lval + 1}; + } + } + return common::Clone(ubound.value()) - common::Clone(lbound.value()) + + ExtentExpr{1}; +} + MaybeExtentExpr GetExtent(const NamedEntity &base, int dimension) { CHECK(dimension >= 0); const Symbol &symbol{ResolveAssociations(base.GetLastSymbol())}; @@ -306,11 +350,12 @@ MaybeExtentExpr GetExtent(const NamedEntity &base, int dimension) { int j{0}; for (const auto &shapeSpec : details->shape()) { if (j++ == dimension) { - if (shapeSpec.ubound().isExplicit()) { - if (const auto &ubound{shapeSpec.ubound().GetExplicit()}) { - if (const auto &lbound{shapeSpec.lbound().GetExplicit()}) { - return common::Clone(ubound.value()) - - common::Clone(lbound.value()) + ExtentExpr{1}; + if (const auto &ubound{shapeSpec.ubound().GetExplicit()}) { + if (shapeSpec.ubound().GetExplicit()) { + // 8.5.8.2, paragraph 3. If the upper bound is less than the + // lower bound, the extent is zero. + if (shapeSpec.lbound().GetExplicit()) { + return GetNonNegativeExtent(shapeSpec); } else { return ubound.value(); } @@ -490,16 +535,10 @@ auto GetShapeHelper::operator()(const Symbol &symbol) const -> Result { [&](const semantics::ProcBindingDetails &binding) { return (*this)(binding.symbol()); }, - [&](const semantics::UseDetails &use) { - return (*this)(use.symbol()); - }, - [&](const semantics::HostAssocDetails &assoc) { - return (*this)(assoc.symbol()); - }, [](const semantics::TypeParamDetails &) { return ScalarShape(); }, [](const auto &) { return Result{}; }, }, - symbol.details()); + symbol.GetUltimate().details()); } auto GetShapeHelper::operator()(const Component &component) const -> Result { @@ -759,18 +798,16 @@ auto GetShapeHelper::operator()(const ProcedureRef &call) const -> Result { return std::nullopt; } -// Check conformance of the passed shapes. Only return true if we can verify -// that they conform -bool CheckConformance(parser::ContextualMessages &messages, const Shape &left, - const Shape &right, const char *leftIs, const char *rightIs, - bool leftScalarExpandable, bool rightScalarExpandable, - bool leftIsDeferredShape, bool rightIsDeferredShape) { +// Check conformance of the passed shapes. +std::optional CheckConformance(parser::ContextualMessages &messages, + const Shape &left, const Shape &right, CheckConformanceFlags::Flags flags, + const char *leftIs, const char *rightIs) { int n{GetRank(left)}; - if (n == 0 && leftScalarExpandable) { + if (n == 0 && (flags & CheckConformanceFlags::LeftScalarExpandable)) { return true; } int rn{GetRank(right)}; - if (rn == 0 && rightScalarExpandable) { + if (rn == 0 && (flags & CheckConformanceFlags::RightScalarExpandable)) { return true; } if (n != rn) { @@ -787,11 +824,11 @@ bool CheckConformance(parser::ContextualMessages &messages, const Shape &left, j + 1, leftIs, *leftDim, rightIs, *rightDim); return false; } - } else if (!rightIsDeferredShape) { - return false; + } else if (!(flags & CheckConformanceFlags::RightIsDeferredShape)) { + return std::nullopt; } - } else if (!leftIsDeferredShape) { - return false; + } else if (!(flags & CheckConformanceFlags::LeftIsDeferredShape)) { + return std::nullopt; } } return true; diff --git a/flang/lib/Evaluate/tools.cpp b/flang/lib/Evaluate/tools.cpp index e37db5220b34f4..122502123f038a 100644 --- a/flang/lib/Evaluate/tools.cpp +++ b/flang/lib/Evaluate/tools.cpp @@ -475,14 +475,6 @@ Expr LogicalNegation(Expr &&x) { std::move(x.u)); } -template -Expr PackageRelation( - RelationalOperator opr, Expr &&x, Expr &&y) { - static_assert(IsSpecificIntrinsicType); - return Expr{ - Relational{Relational{opr, std::move(x), std::move(y)}}}; -} - template Expr PromoteAndRelate( RelationalOperator opr, Expr> &&x, Expr> &&y) { @@ -615,20 +607,16 @@ std::optional> ConvertToType( if (auto *cx{UnwrapExpr>(x)}) { auto converted{ ConvertToKind(type.kind(), std::move(*cx))}; - if (type.charLength()) { - if (const auto &len{type.charLength()->GetExplicit()}) { - Expr lenParam{*len}; - Expr length{Convert{lenParam}}; - converted = std::visit( - [&](auto &&x) { - using Ty = std::decay_t; - using CharacterType = typename Ty::Result; - return Expr{ - Expr{SetLength{ - std::move(x), std::move(length)}}}; - }, - std::move(converted.u)); - } + if (auto length{type.GetCharLength()}) { + converted = std::visit( + [&](auto &&x) { + using Ty = std::decay_t; + using CharacterType = typename Ty::Result; + return Expr{ + Expr{SetLength{ + std::move(x), std::move(*length)}}}; + }, + std::move(converted.u)); } return Expr{std::move(converted)}; } @@ -1119,10 +1107,12 @@ bool IsSaved(const Symbol &original) { return false; // ASSOCIATE(non-variable) } else if (scopeKind == Scope::Kind::Module) { return true; // BLOCK DATA entities must all be in COMMON, handled below - } else if (symbol.attrs().test(Attr::SAVE)) { - return true; } else if (scopeKind == Scope::Kind::DerivedType) { return false; // this is a component + } else if (symbol.attrs().test(Attr::SAVE)) { + return true; + } else if (symbol.test(Symbol::Flag::InDataStmt)) { + return true; } else if (IsNamedConstant(symbol)) { return false; } else if (const auto *object{symbol.detailsIf()}; @@ -1146,6 +1136,7 @@ bool IsDummy(const Symbol &symbol) { common::visitors{[](const EntityDetails &x) { return x.isDummy(); }, [](const ObjectEntityDetails &x) { return x.isDummy(); }, [](const ProcEntityDetails &x) { return x.isDummy(); }, + [](const SubprogramDetails &x) { return x.isDummy(); }, [](const auto &) { return false; }}, ResolveAssociations(symbol).details()); } diff --git a/flang/lib/Evaluate/type.cpp b/flang/lib/Evaluate/type.cpp index 0d2004d12438b3..22ea3ea27ad292 100644 --- a/flang/lib/Evaluate/type.cpp +++ b/flang/lib/Evaluate/type.cpp @@ -92,20 +92,36 @@ bool IsDescriptor(const Symbol &symbol) { namespace Fortran::evaluate { +DynamicType::DynamicType(int k, const semantics::ParamValue &pv) + : category_{TypeCategory::Character}, kind_{k} { + CHECK(IsValidKindOfIntrinsicType(category_, kind_)); + if (auto n{ToInt64(pv.GetExplicit())}) { + knownLength_ = *n; + } else { + charLengthParamValue_ = &pv; + } +} + template inline bool PointeeComparison(const A *x, const A *y) { return x == y || (x && y && *x == *y); } bool DynamicType::operator==(const DynamicType &that) const { return category_ == that.category_ && kind_ == that.kind_ && - PointeeComparison(charLength_, that.charLength_) && + PointeeComparison(charLengthParamValue_, that.charLengthParamValue_) && + knownLength().has_value() == that.knownLength().has_value() && + (!knownLength() || *knownLength() == *that.knownLength()) && PointeeComparison(derived_, that.derived_); } std::optional> DynamicType::GetCharLength() const { - if (category_ == TypeCategory::Character && charLength_) { - if (auto length{charLength_->GetExplicit()}) { - return ConvertToType(std::move(*length)); + if (category_ == TypeCategory::Character) { + if (knownLength()) { + return AsExpr(Constant(*knownLength())); + } else if (charLengthParamValue_) { + if (auto length{charLengthParamValue_->GetExplicit()}) { + return ConvertToType(std::move(*length)); + } } } return std::nullopt; @@ -171,16 +187,18 @@ std::optional> DynamicType::MeasureSizeInBytes( } bool DynamicType::IsAssumedLengthCharacter() const { - return category_ == TypeCategory::Character && charLength_ && - charLength_->isAssumed(); + return category_ == TypeCategory::Character && charLengthParamValue_ && + charLengthParamValue_->isAssumed(); } bool DynamicType::IsNonConstantLengthCharacter() const { if (category_ != TypeCategory::Character) { return false; - } else if (!charLength_) { + } else if (knownLength()) { + return false; + } else if (!charLengthParamValue_) { return true; - } else if (const auto &expr{charLength_->GetExplicit()}) { + } else if (const auto &expr{charLengthParamValue_->GetExplicit()}) { return !IsConstantExpr(*expr); } else { return true; @@ -427,7 +445,7 @@ bool DynamicType::HasDeferredTypeParameter() const { } } } - return charLength_ && charLength_->isDeferred(); + return charLengthParamValue_ && charLengthParamValue_->isDeferred(); } bool SomeKind::operator==( diff --git a/flang/lib/Evaluate/variable.cpp b/flang/lib/Evaluate/variable.cpp index f26b76fda8595a..6b5f4caeb884ba 100644 --- a/flang/lib/Evaluate/variable.cpp +++ b/flang/lib/Evaluate/variable.cpp @@ -265,18 +265,11 @@ static std::optional> SymbolLEN(const Symbol &symbol) { return chExpr->LEN(); } } else if (auto dyType{DynamicType::From(ultimate)}) { - if (const semantics::ParamValue * len{dyType->charLength()}) { - if (len->isExplicit()) { - if (auto intExpr{len->GetExplicit()}) { - if (IsConstantExpr(*intExpr)) { - return ConvertToType(*std::move(intExpr)); - } - } - } - if (IsDescriptor(ultimate) && !ultimate.owner().IsDerivedType()) { - return Expr{DescriptorInquiry{ - NamedEntity{ultimate}, DescriptorInquiry::Field::Len}}; - } + if (auto len{dyType->GetCharLength()}) { + return len; + } else if (IsDescriptor(ultimate) && !ultimate.owner().IsDerivedType()) { + return Expr{DescriptorInquiry{ + NamedEntity{symbol}, DescriptorInquiry::Field::Len}}; } } return std::nullopt; @@ -351,12 +344,16 @@ std::optional> ProcedureDesignator::LEN() const { return c.value().LEN(); }, [](const SpecificIntrinsic &i) -> T { - if (i.name == "char") { - return Expr{1}; - } - // Some other cases whose results' lengths can be determined + // Some cases whose results' lengths can be determined // from the lengths of their arguments are handled in - // ProcedureRef::LEN(). + // ProcedureRef::LEN() before coming here. + if (const auto &result{i.characteristics.value().functionResult}) { + if (const auto *type{result->GetTypeAndShape()}) { + if (auto length{type->type().GetCharLength()}) { + return std::move(*length); + } + } + } return std::nullopt; }, }, diff --git a/flang/lib/Frontend/FrontendActions.cpp b/flang/lib/Frontend/FrontendActions.cpp index 96aa91a2fa92ff..de8a02753391bd 100644 --- a/flang/lib/Frontend/FrontendActions.cpp +++ b/flang/lib/Frontend/FrontendActions.cpp @@ -158,7 +158,7 @@ bool PrescanAndSemaAction::BeginSourceFileAction(CompilerInstance &c1) { // Prepare semantics setSemantics(std::make_unique( ci.invocation().semanticsContext(), parseTree, - ci.parsing().cooked().AsCharBlock(), ci.invocation().debugModuleDir())); + ci.invocation().debugModuleDir())); auto &semantics = this->semantics(); // Run semantic checks diff --git a/flang/lib/Lower/.clang-tidy b/flang/lib/Lower/.clang-tidy index 87ec2ff53af6e8..9cc942b8870a2e 100644 --- a/flang/lib/Lower/.clang-tidy +++ b/flang/lib/Lower/.clang-tidy @@ -1,5 +1,5 @@ -# Almost identical to the top-level .clang-tidy, except that {Member,Parameter,Variable}Case use camelBack. -Checks: '-*,clang-diagnostic-*,llvm-*,misc-*,-misc-unused-parameters,-misc-non-private-member-variables-in-classes,readability-identifier-naming' +Checks: '-readability-braces-around-statements,readability-identifier-naming,llvm-include-order,clang-diagnostic-*' +InheritParentConfig: true CheckOptions: - key: readability-identifier-naming.ClassCase value: CamelCase diff --git a/flang/lib/Lower/Allocatable.cpp b/flang/lib/Lower/Allocatable.cpp new file mode 100644 index 00000000000000..cd382290ca63ef --- /dev/null +++ b/flang/lib/Lower/Allocatable.cpp @@ -0,0 +1,686 @@ +//===-- Allocatable.cpp -- Allocatable statements lowering ----------------===// +// +// 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 +// +//===----------------------------------------------------------------------===// +// +// Coding style: https://mlir.llvm.org/getting_started/DeveloperGuide/ +// +//===----------------------------------------------------------------------===// + +#include "flang/Lower/Allocatable.h" +#include "StatementContext.h" +#include "flang/Evaluate/tools.h" +#include "flang/Lower/AbstractConverter.h" +#include "flang/Lower/PFTBuilder.h" +#include "flang/Lower/Runtime.h" +#include "flang/Lower/Todo.h" +#include "flang/Optimizer/Builder/FIRBuilder.h" +#include "flang/Optimizer/Dialect/FIROps.h" +#include "flang/Optimizer/Dialect/FIROpsSupport.h" +#include "flang/Optimizer/Builder/Runtime/RTBuilder.h" +#include "flang/Optimizer/Support/FatalError.h" +#include "flang/Parser/parse-tree.h" +#include "flang/Runtime/allocatable.h" +#include "flang/Runtime/pointer.h" +#include "flang/Semantics/tools.h" +#include "flang/Semantics/type.h" +#include "llvm/Support/CommandLine.h" + +/// By default fir memory operation fir::AllocMemOp/fir::FreeMemOp are used. +/// This switch allow forcing the use of runtime and descriptors for everything. +/// This is mainly intended as a debug switch. +static llvm::cl::opt useAllocateRuntime( + "use-alloc-runtime", + llvm::cl::desc("Lower allocations to fortran runtime calls"), + llvm::cl::init(false)); +/// Switch to force lowering of allocatable and pointers to descriptors in all +/// cases for debug purposes. +static llvm::cl::opt useDescForMutableBox( + "use-desc-for-alloc", + llvm::cl::desc("Always use descriptors for POINTER and ALLOCATABLE"), + llvm::cl::init(false)); + +//===----------------------------------------------------------------------===// +// Error management +//===----------------------------------------------------------------------===// + +namespace { +// Manage STAT and ERRMSG specifier information across a sequence of runtime +// calls for an ALLOCATE/DEALLOCATE stmt. +struct ErrorManager { + void init(Fortran::lower::AbstractConverter &converter, mlir::Location loc, + const Fortran::lower::SomeExpr *statExpr, + const Fortran::lower::SomeExpr *errMsgExpr) { + Fortran::lower::StatementContext stmtCtx; + auto &builder = converter.getFirOpBuilder(); + hasStat = builder.createBool(loc, statExpr != nullptr); + statAddr = statExpr + ? fir::getBase(converter.genExprAddr(statExpr, stmtCtx, loc)) + : mlir::Value{}; + errMsgAddr = + statExpr && errMsgExpr + ? builder.createBox(loc, + converter.genExprAddr(errMsgExpr, stmtCtx, loc)) + : builder.create( + loc, + fir::BoxType::get(mlir::NoneType::get(builder.getContext()))); + sourceFile = fir::factory::locationToFilename(builder, loc); + sourceLine = fir::factory::locationToLineNo(builder, loc, + builder.getIntegerType(32)); + } + + bool hasStatSpec() const { return static_cast(statAddr); } + + void genStatCheck(fir::FirOpBuilder &builder, mlir::Location loc) { + if (statValue) { + auto zero = builder.createIntegerConstant(loc, statValue.getType(), 0); + auto cmp = builder.create(loc, mlir::CmpIPredicate::eq, + statValue, zero); + auto ifOp = builder.create(loc, cmp, + /*withElseRegion=*/false); + builder.setInsertionPointToStart(&ifOp.thenRegion().front()); + } + } + + void assignStat(fir::FirOpBuilder &builder, mlir::Location loc, + mlir::Value stat) { + if (hasStatSpec()) { + assert(stat && "missing stat value"); + auto castStat = builder.createConvert( + loc, fir::dyn_cast_ptrEleTy(statAddr.getType()), stat); + builder.create(loc, castStat, statAddr); + statValue = stat; + } + } + + mlir::Value hasStat; + mlir::Value errMsgAddr; + mlir::Value sourceFile; + mlir::Value sourceLine; + +private: + mlir::Value statAddr; // STAT variable address + mlir::Value statValue; // current runtime STAT value +}; + +//===----------------------------------------------------------------------===// +// Allocatables runtime call generators +//===----------------------------------------------------------------------===// + +using namespace Fortran::runtime; +/// Generate a runtime call to set the bounds of an allocatable or pointer +/// descriptor. +static void genRuntimeSetBounds(fir::FirOpBuilder &builder, mlir::Location loc, + const fir::MutableBoxValue &box, + mlir::Value dimIndex, mlir::Value lowerBound, + mlir::Value upperBound) { + auto callee = + box.isPointer() + ? fir::runtime::getRuntimeFunc(loc, + builder) + : fir::runtime::getRuntimeFunc( + loc, builder); + llvm::SmallVector args{box.getAddr(), dimIndex, lowerBound, + upperBound}; + llvm::SmallVector operands; + for (auto [fst, snd] : llvm::zip(args, callee.getType().getInputs())) + operands.emplace_back(builder.createConvert(loc, snd, fst)); + builder.create(loc, callee, operands); +} + +/// Generate runtime call to set the lengths of a character allocatable or +/// pointer descriptor. +static void genRuntimeInitCharacter(fir::FirOpBuilder &builder, + mlir::Location loc, + const fir::MutableBoxValue &box, + mlir::Value len) { + auto callee = + box.isPointer() + ? fir::runtime::getRuntimeFunc( + loc, builder) + : fir::runtime::getRuntimeFunc( + loc, builder); + auto inputTypes = callee.getType().getInputs(); + if (inputTypes.size() != 5) + fir::emitFatalError( + loc, "AllocatableInitCharacter runtime interface not as expected"); + llvm::SmallVector args; + args.push_back(builder.createConvert(loc, inputTypes[0], box.getAddr())); + args.push_back(builder.createConvert(loc, inputTypes[1], len)); + auto kind = box.getEleTy().cast().getFKind(); + args.push_back(builder.createIntegerConstant(loc, inputTypes[2], kind)); + auto rank = box.rank(); + args.push_back(builder.createIntegerConstant(loc, inputTypes[3], rank)); + // TODO: coarrays + auto corank = 0; + args.push_back(builder.createIntegerConstant(loc, inputTypes[4], corank)); + builder.create(loc, callee, args); +} + +/// Generate a sequence of runtime calls to allocate memory. +static mlir::Value genRuntimeAllocate(fir::FirOpBuilder &builder, + mlir::Location loc, + const fir::MutableBoxValue &box, + ErrorManager &errorManager) { + auto callee = + box.isPointer() + ? fir::runtime::getRuntimeFunc(loc, builder) + : fir::runtime::getRuntimeFunc(loc, + builder); + llvm::SmallVector args{ + box.getAddr(), errorManager.hasStat, errorManager.errMsgAddr, + errorManager.sourceFile, errorManager.sourceLine}; + llvm::SmallVector operands; + for (auto [fst, snd] : llvm::zip(args, callee.getType().getInputs())) + operands.emplace_back(builder.createConvert(loc, snd, fst)); + return builder.create(loc, callee, operands).getResult(0); +} + +/// Generate a runtime call to deallocate memory. +static mlir::Value genRuntimeDeallocate(fir::FirOpBuilder &builder, + mlir::Location loc, + const fir::MutableBoxValue &box, + ErrorManager &errorManager) { + // Ensure fir.box is up-to-date before passing it to deallocate runtime. + auto boxAddress = fir::factory::getMutableIRBox(builder, loc, box); + auto callee = + box.isPointer() + ? fir::runtime::getRuntimeFunc(loc, + builder) + : fir::runtime::getRuntimeFunc( + loc, builder); + llvm::SmallVector args{ + boxAddress, errorManager.hasStat, errorManager.errMsgAddr, + errorManager.sourceFile, errorManager.sourceLine}; + llvm::SmallVector operands; + for (auto [fst, snd] : llvm::zip(args, callee.getType().getInputs())) + operands.emplace_back(builder.createConvert(loc, snd, fst)); + return builder.create(loc, callee, operands).getResult(0); +} + +//===----------------------------------------------------------------------===// +// Allocate statement implementation +//===----------------------------------------------------------------------===// + +/// Helper to get symbol from AllocateObject. +static const Fortran::semantics::Symbol & +unwrapSymbol(const Fortran::parser::AllocateObject &allocObj) { + const auto &lastName = Fortran::parser::GetLastName(allocObj); + assert(lastName.symbol); + return *lastName.symbol; +} + +static fir::MutableBoxValue +genMutableBoxValue(Fortran::lower::AbstractConverter &converter, + mlir::Location loc, + const Fortran::parser::AllocateObject &allocObj) { + const auto *expr = Fortran::semantics::GetExpr(allocObj); + assert(expr && "semantic analysis failure"); + return converter.genExprMutableBox(loc, *expr); +} + +/// Implement Allocate statement lowering. +class AllocateStmtHelper { +public: + AllocateStmtHelper(Fortran::lower::AbstractConverter &converter, + const Fortran::parser::AllocateStmt &stmt, + mlir::Location loc) + : converter{converter}, builder{converter.getFirOpBuilder()}, stmt{stmt}, + loc{loc} {} + + void lower() { + visitAllocateOptions(); + lowerAllocateLengthParameters(); + errorManager.init(converter, loc, statExpr, errMsgExpr); + if (sourceExpr || moldExpr) + TODO(loc, "lower MOLD/SOURCE expr in allocate"); + auto insertPt = builder.saveInsertionPoint(); + for (const auto &allocation : + std::get>(stmt.t)) + lowerAllocation(unwrapAllocation(allocation)); + builder.restoreInsertionPoint(insertPt); + } + +private: + struct Allocation { + const Fortran::parser::Allocation &alloc; + const Fortran::semantics::DeclTypeSpec &type; + bool hasCoarraySpec() const { + return std::get>( + alloc.t) + .has_value(); + } + const auto &getAllocObj() const { + return std::get(alloc.t); + } + const Fortran::semantics::Symbol &getSymbol() const { + return unwrapSymbol(getAllocObj()); + } + const auto &getShapeSpecs() const { + return std::get>(alloc.t); + } + }; + + Allocation unwrapAllocation(const Fortran::parser::Allocation &alloc) { + const auto &allocObj = std::get(alloc.t); + const auto &symbol = unwrapSymbol(allocObj); + assert(symbol.GetType()); + return Allocation{alloc, *symbol.GetType()}; + } + + void visitAllocateOptions() { + for (const auto &allocOption : + std::get>(stmt.t)) + std::visit( + Fortran::common::visitors{ + [&](const Fortran::parser::StatOrErrmsg &statOrErr) { + std::visit( + Fortran::common::visitors{ + [&](const Fortran::parser::StatVariable &statVar) { + statExpr = Fortran::semantics::GetExpr(statVar); + }, + [&](const Fortran::parser::MsgVariable &errMsgVar) { + errMsgExpr = Fortran::semantics::GetExpr(errMsgVar); + }, + }, + statOrErr.u); + }, + [&](const Fortran::parser::AllocOpt::Source &source) { + sourceExpr = Fortran::semantics::GetExpr(source.v.value()); + }, + [&](const Fortran::parser::AllocOpt::Mold &mold) { + moldExpr = Fortran::semantics::GetExpr(mold.v.value()); + }, + }, + allocOption.u); + } + + void lowerAllocation(const Allocation &alloc) { + auto boxAddr = genMutableBoxValue(converter, loc, alloc.getAllocObj()); + mlir::Value backupBox; + + if (sourceExpr) { + genSourceAllocation(alloc, boxAddr); + } else if (moldExpr) { + genMoldAllocation(alloc, boxAddr); + } else { + genSimpleAllocation(alloc, boxAddr); + } + } + + static bool lowerBoundsAreOnes(const Allocation &alloc) { + for (const auto &shapeSpec : alloc.getShapeSpecs()) + if (std::get<0>(shapeSpec.t)) + return false; + return true; + } + + /// Build name for the fir::allocmem generated for alloc. + std::string mangleAlloc(const Allocation &alloc) { + return converter.mangleName(alloc.getSymbol()) + ".alloc"; + } + + /// Generate allocation without runtime calls. + /// Only for intrinsic types. No coarrays, no polymorphism. No error recovery. + void genInlinedAllocation(const Allocation &alloc, + const fir::MutableBoxValue &box) { + llvm::SmallVector lbounds; + llvm::SmallVector extents; + Fortran::lower::StatementContext stmtCtx; + auto idxTy = builder.getIndexType(); + auto lBoundsAreOnes = lowerBoundsAreOnes(alloc); + auto one = builder.createIntegerConstant(loc, idxTy, 1); + for (const auto &shapeSpec : alloc.getShapeSpecs()) { + mlir::Value lb; + if (!lBoundsAreOnes) { + if (const auto &lbExpr = std::get<0>(shapeSpec.t)) { + lb = fir::getBase(converter.genExprValue( + Fortran::semantics::GetExpr(*lbExpr), stmtCtx, loc)); + lb = builder.createConvert(loc, idxTy, lb); + } else { + lb = one; + } + lbounds.emplace_back(lb); + } + auto ub = fir::getBase(converter.genExprValue( + Fortran::semantics::GetExpr(std::get<1>(shapeSpec.t)), stmtCtx, loc)); + ub = builder.createConvert(loc, idxTy, ub); + if (lb) { + auto diff = builder.create(loc, ub, lb); + extents.emplace_back(builder.create(loc, diff, one)); + } else { + extents.emplace_back(ub); + } + } + fir::factory::genInlinedAllocation(builder, loc, box, lbounds, extents, + lenParams, mangleAlloc(alloc)); + } + + void genSimpleAllocation(const Allocation &alloc, + const fir::MutableBoxValue &box) { + if (!box.isDerived() && !errorManager.hasStatSpec() && + !alloc.type.IsPolymorphic() && !alloc.hasCoarraySpec() && + !useAllocateRuntime) { + genInlinedAllocation(alloc, box); + return; + } + // Generate a sequence of runtime calls. + errorManager.genStatCheck(builder, loc); + if (box.isPointer()) { + // For pointers, the descriptor may still be uninitialized (see Fortran + // 2018 19.5.2.2). The allocation runtime needs to be given a descriptor + // with initialized rank, types and attributes. Initialize the descriptor + // here to ensure these constraints are fulfilled. + auto nullPointer = fir::factory::createUnallocatedBox( + builder, loc, box.getBoxTy(), box.nonDeferredLenParams()); + builder.create(loc, nullPointer, box.getAddr()); + } else { + assert(box.isAllocatable() && "must be an allocatable"); + // For allocatables, sync the MutableBoxValue and descriptor before the + // calls in case it is tracked locally by a set of variables. + fir::factory::getMutableIRBox(builder, loc, box); + } + if (alloc.hasCoarraySpec()) + TODO(loc, "coarray allocation"); + if (alloc.type.IsPolymorphic()) + genSetType(alloc, box); + genSetDeferredLengthParameters(alloc, box); + // Set bounds for arrays + auto idxTy = builder.getIndexType(); + auto i32Ty = builder.getIntegerType(32); + Fortran::lower::StatementContext stmtCtx; + for (const auto &iter : llvm::enumerate(alloc.getShapeSpecs())) { + mlir::Value lb; + const auto &bounds = iter.value().t; + if (const auto &lbExpr = std::get<0>(bounds)) + lb = fir::getBase(converter.genExprValue( + Fortran::semantics::GetExpr(*lbExpr), stmtCtx, loc)); + else + lb = builder.createIntegerConstant(loc, idxTy, 1); + auto ub = fir::getBase(converter.genExprValue( + Fortran::semantics::GetExpr(std::get<1>(bounds)), stmtCtx, loc)); + auto dimIndex = builder.createIntegerConstant(loc, i32Ty, iter.index()); + // Runtime call + genRuntimeSetBounds(builder, loc, box, dimIndex, lb, ub); + } + auto stat = genRuntimeAllocate(builder, loc, box, errorManager); + fir::factory::syncMutableBoxFromIRBox(builder, loc, box); + errorManager.assignStat(builder, loc, stat); + } + + /// Lower the length parameters that may be specified in the optional + /// type specification. + void lowerAllocateLengthParameters() { + const auto *typeSpec = getIfAllocateStmtTypeSpec(); + if (!typeSpec) + return; + if (const auto *derived = typeSpec->AsDerived()) + if (Fortran::semantics::CountLenParameters(*derived) > 0) + TODO(loc, "TODO: setting derived type params in allocation"); + if (typeSpec->category() == + Fortran::semantics::DeclTypeSpec::Category::Character) { + auto lenParam = typeSpec->characterTypeSpec().length(); + if (auto intExpr = lenParam.GetExplicit()) { + Fortran::lower::StatementContext stmtCtx; + Fortran::semantics::SomeExpr lenExpr{*intExpr}; + lenParams.push_back( + fir::getBase(converter.genExprValue(lenExpr, stmtCtx, &loc))); + } + } + } + + // Set length parameters in the box stored in boxAddr. + // This must be called before setting the bounds because it may use + // Init runtime calls that may set the bounds to zero. + void genSetDeferredLengthParameters(const Allocation &alloc, + const fir::MutableBoxValue &box) { + if (lenParams.empty()) + return; + // TODO: in case a length parameter was not deferred, insert a runtime check + // that the length is the same (AllocatableCheckLengthParameter runtime + // call). + if (box.isCharacter()) + genRuntimeInitCharacter(builder, loc, box, lenParams[0]); + + if (box.isDerived()) + TODO(loc, "derived type length parameters in allocate"); + } + + void genSourceAllocation(const Allocation &, const fir::MutableBoxValue &) { + TODO(loc, "SOURCE allocation lowering"); + } + void genMoldAllocation(const Allocation &, const fir::MutableBoxValue &) { + TODO(loc, "MOLD allocation lowering"); + } + void genSetType(const Allocation &, const fir::MutableBoxValue &) { + TODO(loc, "Polymorphic entity allocation lowering"); + } + + /// Returns a pointer to the DeclTypeSpec if a type-spec is provided in the + /// allocate statement. Returns a null pointer otherwise. + const Fortran::semantics::DeclTypeSpec *getIfAllocateStmtTypeSpec() const { + if (const auto &typeSpec = + std::get>(stmt.t)) + return typeSpec->declTypeSpec; + return nullptr; + } + + Fortran::lower::AbstractConverter &converter; + fir::FirOpBuilder &builder; + const Fortran::parser::AllocateStmt &stmt; + const Fortran::lower::SomeExpr *sourceExpr{nullptr}; + const Fortran::lower::SomeExpr *moldExpr{nullptr}; + const Fortran::lower::SomeExpr *statExpr{nullptr}; + const Fortran::lower::SomeExpr *errMsgExpr{nullptr}; + // If the allocate has a type spec, lenParams contains the + // value of the length parameters that were specified inside. + llvm::SmallVector lenParams; + ErrorManager errorManager; + + mlir::Location loc; +}; +} // namespace + +void Fortran::lower::genAllocateStmt( + Fortran::lower::AbstractConverter &converter, + const Fortran::parser::AllocateStmt &stmt, mlir::Location loc) { + AllocateStmtHelper{converter, stmt, loc}.lower(); + return; +} + +//===----------------------------------------------------------------------===// +// Deallocate statement implementation +//===----------------------------------------------------------------------===// + +// Generate deallocation of a pointer/allocatable. +static void genDeallocate(fir::FirOpBuilder &builder, mlir::Location loc, + const fir::MutableBoxValue &box, + ErrorManager &errorManager) { + // Deallocate intrinsic types inline. + if (!box.isDerived() && !errorManager.hasStatSpec() && !useAllocateRuntime) { + fir::factory::genInlinedDeallocate(builder, loc, box); + return; + } + // Use runtime calls to deallocate descriptor cases. Sync MutableBoxValue + // with its descriptor before and after calls if needed. + errorManager.genStatCheck(builder, loc); + auto stat = genRuntimeDeallocate(builder, loc, box, errorManager); + fir::factory::syncMutableBoxFromIRBox(builder, loc, box); + errorManager.assignStat(builder, loc, stat); +} + +void Fortran::lower::genDeallocateStmt( + Fortran::lower::AbstractConverter &converter, + const Fortran::parser::DeallocateStmt &stmt, mlir::Location loc) { + const Fortran::lower::SomeExpr *statExpr{nullptr}; + const Fortran::lower::SomeExpr *errMsgExpr{nullptr}; + for (const auto &statOrErr : + std::get>(stmt.t)) + std::visit(Fortran::common::visitors{ + [&](const Fortran::parser::StatVariable &statVar) { + statExpr = Fortran::semantics::GetExpr(statVar); + }, + [&](const Fortran::parser::MsgVariable &errMsgVar) { + errMsgExpr = Fortran::semantics::GetExpr(errMsgVar); + }, + }, + statOrErr.u); + ErrorManager errorManager; + errorManager.init(converter, loc, statExpr, errMsgExpr); + auto &builder = converter.getFirOpBuilder(); + auto insertPt = builder.saveInsertionPoint(); + for (const auto &allocateObject : + std::get>(stmt.t)) { + auto box = genMutableBoxValue(converter, loc, allocateObject); + genDeallocate(builder, loc, box, errorManager); + } + builder.restoreInsertionPoint(insertPt); +} + +//===----------------------------------------------------------------------===// +// MutableBoxValue creation implementation +//===----------------------------------------------------------------------===// + +/// Is this symbol a pointer to a pointer array that does not have the +/// CONTIGUOUS attribute ? +static inline bool +isNonContiguousArrayPointer(const Fortran::semantics::Symbol &sym) { + return Fortran::semantics::IsPointer(sym) && sym.Rank() != 0 && + !sym.attrs().test(Fortran::semantics::Attr::CONTIGUOUS); +} + +/// Is this a local procedure symbol in a procedure that contains internal +/// procedures ? +static bool mayBeCapturedInInternalProc(const Fortran::semantics::Symbol &sym) { + const auto &owner = sym.owner(); + auto kind = owner.kind(); + // Test if this is a procedure scope that contains a subprogram scope that is + // not an interface. + if (kind == Fortran::semantics::Scope::Kind::Subprogram || + kind == Fortran::semantics::Scope::Kind::MainProgram) + for (const auto &childScope : owner.children()) + if (childScope.kind() == Fortran::semantics::Scope::Kind::Subprogram) + if (const auto *childSym = childScope.symbol()) + if (const auto *details = + childSym->detailsIf()) + if (!details->isInterface()) + return true; + return false; +} + +/// In case it is safe to track the properties in variables outside a +/// descriptor, create the variables to hold the mutable properties of the +/// entity var. The variables are not initialized here. +static fir::MutableProperties +createMutableProperties(Fortran::lower::AbstractConverter &converter, + mlir::Location loc, + const Fortran::lower::pft::Variable &var, + mlir::ValueRange nonDeferredParams) { + auto &builder = converter.getFirOpBuilder(); + const auto &sym = var.getSymbol(); + // Globals and dummies may be associated, creating local variables would + // require keeping the values and descriptor before and after every single + // impure calls in the current scope (not only the ones taking the variable as + // arguments. All.) Volatile means the variable may change in ways not defined + // per Fortran, so lowering can most likely not keep the descriptor and values + // in sync as needed. + // Pointers to non contiguous arrays need to be represented with a fir.box to + // account for the discontiguity. + // Pointer/Allocatable in internal procedure are descriptors in the host link, + // and it would increase complexity to sync this descriptor with the local + // values every time the host link is escaping. + if (var.isGlobal() || Fortran::semantics::IsDummy(sym) || + Fortran::semantics::IsFunctionResult(sym) || + sym.attrs().test(Fortran::semantics::Attr::VOLATILE) || + isNonContiguousArrayPointer(sym) || useAllocateRuntime || + useDescForMutableBox || mayBeCapturedInInternalProc(sym)) + return {}; + fir::MutableProperties mutableProperties; + auto name = converter.mangleName(sym); + auto baseAddrTy = converter.genType(sym); + if (auto boxType = baseAddrTy.dyn_cast()) + baseAddrTy = boxType.getEleTy(); + // Allocate and set a variable to hold the address. + // It will be set to null in setUnallocatedStatus. + mutableProperties.addr = + builder.allocateLocal(loc, baseAddrTy, name + ".addr", "", + /*shape=*/llvm::None, /*typeparams=*/llvm::None); + // Allocate variables to hold lower bounds and extents. + auto rank = sym.Rank(); + auto idxTy = builder.getIndexType(); + for (decltype(rank) i = 0; i < rank; ++i) { + auto lboundVar = + builder.allocateLocal(loc, idxTy, name + ".lb" + std::to_string(i), "", + /*shape=*/llvm::None, /*typeparams=*/llvm::None); + auto extentVar = + builder.allocateLocal(loc, idxTy, name + ".ext" + std::to_string(i), "", + /*shape=*/llvm::None, /*typeparams=*/llvm::None); + mutableProperties.lbounds.emplace_back(lboundVar); + mutableProperties.extents.emplace_back(extentVar); + } + + // Allocate variable to hold deferred length parameters. + auto eleTy = baseAddrTy; + if (auto newTy = fir::dyn_cast_ptrEleTy(eleTy)) + eleTy = newTy; + if (auto seqTy = eleTy.dyn_cast()) + eleTy = seqTy.getEleTy(); + if (auto record = eleTy.dyn_cast()) + if (record.getNumLenParams() != 0) + TODO(loc, "deferred length type parameters."); + if (fir::isa_char(eleTy) && nonDeferredParams.empty()) { + auto lenVar = builder.allocateLocal(loc, builder.getCharacterLengthType(), + name + ".len", "", /*shape=*/llvm::None, + /*typeparams=*/llvm::None); + mutableProperties.deferredParams.emplace_back(lenVar); + } + return mutableProperties; +} + +fir::MutableBoxValue Fortran::lower::createMutableBox( + Fortran::lower::AbstractConverter &converter, mlir::Location loc, + const Fortran::lower::pft::Variable &var, mlir::Value boxAddr, + mlir::ValueRange nonDeferredParams) { + + auto mutableProperties = + createMutableProperties(converter, loc, var, nonDeferredParams); + auto box = + fir::MutableBoxValue(boxAddr, nonDeferredParams, mutableProperties); + auto &builder = converter.getFirOpBuilder(); + if (!var.isGlobal() && !Fortran::semantics::IsDummy(var.getSymbol())) + fir::factory::disassociateMutableBox(builder, loc, box); + return box; +} + +//===----------------------------------------------------------------------===// +// MutableBoxValue reading interface implementation +//===----------------------------------------------------------------------===// + +static bool +isArraySectionWithoutVectorSubscript(const Fortran::lower::SomeExpr &expr) { + return expr.Rank() > 0 && Fortran::evaluate::IsVariable(expr) && + !Fortran::evaluate::UnwrapWholeSymbolDataRef(expr) && + !Fortran::evaluate::HasVectorSubscript(expr); +} + +void Fortran::lower::associateMutableBox( + Fortran::lower::AbstractConverter &converter, mlir::Location loc, + const fir::MutableBoxValue &box, const Fortran::lower::SomeExpr &source, + mlir::ValueRange lbounds, Fortran::lower::StatementContext &stmtCtx) { + auto &builder = converter.getFirOpBuilder(); + if (Fortran::evaluate::UnwrapExpr(source)) { + fir::factory::disassociateMutableBox(builder, loc, box); + return; + } + // The right hand side must not be evaluated in a temp. + // Array sections can be described by fir.box without making a temp. + // Otherwise, do not generate a fir.box to avoid having to later use a + // fir.rebox to implement the pointer association. + auto rhs = isArraySectionWithoutVectorSubscript(source) + ? converter.genExprBox(source, stmtCtx, loc) + : converter.genExprAddr(source, stmtCtx); + fir::factory::associateMutableBox(builder, loc, box, rhs, lbounds); +} diff --git a/flang/lib/Lower/BoxAnalyzer.h b/flang/lib/Lower/BoxAnalyzer.h new file mode 100644 index 00000000000000..1140401f5a5dde --- /dev/null +++ b/flang/lib/Lower/BoxAnalyzer.h @@ -0,0 +1,494 @@ +//===-- BoxAnalyzer.h -------------------------------------------*- C++ -*-===// +// +// 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 +// +//===----------------------------------------------------------------------===// +// +// Coding style: https://mlir.llvm.org/getting_started/DeveloperGuide/ +// +//===----------------------------------------------------------------------===// + +#ifndef FORTRAN_LOWER_BOXANALYZER_H +#define FORTRAN_LOWER_BOXANALYZER_H + +#include "flang/Evaluate/fold.h" +#include "flang/Evaluate/tools.h" +#include "flang/Optimizer/Dialect/FIRType.h" +#include "flang/Optimizer/Support/Matcher.h" +#include "flang/Semantics/symbol.h" + +namespace Fortran::lower { + +//===----------------------------------------------------------------------===// +// Classifications of a symbol. +// +// Each classification is a distinct class and can be used in pattern matching. +//===----------------------------------------------------------------------===// + +namespace details { + +using FromBox = std::monostate; + +/// Base class for all box analysis results. +struct ScalarSym { + ScalarSym(const Fortran::semantics::Symbol &sym) : sym{&sym} {} + ScalarSym &operator=(const ScalarSym &) = default; + + const Fortran::semantics::Symbol &symbol() const { return *sym; } + + static constexpr bool staticSize() { return true; } + static constexpr bool isChar() { return false; } + static constexpr bool isArray() { return false; } + +private: + const Fortran::semantics::Symbol *sym; +}; + +/// Scalar of dependent type CHARACTER, constant LEN. +struct ScalarStaticChar : ScalarSym { + ScalarStaticChar(const Fortran::semantics::Symbol &sym, int64_t len) + : ScalarSym{sym}, len{len} {} + + int64_t charLen() const { return len; } + + static constexpr bool isChar() { return true; } + +private: + int64_t len; +}; + +/// Scalar of dependent type Derived, constant LEN(s). +struct ScalarStaticDerived : ScalarSym { + ScalarStaticDerived(const Fortran::semantics::Symbol &sym, + llvm::SmallVectorImpl &&lens) + : ScalarSym{sym}, lens{std::move(lens)} {} + +private: + llvm::SmallVector lens; +}; + +/// Scalar of dependent type CHARACTER, dynamic LEN. +struct ScalarDynamicChar : ScalarSym { + ScalarDynamicChar(const Fortran::semantics::Symbol &sym, + const Fortran::semantics::SomeExpr &len) + : ScalarSym{sym}, len{len} {} + ScalarDynamicChar(const Fortran::semantics::Symbol &sym) + : ScalarSym{sym}, len{FromBox{}} {} + + llvm::Optional charLen() const { + if (auto *l = std::get_if(&len)) + return {*l}; + return llvm::None; + } + + static constexpr bool staticSize() { return false; } + static constexpr bool isChar() { return true; } + +private: + std::variant len; +}; + +/// Scalar of dependent type Derived, dynamic LEN(s). +struct ScalarDynamicDerived : ScalarSym { + ScalarDynamicDerived( + const Fortran::semantics::Symbol &sym, + llvm::SmallVectorImpl &&lens) + : ScalarSym{sym}, lens{std::move(lens)} {} + +private: + llvm::SmallVector lens; +}; + +struct LBoundsAndShape { + LBoundsAndShape(llvm::SmallVectorImpl &&lbounds, + llvm::SmallVectorImpl &&shapes) + : lbounds{std::move(lbounds)}, shapes{std::move(shapes)} {} + + static constexpr bool staticSize() { return true; } + static constexpr bool isArray() { return true; } + bool lboundAllOnes() const { + return llvm::all_of(lbounds, [](int64_t v) { return v == 1; }); + } + + llvm::SmallVector lbounds; + llvm::SmallVector shapes; +}; + +/// Array of T with statically known origin (lbounds) and shape. +struct StaticArray : ScalarSym, LBoundsAndShape { + StaticArray(const Fortran::semantics::Symbol &sym, + llvm::SmallVectorImpl &&lbounds, + llvm::SmallVectorImpl &&shapes) + : ScalarSym{sym}, LBoundsAndShape{std::move(lbounds), std::move(shapes)} { + } + + static constexpr bool staticSize() { return LBoundsAndShape::staticSize(); } +}; + +struct DynamicBound { + DynamicBound( + llvm::SmallVectorImpl &&bounds) + : bounds{std::move(bounds)} {} + + static constexpr bool staticSize() { return false; } + static constexpr bool isArray() { return true; } + bool lboundAllOnes() const { + return llvm::all_of(bounds, [](const Fortran::semantics::ShapeSpec *p) { + if (auto low = p->lbound().GetExplicit()) + if (auto lb = Fortran::evaluate::ToInt64(*low)) + return *lb == 1; + return false; + }); + } + + llvm::SmallVector bounds; +}; + +/// Array of T with dynamic origin and/or shape. +struct DynamicArray : ScalarSym, DynamicBound { + DynamicArray( + const Fortran::semantics::Symbol &sym, + llvm::SmallVectorImpl &&bounds) + : ScalarSym{sym}, DynamicBound{std::move(bounds)} {} + + static constexpr bool staticSize() { return DynamicBound::staticSize(); } +}; + +/// Array of CHARACTER with statically known LEN, origin, and shape. +struct StaticArrayStaticChar : ScalarStaticChar, LBoundsAndShape { + StaticArrayStaticChar(const Fortran::semantics::Symbol &sym, int64_t len, + llvm::SmallVectorImpl &&lbounds, + llvm::SmallVectorImpl &&shapes) + : ScalarStaticChar{sym, len}, LBoundsAndShape{std::move(lbounds), + std::move(shapes)} {} + + static constexpr bool staticSize() { + return ScalarStaticChar::staticSize() && LBoundsAndShape::staticSize(); + } +}; + +/// Array of CHARACTER with dynamic LEN but constant origin, shape. +struct StaticArrayDynamicChar : ScalarDynamicChar, LBoundsAndShape { + StaticArrayDynamicChar(const Fortran::semantics::Symbol &sym, + const Fortran::semantics::SomeExpr &len, + llvm::SmallVectorImpl &&lbounds, + llvm::SmallVectorImpl &&shapes) + : ScalarDynamicChar{sym, len}, LBoundsAndShape{std::move(lbounds), + std::move(shapes)} {} + StaticArrayDynamicChar(const Fortran::semantics::Symbol &sym, + llvm::SmallVectorImpl &&lbounds, + llvm::SmallVectorImpl &&shapes) + : ScalarDynamicChar{sym}, LBoundsAndShape{std::move(lbounds), + std::move(shapes)} {} + + static constexpr bool staticSize() { + return ScalarDynamicChar::staticSize() && LBoundsAndShape::staticSize(); + } +}; + +/// Array of CHARACTER with constant LEN but dynamic origin, shape. +struct DynamicArrayStaticChar : ScalarStaticChar, DynamicBound { + DynamicArrayStaticChar( + const Fortran::semantics::Symbol &sym, int64_t len, + llvm::SmallVectorImpl &&bounds) + : ScalarStaticChar{sym, len}, DynamicBound{std::move(bounds)} {} + + static constexpr bool staticSize() { + return ScalarStaticChar::staticSize() && DynamicBound::staticSize(); + } +}; + +/// Array of CHARACTER with dynamic LEN, origin, and shape. +struct DynamicArrayDynamicChar : ScalarDynamicChar, DynamicBound { + DynamicArrayDynamicChar( + const Fortran::semantics::Symbol &sym, + const Fortran::semantics::SomeExpr &len, + llvm::SmallVectorImpl &&bounds) + : ScalarDynamicChar{sym, len}, DynamicBound{std::move(bounds)} {} + DynamicArrayDynamicChar( + const Fortran::semantics::Symbol &sym, + llvm::SmallVectorImpl &&bounds) + : ScalarDynamicChar{sym}, DynamicBound{std::move(bounds)} {} + + static constexpr bool staticSize() { + return ScalarDynamicChar::staticSize() && DynamicBound::staticSize(); + } +}; + +// TODO: Arrays of derived types with LEN(s)... + +} // namespace details + +inline bool symIsChar(const Fortran::semantics::Symbol &sym) { + return sym.GetType()->category() == + Fortran::semantics::DeclTypeSpec::Character; +} + +inline bool symIsArray(const Fortran::semantics::Symbol &sym) { + const auto *det = + sym.GetUltimate().detailsIf(); + return det && det->IsArray(); +} + +inline bool isExplicitShape(const Fortran::semantics::Symbol &sym) { + const auto *det = + sym.GetUltimate().detailsIf(); + return det && det->IsArray() && det->shape().IsExplicitShape(); +} + +//===----------------------------------------------------------------------===// +// Perform analysis to determine a box's parameter values +//===----------------------------------------------------------------------===// + +/// Analyze a symbol, classify it as to whether it just a scalar, a CHARACTER +/// scalar, an array entity, a combination thereof, and whether the LEN, shape, +/// and lbounds are constant or not. +class BoxAnalyzer : public fir::details::matcher { +public: + // Analysis default state + using None = std::monostate; + + using ScalarSym = details::ScalarSym; + using ScalarStaticChar = details::ScalarStaticChar; + using ScalarDynamicChar = details::ScalarDynamicChar; + using StaticArray = details::StaticArray; + using DynamicArray = details::DynamicArray; + using StaticArrayStaticChar = details::StaticArrayStaticChar; + using StaticArrayDynamicChar = details::StaticArrayDynamicChar; + using DynamicArrayStaticChar = details::DynamicArrayStaticChar; + using DynamicArrayDynamicChar = details::DynamicArrayDynamicChar; + // TODO: derived types + + using VT = std::variant; + + //===--------------------------------------------------------------------===// + // Constructor + //===--------------------------------------------------------------------===// + + BoxAnalyzer() : box{None{}} {} + + operator bool() const { return !std::holds_alternative(box); } + + bool isTrivial() const { return std::holds_alternative(box); } + + /// Returns true for any sort of CHARACTER. + bool isChar() const { + return match([](const ScalarStaticChar &) { return true; }, + [](const ScalarDynamicChar &) { return true; }, + [](const StaticArrayStaticChar &) { return true; }, + [](const StaticArrayDynamicChar &) { return true; }, + [](const DynamicArrayStaticChar &) { return true; }, + [](const DynamicArrayDynamicChar &) { return true; }, + [](const auto &) { return false; }); + } + + /// Returns true for any sort of array. + bool isArray() const { + return match([](const StaticArray &) { return true; }, + [](const DynamicArray &) { return true; }, + [](const StaticArrayStaticChar &) { return true; }, + [](const StaticArrayDynamicChar &) { return true; }, + [](const DynamicArrayStaticChar &) { return true; }, + [](const DynamicArrayDynamicChar &) { return true; }, + [](const auto &) { return false; }); + } + + /// Returns true iff this is an array with constant extents and lbounds. This + /// returns true for arrays of CHARACTER, even if the LEN is not a constant. + bool isStaticArray() const { + return match([](const StaticArray &) { return true; }, + [](const StaticArrayStaticChar &) { return true; }, + [](const StaticArrayDynamicChar &) { return true; }, + [](const auto &) { return false; }); + } + + bool isConstant() const { + return match( + [](const None &) -> bool { + llvm::report_fatal_error("internal: analysis failed"); + }, + [](const auto &x) { return x.staticSize(); }); + } + + llvm::Optional getCharLenConst() const { + using A = llvm::Optional; + return match( + [](const ScalarStaticChar &x) -> A { return {x.charLen()}; }, + [](const StaticArrayStaticChar &x) -> A { return {x.charLen()}; }, + [](const DynamicArrayStaticChar &x) -> A { return {x.charLen()}; }, + [](const auto &) -> A { return llvm::None; }); + } + + llvm::Optional getCharLenExpr() const { + using A = llvm::Optional; + return match([](const ScalarDynamicChar &x) { return x.charLen(); }, + [](const StaticArrayDynamicChar &x) { return x.charLen(); }, + [](const DynamicArrayDynamicChar &x) { return x.charLen(); }, + [](const auto &) -> A { return llvm::None; }); + } + + /// Is the origin of this array the default of vector of `1`? + bool lboundIsAllOnes() const { + return match( + [&](const StaticArray &x) { return x.lboundAllOnes(); }, + [&](const DynamicArray &x) { return x.lboundAllOnes(); }, + [&](const StaticArrayStaticChar &x) { return x.lboundAllOnes(); }, + [&](const StaticArrayDynamicChar &x) { return x.lboundAllOnes(); }, + [&](const DynamicArrayStaticChar &x) { return x.lboundAllOnes(); }, + [&](const DynamicArrayDynamicChar &x) { return x.lboundAllOnes(); }, + [](const auto &) -> bool { llvm::report_fatal_error("not an array"); }); + } + + /// Get the static lbound values (the origin of the array). + llvm::ArrayRef staticLBound() const { + using A = llvm::ArrayRef; + return match([](const StaticArray &x) -> A { return x.lbounds; }, + [](const StaticArrayStaticChar &x) -> A { return x.lbounds; }, + [](const StaticArrayDynamicChar &x) -> A { return x.lbounds; }, + [](const auto &) -> A { + llvm::report_fatal_error("does not have static lbounds"); + }); + } + + /// Get the static extents of the array. + llvm::ArrayRef staticShape() const { + using A = llvm::ArrayRef; + return match([](const StaticArray &x) -> A { return x.shapes; }, + [](const StaticArrayStaticChar &x) -> A { return x.shapes; }, + [](const StaticArrayDynamicChar &x) -> A { return x.shapes; }, + [](const auto &) -> A { + llvm::report_fatal_error("does not have static shape"); + }); + } + + /// Get the dynamic bounds information of the array (both origin, shape). + llvm::ArrayRef dynamicBound() const { + using A = llvm::ArrayRef; + return match([](const DynamicArray &x) -> A { return x.bounds; }, + [](const DynamicArrayStaticChar &x) -> A { return x.bounds; }, + [](const DynamicArrayDynamicChar &x) -> A { return x.bounds; }, + [](const auto &) -> A { + llvm::report_fatal_error("does not have bounds"); + }); + } + + /// Run the analysis on `sym`. + void analyze(const Fortran::semantics::Symbol &sym) { + if (symIsArray(sym)) { + auto isConstant = true; + llvm::SmallVector lbounds; + llvm::SmallVector shapes; + llvm::SmallVector bounds; + for (const auto &subs : getSymShape(sym)) { + bounds.push_back(&subs); + if (!isConstant) + continue; + if (auto low = subs.lbound().GetExplicit()) { + if (auto lb = Fortran::evaluate::ToInt64(*low)) { + lbounds.push_back(*lb); // origin for this dim + if (auto high = subs.ubound().GetExplicit()) { + if (auto ub = Fortran::evaluate::ToInt64(*high)) { + auto extent = *ub - *lb + 1; + shapes.push_back(extent < 0 ? 0 : extent); + continue; + } + } else if (subs.ubound().isAssumed()) { + shapes.push_back(fir::SequenceType::getUnknownExtent()); + continue; + } + } + } + isConstant = false; + } + + // sym : array + if (symIsChar(sym)) { + if (auto len = charLenConstant(sym)) { + if (isConstant) + box = StaticArrayStaticChar(sym, *len, std::move(lbounds), + std::move(shapes)); + else + box = DynamicArrayStaticChar(sym, *len, std::move(bounds)); + return; + } + if (auto var = charLenVariable(sym)) { + if (isConstant) + box = StaticArrayDynamicChar(sym, *var, std::move(lbounds), + std::move(shapes)); + else + box = DynamicArrayDynamicChar(sym, *var, std::move(bounds)); + return; + } + if (isConstant) + box = StaticArrayDynamicChar(sym, std::move(lbounds), + std::move(shapes)); + else + box = DynamicArrayDynamicChar(sym, std::move(bounds)); + return; + } + + // sym : array + if (isConstant) + box = StaticArray(sym, std::move(lbounds), std::move(shapes)); + else + box = DynamicArray(sym, std::move(bounds)); + return; + } + + // sym : CHARACTER + if (symIsChar(sym)) { + if (auto len = charLenConstant(sym)) + box = ScalarStaticChar(sym, *len); + else if (auto var = charLenVariable(sym)) + box = ScalarDynamicChar(sym, *var); + else + box = ScalarDynamicChar(sym); + return; + } + + // sym : other + box = ScalarSym(sym); + } + + const VT &matchee() const { return box; } + +private: + // Get the shape of a symbol. + const Fortran::semantics::ArraySpec & + getSymShape(const Fortran::semantics::Symbol &sym) { + return sym.GetUltimate() + .get() + .shape(); + } + + // Get the constant LEN of a CHARACTER, if it exists. + llvm::Optional + charLenConstant(const Fortran::semantics::Symbol &sym) { + const auto &lenParam = sym.GetType()->characterTypeSpec().length(); + if (auto expr = lenParam.GetExplicit()) + if (auto asInt = Fortran::evaluate::ToInt64( + Fortran::evaluate::AsGenericExpr(std::move(*expr)))) + return {*asInt}; + return llvm::None; + } + + // Get the `SomeExpr` that describes the CHARACTER's LEN. + llvm::Optional + charLenVariable(const Fortran::semantics::Symbol &sym) { + const auto &lenParam = sym.GetType()->characterTypeSpec().length(); + if (auto expr = lenParam.GetExplicit()) + return {Fortran::evaluate::AsGenericExpr(std::move(*expr))}; + return llvm::None; + } + + VT box; +}; // namespace Fortran::lower + +} // namespace Fortran::lower + +#endif // FORTRAN_LOWER_BOXANALYZER_H diff --git a/flang/lib/Lower/Bridge.cpp b/flang/lib/Lower/Bridge.cpp new file mode 100644 index 00000000000000..92e676bc0dd053 --- /dev/null +++ b/flang/lib/Lower/Bridge.cpp @@ -0,0 +1,2818 @@ +//===-- Bridge.cpp -- bridge to lower to MLIR -----------------------------===// +// +// 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 +// +//===----------------------------------------------------------------------===// +// +// Coding style: https://mlir.llvm.org/getting_started/DeveloperGuide/ +// +//===----------------------------------------------------------------------===// + +#include "flang/Lower/Bridge.h" +#include "ConvertVariable.h" +#include "IterationSpace.h" +#include "StatementContext.h" +#include "flang/Lower/Allocatable.h" +#include "flang/Lower/CallInterface.h" +#include "flang/Lower/Coarray.h" +#include "flang/Lower/ConvertExpr.h" +#include "flang/Lower/ConvertType.h" +#include "flang/Lower/HostAssociations.h" +#include "flang/Lower/IO.h" +#include "flang/Lower/Mangler.h" +#include "flang/Lower/OpenACC.h" +#include "flang/Lower/OpenMP.h" +#include "flang/Lower/PFTBuilder.h" +#include "flang/Lower/Runtime.h" +#include "flang/Lower/Support/Utils.h" +#include "flang/Lower/Todo.h" +#include "flang/Optimizer/Builder/BoxValue.h" +#include "flang/Optimizer/Builder/Character.h" +#include "flang/Optimizer/Builder/FIRBuilder.h" +#include "flang/Optimizer/Builder/Runtime/Character.h" +#include "flang/Optimizer/Dialect/FIRAttr.h" +#include "flang/Optimizer/Dialect/FIRDialect.h" +#include "flang/Optimizer/Dialect/FIROps.h" +#include "flang/Optimizer/Support/FIRContext.h" +#include "flang/Optimizer/Support/FatalError.h" +#include "flang/Optimizer/Support/InternalNames.h" +#include "flang/Optimizer/Transforms/Passes.h" +#include "flang/Parser/parse-tree.h" +#include "flang/Runtime/iostat.h" +#include "mlir/Dialect/LLVMIR/LLVMDialect.h" +#include "mlir/Dialect/StandardOps/IR/Ops.h" +#include "mlir/IR/PatternMatch.h" +#include "mlir/Parser.h" +#include "mlir/Target/LLVMIR/Import.h" +#include "mlir/Transforms/RegionUtils.h" +#include "llvm/Support/CommandLine.h" +#include "llvm/Support/Debug.h" +#include "llvm/Support/ErrorHandling.h" + +#define DEBUG_TYPE "flang-lower-bridge" + +static llvm::cl::opt dumpBeforeFir( + "fdebug-dump-pre-fir", llvm::cl::init(false), + llvm::cl::desc("dump the Pre-FIR tree prior to FIR generation")); + +namespace { +/// Information for generating a structured or unstructured increment loop. +struct IncrementLoopInfo { + template + explicit IncrementLoopInfo(Fortran::semantics::Symbol &sym, const T &lower, + const T &upper, const std::optional &step, + bool isUnordered = false) + : loopVariableSym{sym}, lowerExpr{Fortran::semantics::GetExpr(lower)}, + upperExpr{Fortran::semantics::GetExpr(upper)}, + stepExpr{Fortran::semantics::GetExpr(step)}, isUnordered{isUnordered} {} + + IncrementLoopInfo(IncrementLoopInfo &&) = default; + IncrementLoopInfo &operator=(IncrementLoopInfo &&x) { return x; } + + bool isStructured() const { return !headerBlock; } + + // Data members common to both structured and unstructured loops. + const Fortran::semantics::Symbol &loopVariableSym; + const Fortran::semantics::SomeExpr *lowerExpr; + const Fortran::semantics::SomeExpr *upperExpr; + const Fortran::semantics::SomeExpr *stepExpr; + const Fortran::semantics::SomeExpr *maskExpr = nullptr; + bool isUnordered; // do concurrent, forall + llvm::SmallVector localInitSymList; + llvm::SmallVector sharedSymList; + mlir::Value loopVariable = nullptr; + mlir::Value stepValue = nullptr; // possible uses in multiple blocks + + // Data members for structured loops. + fir::DoLoopOp doLoop = nullptr; + + // Data members for unstructured loops. + bool hasRealControl = false; + mlir::Value tripVariable = nullptr; + mlir::Block *headerBlock = nullptr; // loop entry and test block + mlir::Block *maskBlock = nullptr; // concurrent loop mask block + mlir::Block *bodyBlock = nullptr; // first loop body block + mlir::Block *exitBlock = nullptr; // loop exit target block +}; + +using IncrementLoopNestInfo = llvm::SmallVector; +} // namespace + +//===----------------------------------------------------------------------===// +// FirConverter +//===----------------------------------------------------------------------===// + +namespace { + +/// Traverse the pre-FIR tree (PFT) to generate the FIR dialect of MLIR. +class FirConverter : public Fortran::lower::AbstractConverter { +public: + explicit FirConverter(Fortran::lower::LoweringBridge &bridge) + : bridge{bridge}, foldingContext{bridge.createFoldingContext()} {} + virtual ~FirConverter() = default; + + /// Convert the PFT to FIR. + void run(Fortran::lower::pft::Program &pft) { + // Preliminary translation pass. + // - Declare all functions that have definitions so that definition + // signatures prevail over call site signatures. + // - Define module variables so they are available before lowering any + // function that may use them. + // - Translate block data programs so that common block definitions with + // data initializations take precedence over other definitions. + for (auto &u : pft.getUnits()) { + std::visit( + Fortran::common::visitors{ + [&](Fortran::lower::pft::FunctionLikeUnit &f) { + declareFunction(f); + }, + [&](Fortran::lower::pft::ModuleLikeUnit &m) { + lowerModuleVariables(m); + for (auto &f : m.nestedFunctions) + declareFunction(f); + }, + [&](Fortran::lower::pft::BlockDataUnit &b) { lowerBlockData(b); }, + [&](Fortran::lower::pft::CompilerDirectiveUnit &d) {}, + }, + u); + } + + // Primary translation pass. + for (auto &u : pft.getUnits()) { + std::visit( + Fortran::common::visitors{ + [&](Fortran::lower::pft::FunctionLikeUnit &f) { lowerFunc(f); }, + [&](Fortran::lower::pft::ModuleLikeUnit &m) { lowerMod(m); }, + [&](Fortran::lower::pft::BlockDataUnit &b) {}, + [&](Fortran::lower::pft::CompilerDirectiveUnit &d) { + setCurrentPosition( + d.get().source); + mlir::emitWarning(toLocation(), + "ignoring all compiler directives"); + }, + }, + u); + } + } + + /// Declare a function. + void declareFunction(Fortran::lower::pft::FunctionLikeUnit &funit) { + setCurrentPosition(funit.getStartingSourceLoc()); + for (int entryIndex = 0, last = funit.entryPointList.size(); + entryIndex < last; ++entryIndex) { + funit.setActiveEntry(entryIndex); + // Calling CalleeInterface ctor will build a declaration mlir::FuncOp with + // no other side effects. + // TODO: when doing some compiler profiling on real apps, it may be worth + // to check it's better to save the CalleeInterface instead of recomputing + // it later when lowering the body. CalleeInterface ctor should be linear + // with the number of arguments, so it is not awful to do it that way for + // now, but the linear coefficient might be non negligible. Until + // measured, stick to the solution that impacts the code less. + Fortran::lower::CalleeInterface{funit, *this}; + } + funit.setActiveEntry(0); + + // Compute the set of host associated entities from the nested functions. + llvm::SetVector escapeHost; + for (auto &f : funit.nestedFunctions) + collectHostAssociatedVariables(f, escapeHost); + funit.setHostAssociatedSymbols(escapeHost); + + // Declare internal procedures + for (auto &f : funit.nestedFunctions) + declareFunction(f); + } + + /// Return the host symbol if \p sym is a symbol inside an internal procedure + /// of a variable that belongs to the host procedure. + const Fortran::semantics::Symbol * + getIfHostProcedureSymbol(const Fortran::semantics::Symbol &sym) { + if (const auto *details = + sym.detailsIf()) { + const auto &ultimateSym = details->symbol().GetUltimate(); + const auto &refScope = Fortran::semantics::GetProgramUnitContaining(sym); + const auto &owningScope = + Fortran::semantics::GetProgramUnitContaining(ultimateSym); + if (refScope != owningScope && !owningScope.IsModule()) + return &ultimateSym; + } + return nullptr; + } + + /// Collects the canonical list of all host associated symbols. These bindings + /// must be aggregated into a tuple which can then be added to each of the + /// internal procedure declarations and passed at each call site. + void collectHostAssociatedVariables( + Fortran::lower::pft::FunctionLikeUnit &funit, + llvm::SetVector &escapees) { + for (const auto &var : funit.getOrderedSymbolTable()) { + const auto &sym = var.getSymbol(); + if (const auto *escapingSym = getIfHostProcedureSymbol(sym)) { + LLVM_DEBUG(llvm::dbgs() << "host associated symbol " << sym << '\n'); + escapees.insert(escapingSym); + } + } + } + + //===--------------------------------------------------------------------===// + // AbstractConverter overrides + //===--------------------------------------------------------------------===// + + mlir::Value getSymbolAddress(Fortran::lower::SymbolRef sym) override final { + return lookupSymbol(sym).getAddr(); + } + + mlir::Value impliedDoBinding(llvm::StringRef name) override final { + auto val = localSymbols.lookupImpliedDo(name); + if (!val) + fir::emitFatalError(toLocation(), "ac-do-variable has no binding"); + return val; + } + + void copySymbolBinding(Fortran::lower::SymbolRef src, + Fortran::lower::SymbolRef target) override final { + localSymbols.addSymbol(target, lookupSymbol(src).toExtendedValue()); + } + + bool bindSymbol(Fortran::lower::SymbolRef sym, + const fir::ExtendedValue &exval) override final { + if (lookupSymbol(sym)) + return false; + localSymbols.addSymbol(sym, exval); + return true; + } + + bool lookupLabelSet(Fortran::lower::SymbolRef sym, + Fortran::lower::pft::LabelSet &labelSet) override final { + auto &owningProc = *getEval().getOwningProcedure(); + auto iter = owningProc.assignSymbolLabelMap.find(sym); + if (iter == owningProc.assignSymbolLabelMap.end()) + return false; + labelSet = iter->second; + return true; + } + + Fortran::lower::pft::Evaluation * + lookupLabel(Fortran::lower::pft::Label label) override final { + auto &owningProc = *getEval().getOwningProcedure(); + auto iter = owningProc.labelEvaluationMap.find(label); + if (iter == owningProc.labelEvaluationMap.end()) + return nullptr; + return iter->second; + } + + fir::ExtendedValue genExprAddr(const Fortran::lower::SomeExpr &expr, + Fortran::lower::StatementContext &context, + mlir::Location *loc = nullptr) override final { + return createSomeExtendedAddress(loc ? *loc : toLocation(), *this, expr, + localSymbols, context); + } + fir::ExtendedValue + genExprValue(const Fortran::lower::SomeExpr &expr, + Fortran::lower::StatementContext &context, + mlir::Location *loc = nullptr) override final { + return createSomeExtendedExpression(loc ? *loc : toLocation(), *this, expr, + localSymbols, context); + } + fir::MutableBoxValue + genExprMutableBox(mlir::Location loc, + const Fortran::lower::SomeExpr &expr) override final { + return createMutableBox(loc, *this, expr, localSymbols); + } + fir::ExtendedValue genExprBox(const Fortran::lower::SomeExpr &expr, + Fortran::lower::StatementContext &context, + mlir::Location loc) override final { + if (expr.Rank() > 0 && Fortran::evaluate::IsVariable(expr) && + !Fortran::evaluate::HasVectorSubscript(expr)) + return createSomeArrayBox(*this, expr, localSymbols, context); + return fir::BoxValue( + builder->createBox(loc, genExprAddr(expr, context, &loc))); + } + + Fortran::evaluate::FoldingContext &getFoldingContext() override final { + return foldingContext; + } + + mlir::Type genType(const Fortran::lower::SomeExpr &expr) override final { + return Fortran::lower::translateSomeExprToFIRType(*this, expr); + } + mlir::Type genType(const Fortran::lower::pft::Variable &var) override final { + return Fortran::lower::translateVariableToFIRType(*this, var); + } + mlir::Type genType(Fortran::lower::SymbolRef sym) override final { + return Fortran::lower::translateSymbolToFIRType(*this, sym); + } + mlir::Type + genType(Fortran::common::TypeCategory tc, int kind, + llvm::ArrayRef lenParameters) override final { + return Fortran::lower::getFIRType(&getMLIRContext(), tc, kind, + lenParameters); + } + mlir::Type + genType(const Fortran::semantics::DerivedTypeSpec &tySpec) override final { + return Fortran::lower::translateDerivedTypeToFIRType(*this, tySpec); + } + mlir::Type genType(Fortran::common::TypeCategory tc) override final { + return Fortran::lower::getFIRType( + &getMLIRContext(), tc, bridge.getDefaultKinds().GetDefaultKind(tc), + llvm::None); + } + + bool createHostAssociateVarClone( + const Fortran::semantics::Symbol &sym) override final { + auto loc = genLocation(sym.name()); + const auto *details = sym.detailsIf(); + assert(details != nullptr && "No host-association found"); + const Fortran::semantics::Symbol &hsym = details->symbol(); + Fortran::lower::SymbolBox hsb = lookupSymbol(hsym); + + auto allocate = [&](llvm::ArrayRef shape, + llvm::ArrayRef typeParams) -> mlir::Value { + mlir::Type symType = genType(sym); + return builder->allocateLocal( + loc, symType, mangleName(sym), toStringRef(sym.GetUltimate().name()), + shape, typeParams, + sym.GetUltimate().attrs().test(Fortran::semantics::Attr::TARGET)); + }; + + auto getExtendedValue = [&](Fortran::lower::SymbolBox sb) { + return sb.match( + [&](const Fortran::lower::SymbolBox::PointerOrAllocatable &box) { + return fir::factory::genMutableBoxRead(*builder, loc, box); + }, + [&sb](auto &) { return sb.toExtendedValue(); }); + }; + + fir::ExtendedValue hexv = getExtendedValue(hsb); + auto exval = hexv.match( + [&](const fir::BoxValue &box) -> fir::ExtendedValue { + const auto *type = sym.GetType(); + if (type && type->IsPolymorphic()) + TODO(loc, "create polymorphic host associated copy"); + // Create a contiguous temp with the same shape and length as + // the original variable described by a fir.box. + auto extents = fir::factory::getExtents(*builder, loc, hexv); + if (box.isDerivedWithLengthParameters()) + TODO(loc, "get length parameters from derived type BoxValue"); + if (box.isCharacter()) { + auto len = fir::factory::readCharLen(*builder, loc, box); + auto temp = allocate(extents, {len}); + return fir::CharArrayBoxValue{temp, len, extents}; + } + return fir::ArrayBoxValue{allocate(extents, {}), extents}; + }, + [&](const fir::MutableBoxValue &box) -> fir::ExtendedValue { + // Allocate storage for a pointer/allocatble descriptor. + // No shape/lengths to be passed to the alloca. + return fir::MutableBoxValue(allocate({}, {}), + box.nonDeferredLenParams(), {}); + }, + [&](const auto &) -> fir::ExtendedValue { + auto temp = allocate(fir::factory::getExtents(*builder, loc, hexv), + fir::getTypeParams(hexv)); + return fir::substBase(hexv, temp); + }); + return bindSymbol(sym, exval); + } + + mlir::Location getCurrentLocation() override final { return toLocation(); } + + /// Generate a dummy location. + mlir::Location genLocation() override final { + // Note: builder may not be instantiated yet + return mlir::UnknownLoc::get(&getMLIRContext()); + } + + /// Generate a `Location` from the `CharBlock`. + mlir::Location + genLocation(const Fortran::parser::CharBlock &block) override final { + if (const auto *cooked = bridge.getCookedSource()) { + auto loc = cooked->GetSourcePositionRange(block); + if (loc.has_value()) { + // loc is a pair (begin, end); use the beginning position + auto &filePos = loc->first; + return mlir::FileLineColLoc::get(&getMLIRContext(), filePos.file.path(), + filePos.line, filePos.column); + } + } + return genLocation(); + } + + fir::FirOpBuilder &getFirOpBuilder() override final { return *builder; } + + mlir::ModuleOp &getModuleOp() override final { return bridge.getModule(); } + + mlir::MLIRContext &getMLIRContext() override final { + return bridge.getMLIRContext(); + } + std::string + mangleName(const Fortran::semantics::Symbol &symbol) override final { + return Fortran::lower::mangle::mangleName(symbol); + } + + fir::KindMapping &getKindMap() override final { return bridge.getKindMap(); } + + mlir::Value hostAssocTupleValue() override final { return hostAssocTuple; } + + /// Record a binding for the ssa-value of the tuple for this function. + void bindHostAssocTuple(mlir::Value val) override final { + assert(!hostAssocTuple && val); + hostAssocTuple = val; + } + +private: + FirConverter() = delete; + FirConverter(const FirConverter &) = delete; + FirConverter &operator=(const FirConverter &) = delete; + + //===--------------------------------------------------------------------===// + // Helper member functions + //===--------------------------------------------------------------------===// + + mlir::Value createFIRExpr(mlir::Location loc, + const Fortran::semantics::SomeExpr *expr, + Fortran::lower::StatementContext &stmtCtx) { + return fir::getBase(genExprValue(*expr, stmtCtx, &loc)); + } + + /// Find the symbol in the local map or return null. + Fortran::lower::SymbolBox + lookupSymbol(const Fortran::semantics::Symbol &sym) { + if (auto v = localSymbols.lookupSymbol(sym)) + return v; + return {}; + } + + /// Add the symbol to the local map. If the symbol is already in the map, it + /// is not updated. Instead the value `false` is returned. + bool addSymbol(const Fortran::semantics::SymbolRef sym, mlir::Value val, + bool forced = false) { + if (!forced && lookupSymbol(sym)) + return false; + localSymbols.addSymbol(sym, val, forced); + return true; + } + + bool addCharSymbol(const Fortran::semantics::SymbolRef sym, mlir::Value val, + mlir::Value len, bool forced = false) { + if (!forced && lookupSymbol(sym)) + return false; + // TODO: ensure val type is fir.array> like. Insert + // cast if needed. + localSymbols.addCharSymbol(sym, val, len, forced); + return true; + } + + mlir::Value createTemp(mlir::Location loc, + const Fortran::semantics::Symbol &sym, + llvm::ArrayRef shape = {}) { + // FIXME: should return fir::ExtendedValue + if (auto v = lookupSymbol(sym)) + return v.getAddr(); + auto newVal = builder->createTemporary(loc, genType(sym), + toStringRef(sym.name()), shape); + addSymbol(sym, newVal); + return newVal; + } + + bool isNumericScalarCategory(Fortran::common::TypeCategory cat) { + return cat == Fortran::common::TypeCategory::Integer || + cat == Fortran::common::TypeCategory::Real || + cat == Fortran::common::TypeCategory::Complex || + cat == Fortran::common::TypeCategory::Logical; + } + bool isLogicalCategory(Fortran::common::TypeCategory cat) { + return cat == Fortran::common::TypeCategory::Logical; + } + bool isCharacterCategory(Fortran::common::TypeCategory cat) { + return cat == Fortran::common::TypeCategory::Character; + } + bool isDerivedCategory(Fortran::common::TypeCategory cat) { + return cat == Fortran::common::TypeCategory::Derived; + } + + /// Insert a new block before \p block. Leave the insertion point unchanged. + mlir::Block *insertBlock(mlir::Block *block) { + auto insertPt = builder->saveInsertionPoint(); + auto newBlock = builder->createBlock(block); + builder->restoreInsertionPoint(insertPt); + return newBlock; + } + + mlir::Block *blockOfLabel(Fortran::lower::pft::Evaluation &eval, + Fortran::parser::Label label) { + const auto &labelEvaluationMap = + eval.getOwningProcedure()->labelEvaluationMap; + const auto iter = labelEvaluationMap.find(label); + assert(iter != labelEvaluationMap.end() && "label missing from map"); + auto *block = iter->second->block; + assert(block && "missing labeled evaluation block"); + return block; + } + + void genFIRBranch(mlir::Block *targetBlock) { + assert(targetBlock && "missing unconditional target block"); + builder->create(toLocation(), targetBlock); + } + + void genFIRConditionalBranch(mlir::Value cond, mlir::Block *trueTarget, + mlir::Block *falseTarget) { + assert(trueTarget && "missing conditional branch true block"); + assert(falseTarget && "missing conditional branch false block"); + auto loc = toLocation(); + auto bcc = builder->createConvert(loc, builder->getI1Type(), cond); + builder->create(loc, bcc, trueTarget, llvm::None, + falseTarget, llvm::None); + } + void genFIRConditionalBranch(mlir::Value cond, + Fortran::lower::pft::Evaluation *trueTarget, + Fortran::lower::pft::Evaluation *falseTarget) { + genFIRConditionalBranch(cond, trueTarget->block, falseTarget->block); + } + void genFIRConditionalBranch(const Fortran::parser::ScalarLogicalExpr &expr, + mlir::Block *trueTarget, + mlir::Block *falseTarget) { + Fortran::lower::StatementContext stmtCtx; + mlir::Value cond = + createFIRExpr(toLocation(), Fortran::semantics::GetExpr(expr), stmtCtx); + stmtCtx.finalize(); + genFIRConditionalBranch(cond, trueTarget, falseTarget); + } + void genFIRConditionalBranch(const Fortran::parser::ScalarLogicalExpr &expr, + Fortran::lower::pft::Evaluation *trueTarget, + Fortran::lower::pft::Evaluation *falseTarget) { + Fortran::lower::StatementContext stmtCtx; + auto cond = + createFIRExpr(toLocation(), Fortran::semantics::GetExpr(expr), stmtCtx); + stmtCtx.finalize(); + genFIRConditionalBranch(cond, trueTarget->block, falseTarget->block); + } + + //===--------------------------------------------------------------------===// + // Termination of symbolically referenced execution units + //===--------------------------------------------------------------------===// + + /// END of program + /// + /// Generate the cleanup block before the program exits + void genExitRoutine() { + if (blockIsUnterminated()) + builder->create(toLocation()); + } + void genFIR(const Fortran::parser::EndProgramStmt &) { genExitRoutine(); } + + /// END of procedure-like constructs + /// + /// Generate the cleanup block before the procedure exits + void genReturnSymbol(const Fortran::semantics::Symbol &functionSymbol) { + const auto &resultSym = + functionSymbol.get().result(); + auto resultSymBox = lookupSymbol(resultSym); + auto loc = toLocation(); + if (!resultSymBox) { + mlir::emitError(loc, "failed lowering function return"); + return; + } + auto resultVal = resultSymBox.match( + [&](const fir::CharBoxValue &x) -> mlir::Value { + return fir::factory::CharacterExprHelper{*builder, loc} + .createEmboxChar(x.getBuffer(), x.getLen()); + }, + [&](const auto &) -> mlir::Value { + auto resultRef = resultSymBox.getAddr(); + auto resultType = genType(resultSym); + mlir::Type resultRefType = builder->getRefType(resultType); + // A function with multiple entry points returning different types + // tags all result variables with one of the largest types to allow + // them to share the same storage. Convert this to the actual type. + if (resultRef.getType() != resultRefType) + resultRef = builder->createConvert(loc, resultRefType, resultRef); + return builder->create(loc, resultRef); + }); + builder->create(loc, resultVal); + } + + /// Get the return value of a call to \p symbol, which is a subroutine entry + /// point that has alternative return specifiers. + const mlir::Value + getAltReturnResult(const Fortran::semantics::Symbol &symbol) { + assert(Fortran::semantics::HasAlternateReturns(symbol) && + "subroutine does not have alternate returns"); + return getSymbolAddress(symbol); + } + + void genFIRProcedureExit(Fortran::lower::pft::FunctionLikeUnit &funit, + const Fortran::semantics::Symbol &symbol) { + if (auto *finalBlock = funit.finalBlock) { + // The current block must end with a terminator. + if (blockIsUnterminated()) + builder->create(toLocation(), finalBlock); + // Set insertion point to final block. + builder->setInsertionPoint(finalBlock, finalBlock->end()); + } + if (Fortran::semantics::IsFunction(symbol)) { + genReturnSymbol(symbol); + } else if (Fortran::semantics::HasAlternateReturns(symbol)) { + mlir::Value retval = builder->create( + toLocation(), getAltReturnResult(symbol)); + builder->create(toLocation(), retval); + } else { + genExitRoutine(); + } + } + + // + // Statements that have control-flow semantics + // + + /// Generate an If[Then]Stmt condition or its negation. + template + mlir::Value genIfCondition(const A *stmt, bool negate = false) { + auto loc = toLocation(); + Fortran::lower::StatementContext stmtCtx; + auto condExpr = createFIRExpr( + loc, + Fortran::semantics::GetExpr( + std::get(stmt->t)), + stmtCtx); + stmtCtx.finalize(); + auto cond = builder->createConvert(loc, builder->getI1Type(), condExpr); + if (negate) + cond = builder->create( + loc, cond, builder->createIntegerConstant(loc, cond.getType(), 1)); + return cond; + } + + mlir::FuncOp getFunc(llvm::StringRef name, mlir::FunctionType ty) { + if (auto func = builder->getNamedFunction(name)) { + assert(func.getType() == ty); + return func; + } + return builder->createFunction(toLocation(), name, ty); + } + + /// Lowering of CALL statement + void genFIR(const Fortran::parser::CallStmt &stmt) { + Fortran::lower::StatementContext stmtCtx; + auto &eval = getEval(); + setCurrentPosition(stmt.v.source); + assert(stmt.typedCall && "Call was not analyzed"); + // Call statement lowering shares code with function call lowering. + Fortran::semantics::SomeExpr expr{*stmt.typedCall}; + auto res = Fortran::lower::createSubroutineCall( + *this, expr, localSymbols, stmtCtx, /*isUserDefAssignment=*/false); + if (!res) + return; // "Normal" subroutine call. + // Call with alternate return specifiers. + // The call returns an index that selects an alternate return branch target. + llvm::SmallVector indexList; + llvm::SmallVector blockList; + int64_t index = 0; + for (const auto &arg : + std::get>(stmt.v.t)) { + const auto &actual = std::get(arg.t); + if (const auto *altReturn = + std::get_if(&actual.u)) { + indexList.push_back(++index); + blockList.push_back(blockOfLabel(eval, altReturn->v)); + } + } + blockList.push_back(eval.nonNopSuccessor().block); // default = fallthrough + stmtCtx.finalize(); + builder->create(toLocation(), res, indexList, blockList); + } + + void genFIR(const Fortran::parser::ComputedGotoStmt &stmt) { + Fortran::lower::StatementContext stmtCtx; + auto &eval = getEval(); + auto selectExpr = + createFIRExpr(toLocation(), + Fortran::semantics::GetExpr( + std::get(stmt.t)), + stmtCtx); + stmtCtx.finalize(); + llvm::SmallVector indexList; + llvm::SmallVector blockList; + int64_t index = 0; + for (auto &label : std::get>(stmt.t)) { + indexList.push_back(++index); + blockList.push_back(blockOfLabel(eval, label)); + } + blockList.push_back(eval.nonNopSuccessor().block); // default + builder->create(toLocation(), selectExpr, indexList, + blockList); + } + + void genFIR(const Fortran::parser::ArithmeticIfStmt &stmt) { + Fortran::lower::StatementContext stmtCtx; + auto &eval = getEval(); + auto expr = createFIRExpr( + toLocation(), + Fortran::semantics::GetExpr(std::get(stmt.t)), + stmtCtx); + stmtCtx.finalize(); + auto exprType = expr.getType(); + auto loc = toLocation(); + if (exprType.isSignlessInteger()) { + // Arithmetic expression has Integer type. Generate a SelectCaseOp + // with ranges {(-inf:-1], 0=default, [1:inf)}. + MLIRContext *context = builder->getContext(); + llvm::SmallVector attrList; + llvm::SmallVector valueList; + llvm::SmallVector blockList; + attrList.push_back(fir::UpperBoundAttr::get(context)); + valueList.push_back(builder->createIntegerConstant(loc, exprType, -1)); + blockList.push_back(blockOfLabel(eval, std::get<1>(stmt.t))); + attrList.push_back(fir::LowerBoundAttr::get(context)); + valueList.push_back(builder->createIntegerConstant(loc, exprType, 1)); + blockList.push_back(blockOfLabel(eval, std::get<3>(stmt.t))); + attrList.push_back(mlir::UnitAttr::get(context)); // 0 is the "default" + blockList.push_back(blockOfLabel(eval, std::get<2>(stmt.t))); + builder->create(loc, expr, attrList, valueList, + blockList); + return; + } + // Arithmetic expression has Real type. Generate + // sum = expr + expr [ raise an exception if expr is a NaN ] + // if (sum < 0.0) goto L1 else if (sum > 0.0) goto L3 else goto L2 + auto sum = builder->create(loc, expr, expr); + auto zero = builder->create( + loc, exprType, builder->getFloatAttr(exprType, 0.0)); + auto cond1 = + builder->create(loc, mlir::CmpFPredicate::OLT, sum, zero); + auto *elseIfBlock = + builder->getBlock()->splitBlock(builder->getInsertionPoint()); + genFIRConditionalBranch(cond1, blockOfLabel(eval, std::get<1>(stmt.t)), + elseIfBlock); + startBlock(elseIfBlock); + auto cond2 = + builder->create(loc, mlir::CmpFPredicate::OGT, sum, zero); + genFIRConditionalBranch(cond2, blockOfLabel(eval, std::get<3>(stmt.t)), + blockOfLabel(eval, std::get<2>(stmt.t))); + } + + void genFIR(const Fortran::parser::AssignedGotoStmt &stmt) { + // Program requirement 1990 8.2.4 - + // + // At the time of execution of an assigned GOTO statement, the integer + // variable must be defined with the value of a statement label of a + // branch target statement that appears in the same scoping unit. + // Note that the variable may be defined with a statement label value + // only by an ASSIGN statement in the same scoping unit as the assigned + // GOTO statement. + + auto loc = toLocation(); + auto &eval = getEval(); + const auto &symbolLabelMap = + eval.getOwningProcedure()->assignSymbolLabelMap; + const auto &symbol = *std::get(stmt.t).symbol; + auto selectExpr = + builder->create(loc, getSymbolAddress(symbol)); + auto iter = symbolLabelMap.find(symbol); + if (iter == symbolLabelMap.end()) { + // Fail for a nonconforming program unit that does not have any ASSIGN + // statements. The front end should check for this. + mlir::emitError(loc, "(semantics issue) no assigned goto targets"); + exit(1); + } + auto labelSet = iter->second; + llvm::SmallVector indexList; + llvm::SmallVector blockList; + auto addLabel = [&](Fortran::parser::Label label) { + indexList.push_back(label); + blockList.push_back(blockOfLabel(eval, label)); + }; + // Add labels from an explicit list. The list may have duplicates. + for (auto &label : std::get>(stmt.t)) { + if (labelSet.count(label) && + std::find(indexList.begin(), indexList.end(), label) == + indexList.end()) { // ignore duplicates + addLabel(label); + } + } + // Absent an explicit list, add all possible label targets. + if (indexList.empty()) + for (auto &label : labelSet) + addLabel(label); + // Add a nop/fallthrough branch to the switch for a nonconforming program + // unit that violates the program requirement above. + blockList.push_back(eval.nonNopSuccessor().block); // default + builder->create(loc, selectExpr, indexList, blockList); + } + + /// Collect DO CONCURRENT or FORALL loop control information. + IncrementLoopNestInfo getConcurrentControl( + const Fortran::parser::ConcurrentHeader &header, + const std::list &localityList = {}) { + IncrementLoopNestInfo incrementLoopNestInfo; + for (const auto &control : + std::get>(header.t)) + incrementLoopNestInfo.emplace_back( + *std::get<0>(control.t).symbol, std::get<1>(control.t), + std::get<2>(control.t), std::get<3>(control.t), true); + auto &info = incrementLoopNestInfo.back(); + info.maskExpr = Fortran::semantics::GetExpr( + std::get>(header.t)); + for (const auto &x : localityList) { + if (const auto *localInitList = + std::get_if(&x.u)) + for (const auto &x : localInitList->v) + info.localInitSymList.push_back(x.symbol); + if (const auto *sharedList = + std::get_if(&x.u)) + for (const auto &x : sharedList->v) + info.sharedSymList.push_back(x.symbol); + if (std::get_if(&x.u)) + TODO(toLocation(), "do concurrent locality specs not implemented"); + } + return incrementLoopNestInfo; + } + + /// Generate FIR for a DO construct. There are six variants: + /// - unstructured infinite and while loops + /// - structured and unstructured increment loops + /// - structured and unstructured concurrent loops + void genFIR(const Fortran::parser::DoConstruct &doConstruct) { + setCurrentPosition(Fortran::parser::FindSourceLocation(doConstruct)); + // Collect loop nest information. + // Generate begin loop code directly for infinite and while loops. + auto &eval = getEval(); + bool unstructuredContext = eval.lowerAsUnstructured(); + auto &doStmtEval = eval.getFirstNestedEvaluation(); + auto *doStmt = doStmtEval.getIf(); + const auto &loopControl = + std::get>(doStmt->t); + auto *preheaderBlock = doStmtEval.block; + auto *beginBlock = preheaderBlock ? preheaderBlock : builder->getBlock(); + auto createNextBeginBlock = [&]() { + // Step beginBlock through unstructured preheader, header, and mask + // blocks, created in outermost to innermost order. + return beginBlock = beginBlock->splitBlock(beginBlock->end()); + }; + auto *headerBlock = unstructuredContext ? createNextBeginBlock() : nullptr; + auto *bodyBlock = doStmtEval.lexicalSuccessor->block; + auto *exitBlock = doStmtEval.parentConstruct->constructExit->block; + IncrementLoopNestInfo incrementLoopNestInfo; + const Fortran::parser::ScalarLogicalExpr *whileCondition = nullptr; + bool infiniteLoop = !loopControl.has_value(); + if (infiniteLoop) { + assert(unstructuredContext && "infinite loop must be unstructured"); + startBlock(headerBlock); + } else if ((whileCondition = + std::get_if( + &loopControl->u))) { + assert(unstructuredContext && "while loop must be unstructured"); + maybeStartBlock(preheaderBlock); // no block or empty block + startBlock(headerBlock); + genFIRConditionalBranch(*whileCondition, bodyBlock, exitBlock); + } else if (const auto *bounds = + std::get_if( + &loopControl->u)) { + // Non-concurrent increment loop. + auto &info = incrementLoopNestInfo.emplace_back( + *bounds->name.thing.symbol, bounds->lower, bounds->upper, + bounds->step); + if (unstructuredContext) { + maybeStartBlock(preheaderBlock); + info.hasRealControl = info.loopVariableSym.GetType()->IsNumeric( + Fortran::common::TypeCategory::Real); + info.headerBlock = headerBlock; + info.bodyBlock = bodyBlock; + info.exitBlock = exitBlock; + } + } else { + const auto *concurrent = + std::get_if( + &loopControl->u); + assert(concurrent && "invalid DO loop variant"); + incrementLoopNestInfo = getConcurrentControl( + std::get(concurrent->t), + std::get>(concurrent->t)); + if (unstructuredContext) { + maybeStartBlock(preheaderBlock); + for (auto &info : incrementLoopNestInfo) { + // The original loop body provides the body and latch blocks of the + // innermost dimension. The (first) body block of a non-innermost + // dimension is the preheader block of the immediately enclosed + // dimension. The latch block of a non-innermost dimension is the + // exit block of the immediately enclosed dimension. + auto createNextExitBlock = [&]() { + // Create unstructured loop exit blocks, outermost to innermost. + return exitBlock = insertBlock(exitBlock); + }; + auto isInnermost = &info == &incrementLoopNestInfo.back(); + auto isOutermost = &info == &incrementLoopNestInfo.front(); + info.headerBlock = isOutermost ? headerBlock : createNextBeginBlock(); + info.bodyBlock = isInnermost ? bodyBlock : createNextBeginBlock(); + info.exitBlock = isOutermost ? exitBlock : createNextExitBlock(); + if (info.maskExpr) + info.maskBlock = createNextBeginBlock(); + } + } + } + + // Increment loop begin code. (Infinite/while code was already generated.) + if (!infiniteLoop && !whileCondition) + genFIRIncrementLoopBegin(incrementLoopNestInfo); + + // Loop body code - NonLabelDoStmt and EndDoStmt code is generated here. + // Their genFIR calls are nops except for block management in some cases. + for (auto &e : eval.getNestedEvaluations()) + genFIR(e, unstructuredContext); + + // Loop end code. + if (infiniteLoop || whileCondition) + genFIRBranch(headerBlock); + else + genFIRIncrementLoopEnd(incrementLoopNestInfo); + } + + /// Generate FIR to begin a structured or unstructured increment loop nest. + void genFIRIncrementLoopBegin(IncrementLoopNestInfo &incrementLoopNestInfo) { + assert(!incrementLoopNestInfo.empty() && "empty loop nest"); + auto loc = toLocation(); + auto controlType = incrementLoopNestInfo[0].isStructured() + ? builder->getIndexType() + : genType(incrementLoopNestInfo[0].loopVariableSym); + auto hasRealControl = incrementLoopNestInfo[0].hasRealControl; + auto genControlValue = [&](const Fortran::semantics::SomeExpr *expr) { + Fortran::lower::StatementContext stmtCtx; + if (expr) + return builder->createConvert(loc, controlType, + createFIRExpr(loc, expr, stmtCtx)); + if (hasRealControl) + return builder->createRealConstant(loc, controlType, 1u); + return builder->createIntegerConstant(loc, controlType, 1); // step + }; + auto handleLocalitySpec = [&](IncrementLoopInfo &info) { + // Generate Local Init Assignments + for (const auto *sym : info.localInitSymList) { + const auto *hostDetails = + sym->detailsIf(); + assert(hostDetails && "missing local_init variable host variable"); + [[maybe_unused]] const Fortran::semantics::Symbol &hostSym = + hostDetails->symbol(); + TODO(loc, "do concurrent locality specs not implemented"); + // assign sym = hostSym + } + // Handle shared locality spec + for (const auto *sym : info.sharedSymList) { + const auto *hostDetails = + sym->detailsIf(); + assert(hostDetails && "missing shared variable host variable"); + const Fortran::semantics::Symbol &hostSym = hostDetails->symbol(); + copySymbolBinding(hostSym, *sym); + } + }; + for (auto &info : incrementLoopNestInfo) { + info.loopVariable = createTemp(loc, info.loopVariableSym); + auto lowerValue = genControlValue(info.lowerExpr); + auto upperValue = genControlValue(info.upperExpr); + info.stepValue = genControlValue(info.stepExpr); + + // Structured loop - generate fir.do_loop. + if (info.isStructured()) { + info.doLoop = builder->create( + loc, lowerValue, upperValue, info.stepValue, info.isUnordered, + /*finalCountValue=*/!info.isUnordered); + builder->setInsertionPointToStart(info.doLoop.getBody()); + // Update the loop variable value, as it may have non-index references. + auto value = builder->createConvert(loc, genType(info.loopVariableSym), + info.doLoop.getInductionVar()); + builder->create(loc, value, info.loopVariable); + if (info.maskExpr) { + Fortran::lower::StatementContext stmtCtx; + auto maskCond = createFIRExpr(loc, info.maskExpr, stmtCtx); + stmtCtx.finalize(); + auto maskCondCast = + builder->createConvert(loc, builder->getI1Type(), maskCond); + auto ifOp = builder->create(loc, maskCondCast, + /*withElseRegion=*/false); + builder->setInsertionPointToStart(&ifOp.thenRegion().front()); + } + handleLocalitySpec(info); + continue; + } + + // Unstructured loop preheader - initialize tripVariable and loopVariable. + mlir::Value tripCount; + if (info.hasRealControl) { + auto diff1 = builder->create(loc, upperValue, lowerValue); + auto diff2 = builder->create(loc, diff1, info.stepValue); + tripCount = builder->create(loc, diff2, info.stepValue); + controlType = builder->getIndexType(); + tripCount = builder->createConvert(loc, controlType, tripCount); + } else { + auto diff1 = builder->create(loc, upperValue, lowerValue); + auto diff2 = builder->create(loc, diff1, info.stepValue); + tripCount = + builder->create(loc, diff2, info.stepValue); + } + if (fir::isAlwaysExecuteLoopBody()) { // minimum tripCount is 1 + auto one = builder->createIntegerConstant(loc, controlType, 1); + auto cond = builder->create(loc, CmpIPredicate::slt, + tripCount, one); + tripCount = builder->create(loc, cond, one, tripCount); + } + info.tripVariable = builder->createTemporary(loc, controlType); + builder->create(loc, tripCount, info.tripVariable); + builder->create(loc, lowerValue, info.loopVariable); + + // Unstructured loop header - generate loop condition and mask. + // Note - Currently there is no way to tag a loop as a concurrent loop. + startBlock(info.headerBlock); + tripCount = builder->create(loc, info.tripVariable); + auto zero = builder->createIntegerConstant(loc, controlType, 0); + auto cond = builder->create(loc, mlir::CmpIPredicate::sgt, + tripCount, zero); + if (info.maskExpr) { + genFIRConditionalBranch(cond, info.maskBlock, info.exitBlock); + startBlock(info.maskBlock); + auto latchBlock = getEval().getLastNestedEvaluation().block; + assert(latchBlock && "missing masked concurrent loop latch block"); + Fortran::lower::StatementContext stmtCtx; + auto maskCond = createFIRExpr(loc, info.maskExpr, stmtCtx); + stmtCtx.finalize(); + genFIRConditionalBranch(maskCond, info.bodyBlock, latchBlock); + } else { + genFIRConditionalBranch(cond, info.bodyBlock, info.exitBlock); + if (&info != &incrementLoopNestInfo.back()) // not innermost + startBlock(info.bodyBlock); // preheader block of enclosed dimension + } + if (!info.localInitSymList.empty()) { + auto insertPt = builder->saveInsertionPoint(); + builder->setInsertionPointToStart(info.bodyBlock); + handleLocalitySpec(info); + builder->restoreInsertionPoint(insertPt); + } + } + } + + /// Generate FIR to end a structured or unstructured increment loop nest. + void genFIRIncrementLoopEnd(IncrementLoopNestInfo &incrementLoopNestInfo) { + assert(!incrementLoopNestInfo.empty() && "empty loop nest"); + auto loc = toLocation(); + for (auto it = incrementLoopNestInfo.rbegin(), + rend = incrementLoopNestInfo.rend(); + it != rend; ++it) { + auto &info = *it; + if (info.isStructured()) { + // End fir.do_loop. + if (!info.isUnordered) { + builder->setInsertionPointToEnd(info.doLoop.getBody()); + mlir::Value result = builder->create( + loc, info.doLoop.getInductionVar(), info.doLoop.step()); + builder->create(loc, result); + } + builder->setInsertionPointAfter(info.doLoop); + if (info.isUnordered) + continue; + // The loop control variable may be used after loop execution. + auto lcv = builder->createConvert(loc, genType(info.loopVariableSym), + info.doLoop.getResult(0)); + builder->create(loc, lcv, info.loopVariable); + continue; + } + + // Unstructured loop - decrement tripVariable and step loopVariable. + mlir::Value tripCount = + builder->create(loc, info.tripVariable); + auto tripVarType = info.hasRealControl ? builder->getIndexType() + : genType(info.loopVariableSym); + auto one = builder->createIntegerConstant(loc, tripVarType, 1); + tripCount = builder->create(loc, tripCount, one); + builder->create(loc, tripCount, info.tripVariable); + mlir::Value value = builder->create(loc, info.loopVariable); + if (info.hasRealControl) + value = builder->create(loc, value, info.stepValue); + else + value = builder->create(loc, value, info.stepValue); + builder->create(loc, value, info.loopVariable); + + genFIRBranch(info.headerBlock); + if (&info != &incrementLoopNestInfo.front()) // not outermost + startBlock(info.exitBlock); // latch block of enclosing dimension + } + } + + /// Generate structured or unstructured FIR for an IF construct. + /// The initial statement may be either an IfStmt or an IfThenStmt. + void genFIR(const Fortran::parser::IfConstruct &) { + auto loc = toLocation(); + auto &eval = getEval(); + if (eval.lowerAsStructured()) { + // Structured fir.if nest. + fir::IfOp topIfOp, currentIfOp; + for (auto &e : eval.getNestedEvaluations()) { + auto genIfOp = [&](mlir::Value cond) { + auto ifOp = builder->create(loc, cond, /*withElse=*/true); + builder->setInsertionPointToStart(&ifOp.thenRegion().front()); + return ifOp; + }; + if (auto *s = e.getIf()) { + topIfOp = currentIfOp = genIfOp(genIfCondition(s, e.negateCondition)); + } else if (auto *s = e.getIf()) { + topIfOp = currentIfOp = genIfOp(genIfCondition(s, e.negateCondition)); + } else if (auto *s = e.getIf()) { + builder->setInsertionPointToStart(¤tIfOp.elseRegion().front()); + currentIfOp = genIfOp(genIfCondition(s)); + } else if (e.isA()) { + builder->setInsertionPointToStart(¤tIfOp.elseRegion().front()); + } else if (e.isA()) { + builder->setInsertionPointAfter(topIfOp); + } else { + genFIR(e, /*unstructuredContext=*/false); + } + } + return; + } + + // Unstructured branch sequence. + for (auto &e : eval.getNestedEvaluations()) { + auto genIfBranch = [&](mlir::Value cond) { + if (e.lexicalSuccessor == e.controlSuccessor) // empty block -> exit + genFIRConditionalBranch(cond, e.parentConstruct->constructExit, + e.controlSuccessor); + else // non-empty block + genFIRConditionalBranch(cond, e.lexicalSuccessor, e.controlSuccessor); + }; + if (auto *s = e.getIf()) { + maybeStartBlock(e.block); + genIfBranch(genIfCondition(s, e.negateCondition)); + } else if (auto *s = e.getIf()) { + maybeStartBlock(e.block); + genIfBranch(genIfCondition(s, e.negateCondition)); + } else if (auto *s = e.getIf()) { + startBlock(e.block); + genIfBranch(genIfCondition(s)); + } else { + genFIR(e); + } + } + } + + void genFIR(const Fortran::parser::CaseConstruct &) { + for (auto &e : getEval().getNestedEvaluations()) + genFIR(e); + } + + template + void genNestedStatement(const Fortran::parser::Statement &stmt) { + setCurrentPosition(stmt.source); + genFIR(stmt.statement); + } + + /// Force the binding of an explicit symbol. This is used to bind and re-bind + /// a concurrent control symbol to its value. + void forceControlVariableBinding(const Fortran::semantics::Symbol *sym, + mlir::Value inducVar) { + auto loc = toLocation(); + assert(sym && "There must be a symbol to bind"); + auto toTy = genType(*sym); + // FIXME: this should be a "per iteration" temporary. + auto tmp = builder->createTemporary( + loc, toTy, toStringRef(sym->name()), + llvm::ArrayRef{ + Fortran::lower::getAdaptToByRefAttr(*builder)}); + auto cast = builder->createConvert(loc, toTy, inducVar); + builder->create(loc, cast, tmp); + localSymbols.addSymbol(*sym, tmp, /*force=*/true); + } + + /// Process a concurrent header for a FORALL. (Concurrent headers for DO + /// CONCURRENT loops are lowered elsewhere.) + void genFIR(const Fortran::parser::ConcurrentHeader &header) { + llvm::SmallVector lows; + llvm::SmallVector highs; + llvm::SmallVector steps; + if (explicitIterSpace.isOutermostForall()) { + // For the outermost forall, we evaluate the bounds expressions once. + // Contrastingly, if this forall is nested, the bounds expressions are + // assumed to be pure, possibly dependent on outer concurrent control + // variables, possibly variant with respect to arguments, and will be + // re-evaluated. + auto loc = toLocation(); + auto idxTy = builder->getIndexType(); + auto &stmtCtx = explicitIterSpace.stmtContext(); + auto lowerExpr = [&](auto &e) { + return fir::getBase(genExprValue(e, stmtCtx)); + }; + for (auto &ctrl : + std::get>(header.t)) { + const auto *lo = Fortran::semantics::GetExpr(std::get<1>(ctrl.t)); + const auto *hi = Fortran::semantics::GetExpr(std::get<2>(ctrl.t)); + auto &optStep = + std::get>(ctrl.t); + lows.push_back(builder->createConvert(loc, idxTy, lowerExpr(*lo))); + highs.push_back(builder->createConvert(loc, idxTy, lowerExpr(*hi))); + steps.push_back( + optStep.has_value() + ? builder->createConvert( + loc, idxTy, + lowerExpr(*Fortran::semantics::GetExpr(*optStep))) + : builder->createIntegerConstant(loc, idxTy, 1)); + } + } + auto lambda = [&, lows, highs, steps]() { + // Create our iteration space from the header spec. + auto loc = toLocation(); + auto idxTy = builder->getIndexType(); + llvm::SmallVector loops; + auto &stmtCtx = explicitIterSpace.stmtContext(); + auto lowerExpr = [&](auto &e) { + return fir::getBase(genExprValue(e, stmtCtx)); + }; + const auto outermost = !lows.empty(); + std::size_t headerIndex = 0; + for (auto &ctrl : + std::get>(header.t)) { + const auto *ctrlVar = std::get(ctrl.t).symbol; + mlir::Value lb; + mlir::Value ub; + mlir::Value by; + if (outermost) { + assert(headerIndex < lows.size()); + lb = lows[headerIndex]; + ub = highs[headerIndex]; + by = steps[headerIndex++]; + } else { + const auto *lo = Fortran::semantics::GetExpr(std::get<1>(ctrl.t)); + const auto *hi = Fortran::semantics::GetExpr(std::get<2>(ctrl.t)); + auto &optStep = + std::get>(ctrl.t); + lb = builder->createConvert(loc, idxTy, lowerExpr(*lo)); + ub = builder->createConvert(loc, idxTy, lowerExpr(*hi)); + by = optStep.has_value() + ? builder->createConvert( + loc, idxTy, + lowerExpr(*Fortran::semantics::GetExpr(*optStep))) + : builder->createIntegerConstant(loc, idxTy, 1); + } + auto lp = builder->create( + loc, lb, ub, by, /*unordered=*/true, + /*finalCount=*/false, explicitIterSpace.getInnerArgs()); + if (!loops.empty() || !outermost) + builder->create(loc, lp.getResults()); + explicitIterSpace.setInnerArgs(lp.getRegionIterArgs()); + builder->setInsertionPointToStart(lp.getBody()); + forceControlVariableBinding(ctrlVar, lp.getInductionVar()); + loops.push_back(lp); + } + explicitIterSpace.setOuterLoop(loops[0]); + if (const auto &mask = + std::get>( + header.t); + mask.has_value()) { + auto i1Ty = builder->getI1Type(); + auto maskExv = + genExprValue(*Fortran::semantics::GetExpr(mask.value()), stmtCtx); + auto cond = builder->createConvert(loc, i1Ty, fir::getBase(maskExv)); + auto ifOp = builder->create( + loc, explicitIterSpace.innerArgTypes(), cond, + /*withElseRegion=*/true); + builder->create(loc, ifOp.getResults()); + builder->setInsertionPointToStart(&ifOp.elseRegion().front()); + builder->create(loc, explicitIterSpace.getInnerArgs()); + builder->setInsertionPointToStart(&ifOp.thenRegion().front()); + } + }; + // Push the lambda to gen the loop nest context. + explicitIterSpace.pushLoopNest(lambda); + } + + void genFIR(const Fortran::parser::ForallAssignmentStmt &stmt) { + std::visit([&](const auto &x) { genFIR(x); }, stmt.u); + } + + void genFIR(const Fortran::parser::EndForallStmt &) { + cleanupExplicitSpace(); + } + + template + void prepareExplicitSpace(const A &forall) { + if (!explicitIterSpace.isActive()) + analyzeExplicitSpace(forall); + localSymbols.pushScope(); + explicitIterSpace.enter(); + } + + /// Cleanup all the FORALL context information when we exit. + void cleanupExplicitSpace() { + explicitIterSpace.leave(); + localSymbols.popScope(); + } + + /// Generate FIR for a FORALL statement. + void genFIR(const Fortran::parser::ForallStmt &stmt) { + prepareExplicitSpace(stmt); + genFIR(std::get< + Fortran::common::Indirection>( + stmt.t) + .value()); + genFIR(std::get>(stmt.t) + .statement); + cleanupExplicitSpace(); + } + + /// Generate FIR for a FORALL construct. + void genFIR(const Fortran::parser::ForallConstruct &forall) { + prepareExplicitSpace(forall); + genNestedStatement( + std::get< + Fortran::parser::Statement>( + forall.t)); + for (const auto &s : + std::get>(forall.t)) { + std::visit( + Fortran::common::visitors{ + [&](const Fortran::parser::WhereConstruct &b) { genFIR(b); }, + [&](const Fortran::common::Indirection< + Fortran::parser::ForallConstruct> &b) { genFIR(b.value()); }, + [&](const auto &b) { genNestedStatement(b); }}, + s.u); + } + genNestedStatement( + std::get>( + forall.t)); + } + + /// Lower the concurrent header specification. + void genFIR(const Fortran::parser::ForallConstructStmt &stmt) { + genFIR(std::get< + Fortran::common::Indirection>( + stmt.t) + .value()); + } + + void genFIR(const Fortran::parser::CompilerDirective &) { + mlir::emitWarning(toLocation(), "ignoring all compiler directives"); + } + + void genFIR(const Fortran::parser::OpenACCConstruct &acc) { + auto insertPt = builder->saveInsertionPoint(); + genOpenACCConstruct(*this, getEval(), acc); + for (auto &e : getEval().getNestedEvaluations()) + genFIR(e); + builder->restoreInsertionPoint(insertPt); + } + + void genFIR(const Fortran::parser::OpenMPConstruct &omp) { + auto insertPt = builder->saveInsertionPoint(); + localSymbols.pushScope(); + genOpenMPConstruct(*this, getEval(), omp); + + auto ompLoop = std::get_if(&omp.u); + + // If loop is part of an OpenMP Construct then the OpenMP dialect + // workshare loop operation has already been created. Only the + // body needs to be created here and the do_loop can be skipped. + // Skip the number of collapsed loops, which is 1 when there is a + // no collapse requested. + + Fortran::lower::pft::Evaluation *curEval = &getEval(); + if (ompLoop) { + const auto &wsLoopOpClauseList = std::get( + std::get(ompLoop->t).t); + int64_t collapseValue = + Fortran::lower::getCollapseValue(wsLoopOpClauseList); + + curEval = &curEval->getFirstNestedEvaluation(); + for (auto i = 1; i < collapseValue; i++) { + curEval = &*std::next(curEval->getNestedEvaluations().begin()); + } + } + + for (auto &e : curEval->getNestedEvaluations()) + genFIR(e); + localSymbols.popScope(); + builder->restoreInsertionPoint(insertPt); + } + + /// Generate FIR for a SELECT CASE statement. + /// The type may be CHARACTER, INTEGER, or LOGICAL. + void genFIR(const Fortran::parser::SelectCaseStmt &stmt) { + auto &eval = getEval(); + auto *context = builder->getContext(); + auto loc = toLocation(); + Fortran::lower::StatementContext stmtCtx; + const auto *expr = Fortran::semantics::GetExpr( + std::get>(stmt.t)); + bool isCharSelector = isCharacterCategory(expr->GetType()->category()); + bool isLogicalSelector = isLogicalCategory(expr->GetType()->category()); + auto charValue = [&](const Fortran::lower::SomeExpr *expr) { + fir::ExtendedValue exv = genExprAddr(*expr, stmtCtx, &loc); + return exv.match( + [&](const fir::CharBoxValue &cbv) { + return fir::factory::CharacterExprHelper{*builder, loc} + .createEmboxChar(cbv.getAddr(), cbv.getLen()); + }, + [&](auto) { + fir::emitFatalError(loc, "not a character"); + return mlir::Value{}; + }); + }; + mlir::Value selector; + if (isCharSelector) { + selector = charValue(expr); + } else { + selector = createFIRExpr(loc, expr, stmtCtx); + if (isLogicalSelector) + selector = builder->createConvert(loc, builder->getI1Type(), selector); + } + auto selectType = selector.getType(); + llvm::SmallVector attrList; + llvm::SmallVector valueList; + llvm::SmallVector blockList; + auto *defaultBlock = eval.parentConstruct->constructExit->block; + using CaseValue = Fortran::parser::Scalar; + auto addValue = [&](const CaseValue &caseValue) { + const auto *expr = Fortran::semantics::GetExpr(caseValue.thing); + if (isCharSelector) + valueList.push_back(charValue(expr)); + else if (isLogicalSelector) + valueList.push_back(builder->createConvert( + loc, selectType, createFIRExpr(toLocation(), expr, stmtCtx))); + else + valueList.push_back(builder->createIntegerConstant( + loc, selectType, *Fortran::evaluate::ToInt64(*expr))); + }; + for (Fortran::lower::pft::Evaluation *e = eval.controlSuccessor; e; + e = e->controlSuccessor) { + const auto &caseStmt = e->getIf(); + assert(e->block && "missing CaseStmt block"); + const auto &caseSelector = + std::get(caseStmt->t); + const auto *caseValueRangeList = + std::get_if>( + &caseSelector.u); + if (!caseValueRangeList) { + defaultBlock = e->block; + continue; + } + for (auto &caseValueRange : *caseValueRangeList) { + blockList.push_back(e->block); + if (const auto *caseValue = std::get_if(&caseValueRange.u)) { + attrList.push_back(fir::PointIntervalAttr::get(context)); + addValue(*caseValue); + continue; + } + const auto &caseRange = + std::get(caseValueRange.u); + if (caseRange.lower && caseRange.upper) { + attrList.push_back(fir::ClosedIntervalAttr::get(context)); + addValue(*caseRange.lower); + addValue(*caseRange.upper); + } else if (caseRange.lower) { + attrList.push_back(fir::LowerBoundAttr::get(context)); + addValue(*caseRange.lower); + } else { + attrList.push_back(fir::UpperBoundAttr::get(context)); + addValue(*caseRange.upper); + } + } + } + // Skip a logical default block that can never be referenced. + if (isLogicalSelector && attrList.size() == 2) + defaultBlock = eval.parentConstruct->constructExit->block; + attrList.push_back(mlir::UnitAttr::get(context)); + blockList.push_back(defaultBlock); + stmtCtx.finalize(); + + // Generate a fir::SelectCaseOp. + // Explicit branch code is better for the LOGICAL type. The CHARACTER type + // does not yet have downstream support, and also uses explicit branch code. + // The -no-structured-fir option can be used to force generation of INTEGER + // type branch code. + if (!isLogicalSelector && !isCharSelector && eval.lowerAsStructured()) { + builder->create(loc, selector, attrList, valueList, + blockList); + return; + } + + // Generate a sequence of case value comparisons and branches. + auto caseValue = valueList.begin(); + auto caseBlock = blockList.begin(); + for (auto attr : attrList) { + if (attr.isa()) { + genFIRBranch(*caseBlock++); + break; + } + auto genCond = [&](mlir::Value rhs, + mlir::CmpIPredicate pred) -> mlir::Value { + if (!isCharSelector) + return builder->create(loc, pred, selector, rhs); + fir::factory::CharacterExprHelper charHelper{*builder, loc}; + auto [lhsAddr, lhsLen] = charHelper.createUnboxChar(selector); + auto [rhsAddr, rhsLen] = charHelper.createUnboxChar(rhs); + return fir::runtime::genCharCompare(*builder, loc, pred, lhsAddr, + lhsLen, rhsAddr, rhsLen); + }; + auto *newBlock = insertBlock(*caseBlock); + if (attr.isa()) { + auto *newBlock2 = insertBlock(*caseBlock); + auto cond = genCond(*caseValue++, mlir::CmpIPredicate::sge); + genFIRConditionalBranch(cond, newBlock, newBlock2); + builder->setInsertionPointToEnd(newBlock); + auto cond2 = genCond(*caseValue++, mlir::CmpIPredicate::sle); + genFIRConditionalBranch(cond2, *caseBlock++, newBlock2); + builder->setInsertionPointToEnd(newBlock2); + continue; + } + mlir::CmpIPredicate pred; + if (attr.isa()) { + pred = mlir::CmpIPredicate::eq; + } else if (attr.isa()) { + pred = mlir::CmpIPredicate::sge; + } else { + assert(attr.isa() && "unexpected predicate"); + pred = mlir::CmpIPredicate::sle; + } + auto cond = genCond(*caseValue++, pred); + genFIRConditionalBranch(cond, *caseBlock++, newBlock); + builder->setInsertionPointToEnd(newBlock); + } + assert(caseValue == valueList.end() && caseBlock == blockList.end() && + "select case list mismatch"); + } + + fir::ExtendedValue + genAssociateSelector(const Fortran::semantics::SomeExpr &selector, + Fortran::lower::StatementContext &stmtCtx) { + return isArraySectionWithoutVectorSubscript(selector) + ? Fortran::lower::createSomeArrayBox(*this, selector, + localSymbols, stmtCtx) + : genExprAddr(selector, stmtCtx); + } + + void genFIR(const Fortran::parser::AssociateConstruct &) { + Fortran::lower::StatementContext stmtCtx; + for (auto &e : getEval().getNestedEvaluations()) { + if (auto *stmt = e.getIf()) { + localSymbols.pushScope(); + for (auto &assoc : + std::get>(stmt->t)) { + auto &sym = *std::get(assoc.t).symbol; + const auto &selector = + *sym.get().expr(); + localSymbols.addSymbol(sym, genAssociateSelector(selector, stmtCtx)); + } + } else if (e.getIf()) { + stmtCtx.finalize(); + localSymbols.popScope(); + } else { + genFIR(e); + } + } + } + + void genFIR(const Fortran::parser::BlockConstruct &) { + TODO(toLocation(), "BlockConstruct lowering"); + } + void genFIR(const Fortran::parser::BlockStmt &) { + TODO(toLocation(), "BlockStmt lowering"); + } + void genFIR(const Fortran::parser::EndBlockStmt &) { + TODO(toLocation(), "EndBlockStmt lowering"); + } + + void genFIR(const Fortran::parser::ChangeTeamConstruct &construct) { + genChangeTeamConstruct(*this, getEval(), construct); + } + void genFIR(const Fortran::parser::ChangeTeamStmt &stmt) { + genChangeTeamStmt(*this, getEval(), stmt); + } + void genFIR(const Fortran::parser::EndChangeTeamStmt &stmt) { + genEndChangeTeamStmt(*this, getEval(), stmt); + } + + void genFIR(const Fortran::parser::CriticalConstruct &) { + TODO(toLocation(), "CriticalConstruct lowering"); + } + void genFIR(const Fortran::parser::CriticalStmt &) { + TODO(toLocation(), "CriticalStmt lowering"); + } + void genFIR(const Fortran::parser::EndCriticalStmt &) { + TODO(toLocation(), "EndCriticalStmt lowering"); + } + + void genFIR(const Fortran::parser::SelectRankConstruct &) { + TODO(toLocation(), "SelectRankConstruct lowering"); + } + void genFIR(const Fortran::parser::SelectRankStmt &) { + TODO(toLocation(), "SelectRankStmt lowering"); + } + void genFIR(const Fortran::parser::SelectRankCaseStmt &) { + TODO(toLocation(), "SelectRankCaseStmt lowering"); + } + + void genFIR(const Fortran::parser::SelectTypeConstruct &) { + TODO(toLocation(), "SelectTypeConstruct lowering"); + } + void genFIR(const Fortran::parser::SelectTypeStmt &) { + TODO(toLocation(), "SelectTypeStmt lowering"); + } + void genFIR(const Fortran::parser::TypeGuardStmt &) { + TODO(toLocation(), "TypeGuardStmt lowering"); + } + + //===--------------------------------------------------------------------===// + // IO statements (see io.h) + //===--------------------------------------------------------------------===// + + void genFIR(const Fortran::parser::BackspaceStmt &stmt) { + auto iostat = genBackspaceStatement(*this, stmt); + genIoConditionBranches(getEval(), stmt.v, iostat); + } + void genFIR(const Fortran::parser::CloseStmt &stmt) { + auto iostat = genCloseStatement(*this, stmt); + genIoConditionBranches(getEval(), stmt.v, iostat); + } + void genFIR(const Fortran::parser::EndfileStmt &stmt) { + auto iostat = genEndfileStatement(*this, stmt); + genIoConditionBranches(getEval(), stmt.v, iostat); + } + void genFIR(const Fortran::parser::FlushStmt &stmt) { + auto iostat = genFlushStatement(*this, stmt); + genIoConditionBranches(getEval(), stmt.v, iostat); + } + void genFIR(const Fortran::parser::InquireStmt &stmt) { + auto iostat = genInquireStatement(*this, stmt); + if (const auto *specs = + std::get_if>(&stmt.u)) + genIoConditionBranches(getEval(), *specs, iostat); + } + void genFIR(const Fortran::parser::OpenStmt &stmt) { + auto iostat = genOpenStatement(*this, stmt); + genIoConditionBranches(getEval(), stmt.v, iostat); + } + void genFIR(const Fortran::parser::PrintStmt &stmt) { + genPrintStatement(*this, stmt); + } + void genFIR(const Fortran::parser::ReadStmt &stmt) { + auto iostat = genReadStatement(*this, stmt); + genIoConditionBranches(getEval(), stmt.controls, iostat); + } + void genFIR(const Fortran::parser::RewindStmt &stmt) { + auto iostat = genRewindStatement(*this, stmt); + genIoConditionBranches(getEval(), stmt.v, iostat); + } + void genFIR(const Fortran::parser::WaitStmt &stmt) { + auto iostat = genWaitStatement(*this, stmt); + genIoConditionBranches(getEval(), stmt.v, iostat); + } + void genFIR(const Fortran::parser::WriteStmt &stmt) { + auto iostat = genWriteStatement(*this, stmt); + genIoConditionBranches(getEval(), stmt.controls, iostat); + } + + template + void genIoConditionBranches(Fortran::lower::pft::Evaluation &eval, + const A &specList, mlir::Value iostat) { + if (!iostat) + return; + + mlir::Block *endBlock = nullptr; + mlir::Block *eorBlock = nullptr; + mlir::Block *errBlock = nullptr; + for (const auto &spec : specList) { + std::visit(Fortran::common::visitors{ + [&](const Fortran::parser::EndLabel &label) { + endBlock = blockOfLabel(eval, label.v); + }, + [&](const Fortran::parser::EorLabel &label) { + eorBlock = blockOfLabel(eval, label.v); + }, + [&](const Fortran::parser::ErrLabel &label) { + errBlock = blockOfLabel(eval, label.v); + }, + [](const auto &) {}}, + spec.u); + } + if (!endBlock && !eorBlock && !errBlock) + return; + + auto loc = toLocation(); + auto indexType = builder->getIndexType(); + auto selector = builder->createConvert(loc, indexType, iostat); + llvm::SmallVector indexList; + llvm::SmallVector blockList; + if (eorBlock) { + indexList.push_back(Fortran::runtime::io::IostatEor); + blockList.push_back(eorBlock); + } + if (endBlock) { + indexList.push_back(Fortran::runtime::io::IostatEnd); + blockList.push_back(endBlock); + } + if (errBlock) { + indexList.push_back(0); + blockList.push_back(eval.nonNopSuccessor().block); + // ERR label statement is the default successor. + blockList.push_back(errBlock); + } else { + // Fallthrough successor statement is the default successor. + blockList.push_back(eval.nonNopSuccessor().block); + } + builder->create(loc, selector, indexList, blockList); + } + + //===--------------------------------------------------------------------===// + // Memory allocation and deallocation + //===--------------------------------------------------------------------===// + + void genFIR(const Fortran::parser::AllocateStmt &stmt) { + Fortran::lower::genAllocateStmt(*this, stmt, toLocation()); + } + + void genFIR(const Fortran::parser::DeallocateStmt &stmt) { + Fortran::lower::genDeallocateStmt(*this, stmt, toLocation()); + } + + /// Nullify pointer object list + /// + /// For each pointer object, reset the pointer to a disassociated status. + /// We do this by setting each pointer to null. + void genFIR(const Fortran::parser::NullifyStmt &stmt) { + auto loc = toLocation(); + for (auto &pointerObject : stmt.v) { + const auto *expr = Fortran::semantics::GetExpr(pointerObject); + assert(expr); + auto box = genExprMutableBox(loc, *expr); + fir::factory::disassociateMutableBox(*builder, loc, box); + } + } + + //===--------------------------------------------------------------------===// + + void genFIR(const Fortran::parser::EventPostStmt &stmt) { + genEventPostStatement(*this, stmt); + } + + void genFIR(const Fortran::parser::EventWaitStmt &stmt) { + genEventWaitStatement(*this, stmt); + } + + void genFIR(const Fortran::parser::FormTeamStmt &stmt) { + genFormTeamStatement(*this, getEval(), stmt); + } + + void genFIR(const Fortran::parser::LockStmt &stmt) { + genLockStatement(*this, stmt); + } + + fir::ExtendedValue + genInitializerExprValue(const Fortran::lower::SomeExpr &expr, + Fortran::lower::StatementContext &stmtCtx) { + return createSomeInitializerExpression(toLocation(), *this, expr, + localSymbols, stmtCtx); + } + + /// Return true if the current context is a conditionalized and implied + /// iteration space. + bool implicitIterationSpace() { return !implicitIterSpace.empty(); } + + /// Return true if context is currently an explicit iteration space. A scalar + /// assignment expression may be contextually within a user-defined iteration + /// space, transforming it into an array expression. + bool explicitIterationSpace() { return explicitIterSpace.isActive(); } + + /// Generate an array assignment. + /// This is an assignment expression with rank > 0. The assignment may or may + /// not be in a WHERE and/or FORALL context. + void genArrayAssignment(const Fortran::evaluate::Assignment &assign, + Fortran::lower::StatementContext &stmtCtx) { + if (isWholeAllocatable(assign.lhs)) { + // Assignment to allocatables may require the lhs to be + // deallocated/reallocated. See Fortran 2018 10.2.1.3 p3 + Fortran::lower::createAllocatableArrayAssignment( + *this, assign.lhs, assign.rhs, explicitIterSpace, implicitIterSpace, + localSymbols, stmtCtx); + return; + } + + if (!implicitIterationSpace() && !explicitIterationSpace()) { + // No masks and the iteration space is implied by the array, so create a + // simple array assignment. + Fortran::lower::createSomeArrayAssignment(*this, assign.lhs, assign.rhs, + localSymbols, stmtCtx); + return; + } + + // If there is an explicit iteration space, generate an array assignment + // with a user-specified iteration space and possibly with masks. These + // assignments may *appear* to be scalar expressions, but the scalar + // expression is evaluated at all points in the user-defined space much like + // an ordinary array assignment. More specifically, the semantics inside the + // FORALL much more closely resembles that of WHERE than a scalar + // assignment. + // Otherwise, generate a masked array assignment. The iteration space is + // implied by the lhs array expression. + Fortran::lower::createAnyMaskedArrayAssignment( + *this, assign.lhs, assign.rhs, explicitIterSpace, implicitIterSpace, + localSymbols, + explicitIterationSpace() ? explicitIterSpace.stmtContext() + : implicitIterSpace.stmtContext()); + } + + static bool isArraySectionWithoutVectorSubscript( + const Fortran::semantics::SomeExpr &expr) { + return expr.Rank() > 0 && Fortran::evaluate::IsVariable(expr) && + !Fortran::evaluate::UnwrapWholeSymbolDataRef(expr) && + !Fortran::evaluate::HasVectorSubscript(expr); + } + + [[maybe_unused]] static bool + isFuncResultDesignator(const Fortran::lower::SomeExpr &expr) { + const auto *sym = Fortran::evaluate::GetFirstSymbol(expr); + return sym && sym->IsFuncResult(); + } + + static bool isWholeAllocatable(const Fortran::lower::SomeExpr &expr) { + const auto *sym = + Fortran::evaluate::UnwrapWholeSymbolOrComponentDataRef(expr); + return sym && Fortran::semantics::IsAllocatable(*sym); + } + + /// Shared for both assignments and pointer assignments. + void genAssignment(const Fortran::evaluate::Assignment &assign) { + Fortran::lower::StatementContext stmtCtx; + auto loc = toLocation(); + if (explicitIterationSpace()) { + Fortran::lower::createArrayLoads(*this, explicitIterSpace, localSymbols); + explicitIterSpace.genLoopNest(); + } + std::visit( + Fortran::common::visitors{ + // [1] Plain old assignment. + [&](const Fortran::evaluate::Assignment::Intrinsic &) { + const auto *sym = Fortran::evaluate::GetLastSymbol(assign.lhs); + + if (!sym) + TODO(loc, "assignment to pointer result of function reference"); + + auto lhsType = assign.lhs.GetType(); + assert(lhsType && "lhs cannot be typeless"); + // Assignment to polymorphic allocatables may require changing the + // variable dynamic type (See Fortran 2018 10.2.1.3 p3). + if (lhsType->IsPolymorphic() && isWholeAllocatable(assign.lhs)) + TODO(loc, "assignment to polymorphic allocatable"); + + // Note: no ad-hoc handling for pointers is require here, the + // target will be assigned as per 2018 10.2.1.3 p2. genExprAddr + // on a pointer returns the target address. + + if (assign.lhs.Rank() > 0 || explicitIterationSpace()) { + // Array assignment + // See Fortran 2018 10.2.1.3 p5, p6, and p7 + genArrayAssignment(assign, stmtCtx); + return; + } + + // Scalar assignment + const bool isNumericScalar = + isNumericScalarCategory(lhsType->category()); + auto rhs = isNumericScalar ? genExprValue(assign.rhs, stmtCtx) + : genExprAddr(assign.rhs, stmtCtx); + auto lowerAllocatableLHS = [&]() -> fir::ExtendedValue { + auto lhs = genExprMutableBox(loc, assign.lhs); + llvm::SmallVector lengthParams; + if (auto *charBox = rhs.getCharBox()) + lengthParams.push_back(charBox->getLen()); + else if (lhs.isDerivedWithLengthParameters()) + TODO(loc, "assignment to derived type allocatable with " + "length parameters"); + fir::factory::genReallocIfNeeded( + *builder, loc, lhs, /*lbounds=*/llvm::None, + /*shape=*/llvm::None, lengthParams); + // Assume lhs is not polymorphic for now given TODO above, + // otherwise, the read would is conservative and returns + // BoxValue for derived types. + return fir::factory::genMutableBoxRead( + *builder, loc, lhs, /*mayBePolymorphic=*/false); + }; + auto lhs = isWholeAllocatable(assign.lhs) + ? lowerAllocatableLHS() + : genExprAddr(assign.lhs, stmtCtx); + + if (isNumericScalar) { + // Fortran 2018 10.2.1.3 p8 and p9 + // Conversions should have been inserted by semantic analysis, + // but they can be incorrect between the rhs and lhs. Correct + // that here. + auto addr = fir::getBase(lhs); + auto val = fir::getBase(rhs); + // A function with multiple entry points returning different + // types tags all result variables with one of the largest + // types to allow them to share the same storage. Assignment + // to a result variable of one of the other types requires + // conversion to the actual type. + auto toTy = genType(assign.lhs); + auto cast = builder->convertWithSemantics(loc, toTy, val); + if (fir::dyn_cast_ptrEleTy(addr.getType()) != toTy) { + assert(isFuncResultDesignator(assign.lhs) && "type mismatch"); + addr = builder->createConvert( + toLocation(), builder->getRefType(toTy), addr); + } + builder->create(loc, cast, addr); + return; + } + if (isCharacterCategory(lhsType->category())) { + // Fortran 2018 10.2.1.3 p10 and p11 + fir::factory::CharacterExprHelper{*builder, loc}.createAssign( + lhs, rhs); + return; + } + if (isDerivedCategory(lhsType->category())) { + // Fortran 2018 10.2.1.3 p13 and p14 + // Recursively gen an assignment on each element pair. + fir::factory::genRecordAssignment(*builder, loc, lhs, rhs); + return; + } + llvm_unreachable("unknown category"); + }, + + // [2] User defined assignment. If the context is a scalar + // expression then call the procedure. + [&](const Fortran::evaluate::ProcedureRef &procRef) { + if (implicitIterationSpace()) + TODO(loc, "user defined assignment within WHERE"); + + Fortran::semantics::SomeExpr expr{procRef}; + auto &ctx = explicitIterationSpace() + ? explicitIterSpace.stmtContext() + : stmtCtx; + Fortran::lower::createSubroutineCall( + *this, expr, localSymbols, ctx, /*isUserDefAssignment=*/true); + }, + + // [3] Pointer assignment with possibly empty bounds-spec. R1035: a + // bounds-spec is a lower bound value. + [&](const Fortran::evaluate::Assignment::BoundsSpec &lbExprs) { + auto lhsType = assign.lhs.GetType(); + auto rhsType = assign.rhs.GetType(); + // Polymorphic lhs/rhs may need more care. See F2018 10.2.2.3. + if ((lhsType && lhsType->IsPolymorphic()) || + (rhsType && rhsType->IsPolymorphic())) + TODO(loc, "pointer assignment involving polymorphic entity"); + + // FIXME: in the explicit space context, we want to use + // ScalarArrayExprLowering here. + auto lhs = genExprMutableBox(loc, assign.lhs); + llvm::SmallVector lbounds; + for (const auto &lbExpr : lbExprs) + lbounds.push_back( + fir::getBase(genExprValue(toEvExpr(lbExpr), stmtCtx))); + Fortran::lower::associateMutableBox(*this, loc, lhs, assign.rhs, + lbounds, stmtCtx); + }, + + // [4] Pointer assignment with bounds-remapping. R1036: a + // bounds-remapping is a pair, lower bound and upper bound. + [&](const Fortran::evaluate::Assignment::BoundsRemapping + &boundExprs) { + auto lhsType = assign.lhs.GetType(); + auto rhsType = assign.rhs.GetType(); + // Polymorphic lhs/rhs may need more care. See F2018 10.2.2.3. + if ((lhsType && lhsType->IsPolymorphic()) || + (rhsType && rhsType->IsPolymorphic())) + TODO(loc, "pointer assignment involving polymorphic entity"); + + // FIXME: in the explicit space context, we want to use + // ScalarArrayExprLowering here. + auto lhs = genExprMutableBox(loc, assign.lhs); + if (Fortran::evaluate::UnwrapExpr( + assign.rhs)) { + fir::factory::disassociateMutableBox(*builder, loc, lhs); + return; + } + llvm::SmallVector lbounds; + llvm::SmallVector ubounds; + for (const auto &[lbExpr, ubExpr] : boundExprs) { + lbounds.push_back( + fir::getBase(genExprValue(toEvExpr(lbExpr), stmtCtx))); + ubounds.push_back( + fir::getBase(genExprValue(toEvExpr(ubExpr), stmtCtx))); + } + // Do not generate a temp in case rhs is an array section. + auto rhs = isArraySectionWithoutVectorSubscript(assign.rhs) + ? Fortran::lower::createSomeArrayBox( + *this, assign.rhs, localSymbols, stmtCtx) + : genExprAddr(assign.rhs, stmtCtx); + fir::factory::associateMutableBoxWithRemap(*builder, loc, lhs, + rhs, lbounds, ubounds); + }, + }, + assign.u); + if (explicitIterationSpace()) + Fortran::lower::createArrayMergeStores(*this, explicitIterSpace); + } + + void genFIR(const Fortran::parser::WhereConstruct &c) { + implicitIterSpace.growStack(); + genNestedStatement( + std::get< + Fortran::parser::Statement>( + c.t)); + for (const auto &body : + std::get>(c.t)) + genFIR(body); + for (const auto &e : + std::get>( + c.t)) + genFIR(e); + if (const auto &e = + std::get>( + c.t); + e.has_value()) + genFIR(*e); + genNestedStatement( + std::get>( + c.t)); + } + void genFIR(const Fortran::parser::WhereBodyConstruct &body) { + std::visit( + Fortran::common::visitors{ + [&](const Fortran::parser::Statement< + Fortran::parser::AssignmentStmt> &stmt) { + genNestedStatement(stmt); + }, + [&](const Fortran::parser::Statement + &stmt) { genNestedStatement(stmt); }, + [&](const Fortran::common::Indirection< + Fortran::parser::WhereConstruct> &c) { genFIR(c.value()); }, + }, + body.u); + } + void genFIR(const Fortran::parser::WhereConstructStmt &stmt) { + implicitIterSpace.append(Fortran::semantics::GetExpr( + std::get(stmt.t))); + } + void genFIR(const Fortran::parser::WhereConstruct::MaskedElsewhere &ew) { + genNestedStatement( + std::get< + Fortran::parser::Statement>( + ew.t)); + for (const auto &body : + std::get>(ew.t)) + genFIR(body); + } + void genFIR(const Fortran::parser::MaskedElsewhereStmt &stmt) { + implicitIterSpace.append(Fortran::semantics::GetExpr( + std::get(stmt.t))); + } + void genFIR(const Fortran::parser::WhereConstruct::Elsewhere &ew) { + genNestedStatement( + std::get>( + ew.t)); + for (const auto &body : + std::get>(ew.t)) + genFIR(body); + } + void genFIR(const Fortran::parser::ElsewhereStmt &stmt) { + implicitIterSpace.append(nullptr); + } + void genFIR(const Fortran::parser::EndWhereStmt &) { + implicitIterSpace.shrinkStack(); + } + + void genFIR(const Fortran::parser::WhereStmt &stmt) { + Fortran::lower::StatementContext stmtCtx; + const auto &assign = std::get(stmt.t); + implicitIterSpace.growStack(); + implicitIterSpace.append(Fortran::semantics::GetExpr( + std::get(stmt.t))); + genAssignment(*assign.typedAssignment->v); + implicitIterSpace.shrinkStack(); + } + + void genFIR(const Fortran::parser::PointerAssignmentStmt &stmt) { + genAssignment(*stmt.typedAssignment->v); + } + + void genFIR(const Fortran::parser::AssignmentStmt &stmt) { + genAssignment(*stmt.typedAssignment->v); + } + + void genFIR(const Fortran::parser::SyncAllStmt &stmt) { + genSyncAllStatement(*this, stmt); + } + + void genFIR(const Fortran::parser::SyncImagesStmt &stmt) { + genSyncImagesStatement(*this, stmt); + } + + void genFIR(const Fortran::parser::SyncMemoryStmt &stmt) { + genSyncMemoryStatement(*this, stmt); + } + + void genFIR(const Fortran::parser::SyncTeamStmt &stmt) { + genSyncTeamStatement(*this, stmt); + } + + void genFIR(const Fortran::parser::UnlockStmt &stmt) { + genUnlockStatement(*this, stmt); + } + + void genFIR(const Fortran::parser::AssignStmt &stmt) { + const auto &symbol = *std::get(stmt.t).symbol; + auto loc = toLocation(); + const auto labelValue = builder->createIntegerConstant( + loc, genType(symbol), std::get(stmt.t)); + builder->create(loc, labelValue, getSymbolAddress(symbol)); + } + + void genFIR(const Fortran::parser::FormatStmt &) { + // do nothing. + + // FORMAT statements have no semantics. They may be lowered if used by a + // data transfer statement. + } + + void genFIR(const Fortran::parser::PauseStmt &stmt) { + genPauseStatement(*this, stmt); + } + + // call FAIL IMAGE in runtime + void genFIR(const Fortran::parser::FailImageStmt &stmt) { + genFailImageStatement(*this); + } + + // call STOP, ERROR STOP in runtime + void genFIR(const Fortran::parser::StopStmt &stmt) { + genStopStatement(*this, stmt); + } + + void genFIR(const Fortran::parser::ReturnStmt &stmt) { + auto *funit = getEval().getOwningProcedure(); + assert(funit && "not inside main program, function or subroutine"); + if (funit->isMainProgram()) { + genExitRoutine(); + return; + } + auto loc = toLocation(); + if (stmt.v) { + // Alternate return statement - If this is a subroutine where some + // alternate entries have alternate returns, but the active entry point + // does not, ignore the alternate return value. Otherwise, assign it + // to the compiler-generated result variable. + const auto &symbol = funit->getSubprogramSymbol(); + if (Fortran::semantics::HasAlternateReturns(symbol)) { + Fortran::lower::StatementContext stmtCtx; + const auto *expr = Fortran::semantics::GetExpr(*stmt.v); + assert(expr && "missing alternate return expression"); + auto altReturnIndex = builder->createConvert( + loc, builder->getIndexType(), createFIRExpr(loc, expr, stmtCtx)); + builder->create(loc, altReturnIndex, + getAltReturnResult(symbol)); + } + } + // Branch to the last block of the SUBROUTINE, which has the actual return. + if (!funit->finalBlock) { + const auto insPt = builder->saveInsertionPoint(); + funit->finalBlock = builder->createBlock(&builder->getRegion()); + builder->restoreInsertionPoint(insPt); + } + builder->create(loc, funit->finalBlock); + } + + void genFIR(const Fortran::parser::CycleStmt &) { + genFIRBranch(getEval().controlSuccessor->block); + } + void genFIR(const Fortran::parser::ExitStmt &) { + genFIRBranch(getEval().controlSuccessor->block); + } + void genFIR(const Fortran::parser::GotoStmt &) { + genFIRBranch(getEval().controlSuccessor->block); + } + + // Nop statements - No code, or code is generated at the construct level. + void genFIR(const Fortran::parser::AssociateStmt &) {} // nop + void genFIR(const Fortran::parser::CaseStmt &) {} // nop + void genFIR(const Fortran::parser::ContinueStmt &) {} // nop + void genFIR(const Fortran::parser::ElseIfStmt &) {} // nop + void genFIR(const Fortran::parser::ElseStmt &) {} // nop + void genFIR(const Fortran::parser::EndAssociateStmt &) {} // nop + void genFIR(const Fortran::parser::EndDoStmt &) {} // nop + void genFIR(const Fortran::parser::EndFunctionStmt &) {} // nop + void genFIR(const Fortran::parser::EndIfStmt &) {} // nop + void genFIR(const Fortran::parser::EndMpSubprogramStmt &) {} // nop + void genFIR(const Fortran::parser::EndSelectStmt &) {} // nop + void genFIR(const Fortran::parser::EndSubroutineStmt &) {} // nop + void genFIR(const Fortran::parser::EntryStmt &) {} // nop + void genFIR(const Fortran::parser::IfStmt &) {} // nop + void genFIR(const Fortran::parser::IfThenStmt &) {} // nop + void genFIR(const Fortran::parser::NonLabelDoStmt &) {} // nop + void genFIR(const Fortran::parser::OmpEndLoopDirective &) {} // nop + + /// Generate FIR for the Evaluation `eval`. + void genFIR(Fortran::lower::pft::Evaluation &eval, + bool unstructuredContext = true) { + if (unstructuredContext) { + // When transitioning from unstructured to structured code, + // the structured code could be a target that starts a new block. + maybeStartBlock(eval.isConstruct() && eval.lowerAsStructured() + ? eval.getFirstNestedEvaluation().block + : eval.block); + } + + setCurrentEval(eval); + setCurrentPosition(eval.position); + eval.visit([&](const auto &stmt) { genFIR(stmt); }); + + if (unstructuredContext && blockIsUnterminated()) { + // Exit from an unstructured IF or SELECT construct block. + Fortran::lower::pft::Evaluation *successor{}; + if (eval.isActionStmt()) + successor = eval.controlSuccessor; + else if (eval.isConstruct() && + eval.getLastNestedEvaluation() + .lexicalSuccessor->isIntermediateConstructStmt()) + successor = eval.constructExit; + if (successor && successor->block) + genFIRBranch(successor->block); + } + } + + /// Map mlir function block arguments to the corresponding Fortran dummy + /// variables. When the result is passed as a hidden argument, the Fortran + /// result is also mapped. The symbol map is used to hold this mapping. + void mapDummiesAndResults(Fortran::lower::pft::FunctionLikeUnit &funit, + const Fortran::lower::CalleeInterface &callee) { + assert(builder && "need a builder at this point"); + using PassBy = Fortran::lower::CalleeInterface::PassEntityBy; + auto mapPassedEntity = [&](const auto arg) -> void { + if (arg.passBy == PassBy::AddressAndLength) { + // TODO: now that fir call has some attributes regarding character + // return, this should PassBy::AddressAndLength should be retired. + auto loc = toLocation(); + fir::factory::CharacterExprHelper charHelp{*builder, loc}; + auto box = charHelp.createEmboxChar(arg.firArgument, arg.firLength); + addSymbol(arg.entity->get(), box); + } else { + if (arg.entity.has_value()) { + addSymbol(arg.entity->get(), arg.firArgument); + } else { + assert(funit.parentHasHostAssoc()); + funit.parentHostAssoc().internalProcedureBindings(*this, + localSymbols); + } + } + }; + for (const auto &arg : callee.getPassedArguments()) + mapPassedEntity(arg); + + // Allocate local skeleton instances of dummies from other entry points. + // Most of these locals will not survive into final generated code, but + // some will. It is illegal to reference them at run time if they do. + for (const auto *arg : funit.nonUniversalDummyArguments) { + if (lookupSymbol(*arg)) + continue; + auto type = genType(*arg); + // TODO: Account for VALUE arguments (and possibly other variants). + type = builder->getRefType(type); + addSymbol(*arg, builder->create(toLocation(), type)); + } + if (auto passedResult = callee.getPassedResult()) { + mapPassedEntity(*passedResult); + // FIXME: need to make sure things are OK here. addSymbol may not be OK + if (funit.primaryResult && + passedResult->entity->get() != *funit.primaryResult) + addSymbol(*funit.primaryResult, + getSymbolAddress(passedResult->entity->get())); + } + } + + /// Instantiate variable \p var and add it to the symbol map. + /// See ConvertVariable.cpp. + void instantiateVar(const Fortran::lower::pft::Variable &var, + Fortran::lower::AggregateStoreMap &storeMap) { + Fortran::lower::instantiateVariable(*this, var, localSymbols, storeMap); + } + + /// Prepare to translate a new function + void startNewFunction(Fortran::lower::pft::FunctionLikeUnit &funit) { + assert(!builder && "expected nullptr"); + Fortran::lower::CalleeInterface callee(funit, *this); + mlir::FuncOp func = callee.addEntryBlockAndMapArguments(); + builder = new fir::FirOpBuilder(func, bridge.getKindMap()); + assert(builder && "FirOpBuilder did not instantiate"); + builder->setInsertionPointToStart(&func.front()); + func.setVisibility(mlir::SymbolTable::Visibility::Public); + + mapDummiesAndResults(funit, callee); + + // Note: not storing Variable references because getOrderedSymbolTable + // below returns a temporary. + llvm::SmallVector deferredFuncResultList; + + // Backup actual argument for entry character results + // with different lengths. It needs to be added to the non + // primary results symbol before mapSymbolAttributes is called. + Fortran::lower::SymbolBox resultArg; + if (auto passedResult = callee.getPassedResult()) + resultArg = lookupSymbol(passedResult->entity->get()); + + Fortran::lower::AggregateStoreMap storeMap; + // The front-end is currently not adding module variables referenced + // in a module procedure as host associated. As a result we need to + // instantiate all module variables here if this is a module procedure. + // It is likely that the front-end behavior should change here. + // This also applies to internal procedures inside module procedures. + if (auto *module = Fortran::lower::pft::getAncestor< + Fortran::lower::pft::ModuleLikeUnit>(funit)) + for (const auto &var : module->getOrderedSymbolTable()) + instantiateVar(var, storeMap); + + mlir::Value primaryFuncResultStorage; + for (const auto &var : funit.getOrderedSymbolTable()) { + // Always instantiate aggregate storage blocks. + if (var.isAggregateStore()) { + instantiateVar(var, storeMap); + continue; + } + const Fortran::semantics::Symbol &sym = var.getSymbol(); + // Never instantitate host associated variables, as they are already + // instantiated from an argument tuple. Instead, just bind the symbol to + // the reference to the host variable, which must be in the map. + if (const auto *escapingSym = getIfHostProcedureSymbol(sym)) { + auto hostBox = localSymbols.lookupSymbol(escapingSym); + assert(hostBox && "host association is not in map"); + localSymbols.addSymbol(sym, hostBox.toExtendedValue()); + continue; + } + if (!sym.IsFuncResult() || !funit.primaryResult) { + instantiateVar(var, storeMap); + } else if (&sym == funit.primaryResult) { + instantiateVar(var, storeMap); + primaryFuncResultStorage = getSymbolAddress(sym); + } else { + deferredFuncResultList.push_back(var); + } + } + + // If this is a host procedure with host associations, then create the tuple + // of pointers for passing to the internal procedures. + if (!funit.getHostAssoc().empty()) + funit.getHostAssoc().hostProcedureBindings(*this, localSymbols); + + /// TODO: should use same mechanism as equivalence? + /// One blocking point is character entry returns that need special handling + /// since they are not locally allocated but come as argument. CHARACTER(*) + /// is not something that fit wells with equivalence lowering. + for (const auto &altResult : deferredFuncResultList) { + if (auto passedResult = callee.getPassedResult()) + addSymbol(altResult.getSymbol(), resultArg.getAddr()); + Fortran::lower::StatementContext stmtCtx; + Fortran::lower::mapSymbolAttributes(*this, altResult, localSymbols, + stmtCtx, primaryFuncResultStorage); + } + + // Create most function blocks in advance. + auto *alternateEntryEval = funit.getEntryEval(); + if (alternateEntryEval) { + // Move to executable successor. + alternateEntryEval = alternateEntryEval->lexicalSuccessor; + auto evalIsNewBlock = alternateEntryEval->isNewBlock; + alternateEntryEval->isNewBlock = true; + createEmptyBlocks(funit.evaluationList); + alternateEntryEval->isNewBlock = evalIsNewBlock; + } else { + createEmptyBlocks(funit.evaluationList); + } + + // Reinstate entry block as the current insertion point. + builder->setInsertionPointToEnd(&func.front()); + + if (callee.hasAlternateReturns()) { + // Create a local temp to hold the alternate return index. + // Give it an integer index type and the subroutine name (for dumps). + // Attach it to the subroutine symbol in the localSymbols map. + // Initialize it to zero, the "fallthrough" alternate return value. + const auto &symbol = funit.getSubprogramSymbol(); + auto loc = toLocation(); + auto idxTy = builder->getIndexType(); + const auto altResult = + builder->createTemporary(loc, idxTy, toStringRef(symbol.name())); + addSymbol(symbol, altResult); + const auto zero = builder->createIntegerConstant(loc, idxTy, 0); + builder->create(loc, zero, altResult); + } + + if (alternateEntryEval) { + genFIRBranch(alternateEntryEval->block); + builder->setInsertionPointToStart( + builder->createBlock(&builder->getRegion())); + } + } + + /// Create empty blocks for the current function. + void createEmptyBlocks( + std::list &evaluationList) { + auto *region = &builder->getRegion(); + for (auto &eval : evaluationList) { + if (eval.isNewBlock) + eval.block = builder->createBlock(region); + if (eval.isConstruct() || eval.isDirective()) { + if (eval.lowerAsUnstructured()) { + createEmptyBlocks(eval.getNestedEvaluations()); + } else if (eval.hasNestedEvaluations()) { + // A structured construct that is a target starts a new block. + auto &constructStmt = eval.getFirstNestedEvaluation(); + if (constructStmt.isNewBlock) + constructStmt.block = builder->createBlock(region); + } + } + } + } + + /// Return the predicate: "current block does not have a terminator branch". + bool blockIsUnterminated() { + auto *currentBlock = builder->getBlock(); + return currentBlock->empty() || + !currentBlock->back().hasTrait(); + } + + /// Unconditionally switch code insertion to a new block. + void startBlock(mlir::Block *newBlock) { + assert(newBlock && "missing block"); + if (blockIsUnterminated()) + genFIRBranch(newBlock); // default termination is a fallthrough branch + builder->setInsertionPointToEnd(newBlock); // newBlock might not be empty + } + + /// Conditionally switch code insertion to a new block. + void maybeStartBlock(mlir::Block *newBlock) { + if (newBlock) + startBlock(newBlock); + } + + /// Emit return and cleanup after the function has been translated. + void endNewFunction(Fortran::lower::pft::FunctionLikeUnit &funit) { + setCurrentPosition(Fortran::lower::pft::stmtSourceLoc(funit.endStmt)); + if (funit.isMainProgram()) + genExitRoutine(); + else + genFIRProcedureExit(funit, funit.getSubprogramSymbol()); + funit.finalBlock = nullptr; + LLVM_DEBUG(llvm::dbgs() << "*** Lowering result:\n\n" + << *builder->getFunction() << '\n'); + // FIXME: Simplification should happen in a normal pass, not here. + mlir::IRRewriter rewriter(*builder); + (void)mlir::simplifyRegions(rewriter, + {builder->getRegion()}); // remove dead code + delete builder; + builder = nullptr; + hostAssocTuple = mlir::Value{}; + localSymbols.clear(); + } + + /// Instantiate the data from a BLOCK DATA unit. + void lowerBlockData(Fortran::lower::pft::BlockDataUnit &bdunit) { + // FIXME: get rid of the bogus function context and instantiate the + // globals directly into the module. + auto *context = &getMLIRContext(); + auto func = fir::FirOpBuilder::createFunction( + mlir::UnknownLoc::get(context), getModuleOp(), + fir::NameUniquer::doGenerated("Sham"), + mlir::FunctionType::get(context, llvm::None, llvm::None)); + + builder = new fir::FirOpBuilder(func, bridge.getKindMap()); + Fortran::lower::AggregateStoreMap fakeMap; + for (const auto &[_, sym] : bdunit.symTab) { + if (sym->has()) { + Fortran::lower::pft::Variable var(*sym, true); + instantiateVar(var, fakeMap); + } + } + + if (auto *region = func.getCallableRegion()) + region->dropAllReferences(); + func.erase(); + delete builder; + builder = nullptr; + localSymbols.clear(); + } + + /// Lower a procedure (nest). + void lowerFunc(Fortran::lower::pft::FunctionLikeUnit &funit) { + setCurrentPosition(funit.getStartingSourceLoc()); + for (int entryIndex = 0, last = funit.entryPointList.size(); + entryIndex < last; ++entryIndex) { + funit.setActiveEntry(entryIndex); + startNewFunction(funit); // the entry point for lowering this procedure + for (auto &eval : funit.evaluationList) + genFIR(eval); + endNewFunction(funit); + } + funit.setActiveEntry(0); + for (auto &f : funit.nestedFunctions) + lowerFunc(f); // internal procedure + } + + /// Lower module variable definitions to fir::globalOp + void lowerModuleVariables(Fortran::lower::pft::ModuleLikeUnit &mod) { + // FIXME: get rid of the bogus function context and instantiate the + // globals directly into the module. + auto *context = &getMLIRContext(); + setCurrentPosition(mod.getStartingSourceLoc()); + auto func = fir::FirOpBuilder::createFunction( + mlir::UnknownLoc::get(context), getModuleOp(), + fir::NameUniquer::doGenerated("ModuleSham"), + mlir::FunctionType::get(context, llvm::None, llvm::None)); + builder = new fir::FirOpBuilder(func, bridge.getKindMap()); + for (const auto &var : mod.getOrderedSymbolTable()) + Fortran::lower::defineModuleVariable(*this, var); + if (auto *region = func.getCallableRegion()) + region->dropAllReferences(); + func.erase(); + delete builder; + builder = nullptr; + } + + /// Lower functions contained in a module. + void lowerMod(Fortran::lower::pft::ModuleLikeUnit &mod) { + for (auto &f : mod.nestedFunctions) + lowerFunc(f); + } + + void setCurrentPosition(const Fortran::parser::CharBlock &position) { + if (position != Fortran::parser::CharBlock{}) + currentPosition = position; + } + + //===--------------------------------------------------------------------===// + // Utility methods + //===--------------------------------------------------------------------===// + + /// Convert a parser CharBlock to a Location + mlir::Location toLocation(const Fortran::parser::CharBlock &cb) { + return genLocation(cb); + } + + mlir::Location toLocation() { return toLocation(currentPosition); } + void setCurrentEval(Fortran::lower::pft::Evaluation &eval) { + evalPtr = &eval; + } + Fortran::lower::pft::Evaluation &getEval() { + assert(evalPtr); + return *evalPtr; + } + + std::optional + getShape(const Fortran::lower::SomeExpr &expr) { + return Fortran::evaluate::GetShape(foldingContext, expr); + } + + //===--------------------------------------------------------------------===// + // Analysis on a nested explicit iteration space. + //===--------------------------------------------------------------------===// + + void analyzeExplicitSpace(const Fortran::parser::ConcurrentHeader &header) { + explicitIterSpace.pushLevel(); + for (const auto &ctrl : + std::get>(header.t)) { + const auto *ctrlVar = std::get(ctrl.t).symbol; + explicitIterSpace.addSymbol(ctrlVar); + } + if (const auto &mask = + std::get>( + header.t); + mask.has_value()) + analyzeExplicitSpace(*Fortran::semantics::GetExpr(*mask)); + } + template + void analyzeExplicitSpace(const Fortran::evaluate::Expr &e) { + explicitIterSpace.exprBase(&e, LHS); + } + void analyzeExplicitSpace(const Fortran::evaluate::Assignment *assign) { + analyzeExplicitSpace(assign->lhs); + analyzeExplicitSpace(assign->rhs); + explicitIterSpace.endAssign(); + } + void analyzeExplicitSpace(const Fortran::parser::ForallAssignmentStmt &stmt) { + std::visit([&](const auto &s) { analyzeExplicitSpace(s); }, stmt.u); + } + void analyzeExplicitSpace(const Fortran::parser::AssignmentStmt &s) { + analyzeExplicitSpace(s.typedAssignment->v.operator->()); + } + void analyzeExplicitSpace(const Fortran::parser::PointerAssignmentStmt &s) { + analyzeExplicitSpace(s.typedAssignment->v.operator->()); + } + void analyzeExplicitSpace(const Fortran::parser::WhereConstruct &c) { + analyzeExplicitSpace( + std::get< + Fortran::parser::Statement>( + c.t) + .statement); + for (const auto &body : + std::get>(c.t)) + analyzeExplicitSpace(body); + for (const auto &e : + std::get>( + c.t)) + analyzeExplicitSpace(e); + if (const auto &e = + std::get>( + c.t); + e.has_value()) + analyzeExplicitSpace(e.operator->()); + } + void analyzeExplicitSpace(const Fortran::parser::WhereConstructStmt &ws) { + auto *exp = Fortran::semantics::GetExpr( + std::get(ws.t)); + addMaskVariable(exp); + analyzeExplicitSpace(*exp); + } + void analyzeExplicitSpace( + const Fortran::parser::WhereConstruct::MaskedElsewhere &ew) { + analyzeExplicitSpace( + std::get< + Fortran::parser::Statement>( + ew.t) + .statement); + for (const auto &e : + std::get>(ew.t)) + analyzeExplicitSpace(e); + } + void analyzeExplicitSpace(const Fortran::parser::WhereBodyConstruct &body) { + std::visit(Fortran::common::visitors{ + [&](const Fortran::common::Indirection< + Fortran::parser::WhereConstruct> &wc) { + analyzeExplicitSpace(wc.value()); + }, + [&](const auto &s) { analyzeExplicitSpace(s.statement); }}, + body.u); + } + void analyzeExplicitSpace(const Fortran::parser::MaskedElsewhereStmt &stmt) { + auto *exp = Fortran::semantics::GetExpr( + std::get(stmt.t)); + addMaskVariable(exp); + analyzeExplicitSpace(*exp); + } + void + analyzeExplicitSpace(const Fortran::parser::WhereConstruct::Elsewhere *ew) { + for (const auto &e : + std::get>(ew->t)) + analyzeExplicitSpace(e); + } + void analyzeExplicitSpace(const Fortran::parser::WhereStmt &stmt) { + auto *exp = Fortran::semantics::GetExpr( + std::get(stmt.t)); + addMaskVariable(exp); + analyzeExplicitSpace(*exp); + const auto &assign = + std::get(stmt.t).typedAssignment->v; + assert(assign.has_value() && "WHERE has no statement"); + analyzeExplicitSpace(assign.operator->()); + } + void analyzeExplicitSpace(const Fortran::parser::ForallStmt &forall) { + analyzeExplicitSpace( + std::get< + Fortran::common::Indirection>( + forall.t) + .value()); + analyzeExplicitSpace(std::get>(forall.t) + .statement); + analyzeExplicitSpacePop(); + } + void + analyzeExplicitSpace(const Fortran::parser::ForallConstructStmt &forall) { + analyzeExplicitSpace( + std::get< + Fortran::common::Indirection>( + forall.t) + .value()); + } + void analyzeExplicitSpace(const Fortran::parser::ForallConstruct &forall) { + analyzeExplicitSpace( + std::get< + Fortran::parser::Statement>( + forall.t) + .statement); + for (const auto &s : + std::get>(forall.t)) { + std::visit(Fortran::common::visitors{ + [&](const Fortran::common::Indirection< + Fortran::parser::ForallConstruct> &b) { + analyzeExplicitSpace(b.value()); + }, + [&](const Fortran::parser::WhereConstruct &w) { + analyzeExplicitSpace(w); + }, + [&](const auto &b) { analyzeExplicitSpace(b.statement); }}, + s.u); + } + analyzeExplicitSpacePop(); + } + + void analyzeExplicitSpacePop() { explicitIterSpace.popLevel(); } + + void addMaskVariable(Fortran::lower::FrontEndExpr exp) { + // Note: use i8 to store bool values. This avoids round-down behavior found + // with sequences of i1. That is, an array of i1 will be truncated in size + // and be too small. For example, a buffer of type fir.array<7xi1> will have + // 0 size. + auto ty = fir::HeapType::get(builder->getIntegerType(8)); + auto loc = toLocation(); + auto var = builder->createTemporary(loc, ty); + auto nil = builder->createNullConstant(loc, ty); + builder->create(loc, nil, var); + auto shTy = fir::HeapType::get(builder->getIndexType()); + auto shape = builder->createTemporary(loc, shTy); + auto nilSh = builder->createNullConstant(loc, shTy); + builder->create(loc, nilSh, shape); + implicitIterSpace.addMaskVariable(exp, var, shape); + explicitIterSpace.outermostContext().attachCleanup([=]() { + auto load = builder->create(loc, var); + auto cmp = builder->genIsNotNull(loc, load); + builder->genIfThen(loc, cmp) + .genThen([&]() { builder->create(loc, load); }) + .end(); + }); + } + + //===--------------------------------------------------------------------===// + + Fortran::lower::LoweringBridge &bridge; + Fortran::evaluate::FoldingContext foldingContext; + fir::FirOpBuilder *builder = nullptr; + Fortran::lower::pft::Evaluation *evalPtr = nullptr; + Fortran::lower::SymMap localSymbols; + Fortran::parser::CharBlock currentPosition; + + /// WHERE statement/construct mask expression stack. + Fortran::lower::ImplicitIterSpace implicitIterSpace; + + /// FORALL context + Fortran::lower::ExplicitIterSpace explicitIterSpace; + + /// Tuple of host assoicated variables. + mlir::Value hostAssocTuple; +}; + +} // namespace + +Fortran::evaluate::FoldingContext +Fortran::lower::LoweringBridge::createFoldingContext() const { + return {getDefaultKinds(), getIntrinsicTable()}; +} + +void Fortran::lower::LoweringBridge::lower( + const Fortran::parser::Program &prg, + const Fortran::semantics::SemanticsContext &semanticsContext) { + auto pft = Fortran::lower::createPFT(prg, semanticsContext); + if (dumpBeforeFir) + Fortran::lower::dumpPFT(llvm::errs(), *pft); + FirConverter converter{*this}; + converter.run(*pft); +} + +void Fortran::lower::LoweringBridge::parseSourceFile(llvm::SourceMgr &srcMgr) { + auto owningRef = mlir::parseSourceFile(srcMgr, &context); + module.reset(new mlir::ModuleOp(owningRef.get().getOperation())); + owningRef.release(); +} + +Fortran::lower::LoweringBridge::LoweringBridge( + mlir::MLIRContext &context, + const Fortran::common::IntrinsicTypeDefaultKinds &defaultKinds, + const Fortran::evaluate::IntrinsicProcTable &intrinsics, + const Fortran::parser::AllCookedSources &cooked, llvm::StringRef triple, + fir::KindMapping &kindMap) + : defaultKinds{defaultKinds}, intrinsics{intrinsics}, cooked{&cooked}, + context{context}, kindMap{kindMap} { + // Register the diagnostic handler. + context.getDiagEngine().registerHandler([](mlir::Diagnostic &diag) { + auto &os = llvm::errs(); + switch (diag.getSeverity()) { + case mlir::DiagnosticSeverity::Error: + os << "error: "; + break; + case mlir::DiagnosticSeverity::Remark: + os << "info: "; + break; + case mlir::DiagnosticSeverity::Warning: + os << "warning: "; + break; + default: + break; + } + if (!diag.getLocation().isa()) + os << diag.getLocation() << ": "; + os << diag << '\n'; + os.flush(); + return mlir::success(); + }); + + // Create the module and attach the attributes. + module = std::make_unique( + mlir::ModuleOp::create(mlir::UnknownLoc::get(&context))); + assert(module.get() && "module was not created"); + fir::setTargetTriple(*module.get(), triple); + fir::setKindMapping(*module.get(), kindMap); +} diff --git a/flang/lib/Lower/BuiltinModules.h b/flang/lib/Lower/BuiltinModules.h new file mode 100644 index 00000000000000..5e251d6060c47c --- /dev/null +++ b/flang/lib/Lower/BuiltinModules.h @@ -0,0 +1,26 @@ +//===-- BuiltinModules.h --------------------------------------*- C++ -*-===// +// +// 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 +// +//===----------------------------------------------------------------------===// +// +// Coding style: https://mlir.llvm.org/getting_started/DeveloperGuide/ +// +//===----------------------------------------------------------------------===// +/// +/// Define information about builtin derived types from flang/module/xxx.f90 +/// files so that these types can be manipulated by lowering. +/// +//===----------------------------------------------------------------------===// + +#ifndef FORTRAN_LOWER_BUILTINMODULES_H +#define FORTRAN_LOWER_BUILTINMODULES_H + +namespace Fortran::lower::builtin { +/// Address field name of __builtin_c_f_pointer and __builtin_c_ptr types. +constexpr char cptrFieldName[] = "__address"; +} // namespace Fortran::lower::builtin + +#endif // FORTRAN_LOWER_BUILTINMODULES_H diff --git a/flang/lib/Lower/CMakeLists.txt b/flang/lib/Lower/CMakeLists.txt index 07b87ef22ce924..f44d1ea35f72b3 100644 --- a/flang/lib/Lower/CMakeLists.txt +++ b/flang/lib/Lower/CMakeLists.txt @@ -1,27 +1,40 @@ + get_property(dialect_libs GLOBAL PROPERTY MLIR_DIALECT_LIBS) add_flang_library(FortranLower - CharacterExpr.cpp - CharacterRuntime.cpp + Allocatable.cpp + Bridge.cpp + CallInterface.cpp Coarray.cpp - ComplexExpr.cpp - ConvertType.cpp ConvertExpr.cpp - DoLoopHelper.cpp - FIRBuilder.cpp + ConvertType.cpp + ConvertVariable.cpp + HostAssociations.cpp IntrinsicCall.cpp IO.cpp + IterationSpace.cpp Mangler.cpp OpenACC.cpp OpenMP.cpp PFTBuilder.cpp + Runtime.cpp + SymbolMap.cpp + VectorSubscripts.cpp DEPENDS - FIROptimizer + FIRBuilder + FIRDialect + FIRSupport + FIRTransforms ${dialect_libs} + omp_gen + acc_gen LINK_LIBS - FIROptimizer + FIRBuilder + FIRDialect + FIRSupport + FIRTransforms ${dialect_libs} FortranCommon FortranParser diff --git a/flang/lib/Lower/CallInterface.cpp b/flang/lib/Lower/CallInterface.cpp new file mode 100644 index 00000000000000..af6c8e3272f984 --- /dev/null +++ b/flang/lib/Lower/CallInterface.cpp @@ -0,0 +1,1034 @@ +//===-- CallInterface.cpp -- Procedure call interface ---------------------===// +// +// 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 +// +//===----------------------------------------------------------------------===// + +#include "flang/Lower/CallInterface.h" +#include "StatementContext.h" +#include "flang/Evaluate/fold.h" +#include "flang/Lower/Bridge.h" +#include "flang/Lower/Mangler.h" +#include "flang/Lower/PFTBuilder.h" +#include "flang/Lower/Todo.h" +#include "flang/Optimizer/Builder/FIRBuilder.h" +#include "flang/Optimizer/Dialect/FIRDialect.h" +#include "flang/Optimizer/Dialect/FIROpsSupport.h" +#include "flang/Optimizer/Support/InternalNames.h" +#include "flang/Semantics/symbol.h" +#include "flang/Semantics/tools.h" + +//===----------------------------------------------------------------------===// +// BIND(C) mangling helpers +//===----------------------------------------------------------------------===// + +// Return the binding label (from BIND(C...)) or the mangled name of a symbol. +static std::string getMangledName(const Fortran::semantics::Symbol &symbol) { + const std::string *bindName = symbol.GetBindName(); + return bindName ? *bindName : Fortran::lower::mangle::mangleName(symbol); +} + +//===----------------------------------------------------------------------===// +// Caller side interface implementation +//===----------------------------------------------------------------------===// + +bool Fortran::lower::CallerInterface::hasAlternateReturns() const { + return procRef.hasAlternateReturns(); +} + +std::string Fortran::lower::CallerInterface::getMangledName() const { + const auto &proc = procRef.proc(); + if (const auto *symbol = proc.GetSymbol()) + return ::getMangledName(symbol->GetUltimate()); + assert(proc.GetSpecificIntrinsic() && + "expected intrinsic procedure in designator"); + return proc.GetName(); +} + +const Fortran::semantics::Symbol * +Fortran::lower::CallerInterface::getProcedureSymbol() const { + return procRef.proc().GetSymbol(); +} + +bool Fortran::lower::CallerInterface::isIndirectCall() const { + if (const auto *symbol = procRef.proc().GetSymbol()) + return Fortran::semantics::IsPointer(*symbol) || + Fortran::semantics::IsDummy(*symbol); + return false; +} + +const Fortran::semantics::Symbol * +Fortran::lower::CallerInterface::getIfIndirectCallSymbol() const { + if (const auto *symbol = procRef.proc().GetSymbol()) + if (Fortran::semantics::IsPointer(*symbol) || + Fortran::semantics::IsDummy(*symbol)) + return symbol; + return nullptr; +} + +mlir::Location Fortran::lower::CallerInterface::getCalleeLocation() const { + const auto &proc = procRef.proc(); + // FIXME: If the callee is defined in the same file but after the current + // unit we cannot get its location here and the funcOp is created at the + // wrong location (i.e, the caller location). + if (const auto *symbol = proc.GetSymbol()) + return converter.genLocation(symbol->name()); + // Unknown location for intrinsics. + return converter.genLocation(); +} + +// Get dummy argument characteristic for a procedure with implicit interface +// from the actual argument characteristic. The actual argument may not be a F77 +// entity. The attribute must be dropped and the shape, if any, must be made +// explicit. +static Fortran::evaluate::characteristics::DummyDataObject +asImplicitArg(Fortran::evaluate::characteristics::DummyDataObject &&dummy) { + Fortran::evaluate::Shape shape = + dummy.type.attrs().none() ? dummy.type.shape() + : Fortran::evaluate::Shape(dummy.type.Rank()); + return Fortran::evaluate::characteristics::DummyDataObject( + Fortran::evaluate::characteristics::TypeAndShape(dummy.type.type(), + std::move(shape))); +} + +static Fortran::evaluate::characteristics::DummyArgument +asImplicitArg(Fortran::evaluate::characteristics::DummyArgument &&dummy) { + return std::visit( + Fortran::common::visitors{ + [&](Fortran::evaluate::characteristics::DummyDataObject &obj) { + return Fortran::evaluate::characteristics::DummyArgument( + std::move(dummy.name), asImplicitArg(std::move(obj))); + }, + [&](Fortran::evaluate::characteristics::DummyProcedure &proc) { + return Fortran::evaluate::characteristics::DummyArgument( + std::move(dummy.name), std::move(proc)); + }, + [](Fortran::evaluate::characteristics::AlternateReturn &x) { + return Fortran::evaluate::characteristics::DummyArgument( + std::move(x)); + }}, + dummy.u); +} + +Fortran::evaluate::characteristics::Procedure +Fortran::lower::CallerInterface::characterize() const { + auto &foldingContext = converter.getFoldingContext(); + auto characteristic = + Fortran::evaluate::characteristics::Procedure::Characterize( + procRef.proc(), foldingContext); + assert(characteristic && "Failed to get characteristic from procRef"); + // The characteristic may not contain the argument characteristic if the + // ProcedureDesignator has no interface. + if (!characteristic->HasExplicitInterface()) { + for (const auto &arg : procRef.arguments()) { + if (arg.value().isAlternateReturn()) { + characteristic->dummyArguments.emplace_back( + Fortran::evaluate::characteristics::AlternateReturn{}); + } else { + // Argument cannot be optional with implicit interface + const auto *expr = arg.value().UnwrapExpr(); + assert( + expr && + "argument in call with implicit interface cannot be assumed type"); + auto argCharacteristic = + Fortran::evaluate::characteristics::DummyArgument::FromActual( + "actual", *expr, foldingContext); + assert(argCharacteristic && + "failed to characterize argument in implicit call"); + characteristic->dummyArguments.emplace_back( + asImplicitArg(std::move(*argCharacteristic))); + } + } + } + return *characteristic; +} + +void Fortran::lower::CallerInterface::placeInput( + const PassedEntity &passedEntity, mlir::Value arg) { + assert(static_cast(actualInputs.size()) > passedEntity.firArgument && + passedEntity.firArgument >= 0 && + passedEntity.passBy != CallInterface::PassEntityBy::AddressAndLength && + "bad arg position"); + actualInputs[passedEntity.firArgument] = arg; +} + +void Fortran::lower::CallerInterface::placeAddressAndLengthInput( + const PassedEntity &passedEntity, mlir::Value addr, mlir::Value len) { + assert(static_cast(actualInputs.size()) > passedEntity.firArgument && + static_cast(actualInputs.size()) > passedEntity.firLength && + passedEntity.firArgument >= 0 && passedEntity.firLength >= 0 && + passedEntity.passBy == CallInterface::PassEntityBy::AddressAndLength && + "bad arg position"); + actualInputs[passedEntity.firArgument] = addr; + actualInputs[passedEntity.firLength] = len; +} + +bool Fortran::lower::CallerInterface::verifyActualInputs() const { + if (getNumFIRArguments() != actualInputs.size()) + return false; + for (auto arg : actualInputs) { + if (!arg) + return false; + } + return true; +} + +template +static inline auto AsGenericExpr(T e) { + return Fortran::evaluate::AsGenericExpr(Fortran::common::Clone(e)); +} + +void Fortran::lower::CallerInterface::walkResultLengths( + ExprVisitor visitor) const { + assert(characteristic && "characteristic was not computed"); + const auto &result = characteristic->functionResult.value(); + const auto *typeAndShape = result.GetTypeAndShape(); + assert(typeAndShape && "no result type"); + auto dynamicType = typeAndShape->type(); + // Visit result length specification expressions that are explicit. + if (dynamicType.category() == Fortran::common::TypeCategory::Character) { + if (auto length = dynamicType.GetCharLength()) + visitor(AsGenericExpr(*length)); + } else if (dynamicType.category() == common::TypeCategory::Derived) { + const auto &derivedTypeSpec = dynamicType.GetDerivedTypeSpec(); + if (Fortran::semantics::CountLenParameters(derivedTypeSpec) > 0) + TODO(converter.genLocation(), + "function result with derived type length parameters"); + } +} + +void Fortran::lower::CallerInterface::walkResultExtents( + ExprVisitor visitor) const { + using Attr = Fortran::evaluate::characteristics::TypeAndShape::Attr; + assert(characteristic && "characteristic was not computed"); + const auto &result = characteristic->functionResult.value(); + const auto *typeAndShape = result.GetTypeAndShape(); + assert(typeAndShape && "no result type"); + if (typeAndShape->attrs().test(Attr::DeferredShape)) + return; + for (auto extent : typeAndShape->shape()) + visitor(AsGenericExpr(extent.value())); +} + +bool Fortran::lower::CallerInterface::mustMapInterfaceSymbols() const { + assert(characteristic && "characteristic was not computed"); + const auto &result = characteristic->functionResult; + if (!result || result->CanBeReturnedViaImplicitInterface()) + return false; + bool allResultSpecExprConstant = true; + auto visitor = [&](const Fortran::lower::SomeExpr &e) { + allResultSpecExprConstant &= Fortran::evaluate::IsConstantExpr(e); + }; + walkResultLengths(visitor); + walkResultExtents(visitor); + return !allResultSpecExprConstant; +} + +mlir::Value Fortran::lower::CallerInterface::getArgumentValue( + const semantics::Symbol &sym) const { + auto loc = converter.genLocation(); + const auto *iface = procRef.proc().GetInterfaceSymbol(); + + if (!iface) + fir::emitFatalError( + loc, "mapping actual and dummy arguments requires an interface"); + const auto &dummies = iface->get().dummyArgs(); + auto it = std::find(dummies.begin(), dummies.end(), &sym); + if (it == dummies.end()) + fir::emitFatalError(loc, "symbol is not a dummy in this call"); + auto mlirArgIndex = passedArguments[it - dummies.begin()].firArgument; + return actualInputs[mlirArgIndex]; +} + +mlir::Type Fortran::lower::CallerInterface::getResultStorageType() const { + if (passedResult) + return fir::dyn_cast_ptrEleTy(inputs[passedResult->firArgument].type); + assert(saveResult && !outputs.empty()); + return outputs[0].type; +} + +const Fortran::semantics::Symbol & +Fortran::lower::CallerInterface::getResultSymbol() const { + auto loc = converter.genLocation(); + const auto *iface = procRef.proc().GetInterfaceSymbol(); + if (!iface) + fir::emitFatalError( + loc, "mapping actual and dummy arguments requires an interface"); + return iface->get().result(); +} + +//===----------------------------------------------------------------------===// +// Callee side interface implementation +//===----------------------------------------------------------------------===// + +bool Fortran::lower::CalleeInterface::hasAlternateReturns() const { + return !funit.isMainProgram() && + Fortran::semantics::HasAlternateReturns(funit.getSubprogramSymbol()); +} + +std::string Fortran::lower::CalleeInterface::getMangledName() const { + if (funit.isMainProgram()) + return fir::NameUniquer::doProgramEntry().str(); + return ::getMangledName(funit.getSubprogramSymbol()); +} + +const Fortran::semantics::Symbol * +Fortran::lower::CalleeInterface::getProcedureSymbol() const { + if (funit.isMainProgram()) + return nullptr; + return &funit.getSubprogramSymbol(); +} + +mlir::Location Fortran::lower::CalleeInterface::getCalleeLocation() const { + // FIXME: do NOT use unknown for the anonymous PROGRAM case. We probably + // should just stash the location in the funit regardless. + return converter.genLocation(funit.getStartingSourceLoc()); +} + +Fortran::evaluate::characteristics::Procedure +Fortran::lower::CalleeInterface::characterize() const { + auto &foldingContext = converter.getFoldingContext(); + auto characteristic = + Fortran::evaluate::characteristics::Procedure::Characterize( + funit.getSubprogramSymbol(), foldingContext); + assert(characteristic && "Fail to get characteristic from symbol"); + return *characteristic; +} + +bool Fortran::lower::CalleeInterface::isMainProgram() const { + return funit.isMainProgram(); +} + +mlir::FuncOp Fortran::lower::CalleeInterface::addEntryBlockAndMapArguments() { + // On the callee side, directly map the mlir::value argument of + // the function block to the Fortran symbols. + func.addEntryBlock(); + mapPassedEntities(); + return func; +} + +bool Fortran::lower::CalleeInterface::hasHostAssociated() const { + return funit.parentHasHostAssoc(); +} + +mlir::Type Fortran::lower::CalleeInterface::getHostAssociatedTy() const { + assert(hasHostAssociated()); + return funit.parentHostAssoc().getArgumentType(converter); +} + +mlir::Value Fortran::lower::CalleeInterface::getHostAssociatedTuple() const { + assert(hasHostAssociated() || !funit.getHostAssoc().empty()); + return converter.hostAssocTupleValue(); +} + +//===----------------------------------------------------------------------===// +// CallInterface implementation: this part is common to both caller and caller +// sides. +//===----------------------------------------------------------------------===// + +static void addSymbolAttribute(mlir::FuncOp func, + const Fortran::semantics::Symbol &sym, + mlir::MLIRContext &mlirContext) { + // Only add this on bind(C) functions for which the symbol is not reflected in + // the current context. + if (!Fortran::semantics::IsBindCProcedure(sym)) + return; + auto name = + Fortran::lower::mangle::mangleName(sym, /*keepExternalInScope=*/true); + auto strAttr = mlir::StringAttr::get(&mlirContext, name); + func->setAttr(fir::getSymbolAttrName(), strAttr); +} + +/// Declare drives the different actions to be performed while analyzing the +/// signature and building/finding the mlir::FuncOp. +template +void Fortran::lower::CallInterface::declare() { + if (!side().isMainProgram()) { + characteristic.emplace(side().characterize()); + auto isImplicit = characteristic->CanBeCalledViaImplicitInterface(); + determineInterface(isImplicit, *characteristic); + } + // No input/output for main program + + // Create / get funcOp for direct calls. For indirect calls (only meaningful + // on the caller side), no funcOp has to be created here. The mlir::Value + // holding the indirection is used when creating the fir::CallOp. + if (!side().isIndirectCall()) { + auto name = side().getMangledName(); + auto module = converter.getModuleOp(); + func = fir::FirOpBuilder::getNamedFunction(module, name); + if (!func) { + mlir::Location loc = side().getCalleeLocation(); + mlir::FunctionType ty = genFunctionType(); + func = fir::FirOpBuilder::createFunction(loc, module, name, ty); + if (const auto *sym = side().getProcedureSymbol()) + addSymbolAttribute(func, *sym, converter.getMLIRContext()); + for (const auto &placeHolder : llvm::enumerate(inputs)) + if (!placeHolder.value().attributes.empty()) + func.setArgAttrs(placeHolder.index(), placeHolder.value().attributes); + } + } +} + +/// Once the signature has been analyzed and the mlir::FuncOp was built/found, +/// map the fir inputs to Fortran entities (the symbols or expressions). +template +void Fortran::lower::CallInterface::mapPassedEntities() { + // map back fir inputs to passed entities + if constexpr (std::is_same_v) { + assert(inputs.size() == func.front().getArguments().size() && + "function previously created with different number of arguments"); + for (auto [fst, snd] : llvm::zip(inputs, func.front().getArguments())) + mapBackInputToPassedEntity(fst, snd); + } else { + // On the caller side, map the index of the mlir argument position + // to Fortran ActualArguments. + auto firPosition = 0; + for (const auto &placeHolder : inputs) + mapBackInputToPassedEntity(placeHolder, firPosition++); + } +} + +template +void Fortran::lower::CallInterface::mapBackInputToPassedEntity( + const FirPlaceHolder &placeHolder, FirValue firValue) { + auto &passedEntity = + placeHolder.passedEntityPosition == FirPlaceHolder::resultEntityPosition + ? passedResult.value() + : passedArguments[placeHolder.passedEntityPosition]; + if (placeHolder.property == Property::CharLength) + passedEntity.firLength = firValue; + else + passedEntity.firArgument = firValue; +} + +/// Helpers to access ActualArgument/Symbols +static const Fortran::evaluate::ActualArguments & +getEntityContainer(const Fortran::evaluate::ProcedureRef &proc) { + return proc.arguments(); +} + +static const std::vector & +getEntityContainer(Fortran::lower::pft::FunctionLikeUnit &funit) { + return funit.getSubprogramSymbol() + .get() + .dummyArgs(); +} + +static const Fortran::evaluate::ActualArgument *getDataObjectEntity( + const std::optional &arg) { + if (arg) + return &*arg; + return nullptr; +} + +static const Fortran::semantics::Symbol & +getDataObjectEntity(const Fortran::semantics::Symbol *arg) { + assert(arg && "expect symbol for data object entity"); + return *arg; +} + +static const Fortran::evaluate::ActualArgument * +getResultEntity(const Fortran::evaluate::ProcedureRef &) { + return nullptr; +} + +static const Fortran::semantics::Symbol & +getResultEntity(Fortran::lower::pft::FunctionLikeUnit &funit) { + const auto &details = + funit.getSubprogramSymbol().get(); + return details.result(); +} + +/// Bypass helpers to manipulate entities since they are not any symbol/actual +/// argument to associate. See SignatureBuilder below. +using FakeEntity = bool; +using FakeEntities = llvm::SmallVector; +static FakeEntities +getEntityContainer(const Fortran::evaluate::characteristics::Procedure &proc) { + FakeEntities enities(proc.dummyArguments.size()); + return enities; +} +static const FakeEntity &getDataObjectEntity(const FakeEntity &e) { return e; } +static FakeEntity +getResultEntity(const Fortran::evaluate::characteristics::Procedure &proc) { + return false; +} + +/// This is the actual part that defines the FIR interface based on the +/// characteristic. It directly mutates the CallInterface members. +template +class Fortran::lower::CallInterfaceImpl { + using CallInterface = Fortran::lower::CallInterface; + using PassEntityBy = typename CallInterface::PassEntityBy; + using PassedEntity = typename CallInterface::PassedEntity; + using FirValue = typename CallInterface::FirValue; + using FortranEntity = typename CallInterface::FortranEntity; + using FirPlaceHolder = typename CallInterface::FirPlaceHolder; + using Property = typename CallInterface::Property; + using TypeAndShape = Fortran::evaluate::characteristics::TypeAndShape; + using DummyCharacteristics = + Fortran::evaluate::characteristics::DummyArgument; + +public: + CallInterfaceImpl(CallInterface &i) + : interface(i), mlirContext{i.converter.getMLIRContext()} {} + + void buildImplicitInterface( + const Fortran::evaluate::characteristics::Procedure &procedure) { + // Handle result + if (const auto &result = procedure.functionResult) + handleImplicitResult(*result); + else if (interface.side().hasAlternateReturns()) + addFirResult(mlir::IndexType::get(&mlirContext), + FirPlaceHolder::resultEntityPosition, Property::Value); + // Handle arguments + const auto &argumentEntities = + getEntityContainer(interface.side().getCallDescription()); + for (auto pair : llvm::zip(procedure.dummyArguments, argumentEntities)) { + const auto &argCharacteristics = std::get<0>(pair); + std::visit( + Fortran::common::visitors{ + [&](const auto &dummy) { + const auto &entity = getDataObjectEntity(std::get<1>(pair)); + handleImplicitDummy(&argCharacteristics, dummy, entity); + }, + [&](const Fortran::evaluate::characteristics::AlternateReturn &) { + // nothing to do + }, + }, + argCharacteristics.u); + } + } + + void buildExplicitInterface( + const Fortran::evaluate::characteristics::Procedure &procedure) { + // Handle result + if (const auto &result = procedure.functionResult) { + if (result->CanBeReturnedViaImplicitInterface()) + handleImplicitResult(*result); + else + handleExplicitResult(*result); + } else if (interface.side().hasAlternateReturns()) { + addFirResult(mlir::IndexType::get(&mlirContext), + FirPlaceHolder::resultEntityPosition, Property::Value); + } + // Handle arguments + const auto &argumentEntities = + getEntityContainer(interface.side().getCallDescription()); + for (auto pair : llvm::zip(procedure.dummyArguments, argumentEntities)) { + const auto &argCharacteristics = std::get<0>(pair); + std::visit( + Fortran::common::visitors{ + [&](const Fortran::evaluate::characteristics::DummyDataObject + &dummy) { + const auto &entity = getDataObjectEntity(std::get<1>(pair)); + if (dummy.CanBePassedViaImplicitInterface()) + handleImplicitDummy(&argCharacteristics, dummy, entity); + else + handleExplicitDummy(&argCharacteristics, dummy, entity); + }, + [&](const Fortran::evaluate::characteristics::DummyProcedure + &dummy) { + const auto &entity = getDataObjectEntity(std::get<1>(pair)); + handleImplicitDummy(&argCharacteristics, dummy, entity); + }, + [&](const Fortran::evaluate::characteristics::AlternateReturn &) { + // nothing to do + }, + }, + argCharacteristics.u); + } + } + + void appendHostAssocTupleArg(mlir::Type tupTy) { + auto *ctxt = tupTy.getContext(); + addFirOperand(tupTy, nextPassedArgPosition(), Property::BaseAddress, + {mlir::NamedAttribute{ + mlir::Identifier::get(fir::getHostAssocAttrName(), ctxt), + mlir::UnitAttr::get(ctxt)}}); + interface.passedArguments.emplace_back( + PassedEntity{PassEntityBy::BaseAddress, std::nullopt, + interface.side().getHostAssociatedTuple(), emptyValue()}); + } + +private: + void handleImplicitResult( + const Fortran::evaluate::characteristics::FunctionResult &result) { + if (result.IsProcedurePointer()) + TODO(interface.converter.genLocation(), + "procedure pointer result not yet handled"); + const auto *typeAndShape = result.GetTypeAndShape(); + assert(typeAndShape && "expect type for non proc pointer result"); + auto dynamicType = typeAndShape->type(); + // Character result allocated by caller and passed as hidden arguments + if (dynamicType.category() == Fortran::common::TypeCategory::Character) { + handleImplicitCharacterResult(dynamicType); + } else if (dynamicType.category() == + Fortran::common::TypeCategory::Derived) { + // Derived result need to be allocated by the caller and the result value + // must be saved. Derived type in implicit interface cannot have length + // parameters. + setSaveResult(); + auto mlirType = translateDynamicType(dynamicType); + addFirResult(mlirType, FirPlaceHolder::resultEntityPosition, + Property::Value); + } else { + // All result other than characters/derived are simply returned by value + // in implicit interfaces + auto mlirType = + getConverter().genType(dynamicType.category(), dynamicType.kind()); + addFirResult(mlirType, FirPlaceHolder::resultEntityPosition, + Property::Value); + } + } + void + handleImplicitCharacterResult(const Fortran::evaluate::DynamicType &type) { + auto resultPosition = FirPlaceHolder::resultEntityPosition; + setPassedResult(PassEntityBy::AddressAndLength, + getResultEntity(interface.side().getCallDescription())); + auto lenTy = mlir::IndexType::get(&mlirContext); + auto charRefTy = fir::ReferenceType::get( + fir::CharacterType::getUnknownLen(&mlirContext, type.kind())); + auto boxCharTy = fir::BoxCharType::get(&mlirContext, type.kind()); + addFirOperand(charRefTy, resultPosition, Property::CharAddress); + addFirOperand(lenTy, resultPosition, Property::CharLength); + /// For now, also return it by boxchar + addFirResult(boxCharTy, resultPosition, Property::BoxChar); + } + + void handleImplicitDummy( + const DummyCharacteristics *characteristics, + const Fortran::evaluate::characteristics::DummyDataObject &obj, + const FortranEntity &entity) { + auto dynamicType = obj.type.type(); + if (dynamicType.category() == Fortran::common::TypeCategory::Character) { + auto boxCharTy = fir::BoxCharType::get(&mlirContext, dynamicType.kind()); + addFirOperand(boxCharTy, nextPassedArgPosition(), Property::BoxChar); + addPassedArg(PassEntityBy::BoxChar, entity, characteristics); + } else { + // non-PDT derived type allowed in implicit interface. + auto type = translateDynamicType(dynamicType); + fir::SequenceType::Shape bounds = getBounds(obj.type.shape()); + if (!bounds.empty()) + type = fir::SequenceType::get(bounds, type); + auto refType = fir::ReferenceType::get(type); + + addFirOperand(refType, nextPassedArgPosition(), Property::BaseAddress); + addPassedArg(PassEntityBy::BaseAddress, entity, characteristics); + } + } + + // Define when an explicit argument must be passed in a fir.box. + bool dummyRequiresBox( + const Fortran::evaluate::characteristics::DummyDataObject &obj) { + using ShapeAttr = Fortran::evaluate::characteristics::TypeAndShape::Attr; + using ShapeAttrs = Fortran::evaluate::characteristics::TypeAndShape::Attrs; + constexpr ShapeAttrs shapeRequiringBox = { + ShapeAttr::AssumedShape, ShapeAttr::DeferredShape, + ShapeAttr::AssumedRank, ShapeAttr::Coarray}; + if ((obj.type.attrs() & shapeRequiringBox).any()) + // Need to pass shape/coshape info in fir.box. + return true; + if (obj.type.type().IsPolymorphic()) + // Need to pass dynamic type info in fir.box. + return true; + if (const auto *derived = + Fortran::evaluate::GetDerivedTypeSpec(obj.type.type())) + // Need to pass type parameters in fir.box if any. + return derived->parameters().empty(); + return false; + } + + mlir::Type + translateDynamicType(const Fortran::evaluate::DynamicType &dynamicType) { + auto cat = dynamicType.category(); + // DERIVED + if (cat == Fortran::common::TypeCategory::Derived) + return getConverter().genType(dynamicType.GetDerivedTypeSpec()); + // CHARACTER with compile time constant length. + if (cat == Fortran::common::TypeCategory::Character) + if (auto constantLen = toInt64(dynamicType.GetCharLength())) + return getConverter().genType(cat, dynamicType.kind(), {*constantLen}); + // INTEGER, REAL, LOGICAL, COMPLEX, and CHARACTER with dynamic length. + return getConverter().genType(cat, dynamicType.kind()); + } + + void handleExplicitDummy( + const DummyCharacteristics *characteristics, + const Fortran::evaluate::characteristics::DummyDataObject &obj, + const FortranEntity &entity) { + using Attrs = Fortran::evaluate::characteristics::DummyDataObject::Attr; + + bool isValueAttr = false; + [[maybe_unused]] auto loc = interface.converter.genLocation(); + llvm::SmallVector attrs; + auto addMLIRAttr = [&](llvm::StringRef attr) { + attrs.emplace_back(mlir::Identifier::get(attr, &mlirContext), + UnitAttr::get(&mlirContext)); + }; + if (obj.attrs.test(Attrs::Optional)) + addMLIRAttr(fir::getOptionalAttrName()); + if (obj.attrs.test(Attrs::Asynchronous)) + TODO(loc, "Asynchronous in procedure interface"); + if (obj.attrs.test(Attrs::Contiguous)) + addMLIRAttr(fir::getContiguousAttrName()); + if (obj.attrs.test(Attrs::Value)) + isValueAttr = true; // TODO: do we want an mlir::Attribute as well? + if (obj.attrs.test(Attrs::Volatile)) + TODO(loc, "Volatile in procedure interface"); + if (obj.attrs.test(Attrs::Target)) + addMLIRAttr(fir::getTargetAttrName()); + + // TODO: intents that require special care (e.g finalization) + + using ShapeAttrs = Fortran::evaluate::characteristics::TypeAndShape::Attr; + const auto &shapeAttrs = obj.type.attrs(); + if (shapeAttrs.test(ShapeAttrs::AssumedRank)) + TODO(loc, "Assumed Rank in procedure interface"); + if (shapeAttrs.test(ShapeAttrs::Coarray)) + TODO(loc, "Coarray in procedure interface"); + + // So far assume that if the argument cannot be passed by implicit interface + // it must be by box. That may no be always true (e.g for simple optionals) + + auto dynamicType = obj.type.type(); + auto type = translateDynamicType(dynamicType); + fir::SequenceType::Shape bounds = getBounds(obj.type.shape()); + if (!bounds.empty()) + type = fir::SequenceType::get(bounds, type); + if (obj.attrs.test(Attrs::Allocatable)) + type = fir::HeapType::get(type); + if (obj.attrs.test(Attrs::Pointer)) + type = fir::PointerType::get(type); + auto boxType = fir::BoxType::get(type); + + if (obj.attrs.test(Attrs::Allocatable) || obj.attrs.test(Attrs::Pointer)) { + // Pass as fir.ref + auto boxRefType = fir::ReferenceType::get(boxType); + addFirOperand(boxRefType, nextPassedArgPosition(), Property::MutableBox, + attrs); + addPassedArg(PassEntityBy::MutableBox, entity, characteristics); + } else if (dummyRequiresBox(obj)) { + // Pass as fir.box + addFirOperand(boxType, nextPassedArgPosition(), Property::Box, attrs); + addPassedArg(PassEntityBy::Box, entity, characteristics); + } else if (dynamicType.category() == + Fortran::common::TypeCategory::Character) { + // Pass as fir.box_char + auto boxCharTy = fir::BoxCharType::get(&mlirContext, dynamicType.kind()); + addFirOperand(boxCharTy, nextPassedArgPosition(), Property::BoxChar, + attrs); + addPassedArg(isValueAttr ? PassEntityBy::CharBoxValueAttribute + : PassEntityBy::BoxChar, + entity, characteristics); + } else { + // Pass as fir.ref + auto refType = fir::ReferenceType::get(type); + addFirOperand(refType, nextPassedArgPosition(), Property::BaseAddress, + attrs); + addPassedArg(isValueAttr ? PassEntityBy::BaseAddressValueAttribute + : PassEntityBy::BaseAddress, + entity, characteristics); + } + } + + void handleImplicitDummy( + const DummyCharacteristics *characteristics, + const Fortran::evaluate::characteristics::DummyProcedure &proc, + const FortranEntity &entity) { + if (proc.attrs.test( + Fortran::evaluate::characteristics::DummyProcedure::Attr::Pointer)) + llvm_unreachable("TODO: procedure pointer arguments"); + // Otherwise, it is a dummy procedure + + // TODO: Get actual function type of the dummy procedure, at least when an + // interface is given. + // In general, that is a nice to have but we cannot guarantee to find the + // function type that will match the one of the calls, we may not even know + // how many arguments the dummy procedure accepts (e.g. if a procedure + // pointer is only transiting through the current procedure without being + // called), so a function type cast must always be inserted. + auto funcType = + mlir::FunctionType::get(&mlirContext, llvm::None, llvm::None); + addFirOperand(funcType, nextPassedArgPosition(), Property::BaseAddress); + addPassedArg(PassEntityBy::BaseAddress, entity, characteristics); + } + + void handleExplicitResult( + const Fortran::evaluate::characteristics::FunctionResult &result) { + using Attr = Fortran::evaluate::characteristics::FunctionResult::Attr; + + if (result.IsProcedurePointer()) + TODO(interface.converter.genLocation(), + "procedure pointer result not yet handled"); + const auto *typeAndShape = result.GetTypeAndShape(); + assert(typeAndShape && "expect type for non proc pointer result"); + auto mlirType = translateDynamicType(typeAndShape->type()); + fir::SequenceType::Shape bounds = getBounds(typeAndShape->shape()); + if (!bounds.empty()) + mlirType = fir::SequenceType::get(bounds, mlirType); + if (result.attrs.test(Attr::Allocatable)) + mlirType = fir::BoxType::get(fir::HeapType::get(mlirType)); + if (result.attrs.test(Attr::Pointer)) + mlirType = fir::BoxType::get(fir::PointerType::get(mlirType)); + + if (fir::isa_char(mlirType)) { + // Character scalar results must be passed as arguments in lowering so + // that an assumed length character function callee can access the result + // length. A function with a result requiring an explicit interface does + // not have to be compatible with assumed length function, but most + // compilers supports it. + handleImplicitCharacterResult(typeAndShape->type()); + return; + } + + addFirResult(mlirType, FirPlaceHolder::resultEntityPosition, + Property::Value); + // Explicit results require the caller to allocate the storage and save the + // function result in the storage with a fir.save_result. + setSaveResult(); + } + + fir::SequenceType::Shape getBounds(const Fortran::evaluate::Shape &shape) { + fir::SequenceType::Shape bounds; + for (const auto &extent : shape) { + auto bound = fir::SequenceType::getUnknownExtent(); + if (auto i = toInt64(extent)) + bound = *i; + bounds.emplace_back(bound); + } + return bounds; + } + std::optional + toInt64(std::optional< + Fortran::evaluate::Expr> + expr) { + if (expr) + return Fortran::evaluate::ToInt64(Fortran::evaluate::Fold( + getConverter().getFoldingContext(), AsGenericExpr(*expr))); + return std::nullopt; + } + void + addFirOperand(mlir::Type type, int entityPosition, Property p, + llvm::ArrayRef attributes = llvm::None) { + interface.inputs.emplace_back( + FirPlaceHolder{type, entityPosition, p, attributes}); + } + void + addFirResult(mlir::Type type, int entityPosition, Property p, + llvm::ArrayRef attributes = llvm::None) { + interface.outputs.emplace_back( + FirPlaceHolder{type, entityPosition, p, attributes}); + } + void addPassedArg(PassEntityBy p, FortranEntity entity, + const DummyCharacteristics *characteristics) { + interface.passedArguments.emplace_back( + PassedEntity{p, entity, emptyValue(), emptyValue(), characteristics}); + } + void setPassedResult(PassEntityBy p, FortranEntity entity) { + interface.passedResult = + PassedEntity{p, entity, emptyValue(), emptyValue()}; + } + void setSaveResult() { interface.saveResult = true; } + int nextPassedArgPosition() { return interface.passedArguments.size(); } + + static FirValue emptyValue() { + if constexpr (std::is_same_v) { + return {}; + } else { + return -1; + } + } + + Fortran::lower::AbstractConverter &getConverter() { + return interface.converter; + } + CallInterface &interface; + mlir::MLIRContext &mlirContext; +}; + +template +bool Fortran::lower::CallInterface::PassedEntity::isOptional() const { + if (!characteristics) + return false; + return characteristics->IsOptional(); +} +template +bool Fortran::lower::CallInterface::PassedEntity::mayBeModifiedByCall() + const { + if (!characteristics) + return true; + return characteristics->GetIntent() != Fortran::common::Intent::In; +} +template +bool Fortran::lower::CallInterface::PassedEntity::mayBeReadByCall() const { + if (!characteristics) + return true; + return characteristics->GetIntent() != Fortran::common::Intent::Out; +} + +template +void Fortran::lower::CallInterface::determineInterface( + bool isImplicit, + const Fortran::evaluate::characteristics::Procedure &procedure) { + CallInterfaceImpl impl(*this); + if (isImplicit) + impl.buildImplicitInterface(procedure); + else + impl.buildExplicitInterface(procedure); + // We only expect the extra host asspciations argument from the callee side as + // the definition of internal procedures will be present, and we'll always + // have a FuncOp definition in the ModuleOp, when lowering. + if constexpr (std::is_same_v) { + if (side().hasHostAssociated()) + impl.appendHostAssocTupleArg(side().getHostAssociatedTy()); + } +} + +template +mlir::FunctionType Fortran::lower::CallInterface::genFunctionType() { + llvm::SmallVector returnTys; + llvm::SmallVector inputTys; + for (const auto &placeHolder : outputs) + returnTys.emplace_back(placeHolder.type); + for (const auto &placeHolder : inputs) + inputTys.emplace_back(placeHolder.type); + return mlir::FunctionType::get(&converter.getMLIRContext(), inputTys, + returnTys); +} + +template +llvm::SmallVector +Fortran::lower::CallInterface::getResultType() const { + llvm::SmallVector types; + for (const auto &out : outputs) + types.emplace_back(out.type); + return types; +} + +template class Fortran::lower::CallInterface; +template class Fortran::lower::CallInterface; + +//===----------------------------------------------------------------------===// +// Function Type Translation +//===----------------------------------------------------------------------===// + +/// Build signature from characteristics when there is no Fortran entity to +/// associate with the arguments (i.e, this is not a call site or a procedure +/// declaration. This is needed when dealing with function pointers/dummy +/// arguments. + +class SignatureBuilder; +template <> +struct Fortran::lower::PassedEntityTypes { + using FortranEntity = FakeEntity; + using FirValue = int; +}; + +/// SignatureBuilder is a CRTP implementation of CallInterface intended to +/// help translating characteristics::Procedure to mlir::FunctionType using +/// the CallInterface translation. +class SignatureBuilder + : public Fortran::lower::CallInterface { +public: + SignatureBuilder(const Fortran::evaluate::characteristics::Procedure &p, + Fortran::lower::AbstractConverter &c, bool forceImplicit) + : CallInterface{c}, proc{p} { + auto isImplicit = forceImplicit || proc.CanBeCalledViaImplicitInterface(); + determineInterface(isImplicit, proc); + } + /// Does the procedure characteristics being translated have alternate + /// returns ? + bool hasAlternateReturns() const { + for (const auto &dummy : proc.dummyArguments) + if (std::holds_alternative< + Fortran::evaluate::characteristics::AlternateReturn>(dummy.u)) + return true; + return false; + }; + + /// This is only here to fulfill CRTP dependencies and should not be called. + std::string getMangledName() const { + llvm_unreachable("trying to get name from SignatureBuilder"); + } + + /// This is only here to fulfill CRTP dependencies and should not be called. + mlir::Location getCalleeLocation() const { + llvm_unreachable("trying to get callee location from SignatureBuilder"); + } + + /// This is only here to fulfill CRTP dependencies and should not be called. + const Fortran::semantics::Symbol *getProcedureSymbol() const { + llvm_unreachable("trying to get callee symbol from SignatureBuilder"); + }; + + Fortran::evaluate::characteristics::Procedure characterize() const { + return proc; + } + /// SignatureBuilder cannot be used on main program. + static constexpr bool isMainProgram() { return false; } + + /// Return the characteristics::Procedure that is being translated to + /// mlir::FunctionType. + const Fortran::evaluate::characteristics::Procedure & + getCallDescription() const { + return proc; + } + + /// This is not the description of an indirect call. + static constexpr bool isIndirectCall() { return false; } + + /// Return the translated signature. + mlir::FunctionType getFunctionType() { return genFunctionType(); } + + // Copy of base implementation. + static constexpr bool hasHostAssociated() { return false; } + mlir::Type getHostAssociatedTy() const { + llvm_unreachable("getting host associated type in SignatureBuilder"); + } + +private: + const Fortran::evaluate::characteristics::Procedure &proc; +}; + +mlir::FunctionType Fortran::lower::translateSignature( + const Fortran::evaluate::ProcedureDesignator &proc, + Fortran::lower::AbstractConverter &converter) { + auto characteristics = + Fortran::evaluate::characteristics::Procedure::Characterize( + proc, converter.getFoldingContext()); + // Most unrestricted intrinsic characteristic has the Elemental attribute + // which triggers CanBeCalledViaImplicitInterface to return false. However, + // using implicit interface rules is just fine here. + bool forceImplicit = proc.GetSpecificIntrinsic(); + return SignatureBuilder{characteristics.value(), converter, forceImplicit} + .getFunctionType(); +} + +mlir::FuncOp Fortran::lower::getOrDeclareFunction( + llvm::StringRef name, const Fortran::evaluate::ProcedureDesignator &proc, + Fortran::lower::AbstractConverter &converter) { + auto module = converter.getModuleOp(); + mlir::FuncOp func = fir::FirOpBuilder::getNamedFunction(module, name); + if (func) + return func; + + const auto *symbol = proc.GetSymbol(); + assert(symbol && "non user function in getOrDeclareFunction"); + // getOrDeclareFunction is only used for functions not defined in the current + // program unit, so use the location of the procedure designator symbol, which + // is the first occurrence of the procedure in the program unit. + auto loc = converter.genLocation(symbol->name()); + auto characteristics = + Fortran::evaluate::characteristics::Procedure::Characterize( + proc, converter.getFoldingContext()); + auto ty = SignatureBuilder{characteristics.value(), converter, + /*forceImplicit=*/false} + .getFunctionType(); + auto newFunc = fir::FirOpBuilder::createFunction(loc, module, name, ty); + addSymbolAttribute(newFunc, *symbol, converter.getMLIRContext()); + return newFunc; +} diff --git a/flang/lib/Lower/CharacterExpr.cpp b/flang/lib/Lower/CharacterExpr.cpp deleted file mode 100644 index ab720475183cf6..00000000000000 --- a/flang/lib/Lower/CharacterExpr.cpp +++ /dev/null @@ -1,457 +0,0 @@ -//===-- CharacterExpr.cpp -------------------------------------------------===// -// -// 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 -// -//===----------------------------------------------------------------------===// - -#include "flang/Lower/CharacterExpr.h" -#include "flang/Lower/ConvertType.h" -#include "flang/Lower/DoLoopHelper.h" -#include "flang/Lower/IntrinsicCall.h" - -//===----------------------------------------------------------------------===// -// CharacterExprHelper implementation -//===----------------------------------------------------------------------===// - -/// Get fir.char type with the same kind as inside str. -static fir::CharacterType getCharacterType(mlir::Type type) { - if (auto boxType = type.dyn_cast()) - return boxType.getEleTy(); - if (auto refType = type.dyn_cast()) - type = refType.getEleTy(); - if (auto seqType = type.dyn_cast()) { - assert(seqType.getShape().size() == 1 && "rank must be 1"); - type = seqType.getEleTy(); - } - if (auto charType = type.dyn_cast()) - return charType; - llvm_unreachable("Invalid character value type"); -} - -static fir::CharacterType getCharacterType(const fir::CharBoxValue &box) { - return getCharacterType(box.getBuffer().getType()); -} - -static bool needToMaterialize(const fir::CharBoxValue &box) { - return box.getBuffer().getType().isa() || - box.getBuffer().getType().isa(); -} - -static std::optional -getCompileTimeLength(const fir::CharBoxValue &box) { - // FIXME: should this just return box.getLen() ?? - auto type = box.getBuffer().getType(); - if (type.isa()) - return 1; - if (auto refType = type.dyn_cast()) - type = refType.getEleTy(); - if (auto seqType = type.dyn_cast()) { - auto shape = seqType.getShape(); - assert(shape.size() == 1 && "only scalar character supported"); - if (shape[0] != fir::SequenceType::getUnknownExtent()) - return shape[0]; - } - return {}; -} - -fir::CharBoxValue Fortran::lower::CharacterExprHelper::materializeValue( - const fir::CharBoxValue &str) { - if (!needToMaterialize(str)) - return str; - auto variable = builder.create(loc, str.getBuffer().getType()); - builder.create(loc, str.getBuffer(), variable); - return {variable, str.getLen()}; -} - -fir::CharBoxValue -Fortran::lower::CharacterExprHelper::toDataLengthPair(mlir::Value character) { - // TODO: get rid of toDataLengthPair when adding support for arrays - auto charBox = toExtendedValue(character).getCharBox(); - assert(charBox && "Array unsupported in character lowering helper"); - return *charBox; -} - -fir::ExtendedValue -Fortran::lower::CharacterExprHelper::toExtendedValue(mlir::Value character, - mlir::Value len) { - auto lenType = getLengthType(); - auto type = character.getType(); - auto base = character; - mlir::Value resultLen = len; - llvm::SmallVector extents; - - if (auto refType = type.dyn_cast()) - type = refType.getEleTy(); - - if (auto arrayType = type.dyn_cast()) { - type = arrayType.getEleTy(); - auto shape = arrayType.getShape(); - auto cstLen = shape[0]; - if (!resultLen && cstLen != fir::SequenceType::getUnknownExtent()) - resultLen = builder.createIntegerConstant(loc, lenType, cstLen); - // FIXME: only allow `?` in last dimension ? - auto typeExtents = - llvm::ArrayRef{shape}.drop_front(); - auto indexType = builder.getIndexType(); - for (auto extent : typeExtents) { - if (extent == fir::SequenceType::getUnknownExtent()) - break; - extents.emplace_back( - builder.createIntegerConstant(loc, indexType, extent)); - } - // Last extent might be missing in case of assumed-size. If more extents - // could not be deduced from type, that's an error (a fir.box should - // have been used in the interface). - if (extents.size() + 1 < typeExtents.size()) - mlir::emitError(loc, "cannot retrieve array extents from type"); - } else if (type.isa()) { - if (!resultLen) - resultLen = builder.createIntegerConstant(loc, lenType, 1); - } else if (auto boxCharType = type.dyn_cast()) { - auto refType = builder.getRefType(boxCharType.getEleTy()); - auto unboxed = - builder.create(loc, refType, lenType, character); - base = unboxed.getResult(0); - if (!resultLen) - resultLen = unboxed.getResult(1); - } else if (type.isa()) { - mlir::emitError(loc, "descriptor or derived type not yet handled"); - } else { - llvm_unreachable("Cannot translate mlir::Value to character ExtendedValue"); - } - - if (!resultLen) - mlir::emitError(loc, "no dynamic length found for character"); - if (!extents.empty()) - return fir::CharArrayBoxValue{base, resultLen, extents}; - return fir::CharBoxValue{base, resultLen}; -} - -/// Get fir.ref> type. -mlir::Type Fortran::lower::CharacterExprHelper::getReferenceType( - const fir::CharBoxValue &box) const { - return builder.getRefType(getCharacterType(box)); -} - -mlir::Value -Fortran::lower::CharacterExprHelper::createEmbox(const fir::CharBoxValue &box) { - // BoxChar require a reference. - auto str = box; - if (needToMaterialize(box)) - str = materializeValue(box); - auto kind = getCharacterType(str).getFKind(); - auto boxCharType = fir::BoxCharType::get(builder.getContext(), kind); - auto refType = getReferenceType(str); - // So far, fir.emboxChar fails lowering to llvm when it is given - // fir.ref>> types, so convert to - // fir.ref> if needed. - auto buff = str.getBuffer(); - buff = builder.createConvert(loc, refType, buff); - // Convert in case the provided length is not of the integer type that must - // be used in boxchar. - auto lenType = getLengthType(); - auto len = str.getLen(); - len = builder.createConvert(loc, lenType, len); - return builder.create(loc, boxCharType, buff, len); -} - -mlir::Value Fortran::lower::CharacterExprHelper::createLoadCharAt( - const fir::CharBoxValue &str, mlir::Value index) { - // In case this is addressing a length one character scalar simply return - // the single character. - if (str.getBuffer().getType().isa()) - return str.getBuffer(); - auto addr = builder.create(loc, getReferenceType(str), - str.getBuffer(), index); - return builder.create(loc, addr); -} - -void Fortran::lower::CharacterExprHelper::createStoreCharAt( - const fir::CharBoxValue &str, mlir::Value index, mlir::Value c) { - assert(!needToMaterialize(str) && "not in memory"); - auto addr = builder.create(loc, getReferenceType(str), - str.getBuffer(), index); - builder.create(loc, c, addr); -} - -void Fortran::lower::CharacterExprHelper::createCopy( - const fir::CharBoxValue &dest, const fir::CharBoxValue &src, - mlir::Value count) { - Fortran::lower::DoLoopHelper{builder, loc}.createLoop( - count, [&](Fortran::lower::FirOpBuilder &, mlir::Value index) { - auto charVal = createLoadCharAt(src, index); - createStoreCharAt(dest, index, charVal); - }); -} - -void Fortran::lower::CharacterExprHelper::createPadding( - const fir::CharBoxValue &str, mlir::Value lower, mlir::Value upper) { - auto blank = createBlankConstant(getCharacterType(str)); - // Always create the loop, if upper < lower, no iteration will be - // executed. - Fortran::lower::DoLoopHelper{builder, loc}.createLoop( - lower, upper, [&](Fortran::lower::FirOpBuilder &, mlir::Value index) { - createStoreCharAt(str, index, blank); - }); -} - -fir::CharBoxValue -Fortran::lower::CharacterExprHelper::createTemp(mlir::Type type, - mlir::Value len) { - assert(type.isa() && "expected fir character type"); - llvm::SmallVector sizes{len}; - auto ref = builder.allocateLocal(loc, type, llvm::StringRef{}, sizes); - return {ref, len}; -} - -// Simple length one character assignment without loops. -void Fortran::lower::CharacterExprHelper::createLengthOneAssign( - const fir::CharBoxValue &lhs, const fir::CharBoxValue &rhs) { - auto addr = lhs.getBuffer(); - auto val = rhs.getBuffer(); - // If rhs value resides in memory, load it. - if (!needToMaterialize(rhs)) - val = builder.create(loc, val); - auto valTy = val.getType(); - // Precondition is rhs is size 1, but it may be wrapped in a fir.array. - if (auto seqTy = valTy.dyn_cast()) { - auto zero = builder.createIntegerConstant(loc, builder.getIndexType(), 0); - valTy = seqTy.getEleTy(); - val = builder.create(loc, valTy, val, zero); - } - auto addrTy = fir::ReferenceType::get(valTy); - addr = builder.createConvert(loc, addrTy, addr); - assert(fir::dyn_cast_ptrEleTy(addr.getType()) == val.getType()); - builder.create(loc, val, addr); -} - -void Fortran::lower::CharacterExprHelper::createAssign( - const fir::CharBoxValue &lhs, const fir::CharBoxValue &rhs) { - auto rhsCstLen = getCompileTimeLength(rhs); - auto lhsCstLen = getCompileTimeLength(lhs); - bool compileTimeSameLength = - lhsCstLen && rhsCstLen && *lhsCstLen == *rhsCstLen; - - if (compileTimeSameLength && *lhsCstLen == 1) { - createLengthOneAssign(lhs, rhs); - return; - } - - // Copy the minimum of the lhs and rhs lengths and pad the lhs remainder - // if needed. - mlir::Value copyCount = lhs.getLen(); - if (!compileTimeSameLength) - copyCount = - Fortran::lower::genMin(builder, loc, {lhs.getLen(), rhs.getLen()}); - - fir::CharBoxValue safeRhs = rhs; - if (needToMaterialize(rhs)) { - // TODO: revisit now that character constant handling changed. - // Need to materialize the constant to get its elements. - // (No equivalent of fir.coordinate_of for array value). - safeRhs = materializeValue(rhs); - } else { - // If rhs is in memory, always assumes rhs might overlap with lhs - // in a way that require a temp for the copy. That can be optimize later. - // Only create a temp of copyCount size because we do not need more from - // rhs. - auto temp = createTemp(getCharacterType(rhs), copyCount); - createCopy(temp, rhs, copyCount); - safeRhs = temp; - } - - // Actual copy - createCopy(lhs, safeRhs, copyCount); - - // Pad if needed. - if (!compileTimeSameLength) { - auto one = builder.createIntegerConstant(loc, lhs.getLen().getType(), 1); - auto maxPadding = builder.create(loc, lhs.getLen(), one); - createPadding(lhs, copyCount, maxPadding); - } -} - -fir::CharBoxValue Fortran::lower::CharacterExprHelper::createConcatenate( - const fir::CharBoxValue &lhs, const fir::CharBoxValue &rhs) { - mlir::Value len = - builder.create(loc, lhs.getLen(), rhs.getLen()); - auto temp = createTemp(getCharacterType(rhs), len); - createCopy(temp, lhs, lhs.getLen()); - auto one = builder.createIntegerConstant(loc, len.getType(), 1); - auto upperBound = builder.create(loc, len, one); - auto lhsLen = - builder.createConvert(loc, builder.getIndexType(), lhs.getLen()); - Fortran::lower::DoLoopHelper{builder, loc}.createLoop( - lhs.getLen(), upperBound, one, - [&](Fortran::lower::FirOpBuilder &bldr, mlir::Value index) { - auto rhsIndex = bldr.create(loc, index, lhsLen); - auto charVal = createLoadCharAt(rhs, rhsIndex); - createStoreCharAt(temp, index, charVal); - }); - return temp; -} - -fir::CharBoxValue Fortran::lower::CharacterExprHelper::createSubstring( - const fir::CharBoxValue &box, llvm::ArrayRef bounds) { - // Constant need to be materialize in memory to use fir.coordinate_of. - auto str = box; - if (needToMaterialize(box)) - str = materializeValue(box); - - auto nbounds{bounds.size()}; - if (nbounds < 1 || nbounds > 2) { - mlir::emitError(loc, "Incorrect number of bounds in substring"); - return {mlir::Value{}, mlir::Value{}}; - } - mlir::SmallVector castBounds; - // Convert bounds to length type to do safe arithmetic on it. - for (auto bound : bounds) - castBounds.push_back(builder.createConvert(loc, getLengthType(), bound)); - auto lowerBound = castBounds[0]; - // FIR CoordinateOp is zero based but Fortran substring are one based. - auto one = builder.createIntegerConstant(loc, lowerBound.getType(), 1); - auto offset = builder.create(loc, lowerBound, one).getResult(); - auto idxType = builder.getIndexType(); - if (offset.getType() != idxType) - offset = builder.createConvert(loc, idxType, offset); - auto substringRef = builder.create( - loc, getReferenceType(str), str.getBuffer(), offset); - - // Compute the length. - mlir::Value substringLen{}; - if (nbounds < 2) { - substringLen = - builder.create(loc, str.getLen(), castBounds[0]); - } else { - substringLen = - builder.create(loc, castBounds[1], castBounds[0]); - } - substringLen = builder.create(loc, substringLen, one); - - // Set length to zero if bounds were reversed (Fortran 2018 9.4.1) - auto zero = builder.createIntegerConstant(loc, substringLen.getType(), 0); - auto cdt = builder.create(loc, mlir::CmpIPredicate::slt, - substringLen, zero); - substringLen = builder.create(loc, cdt, zero, substringLen); - - return {substringRef, substringLen}; -} - -mlir::Value Fortran::lower::CharacterExprHelper::createLenTrim( - const fir::CharBoxValue &str) { - return {}; -} - -mlir::Value Fortran::lower::CharacterExprHelper::createTemp(mlir::Type type, - int len) { - assert(type.isa() && "expected fir character type"); - assert(len >= 0 && "expected positive length"); - fir::SequenceType::Shape shape{len}; - auto seqType = fir::SequenceType::get(shape, type); - return builder.create(loc, seqType); -} - -// Returns integer with code for blank. The integer has the same -// size as the character. Blank has ascii space code for all kinds. -mlir::Value Fortran::lower::CharacterExprHelper::createBlankConstantCode( - fir::CharacterType type) { - auto bits = builder.getKindMap().getCharacterBitsize(type.getFKind()); - auto intType = builder.getIntegerType(bits); - return builder.createIntegerConstant(loc, intType, ' '); -} - -mlir::Value Fortran::lower::CharacterExprHelper::createBlankConstant( - fir::CharacterType type) { - return builder.createConvert(loc, type, createBlankConstantCode(type)); -} - -void Fortran::lower::CharacterExprHelper::createCopy(mlir::Value dest, - mlir::Value src, - mlir::Value count) { - createCopy(toDataLengthPair(dest), toDataLengthPair(src), count); -} - -void Fortran::lower::CharacterExprHelper::createPadding(mlir::Value str, - mlir::Value lower, - mlir::Value upper) { - createPadding(toDataLengthPair(str), lower, upper); -} - -mlir::Value Fortran::lower::CharacterExprHelper::createSubstring( - mlir::Value str, llvm::ArrayRef bounds) { - return createEmbox(createSubstring(toDataLengthPair(str), bounds)); -} - -void Fortran::lower::CharacterExprHelper::createAssign(mlir::Value lhs, - mlir::Value rhs) { - createAssign(toDataLengthPair(lhs), toDataLengthPair(rhs)); -} - -mlir::Value -Fortran::lower::CharacterExprHelper::createLenTrim(mlir::Value str) { - return createLenTrim(toDataLengthPair(str)); -} - -void Fortran::lower::CharacterExprHelper::createAssign(mlir::Value lptr, - mlir::Value llen, - mlir::Value rptr, - mlir::Value rlen) { - createAssign(fir::CharBoxValue{lptr, llen}, fir::CharBoxValue{rptr, rlen}); -} - -mlir::Value -Fortran::lower::CharacterExprHelper::createConcatenate(mlir::Value lhs, - mlir::Value rhs) { - return createEmbox( - createConcatenate(toDataLengthPair(lhs), toDataLengthPair(rhs))); -} - -mlir::Value -Fortran::lower::CharacterExprHelper::createEmboxChar(mlir::Value addr, - mlir::Value len) { - return createEmbox(fir::CharBoxValue{addr, len}); -} - -std::pair -Fortran::lower::CharacterExprHelper::createUnboxChar(mlir::Value boxChar) { - auto box = toDataLengthPair(boxChar); - return {box.getBuffer(), box.getLen()}; -} - -mlir::Value -Fortran::lower::CharacterExprHelper::createCharacterTemp(mlir::Type type, - mlir::Value len) { - return createEmbox(createTemp(type, len)); -} - -std::pair -Fortran::lower::CharacterExprHelper::materializeCharacter(mlir::Value str) { - auto box = toDataLengthPair(str); - if (needToMaterialize(box)) - box = materializeValue(box); - return {box.getBuffer(), box.getLen()}; -} - -bool Fortran::lower::CharacterExprHelper::isCharacterLiteral(mlir::Type type) { - if (auto seqType = type.dyn_cast()) - return (seqType.getShape().size() == 1) && - seqType.getEleTy().isa(); - return false; -} - -bool Fortran::lower::CharacterExprHelper::isCharacter(mlir::Type type) { - if (type.isa()) - return true; - if (auto refType = type.dyn_cast()) - type = refType.getEleTy(); - if (auto seqType = type.dyn_cast()) - if (seqType.getShape().size() == 1) - type = seqType.getEleTy(); - return type.isa(); -} - -int Fortran::lower::CharacterExprHelper::getCharacterKind(mlir::Type type) { - return getCharacterType(type).getFKind(); -} diff --git a/flang/lib/Lower/CharacterRuntime.cpp b/flang/lib/Lower/CharacterRuntime.cpp deleted file mode 100644 index 4bfbf5824efbbe..00000000000000 --- a/flang/lib/Lower/CharacterRuntime.cpp +++ /dev/null @@ -1,129 +0,0 @@ -//===-- CharacterRuntime.cpp -- runtime for CHARACTER type entities -------===// -// -// 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 -// -//===----------------------------------------------------------------------===// - -#include "flang/Lower/CharacterRuntime.h" -#include "../../runtime/character.h" -#include "RTBuilder.h" -#include "flang/Lower/Bridge.h" -#include "flang/Lower/CharacterExpr.h" -#include "flang/Lower/FIRBuilder.h" -#include "mlir/Dialect/StandardOps/IR/Ops.h" - -using namespace Fortran::runtime; - -#define NAMIFY_HELPER(X) #X -#define NAMIFY(X) NAMIFY_HELPER(IONAME(X)) -#define mkRTKey(X) mkKey(RTNAME(X)) - -namespace Fortran::lower { -/// Static table of CHARACTER runtime calls -/// -/// This logical map contains the name and type builder function for each -/// runtime function listed in the tuple. This table is fully constructed at -/// compile-time. Use the `mkRTKey` macro to access the table. -static constexpr std::tuple< - mkRTKey(CharacterCompareScalar), mkRTKey(CharacterCompareScalar1), - mkRTKey(CharacterCompareScalar2), mkRTKey(CharacterCompareScalar4), - mkRTKey(CharacterCompare)> - newCharRTTable; -} // namespace Fortran::lower - -using namespace Fortran::lower; - -/// Helper function to retrieve the name of the IO function given the key `A` -template -static constexpr const char *getName() { - return std::get(newCharRTTable).name; -} - -/// Helper function to retrieve the type model signature builder of the IO -/// function as defined by the key `A` -template -static constexpr FuncTypeBuilderFunc getTypeModel() { - return std::get(newCharRTTable).getTypeModel(); -} - -inline int64_t getLength(mlir::Type argTy) { - return argTy.cast().getShape()[0]; -} - -/// Get (or generate) the MLIR FuncOp for a given runtime function. -template -static mlir::FuncOp getRuntimeFunc(mlir::Location loc, - Fortran::lower::FirOpBuilder &builder) { - auto name = getName(); - auto func = builder.getNamedFunction(name); - if (func) - return func; - auto funTy = getTypeModel()(builder.getContext()); - func = builder.createFunction(loc, name, funTy); - func->setAttr("fir.runtime", builder.getUnitAttr()); - return func; -} - -/// Helper function to recover the KIND from the FIR type. -static int discoverKind(mlir::Type ty) { - if (auto charTy = ty.dyn_cast()) - return charTy.getFKind(); - if (auto eleTy = fir::dyn_cast_ptrEleTy(ty)) - return discoverKind(eleTy); - if (auto arrTy = ty.dyn_cast()) - return discoverKind(arrTy.getEleTy()); - if (auto boxTy = ty.dyn_cast()) - return discoverKind(boxTy.getEleTy()); - if (auto boxTy = ty.dyn_cast()) - return discoverKind(boxTy.getEleTy()); - llvm_unreachable("unexpected character type"); -} - -//===----------------------------------------------------------------------===// -// Lower character operations -//===----------------------------------------------------------------------===// - -mlir::Value -Fortran::lower::genRawCharCompare(Fortran::lower::AbstractConverter &converter, - mlir::Location loc, mlir::CmpIPredicate cmp, - mlir::Value lhsBuff, mlir::Value lhsLen, - mlir::Value rhsBuff, mlir::Value rhsLen) { - auto &builder = converter.getFirOpBuilder(); - mlir::FuncOp beginFunc; - switch (discoverKind(lhsBuff.getType())) { - case 1: - beginFunc = getRuntimeFunc(loc, builder); - break; - case 2: - beginFunc = getRuntimeFunc(loc, builder); - break; - case 4: - beginFunc = getRuntimeFunc(loc, builder); - break; - default: - llvm_unreachable("runtime does not support CHARACTER KIND"); - } - auto fTy = beginFunc.getType(); - auto lptr = builder.createConvert(loc, fTy.getInput(0), lhsBuff); - auto llen = builder.createConvert(loc, fTy.getInput(2), lhsLen); - auto rptr = builder.createConvert(loc, fTy.getInput(1), rhsBuff); - auto rlen = builder.createConvert(loc, fTy.getInput(3), rhsLen); - llvm::SmallVector args = {lptr, rptr, llen, rlen}; - auto tri = builder.create(loc, beginFunc, args).getResult(0); - auto zero = builder.createIntegerConstant(loc, tri.getType(), 0); - return builder.create(loc, cmp, tri, zero); -} - -mlir::Value -Fortran::lower::genBoxCharCompare(Fortran::lower::AbstractConverter &converter, - mlir::Location loc, mlir::CmpIPredicate cmp, - mlir::Value lhs, mlir::Value rhs) { - auto &builder = converter.getFirOpBuilder(); - Fortran::lower::CharacterExprHelper helper{builder, loc}; - auto lhsPair = helper.materializeCharacter(lhs); - auto rhsPair = helper.materializeCharacter(rhs); - return genRawCharCompare(converter, loc, cmp, lhsPair.first, lhsPair.second, - rhsPair.first, rhsPair.second); -} diff --git a/flang/lib/Lower/Coarray.cpp b/flang/lib/Lower/Coarray.cpp index d73acbe17ce20f..c67ad73bed806d 100644 --- a/flang/lib/Lower/Coarray.cpp +++ b/flang/lib/Lower/Coarray.cpp @@ -14,18 +14,11 @@ #include "flang/Lower/Coarray.h" #include "SymbolMap.h" #include "flang/Lower/AbstractConverter.h" -#include "flang/Lower/FIRBuilder.h" +#include "flang/Lower/Todo.h" +#include "flang/Optimizer/Builder/FIRBuilder.h" #include "flang/Parser/parse-tree.h" #include "flang/Semantics/expression.h" -#undef TODO -#define TODO(MSG) \ - { \ - mlir::emitError(converter.getCurrentLocation(), "not yet implemented") \ - << MSG; \ - exit(1); \ - } - //===----------------------------------------------------------------------===// // TEAM statements and constructs //===----------------------------------------------------------------------===// @@ -34,27 +27,27 @@ void Fortran::lower::genChangeTeamConstruct( Fortran::lower::AbstractConverter &converter, Fortran::lower::pft::Evaluation &, const Fortran::parser::ChangeTeamConstruct &) { - TODO("CHANGE TEAM construct"); + TODO(converter.genLocation(), "CHANGE TEAM construct"); } void Fortran::lower::genChangeTeamStmt( Fortran::lower::AbstractConverter &converter, Fortran::lower::pft::Evaluation &, const Fortran::parser::ChangeTeamStmt &) { - TODO("CHANGE TEAM stmt"); + TODO(converter.genLocation(), "CHANGE TEAM stmt"); } void Fortran::lower::genEndChangeTeamStmt( Fortran::lower::AbstractConverter &converter, Fortran::lower::pft::Evaluation &, const Fortran::parser::EndChangeTeamStmt &) { - TODO("END CHANGE TEAM"); + TODO(converter.genLocation(), "END CHANGE TEAM"); } void Fortran::lower::genFormTeamStatement( Fortran::lower::AbstractConverter &converter, Fortran::lower::pft::Evaluation &, const Fortran::parser::FormTeamStmt &) { - TODO("FORM TEAM"); + TODO(converter.genLocation(), "FORM TEAM"); } //===----------------------------------------------------------------------===// @@ -63,11 +56,13 @@ void Fortran::lower::genFormTeamStatement( fir::ExtendedValue Fortran::lower::CoarrayExprHelper::genAddr( const Fortran::evaluate::CoarrayRef &expr) { + (void)converter; (void)symMap; - TODO("co-array address"); + (void)loc; + TODO(converter.genLocation(), "co-array address"); } fir::ExtendedValue Fortran::lower::CoarrayExprHelper::genValue( const Fortran::evaluate::CoarrayRef &expr) { - TODO("co-array value"); + TODO(converter.genLocation(), "co-array value"); } diff --git a/flang/lib/Lower/ComplexExpr.cpp b/flang/lib/Lower/ComplexExpr.cpp deleted file mode 100644 index 03a91dc00e2666..00000000000000 --- a/flang/lib/Lower/ComplexExpr.cpp +++ /dev/null @@ -1,58 +0,0 @@ -//===-- ComplexExpr.cpp ---------------------------------------------------===// -// -// 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 -// -//===----------------------------------------------------------------------===// - -#include "flang/Lower/ComplexExpr.h" -#include "flang/Lower/ConvertType.h" - -//===----------------------------------------------------------------------===// -// ComplexExprHelper implementation -//===----------------------------------------------------------------------===// - -mlir::Type -Fortran::lower::ComplexExprHelper::getComplexPartType(mlir::Type complexType) { - return Fortran::lower::convertReal( - builder.getContext(), complexType.cast().getFKind()); -} - -mlir::Type -Fortran::lower::ComplexExprHelper::getComplexPartType(mlir::Value cplx) { - return getComplexPartType(cplx.getType()); -} - -mlir::Value Fortran::lower::ComplexExprHelper::createComplex(fir::KindTy kind, - mlir::Value real, - mlir::Value imag) { - auto complexTy = fir::ComplexType::get(builder.getContext(), kind); - mlir::Value und = builder.create(loc, complexTy); - return insert(insert(und, real), imag); -} - -mlir::Value Fortran::lower::ComplexExprHelper::createComplex(mlir::Type cplxTy, - mlir::Value real, - mlir::Value imag) { - mlir::Value und = builder.create(loc, cplxTy); - return insert(insert(und, real), imag); -} - -mlir::Value Fortran::lower::ComplexExprHelper::createComplexCompare( - mlir::Value cplx1, mlir::Value cplx2, bool eq) { - auto real1 = extract(cplx1); - auto real2 = extract(cplx2); - auto imag1 = extract(cplx1); - auto imag2 = extract(cplx2); - - mlir::CmpFPredicate predicate = - eq ? mlir::CmpFPredicate::UEQ : mlir::CmpFPredicate::UNE; - mlir::Value realCmp = - builder.create(loc, predicate, real1, real2); - mlir::Value imagCmp = - builder.create(loc, predicate, imag1, imag2); - - return eq ? builder.create(loc, realCmp, imagCmp).getResult() - : builder.create(loc, realCmp, imagCmp).getResult(); -} diff --git a/flang/lib/Lower/ConvertExpr.cpp b/flang/lib/Lower/ConvertExpr.cpp index 1bac6884a5f7e8..41005dceb39a92 100644 --- a/flang/lib/Lower/ConvertExpr.cpp +++ b/flang/lib/Lower/ConvertExpr.cpp @@ -5,91 +5,5899 @@ // SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception // //===----------------------------------------------------------------------===// +// +// Coding style: https://mlir.llvm.org/getting_started/DeveloperGuide/ +// +//===----------------------------------------------------------------------===// -#include "flang/Common/idioms.h" +#include "flang/Lower/ConvertExpr.h" +#include "BuiltinModules.h" +#include "ConvertVariable.h" +#include "IterationSpace.h" +#include "StatementContext.h" +#include "flang/Common/default-kinds.h" +#include "flang/Common/unwrap.h" +#include "flang/Evaluate/fold.h" +#include "flang/Evaluate/real.h" +#include "flang/Evaluate/traverse.h" +#include "flang/Lower/Allocatable.h" +#include "flang/Lower/Bridge.h" +#include "flang/Lower/CallInterface.h" +#include "flang/Lower/Coarray.h" +#include "flang/Lower/ConvertType.h" #include "flang/Lower/IntrinsicCall.h" -#include "flang/Lower/Support/BoxValue.h" - -mlir::Value fir::getBase(const fir::ExtendedValue &ex) { - return std::visit(Fortran::common::visitors{ - [](const fir::UnboxedValue &x) { return x; }, - [](const auto &x) { return x.getAddr(); }, - }, - ex.box); -} - -llvm::raw_ostream &fir::operator<<(llvm::raw_ostream &os, - const fir::CharBoxValue &box) { - os << "boxchar { addr: " << box.getAddr() << ", len: " << box.getLen() - << " }"; - return os; -} - -llvm::raw_ostream &fir::operator<<(llvm::raw_ostream &os, - const fir::ArrayBoxValue &box) { - os << "boxarray { addr: " << box.getAddr(); - if (box.getLBounds().size()) { - os << ", lbounds: ["; - llvm::interleaveComma(box.getLBounds(), os); - os << "]"; - } else { - os << ", lbounds: all-ones"; +#include "flang/Lower/Mangler.h" +#include "flang/Lower/Runtime.h" +#include "flang/Lower/Support/Utils.h" +#include "flang/Lower/Todo.h" +#include "flang/Optimizer/Builder/Character.h" +#include "flang/Optimizer/Builder/Complex.h" +#include "flang/Optimizer/Builder/Runtime/Character.h" +#include "flang/Optimizer/Builder/Runtime/RTBuilder.h" +#include "flang/Optimizer/Dialect/FIRAttr.h" +#include "flang/Optimizer/Dialect/FIRDialect.h" +#include "flang/Optimizer/Dialect/FIROpsSupport.h" +#include "flang/Optimizer/Support/FatalError.h" +#include "flang/Optimizer/Transforms/Factory.h" +#include "flang/Semantics/expression.h" +#include "flang/Semantics/symbol.h" +#include "flang/Semantics/tools.h" +#include "flang/Semantics/type.h" +#include "mlir/Dialect/Affine/IR/AffineOps.h" +#include "mlir/Dialect/StandardOps/IR/Ops.h" +#include "llvm/ADT/APFloat.h" +#include "llvm/ADT/TypeSwitch.h" +#include "llvm/Support/CommandLine.h" +#include "llvm/Support/Debug.h" +#include "llvm/Support/ErrorHandling.h" +#include "llvm/Support/raw_ostream.h" +#include + +#define DEBUG_TYPE "flang-lower-expr" + +//===----------------------------------------------------------------------===// +// The composition and structure of Fortran::evaluate::Expr is defined in +// the various header files in include/flang/Evaluate. You are referred +// there for more information on these data structures. Generally speaking, +// these data structures are a strongly typed family of abstract data types +// that, composed as trees, describe the syntax of Fortran expressions. +// +// This part of the bridge can traverse these tree structures and lower them +// to the correct FIR representation in SSA form. +//===----------------------------------------------------------------------===// + +static llvm::cl::opt generateArrayCoordinate( + "gen-array-coor", + llvm::cl::desc("in lowering create ArrayCoorOp instead of CoordinateOp"), + llvm::cl::init(false)); + +// The default attempts to balance a modest allocation size with expected user +// input to minimize bounds checks and reallocations during dynamic array +// construction. Some user codes may have very large array constructors for +// which the default can be increased. +static llvm::cl::opt clInitialBufferSize( + "array-constructor-initial-buffer-size", + llvm::cl::desc( + "set the incremental array construction buffer size (default=32)"), + llvm::cl::init(32u)); + +/// The various semantics of a program constituent (or a part thereof) as it may +/// appear in an expression. +/// +/// Given the following Fortran declarations. +/// ```fortran +/// REAL :: v1, v2, v3 +/// REAL, POINTER :: vp1 +/// REAL :: a1(c), a2(c) +/// REAL ELEMENTAL FUNCTION f1(arg) ! array -> array +/// FUNCTION f2(arg) ! array -> array +/// vp1 => v3 ! 1 +/// v1 = v2 * vp1 ! 2 +/// a1 = a1 + a2 ! 3 +/// a1 = f1(a2) ! 4 +/// a1 = f2(a2) ! 5 +/// ``` +/// +/// In line 1, `vp1` is a BoxAddr to copy a box value into. The box value is +/// constructed from the DataAddr of `v3`. +/// In line 2, `v1` is a DataAddr to copy a value into. The value is constructed +/// from the DataValue of `v2` and `vp1`. DataValue is implicitly a double +/// dereference in the `vp1` case. +/// In line 3, `a1` and `a2` on the rhs are RefTransparent. The `a1` on the lhs +/// is CopyInCopyOut as `a1` is replaced elementally by the additions. +/// In line 4, `a2` can be RefTransparent, ByValueArg, RefOpaque, or BoxAddr if +/// `arg` is declared as C-like pass-by-value, VALUE, INTENT(?), or ALLOCATABLE/ +/// POINTER, respectively. `a1` on the lhs is CopyInCopyOut. +/// In line 5, `a2` may be DataAddr or BoxAddr assuming f2 is transformational. +/// `a1` on the lhs is again CopyInCopyOut. +enum class ConstituentSemantics { + // Scalar data reference semantics. + // + // For these let `v` be the location in memory of a variable with value `x` + DataValue, // refers to the value `x` + DataAddr, // refers to the address `v` + BoxValue, // refers to a box value containing `v` + BoxAddr, // refers to the address of a box value containing `v` + + // Array data reference semantics. + // + // For these let `a` be the location in memory of a sequence of value `[xs]`. + // Let `x_i` be the `i`-th value in the sequence `[xs]`. + + // Referentially transparent. Refers to the array's value, `[xs]`. + RefTransparent, + // Refers to an ephemeral address `tmp` containing value `x_i` (15.5.2.3.p7 + // note 2). (Passing a copy by reference to simulate pass-by-value.) + ByValueArg, + // Refers to the merge of array value `[xs]` with another array value `[ys]`. + // This merged array value will be written into memory location `a`. + CopyInCopyOut, + // Similar to CopyInCopyOut but `a` may be a transient projection (rather than + // a whole array). + ProjectedCopyInCopyOut, + // Referentially opaque. Refers to the address of `x_i`. + RefOpaque +}; + +/// Convert parser's INTEGER relational operators to MLIR. TODO: using +/// unordered, but we may want to cons ordered in certain situation. +static mlir::CmpIPredicate +translateRelational(Fortran::common::RelationalOperator rop) { + switch (rop) { + case Fortran::common::RelationalOperator::LT: + return mlir::CmpIPredicate::slt; + case Fortran::common::RelationalOperator::LE: + return mlir::CmpIPredicate::sle; + case Fortran::common::RelationalOperator::EQ: + return mlir::CmpIPredicate::eq; + case Fortran::common::RelationalOperator::NE: + return mlir::CmpIPredicate::ne; + case Fortran::common::RelationalOperator::GT: + return mlir::CmpIPredicate::sgt; + case Fortran::common::RelationalOperator::GE: + return mlir::CmpIPredicate::sge; } - os << ", shape: ["; - llvm::interleaveComma(box.getExtents(), os); - os << "]}"; - return os; + llvm_unreachable("unhandled INTEGER relational operator"); } -llvm::raw_ostream &fir::operator<<(llvm::raw_ostream &os, - const fir::CharArrayBoxValue &box) { - os << "boxchararray { addr: " << box.getAddr() << ", len : " << box.getLen(); - if (box.getLBounds().size()) { - os << ", lbounds: ["; - llvm::interleaveComma(box.getLBounds(), os); - os << "]"; - } else { - os << " lbounds: all-ones"; +/// Convert parser's REAL relational operators to MLIR. +/// The choice of order (O prefix) vs unorder (U prefix) follows Fortran 2018 +/// requirements in the IEEE context (table 17.1 of F2018). This choice is +/// also applied in other contexts because it is easier and in line with +/// other Fortran compilers. +/// FIXME: The signaling/quiet aspect of the table 17.1 requirement is not +/// fully enforced. FIR and LLVM `fcmp` instructions do not give any guarantee +/// whether the comparison will signal or not in case of quiet NaN argument. +static mlir::CmpFPredicate +translateFloatRelational(Fortran::common::RelationalOperator rop) { + switch (rop) { + case Fortran::common::RelationalOperator::LT: + return mlir::CmpFPredicate::OLT; + case Fortran::common::RelationalOperator::LE: + return mlir::CmpFPredicate::OLE; + case Fortran::common::RelationalOperator::EQ: + return mlir::CmpFPredicate::OEQ; + case Fortran::common::RelationalOperator::NE: + return mlir::CmpFPredicate::UNE; + case Fortran::common::RelationalOperator::GT: + return mlir::CmpFPredicate::OGT; + case Fortran::common::RelationalOperator::GE: + return mlir::CmpFPredicate::OGE; } - os << ", shape: ["; - llvm::interleaveComma(box.getExtents(), os); - os << "]}"; - return os; + llvm_unreachable("unhandled REAL relational operator"); } -llvm::raw_ostream &fir::operator<<(llvm::raw_ostream &os, - const fir::BoxValue &box) { - os << "box { addr: " << box.getAddr(); - if (box.getLen()) - os << ", size: " << box.getLen(); - if (box.params.size()) { - os << ", type params: ["; - llvm::interleaveComma(box.params, os); - os << "]"; +/// Lower `opt` (from front-end shape analysis) to MLIR. If `opt` is `nullopt` +/// then issue an error. +static mlir::Value +convertOptExtentExpr(Fortran::lower::AbstractConverter &converter, + Fortran::lower::StatementContext &stmtCtx, + const Fortran::evaluate::MaybeExtentExpr &opt) { + auto loc = converter.getCurrentLocation(); + if (!opt.has_value()) + fir::emitFatalError(loc, "shape analysis failed to return an expression"); + auto e = toEvExpr(*opt); + return fir::getBase(converter.genExprValue(&e, stmtCtx, loc)); +} + +/// Does this expr designate an allocatable or pointer entity ? +static bool isAllocatableOrPointer(const Fortran::lower::SomeExpr &expr) { + const auto *sym = + Fortran::evaluate::UnwrapWholeSymbolOrComponentDataRef(expr); + return sym && Fortran::semantics::IsAllocatableOrPointer(*sym); +} + +/// Convert the array_load, `load`, to an extended value. If `path` is not +/// empty, then traverse through the components designated. The base value is +/// `newBase`. This does not accept an array_load with a slice operand. +static fir::ExtendedValue arrayLoadExtValue(fir::FirOpBuilder &builder, + mlir::Location loc, + fir::ArrayLoadOp load, + llvm::ArrayRef path, + mlir::Value newBase) { + // Recover the extended value from the load. + assert(!load.slice() && "slice is not allowed"); + auto arrTy = load.getType(); + auto idxTy = builder.getIndexType(); + if (!path.empty()) { + auto ty = fir::applyPathToType(arrTy, path); + if (!ty) + fir::emitFatalError(loc, "path does not apply to type"); + if (!ty.isa()) { + if (auto charTy = ty.dyn_cast()) { + // ???: Is this in CharacterExprHelper? + auto len = charTy.hasConstantLen() + ? builder.createIntegerConstant( + loc, idxTy, ty.cast().getLen()) + : load.typeparams()[0]; + return fir::CharBoxValue{newBase, len}; + } + return newBase; + } + arrTy = ty.cast(); } - if (box.getLBounds().size()) { - os << ", lbounds: ["; - llvm::interleaveComma(box.getLBounds(), os); - os << "]"; + // Recycle componentToExtendedValue if it looks plausible. + if (!fir::hasDynamicSize(arrTy)) + return fir::factory::componentToExtendedValue(builder, loc, newBase); + + auto eleTy = fir::unwrapSequenceType(arrTy); + if (!load.shape()) { + // ???: The final argument is a BoxValue, but that's what we are trying to + // recover here. + auto exv = fir::factory::readBoxValue(builder, loc, load.memref()); + return fir::substBase(exv, newBase); + } + auto extents = fir::factory::getExtents(load.shape()); + auto lbounds = fir::factory::getOrigins(load.shape()); + if (auto charTy = eleTy.dyn_cast()) { + auto len = charTy.hasConstantLen() + ? builder.createIntegerConstant( + loc, idxTy, eleTy.cast().getLen()) + : load.typeparams()[0]; + return fir::CharArrayBoxValue{newBase, len, extents, lbounds}; } - if (box.getExtents().size()) { - os << ", shape: ["; - llvm::interleaveComma(box.getExtents(), os); - os << "]"; + if (load.typeparams().empty()) { + return fir::ArrayBoxValue{newBase, extents, lbounds}; } - os << "}"; - return os; + TODO(loc, "should build a BoxValue, but there is no good way to know which " + "properties are explicit, assumed, deferred, or ?"); } -llvm::raw_ostream &fir::operator<<(llvm::raw_ostream &os, - const fir::ProcBoxValue &box) { - os << "boxproc: { addr: " << box.getAddr() << ", context: " << box.hostContext - << "}"; - return os; +/// Is this a call to an elemental procedure with at least one array argument ? +static bool +isElementalProcWithArrayArgs(const Fortran::evaluate::ProcedureRef &procRef) { + if (procRef.IsElemental()) + for (const auto &arg : procRef.arguments()) + if (arg && arg->Rank() != 0) + return true; + return false; +} +template +static bool isElementalProcWithArrayArgs(const Fortran::evaluate::Expr &) { + return false; +} +template <> +bool isElementalProcWithArrayArgs(const Fortran::lower::SomeExpr &x) { + if (const auto *procRef = std::get_if(&x.u)) + return isElementalProcWithArrayArgs(*procRef); + return false; } -llvm::raw_ostream &fir::operator<<(llvm::raw_ostream &os, - const fir::ExtendedValue &ex) { - std::visit([&](const auto &value) { os << value; }, ex.box); - return os; +namespace { + +/// Lowering of Fortran::evaluate::Expr expressions +class ScalarExprLowering { +public: + using ExtValue = fir::ExtendedValue; + + explicit ScalarExprLowering(mlir::Location loc, + Fortran::lower::AbstractConverter &converter, + Fortran::lower::SymMap &symMap, + Fortran::lower::StatementContext &stmtCtx, + bool initializer = false) + : location{loc}, converter{converter}, + builder{converter.getFirOpBuilder()}, stmtCtx{stmtCtx}, symMap{symMap}, + inInitializer{initializer} {} + + ExtValue genExtAddr(const Fortran::lower::SomeExpr &expr) { + return gen(expr); + } + + /// Lower `expr` to be passed as a fir.box argument. Do not create a temp + /// for the expr if it is a variable that can be described as a fir.box. + ExtValue genBoxArg(const Fortran::lower::SomeExpr &expr) { + bool saveUseBoxArg = useBoxArg; + useBoxArg = true; + auto result = gen(expr); + useBoxArg = saveUseBoxArg; + return result; + } + + ExtValue genExtValue(const Fortran::lower::SomeExpr &expr) { + return genval(expr); + } + + /// Lower an expression that is a pointer or an allocatable to a + /// MutableBoxValue. + fir::MutableBoxValue + genMutableBoxValue(const Fortran::lower::SomeExpr &expr) { + // Pointers and allocatables can only be: + // - a simple designator "x" + // - a component designator "a%b(i,j)%x" + // - a function reference "foo()" + // - result of NULL() or NULL(MOLD) intrinsic. + // NULL() requires some context to be lowered, so it is not handled + // here and must be lowered according to the context where it appears. + auto exv = std::visit( + [&](const auto &x) { return genMutableBoxValueImpl(x); }, expr.u); + auto *mutableBox = exv.getBoxOf(); + if (!mutableBox) + fir::emitFatalError(getLoc(), "expr was not lowered to MutableBoxValue"); + return *mutableBox; + } + + template + ExtValue genMutableBoxValueImpl(const T &) { + // NULL() case should not be handled here. + fir::emitFatalError(getLoc(), "NULL() must be lowered in its context"); + } + + template + ExtValue + genMutableBoxValueImpl(const Fortran::evaluate::FunctionRef &funRef) { + return genRawProcedureRef(funRef, converter.genType(toEvExpr(funRef))); + } + + template + ExtValue + genMutableBoxValueImpl(const Fortran::evaluate::Designator &designator) { + return std::visit( + Fortran::common::visitors{ + [&](const Fortran::evaluate::SymbolRef &sym) -> ExtValue { + return symMap.lookupSymbol(*sym).toExtendedValue(); + }, + [&](const Fortran::evaluate::Component &comp) -> ExtValue { + return genComponent(comp); + }, + [&](const auto &) -> ExtValue { + fir::emitFatalError(getLoc(), + "not an allocatable or pointer designator"); + }}, + designator.u); + } + + template + ExtValue genMutableBoxValueImpl(const Fortran::evaluate::Expr &expr) { + return std::visit([&](const auto &x) { return genMutableBoxValueImpl(x); }, + expr.u); + } + + mlir::Location getLoc() { return location; } + + template + mlir::Value genunbox(const A &expr) { + auto e = genval(expr); + if (auto *r = e.getUnboxed()) + return *r; + fir::emitFatalError(getLoc(), "unboxed expression expected"); + } + + /// Generate an integral constant of `value` + template + mlir::Value genIntegerConstant(mlir::MLIRContext *context, + std::int64_t value) { + auto type = converter.genType(Fortran::common::TypeCategory::Integer, KIND); + return builder.createIntegerConstant(getLoc(), type, value); + } + + /// Generate a logical/boolean constant of `value` + mlir::Value genBoolConstant(bool value) { + return builder.createBool(getLoc(), value); + } + + /// Generate a real constant with a value `value`. + template + mlir::Value genRealConstant(mlir::MLIRContext *context, + const llvm::APFloat &value) { + auto fltTy = Fortran::lower::convertReal(context, KIND); + return builder.createRealConstant(getLoc(), fltTy, value); + } + + mlir::Type getSomeKindInteger() { return builder.getIndexType(); } + + mlir::FuncOp getFunction(llvm::StringRef name, mlir::FunctionType funTy) { + if (auto func = builder.getNamedFunction(name)) + return func; + return builder.createFunction(getLoc(), name, funTy); + } + + template + mlir::Value createCompareOp(mlir::CmpIPredicate pred, const ExtValue &left, + const ExtValue &right) { + if (auto *lhs = left.getUnboxed()) + if (auto *rhs = right.getUnboxed()) + return builder.create(getLoc(), pred, *lhs, *rhs); + fir::emitFatalError(getLoc(), "array compare should be handled in genarr"); + } + template + mlir::Value createCompareOp(const A &ex, mlir::CmpIPredicate pred) { + auto left = genval(ex.left()); + return createCompareOp(pred, left, genval(ex.right())); + } + + template + mlir::Value createFltCmpOp(mlir::CmpFPredicate pred, const ExtValue &left, + const ExtValue &right) { + if (auto *lhs = left.getUnboxed()) + if (auto *rhs = right.getUnboxed()) + return builder.create(getLoc(), pred, *lhs, *rhs); + fir::emitFatalError(getLoc(), "array compare should be handled in genarr"); + } + template + mlir::Value createFltCmpOp(const A &ex, mlir::CmpFPredicate pred) { + auto left = genval(ex.left()); + return createFltCmpOp(pred, left, genval(ex.right())); + } + + /// Create a call to the runtime to compare two CHARACTER values. + /// Precondition: This assumes that the two values have `fir.boxchar` type. + mlir::Value createCharCompare(mlir::CmpIPredicate pred, const ExtValue &left, + const ExtValue &right) { + return fir::runtime::genCharCompare(builder, getLoc(), pred, left, right); + } + + template + mlir::Value createCharCompare(const A &ex, mlir::CmpIPredicate pred) { + auto left = genval(ex.left()); + return createCharCompare(pred, left, genval(ex.right())); + } + + /// Returns a reference to a symbol or its box/boxChar descriptor if it has + /// one. + ExtValue gen(Fortran::semantics::SymbolRef sym) { + if (auto val = symMap.lookupSymbol(sym)) + return val.match( + [&](const Fortran::lower::SymbolBox::PointerOrAllocatable &boxAddr) { + return fir::factory::genMutableBoxRead(builder, getLoc(), boxAddr); + }, + [&val](auto &) { return val.toExtendedValue(); }); + LLVM_DEBUG(llvm::dbgs() + << "unknown symbol: " << sym << "\nmap: " << symMap << '\n'); + fir::emitFatalError(getLoc(), "symbol is not mapped to any IR value"); + } + + /// Generate a load of a value from an address. + ExtValue genLoad(const ExtValue &addr) { + auto loc = getLoc(); + return addr.match( + [](const fir::CharBoxValue &box) -> ExtValue { return box; }, + [&](const fir::UnboxedValue &v) -> ExtValue { + return builder.create(loc, fir::getBase(v)); + }, + [&](const auto &v) -> ExtValue { + TODO(getLoc(), "loading array or descriptor"); + }); + } + + ExtValue genval(Fortran::semantics::SymbolRef sym) { + auto loc = getLoc(); + auto var = gen(sym); + if (auto *s = var.getUnboxed()) + if (fir::isReferenceLike(s->getType())) { + // A function with multiple entry points returning different types + // tags all result variables with one of the largest types to allow + // them to share the same storage. A reference to a result variable + // of one of the other types requires conversion to the actual type. + auto addr = *s; + if (Fortran::semantics::IsFunctionResult(sym)) { + auto resultType = converter.genType(*sym); + if (addr.getType() != resultType) + addr = builder.createConvert(loc, builder.getRefType(resultType), + addr); + } + return genLoad(addr); + } + return var; + } + + ExtValue genval(const Fortran::evaluate::BOZLiteralConstant &) { + TODO(getLoc(), "BOZ"); + } + + /// Return indirection to function designated in ProcedureDesignator. + /// The type of the function indirection is not guaranteed to match the one + /// of the ProcedureDesignator due to Fortran implicit typing rules. + ExtValue genval(const Fortran::evaluate::ProcedureDesignator &proc) { + if (const auto *intrinsic = proc.GetSpecificIntrinsic()) { + auto signature = Fortran::lower::translateSignature(proc, converter); + // Intrinsic lowering is based on the generic name, so retrieve it here in + // case it is different from the specific name. The type of the specific + // intrinsic is retained in the signature. + auto genericName = + converter.getFoldingContext().intrinsics().GetGenericIntrinsicName( + intrinsic->name); + auto symbolRefAttr = + Fortran::lower::getUnrestrictedIntrinsicSymbolRefAttr( + builder, getLoc(), genericName, signature); + mlir::Value funcPtr = + builder.create(getLoc(), signature, symbolRefAttr); + return funcPtr; + } + const auto *symbol = proc.GetSymbol(); + assert(symbol && "expected symbol in ProcedureDesignator"); + if (Fortran::semantics::IsDummy(*symbol)) { + auto val = symMap.lookupSymbol(*symbol); + assert(val && "Dummy procedure not in symbol map"); + return val.getAddr(); + } + auto name = converter.mangleName(*symbol); + auto func = Fortran::lower::getOrDeclareFunction(name, proc, converter); + mlir::Value funcPtr = builder.create( + getLoc(), func.getType(), builder.getSymbolRefAttr(name)); + return funcPtr; + } + ExtValue genval(const Fortran::evaluate::NullPointer &) { + return builder.createNullConstant(getLoc()); + } + + static bool + isDerivedTypeWithLengthParameters(const Fortran::semantics::Symbol &sym) { + if (const auto *declTy = sym.GetType()) + if (const auto *derived = declTy->AsDerived()) + return Fortran::semantics::CountLenParameters(*derived) > 0; + return false; + } + + static bool isBuiltinCPtr(const Fortran::semantics::Symbol &sym) { + if (const auto *declType = sym.GetType()) + if (const auto *derived = declType->AsDerived()) + return Fortran::semantics::IsIsoCType(derived); + return false; + } + + /// Lower structure constructor without a temporary. This can be used in + /// fir::GloablOp, and assumes that the structure component is a constant. + ExtValue genStructComponentInInitializer( + const Fortran::evaluate::StructureConstructor &ctor) { + auto loc = getLoc(); + auto ty = translateSomeExprToFIRType(converter, toEvExpr(ctor)); + auto recTy = ty.cast(); + auto fieldTy = fir::FieldType::get(ty.getContext()); + mlir::Value res = builder.create(loc, recTy); + + for (auto [sym, expr] : ctor.values()) { + // Parent components need more work because they do not appear in the + // fir.rec type. + if (sym->test(Fortran::semantics::Symbol::Flag::ParentComp)) + TODO(loc, "parent component in structure constructor"); + + auto name = toStringRef(sym->name()); + auto componentTy = recTy.getType(name); + // FIXME: type parameters must come from the derived-type-spec + mlir::Value field = builder.create( + loc, fieldTy, name, ty, + /*typeParams=*/mlir::ValueRange{} /*TODO*/); + + if (Fortran::semantics::IsAllocatable(sym)) + TODO(loc, "allocatable component in structure constructor"); + + if (Fortran::semantics::IsPointer(sym)) { + auto initialTarget = Fortran::lower::genInitialDataTarget( + converter, loc, componentTy, expr.value()); + res = builder.create(loc, recTy, res, initialTarget, + field); + continue; + } + + if (isDerivedTypeWithLengthParameters(sym)) + TODO(loc, "component with length parameters in structure constructor"); + + if (isBuiltinCPtr(sym)) { + // Builtin c_ptr and c_funptr have special handling because initial + // value are handled for them as an extension. + auto addr = Fortran::lower::genExtAddrInInitializer(converter, loc, + expr.value()); + auto baseAddr = fir::getBase(addr); + auto undef = builder.create(loc, componentTy); + auto cPtrRecTy = componentTy.dyn_cast(); + assert(cPtrRecTy && "c_ptr and c_funptr must be derived types"); + llvm::StringRef addrFieldName = Fortran::lower::builtin::cptrFieldName; + auto addrFieldTy = cPtrRecTy.getType(addrFieldName); + mlir::Value addrField = builder.create( + loc, fieldTy, addrFieldName, componentTy, + /*typeParams=*/mlir::ValueRange{}); + auto castAddr = builder.createConvert(loc, addrFieldTy, baseAddr); + auto val = builder.create(loc, componentTy, undef, + castAddr, addrField); + res = builder.create(loc, recTy, res, val, field); + continue; + } + + auto val = fir::getBase(genval(expr.value())); + assert(!fir::isa_ref_type(val.getType()) && "expecting a constant value"); + auto castVal = builder.createConvert(loc, componentTy, val); + res = builder.create(loc, recTy, res, castVal, field); + } + return res; + } + + /// A structure constructor is lowered two ways. In an initializer context, + /// the entire structure must be constant, so the aggregate value is + /// constructed inline. This allows it to be the body of a GlobalOp. + /// Otherwise, the structure constructor is in an expression. In that case, a + /// temporary object is constructed in the stack frame of the procedure. + ExtValue genval(const Fortran::evaluate::StructureConstructor &ctor) { + if (inInitializer) + return genStructComponentInInitializer(ctor); + auto loc = getLoc(); + auto ty = translateSomeExprToFIRType(converter, toEvExpr(ctor)); + auto recTy = ty.cast(); + auto fieldTy = fir::FieldType::get(ty.getContext()); + mlir::Value res = builder.createTemporary(loc, recTy); + + for (auto value : ctor.values()) { + const auto &sym = value.first; + auto &expr = value.second; + // Parent components need more work because they do not appear in the + // fir.rec type. + if (sym->test(Fortran::semantics::Symbol::Flag::ParentComp)) + TODO(loc, "parent component in structure constructor"); + + if (isDerivedTypeWithLengthParameters(sym)) + TODO(loc, "component with length parameters in structure constructor"); + + auto name = toStringRef(sym->name()); + // FIXME: type parameters must come from the derived-type-spec + mlir::Value field = builder.create( + loc, fieldTy, name, ty, + /*typeParams=*/mlir::ValueRange{} /*TODO*/); + auto coorTy = builder.getRefType(recTy.getType(name)); + auto coor = builder.create(loc, coorTy, + fir::getBase(res), field); + auto to = fir::factory::componentToExtendedValue(builder, loc, coor); + to.match( + [&](const fir::UnboxedValue &toPtr) { + // FIXME: if toPtr is a derived type, it is incorrect after F95 to + // simply load/store derived type since they may have allocatable + // components that require deep-copy or may have defined assignment + // procedures. + auto val = fir::getBase(genval(expr.value())); + auto cast = builder.createConvert( + loc, fir::dyn_cast_ptrEleTy(toPtr.getType()), val); + builder.create(loc, cast, toPtr); + }, + [&](const fir::CharBoxValue &) { + fir::factory::CharacterExprHelper{builder, loc}.createAssign( + to, genval(expr.value())); + }, + [&](const fir::ArrayBoxValue &) { + Fortran::lower::createSomeArrayAssignment( + converter, to, expr.value(), symMap, stmtCtx); + }, + [&](const fir::CharArrayBoxValue &) { + Fortran::lower::createSomeArrayAssignment( + converter, to, expr.value(), symMap, stmtCtx); + }, + [&](const fir::BoxValue &toBox) { + fir::emitFatalError(loc, "derived type components must not be " + "represented by fir::BoxValue"); + }, + [&](const fir::MutableBoxValue &toBox) { + if (toBox.isPointer()) { + Fortran::lower::associateMutableBox( + converter, loc, toBox, expr.value(), /*lbounds=*/llvm::None, + stmtCtx); + return; + } + // For allocatable components, a deep copy is needed. + TODO(loc, "allocatable components in derived type assignment"); + }, + [&](const fir::ProcBoxValue &toBox) { + TODO(loc, "procedure pointer component in derived type assignment"); + }); + } + return builder.create(loc, res); + } + + /// Lowering of an ac-do-variable, which is not a Symbol. + ExtValue genval(const Fortran::evaluate::ImpliedDoIndex &var) { + return converter.impliedDoBinding(toStringRef(var.name)); + } + + ExtValue genval(const Fortran::evaluate::DescriptorInquiry &desc) { + auto exv = desc.base().IsSymbol() ? gen(desc.base().GetLastSymbol()) + : gen(desc.base().GetComponent()); + auto idxTy = builder.getIndexType(); + auto loc = getLoc(); + auto castResult = [&](mlir::Value v) { + using ResTy = Fortran::evaluate::DescriptorInquiry::Result; + return builder.createConvert( + loc, converter.genType(ResTy::category, ResTy::kind), v); + }; + switch (desc.field()) { + case Fortran::evaluate::DescriptorInquiry::Field::Len: + return castResult(fir::factory::readCharLen(builder, loc, exv)); + case Fortran::evaluate::DescriptorInquiry::Field::LowerBound: + return castResult(fir::factory::readLowerBound( + builder, loc, exv, desc.dimension(), + builder.createIntegerConstant(loc, idxTy, 1))); + case Fortran::evaluate::DescriptorInquiry::Field::Extent: + return castResult( + fir::factory::readExtent(builder, loc, exv, desc.dimension())); + case Fortran::evaluate::DescriptorInquiry::Field::Rank: + TODO(loc, "rank inquiry on assumed rank"); + case Fortran::evaluate::DescriptorInquiry::Field::Stride: + // So far the front end does not generate this inquiry. + TODO(loc, "Stride inquiry"); + } + llvm_unreachable("unknown descriptor inquiry"); + } + + ExtValue genval(const Fortran::evaluate::TypeParamInquiry &) { + TODO(getLoc(), "type parameter inquiry"); + } + + mlir::Value extractComplexPart(mlir::Value cplx, bool isImagPart) { + return fir::factory::ComplexExprHelper{builder, getLoc()} + .extractComplexPart(cplx, isImagPart); + } + + template + ExtValue genval(const Fortran::evaluate::ComplexComponent &part) { + return extractComplexPart(genunbox(part.left()), part.isImaginaryPart); + } + + template + ExtValue genval(const Fortran::evaluate::Negate> &op) { + auto input = genunbox(op.left()); + // Like LLVM, integer negation is the binary op "0 - value" + auto zero = genIntegerConstant(builder.getContext(), 0); + return builder.create(getLoc(), zero, input); + } + template + ExtValue genval(const Fortran::evaluate::Negate> &op) { + return builder.create(getLoc(), genunbox(op.left())); + } + template + ExtValue genval(const Fortran::evaluate::Negate> &op) { + return builder.create(getLoc(), genunbox(op.left())); + } + + template + mlir::Value createBinaryOp(const ExtValue &left, const ExtValue &right) { + assert(fir::isUnboxedValue(left) && fir::isUnboxedValue(right)); + auto lhs = fir::getBase(left); + auto rhs = fir::getBase(right); + assert(lhs.getType() == rhs.getType() && "types must be the same"); + return builder.create(getLoc(), lhs, rhs); + } + + template + mlir::Value createBinaryOp(const A &ex) { + auto left = genval(ex.left()); + return createBinaryOp(left, genval(ex.right())); + } + +#undef GENBIN +#define GENBIN(GenBinEvOp, GenBinTyCat, GenBinFirOp) \ + template \ + ExtValue genval(const Fortran::evaluate::GenBinEvOp> &x) { \ + return createBinaryOp(x); \ + } + + GENBIN(Add, Integer, mlir::AddIOp) + GENBIN(Add, Real, mlir::AddFOp) + GENBIN(Add, Complex, fir::AddcOp) + GENBIN(Subtract, Integer, mlir::SubIOp) + GENBIN(Subtract, Real, mlir::SubFOp) + GENBIN(Subtract, Complex, fir::SubcOp) + GENBIN(Multiply, Integer, mlir::MulIOp) + GENBIN(Multiply, Real, mlir::MulFOp) + GENBIN(Multiply, Complex, fir::MulcOp) + GENBIN(Divide, Integer, mlir::SignedDivIOp) + GENBIN(Divide, Real, mlir::DivFOp) + GENBIN(Divide, Complex, fir::DivcOp) + + template + ExtValue genval( + const Fortran::evaluate::Power> &op) { + auto ty = converter.genType(TC, KIND); + auto lhs = genunbox(op.left()); + auto rhs = genunbox(op.right()); + return Fortran::lower::genPow(builder, getLoc(), ty, lhs, rhs); + } + + template + ExtValue genval( + const Fortran::evaluate::RealToIntPower> + &op) { + auto ty = converter.genType(TC, KIND); + auto lhs = genunbox(op.left()); + auto rhs = genunbox(op.right()); + return Fortran::lower::genPow(builder, getLoc(), ty, lhs, rhs); + } + + template + ExtValue genval(const Fortran::evaluate::ComplexConstructor &op) { + return fir::factory::ComplexExprHelper{builder, getLoc()}.createComplex( + KIND, genunbox(op.left()), genunbox(op.right())); + } + + template + ExtValue genval(const Fortran::evaluate::Concat &op) { + auto lhs = genval(op.left()); + auto rhs = genval(op.right()); + auto *lhsChar = lhs.getCharBox(); + auto *rhsChar = rhs.getCharBox(); + if (lhsChar && rhsChar) + return fir::factory::CharacterExprHelper{builder, getLoc()} + .createConcatenate(*lhsChar, *rhsChar); + TODO(getLoc(), "character array concatenate"); + } + + /// MIN and MAX operations + template + ExtValue + genval(const Fortran::evaluate::Extremum> + &op) { + auto lhs = genunbox(op.left()); + auto rhs = genunbox(op.right()); + switch (op.ordering) { + case Fortran::evaluate::Ordering::Greater: + return Fortran::lower::genMax(builder, getLoc(), + llvm::ArrayRef{lhs, rhs}); + case Fortran::evaluate::Ordering::Less: + return Fortran::lower::genMin(builder, getLoc(), + llvm::ArrayRef{lhs, rhs}); + case Fortran::evaluate::Ordering::Equal: + llvm_unreachable("Equal is not a valid ordering in this context"); + } + llvm_unreachable("unknown ordering"); + } + + template + ExtValue genval(const Fortran::evaluate::SetLength &) { + TODO(getLoc(), "evaluate::SetLength lowering"); + } + + template + ExtValue genval(const Fortran::evaluate::Relational> &op) { + return createCompareOp(op, translateRelational(op.opr)); + } + template + ExtValue genval(const Fortran::evaluate::Relational> &op) { + return createFltCmpOp(op, translateFloatRelational(op.opr)); + } + template + ExtValue genval(const Fortran::evaluate::Relational> &op) { + return createFltCmpOp(op, translateFloatRelational(op.opr)); + } + template + ExtValue genval(const Fortran::evaluate::Relational> &op) { + return createCharCompare(op, translateRelational(op.opr)); + } + + ExtValue + genval(const Fortran::evaluate::Relational &op) { + return std::visit([&](const auto &x) { return genval(x); }, op.u); + } + + template + ExtValue + genval(const Fortran::evaluate::Convert, + TC2> &convert) { + auto ty = converter.genType(TC1, KIND); + auto operand = genunbox(convert.left()); + return builder.convertWithSemantics(getLoc(), ty, operand); + } + + template + ExtValue genval(const Fortran::evaluate::Parentheses &op) { + auto input = genval(op.left()); + auto base = fir::getBase(input); + mlir::Value newBase = + builder.create(getLoc(), base.getType(), base); + return fir::substBase(input, newBase); + } + + template + ExtValue genval(const Fortran::evaluate::Not &op) { + auto logical = genunbox(op.left()); + auto one = genBoolConstant(true); + auto val = builder.createConvert(getLoc(), builder.getI1Type(), logical); + return builder.create(getLoc(), val, one); + } + + template + ExtValue genval(const Fortran::evaluate::LogicalOperation &op) { + auto i1Type = builder.getI1Type(); + auto slhs = genunbox(op.left()); + auto srhs = genunbox(op.right()); + auto lhs = builder.createConvert(getLoc(), i1Type, slhs); + auto rhs = builder.createConvert(getLoc(), i1Type, srhs); + switch (op.logicalOperator) { + case Fortran::evaluate::LogicalOperator::And: + return createBinaryOp(lhs, rhs); + case Fortran::evaluate::LogicalOperator::Or: + return createBinaryOp(lhs, rhs); + case Fortran::evaluate::LogicalOperator::Eqv: + return createCompareOp(mlir::CmpIPredicate::eq, lhs, rhs); + case Fortran::evaluate::LogicalOperator::Neqv: + return createCompareOp(mlir::CmpIPredicate::ne, lhs, rhs); + case Fortran::evaluate::LogicalOperator::Not: + // lib/evaluate expression for .NOT. is Fortran::evaluate::Not. + llvm_unreachable(".NOT. is not a binary operator"); + } + llvm_unreachable("unhandled logical operation"); + } + + /// Convert a scalar literal constant to IR. + template + ExtValue genScalarLit( + const Fortran::evaluate::Scalar> + &value) { + if constexpr (TC == Fortran::common::TypeCategory::Integer) { + return genIntegerConstant(builder.getContext(), value.ToInt64()); + } else if constexpr (TC == Fortran::common::TypeCategory::Logical) { + return genBoolConstant(value.IsTrue()); + } else if constexpr (TC == Fortran::common::TypeCategory::Real) { + std::string str = value.DumpHexadecimal(); + if constexpr (KIND == 2) { + llvm::APFloat floatVal{llvm::APFloatBase::IEEEhalf(), str}; + return genRealConstant(builder.getContext(), floatVal); + } else if constexpr (KIND == 3) { + llvm::APFloat floatVal{llvm::APFloatBase::BFloat(), str}; + return genRealConstant(builder.getContext(), floatVal); + } else if constexpr (KIND == 4) { + llvm::APFloat floatVal{llvm::APFloatBase::IEEEsingle(), str}; + return genRealConstant(builder.getContext(), floatVal); + } else if constexpr (KIND == 10) { + llvm::APFloat floatVal{llvm::APFloatBase::x87DoubleExtended(), str}; + return genRealConstant(builder.getContext(), floatVal); + } else if constexpr (KIND == 16) { + llvm::APFloat floatVal{llvm::APFloatBase::IEEEquad(), str}; + return genRealConstant(builder.getContext(), floatVal); + } else { + // convert everything else to double + llvm::APFloat floatVal{llvm::APFloatBase::IEEEdouble(), str}; + return genRealConstant(builder.getContext(), floatVal); + } + } else if constexpr (TC == Fortran::common::TypeCategory::Complex) { + using TR = + Fortran::evaluate::Type; + Fortran::evaluate::ComplexConstructor ctor( + Fortran::evaluate::Expr{ + Fortran::evaluate::Constant{value.REAL()}}, + Fortran::evaluate::Expr{ + Fortran::evaluate::Constant{value.AIMAG()}}); + return genunbox(ctor); + } else /*constexpr*/ { + llvm_unreachable("unhandled constant"); + } + } + /// Convert a ascii scalar literal CHARACTER to IR. (specialization) + ExtValue + genAsciiScalarLit(const Fortran::evaluate::Scalar> &value, + int64_t len) { + assert(value.size() == static_cast(len)); + // Outline character constant in ro data if it is not in an initializer. + if (!inInitializer) + return fir::factory::createStringLiteral(builder, getLoc(), value); + // When in an initializer context, construct the literal op itself and do + // not construct another constant object in rodata. + auto stringLit = builder.createStringLitOp(getLoc(), value); + auto lenp = builder.createIntegerConstant( + getLoc(), builder.getCharacterLengthType(), len); + return fir::CharBoxValue{stringLit.getResult(), lenp}; + } + /// Convert a non ascii scalar literal CHARACTER to IR. (specialization) + template + ExtValue + genScalarLit(const Fortran::evaluate::Scalar> &value, + int64_t len) { + using ET = typename std::decay_t::value_type; + if constexpr (KIND == 1) { + return genAsciiScalarLit(value, len); + } + auto type = fir::CharacterType::get(builder.getContext(), KIND, len); + auto consLit = [&]() -> fir::StringLitOp { + auto context = builder.getContext(); + std::int64_t size = static_cast(value.size()); + auto shape = mlir::VectorType::get( + llvm::ArrayRef{size}, + mlir::IntegerType::get(builder.getContext(), sizeof(ET) * 8)); + auto strAttr = mlir::DenseElementsAttr::get( + shape, llvm::ArrayRef{value.data(), value.size()}); + auto valTag = mlir::Identifier::get(fir::StringLitOp::value(), context); + mlir::NamedAttribute dataAttr(valTag, strAttr); + auto sizeTag = mlir::Identifier::get(fir::StringLitOp::size(), context); + mlir::NamedAttribute sizeAttr(sizeTag, builder.getI64IntegerAttr(len)); + llvm::SmallVector attrs{dataAttr, sizeAttr}; + return builder.create( + getLoc(), llvm::ArrayRef{type}, llvm::None, attrs); + }; + + auto lenp = builder.createIntegerConstant( + getLoc(), builder.getCharacterLengthType(), len); + // When in an initializer context, construct the literal op itself and do + // not construct another constant object in rodata. + if (inInitializer) + return fir::CharBoxValue{consLit().getResult(), lenp}; + + // Otherwise, the string is in a plain old expression so "outline" the value + // by hashconsing it to a constant literal object. + + // FIXME: For wider char types, lowering ought to use an array of i16 or + // i32. But for now, lowering just fakes that the string value is a range of + // i8 to get it past the C++ compiler. + std::string globalName = + fir::factory::uniqueCGIdent("cl", (const char *)value.c_str()); + auto global = builder.getNamedGlobal(globalName); + if (!global) + global = builder.createGlobalConstant( + getLoc(), type, globalName, + [&](fir::FirOpBuilder &builder) { + auto str = consLit(); + builder.create(getLoc(), str); + }, + builder.createLinkOnceLinkage()); + auto addr = builder.create(getLoc(), global.resultType(), + global.getSymbol()); + return fir::CharBoxValue{addr, lenp}; + } + + template + ExtValue genArrayLit( + const Fortran::evaluate::Constant> + &con) { + auto loc = getLoc(); + auto idxTy = builder.getIndexType(); + auto size = Fortran::evaluate::GetSize(con.shape()); + fir::SequenceType::Shape shape(con.shape().begin(), con.shape().end()); + mlir::Type eleTy; + if constexpr (TC == Fortran::common::TypeCategory::Character) + eleTy = converter.genType(TC, KIND, {con.LEN()}); + else + eleTy = converter.genType(TC, KIND); + auto arrayTy = fir::SequenceType::get(shape, eleTy); + mlir::Value array = builder.create(loc, arrayTy); + llvm::SmallVector lbounds; + llvm::SmallVector extents; + for (auto [lb, extent] : llvm::zip(con.lbounds(), shape)) { + lbounds.push_back(builder.createIntegerConstant(loc, idxTy, lb - 1)); + extents.push_back(builder.createIntegerConstant(loc, idxTy, extent)); + } + if (size == 0) { + if constexpr (TC == Fortran::common::TypeCategory::Character) { + auto len = builder.createIntegerConstant(loc, idxTy, con.LEN()); + return fir::CharArrayBoxValue{array, len, extents, lbounds}; + } else { + return fir::ArrayBoxValue{array, extents, lbounds}; + } + } + Fortran::evaluate::ConstantSubscripts subscripts = con.lbounds(); + auto createIdx = [&]() { + llvm::SmallVector idx; + for (size_t i = 0; i < subscripts.size(); ++i) + idx.push_back(builder.createIntegerConstant( + getLoc(), idxTy, subscripts[i] - con.lbounds()[i])); + return idx; + }; + if constexpr (TC == Fortran::common::TypeCategory::Character) { + do { + auto elementVal = + fir::getBase(genScalarLit(con.At(subscripts), con.LEN())); + array = builder.create(loc, arrayTy, array, + elementVal, createIdx()); + } while (con.IncrementSubscripts(subscripts)); + auto len = builder.createIntegerConstant(loc, idxTy, con.LEN()); + return fir::CharArrayBoxValue{array, len, extents, lbounds}; + } else { + llvm::SmallVector rangeStartIdx; + uint64_t rangeSize = 0; + do { + auto getElementVal = [&]() { + return builder.createConvert( + loc, eleTy, + fir::getBase(genScalarLit(con.At(subscripts)))); + }; + auto nextSubscripts = subscripts; + bool nextIsSame = con.IncrementSubscripts(nextSubscripts) && + con.At(subscripts) == con.At(nextSubscripts); + if (!rangeSize && !nextIsSame) { // single (non-range) value + array = builder.create( + loc, arrayTy, array, getElementVal(), createIdx()); + } else if (!rangeSize) { // start a range + rangeStartIdx = createIdx(); + rangeSize = 1; + } else if (nextIsSame) { // expand a range + ++rangeSize; + } else { // end a range + llvm::SmallVector rangeBounds; + auto idx = createIdx(); + for (size_t i = 0; i < idx.size(); ++i) { + rangeBounds.push_back(rangeStartIdx[i]); + rangeBounds.push_back(idx[i]); + } + array = builder.create( + loc, arrayTy, array, getElementVal(), rangeBounds); + rangeSize = 0; + } + } while (con.IncrementSubscripts(subscripts)); + return fir::ArrayBoxValue{array, extents, lbounds}; + } + } + + fir::ExtendedValue genArrayLit( + const Fortran::evaluate::Constant &con) { + auto loc = getLoc(); + auto idxTy = builder.getIndexType(); + auto size = Fortran::evaluate::GetSize(con.shape()); + fir::SequenceType::Shape shape(con.shape().begin(), con.shape().end()); + auto eleTy = converter.genType(con.GetType().GetDerivedTypeSpec()); + auto arrayTy = fir::SequenceType::get(shape, eleTy); + mlir::Value array = builder.create(loc, arrayTy); + llvm::SmallVector lbounds; + llvm::SmallVector extents; + for (auto [lb, extent] : llvm::zip(con.lbounds(), con.shape())) { + lbounds.push_back(builder.createIntegerConstant(loc, idxTy, lb - 1)); + extents.push_back(builder.createIntegerConstant(loc, idxTy, extent)); + } + if (size == 0) + return fir::ArrayBoxValue{array, extents, lbounds}; + Fortran::evaluate::ConstantSubscripts subscripts = con.lbounds(); + do { + auto derivedVal = fir::getBase(genval(con.At(subscripts))); + llvm::SmallVector idx; + for (auto [dim, lb] : llvm::zip(subscripts, con.lbounds())) + idx.push_back(builder.createIntegerConstant(loc, idxTy, dim - lb)); + array = builder.create(loc, arrayTy, array, + derivedVal, idx); + } while (con.IncrementSubscripts(subscripts)); + return fir::ArrayBoxValue{array, extents, lbounds}; + } + + template + ExtValue + genval(const Fortran::evaluate::Constant> + &con) { + if (con.Rank() > 0) + return genArrayLit(con); + auto opt = con.GetScalarValue(); + assert(opt.has_value() && "constant has no value"); + if constexpr (TC == Fortran::common::TypeCategory::Character) { + return genScalarLit(opt.value(), con.LEN()); + } else { + return genScalarLit(opt.value()); + } + } + fir::ExtendedValue genval( + const Fortran::evaluate::Constant &con) { + if (con.Rank() > 0) + return genArrayLit(con); + if (auto ctor = con.GetScalarValue()) + return genval(ctor.value()); + fir::emitFatalError(getLoc(), + "constant of derived type has no constructor"); + } + + template + ExtValue genval(const Fortran::evaluate::ArrayConstructor &) { + fir::emitFatalError(getLoc(), + "array constructor: lowering should not reach here"); + } + + ExtValue gen(const Fortran::evaluate::ComplexPart &x) { + auto loc = getLoc(); + auto idxTy = builder.getIndexType(); + auto exv = gen(x.complex()); + auto base = fir::getBase(exv); + fir::factory::ComplexExprHelper helper{builder, loc}; + auto eleTy = + helper.getComplexPartType(fir::dyn_cast_ptrEleTy(base.getType())); + auto offset = builder.createIntegerConstant( + loc, idxTy, + x.part() == Fortran::evaluate::ComplexPart::Part::RE ? 0 : 1); + mlir::Value result = builder.create( + loc, builder.getRefType(eleTy), base, mlir::ValueRange{offset}); + return {result}; + } + ExtValue genval(const Fortran::evaluate::ComplexPart &x) { + return genLoad(gen(x)); + } + + /// Reference to a substring. + ExtValue gen(const Fortran::evaluate::Substring &s) { + // Get base string + auto baseString = std::visit( + Fortran::common::visitors{ + [&](const Fortran::evaluate::DataRef &x) { return gen(x); }, + [&](const Fortran::evaluate::StaticDataObject::Pointer &p) + -> ExtValue { + if (auto str = p->AsString()) + return fir::factory::createStringLiteral(builder, getLoc(), + *str); + // TODO: convert StaticDataObject to Constant and use normal + // constant path. Beware that StaticDataObject data() takes into + // account build machine endianness. + TODO(getLoc(), + "StaticDataObject::Pointer substring with kind > 1"); + }, + }, + s.parent()); + llvm::SmallVector bounds; + auto lower = genunbox(s.lower()); + bounds.push_back(lower); + if (auto upperBound = s.upper()) { + auto upper = genunbox(*upperBound); + bounds.push_back(upper); + } + fir::factory::CharacterExprHelper charHelper{builder, getLoc()}; + return baseString.match( + [&](const fir::CharBoxValue &x) -> ExtValue { + return charHelper.createSubstring(x, bounds); + }, + [&](const fir::CharArrayBoxValue &) -> ExtValue { + fir::emitFatalError( + getLoc(), + "array substring should be handled in array expression"); + }, + [&](const auto &) -> ExtValue { + fir::emitFatalError(getLoc(), "substring base is not a CharBox"); + }); + } + + /// The value of a substring. + ExtValue genval(const Fortran::evaluate::Substring &ss) { + // FIXME: why is the value of a substring being lowered the same as the + // address of a substring? + return gen(ss); + } + + ExtValue genval(const Fortran::evaluate::Subscript &subs) { + if (auto *s = std::get_if( + &subs.u)) { + if (s->value().Rank() > 0) + fir::emitFatalError(getLoc(), "vector subscript is not scalar"); + return {genval(s->value())}; + } + fir::emitFatalError(getLoc(), "subscript triple notation is not scalar"); + } + ExtValue genSubscript(const Fortran::evaluate::Subscript &subs) { + return genval(subs); + } + + ExtValue gen(const Fortran::evaluate::DataRef &dref) { + return std::visit([&](const auto &x) { return gen(x); }, dref.u); + } + ExtValue genval(const Fortran::evaluate::DataRef &dref) { + return std::visit([&](const auto &x) { return genval(x); }, dref.u); + } + + // Helper function to turn the left-recursive Component structure into a list + // that does not contain allocatable or pointer components other than the last + // one. + // Returns the object used as the base coordinate for the component chain. + static Fortran::evaluate::DataRef const * + reverseComponents(const Fortran::evaluate::Component &cmpt, + std::list &list) { + list.push_front(&cmpt); + return std::visit( + Fortran::common::visitors{ + [&](const Fortran::evaluate::Component &x) { + // Stop the list when a component is an allocatable or pointer + // because the component cannot be lowered into a single + // fir.coordinate_of. + if (Fortran::semantics::IsAllocatableOrPointer(x.GetLastSymbol())) + return &cmpt.base(); + return reverseComponents(x, list); + }, + [&](auto &) { return &cmpt.base(); }, + }, + cmpt.base().u); + } + + // Return the coordinate of the component reference + ExtValue genComponent(const Fortran::evaluate::Component &cmpt) { + std::list list; + auto *base = reverseComponents(cmpt, list); + llvm::SmallVector coorArgs; + auto obj = gen(*base); + auto ty = fir::dyn_cast_ptrOrBoxEleTy(fir::getBase(obj).getType()); + auto loc = getLoc(); + auto fldTy = fir::FieldType::get(&converter.getMLIRContext()); + // FIXME: need to thread the LEN type parameters here. + for (auto *field : list) { + auto recTy = ty.cast(); + const auto *sym = &field->GetLastSymbol(); + auto name = toStringRef(sym->name()); + coorArgs.push_back(builder.create( + loc, fldTy, name, recTy, fir::getTypeParams(obj))); + ty = recTy.getType(name); + } + ty = builder.getRefType(ty); + return fir::factory::componentToExtendedValue( + builder, loc, + builder.create(loc, ty, fir::getBase(obj), + coorArgs)); + } + + ExtValue gen(const Fortran::evaluate::Component &cmpt) { + // Components may be pointer or allocatable. In the gen() path, the mutable + // aspect is lost to simplify handling on the client side. To retain the + // mutable aspect, genMutableBoxValue should be used. + return genComponent(cmpt).match( + [&](const fir::MutableBoxValue &mutableBox) { + return fir::factory::genMutableBoxRead(builder, getLoc(), mutableBox); + }, + [](auto &box) -> ExtValue { return box; }); + } + + ExtValue genval(const Fortran::evaluate::Component &cmpt) { + return genLoad(gen(cmpt)); + } + + // Determine the result type after removing `dims` dimensions from the array + // type `arrTy` + mlir::Type genSubType(mlir::Type arrTy, unsigned dims) { + auto unwrapTy = fir::dyn_cast_ptrOrBoxEleTy(arrTy); + assert(unwrapTy && "must be a pointer or box type"); + auto seqTy = unwrapTy.cast(); + auto shape = seqTy.getShape(); + assert(shape.size() > 0 && "removing columns for sequence sans shape"); + assert(dims <= shape.size() && "removing more columns than exist"); + fir::SequenceType::Shape newBnds; + // follow Fortran semantics and remove columns (from right) + auto e = shape.size() - dims; + for (decltype(e) i{0}; i < e; ++i) + newBnds.push_back(shape[i]); + if (!newBnds.empty()) + return fir::SequenceType::get(newBnds, seqTy.getEleTy()); + return seqTy.getEleTy(); + } + + // Generate the code for a Bound value. + ExtValue genval(const Fortran::semantics::Bound &bound) { + if (bound.isExplicit()) { + auto sub = bound.GetExplicit(); + if (sub.has_value()) + return genval(*sub); + return genIntegerConstant<8>(builder.getContext(), 1); + } + TODO(getLoc(), "non explicit semantics::Bound lowering"); + } + + static bool isSlice(const Fortran::evaluate::ArrayRef &aref) { + for (auto &sub : aref.subscript()) + if (std::holds_alternative(sub.u)) + return true; + return false; + } + + /// Lower an ArrayRef to a fir.coordinate_of given its lowered base. + ExtValue genCoordinateOp(const ExtValue &array, + const Fortran::evaluate::ArrayRef &aref) { + auto loc = getLoc(); + // References to array of rank > 1 with non constant shape that are not + // fir.box must be collapsed into an offset computation in lowering already. + // The same is needed with dynamic length character arrays of all ranks. + auto baseType = fir::dyn_cast_ptrOrBoxEleTy(fir::getBase(array).getType()); + if ((array.rank() > 1 && fir::hasDynamicSize(baseType)) || + fir::characterWithDynamicLen(fir::unwrapSequenceType(baseType))) + if (!array.getBoxOf()) + return genOffsetAndCoordinateOp(array, aref); + // Generate a fir.coordinate_of with zero based array indexes. + llvm::SmallVector args; + for (auto &subsc : llvm::enumerate(aref.subscript())) { + auto subVal = genSubscript(subsc.value()); + assert(fir::isUnboxedValue(subVal) && "subscript must be simple scalar"); + auto val = fir::getBase(subVal); + auto ty = val.getType(); + auto lb = getLBound(array, subsc.index(), ty); + args.push_back(builder.create(loc, ty, val, lb)); + } + + auto base = fir::getBase(array); + auto seqTy = + fir::dyn_cast_ptrOrBoxEleTy(base.getType()).cast(); + assert(args.size() == seqTy.getDimension()); + auto ty = builder.getRefType(seqTy.getEleTy()); + auto addr = builder.create(loc, ty, base, args); + return fir::factory::arrayElementToExtendedValue(builder, loc, array, addr); + } + + /// Lower an ArrayRef to a fir.coordinate_of using an element offset instead + /// of array indexes. + /// This generates offset computation from the indexes and length parameters, + /// and use the offset to access the element with a fir.coordinate_of. This + /// must only be used if it is not possible to generate a normal + /// fir.coordinate_of using array indexes (i.e. when the shape information is + /// unavailable in the IR). + ExtValue genOffsetAndCoordinateOp(const ExtValue &array, + const Fortran::evaluate::ArrayRef &aref) { + auto loc = getLoc(); + auto addr = fir::getBase(array); + auto arrTy = fir::dyn_cast_ptrEleTy(addr.getType()); + auto eleTy = arrTy.cast().getEleTy(); + auto seqTy = builder.getRefType(builder.getVarLenSeqTy(eleTy)); + auto refTy = builder.getRefType(eleTy); + auto base = builder.createConvert(loc, seqTy, addr); + auto idxTy = builder.getIndexType(); + auto one = builder.createIntegerConstant(loc, idxTy, 1); + auto zero = builder.createIntegerConstant(loc, idxTy, 0); + auto getLB = [&](const auto &arr, unsigned dim) -> mlir::Value { + return arr.getLBounds().empty() ? one : arr.getLBounds()[dim]; + }; + auto genFullDim = [&](const auto &arr, mlir::Value delta) -> mlir::Value { + mlir::Value total = zero; + assert(arr.getExtents().size() == aref.subscript().size()); + delta = builder.createConvert(loc, idxTy, delta); + unsigned dim = 0; + for (auto [ext, sub] : llvm::zip(arr.getExtents(), aref.subscript())) { + auto subVal = genSubscript(sub); + assert(fir::isUnboxedValue(subVal)); + auto val = builder.createConvert(loc, idxTy, fir::getBase(subVal)); + auto lb = builder.createConvert(loc, idxTy, getLB(arr, dim)); + auto diff = builder.create(loc, val, lb); + auto prod = builder.create(loc, delta, diff); + total = builder.create(loc, prod, total); + if (ext) + delta = builder.create(loc, delta, ext); + ++dim; + } + auto origRefTy = refTy; + if (fir::factory::CharacterExprHelper::isCharacterScalar(refTy)) { + auto chTy = fir::factory::CharacterExprHelper::getCharacterType(refTy); + if (fir::characterWithDynamicLen(chTy)) { + auto ctx = builder.getContext(); + auto kind = fir::factory::CharacterExprHelper::getCharacterKind(chTy); + auto singleTy = fir::CharacterType::getSingleton(ctx, kind); + refTy = builder.getRefType(singleTy); + auto seqRefTy = builder.getRefType(builder.getVarLenSeqTy(singleTy)); + base = builder.createConvert(loc, seqRefTy, base); + } + } + auto coor = builder.create( + loc, refTy, base, llvm::ArrayRef{total}); + // Convert to expected, original type after address arithmetic. + return builder.createConvert(loc, origRefTy, coor); + }; + return array.match( + [&](const fir::ArrayBoxValue &arr) -> ExtValue { + // FIXME: this check can be removed when slicing is implemented + if (isSlice(aref)) + fir::emitFatalError( + getLoc(), + "slice should be handled in array expression context"); + return genFullDim(arr, one); + }, + [&](const fir::CharArrayBoxValue &arr) -> ExtValue { + auto delta = arr.getLen(); + // If the length is known in the type, fir.coordinate_of will + // already take the length into account. + if (fir::factory::CharacterExprHelper::hasConstantLengthInType(arr)) + delta = one; + return fir::CharBoxValue(genFullDim(arr, delta), arr.getLen()); + }, + [&](const fir::BoxValue &arr) -> ExtValue { + // CoordinateOp for BoxValue is not generated here. The dimensions + // must be kept in the fir.coordinate_op so that potential fir.box + // strides can be applied by codegen. + fir::emitFatalError( + loc, "internal: BoxValue in dim-collapsed fir.coordinate_of"); + }, + [&](const auto &) -> ExtValue { + fir::emitFatalError(loc, "internal: array lowering failed"); + }); + } + + /// Lower an ArrayRef to a fir.array_coor. + ExtValue genArrayCoorOp(const ExtValue &exv, + const Fortran::evaluate::ArrayRef &aref) { + auto loc = getLoc(); + auto addr = fir::getBase(exv); + auto arrTy = fir::dyn_cast_ptrOrBoxEleTy(addr.getType()); + auto eleTy = arrTy.cast().getEleTy(); + auto refTy = builder.getRefType(eleTy); + auto idxTy = builder.getIndexType(); + llvm::SmallVector arrayCoorArgs; + // The ArrayRef is expected to be scalar here, arrays are handled in array + // expression lowering. So no vector subscript or triplet is expected here. + for (const auto &sub : aref.subscript()) { + auto subVal = genSubscript(sub); + assert(fir::isUnboxedValue(subVal)); + arrayCoorArgs.push_back( + builder.createConvert(loc, idxTy, fir::getBase(subVal))); + } + auto shape = builder.createShape(loc, exv); + auto elementAddr = builder.create( + loc, refTy, addr, shape, /*slice=*/mlir::Value{}, arrayCoorArgs, + fir::getTypeParams(exv)); + return fir::factory::arrayElementToExtendedValue(builder, loc, exv, + elementAddr); + } + + /// Return the coordinate of the array reference. + ExtValue gen(const Fortran::evaluate::ArrayRef &aref) { + auto base = aref.base().IsSymbol() ? gen(aref.base().GetFirstSymbol()) + : gen(aref.base().GetComponent()); + // Check for command-line override to use array_coor op. + if (generateArrayCoordinate) + return genArrayCoorOp(base, aref); + // Otherwise, use coordinate_of op. + return genCoordinateOp(base, aref); + } + + /// Return lower bounds of \p box in dimension \p dim. The returned value + /// has type \ty. + mlir::Value getLBound(const ExtValue &box, unsigned dim, mlir::Type ty) { + assert(box.rank() > 0 && "must be an array"); + auto loc = getLoc(); + auto one = builder.createIntegerConstant(loc, ty, 1); + auto lb = fir::factory::readLowerBound(builder, loc, box, dim, one); + return builder.createConvert(loc, ty, lb); + } + + ExtValue genval(const Fortran::evaluate::ArrayRef &aref) { + return genLoad(gen(aref)); + } + + ExtValue gen(const Fortran::evaluate::CoarrayRef &coref) { + return Fortran::lower::CoarrayExprHelper{converter, getLoc(), symMap} + .genAddr(coref); + } + + ExtValue genval(const Fortran::evaluate::CoarrayRef &coref) { + return Fortran::lower::CoarrayExprHelper{converter, getLoc(), symMap} + .genValue(coref); + } + + template + ExtValue gen(const Fortran::evaluate::Designator &des) { + return std::visit([&](const auto &x) { return gen(x); }, des.u); + } + template + ExtValue genval(const Fortran::evaluate::Designator &des) { + return std::visit([&](const auto &x) { return genval(x); }, des.u); + } + + mlir::Type genType(const Fortran::evaluate::DynamicType &dt) { + if (dt.category() != Fortran::common::TypeCategory::Derived) + return converter.genType(dt.category(), dt.kind()); + return converter.genType(dt.GetDerivedTypeSpec()); + } + + /// Apply the function `func` and return a reference to the resultant value. + /// This is required for lowering expressions such as `f1(f2(v))`. + template + ExtValue gen(const Fortran::evaluate::FunctionRef &func) { + if (!func.GetType().has_value()) + mlir::emitError(getLoc(), "internal: a function must have a type"); + auto resTy = genType(*func.GetType()); + auto retVal = genProcedureRef(func, {resTy}); + auto retValBase = fir::getBase(retVal); + if (fir::conformsWithPassByRef(retValBase.getType())) + return retVal; + auto mem = builder.create(getLoc(), retValBase.getType()); + builder.create(getLoc(), retValBase, mem); + return fir::substBase(retVal, mem.getResult()); + } + + /// Helper to lower intrinsic arguments for inquiry intrinsic. + ExtValue + lowerIntrinsicArgumentAsInquired(const Fortran::lower::SomeExpr &expr) { + if (isAllocatableOrPointer(expr)) + return genMutableBoxValue(expr); + return gen(expr); + } + + /// Generate a call to an intrinsic function. + ExtValue + genIntrinsicRef(const Fortran::evaluate::ProcedureRef &procRef, + const Fortran::evaluate::SpecificIntrinsic &intrinsic, + llvm::Optional resultType) { + llvm::SmallVector operands; + + llvm::StringRef name = intrinsic.name; + const auto *argLowering = + Fortran::lower::getIntrinsicArgumentLowering(name); + for (const auto &[arg, dummy] : + llvm::zip(procRef.arguments(), + intrinsic.characteristics.value().dummyArguments)) { + auto *expr = Fortran::evaluate::UnwrapExpr< + Fortran::evaluate::Expr>(arg); + if (!expr) { + // Absent optional. + operands.emplace_back(Fortran::lower::getAbsentIntrinsicArgument()); + continue; + } + if (!argLowering) { + // No argument lowering instruction, lower by value. + operands.emplace_back(genval(*expr)); + continue; + } + // Ad-hoc argument lowering handling. + auto lowerAs = Fortran::lower::lowerIntrinsicArgumentAs( + getLoc(), *argLowering, dummy.name); + switch (lowerAs) { + case Fortran::lower::LowerIntrinsicArgAs::Value: + operands.emplace_back(genval(*expr)); + continue; + case Fortran::lower::LowerIntrinsicArgAs::Addr: + operands.emplace_back(gen(*expr)); + continue; + case Fortran::lower::LowerIntrinsicArgAs::Box: + operands.emplace_back(builder.createBox(getLoc(), genBoxArg(*expr))); + continue; + case Fortran::lower::LowerIntrinsicArgAs::Inquired: + operands.emplace_back(lowerIntrinsicArgumentAsInquired(*expr)); + continue; + } + llvm_unreachable("bad switch"); + } + // Let the intrinsic library lower the intrinsic procedure call + return Fortran::lower::genIntrinsicCall(builder, getLoc(), name, resultType, + operands, stmtCtx); + } + + template + bool isCharacterType(const A &exp) { + if (auto type = exp.GetType()) + return type->category() == Fortran::common::TypeCategory::Character; + return false; + } + + /// helper to detect statement functions + static bool + isStatementFunctionCall(const Fortran::evaluate::ProcedureRef &procRef) { + if (const auto *symbol = procRef.proc().GetSymbol()) + if (const auto *details = + symbol->detailsIf()) + return details->stmtFunction().has_value(); + return false; + } + /// Generate Statement function calls + ExtValue genStmtFunctionRef(const Fortran::evaluate::ProcedureRef &procRef) { + const auto *symbol = procRef.proc().GetSymbol(); + assert(symbol && "expected symbol in ProcedureRef of statement functions"); + const auto &details = symbol->get(); + + // Statement functions have their own scope, we just need to associate + // the dummy symbols to argument expressions. They are no + // optional/alternate return arguments. Statement functions cannot be + // recursive (directly or indirectly) so it is safe to add dummy symbols to + // the local map here. + symMap.pushScope(); + for (auto [arg, bind] : + llvm::zip(details.dummyArgs(), procRef.arguments())) { + assert(arg && "alternate return in statement function"); + assert(bind && "optional argument in statement function"); + const auto *expr = bind->UnwrapExpr(); + // TODO: assumed type in statement function, that surprisingly seems + // allowed, probably because nobody thought of restricting this usage. + // gfortran/ifort compiles this. + assert(expr && "assumed type used as statement function argument"); + // As per Fortran 2018 C1580, statement function arguments can only be + // scalars, so just pass the box with the address. + symMap.addSymbol(*arg, gen(*expr)); + } + + // Explicitly map statement function host associated symbols to their + // parent scope lowered symbol box. + for (const Fortran::semantics::SymbolRef &sym : + Fortran::evaluate::CollectSymbols(*details.stmtFunction())) + if (const auto *details = + sym->detailsIf()) + if (!symMap.lookupSymbol(*sym)) + symMap.addSymbol(*sym, gen(details->symbol())); + + auto result = genval(details.stmtFunction().value()); + LLVM_DEBUG(llvm::dbgs() << "stmt-function: " << result << '\n'); + symMap.popScope(); + return result; + } + + /// Helper to package a Value and its properties into an ExtendedValue. + ExtValue toExtendedValue(mlir::Value base, + llvm::ArrayRef extents, + llvm::ArrayRef lengths) { + auto type = base.getType(); + if (type.isa()) + return fir::BoxValue(base, /*lbounds=*/{}, lengths, extents); + if (auto pointedType = fir::dyn_cast_ptrEleTy(type)) + type = pointedType; + if (type.isa()) + return fir::MutableBoxValue(base, lengths, /*mutableProperties*/ {}); + if (auto seqTy = type.dyn_cast()) { + if (seqTy.getDimension() != extents.size()) + fir::emitFatalError(getLoc(), "incorrect number of extents for array"); + if (seqTy.getEleTy().isa()) { + if (lengths.empty()) + fir::emitFatalError(getLoc(), "missing length for character"); + assert(lengths.size() == 1); + return fir::CharArrayBoxValue(base, lengths[0], extents); + } + return fir::ArrayBoxValue(base, extents); + } + if (type.isa()) { + if (lengths.empty()) + fir::emitFatalError(getLoc(), "missing length for character"); + assert(lengths.size() == 1); + return fir::CharBoxValue(base, lengths[0]); + } + return base; + } + + // Find the argument that corresponds to the host associations. + // Verify some assumptions about how the signature was built here. + [[maybe_unused]] static unsigned findHostAssocTuplePos(mlir::FuncOp fn) { + // Scan the argument list from last to first as the host associations are + // appended for now. + for (unsigned i = fn.getNumArguments(); i > 0; --i) + if (fn.getArgAttr(i - 1, fir::getHostAssocAttrName())) { + // Host assoc tuple must be last argument (for now). + assert(i == fn.getNumArguments() && "tuple must be last"); + return i - 1; + } + llvm_unreachable("anyFuncArgsHaveAttr failed"); + } + + /// Create a contiguous temporary array with the same shape, + /// length parameters and type as mold + ExtValue genTempFromMold(const ExtValue &mold, llvm::StringRef tempName) { + auto type = fir::dyn_cast_ptrOrBoxEleTy(fir::getBase(mold).getType()); + assert(type && "expected descriptor or memory type"); + auto loc = getLoc(); + auto extents = fir::factory::getExtents(builder, loc, mold); + auto typeParams = fir::getTypeParams(mold); + mlir::Value temp = builder.create(loc, type, tempName, + typeParams, extents); + auto *bldr = &converter.getFirOpBuilder(); + // TODO: call finalizer if needed. + stmtCtx.attachCleanup([=]() { bldr->create(loc, temp); }); + if (fir::unwrapSequenceType(type).isa()) { + auto len = typeParams.empty() + ? fir::factory::readCharLen(builder, loc, mold) + : typeParams[0]; + return fir::CharArrayBoxValue{temp, len, extents}; + } + return fir::ArrayBoxValue{temp, extents}; + } + + /// Copy \p source array into \p dest array. Both arrays must be + /// conforming, but neither array must be contiguous. + void genArrayCopy(ExtValue dest, ExtValue source) { + return createSomeArrayAssignment(converter, dest, source, symMap, stmtCtx); + } + + /// Lower a non-elemental procedure reference and read allocatable and pointer + /// results into normal values. + ExtValue genProcedureRef(const Fortran::evaluate::ProcedureRef &procRef, + llvm::Optional resultType) { + auto res = genRawProcedureRef(procRef, resultType); + // In most contexts, pointers and allocatable do not appear as allocatable + // or pointer variable on the caller side (see 8.5.3 note 1 for + // allocatables). The few context where this can happen must call + // genRawProcedureRef directly. + if (const auto *box = res.getBoxOf()) + return fir::factory::genMutableBoxRead(builder, getLoc(), *box); + return res; + } + + /// Given a call site for which the arguments were already lowered, generate + /// the call and return the result. This function deals with explicit result + /// allocation and lowering if needed. It also deals with passing the host + /// link to internal procedures. + ExtValue genCallOpAndResult(Fortran::lower::CallerInterface &caller, + mlir::FunctionType callSiteType, + llvm::Optional resultType) { + auto loc = getLoc(); + using PassBy = Fortran::lower::CallerInterface::PassEntityBy; + // Handle cases where caller must allocate the result or a fir.box for it. + bool mustPopSymMap = false; + if (caller.mustMapInterfaceSymbols()) { + symMap.pushScope(); + mustPopSymMap = true; + Fortran::lower::mapCallInterfaceSymbols(converter, caller, symMap); + } + + auto idxTy = builder.getIndexType(); + auto lowerSpecExpr = [&](const auto &expr) -> mlir::Value { + return builder.createConvert( + loc, idxTy, fir::getBase(converter.genExprValue(expr, stmtCtx))); + }; + llvm::SmallVector resultLengths; + auto allocatedResult = [&]() -> llvm::Optional { + llvm::SmallVector extents; + llvm::SmallVector lengths; + if (!caller.callerAllocateResult()) + return {}; + auto type = caller.getResultStorageType(); + if (type.isa()) + caller.walkResultExtents([&](const Fortran::lower::SomeExpr &e) { + extents.emplace_back(lowerSpecExpr(e)); + }); + caller.walkResultLengths([&](const Fortran::lower::SomeExpr &e) { + lengths.emplace_back(lowerSpecExpr(e)); + }); + /// Result lengths parameters should not be provided to box storage + /// allocation and save_results, but they are still useful information to + /// keep in the ExtentdedValue if non-deferred. + if (!type.isa()) + resultLengths = lengths; + auto temp = + builder.createTemporary(loc, type, ".result", extents, resultLengths); + return toExtendedValue(temp, extents, lengths); + }(); + + if (mustPopSymMap) + symMap.popScope(); + + // Place allocated result or prepare the fir.save_result arguments. + mlir::Value arrayResultShape; + if (allocatedResult) { + if (auto resultArg = caller.getPassedResult()) { + if (resultArg->passBy == PassBy::AddressAndLength) + caller.placeAddressAndLengthInput(*resultArg, + fir::getBase(*allocatedResult), + fir::getLen(*allocatedResult)); + else if (resultArg->passBy == PassBy::BaseAddress) + caller.placeInput(*resultArg, fir::getBase(*allocatedResult)); + else + fir::emitFatalError( + loc, "only expect character scalar result to be passed by ref"); + } else { + assert(caller.mustSaveResult()); + arrayResultShape = allocatedResult->match( + [&](const fir::CharArrayBoxValue &) { + return builder.createShape(loc, *allocatedResult); + }, + [&](const fir::ArrayBoxValue &) { + return builder.createShape(loc, *allocatedResult); + }, + [&](const auto &) { return mlir::Value{}; }); + } + } + + // In older Fortran, procedure argument types are inferred. This may lead + // different view of what the function signature is in different locations. + // Casts are inserted as needed below to acomodate this. + + // The mlir::FuncOp type prevails, unless it has a different number of + // arguments which can happen in legal program if it was passed as a dummy + // procedure argument earlier with no further type information. + mlir::Value funcPointer; + mlir::SymbolRefAttr funcSymbolAttr; + bool addHostAssociations = false; + if (const auto *sym = caller.getIfIndirectCallSymbol()) { + funcPointer = symMap.lookupSymbol(*sym).getAddr(); + assert(funcPointer && + "dummy procedure or procedure pointer not in symbol map"); + } else { + auto funcOpType = caller.getFuncOp().getType(); + auto symbolAttr = builder.getSymbolRefAttr(caller.getMangledName()); + if (callSiteType.getNumResults() == funcOpType.getNumResults() && + callSiteType.getNumInputs() + 1 == funcOpType.getNumInputs() && + fir::anyFuncArgsHaveAttr(caller.getFuncOp(), + fir::getHostAssocAttrName())) { + // The number of arguments is off by one, and we're lowering a function + // with host associations. Modify call to include host associations + // argument by appending the value at the end of the operands. + assert(funcOpType.getInput(findHostAssocTuplePos(caller.getFuncOp())) == + converter.hostAssocTupleValue().getType()); + addHostAssociations = true; + } + if (!addHostAssociations && + (callSiteType.getNumResults() != funcOpType.getNumResults() || + callSiteType.getNumInputs() != funcOpType.getNumInputs())) { + // Deal with argument number mismatch by making a function pointer so + // that function type cast can be inserted. Do not emit a warning here + // because this can happen in legal program if the function is not + // defined here and it was first passed as an argument without any more + // information. + funcPointer = + builder.create(loc, funcOpType, symbolAttr); + } else if (callSiteType.getResults() != funcOpType.getResults()) { + // Implicit interface result type mismatch are not standard Fortran, but + // some compilers are not complaining about it. The front end is not + // protecting lowering from this currently. Support this with a + // discouraging warning. + LLVM_DEBUG(mlir::emitWarning( + loc, "a return type mismatch is not standard compliant and may " + "lead to undefined behavior.")); + // Cast the actual function to the current caller implicit type because + // that is the behavior we would get if we could not see the definition. + funcPointer = + builder.create(loc, funcOpType, symbolAttr); + } else { + funcSymbolAttr = symbolAttr; + } + } + + auto funcType = funcPointer ? callSiteType : caller.getFuncOp().getType(); + llvm::SmallVector operands; + // First operand of indirect call is the function pointer. Cast it to + // required function type for the call to handle procedures that have a + // compatible interface in Fortran, but that have different signatures in + // FIR. + if (funcPointer) + operands.push_back(builder.createConvert(loc, funcType, funcPointer)); + + // Deal with potential mismatches in arguments types. Passing an array to a + // scalar argument should for instance be tolerated here. + for (auto [fst, snd] : + llvm::zip(caller.getInputs(), funcType.getInputs())) { + auto cast = builder.convertWithSemantics(getLoc(), snd, fst); + operands.push_back(cast); + } + + // Add host associations as necessary. + if (addHostAssociations) + operands.push_back(converter.hostAssocTupleValue()); + + auto call = builder.create(loc, funcType.getResults(), + funcSymbolAttr, operands); + + if (caller.mustSaveResult()) + builder.create( + loc, call.getResult(0), fir::getBase(allocatedResult.getValue()), + arrayResultShape, resultLengths); + + if (allocatedResult) { + allocatedResult->match( + [&](const fir::MutableBoxValue &box) { + if (box.isAllocatable()) { + // 9.7.3.2 point 4. Finalize allocatables. + auto *bldr = &converter.getFirOpBuilder(); + stmtCtx.attachCleanup( + [=]() { fir::factory::genFinalization(*bldr, loc, box); }); + } + }, + [](const auto &) {}); + return *allocatedResult; + } + + if (!resultType.hasValue()) + return mlir::Value{}; // subroutine call + // For now, Fortran return values are implemented with a single MLIR + // function return value. + assert(call.getNumResults() == 1 && + "Expected exactly one result in FUNCTION call"); + return call.getResult(0); + } + + /// Lower a non-elemental procedure reference. + ExtValue genRawProcedureRef(const Fortran::evaluate::ProcedureRef &procRef, + llvm::Optional resultType) { + auto loc = getLoc(); + if (isElementalProcWithArrayArgs(procRef)) + fir::emitFatalError(loc, "trying to lower elemental procedure with array " + "arguments as normal procedure"); + if (const auto *intrinsic = procRef.proc().GetSpecificIntrinsic()) + return genIntrinsicRef(procRef, *intrinsic, resultType); + + if (isStatementFunctionCall(procRef)) + return genStmtFunctionRef(procRef); + + Fortran::lower::CallerInterface caller(procRef, converter); + using PassBy = Fortran::lower::CallerInterface::PassEntityBy; + + llvm::SmallVector mutableModifiedByCall; + // List of where temp must be copied into var after the call. + llvm::SmallVector, 4> copyOutPairs; + + auto callSiteType = caller.genFunctionType(); + + // Lower the actual arguments and map the lowered values to the dummy + // arguments. + for (const auto &arg : caller.getPassedArguments()) { + const auto *actual = arg.entity; + auto argTy = callSiteType.getInput(arg.firArgument); + if (!actual) { + // Optional dummy argument for which there is no actual argument. + caller.placeInput(arg, builder.create(loc, argTy)); + continue; + } + const auto *expr = actual->UnwrapExpr(); + if (!expr) + TODO(loc, "assumed type actual argument lowering"); + + if (arg.passBy == PassBy::Value) { + auto argVal = genval(*expr); + if (!fir::isUnboxedValue(argVal)) + fir::emitFatalError( + loc, "internal error: passing non trivial value by value"); + caller.placeInput(arg, fir::getBase(argVal)); + continue; + } + + if (arg.passBy == PassBy::MutableBox) { + if (Fortran::evaluate::UnwrapExpr( + *expr)) { + // If expr is NULL(), the mutableBox created must be a deallocated + // pointer with the dummy argument characteristics (see table 16.5 + // in Fortran 2018 standard). + // No length parameters are set for the created box because any non + // deferred type parameters of the dummy will be evaluated on the + // callee side, and it is illegal to use NULL without a MOLD if any + // dummy length parameters are assumed. + auto boxTy = fir::dyn_cast_ptrEleTy(argTy); + assert(boxTy && boxTy.isa() && + "must be a fir.box type"); + auto boxStorage = builder.createTemporary(loc, boxTy); + auto nullBox = fir::factory::createUnallocatedBox( + builder, loc, boxTy, /*nonDeferredParams=*/{}); + builder.create(loc, nullBox, boxStorage); + caller.placeInput(arg, boxStorage); + continue; + } + auto mutableBox = genMutableBoxValue(*expr); + auto irBox = fir::factory::getMutableIRBox(builder, loc, mutableBox); + caller.placeInput(arg, irBox); + if (arg.mayBeModifiedByCall()) + mutableModifiedByCall.emplace_back(std::move(mutableBox)); + continue; + } + + if (arg.passBy == PassBy::BaseAddress || arg.passBy == PassBy::BoxChar) { + auto argAddr = [&]() -> ExtValue { + ExtValue baseAddr; + if (Fortran::evaluate::IsVariable(*expr) && expr->Rank() > 0) { + auto box = genBoxArg(*expr); + if (!Fortran::evaluate::IsSimplyContiguous( + *expr, converter.getFoldingContext())) { + // Non contiguous variable need to be copied into a contiguous + // temp, and the temp need to be copied back after the call in + // case it was modified. + auto temp = genTempFromMold(box, ".copyinout"); + if (arg.mayBeReadByCall()) + genArrayCopy(temp, box); + if (arg.mayBeModifiedByCall()) + copyOutPairs.emplace_back(box, temp); + return temp; + } + // Contiguous: just use the box we created above! + // This gets "unboxed" below, if needed. + baseAddr = box; + } else + baseAddr = genExtAddr(*expr); + + // Scalar and contiguous expressions may be lowered to a fir.box, + // either to account for potential polymorphism, or because lowering + // did not account for some contiguity hints. + // Here, polymorphism does not matter (an entity of the declared type + // is passed, not one of the dynamic type), and the expr is known to + // be simply contiguous, so it is safe to unbox it and pass the + // address without making a copy. + if (const auto *box = baseAddr.getBoxOf()) + return fir::factory::readBoxValue(builder, loc, *box); + return baseAddr; + }(); + if (arg.passBy == PassBy::BaseAddress) { + caller.placeInput(arg, fir::getBase(argAddr)); + } else { + assert(arg.passBy == PassBy::BoxChar); + auto helper = fir::factory::CharacterExprHelper{builder, loc}; + auto boxChar = argAddr.match( + [&](const fir::CharBoxValue &x) { return helper.createEmbox(x); }, + [&](const fir::CharArrayBoxValue &x) { + return helper.createEmbox(x); + }, + [&](const auto &) -> mlir::Value { + fir::emitFatalError( + loc, "internal error: actual argument is not a character"); + }); + caller.placeInput(arg, boxChar); + } + } else if (arg.passBy == PassBy::Box) { + // Before lowering to an address, handle the allocatable/pointer actual + // argument to optional fir.box dummy. It is legal to pass + // unallocated/disassociated entity to an optional. In this case, an + // absent fir.box must be created instead of a fir.box with a null value + // (Fortran 2018 15.5.2.12 point 1). + if (arg.isOptional() && isAllocatableOrPointer(*expr)) { + // Note that passing an absent allocatable to a non-allocatable + // optional dummy argument is illegal (15.5.2.12 point 3 (8)). So + // nothing has to be done to generate an absent argument in this case, + // and it is OK to unconditionally read the mutable box here. + auto mutableBox = genMutableBoxValue(*expr); + auto isAllocated = fir::factory::genIsAllocatedOrAssociatedTest( + builder, loc, mutableBox); + auto absent = builder.create(loc, argTy); + /// For now, assume it is not OK to pass the allocatable/pointer + /// descriptor to a non pointer/allocatable dummy. That is a strict + /// interpretation of 18.3.6 point 4 that stipulates the descriptor + /// has the dummy attributes in BIND(C) contexts. + auto box = builder.createBox( + loc, fir::factory::genMutableBoxRead(builder, loc, mutableBox)); + // Need the box types to be exactly similar for the selectOp. + auto convertedBox = builder.createConvert(loc, argTy, box); + caller.placeInput(arg, builder.create( + loc, isAllocated, convertedBox, absent)); + } else { + auto box = builder.createBox(loc, genBoxArg(*expr)); + caller.placeInput(arg, box); + } + } else if (arg.passBy == PassBy::AddressAndLength) { + auto argRef = genExtAddr(*expr); + caller.placeAddressAndLengthInput(arg, fir::getBase(argRef), + fir::getLen(argRef)); + } else { + TODO(loc, "pass by value in non elemental function call"); + } + } + + auto result = genCallOpAndResult(caller, callSiteType, resultType); + + // Sync pointers and allocatables that may have been modified during the + // call. + for (const auto &mutableBox : mutableModifiedByCall) + fir::factory::syncMutableBoxFromIRBox(builder, loc, mutableBox); + // Handle case where result was passed as argument + + // Copy-out temps that were created for non contiguous variable arguments if + // needed. + for (auto [var, temp] : copyOutPairs) + genArrayCopy(var, temp); + + return result; + } + + template + ExtValue + genval(const Fortran::evaluate::FunctionRef> + &funRef) { + auto retTy = converter.genType(TC, KIND); + return genProcedureRef(funRef, {retTy}); + } + + ExtValue genval(const Fortran::evaluate::ProcedureRef &procRef) { + llvm::Optional resTy; + if (procRef.hasAlternateReturns()) + resTy = builder.getIndexType(); + return genProcedureRef(procRef, resTy); + } + + template + bool isScalar(const A &x) { + return x.Rank() == 0; + } + + /// Helper to detect Transformational function reference. + template + bool isTransformationalRef(const T &) { + return false; + } + template + bool isTransformationalRef(const Fortran::evaluate::FunctionRef &funcRef) { + return !funcRef.IsElemental() && funcRef.Rank(); + } + template + bool isTransformationalRef(Fortran::evaluate::Expr expr) { + return std::visit([&](const auto &e) { return isTransformationalRef(e); }, + expr.u); + } + + template + ExtValue asArray(const A &x) { + auto expr = toEvExpr(x); + auto optShape = + Fortran::evaluate::GetShape(converter.getFoldingContext(), expr); + return Fortran::lower::createSomeArrayTempValue(converter, optShape, expr, + symMap, stmtCtx); + } + + /// Lower an array value as an argument. This argument can be passed as a box + /// value, so it may be possible to avoid making a temporary. + template + ExtValue asArrayArg(const Fortran::evaluate::Expr &x) { + return std::visit([&](const auto &e) { return asArrayArg(e, x); }, x.u); + } + template + ExtValue asArrayArg(const Fortran::evaluate::Expr &x, const B &y) { + return std::visit([&](const auto &e) { return asArrayArg(e, y); }, x.u); + } + template + ExtValue asArrayArg(const Fortran::evaluate::Designator &, const B &x) { + // Designator is being passed as an argument to a procedure. Lower the + // expression to a boxed value. + return Fortran::lower::createSomeArrayBox(converter, toEvExpr(x), symMap, + stmtCtx); + } + template + ExtValue asArrayArg(const A &, const B &x) { + // If the expression to pass as an argument is not a designator, then create + // an array temp. + return asArray(x); + } + + template + ExtValue gen(const Fortran::evaluate::Expr &x) { + // Whole array symbols or components, and results of transformational + // functions already have a storage and the scalar expression lowering path + // is used to not create a new temporary storage. + if (isScalar(x) || + Fortran::evaluate::UnwrapWholeSymbolOrComponentDataRef(x) || + isTransformationalRef(x)) + return std::visit([&](const auto &e) { return genref(e); }, x.u); + if (useBoxArg) + return asArrayArg(x); + return asArray(x); + } + template + ExtValue genval(const Fortran::evaluate::Expr &x) { + if (isScalar(x) || Fortran::evaluate::UnwrapWholeSymbolDataRef(x) || + inInitializer) + return std::visit([&](const auto &e) { return genval(e); }, x.u); + return asArray(x); + } + + template + ExtValue genval(const Fortran::evaluate::Expr> &exp) { + return std::visit([&](const auto &e) { return genval(e); }, exp.u); + } + + using RefSet = + std::tuple; + template + static constexpr bool inRefSet = Fortran::common::HasMember; + + template >> + ExtValue genref(const A &a) { + return gen(a); + } + template + ExtValue genref(const A &a) { + auto exv = genval(a); + auto valBase = fir::getBase(exv); + // Functions are always referent. + if (valBase.getType().template isa() || + fir::conformsWithPassByRef(valBase.getType())) + return exv; + + // Since `a` is not itself a valid referent, determine its value and + // create a temporary location at the begining of the function for + // referencing. + auto val = valBase; + if constexpr (!Fortran::common::HasMember< + A, Fortran::evaluate::TypelessExpression>) { + if constexpr (A::Result::category == + Fortran::common::TypeCategory::Logical) { + // Ensure logicals that may have been lowered to `i1` are cast to the + // Fortran logical type before being placed in memory. + auto type = converter.genType(A::Result::category, A::Result::kind); + val = builder.createConvert(getLoc(), type, valBase); + } + } + auto func = builder.getFunction(); + auto initPos = builder.saveInsertionPoint(); + builder.setInsertionPointToStart(&func.front()); + auto mem = builder.create(getLoc(), val.getType()); + builder.restoreInsertionPoint(initPos); + builder.create(getLoc(), val, mem); + return fir::substBase(exv, mem.getResult()); + } + + template typename T, + typename B = std::decay_t>, + std::enable_if_t< + std::is_same_v> || + std::is_same_v> || + std::is_same_v>, + bool> = true> + ExtValue genref(const T &x) { + return gen(x); + } + +private: + mlir::Location location; + Fortran::lower::AbstractConverter &converter; + fir::FirOpBuilder &builder; + Fortran::lower::StatementContext &stmtCtx; + Fortran::lower::SymMap &symMap; + bool inInitializer; + bool useBoxArg{false}; // expression lowered as argument +}; +} // namespace + +// Helper for changing the semantics in a given context. Preserves the current +// semantics which is resumed when the "push" goes out of scope. +#define PushSemantics(PushVal) \ + [[maybe_unused]] auto pushSemanticsLocalVariable97201 = \ + Fortran::common::ScopedSet(semant, PushVal); + +static bool isAdjustedArrayElementType(mlir::Type t) { + return fir::isa_char(t) || fir::isa_derived(t); +} +static bool elementTypeWasAdjusted(mlir::Type t) { + if (auto ty = t.dyn_cast()) + return isAdjustedArrayElementType(ty.getEleTy()); + return false; +} +static mlir::Type adjustedArrayElementType(mlir::Type t) { + return isAdjustedArrayElementType(t) ? fir::ReferenceType::get(t) : t; +} + +/// Extract the subelement type and perform any trivial conversions on `val`, +/// such as `index -> i32` or `i1 -> !fir.logical`, to align the value's type to +/// array storage. +static mlir::Value adjustedArrayElement(mlir::Location loc, + fir::FirOpBuilder &builder, + mlir::Value val, mlir::Type arrTy) { + auto eleTy = fir::unwrapSequenceType(arrTy); + return builder.createConvert(loc, adjustedArrayElementType(eleTy), val); +} + +//===----------------------------------------------------------------------===// +// +// Lowering of scalar expressions in an explicit iteration space context. +// +//===----------------------------------------------------------------------===// + +namespace { +/// In an explicit iteration space, a scalar expression can be lowered +/// immediately as the explicit iteration space will have already been +/// constructed. However, the base array expressions must be handled distinctly +/// from a "regular" scalar expression. Base arrays are bound to fir.array_load +/// values. Base arrays on the LHS of an assignment must be properly threaded +/// using block arguments. +class ScalarArrayExprLowering { + using ExtValue = fir::ExtendedValue; + using PathComponent = std::variant; + using PathValues = llvm::SmallVector; + +public: + explicit ScalarArrayExprLowering(Fortran::lower::AbstractConverter &c, + Fortran::lower::SymMap &symMap, + Fortran::lower::ExplicitIterSpace &esp, + Fortran::lower::StatementContext &sc) + : converter{c}, builder{c.getFirOpBuilder()}, stmtCtx{sc}, symMap{symMap}, + expSpace{esp} {} + + template + ExtValue lower(const A &x) { + return gen(x); + } + + template + ExtValue lowerRef(const A &x) { + semant = ConstituentSemantics::RefOpaque; + return gen(x); + } + + template + ExtValue assign(const A &lhs, const B &rhs) { + semant = ConstituentSemantics::RefTransparent; + // 1) Lower the rhs expression with array_fetch op(s). + auto rexv = lower(rhs); + elementalValue = fir::getBase(rexv); + // 2) Lower the lhs expression to an array_update. + semant = ConstituentSemantics::ProjectedCopyInCopyOut; + auto lexv = lower(lhs); + // 3) Thread the array value updated forward. Note: the lhs might be + // ill-formed, in which case there is no array to thread. + if (auto updateOp = mlir::dyn_cast( + fir::getBase(lexv).getDefiningOp())) { + auto oldInnerArg = updateOp.sequence(); + auto offset = expSpace.argPosition(oldInnerArg); + expSpace.setInnerArg(offset, fir::getBase(lexv)); + } + return lexv; + } + +private: + bool pathIsEmpty() { return reversePath.empty(); } + + void clearPath() { reversePath.clear(); } + + llvm::SmallVector lowerPath(mlir::Type ty) { + auto loc = getLoc(); + auto fieldTy = fir::FieldType::get(builder.getContext()); + auto idxTy = builder.getIndexType(); + llvm::SmallVector result; + for (const auto &v : llvm::reverse(reversePath)) { + auto addField = [&](const Fortran::evaluate::Component &x) { + // TODO: Move to a helper function. + auto name = toStringRef(x.GetLastSymbol().name()); + auto recTy = ty.cast(); + auto memTy = recTy.getType(name); + auto fld = builder.create( + loc, fieldTy, name, recTy, /*typeparams=*/mlir::ValueRange{}); + result.push_back(fld); + return memTy; + }; + auto addSub = [&](const Fortran::evaluate::Subscript &sub) { + auto v = fir::getBase(gen(sub)); + auto cast = builder.createConvert(loc, idxTy, v); + result.push_back(cast); + }; + std::visit(Fortran::common::visitors{ + [&](int) { ty = fir::unwrapSequenceType(ty); }, + [&](const Fortran::evaluate::Subscript *x) { addSub(*x); }, + [&](const Fortran::evaluate::ArrayRef *x) { + assert(!x->base().IsSymbol()); + ty = addField(x->base().GetComponent()); + for (const auto &sub : x->subscript()) + addSub(sub); + ty = fir::unwrapSequenceType(ty); + }, + [&](const Fortran::evaluate::Component *x) { + ty = addField(*x); + }}, + v); + } + return result; + } + + /// Apply the reversed path components to the value returned from `load`. + ExtValue applyPathToArrayLoad(fir::ArrayLoadOp &load) { + auto loc = getLoc(); + ExtValue result; + if (semant == ConstituentSemantics::ProjectedCopyInCopyOut) { + auto innerArg = expSpace.findArgumentOfLoad(load); + auto path = lowerPath(load.getType()); + auto eleTy = fir::applyPathToType(innerArg.getType(), path); + auto toTy = adjustedArrayElementType(eleTy); + auto castedElement = builder.createConvert(loc, toTy, elementalValue); + auto update = builder.create(loc, innerArg.getType(), + innerArg, castedElement, + path, load.typeparams()); + // Flag the offsets as "Fortran" as they are not zero-origin. + update->setAttr(fir::factory::attrFortranArrayOffsets(), + builder.getUnitAttr()); + result = arrayLoadExtValue(builder, loc, load, {}, update); + } else { + auto path = lowerPath(load.getType()); + auto eleTy = fir::applyPathToType(load.getType(), path); + assert(eleTy && "path did not apply to type"); + auto resTy = adjustedArrayElementType(eleTy); + // TODO: When loading a subobject array, convert the fetch (value) to a + // fetch reference. This reference can then be used in a secondary + // array_load. Consider handling this another way. + if (semant == ConstituentSemantics::RefOpaque && + !fir::isa_ref_type(resTy)) + resTy = builder.getRefType(resTy); + auto fetch = builder.create(loc, resTy, load, path, + load.typeparams()); + // Flag the offsets as "Fortran" as they are not zero-origin. + fetch->setAttr(fir::factory::attrFortranArrayOffsets(), + builder.getUnitAttr()); + result = arrayLoadExtValue(builder, loc, load, path, fetch); + } + clearPath(); + return result; + } + + //===-------------------------------------------------------------------===// + // Use the cached base array_load, where possible. + //===-------------------------------------------------------------------===// + + ExtValue gen(const Fortran::evaluate::Subscript &sub) { + if (const auto *e = + std::get_if( + &sub.u)) + return asScalarArray(e->value()); + TODO(getLoc(), "triplet"); + } + + ExtValue gen(const Fortran::semantics::Symbol &x) { + if (auto load = expSpace.findBinding(&x)) + return applyPathToArrayLoad(load); + if (pathIsEmpty()) + return asScalar(x); + return {}; + } + + ExtValue gen(const Fortran::evaluate::Component &x) { + if (auto load = expSpace.findBinding(&x)) + return applyPathToArrayLoad(load); + auto top = pathIsEmpty(); + reversePath.push_back(&x); + auto result = gen(x.base()); + if (pathIsEmpty()) + return result; + if (top) + return asScalar(x); + return {}; + } + + ExtValue gen(const Fortran::evaluate::ArrayRef &x) { + if (auto load = expSpace.findBinding(&x)) { + reversePath.push_back(0); // flag for end of subscripts + for (const auto &sub : llvm::reverse(x.subscript())) + reversePath.push_back(&sub); + return applyPathToArrayLoad(load); + } + auto top = pathIsEmpty(); + reversePath.push_back(&x); + auto result = gen(x.base()); + if (pathIsEmpty()) + return result; + if (top) + return asScalar(x); + return {}; + } + + ExtValue gen(const Fortran::evaluate::CoarrayRef &x) { + TODO(getLoc(), "coarray reference"); + return {}; + } + + //===-------------------------------------------------------------------===// + // Traversal and canonical translation boilerplate. + //===-------------------------------------------------------------------===// + + ExtValue gen(const Fortran::evaluate::NamedEntity &x) { + return x.IsSymbol() ? gen(x.GetFirstSymbol()) : gen(x.GetComponent()); + } + ExtValue gen(const Fortran::evaluate::DataRef &x) { + return std::visit([&](const auto &v) { return gen(v); }, x.u); + } + ExtValue gen(const Fortran::evaluate::ComplexPart &x) { + auto exv = gen(x.complex()); + auto imaginary = x.part() != Fortran::evaluate::ComplexPart::Part::RE; + fir::factory::ComplexExprHelper helper(builder, getLoc()); + auto base = fir::getBase(exv); + if (fir::isa_complex(base.getType())) + return helper.extractComplexPart(base, imaginary); + auto eleTy = + helper.getComplexPartType(fir::dyn_cast_ptrEleTy(base.getType())); + auto loc = getLoc(); + auto idxTy = builder.getIndexType(); + auto offset = builder.createIntegerConstant(loc, idxTy, imaginary ? 1 : 0); + mlir::Value result = builder.create( + loc, builder.getRefType(eleTy), base, mlir::ValueRange{offset}); + return result; + } + template + ExtValue + gen(const Fortran::evaluate::Convert, TC2> + &x) { + auto exv = gen(x.left()); + auto ty = converter.genType(TC1, KIND); + return builder.createConvert(getLoc(), ty, fir::getBase(exv)); + } + template + ExtValue gen(const Fortran::evaluate::ComplexComponent &x) { + auto exv = gen(x.left()); + return fir::factory::ComplexExprHelper{builder, getLoc()} + .extractComplexPart(fir::getBase(exv), x.isImaginaryPart); + } + template + ExtValue + gen(const Fortran::evaluate::Parentheses> + &x) { + auto exv = gen(x.left()); + auto base = fir::getBase(exv); + auto newBase = + builder.create(getLoc(), base.getType(), base); + return fir::substBase(exv, newBase); + } + template + ExtValue gen(const Fortran::evaluate::Negate> &x) { + auto loc = getLoc(); + auto exv = gen(x.left()); + auto ty = converter.genType(Fortran::common::TypeCategory::Integer, KIND); + auto zero = builder.createIntegerConstant(loc, ty, 0); + return builder.create(loc, zero, fir::getBase(exv)); + } + template + ExtValue genNegate(const A &x) { + auto exv = gen(x.left()); + return builder.create(getLoc(), fir::getBase(exv)); + } + template + ExtValue + gen(const Fortran::evaluate::Negate< + Fortran::evaluate::Type> &x) { + return genNegate(x); + } + template + ExtValue gen(const Fortran::evaluate::Negate> &x) { + return genNegate(x); + } + + template + ExtValue createBinaryOp(const A &evEx) { + auto lhs = gen(evEx.left()); + auto rhs = gen(evEx.right()); + return builder.create(getLoc(), fir::getBase(lhs), fir::getBase(rhs)); + } + +#undef GENBIN +#define GENBIN(GenBinEvOp, GenBinTyCat, GenBinFirOp) \ + template \ + ExtValue gen(const Fortran::evaluate::GenBinEvOp> &x) { \ + return createBinaryOp(x); \ + } + GENBIN(Add, Integer, mlir::AddIOp) + GENBIN(Add, Real, mlir::AddFOp) + GENBIN(Add, Complex, fir::AddcOp) + GENBIN(Subtract, Integer, mlir::SubIOp) + GENBIN(Subtract, Real, mlir::SubFOp) + GENBIN(Subtract, Complex, fir::SubcOp) + GENBIN(Multiply, Integer, mlir::MulIOp) + GENBIN(Multiply, Real, mlir::MulFOp) + GENBIN(Multiply, Complex, fir::MulcOp) + GENBIN(Divide, Integer, mlir::SignedDivIOp) + GENBIN(Divide, Real, mlir::DivFOp) + GENBIN(Divide, Complex, fir::DivcOp) + + template + ExtValue + gen(const Fortran::evaluate::Power> &x) { + auto ty = converter.genType(TC, KIND); + auto lhs = gen(x.left()); + auto rhs = gen(x.right()); + return Fortran::lower::genPow(builder, getLoc(), ty, fir::getBase(lhs), + fir::getBase(rhs)); + } + template + ExtValue + gen(const Fortran::evaluate::Extremum> &x) { + auto loc = getLoc(); + auto lhs = gen(x.left()); + auto rhs = gen(x.right()); + switch (x.ordering) { + case Fortran::evaluate::Ordering::Greater: + return Fortran::lower::genMax( + builder, loc, + llvm::ArrayRef{fir::getBase(lhs), fir::getBase(rhs)}); + case Fortran::evaluate::Ordering::Less: + return Fortran::lower::genMin( + builder, loc, + llvm::ArrayRef{fir::getBase(lhs), fir::getBase(rhs)}); + case Fortran::evaluate::Ordering::Equal: + llvm_unreachable("Equal is not a valid ordering in this context"); + } + llvm_unreachable("unknown ordering"); + } + template + ExtValue + gen(const Fortran::evaluate::RealToIntPower> + &x) { + auto loc = getLoc(); + auto ty = converter.genType(TC, KIND); + auto lhs = gen(x.left()); + auto rhs = gen(x.right()); + return Fortran::lower::genPow(builder, loc, ty, fir::getBase(lhs), + fir::getBase(rhs)); + } + template + ExtValue gen(const Fortran::evaluate::ComplexConstructor &x) { + auto loc = getLoc(); + auto left = gen(x.left()); + auto right = gen(x.right()); + return fir::factory::ComplexExprHelper{builder, loc}.createComplex( + KIND, fir::getBase(left), fir::getBase(right)); + } + template + ExtValue gen(const Fortran::evaluate::Concat &x) { + auto loc = getLoc(); + auto left = gen(x.left()); + auto right = gen(x.right()); + auto *lchr = left.getCharBox(); + auto *rchr = right.getCharBox(); + if (lchr && rchr) { + return fir::factory::CharacterExprHelper{builder, loc}.createConcatenate( + *lchr, *rchr); + } + TODO(loc, "concat on unexpected extended values"); + return mlir::Value{}; + } + template + ExtValue gen(const Fortran::evaluate::SetLength &x) { + auto left = gen(x.left()); + auto right = asScalar(x.right()); + return fir::CharBoxValue{fir::getBase(left), fir::getBase(right)}; + } + ExtValue gen(const Fortran::semantics::SymbolRef &sym) { + return gen(sym.get()); + } + ExtValue gen(const Fortran::evaluate::Substring &x) { + auto loc = getLoc(); + auto base = std::visit( + Fortran::common::visitors{ + [&](const Fortran::evaluate::DataRef &p) { return gen(p); }, + [&](const Fortran::evaluate::StaticDataObject::Pointer &) + -> ExtValue { + fir::emitFatalError(loc, "substring of static array object"); + }}, + x.parent()); + llvm::SmallVector bounds = {fir::getBase(gen(x.lower()))}; + if (auto upper = x.upper()) + bounds.push_back(fir::getBase(gen(*upper))); + if (auto *chr = base.getCharBox()) + return fir::factory::CharacterExprHelper{builder, loc}.createSubstring( + *chr, bounds); + TODO(loc, "unhandled substring base type"); + return mlir::Value{}; + } + template + ExtValue gen(const Fortran::evaluate::FunctionRef &x) { + return asScalar(x); + } + template + ExtValue gen(const Fortran::evaluate::Constant &x) { + return asScalar(x); + } + ExtValue gen(const Fortran::evaluate::ProcedureDesignator &x) { + return asScalar(x); + } + ExtValue gen(const Fortran::evaluate::ProcedureRef &x) { return asScalar(x); } + template >> + ExtValue gen(const A &x) { + return asScalar(x); + } + template + ExtValue gen(const Fortran::evaluate::ArrayConstructor &x) { + return asScalar(x); + } + ExtValue gen(const Fortran::evaluate::ImpliedDoIndex &x) { + return asScalar(x); + } + ExtValue gen(const Fortran::evaluate::TypeParamInquiry &x) { + return asScalar(x); + } + ExtValue gen(const Fortran::evaluate::DescriptorInquiry &x) { + return asScalar(x); + } + ExtValue gen(const Fortran::evaluate::StructureConstructor &x) { + return asScalar(x); + } + + template + ExtValue gen(const Fortran::evaluate::Not &x) { + auto loc = getLoc(); + auto i1Ty = builder.getI1Type(); + auto logical = gen(x.left()); + auto truth = builder.createBool(loc, true); + auto val = builder.createConvert(loc, i1Ty, fir::getBase(logical)); + return builder.create(loc, val, truth); + } + + template + ExtValue createBinaryBoolOp(const A &x) { + auto loc = getLoc(); + auto i1Ty = builder.getI1Type(); + auto left = gen(x.left()); + auto right = gen(x.right()); + auto lhs = builder.createConvert(loc, i1Ty, fir::getBase(left)); + auto rhs = builder.createConvert(loc, i1Ty, fir::getBase(right)); + return builder.create(loc, lhs, rhs); + } + template + ExtValue createCompareBoolOp(mlir::CmpIPredicate pred, const A &x) { + auto loc = getLoc(); + auto i1Ty = builder.getI1Type(); + auto left = gen(x.left()); + auto right = gen(x.right()); + auto lhs = builder.createConvert(loc, i1Ty, fir::getBase(left)); + auto rhs = builder.createConvert(loc, i1Ty, fir::getBase(right)); + return builder.create(loc, pred, lhs, rhs); + } + template + ExtValue gen(const Fortran::evaluate::LogicalOperation &x) { + switch (x.logicalOperator) { + case Fortran::evaluate::LogicalOperator::And: + return createBinaryBoolOp(x); + case Fortran::evaluate::LogicalOperator::Or: + return createBinaryBoolOp(x); + case Fortran::evaluate::LogicalOperator::Eqv: + return createCompareBoolOp(mlir::CmpIPredicate::eq, x); + case Fortran::evaluate::LogicalOperator::Neqv: + return createCompareBoolOp(mlir::CmpIPredicate::ne, x); + case Fortran::evaluate::LogicalOperator::Not: + llvm_unreachable(".NOT. handled elsewhere"); + } + llvm_unreachable("unhandled case"); + } + + template + ExtValue createCompareOp(PRED pred, const A &x) { + auto loc = getLoc(); + auto lhs = gen(x.left()); + auto rhs = gen(x.right()); + return builder.create(loc, pred, fir::getBase(lhs), fir::getBase(rhs)); + } + template + ExtValue createCompareCharOp(mlir::CmpIPredicate pred, const A &x) { + auto loc = getLoc(); + auto lhs = gen(x.left()); + auto rhs = gen(x.right()); + return fir::runtime::genCharCompare(builder, loc, pred, lhs, rhs); + } + template + ExtValue gen(const Fortran::evaluate::Relational> &x) { + return createCompareOp(translateRelational(x.opr), x); + } + template + ExtValue gen(const Fortran::evaluate::Relational> &x) { + return createCompareCharOp(translateRelational(x.opr), x); + } + template + ExtValue + gen(const Fortran::evaluate::Relational< + Fortran::evaluate::Type> &x) { + return createCompareOp(translateFloatRelational(x.opr), x); + } + template + ExtValue gen(const Fortran::evaluate::Relational> &x) { + return createCompareOp(translateFloatRelational(x.opr), x); + } + + template + ExtValue gen(const Fortran::evaluate::Expr &x) { + return std::visit([&](const auto &e) { return gen(e); }, x.u); + } + ExtValue + gen(const Fortran::evaluate::Relational &r) { + return std::visit([&](const auto &x) { return gen(x); }, r.u); + } + template + ExtValue gen(const Fortran::evaluate::Designator &des) { + return std::visit([&](const auto &x) { return gen(x); }, des.u); + } + + /// Use archetypal ScalarExprLowering to lower this Expr. + template + ExtValue asScalar(const A &x) { + // add gen() + return ScalarExprLowering{getLoc(), converter, symMap, stmtCtx}.genval(x); + } + + template + ExtValue asScalarArray(const A &x) { + return ScalarArrayExprLowering{converter, symMap, expSpace, stmtCtx}.gen(x); + } + + mlir::Location getLoc() { return converter.getCurrentLocation(); } + + Fortran::lower::AbstractConverter &converter; + fir::FirOpBuilder &builder; + Fortran::lower::StatementContext &stmtCtx; + Fortran::lower::SymMap &symMap; + Fortran::lower::ExplicitIterSpace &expSpace; + ConstituentSemantics semant = ConstituentSemantics::RefTransparent; + mlir::Value elementalValue; + llvm::SmallVector reversePath; +}; +} // namespace + +//===----------------------------------------------------------------------===// +// +// Lowering of array expressions. +// +//===----------------------------------------------------------------------===// + +namespace { +class ArrayExprLowering { + using ExtValue = fir::ExtendedValue; + + /// An array is accessed with a vector of subscript values. In an aray + /// expression with a user-defined explicit iteration space, the vector may be + /// composed of both subscripts using the explicit iteration space and + /// implicit subscripts. The explicit subscripts may come before or after the + /// implicit subscripts in the vector as applied to a component path. + /// + /// For example, given a designator of rank 2, `a1(i,j)%a2%a3(k), `i` and `j` + /// could be pre-explicit, then two (rank of `a2`) impplicit values, and + /// finally `k` which could be a post-explicit access value. + enum class AccessKind { Implicit, PreExplicit, PostExplicit }; + + /// AccessValue is a (value, tag) pair used by an IterationSpace to keep track + /// of the access kind of values in the iteration space so they may be applied + /// in a continuation properly. + struct AccessValue { + explicit AccessValue(AccessKind k, mlir::Value v) : kind{k}, val{v} {} + AccessValue(mlir::Value v) : AccessValue(AccessKind::Implicit, v) {} + + mlir::Value value() const { return val; } + AccessKind access() const { return kind; } + + private: + AccessKind kind; + mlir::Value val; + }; + + struct IterationSpace { + IterationSpace() = default; + + template + explicit IterationSpace(mlir::Value inArg, mlir::Value outRes, + llvm::iterator_range range) + : inArg{inArg}, outRes{outRes}, indices{range.begin(), range.end()} {} + + explicit IterationSpace(const IterationSpace &from, + llvm::ArrayRef idxs) + : inArg(from.inArg), outRes(from.outRes), element(from.element), + indices(idxs.begin(), idxs.end()) {} + + bool empty() const { return indices.empty(); } + mlir::Value innerArgument() const { return inArg; } + mlir::Value outerResult() const { return outRes; } + llvm::SmallVector iterVec() const { + llvm::SmallVector result; + for (auto i : indices) + result.push_back(i.value()); + return result; + } + mlir::Value iterValue(std::size_t i) const { + assert(i < indices.size()); + return indices[i].value(); + } + + /// Set (rewrite) the Value at a given index. + void setIndexValue(std::size_t i, mlir::Value v) { + assert(i < indices.size()); + indices[i] = v; + } + + void setIndexValues(llvm::ArrayRef vals) { + indices.assign(vals.begin(), vals.end()); + } + + void insertIndexValue(std::size_t i, AccessValue av) { + assert(i <= indices.size()); + indices.insert(indices.begin() + i, av); + } + + void insertIndexValue(std::size_t i, mlir::Value v) { + insertIndexValue(i, AccessValue(AccessKind::Implicit, v)); + } + + /// Append an argument to the iteration space. Like prepended arguments, it + /// is assumed the appended arguments will be added in a reverse order. + void appendIndexValue(mlir::Value v) { + auto appendPoint = endImplicitIndex(); + insertIndexValue(appendPoint, AccessValue(AccessKind::PostExplicit, v)); + } + + /// Prepend an argument to the iteration space. Arguments are assumed to be + /// prepended in reverse order. + void prependIndexValue(mlir::Value v) { + insertIndexValue(0, AccessValue(AccessKind::PreExplicit, v)); + } + + /// Set the `element` value. This is the SSA value that corresponds to an + /// element of the resultant array value. + void setElement(ExtValue &&ele) { + assert(!fir::getBase(element) && "result element already set"); + element = ele; + } + + /// Get the value that will be merged into the resultant array. This is the + /// computed value that will be stored to the lhs of the assignment. + mlir::Value getElement() const { + assert(fir::getBase(element) && "element must be set"); + return fir::getBase(element); + } + ExtValue elementExv() const { return element; } + + /// Index of the first implicit access in indices. Returns the index + /// immediately after the last pre explicit index or 0. Returns 0 if there + /// are no indices in this iteration space. + size_t beginImplicitIndex() const { + const auto size = indices.size(); + std::remove_const_t result = 0; + while (result < size && + indices[result].access() == AccessKind::PreExplicit) + ++result; + return result; + } + + /// Index of element immediately after the last implicit access index. + /// Returns the index immediately before the first post explicit index or 0. + /// Returns 0 if there are no indices in this iteration space. + size_t endImplicitIndex() const { + auto result = indices.size(); + while (result > 0 && + indices[result - 1].access() == AccessKind::PostExplicit) + --result; + return result; + } + + /// In an explicit space, the context may include an implicit subspace. The + /// RHS of the assignment does not necessarily have rank and can be promoted + /// from a scalar to an array. In that case, the implicit subscripts must be + /// removed. + void removeImplicit() { + const auto size = indices.size(); + if (size == 0) + return; + llvm::SmallVector newIndices; + for (std::remove_const_t j = 0; j < size; ++j) + if (indices[j].access() != AccessKind::Implicit) + newIndices.push_back(indices[j]); + indices.swap(newIndices); + } + + private: + mlir::Value inArg; + mlir::Value outRes; + ExtValue element; + llvm::SmallVector indices; + }; + + /// Structure to keep track of lowered array operands in the + /// array expression. Useful to later deduce the shape of the + /// array expression. + struct ArrayOperand { + /// Array base (can be a fir.box). + mlir::Value memref; + /// ShapeOp, ShapeShiftOp or ShiftOp + mlir::Value shape; + /// SliceOp + mlir::Value slice; + }; + + /// Active iteration space. + using IterSpace = const IterationSpace &; + /// Current continuation. Function that will generate IR for a single + /// iteration of the pending iterative loop structure. + using CC = std::function; + /// Projection continuation. Function that will project one iteration space + /// into another. + using PC = std::function; + /// Loop bounds continuation. Function that will generate IR to compute loop + /// bounds in a future context. + using LBC = std::function()>; + using PBC = std::function, + llvm::SmallVector>()>; + using PPC = std::function; + using ArrayBaseTy = + std::variant; + + struct ComponentCollection { + ComponentCollection() : pc{[=](IterSpace s) { return s; }} {} + ComponentCollection(const ComponentCollection &) = delete; + ComponentCollection &operator=(const ComponentCollection &) = delete; + + llvm::SmallVector trips; + llvm::SmallVector components; + PC pc; + }; + +public: + //===--------------------------------------------------------------------===// + // Regular array assignment + //===--------------------------------------------------------------------===// + + /// Entry point for array assignments. Both the left-hand and right-hand sides + /// can either be ExtendedValue or evaluate::Expr. + template + static void lowerArrayAssignment(Fortran::lower::AbstractConverter &converter, + Fortran::lower::SymMap &symMap, + Fortran::lower::StatementContext &stmtCtx, + const TL &lhs, const TR &rhs) { + ArrayExprLowering ael{converter, stmtCtx, symMap, + ConstituentSemantics::CopyInCopyOut}; + ael.lowerArrayAssignment(lhs, rhs); + } + + template + void lowerArrayAssignment(const TL &lhs, const TR &rhs) { + auto loc = getLoc(); + /// Here the target subspace is not necessarily contiguous. The ArrayUpdate + /// continuation is implicitly returned in `ccStoreToDest` and the ArrayLoad + /// in `destination`. + PushSemantics(ConstituentSemantics::ProjectedCopyInCopyOut); + ccStoreToDest = genarr(lhs); + determineShapeOfDest(lhs); + semant = ConstituentSemantics::RefTransparent; + auto exv = lowerArrayExpression(rhs); + builder.create( + loc, destination, fir::getBase(exv), destination.memref(), + destination.slice(), destination.typeparams()); + } + + void lowerArrayAssignment( + fir::ArrayLoadOp lhs, + const Fortran::evaluate::Expr &rhs, + llvm::ArrayRef indices, + llvm::ArrayRef extents) { + auto loc = getLoc(); + destination = lhs; + auto lambda = [=](IterSpace iters) -> ExtValue { + auto innerArg = iters.innerArgument(); + auto resTy = adjustedArrayElementType(innerArg.getType()); + auto cast = adjustedArrayElement(loc, builder, iters.getElement(), + innerArg.getType()); + auto arrUpdate = builder.create( + loc, resTy, innerArg, cast, iters.iterVec(), + destination.typeparams()); + return abstractArrayExtValue(arrUpdate); + }; + auto pc = [=](IterSpace iters) { + IterationSpace newIters = iters; + for (auto i : llvm::reverse(indices)) + newIters.prependIndexValue(i); + return newIters; + }; + ccStoreToDest = [=](IterSpace iters) { return lambda(pc(iters)); }; + destShape.assign(extents.begin(), extents.end()); + semant = ConstituentSemantics::RefTransparent; + auto exv = lowerArrayExpression(rhs); + // The array_merge_store will be created by the caller. Finish the implicit + // loop nest here. + builder.create(getLoc(), fir::getBase(exv)); + } + + //===--------------------------------------------------------------------===// + // WHERE array assignment, FORALL assignment, and FORALL+WHERE array + // assignment + //===--------------------------------------------------------------------===// + + /// Entry point for array assignment when the iteration space is explicitly + /// defined (Fortran's FORALL) with or without masks, and/or the implied + /// iteration space involves masks (Fortran's WHERE). Both contexts (explicit + /// space and implicit space with masks) may be present. + static void lowerAnyMaskedArrayAssignment( + Fortran::lower::AbstractConverter &converter, + Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx, + const Fortran::evaluate::Expr &lhs, + const Fortran::evaluate::Expr &rhs, + Fortran::lower::ExplicitIterSpace &explicitSpace, + Fortran::lower::ImplicitIterSpace &implicitSpace) { + if (explicitSpace.isActive() && lhs.Rank() == 0) { + // Scalar assignment expression in a FORALL context. + ScalarArrayExprLowering sael(converter, symMap, explicitSpace, stmtCtx); + sael.assign(lhs, rhs); + return; + } + // Array assignment expression in a FORALL and/or WHERE context. + ArrayExprLowering ael(converter, stmtCtx, symMap, + ConstituentSemantics::CopyInCopyOut, &explicitSpace, + &implicitSpace); + ael.lowerArrayAssignment(lhs, rhs); + } + + //===--------------------------------------------------------------------===// + // Array assignment to allocatable array + //===--------------------------------------------------------------------===// + + /// Entry point for assignment to allocatable array. + static void lowerAllocatableArrayAssignment( + Fortran::lower::AbstractConverter &converter, + Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx, + const Fortran::evaluate::Expr &lhs, + const Fortran::evaluate::Expr &rhs, + Fortran::lower::ExplicitIterSpace &explicitSpace, + Fortran::lower::ImplicitIterSpace &implicitSpace) { + ArrayExprLowering ael(converter, stmtCtx, symMap, + ConstituentSemantics::CopyInCopyOut, &explicitSpace, + &implicitSpace); + ael.lowerAllocatableArrayAssignment(lhs, rhs); + } + + /// Assignment to allocatable array. + /// + /// The semantics are reverse that of a "regular" array assignment. The rhs + /// defines the iteration space of the computation and the lhs is + /// resized/reallocated to fit if necessary. + void lowerAllocatableArrayAssignment( + const Fortran::evaluate::Expr &lhs, + const Fortran::evaluate::Expr &rhs) { + // With assignment to allocatable, we want to lower the rhs first and use + // its shape to determine if we need to reallocate, etc. + auto loc = getLoc(); + // FIXME: If the lhs is in an explicit iteration space, the assignment may + // be to an array of allocatable arrays rather than a single allocatable + // array. + auto mutableBox = createMutableBox(loc, converter, lhs, symMap); + auto resultTy = converter.genType(rhs); + auto rhsCC = [&]() { + PushSemantics(ConstituentSemantics::RefTransparent); + return genarr(rhs); + }(); + if (!arrayOperands.empty()) + destShape = getShape(arrayOperands[0]); + + llvm::SmallVector lengthParams; + // Currently no safe way to gather length from rhs (at least for + // character, it cannot be taken from array_loads since it may be + // changed by concatenations). + if ((mutableBox.isCharacter() && !mutableBox.hasNonDeferredLenParams()) || + mutableBox.isDerivedWithLengthParameters()) + TODO(loc, "gather rhs length parameters in assignment to allocatable"); + + // The allocatable must take lower bounds from the expr if reallocated. + // An expr has lbounds only if it is an array symbol or component. + llvm::SmallVector lbounds; + // takeLboundsIfRealloc is only true iff the rhs is a single dataref. + const bool takeLboundsIfRealloc = + Fortran::evaluate::UnwrapWholeSymbolOrComponentDataRef(rhs); + if (takeLboundsIfRealloc && !arrayOperands.empty()) { + assert(arrayOperands.size() == 1 && + "lbounds can only come from one array"); + auto lbs = fir::factory::getOrigins(arrayOperands[0].shape); + lbounds.append(lbs.begin(), lbs.end()); + } + fir::factory::genReallocIfNeeded(builder, loc, mutableBox, lbounds, + destShape, lengthParams); + // Create ArrayLoad for the mutable box and save it into `destination`. + PushSemantics(ConstituentSemantics::ProjectedCopyInCopyOut); + ccStoreToDest = + genarr(fir::factory::genMutableBoxRead(builder, loc, mutableBox)); + // If the rhs is scalar, get shape from the allocatable ArrayLoad. + if (destShape.empty()) + destShape = getShape(destination); + // Finish lowering the loop nest. + assert(destination && "destination must have been set"); + auto exv = lowerArrayExpression(rhsCC, resultTy); + builder.create( + loc, destination, fir::getBase(exv), destination.memref(), + destination.slice(), destination.typeparams()); + } + + /// Entry point for when an array expression appears on the lhs of an + /// assignment. In the default case, the rhs is fully evaluated prior to any + /// of the results being written back to the lhs. (CopyInCopyOut semantics.) + static fir::ArrayLoadOp lowerArraySubspace( + Fortran::lower::AbstractConverter &converter, + Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx, + const Fortran::evaluate::Expr &expr) { + ArrayExprLowering ael{converter, stmtCtx, symMap, + ConstituentSemantics::CopyInCopyOut}; + return ael.lowerArraySubspace(expr); + } + + fir::ArrayLoadOp lowerArraySubspace( + const Fortran::evaluate::Expr &exp) { + return std::visit( + [&](const auto &e) { + auto f = genarr(e); + auto exv = f(IterationSpace{}); + if (auto *defOp = fir::getBase(exv).getDefiningOp()) + if (auto arrLd = mlir::dyn_cast(defOp)) + return arrLd; + fir::emitFatalError(getLoc(), "array must be loaded"); + }, + exp.u); + } + + /// Entry point for when an array expression appears in a context where the + /// result must be boxed. (BoxValue semantics.) + static ExtValue lowerBoxedArrayExpression( + Fortran::lower::AbstractConverter &converter, + Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx, + const Fortran::evaluate::Expr &expr) { + ArrayExprLowering ael{converter, stmtCtx, symMap, + ConstituentSemantics::BoxValue}; + return ael.lowerBoxedArrayExpr(expr); + } + + ExtValue lowerBoxedArrayExpr( + const Fortran::evaluate::Expr &exp) { + return std::visit( + [&](const auto &e) { + auto f = genarr(e); + auto exv = f(IterationSpace{}); + if (fir::getBase(exv).getType().template isa()) + return exv; + fir::emitFatalError(getLoc(), "array must be emboxed"); + }, + exp.u); + } + + /// Entry point into lowering an expression with rank. This entry point is for + /// lowering a rhs expression, for example. (RefTransparent semantics.) + static ExtValue lowerNewArrayExpression( + Fortran::lower::AbstractConverter &converter, + Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx, + const std::optional &shape, + const Fortran::evaluate::Expr &expr) { + ArrayExprLowering ael{converter, stmtCtx, symMap}; + if (shape.has_value()) + ael.determineShapeOfDest(*shape); + auto loopRes = ael.lowerArrayExpression(expr); + auto dest = ael.destination; + auto tempRes = dest.memref(); + auto &builder = converter.getFirOpBuilder(); + auto loc = converter.getCurrentLocation(); + builder.create(loc, dest, fir::getBase(loopRes), + tempRes, dest.slice(), + dest.typeparams()); + + auto arrTy = + fir::dyn_cast_ptrEleTy(tempRes.getType()).cast(); + if (auto charTy = + arrTy.getEleTy().template dyn_cast()) { + if (fir::characterWithDynamicLen(charTy)) + TODO(loc, "CHARACTER does not have constant LEN"); + auto len = builder.createIntegerConstant( + loc, builder.getCharacterLengthType(), charTy.getLen()); + return fir::CharArrayBoxValue(tempRes, len, dest.getExtents()); + } + return fir::ArrayBoxValue(tempRes, dest.getExtents()); + } + + static ExtValue lowerLazyArrayExpression( + Fortran::lower::AbstractConverter &converter, + Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx, + const Fortran::evaluate::Expr &expr, + mlir::Value var, mlir::Value shape) { + ArrayExprLowering ael{converter, stmtCtx, symMap}; + return ael.lowerLazyArrayExpression(expr, var, shape); + } + + ExtValue lowerLazyArrayExpression( + const Fortran::evaluate::Expr &expr, + mlir::Value var, mlir::Value shapeBuffer) { + auto loc = getLoc(); + // Once the loop extents have been computed, which may require being inside + // some explicit loops, lazily allocate the expression on the heap. + ccPrelude = [=](llvm::ArrayRef shape) { + auto load = builder.create(loc, var); + auto eleTy = fir::unwrapRefType(load.getType()); + auto unknown = fir::SequenceType::getUnknownExtent(); + fir::SequenceType::Shape extents(shape.size(), unknown); + auto seqTy = fir::SequenceType::get(extents, eleTy); + auto toTy = fir::HeapType::get(seqTy); + auto castTo = builder.createConvert(loc, toTy, load); + auto cmp = builder.genIsNull(loc, castTo); + auto shapeEleTy = + fir::unwrapRefType(fir::unwrapRefType(shapeBuffer.getType())); + auto shapeSeqTy = fir::SequenceType::get( + fir::SequenceType::ShapeRef{ + static_cast(shape.size())}, + shapeEleTy); + auto idxTy = builder.getIndexType(); + builder.genIfThen(loc, cmp) + .genThen([&]() { + auto mem = builder.create(loc, seqTy, ".lazy.mask", + llvm::None, shape); + auto castVar = builder.createConvert( + loc, builder.getRefType(mem.getType()), var); + builder.create(loc, mem, castVar); + auto shapeMem = builder.create( + loc, shapeSeqTy, ".lazy.mask.shape", llvm::None); + auto eleRefTy = builder.getRefType(shapeEleTy); + for (auto sh : llvm::enumerate(shape)) { + auto offset = + builder.createIntegerConstant(loc, idxTy, sh.index()); + auto ref = builder.create(loc, eleRefTy, + shapeMem, offset); + builder.create(loc, sh.value(), ref); + } + auto castBuffer = builder.createConvert( + loc, builder.getRefType(shapeMem.getType()), shapeBuffer); + builder.create(loc, shapeMem, castBuffer); + }) + .end(); + }; + // Create a dummy array_load before the loop. We're storing to a lazy + // temporary, so there will be no conflict and no copy-in. + ccLoadDest = [=](llvm::ArrayRef shape) -> fir::ArrayLoadOp { + auto load = builder.create(loc, var); + auto eleTy = fir::unwrapRefType(load.getType()); + auto unknown = fir::SequenceType::getUnknownExtent(); + fir::SequenceType::Shape extents(shape.size(), unknown); + auto seqTy = fir::SequenceType::get(extents, eleTy); + auto toTy = fir::HeapType::get(seqTy); + auto castTo = builder.createConvert(loc, toTy, load); + auto shapeOp = builder.genShape(loc, shape); + return builder.create( + loc, seqTy, castTo, shapeOp, /*slice=*/mlir::Value{}, llvm::None); + }; + // Custom lowering of the element store to deal with the extra indirection + // to the lazy allocated buffer. + ccStoreToDest = [=](IterSpace iters) { + auto load = builder.create(loc, var); + auto eleTy = fir::unwrapRefType(load.getType()); + auto unknown = fir::SequenceType::getUnknownExtent(); + fir::SequenceType::Shape extents(iters.iterVec().size(), unknown); + auto seqTy = fir::SequenceType::get(extents, eleTy); + auto toTy = fir::HeapType::get(seqTy); + auto castTo = builder.createConvert(loc, toTy, load); + auto shape = builder.genShape(loc, genIterationShape()); + auto indices = fir::factory::originateIndices( + loc, builder, castTo.getType(), shape, iters.iterVec()); + auto eleAddr = builder.create( + loc, builder.getRefType(eleTy), castTo, shape, + /*slice=*/mlir::Value{}, indices, destination.typeparams()); + auto eleVal = builder.createConvert(loc, eleTy, iters.getElement()); + builder.create(loc, eleVal, eleAddr); + return iters.innerArgument(); + }; + auto loopRes = lowerArrayExpression(expr); + auto unknown = fir::SequenceType::getUnknownExtent(); + fir::SequenceType::Shape extents(genIterationShape().size(), unknown); + auto load = builder.create(loc, var); + auto eleTy = fir::unwrapRefType(load.getType()); + auto seqTy = fir::SequenceType::get(extents, eleTy); + auto toTy = fir::HeapType::get(seqTy); + auto tempRes = builder.createConvert(loc, toTy, load); + builder.create( + loc, destination, fir::getBase(loopRes), tempRes, destination.slice(), + destination.typeparams()); + auto tempTy = fir::dyn_cast_ptrEleTy(tempRes.getType()); + assert(tempTy && tempTy.isa() && + "must be a reference to an array"); + auto ety = fir::unwrapSequenceType(tempTy); + if (auto charTy = ety.dyn_cast()) { + if (fir::characterWithDynamicLen(charTy)) + TODO(loc, "CHARACTER does not have constant LEN"); + auto len = builder.createIntegerConstant( + loc, builder.getCharacterLengthType(), charTy.getLen()); + return fir::CharArrayBoxValue(tempRes, len, destination.getExtents()); + } + return fir::ArrayBoxValue(tempRes, destination.getExtents()); + } + + void determineShapeOfDest(const fir::ExtendedValue &lhs) { + destShape = fir::factory::getExtents(builder, getLoc(), lhs); + } + + void determineShapeOfDest( + const Fortran::evaluate::Expr &lhs) { + if (auto shape = + Fortran::evaluate::GetShape(converter.getFoldingContext(), lhs)) + determineShapeOfDest(*shape); + } + + /// Returns true iff the Ev::Shape is constant. + static bool evalShapeIsConstant(const Fortran::evaluate::Shape &shape) { + for (const auto &s : shape) + if (!s || !Fortran::evaluate::IsConstantExpr(*s)) + return false; + return true; + } + + /// Convert an Ev::Shape to IR values. + void convertFEShape(const Fortran::evaluate::Shape &shape, + llvm::SmallVectorImpl &result) { + if (evalShapeIsConstant(shape)) { + auto idxTy = builder.getIndexType(); + auto loc = getLoc(); + for (const auto &s : shape) + result.emplace_back(builder.createConvert( + loc, idxTy, convertOptExtentExpr(converter, stmtCtx, s))); + } + } + + /// Convert the shape computed by the front end if it is constant. Modifies + /// `destShape` when successful. + void determineShapeOfDest(const Fortran::evaluate::Shape &shape) { + assert(destShape.empty()); + convertFEShape(shape, destShape); + } + + /// CHARACTER and derived type elements are treated as memory references. The + /// numeric types are treated as values. + static mlir::Type adjustedArraySubtype(mlir::Type ty, + mlir::ValueRange indices) { + auto pathTy = fir::applyPathToType(ty, indices); + assert(pathTy && "indices failed to apply to type"); + return adjustedArrayElementType(pathTy); + } + + ExtValue lowerArrayExpression( + const Fortran::evaluate::Expr &exp) { + auto resTy = converter.genType(exp); + return std::visit( + [&](const auto &e) { return lowerArrayExpression(genarr(e), resTy); }, + exp.u); + } + ExtValue lowerArrayExpression(const ExtValue &exv) { + assert(!explicitSpace); + auto resTy = fir::unwrapPassByRefType(fir::getBase(exv).getType()); + return lowerArrayExpression(genarr(exv), resTy); + } + + /// For an elemental array expression. + /// 1. Lower the scalars and array loads. + /// 2. Create the iteration space. + /// 3. Create the element-by-element computation in the loop. + /// 4. Return the resulting array value. + /// If no destination was set in the array context, a temporary of + /// \p resultTy will be created to hold the evaluated expression. + /// Otherwise, \p resultTy is ignored and the expression is evaluated + /// in the destination. \p f is a continuation built from an + /// evaluate::Expr or an ExtendedValue. + ExtValue lowerArrayExpression(CC f, mlir::Type resultTy) { + auto loc = getLoc(); + auto [iterSpace, insPt] = genIterSpace(resultTy); + auto innerArg = iterSpace.innerArgument(); + auto exv = f(iterSpace); + mlir::Value upd; + if (ccStoreToDest.hasValue()) { + iterSpace.setElement(std::move(exv)); + upd = fir::getBase(ccStoreToDest.getValue()(iterSpace)); + } else { + auto resTy = adjustedArrayElementType(innerArg.getType()); + auto element = adjustedArrayElement(loc, builder, fir::getBase(exv), + innerArg.getType()); + upd = builder.create(loc, resTy, innerArg, element, + iterSpace.iterVec(), + destination.typeparams()); + } + builder.create(loc, upd); + builder.restoreInsertionPoint(insPt); + return abstractArrayExtValue(iterSpace.outerResult()); + } + + static void lowerArrayElementalSubroutine( + Fortran::lower::AbstractConverter &converter, + Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx, + const Fortran::evaluate::Expr &call) { + ArrayExprLowering ael(converter, stmtCtx, symMap, + ConstituentSemantics::RefTransparent); + ael.lowerArrayElementalSubroutine(call); + } + + // ! Not for user defined assignment elemental subroutine. + void lowerArrayElementalSubroutine( + const Fortran::evaluate::Expr &call) { + auto f = genarr(call); + auto shape = genIterationShape(); + auto [iterSpace, insPt] = genImplicitLoops(shape, /*innerArg=*/{}); + f(iterSpace); + builder.restoreInsertionPoint(insPt); + } + + /// Compute the shape of a slice. + llvm::SmallVector computeSliceShape(mlir::Value slice) { + llvm::SmallVector slicedShape; + auto slOp = mlir::cast(slice.getDefiningOp()); + auto triples = slOp.triples(); + auto idxTy = builder.getIndexType(); + auto loc = getLoc(); + auto zero = builder.createIntegerConstant(loc, idxTy, 0); + for (unsigned i = 0, end = triples.size(); i < end; i += 3) { + if (!mlir::isa_and_nonnull( + triples[i + 1].getDefiningOp())) { + // (..., lb:ub:step, ...) case: extent = max((ub-lb+step)/step, 0) + // See Fortran 2018 9.5.3.3.2 section for more details. + auto lb = builder.createConvert(loc, idxTy, triples[i]); + auto ub = builder.createConvert(loc, idxTy, triples[i + 1]); + auto step = builder.createConvert(loc, idxTy, triples[i + 2]); + auto diff = builder.create(loc, ub, lb); + auto add = builder.create(loc, diff, step); + auto div = builder.create(loc, add, step); + auto cmp = builder.create(loc, mlir::CmpIPredicate::sgt, + div, zero); + slicedShape.emplace_back( + builder.create(loc, cmp, div, zero)); + } else { + // do nothing. `..., i, ...` case, so dimension is dropped. + } + } + return slicedShape; + } + + /// Get the shape from an ArrayOperand. The shape of the array is adjusted if + /// the array was sliced. + llvm::SmallVector getShape(ArrayOperand array) { + if (array.slice) + return computeSliceShape(array.slice); + if (array.memref.getType().isa()) + return fir::factory::readExtents(builder, getLoc(), + fir::BoxValue{array.memref}); + auto extents = fir::factory::getExtents(array.shape); + return {extents.begin(), extents.end()}; + } + + /// Get the shape from an ArrayLoad. + llvm::SmallVector getShape(fir::ArrayLoadOp arrayLoad) { + return getShape( + ArrayOperand{arrayLoad.memref(), arrayLoad.shape(), arrayLoad.slice()}); + } + + /// Generate the shape of the iteration space over the array expression. The + /// iteration space may be implicit, explicit, or both. If it is implied it is + /// based on the destination and operand array loads, or an optional + /// Fortran::evaluate::Shape from the front end. If the shape is explicit, + /// this returns any implicit shape component, if it exists. + llvm::SmallVector genIterationShape() { + // Use the precomputed destination shape. + if (!destShape.empty()) + return destShape; + // Otherwise, use the destination's shape. + if (destination) + return getShape(destination); + // Otherwise, use the first ArrayLoad operand shape. + if (!arrayOperands.empty()) + return getShape(arrayOperands[0]); + fir::emitFatalError(getLoc(), + "failed to compute the array expression shape"); + } + + bool explicitSpaceIsActive() const { + return explicitSpace && explicitSpace->isActive(); + } + + bool implicitSpaceHasMasks() const { + return implicitSpace && !implicitSpace->empty(); + } + + void addMaskRebind(Fortran::lower::FrontEndExpr e, mlir::Value var, + mlir::Value shapeBuffer, ExtValue tmp) { + auto loc = getLoc(); + auto unknown = fir::SequenceType::getUnknownExtent(); + auto size = tmp.rank(); + fir::SequenceType::Shape extents(size, unknown); + auto *implicit = implicitSpace; + // After this statement is completed, rebind the mask expression to some + // code that loads the mask result from the variable that was initialized + // lazily. + explicitSpace->attachLoopCleanup([=](fir::FirOpBuilder &builder) { + // Do not use `this` in this lambda. + auto load = builder.create(loc, var); + auto eleTy = fir::unwrapRefType(load.getType()); + auto seqTy = fir::SequenceType::get(extents, eleTy); + auto toTy = fir::HeapType::get(seqTy); + auto base = builder.createConvert(loc, toTy, load); + llvm::SmallVector shapeVec; + auto idxTy = builder.getIndexType(); + auto refIdxTy = builder.getRefType(idxTy); + auto shEleTy = + fir::unwrapRefType(fir::unwrapRefType(shapeBuffer.getType())); + auto buffTy = builder.getRefType(fir::SequenceType::get( + fir::SequenceType::ShapeRef{ + static_cast(size)}, + shEleTy)); + auto buffer = builder.createConvert(loc, buffTy, shapeBuffer); + for (std::size_t i = 0; i < size; ++i) { + auto offset = builder.createIntegerConstant(loc, idxTy, i); + auto ele = + builder.create(loc, refIdxTy, buffer, offset); + shapeVec.push_back(builder.create(loc, ele)); + } + auto shape = builder.genShape(loc, shapeVec); + implicit->replaceBinding(e, base, shape); + }); + } + + void genMasks() { + auto loc = getLoc(); + // Lower the mask expressions, if any. + if (implicitSpaceHasMasks()) { + // Mask expressions are array expressions too. + for (const auto *e : implicitSpace->getExprs()) + if (e && !implicitSpace->isLowered(e)) { + if (auto var = implicitSpace->lookupMaskVariable(e)) { + // Allocate the mask buffer lazily. + auto tmp = Fortran::lower::createLazyArrayTempValue( + converter, *e, var, implicitSpace->lookupMaskShapeBuffer(e), + symMap, stmtCtx); + auto shape = builder.createShape(loc, tmp); + implicitSpace->bind(e, fir::getBase(tmp), shape); + if (explicitSpaceIsActive()) + addMaskRebind(e, var, implicitSpace->lookupMaskShapeBuffer(e), + tmp); + continue; + } + auto optShape = + Fortran::evaluate::GetShape(converter.getFoldingContext(), *e); + auto tmp = Fortran::lower::createSomeArrayTempValue( + converter, optShape, *e, symMap, stmtCtx); + auto shape = builder.createShape(loc, tmp); + implicitSpace->bind(e, fir::getBase(tmp), shape); + } + } + } + + std::pair + genImplicitLoops(mlir::ValueRange shape, mlir::Value innerArg) { + auto loc = getLoc(); + auto idxTy = builder.getIndexType(); + auto one = builder.createIntegerConstant(loc, idxTy, 1); + auto zero = builder.createIntegerConstant(loc, idxTy, 0); + llvm::SmallVector loopUppers; + + // Convert any implied shape to closed interval form. The fir.do_loop will + // run from 0 to `extent - 1` inclusive. + for (auto extent : shape) { + auto up = builder.create(loc, extent, one); + loopUppers.push_back(up); + } + + // Iteration space is created with outermost columns, innermost rows + llvm::SmallVector loops; + + const auto loopDepth = loopUppers.size(); + llvm::SmallVector ivars; + + for (auto i : llvm::enumerate(llvm::reverse(loopUppers))) { + if (i.index() > 0) { + assert(!loops.empty()); + builder.setInsertionPointToStart(loops.back().getBody()); + } + fir::DoLoopOp loop; + if (innerArg) { + loop = builder.create( + loc, zero, i.value(), one, getUnordered(), + /*finalCount=*/false, mlir::ValueRange{innerArg}); + innerArg = loop.getRegionIterArgs().front(); + } else { + loop = builder.create(loc, zero, i.value(), one, + getUnordered(), + /*finalCount=*/false); + } + ivars.push_back(loop.getInductionVar()); + loops.push_back(loop); + } + + if (innerArg) + for (std::remove_const_t i = 0; i + 1 < loopDepth; + ++i) { + builder.setInsertionPointToEnd(loops[i].getBody()); + builder.create(loc, loops[i + 1].getResult(0)); + } + + // Move insertion point to the start of the innermost loop in the nest. + builder.setInsertionPointToStart(loops.back().getBody()); + // Set `afterLoopNest` to just after the entire loop nest. + auto currPt = builder.saveInsertionPoint(); + builder.setInsertionPointAfter(loops[0]); + auto afterLoopNest = builder.saveInsertionPoint(); + builder.restoreInsertionPoint(currPt); + + // Put the implicit loop variables in row to column order to match FIR's + // Ops. (The loops were constructed from outermost column to innermost row.) + mlir::Value outerRes = loops[0].getResult(0); + return {IterationSpace(innerArg, outerRes, llvm::reverse(ivars)), + afterLoopNest}; + } + + /// Build the iteration space into which the array expression will be lowered. + /// The resultType is used to create a temporary, if needed. + std::pair + genIterSpace(mlir::Type resultType) { + auto loc = getLoc(); + + // Generate any mask expressions, as necessary. This is the compute step + // that creates the effective masks. See 10.2.3.2 in particular. + genMasks(); + + auto shape = genIterationShape(); + if (!destination) { + // Allocate storage for the result if it is not already provided. + destination = createAndLoadSomeArrayTemp(resultType, shape); + } + + // Generate the lazy mask allocation, if one was given. + if (ccPrelude.hasValue()) + ccPrelude.getValue()(shape); + + // Now handle the implicit loops. + auto [iters, afterLoopNest] = + genImplicitLoops(shape, destination.getResult()); + auto innerArg = iters.innerArgument(); + + // Generate the mask conditional structure, if there are masks. Unlike the + // explicit masks, which are interleaved, these mask expression appear in + // the innermost loop. + if (implicitSpaceHasMasks()) { + auto appendAsNeeded = [&](auto &&indices) { + llvm::SmallVector result; + result.append(indices.begin(), indices.end()); + return result; + }; + auto genCond = [&](Fortran::lower::MaskAddrAndShape &&mask, + IterSpace iters) { + auto tmp = mask.first; + auto shape = mask.second; + auto arrTy = fir::dyn_cast_ptrOrBoxEleTy(tmp.getType()); + auto eleTy = arrTy.cast().getEleTy(); + auto eleRefTy = builder.getRefType(eleTy); + auto i1Ty = builder.getI1Type(); + // Adjust indices for any shift of the origin of the array. + auto indexes = appendAsNeeded(fir::factory::originateIndices( + loc, builder, tmp.getType(), shape, iters.iterVec())); + auto addr = builder.create( + loc, eleRefTy, tmp, shape, /*slice=*/mlir::Value{}, indexes, + /*typeParams=*/llvm::None); + auto load = builder.create(loc, addr); + return builder.createConvert(loc, i1Ty, load); + }; + + // Handle the negated conditions. See 10.2.3.2p4 as to why this control + // structure is produced. + auto maskExprs = implicitSpace->getExprs(); + const auto size = maskExprs.size() - 1; + for (std::remove_const_t i = 0; i < size; ++i) + if (maskExprs[i]) { + auto ifOp = builder.create( + loc, mlir::TypeRange{innerArg.getType()}, + fir::getBase(genCond( + implicitSpace->getBindingWithShape(maskExprs[i]), iters)), + /*withElseRegion=*/true); + builder.create(loc, ifOp.getResult(0)); + builder.setInsertionPointToStart(&ifOp.thenRegion().front()); + builder.create(loc, innerArg); + builder.setInsertionPointToStart(&ifOp.elseRegion().front()); + } + + // The last condition is either non-negated or unconditionally negated. + if (maskExprs[size]) { + auto ifOp = builder.create( + loc, mlir::TypeRange{innerArg.getType()}, + fir::getBase(genCond( + implicitSpace->getBindingWithShape(maskExprs[size]), iters)), + /*withElseRegion=*/true); + builder.create(loc, ifOp.getResult(0)); + builder.setInsertionPointToStart(&ifOp.elseRegion().front()); + builder.create(loc, innerArg); + builder.setInsertionPointToStart(&ifOp.thenRegion().front()); + } else { + // do nothing + } + } + + // We're ready to lower the body (an assignment statement) for this context + // of loop nests at this point. + return {iters, afterLoopNest}; + } + + fir::ArrayLoadOp + createAndLoadSomeArrayTemp(mlir::Type type, + llvm::ArrayRef shape) { + if (ccLoadDest.hasValue()) + return ccLoadDest.getValue()(shape); + auto seqTy = type.dyn_cast(); + assert(seqTy && "must be an array"); + auto loc = getLoc(); + // TODO: Need to thread the length parameters here. For character, they may + // differ from the operands length (e.g concatenation). So the array loads + // type parameters are not enough. + if (auto charTy = seqTy.getEleTy().dyn_cast()) + if (charTy.hasDynamicLen()) + TODO(loc, "character array expression temp with dynamic length"); + if (auto recTy = seqTy.getEleTy().dyn_cast()) + if (recTy.getNumLenParams() > 0) + TODO(loc, "derived type array expression temp with length parameters"); + mlir::Value temp = seqTy.hasConstantShape() + ? builder.create(loc, type) + : builder.create( + loc, type, ".array.expr", llvm::None, shape); + auto *bldr = &converter.getFirOpBuilder(); + stmtCtx.attachCleanup([=]() { bldr->create(loc, temp); }); + auto shapeOp = genShapeOp(shape); + return builder.create( + loc, seqTy, temp, shapeOp, /*slice=*/mlir::Value{}, llvm::None); + } + + fir::ShapeOp genShapeOp(llvm::ArrayRef shape) { + auto loc = getLoc(); + auto idxTy = builder.getIndexType(); + llvm::SmallVector idxShape; + for (auto s : shape) + idxShape.push_back(builder.createConvert(loc, idxTy, s)); + auto shapeTy = fir::ShapeType::get(builder.getContext(), idxShape.size()); + return builder.create(loc, shapeTy, idxShape); + } + + //===--------------------------------------------------------------------===// + // Expression traversal and lowering. + //===--------------------------------------------------------------------===// + + // Lower the expression in a scalar context. + template + ExtValue asScalar(const A &x) { + return ScalarExprLowering{getLoc(), converter, symMap, stmtCtx}.genval(x); + } + template + ExtValue asScalarArray(const A &x) { + assert(explicitSpace); + return ScalarArrayExprLowering{converter, symMap, *explicitSpace, stmtCtx} + .lower(x); + } + + /// Lower the expression in a scalar context to a (boxed) reference. + template + ExtValue asScalarRef(const A &x) { + return ScalarExprLowering{getLoc(), converter, symMap, stmtCtx}.gen(x); + } + template + ExtValue asScalarArrayRef(const A &x) { + assert(explicitSpace); + return ScalarArrayExprLowering{converter, symMap, *explicitSpace, stmtCtx} + .lowerRef(x); + } + + // An expression with non-zero rank is an array expression. + template + bool isArray(const A &x) const { + return x.Rank() != 0; + } + + // A procedure reference to a Fortran elemental intrinsic procedure. + CC genElementalIntrinsicProcRef( + const Fortran::evaluate::ProcedureRef &procRef, + llvm::Optional retTy, + const Fortran::evaluate::SpecificIntrinsic &intrinsic) { + llvm::SmallVector operands; + llvm::StringRef name = intrinsic.name; + const auto *argLowering = + Fortran::lower::getIntrinsicArgumentLowering(name); + auto loc = getLoc(); + for (const auto &[arg, dummy] : + llvm::zip(procRef.arguments(), + intrinsic.characteristics.value().dummyArguments)) { + auto *expr = Fortran::evaluate::UnwrapExpr< + Fortran::evaluate::Expr>(arg); + if (!expr) { + // Absent optional. + operands.emplace_back([=](IterSpace) { return mlir::Value{}; }); + } else if (!argLowering) { + // No argument lowering instruction, lower by value. + PushSemantics(ConstituentSemantics::RefTransparent); + auto lambda = genarr(*expr); + operands.emplace_back([=](IterSpace iters) { return lambda(iters); }); + } else { + // Ad-hoc argument lowering handling. + switch (Fortran::lower::lowerIntrinsicArgumentAs(getLoc(), *argLowering, + dummy.name)) { + case Fortran::lower::LowerIntrinsicArgAs::Value: { + PushSemantics(ConstituentSemantics::RefTransparent); + auto lambda = genarr(*expr); + operands.emplace_back([=](IterSpace iters) { return lambda(iters); }); + } break; + case Fortran::lower::LowerIntrinsicArgAs::Addr: { + // Note: assume does not have Fortran VALUE attribute semantics. + PushSemantics(ConstituentSemantics::RefOpaque); + auto lambda = genarr(*expr); + operands.emplace_back([=](IterSpace iters) { return lambda(iters); }); + } break; + case Fortran::lower::LowerIntrinsicArgAs::Box: { + PushSemantics(ConstituentSemantics::RefOpaque); + auto lambda = genarr(*expr); + operands.emplace_back([=](IterSpace iters) { + return builder.createBox(loc, lambda(iters)); + }); + } break; + case Fortran::lower::LowerIntrinsicArgAs::Inquired: + TODO(loc, "intrinsic function with inquired argument"); + break; + } + } + } + + // Let the intrinsic library lower the intrinsic procedure call + return [=](IterSpace iters) { + llvm::SmallVector args; + for (const auto &cc : operands) + args.push_back(cc(iters)); + return Fortran::lower::genIntrinsicCall(builder, loc, name, retTy, args, + stmtCtx); + }; + } + + // A procedure reference to a user-defined elemental procedure. + CC genElementalUserDefinedProcRef( + const Fortran::evaluate::ProcedureRef &procRef, + llvm::Optional retTy) { + using PassBy = Fortran::lower::CallerInterface::PassEntityBy; + + // 10.1.4 p5. Impure elemental procedures must be called in element order. + if (const auto *procSym = procRef.proc().GetSymbol()) + if (!Fortran::semantics::IsPureProcedure(*procSym)) + setUnordered(false); + + Fortran::lower::CallerInterface caller(procRef, converter); + llvm::SmallVector operands; + operands.reserve(caller.getPassedArguments().size()); + auto loc = getLoc(); + auto callSiteType = caller.genFunctionType(); + for (const auto &arg : caller.getPassedArguments()) { + // 15.8.3 p1. Elemental procedure with intent(out)/intent(inout) + // arguments must be called in element order. + if (arg.mayBeModifiedByCall()) + setUnordered(false); + const auto *actual = arg.entity; + auto argTy = callSiteType.getInput(arg.firArgument); + if (!actual) { + // Optional dummy argument for which there is no actual argument. + auto absent = builder.create(loc, argTy); + operands.emplace_back([=](IterSpace) { return absent; }); + continue; + } + const auto *expr = actual->UnwrapExpr(); + if (!expr) + TODO(loc, "assumed type actual argument lowering"); + + LLVM_DEBUG(expr->AsFortran(llvm::dbgs() + << "argument: " << arg.firArgument << " = [") + << "]\n"); + switch (arg.passBy) { + case PassBy::Value: { + // True pass-by-value semantics. + PushSemantics(ConstituentSemantics::RefTransparent); + operands.emplace_back(genarr(*expr)); + } break; + case PassBy::BaseAddressValueAttribute: { + // VALUE attribute or pass-by-reference to a copy semantics. (byval*) + if (isArray(*expr)) { + PushSemantics(ConstituentSemantics::ByValueArg); + operands.emplace_back(genarr(*expr)); + } else { + // Store scalar value in a temp to fulfill VALUE attribute. + auto val = fir::getBase(asScalar(*expr)); + auto temp = builder.createTemporary( + loc, val.getType(), + llvm::ArrayRef{ + Fortran::lower::getAdaptToByRefAttr(builder)}); + builder.create(loc, val, temp); + operands.emplace_back( + [=](IterSpace iters) -> ExtValue { return temp; }); + } + } break; + case PassBy::BaseAddress: { + if (isArray(*expr)) { + PushSemantics(ConstituentSemantics::RefOpaque); + operands.emplace_back(genarr(*expr)); + } else { + auto exv = asScalarRef(*expr); + operands.emplace_back([=](IterSpace iters) { return exv; }); + } + } break; + case PassBy::CharBoxValueAttribute: { + if (isArray(*expr)) { + PushSemantics(ConstituentSemantics::RefOpaque); + auto lambda = genarr(*expr); + operands.emplace_back([=](IterSpace iters) { + return fir::factory::CharacterExprHelper{builder, loc} + .createTempFrom(lambda(iters)); + }); + } else { + fir::factory::CharacterExprHelper helper(builder, loc); + auto argVal = helper.createTempFrom(asScalarRef(*expr)); + operands.emplace_back( + [=](IterSpace iters) -> ExtValue { return argVal; }); + } + } break; + case PassBy::BoxChar: { + PushSemantics(ConstituentSemantics::RefOpaque); + operands.emplace_back(genarr(*expr)); + } break; + case PassBy::AddressAndLength: + // PassBy::AddressAndLength is only used for character results. Results + // are not handled here. + fir::emitFatalError( + loc, "unexpected PassBy::AddressAndLength in elemental call"); + break; + case PassBy::Box: + case PassBy::MutableBox: + // See C15100 and C15101 + fir::emitFatalError(loc, "cannot be POINTER, ALLOCATABLE"); + } + } + + if (caller.getIfIndirectCallSymbol()) + fir::emitFatalError(loc, "cannot be indirect call"); + + // The lambda is mutable so that `caller` copy can be modified inside it. + return + [=, caller = std::move(caller)](IterSpace iters) mutable -> ExtValue { + for (const auto &[cc, argIface] : + llvm::zip(operands, caller.getPassedArguments())) { + auto exv = cc(iters); + auto arg = exv.match( + [&](const fir::CharBoxValue &cb) -> mlir::Value { + return fir::factory::CharacterExprHelper{builder, loc} + .createEmbox(cb); + }, + [&](const auto &) { return fir::getBase(exv); }); + caller.placeInput(argIface, arg); + } + return ScalarExprLowering{loc, converter, symMap, stmtCtx} + .genCallOpAndResult(caller, callSiteType, retTy); + }; + } + + /// Generate a procedure reference. + CC genProcRef(const Fortran::evaluate::ProcedureRef &procRef, + llvm::Optional retTy) { + auto loc = getLoc(); + if (procRef.IsElemental()) { + if (const auto *intrin = procRef.proc().GetSpecificIntrinsic()) { + // All elemental intrinsic functions are pure and cannot modify their + // arguments. The only elemental subroutine, MVBITS has an Intent(inout) + // argument. So for this last one, loops must be in element order + // according to 15.8.3 p1. + if (!retTy) + setUnordered(false); + + // Elemental intrinsic call. + // The intrinsic procedure is called once per element of the array. + return genElementalIntrinsicProcRef(procRef, retTy, *intrin); + } + if (ScalarExprLowering::isStatementFunctionCall(procRef)) + fir::emitFatalError(loc, "statement function cannot be elemental"); + + // Elemental call. + // The procedure is called once per element of the array argument(s). + return genElementalUserDefinedProcRef(procRef, retTy); + } + + // Transformational call. + // The procedure is called once and produces a value of rank > 0. + if (const auto *intrinsic = procRef.proc().GetSpecificIntrinsic()) { + auto resultBox = + ScalarExprLowering{loc, converter, symMap, stmtCtx}.genIntrinsicRef( + procRef, *intrinsic, retTy); + if (explicitSpaceIsActive() && procRef.Rank() == 0) { + // Elide any implicit loop iters. + return [=](IterSpace) { return resultBox; }; + } + return genarr(resultBox); + } + + // In the default case, the call can be hoisted out of the loop nest. Apply + // the iterations to the result, which may be an array value. + auto resultBox = + ScalarExprLowering{loc, converter, symMap, stmtCtx}.genProcedureRef( + procRef, retTy); + if (explicitSpaceIsActive() && procRef.Rank() == 0) { + // Elide any implicit loop iters. + return [=](IterSpace) { return resultBox; }; + } + return genarr(resultBox); + } + + CC genarr(const Fortran::evaluate::ProcedureDesignator &) { + TODO(getLoc(), "procedure designator"); + } + CC genarr(const Fortran::evaluate::ProcedureRef &x) { + if (x.hasAlternateReturns()) + fir::emitFatalError(getLoc(), + "array procedure reference with alt-return"); + return genProcRef(x, llvm::None); + } + template + CC genscl(const A &x) { + auto result = asScalar(x); + return [=](IterSpace) { return result; }; + } + template + CC gensclarr(const A &x) { + auto result = asScalarArray(x); + return [=](IterSpace) { return result; }; + } + template >> + CC genarr(const A &x) { + return genscl(x); + } + + template + CC genarr(const Fortran::evaluate::Expr &x) { + if (isArray(x) || explicitSpaceIsActive() || + isElementalProcWithArrayArgs(x)) + return std::visit([&](const auto &e) { return genarr(e); }, x.u); + return genscl(x); + } + + // Converting a value of memory bound type requires creating a temp and + // copying the value. + static ExtValue convertAdjustedType(fir::FirOpBuilder &builder, + mlir::Location loc, mlir::Type toType, + const ExtValue &exv) { + auto lenFromBufferType = [&](mlir::Type ty) { + return builder.create( + loc, fir::dyn_cast_ptrEleTy(ty).cast().getLen()); + }; + return exv.match( + [&](const fir::CharBoxValue &cb) -> ExtValue { + auto typeParams = fir::getTypeParams(exv); + auto len = typeParams.size() > 0 + ? typeParams[0] + : lenFromBufferType(cb.getBuffer().getType()); + auto mem = + builder.create(loc, toType, mlir::ValueRange{len}); + fir::CharBoxValue result(mem, len); + fir::factory::CharacterExprHelper{builder, loc}.createAssign( + ExtValue{result}, exv); + return result; + }, + [&](const auto &) -> ExtValue { + fir::emitFatalError(loc, "convert on adjusted extended value"); + }); + } + template + CC genarr(const Fortran::evaluate::Convert, + TC2> &x) { + auto loc = getLoc(); + auto lambda = genarr(x.left()); + auto ty = converter.genType(TC1, KIND); + return [=](IterSpace iters) -> ExtValue { + auto exv = lambda(iters); + auto val = fir::getBase(exv); + if (elementTypeWasAdjusted(val.getType())) + return convertAdjustedType(builder, loc, ty, exv); + return builder.createConvert(loc, ty, val); + }; + } + + template + CC genarr(const Fortran::evaluate::ComplexComponent &x) { + auto loc = getLoc(); + auto lambda = genarr(x.left()); + auto isImagPart = x.isImaginaryPart; + return [=](IterSpace iters) -> ExtValue { + auto lhs = fir::getBase(lambda(iters)); + return fir::factory::ComplexExprHelper{builder, loc}.extractComplexPart( + lhs, isImagPart); + }; + } + template + CC genarr( + const Fortran::evaluate::Parentheses> + &x) { + auto loc = getLoc(); + auto f = genarr(x.left()); + return [=](IterSpace iters) -> ExtValue { + auto val = f(iters); + auto base = fir::getBase(val); + auto newBase = + builder.create(loc, base.getType(), base); + return fir::substBase(val, newBase); + }; + } + template + CC genarr(const Fortran::evaluate::Negate> &x) { + auto loc = getLoc(); + auto f = genarr(x.left()); + return [=](IterSpace iters) -> ExtValue { + auto val = fir::getBase(f(iters)); + auto ty = converter.genType(Fortran::common::TypeCategory::Integer, KIND); + auto zero = builder.createIntegerConstant(loc, ty, 0); + return builder.create(loc, zero, val); + }; + } + template + CC genarr(const Fortran::evaluate::Negate> &x) { + auto loc = getLoc(); + auto f = genarr(x.left()); + return [=](IterSpace iters) -> ExtValue { + return builder.create(loc, fir::getBase(f(iters))); + }; + } + template + CC genarr(const Fortran::evaluate::Negate> &x) { + auto loc = getLoc(); + auto f = genarr(x.left()); + return [=](IterSpace iters) -> ExtValue { + return builder.create(loc, fir::getBase(f(iters))); + }; + } + + //===--------------------------------------------------------------------===// + // Binary elemental ops + //===--------------------------------------------------------------------===// + + template + CC createBinaryOp(const A &evEx) { + auto loc = getLoc(); + auto lambda = genarr(evEx.left()); + auto rf = genarr(evEx.right()); + return [=](IterSpace iters) -> ExtValue { + auto left = fir::getBase(lambda(iters)); + auto right = fir::getBase(rf(iters)); + return builder.create(loc, left, right); + }; + } + +#undef GENBIN +#define GENBIN(GenBinEvOp, GenBinTyCat, GenBinFirOp) \ + template \ + CC genarr(const Fortran::evaluate::GenBinEvOp> &x) { \ + return createBinaryOp(x); \ + } + + GENBIN(Add, Integer, mlir::AddIOp) + GENBIN(Add, Real, mlir::AddFOp) + GENBIN(Add, Complex, fir::AddcOp) + GENBIN(Subtract, Integer, mlir::SubIOp) + GENBIN(Subtract, Real, mlir::SubFOp) + GENBIN(Subtract, Complex, fir::SubcOp) + GENBIN(Multiply, Integer, mlir::MulIOp) + GENBIN(Multiply, Real, mlir::MulFOp) + GENBIN(Multiply, Complex, fir::MulcOp) + GENBIN(Divide, Integer, mlir::SignedDivIOp) + GENBIN(Divide, Real, mlir::DivFOp) + GENBIN(Divide, Complex, fir::DivcOp) + + template + CC genarr( + const Fortran::evaluate::Power> &x) { + auto loc = getLoc(); + auto ty = converter.genType(TC, KIND); + auto lf = genarr(x.left()); + auto rf = genarr(x.right()); + return [=](IterSpace iters) -> ExtValue { + auto lhs = fir::getBase(lf(iters)); + auto rhs = fir::getBase(rf(iters)); + return Fortran::lower::genPow(builder, loc, ty, lhs, rhs); + }; + } + template + CC genarr( + const Fortran::evaluate::Extremum> &x) { + auto loc = getLoc(); + auto lf = genarr(x.left()); + auto rf = genarr(x.right()); + switch (x.ordering) { + case Fortran::evaluate::Ordering::Greater: + return [=](IterSpace iters) -> ExtValue { + auto lhs = fir::getBase(lf(iters)); + auto rhs = fir::getBase(rf(iters)); + return Fortran::lower::genMax(builder, loc, + llvm::ArrayRef{lhs, rhs}); + }; + case Fortran::evaluate::Ordering::Less: + return [=](IterSpace iters) -> ExtValue { + auto lhs = fir::getBase(lf(iters)); + auto rhs = fir::getBase(rf(iters)); + return Fortran::lower::genMin(builder, loc, + llvm::ArrayRef{lhs, rhs}); + }; + case Fortran::evaluate::Ordering::Equal: + llvm_unreachable("Equal is not a valid ordering in this context"); + } + llvm_unreachable("unknown ordering"); + } + template + CC genarr( + const Fortran::evaluate::RealToIntPower> + &x) { + auto loc = getLoc(); + auto ty = converter.genType(TC, KIND); + auto lf = genarr(x.left()); + auto rf = genarr(x.right()); + return [=](IterSpace iters) { + auto lhs = fir::getBase(lf(iters)); + auto rhs = fir::getBase(rf(iters)); + return Fortran::lower::genPow(builder, loc, ty, lhs, rhs); + }; + } + template + CC genarr(const Fortran::evaluate::ComplexConstructor &x) { + auto loc = getLoc(); + auto lf = genarr(x.left()); + auto rf = genarr(x.right()); + return [=](IterSpace iters) -> ExtValue { + auto lhs = fir::getBase(lf(iters)); + auto rhs = fir::getBase(rf(iters)); + return fir::factory::ComplexExprHelper{builder, loc}.createComplex( + KIND, lhs, rhs); + }; + } + + /// Fortran's concatenation operator `//`. + template + CC genarr(const Fortran::evaluate::Concat &x) { + auto loc = getLoc(); + auto lf = genarr(x.left()); + auto rf = genarr(x.right()); + return [=](IterSpace iters) -> ExtValue { + auto lhs = lf(iters); + auto rhs = rf(iters); + auto *lchr = lhs.getCharBox(); + auto *rchr = rhs.getCharBox(); + if (lchr && rchr) { + return fir::factory::CharacterExprHelper{builder, loc} + .createConcatenate(*lchr, *rchr); + } + TODO(loc, "concat on unexpected extended values"); + return mlir::Value{}; + }; + } + + template + CC genarr(const Fortran::evaluate::SetLength &x) { + auto lf = genarr(x.left()); + auto rhs = fir::getBase(asScalar(x.right())); + return [=](IterSpace iters) -> ExtValue { + auto lhs = fir::getBase(lf(iters)); + return fir::CharBoxValue{lhs, rhs}; + }; + } + + template + CC genarr(const Fortran::evaluate::Constant &x) { + if (explicitSpaceIsActive() && x.Rank() == 0) + return gensclarr(x); + auto loc = getLoc(); + auto idxTy = builder.getIndexType(); + auto arrTy = converter.genType(toEvExpr(x)); + std::string globalName = Fortran::lower::mangle::mangleArrayLiteral(x); + auto global = builder.getNamedGlobal(globalName); + if (!global) { + global = builder.createGlobalConstant( + loc, arrTy, globalName, + [&](fir::FirOpBuilder &builder) { + Fortran::lower::StatementContext stmtCtx; + auto result = Fortran::lower::createSomeInitializerExpression( + loc, converter, toEvExpr(x), symMap, stmtCtx); + auto castTo = + builder.createConvert(loc, arrTy, fir::getBase(result)); + builder.create(loc, castTo); + }, + builder.createInternalLinkage()); + } + auto addr = builder.create(getLoc(), global.resultType(), + global.getSymbol()); + auto seqTy = global.getType().cast(); + llvm::SmallVector extents; + for (auto extent : seqTy.getShape()) + extents.push_back(builder.createIntegerConstant(loc, idxTy, extent)); + if (auto charTy = seqTy.getEleTy().dyn_cast()) { + auto len = builder.createIntegerConstant(loc, builder.getI64Type(), + charTy.getLen()); + return genarr(fir::CharArrayBoxValue{addr, len, extents}); + } + return genarr(fir::ArrayBoxValue{addr, extents}); + } + + //===--------------------------------------------------------------------===// + // A vector subscript expression may be wrapped with a cast to INTEGER*8. + // Get rid of it here so the vector can be loaded. Add it back when + // generating the elemental evaluation (inside the loop nest). + + static Fortran::evaluate::Expr + ignoreEvConvert(const Fortran::evaluate::Expr> &x) { + return std::visit([&](const auto &v) { return ignoreEvConvert(v); }, x.u); + } + template + static Fortran::evaluate::Expr ignoreEvConvert( + const Fortran::evaluate::Convert< + Fortran::evaluate::Type, + FROM> &x) { + return toEvExpr(x.left()); + } + template + static Fortran::evaluate::Expr + ignoreEvConvert(const A &x) { + return toEvExpr(x); + } + + //===--------------------------------------------------------------------===// + // Get the `Se::Symbol*` for the subscript expression, `x`. This symbol can + // be used to determine the lbound, ubound of the vector. + + template + static const Fortran::semantics::Symbol * + extractSubscriptSymbol(const Fortran::evaluate::Expr &x) { + return std::visit([&](const auto &v) { return extractSubscriptSymbol(v); }, + x.u); + } + template + static const Fortran::semantics::Symbol * + extractSubscriptSymbol(const Fortran::evaluate::Designator &x) { + return Fortran::evaluate::UnwrapWholeSymbolDataRef(x); + } + template + static const Fortran::semantics::Symbol *extractSubscriptSymbol(const A &x) { + return nullptr; + } + + //===--------------------------------------------------------------------===// + + /// Get the declared lower bound value of the array `x` in dimension `dim`. + /// The argument `one` must be an ssa-value for the constant 1. + mlir::Value getLBound(const ExtValue &x, unsigned dim, mlir::Value one) { + return fir::factory::readLowerBound(builder, getLoc(), x, dim, one); + } + + /// Get the declared upper bound value of the array `x` in dimension `dim`. + /// The argument `one` must be an ssa-value for the constant 1. + mlir::Value getUBound(const ExtValue &x, unsigned dim, mlir::Value one) { + auto loc = getLoc(); + auto lb = getLBound(x, dim, one); + auto extent = fir::factory::readExtent(builder, loc, x, dim); + auto add = builder.create(loc, lb, extent); + return builder.create(loc, add, one); + } + + /// Return the extent of the boxed array `x` in dimesion `dim`. + mlir::Value getExtent(const ExtValue &x, unsigned dim) { + return fir::factory::readExtent(builder, getLoc(), x, dim); + } + + // Build a components path for a component that is type Ev::ArrayRef. The base + // of `x` must be an Ev::Component, and that base must be a trailing array + // expression. The left-most ranked expression will not be part of a sliced + // path expression. + std::tuple + buildComponentsPathArrayRef(ComponentCollection &cmptData, + const Fortran::evaluate::ArrayRef &x) { + auto loc = getLoc(); + const auto &arrBase = x.base(); + assert(!arrBase.IsSymbol()); + const auto &cmpt = arrBase.GetComponent(); + assert(cmpt.base().Rank() > 0); + llvm::SmallVector subs; + // All subscripts must be present, complete, and cannot be vectors nor + // slice operations. + for (const auto &ss : x.subscript()) + std::visit( + Fortran::common::visitors{ + [&](const Fortran::evaluate::IndirectSubscriptIntegerExpr &ie) { + const auto &e = ie.value(); // get rid of bonus dereference + if (isArray(e)) + fir::emitFatalError(loc, + "multiple components along single path " + "generating array subexpressions"); + // Lower scalar index expression, append it to subs. + subs.push_back(fir::getBase(asScalar(e))); + }, + [&](const auto &) { + fir::emitFatalError(loc, + "multiple components along single path " + "generating array subexpressions"); + }}, + ss.u); + auto tup = buildComponentsPath(cmptData, cmpt); + cmptData.components.append(subs.begin(), subs.end()); + return tup; + } + + template + ExtValue genArrayBase(const A &base) { + ScalarExprLowering sel{getLoc(), converter, symMap, stmtCtx}; + return base.IsSymbol() ? sel.gen(base.GetFirstSymbol()) + : sel.gen(base.GetComponent()); + } + + /// When we have an array reference, the expressions specified in each + /// dimension may be slice operations (e.g. `i:j:k`), vectors, or simple + /// (loop-invarianet) scalar expressions. This returns the base entity, the + /// resulting type, and a continuation to adjust the default iteration space. + std::tuple + genSliceIndices(ComponentCollection &cmptData, + const Fortran::evaluate::ArrayRef &x) { + auto loc = getLoc(); + auto idxTy = builder.getIndexType(); + auto one = builder.createIntegerConstant(loc, idxTy, 1); + auto &trips = cmptData.trips; + auto base = x.base(); + auto arrExt = genArrayBase(base); + LLVM_DEBUG(llvm::dbgs() << "array: " << arrExt << '\n'); + auto &pc = cmptData.pc; + for (auto sub : llvm::enumerate(x.subscript())) { + std::visit( + Fortran::common::visitors{ + [&](const Fortran::evaluate::Triplet &t) { + // Generate a slice operation for the triplet. The first and + // second position of the triplet may be omitted, and the + // declared lbound and/or ubound expression values, + // respectively, should be used instead. + if (auto optLo = t.lower()) + trips.push_back(fir::getBase(asScalar(*optLo))); + else + trips.push_back(getLBound(arrExt, sub.index(), one)); + if (auto optUp = t.upper()) + trips.push_back(fir::getBase(asScalar(*optUp))); + else + trips.push_back(getUBound(arrExt, sub.index(), one)); + trips.push_back(fir::getBase(asScalar(t.stride()))); + }, + [&](const Fortran::evaluate::IndirectSubscriptIntegerExpr &ie) { + const auto &e = ie.value(); // get rid of bonus dereference + if (isArray(e)) { + // vector-subscript: Use the index values as read from a + // vector to determine the temporary array value. + // Note: 9.5.3.3.3(3) specifies undefined behavior for + // multiple updates to any specific array element through a + // vector subscript with replicated values. + assert(!isBoxValue() && + "fir.box cannot be created with vector subscripts"); + auto base = x.base(); + auto exv = genArrayBase(base); + auto arrExpr = ignoreEvConvert(e); + auto arrLoad = + lowerArraySubspace(converter, symMap, stmtCtx, arrExpr); + auto arrLd = arrLoad.getResult(); + auto eleTy = + arrLd.getType().cast().getEleTy(); + auto currentPC = pc; + auto dim = sub.index(); + auto lb = + fir::factory::readLowerBound(builder, loc, exv, dim, one); + auto arrLdTypeParams = arrLoad.typeparams(); + pc = [=](IterSpace iters) { + IterationSpace newIters = currentPC(iters); + auto iter = newIters.iterVec()[dim]; + auto resTy = adjustedArrayElementType(eleTy); + auto fetch = builder.create( + loc, resTy, arrLd, mlir::ValueRange{iter}, + arrLdTypeParams); + auto cast = builder.createConvert(loc, idxTy, fetch); + auto val = + builder.create(loc, idxTy, cast, lb); + newIters.setIndexValue(dim, val); + return newIters; + }; + // Create a slice with the vector size so that the shape + // of array reference is correctly computed in later phase, + // even though this is not a triplet. + auto vectorSubscriptShape = getShape(arrLoad); + assert(vectorSubscriptShape.size() == 1); + trips.push_back(one); + trips.push_back(vectorSubscriptShape[0]); + trips.push_back(one); + } else { + // A regular scalar index, which does not yield an array + // section. Use a degenerate slice operation `(e:undef:undef)` + // in this dimension as a placeholder. This does not + // necessarily change the rank of the original array, so the + // iteration space must also be extended to include this + // expression in this dimension to adjust to the array's + // declared rank. + auto base = x.base(); + auto exv = genArrayBase(base); + auto v = fir::getBase(asScalar(e)); + trips.push_back(v); + auto undef = builder.create(loc, idxTy); + trips.push_back(undef); + trips.push_back(undef); + auto currentPC = pc; + // Cast `e` to index type. + auto iv = builder.createConvert(loc, idxTy, v); + auto dim = sub.index(); + auto lb = + fir::factory::readLowerBound(builder, loc, exv, dim, one); + // Normalize `e` by subtracting the declared lbound. + mlir::Value ivAdj = + builder.create(loc, idxTy, iv, lb); + // Add lbound adjusted value of `e` to the iteration vector + // (except when creating a box because the iteration vector is + // empty). + if (!isBoxValue()) + pc = [=](IterSpace iters) { + IterationSpace newIters = currentPC(iters); + newIters.insertIndexValue(dim, ivAdj); + return newIters; + }; + } + }}, + sub.value().u); + } + auto ty = fir::dyn_cast_ptrOrBoxEleTy(fir::getBase(arrExt).getType()); + return {arrExt, ty}; + } + + static mlir::Type unwrapBoxEleTy(mlir::Type ty) { + if (auto boxTy = ty.dyn_cast()) { + ty = boxTy.getEleTy(); + if (auto refTy = fir::dyn_cast_ptrEleTy(ty)) + ty = refTy; + } + return ty; + } + llvm::SmallVector getShape(mlir::Type ty) { + llvm::SmallVector result; + ty = unwrapBoxEleTy(ty); + auto loc = getLoc(); + auto idxTy = builder.getIndexType(); + for (auto extent : ty.cast().getShape()) { + auto v = extent == fir::SequenceType::getUnknownExtent() + ? builder.create(loc, idxTy).getResult() + : builder.createIntegerConstant(loc, idxTy, extent); + result.push_back(v); + } + return result; + } + llvm::SmallVector + getShape(const Fortran::semantics::SymbolRef &x) { + if (x.get().Rank() == 0) + return {}; + return getFrontEndShape(x); + } + template + llvm::SmallVector getShape(const A &x) { + if (x.Rank() == 0) + return {}; + return getFrontEndShape(x); + } + template + llvm::SmallVector getFrontEndShape(const A &x) { + if (auto optShape = Fortran::evaluate::GetShape(x)) { + llvm::SmallVector result; + convertFEShape(*optShape, result); + return result; + } + return {}; + } + + /// Array reference with subscripts. If this has rank > 0, this is a form + /// of an array section (slice). + /// + /// There are two "slicing" primitives that may be applied on a dimension by + /// dimension basis: (1) triple notation and (2) vector addressing. Since + /// dimensions can be selectively sliced, some dimensions may contain + /// regular scalar expressions and those dimensions do not participate in + /// the array expression evaluation. + CC genarr(const Fortran::evaluate::ArrayRef &x) { + if (explicitSpaceIsActive() && x.Rank() == 0) + return gensclarr(x); + const auto &arrBase = x.base(); + if (!arrBase.IsSymbol()) { + // `x` is a component with rank. + const auto &cmpt = arrBase.GetComponent(); + if (cmpt.base().Rank() > 0) { + // `x` is right of the base/component giving rise to the ranked expr. + // In this case, the array in question is to the left of this + // component. This component is an intraobject slice. + ComponentCollection cmptData; + auto tup = buildComponentsPathArrayRef(cmptData, x); + auto lambda = genSlicePath(std::get(tup), cmptData.trips, + cmptData.components); + auto pc = cmptData.pc; + return [=](IterSpace iters) { return lambda(pc(iters)); }; + } + } + ComponentCollection cmptData; + auto tup = genSliceIndices(cmptData, x); + auto lambda = genSlicePath(std::get(tup), cmptData.trips, + cmptData.components); + auto pc = cmptData.pc; + return [=](IterSpace iters) { return lambda(pc(iters)); }; + } + + CC genarr(const Fortran::evaluate::NamedEntity &entity) { + if (entity.IsSymbol()) + return genarr(Fortran::semantics::SymbolRef{entity.GetFirstSymbol()}); + return genarr(entity.GetComponent()); + } + + CC genarr(const Fortran::semantics::SymbolRef &sym) { + if (explicitSpaceIsActive() && sym.get().Rank() == 0) + return gensclarr(sym); + return genarr(asScalarRef(sym)); + } + CC genarr(const Fortran::semantics::Symbol &sym) { + return genarr(Fortran::semantics::SymbolRef{sym}); + } + + /// Build an ExtendedValue from a fir.array without actually + /// setting the actual extents and lengths. This is only to allow their + /// propagation as ExtendedValue without triggering verifier failures when + /// propagating character/arrays as unboxed values. Only the base of the + /// resulting ExtendedValue should be used, it is undefined to use the + /// length or extents of the extended value returned, + ExtValue abstractArrayExtValue(mlir::Value val) { + auto ty = val.getType(); + if (auto ety = fir::dyn_cast_ptrEleTy(ty)) + ty = ety; + auto idxTy = builder.getIndexType(); + auto loc = getLoc(); + auto seqTy = ty.cast(); + auto undef = builder.create(loc, idxTy); + llvm::SmallVector extents(seqTy.getDimension(), undef); + if (fir::isa_char(seqTy.getEleTy())) + return fir::CharArrayBoxValue(val, undef, extents); + return fir::ArrayBoxValue(val, extents); + } + + mlir::Value maybeGenStringCopy(mlir::Type toTy, mlir::Value fromVal) { + // FIXME: For now, just blindly insert a fir.convert, but that doesn't + // really capture the semantics properly. The string needs to be memmoved + // with truncation, padding, or neither. + if (fir::isa_char(toTy)) { + // assert(elementTypeWasAdjusted(fromVal.getType())); + return builder.createConvert(getLoc(), builder.getRefType(toTy), fromVal); + } + return fromVal; + } + mlir::Value tryUpdateConversions(mlir::Type toTy, mlir::Value fromVal) { + if (fir::isa_char(toTy)) + return maybeGenStringCopy(toTy, fromVal); + if (!fir::isa_ref_type(toTy) && !fir::isa_ref_type(fromVal.getType())) + return builder.createConvert(getLoc(), toTy, fromVal); + return fromVal; + } + + /// Base case of generating an array reference, + CC genarr(const ExtValue &extMemref) { + auto loc = getLoc(); + auto memref = fir::getBase(extMemref); + auto arrTy = fir::dyn_cast_ptrOrBoxEleTy(memref.getType()); + assert(arrTy.isa() && "memory ref must be an array"); + auto shape = builder.createShape(loc, extMemref); + mlir::Value slice; + if (inSlice) { + slice = builder.createSlice(loc, extMemref, sliceTriple, slicePath); + if (!slicePath.empty()) { + auto seqTy = arrTy.cast(); + auto eleTy = fir::applyPathToType(seqTy.getEleTy(), slicePath); + if (!eleTy) + fir::emitFatalError(loc, "slicing path is ill-formed"); + if (auto realTy = eleTy.dyn_cast()) + eleTy = Fortran::lower::convertReal(realTy.getContext(), + realTy.getFKind()); + + // create the type of the projected array. + arrTy = fir::SequenceType::get(seqTy.getShape(), eleTy); + LLVM_DEBUG(llvm::dbgs() + << "type of array projection from component slicing: " + << eleTy << ", " << arrTy << '\n'); + } + } + arrayOperands.push_back(ArrayOperand{memref, shape, slice}); + if (isBoxValue()) { + // Semantics are a reference to a boxed array. + // This case just requires that an embox operation be created to box the + // value. The value of the box is forwarded in the continuation. + auto boxTy = fir::BoxType::get(reduceRank(arrTy, slice)); + mlir::Value embox = + memref.getType().isa() + ? builder.create(loc, boxTy, memref, shape, slice) + .getResult() + : builder + .create(loc, boxTy, memref, shape, slice, + fir::getTypeParams(extMemref)) + .getResult(); + return [=](IterSpace) -> ExtValue { return fir::BoxValue(embox); }; + } + auto eleTy = arrTy.cast().getEleTy(); + if (isReferentiallyOpaque()) { + // Semantics are an opaque reference to an array. + // This case forwards a continuation that will generate the address + // arithmetic to the array element. No attempt to preserve the value at + // the address during the interpretation of Fortran statement is made. + auto refEleTy = builder.getRefType(eleTy); + return [=](IterSpace iters) -> ExtValue { + // ArrayCoorOp does not expect zero based indices. + auto indices = fir::factory::originateIndices( + loc, builder, memref.getType(), shape, iters.iterVec()); + mlir::Value coor = builder.create( + loc, refEleTy, memref, shape, slice, indices, + fir::getTypeParams(extMemref)); + return fir::factory::arraySectionElementToExtendedValue( + builder, loc, extMemref, coor, slice); + }; + } + auto arrLoad = builder.create( + loc, arrTy, memref, shape, slice, fir::getTypeParams(extMemref)); + auto arrLd = arrLoad.getResult(); + if (isProjectedCopyInCopyOut()) { + // Semantics are projected copy-in copy-out. + // The backing store of the destination of an array expression may be + // partially modified. These updates are recorded in FIR by forwarding a + // continuation that generates an `array_update` Op. The destination is + // always loaded at the beginning of the statement and merged at the + // end. + destination = arrLoad; + return [=](IterSpace iters) -> ExtValue { + auto innerArg = iters.innerArgument(); + auto resTy = innerArg.getType(); + auto eleTy = fir::applyPathToType(resTy, iters.iterVec()); + auto element = tryUpdateConversions(eleTy, iters.getElement()); + auto arrUpdate = builder.create( + loc, resTy, innerArg, element, iters.iterVec(), + destination.typeparams()); + return abstractArrayExtValue(arrUpdate); + }; + } + if (isCopyInCopyOut()) { + // Semantics are copy-in copy-out. + // The continuation simply forwards the result of the `array_load` Op, + // which is the value of the array as it was when loaded. All data + // references with rank > 0 in an array expression typically have + // copy-in copy-out semantics. + return [=](IterSpace) -> ExtValue { return arrLd; }; + } + auto arrLdTypeParams = arrLoad.typeparams(); + if (isValueAttribute()) { + // Semantics are value attribute. + // Here the continuation will `array_fetch` a value from an array and + // then store that value in a temporary. One can thus imitate pass by + // value even when the call is pass by reference. + return [=](IterSpace iters) -> ExtValue { + auto arrFetch = builder.create( + loc, adjustedArraySubtype(arrTy, iters.iterVec()), arrLd, + iters.iterVec(), arrLdTypeParams); + auto base = arrFetch.getResult(); + auto temp = builder.createTemporary( + loc, base.getType(), + llvm::ArrayRef{ + Fortran::lower::getAdaptToByRefAttr(builder)}); + builder.create(loc, base, temp); + return fir::factory::arraySectionElementToExtendedValue( + builder, loc, extMemref, temp, slice); + }; + } + // In the default case, the array reference forwards an `array_fetch` Op + // in the continuation. + return [=](IterSpace iters) -> ExtValue { + auto arrFetch = builder.create( + loc, adjustedArraySubtype(arrTy, iters.iterVec()), arrLd, + iters.iterVec(), arrLdTypeParams); + return fir::factory::arraySectionElementToExtendedValue( + builder, loc, extMemref, arrFetch, slice); + }; + } + + /// Reduce the rank of a array to be boxed based on the slice's operands. + static mlir::Type reduceRank(mlir::Type arrTy, mlir::Value slice) { + if (slice) { + auto slOp = mlir::dyn_cast(slice.getDefiningOp()); + assert(slOp); + auto seqTy = arrTy.dyn_cast(); + assert(seqTy); + auto triples = slOp.triples(); + fir::SequenceType::Shape shape; + // reduce the rank for each invariant dimension + for (unsigned i = 1, end = triples.size(); i < end; i += 3) + if (!mlir::isa_and_nonnull(triples[i].getDefiningOp())) + shape.push_back(fir::SequenceType::getUnknownExtent()); + return fir::SequenceType::get(shape, seqTy.getEleTy()); + } + // not sliced, so no change in rank + return arrTy; + } + + /// Lower a component path with rank or raise it from a scalar expression to + /// have array semantics. + /// Example: array%baz%qux%waldo + CC genarr(const Fortran::evaluate::Component &x) { + if (explicitSpaceIsActive() && x.Rank() == 0) + return gensclarr(x); + return genComponent(x); + } + CC genComponent(const Fortran::evaluate::Component &x) { + ComponentCollection cmptData; + auto tup = buildComponentsPath(cmptData, x); + auto lambda = genSlicePath(std::get(tup), cmptData.trips, + cmptData.components); + auto pc = cmptData.pc; + return [=](IterSpace iters) { return lambda(pc(iters)); }; + } + + /// The `Ev::Component` structure is tailmost down to head, so the expression + /// a%b%c will be presented as (component (dataref + /// (component (dataref (symbol 'a)) (symbol 'b))) (symbol 'c)). + std::tuple + buildComponentsPath(ComponentCollection &cmptData, + const Fortran::evaluate::Component &x) { + using RT = std::tuple; + auto loc = getLoc(); + auto dr = x.base(); + if (dr.Rank() == 0) { + auto exv = explicitSpaceIsActive() ? asScalarArrayRef(x) : asScalarRef(x); + return RT{exv, fir::getBase(exv).getType()}; + } + auto addComponent = [&](const ExtValue &exv, mlir::Type ty) { + assert(ty.isa()); + auto arrTy = ty.cast(); + auto name = toStringRef(x.GetLastSymbol().name()); + auto recTy = arrTy.getEleTy(); + auto eleTy = recTy.cast().getType(name); + auto fldTy = fir::FieldType::get(eleTy.getContext()); + cmptData.components.push_back(builder.create( + getLoc(), fldTy, name, recTy, fir::getTypeParams(exv))); + auto refOfTy = eleTy.isa() + ? eleTy + : fir::SequenceType::get(arrTy.getShape(), eleTy); + return RT{exv, builder.getRefType(refOfTy)}; + }; + return std::visit( + Fortran::common::visitors{ + [&](const Fortran::evaluate::Component &c) { + auto [exv, refTy] = buildComponentsPath(cmptData, c); + auto ty = fir::dyn_cast_ptrOrBoxEleTy(refTy); + return addComponent(exv, ty); + }, + [&](const Fortran::semantics::SymbolRef &y) { + auto exv = asScalarRef(y); + auto ty = + fir::dyn_cast_ptrOrBoxEleTy(fir::getBase(exv).getType()); + return addComponent(exv, ty); + }, + [&](const Fortran::evaluate::ArrayRef &r) -> RT { + auto arrBase = r.base(); + if (arrBase.Rank() > 0 && !arrBase.IsSymbol()) + if (const auto &cmpt = arrBase.GetComponent(); + cmpt.base().Rank() > 0) { + auto [exv, refTy] = buildComponentsPathArrayRef(cmptData, r); + auto ty = fir::dyn_cast_ptrOrBoxEleTy(refTy); + return addComponent(exv, ty); + } + auto [exv, ty] = genSliceIndices(cmptData, r); + return addComponent(exv, ty); + }, + [&](const Fortran::evaluate::CoarrayRef &r) -> RT { + TODO(loc, ""); + }}, + dr.u); + } + + /// Example: array%RE + CC genarr(const Fortran::evaluate::ComplexPart &x) { + auto loc = getLoc(); + auto i32Ty = builder.getI32Type(); // llvm's GEP requires i32 + auto offset = builder.createIntegerConstant( + loc, i32Ty, + x.part() == Fortran::evaluate::ComplexPart::Part::RE ? 0 : 1); + auto lambda = genSlicePath(x.complex(), {}, {offset}); + return [=](IterSpace iters) { return lambda(iters); }; + } + + template + CC genSlicePath(const A &x, mlir::ValueRange trips, mlir::ValueRange path) { + if (!sliceTriple.empty()) + fir::emitFatalError(getLoc(), "multiple slices"); + auto saveInSlice = inSlice; + inSlice = true; + auto sz = slicePath.size(); + sliceTriple.append(trips.begin(), trips.end()); + slicePath.append(path.begin(), path.end()); + auto result = genarr(x); + sliceTriple.clear(); + slicePath.resize(sz); + inSlice = saveInSlice; + return result; + } + + CC genarr(const Fortran::evaluate::CoarrayRef &) { + TODO(getLoc(), "coarray ref"); + } + + /// 9.4.1 Substrings + CC genarr(const Fortran::evaluate::Substring &x) { + auto loc = getLoc(); + auto pf = std::visit( + Fortran::common::visitors{ + [&](const Fortran::evaluate::DataRef &p) { return genarr(p); }, + [&](const Fortran::evaluate::StaticDataObject::Pointer &) -> CC { + fir::emitFatalError(loc, "substring of static array object"); + }}, + x.parent()); + // lower and upper *must* be scalars + llvm::SmallVector bounds = {fir::getBase(asScalar(x.lower()))}; + if (auto upper = x.upper()) + bounds.push_back(fir::getBase(asScalar(*upper))); + return [=](IterSpace iters) -> ExtValue { + auto base = pf(iters); + if (auto *chr = base.getCharBox()) + return fir::factory::CharacterExprHelper{builder, loc}.createSubstring( + *chr, bounds); + TODO(loc, "unhandled substring base type"); + return mlir::Value{}; + }; + } + + template + CC genarr( + const Fortran::evaluate::FunctionRef> + &x) { + return genProcRef(x, {converter.genType(TC, KIND)}); + } + + //===--------------------------------------------------------------------===// + // Array construction + //===--------------------------------------------------------------------===// + + // Lower the expr cases in an ac-value-list. + template + std::pair + genArrayCtorInitializer(const Fortran::evaluate::Expr &x, mlir::Type, + mlir::Value, mlir::Value, mlir::Value, + Fortran::lower::StatementContext &stmtCtx) { + if (isArray(x)) { + auto e = toEvExpr(x); + auto sh = Fortran::evaluate::GetShape(converter.getFoldingContext(), e); + return {lowerNewArrayExpression(converter, symMap, stmtCtx, sh, e), + /*needCopy=*/true}; + } + return {asScalar(x), /*needCopy=*/true}; + } + + /// Target agnostic computation of the size of an element in the array. + /// Returns the size in bytes with type `index` or a null Value if the element + /// size is not constant. + mlir::Value computeElementSize(mlir::Type eleTy, mlir::Type eleRefTy, + mlir::Type resRefTy) { + if (fir::hasDynamicSize(eleTy)) + return {}; + auto loc = getLoc(); + auto idxTy = builder.getIndexType(); + auto nullPtr = builder.createNullConstant(loc, resRefTy); + auto one = builder.createIntegerConstant(loc, idxTy, 1); + auto offset = builder.create(loc, eleRefTy, nullPtr, + mlir::ValueRange{one}); + return builder.createConvert(loc, idxTy, offset); + } + + /// Get the function signature of the LLVM memcpy intrinsic. + mlir::FunctionType memcpyType() { + return fir::factory::getLlvmMemcpy(builder).getType(); + } + + /// Create a call to the LLVM memcpy intrinsic. + void createCallMemcpy(llvm::ArrayRef args) { + auto loc = getLoc(); + auto memcpyFunc = fir::factory::getLlvmMemcpy(builder); + auto funcSymAttr = builder.getSymbolRefAttr(memcpyFunc.getName()); + auto funcTy = memcpyFunc.getType(); + builder.create(loc, funcTy.getResults(), funcSymAttr, args); + } + + // Construct code to check for a buffer overrun and realloc the buffer when + // space is depleted. This is done between each item in the ac-value-list. + mlir::Value growBuffer(mlir::Value mem, mlir::Value needed, + mlir::Value bufferSize, mlir::Value buffSize, + mlir::Value eleSz) { + auto loc = getLoc(); + auto reallocFunc = fir::factory::getRealloc(builder); + auto cond = builder.create(loc, mlir::CmpIPredicate::sle, + bufferSize, needed); + auto ifOp = builder.create(loc, mem.getType(), cond, + /*withElseRegion=*/true); + auto insPt = builder.saveInsertionPoint(); + builder.setInsertionPointToStart(&ifOp.thenRegion().front()); + // Not enough space, resize the buffer. + auto idxTy = builder.getIndexType(); + auto two = builder.createIntegerConstant(loc, idxTy, 2); + auto newSz = builder.create(loc, needed, two); + builder.create(loc, newSz, buffSize); + mlir::Value byteSz = builder.create(loc, newSz, eleSz); + auto funcSymAttr = builder.getSymbolRefAttr(reallocFunc.getName()); + auto funcTy = reallocFunc.getType(); + auto newMem = builder.create( + loc, funcTy.getResults(), funcSymAttr, + llvm::ArrayRef{ + builder.createConvert(loc, funcTy.getInputs()[0], mem), + builder.createConvert(loc, funcTy.getInputs()[1], byteSz)}); + auto castNewMem = + builder.createConvert(loc, mem.getType(), newMem.getResult(0)); + builder.create(loc, castNewMem); + builder.setInsertionPointToStart(&ifOp.elseRegion().front()); + // Otherwise, just forward the buffer. + builder.create(loc, mem); + builder.restoreInsertionPoint(insPt); + return ifOp.getResult(0); + } + + /// Copy the next value (or vector of values) into the array being + /// constructed. + mlir::Value copyNextArrayCtorSection(const ExtValue &exv, mlir::Value buffPos, + mlir::Value buffSize, mlir::Value mem, + mlir::Value eleSz, mlir::Type eleTy, + mlir::Type eleRefTy, mlir::Type resTy) { + auto loc = getLoc(); + auto off = builder.create(loc, buffPos); + auto limit = builder.create(loc, buffSize); + auto idxTy = builder.getIndexType(); + auto one = builder.createIntegerConstant(loc, idxTy, 1); + + if (fir::isRecordWithAllocatableMember(eleTy)) + TODO(loc, "deep copy on allocatable members"); + + if (!eleSz) { + // Compute the element size at runtime. + assert(fir::hasDynamicSize(eleTy)); + if (auto charTy = eleTy.dyn_cast()) { + auto charBytes = + builder.getKindMap().getCharacterBitsize(charTy.getFKind()) / 8; + auto bytes = builder.createIntegerConstant(loc, idxTy, charBytes); + auto length = fir::getLen(exv); + if (!length) + fir::emitFatalError(loc, "result is not boxed character"); + eleSz = builder.create(loc, bytes, length); + } else { + TODO(loc, "PDT size"); + // Will call the PDT's size function with the type parameters. + } + } + + // Compute the coordinate using `fir.coordinate_of`, or, if the type has + // dynamic size, generating the pointer arithmetic. + auto computeCoordinate = [&](mlir::Value buff, mlir::Value off) { + auto refTy = eleRefTy; + if (fir::hasDynamicSize(eleTy)) { + if (auto charTy = eleTy.dyn_cast()) { + // Scale a simple pointer using dynamic length and offset values. + auto chTy = fir::CharacterType::getSingleton(charTy.getContext(), + charTy.getFKind()); + refTy = builder.getRefType(chTy); + auto toTy = builder.getRefType(builder.getVarLenSeqTy(chTy)); + buff = builder.createConvert(loc, toTy, buff); + off = builder.create(loc, off, eleSz); + } else { + TODO(loc, "PDT offset"); + } + } + auto coor = builder.create(loc, refTy, buff, + mlir::ValueRange{off}); + return builder.createConvert(loc, eleRefTy, coor); + }; + + // Lambda to lower an abstract array box value. + auto doAbstractArray = [&](const auto &v) { + // Compute the array size. + auto arrSz = one; + for (auto ext : v.getExtents()) + arrSz = builder.create(loc, arrSz, ext); + + // Grow the buffer as needed. + auto endOff = builder.create(loc, off, arrSz); + mem = growBuffer(mem, endOff, limit, buffSize, eleSz); + + // Copy the elements to the buffer. + mlir::Value byteSz = builder.create(loc, arrSz, eleSz); + auto buff = builder.createConvert(loc, fir::HeapType::get(resTy), mem); + auto buffi = computeCoordinate(buff, off); + auto args = fir::runtime::createArguments( + builder, loc, memcpyType(), buffi, v.getAddr(), byteSz, + /*volatile=*/builder.createBool(loc, false)); + createCallMemcpy(args); + + // Save the incremented buffer position. + builder.create(loc, endOff, buffPos); + }; + + // Copy the value. + exv.match( + [&](const mlir::Value &v) { + // Increment the buffer position. + auto plusOne = builder.create(loc, off, one); + + // Grow the buffer as needed. + mem = growBuffer(mem, plusOne, limit, buffSize, eleSz); + + // Store the element in the buffer. + auto buff = + builder.createConvert(loc, fir::HeapType::get(resTy), mem); + auto buffi = builder.create(loc, eleRefTy, buff, + mlir::ValueRange{off}); + auto val = builder.createConvert(loc, eleTy, v); + builder.create(loc, val, buffi); + + builder.create(loc, plusOne, buffPos); + }, + [&](const fir::CharBoxValue &v) { + // Increment the buffer position. + auto plusOne = builder.create(loc, off, one); + + // Grow the buffer as needed. + mem = growBuffer(mem, plusOne, limit, buffSize, eleSz); + + // Store the element in the buffer. + auto buff = + builder.createConvert(loc, fir::HeapType::get(resTy), mem); + auto buffi = computeCoordinate(buff, off); + auto args = fir::runtime::createArguments( + builder, loc, memcpyType(), buffi, v.getAddr(), eleSz, + /*volatile=*/builder.createBool(loc, false)); + createCallMemcpy(args); + + builder.create(loc, plusOne, buffPos); + }, + [&](const fir::ArrayBoxValue &v) { doAbstractArray(v); }, + [&](const fir::CharArrayBoxValue &v) { doAbstractArray(v); }, + [&](const auto &) { + TODO(loc, "unhandled array constructor expression"); + }); + return mem; + } + + // Lower an ac-implied-do in an ac-value-list. + template + std::pair + genArrayCtorInitializer(const Fortran::evaluate::ImpliedDo &x, + mlir::Type resTy, mlir::Value mem, + mlir::Value buffPos, mlir::Value buffSize, + Fortran::lower::StatementContext &) { + auto loc = getLoc(); + auto idxTy = builder.getIndexType(); + auto lo = + builder.createConvert(loc, idxTy, fir::getBase(asScalar(x.lower()))); + auto up = + builder.createConvert(loc, idxTy, fir::getBase(asScalar(x.upper()))); + auto step = + builder.createConvert(loc, idxTy, fir::getBase(asScalar(x.stride()))); + auto seqTy = resTy.template cast(); + auto eleTy = fir::unwrapSequenceType(seqTy); + auto loop = + builder.create(loc, lo, up, step, /*unordered=*/false, + /*finalCount=*/false, mem); + // create a new binding for x.name(), to ac-do-variable, to the iteration + // value. + symMap.pushImpliedDoBinding(toStringRef(x.name()), loop.getInductionVar()); + auto insPt = builder.saveInsertionPoint(); + builder.setInsertionPointToStart(loop.getBody()); + // Thread mem inside the loop via loop argument. + mem = loop.getRegionIterArgs()[0]; + + auto eleRefTy = builder.getRefType(eleTy); + auto eleSz = computeElementSize(eleTy, eleRefTy, builder.getRefType(resTy)); + + // Cleanups for temps in loop body. Any temps created in the loop body + // need to be freed before the end of the loop. + Fortran::lower::StatementContext loopCtx; + for (const Fortran::evaluate::ArrayConstructorValue &acv : x.values()) { + auto [exv, copyNeeded] = std::visit( + [&](const auto &v) { + return genArrayCtorInitializer(v, resTy, mem, buffPos, buffSize, + loopCtx); + }, + acv.u); + mem = copyNeeded ? copyNextArrayCtorSection(exv, buffPos, buffSize, mem, + eleSz, eleTy, eleRefTy, resTy) + : fir::getBase(exv); + } + loopCtx.finalize(); + + builder.create(loc, mem); + builder.restoreInsertionPoint(insPt); + mem = loop.getResult(0); + symMap.popImpliedDoBinding(); + llvm::SmallVector extents = { + builder.create(loc, buffPos).getResult()}; + + // Convert to extended value. + if (auto charTy = + seqTy.getEleTy().template dyn_cast()) { + auto len = builder.createIntegerConstant(loc, builder.getI64Type(), + charTy.getLen()); + return {fir::CharArrayBoxValue{mem, len, extents}, /*needCopy=*/false}; + } + return {fir::ArrayBoxValue{mem, extents}, /*needCopy=*/false}; + } + + // To simplify the handling and interaction between the various cases, array + // constructors are always lowered to the incremental construction code + // pattern, even if the extent of the array value is constant. After the + // MemToReg pass and constant folding, the optimizer should be able to + // determine that all the buffer overrun tests are false when the + // incremental construction wasn't actually required. + template + CC genarr(const Fortran::evaluate::ArrayConstructor &x) { + auto loc = getLoc(); + auto evExpr = toEvExpr(x); + auto resTy = translateSomeExprToFIRType(converter, evExpr); + auto idxTy = builder.getIndexType(); + auto seqTy = resTy.template cast(); + auto eleTy = fir::unwrapSequenceType(resTy); + auto buffSize = builder.createTemporary(loc, idxTy, ".buff.size"); + auto zero = builder.createIntegerConstant(loc, idxTy, 0); + auto buffPos = builder.createTemporary(loc, idxTy, ".buff.pos"); + builder.create(loc, zero, buffPos); + // Allocate space for the array to be constructed. + mlir::Value mem; + if (fir::hasDynamicSize(resTy)) { + if (fir::hasDynamicSize(eleTy)) { + // The size of each element may depend on a general expression. Defer + // creating the buffer until after the expression is evaluated. + mem = builder.createNullConstant(loc, builder.getRefType(eleTy)); + builder.create(loc, zero, buffSize); + } else { + auto initBuffSz = + builder.createIntegerConstant(loc, idxTy, clInitialBufferSize); + mem = builder.create( + loc, eleTy, /*typeparams=*/llvm::None, initBuffSz); + builder.create(loc, initBuffSz, buffSize); + } + } else { + mem = builder.create(loc, resTy); + int64_t buffSz = 1; + for (auto extent : seqTy.getShape()) + buffSz *= extent; + auto initBuffSz = builder.createIntegerConstant(loc, idxTy, buffSz); + builder.create(loc, initBuffSz, buffSize); + } + // Compute size of element + auto eleRefTy = builder.getRefType(eleTy); + auto eleSz = computeElementSize(eleTy, eleRefTy, builder.getRefType(resTy)); + + // Populate the buffer with the elements, growing as necessary. + for (const auto &expr : x) { + auto [exv, copyNeeded] = std::visit( + [&](const auto &e) { + return genArrayCtorInitializer(e, resTy, mem, buffPos, buffSize, + stmtCtx); + }, + expr.u); + mem = copyNeeded ? copyNextArrayCtorSection(exv, buffPos, buffSize, mem, + eleSz, eleTy, eleRefTy, resTy) + : fir::getBase(exv); + } + mem = builder.createConvert(loc, fir::HeapType::get(resTy), mem); + llvm::SmallVector extents = { + builder.create(loc, buffPos)}; + + // Cleanup the temporary. + auto *bldr = &converter.getFirOpBuilder(); + stmtCtx.attachCleanup( + [bldr, loc, mem]() { bldr->create(loc, mem); }); + + // Return the continuation. + if (auto charTy = + seqTy.getEleTy().template dyn_cast()) { + auto len = builder.createIntegerConstant(loc, builder.getI64Type(), + charTy.getLen()); + return genarr(fir::CharArrayBoxValue{mem, len, extents}); + } + return genarr(fir::ArrayBoxValue{mem, extents}); + } + + CC genarr(const Fortran::evaluate::ImpliedDoIndex &) { + fir::emitFatalError(getLoc(), "implied do index cannot have rank > 0"); + } + CC genarr(const Fortran::evaluate::TypeParamInquiry &x) { + TODO(getLoc(), "array expr type parameter inquiry"); + return [](IterSpace iters) -> ExtValue { return mlir::Value{}; }; + } + CC genarr(const Fortran::evaluate::DescriptorInquiry &x) { + TODO(getLoc(), "array expr descriptor inquiry"); + return [](IterSpace iters) -> ExtValue { return mlir::Value{}; }; + } + CC genarr(const Fortran::evaluate::StructureConstructor &x) { + TODO(getLoc(), "structure constructor"); + return [](IterSpace iters) -> ExtValue { return mlir::Value{}; }; + } + + //===--------------------------------------------------------------------===// + // LOCICAL operators (.NOT., .AND., .EQV., etc.) + //===--------------------------------------------------------------------===// + + template + CC genarr(const Fortran::evaluate::Not &x) { + auto loc = getLoc(); + auto i1Ty = builder.getI1Type(); + auto lambda = genarr(x.left()); + auto truth = builder.createBool(loc, true); + return [=](IterSpace iters) -> ExtValue { + auto logical = fir::getBase(lambda(iters)); + auto val = builder.createConvert(loc, i1Ty, logical); + return builder.create(loc, val, truth); + }; + } + template + CC createBinaryBoolOp(const A &x) { + auto loc = getLoc(); + auto i1Ty = builder.getI1Type(); + auto lf = genarr(x.left()); + auto rf = genarr(x.right()); + return [=](IterSpace iters) -> ExtValue { + auto left = fir::getBase(lf(iters)); + auto right = fir::getBase(rf(iters)); + auto lhs = builder.createConvert(loc, i1Ty, left); + auto rhs = builder.createConvert(loc, i1Ty, right); + return builder.create(loc, lhs, rhs); + }; + } + template + CC createCompareBoolOp(mlir::CmpIPredicate pred, const A &x) { + auto loc = getLoc(); + auto i1Ty = builder.getI1Type(); + auto lf = genarr(x.left()); + auto rf = genarr(x.right()); + return [=](IterSpace iters) -> ExtValue { + auto left = fir::getBase(lf(iters)); + auto right = fir::getBase(rf(iters)); + auto lhs = builder.createConvert(loc, i1Ty, left); + auto rhs = builder.createConvert(loc, i1Ty, right); + return builder.create(loc, pred, lhs, rhs); + }; + } + template + CC genarr(const Fortran::evaluate::LogicalOperation &x) { + switch (x.logicalOperator) { + case Fortran::evaluate::LogicalOperator::And: + return createBinaryBoolOp(x); + case Fortran::evaluate::LogicalOperator::Or: + return createBinaryBoolOp(x); + case Fortran::evaluate::LogicalOperator::Eqv: + return createCompareBoolOp(mlir::CmpIPredicate::eq, x); + case Fortran::evaluate::LogicalOperator::Neqv: + return createCompareBoolOp(mlir::CmpIPredicate::ne, x); + case Fortran::evaluate::LogicalOperator::Not: + llvm_unreachable(".NOT. handled elsewhere"); + } + llvm_unreachable("unhandled case"); + } + + //===--------------------------------------------------------------------===// + // Relational operators (<, <=, ==, etc.) + //===--------------------------------------------------------------------===// + + template + CC createCompareOp(PRED pred, const A &x) { + auto loc = getLoc(); + auto lf = genarr(x.left()); + auto rf = genarr(x.right()); + return [=](IterSpace iters) -> ExtValue { + auto lhs = fir::getBase(lf(iters)); + auto rhs = fir::getBase(rf(iters)); + return builder.create(loc, pred, lhs, rhs); + }; + } + template + CC createCompareCharOp(mlir::CmpIPredicate pred, const A &x) { + auto loc = getLoc(); + auto lf = genarr(x.left()); + auto rf = genarr(x.right()); + return [=](IterSpace iters) -> ExtValue { + auto lhs = lf(iters); + auto rhs = rf(iters); + return fir::runtime::genCharCompare(builder, loc, pred, lhs, rhs); + }; + } + template + CC genarr(const Fortran::evaluate::Relational> &x) { + return createCompareOp(translateRelational(x.opr), x); + } + template + CC genarr(const Fortran::evaluate::Relational> &x) { + return createCompareCharOp(translateRelational(x.opr), x); + } + template + CC genarr(const Fortran::evaluate::Relational> &x) { + return createCompareOp(translateFloatRelational(x.opr), x); + } + template + CC genarr(const Fortran::evaluate::Relational> &x) { + return createCompareOp(translateFloatRelational(x.opr), x); + } + CC genarr( + const Fortran::evaluate::Relational &r) { + return std::visit([&](const auto &x) { return genarr(x); }, r.u); + } + + template + CC genarr(const Fortran::evaluate::Designator &des) { + return std::visit([&](const auto &x) { return genarr(x); }, des.u); + } + + CC genarr(const Fortran::evaluate::DataRef &d) { + return std::visit([&](const auto &x) { return genarr(x); }, d.u); + } + +private: + explicit ArrayExprLowering(Fortran::lower::AbstractConverter &converter, + Fortran::lower::StatementContext &stmtCtx, + Fortran::lower::SymMap &symMap) + : converter{converter}, builder{converter.getFirOpBuilder()}, + stmtCtx{stmtCtx}, symMap{symMap} {} + + explicit ArrayExprLowering(Fortran::lower::AbstractConverter &converter, + Fortran::lower::StatementContext &stmtCtx, + Fortran::lower::SymMap &symMap, + ConstituentSemantics sem) + : converter{converter}, builder{converter.getFirOpBuilder()}, + stmtCtx{stmtCtx}, symMap{symMap}, semant{sem} {} + + explicit ArrayExprLowering(Fortran::lower::AbstractConverter &converter, + Fortran::lower::StatementContext &stmtCtx, + Fortran::lower::SymMap &symMap, + ConstituentSemantics sem, + Fortran::lower::ExplicitIterSpace *expSpace, + Fortran::lower::ImplicitIterSpace *impSpace) + : converter{converter}, builder{converter.getFirOpBuilder()}, + stmtCtx{stmtCtx}, symMap{symMap}, + explicitSpace(expSpace->isActive() ? expSpace : nullptr), + implicitSpace(impSpace->empty() ? nullptr : impSpace), semant{sem} {} + + mlir::Location getLoc() { return converter.getCurrentLocation(); } + + /// Array appears in a lhs context such that it is assigned after the rhs is + /// fully evaluated. + bool isCopyInCopyOut() { + return semant == ConstituentSemantics::CopyInCopyOut; + } + + /// Array appears in a lhs (or temp) context such that a projected, + /// discontiguous subspace of the array is assigned after the rhs is fully + /// evaluated. That is, the rhs array value is merged into a section of the + /// lhs array. + bool isProjectedCopyInCopyOut() { + return semant == ConstituentSemantics::ProjectedCopyInCopyOut; + } + + /// Array appears in a context where it must be boxed. + bool isBoxValue() { return semant == ConstituentSemantics::BoxValue; } + + /// Array appears in a context where differences in the memory reference can + /// be observable in the computational results. For example, an array + /// element is passed to an impure procedure. + bool isReferentiallyOpaque() { + return semant == ConstituentSemantics::RefOpaque; + } + + /// Array appears in a context where it is passed as a VALUE argument. + bool isValueAttribute() { return semant == ConstituentSemantics::ByValueArg; } + + /// Can the loops over the expression be unordered ? + bool getUnordered() const { return unordered; } + + void setUnordered(bool b) { unordered = b; } + + Fortran::lower::AbstractConverter &converter; + fir::FirOpBuilder &builder; + Fortran::lower::StatementContext &stmtCtx; + Fortran::lower::SymMap &symMap; + /// The continuation to generate code to update the destination. + llvm::Optional ccStoreToDest; + llvm::Optional)>> ccPrelude; + llvm::Optional)>> + ccLoadDest; + /// The destination is the loaded array into which the results will be + /// merged. + fir::ArrayLoadOp destination; + /// The shape of the destination. + llvm::SmallVector destShape; + /// List of arrays in the expression that have been loaded. + llvm::SmallVector arrayOperands; + llvm::SmallVector sliceTriple; + llvm::SmallVector slicePath; + /// If there is a user-defined iteration space, explicitShape will hold the + /// information from the front end. + Fortran::lower::ExplicitIterSpace *explicitSpace = nullptr; + Fortran::lower::ImplicitIterSpace *implicitSpace = nullptr; + ConstituentSemantics semant = ConstituentSemantics::RefTransparent; + bool inSlice = false; + // Can the array expression be evaluated in any order ? + // Will be set to false if any of the expression parts prevent this. + bool unordered = true; +}; +} // namespace + +fir::ExtendedValue Fortran::lower::createSomeExtendedExpression( + mlir::Location loc, Fortran::lower::AbstractConverter &converter, + const Fortran::evaluate::Expr &expr, + Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx) { + LLVM_DEBUG(expr.AsFortran(llvm::dbgs() << "expr: ") << '\n'); + return ScalarExprLowering{loc, converter, symMap, stmtCtx}.genval(expr); +} + +fir::ExtendedValue Fortran::lower::createSomeInitializerExpression( + mlir::Location loc, Fortran::lower::AbstractConverter &converter, + const Fortran::evaluate::Expr &expr, + Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx) { + LLVM_DEBUG(expr.AsFortran(llvm::dbgs() << "expr: ") << '\n'); + return ScalarExprLowering{loc, converter, symMap, stmtCtx, + /*initializer=*/true} + .genval(expr); +} + +fir::ExtendedValue Fortran::lower::createSomeExtendedAddress( + mlir::Location loc, Fortran::lower::AbstractConverter &converter, + const Fortran::evaluate::Expr &expr, + Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx) { + LLVM_DEBUG(expr.AsFortran(llvm::dbgs() << "address: ") << '\n'); + return ScalarExprLowering{loc, converter, symMap, stmtCtx}.gen(expr); +} + +void Fortran::lower::createSomeArrayAssignment( + Fortran::lower::AbstractConverter &converter, + const Fortran::evaluate::Expr &lhs, + const Fortran::evaluate::Expr &rhs, + Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx) { + LLVM_DEBUG(lhs.AsFortran(llvm::dbgs() << "onto array: ") << '\n'; + rhs.AsFortran(llvm::dbgs() << "assign expression: ") << '\n';); + ArrayExprLowering::lowerArrayAssignment(converter, symMap, stmtCtx, lhs, rhs); +} + +void Fortran::lower::createSomeArrayAssignment( + Fortran::lower::AbstractConverter &converter, const fir::ExtendedValue &lhs, + const Fortran::evaluate::Expr &rhs, + Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx) { + LLVM_DEBUG(llvm::dbgs() << "onto array: " << lhs << '\n'; + rhs.AsFortran(llvm::dbgs() << "assign expression: ") << '\n';); + ArrayExprLowering::lowerArrayAssignment(converter, symMap, stmtCtx, lhs, rhs); +} +void Fortran::lower::createSomeArrayAssignment( + Fortran::lower::AbstractConverter &converter, const fir::ExtendedValue &lhs, + const fir::ExtendedValue &rhs, Fortran::lower::SymMap &symMap, + Fortran::lower::StatementContext &stmtCtx) { + LLVM_DEBUG(llvm::dbgs() << "onto array: " << lhs << '\n'; + llvm::dbgs() << "assign expression: " << rhs << '\n';); + ArrayExprLowering::lowerArrayAssignment(converter, symMap, stmtCtx, lhs, rhs); +} + +void Fortran::lower::createAnyMaskedArrayAssignment( + Fortran::lower::AbstractConverter &converter, + const Fortran::evaluate::Expr &lhs, + const Fortran::evaluate::Expr &rhs, + Fortran::lower::ExplicitIterSpace &explicitSpace, + Fortran::lower::ImplicitIterSpace &implicitSpace, + Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx) { + LLVM_DEBUG(lhs.AsFortran(llvm::dbgs() << "onto array: ") << '\n'; + rhs.AsFortran(llvm::dbgs() << "assign expression: ") + << " given the explicit iteration space:\n" + << explicitSpace << "\n and implied mask conditions:\n" + << implicitSpace << '\n';); + ArrayExprLowering::lowerAnyMaskedArrayAssignment( + converter, symMap, stmtCtx, lhs, rhs, explicitSpace, implicitSpace); +} + +void Fortran::lower::createAllocatableArrayAssignment( + Fortran::lower::AbstractConverter &converter, + const Fortran::evaluate::Expr &lhs, + const Fortran::evaluate::Expr &rhs, + Fortran::lower::ExplicitIterSpace &explicitSpace, + Fortran::lower::ImplicitIterSpace &implicitSpace, + Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx) { + LLVM_DEBUG(lhs.AsFortran(llvm::dbgs() << "defining array: ") << '\n'; + rhs.AsFortran(llvm::dbgs() << "assign expression: ") + << " given the explicit iteration space:\n" + << explicitSpace << "\n and implied mask conditions:\n" + << implicitSpace << '\n';); + ArrayExprLowering::lowerAllocatableArrayAssignment( + converter, symMap, stmtCtx, lhs, rhs, explicitSpace, implicitSpace); +} + +fir::ExtendedValue Fortran::lower::createSomeArrayTempValue( + Fortran::lower::AbstractConverter &converter, + const std::optional &shape, + const Fortran::evaluate::Expr &expr, + Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx) { + LLVM_DEBUG(expr.AsFortran(llvm::dbgs() << "array value: ") << '\n'); + return ArrayExprLowering::lowerNewArrayExpression(converter, symMap, stmtCtx, + shape, expr); +} + +fir::ExtendedValue Fortran::lower::createLazyArrayTempValue( + Fortran::lower::AbstractConverter &converter, + const Fortran::evaluate::Expr &expr, + mlir::Value var, mlir::Value shapeBuffer, Fortran::lower::SymMap &symMap, + Fortran::lower::StatementContext &stmtCtx) { + LLVM_DEBUG(expr.AsFortran(llvm::dbgs() << "array value: ") << '\n'); + return ArrayExprLowering::lowerLazyArrayExpression(converter, symMap, stmtCtx, + expr, var, shapeBuffer); +} + +fir::ExtendedValue Fortran::lower::createSomeArrayBox( + Fortran::lower::AbstractConverter &converter, + const Fortran::evaluate::Expr &expr, + Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx) { + LLVM_DEBUG(expr.AsFortran(llvm::dbgs() << "box designator: ") << '\n'); + return ArrayExprLowering::lowerBoxedArrayExpression(converter, symMap, + stmtCtx, expr); +} + +fir::MutableBoxValue Fortran::lower::createMutableBox( + mlir::Location loc, Fortran::lower::AbstractConverter &converter, + const Fortran::evaluate::Expr &expr, + Fortran::lower::SymMap &symMap) { + // MutableBox lowering StatementContext does not need to be propagated + // to the caller because the result value is a variable, not a temporary + // expression. The StatementContext clean-up can occur before using the + // resulting MutableBoxValue. Variables of all other types are handled in the + // bridge. + Fortran::lower::StatementContext dummyStmtCtx; + return ScalarExprLowering{loc, converter, symMap, dummyStmtCtx} + .genMutableBoxValue(expr); +} + +mlir::Value Fortran::lower::createSubroutineCall( + AbstractConverter &converter, + const evaluate::Expr &call, SymMap &symMap, + StatementContext &stmtCtx, bool isUserDefAssignment) { + auto loc = converter.getCurrentLocation(); + if (isElementalProcWithArrayArgs(call)) { + // Elemental user defined assignment has special requirements to deal with + // LHS/RHS overlaps. See 10.2.1.5 p2. + if (isUserDefAssignment) + TODO(converter.getCurrentLocation(), "elemental user defined assignment"); + ArrayExprLowering::lowerArrayElementalSubroutine(converter, symMap, stmtCtx, + call); + return mlir::Value{}; + } + // FIXME: The non elemental user defined assignment case with array arguments + // must be take into account potential overlap. So far the front end does not + // add parentheses around the RHS argument in the call as it should according + // to 15.4.3.4.3 p2. + auto res = Fortran::lower::createSomeExtendedExpression(loc, converter, call, + symMap, stmtCtx); + return fir::getBase(res); +} + +template +fir::ArrayLoadOp genArrayLoad(mlir::Location loc, + Fortran::lower::AbstractConverter &converter, + fir::FirOpBuilder &builder, const A *x, + Fortran::lower::SymMap &symMap, + Fortran::lower::StatementContext &stmtCtx) { + auto exv = ScalarExprLowering{loc, converter, symMap, stmtCtx}.gen(*x); + auto addr = fir::getBase(exv); + auto shapeOp = builder.createShape(loc, exv); + auto arrTy = fir::dyn_cast_ptrOrBoxEleTy(addr.getType()); + return builder.create(loc, arrTy, addr, shapeOp, + /*slice=*/mlir::Value{}, + fir::getTypeParams(exv)); +} +template <> +fir::ArrayLoadOp +genArrayLoad(mlir::Location loc, Fortran::lower::AbstractConverter &converter, + fir::FirOpBuilder &builder, const Fortran::evaluate::ArrayRef *x, + Fortran::lower::SymMap &symMap, + Fortran::lower::StatementContext &stmtCtx) { + if (x->base().IsSymbol()) + return genArrayLoad(loc, converter, builder, &x->base().GetLastSymbol(), + symMap, stmtCtx); + return genArrayLoad(loc, converter, builder, &x->base().GetComponent(), + symMap, stmtCtx); +} + +void Fortran::lower::createArrayLoads( + Fortran::lower::AbstractConverter &converter, + Fortran::lower::ExplicitIterSpace &esp, Fortran::lower::SymMap &symMap) { + auto counter = esp.getCounter(); + auto &builder = converter.getFirOpBuilder(); + auto loc = converter.getCurrentLocation(); + auto &stmtCtx = esp.stmtContext(); + // Gen the fir.array_load ops. + auto genLoad = [&](const auto *x) -> fir::ArrayLoadOp { + return genArrayLoad(loc, converter, builder, x, symMap, stmtCtx); + }; + if (esp.lhsBases[counter].hasValue()) { + auto &base = esp.lhsBases[counter].getValue(); + auto load = std::visit(genLoad, base); + esp.innerArgs.push_back(load); + esp.bindLoad(base, load); + } + for (auto &base : esp.rhsBases[counter]) + esp.bindLoad(base, std::visit(genLoad, base)); +} + +void Fortran::lower::createArrayMergeStores( + Fortran::lower::AbstractConverter &converter, + Fortran::lower::ExplicitIterSpace &esp) { + auto &builder = converter.getFirOpBuilder(); + auto loc = converter.getCurrentLocation(); + esp.finalizeContext(); + if (esp.innerArgs.empty()) { + // ResultOp was already created by DoLoopOp builder. + } else { + builder.create(loc, esp.innerArgs); + } + builder.setInsertionPointAfter(esp.getOuterLoop()); + // Gen the fir.array_merge_store ops for all LHS arrays. + for (auto i : llvm::enumerate(esp.getOuterLoop().getResults())) + if (auto ldOpt = esp.getLhsLoad(i.index())) { + auto load = ldOpt.getValue(); + builder.create( + loc, load, i.value(), load.memref(), load.slice(), load.typeparams()); + } + if (esp.loopCleanup.hasValue()) { + esp.loopCleanup.getValue()(builder); + esp.loopCleanup = llvm::None; + } + esp.innerArgs.clear(); + esp.outerLoop = llvm::None; + esp.resetBindings(); + esp.incrementCounter(); } diff --git a/flang/lib/Lower/ConvertType.cpp b/flang/lib/Lower/ConvertType.cpp index 43c1bb0a092cf3..c522e2340d0f3b 100644 --- a/flang/lib/Lower/ConvertType.cpp +++ b/flang/lib/Lower/ConvertType.cpp @@ -7,524 +7,441 @@ //===----------------------------------------------------------------------===// #include "flang/Lower/ConvertType.h" +#include "flang/Evaluate/fold.h" +#include "flang/Evaluate/shape.h" +#include "flang/Lower/AbstractConverter.h" +#include "flang/Lower/CallInterface.h" +#include "flang/Lower/Mangler.h" #include "flang/Lower/PFTBuilder.h" -#include "flang/Lower/Utils.h" +#include "flang/Lower/Support/Utils.h" +#include "flang/Lower/Todo.h" #include "flang/Optimizer/Dialect/FIRType.h" +#include "flang/Optimizer/Support/FatalError.h" #include "flang/Semantics/tools.h" #include "flang/Semantics/type.h" #include "mlir/IR/Builders.h" #include "mlir/IR/BuiltinTypes.h" +#include "llvm/Support/Debug.h" -#undef QUOTE -#undef TODO -#define QUOTE(X) #X -#define TODO(S) \ - { \ - emitError(__FILE__ ":" QUOTE(__LINE__) ": type lowering of " S \ - " not implemented"); \ - exit(1); \ - } - -template -bool isConstant(const Fortran::evaluate::Expr &e) { - return Fortran::evaluate::IsConstantExpr(Fortran::lower::SomeExpr{e}); -} - -template -int64_t toConstant(const Fortran::evaluate::Expr &e) { - auto opt = Fortran::evaluate::ToInt64(e); - assert(opt.has_value() && "expression didn't resolve to a constant"); - return opt.value(); -} - -// one argument template, must be specialized -template -mlir::Type genFIRType(mlir::MLIRContext *, int) { - return {}; -} - -// two argument template -template -mlir::Type genFIRType(mlir::MLIRContext *context) { - if constexpr (TC == Fortran::common::TypeCategory::Integer) { - auto bits{Fortran::evaluate::Type::Scalar::bits}; - return mlir::IntegerType::get(context, bits); - } else if constexpr (TC == Fortran::common::TypeCategory::Logical || - TC == Fortran::common::TypeCategory::Character || - TC == Fortran::common::TypeCategory::Complex) { - return genFIRType(context, KIND); - } else { - return {}; - } -} +#define DEBUG_TYPE "flang-lower-type" -template <> -mlir::Type -genFIRType(mlir::MLIRContext *context) { - return mlir::FloatType::getF16(context); -} - -template <> -mlir::Type -genFIRType(mlir::MLIRContext *context) { - return mlir::FloatType::getBF16(context); -} - -template <> -mlir::Type -genFIRType(mlir::MLIRContext *context) { - return mlir::FloatType::getF32(context); -} - -template <> -mlir::Type -genFIRType(mlir::MLIRContext *context) { - return mlir::FloatType::getF64(context); -} - -template <> -mlir::Type genFIRType( - mlir::MLIRContext *context) { - return fir::RealType::get(context, 10); -} +//===--------------------------------------------------------------------===// +// Intrinsic type translation helpers +//===--------------------------------------------------------------------===// -template <> -mlir::Type genFIRType( - mlir::MLIRContext *context) { - return fir::RealType::get(context, 16); -} - -template <> -mlir::Type -genFIRType(mlir::MLIRContext *context, - int kind) { +static mlir::Type genRealType(mlir::MLIRContext *context, int kind) { if (Fortran::evaluate::IsValidKindOfIntrinsicType( Fortran::common::TypeCategory::Real, kind)) { switch (kind) { case 2: - return genFIRType(context); + return mlir::FloatType::getF16(context); case 3: - return genFIRType(context); + return mlir::FloatType::getBF16(context); case 4: - return genFIRType(context); + return mlir::FloatType::getF32(context); case 8: - return genFIRType(context); + return mlir::FloatType::getF64(context); case 10: - return genFIRType(context); + return mlir::FloatType::getF80(context); case 16: - return genFIRType(context); + return mlir::FloatType::getF128(context); } } llvm_unreachable("REAL type translation not implemented"); } -template <> -mlir::Type -genFIRType(mlir::MLIRContext *context, - int kind) { +template +int getIntegerBits() { + return Fortran::evaluate::Type::Scalar::bits; +} +static mlir::Type genIntegerType(mlir::MLIRContext *context, int kind) { if (Fortran::evaluate::IsValidKindOfIntrinsicType( Fortran::common::TypeCategory::Integer, kind)) { switch (kind) { case 1: - return genFIRType(context); + return mlir::IntegerType::get(context, getIntegerBits<1>()); case 2: - return genFIRType(context); + return mlir::IntegerType::get(context, getIntegerBits<2>()); case 4: - return genFIRType(context); + return mlir::IntegerType::get(context, getIntegerBits<4>()); case 8: - return genFIRType(context); + return mlir::IntegerType::get(context, getIntegerBits<8>()); case 16: - return genFIRType(context); + return mlir::IntegerType::get(context, getIntegerBits<16>()); } } llvm_unreachable("INTEGER type translation not implemented"); } -template <> -mlir::Type -genFIRType(mlir::MLIRContext *context, - int KIND) { +static mlir::Type genLogicalType(mlir::MLIRContext *context, int KIND) { if (Fortran::evaluate::IsValidKindOfIntrinsicType( Fortran::common::TypeCategory::Logical, KIND)) return fir::LogicalType::get(context, KIND); return {}; } -template <> -mlir::Type -genFIRType(mlir::MLIRContext *context, - int KIND) { +static mlir::Type genCharacterType( + mlir::MLIRContext *context, int KIND, + Fortran::lower::LenParameterTy len = fir::CharacterType::unknownLen()) { if (Fortran::evaluate::IsValidKindOfIntrinsicType( Fortran::common::TypeCategory::Character, KIND)) - return fir::CharacterType::get(context, KIND, 1); + return fir::CharacterType::get(context, KIND, len); return {}; } -template <> -mlir::Type -genFIRType(mlir::MLIRContext *context, - int KIND) { +static mlir::Type genComplexType(mlir::MLIRContext *context, int KIND) { if (Fortran::evaluate::IsValidKindOfIntrinsicType( Fortran::common::TypeCategory::Complex, KIND)) return fir::ComplexType::get(context, KIND); return {}; } -namespace { +static mlir::Type +genFIRType(mlir::MLIRContext *context, Fortran::common::TypeCategory tc, + int kind, + llvm::ArrayRef lenParameters) { + switch (tc) { + case Fortran::common::TypeCategory::Real: + return genRealType(context, kind); + case Fortran::common::TypeCategory::Integer: + return genIntegerType(context, kind); + case Fortran::common::TypeCategory::Complex: + return genComplexType(context, kind); + case Fortran::common::TypeCategory::Logical: + return genLogicalType(context, kind); + case Fortran::common::TypeCategory::Character: + if (!lenParameters.empty()) + return genCharacterType(context, kind, lenParameters[0]); + return genCharacterType(context, kind); + default: + break; + } + llvm_unreachable("unhandled type category"); +} -/// Discover the type of an Fortran::evaluate::Expr and convert it to an -/// mlir::Type. The type returned may be an MLIR standard or FIR type. -class TypeBuilder { -public: - /// Constructor. - explicit TypeBuilder( - mlir::MLIRContext *context, - const Fortran::common::IntrinsicTypeDefaultKinds &defaults) - : context{context}, defaults{defaults} {} - - //===--------------------------------------------------------------------===// - // Generate type entry points - //===--------------------------------------------------------------------===// - - template