diff --git a/flang/CMakeLists.txt b/flang/CMakeLists.txt index 886213fd3c3eca..e18ed5c0d788ce 100644 --- a/flang/CMakeLists.txt +++ b/flang/CMakeLists.txt @@ -1,29 +1,27 @@ -cmake_minimum_required(VERSION 3.9.0) +cmake_minimum_required(VERSION 3.9.0) # RPATH settings on macOS do not affect INSTALL_NAME. -if (POLICY CMP0068) +if (POLICY CMP0068) cmake_policy(SET CMP0068 NEW) set(CMAKE_BUILD_WITH_INSTALL_NAME_DIR ON) endif() # Include file check macros honor CMAKE_REQUIRED_LIBRARIES. -if(POLICY CMP0075) +if(POLICY CMP0075) cmake_policy(SET CMP0075 NEW) endif() # option() honors normal variables. -if (POLICY CMP0077) +if (POLICY CMP0077) cmake_policy(SET CMP0077 NEW) endif() -option(LINK_WITH_FIR "Link driver with FIR and LLVM" ON) - -# Flang requires C++17. +# Flang requires C++17. set(CMAKE_CXX_STANDARD 17) set(CMAKE_CXX_STANDARD_REQUIRED TRUE) -set(CMAKE_CXX_EXTENSIONS OFF) set(FLANG_SOURCE_DIR ${CMAKE_CURRENT_SOURCE_DIR}) +set(FLANG_BINARY_DIR ${CMAKE_CURRENT_BINARY_DIR}) if (CMAKE_SOURCE_DIR STREQUAL CMAKE_BINARY_DIR AND NOT MSVC_IDE) message(FATAL_ERROR "In-source builds are not allowed. \ @@ -37,13 +35,13 @@ endif() list(APPEND CMAKE_MODULE_PATH "${CMAKE_CURRENT_SOURCE_DIR}/cmake/modules") include(AddFlang) + # Check for a standalone build and configure as appropriate from # there. if (CMAKE_SOURCE_DIR STREQUAL CMAKE_CURRENT_SOURCE_DIR) -message("Building Flang as a standalone project.") -project(Flang) + message("Building Flang as a standalone project.") + project(Flang) - set(FLANG_BINARY_DIR ${CMAKE_CURRENT_BINARY_DIR}) if (NOT MSVC_IDE) set(LLVM_ENABLE_ASSERTIONS ${ENABLE_ASSERTIONS} CACHE BOOL "Enable assertions") @@ -51,30 +49,28 @@ project(Flang) 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}") list(APPEND CMAKE_MODULE_PATH ${LLVM_DIR}) + 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() + # 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) include(HandleLLVMOptions) include(VersionFromVCS) - - if(LINK_WITH_FIR) - include(TableGen) - find_package(MLIR REQUIRED CONFIG) - # Use SYSTEM for the same reasons as for LLVM includes - include_directories(SYSTEM ${MLIR_INCLUDE_DIRS}) - list(APPEND CMAKE_MODULE_PATH ${MLIR_DIR}) - include(AddMLIR) - find_program(MLIR_TABLEGEN_EXE "mlir-tblgen" ${LLVM_TOOLS_BINARY_DIR} - NO_DEFAULT_PATH) - endif() + include(TableGen) + include(AddMLIR) option(LLVM_ENABLE_WARNINGS "Enable compiler warnings." ON) option(LLVM_INSTALL_TOOLCHAIN_ONLY @@ -92,11 +88,13 @@ project(Flang) # 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 - # avoid some mixed compilation flangs (e.g. -std=c++11 ... -std=c++17). - if (DEFINED LLVM_CXX_STD) + # We look for it here and remove it from Flang's compile flags to + # avoid some mixed compilation flangs (e.g. -std=c++11 ... -std=c++17). + if (DEFINED LLVM_CXX_STD) message("LLVM configuration set a C++ standard: ${LLVM_CXX_STD}") if (NOT LLVM_CXX_STD EQUAL "c++17") message("Flang: Overriding LLVM's 'cxx_std' setting...") @@ -109,12 +107,16 @@ project(Flang) link_directories("${LLVM_LIBRARY_DIR}") + set(LLVM_TOOLS_BINARY_DIR ${TOOLS_BINARY_DIR} CACHE PATH "Path to llvm/bin") + find_program(MLIR_TABLEGEN_EXE "mlir-tblgen" ${LLVM_TOOLS_BINARY_DIR} + NO_DEFAULT_PATH) + set(CMAKE_RUNTIME_OUTPUT_DIRECTORY ${CMAKE_BINARY_DIR}/bin) - set(CMAKE_LIBRARY_OUTPUT_DIRECTORY + set(CMAKE_LIBRARY_OUTPUT_DIRECTORY ${CMAKE_BINARY_DIR}/lib${LLVM_LIBDIR_SUFFIX}) - set(CMAKE_ARCHIVE_OUTPUT_DIRECTORY + set(CMAKE_ARCHIVE_OUTPUT_DIRECTORY ${CMAKE_BINARY_DIR}/lib${LLVM_LIBDIR_SUFFIX}) - + set(BACKEND_PACKAGE_STRING "LLVM ${LLVM_PACKAGE_VERSION}") set(LLVM_EXTERNAL_LIT "${LLVM_TOOLS_BINARY_DIR}/llvm-lit" CACHE STRING "Command used to spawn lit") @@ -127,37 +129,37 @@ project(Flang) endif() else() - option(FLANG_INCLUDE_TESTS - "Generate build targets for the Flang unit tests." - ${LLVM_INCLUDE_TESTS}) - set(FLANG_BINARY_DIR ${CMAKE_BINARY_DIR}/tools/flang) set(BACKEND_PACKAGE_STRING "${PACKAGE_STRING}") - if (LINK_WITH_FIR) - set(MLIR_MAIN_SRC_DIR ${LLVM_MAIN_SRC_DIR}/../mlir/include ) # --src-root - set(MLIR_INCLUDE_DIR ${LLVM_MAIN_SRC_DIR}/../mlir/include ) # --includedir - set(MLIR_TABLEGEN_OUTPUT_DIR ${CMAKE_BINARY_DIR}/tools/mlir/include) - set(MLIR_TABLEGEN_EXE $) - include_directories(SYSTEM ${MLIR_INCLUDE_DIR}) - include_directories(SYSTEM ${MLIR_TABLEGEN_OUTPUT_DIR}) - endif() + set(MLIR_BINARY_DIR ${LLVM_BINARY_DIR}/tools/mlir) + set(MLIR_SOURCE_DIR ${LLVM_SOURCE_DIR}/../mlir) endif() -if(LINK_WITH_FIR) - # tco tool and FIR lib output directories - set(LLVM_RUNTIME_OUTPUT_INTDIR ${CMAKE_BINARY_DIR}/bin) - set(LLVM_LIBRARY_OUTPUT_INTDIR ${CMAKE_BINARY_DIR}/lib) - # Always build tco tool - set(LLVM_BUILD_TOOLS ON) - message(STATUS "Linking driver with FIR and LLVM") - llvm_map_components_to_libnames(LLVM_COMMON_LIBS support) - message(STATUS "LLVM libraries: ${LLVM_COMMON_LIBS}") -endif() - -# Add Flang-centric modules to cmake path. 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") if (NOT DEFAULT_SYSROOT) @@ -172,7 +174,7 @@ endif() set(FLANG_DEFAULT_LINKER "" CACHE STRING "Default linker to use (linker name or absolute path, empty for platform default)") -set(FLANG_DEFAULT_RTLIB "" CACHE STRING +set(FLANG_DEFAULT_RTLIB "" CACHE STRING "Default Fortran runtime library to use (\"libFortranRuntime\"), leave empty for platform default.") if (NOT(FLANG_DEFAULT_RTLIB STREQUAL "")) @@ -184,7 +186,7 @@ endif() set(PACKAGE_VERSION "${LLVM_PACKAGE_VERSION}") -# Override LLVM versioning for now... +# Override LLVM versioning for now... set(FLANG_VERSION_MAJOR "0") set(FLANG_VERSION_MINOR "1") set(FLANG_VERSION_PATCHLEVEL "0") @@ -234,59 +236,53 @@ endif() configure_file( ${CMAKE_CURRENT_SOURCE_DIR}/include/flang/Version.inc.in ${CMAKE_CURRENT_BINARY_DIR}/include/flang/Version.inc) -# Configure Flang's version info header file. +# Configure Flang's version info header file. configure_file( ${FLANG_SOURCE_DIR}/include/flang/Config/config.h.cmake ${FLANG_BINARY_DIR}/include/flang/Config/config.h) -# Add global F18 flags. -set(CMAKE_CXX_FLAGS "-fno-rtti -fno-exceptions -pedantic -Wall -Wextra -Werror -Wcast-qual -Wimplicit-fallthrough -Wdelete-non-virtual-dtor ${CMAKE_CXX_FLAGS}") - -# Builtin check_cxx_compiler_flag doesn't seem to work correctly -macro(check_compiler_flag flag resultVar) - unset(${resultVar} CACHE) - check_cxx_compiler_flag("${flag}" ${resultVar}) -endmacro() - -check_compiler_flag("-Werror -Wno-deprecated-copy" CXX_SUPPORTS_NO_DEPRECATED_COPY_FLAG) -if (CXX_SUPPORTS_NO_DEPRECATED_COPY_FLAG) -set(CMAKE_CXX_FLAGS "${CMAKE_CXX_FLAGS} -Wno-deprecated-copy") -endif() -check_compiler_flag("-Wstring-conversion" CXX_SUPPORTS_NO_STRING_CONVERSION_FLAG) -if (CXX_SUPPORTS_NO_STRING_CONVERSION_FLAG) -set(CMAKE_CXX_FLAGS "${CMAKE_CXX_FLAGS} -Wno-string-conversion") -endif() - # Add appropriate flags for GCC if (LLVM_COMPILER_IS_GCC_COMPATIBLE) - + set(CMAKE_CXX_FLAGS "${CMAKE_CXX_FLAGS} -fno-rtti -fno-exceptions") if (NOT "${CMAKE_CXX_COMPILER_ID}" MATCHES "Clang") set(CMAKE_CXX_FLAGS "${CMAKE_CXX_FLAGS} -fno-strict-aliasing -fno-semantic-interposition") else() set(CMAKE_CXX_FLAGS "${CMAKE_CXX_FLAGS} -Wno-unused-command-line-argument -Wstring-conversion \ -Wcovered-switch-default") - endif() # Clang. + + # The following works around warnings in the f18 sources. TODO: Should these move + # outside of GCC compatible block at some point? + + check_cxx_compiler_flag("-Werror -Wstring-conversion" CXX_SUPPORTS_NO_STRING_CONVERSION_FLAG) + if (CXX_SUPPORTS_NO_STRING_CONVERSION_FLAG) + set(CMAKE_CXX_FLAGS "${CMAKE_CXX_FLAGS} -Wno-string-conversion") + endif() + endif() # Clang. check_cxx_compiler_flag("-Werror -Wnested-anon-types" CXX_SUPPORTS_NO_NESTED_ANON_TYPES_FLAG) if (CXX_SUPPORTS_NO_NESTED_ANON_TYPES_FLAG) set(CMAKE_CXX_FLAGS "${CMAKE_CXX_FLAGS} -Wno-nested-anon-types") endif() - # Add to or adjust build type flags. - # - # TODO: This needs some extra thought. CMake's default for release builds + # Add to or adjust build type flags. + # + # TODO: This needs some extra thought. CMake's default for release builds # is -O3, which can cause build failures on certain platforms (and compilers) # with the current code base -- some templated functions are inlined and don't # become available at link time when using -O3 (with Clang under MacOS/darwin). - # If we reset CMake's default flags we also clobber any user provided settings; + # If we reset CMake's default flags we also clobber any user provided settings; # make it difficult to customize a build in this regard... The setup below - # has this side effect but enables successful builds across multiple platforms - # in release mode... - set(CMAKE_CXX_FLAGS_DEBUG "${CMAKE_CXX_FLAGS_DEBUG} -DDEBUGF18") - set(CMAKE_CXX_FLAGS_MINSIZEREL "${CMAKE_CXX_FLAGS_MINSIZEREL} -DCHECK=\"(void)\"") # do we need -O2 here? - set(CMAKE_CXX_FLAGS_RELEASE "-O2") + # has this side effect but enables successful builds across multiple platforms + # in release mode... + set(CMAKE_CXX_FLAGS_DEBUG "${CMAKE_CXX_FLAGS_DEBUG} -DDEBUGF18") + set(CMAKE_CXX_FLAGS_MINSIZEREL "${CMAKE_CXX_FLAGS_MINSIZEREL} -DCHECK=(void)") # do we need -O2 here? + set(CMAKE_CXX_FLAGS_RELEASE "-O2") + + if (GCC) + set(CMAKE_CXX_FLAGS "${CMAKE_CXX_FLAGS} --gcc-toolchain=${GCC}") + endif() - # Building shared libraries is bad for performance with GCC by default + # Building shared libraries is death on 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")) set(CMAKE_CXX_FLAGS_RELEASE "${CMAKE_CXX_FLAGS_RELEASE} -fno-semantic-interposition") @@ -330,11 +326,11 @@ if (FLANG_BUILD_TOOLS) endif() add_subdirectory(runtime) -if (FLANG_INCLUDE_TESTS) - enable_testing() - add_subdirectory(test) - add_subdirectory(unittests) -endif() +option(FLANG_INCLUDE_TESTS + "Generate build targets for the Flang unit tests." + ${LLVM_INCLUDE_TESTS}) +enable_testing() +add_subdirectory(test) option(FLANG_INCLUDE_DOCS "Generate build targets for the Flang docs." ${LLVM_INCLUDE_DOCS}) @@ -370,9 +366,10 @@ if (NOT LLVM_INSTALL_TOOLCHAIN_ONLY) FILES_MATCHING PATTERN "*.def" PATTERN "*.h" - PATTERN "*.inc" - PATTERN "*.td" + PATTERN "*.inc" PATTERN "config.h" EXCLUDE PATTERN ".git" EXCLUDE - PATTERN "CMakeFiles" EXCLUDE) + PATTERN "CMakeFiles" EXCLUDE + PATTERN "*") endif() + diff --git a/flang/README.md b/flang/README.md index 17f9939311bb19..e98cc1da7196b0 100644 --- a/flang/README.md +++ b/flang/README.md @@ -1,168 +1,68 @@ -# 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 +Yes, we've moved. This is now the working branch for FIR development. -Read more about flang in the [documentation directory](documentation). -Start with the [compiler overview](documentation/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](documentation/FortranForCProgrammers.md) -and -flang's specifications of the [Fortran grammar](documentation/f2018-grammar.txt) -and -the [OpenMP grammar](documentation/OpenMP-4.5-grammar.txt). +### In-tree build -Treatment of language extensions is covered -in [this document](documentation/Extensions.md). +1. Get the stuff. -To understand the compilers handling of intrinsics, -see the [discussion of intrinsics](documentation/Intrinsics.md). - -To understand how a flang program communicates with libraries at runtime, -see the discussion of [runtime descriptors](documentation/RuntimeDescriptor.md). - -If you're interested in contributing to the compiler, -read the [style guide](documentation/C++style.md) -and -also review [how flang uses modern C++ features](documentation/C++17.md). - -## Supported C++ compilers - -Flang is written in C++17. - -The code has been compiled and tested with -GCC versions from 7.2.0 to 9.3.0. - -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++. - -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. - -The code does not compile with Windows and a compiler that does not have -support for C++17. - -## 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. - -### LLVM dependency - -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`. - -We highly recommend using the same compiler to compile both llvm and flang. - -The flang CMakeList.txt file uses -the variable `LLVM_DIR` to find the installed LLVM components -and -the variable `MLIR_DIR` to find the installed MLIR components. - -To get the correct LLVM and MLIR libraries included in your flang build, -define LLVM_DIR and MLIR_DIR on the cmake command line. ``` -LLVM=/lib/cmake/llvm \ -MLIR=/lib/cmake/mlir \ -cmake -DLLVM_DIR=$LLVM -DMLIR_DIR=$MLIR ... + git clone git@github.com:flang-compiler/f18-llvm-project.git ``` -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. +2. Get "on" the right branches. ``` -export CXX=g++-8.3 + (cd f18-llvm-project ; git checkout fir-dev) ``` -or -``` -CXX=/opt/gcc-8.3/bin/g++-8.3 cmake ... -``` - -### 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++. +3. (not needed!) + +4. Create a build space for 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 + 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 ``` -### Installation Directory +5. Build everything -To specify a custom install location, -add -`-DCMAKE_INSTALL_PREFIX=` -to the cmake command -where `` -is the path where flang should be installed. +``` + make + make check-flang + make install +``` -### Build Types +### Out-of-tree build -To create a debug build, -add -`-DCMAKE_BUILD_TYPE=Debug` -to the cmake command. -Debug builds execute slowly. +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. -To create a release build, -add -`-DCMAKE_BUILD_TYPE=Release` -to the cmake command. -Release builds execute quickly. +1. Get the stuff is the same as above. Get the code from the same repos. -### Build Flang out of tree -``` -cd ~/flang/build -cmake -DLLVM_DIR=$LLVM -DMLIR_DIR=$MLIR ~/flang/src -make -``` -### How to Run the Regression Tests +2. Get on the right branches. Again, same as above. -To run all tests: -``` -cd ~/flang/build -cmake -DLLVM_DIR=$LLVM -DMLIR_DIR=$MLIR ~/flang/src -make test check-all -``` +3. Create a build space for cmake and make (or ninja) -To run individual regression tests llvm-lit needs to know the lit -configuration for flang. The parameters in charge of this are: -flang_site_config and flang_config. And they can be set as shown bellow: ``` -/llvm-lit \ - --param flang_site_config=/test-lit/lit.site.cfg.py \ - --param flang_config=/test-lit/lit.cfg.py \ - + mkdir build + cd build + export CC= + export CXX= + cmake ../llvm/flang -DCMAKE_PREFIX_PATH= -DCMAKE_BUILD_TYPE=Release -DLLVM_TARGETS_TO_BUILD=X86 -DCMAKE_CXX_STANDARD=17 + make + 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 7fe8b7e9f4062b..e83b6b97ebad24 100644 --- a/flang/cmake/modules/AddFlang.cmake +++ b/flang/cmake/modules/AddFlang.cmake @@ -1,3 +1,11 @@ +#===-- cmake/modules/AddFlang.cmake ----------------------------------------===# +# +# 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 +# +#===------------------------------------------------------------------------===# + macro(set_flang_windows_version_resource_properties name) if (DEFINED windows_resource_file) set_windows_version_resource_properties(${name} ${windows_resource_file} diff --git a/flang/documentation/BurnsideToFIR.md b/flang/documentation/BurnsideToFIR.md new file mode 100644 index 00000000000000..de4d1ff44dd9b5 --- /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.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.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.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.loop %i = %c1 to %m { + fir.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/CMakeLists.txt b/flang/include/flang/CMakeLists.txt index db5d26a83b5684..8fa6447f19be7f 100644 --- a/flang/include/flang/CMakeLists.txt +++ b/flang/include/flang/CMakeLists.txt @@ -1,3 +1 @@ -if(LINK_WITH_FIR) - add_subdirectory(Optimizer) -endif() +add_subdirectory(Optimizer) diff --git a/flang/include/flang/Common/enum-set.h b/flang/include/flang/Common/enum-set.h index 5346cceaadfabb..9470b3196b3b5b 100644 --- a/flang/include/flang/Common/enum-set.h +++ b/flang/include/flang/Common/enum-set.h @@ -16,7 +16,9 @@ #include "constexpr-bitset.h" #include "idioms.h" +#ifndef FORTRAN_IN_RUNTIME #include "llvm/Support/raw_ostream.h" +#endif #include #include #include @@ -206,6 +208,7 @@ template class EnumSet { } } +#ifndef FORTRAN_IN_RUNTIME llvm::raw_ostream &Dump( llvm::raw_ostream &o, std::string EnumToString(enumerationType)) const { char sep{'{'}; @@ -215,6 +218,7 @@ template class EnumSet { }); return o << (sep == '{' ? "{}" : "}"); } +#endif private: bitsetType bitset_{}; diff --git a/flang/include/flang/Evaluate/call.h b/flang/include/flang/Evaluate/call.h index 15fe5b879dc4c7..4814633d692c44 100644 --- a/flang/include/flang/Evaluate/call.h +++ b/flang/include/flang/Evaluate/call.h @@ -190,8 +190,9 @@ struct ProcedureDesignator { class ProcedureRef { public: CLASS_BOILERPLATE(ProcedureRef) - ProcedureRef(ProcedureDesignator &&p, ActualArguments &&a) - : proc_{std::move(p)}, arguments_(std::move(a)) {} + ProcedureRef(ProcedureDesignator &&p, ActualArguments &&a, bool alt = false) + : proc_{std::move(p)}, arguments_{std::move(a)}, hasAlternateReturns_{ + alt} {} ~ProcedureRef(); ProcedureDesignator &proc() { return proc_; } @@ -202,12 +203,14 @@ class ProcedureRef { std::optional> LEN() const; int Rank() const; bool IsElemental() const { return proc_.IsElemental(); } + bool HasAlternateReturns() const { return hasAlternateReturns_; } bool operator==(const ProcedureRef &) const; llvm::raw_ostream &AsFortran(llvm::raw_ostream &) const; protected: ProcedureDesignator proc_; ActualArguments arguments_; + bool hasAlternateReturns_; }; template class FunctionRef : public ProcedureRef { diff --git a/flang/include/flang/Lower/Bridge.h b/flang/include/flang/Lower/Bridge.h new file mode 100644 index 00000000000000..5ca2fc45ef326a --- /dev/null +++ b/flang/include/flang/Lower/Bridge.h @@ -0,0 +1,176 @@ +//===-- Lower/Bridge.h -- main interface to 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 +// +//===----------------------------------------------------------------------===// +/// +/// \file +/// Implements lowering. Convert Fortran source to +/// [MLIR](https://github.com/tensorflow/mlir). +/// +/// [Coding style](https://llvm.org/docs/CodingStandards.html) +/// +//===----------------------------------------------------------------------===// + +#ifndef FORTRAN_LOWER_BRIDGE_H_ +#define FORTRAN_LOWER_BRIDGE_H_ + +#include "flang/Common/Fortran.h" +#include "flang/Optimizer/Support/KindMapping.h" +#include "mlir/IR/Module.h" + +namespace Fortran { +namespace common { +class IntrinsicTypeDefaultKinds; +template +class Reference; +} // namespace common +namespace evaluate { +struct DataRef; +template +class Expr; +struct SomeType; +} // namespace evaluate +namespace parser { +class CharBlock; +class CookedSource; +struct Program; +} // namespace parser +namespace semantics { +class Symbol; +class SemanticsContext; +} // namespace semantics +} // namespace Fortran + +namespace llvm { +class Module; +class SourceMgr; +} // namespace llvm +namespace mlir { +class OpBuilder; +} +namespace fir { +struct NameUniquer; +} + +namespace Fortran::lower { + +using SomeExpr = evaluate::Expr; +using SymbolRef = common::Reference; +class FirOpBuilder; + +//===----------------------------------------------------------------------===// + +/// The abstract interface for converter implementations to lower Fortran +/// front-end fragments such as expressions, types, etc. to the FIR dialect of +/// MLIR. +class AbstractConverter { +public: + // + // Expressions + + /// Generate the address of the location holding the expression + virtual mlir::Value genExprAddr(const SomeExpr &, + mlir::Location *loc = nullptr) = 0; + mlir::Value genExprAddr(const SomeExpr *someExpr, mlir::Location loc) { + return genExprAddr(*someExpr, &loc); + } + + /// Generate the computations of the expression to produce a value + virtual mlir::Value genExprValue(const SomeExpr &, + mlir::Location *loc = nullptr) = 0; + mlir::Value genExprValue(const SomeExpr *someExpr, mlir::Location loc) { + return genExprValue(*someExpr, &loc); + } + + // + // Types + + /// Generate the type of a DataRef + virtual mlir::Type genType(const 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(common::TypeCategory tc) = 0; + /// Generate the type from a category and kind + virtual mlir::Type genType(common::TypeCategory tc, int kind) = 0; + + // + // Locations + + /// Get the converter's current location + virtual mlir::Location getCurrentLocation() = 0; + /// Generate a dummy location + virtual mlir::Location genLocation() = 0; + /// Generate the location as converted from a CharBlock + virtual mlir::Location genLocation(const parser::CharBlock &) = 0; + + // + // FIR/MLIR + + /// Get the OpBuilder + virtual Fortran::lower::FirOpBuilder &getFirOpBuilder() = 0; + /// Get the ModuleOp + virtual mlir::ModuleOp &getModuleOp() = 0; + /// Unique a symbol + virtual std::string mangleName(const 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; + + virtual ~AbstractConverter() = default; +}; + +//===----------------------------------------------------------------------===// + +/// The lowering bridge converts the front-end parse trees and semantics +/// checking residual to MLIR (FIR dialect) code. +class LoweringBridge { +public: + static LoweringBridge + create(const common::IntrinsicTypeDefaultKinds &defaultKinds, + const parser::CookedSource *cooked) { + return LoweringBridge{defaultKinds, cooked}; + } + + mlir::MLIRContext &getMLIRContext() { return *context.get(); } + mlir::ModuleOp &getModule() { return *module.get(); } + + void parseSourceFile(llvm::SourceMgr &); + + common::IntrinsicTypeDefaultKinds const &getDefaultKinds() { + return defaultKinds; + } + + bool validModule() { return getModule(); } + + const parser::CookedSource *getCookedSource() const { return cooked; } + + /// Cross the bridge from the Fortran parse-tree, etc. to FIR+OpenMP+MLIR + void lower(const parser::Program &program, fir::NameUniquer &uniquer, + const Fortran::semantics::SemanticsContext &semanticsContext); + + /// Get the kind map. + const fir::KindMapping &getKindMap() const { return kindMap; } + +private: + explicit LoweringBridge(const common::IntrinsicTypeDefaultKinds &defaultKinds, + const parser::CookedSource *cooked); + LoweringBridge() = delete; + LoweringBridge(const LoweringBridge &) = delete; + + const common::IntrinsicTypeDefaultKinds &defaultKinds; + const parser::CookedSource *cooked; + std::unique_ptr context; + std::unique_ptr module; + fir::KindMapping kindMap; +}; + +} // namespace Fortran::lower + +#endif // FORTRAN_LOWER_BRIDGE_H_ diff --git a/flang/include/flang/Lower/CharRT.h b/flang/include/flang/Lower/CharRT.h new file mode 100644 index 00000000000000..4be9480dbfb31c --- /dev/null +++ b/flang/include/flang/Lower/CharRT.h @@ -0,0 +1,36 @@ +//===-- Lower/CharRT.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_CHARRT_H +#define FORTRAN_LOWER_CHARRT_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_CHARRT_H diff --git a/flang/include/flang/Lower/ConvertExpr.h b/flang/include/flang/Lower/ConvertExpr.h new file mode 100644 index 00000000000000..453fbfdcc1f720 --- /dev/null +++ b/flang/include/flang/Lower/ConvertExpr.h @@ -0,0 +1,64 @@ +//===-- 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 +// +//===----------------------------------------------------------------------===// + +#ifndef FORTRAN_LOWER_CONVERT_EXPR_H +#define FORTRAN_LOWER_CONVERT_EXPR_H + +/// [Coding style](https://llvm.org/docs/CodingStandards.html) + +namespace mlir { +class Location; +class OpBuilder; +class Type; +class Value; +} // namespace mlir + +namespace fir { +class AllocaExpr; +} // namespace fir + +namespace Fortran { +namespace common { +class IntrinsicTypeDefaultKinds; +} // namespace common + +namespace evaluate { +template +class Expr; +struct SomeType; +} // namespace evaluate + +namespace semantics { +class Symbol; +} // namespace semantics + +namespace lower { + +class AbstractConverter; +class FirOpBuilder; +class SymMap; + +/// Create an expression. +/// Lowers `expr` to the FIR dialect of MLIR. The expression is lowered to a +/// value result. +mlir::Value createSomeExpression(mlir::Location loc, + AbstractConverter &converter, + const evaluate::Expr &expr, + SymMap &symMap); + +/// Create an address. +/// Lowers `expr` to the FIR dialect of MLIR. The expression must be an entity +/// and the address of the entity is returned. +mlir::Value createSomeAddress(mlir::Location loc, AbstractConverter &converter, + const evaluate::Expr &expr, + SymMap &symMap); + +} // namespace lower +} // namespace Fortran + +#endif // FORTRAN_LOWER_CONVERT_EXPR_H diff --git a/flang/include/flang/Lower/ConvertType.h b/flang/include/flang/Lower/ConvertType.h new file mode 100644 index 00000000000000..b7b58cf95833a2 --- /dev/null +++ b/flang/include/flang/Lower/ConvertType.h @@ -0,0 +1,115 @@ +//===-- Lower/ConvertType.h -- lowering of types ----------------*- 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_CONVERT_TYPE_H_ +#define FORTRAN_LOWER_CONVERT_TYPE_H_ + +/// 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 +/// conversions when lowering to FIR. This implements all lowering of parse +/// 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) + +#include "flang/Common/Fortran.h" +#include "mlir/IR/Types.h" + +namespace mlir { +class Location; +class MLIRContext; +class Type; +} // namespace mlir + +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 parser { +class CharBlock; +class CookedSource; +} // namespace parser + +namespace semantics { +class Symbol; +} // namespace semantics + +namespace lower { + +using SomeExpr = evaluate::Expr; +using SymbolRef = common::Reference; + +mlir::Type getFIRType(mlir::MLIRContext *ctxt, + common::IntrinsicTypeDefaultKinds const &defaults, + common::TypeCategory tc, int kind); +mlir::Type getFIRType(mlir::MLIRContext *ctxt, + common::IntrinsicTypeDefaultKinds const &defaults, + common::TypeCategory tc); + +mlir::Type +translateDataRefToFIRType(mlir::MLIRContext *ctxt, + common::IntrinsicTypeDefaultKinds const &defaults, + const evaluate::DataRef &dataRef); + +template +inline mlir::Type translateDesignatorToFIRType( + mlir::MLIRContext *ctxt, common::IntrinsicTypeDefaultKinds const &defaults, + const evaluate::Designator> &) { + return getFIRType(ctxt, defaults, TC, KIND); +} + +template +inline mlir::Type translateDesignatorToFIRType( + mlir::MLIRContext *ctxt, common::IntrinsicTypeDefaultKinds const &defaults, + const evaluate::Designator> &) { + return getFIRType(ctxt, defaults, TC); +} + +mlir::Type +translateSomeExprToFIRType(mlir::MLIRContext *ctxt, + common::IntrinsicTypeDefaultKinds const &defaults, + const SomeExpr *expr); + +mlir::Type +translateSymbolToFIRType(mlir::MLIRContext *ctxt, + common::IntrinsicTypeDefaultKinds const &defaults, + const SymbolRef symbol); + +mlir::FunctionType translateSymbolToFIRFunctionType( + mlir::MLIRContext *ctxt, common::IntrinsicTypeDefaultKinds const &defaults, + const SymbolRef symbol); + +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 + +#endif // FORTRAN_LOWER_CONVERT_TYPE_H_ diff --git a/flang/include/flang/Lower/FIRBuilder.h b/flang/include/flang/Lower/FIRBuilder.h new file mode 100644 index 00000000000000..0c7a916058e62d --- /dev/null +++ b/flang/include/flang/Lower/FIRBuilder.h @@ -0,0 +1,424 @@ +//===-- 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/Function.h" +#include "mlir/IR/Module.h" +#include "llvm/ADT/DenseMap.h" +#include "llvm/ADT/Optional.h" + +namespace Fortran::lower { + +class AbstractConverter; + +//===----------------------------------------------------------------------===// +// FirOpBuilder interface extensions +//===----------------------------------------------------------------------===// + +// TODO: Used CRTP to extend the FirOpBuilder interface, but this leads to some +// complex and downright ugly template code. + +/// Extension class to facilitate lowering of CHARACTER operation +template +class CharacterOpsBuilder { +public: + // access the implementation + T &impl() { return *static_cast(this); } + + /// 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); + + 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 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. + mlir::Type getLengthType(); +}; + +/// Extension class to facilitate lowering of COMPLEX manipulations in FIR. +template +class ComplexOpsBuilder { +public: + // The values of part enum members are meaningful for + // InsertValueOp and ExtractValueOp so they are explicit. + enum class Part { Real = 0, Imag = 1 }; + + // access the implementation + T &impl() { return *static_cast(this); } + + /// Type helper. They do not create MLIR operations. + mlir::Type getComplexPartType(mlir::Value cplx); + mlir::Type getComplexPartType(mlir::Type complexType); + + /// Complex operation creation helper. They create MLIR operations. + mlir::Value createComplex(fir::KindTy kind, mlir::Value real, + mlir::Value imag); + + /// Create a complex value. + mlir::Value createComplex(mlir::Location loc, mlir::Type complexType, + mlir::Value real, mlir::Value imag); + + mlir::Value extractComplexPart(mlir::Value cplx, bool isImagPart) { + return isImagPart ? extract(cplx) : extract(cplx); + } + + /// Returns (Real, Imag) pair of \p cplx + std::pair extractParts(mlir::Value cplx) { + return {extract(cplx), extract(cplx)}; + } + mlir::Value insertComplexPart(mlir::Value cplx, mlir::Value part, + bool isImagPart) { + return isImagPart ? insert(cplx, part) + : insert(cplx, part); + } + + mlir::Value createComplexCompare(mlir::Value cplx1, mlir::Value cplx2, + bool eq); + +protected: + template + mlir::Value extract(mlir::Value cplx) { + return impl().template createHere( + getComplexPartType(cplx), cplx, createPartId()); + } + + template + mlir::Value insert(mlir::Value cplx, mlir::Value part) { + return impl().template createHere( + cplx.getType(), cplx, part, createPartId()); + } + + template + mlir::Value createPartId() { + return impl().createIntegerConstant(impl().getIndexType(), + static_cast(partId)); + } +}; + +/// Extension class to facilitate lowering of COMPLEX manipulations in FIR. +template +class IntrinsicCallOpsBuilder { +public: + // access the implementation + T &impl() { return *static_cast(this); } + + // 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. + // TODO: Error handling interface ? + // TODO: Implementation is incomplete. Many intrinsics to tbd. + + /// 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. + mlir::Value genIntrinsicCall(llvm::StringRef name, mlir::Type resultType, + llvm::ArrayRef args); + /// Direct access to intrinsics that may be used by lowering outside + /// of intrinsic call lowering. + + /// Generate maximum. There must be at least one argument and all arguments + /// must have the same type. + mlir::Value genMax(llvm::ArrayRef args); + /// Generate minimum. Same constraints as genMax. + mlir::Value genMin(llvm::ArrayRef args); + /// Generate power function x**y with given the expected + /// result type. + mlir::Value genPow(mlir::Type resultType, mlir::Value x, mlir::Value y); +}; + +//===----------------------------------------------------------------------===// +// FirOpBuilder +//===----------------------------------------------------------------------===// + +/// Extends the MLIR OpBuilder to provide methods for building common FIR +/// patterns. +class FirOpBuilder : public mlir::OpBuilder, + public CharacterOpsBuilder, + public ComplexOpsBuilder, + public IntrinsicCallOpsBuilder { +public: + explicit FirOpBuilder(mlir::Operation *op, const fir::KindMapping &kindMap) + : OpBuilder{op}, kindMap{kindMap} {} + + /// TODO: remove this as caching the location may have the location + /// unexpectedly overridden along the way. + /// Set the current location. Used by createHere template method, etc. + void setLocation(mlir::Location loc) { currentLoc = loc; } + + /// Get the current location (if any) or return unknown location. + mlir::Location getLoc() { + return currentLoc.hasValue() ? currentLoc.getValue() : getUnknownLoc(); + } + + template + auto createHere(AS... args) { + return create(getLoc(), std::forward(args)...); + } + + 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(); + } + + 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(); } + + mlir::Type getRefType(mlir::Type eleTy); + + /// Create an integer constant of type \p type and value \p i. + mlir::Value createIntegerConstant(mlir::Type integerType, std::int64_t i); + + mlir::Value createRealConstant(mlir::Location loc, mlir::Type realType, + const llvm::APFloat &val); + + mlir::Value allocateLocal(mlir::Location loc, mlir::Type ty, + llvm::StringRef nm, + llvm::ArrayRef shape); + + /// 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 = {}); + + mlir::Value createTemporary(mlir::Type type, llvm::StringRef name = {}, + llvm::ArrayRef shape = {}) { + return createTemporary(getLoc(), type, name, shape); + } + + /// Create an unnamed and untracked temporary on the stack. + mlir::Value createTemporary(mlir::Type type, + llvm::ArrayRef shape) { + return createTemporary(getLoc(), 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); + } + + mlir::FuncOp createFunction(llvm::StringRef name, mlir::FunctionType ty) { + return createFunction(getLoc(), 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); + } + + mlir::FuncOp addNamedFunction(llvm::StringRef name, mlir::FunctionType ty) { + if (auto func = getNamedFunction(name)) + return func; + return createFunction(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); + } + + //===--------------------------------------------------------------------===// + // LoopOp helpers + //===--------------------------------------------------------------------===// + + 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. + void createLoop(mlir::Value lb, mlir::Value ub, mlir::Value step, + const BodyGenerator &bodyGenerator); + + /// Build loop [\p lb, \p ub] with step 1. + void createLoop(mlir::Value lb, mlir::Value ub, + const BodyGenerator &bodyGenerator); + + /// Build loop [0, \p count) with step 1. + void createLoop(mlir::Value count, const BodyGenerator &bodyGenerator); + + /// Cast the input value to IndexType. + mlir::Value convertToIndexType(mlir::Value val) { + return createConvert(getLoc(), getIndexType(), val); + } + +private: + llvm::Optional currentLoc{}; + const fir::KindMapping &kindMap; +}; + +} // namespace Fortran::lower + +#endif // FORTRAN_LOWER_FIRBUILDER_H diff --git a/flang/include/flang/Lower/IO.h b/flang/include/flang/Lower/IO.h new file mode 100644 index 00000000000000..4dd6715b258bf9 --- /dev/null +++ b/flang/include/flang/Lower/IO.h @@ -0,0 +1,99 @@ +//===-- Lower/IO.h -- lower I/O 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 +// +//===----------------------------------------------------------------------===// +/// +/// Experimental IO lowering to FIR + runtime. The Runtime design is under +/// design. +/// +/// FIXME This interface is also not final. Should it be based on parser::.. +/// nodes and lower expressions as needed or should it get every expression +/// already lowered as mlir::Value? (currently second options, not sure it will +/// provide enough information for complex IO statements). +/// +//===----------------------------------------------------------------------===// + +#ifndef FORTRAN_LOWER_IO_H +#define FORTRAN_LOWER_IO_H + +#include "llvm/ADT/DenseMap.h" + +namespace mlir { +class Value; +} // namespace mlir + +namespace Fortran { +namespace parser { +using Label = std::uint64_t; +struct BackspaceStmt; +struct CloseStmt; +struct EndfileStmt; +struct FlushStmt; +struct InquireStmt; +struct OpenStmt; +struct PrintStmt; +struct ReadStmt; +struct RewindStmt; +struct WaitStmt; +struct WriteStmt; +} // namespace parser + +namespace lower { + +class AbstractConverter; +class BridgeImpl; + +namespace pft { +struct Evaluation; +using LabelEvalMap = llvm::DenseMap; +} // namespace pft + +/// Generate IO call(s) for BACKSPACE; return the IOSTAT code +mlir::Value genBackspaceStatement(AbstractConverter &, + const parser::BackspaceStmt &); + +/// Generate IO call(s) for CLOSE; return the IOSTAT code +mlir::Value genCloseStatement(AbstractConverter &, const parser::CloseStmt &); + +/// Generate IO call(s) for ENDFILE; return the IOSTAT code +mlir::Value genEndfileStatement(AbstractConverter &, + const parser::EndfileStmt &); + +/// Generate IO call(s) for FLUSH; return the IOSTAT code +mlir::Value genFlushStatement(AbstractConverter &, const parser::FlushStmt &); + +/// Generate IO call(s) for INQUIRE; return the IOSTAT code +mlir::Value genInquireStatement(AbstractConverter &, + const parser::InquireStmt &); + +/// Generate IO call(s) for OPEN; return the IOSTAT code +mlir::Value genOpenStatement(AbstractConverter &, const parser::OpenStmt &); + +/// Generate IO call(s) for PRINT +void genPrintStatement(AbstractConverter &converter, + const parser::PrintStmt &stmt, + pft::LabelEvalMap &labelMap); + +/// Generate IO call(s) for READ; return the IOSTAT code +mlir::Value genReadStatement(AbstractConverter &converter, + const parser::ReadStmt &stmt, + pft::LabelEvalMap &labelMap); + +/// Generate IO call(s) for REWIND; return the IOSTAT code +mlir::Value genRewindStatement(AbstractConverter &, const parser::RewindStmt &); + +/// Generate IO call(s) for WAIT; return the IOSTAT code +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); + +} // namespace lower +} // namespace Fortran + +#endif // FORTRAN_LOWER_IO_H diff --git a/flang/include/flang/Lower/Mangler.h b/flang/include/flang/Lower/Mangler.h new file mode 100644 index 00000000000000..b13b51355c8121 --- /dev/null +++ b/flang/include/flang/Lower/Mangler.h @@ -0,0 +1,44 @@ +//===-- Lower/Mangler.h -- name mangling ------------------------*- 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_MANGLER_H_ +#define FORTRAN_LOWER_MANGLER_H_ + +#include + +namespace fir { +struct NameUniquer; +} + +namespace llvm { +class StringRef; +} + +namespace Fortran { +namespace common { +template +class Reference; +} + +namespace semantics { +class Symbol; +} + +namespace lower { +namespace mangle { + +/// Convert a front-end Symbol to an internal name +std::string mangleName(fir::NameUniquer &uniquer, const semantics::Symbol &); + +std::string demangleName(llvm::StringRef name); + +} // namespace mangle +} // namespace lower +} // namespace Fortran + +#endif // FORTRAN_LOWER_MANGLER_H_ diff --git a/flang/include/flang/Lower/PFTBuilder.h b/flang/include/flang/Lower/PFTBuilder.h index 733027cc425d8b..c7d28dc1bcbdd1 100644 --- a/flang/include/flang/Lower/PFTBuilder.h +++ b/flang/include/flang/Lower/PFTBuilder.h @@ -1,35 +1,35 @@ -//===-- include/flang/Lower/PFTBuilder.h ------------------------*- C++ -*-===// +//===-- Lower/PFTBuilder.h -- PFT 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 // //===----------------------------------------------------------------------===// +// +// PFT (Pre-FIR Tree) interface. +// +//===----------------------------------------------------------------------===// -#ifndef FORTRAN_LOWER_PFT_BUILDER_H_ -#define FORTRAN_LOWER_PFT_BUILDER_H_ +#ifndef FORTRAN_LOWER_PFTBUILDER_H +#define FORTRAN_LOWER_PFTBUILDER_H +#include "flang/Common/reference.h" #include "flang/Common/template.h" #include "flang/Parser/parse-tree.h" -#include - -/// Build a light-weight tree over the parse-tree to help with lowering to FIR. -/// It is named Pre-FIR Tree (PFT) to underline it has no other usage than -/// helping lowering to FIR. -/// The PFT will capture pointers back into the parse tree, so the parse tree -/// data structure may not be changed between the construction of the -/// PFT and all of its uses. -/// -/// The PFT captures a structured view of the program. The program is a list of -/// units. Function like units will contain lists of evaluations. Evaluations -/// are either statements or constructs, where a construct contains a list of -/// evaluations. The resulting PFT structure can then be used to create FIR. +#include "llvm/ADT/DenseMap.h" +#include "llvm/ADT/SmallSet.h" +#include "llvm/Support/raw_ostream.h" -namespace llvm { -class raw_ostream; +namespace mlir { +class Block; } -namespace Fortran::lower { +namespace Fortran { +namespace semantics { +class SemanticsContext; +class Scope; +} // namespace semantics +namespace lower { namespace pft { struct Evaluation; @@ -37,44 +37,19 @@ struct Program; struct ModuleLikeUnit; struct FunctionLikeUnit; -// TODO: A collection of Evaluations can obviously be any of the container -// types; leaving this as a std::list _for now_ because we reserve the right to -// insert PFT nodes in any order in O(1) time. -using EvaluationCollection = std::list; +// Using std::list for a list of Evaluations preserves the option to do +// O(1) time insertions anywhere. +using EvaluationList = std::list; +using LabelEvalMap = llvm::DenseMap; -struct ParentType { +struct ParentVariant { template - ParentType(A &parent) : p{&parent} {} + ParentVariant(A &parentVariant) : p{&parentVariant} {} const std::variant p; }; -/// Flags to describe the impact of parse-trees nodes on the program -/// control flow. These annotations to parse-tree nodes are later used to -/// build the control flow graph when lowering to FIR. -enum class CFGAnnotation { - None, // Node does not impact control flow. - Goto, // Node acts like a goto on the control flow. - CondGoto, // Node acts like a conditional goto on the control flow. - IndGoto, // Node acts like an indirect goto on the control flow. - IoSwitch, // Node is an IO statement with ERR, END, or EOR specifier. - Switch, // Node acts like a switch on the control flow. - Iterative, // Node creates iterations in the control flow. - FirStructuredOp, // Node is a structured loop. - Return, // Node triggers a return from the current procedure. - Terminate // Node terminates the program. -}; - -/// Compiler-generated jump -/// -/// This is used to convert implicit control-flow edges to explicit form in the -/// decorated PFT -struct CGJump { - CGJump(Evaluation &to) : target{to} {} - Evaluation ⌖ -}; - /// Classify the parse-tree nodes from ExecutablePartConstruct using ActionStmts = std::tuple< @@ -95,15 +70,6 @@ using ActionStmts = std::tuple< using OtherStmts = std::tuple; -using Constructs = - std::tuple; - using ConstructStmts = std::tuple< parser::AssociateStmt, parser::EndAssociateStmt, parser::BlockStmt, parser::EndBlockStmt, parser::SelectCaseStmt, parser::CaseStmt, @@ -115,257 +81,355 @@ using ConstructStmts = std::tuple< parser::MaskedElsewhereStmt, parser::ElsewhereStmt, parser::EndWhereStmt, parser::ForallConstructStmt, parser::EndForallStmt>; +using Constructs = + std::tuple; + template -constexpr static bool isActionStmt{common::HasMember}; +static constexpr bool isActionStmt{common::HasMember}; template -constexpr static bool isConstruct{common::HasMember}; +static constexpr bool isOtherStmt{common::HasMember}; template -constexpr static bool isConstructStmt{common::HasMember}; +static constexpr bool isConstructStmt{common::HasMember}; template -constexpr static bool isOtherStmt{common::HasMember}; +static constexpr bool isConstruct{common::HasMember}; template -constexpr static bool isGenerated{std::is_same_v}; +static constexpr bool isIntermediateConstructStmt{common::HasMember< + A, std::tuple>}; template -constexpr static bool isFunctionLike{common::HasMember< +static constexpr bool isNopConstructStmt{common::HasMember< + A, std::tuple>}; + +template +static constexpr bool isFunctionLike{common::HasMember< A, std::tuple>}; -/// Function-like units can contains lists of evaluations. These can be -/// (simple) statements or constructs, where a construct contains its own -/// evaluations. -struct Evaluation { - using EvalTuple = common::CombineTuples; - - /// Hide non-nullable pointers to the parse-tree node. - template - using MakeRefType = const A *const; - using EvalVariant = - common::CombineVariants, - std::variant>; - template - constexpr auto visit(A visitor) const { - return std::visit(common::visitors{ - [&](const auto *p) { return visitor(*p); }, - [&](auto &r) { return visitor(r); }, - }, - u); +using LabelSet = llvm::SmallSet; +using SymbolRef = common::Reference; +using SymbolLabelMap = llvm::DenseMap; + +/// Provide a variant like container that can holds constant references. +/// It is used in the other classes to provide union of const references +/// to parse-tree nodes. +template +class ReferenceVariant { +public: + template + using ConstRef = common::Reference; + + ReferenceVariant() = delete; + template + ReferenceVariant(const B &b) : u{ConstRef{b}} {} + + template + constexpr const B &get() const { + return std::get> > (u).get(); } - template - constexpr const A *getIf() const { - if constexpr (!std::is_same_v) { - if (auto *ptr{std::get_if>(&u)}) { - return *ptr; - } - } else { - return std::get_if(&u); - } - return nullptr; + template + constexpr const B *getIf() const { + auto *ptr = std::get_if>(&u); + return ptr ? &ptr->get() : nullptr; } - template + template constexpr bool isA() const { - if constexpr (!std::is_same_v) { - return std::holds_alternative>(u); - } - return std::holds_alternative(u); + return std::holds_alternative>(u); + } + template + constexpr auto visit(VISITOR &&visitor) const { + return std::visit( + common::visitors{[&visitor](auto ref) { return visitor(ref.get()); }}, + u); } - Evaluation() = delete; - Evaluation(const Evaluation &) = delete; - Evaluation(Evaluation &&) = default; +private: + std::variant...> u; +}; + +template +struct MakeReferenceVariantHelper {}; +template +struct MakeReferenceVariantHelper> { + using type = ReferenceVariant; +}; +template +struct MakeReferenceVariantHelper> { + using type = ReferenceVariant; +}; +template +using MakeReferenceVariant = typename MakeReferenceVariantHelper::type; + +using EvaluationTuple = + common::CombineTuples; +/// Hide non-nullable pointers to the parse-tree node. +/// Build type std::variant +/// from EvaluationTuple type (std::tuple). +using EvaluationVariant = MakeReferenceVariant; + +/// Function-like units contain lists of evaluations. These can be simple +/// statements or constructs, where a construct contains its own evaluations. +struct Evaluation : EvaluationVariant { /// General ctor template - Evaluation(const A &a, const ParentType &p, const parser::CharBlock &pos, - const std::optional &lab) - : u{&a}, parent{p}, pos{pos}, lab{lab} {} - - /// Compiler-generated jump - Evaluation(const CGJump &jump, const ParentType &p) - : u{jump}, parent{p}, cfg{CFGAnnotation::Goto} {} + Evaluation(const A &a, const ParentVariant &parentVariant, + const parser::CharBlock &position, + const std::optional &label) + : EvaluationVariant{a}, + parentVariant{parentVariant}, position{position}, label{label} {} /// Construct ctor template - Evaluation(const A &a, const ParentType &parent) : u{&a}, parent{parent} { + Evaluation(const A &a, const ParentVariant &parentVariant) + : EvaluationVariant{a}, parentVariant{parentVariant} { static_assert(pft::isConstruct, "must be a construct"); } - constexpr bool isActionOrGenerated() const { + /// Evaluation classification predicates. + constexpr bool isActionStmt() const { return visit(common::visitors{ - [](auto &r) { - using T = std::decay_t; - return isActionStmt || isGenerated; - }, - }); + [](auto &r) { return pft::isActionStmt>; }}); } - - constexpr bool isStmt() const { + constexpr bool isOtherStmt() const { return visit(common::visitors{ - [](auto &r) { - using T = std::decay_t; - static constexpr bool isStmt{isActionStmt || isOtherStmt || - isConstructStmt}; - static_assert(!(isStmt && pft::isConstruct), - "statement classification is inconsistent"); - return isStmt; - }, - }); + [](auto &r) { return pft::isOtherStmt>; }}); } - constexpr bool isConstruct() const { return !isStmt(); } - - /// Set the type of originating control flow type for this evaluation. - void setCFG(CFGAnnotation a, Evaluation *cstr) { - cfg = a; - setBranches(cstr); + constexpr bool isConstructStmt() const { + return visit(common::visitors{[](auto &r) { + return pft::isConstructStmt>; + }}); } - - /// Is this evaluation a control-flow origin? (The PFT must be annotated) - bool isControlOrigin() const { return cfg != CFGAnnotation::None; } - - /// Is this evaluation a control-flow target? (The PFT must be annotated) - bool isControlTarget() const { return isTarget; } - - /// Set the containsBranches flag iff this evaluation (a construct) contains - /// control flow - void setBranches() { containsBranches = true; } - - EvaluationCollection *getConstructEvals() { - auto *evals{subs.get()}; - if (isStmt() && !evals) { - return nullptr; - } - if (isConstruct() && evals) { - return evals; - } - llvm_unreachable("evaluation subs is inconsistent"); - return nullptr; + constexpr bool isConstruct() const { + return visit(common::visitors{ + [](auto &r) { return pft::isConstruct>; }}); } - /// Set that the construct `cstr` (if not a nullptr) has branches. - static void setBranches(Evaluation *cstr) { - if (cstr) - cstr->setBranches(); + /// For a construct with multiway control-flow semantics, return true if this + /// is one of the alternative condition statements of the construct. For + /// example, `ELSE IF` in an `IF` construct. + constexpr bool isIntermediateConstructStmt() const { + return visit(common::visitors{[](auto &r) { + return pft::isIntermediateConstructStmt>; + }}); + } + constexpr bool isNopConstructStmt() const { + return visit(common::visitors{[](auto &r) { + return pft::isNopConstructStmt>; + }}); } - EvalVariant u; - ParentType parent; - parser::CharBlock pos; - std::optional lab; - std::unique_ptr subs; // construct sub-statements - CFGAnnotation cfg{CFGAnnotation::None}; - bool isTarget{false}; // this evaluation is a control target - bool containsBranches{false}; // construct contains branches + /// Return FunctionLikeUnit to which this evaluation + /// belongs. Nullptr if it does not belong to such unit. + FunctionLikeUnit *getOwningProcedure() const; + + bool lowerAsStructured() const; + bool lowerAsUnstructured() const; + + // FIR generation looks primarily at PFT statement (leaf) nodes. So members + // such as lexicalSuccessor and the various block fields are only applicable + // to statement nodes. One exception is that an internal construct node is + // a convenient place for a constructExit link that applies to exits from any + // statement within the construct. The controlSuccessor member is used for + // nonlexical successors, such as linking to a GOTO target. For multiway + // branches, controlSuccessor is set to one of the targets (might as well be + // the first target). Successor and exit links always target statements. + // + // An unstructured construct is one that contains some form of goto. This + // is indicated by the isUnstructured member flag, which may be set on a + // statement and propagated to enclosing constructs. This distinction allows + // a structured IF or DO statement to be materialized with custom structured + // FIR operations. An unstructured statement is materialized as mlir + // operation sequences that include explicit branches. + // + // There are two mlir::Block members. The block member is set for statements + // that begin a new block. If a statement may have more than one associated + // block, this member must be the block that would be the target of a branch + // to the statement. The prime example of a statement that may have multiple + // associated blocks is NonLabelDoStmt, which may have a loop preheader block + // for loop initialization code, and always has a header block that is the + // target of the loop back edge. If the NonLabelDoStmt is a concurrent loop, + // there may be an arbitrary number of nested preheader, header, and mask + // blocks. Any such additional blocks in the localBlocks member are local + // to a construct and cannot be the target of an unstructured branch. For + // NonLabelDoStmt, the block member designates the preheader block, which may + // be absent if loop initialization code may be appended to a predecessor + // block. The primary loop header block is localBlocks[0], with additional + // DO CONCURRENT blocks at localBlocks[1], etc. + // + // The printIndex member is only set for statements. It is used for dumps + // and does not affect FIR generation. It may also be helpful for debugging. + + ParentVariant parentVariant; + parser::CharBlock position{}; + std::optional label{}; + std::unique_ptr evaluationList; // nested evaluations + Evaluation *parentConstruct{nullptr}; // set for nodes below the top level + Evaluation *lexicalSuccessor{nullptr}; // set for ActionStmt, ConstructStmt + Evaluation *controlSuccessor{nullptr}; // set for some statements + Evaluation *constructExit{nullptr}; // set for constructs + bool isNewBlock{false}; // evaluation begins a new basic block + bool isUnstructured{false}; // evaluation has unstructured control flow + bool skip{false}; // evaluation has been processed in advance + class mlir::Block *block{nullptr}; // isNewBlock block + llvm::SmallVector localBlocks{}; // construct local blocks + int printIndex{0}; // (ActionStmt, ConstructStmt) evaluation index for dumps }; +using ProgramVariant = + ReferenceVariant; /// A program is a list of program units. -/// These units can be function like, module like, or block data -struct ProgramUnit { +/// These units can be function like, module like, or block data. +struct ProgramUnit : ProgramVariant { template - ProgramUnit(const A &ptr, const ParentType &parent) - : p{&ptr}, parent{parent} {} + ProgramUnit(const A &p, const ParentVariant &parentVariant) + : ProgramVariant{p}, parentVariant{parentVariant} {} ProgramUnit(ProgramUnit &&) = default; ProgramUnit(const ProgramUnit &) = delete; - const std::variant< - const parser::MainProgram *, const parser::FunctionSubprogram *, - const parser::SubroutineSubprogram *, const parser::Module *, - const parser::Submodule *, const parser::SeparateModuleSubprogram *, - const parser::BlockData *> - p; - ParentType parent; + ParentVariant parentVariant; }; -/// Function-like units have similar structure. They all can contain executable -/// statements as well as other function-like units (internal procedures and -/// function statements). +/// A variable captures an object to be created per the declaration part of a +/// function like unit. +struct Variable { + explicit Variable(const Fortran::semantics::Symbol &sym, bool global = false, + int depth = 0) + : sym{&sym}, depth{depth}, global{global} {} + + const Fortran::semantics::Symbol &getSymbol() const { return *sym; } + bool isGlobal() const { return global; } + int getDepth() const { return depth; } + +private: + const Fortran::semantics::Symbol *sym; + int depth; + bool global; + //bool heap{false}; // variable needs deallocation on exit +}; + +/// Function-like units may contain evaluations (executable statements) and +/// nested function-like units (internal procedures and function statements). struct FunctionLikeUnit : public ProgramUnit { // wrapper statements for function-like syntactic structures using FunctionStatement = - std::variant *, - const parser::Statement *, - const parser::Statement *, - const parser::Statement *, - const parser::Statement *, - const parser::Statement *, - const parser::Statement *, - const parser::Statement *>; - - FunctionLikeUnit(const parser::MainProgram &f, const ParentType &parent); - FunctionLikeUnit(const parser::FunctionSubprogram &f, - const ParentType &parent); - FunctionLikeUnit(const parser::SubroutineSubprogram &f, - const ParentType &parent); - FunctionLikeUnit(const parser::SeparateModuleSubprogram &f, - const ParentType &parent); + ReferenceVariant, + parser::Statement, + parser::Statement, + parser::Statement, + parser::Statement, + parser::Statement, + parser::Statement, + parser::Statement>; + + FunctionLikeUnit( + const parser::MainProgram &f, const ParentVariant &parentVariant, + const Fortran::semantics::SemanticsContext &semanticsContext); + FunctionLikeUnit( + const parser::FunctionSubprogram &f, const ParentVariant &parentVariant, + const Fortran::semantics::SemanticsContext &semanticsContext); + FunctionLikeUnit( + const parser::SubroutineSubprogram &f, const ParentVariant &parentVariant, + const Fortran::semantics::SemanticsContext &semanticsContext); + FunctionLikeUnit( + const parser::SeparateModuleSubprogram &f, + const ParentVariant &parentVariant, + const Fortran::semantics::SemanticsContext &semanticsContext); FunctionLikeUnit(FunctionLikeUnit &&) = default; FunctionLikeUnit(const FunctionLikeUnit &) = delete; - bool isMainProgram() { - return std::holds_alternative< - const parser::Statement *>(endStmt); + void processSymbolTable(const Fortran::semantics::Scope &); + + std::vector getOrderedSymbolTable() { return varList[0]; } + + bool isMainProgram() const { + return endStmt.isA>(); } - const parser::FunctionStmt *getFunction() { - return getA(); + + /// 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); } - const parser::SubroutineStmt *getSubroutine() { - return getA(); + + /// Returns reference to the subprogram symbol of this FunctionLikeUnit. + /// Dies if the FunctionLikeUnit is not a subprogram. + const semantics::Symbol &getSubprogramSymbol() const { + assert(symbol && "not inside a procedure"); + return *symbol; } - const parser::MpSubprogramStmt *getMPSubp() { - return getA(); + + /// 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; }}); } /// Anonymous programs do not have a begin statement std::optional beginStmt; FunctionStatement endStmt; - EvaluationCollection evals; // statements - std::list funcs; // internal procedures - -private: - template - const A *getA() { - if (beginStmt) { - if (auto p = - std::get_if *>(&beginStmt.value())) - return &(*p)->statement; - } - return nullptr; - } + EvaluationList evaluationList; + LabelEvalMap labelEvaluationMap; + SymbolLabelMap assignSymbolLabelMap; + std::list nestedFunctions; + /// Symbol associated to this FunctionLikeUnit. + /// Null if the FunctionLikeUnit is an anonymous program. + /// The symbol has MainProgramDetails for named programs, otherwise it has + /// SubprogramDetails. + const semantics::Symbol *symbol{nullptr}; + /// Terminal basic block (if any) + mlir::Block *finalBlock{}; + std::vector> varList; }; -/// Module-like units have similar structure. They all can contain a list of -/// function-like units. +/// Module-like units contain a list of function-like units. struct ModuleLikeUnit : public ProgramUnit { // wrapper statements for module-like syntactic structures using ModuleStatement = - std::variant *, - const parser::Statement *, - const parser::Statement *, - const parser::Statement *>; - - ModuleLikeUnit(const parser::Module &m, const ParentType &parent); - ModuleLikeUnit(const parser::Submodule &m, const ParentType &parent); + ReferenceVariant, + parser::Statement, + parser::Statement, + parser::Statement>; + + ModuleLikeUnit(const parser::Module &m, const ParentVariant &parentVariant); + ModuleLikeUnit(const parser::Submodule &m, + const ParentVariant &parentVariant); ~ModuleLikeUnit() = default; ModuleLikeUnit(ModuleLikeUnit &&) = default; ModuleLikeUnit(const ModuleLikeUnit &) = delete; ModuleStatement beginStmt; ModuleStatement endStmt; - std::list funcs; + std::list nestedFunctions; }; struct BlockDataUnit : public ProgramUnit { - BlockDataUnit(const parser::BlockData &bd, const ParentType &parent); + BlockDataUnit(const parser::BlockData &bd, + const ParentVariant &parentVariant); BlockDataUnit(BlockDataUnit &&) = default; BlockDataUnit(const BlockDataUnit &) = delete; }; -/// A Program is the top-level PFT +/// A Program is the top-level root of the PFT. struct Program { using Units = std::variant; @@ -375,23 +439,31 @@ struct Program { std::list &getUnits() { return units; } + /// LLVM dump method on a Program. + void dump(); + private: std::list units; }; } // namespace pft -/// Create an PFT from the parse tree -std::unique_ptr createPFT(const parser::Program &root); - -/// Decorate the PFT with control flow annotations +/// Create a PFT (Pre-FIR Tree) from the parse tree. /// -/// The PFT must be decorated with control-flow annotations to prepare it for -/// use in generating a CFG-like structure. -void annotateControl(pft::Program &); - -void dumpPFT(llvm::raw_ostream &o, pft::Program &); - -} // namespace Fortran::lower - -#endif // FORTRAN_LOWER_PFT_BUILDER_H_ +/// A PFT is a light weight tree over the parse tree that is used to create FIR. +/// The PFT captures pointers back into the parse tree, so the parse tree must +/// not be changed between the construction of the PFT and its last use. The +/// PFT captures a structured view of a program. A program is a list of units. +/// A function like unit contains a list of evaluations. An evaluation is +/// either a statement, or a construct with a nested list of evaluations. +std::unique_ptr +createPFT(const parser::Program &root, + const Fortran::semantics::SemanticsContext &semanticsContext); + +/// Dumper for displaying a PFT. +void dumpPFT(llvm::raw_ostream &outputStream, pft::Program &pft); + +} // namespace lower +} // namespace Fortran + +#endif // FORTRAN_LOWER_PFTBUILDER_H diff --git a/flang/include/flang/Lower/Runtime.h b/flang/include/flang/Lower/Runtime.h new file mode 100644 index 00000000000000..db01f584430758 --- /dev/null +++ b/flang/include/flang/Lower/Runtime.h @@ -0,0 +1,209 @@ +//===-- Lower/Runtime.h -- Fortran runtime codegen 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 +// +//===----------------------------------------------------------------------===// +// +// 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_RUNTIME_H_ +#define FORTRAN_LOWER_RUNTIME_H_ + +// use std::optional to effect constexpr evaluation +#include + +namespace llvm { +class StringRef; +} +namespace mlir { +class Type; +class FunctionType; +class MLIRContext; +class FuncOp; +} // namespace mlir + +namespace Fortran::lower { + +class FirOpBuilder; + +//===----------------------------------------------------------------------===// +// C++ does not provide variable size constexpr container yet. StaticVector is +// a class that can be used to hold constexpr data as if it was a vector (i.e, +// the number of element is not reflected in the container type). This is +// useful to use in classes that need to be constexpr and where leaking the +// size as a template type would make it harder to manipulate. It can hold +// whatever data that can appear as non-type templates (integers, enums, +// pointer to objects, function pointers...). +// +// Example usage: +// +// enum class Enum {A, B}; +// constexpr StaticVector vec{StaticVector::create()}; +// for (const Enum& code : vec) { /*...*/ } +// +//===----------------------------------------------------------------------===// + +/// This is the class where the constexpr data is "allocated". In fact +/// the data is stored "in" the type. Objects of this type are not meant to +/// be ever constructed. +template +struct StaticVectorStorage { + static constexpr T values[]{v...}; + static constexpr const T *start{&values[0]}; + static constexpr const T *end{start + sizeof...(v)}; +}; + +template +struct StaticVectorStorage { + static constexpr const T *start{nullptr}, *end{nullptr}; +}; + +/// StaticVector cannot be directly constructed, instead its +/// `create` static method has to be used to create StaticVector objects. +/// StaticVector are views over the StaticVectorStorage type that was built +/// while instantiating the create method. They do not duplicate the values from +/// these read-only storages. +template +struct StaticVector { + template + static constexpr StaticVector create() { + using storage = StaticVectorStorage; + return StaticVector{storage::start, storage::end}; + } + using const_iterator = const T *; + constexpr const_iterator begin() const { return startPtr; } + constexpr const_iterator end() const { return endPtr; } + const T *startPtr{nullptr}; + const T *endPtr{nullptr}; +}; + +/// Define a simple static runtime description that different runtime can +/// derived from (e.g io, maths ...). +/// This base class only define enough to generate the functuion declarations, +/// it is up to the actual runtime descriptions to define a way to organize +/// these descriptions in a meaningful way. +/// It is constexpr constructible so that static tables of such descriptions can +/// be safely stored as global variables without requiring global constructors. +class RuntimeStaticDescription { +public: + /// Define possible runtime function argument/return type used in signature + /// descriptions. They follow mlir standard types naming. MLIR types cannot + /// directly be used because they can only be dynamically built. + enum TypeCode { i32, i64, f32, f64, c32, c64, boolean, charPtr, IOCookie }; + using MaybeTypeCode = std::optional; // for results + using TypeCodeVector = StaticVector; // for arguments + static constexpr MaybeTypeCode voidTy{MaybeTypeCode{std::nullopt}}; + + constexpr RuntimeStaticDescription(const char *s, MaybeTypeCode r, + TypeCodeVector a) + : symbol{s}, resultTypeCode{r}, argumentTypeCodes{a} {} + const char *getSymbol() const { return symbol; } + /// Conversion between types of the static representation and MLIR types. + mlir::FunctionType getMLIRFunctionType(mlir::MLIRContext *) const; + mlir::FuncOp getFuncOp(Fortran::lower::FirOpBuilder &builder) const; + static mlir::Type getMLIRType(TypeCode, mlir::MLIRContext *); + +private: + const char *symbol{nullptr}; + MaybeTypeCode resultTypeCode; + TypeCodeVector argumentTypeCodes; +}; + +/// StaticMultimapView is a constexpr friendly multimap +/// implementation over sorted constexpr arrays. +/// As the View name suggests, it does not duplicate the +/// sorted array but only brings range and search concepts +/// over it. It provides compile time search and can also +/// provide dynamic search (currently linear, can be improved to +/// log(n) due to the sorted array property). + +// TODO: Find a better place for this if this is retained. +// This is currently here because this was designed to provide +// maps over runtime description without the burden of having to +// instantiate these maps dynamically and to keep them somewhere. +template +class StaticMultimapView { +public: + using Key = typename V::Key; + struct Range { + using const_iterator = const V *; + constexpr const_iterator begin() const { return startPtr; } + constexpr const_iterator end() const { return endPtr; } + constexpr bool empty() const { + return startPtr == nullptr || endPtr == nullptr || endPtr <= startPtr; + } + constexpr std::size_t size() const { + return empty() ? 0 : static_cast(endPtr - startPtr); + } + const V *startPtr{nullptr}; + const V *endPtr{nullptr}; + }; + using const_iterator = typename Range::const_iterator; + + template + constexpr StaticMultimapView(const V (&array)[N]) + : range{&array[0], &array[0] + N} {} + template + constexpr bool verify() { + // TODO: sorted + // non empty increasing pointer direction + return !range.empty(); + } + constexpr const_iterator begin() const { return range.begin(); } + constexpr const_iterator end() const { return range.end(); } + + // Assume array is sorted. + // TODO make it a log(n) search based on sorted property + // std::equal_range will be constexpr in C++20 only. + constexpr Range getRange(const Key &key) const { + bool matched{false}; + const V *start{nullptr}, *end{nullptr}; + for (const auto &desc : range) { + if (desc.key == key) { + if (!matched) { + start = &desc; + matched = true; + } + } else if (matched) { + end = &desc; + matched = false; + } + } + if (matched) { + end = range.end(); + } + return Range{start, end}; + } + + constexpr std::pair + equal_range(const Key &key) const { + Range range{getRange(key)}; + return {range.begin(), range.end()}; + } + + constexpr typename Range::const_iterator find(Key key) const { + const Range subRange{getRange(key)}; + return subRange.size() == 1 ? subRange.begin() : end(); + } + +private: + Range range{nullptr, nullptr}; +}; + +// Define Fortran statement related runtime (other than IO and maths) + +mlir::FuncOp genStopStatementRuntime(FirOpBuilder &); +mlir::FuncOp genStopStatementTextRuntime(FirOpBuilder &); +mlir::FuncOp genFailImageStatementRuntime(FirOpBuilder &); +mlir::FuncOp genProgramEndStatementRuntime(FirOpBuilder &); + +} // namespace Fortran::lower + +#endif // FORTRAN_LOWER_RUNTIME_H_ diff --git a/flang/include/flang/Lower/Utils.h b/flang/include/flang/Lower/Utils.h new file mode 100644 index 00000000000000..d7c7b565dbc6aa --- /dev/null +++ b/flang/include/flang/Lower/Utils.h @@ -0,0 +1,31 @@ +//===-- 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/Optimizer/Analysis/IteratedDominanceFrontier.h b/flang/include/flang/Optimizer/Analysis/IteratedDominanceFrontier.h new file mode 100644 index 00000000000000..5f686d59474569 --- /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 OPTIMIZER_ANALYSIS_IDF_H +#define OPTIMIZER_ANALYSIS_IDF_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 // OPTIMIZER_ANALYSIS_IDF_H diff --git a/flang/include/flang/Optimizer/Support/KindMapping.h b/flang/include/flang/Optimizer/Support/KindMapping.h index 8c8ed1f24afddd..e0a71ce207ae15 100644 --- a/flang/include/flang/Optimizer/Support/KindMapping.h +++ b/flang/include/flang/Optimizer/Support/KindMapping.h @@ -1,4 +1,4 @@ -//===-- Optimizer/Support/KindMapping.h -------------------------*- C++ -*-===// +//===-- Optimizer/Support/KindMapping.h -- support kind mapping -*- C++ -*-===// // // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. // See https://llvm.org/LICENSE.txt for license information. @@ -14,15 +14,9 @@ #include "llvm/IR/Type.h" namespace llvm { -template -class Optional; struct fltSemantics; } // namespace llvm -namespace mlir { -class MLIRContext; -} // namespace mlir - namespace fir { /// The kind mapping is an encoded string that informs FIR how the Fortran KIND @@ -57,24 +51,24 @@ class KindMapping { explicit KindMapping(mlir::MLIRContext *context, llvm::StringRef map); /// Get the size in bits of !fir.char - Bitsize getCharacterBitsize(KindTy kind); + Bitsize getCharacterBitsize(KindTy kind) const; /// Get the size in bits of !fir.int - Bitsize getIntegerBitsize(KindTy kind); + Bitsize getIntegerBitsize(KindTy kind) const; /// Get the size in bits of !fir.logical - Bitsize getLogicalBitsize(KindTy kind); + Bitsize getLogicalBitsize(KindTy kind) const; /// Get the LLVM Type::TypeID of !fir.real - LLVMTypeID getRealTypeID(KindTy kind); + LLVMTypeID getRealTypeID(KindTy kind) const; /// Get the LLVM Type::TypeID of !fir.complex - LLVMTypeID getComplexTypeID(KindTy kind); + LLVMTypeID getComplexTypeID(KindTy kind) const; mlir::MLIRContext *getContext() const { return context; } /// Get the float semantics of !fir.real - const llvm::fltSemantics &getFloatSemantics(KindTy kind); + const llvm::fltSemantics &getFloatSemantics(KindTy kind) const; private: MatchResult badMapString(const llvm::Twine &ptr); diff --git a/flang/include/flang/Optimizer/Transforms/Passes.h b/flang/include/flang/Optimizer/Transforms/Passes.h new file mode 100644 index 00000000000000..a7530d865d957e --- /dev/null +++ b/flang/include/flang/Optimizer/Transforms/Passes.h @@ -0,0 +1,42 @@ +//===-- Optimizer/Transforms/Passes.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 OPTIMIZER_TRANSFORMS_PASSES_H +#define OPTIMIZER_TRANSFORMS_PASSES_H + +#include + +namespace mlir { +class Pass; +} // namespace mlir + +namespace fir { + +/// Convert fir.select_type to the standard dialect +std::unique_ptr createControlFlowLoweringPass(); + +/// Effects aware CSE pass +std::unique_ptr createCSEPass(); + +/// Convert FIR loop constructs to the Affine dialect +std::unique_ptr createPromoteToAffinePass(); + +/// Convert `fir.do_loop` and `fir.if` to `loop.for` and `loop.if`. This +/// conversion enables the `createLowerToCFGPass` to transform these to CFG +/// form. +std::unique_ptr createLowerToLoopPass(); + +/// 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 createMemToRegPass(); + +} // namespace fir + +#endif // OPTIMIZER_TRANSFORMS_PASSES_H diff --git a/flang/include/flang/Semantics/symbol.h b/flang/include/flang/Semantics/symbol.h index 2a95f483a173ea..fb1fe03c531e6e 100644 --- a/flang/include/flang/Semantics/symbol.h +++ b/flang/include/flang/Semantics/symbol.h @@ -13,6 +13,7 @@ #include "flang/Common/Fortran.h" #include "flang/Common/enum-set.h" #include "flang/Common/reference.h" +#include "llvm/ADT/DenseMapInfo.h" #include #include #include @@ -752,6 +753,31 @@ inline bool operator<(MutableSymbolRef x, MutableSymbolRef y) { return *x < *y; } using SymbolSet = std::set; - } // namespace Fortran::semantics + +// Define required info so that SymbolRef can be used inside llvm::DenseMap. +namespace llvm { +template <> struct DenseMapInfo { + static inline Fortran::semantics::SymbolRef getEmptyKey() { + auto ptr = DenseMapInfo::getEmptyKey(); + return *reinterpret_cast(&ptr); + } + + static inline Fortran::semantics::SymbolRef getTombstoneKey() { + auto ptr = + DenseMapInfo::getTombstoneKey(); + return *reinterpret_cast(&ptr); + } + + static unsigned getHashValue(const Fortran::semantics::SymbolRef &sym) { + return DenseMapInfo::getHashValue( + &sym.get()); + } + + static bool isEqual(const Fortran::semantics::SymbolRef &LHS, + const Fortran::semantics::SymbolRef &RHS) { + return LHS == RHS; + } +}; +} // namespace llvm #endif // FORTRAN_SEMANTICS_SYMBOL_H_ diff --git a/flang/include/flang/Semantics/tools.h b/flang/include/flang/Semantics/tools.h index e6a3a2eb53f1e1..0493ca4dd340c4 100644 --- a/flang/include/flang/Semantics/tools.h +++ b/flang/include/flang/Semantics/tools.h @@ -109,6 +109,8 @@ bool CanBeTypeBoundProc(const Symbol *); bool IsInitialized(const Symbol &); bool HasIntrinsicTypeName(const Symbol &); bool IsSeparateModuleProcedureInterface(const Symbol *); +// Given a subroutine symbol, tells if the subroutine has alternate returns +bool HasAlternateReturns(const Symbol &); // Return an ultimate component of type that matches predicate, or nullptr. const Symbol *FindUltimateComponent(const DerivedTypeSpec &type, 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 ae321b872a7626..22ecde7b8844b2 100644 --- a/flang/lib/CMakeLists.txt +++ b/flang/lib/CMakeLists.txt @@ -1,10 +1,13 @@ +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(LINK_WITH_FIR) - add_subdirectory(Optimizer) -endif() diff --git a/flang/lib/Decimal/big-radix-floating-point.h b/flang/lib/Decimal/big-radix-floating-point.h index cc203e90bc9139..cac5a2755a901c 100644 --- a/flang/lib/Decimal/big-radix-floating-point.h +++ b/flang/lib/Decimal/big-radix-floating-point.h @@ -27,7 +27,9 @@ #include "flang/Common/unsigned-const-division.h" #include "flang/Decimal/binary-floating-point.h" #include "flang/Decimal/decimal.h" +#if 0 #include "llvm/Support/raw_ostream.h" +#endif #include #include #include @@ -112,7 +114,9 @@ template class BigRadixFloatingPointNumber { void Minimize( BigRadixFloatingPointNumber &&less, BigRadixFloatingPointNumber &&more); +#if 0 llvm::raw_ostream &Dump(llvm::raw_ostream &) const; +#endif private: BigRadixFloatingPointNumber(const BigRadixFloatingPointNumber &that) diff --git a/flang/lib/Decimal/binary-to-decimal.cpp b/flang/lib/Decimal/binary-to-decimal.cpp index 02e39c241ee1a1..f10013719b1202 100644 --- a/flang/lib/Decimal/binary-to-decimal.cpp +++ b/flang/lib/Decimal/binary-to-decimal.cpp @@ -304,7 +304,45 @@ void BigRadixFloatingPointNumber::Minimize( Normalize(); } -template +template +void BigRadixFloatingPointNumber::LoseLeastSignificantDigit() { + Digit LSD{digit_[0]}; + for (int j{0}; j < digits_ - 1; ++j) { + digit_[j] = digit_[j + 1]; + } + digit_[digits_ - 1] = 0; + bool incr{false}; + switch (rounding_) { + case RoundNearest: + case RoundDefault: + incr = LSD > radix / 2 || (LSD == radix / 2 && digit_[0] % 2 != 0); + break; + case RoundUp: + incr = LSD > 0 && !isNegative_; + break; + case RoundDown: + incr = LSD > 0 && isNegative_; + break; + case RoundToZero: + break; + case RoundCompatible: + incr = LSD >= radix / 2; + break; + } + for (int j{0}; (digit_[j] += incr) == radix; ++j) { + digit_[j] = 0; + } +} + +template void BigRadixFloatingPointNumber<8,16>::LoseLeastSignificantDigit(); +template void BigRadixFloatingPointNumber<11,16>::LoseLeastSignificantDigit(); +template void BigRadixFloatingPointNumber<24,16>::LoseLeastSignificantDigit(); +template void BigRadixFloatingPointNumber<53,16>::LoseLeastSignificantDigit(); +template void BigRadixFloatingPointNumber<64,16>::LoseLeastSignificantDigit(); +template void BigRadixFloatingPointNumber<113,16>::LoseLeastSignificantDigit(); + +template ConversionToDecimalResult ConvertToDecimal(char *buffer, std::size_t size, enum DecimalConversionFlags flags, int digits, enum FortranRounding rounding, BinaryFloatingPointNumber x) { @@ -388,6 +426,7 @@ ConversionToDecimalResult ConvertLongDoubleToDecimal(char *buffer, #endif } +#if 0 template llvm::raw_ostream &BigRadixFloatingPointNumber::Dump( llvm::raw_ostream &o) const { @@ -405,4 +444,6 @@ llvm::raw_ostream &BigRadixFloatingPointNumber::Dump( } return o; } +#endif + } // namespace Fortran::decimal diff --git a/flang/lib/Evaluate/CMakeLists.txt b/flang/lib/Evaluate/CMakeLists.txt index 0e5dc4d2c5ff1a..3dc95960a226d5 100644 --- a/flang/lib/Evaluate/CMakeLists.txt +++ b/flang/lib/Evaluate/CMakeLists.txt @@ -1,3 +1,13 @@ +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}") + else() + message(STATUS "Libpgmath not found in: ${LIBPGMATH_DIR}") + endif() +endif() add_flang_library(FortranEvaluate call.cpp @@ -31,16 +41,6 @@ add_flang_library(FortranEvaluate FortranDecimal FortranSemantics FortranParser + ${LIBPGMATH} ) -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) - target_link_libraries(FortranEvaluate ${LIBPGMATH}) - message(STATUS "Found libpgmath: ${LIBPGMATH}") - else() - message(STATUS "Libpgmath not found in: ${LIBPGMATH_DIR}") - endif() -endif() diff --git a/flang/lib/Evaluate/fold-real.cpp b/flang/lib/Evaluate/fold-real.cpp index ee2ff593746238..3635e876bab4fa 100644 --- a/flang/lib/Evaluate/fold-real.cpp +++ b/flang/lib/Evaluate/fold-real.cpp @@ -39,7 +39,7 @@ Expr> FoldIntrinsicFunction( } } else if (name == "atan" || name == "atan2" || name == "hypot" || name == "mod") { - std::string localName{name == "atan2" ? "atan" : name}; + std::string localName{name == "atan" ? "atan2" : name}; CHECK(args.size() == 2); if (auto callable{ context.hostIntrinsicsLibrary() diff --git a/flang/lib/Evaluate/intrinsics-library.cpp b/flang/lib/Evaluate/intrinsics-library.cpp index 84c71e145bb60a..61f7ce766f25de 100644 --- a/flang/lib/Evaluate/intrinsics-library.cpp +++ b/flang/lib/Evaluate/intrinsics-library.cpp @@ -1,4 +1,5 @@ //===-- lib/Evaluate/intrinsics-library.cpp -------------------------------===// + // // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. // See https://llvm.org/LICENSE.txt for license information. @@ -57,7 +58,7 @@ static void AddLibmRealHostProcedures( {"asin", F{std::asin}, true}, {"asinh", F{std::asinh}, true}, {"atan", F{std::atan}, true}, - {"atan", F2{std::atan2}, true}, + {"atan2", F2{std::atan2}, true}, {"atanh", F{std::atanh}, true}, {"cos", F{std::cos}, true}, {"cosh", F{std::cosh}, true}, @@ -135,7 +136,8 @@ static void AddLibmComplexHostProcedures( } } -void InitHostIntrinsicLibraryWithLibm(HostIntrinsicProceduresLibrary &lib) { +[[maybe_unused]] static void InitHostIntrinsicLibraryWithLibm( + HostIntrinsicProceduresLibrary &lib) { if constexpr (host::FortranTypeExists()) { AddLibmRealHostProcedures(lib); } @@ -158,397 +160,226 @@ void InitHostIntrinsicLibraryWithLibm(HostIntrinsicProceduresLibrary &lib) { } #if LINK_WITH_LIBPGMATH -namespace pgmath { -// Define mapping between numerical intrinsics and libpgmath symbols -// namespace is used to have shorter names on repeated patterns. -// A class would be better to hold all these defs, but GCC does not -// support specialization of template variables inside class even -// if it is C++14 standard compliant here because there are only full -// specializations. - -// List of intrinsics that have libpgmath implementations that can be used for -// constant folding The tag names must match the name used inside libpgmath name -// so that the macro below work. -enum class I { - acos, - acosh, - asin, - asinh, - atan, - atan2, - atanh, - bessel_j0, - bessel_j1, - bessel_jn, - bessel_y0, - bessel_y1, - bessel_yn, - cos, - cosh, - erf, - erfc, - erfc_scaled, - exp, - gamma, - hypot, - log, - log10, - log_gamma, - mod, - pow, - sin, - sinh, - sqrt, - tan, - tanh -}; +// Only use libpgmath for folding if it is available. +// First declare all libpgmaths functions +#define PGMATH_DECLARE +#include "../runtime/pgmath.h.inc" // Library versions: P for Precise, R for Relaxed, F for Fast enum class L { F, R, P }; -struct NoSuchRuntimeSymbol {}; -template constexpr auto Sym{NoSuchRuntimeSymbol{}}; - -// Macros to declare fast/relaxed/precise libpgmath variants. -#define DECLARE_PGMATH_FAST_REAL(func) \ - extern "C" float __fs_##func##_1(float); \ - extern "C" double __fd_##func##_1(double); \ - template <> constexpr auto Sym{__fs_##func##_1}; \ - template <> constexpr auto Sym{__fd_##func##_1}; - -#define DECLARE_PGMATH_FAST_COMPLEX(func) \ - extern "C" float _Complex __fc_##func##_1(float _Complex); \ - extern "C" double _Complex __fz_##func##_1(double _Complex); \ - template <> \ - constexpr auto Sym>{__fc_##func##_1}; \ - template <> \ - constexpr auto Sym>{__fz_##func##_1}; - -#define DECLARE_PGMATH_FAST_ALL_FP(func) \ - DECLARE_PGMATH_FAST_REAL(func) \ - DECLARE_PGMATH_FAST_COMPLEX(func) - -#define DECLARE_PGMATH_PRECISE_REAL(func) \ - extern "C" float __ps_##func##_1(float); \ - extern "C" double __pd_##func##_1(double); \ - template <> constexpr auto Sym{__ps_##func##_1}; \ - template <> constexpr auto Sym{__pd_##func##_1}; - -#define DECLARE_PGMATH_PRECISE_COMPLEX(func) \ - extern "C" float _Complex __pc_##func##_1(float _Complex); \ - extern "C" double _Complex __pz_##func##_1(double _Complex); \ - template <> \ - constexpr auto Sym>{__pc_##func##_1}; \ - template <> \ - constexpr auto Sym>{__pz_##func##_1}; - -#define DECLARE_PGMATH_PRECISE_ALL_FP(func) \ - DECLARE_PGMATH_PRECISE_REAL(func) \ - DECLARE_PGMATH_PRECISE_COMPLEX(func) - -#define DECLARE_PGMATH_RELAXED_REAL(func) \ - extern "C" float __rs_##func##_1(float); \ - extern "C" double __rd_##func##_1(double); \ - template <> constexpr auto Sym{__rs_##func##_1}; \ - template <> constexpr auto Sym{__rd_##func##_1}; - -#define DECLARE_PGMATH_RELAXED_COMPLEX(func) \ - extern "C" float _Complex __rc_##func##_1(float _Complex); \ - extern "C" double _Complex __rz_##func##_1(double _Complex); \ - template <> \ - constexpr auto Sym>{__rc_##func##_1}; \ - template <> \ - constexpr auto Sym>{__rz_##func##_1}; - -#define DECLARE_PGMATH_RELAXED_ALL_FP(func) \ - DECLARE_PGMATH_RELAXED_REAL(func) \ - DECLARE_PGMATH_RELAXED_COMPLEX(func) - -#define DECLARE_PGMATH_REAL(func) \ - DECLARE_PGMATH_FAST_REAL(func) \ - DECLARE_PGMATH_PRECISE_REAL(func) \ - DECLARE_PGMATH_RELAXED_REAL(func) - -#define DECLARE_PGMATH_COMPLEX(func) \ - DECLARE_PGMATH_FAST_COMPLEX(func) \ - DECLARE_PGMATH_PRECISE_COMPLEX(func) \ - DECLARE_PGMATH_RELAXED_COMPLEX(func) - -#define DECLARE_PGMATH_ALL(func) \ - DECLARE_PGMATH_REAL(func) \ - DECLARE_PGMATH_COMPLEX(func) - -// Macros to declare fast/relaxed/precise libpgmath variants with two arguments. -#define DECLARE_PGMATH_FAST_REAL2(func) \ - extern "C" float __fs_##func##_1(float, float); \ - extern "C" double __fd_##func##_1(double, double); \ - template <> constexpr auto Sym{__fs_##func##_1}; \ - template <> constexpr auto Sym{__fd_##func##_1}; - -#define DECLARE_PGMATH_FAST_COMPLEX2(func) \ - extern "C" float _Complex __fc_##func##_1(float _Complex, float _Complex); \ - extern "C" double _Complex __fz_##func##_1( \ - double _Complex, double _Complex); \ - template <> \ - constexpr auto Sym>{__fc_##func##_1}; \ - template <> \ - constexpr auto Sym>{__fz_##func##_1}; - -#define DECLARE_PGMATH_FAST_ALL_FP2(func) \ - DECLARE_PGMATH_FAST_REAL2(func) \ - DECLARE_PGMATH_FAST_COMPLEX2(func) - -#define DECLARE_PGMATH_PRECISE_REAL2(func) \ - extern "C" float __ps_##func##_1(float, float); \ - extern "C" double __pd_##func##_1(double, double); \ - template <> constexpr auto Sym{__ps_##func##_1}; \ - template <> constexpr auto Sym{__pd_##func##_1}; - -#define DECLARE_PGMATH_PRECISE_COMPLEX2(func) \ - extern "C" float _Complex __pc_##func##_1(float _Complex, float _Complex); \ - extern "C" double _Complex __pz_##func##_1( \ - double _Complex, double _Complex); \ - template <> \ - constexpr auto Sym>{__pc_##func##_1}; \ - template <> \ - constexpr auto Sym>{__pz_##func##_1}; - -#define DECLARE_PGMATH_PRECISE_ALL_FP2(func) \ - DECLARE_PGMATH_PRECISE_REAL2(func) \ - DECLARE_PGMATH_PRECISE_COMPLEX2(func) - -#define DECLARE_PGMATH_RELAXED_REAL2(func) \ - extern "C" float __rs_##func##_1(float, float); \ - extern "C" double __rd_##func##_1(double, double); \ - template <> constexpr auto Sym{__rs_##func##_1}; \ - template <> constexpr auto Sym{__rd_##func##_1}; - -#define DECLARE_PGMATH_RELAXED_COMPLEX2(func) \ - extern "C" float _Complex __rc_##func##_1(float _Complex, float _Complex); \ - extern "C" double _Complex __rz_##func##_1( \ - double _Complex, double _Complex); \ - template <> \ - constexpr auto Sym>{__rc_##func##_1}; \ - template <> \ - constexpr auto Sym>{__rz_##func##_1}; - -#define DECLARE_PGMATH_RELAXED_ALL_FP2(func) \ - DECLARE_PGMATH_RELAXED_REAL2(func) \ - DECLARE_PGMATH_RELAXED_COMPLEX2(func) - -#define DECLARE_PGMATH_REAL2(func) \ - DECLARE_PGMATH_FAST_REAL2(func) \ - DECLARE_PGMATH_PRECISE_REAL2(func) \ - DECLARE_PGMATH_RELAXED_REAL2(func) - -#define DECLARE_PGMATH_COMPLEX2(func) \ - DECLARE_PGMATH_FAST_COMPLEX2(func) \ - DECLARE_PGMATH_PRECISE_COMPLEX2(func) \ - DECLARE_PGMATH_RELAXED_COMPLEX2(func) - -#define DECLARE_PGMATH_ALL2(func) \ - DECLARE_PGMATH_REAL2(func) \ - DECLARE_PGMATH_COMPLEX2(func) - -// Marcos to declare __mth_i libpgmath variants -#define DECLARE_PGMATH_MTH_VERSION_REAL(func) \ - extern "C" float __mth_i_##func(float); \ - extern "C" double __mth_i_d##func(double); \ - template <> constexpr auto Sym{__mth_i_##func}; \ - template <> constexpr auto Sym{__mth_i_d##func}; \ - template <> constexpr auto Sym{__mth_i_##func}; \ - template <> constexpr auto Sym{__mth_i_d##func}; \ - template <> constexpr auto Sym{__mth_i_##func}; \ - template <> constexpr auto Sym{__mth_i_d##func}; - -// Actual libpgmath declarations -DECLARE_PGMATH_ALL(acos) -DECLARE_PGMATH_MTH_VERSION_REAL(acosh) -DECLARE_PGMATH_ALL(asin) -DECLARE_PGMATH_MTH_VERSION_REAL(asinh) -DECLARE_PGMATH_ALL(atan) -DECLARE_PGMATH_REAL2(atan2) -DECLARE_PGMATH_MTH_VERSION_REAL(atanh) -DECLARE_PGMATH_MTH_VERSION_REAL(bessel_j0) -DECLARE_PGMATH_MTH_VERSION_REAL(bessel_j1) -DECLARE_PGMATH_MTH_VERSION_REAL(bessel_y0) -DECLARE_PGMATH_MTH_VERSION_REAL(bessel_y1) -// bessel_jn and bessel_yn takes an int as first arg -extern "C" float __mth_i_bessel_jn(int, float); -extern "C" double __mth_i_dbessel_jn(int, double); -template <> constexpr auto Sym{__mth_i_bessel_jn}; -template <> constexpr auto Sym{__mth_i_dbessel_jn}; -template <> constexpr auto Sym{__mth_i_bessel_jn}; -template <> constexpr auto Sym{__mth_i_dbessel_jn}; -template <> constexpr auto Sym{__mth_i_bessel_jn}; -template <> constexpr auto Sym{__mth_i_dbessel_jn}; -extern "C" float __mth_i_bessel_yn(int, float); -extern "C" double __mth_i_dbessel_yn(int, double); -template <> constexpr auto Sym{__mth_i_bessel_yn}; -template <> constexpr auto Sym{__mth_i_dbessel_yn}; -template <> constexpr auto Sym{__mth_i_bessel_yn}; -template <> constexpr auto Sym{__mth_i_dbessel_yn}; -template <> constexpr auto Sym{__mth_i_bessel_yn}; -template <> constexpr auto Sym{__mth_i_dbessel_yn}; -DECLARE_PGMATH_ALL(cos) -DECLARE_PGMATH_ALL(cosh) -DECLARE_PGMATH_MTH_VERSION_REAL(erf) -DECLARE_PGMATH_MTH_VERSION_REAL(erfc) -DECLARE_PGMATH_MTH_VERSION_REAL(erfc_scaled) -DECLARE_PGMATH_ALL(exp) -DECLARE_PGMATH_MTH_VERSION_REAL(gamma) -extern "C" float __mth_i_hypot(float, float); -extern "C" double __mth_i_dhypot(double, double); -template <> constexpr auto Sym{__mth_i_hypot}; -template <> constexpr auto Sym{__mth_i_dhypot}; -template <> constexpr auto Sym{__mth_i_hypot}; -template <> constexpr auto Sym{__mth_i_dhypot}; -template <> constexpr auto Sym{__mth_i_hypot}; -template <> constexpr auto Sym{__mth_i_dhypot}; -DECLARE_PGMATH_ALL(log) -DECLARE_PGMATH_REAL(log10) -DECLARE_PGMATH_MTH_VERSION_REAL(log_gamma) -// no function for modulo in libpgmath -extern "C" float __fs_mod_1(float, float); -extern "C" double __fd_mod_1(double, double); -template <> constexpr auto Sym{__fs_mod_1}; -template <> constexpr auto Sym{__fd_mod_1}; -template <> constexpr auto Sym{__fs_mod_1}; -template <> constexpr auto Sym{__fd_mod_1}; -template <> constexpr auto Sym{__fs_mod_1}; -template <> constexpr auto Sym{__fd_mod_1}; -DECLARE_PGMATH_ALL2(pow) -DECLARE_PGMATH_ALL(sin) -DECLARE_PGMATH_ALL(sinh) -DECLARE_PGMATH_MTH_VERSION_REAL(sqrt) -DECLARE_PGMATH_COMPLEX(sqrt) // real versions are __mth_i... -DECLARE_PGMATH_ALL(tan) -DECLARE_PGMATH_ALL(tanh) - // Fill the function map used for folding with libpgmath symbols -template -static void AddLibpgmathRealHostProcedures( +template +static void AddLibpgmathFloatHostProcedures( HostIntrinsicProceduresLibrary &hostIntrinsicLibrary) { - static_assert(std::is_same_v || std::is_same_v); - HostRuntimeIntrinsicProcedure pgmathSymbols[]{ - {"acos", Sym, true}, - {"acosh", Sym, true}, - {"asin", Sym, true}, - {"asinh", Sym, true}, - {"atan", Sym, true}, - {"atan", Sym, - true}, // atan is also the generic name for atan2 - {"atanh", Sym, true}, - {"bessel_j0", Sym, true}, - {"bessel_j1", Sym, true}, - {"bessel_jn", Sym, true}, - {"bessel_y0", Sym, true}, - {"bessel_y1", Sym, true}, - {"bessel_yn", Sym, true}, - {"cos", Sym, true}, - {"cosh", Sym, true}, - {"erf", Sym, true}, - {"erfc", Sym, true}, - {"erfc_scaled", Sym, true}, - {"exp", Sym, true}, - {"gamma", Sym, true}, - {"hypot", Sym, true}, - {"log", Sym, true}, - {"log10", Sym, true}, - {"log_gamma", Sym, true}, - {"mod", Sym, true}, - {"pow", Sym, true}, - {"sin", Sym, true}, - {"sinh", Sym, true}, - {"sqrt", Sym, true}, - {"tan", Sym, true}, - {"tanh", Sym, true}, - }; + // FIXME: atan / atan2 ! + if constexpr (Lib == L::F) { + HostRuntimeIntrinsicProcedure pgmathSymbols[]{ +#define PGMATH_FAST +#define PGMATH_USE_S(name, function) {#name, function, true}, +#include "../runtime/pgmath.h.inc" + }; + for (auto sym : pgmathSymbols) { + hostIntrinsicLibrary.AddProcedure(std::move(sym)); + } + } else if constexpr (Lib == L::R) { + HostRuntimeIntrinsicProcedure pgmathSymbols[]{ +#define PGMATH_RELAXED +#define PGMATH_USE_S(name, function) {#name, function, true}, +#include "../runtime/pgmath.h.inc" + }; + for (auto sym : pgmathSymbols) { + hostIntrinsicLibrary.AddProcedure(std::move(sym)); + } + } else { + static_assert(Lib == L::P && "unexpected libpgmath version"); + HostRuntimeIntrinsicProcedure pgmathSymbols[]{ +#define PGMATH_PRECISE +#define PGMATH_USE_S(name, function) {#name, function, true}, +#include "../runtime/pgmath.h.inc" + }; + for (auto sym : pgmathSymbols) { + hostIntrinsicLibrary.AddProcedure(std::move(sym)); + } + } +} - for (auto sym : pgmathSymbols) { - hostIntrinsicLibrary.AddProcedure(std::move(sym)); +template +static void AddLibpgmathDoubleHostProcedures( + HostIntrinsicProceduresLibrary &hostIntrinsicLibrary) { + // FIXME: atan / atan2 ! + if constexpr (Lib == L::F) { + HostRuntimeIntrinsicProcedure pgmathSymbols[]{ +#define PGMATH_FAST +#define PGMATH_USE_D(name, function) {#name, function, true}, +#include "../runtime/pgmath.h.inc" + }; + for (auto sym : pgmathSymbols) { + hostIntrinsicLibrary.AddProcedure(std::move(sym)); + } + } else if constexpr (Lib == L::R) { + HostRuntimeIntrinsicProcedure pgmathSymbols[]{ +#define PGMATH_RELAXED +#define PGMATH_USE_D(name, function) {#name, function, true}, +#include "../runtime/pgmath.h.inc" + }; + for (auto sym : pgmathSymbols) { + hostIntrinsicLibrary.AddProcedure(std::move(sym)); + } + } else { + static_assert(Lib == L::P && "unexpected libpgmath version"); + HostRuntimeIntrinsicProcedure pgmathSymbols[]{ +#define PGMATH_PRECISE +#define PGMATH_USE_D(name, function) {#name, function, true}, +#include "../runtime/pgmath.h.inc" + }; + for (auto sym : pgmathSymbols) { + hostIntrinsicLibrary.AddProcedure(std::move(sym)); + } } } -// Note: std::complex and _complex are layout compatible but are not guaranteed +// Note: Lipgmath uses _Complex but the front-end use std::complex for folding. +// std::complex and _Complex are layout compatible but are not guaranteed // to be linkage compatible. For instance, on i386, float _Complex is returned // by a pair of register but std::complex is returned by structure // address. To fix the issue, wrapper around C _Complex functions are defined // below. -template func> -static std::complex ComplexCFuncWrapper(std::complex &arg) { - float _Complex res{func(*reinterpret_cast(&arg))}; - return *reinterpret_cast *>(&res); -} -template func> -static std::complex ComplexCFuncWrapper(std::complex &arg) { - double _Complex res{func(*reinterpret_cast(&arg))}; - return *reinterpret_cast *>(&res); -} +template struct ToStdComplex { + using Type = T; + using AType = Type; +}; -template func> -static std::complex ComplexCFuncWrapper( - std::complex &arg1, std::complex &arg2) { - float _Complex res{func(*reinterpret_cast(&arg1), - *reinterpret_cast(&arg2))}; - return *reinterpret_cast *>(&res); -} +template <> struct ToStdComplex { + using Type = std::complex; + // Complex arguments are passed by reference in C++ std math functions. + using AType = Type &; +}; -template func> -static std::complex ComplexCFuncWrapper( - std::complex &arg1, std::complex &arg2) { - double _Complex res{func(*reinterpret_cast(&arg1), - *reinterpret_cast(&arg2))}; - return *reinterpret_cast *>(&res); -} +template <> struct ToStdComplex { + using Type = std::complex; + using AType = Type &; +}; + +template struct CComplexFunc {}; +template func> +struct CComplexFunc, func> { + static typename ToStdComplex::Type wrapper( + typename ToStdComplex::AType... args) { + R res{func(*reinterpret_cast(&args)...)}; + return *reinterpret_cast::Type *>(&res); + } +}; -template +template static void AddLibpgmathComplexHostProcedures( HostIntrinsicProceduresLibrary &hostIntrinsicLibrary) { - static_assert(std::is_same_v || std::is_same_v); - using CHostT = std::complex; + if constexpr (Lib == L::F) { + HostRuntimeIntrinsicProcedure pgmathSymbols[]{ +#define PGMATH_FAST +#define PGMATH_USE_C(name, function) \ + {#name, CComplexFunc::wrapper, true}, +#include "../runtime/pgmath.h.inc" + }; + for (auto sym : pgmathSymbols) { + hostIntrinsicLibrary.AddProcedure(std::move(sym)); + } + } else if constexpr (Lib == L::R) { + HostRuntimeIntrinsicProcedure pgmathSymbols[]{ +#define PGMATH_RELAXED +#define PGMATH_USE_C(name, function) \ + {#name, CComplexFunc::wrapper, true}, +#include "../runtime/pgmath.h.inc" + }; + for (auto sym : pgmathSymbols) { + hostIntrinsicLibrary.AddProcedure(std::move(sym)); + } + } else { + static_assert(Lib == L::P && "unexpected libpgmath version"); + HostRuntimeIntrinsicProcedure pgmathSymbols[]{ +#define PGMATH_PRECISE +#define PGMATH_USE_C(name, function) \ + {#name, CComplexFunc::wrapper, true}, +#include "../runtime/pgmath.h.inc" + }; + for (auto sym : pgmathSymbols) { + hostIntrinsicLibrary.AddProcedure(std::move(sym)); + } + } + // cmath is used to complement pgmath when symbols are not available + using HostT = float; + using CHostT = std::complex; using CmathF = FuncPointer; - HostRuntimeIntrinsicProcedure pgmathSymbols[]{ - {"abs", FuncPointer{std::abs}, true}, - {"acos", ComplexCFuncWrapper>, true}, - {"acosh", CmathF{std::acosh}, true}, - {"asin", ComplexCFuncWrapper>, true}, - {"asinh", CmathF{std::asinh}, true}, - {"atan", ComplexCFuncWrapper>, true}, - {"atanh", CmathF{std::atanh}, true}, - {"cos", ComplexCFuncWrapper>, true}, - {"cosh", ComplexCFuncWrapper>, true}, - {"exp", ComplexCFuncWrapper>, true}, - {"log", ComplexCFuncWrapper>, true}, - {"pow", ComplexCFuncWrapper>, true}, - {"sin", ComplexCFuncWrapper>, true}, - {"sinh", ComplexCFuncWrapper>, true}, - {"sqrt", ComplexCFuncWrapper>, true}, - {"tan", ComplexCFuncWrapper>, true}, - {"tanh", ComplexCFuncWrapper>, true}, - }; + hostIntrinsicLibrary.AddProcedure( + {"abs", FuncPointer{std::abs}, true}); + hostIntrinsicLibrary.AddProcedure({"acosh", CmathF{std::acosh}, true}); + hostIntrinsicLibrary.AddProcedure({"asinh", CmathF{std::asinh}, true}); + hostIntrinsicLibrary.AddProcedure({"atanh", CmathF{std::atanh}, true}); +} - for (auto sym : pgmathSymbols) { - hostIntrinsicLibrary.AddProcedure(std::move(sym)); +template +static void AddLibpgmathDoubleComplexHostProcedures( + HostIntrinsicProceduresLibrary &hostIntrinsicLibrary) { + if constexpr (Lib == L::F) { + HostRuntimeIntrinsicProcedure pgmathSymbols[]{ +#define PGMATH_FAST +#define PGMATH_USE_Z(name, function) \ + {#name, CComplexFunc::wrapper, true}, +#include "../runtime/pgmath.h.inc" + }; + for (auto sym : pgmathSymbols) { + hostIntrinsicLibrary.AddProcedure(std::move(sym)); + } + } else if constexpr (Lib == L::R) { + HostRuntimeIntrinsicProcedure pgmathSymbols[]{ +#define PGMATH_RELAXED +#define PGMATH_USE_Z(name, function) \ + {#name, CComplexFunc::wrapper, true}, +#include "../runtime/pgmath.h.inc" + }; + for (auto sym : pgmathSymbols) { + hostIntrinsicLibrary.AddProcedure(std::move(sym)); + } + } else { + static_assert(Lib == L::P && "unexpected libpgmath version"); + HostRuntimeIntrinsicProcedure pgmathSymbols[]{ +#define PGMATH_PRECISE +#define PGMATH_USE_Z(name, function) \ + {#name, CComplexFunc::wrapper, true}, +#include "../runtime/pgmath.h.inc" + }; + for (auto sym : pgmathSymbols) { + hostIntrinsicLibrary.AddProcedure(std::move(sym)); + } } + + // cmath is used to complement pgmath when symbols are not available + using HostT = double; + using CHostT = std::complex; + using CmathF = FuncPointer; + hostIntrinsicLibrary.AddProcedure( + {"abs", FuncPointer{std::abs}, true}); + hostIntrinsicLibrary.AddProcedure({"acosh", CmathF{std::acosh}, true}); + hostIntrinsicLibrary.AddProcedure({"asinh", CmathF{std::asinh}, true}); + hostIntrinsicLibrary.AddProcedure({"atanh", CmathF{std::atanh}, true}); } template static void InitHostIntrinsicLibraryWithLibpgmath( HostIntrinsicProceduresLibrary &lib) { if constexpr (host::FortranTypeExists()) { - AddLibpgmathRealHostProcedures(lib); + AddLibpgmathFloatHostProcedures(lib); } if constexpr (host::FortranTypeExists()) { - AddLibpgmathRealHostProcedures(lib); + AddLibpgmathDoubleHostProcedures(lib); } if constexpr (host::FortranTypeExists>()) { - AddLibpgmathComplexHostProcedures(lib); + AddLibpgmathComplexHostProcedures(lib); } if constexpr (host::FortranTypeExists>()) { - AddLibpgmathComplexHostProcedures(lib); + AddLibpgmathDoubleComplexHostProcedures(lib); } // No long double functions in libpgmath if constexpr (host::FortranTypeExists()) { @@ -558,7 +389,6 @@ static void InitHostIntrinsicLibraryWithLibpgmath( AddLibmComplexHostProcedures(lib); } } -} // namespace pgmath #endif // LINK_WITH_LIBPGMATH // Define which host runtime functions will be used for folding @@ -571,11 +401,11 @@ HostIntrinsicProceduresLibrary::HostIntrinsicProceduresLibrary() { // to silence clang warnings on unused symbols if all declared pgmath // symbols are not used somewhere. if (true) { - pgmath::InitHostIntrinsicLibraryWithLibpgmath(*this); + InitHostIntrinsicLibraryWithLibpgmath(*this); } else if (false) { - pgmath::InitHostIntrinsicLibraryWithLibpgmath(*this); + InitHostIntrinsicLibraryWithLibpgmath(*this); } else { - pgmath::InitHostIntrinsicLibraryWithLibpgmath(*this); + InitHostIntrinsicLibraryWithLibpgmath(*this); } #else InitHostIntrinsicLibraryWithLibm(*this); diff --git a/flang/lib/Evaluate/type.cpp b/flang/lib/Evaluate/type.cpp index 3360d30d9f9335..9d3fec03fbe71d 100644 --- a/flang/lib/Evaluate/type.cpp +++ b/flang/lib/Evaluate/type.cpp @@ -32,6 +32,10 @@ static bool IsDescriptor(const ObjectEntityDetails &details) { } } // TODO: Automatic (adjustable) arrays - are they descriptors? + if (details.isDummy()) { + return details.IsAssumedShape() || details.IsDeferredShape() || + details.IsAssumedRank(); + } return !details.shape().empty() && !details.shape().IsConstantShape(); } diff --git a/flang/lib/Lower/Bridge.cpp b/flang/lib/Lower/Bridge.cpp new file mode 100644 index 00000000000000..bd3525b73dd20d --- /dev/null +++ b/flang/lib/Lower/Bridge.cpp @@ -0,0 +1,2075 @@ +//===-- Bridge.cc -- 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 +// +//===----------------------------------------------------------------------===// + +#include "flang/Lower/Bridge.h" +#include "../../runtime/iostat.h" +#include "SymbolMap.h" +#include "flang/Lower/ConvertExpr.h" +#include "flang/Lower/ConvertType.h" +#include "flang/Lower/FIRBuilder.h" +#include "flang/Lower/IO.h" +#include "flang/Lower/Mangler.h" +#include "flang/Lower/PFTBuilder.h" +#include "flang/Lower/Runtime.h" +#include "flang/Optimizer/Dialect/FIRAttr.h" +#include "flang/Optimizer/Dialect/FIRDialect.h" +#include "flang/Optimizer/Support/InternalNames.h" +#include "flang/Parser/parse-tree.h" +#include "flang/Semantics/tools.h" +#include "mlir/Dialect/LLVMIR/LLVMDialect.h" +#include "mlir/Dialect/StandardOps/IR/Ops.h" +#include "mlir/Parser.h" +#include "mlir/Target/LLVMIR.h" +#include "mlir/Transforms/RegionUtils.h" +#include "llvm/Support/CommandLine.h" +#include "llvm/Support/ErrorHandling.h" +#include "llvm/Support/MD5.h" + +#undef TODO +#define TODO() \ + { \ + if (disableToDoAssertions) \ + mlir::emitError(toLocation(), __FILE__) \ + << ':' << __LINE__ << " not implemented"; \ + else \ + llvm_unreachable("not yet implemented"); \ + } + +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")); + +static llvm::cl::opt + disableToDoAssertions("disable-burnside-todo", + llvm::cl::desc("disable burnside bridge asserts"), + llvm::cl::init(false), llvm::cl::Hidden); + +static llvm::cl::opt + nameLengthHashSize("length-to-hash-string-literal", + llvm::cl::desc("string literals that exceed this length" + " will use a hash value as their symbol " + "name"), + llvm::cl::init(32)); + +namespace { +/// Information for generating a structured or unstructured increment loop. +struct IncrementLoopInfo { + explicit IncrementLoopInfo( + Fortran::semantics::Symbol *sym, + const Fortran::parser::ScalarExpr &lowerExpr, + const Fortran::parser::ScalarExpr &upperExpr, + const std::optional &stepExpr, + mlir::Type type) + : loopVariableSym{sym}, lowerExpr{lowerExpr}, upperExpr{upperExpr}, + stepExpr{stepExpr}, loopVariableType{type} {} + + bool isStructured() const { return !headerBlock; } + + // Data members for both structured and unstructured loops. + Fortran::semantics::Symbol *loopVariableSym; + const Fortran::parser::ScalarExpr &lowerExpr; + const Fortran::parser::ScalarExpr &upperExpr; + const std::optional &stepExpr; + mlir::Type loopVariableType; + + mlir::Value loopVariable{}; + mlir::Value stepValue{}; // possible uses in multiple blocks + + // Data members for structured loops. + fir::LoopOp doLoop{}; + mlir::OpBuilder::InsertPoint insertionPoint{}; + + // Data members for unstructured loops. + mlir::Value tripVariable{}; + mlir::Block *headerBlock{nullptr}; // loop entry and test block + mlir::Block *bodyBlock{nullptr}; // first loop body block + mlir::Block *successorBlock{nullptr}; // loop exit target block +}; +} // namespace + +static bool symIsChar(const Fortran::semantics::Symbol &sym) { + return sym.GetType()->category() == + Fortran::semantics::DeclTypeSpec::Character; +} + +static bool symIsArray(const Fortran::semantics::Symbol &sym) { + const auto *det = sym.detailsIf(); + return det && det->IsArray(); +} + +static bool isExplicitShape(const Fortran::semantics::Symbol &sym) { + const auto *det = sym.detailsIf(); + return det && det->IsArray() && det->shape().IsExplicitShape(); +} + +namespace { +struct SymbolIndexAnalyzer { + using FromBox = std::monostate; + + explicit SymbolIndexAnalyzer(const Fortran::semantics::Symbol &sym) + : sym{sym} {} + SymbolIndexAnalyzer() = delete; + SymbolIndexAnalyzer(const SymbolIndexAnalyzer &) = delete; + + /// Run the analysis on the symbol. Used to determine the type of index to + /// save in the symbol map. + void analyze() { + isChar = symIsChar(sym); + if (isChar) { + const auto &lenParam = sym.GetType()->characterTypeSpec().length(); + if (auto expr = lenParam.GetExplicit()) { + auto len = Fortran::evaluate::AsGenericExpr(std::move(*expr)); + auto asInt = Fortran::evaluate::ToInt64(len); + if (asInt) { + charLen = *asInt; + } else { + charLen = len; + staticSize = false; + } + } else { + charLen = FromBox{}; + staticSize = false; + } + } + isArray = symIsArray(sym); + for (const auto &subs : getSymShape()) { + auto low = subs.lbound().GetExplicit(); + auto high = subs.ubound().GetExplicit(); + if (staticSize && low && high) { + auto lb = Fortran::evaluate::ToInt64(*low); + auto ub = Fortran::evaluate::ToInt64(*high); + if (lb && ub) { + staticLBound.push_back(*lb); + staticShape.push_back(*ub - *lb + 1); + continue; + } + } + staticSize = false; + dynamicBound.push_back(&subs); + } + } + + /// Get the shape of an analyzed symbol. + const Fortran::semantics::ArraySpec &getSymShape() { + return sym.get().shape(); + } + + /// Get the CHARACTER's LEN value, if there is one. + llvm::Optional getCharLenConst() { + if (isChar) + if (auto *res = std::get_if(&charLen)) + return {*res}; + return {}; + } + + /// Get the CHARACTER's LEN expression, if there is one. + llvm::Optional getCharLenExpr() { + if (isChar) + if (auto *res = std::get_if(&charLen)) + return {*res}; + return {}; + } + + /// Is it a CHARACTER with a constant LEN? + bool charConstSize() const { + return isChar && std::holds_alternative(charLen); + } + + /// Symbol is neither a CHARACTER nor an array. + bool isTrivial() const { return !(isChar || isArray); } + + /// Return true iff all the lower bound values are the constant 1. + bool lboundIsAllOnes() const { + return staticSize && + llvm::all_of(staticLBound, [](int64_t v) { return v == 1; }); + } + + llvm::SmallVector staticLBound; + llvm::SmallVector staticShape; + llvm::SmallVector dynamicBound; + bool staticSize{true}; + bool isChar{false}; + bool isArray{false}; + +private: + std::variant charLen{ + FromBox{}}; + const Fortran::semantics::Symbol &sym; +}; +} // namespace + +//===----------------------------------------------------------------------===// +// FirConverter +//===----------------------------------------------------------------------===// + +namespace { +/// Walk over the pre-FIR tree (PFT) and lower it to the FIR dialect of MLIR. +/// +/// After building the PFT, the FirConverter processes that representation +/// and lowers it to the FIR executable representation. +class FirConverter : public Fortran::lower::AbstractConverter { +public: + explicit FirConverter(Fortran::lower::LoweringBridge &bridge, + fir::NameUniquer &uniquer) + : mlirContext{bridge.getMLIRContext()}, cooked{bridge.getCookedSource()}, + module{bridge.getModule()}, defaults{bridge.getDefaultKinds()}, + kindMap{bridge.getKindMap()}, uniquer{uniquer} {} + virtual ~FirConverter() = default; + + /// Convert the PFT to FIR + void run(Fortran::lower::pft::Program &pft) { + // do translation + 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 &) { TODO(); }, + }, + u); + } + } + + mlir::FunctionType genFunctionType(Fortran::lower::SymbolRef sym) { + return Fortran::lower::translateSymbolToFIRFunctionType(&mlirContext, + defaults, sym); + } + + //===--------------------------------------------------------------------===// + // AbstractConverter overrides + //===--------------------------------------------------------------------===// + + mlir::Value genExprAddr(const Fortran::lower::SomeExpr &expr, + mlir::Location *loc = nullptr) override final { + return createFIRAddr(loc ? *loc : toLocation(), &expr); + } + mlir::Value genExprValue(const Fortran::lower::SomeExpr &expr, + mlir::Location *loc = nullptr) override final { + return createFIRExpr(loc ? *loc : toLocation(), &expr); + } + + mlir::Type genType(const Fortran::evaluate::DataRef &data) override final { + return Fortran::lower::translateDataRefToFIRType(&mlirContext, defaults, + data); + } + mlir::Type genType(const Fortran::lower::SomeExpr &expr) override final { + return Fortran::lower::translateSomeExprToFIRType(&mlirContext, defaults, + &expr); + } + mlir::Type genType(Fortran::lower::SymbolRef sym) override final { + return Fortran::lower::translateSymbolToFIRType(&mlirContext, defaults, + sym); + } + mlir::Type genType(Fortran::common::TypeCategory tc, + int kind) override final { + return Fortran::lower::getFIRType(&mlirContext, defaults, tc, kind); + } + mlir::Type genType(Fortran::common::TypeCategory tc) override final { + return Fortran::lower::getFIRType(&mlirContext, defaults, tc); + } + + 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(&mlirContext); + } + + /// Generate a `Location` from the `CharBlock`. + mlir::Location + genLocation(const Fortran::parser::CharBlock &block) override final { + if (cooked) { + 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(filePos.file.path(), filePos.line, + filePos.column, &mlirContext); + } + } + return genLocation(); + } + + Fortran::lower::FirOpBuilder &getFirOpBuilder() override final { + return *builder; + } + + mlir::ModuleOp &getModuleOp() override final { return module; } + + std::string + mangleName(const Fortran::semantics::Symbol &symbol) override final { + return Fortran::lower::mangle::mangleName(uniquer, symbol); + } + + std::string uniqueCGIdent(llvm::StringRef prefix, + llvm::StringRef name) override final { + // For "long" identifiers use a hash value + if (name.size() > nameLengthHashSize) { + llvm::MD5 hash; + hash.update(name); + llvm::MD5::MD5Result result; + hash.final(result); + llvm::SmallString<32> str; + llvm::MD5::stringifyResult(result, str); + std::string hashName = prefix.str(); + hashName.append(".").append(str.c_str()); + return uniquer.doGenerated(hashName); + } + // "Short" identifiers use a reversible hex string + std::string nm = prefix.str(); + return uniquer.doGenerated(nm.append(".").append(llvm::toHex(name))); + } + +private: + FirConverter() = delete; + FirConverter(const FirConverter &) = delete; + FirConverter &operator=(const FirConverter &) = delete; + + //===--------------------------------------------------------------------===// + // Helper member functions + //===--------------------------------------------------------------------===// + + mlir::Value createFIRAddr(mlir::Location loc, + const Fortran::semantics::SomeExpr *expr) { + return createSomeAddress(loc, *this, *expr, localSymbols); + } + + mlir::Value createFIRExpr(mlir::Location loc, + const Fortran::semantics::SomeExpr *expr) { + return createSomeExpression(loc, *this, *expr, localSymbols); + } + + /// Find the symbol in the local map or return null. + mlir::Value 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) + localSymbols.erase(sym); + else if (lookupSymbol(sym)) + return false; + localSymbols.addSymbol(sym, val); + return true; + } + + bool addCharSymbol(const Fortran::semantics::SymbolRef sym, mlir::Value val, + mlir::Value len, bool forced = false) { + if (forced) + localSymbols.erase(sym); + else if (lookupSymbol(sym)) + return false; + localSymbols.addCharSymbol(sym, val, len); + return true; + } + + mlir::Value createTemp(mlir::Location loc, + const Fortran::semantics::Symbol &sym, + llvm::ArrayRef shape = {}) { + if (auto v = lookupSymbol(sym)) + return v; + auto newVal = builder->createTemporary(loc, genType(sym), + sym.name().ToString(), 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 isCharacterCategory(Fortran::common::TypeCategory cat) { + return cat == Fortran::common::TypeCategory::Character; + } + + 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 genBranch(mlir::Block *targetBlock) { + assert(targetBlock && "missing unconditional target block"); + builder->create(toLocation(), targetBlock); + } + + void genFIRConditionalBranch(mlir::Value &cond, mlir::Block *trueTarget, + mlir::Block *falseTarget) { + auto loc = toLocation(); + auto bcc = builder->createConvert(loc, builder->getI1Type(), cond); + builder->create(loc, bcc, trueTarget, llvm::None, + falseTarget, llvm::None); + } + + void genFIRConditionalBranch(const Fortran::parser::ScalarLogicalExpr &expr, + Fortran::lower::pft::Evaluation *trueTarget, + Fortran::lower::pft::Evaluation *falseTarget) { + assert(trueTarget && "missing conditional branch true block"); + assert(falseTarget && "missing conditional branch true block"); + mlir::Value cond = genExprValue(*Fortran::semantics::GetExpr(expr)); + 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() { 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 &details = + functionSymbol.get(); + auto resultRef = lookupSymbol(details.result()); + mlir::Value retval = builder->create(toLocation(), resultRef); + builder->create(toLocation(), retval); + } + + /// Argument \p funit is a subroutine that has alternate return specifiers. + /// Return the variable that contains the result value of a call to \p funit. + const mlir::Value + getAltReturnResult(const Fortran::lower::pft::FunctionLikeUnit &funit) { + const auto &symbol = funit.getSubprogramSymbol(); + assert(Fortran::semantics::HasAlternateReturns(symbol) && + "subroutine does not have alternate returns"); + const auto returnValue = lookupSymbol(symbol); + assert(returnValue && "missing alternate return value"); + return returnValue; + } + + 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(funit)); + builder->create(toLocation(), retval); + } else { + genExitRoutine(); + } + } + + // + // Statements that have control-flow semantics + // + + template + std::pair + genWhereCondition(const A *stmt, bool withElse = true) { + auto cond = genExprValue(*Fortran::semantics::GetExpr( + std::get(stmt->t))); + auto bcc = builder->createConvert(toLocation(), builder->getI1Type(), cond); + auto where = builder->create(toLocation(), bcc, withElse); + auto insPt = builder->saveInsertionPoint(); + builder->setInsertionPointToStart(&where.whereRegion().front()); + return {insPt, where}; + } + + mlir::Value genFIRLoopIndex(const Fortran::parser::ScalarExpr &x, + mlir::Type t) { + mlir::Value v = genExprValue(*Fortran::semantics::GetExpr(x)); + return builder->createConvert(toLocation(), t, v); + } + + mlir::FuncOp getFunc(llvm::StringRef name, mlir::FunctionType ty) { + if (auto func = builder->getNamedFunction(name)) { + assert(func.getType() == ty); + return func; + } + return builder->createFunction(name, ty); + } + + /// Lowering of CALL statement + void genFIR(Fortran::lower::pft::Evaluation &eval, + const Fortran::parser::CallStmt &stmt) { + setCurrentPosition(stmt.v.source); + assert(stmt.typedCall && "Call was not analyzed"); + Fortran::semantics::SomeExpr expr{*stmt.typedCall}; + // Call statement lowering shares code with function call lowering. + auto res = createFIRExpr(toLocation(), &expr); + 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.lexicalSuccessor->block); // default = fallthrough + builder->create(toLocation(), res, indexList, blockList); + } + + void genFIR(Fortran::lower::pft::Evaluation &eval, + const Fortran::parser::IfStmt &stmt) { + if (eval.lowerAsUnstructured()) { + genFIRConditionalBranch( + std::get(stmt.t), + eval.lexicalSuccessor, eval.controlSuccessor); + return; + } + + // Generate fir.where. + auto pair = genWhereCondition(&stmt, /*withElse=*/false); + genFIR(*eval.lexicalSuccessor, /*unstructuredContext=*/false); + eval.lexicalSuccessor->skip = true; + builder->restoreInsertionPoint(pair.first); + } + + void genFIR(Fortran::lower::pft::Evaluation &eval, + const Fortran::parser::WhereStmt &) { + TODO(); + } + + void genFIR(Fortran::lower::pft::Evaluation &eval, + const Fortran::parser::ComputedGotoStmt &stmt) { + mlir::Value selectExpr = genExprValue(*Fortran::semantics::GetExpr( + std::get(stmt.t))); + 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.lexicalSuccessor->block); // default + builder->create(toLocation(), selectExpr, indexList, + blockList); + } + + void genFIR(Fortran::lower::pft::Evaluation &eval, + const Fortran::parser::ForallStmt &) { + TODO(); + } + + void genFIR(Fortran::lower::pft::Evaluation &eval, + const Fortran::parser::ArithmeticIfStmt &stmt) { + mlir::Value expr = genExprValue( + *Fortran::semantics::GetExpr(std::get(stmt.t))); + auto exprType = expr.getType(); + 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(exprType, -1)); + blockList.push_back(blockOfLabel(eval, std::get<1>(stmt.t))); + attrList.push_back(fir::LowerBoundAttr::get(context)); + valueList.push_back(builder->createIntegerConstant(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(toLocation(), 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 + assert(eval.localBlocks.size() == 1 && "missing arithmetic if block"); + mlir::Value sum = builder->create(toLocation(), expr, expr); + mlir::Value zero = builder->create( + toLocation(), exprType, builder->getFloatAttr(exprType, 0.0)); + mlir::Value cond1 = builder->create( + toLocation(), mlir::CmpFPredicate::OLT, sum, zero); + genFIRConditionalBranch(cond1, blockOfLabel(eval, std::get<1>(stmt.t)), + eval.localBlocks[0]); + startBlock(eval.localBlocks[0]); + mlir::Value cond2 = builder->create( + toLocation(), mlir::CmpFPredicate::OGT, sum, zero); + genFIRConditionalBranch(cond2, blockOfLabel(eval, std::get<3>(stmt.t)), + blockOfLabel(eval, std::get<2>(stmt.t))); + } + + void genFIR(Fortran::lower::pft::Evaluation &eval, + 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. + + const auto &symbolLabelMap = + eval.getOwningProcedure()->assignSymbolLabelMap; + const auto &symbol = *std::get(stmt.t).symbol; + auto variable = lookupSymbol(symbol); + if (!variable) + variable = createTemp(toLocation(), symbol); + auto selectExpr = builder->create(toLocation(), variable); + auto iter = symbolLabelMap.find(symbol); + if (iter == symbolLabelMap.end()) { + // This "assert" will fail for a nonconforming program unit that does not + // have any ASSIGN statements. The front end should check for this. + // If asserts are inactive, the assigned GOTO statement will be a nop. + llvm_unreachable("no assigned goto targets"); + return; + } + 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) == 0) { + // This "assert" will fail for a nonconforming program unit that never + // ASSIGNs this label to the selector variable. The front end should + // check that there is at least one such ASSIGN statement. If asserts + // are inactive, the label will be ignored. + llvm_unreachable("invalid assigned goto target"); + continue; + } + if (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.lexicalSuccessor->block); // default + builder->create(toLocation(), selectExpr, indexList, + blockList); + } + + void genFIR(Fortran::lower::pft::Evaluation &eval, + const Fortran::parser::AssociateConstruct &) { + TODO(); + } + void genFIR(Fortran::lower::pft::Evaluation &eval, + const Fortran::parser::BlockConstruct &) { + TODO(); + } + void genFIR(Fortran::lower::pft::Evaluation &eval, + const Fortran::parser::ChangeTeamConstruct &) { + TODO(); + } + void genFIR(Fortran::lower::pft::Evaluation &eval, + const Fortran::parser::CriticalConstruct &) { + TODO(); + } + + /// 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(Fortran::lower::pft::Evaluation &eval, + const Fortran::parser::DoConstruct &) { + bool unstructuredContext{eval.lowerAsUnstructured()}; + Fortran::lower::pft::Evaluation &doStmtEval = eval.evaluationList->front(); + auto *doStmt = doStmtEval.getIf(); + assert(doStmt && "missing DO statement"); + const auto &loopControl = + std::get>(doStmt->t); + llvm::SmallVector incrementLoopInfo; + const Fortran::parser::ScalarLogicalExpr *whileCondition = nullptr; + bool infiniteLoop = !loopControl.has_value(); + if (infiniteLoop) { + assert(unstructuredContext && "infinite loop must be unstructured"); + startBlock(doStmtEval.localBlocks[0]); // header block + } else if ((whileCondition = + std::get_if( + &loopControl->u))) { + assert(unstructuredContext && "while loop must be unstructured"); + startBlock(doStmtEval.localBlocks[0]); // header block + genFIRConditionalBranch(*whileCondition, doStmtEval.lexicalSuccessor, + doStmtEval.parentConstruct->constructExit); + } else if (const auto *bounds = + std::get_if( + &loopControl->u)) { + // "Normal" increment loop. + incrementLoopInfo.emplace_back(bounds->name.thing.symbol, bounds->lower, + bounds->upper, bounds->step, + genType(*bounds->name.thing.symbol)); + if (unstructuredContext) { + maybeStartBlock(doStmtEval.block); // preheader block + incrementLoopInfo[0].headerBlock = doStmtEval.localBlocks[0]; + incrementLoopInfo[0].bodyBlock = doStmtEval.lexicalSuccessor->block; + incrementLoopInfo[0].successorBlock = + doStmtEval.parentConstruct->constructExit->block; + } + } else { + const auto *concurrentInfo = + std::get_if( + &loopControl->u); + assert(concurrentInfo && "DO loop variant is invalid"); + TODO(); + // Add entries to incrementLoopInfo. (Define extra members for a mask.) + } + auto n = incrementLoopInfo.size(); + for (decltype(n) i = 0; i < n; ++i) + genFIRIncrementLoopBegin(incrementLoopInfo[i]); + + // Generate loop body code. + for (auto &e : *eval.evaluationList) + genFIR(e, unstructuredContext); + + // Generate end loop code. + if (infiniteLoop || whileCondition) { + genBranch(doStmtEval.localBlocks[0]); + } else { + for (auto i = incrementLoopInfo.size(); i > 0;) + genFIRIncrementLoopEnd(incrementLoopInfo[--i]); + } + } + + /// Generate FIR to begin a structured or unstructured increment loop. + void genFIRIncrementLoopBegin(IncrementLoopInfo &info) { + auto location = toLocation(); + mlir::Type type = info.isStructured() + ? mlir::IndexType::get(builder->getContext()) + : info.loopVariableType; + auto lowerValue = genFIRLoopIndex(info.lowerExpr, type); + auto upperValue = genFIRLoopIndex(info.upperExpr, type); + info.stepValue = + info.stepExpr.has_value() + ? genFIRLoopIndex(*info.stepExpr, type) + : (info.isStructured() + ? builder->create(location, 1) + : builder->createIntegerConstant(info.loopVariableType, 1)); + assert(info.stepValue && "step value must be set"); + info.loopVariable = createTemp(location, *info.loopVariableSym); + + // Structured loop - generate fir.loop. + if (info.isStructured()) { + info.insertionPoint = builder->saveInsertionPoint(); + info.doLoop = builder->create(location, lowerValue, + upperValue, info.stepValue); + builder->setInsertionPointToStart(info.doLoop.getBody()); + // Always store iteration ssa-value to the LCV to avoid missing any + // aliasing of the LCV. + auto lcv = builder->createConvert(location, info.loopVariableType, + info.doLoop.getInductionVar()); + builder->create(location, lcv, info.loopVariable); + return; + } + + // Unstructured loop preheader code - initialize tripVariable, loopVariable. + auto distance = + builder->create(location, upperValue, lowerValue); + auto adjusted = + builder->create(location, distance, info.stepValue); + auto tripCount = + builder->create(location, adjusted, info.stepValue); + info.tripVariable = + builder->createTemporary(location, info.loopVariableType); + builder->create(location, tripCount, info.tripVariable); + builder->create(location, lowerValue, info.loopVariable); + + // Unstructured loop header code - generate loop condition. + startBlock(info.headerBlock); + mlir::Value tripVariable = + builder->create(location, info.tripVariable); + mlir::Value zero = builder->createIntegerConstant(info.loopVariableType, 0); + mlir::Value cond = builder->create( + location, mlir::CmpIPredicate::sgt, tripVariable, zero); + genFIRConditionalBranch(cond, info.bodyBlock, info.successorBlock); + } + + /// Generate FIR to end a structured or unstructured increment loop. + void genFIRIncrementLoopEnd(IncrementLoopInfo &info) { + mlir::Location location = toLocation(); + if (info.isStructured()) { + // End fir.loop. + builder->restoreInsertionPoint(info.insertionPoint); + return; + } + + // Unstructured loop - increment loopVariable. + mlir::Value loopVariable = + builder->create(location, info.loopVariable); + loopVariable = + builder->create(location, loopVariable, info.stepValue); + builder->create(location, loopVariable, info.loopVariable); + + // Unstructured loop - decrement tripVariable. + mlir::Value tripVariable = + builder->create(location, info.tripVariable); + mlir::Value one = builder->create( + location, builder->getIntegerAttr(info.loopVariableType, 1)); + tripVariable = builder->create(location, tripVariable, one); + builder->create(location, tripVariable, info.tripVariable); + genBranch(info.headerBlock); + } + + /// Generate structured or unstructured FIR for an IF construct. + void genFIR(Fortran::lower::pft::Evaluation &eval, + const Fortran::parser::IfConstruct &) { + if (eval.lowerAsStructured()) { + // Structured fir.where nest. + fir::WhereOp underWhere; + mlir::OpBuilder::InsertPoint insPt; + for (auto &e : *eval.evaluationList) { + if (auto *s = e.getIf()) { + // fir.where op + std::tie(insPt, underWhere) = genWhereCondition(s); + } else if (auto *s = e.getIf()) { + // otherwise block, then nested fir.where + builder->setInsertionPointToStart(&underWhere.otherRegion().front()); + std::tie(std::ignore, underWhere) = genWhereCondition(s); + } else if (e.isA()) { + // otherwise block + builder->setInsertionPointToStart(&underWhere.otherRegion().front()); + } else if (e.isA()) { + builder->restoreInsertionPoint(insPt); + } else { + genFIR(e, /*unstructuredContext=*/false); + } + } + return; + } + + // Unstructured branch sequence. + for (auto &e : *eval.evaluationList) { + const Fortran::parser::ScalarLogicalExpr *cond = nullptr; + if (auto *s = e.getIf()) { + maybeStartBlock(e.block); + cond = &std::get(s->t); + } else if (auto *s = e.getIf()) { + startBlock(e.block); + cond = &std::get(s->t); + } + if (cond) { + genFIRConditionalBranch( + *cond, + e.lexicalSuccessor == e.controlSuccessor + ? e.parentConstruct->constructExit // empty block --> exit + : e.lexicalSuccessor, // nonempty block + e.controlSuccessor); + } else { + genFIR(e); + } + } + } + + void genFIR(Fortran::lower::pft::Evaluation &eval, + const Fortran::parser::CaseConstruct &) { + for (auto &e : *eval.evaluationList) + genFIR(e); + } + + void genFIR(Fortran::lower::pft::Evaluation &eval, + const Fortran::parser::SelectRankConstruct &) { + TODO(); + } + void genFIR(Fortran::lower::pft::Evaluation &eval, + const Fortran::parser::SelectTypeConstruct &) { + TODO(); + } + + void genFIR(Fortran::lower::pft::Evaluation &eval, + const Fortran::parser::WhereConstruct &) { + TODO(); + } + + /// Lower FORALL construct (See 10.2.4) + void genFIR(Fortran::lower::pft::Evaluation &eval, + const Fortran::parser::ForallConstruct &forall) { + auto &stmt = std::get< + Fortran::parser::Statement>( + forall.t); + setCurrentPosition(stmt.source); + auto &fas = stmt.statement; + auto &ctrl = + std::get< + Fortran::common::Indirection>( + fas.t) + .value(); + (void)ctrl; + for (auto &s : + std::get>(forall.t)) { + std::visit( + Fortran::common::visitors{ + [&](const Fortran::parser::Statement< + Fortran::parser::ForallAssignmentStmt> &b) { + setCurrentPosition(b.source); + genFIR(eval, b.statement); + }, + [&](const Fortran::parser::Statement + &b) { + setCurrentPosition(b.source); + genFIR(eval, b.statement); + }, + [&](const Fortran::parser::WhereConstruct &b) { + genFIR(eval, b); + }, + [&](const Fortran::common::Indirection< + Fortran::parser::ForallConstruct> &b) { + genFIR(eval, b.value()); + }, + [&](const Fortran::parser::Statement + &b) { + setCurrentPosition(b.source); + genFIR(eval, b.statement); + }, + }, + s.u); + } + TODO(); + } + + void genFIR(Fortran::lower::pft::Evaluation &eval, + const Fortran::parser::ForallAssignmentStmt &s) { + std::visit([&](auto &b) { genFIR(eval, b); }, s.u); + } + + void genFIR(Fortran::lower::pft::Evaluation &eval, + const Fortran::parser::CompilerDirective &) { + mlir::emitWarning(toLocation(), "ignoring all compiler directives"); + } + void genFIR(Fortran::lower::pft::Evaluation &eval, + const Fortran::parser::OpenMPConstruct &) { + TODO(); + } + void genFIR(Fortran::lower::pft::Evaluation &eval, + const Fortran::parser::OmpEndLoopDirective &) { + TODO(); + } + + void genFIR(Fortran::lower::pft::Evaluation &eval, + const Fortran::parser::AssociateStmt &) { + TODO(); + } + void genFIR(Fortran::lower::pft::Evaluation &eval, + const Fortran::parser::EndAssociateStmt &) { + TODO(); + } + void genFIR(Fortran::lower::pft::Evaluation &eval, + const Fortran::parser::BlockStmt &) { + TODO(); + } + void genFIR(Fortran::lower::pft::Evaluation &eval, + const Fortran::parser::EndBlockStmt &) { + TODO(); + } + + void genFIR(Fortran::lower::pft::Evaluation &eval, + const Fortran::parser::SelectCaseStmt &stmt) { + using ScalarExpr = Fortran::parser::Scalar; + MLIRContext *context = builder->getContext(); + const auto selectExpr = genExprValue( + *Fortran::semantics::GetExpr(std::get(stmt.t))); + const auto selectType = selectExpr.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); + const auto v = Fortran::evaluate::ToInt64(*expr); + valueList.push_back(v ? builder->createIntegerConstant(selectType, *v) + : builder->createConvert(toLocation(), selectType, + genExprValue(*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); + } + } + } + attrList.push_back(mlir::UnitAttr::get(context)); + blockList.push_back(defaultBlock); + builder->create(toLocation(), selectExpr, attrList, + valueList, blockList); + } + + void genFIR(Fortran::lower::pft::Evaluation &eval, + const Fortran::parser::CaseStmt &) {} // nop + void genFIR(Fortran::lower::pft::Evaluation &eval, + const Fortran::parser::EndSelectStmt &) {} // nop + + void genFIR(Fortran::lower::pft::Evaluation &eval, + const Fortran::parser::ChangeTeamStmt &) { + TODO(); + } + void genFIR(Fortran::lower::pft::Evaluation &eval, + const Fortran::parser::EndChangeTeamStmt &) { + TODO(); + } + void genFIR(Fortran::lower::pft::Evaluation &eval, + const Fortran::parser::CriticalStmt &) { + TODO(); + } + void genFIR(Fortran::lower::pft::Evaluation &eval, + const Fortran::parser::EndCriticalStmt &) { + TODO(); + } + + void genFIR(Fortran::lower::pft::Evaluation &, + const Fortran::parser::NonLabelDoStmt &) {} // nop + void genFIR(Fortran::lower::pft::Evaluation &, + const Fortran::parser::EndDoStmt &) {} // nop + + void genFIR(Fortran::lower::pft::Evaluation &, + const Fortran::parser::IfThenStmt &) {} // nop + void genFIR(Fortran::lower::pft::Evaluation &, + const Fortran::parser::ElseIfStmt &) {} // nop + void genFIR(Fortran::lower::pft::Evaluation &, + const Fortran::parser::ElseStmt &) {} // nop + void genFIR(Fortran::lower::pft::Evaluation &, + const Fortran::parser::EndIfStmt &) {} // nop + + void genFIR(Fortran::lower::pft::Evaluation &eval, + const Fortran::parser::SelectRankStmt &) { + TODO(); + } + void genFIR(Fortran::lower::pft::Evaluation &eval, + const Fortran::parser::SelectRankCaseStmt &) { + TODO(); + } + void genFIR(Fortran::lower::pft::Evaluation &eval, + const Fortran::parser::SelectTypeStmt &) { + TODO(); + } + void genFIR(Fortran::lower::pft::Evaluation &eval, + const Fortran::parser::TypeGuardStmt &) { + TODO(); + } + + void genFIR(Fortran::lower::pft::Evaluation &eval, + const Fortran::parser::WhereConstructStmt &) { + TODO(); + } + void genFIR(Fortran::lower::pft::Evaluation &eval, + const Fortran::parser::MaskedElsewhereStmt &) { + TODO(); + } + void genFIR(Fortran::lower::pft::Evaluation &eval, + const Fortran::parser::ElsewhereStmt &) { + TODO(); + } + void genFIR(Fortran::lower::pft::Evaluation &eval, + const Fortran::parser::EndWhereStmt &) { + TODO(); + } + void genFIR(Fortran::lower::pft::Evaluation &eval, + const Fortran::parser::ForallConstructStmt &) { + TODO(); + } + void genFIR(Fortran::lower::pft::Evaluation &eval, + const Fortran::parser::EndForallStmt &) { + TODO(); + } + + //===--------------------------------------------------------------------===// + // IO statements (see io.h) + //===--------------------------------------------------------------------===// + + void genFIR(Fortran::lower::pft::Evaluation &eval, + const Fortran::parser::BackspaceStmt &stmt) { + auto iostat = genBackspaceStatement(*this, stmt); + genIoConditionBranches(eval, stmt.v, iostat); + } + void genFIR(Fortran::lower::pft::Evaluation &eval, + const Fortran::parser::CloseStmt &stmt) { + auto iostat = genCloseStatement(*this, stmt); + genIoConditionBranches(eval, stmt.v, iostat); + } + void genFIR(Fortran::lower::pft::Evaluation &eval, + const Fortran::parser::EndfileStmt &stmt) { + auto iostat = genEndfileStatement(*this, stmt); + genIoConditionBranches(eval, stmt.v, iostat); + } + void genFIR(Fortran::lower::pft::Evaluation &eval, + const Fortran::parser::FlushStmt &stmt) { + auto iostat = genFlushStatement(*this, stmt); + genIoConditionBranches(eval, stmt.v, iostat); + } + void genFIR(Fortran::lower::pft::Evaluation &eval, + const Fortran::parser::InquireStmt &stmt) { + auto iostat = genInquireStatement(*this, stmt); + genIoConditionBranches( + eval, std::get>(stmt.u), + iostat); + } + void genFIR(Fortran::lower::pft::Evaluation &eval, + const Fortran::parser::OpenStmt &stmt) { + auto iostat = genOpenStatement(*this, stmt); + genIoConditionBranches(eval, stmt.v, iostat); + } + void genFIR(Fortran::lower::pft::Evaluation &eval, + const Fortran::parser::PrintStmt &stmt) { + genPrintStatement(*this, stmt, + eval.getOwningProcedure()->labelEvaluationMap); + } + void genFIR(Fortran::lower::pft::Evaluation &eval, + const Fortran::parser::ReadStmt &stmt) { + auto iostat = genReadStatement( + *this, stmt, eval.getOwningProcedure()->labelEvaluationMap); + genIoConditionBranches(eval, stmt.controls, iostat); + } + void genFIR(Fortran::lower::pft::Evaluation &eval, + const Fortran::parser::RewindStmt &stmt) { + auto iostat = genRewindStatement(*this, stmt); + genIoConditionBranches(eval, stmt.v, iostat); + } + void genFIR(Fortran::lower::pft::Evaluation &eval, + const Fortran::parser::WaitStmt &stmt) { + auto iostat = genWaitStatement(*this, stmt); + genIoConditionBranches(eval, stmt.v, iostat); + } + void genFIR(Fortran::lower::pft::Evaluation &eval, + const Fortran::parser::WriteStmt &stmt) { + auto iostat = genWriteStatement( + *this, stmt, eval.getOwningProcedure()->labelEvaluationMap); + genIoConditionBranches(eval, stmt.controls, iostat); + } + + template + void genIoConditionBranches(Fortran::lower::pft::Evaluation &eval, + const A &specList, mlir::Value iostat) { + if (!iostat) + return; + + mlir::Block *endBlock{}; + mlir::Block *eorBlock{}; + mlir::Block *errBlock{}; + 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 indexType = builder->getIndexType(); + auto selector = builder->createHere(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.lexicalSuccessor->block); + // ERR label statement is the default successor. + blockList.push_back(errBlock); + } else { + // Fallthrough successor statement is the default successor. + blockList.push_back(eval.lexicalSuccessor->block); + } + builder->createHere(selector, indexList, blockList); + } + + //===--------------------------------------------------------------------===// + // Memory allocation and deallocation + //===--------------------------------------------------------------------===// + + void genFIR(Fortran::lower::pft::Evaluation &eval, + const Fortran::parser::AllocateStmt &) { + TODO(); + } + + void genFIR(Fortran::lower::pft::Evaluation &eval, + const Fortran::parser::DeallocateStmt &) { + TODO(); + } + + /// 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(Fortran::lower::pft::Evaluation &eval, + const Fortran::parser::NullifyStmt &stmt) { + for (auto &po : stmt.v) { + std::visit( + Fortran::common::visitors{ + [&](const Fortran::parser::Name &sym) { + auto ty = genType(*sym.symbol); + auto load = builder->create( + toLocation(), lookupSymbol(*sym.symbol)); + auto idxTy = mlir::IndexType::get(&mlirContext); + auto zero = builder->create( + toLocation(), idxTy, builder->getIntegerAttr(idxTy, 0)); + auto cast = builder->createConvert(toLocation(), ty, zero); + builder->create(toLocation(), cast, load); + }, + [&](const Fortran::parser::StructureComponent &) { TODO(); }, + }, + po.u); + } + } + + //===--------------------------------------------------------------------===// + + void genFIR(Fortran::lower::pft::Evaluation &, + const Fortran::parser::ContinueStmt &) { + // do nothing + } + + // We don't have runtime library support for various features. When they are + // encountered, we emit an error message and exit immediately. + void noRuntimeSupport(llvm::StringRef stmt) { + mlir::emitError(toLocation(), "There is no runtime support for ") + << stmt << " statement.\n"; + std::exit(1); + } + + void genFIR(Fortran::lower::pft::Evaluation &, + const Fortran::parser::EventPostStmt &) { + // FIXME: There is no runtime call to make for this yet. + noRuntimeSupport("EVENT POST"); + } + void genFIR(Fortran::lower::pft::Evaluation &, + const Fortran::parser::EventWaitStmt &) { + // FIXME: There is no runtime call to make for this yet. + noRuntimeSupport("EVENT WAIT"); + } + + void genFIR(Fortran::lower::pft::Evaluation &, + const Fortran::parser::FormTeamStmt &) { + // FIXME: There is no runtime call to make for this yet. + noRuntimeSupport("FORM TEAM"); + } + void genFIR(Fortran::lower::pft::Evaluation &, + const Fortran::parser::LockStmt &) { + // FIXME: There is no runtime call to make for this yet. + noRuntimeSupport("LOCK"); + } + + /// Shared for both assignments and pointer assignments. + void genFIR(const Fortran::evaluate::Assignment &assignment) { + std::visit( + Fortran::common::visitors{ + [&](const Fortran::evaluate::Assignment::Intrinsic &) { + const auto *sym = + Fortran::evaluate::UnwrapWholeSymbolDataRef(assignment.lhs); + if (sym && Fortran::semantics::IsAllocatable(*sym)) { + // Assignment of allocatable are more complex, the lhs + // may need to be deallocated/reallocated. + // See Fortran 2018 10.2.1.3 p3 + TODO(); + } else if (sym && Fortran::semantics::IsPointer(*sym)) { + // Target of the pointer must be assigned. + // See Fortran 2018 10.2.1.3 p2 + auto lhsType = assignment.lhs.GetType(); + assert(lhsType && "lhs cannot be typeless"); + if (isNumericScalarCategory(lhsType->category())) { + auto val = genExprValue(assignment.rhs); + auto addr = genExprValue(assignment.lhs); + auto toTy = fir::dyn_cast_ptrEleTy(addr.getType()); + auto cast = + builder->convertWithSemantics(toLocation(), toTy, val); + builder->create(toLocation(), cast, addr); + } else if (isCharacterCategory(lhsType->category())) { + TODO(); + } else { + assert(lhsType->category() == + Fortran::common::TypeCategory::Derived); + TODO(); + } + } else if (assignment.lhs.Rank() > 0) { + // Array assignment + // See Fortran 2018 10.2.1.3 p5, p6, and p7 + TODO(); + } else { + // Scalar assignments + auto lhsType = assignment.lhs.GetType(); + assert(lhsType && "lhs cannot be typeless"); + if (isNumericScalarCategory(lhsType->category())) { + // 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 loc = toLocation(); + auto addr = genExprAddr(assignment.lhs); + auto val = genExprValue(assignment.rhs); + auto toTy = fir::dyn_cast_ptrEleTy(addr.getType()); + auto cast = builder->convertWithSemantics(loc, toTy, val); + builder->create(loc, cast, addr); + } else if (isCharacterCategory(lhsType->category())) { + // Fortran 2018 10.2.1.3 p10 and p11 + // Generating value for lhs to get fir.boxchar. + auto lhs{genExprValue(assignment.lhs)}; + auto rhs{genExprValue(assignment.rhs)}; + builder->createAssign(lhs, rhs); + } else { + assert(lhsType->category() == + Fortran::common::TypeCategory::Derived); + // Fortran 2018 10.2.1.3 p12 and p13 + TODO(); + } + } + }, + [&](const Fortran::evaluate::ProcedureRef &) { + // Defined assignment: call ProcRef + TODO(); + }, + [&](const Fortran::evaluate::Assignment::BoundsSpec &) { + // Pointer assignment with possibly empty bounds-spec + TODO(); + }, + [&](const Fortran::evaluate::Assignment::BoundsRemapping &) { + // Pointer assignment with bounds-remapping + TODO(); + }, + }, + assignment.u); + } + + void genFIR(Fortran::lower::pft::Evaluation &, + const Fortran::parser::PointerAssignmentStmt &stmt) { + genFIR(*stmt.typedAssignment->v); + } + + void genFIR(Fortran::lower::pft::Evaluation &, + const Fortran::parser::AssignmentStmt &stmt) { + genFIR(*stmt.typedAssignment->v); + } + + void genFIR(Fortran::lower::pft::Evaluation &eval, + const Fortran::parser::SyncAllStmt &) { + // FIXME: There is no runtime call to make for this yet. + noRuntimeSupport("SYNC ALL"); + } + void genFIR(Fortran::lower::pft::Evaluation &eval, + const Fortran::parser::SyncImagesStmt &) { + // FIXME: There is no runtime call to make for this yet. + noRuntimeSupport("SYNC IMAGES"); + } + void genFIR(Fortran::lower::pft::Evaluation &eval, + const Fortran::parser::SyncMemoryStmt &) { + // FIXME: There is no runtime call to make for this yet. + noRuntimeSupport("SYNC MEMORY"); + } + void genFIR(Fortran::lower::pft::Evaluation &eval, + const Fortran::parser::SyncTeamStmt &) { + // FIXME: There is no runtime call to make for this yet. + noRuntimeSupport("SYNC TEAM"); + } + void genFIR(Fortran::lower::pft::Evaluation &eval, + const Fortran::parser::UnlockStmt &) { + // FIXME: There is no runtime call to make for this yet. + noRuntimeSupport("UNLOCK"); + } + + void genFIR(Fortran::lower::pft::Evaluation &eval, + const Fortran::parser::AssignStmt &stmt) { + const auto &symbol = *std::get(stmt.t).symbol; + auto variable = lookupSymbol(symbol); + if (!variable) + variable = createTemp(toLocation(), symbol); + const auto labelValue = builder->createIntegerConstant( + genType(symbol), std::get(stmt.t)); + builder->create(toLocation(), labelValue, variable); + } + + void genFIR(Fortran::lower::pft::Evaluation &, + const Fortran::parser::FormatStmt &) { + // do nothing. + + // FORMAT statements have no semantics. They may be lowered if used by a + // data transfer statement. + } + + void genFIR(Fortran::lower::pft::Evaluation &, + const Fortran::parser::EntryStmt &) { + TODO(); + } + + void genFIR(Fortran::lower::pft::Evaluation &, + const Fortran::parser::PauseStmt &) { + // FIXME: There is no runtime call to make for this yet. + noRuntimeSupport("PAUSE"); + } + + void genFIR(Fortran::lower::pft::Evaluation &, + const Fortran::parser::DataStmt &) { + // FIXME: The front-end doesn't provide the right information yet. + mlir::emitError(toLocation(), "DATA statement is not handled."); + exit(1); + } + + void genFIR(Fortran::lower::pft::Evaluation &eval, + const Fortran::parser::NamelistStmt &) { + TODO(); + } + + // call FAIL IMAGE in runtime + void genFIR(Fortran::lower::pft::Evaluation &eval, + const Fortran::parser::FailImageStmt &stmt) { + auto callee = genFailImageStatementRuntime(*builder); + llvm::SmallVector operands; // FAIL IMAGE has no args + builder->create(toLocation(), callee, operands); + } + + // call STOP, ERROR STOP in runtime + void genFIR(Fortran::lower::pft::Evaluation &eval, + const Fortran::parser::StopStmt &stmt) { + auto callee = genStopStatementRuntime(*builder); + auto calleeType = callee.getType(); + llvm::SmallVector operands; + assert(calleeType.getNumInputs() == 3 && + "expected 3 arguments in STOP runtime"); + // First operand is stop code (zero if absent) + if (const auto &code = + std::get>(stmt.t)) { + auto expr = Fortran::semantics::GetExpr(*code); + assert(expr && "failed getting typed expression"); + operands.push_back(genExprValue(*expr)); + } else { + operands.push_back( + builder->createIntegerConstant(calleeType.getInput(0), 0)); + } + // Second operand indicates ERROR STOP + bool isError = std::get(stmt.t) == + Fortran::parser::StopStmt::Kind::ErrorStop; + operands.push_back( + builder->createIntegerConstant(calleeType.getInput(1), isError)); + + // Third operand indicates QUIET (default to false). + if (const auto &quiet = + std::get>( + stmt.t)) { + auto expr = Fortran::semantics::GetExpr(*quiet); + assert(expr && "failed getting typed expression"); + operands.push_back(genExprValue(*expr)); + } else { + operands.push_back( + builder->createIntegerConstant(calleeType.getInput(2), 0)); + } + + // Cast operands in case they have different integer/logical types + // compare to runtime. + auto i = 0; + for (auto &op : operands) { + auto type = calleeType.getInput(i++); + op = builder->createConvert(toLocation(), type, op); + } + builder->create(toLocation(), callee, operands); + } + + // gen expression, if any; share code with END of procedure + void genFIR(Fortran::lower::pft::Evaluation &eval, + const Fortran::parser::ReturnStmt &stmt) { + auto *funit = eval.getOwningProcedure(); + assert(funit && "not inside main program, function or subroutine"); + if (funit->isMainProgram()) { + genExitRoutine(); + return; + } + if (stmt.v) { + // Alternate return statement -- assign alternate return index. + auto expr = Fortran::semantics::GetExpr(*stmt.v); + assert(expr && "missing alternate return expression"); + auto altReturnIndex = builder->createConvert( + toLocation(), builder->getIndexType(), genExprValue(*expr)); + builder->create(toLocation(), altReturnIndex, + getAltReturnResult(*funit)); + } + // 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(toLocation(), funit->finalBlock); + } + + void genFIR(Fortran::lower::pft::Evaluation &eval, + const Fortran::parser::CycleStmt &) { + genBranch(eval.controlSuccessor->block); + } + void genFIR(Fortran::lower::pft::Evaluation &eval, + const Fortran::parser::ExitStmt &) { + genBranch(eval.controlSuccessor->block); + } + void genFIR(Fortran::lower::pft::Evaluation &eval, + const Fortran::parser::GotoStmt &) { + genBranch(eval.controlSuccessor->block); + } + + void genFIR(Fortran::lower::pft::Evaluation &eval, + bool unstructuredContext = true) { + if (eval.skip) + return; // rhs of {Forall,If,Where}Stmt has already been processed + + setCurrentPosition(eval.position); + if (unstructuredContext) { + // When transitioning from unstructured to structured code, + // the structured code might be a target that starts a new block. + maybeStartBlock(eval.isConstruct() && eval.lowerAsStructured() && + !eval.evaluationList->empty() + ? eval.evaluationList->front().block + : eval.block); + } + eval.visit([&](const auto &stmt) { genFIR(eval, 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.evaluationList->empty() && + eval.evaluationList->back() + .lexicalSuccessor->isIntermediateConstructStmt()) + successor = eval.constructExit; + if (successor && successor->block) + genBranch(successor->block); + } + } + + mlir::FuncOp createNewFunction(mlir::Location loc, llvm::StringRef name, + const Fortran::semantics::Symbol *symbol) { + mlir::FunctionType ty = + symbol ? genFunctionType(*symbol) + : mlir::FunctionType::get(llvm::None, llvm::None, &mlirContext); + return Fortran::lower::FirOpBuilder::createFunction(loc, module, name, ty); + } + + /// Instantiate a global variable. If it hasn't already been processed, add + /// the global to the ModuleOp as a new uniqued symbol and initialize it with + /// the correct value. It will be referenced on demand using `fir.addr_of`. + void instantiateGlobal(const Fortran::lower::pft::Variable &var) { + const auto &sym = var.getSymbol(); + std::string globalName = mangleName(sym); + fir::GlobalOp global; + bool isConst = sym.attrs().test(Fortran::semantics::Attr::PARAMETER); + if (builder->getNamedGlobal(globalName)) + return; + if (const auto *details = + sym.detailsIf()) { + if (details->init()) { + if (!sym.GetType()->AsIntrinsic()) { + TODO(); // Derived type / polymorphic + } + auto symTy = genType(sym); + auto loc = toLocation(); + global = builder->createGlobal( + loc, symTy, globalName, isConst, + [&](Fortran::lower::FirOpBuilder &builder) { + auto initVal = genExprValue(details->init().value()); + auto castTo = builder.createConvert(loc, symTy, initVal); + builder.create(loc, castTo); + }); + } else { + global = builder->createGlobal(toLocation(), genType(sym), globalName); + } + auto addrOf = builder->create( + toLocation(), global.resultType(), global.getSymbol()); + addSymbol(sym, addrOf); + } else { + TODO(); // Procedure pointer + } + } + + /// Create a stack slot for a local variable. Precondition: the insertion + /// point of the builder must be in the entry block, which is currently being + /// constructed. + mlir::Value createNewLocal(mlir::Location loc, + const Fortran::semantics::Symbol &sym, + llvm::ArrayRef shape = {}) { + auto ty = genType(sym); + auto nm = sym.name().ToString(); + if (shape.size()) + if (auto arrTy = ty.dyn_cast()) { + // elide the constant dimensions before construction + assert(shape.size() == arrTy.getDimension()); + llvm::SmallVector args; + auto typeShape = arrTy.getShape(); + for (unsigned i = 0, end = arrTy.getDimension(); i < end; ++i) + if (typeShape[i] == fir::SequenceType::getUnknownExtent()) + args.push_back(shape[i]); + return builder->allocateLocal(loc, ty, nm, args); + } + return builder->allocateLocal(loc, ty, nm, shape); + } + + /// Instantiate a local variable. Precondition: Each variable will be visited + /// such that if it depends on other variables, the variables upon which it + /// depends will already have been visited. + void instantiateLocal(const Fortran::lower::pft::Variable &var) { + const auto &sym = var.getSymbol(); + const auto loc = toLocation(); + builder->setLocation(loc); + auto idxTy = builder->getIndexType(); + const auto isDummy = Fortran::semantics::IsDummy(sym); + SymbolIndexAnalyzer sia(sym); + sia.analyze(); + + if (sia.isTrivial()) { + if (isDummy) { + // This is an argument. + assert(lookupSymbol(sym) && "must already be in map"); + return; + } + // TODO: What about lower host-associated variables? (They probably need + // to be handled as dummy parameters.) + + // Otherwise, it's a local variable. + auto local = createNewLocal(loc, sym); + addSymbol(sym, local); + return; + } + + // The non-trivial cases are when we have an argument or local that has a + // repetition value. Arguments might be passed as simple pointers and need + // to be cast to a multi-dimensional array with constant bounds (possibly + // with a missing column), bounds computed in the callee (here), or with + // bounds from the caller (boxed somewhere else). Locals have the same + // properties except they are never boxed arguments from the caller and + // never having a missing column size. + mlir::Value addr = lookupSymbol(sym); + mlir::Value len{}; + bool mustBeDummy = false; + + if (sia.isChar) { + // if element type is a CHARACTER, determine the LEN value + if (isDummy) { + auto unboxchar = builder->createUnboxChar(addr); + auto boxAddr = unboxchar.first; + if (auto c = sia.getCharLenConst()) { + // Set/override LEN with a constant + len = builder->createIntegerConstant(idxTy, *c); + addr = builder->createEmboxChar(boxAddr, len); + } else if (auto e = sia.getCharLenExpr()) { + // Set/override LEN with an expression + len = genExprValue(*e); + addr = builder->createEmboxChar(boxAddr, len); + } else { + // LEN is from the boxchar + len = unboxchar.second; + mustBeDummy = true; + } + // XXX: Subsequent lowering expects a CHARACTER variable to be in a + // boxchar. We assert that here. We might want to reconsider this + // precondition. + assert(addr.getType().isa()); + } else { + // local CHARACTER variable + if (auto c = sia.getCharLenConst()) { + len = builder->createIntegerConstant(idxTy, *c); + } else { + auto e = sia.getCharLenExpr(); + assert(e && "CHARACTER variable must have LEN parameter"); + len = genExprValue(*e); + } + assert(!addr); + } + } + + if (sia.isArray) { + // if object is an array process the lower bound and extent values + llvm::SmallVector bounds; + mustBeDummy = !isExplicitShape(sym); + if (sia.staticSize) { + // object shape is constant + auto castTy = fir::ReferenceType::get(genType(sym)); + if (addr) + addr = builder->createConvert(loc, castTy, addr); + if (sia.lboundIsAllOnes()) { + // if lower bounds are all ones, build simple shaped object + llvm::SmallVector shape; + for (auto i : sia.staticShape) + shape.push_back(builder->createIntegerConstant(idxTy, i)); + if (sia.isChar) { + if (isDummy) { + localSymbols.addCharSymbolWithShape(sym, addr, len, shape, true); + return; + } + // local CHARACTER array with constant size + auto local = createNewLocal(loc, sym); + localSymbols.addCharSymbolWithShape(sym, local, len, shape); + return; + } + if (isDummy) { + localSymbols.addSymbolWithShape(sym, addr, shape, true); + return; + } + // local array with constant size + auto local = createNewLocal(loc, sym); + localSymbols.addSymbolWithShape(sym, local, shape); + return; + } + } else { + // cast to the known constant parts from the declaration + auto castTy = fir::ReferenceType::get(genType(sym)); + if (addr) { + // XXX: special handling for boxchar; see proviso above + if (auto box = + dyn_cast_or_null(addr.getDefiningOp())) + addr = builder->createConvert(loc, castTy, box.memref()); + else + addr = builder->createConvert(loc, castTy, addr); + } + } + // construct constants and populate `bounds` + for (const auto &i : llvm::zip(sia.staticLBound, sia.staticShape)) { + auto fst = builder->createIntegerConstant(idxTy, std::get<0>(i)); + auto snd = builder->createIntegerConstant(idxTy, std::get<1>(i)); + bounds.emplace_back(fst, snd); + } + + // default array case: populate `bounds` with lower and extent values + for (const auto &spec : sia.dynamicBound) { + auto low = spec->lbound().GetExplicit(); + auto high = spec->ubound().GetExplicit(); + if (low && high) { + // let the folder deal with the common `ub - 1 + 1` case + auto lb = genExprValue(Fortran::semantics::SomeExpr{*low}); + auto ub = genExprValue(Fortran::semantics::SomeExpr{*high}); + auto ty = ub.getType(); + auto diff = builder->create(loc, ty, ub, lb); + auto one = builder->createIntegerConstant(ty, 1); + auto sz = builder->create(loc, ty, diff, one); + auto idx = builder->createConvert(loc, idxTy, sz); + bounds.emplace_back(lb, idx); + continue; + } + if (low && spec->ubound().isAssumed()) { + // An assumed size array. The extent is not computed. + auto lb = genExprValue(Fortran::semantics::SomeExpr{*low}); + bounds.emplace_back(lb, mlir::Value{}); + } + break; + } + + auto unzipInto = + [&](llvm::SmallVectorImpl &shape, + llvm::ArrayRef bounds) { + std::for_each(bounds.begin(), bounds.end(), [&](const auto &pair) { + mlir::Value second; + std::tie(std::ignore, second) = pair; + shape.push_back(second); + }); + }; + if (sia.isChar) { + if (isDummy) { + localSymbols.addCharSymbolWithBounds(sym, addr, len, bounds, true); + return; + } + // local CHARACTER array with computed bounds + assert(!mustBeDummy); + llvm::SmallVector shape; + shape.push_back(len); + unzipInto(shape, bounds); + auto local = createNewLocal(loc, sym, shape); + localSymbols.addCharSymbolWithBounds(sym, local, len, bounds); + return; + } + if (isDummy) { + localSymbols.addSymbolWithBounds(sym, addr, bounds, true); + return; + } + // local array with computed bounds + assert(!mustBeDummy); + llvm::SmallVector shape; + unzipInto(shape, bounds); + auto local = createNewLocal(loc, sym, shape); + localSymbols.addSymbolWithBounds(sym, local, bounds); + return; + } + + // not an array, so process as scalar argument + if (sia.isChar) { + if (isDummy) { + addCharSymbol(sym, addr, len, true); + return; + } + assert(!mustBeDummy); + auto charTy = genType(sym); + auto c = sia.getCharLenConst(); + mlir::Value local = c ? builder->createCharacterTemp(charTy, *c) + : builder->createCharacterTemp(charTy, len); + addCharSymbol(sym, local, len); + return; + } + if (isDummy) { + addSymbol(sym, addr, true); + return; + } + auto local = createNewLocal(loc, sym); + addSymbol(sym, local); + } + + void instantiateVar(const Fortran::lower::pft::Variable &var) { + if (var.isGlobal()) + instantiateGlobal(var); + else + instantiateLocal(var); + } + + /// Prepare to translate a new function + void startNewFunction(Fortran::lower::pft::FunctionLikeUnit &funit) { + assert(!builder && "expected nullptr"); + // get mangled name + std::string name = funit.isMainProgram() + ? uniquer.doProgramEntry().str() + : mangleName(funit.getSubprogramSymbol()); + // FIXME: do NOT use unknown for the anonymous PROGRAM case. We probably + // should just stash the location in the funit regardless. + mlir::Location loc = toLocation(funit.getStartingSourceLoc()); + mlir::FuncOp func = + Fortran::lower::FirOpBuilder::getNamedFunction(module, name); + if (!func) + func = createNewFunction(loc, name, funit.symbol); + builder = new Fortran::lower::FirOpBuilder(func, kindMap); + assert(builder && "FirOpBuilder did not instantiate"); + func.addEntryBlock(); + builder->setInsertionPointToStart(&func.front()); + bool hasAlternateReturns = false; + + auto *entryBlock = &func.front(); + if (funit.symbol && !funit.isMainProgram()) { + const auto &details = + funit.symbol->get(); + auto blockIter = entryBlock->getArguments().begin(); + for (const auto &dummy : details.dummyArgs()) { + if (dummy) + addSymbol(*dummy, *blockIter++); + else + hasAlternateReturns = true; + } + } + for (const auto &var : funit.getOrderedSymbolTable()) + instantiateVar(var); + + // Create most function blocks in advance. + createEmptyBlocks(funit.evaluationList); + + // Reinstate entry block as the current insertion point. + builder->setInsertionPointToEnd(&func.front()); + + if (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(); + const auto altResult = builder->createTemporary( + toLocation(), builder->getIndexType(), symbol.name().ToString()); + addSymbol(symbol, altResult); + const auto zero = + builder->createIntegerConstant(builder->getIndexType(), 0); + builder->create(toLocation(), zero, altResult); + } + } + + /// Create empty blocks for the current function. + void createEmptyBlocks( + std::list &evaluationList) { + for (auto &eval : evaluationList) { + if (eval.isNewBlock) + eval.block = builder->createBlock(&builder->getRegion()); + for (size_t i = 0, n = eval.localBlocks.size(); i < n; ++i) + eval.localBlocks[i] = builder->createBlock(&builder->getRegion()); + if (eval.isConstruct()) { + if (eval.lowerAsUnstructured()) { + createEmptyBlocks(*eval.evaluationList); + } else { + // A structured construct that is a target starts a new block. + Fortran::lower::pft::Evaluation &constructStmt = + eval.evaluationList->front(); + if (constructStmt.isNewBlock) + constructStmt.block = builder->createBlock(&builder->getRegion()); + } + } + } + } + + /// Return the predicate: "current block does not have a terminator branch". + bool blockIsUnterminated() { + auto *currentBlock = builder->getBlock(); + return currentBlock->empty() || currentBlock->back().isKnownNonTerminator(); + } + + /// Unconditionally switch code insertion to a new block. + void startBlock(mlir::Block *newBlock) { + assert(newBlock && "missing block"); + // If the current block does not have a terminator branch, + // append a fallthrough branch. + if (blockIsUnterminated()) + genBranch(newBlock); + builder->setInsertionPointToStart(newBlock); + } + + /// 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::FunctionLikeUnit::stmtSourceLoc(funit.endStmt)); + + if (funit.isMainProgram()) + genExitRoutine(); + else + genFIRProcedureExit(funit, funit.getSubprogramSymbol()); + + // immediately throw away any dead code just created + mlir::simplifyRegions({builder->getRegion()}); + delete builder; + builder = nullptr; + localSymbols.clear(); + } + + /// Lower a procedure-like construct + void lowerFunc(Fortran::lower::pft::FunctionLikeUnit &funit) { + startNewFunction(funit); + // lower this procedure + for (auto &eval : funit.evaluationList) + genFIR(eval); + endNewFunction(funit); + // recursively lower internal procedures + for (auto &f : funit.nestedFunctions) + lowerFunc(f); + } + + void lowerMod(Fortran::lower::pft::ModuleLikeUnit &mod) { + // FIXME: do we need to visit the module statements? + 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); } + + mlir::MLIRContext &mlirContext; + const Fortran::parser::CookedSource *cooked; + mlir::ModuleOp &module; + const Fortran::common::IntrinsicTypeDefaultKinds &defaults; + Fortran::lower::FirOpBuilder *builder = nullptr; + const fir::KindMapping &kindMap; + fir::NameUniquer &uniquer; + Fortran::lower::SymMap localSymbols; + Fortran::parser::CharBlock currentPosition; +}; + +} // namespace + +void Fortran::lower::LoweringBridge::lower( + const Fortran::parser::Program &prg, fir::NameUniquer &uniquer, + const Fortran::semantics::SemanticsContext &semanticsContext) { + auto pft = Fortran::lower::createPFT(prg, semanticsContext); + if (dumpBeforeFir) + Fortran::lower::dumpPFT(llvm::errs(), *pft); + FirConverter converter{*this, uniquer}; + converter.run(*pft); +} + +void Fortran::lower::LoweringBridge::parseSourceFile(llvm::SourceMgr &srcMgr) { + auto owningRef = mlir::parseSourceFile(srcMgr, context.get()); + module.reset(new mlir::ModuleOp(owningRef.get().getOperation())); + owningRef.release(); +} + +Fortran::lower::LoweringBridge::LoweringBridge( + const Fortran::common::IntrinsicTypeDefaultKinds &defaultKinds, + const Fortran::parser::CookedSource *cooked) + : defaultKinds{defaultKinds}, cooked{cooked}, + context{std::make_unique()}, kindMap{context.get()} { + module = std::make_unique( + mlir::ModuleOp::create(mlir::UnknownLoc::get(context.get()))); +} diff --git a/flang/lib/Lower/CMakeLists.txt b/flang/lib/Lower/CMakeLists.txt index 6cbcfc3b630e8d..e5efdc80c72a5a 100644 --- a/flang/lib/Lower/CMakeLists.txt +++ b/flang/lib/Lower/CMakeLists.txt @@ -1,7 +1,27 @@ +set(CMAKE_CXX_FLAGS "${CMAKE_CXX_FLAGS} -Wno-error -Wno-unused-parameter") add_flang_library(FortranLower + Bridge.cpp + CharRT.cpp + ConvertExpr.cpp + ConvertType.cpp + FIRBuilder.cpp + Intrinsics.cpp + IO.cpp + Mangler.cpp PFTBuilder.cpp + Runtime.cpp - LINK_COMPONENTS - Support + DEPENDS + MLIROpAsmInterfacesIncGen + MLIRControlFlowInterfaces + MLIRLinalgStructuredOpsInterfaceIncGen +) + +target_link_libraries(FortranLower + FIRSupport + MLIRAffineToStandard + MLIRLLVMIR + MLIRSCFToStandard + MLIRStandardOps ) diff --git a/flang/lib/Lower/CharRT.cpp b/flang/lib/Lower/CharRT.cpp new file mode 100644 index 00000000000000..b11326a8711c3b --- /dev/null +++ b/flang/lib/Lower/CharRT.cpp @@ -0,0 +1,130 @@ +//===-- CharRT.cpp -- runtime support 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/CharRT.h" +#include "../../runtime/character.h" +#include "RTBuilder.h" +#include "flang/Lower/Bridge.h" +#include "flang/Lower/FIRBuilder.h" +#include "mlir/Dialect/StandardOps/IR/Ops.h" + +#define TODO() llvm_unreachable("not yet implemented") + +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(Fortran::lower::FirOpBuilder &builder) { + auto name = getName(); + auto func = builder.getNamedFunction(name); + if (func) + return func; + auto funTy = getTypeModel()(builder.getContext()); + func = builder.createFunction(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(); + builder.setLocation(loc); + mlir::FuncOp beginFunc; + switch (discoverKind(lhsBuff.getType())) { + case 1: + beginFunc = getRuntimeFunc(builder); + break; + case 2: + beginFunc = getRuntimeFunc(builder); + break; + case 4: + beginFunc = getRuntimeFunc(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(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(); + builder.setLocation(loc); + auto lhsPair = builder.materializeCharacter(lhs); + auto rhsPair = builder.materializeCharacter(rhs); + return genRawCharCompare(converter, loc, cmp, lhsPair.first, lhsPair.second, + rhsPair.first, rhsPair.second); +} diff --git a/flang/lib/Lower/ConvertExpr.cpp b/flang/lib/Lower/ConvertExpr.cpp new file mode 100644 index 00000000000000..777240f04fdbe7 --- /dev/null +++ b/flang/lib/Lower/ConvertExpr.cpp @@ -0,0 +1,1080 @@ +//===-- ConvertExpr.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/ConvertExpr.h" +#include "SymbolMap.h" +#include "flang/Common/default-kinds.h" +#include "flang/Common/unwrap.h" +#include "flang/Evaluate/fold.h" +#include "flang/Evaluate/real.h" +#include "flang/Lower/Bridge.h" +#include "flang/Lower/CharRT.h" +#include "flang/Lower/ConvertType.h" +#include "flang/Lower/FIRBuilder.h" +#include "flang/Lower/Runtime.h" +#include "flang/Optimizer/Dialect/FIRDialect.h" +#include "flang/Semantics/expression.h" +#include "flang/Semantics/symbol.h" +#include "flang/Semantics/type.h" +#include "mlir/Dialect/Affine/IR/AffineOps.h" +#include "mlir/Dialect/LLVMIR/LLVMDialect.h" +#include "mlir/Dialect/StandardOps/IR/Ops.h" +#include "mlir/IR/Attributes.h" +#include "mlir/IR/Operation.h" +#include "mlir/IR/PatternMatch.h" +#include "mlir/Pass/Pass.h" +#include "mlir/Pass/PassManager.h" +#include "mlir/Transforms/DialectConversion.h" +#include "mlir/Transforms/Passes.h" +#include "llvm/ADT/APFloat.h" +#include "llvm/ADT/ArrayRef.h" +#include "llvm/IR/Type.h" +#include "llvm/Support/ErrorHandling.h" +#include "llvm/Support/raw_ostream.h" + +namespace { + +#define TODO() llvm_unreachable("not yet implemented") + +/// Lowering of Fortran::evaluate::Expr expressions +class ExprLowering { +public: + explicit ExprLowering(mlir::Location loc, + Fortran::lower::AbstractConverter &converter, + const Fortran::lower::SomeExpr &vop, + Fortran::lower::SymMap &map) + : location{loc}, converter{converter}, + builder{converter.getFirOpBuilder()}, expr{vop}, symMap{map} {} + + /// Lower the expression `expr` into MLIR standard dialect + mlir::Value gen() { return gen(expr); } + mlir::Value genval() { return genval(expr); } + +private: + mlir::Location location; + Fortran::lower::AbstractConverter &converter; + Fortran::lower::FirOpBuilder &builder; + const Fortran::lower::SomeExpr &expr; + Fortran::lower::SymMap &symMap; + + mlir::Location getLoc() { return location; } + + /// 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; + } + llvm_unreachable("unhandled INTEGER relational operator"); + } + + /// 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; + } + llvm_unreachable("unhandled REAL relational operator"); + } + + /// 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); + auto attr = builder.getIntegerAttr(type, value); + return builder.create(getLoc(), type, attr); + } + + /// Generate a logical/boolean constant of `value` + mlir::Value genBoolConstant(mlir::MLIRContext *context, bool value) { + auto i1Type = builder.getI1Type(); + auto attr = builder.getIntegerAttr(i1Type, value ? 1 : 0); + return builder.create(getLoc(), i1Type, attr).getResult(); + } + + template + mlir::Value genRealConstant(mlir::MLIRContext *context, + const llvm::APFloat &value) { + auto fltTy = Fortran::lower::convertReal(context, KIND); + auto attr = builder.getFloatAttr(fltTy, value); + auto res = builder.create(getLoc(), fltTy, attr); + return res.getResult(); + } + + mlir::Type getSomeKindInteger() { return builder.getIndexType(); } + + template + mlir::Value createBinaryOp(const A &ex, mlir::Value lhs, mlir::Value rhs) { + assert(lhs && rhs && "argument did not lower"); + auto x = builder.create(getLoc(), lhs, rhs); + return x.getResult(); + } + template + mlir::Value createBinaryOp(const A &ex, mlir::Value rhs) { + return createBinaryOp(ex, genval(ex.left()), rhs); + } + template + mlir::Value createBinaryOp(const A &ex) { + return createBinaryOp(ex, genval(ex.left()), genval(ex.right())); + } + + mlir::FuncOp getFunction(llvm::StringRef name, mlir::FunctionType funTy) { + if (auto func = builder.getNamedFunction(name)) + return func; + return builder.createFunction(name, funTy); + } + + template + mlir::FunctionType createFunctionType() { + if constexpr (TC == Fortran::common::TypeCategory::Integer) { + auto output = + converter.genType(Fortran::common::TypeCategory::Integer, KIND); + llvm::SmallVector inputs; + inputs.push_back(output); + inputs.push_back(output); + return mlir::FunctionType::get(inputs, output, builder.getContext()); + } else if constexpr (TC == Fortran::common::TypeCategory::Real) { + auto output = Fortran::lower::convertReal(builder.getContext(), KIND); + llvm::SmallVector inputs; + inputs.push_back(output); + inputs.push_back(output); + return mlir::FunctionType::get(inputs, output, builder.getContext()); + } else { + llvm_unreachable("this category is not implemented"); + } + } + + template + mlir::Value createCompareOp(mlir::CmpIPredicate pred, mlir::Value lhs, + mlir::Value rhs) { + return builder.create(getLoc(), pred, lhs, rhs); + } + template + mlir::Value createCompareOp(const A &ex, mlir::CmpIPredicate pred) { + return createCompareOp(pred, genval(ex.left()), genval(ex.right())); + } + + template + mlir::Value createFltCmpOp(mlir::CmpFPredicate pred, mlir::Value lhs, + mlir::Value rhs) { + return builder.create(getLoc(), pred, lhs, rhs); + } + template + mlir::Value createFltCmpOp(const A &ex, mlir::CmpFPredicate pred) { + return createFltCmpOp(pred, genval(ex.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, mlir::Value lhs, + mlir::Value rhs) { + return Fortran::lower::genBoxCharCompare(converter, getLoc(), pred, lhs, + rhs); + } + template + mlir::Value createCharCompare(const A &ex, mlir::CmpIPredicate pred) { + return createCharCompare(pred, genval(ex.left()), genval(ex.right())); + } + + /// Returns a reference to a symbol or its box/boxChar descriptor if it has + /// one. + mlir::Value gen(Fortran::semantics::SymbolRef sym) { + if (auto val = symMap.lookupSymbol(sym)) + return val; + llvm_unreachable("all symbols should be in the map"); + auto addr = builder.createTemporary(getLoc(), converter.genType(sym), + sym->name().ToString()); + symMap.addSymbol(sym, addr); + return addr; + } + + mlir::Value gendef(Fortran::semantics::SymbolRef sym) { return gen(sym); } + + mlir::Value genLoad(mlir::Value addr) { + return builder.create(getLoc(), addr); + } + + mlir::Value genval(Fortran::semantics::SymbolRef sym) { + auto var = gen(sym); + if (fir::isReferenceLike(var.getType())) + return genLoad(var); + return var; + } + + mlir::Value genval(const Fortran::evaluate::BOZLiteralConstant &) { TODO(); } + mlir::Value genval(const Fortran::evaluate::ProcedureDesignator &) { TODO(); } + mlir::Value genval(const Fortran::evaluate::NullPointer &) { TODO(); } + mlir::Value genval(const Fortran::evaluate::StructureConstructor &) { + TODO(); + } + mlir::Value genval(const Fortran::evaluate::ImpliedDoIndex &) { TODO(); } + + mlir::Value genval(const Fortran::evaluate::DescriptorInquiry &desc) { + auto descRef = symMap.lookupSymbol(desc.base().GetLastSymbol()); + assert(descRef && "no mlir::Value associated to Symbol"); + auto descType = descRef.getAddr().getType(); + mlir::Value res{}; + switch (desc.field()) { + case Fortran::evaluate::DescriptorInquiry::Field::Len: + if (descType.isa()) { + auto lenType = builder.getLengthType(); + res = builder.create(getLoc(), lenType, descRef); + } else if (descType.isa()) { + TODO(); + } else { + llvm_unreachable("not a descriptor"); + } + break; + default: + TODO(); + } + return res; + } + + template + mlir::Value genval(const Fortran::evaluate::TypeParamInquiry &) { + TODO(); + } + + template + mlir::Value genval(const Fortran::evaluate::ComplexComponent &part) { + builder.setLocation(getLoc()); + return builder.extractComplexPart(genval(part.left()), + part.isImaginaryPart); + } + + template + mlir::Value genval( + const Fortran::evaluate::Negate> &op) { + auto input = genval(op.left()); + if constexpr (TC == Fortran::common::TypeCategory::Integer) { + // Currently no Standard/FIR op for integer negation. + auto zero = genIntegerConstant(builder.getContext(), 0); + return builder.create(getLoc(), zero, input); + } else if constexpr (TC == Fortran::common::TypeCategory::Real) { + return builder.create(getLoc(), input); + } else { + static_assert(TC == Fortran::common::TypeCategory::Complex, + "Expected numeric type"); + return createBinaryOp(op); + } + } + + template + mlir::Value + genval(const Fortran::evaluate::Add> &op) { + if constexpr (TC == Fortran::common::TypeCategory::Integer) { + return createBinaryOp(op); + } else if constexpr (TC == Fortran::common::TypeCategory::Real) { + return createBinaryOp(op); + } else { + static_assert(TC == Fortran::common::TypeCategory::Complex, + "Expected numeric type"); + return createBinaryOp(op); + } + } + template + mlir::Value + genval(const Fortran::evaluate::Subtract> + &op) { + if constexpr (TC == Fortran::common::TypeCategory::Integer) { + return createBinaryOp(op); + } else if constexpr (TC == Fortran::common::TypeCategory::Real) { + return createBinaryOp(op); + } else { + static_assert(TC == Fortran::common::TypeCategory::Complex, + "Expected numeric type"); + return createBinaryOp(op); + } + } + + template + mlir::Value + genval(const Fortran::evaluate::Multiply> + &op) { + if constexpr (TC == Fortran::common::TypeCategory::Integer) { + return createBinaryOp(op); + } else if constexpr (TC == Fortran::common::TypeCategory::Real) { + return createBinaryOp(op); + } else { + static_assert(TC == Fortran::common::TypeCategory::Complex, + "Expected numeric type"); + return createBinaryOp(op); + } + } + + template + mlir::Value genval( + const Fortran::evaluate::Divide> &op) { + if constexpr (TC == Fortran::common::TypeCategory::Integer) { + return createBinaryOp(op); + } else if constexpr (TC == Fortran::common::TypeCategory::Real) { + return createBinaryOp(op); + } else { + static_assert(TC == Fortran::common::TypeCategory::Complex, + "Expected numeric type"); + return createBinaryOp(op); + } + } + + template + mlir::Value genval( + const Fortran::evaluate::Power> &op) { + auto ty = converter.genType(TC, KIND); + return builder.genPow(ty, genval(op.left()), genval(op.right())); + } + + template + mlir::Value genval( + const Fortran::evaluate::RealToIntPower> + &op) { + auto ty = converter.genType(TC, KIND); + return builder.genPow(ty, genval(op.left()), genval(op.right())); + } + + template + mlir::Value genval(const Fortran::evaluate::ComplexConstructor &op) { + builder.setLocation(getLoc()); + return builder.createComplex(KIND, genval(op.left()), genval(op.right())); + } + + template + mlir::Value genval(const Fortran::evaluate::Concat &op) { + return builder.createConcatenate(genval(op.left()), genval(op.right())); + } + + /// MIN and MAX operations + template + mlir::Value + genval(const Fortran::evaluate::Extremum> + &op) { + std::string name = + op.ordering == Fortran::evaluate::Ordering::Greater ? "max"s : "min"s; + auto type = converter.genType(TC, KIND); + llvm::SmallVector operands{genval(op.left()), + genval(op.right())}; + return builder.genIntrinsicCall(name, type, operands); + } + + template + mlir::Value genval(const Fortran::evaluate::SetLength &) { + TODO(); + } + + template + mlir::Value + genval(const Fortran::evaluate::Relational> + &op) { + mlir::Value result{}; + if constexpr (TC == Fortran::common::TypeCategory::Integer) { + result = createCompareOp(op, translateRelational(op.opr)); + } else if constexpr (TC == Fortran::common::TypeCategory::Real) { + result = + createFltCmpOp(op, translateFloatRelational(op.opr)); + } else if constexpr (TC == Fortran::common::TypeCategory::Complex) { + bool eq{op.opr == Fortran::common::RelationalOperator::EQ}; + if (!eq && op.opr != Fortran::common::RelationalOperator::NE) + llvm_unreachable("relation undefined for complex"); + builder.setLocation(getLoc()); + result = builder.createComplexCompare(genval(op.left()), + genval(op.right()), eq); + } else { + static_assert(TC == Fortran::common::TypeCategory::Character); + builder.setLocation(getLoc()); + result = createCharCompare(op, translateRelational(op.opr)); + } + return result; + } + + mlir::Value + genval(const Fortran::evaluate::Relational &op) { + return std::visit([&](const auto &x) { return genval(x); }, op.u); + } + + template + mlir::Value + genval(const Fortran::evaluate::Convert, + TC2> &convert) { + auto ty = converter.genType(TC1, KIND); + auto operand = genval(convert.left()); + return builder.createConvert(getLoc(), ty, operand); + } + + template + mlir::Value genval(const Fortran::evaluate::Parentheses &op) { + auto input = genval(op.left()); + return builder.create(getLoc(), input.getType(), input); + } + + template + mlir::Value genval(const Fortran::evaluate::Not &op) { + auto *context = builder.getContext(); + auto logical = genval(op.left()); + auto one = genBoolConstant(context, true); + auto val = builder.createConvert(getLoc(), builder.getI1Type(), logical); + return builder.create(getLoc(), val, one); + } + + template + mlir::Value genval(const Fortran::evaluate::LogicalOperation &op) { + mlir::Value result; + auto i1Type = builder.getI1Type(); + auto lhs = builder.createConvert(getLoc(), i1Type, genval(op.left())); + auto rhs = builder.createConvert(getLoc(), i1Type, genval(op.right())); + switch (op.logicalOperator) { + case Fortran::evaluate::LogicalOperator::And: + result = createBinaryOp(op, lhs, rhs); + break; + case Fortran::evaluate::LogicalOperator::Or: + result = createBinaryOp(op, lhs, rhs); + break; + case Fortran::evaluate::LogicalOperator::Eqv: + result = createCompareOp(mlir::CmpIPredicate::eq, lhs, rhs); + break; + case Fortran::evaluate::LogicalOperator::Neqv: + result = createCompareOp(mlir::CmpIPredicate::ne, lhs, rhs); + break; + case Fortran::evaluate::LogicalOperator::Not: + // lib/evaluate expression for .NOT. is Fortran::evaluate::Not. + llvm_unreachable(".NOT. is not a binary operator"); + } + if (!result) + llvm_unreachable("unhandled logical operation"); + return result; + } + + /// Construct a CHARACTER literal + template + mlir::Value genCharLit(const E &data, int64_t size) { + auto type = fir::SequenceType::get( + {size}, fir::CharacterType::get(builder.getContext(), KIND)); + // FIXME: for wider char types, use an array of i16 or i32 + // for now, just fake it that it's a i8 to get it past the C++ compiler + if constexpr (KIND == 1) { + std::string globalName = converter.uniqueCGIdent("cl", data); + auto global = builder.getNamedGlobal(globalName); + if (!global) + global = builder.createGlobalConstant( + getLoc(), type, globalName, + [&](Fortran::lower::FirOpBuilder &builder) { + auto context = builder.getContext(); + auto strAttr = mlir::StringAttr::get(data.c_str(), context); + 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(size)); + llvm::SmallVector attrs{dataAttr, + sizeAttr}; + auto str = builder.create( + getLoc(), llvm::ArrayRef{type}, llvm::None, + attrs); + builder.create(getLoc(), str); + }); + return builder.create(getLoc(), global.resultType(), + global.getSymbol()); + } + auto context = builder.getContext(); + auto valTag = mlir::Identifier::get(fir::StringLitOp::value(), context); + auto strAttr = mlir::StringAttr::get((const char *)data.c_str(), context); + mlir::NamedAttribute dataAttr(valTag, strAttr); + auto sizeTag = mlir::Identifier::get(fir::StringLitOp::size(), context); + mlir::NamedAttribute sizeAttr(sizeTag, builder.getI64IntegerAttr(size)); + llvm::SmallVector attrs{dataAttr, sizeAttr}; + return builder.create( + getLoc(), llvm::ArrayRef{type}, llvm::None, attrs); + } + + template + mlir::Value 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(builder.getContext(), 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 == 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; + return genval(Fortran::evaluate::ComplexConstructor{ + Fortran::evaluate::Expr{ + Fortran::evaluate::Constant{value.REAL()}}, + Fortran::evaluate::Expr{ + Fortran::evaluate::Constant{value.AIMAG()}}}); + } else { + llvm_unreachable("unhandled constant"); + } + } + + template + mlir::Value genArrayLit( + const Fortran::evaluate::Constant> + &con) { + // Convert Ev::ConstantSubs to SequenceType::Shape + fir::SequenceType::Shape shape(con.shape().begin(), con.shape().end()); + auto arrayTy = fir::SequenceType::get(shape, converter.genType(TC, KIND)); + auto idxTy = builder.getIndexType(); + mlir::Value array = builder.create(getLoc(), arrayTy); + Fortran::evaluate::ConstantSubscripts subscripts = con.lbounds(); + do { + auto constant = genScalarLit(con.At(subscripts)); + std::vector idx; + for (const auto &pair : llvm::zip(subscripts, con.lbounds())) { + const auto &dim = std::get<0>(pair); + const auto &lb = std::get<1>(pair); + idx.push_back(builder.createIntegerConstant(idxTy, dim - lb)); + } + array = builder.create(getLoc(), arrayTy, array, + constant, idx); + } while (con.IncrementSubscripts(subscripts)); + return array; + } + + template + mlir::Value + genval(const Fortran::evaluate::Constant> + &con) { + // TODO: + // - derived type constant + if (con.Rank() > 0) + return genArrayLit(con); + + using T = Fortran::evaluate::Type; + const std::optional> &opt = + con.GetScalarValue(); + if (!opt.has_value()) + llvm_unreachable("constant has no value"); + if constexpr (TC == Fortran::common::TypeCategory::Character) { + return genCharLit(opt.value(), con.LEN()); + } + return genScalarLit(opt.value()); + } + + template + mlir::Value genval( + const Fortran::evaluate::Constant> &con) { + if constexpr (TC == Fortran::common::TypeCategory::Integer) { + auto opt = (*con).ToInt64(); + auto type = getSomeKindInteger(); + auto attr = builder.getIntegerAttr(type, opt); + auto res = builder.create(getLoc(), type, attr); + return res.getResult(); + } else { + llvm_unreachable("unhandled constant of unknown kind"); + } + } + + template + mlir::Value genval(const Fortran::evaluate::ArrayConstructor &) { + TODO(); + } + mlir::Value gen(const Fortran::evaluate::ComplexPart &) { TODO(); } + mlir::Value gendef(const Fortran::evaluate::ComplexPart &cp) { + return gen(cp); + } + mlir::Value genval(const Fortran::evaluate::ComplexPart &) { TODO(); } + + mlir::Value 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 &) + -> mlir::Value { TODO(); }, + }, + s.parent()); + llvm::SmallVector bounds; + bounds.push_back(genval(s.lower())); + if (auto upperBound{s.upper()}) { + bounds.push_back(genval(*upperBound)); + } + return builder.createSubstring(baseString, bounds); + } + + mlir::Value gendef(const Fortran::evaluate::Substring &ss) { return gen(ss); } + mlir::Value genval(const Fortran::evaluate::Substring &ss) { return gen(ss); } + mlir::Value genval(const Fortran::evaluate::Triplet &trip) { TODO(); } + + mlir::Value genval(const Fortran::evaluate::Subscript &subs) { + return std::visit( + Fortran::common::visitors{ + [&](const Fortran::evaluate::IndirectSubscriptIntegerExpr &x) { + return genval(x.value()); + }, + [&](const Fortran::evaluate::Triplet &x) { return genval(x); }, + }, + subs.u); + } + + mlir::Value gen(const Fortran::evaluate::DataRef &dref) { + return std::visit([&](const auto &x) { return gen(x); }, dref.u); + } + mlir::Value gendef(const Fortran::evaluate::DataRef &dref) { + return gen(dref); + } + mlir::Value 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. + // 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) { + return reverseComponents(x, list); + }, + [&](auto &) { return &cmpt.base(); }, + }, + cmpt.base().u); + } + + // Return the coordinate of the component reference + mlir::Value gen(const Fortran::evaluate::Component &cmpt) { + std::list list; + auto *base = reverseComponents(cmpt, list); + llvm::SmallVector coorArgs; + auto obj = gen(*base); + auto *sym = &cmpt.GetFirstSymbol(); + auto ty = converter.genType(*sym); + for (auto *field : list) { + sym = &field->GetLastSymbol(); + auto name = sym->name().ToString(); + // FIXME: as we're walking the chain of field names, we need to update the + // subtype as we drill down + coorArgs.push_back(builder.create(getLoc(), name, ty)); + } + assert(sym && "no component(s)?"); + ty = fir::ReferenceType::get(ty); + return builder.create(getLoc(), ty, obj, coorArgs); + } + + mlir::Value gendef(const Fortran::evaluate::Component &cmpt) { + return gen(cmpt); + } + mlir::Value 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 = arrTy.cast().getEleTy(); + 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. + mlir::Value 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(); + } + + mlir::Value genArrayRefComponent(const Fortran::evaluate::ArrayRef &aref) { + mlir::Value base = gen(aref.base().GetComponent()); + llvm::SmallVector args; + for (auto &subsc : aref.subscript()) + args.push_back(genval(subsc)); + auto ty = genSubType(base.getType(), args.size()); + ty = fir::ReferenceType::get(ty); + return builder.create(getLoc(), ty, base, args); + } + + mlir::Value gen(const Fortran::lower::SymIndex &si, + const Fortran::evaluate::ArrayRef &aref) { + auto loc = getLoc(); + auto addr = si.getAddr(); + auto arrTy = fir::dyn_cast_ptrEleTy(addr.getType()); + auto eleTy = arrTy.cast().getEleTy(); + auto refTy = fir::ReferenceType::get(eleTy); + auto base = builder.createConvert(loc, refTy, addr); + auto idxTy = builder.getIndexType(); + auto one = builder.createIntegerConstant(idxTy, 1); + auto zero = builder.createIntegerConstant(idxTy, 0); + auto genShaped = [&](const auto &arr, mlir::Value delta) -> mlir::Value { + mlir::Value total = zero; + assert(arr.shape.size() == aref.subscript().size()); + for (const auto &pair : llvm::zip(arr.shape, aref.subscript())) { + auto val = builder.createConvert(loc, idxTy, genval(std::get<1>(pair))); + auto diff = builder.create(loc, val, one); + auto prod = builder.create(loc, delta, diff); + total = builder.create(loc, prod, total); + delta = builder.create(loc, delta, std::get<0>(pair)); + } + return builder.create( + loc, refTy, base, llvm::ArrayRef{total}); + }; + auto genFullDim = [&](const auto &arr, mlir::Value delta) -> mlir::Value { + mlir::Value total = zero; + assert(arr.shape.size() == aref.subscript().size()); + for (const auto &pair : llvm::zip(arr.shape, aref.subscript())) { + auto val = builder.createConvert(loc, idxTy, genval(std::get<1>(pair))); + auto lb = + builder.createConvert(loc, idxTy, std::get<0>(std::get<0>(pair))); + auto diff = builder.create(loc, val, lb); + auto prod = builder.create(loc, delta, diff); + total = builder.create(loc, prod, total); + if (auto ext = std::get<1>(std::get<0>(pair))) + delta = builder.create(loc, delta, ext); + } + return builder.create( + loc, refTy, base, llvm::ArrayRef{total}); + }; + return std::visit( + Fortran::common::visitors{ + [&](const Fortran::lower::SymIndex::Shaped &arr) { + return genShaped(arr, one); + }, + [&](const Fortran::lower::SymIndex::FullDim &arr) { + return genFullDim(arr, one); + }, + [&](const Fortran::lower::SymIndex::CharShaped &arr) { + return genShaped(arr, arr.len); + }, + [&](const Fortran::lower::SymIndex::CharFullDim &arr) { + return genFullDim(arr, arr.len); + }, + [&](const Fortran::lower::SymIndex::Derived &arr) { + TODO(); + return mlir::Value{}; + }, + [&](const auto &) { + TODO(); + return mlir::Value{}; + }}, + si.v); + } + + // Return the coordinate of the array reference + mlir::Value gen(const Fortran::evaluate::ArrayRef &aref) { + if (aref.base().IsSymbol()) { + auto &symbol = aref.base().GetFirstSymbol(); + auto si = symMap.lookupSymbol(symbol); + if (!si.hasConstantShape()) + return gen(si, aref); + mlir::Value base = gen(symbol); + auto &shape = + symbol.get().shape(); + unsigned i = 0; + llvm::SmallVector args; + for (auto &subsc : aref.subscript()) { + auto val = genval(subsc); + auto adj = genval(shape[i++].lbound()); + auto ty = val.getType(); + args.push_back(builder.create(getLoc(), ty, val, adj)); + } + auto ty = genSubType(base.getType(), args.size()); + ty = fir::ReferenceType::get(ty); + return builder.create(getLoc(), ty, base, args); + } + return genArrayRefComponent(aref); + } + + mlir::Value gendef(const Fortran::evaluate::ArrayRef &aref) { + return gen(aref); + } + + mlir::Value genval(const Fortran::evaluate::ArrayRef &aref) { + return genLoad(gen(aref)); + } + + // Return a coordinate of the coarray reference. This is necessary as a + // Component may have a CoarrayRef as its base coordinate. + mlir::Value gen(const Fortran::evaluate::CoarrayRef &coref) { + // FIXME: need to visit the cosubscripts... + // return gen(coref.base()); + TODO(); + } + mlir::Value gendef(const Fortran::evaluate::CoarrayRef &coref) { + return gen(coref); + } + mlir::Value genval(const Fortran::evaluate::CoarrayRef &coref) { + return genLoad(gen(coref)); + } + + template + mlir::Value gen(const Fortran::evaluate::Designator &des) { + return std::visit([&](const auto &x) { return gen(x); }, des.u); + } + template + mlir::Value gendef(const Fortran::evaluate::Designator &des) { + return gen(des); + } + template + mlir::Value genval(const Fortran::evaluate::Designator &des) { + return std::visit([&](const auto &x) { return genval(x); }, des.u); + } + + // call a function + template + mlir::Value gen(const Fortran::evaluate::FunctionRef &funRef) { + TODO(); + } + template + mlir::Value gendef(const Fortran::evaluate::FunctionRef &funRef) { + return gen(funRef); + } + template + mlir::Value genval(const Fortran::evaluate::FunctionRef &funRef) { + TODO(); // Derived type functions (user + intrinsics) + } + + mlir::Value + genIntrinsicRef(const Fortran::evaluate::ProcedureRef &procRef, + const Fortran::evaluate::SpecificIntrinsic &intrinsic, + mlir::ArrayRef resultType) { + if (resultType.size() != 1) + TODO(); // Intrinsic subroutine + + llvm::SmallVector operands; + // Lower arguments + // For now, logical arguments for intrinsic are lowered to `fir.logical` + // so that TRANSFER can work. For some arguments, it could lead to useless + // conversions (e.g scalar MASK of MERGE will be converted to `i1`), but + // the generated code is at least correct. To improve this, the intrinsic + // lowering facility should control argument lowering. + for (const auto &arg : procRef.arguments()) { + if (auto *expr = Fortran::evaluate::UnwrapExpr< + Fortran::evaluate::Expr>(arg)) { + operands.push_back(genval(*expr)); + } else { + operands.push_back(nullptr); // optional + } + } + // Let the intrinsic library lower the intrinsic procedure call + llvm::StringRef name{intrinsic.name}; + return builder.genIntrinsicCall(name, resultType[0], operands); + } + + template + bool isCharacterType(const A &exp) { + if (auto type = exp.GetType()) + return type->category() == Fortran::common::TypeCategory::Character; + return false; + } + + mlir::Value genProcedureRef(const Fortran::evaluate::ProcedureRef procRef, + mlir::ArrayRef resultType) { + if (const auto *intrinsic{procRef.proc().GetSpecificIntrinsic()}) { + return genIntrinsicRef(procRef, *intrinsic, resultType[0]); + } + // Implicit interface implementation only + // TODO: Explicit interface, we need to use Characterize here, + // evaluate::IntrinsicProcTable is required to use it. + llvm::SmallVector argTypes; + llvm::SmallVector operands; + // Arguments of user functions must be lowered to the correct type. + for (const auto &arg : procRef.arguments()) { + if (!arg.has_value()) + TODO(); // optional arguments + const auto *expr = arg->UnwrapExpr(); + if (!expr) + TODO(); // assumed type arguments + if (const auto *sym = + Fortran::evaluate::UnwrapWholeSymbolDataRef(*expr)) { + mlir::Value argRef = symMap.lookupSymbol(*sym); + assert(argRef && "could not get symbol reference"); + if (builder.isCharacter(argRef.getType())) { + argTypes.push_back(fir::BoxCharType::get( + builder.getContext(), + builder.getCharacterKind(argRef.getType()))); + auto ch = builder.materializeCharacter(argRef); + operands.push_back(builder.createEmboxChar(ch.first, ch.second)); + } else { + argTypes.push_back(argRef.getType()); + operands.push_back(argRef); + } + } else { + // create a temp to store the expression value + auto val = genval(*expr); + mlir::Value addr; + if (fir::isa_passbyref_type(val.getType())) { + // expression is already a reference, so just pass it + addr = val; + } else { + // expression is a value, so store it in a temporary so we can + // pass-by-reference + addr = builder.createTemporary(getLoc(), val.getType()); + builder.create(getLoc(), val, addr); + } + if (builder.isCharacter(addr.getType())) { + argTypes.push_back(fir::BoxCharType::get( + builder.getContext(), builder.getCharacterKind(addr.getType()))); + auto ch = builder.materializeCharacter(addr); + addr = builder.createEmboxChar(ch.first, ch.second); + } else { + argTypes.push_back(addr.getType()); + } + operands.push_back(addr); + } + } + mlir::FunctionType funTy = + mlir::FunctionType::get(argTypes, resultType, builder.getContext()); + auto funName = applyNameMangling(procRef.proc()); + auto func = getFunction(funName, funTy); + if (func.getType() != funTy) { + // In older Fortran, procedure argument types are inferenced. Deal with + // the potential mismatches by adding casts to the arguments when the + // inferenced types do not match exactly. + llvm::SmallVector castedOperands; + for (const auto &op : llvm::zip(operands, func.getType().getInputs())) { + auto cast = builder.convertWithSemantics(getLoc(), std::get<1>(op), + std::get<0>(op)); + castedOperands.push_back(cast); + } + operands.swap(castedOperands); + } + auto call = builder.create( + getLoc(), resultType, builder.getSymbolRefAttr(funName), operands); + + if (resultType.size() == 0) + return {}; // subroutine call + // For now, Fortran returned 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); + } + + template + mlir::Value + genval(const Fortran::evaluate::FunctionRef> + &funRef) { + llvm::SmallVector resTy; + resTy.push_back(converter.genType(TC, KIND)); + return genProcedureRef(funRef, resTy); + } + + mlir::Value genval(const Fortran::evaluate::ProcedureRef &procRef) { + llvm::SmallVector resTy; + if (procRef.HasAlternateReturns()) + resTy.push_back(builder.getIndexType()); + return genProcedureRef(procRef, resTy); + } + + template + mlir::Value gen(const Fortran::evaluate::Expr &exp) { + // must be a designator or function-reference (R902) + return std::visit([&](const auto &e) { return gendef(e); }, exp.u); + } + template + mlir::Value gendef(const Fortran::evaluate::Expr &exp) { + return gen(exp); + } + template + mlir::Value genval(const Fortran::evaluate::Expr &exp) { + return std::visit([&](const auto &e) { return genval(e); }, exp.u); + } + + template + mlir::Value genval(const Fortran::evaluate::Expr> &exp) { + return std::visit([&](const auto &e) { return genval(e); }, exp.u); + } + + template + mlir::Value gendef(const A &) { + llvm_unreachable("expression error"); + } + + std::string + applyNameMangling(const Fortran::evaluate::ProcedureDesignator &proc) { + if (const auto *symbol = proc.GetSymbol()) + return converter.mangleName(*symbol); + // Do not mangle intrinsic for now + assert(proc.GetSpecificIntrinsic() && + "expected intrinsic procedure in designator"); + return proc.GetName(); + } +}; + +} // namespace + +mlir::Value Fortran::lower::createSomeExpression( + mlir::Location loc, Fortran::lower::AbstractConverter &converter, + const Fortran::evaluate::Expr &expr, + Fortran::lower::SymMap &symMap) { + return ExprLowering{loc, converter, expr, symMap}.genval(); +} + +mlir::Value Fortran::lower::createSomeAddress( + mlir::Location loc, Fortran::lower::AbstractConverter &converter, + const Fortran::evaluate::Expr &expr, + Fortran::lower::SymMap &symMap) { + return ExprLowering{loc, converter, expr, symMap}.gen(); +} diff --git a/flang/lib/Lower/ConvertType.cpp b/flang/lib/Lower/ConvertType.cpp new file mode 100644 index 00000000000000..5e41a9e08b3fd4 --- /dev/null +++ b/flang/lib/Lower/ConvertType.cpp @@ -0,0 +1,555 @@ +//===-- ConvertType.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/ConvertType.h" +#include "../../runtime/io-api.h" +#include "flang/Lower/Bridge.h" +#include "flang/Lower/Utils.h" +#include "flang/Optimizer/Dialect/FIRType.h" +#include "flang/Semantics/expression.h" +#include "flang/Semantics/tools.h" +#include "flang/Semantics/type.h" +#include "mlir/IR/Builders.h" +#include "mlir/IR/Location.h" +#include "mlir/IR/MLIRContext.h" +#include "mlir/IR/StandardTypes.h" + +namespace { + +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(); +} + +#undef TODO +#define TODO() \ + assert(false && "not yet implemented"); \ + return {} + +// 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(bits, context); + } else if constexpr (TC == Fortran::common::TypeCategory::Logical || + TC == Fortran::common::TypeCategory::Character || + TC == Fortran::common::TypeCategory::Complex) { + return genFIRType(context, KIND); + } else { + return {}; + } +} + +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); +} + +template <> +mlir::Type genFIRType( + mlir::MLIRContext *context) { + return fir::RealType::get(context, 16); +} + +template <> +mlir::Type +genFIRType(mlir::MLIRContext *context, + int kind) { + if (Fortran::evaluate::IsValidKindOfIntrinsicType( + Fortran::common::TypeCategory::Real, kind)) { + switch (kind) { + case 2: + return genFIRType(context); + case 3: + return genFIRType(context); + case 4: + return genFIRType(context); + case 8: + return genFIRType(context); + case 10: + return genFIRType(context); + case 16: + return genFIRType(context); + } + assert(false && "type translation not implemented"); + } + return {}; +} + +template <> +mlir::Type +genFIRType(mlir::MLIRContext *context, + int kind) { + if (Fortran::evaluate::IsValidKindOfIntrinsicType( + Fortran::common::TypeCategory::Integer, kind)) { + switch (kind) { + case 1: + return genFIRType(context); + case 2: + return genFIRType(context); + case 4: + return genFIRType(context); + case 8: + return genFIRType(context); + case 16: + return genFIRType(context); + } + assert(false && "type translation not implemented"); + } + return {}; +} + +template <> +mlir::Type +genFIRType(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) { + if (Fortran::evaluate::IsValidKindOfIntrinsicType( + Fortran::common::TypeCategory::Character, KIND)) + return fir::CharacterType::get(context, KIND); + return {}; +} + +template <> +mlir::Type +genFIRType(mlir::MLIRContext *context, + int KIND) { + if (Fortran::evaluate::IsValidKindOfIntrinsicType( + Fortran::common::TypeCategory::Complex, KIND)) + return fir::CplxType::get(context, KIND); + return {}; +} + +/// Recover the type of an Fortran::evaluate::Expr and convert it to an +/// mlir::Type. The type returned can be a MLIR standard or FIR type. +class TypeBuilder { + mlir::MLIRContext *context; + const Fortran::common::IntrinsicTypeDefaultKinds &defaults; + + template + int defaultKind() { + return defaultKind(TC); + } + int defaultKind(Fortran::common::TypeCategory TC) { + return defaults.GetDefaultKind(TC); + } + + mlir::InFlightDiagnostic emitError(const llvm::Twine &message) { + return mlir::emitError(mlir::UnknownLoc::get(context), message); + } + + mlir::InFlightDiagnostic emitWarning(const llvm::Twine &message) { + return mlir::emitWarning(mlir::UnknownLoc::get(context), message); + } + + fir::SequenceType::Shape seqShapeHelper(Fortran::semantics::SymbolRef symbol, + fir::SequenceType::Shape &bounds) { + auto &details = symbol->get(); + const auto size = details.shape().size(); + for (auto &ss : details.shape()) { + auto lb = ss.lbound(); + auto ub = ss.ubound(); + if (lb.isAssumed() && ub.isAssumed() && size == 1) + return {}; + if (lb.isExplicit() && ub.isExplicit()) { + auto &lbv = lb.GetExplicit(); + auto &ubv = ub.GetExplicit(); + if (lbv.has_value() && ubv.has_value() && isConstant(lbv.value()) && + isConstant(ubv.value())) { + bounds.emplace_back(toConstant(ubv.value()) - + toConstant(lbv.value()) + 1); + } else { + bounds.emplace_back(fir::SequenceType::getUnknownExtent()); + } + } else { + bounds.emplace_back(fir::SequenceType::getUnknownExtent()); + } + } + return bounds; + } + +public: + explicit TypeBuilder( + mlir::MLIRContext *context, + const Fortran::common::IntrinsicTypeDefaultKinds &defaults) + : context{context}, defaults{defaults} {} + + // non-template, arguments are runtime values + mlir::Type genFIRTy(Fortran::common::TypeCategory tc, int kind) { + switch (tc) { + case Fortran::common::TypeCategory::Real: + return genFIRType(context, kind); + case Fortran::common::TypeCategory::Integer: + return genFIRType(context, kind); + case Fortran::common::TypeCategory::Complex: + return genFIRType(context, kind); + case Fortran::common::TypeCategory::Logical: + return genFIRType(context, kind); + case Fortran::common::TypeCategory::Character: + return genFIRType(context, + kind); + default: + break; + } + assert(false && "unhandled type category"); + return {}; + } + + // non-template, category is runtime values, kind is defaulted + mlir::Type genFIRTy(Fortran::common::TypeCategory tc) { + return genFIRTy(tc, defaultKind(tc)); + } + + mlir::Type gen(const Fortran::evaluate::ImpliedDoIndex &) { + return genFIRType( + context, defaultKind()); + } + + template