Magic-Mirror/llvm-capstone
1
0
Fork 0
mirror of https://github.com/capstone-engine/llvm-capstone.git synced 2024-12-26 17:57:07 +00:00
Code Issues Actions 2 Packages Projects Releases Wiki Activity

[flang] Lower boxed procedure

Browse Source 
In FIR, we want to wrap function pointers in a special box known as a
boxproc value. Fortran has a limited form of dynamic scoping
[https://tinyurl.com/2p8v2hw7] between "host procedures" and "internal
procedures". There are a number of implementations possible.

Boxproc typed values abstract away the implementation details of when a
function pointer can be passed directly (as a raw address) and when a
function pointer has to account for the presence of a dynamic scope.
When lowering Fortran syntax to FIR, all function pointers are emboxed
as boxproc values.

When creating LLVM IR, we must strip away the abstraction and produce
low-level LLVM "assembly" code. This patch implements that
transformation as converting the boxproc values to either raw function
pointers or executable trampolines on the stack as needed. The
trampoline then captures the dynamic scope context within an executable
thunk that can be passed instead of the function's raw address.

Some extra handling is required for Fortran functions that return a
character value to deal with LEN values here.

Some of the code in Bridge.cpp and ConvertExpr.cpp and be re-arranged to
faciliate the upstreaming effort.

This patch is part of the upstreaming effort from fir-dev branch.

Reviewed By: jeanPerier, PeteSteinfeld

Differential Revision: https://reviews.llvm.org/D122223

Co-authored-by: mleair <leairmark@gmail.com>
Co-authored-by: Jean Perier <jperier@nvidia.com>
Co-authored-by: Eric Schweitz <eschweitz@nvidia.com>
Co-authored-by: V Donaldson <vdonaldson@nvidia.com>
Co-authored-by: Kiran Chandramohan <kiran.chandramohan@arm.com>
This commit is contained in:
Valentin Clement 2022-03-22 15:40:32 +01:00
parent 01a2ba5dfb
commit fe252f8ed6
No known key found for this signature in database
GPG Key ID: 086D54783C928776
41 changed files with 4192 additions and 2246 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
flang/include/flang/Lower/Bridge.h
View File

@ -5,13 +5,9 @@
// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
//
//===----------------------------------------------------------------------===//
///
/// \file
/// Implements lowering. Convert Fortran source to
/// [MLIR](https://github.com/tensorflow/mlir).
///
/// [Coding style](https://llvm.org/docs/CodingStandards.html)
///
//
// Coding style: https://mlir.llvm.org/getting_started/DeveloperGuide/
//
//===----------------------------------------------------------------------===//
#ifndef FORTRAN_LOWER_BRIDGE_H
@ -84,6 +80,8 @@ public:
/// Create a folding context. Careful: this is very expensive.
Fortran::evaluate::FoldingContext createFoldingContext() const;
bool validModule() { return getModule(); }
//===--------------------------------------------------------------------===//
// Perform the creation of an mlir::ModuleOp
//===--------------------------------------------------------------------===//

48
flang/include/flang/Lower/CallInterface.h
View File

@ -12,10 +12,10 @@
//
// Utility that defines fir call interface for procedure both on caller and
// and callee side and get the related FuncOp.
// It does not emit any FIR code but for the created mlir::FuncOp, instead it
// provides back a container of Symbol (callee side)/ActualArgument (caller
// It does not emit any FIR code but for the created mlir::func::FuncOp, instead
// it provides back a container of Symbol (callee side)/ActualArgument (caller
// side) with additional information for each element describing how it must be
// plugged with the mlir::FuncOp.
// plugged with the mlir::func::FuncOp.
// It handles the fact that hidden arguments may be inserted for the result.
// while lowering.
//
@ -76,8 +76,8 @@ template <typename T>
class CallInterfaceImpl;
/// CallInterface defines all the logic to determine FIR function interfaces
/// from a characteristic, build the mlir::FuncOp and describe back the argument
/// mapping to its user.
/// from a characteristic, build the mlir::func::FuncOp and describe back the
/// argument mapping to its user.
/// The logic is shared between the callee and caller sides that it accepts as
/// a curiously recursive template to handle the few things that cannot be
/// shared between both sides (getting characteristics, mangled name, location).
@ -131,7 +131,7 @@ public:
using FirValue = typename PassedEntityTypes<T>::FirValue;
/// FirPlaceHolder are place holders for the mlir inputs and outputs that are
/// created during the first pass before the mlir::FuncOp is created.
/// created during the first pass before the mlir::func::FuncOp is created.
struct FirPlaceHolder {
FirPlaceHolder(mlir::Type t, int passedPosition, Property p,
llvm::ArrayRef<mlir::NamedAttribute> attrs)
@ -162,8 +162,8 @@ public:
/// How entity is passed by.
PassEntityBy passBy;
/// What is the entity (SymbolRef for callee/ActualArgument* for caller)
/// What is the related mlir::FuncOp argument(s) (mlir::Value for callee /
/// index for the caller).
/// What is the related mlir::func::FuncOp argument(s) (mlir::Value for
/// callee / index for the caller).
FortranEntity entity;
FirValue firArgument;
FirValue firLength; /* only for AddressAndLength */
@ -173,9 +173,9 @@ public:
nullptr;
};
/// Return the mlir::FuncOp. Note that front block is added by this
/// Return the mlir::func::FuncOp. Note that front block is added by this
/// utility if callee side.
mlir::FuncOp getFuncOp() const { return func; }
mlir::func::FuncOp getFuncOp() const { return func; }
/// Number of MLIR inputs/outputs of the created FuncOp.
std::size_t getNumFIRArguments() const { return inputs.size(); }
std::size_t getNumFIRResults() const { return outputs.size(); }
@ -183,7 +183,7 @@ public:
llvm::SmallVector<mlir::Type> getResultType() const;
/// Return a container of Symbol/ActualArgument* and how they must
/// be plugged with the mlir::FuncOp.
/// be plugged with the mlir::func::FuncOp.
llvm::ArrayRef<PassedEntity> getPassedArguments() const {
return passedArguments;
}
@ -194,7 +194,7 @@ public:
mlir::FunctionType genFunctionType();
/// determineInterface is the entry point of the first pass that defines the
/// interface and is required to get the mlir::FuncOp.
/// interface and is required to get the mlir::func::FuncOp.
void
determineInterface(bool isImplicit,
const Fortran::evaluate::characteristics::Procedure &);
@ -219,16 +219,16 @@ protected:
/// CRTP handle.
T &side() { return *static_cast<T *>(this); }
/// Entry point to be called by child ctor to analyze the signature and
/// create/find the mlir::FuncOp. Child needs to be initialized first.
/// create/find the mlir::func::FuncOp. Child needs to be initialized first.
void declare();
/// Second pass entry point, once the mlir::FuncOp is created.
/// Second pass entry point, once the mlir::func::FuncOp is created.
/// Nothing is done if it was already called.
void mapPassedEntities();
void mapBackInputToPassedEntity(const FirPlaceHolder &, FirValue);
llvm::SmallVector<FirPlaceHolder> outputs;
llvm::SmallVector<FirPlaceHolder> inputs;
mlir::FuncOp func;
mlir::func::FuncOp func;
llvm::SmallVector<PassedEntity> passedArguments;
std::optional<PassedEntity> passedResult;
bool saveResult = false;
@ -270,6 +270,10 @@ public:
return procRef;
}
/// Get the SubprogramDetails that defines the interface of this call if it is
/// known at the call site. Return nullptr if it is not known.
const Fortran::semantics::SubprogramDetails *getInterfaceDetails() const;
bool isMainProgram() const { return false; }
/// Returns true if this is a call to a procedure pointer of a dummy
@ -368,9 +372,9 @@ public:
/// procedure.
const Fortran::semantics::Symbol *getProcedureSymbol() const;
/// Add mlir::FuncOp entry block and map fir block arguments to Fortran dummy
/// argument symbols.
mlir::FuncOp addEntryBlockAndMapArguments();
/// Add mlir::func::FuncOp entry block and map fir block arguments to Fortran
/// dummy argument symbols.
mlir::func::FuncOp addEntryBlockAndMapArguments();
bool hasHostAssociated() const;
mlir::Type getHostAssociatedTy() const;
@ -385,13 +389,13 @@ mlir::FunctionType
translateSignature(const Fortran::evaluate::ProcedureDesignator &,
Fortran::lower::AbstractConverter &);
/// Declare or find the mlir::FuncOp named \p name. If the mlir::FuncOp does
/// not exist yet, declare it with the signature translated from the
/// ProcedureDesignator argument.
/// Declare or find the mlir::func::FuncOp named \p name. If the
/// mlir::func::FuncOp does not exist yet, declare it with the signature
/// translated from the ProcedureDesignator argument.
/// Due to Fortran implicit function typing rules, the returned FuncOp is not
/// guaranteed to have the signature from ProcedureDesignator if the FuncOp was
/// already declared.
mlir::FuncOp
mlir::func::FuncOp
getOrDeclareFunction(llvm::StringRef name,
const Fortran::evaluate::ProcedureDesignator &,
Fortran::lower::AbstractConverter &);

76
flang/include/flang/Lower/ConvertExpr.h
View File

@ -23,24 +23,22 @@
namespace mlir {
class Location;
}
class Value;
} // namespace mlir
namespace Fortran::evaluate {
template <typename>
class Expr;
struct SomeType;
} // namespace Fortran::evaluate
namespace fir {
class AllocMemOp;
class ArrayLoadOp;
class ShapeOp;
} // namespace fir
namespace Fortran::lower {
class AbstractConverter;
class StatementContext;
class SymMap;
class ExplicitIterSpace;
class ImplicitIterSpace;
class StatementContext;
using SomeExpr = Fortran::evaluate::Expr<Fortran::evaluate::SomeType>;
class SymMap;
/// Create an extended expression value.
fir::ExtendedValue createSomeExtendedExpression(mlir::Location loc,
@ -87,30 +85,6 @@ fir::MutableBoxValue createMutableBox(mlir::Location loc,
AbstractConverter &converter,
const SomeExpr &expr, SymMap &symMap);
/// Lower an array expression to a value of type box. The expression must be a
/// variable.
fir::ExtendedValue createSomeArrayBox(AbstractConverter &converter,
const SomeExpr &expr, SymMap &symMap,
StatementContext &stmtCtx);
/// Lower a subroutine call. This handles both elemental and non elemental
/// subroutines. \p isUserDefAssignment must be set if this is called in the
/// context of a user defined assignment. For subroutines with alternate
/// returns, the returned value indicates which label the code should jump to.
/// The returned value is null otherwise.
mlir::Value createSubroutineCall(AbstractConverter &converter,
const evaluate::ProcedureRef &call,
ExplicitIterSpace &explicitIterSpace,
ImplicitIterSpace &implicitIterSpace,
SymMap &symMap, StatementContext &stmtCtx,
bool isUserDefAssignment);
/// Create the address of the box.
/// \p expr must be the designator of an allocatable/pointer entity.
fir::MutableBoxValue createMutableBox(mlir::Location loc,
AbstractConverter &converter,
const SomeExpr &expr, SymMap &symMap);
/// Create a fir::BoxValue describing the value of \p expr.
/// If \p expr is a variable without vector subscripts, the fir::BoxValue
/// described the variable storage. Otherwise, the created fir::BoxValue
@ -190,6 +164,22 @@ void createAnyMaskedArrayAssignment(AbstractConverter &converter,
ImplicitIterSpace &implicitIterSpace,
SymMap &symMap, StatementContext &stmtCtx);
/// In the context of a FORALL, a pointer assignment is allowed. The pointer
/// assignment can be elementwise on an array of pointers. The bounds
/// expressions as well as the component path may contain references to the
/// concurrent control variables. The explicit iteration space must be defined.
void createAnyArrayPointerAssignment(
AbstractConverter &converter, const SomeExpr &lhs, const SomeExpr &rhs,
const evaluate::Assignment::BoundsSpec &bounds,
ExplicitIterSpace &explicitIterSpace, ImplicitIterSpace &implicitIterSpace,
SymMap &symMap);
/// Support the bounds remapping flavor of pointer assignment.
void createAnyArrayPointerAssignment(
AbstractConverter &converter, const SomeExpr &lhs, const SomeExpr &rhs,
const evaluate::Assignment::BoundsRemapping &bounds,
ExplicitIterSpace &explicitIterSpace, ImplicitIterSpace &implicitIterSpace,
SymMap &symMap);
/// Lower an assignment to an allocatable array, allocating the array if
/// it is not allocated yet or reallocation it if it does not conform
/// with the right hand side.
@ -220,6 +210,24 @@ void createLazyArrayTempValue(AbstractConverter &converter,
const SomeExpr &expr, mlir::Value raggedHeader,
SymMap &symMap, StatementContext &stmtCtx);
/// Lower an array expression to a value of type box. The expression must be a
/// variable.
fir::ExtendedValue createSomeArrayBox(AbstractConverter &converter,
const SomeExpr &expr, SymMap &symMap,
StatementContext &stmtCtx);
/// Lower a subroutine call. This handles both elemental and non elemental
/// subroutines. \p isUserDefAssignment must be set if this is called in the
/// context of a user defined assignment. For subroutines with alternate
/// returns, the returned value indicates which label the code should jump to.
/// The returned value is null otherwise.
mlir::Value createSubroutineCall(AbstractConverter &converter,
const evaluate::ProcedureRef &call,
ExplicitIterSpace &explicitIterSpace,
ImplicitIterSpace &implicitIterSpace,
SymMap &symMap, StatementContext &stmtCtx,
bool isUserDefAssignment);
// Attribute for an alloca that is a trivial adaptor for converting a value to
// pass-by-ref semantics for a VALUE parameter. The optimizer may be able to
// eliminate these.

4
flang/include/flang/Lower/IntrinsicCall.h
View File

@ -100,6 +100,10 @@ getUnrestrictedIntrinsicSymbolRefAttr(fir::FirOpBuilder &, mlir::Location,
mlir::Value genMax(fir::FirOpBuilder &, mlir::Location,
llvm::ArrayRef<mlir::Value> args);
/// Generate minimum. Same constraints as genMax.
mlir::Value genMin(fir::FirOpBuilder &, mlir::Location,
llvm::ArrayRef<mlir::Value> args);
/// Generate power function x**y with the given expected
/// result type.
mlir::Value genPow(fir::FirOpBuilder &, mlir::Location, mlir::Type resultType,

30
flang/include/flang/Optimizer/Builder/Character.h
View File

@ -14,7 +14,11 @@
#define FORTRAN_OPTIMIZER_BUILDER_CHARACTER_H
#include "flang/Optimizer/Builder/BoxValue.h"
#include "flang/Optimizer/Builder/FIRBuilder.h"
#include "flang/Optimizer/Builder/LowLevelIntrinsics.h"
namespace fir {
class FirOpBuilder;
}
namespace fir::factory {
@ -22,7 +26,7 @@ namespace fir::factory {
class CharacterExprHelper {
public:
/// Constructor.
explicit CharacterExprHelper(fir::FirOpBuilder &builder, mlir::Location loc)
explicit CharacterExprHelper(FirOpBuilder &builder, mlir::Location loc)
: builder{builder}, loc{loc} {}
CharacterExprHelper(const CharacterExprHelper &) = delete;
@ -107,11 +111,15 @@ public:
/// Extract the kind of a character or array of character type.
static fir::KindTy getCharacterOrSequenceKind(mlir::Type type);
// TODO: Do we really need all these flavors of unwrapping to get the fir.char
// type? Or can we merge these? It would be better to merge them and eliminate
// the confusion.
/// Determine the inner character type. Unwraps references, boxes, and
/// sequences to find the !fir.char element type.
static fir::CharacterType getCharType(mlir::Type type);
/// Determine the base character type
/// Get fir.char<kind> type with the same kind as inside str.
static fir::CharacterType getCharacterType(mlir::Type type);
static fir::CharacterType getCharacterType(const fir::CharBoxValue &box);
static fir::CharacterType getCharacterType(mlir::Value str);
@ -181,16 +189,11 @@ private:
void createAssign(const fir::CharBoxValue &lhs, const fir::CharBoxValue &rhs);
mlir::Value createBlankConstantCode(fir::CharacterType type);
private:
FirOpBuilder &builder;
mlir::Location loc;
};
// FIXME: Move these to Optimizer
mlir::FuncOp getLlvmMemcpy(FirOpBuilder &builder);
mlir::FuncOp getLlvmMemmove(FirOpBuilder &builder);
mlir::FuncOp getLlvmMemset(FirOpBuilder &builder);
mlir::FuncOp getRealloc(FirOpBuilder &builder);
//===----------------------------------------------------------------------===//
// Tools to work with Character dummy procedures
//===----------------------------------------------------------------------===//
@ -200,15 +203,6 @@ mlir::FuncOp getRealloc(FirOpBuilder &builder);
/// one provided by \p funcPointerType.
mlir::Type getCharacterProcedureTupleType(mlir::Type funcPointerType);
/// Is this tuple type holding a character function and its result length ?
bool isCharacterProcedureTuple(mlir::Type type);
/// Is \p tuple a value holding a character function address and its result
/// length ?
inline bool isCharacterProcedureTuple(mlir::Value tuple) {
return isCharacterProcedureTuple(tuple.getType());
}
/// Create a tuple<addr, len> given \p addr and \p len as well as the tuple
/// type \p argTy. \p addr must be any function address, and \p len must be
/// any integer. Converts will be inserted if needed if \addr and \p len

34
flang/include/flang/Optimizer/Builder/FIRBuilder.h
View File

@ -19,9 +19,10 @@
#include "flang/Optimizer/Dialect/FIROps.h"
#include "flang/Optimizer/Dialect/FIRType.h"
#include "flang/Optimizer/Support/KindMapping.h"
#include "mlir/Dialect/Func/IR/FuncOps.h"
#include "mlir/IR/Builders.h"
#include "mlir/IR/BuiltinOps.h"
#include "llvm/ADT/DenseMap.h"
#include "llvm/ADT/Optional.h"
namespace fir {
class AbstractArrayBox;
@ -104,7 +105,7 @@ public:
return mlir::SymbolRefAttr::get(getContext(), str);
}
/// Get the mlir real type that implements fortran REAL(kind).
/// Get the mlir float type that implements Fortran REAL(kind).
mlir::Type getRealType(int kind);
fir::BoxProcType getBoxProcType(mlir::FunctionType funcTy) {
@ -224,7 +225,6 @@ public:
mlir::FuncOp getNamedFunction(llvm::StringRef name) {
return getNamedFunction(getModule(), name);
}
static mlir::FuncOp getNamedFunction(mlir::ModuleOp module,
llvm::StringRef name);
@ -382,6 +382,9 @@ public:
mlir::Value ub, mlir::Value step,
mlir::Type type);
/// Dump the current function. (debug)
LLVM_DUMP_METHOD void dumpFunc();
private:
const KindMapping &kindMap;
};
@ -462,26 +465,15 @@ llvm::SmallVector<mlir::Value> createExtents(fir::FirOpBuilder &builder,
mlir::Location loc,
fir::SequenceType seqTy);
//===----------------------------------------------------------------------===//
//===--------------------------------------------------------------------===//
// Location helpers
//===----------------------------------------------------------------------===//
//===--------------------------------------------------------------------===//
/// Generate a string literal containing the file name and return its address
mlir::Value locationToFilename(fir::FirOpBuilder &, mlir::Location);
/// Generate a constant of the given type with the location line number
mlir::Value locationToLineNo(fir::FirOpBuilder &, mlir::Location, mlir::Type);
/// Builds and returns the type of a ragged array header used to cache mask
/// evaluations. RaggedArrayHeader is defined in
/// flang/include/flang/Runtime/ragged.h.
mlir::TupleType getRaggedArrayHeaderType(fir::FirOpBuilder &builder);
/// Create the zero value of a given the numerical or logical \p type (`false`
/// for logical types).
mlir::Value createZeroValue(fir::FirOpBuilder &builder, mlir::Location loc,
mlir::Type type);
//===--------------------------------------------------------------------===//
// ExtendedValue helpers
//===--------------------------------------------------------------------===//
@ -523,6 +515,11 @@ void genRecordAssignment(fir::FirOpBuilder &builder, mlir::Location loc,
const fir::ExtendedValue &lhs,
const fir::ExtendedValue &rhs);
/// Builds and returns the type of a ragged array header used to cache mask
/// evaluations. RaggedArrayHeader is defined in
/// flang/include/flang/Runtime/ragged.h.
mlir::TupleType getRaggedArrayHeaderType(fir::FirOpBuilder &builder);
/// Generate the, possibly dynamic, LEN of a CHARACTER. \p arrLoad determines
/// the base array. After applying \p path, the result must be a reference to a
/// `!fir.char` type object. \p substring must have 0, 1, or 2 members. The
@ -537,6 +534,11 @@ mlir::Value genLenOfCharacter(fir::FirOpBuilder &builder, mlir::Location loc,
llvm::ArrayRef<mlir::Value> path,
llvm::ArrayRef<mlir::Value> substring);
/// Create the zero value of a given the numerical or logical \p type (`false`
/// for logical types).
mlir::Value createZeroValue(fir::FirOpBuilder &builder, mlir::Location loc,
mlir::Type type);
} // namespace fir::factory
#endif // FORTRAN_OPTIMIZER_BUILDER_FIRBUILDER_H

18
flang/include/flang/Optimizer/Builder/LowLevelIntrinsics.h
View File

@ -24,12 +24,30 @@ class FirOpBuilder;
namespace fir::factory {
/// Get the LLVM intrinsic for `memcpy`. Use the 64 bit version.
mlir::func::FuncOp getLlvmMemcpy(FirOpBuilder &builder);
/// Get the LLVM intrinsic for `memmove`. Use the 64 bit version.
mlir::func::FuncOp getLlvmMemmove(FirOpBuilder &builder);
/// Get the LLVM intrinsic for `memset`. Use the 64 bit version.
mlir::func::FuncOp getLlvmMemset(FirOpBuilder &builder);
/// Get the C standard library `realloc` function.
mlir::func::FuncOp getRealloc(FirOpBuilder &builder);
/// Get the `llvm.stacksave` intrinsic.
mlir::func::FuncOp getLlvmStackSave(FirOpBuilder &builder);
/// Get the `llvm.stackrestore` intrinsic.
mlir::func::FuncOp getLlvmStackRestore(FirOpBuilder &builder);
/// Get the `llvm.init.trampoline` intrinsic.
mlir::func::FuncOp getLlvmInitTrampoline(FirOpBuilder &builder);
/// Get the `llvm.adjust.trampoline` intrinsic.
mlir::func::FuncOp getLlvmAdjustTrampoline(FirOpBuilder &builder);
} // namespace fir::factory
#endif // FLANG_OPTIMIZER_BUILDER_LOWLEVELINTRINSICS_H

10
flang/include/flang/Optimizer/CodeGen/CGPasses.td
View File

@ -64,4 +64,14 @@ def TargetRewrite : Pass<"target-rewrite", "mlir::ModuleOp"> {
];
}
def BoxedProcedurePass : Pass<"boxed-procedure", "mlir::ModuleOp"> {
let constructor = "::fir::createBoxedProcedurePass()";
let options = [
Option<"useThunks", "use-thunks",
"bool", /*default=*/"true",
"Convert procedure pointer abstractions to a single code pointer, "
"deploying thunks wherever required.">
];
}
#endif // FORTRAN_OPTIMIZER_CODEGEN_FIR_PASSES

6
flang/include/flang/Optimizer/CodeGen/CodeGen.h
View File

@ -55,12 +55,18 @@ std::unique_ptr<mlir::Pass> createFIRToLLVMPass(FIRToLLVMPassOptions options);
using LLVMIRLoweringPrinter =
std::function<void(llvm::Module &, llvm::raw_ostream &)>;
/// Convert the LLVM IR dialect to LLVM-IR proper
std::unique_ptr<mlir::Pass> createLLVMDialectToLLVMPass(
llvm::raw_ostream &output,
LLVMIRLoweringPrinter printer =
[](llvm::Module &m, llvm::raw_ostream &out) { m.print(out, nullptr); });
/// Convert boxproc values to a lower level representation. The default is to
/// use function pointers and thunks.
std::unique_ptr<mlir::Pass> createBoxedProcedurePass();
std::unique_ptr<mlir::Pass> createBoxedProcedurePass(bool useThunks);
// declarative passes
#define GEN_PASS_REGISTRATION
#include "flang/Optimizer/CodeGen/CGPasses.h.inc"

21
flang/include/flang/Optimizer/Dialect/FIROps.td
View File

@ -885,7 +885,8 @@ def fir_EmboxProcOp : fir_Op<"emboxproc", [NoSideEffect]> {
then the form takes only the procedure's symbol.
```mlir
%0 = fir.emboxproc @f : ((i32) -> i32) -> !fir.boxproc<(i32) -> i32>
%f = ... : (i32) -> i32
%0 = fir.emboxproc %f : ((i32) -> i32) -> !fir.boxproc<(i32) -> i32>
```
An internal procedure requiring a host instance for correct execution uses
@ -895,16 +896,20 @@ def fir_EmboxProcOp : fir_Op<"emboxproc", [NoSideEffect]> {
promotion of local values.
```mlir
%4 = ... : !fir.ref<tuple<i32, i32>>
%5 = fir.emboxproc @g, %4 : ((i32) -> i32, !fir.ref<tuple<i32, i32>>) -> !fir.boxproc<(i32) -> i32>
%4 = ... : !fir.ref<tuple<!fir.ref<i32>, !fir.ref<i32>>>
%g = ... : (i32) -> i32
%5 = fir.emboxproc %g, %4 : ((i32) -> i32, !fir.ref<tuple<!fir.ref<i32>, !fir.ref<i32>>>) -> !fir.boxproc<(i32) -> i32>
```
}];
let arguments = (ins SymbolRefAttr:$funcname, AnyReferenceLike:$host);
let arguments = (ins FuncType:$func, Optional<fir_ReferenceType>:$host);
let results = (outs fir_BoxProcType);
let hasCustomAssemblyFormat = 1;
let assemblyFormat = [{
$func (`,` $host^)? attr-dict `:` functional-type(operands, results)
}];
let hasVerifier = 1;
}
@ -958,13 +963,13 @@ def fir_BoxAddrOp : fir_SimpleOneResultOp<"box_addr", [NoSideEffect]> {
```mlir
%51 = fir.box_addr %box : (!fir.box<f64>) -> !fir.ref<f64>
%52 = fir.box_addr %boxchar : (!fir.boxchar<1>) -> !fir.ref<!fir.char<1>>
%53 = fir.box_addr %boxproc : (!fir.boxproc<!P>) -> !fir.ref<!P>
%53 = fir.box_addr %boxproc : (!fir.boxproc<!P>) -> !P
```
}];
let arguments = (ins fir_BoxType:$val);
let arguments = (ins AnyBoxLike:$val);
let results = (outs AnyReferenceLike);
let results = (outs AnyCodeOrDataRefLike);
let hasFolder = 1;
}

8
flang/include/flang/Optimizer/Dialect/FIROpsSupport.h
View File

@ -15,16 +15,18 @@
namespace fir {
/// return true iff the Operation is a non-volatile LoadOp
/// Return true iff the Operation is a non-volatile LoadOp or ArrayLoadOp.
inline bool nonVolatileLoad(mlir::Operation *op) {
if (auto load = mlir::dyn_cast<fir::LoadOp>(op))
return !load->getAttr("volatile");
if (auto arrLoad = mlir::dyn_cast<fir::ArrayLoadOp>(op))
return !arrLoad->getAttr("volatile");
return false;
}
/// return true iff the Operation is a call
/// Return true iff the Operation is a call.
inline bool isaCall(mlir::Operation *op) {
return mlir::isa<fir::CallOp>(op) || llvm::isa<fir::DispatchOp>(op) ||
return mlir::isa<fir::CallOp>(op) || mlir::isa<fir::DispatchOp>(op) ||
mlir::isa<mlir::func::CallOp>(op) ||
mlir::isa<mlir::func::CallIndirectOp>(op);
}

30
flang/include/flang/Optimizer/Dialect/FIRType.h
View File

@ -78,9 +78,9 @@ inline bool isa_passbyref_type(mlir::Type t) {
/// Is `t` a type that can conform to be pass-by-reference? Depending on the
/// context, these types may simply demote to pass-by-reference or a reference
/// to them may have to be passed instead.
/// to them may have to be passed instead. Functions are always referent.
inline bool conformsWithPassByRef(mlir::Type t) {
return isa_ref_type(t) || isa_box_type(t);
return isa_ref_type(t) || isa_box_type(t) || t.isa<mlir::FunctionType>();
}
/// Is `t` a derived (record) type?
@ -162,6 +162,16 @@ inline bool sequenceWithNonConstantShape(fir::SequenceType seqTy) {
/// Returns true iff the type `t` does not have a constant size.
bool hasDynamicSize(mlir::Type t);
inline unsigned getRankOfShapeType(mlir::Type t) {
if (auto shTy = t.dyn_cast<fir::ShapeType>())
return shTy.getRank();
if (auto shTy = t.dyn_cast<fir::ShapeShiftType>())
return shTy.getRank();
if (auto shTy = t.dyn_cast<fir::ShiftType>())
return shTy.getRank();
return 0;
}
/// If `t` is a SequenceType return its element type, otherwise return `t`.
inline mlir::Type unwrapSequenceType(mlir::Type t) {
if (auto seqTy = t.dyn_cast<fir::SequenceType>())
@ -183,6 +193,22 @@ inline mlir::Type unwrapPassByRefType(mlir::Type t) {
return t;
}
/// Unwrap all pointer and box types and return the element type if it is a
/// sequence type, otherwise return null.
inline fir::SequenceType unwrapUntilSeqType(mlir::Type t) {
while (true) {
if (!t)
return {};
if (auto ty = dyn_cast_ptrOrBoxEleTy(t)) {
t = ty;
continue;
}
if (auto seqTy = t.dyn_cast<fir::SequenceType>())
return seqTy;
return {};
}
}
#ifndef NDEBUG
// !fir.ptr<X> and !fir.heap<X> where X is !fir.ptr, !fir.heap, or !fir.ref
// is undefined and disallowed.

5
flang/include/flang/Optimizer/Dialect/FIRTypes.td
View File

@ -567,6 +567,11 @@ def AnyReferenceLike : TypeConstraint<Or<[fir_ReferenceType.predicate,
fir_HeapType.predicate, fir_PointerType.predicate,
fir_LLVMPointerType.predicate]>, "any reference">;
def FuncType : TypeConstraint<FunctionType.predicate, "function type">;
def AnyCodeOrDataRefLike : TypeConstraint<Or<[AnyReferenceLike.predicate,
FunctionType.predicate]>, "any code or data reference">;
def RefOrLLVMPtr : TypeConstraint<Or<[fir_ReferenceType.predicate,
fir_LLVMPointerType.predicate]>, "fir.ref or fir.llvm_ptr">;

8
flang/include/flang/Tools/CLOptions.inc
View File

@ -62,6 +62,8 @@ DisableOption(CodeGenRewrite, "codegen-rewrite", "rewrite FIR for codegen");
DisableOption(TargetRewrite, "target-rewrite", "rewrite FIR for target");
DisableOption(FirToLlvmIr, "fir-to-llvmir", "FIR to LLVM-IR dialect");
DisableOption(LlvmIrToLlvm, "llvm", "conversion to LLVM");
DisableOption(BoxedProcedureRewrite, "boxed-procedure-rewrite",
"rewrite boxed procedures");
#endif
/// Generic for adding a pass to the pass manager if it is not disabled.
@ -130,6 +132,11 @@ inline void addLLVMDialectToLLVMPass(
addPassConditionally(pm, disableLlvmIrToLlvm,
[&]() { return fir::createLLVMDialectToLLVMPass(output); });
}
inline void addBoxedProcedurePass(mlir::PassManager &pm) {
addPassConditionally(pm, disableBoxedProcedureRewrite,
[&]() { return fir::createBoxedProcedurePass(); });
}
#endif
/// Create a pass pipeline for running default optimization passes for
@ -163,6 +170,7 @@ inline void createDefaultFIROptimizerPassPipeline(mlir::PassManager &pm) {
#if !defined(FLANG_EXCLUDE_CODEGEN)
inline void createDefaultFIRCodeGenPassPipeline(mlir::PassManager &pm) {
fir::addBoxedProcedurePass(pm);
pm.addNestedPass<mlir::FuncOp>(fir::createAbstractResultOptPass());
fir::addCodeGenRewritePass(pm);
fir::addTargetRewritePass(pm);

1376
flang/lib/Lower/Bridge.cpp
View File

File diff suppressed because it is too large Load Diff

34
flang/lib/Lower/CallInterface.cpp
View File

@ -239,11 +239,10 @@ void Fortran::lower::CallerInterface::walkResultExtents(
ExprVisitor visitor) const {
// Walk directly the result symbol shape (the characteristic shape may contain
// descriptor inquiries to it that would fail to lower on the caller side).
const Fortran::semantics::Symbol *interfaceSymbol =
procRef.proc().GetInterfaceSymbol();
if (interfaceSymbol) {
const Fortran::semantics::Symbol &result =
interfaceSymbol->get<Fortran::semantics::SubprogramDetails>().result();
const Fortran::semantics::SubprogramDetails *interfaceDetails =
getInterfaceDetails();
if (interfaceDetails) {
const Fortran::semantics::Symbol &result = interfaceDetails->result();
if (const auto *objectDetails =
result.detailsIf<Fortran::semantics::ObjectEntityDetails>())
if (objectDetails->shape().IsExplicitShape())
@ -263,7 +262,7 @@ bool Fortran::lower::CallerInterface::mustMapInterfaceSymbols() const {
const std::optional<Fortran::evaluate::characteristics::FunctionResult>
&result = characteristic->functionResult;
if (!result || result->CanBeReturnedViaImplicitInterface() ||
!procRef.proc().GetInterfaceSymbol())
!getInterfaceDetails())
return false;
bool allResultSpecExprConstant = true;
auto visitor = [&](const Fortran::lower::SomeExpr &e) {
@ -277,12 +276,13 @@ bool Fortran::lower::CallerInterface::mustMapInterfaceSymbols() const {
mlir::Value Fortran::lower::CallerInterface::getArgumentValue(
const semantics::Symbol &sym) const {
mlir::Location loc = converter.getCurrentLocation();
const Fortran::semantics::Symbol *iface = procRef.proc().GetInterfaceSymbol();
if (!iface)
const Fortran::semantics::SubprogramDetails *ifaceDetails =
getInterfaceDetails();
if (!ifaceDetails)
fir::emitFatalError(
loc, "mapping actual and dummy arguments requires an interface");
const std::vector<Fortran::semantics::Symbol *> &dummies =
iface->get<semantics::SubprogramDetails>().dummyArgs();
ifaceDetails->dummyArgs();
auto it = std::find(dummies.begin(), dummies.end(), &sym);
if (it == dummies.end())
fir::emitFatalError(loc, "symbol is not a dummy in this call");
@ -300,11 +300,21 @@ mlir::Type Fortran::lower::CallerInterface::getResultStorageType() const {
const Fortran::semantics::Symbol &
Fortran::lower::CallerInterface::getResultSymbol() const {
mlir::Location loc = converter.getCurrentLocation();
const Fortran::semantics::Symbol *iface = procRef.proc().GetInterfaceSymbol();
if (!iface)
const Fortran::semantics::SubprogramDetails *ifaceDetails =
getInterfaceDetails();
if (!ifaceDetails)
fir::emitFatalError(
loc, "mapping actual and dummy arguments requires an interface");
return iface->get<semantics::SubprogramDetails>().result();
return ifaceDetails->result();
}
const Fortran::semantics::SubprogramDetails *
Fortran::lower::CallerInterface::getInterfaceDetails() const {
if (const Fortran::semantics::Symbol *iface =
procRef.proc().GetInterfaceSymbol())
return iface->GetUltimate()
.detailsIf<Fortran::semantics::SubprogramDetails>();
return nullptr;
}
//===----------------------------------------------------------------------===//

2092
flang/lib/Lower/ConvertExpr.cpp
View File

File diff suppressed because it is too large Load Diff

6
flang/lib/Lower/ConvertVariable.cpp
View File

@ -1119,7 +1119,11 @@ lowerExplicitCharLen(Fortran::lower::AbstractConverter &converter,
if (llvm::Optional<int64_t> len = box.getCharLenConst())
return builder.createIntegerConstant(loc, lenTy, *len);
if (llvm::Optional<Fortran::lower::SomeExpr> lenExpr = box.getCharLenExpr())
return genScalarValue(converter, loc, *lenExpr, symMap, stmtCtx);
// If the length expression is negative, the length is zero. See F2018
// 7.4.4.2 point 5.
return Fortran::lower::genMaxWithZero(
builder, loc,
genScalarValue(converter, loc, *lenExpr, symMap, stmtCtx));
return mlir::Value{};
}

9
flang/lib/Lower/IntrinsicCall.cpp
View File

@ -3688,6 +3688,15 @@ mlir::Value Fortran::lower::genMax(fir::FirOpBuilder &builder,
args);
}
mlir::Value Fortran::lower::genMin(fir::FirOpBuilder &builder,
mlir::Location loc,
llvm::ArrayRef<mlir::Value> args) {
assert(args.size() > 0 && "min requires at least one argument");
return IntrinsicLibrary{builder, loc}
.genExtremum<Extremum::Min, ExtremumBehavior::MinMaxss>(args[0].getType(),
args);
}
mlir::Value Fortran::lower::genPow(fir::FirOpBuilder &builder,
mlir::Location loc, mlir::Type type,
mlir::Value x, mlir::Value y) {

145
flang/lib/Optimizer/Builder/Character.cpp
View File

@ -13,19 +13,18 @@
#include "flang/Optimizer/Builder/Character.h"
#include "flang/Lower/Todo.h"
#include "flang/Optimizer/Builder/DoLoopHelper.h"
#include "flang/Optimizer/Builder/FIRBuilder.h"
#include "llvm/Support/Debug.h"
#include <optional>
#define DEBUG_TYPE "flang-lower-character"
using namespace mlir;
//===----------------------------------------------------------------------===//
// CharacterExprHelper implementation
//===----------------------------------------------------------------------===//
/// Unwrap base fir.char<kind,len> type.
static fir::CharacterType recoverCharacterType(mlir::Type type) {
/// Unwrap all the ref and box types and return the inner element type.
static mlir::Type unwrapBoxAndRef(mlir::Type type) {
if (auto boxType = type.dyn_cast<fir::BoxCharType>())
return boxType.getEleTy();
while (true) {
@ -35,10 +34,29 @@ static fir::CharacterType recoverCharacterType(mlir::Type type) {
else
break;
}
return fir::unwrapSequenceType(type).cast<fir::CharacterType>();
return type;
}
/// Unwrap base fir.char<kind,len> type.
static fir::CharacterType recoverCharacterType(mlir::Type type) {
type = fir::unwrapSequenceType(unwrapBoxAndRef(type));
if (auto charTy = type.dyn_cast<fir::CharacterType>())
return charTy;
llvm::report_fatal_error("expected a character type");
}
bool fir::factory::CharacterExprHelper::isCharacterScalar(mlir::Type type) {
type = unwrapBoxAndRef(type);
return !type.isa<fir::SequenceType>() && fir::isa_char(type);
}
bool fir::factory::CharacterExprHelper::isArray(mlir::Type type) {
type = unwrapBoxAndRef(type);
if (auto seqTy = type.dyn_cast<fir::SequenceType>())
return fir::isa_char(seqTy.getEleTy());
return false;
}
/// Get fir.char<kind> type with the same kind as inside str.
fir::CharacterType
fir::factory::CharacterExprHelper::getCharacterType(mlir::Type type) {
assert(isCharacterScalar(type) && "expected scalar character");
@ -143,8 +161,8 @@ fir::factory::CharacterExprHelper::toExtendedValue(mlir::Value character,
// If the embox is accessible, use its operand to avoid filling
// the generated fir with embox/unbox.
mlir::Value boxCharLen;
if (auto *definingOp = character.getDefiningOp()) {
if (auto box = dyn_cast<fir::EmboxCharOp>(definingOp)) {
if (auto definingOp = character.getDefiningOp()) {
if (auto box = mlir::dyn_cast<fir::EmboxCharOp>(definingOp)) {
base = box.getMemref();
boxCharLen = box.getLen();
}
@ -217,7 +235,7 @@ fir::CharBoxValue fir::factory::CharacterExprHelper::toScalarCharacter(
auto lenType = builder.getCharacterLengthType();
auto len = builder.createConvert(loc, lenType, box.getLen());
for (auto extent : box.getExtents())
len = builder.create<arith::MulIOp>(
len = builder.create<mlir::arith::MulIOp>(
loc, len, builder.createConvert(loc, lenType, extent));
// TODO: typeLen can be improved in compiled constant cases
@ -302,48 +320,6 @@ mlir::Value fir::factory::CharacterExprHelper::getCharBoxBuffer(
return buff;
}
/// Get the LLVM intrinsic for `memcpy`. Use the 64 bit version.
mlir::FuncOp fir::factory::getLlvmMemcpy(fir::FirOpBuilder &builder) {
auto ptrTy = builder.getRefType(builder.getIntegerType(8));
llvm::SmallVector<mlir::Type> args = {ptrTy, ptrTy, builder.getI64Type(),
builder.getI1Type()};
auto memcpyTy =
mlir::FunctionType::get(builder.getContext(), args, llvm::None);
return builder.addNamedFunction(builder.getUnknownLoc(),
"llvm.memcpy.p0i8.p0i8.i64", memcpyTy);
}
/// Get the LLVM intrinsic for `memmove`. Use the 64 bit version.
mlir::FuncOp fir::factory::getLlvmMemmove(fir::FirOpBuilder &builder) {
auto ptrTy = builder.getRefType(builder.getIntegerType(8));
llvm::SmallVector<mlir::Type> args = {ptrTy, ptrTy, builder.getI64Type(),
builder.getI1Type()};
auto memmoveTy =
mlir::FunctionType::get(builder.getContext(), args, llvm::None);
return builder.addNamedFunction(builder.getUnknownLoc(),
"llvm.memmove.p0i8.p0i8.i64", memmoveTy);
}
/// Get the LLVM intrinsic for `memset`. Use the 64 bit version.
mlir::FuncOp fir::factory::getLlvmMemset(fir::FirOpBuilder &builder) {
auto ptrTy = builder.getRefType(builder.getIntegerType(8));
llvm::SmallVector<mlir::Type> args = {ptrTy, ptrTy, builder.getI64Type(),
builder.getI1Type()};
auto memsetTy =
mlir::FunctionType::get(builder.getContext(), args, llvm::None);
return builder.addNamedFunction(builder.getUnknownLoc(),
"llvm.memset.p0i8.p0i8.i64", memsetTy);
}
/// Get the standard `realloc` function.
mlir::FuncOp fir::factory::getRealloc(fir::FirOpBuilder &builder) {
auto ptrTy = builder.getRefType(builder.getIntegerType(8));
llvm::SmallVector<mlir::Type> args = {ptrTy, builder.getI64Type()};
auto reallocTy = mlir::FunctionType::get(builder.getContext(), args, {ptrTy});
return builder.addNamedFunction(builder.getUnknownLoc(), "realloc",
reallocTy);
}
/// Create a loop to copy `count` characters from `src` to `dest`. Note that the
/// KIND indicates the number of bits in a code point. (ASCII, UCS-2, or UCS-4.)
void fir::factory::CharacterExprHelper::createCopy(
@ -362,7 +338,8 @@ void fir::factory::CharacterExprHelper::createCopy(
auto i64Ty = builder.getI64Type();
auto kindBytes = builder.createIntegerConstant(loc, i64Ty, bytes);
auto castCount = builder.createConvert(loc, i64Ty, count);
auto totalBytes = builder.create<arith::MulIOp>(loc, kindBytes, castCount);
auto totalBytes =
builder.create<mlir::arith::MulIOp>(loc, kindBytes, castCount);
auto notVolatile = builder.createBool(loc, false);
auto memmv = getLlvmMemmove(builder);
auto argTys = memmv.getFunctionType().getInputs();
@ -441,8 +418,8 @@ void fir::factory::CharacterExprHelper::createLengthOneAssign(
/// Returns the minimum of integer mlir::Value \p a and \b.
mlir::Value genMin(fir::FirOpBuilder &builder, mlir::Location loc,
mlir::Value a, mlir::Value b) {
auto cmp =
builder.create<arith::CmpIOp>(loc, arith::CmpIPredicate::slt, a, b);
auto cmp = builder.create<mlir::arith::CmpIOp>(
loc, mlir::arith::CmpIPredicate::slt, a, b);
return builder.create<mlir::arith::SelectOp>(loc, cmp, a, b);
}
@ -474,7 +451,8 @@ void fir::factory::CharacterExprHelper::createAssign(
// Pad if needed.
if (!compileTimeSameLength) {
auto one = builder.createIntegerConstant(loc, lhs.getLen().getType(), 1);
auto maxPadding = builder.create<arith::SubIOp>(loc, lhs.getLen(), one);
auto maxPadding =
builder.create<mlir::arith::SubIOp>(loc, lhs.getLen(), one);
createPadding(lhs, copyCount, maxPadding);
}
}
@ -485,18 +463,18 @@ fir::CharBoxValue fir::factory::CharacterExprHelper::createConcatenate(
lhs.getLen());
auto rhsLen = builder.createConvert(loc, builder.getCharacterLengthType(),
rhs.getLen());
mlir::Value len = builder.create<arith::AddIOp>(loc, lhsLen, rhsLen);
mlir::Value len = builder.create<mlir::arith::AddIOp>(loc, lhsLen, rhsLen);
auto temp = createCharacterTemp(getCharacterType(rhs), len);
createCopy(temp, lhs, lhsLen);
auto one = builder.createIntegerConstant(loc, len.getType(), 1);
auto upperBound = builder.create<arith::SubIOp>(loc, len, one);
auto upperBound = builder.create<mlir::arith::SubIOp>(loc, len, one);
auto lhsLenIdx = builder.createConvert(loc, builder.getIndexType(), lhsLen);
auto fromBuff = getCharBoxBuffer(rhs);
auto toBuff = getCharBoxBuffer(temp);
fir::factory::DoLoopHelper{builder, loc}.createLoop(
lhsLenIdx, upperBound, one,
[&](fir::FirOpBuilder &bldr, mlir::Value index) {
auto rhsIndex = bldr.create<arith::SubIOp>(loc, index, lhsLenIdx);
auto rhsIndex = bldr.create<mlir::arith::SubIOp>(loc, index, lhsLenIdx);
auto charVal = createLoadCharAt(fromBuff, rhsIndex);
createStoreCharAt(toBuff, index, charVal);
});
@ -519,7 +497,8 @@ fir::CharBoxValue fir::factory::CharacterExprHelper::createSubstring(
auto lowerBound = castBounds[0];
// FIR CoordinateOp is zero based but Fortran substring are one based.
auto one = builder.createIntegerConstant(loc, lowerBound.getType(), 1);
auto offset = builder.create<arith::SubIOp>(loc, lowerBound, one).getResult();
auto offset =
builder.create<mlir::arith::SubIOp>(loc, lowerBound, one).getResult();
auto addr = createElementAddr(box.getBuffer(), offset);
auto kind = getCharacterKind(box.getBuffer().getType());
auto charTy = fir::CharacterType::getUnknownLen(builder.getContext(), kind);
@ -530,17 +509,17 @@ fir::CharBoxValue fir::factory::CharacterExprHelper::createSubstring(
mlir::Value substringLen;
if (nbounds < 2) {
substringLen =
builder.create<arith::SubIOp>(loc, box.getLen(), castBounds[0]);
builder.create<mlir::arith::SubIOp>(loc, box.getLen(), castBounds[0]);
} else {
substringLen =
builder.create<arith::SubIOp>(loc, castBounds[1], castBounds[0]);
builder.create<mlir::arith::SubIOp>(loc, castBounds[1], castBounds[0]);
}
substringLen = builder.create<arith::AddIOp>(loc, substringLen, one);
substringLen = builder.create<mlir::arith::AddIOp>(loc, substringLen, one);
// Set length to zero if bounds were reversed (Fortran 2018 9.4.1)
auto zero = builder.createIntegerConstant(loc, substringLen.getType(), 0);
auto cdt = builder.create<arith::CmpIOp>(loc, arith::CmpIPredicate::slt,
substringLen, zero);
auto cdt = builder.create<mlir::arith::CmpIOp>(
loc, mlir::arith::CmpIPredicate::slt, substringLen, zero);
substringLen =
builder.create<mlir::arith::SelectOp>(loc, cdt, zero, substringLen);
@ -558,7 +537,7 @@ fir::factory::CharacterExprHelper::createLenTrim(const fir::CharBoxValue &str) {
auto zero = builder.createIntegerConstant(loc, indexType, 0);
auto trueVal = builder.createIntegerConstant(loc, builder.getI1Type(), 1);
auto blank = createBlankConstantCode(getCharacterType(str));
mlir::Value lastChar = builder.create<arith::SubIOp>(loc, len, one);
mlir::Value lastChar = builder.create<mlir::arith::SubIOp>(loc, len, one);
auto iterWhile =
builder.create<fir::IterWhileOp>(loc, lastChar, zero, minusOne, trueVal,
@ -572,14 +551,14 @@ fir::factory::CharacterExprHelper::createLenTrim(const fir::CharBoxValue &str) {
auto codeAddr =
builder.createConvert(loc, builder.getRefType(blank.getType()), elemAddr);
auto c = builder.create<fir::LoadOp>(loc, codeAddr);
auto isBlank =
builder.create<arith::CmpIOp>(loc, arith::CmpIPredicate::eq, blank, c);
auto isBlank = builder.create<mlir::arith::CmpIOp>(
loc, mlir::arith::CmpIPredicate::eq, blank, c);
llvm::SmallVector<mlir::Value> results = {isBlank, index};
builder.create<fir::ResultOp>(loc, results);
builder.restoreInsertionPoint(insPt);
// Compute length after iteration (zero if all blanks)
mlir::Value newLen =
builder.create<arith::AddIOp>(loc, iterWhile.getResult(1), one);
builder.create<mlir::arith::AddIOp>(loc, iterWhile.getResult(1), one);
auto result = builder.create<mlir::arith::SelectOp>(
loc, iterWhile.getResult(0), zero, newLen);
return builder.createConvert(loc, builder.getCharacterLengthType(), result);
@ -651,16 +630,6 @@ bool fir::factory::CharacterExprHelper::isCharacterLiteral(mlir::Type type) {
return false;
}
bool fir::factory::CharacterExprHelper::isCharacterScalar(mlir::Type type) {
if (type.isa<fir::BoxCharType>())
return true;
type = fir::unwrapRefType(type);
if (auto boxTy = type.dyn_cast<fir::BoxType>())
type = boxTy.getEleTy();
type = fir::unwrapRefType(type);
return !type.isa<fir::SequenceType>() && fir::isa_char(type);
}
fir::KindTy
fir::factory::CharacterExprHelper::getCharacterKind(mlir::Type type) {
assert(isCharacterScalar(type) && "expected scalar character");
@ -672,10 +641,6 @@ fir::factory::CharacterExprHelper::getCharacterOrSequenceKind(mlir::Type type) {
return recoverCharacterType(type).getFKind();
}
bool fir::factory::CharacterExprHelper::isArray(mlir::Type type) {
return !isCharacterScalar(type);
}
bool fir::factory::CharacterExprHelper::hasConstantLengthInType(
const fir::ExtendedValue &exv) {
auto charTy = recoverCharacterType(fir::getBase(exv).getType());
@ -715,7 +680,7 @@ fir::factory::CharacterExprHelper::readLengthFromBox(mlir::Value box) {
auto width = bits / 8;
if (width > 1) {
auto widthVal = builder.createIntegerConstant(loc, lenTy, width);
return builder.create<arith::DivSIOp>(loc, size, widthVal);
return builder.create<mlir::arith::DivSIOp>(loc, size, widthVal);
}
return size;
}
@ -745,11 +710,16 @@ fir::factory::extractCharacterProcedureTuple(fir::FirOpBuilder &builder,
loc, tupleType.getType(0), tuple,
builder.getArrayAttr(
{builder.getIntegerAttr(builder.getIndexType(), 0)}));
mlir::Value proc = [&]() -> mlir::Value {
if (auto addrTy = addr.getType().dyn_cast<fir::BoxProcType>())
return builder.create<fir::BoxAddrOp>(loc, addrTy.getEleTy(), addr);
return addr;
}();
mlir::Value len = builder.create<fir::ExtractValueOp>(
loc, tupleType.getType(1), tuple,
builder.getArrayAttr(
{builder.getIntegerAttr(builder.getIndexType(), 1)}));
return {addr, len};
return {proc, len};
}
mlir::Value fir::factory::createCharacterProcedureTuple(
@ -770,13 +740,6 @@ mlir::Value fir::factory::createCharacterProcedureTuple(
return tuple;
}
bool fir::factory::isCharacterProcedureTuple(mlir::Type ty) {
mlir::TupleType tuple = ty.dyn_cast<mlir::TupleType>();
return tuple && tuple.size() == 2 &&
tuple.getType(0).isa<mlir::FunctionType>() &&
fir::isa_integer(tuple.getType(1));
}
mlir::Type
fir::factory::getCharacterProcedureTupleType(mlir::Type funcPointerType) {
mlir::MLIRContext *context = funcPointerType.getContext();

74
flang/lib/Optimizer/Builder/FIRBuilder.cpp
View File

@ -24,7 +24,12 @@
#include "llvm/Support/ErrorHandling.h"
#include "llvm/Support/MD5.h"
static constexpr std::size_t nameLengthHashSize = 32;
static llvm::cl::opt<std::size_t>
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));
mlir::FuncOp fir::FirOpBuilder::createFunction(mlir::Location loc,
mlir::ModuleOp module,
@ -480,12 +485,13 @@ mlir::Value fir::FirOpBuilder::createBox(mlir::Location loc,
return create<fir::LoadOp>(
loc, fir::factory::getMutableIRBox(*this, loc, x));
},
// UnboxedValue, ProcBoxValue or BoxValue.
[&](const auto &) -> mlir::Value {
return create<fir::EmboxOp>(loc, boxTy, itemAddr);
});
}
void fir::FirOpBuilder::dumpFunc() { getFunction().dump(); }
static mlir::Value
genNullPointerComparison(fir::FirOpBuilder &builder, mlir::Location loc,
mlir::Value addr,
@ -576,9 +582,9 @@ mlir::Value fir::factory::readExtent(fir::FirOpBuilder &builder,
.getResult(1);
},
[&](const fir::MutableBoxValue &x) -> mlir::Value {
// MutableBoxValue must be read into another category to work with them
// outside of allocation/assignment contexts.
fir::emitFatalError(loc, "readExtents on MutableBoxValue");
return readExtent(builder, loc,
fir::factory::genMutableBoxRead(builder, loc, x),
dim);
},
[&](const auto &) -> mlir::Value {
fir::emitFatalError(loc, "extent inquiry on scalar");
@ -894,35 +900,6 @@ fir::ExtendedValue fir::factory::arraySectionElementToExtendedValue(
return fir::factory::componentToExtendedValue(builder, loc, element);
}
mlir::TupleType
fir::factory::getRaggedArrayHeaderType(fir::FirOpBuilder &builder) {
mlir::IntegerType i64Ty = builder.getIntegerType(64);
auto arrTy = fir::SequenceType::get(builder.getIntegerType(8), 1);
auto buffTy = fir::HeapType::get(arrTy);
auto extTy = fir::SequenceType::get(i64Ty, 1);
auto shTy = fir::HeapType::get(extTy);
return mlir::TupleType::get(builder.getContext(), {i64Ty, buffTy, shTy});
}
mlir::Value fir::factory::createZeroValue(fir::FirOpBuilder &builder,
mlir::Location loc, mlir::Type type) {
mlir::Type i1 = builder.getIntegerType(1);
if (type.isa<fir::LogicalType>() || type == i1)
return builder.createConvert(loc, type, builder.createBool(loc, false));
if (fir::isa_integer(type))
return builder.createIntegerConstant(loc, type, 0);
if (fir::isa_real(type))
return builder.createRealZeroConstant(loc, type);
if (fir::isa_complex(type)) {
fir::factory::Complex complexHelper(builder, loc);
mlir::Type partType = complexHelper.getComplexPartType(type);
mlir::Value zeroPart = builder.createRealZeroConstant(loc, partType);
return complexHelper.createComplex(type, zeroPart, zeroPart);
}
fir::emitFatalError(loc, "internal: trying to generate zero value of non "
"numeric or logical type");
}
void fir::factory::genScalarAssignment(fir::FirOpBuilder &builder,
mlir::Location loc,
const fir::ExtendedValue &lhs,
@ -1072,6 +1049,16 @@ void fir::factory::genRecordAssignment(fir::FirOpBuilder &builder,
genComponentByComponentAssignment(builder, loc, lhs, rhs);
}
mlir::TupleType
fir::factory::getRaggedArrayHeaderType(fir::FirOpBuilder &builder) {
mlir::IntegerType i64Ty = builder.getIntegerType(64);
auto arrTy = fir::SequenceType::get(builder.getIntegerType(8), 1);
auto buffTy = fir::HeapType::get(arrTy);
auto extTy = fir::SequenceType::get(i64Ty, 1);
auto shTy = fir::HeapType::get(extTy);
return mlir::TupleType::get(builder.getContext(), {i64Ty, buffTy, shTy});
}
mlir::Value fir::factory::genLenOfCharacter(
fir::FirOpBuilder &builder, mlir::Location loc, fir::ArrayLoadOp arrLoad,
llvm::ArrayRef<mlir::Value> path, llvm::ArrayRef<mlir::Value> substring) {
@ -1129,3 +1116,22 @@ mlir::Value fir::factory::genLenOfCharacter(
}
TODO(loc, "LEN of character must be computed at runtime");
}
mlir::Value fir::factory::createZeroValue(fir::FirOpBuilder &builder,
mlir::Location loc, mlir::Type type) {
mlir::Type i1 = builder.getIntegerType(1);
if (type.isa<fir::LogicalType>() || type == i1)
return builder.createConvert(loc, type, builder.createBool(loc, false));
if (fir::isa_integer(type))
return builder.createIntegerConstant(loc, type, 0);
if (fir::isa_real(type))
return builder.createRealZeroConstant(loc, type);
if (fir::isa_complex(type)) {
fir::factory::Complex complexHelper(builder, loc);
mlir::Type partType = complexHelper.getComplexPartType(type);
mlir::Value zeroPart = builder.createRealZeroConstant(loc, partType);
return complexHelper.createComplex(type, zeroPart, zeroPart);
}
fir::emitFatalError(loc, "internal: trying to generate zero value of non "
"numeric or logical type");
}

53
flang/lib/Optimizer/Builder/LowLevelIntrinsics.cpp
View File

@ -21,6 +21,44 @@
#include "flang/Optimizer/Builder/LowLevelIntrinsics.h"
#include "flang/Optimizer/Builder/FIRBuilder.h"
mlir::FuncOp fir::factory::getLlvmMemcpy(fir::FirOpBuilder &builder) {
auto ptrTy = builder.getRefType(builder.getIntegerType(8));
llvm::SmallVector<mlir::Type> args = {ptrTy, ptrTy, builder.getI64Type(),
builder.getI1Type()};
auto memcpyTy =
mlir::FunctionType::get(builder.getContext(), args, llvm::None);
return builder.addNamedFunction(builder.getUnknownLoc(),
"llvm.memcpy.p0i8.p0i8.i64", memcpyTy);
}
mlir::FuncOp fir::factory::getLlvmMemmove(fir::FirOpBuilder &builder) {
auto ptrTy = builder.getRefType(builder.getIntegerType(8));
llvm::SmallVector<mlir::Type> args = {ptrTy, ptrTy, builder.getI64Type(),
builder.getI1Type()};
auto memmoveTy =
mlir::FunctionType::get(builder.getContext(), args, llvm::None);
return builder.addNamedFunction(builder.getUnknownLoc(),
"llvm.memmove.p0i8.p0i8.i64", memmoveTy);
}
mlir::FuncOp fir::factory::getLlvmMemset(fir::FirOpBuilder &builder) {
auto ptrTy = builder.getRefType(builder.getIntegerType(8));
llvm::SmallVector<mlir::Type> args = {ptrTy, ptrTy, builder.getI64Type(),
builder.getI1Type()};
auto memsetTy =
mlir::FunctionType::get(builder.getContext(), args, llvm::None);
return builder.addNamedFunction(builder.getUnknownLoc(),
"llvm.memset.p0i8.p0i8.i64", memsetTy);
}
mlir::FuncOp fir::factory::getRealloc(fir::FirOpBuilder &builder) {
auto ptrTy = builder.getRefType(builder.getIntegerType(8));
llvm::SmallVector<mlir::Type> args = {ptrTy, builder.getI64Type()};
auto reallocTy = mlir::FunctionType::get(builder.getContext(), args, {ptrTy});
return builder.addNamedFunction(builder.getUnknownLoc(), "realloc",
reallocTy);
}
mlir::FuncOp fir::factory::getLlvmStackSave(fir::FirOpBuilder &builder) {
auto ptrTy = builder.getRefType(builder.getIntegerType(8));
auto funcTy =
@ -36,3 +74,18 @@ mlir::FuncOp fir::factory::getLlvmStackRestore(fir::FirOpBuilder &builder) {
return builder.addNamedFunction(builder.getUnknownLoc(), "llvm.stackrestore",
funcTy);
}
mlir::FuncOp fir::factory::getLlvmInitTrampoline(fir::FirOpBuilder &builder) {
auto ptrTy = builder.getRefType(builder.getIntegerType(8));
auto funcTy = mlir::FunctionType::get(builder.getContext(),
{ptrTy, ptrTy, ptrTy}, llvm::None);
return builder.addNamedFunction(builder.getUnknownLoc(),
"llvm.init.trampoline", funcTy);
}
mlir::FuncOp fir::factory::getLlvmAdjustTrampoline(fir::FirOpBuilder &builder) {
auto ptrTy = builder.getRefType(builder.getIntegerType(8));
auto funcTy = mlir::FunctionType::get(builder.getContext(), {ptrTy}, {ptrTy});
return builder.addNamedFunction(builder.getUnknownLoc(),
"llvm.adjust.trampoline", funcTy);
}

77
flang/lib/Optimizer/Builder/MutableBox.cpp
View File

@ -268,52 +268,8 @@ private:
/// Update the IR box (fir.ref<fir.box<T>>) of the MutableBoxValue.
void updateIRBox(mlir::Value addr, mlir::ValueRange lbounds,
mlir::ValueRange extents, mlir::ValueRange lengths) {
mlir::Value shape;
if (!extents.empty()) {
if (lbounds.empty()) {
auto shapeType =
fir::ShapeType::get(builder.getContext(), extents.size());
shape = builder.create<fir::ShapeOp>(loc, shapeType, extents);
} else {
llvm::SmallVector<mlir::Value> shapeShiftBounds;
for (auto [lb, extent] : llvm::zip(lbounds, extents)) {
shapeShiftBounds.emplace_back(lb);
shapeShiftBounds.emplace_back(extent);
}
auto shapeShiftType =
fir::ShapeShiftType::get(builder.getContext(), extents.size());
shape = builder.create<fir::ShapeShiftOp>(loc, shapeShiftType,
shapeShiftBounds);
}
}
mlir::Value emptySlice;
// Ignore lengths if already constant in the box type (this would trigger an
// error in the embox).
llvm::SmallVector<mlir::Value> cleanedLengths;
mlir::Value irBox;
if (addr.getType().isa<fir::BoxType>()) {
// The entity is already boxed.
irBox = builder.createConvert(loc, box.getBoxTy(), addr);
} else {
auto cleanedAddr = addr;
if (auto charTy = box.getEleTy().dyn_cast<fir::CharacterType>()) {
// Cast address to box type so that both input and output type have
// unknown or constant lengths.
auto bt = box.getBaseTy();
auto addrTy = addr.getType();
auto type = addrTy.isa<fir::HeapType>() ? fir::HeapType::get(bt)
: addrTy.isa<fir::PointerType>() ? fir::PointerType::get(bt)
: builder.getRefType(bt);
cleanedAddr = builder.createConvert(loc, type, addr);
if (charTy.getLen() == fir::CharacterType::unknownLen())
cleanedLengths.append(lengths.begin(), lengths.end());
} else if (box.isDerivedWithLengthParameters()) {
TODO(loc, "updating mutablebox of derived type with length parameters");
cleanedLengths = lengths;
}
irBox = builder.create<fir::EmboxOp>(loc, box.getBoxTy(), cleanedAddr,
shape, emptySlice, cleanedLengths);
}
mlir::Value irBox =
createNewFirBox(builder, loc, box, addr, lbounds, extents, lengths);
builder.create<fir::StoreOp>(loc, irBox, box.getAddr());
}
@ -725,26 +681,19 @@ void fir::factory::genInlinedAllocation(fir::FirOpBuilder &builder,
mlir::ValueRange extents,
mlir::ValueRange lenParams,
llvm::StringRef allocName) {
auto idxTy = builder.getIndexType();
llvm::SmallVector<mlir::Value> lengths;
if (auto charTy = box.getEleTy().dyn_cast<fir::CharacterType>()) {
if (charTy.getLen() == fir::CharacterType::unknownLen()) {
if (box.hasNonDeferredLenParams())
lengths.emplace_back(
builder.createConvert(loc, idxTy, box.nonDeferredLenParams()[0]));
else if (!lenParams.empty())
lengths.emplace_back(builder.createConvert(loc, idxTy, lenParams[0]));
else
fir::emitFatalError(
loc, "could not deduce character lengths in character allocation");
}
}
mlir::Value heap = builder.create<fir::AllocMemOp>(
loc, box.getBaseTy(), allocName, lengths, extents);
// TODO: run initializer if any. Currently, there is no way to know this is
// required here.
auto lengths = getNewLengths(builder, loc, box, lenParams);
auto heap = builder.create<fir::AllocMemOp>(loc, box.getBaseTy(), allocName,
lengths, extents);
MutablePropertyWriter{builder, loc, box}.updateMutableBox(heap, lbounds,
extents, lengths);
if (box.getEleTy().isa<fir::RecordType>()) {
// TODO: skip runtime initialization if this is not required. Currently,
// there is no way to know here if a derived type needs it or not. But the
// information is available at compile time and could be reflected here
// somehow.
mlir::Value irBox = fir::factory::getMutableIRBox(builder, loc, box);
fir::runtime::genDerivedTypeInitialize(builder, loc, irBox);
}
}
void fir::factory::genInlinedDeallocate(fir::FirOpBuilder &builder,

326
flang/lib/Optimizer/CodeGen/BoxedProcedure.cpp Normal file
View File

@ -0,0 +1,326 @@
//===-- BoxedProcedure.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 "PassDetail.h"
#include "flang/Optimizer/Builder/FIRBuilder.h"
#include "flang/Optimizer/Builder/LowLevelIntrinsics.h"
#include "flang/Optimizer/CodeGen/CodeGen.h"
#include "flang/Optimizer/Dialect/FIRDialect.h"
#include "flang/Optimizer/Dialect/FIROps.h"
#include "flang/Optimizer/Dialect/FIRType.h"
#include "flang/Optimizer/Support/FIRContext.h"
#include "flang/Optimizer/Support/FatalError.h"
#include "mlir/IR/PatternMatch.h"
#include "mlir/Pass/Pass.h"
#include "mlir/Transforms/DialectConversion.h"
#define DEBUG_TYPE "flang-procedure-pointer"
using namespace fir;
namespace {
/// Options to the procedure pointer pass.
struct BoxedProcedureOptions {
// Lower the boxproc abstraction to function pointers and thunks where
// required.
bool useThunks = true;
};
/// This type converter rewrites all `!fir.boxproc<Func>` types to `Func` types.
class BoxprocTypeRewriter : public mlir::TypeConverter {
public:
using mlir::TypeConverter::convertType;
/// Does the type \p ty need to be converted?
/// Any type that is a `!fir.boxproc` in whole or in part will need to be
/// converted to a function type to lower the IR to function pointer form in
/// the default implementation performed in this pass. Other implementations
/// are possible, so those may convert `!fir.boxproc` to some other type or
/// not at all depending on the implementation target's characteristics and
/// preference.
bool needsConversion(mlir::Type ty) {
if (ty.isa<BoxProcType>())
return true;
if (auto funcTy = ty.dyn_cast<mlir::FunctionType>()) {
for (auto t : funcTy.getInputs())
if (needsConversion(t))
return true;
for (auto t : funcTy.getResults())
if (needsConversion(t))
return true;
return false;
}
if (auto tupleTy = ty.dyn_cast<mlir::TupleType>()) {
for (auto t : tupleTy.getTypes())
if (needsConversion(t))
return true;
return false;
}
if (auto recTy = ty.dyn_cast<RecordType>()) {
bool result = false;
visitedTypes.push_back(recTy);
for (auto t : recTy.getTypeList()) {
if (llvm::any_of(visitedTypes,
[&](mlir::Type rt) { return rt == recTy; }))
continue;
if (needsConversion(t.second)) {
result = true;
break;
}
}
visitedTypes.pop_back();
return result;
}
if (auto boxTy = ty.dyn_cast<BoxType>())
return needsConversion(boxTy.getEleTy());
if (isa_ref_type(ty))
return needsConversion(unwrapRefType(ty));
if (auto t = ty.dyn_cast<SequenceType>())
return needsConversion(unwrapSequenceType(ty));
return false;
}
BoxprocTypeRewriter() {
addConversion([](mlir::Type ty) { return ty; });
addConversion([](BoxProcType boxproc) { return boxproc.getEleTy(); });
addConversion([&](mlir::TupleType tupTy) {
llvm::SmallVector<mlir::Type> memTys;
for (auto ty : tupTy.getTypes())
memTys.push_back(convertType(ty));
return mlir::TupleType::get(tupTy.getContext(), memTys);
});
addConversion([&](mlir::FunctionType funcTy) {
llvm::SmallVector<mlir::Type> inTys;
llvm::SmallVector<mlir::Type> resTys;
for (auto ty : funcTy.getInputs())
inTys.push_back(convertType(ty));
for (auto ty : funcTy.getResults())
resTys.push_back(convertType(ty));
return mlir::FunctionType::get(funcTy.getContext(), inTys, resTys);
});
addConversion([&](ReferenceType ty) {
return ReferenceType::get(convertType(ty.getEleTy()));
});
addConversion([&](PointerType ty) {
return PointerType::get(convertType(ty.getEleTy()));
});
addConversion(
[&](HeapType ty) { return HeapType::get(convertType(ty.getEleTy())); });
addConversion(
[&](BoxType ty) { return BoxType::get(convertType(ty.getEleTy())); });
addConversion([&](SequenceType ty) {
// TODO: add ty.getLayoutMap() as needed.
return SequenceType::get(ty.getShape(), convertType(ty.getEleTy()));
});
addConversion([&](RecordType ty) {
// FIR record types can have recursive references, so conversion is a bit
// more complex than the other types. This conversion is not needed
// presently, so just emit a TODO message. Need to consider the uniqued
// name of the record, etc.
fir::emitFatalError(
mlir::UnknownLoc::get(ty.getContext()),
"not yet implemented: record type with a boxproc type");
return RecordType::get(ty.getContext(), "*fixme*");
});
addArgumentMaterialization(materializeProcedure);
addSourceMaterialization(materializeProcedure);
addTargetMaterialization(materializeProcedure);
}
static mlir::Value materializeProcedure(mlir::OpBuilder &builder,
BoxProcType type,
mlir::ValueRange inputs,
mlir::Location loc) {
assert(inputs.size() == 1);
return builder.create<ConvertOp>(loc, unwrapRefType(type.getEleTy()),
inputs[0]);
}
private:
llvm::SmallVector<mlir::Type> visitedTypes;
};
/// A `boxproc` is an abstraction for a Fortran procedure reference. Typically,
/// Fortran procedures can be referenced directly through a function pointer.
/// However, Fortran has one-level dynamic scoping between a host procedure and
/// its internal procedures. This allows internal procedures to directly access
/// and modify the state of the host procedure's variables.
///
/// There are any number of possible implementations possible.
///
/// The implementation used here is to convert `boxproc` values to function
/// pointers everywhere. If a `boxproc` value includes a frame pointer to the
/// host procedure's data, then a thunk will be created at runtime to capture
/// the frame pointer during execution. In LLVM IR, the frame pointer is
/// designated with the `nest` attribute. The thunk's address will then be used
/// as the call target instead of the original function's address directly.
class BoxedProcedurePass : public BoxedProcedurePassBase<BoxedProcedurePass> {
public:
BoxedProcedurePass() { options = {true}; }
BoxedProcedurePass(bool useThunks) { options = {useThunks}; }
inline mlir::ModuleOp getModule() { return getOperation(); }
void runOnOperation() override final {
if (options.useThunks) {
auto *context = &getContext();
mlir::IRRewriter rewriter(context);
BoxprocTypeRewriter typeConverter;
mlir::Dialect *firDialect = context->getLoadedDialect("fir");
getModule().walk([&](mlir::Operation *op) {
if (auto addr = mlir::dyn_cast<BoxAddrOp>(op)) {
auto ty = addr.getVal().getType();
if (typeConverter.needsConversion(ty) ||
ty.isa<mlir::FunctionType>()) {
// Rewrite all `fir.box_addr` ops on values of type `!fir.boxproc`
// or function type to be `fir.convert` ops.
rewriter.setInsertionPoint(addr);
rewriter.replaceOpWithNewOp<ConvertOp>(
addr, typeConverter.convertType(addr.getType()), addr.getVal());
}
} else if (auto func = mlir::dyn_cast<mlir::FuncOp>(op)) {
mlir::FunctionType ty = func.getFunctionType();
if (typeConverter.needsConversion(ty)) {
rewriter.startRootUpdate(func);
auto toTy =
typeConverter.convertType(ty).cast<mlir::FunctionType>();
if (!func.empty())
for (auto e : llvm::enumerate(toTy.getInputs())) {
unsigned i = e.index();
auto &block = func.front();
block.insertArgument(i, e.value(), func.getLoc());
block.getArgument(i + 1).replaceAllUsesWith(
block.getArgument(i));
block.eraseArgument(i + 1);
}
func.setType(toTy);
rewriter.finalizeRootUpdate(func);
}
} else if (auto embox = mlir::dyn_cast<EmboxProcOp>(op)) {
// Rewrite all `fir.emboxproc` ops to either `fir.convert` or a thunk
// as required.
mlir::Type toTy = embox.getType().cast<BoxProcType>().getEleTy();
rewriter.setInsertionPoint(embox);
if (embox.getHost()) {
// Create the thunk.
auto module = embox->getParentOfType<mlir::ModuleOp>();
FirOpBuilder builder(rewriter, getKindMapping(module));
auto loc = embox.getLoc();
mlir::Type i8Ty = builder.getI8Type();
mlir::Type i8Ptr = builder.getRefType(i8Ty);
mlir::Type buffTy = SequenceType::get({32}, i8Ty);
auto buffer = builder.create<AllocaOp>(loc, buffTy);
mlir::Value closure =
builder.createConvert(loc, i8Ptr, embox.getHost());
mlir::Value tramp = builder.createConvert(loc, i8Ptr, buffer);
mlir::Value func =
builder.createConvert(loc, i8Ptr, embox.getFunc());
builder.create<fir::CallOp>(
loc, factory::getLlvmInitTrampoline(builder),
llvm::ArrayRef<mlir::Value>{tramp, func, closure});
auto adjustCall = builder.create<fir::CallOp>(
loc, factory::getLlvmAdjustTrampoline(builder),
llvm::ArrayRef<mlir::Value>{tramp});
rewriter.replaceOpWithNewOp<ConvertOp>(embox, toTy,
adjustCall.getResult(0));
} else {
// Just forward the function as a pointer.
rewriter.replaceOpWithNewOp<ConvertOp>(embox, toTy,
embox.getFunc());
}
} else if (auto mem = mlir::dyn_cast<AllocaOp>(op)) {
auto ty = mem.getType();
if (typeConverter.needsConversion(ty)) {
rewriter.setInsertionPoint(mem);
auto toTy = typeConverter.convertType(unwrapRefType(ty));
bool isPinned = mem.getPinned();
llvm::StringRef uniqName;
if (mem.getUniqName().hasValue())
uniqName = mem.getUniqName().getValue();
llvm::StringRef bindcName;
if (mem.getBindcName().hasValue())
bindcName = mem.getBindcName().getValue();
rewriter.replaceOpWithNewOp<AllocaOp>(
mem, toTy, uniqName, bindcName, isPinned, mem.getTypeparams(),
mem.getShape());
}
} else if (auto mem = mlir::dyn_cast<AllocMemOp>(op)) {
auto ty = mem.getType();
if (typeConverter.needsConversion(ty)) {
rewriter.setInsertionPoint(mem);
auto toTy = typeConverter.convertType(unwrapRefType(ty));
llvm::StringRef uniqName;
if (mem.getUniqName().hasValue())
uniqName = mem.getUniqName().getValue();
llvm::StringRef bindcName;
if (mem.getBindcName().hasValue())
bindcName = mem.getBindcName().getValue();
rewriter.replaceOpWithNewOp<AllocMemOp>(
mem, toTy, uniqName, bindcName, mem.getTypeparams(),
mem.getShape());
}
} else if (auto coor = mlir::dyn_cast<CoordinateOp>(op)) {
auto ty = coor.getType();
mlir::Type baseTy = coor.getBaseType();
if (typeConverter.needsConversion(ty) ||
typeConverter.needsConversion(baseTy)) {
rewriter.setInsertionPoint(coor);
auto toTy = typeConverter.convertType(ty);
auto toBaseTy = typeConverter.convertType(baseTy);
rewriter.replaceOpWithNewOp<CoordinateOp>(coor, toTy, coor.getRef(),
coor.getCoor(), toBaseTy);
}
} else if (auto index = mlir::dyn_cast<FieldIndexOp>(op)) {
auto ty = index.getType();
mlir::Type onTy = index.getOnType();
if (typeConverter.needsConversion(ty) ||
typeConverter.needsConversion(onTy)) {
rewriter.setInsertionPoint(index);
auto toTy = typeConverter.convertType(ty);
auto toOnTy = typeConverter.convertType(onTy);
rewriter.replaceOpWithNewOp<FieldIndexOp>(
index, toTy, index.getFieldId(), toOnTy, index.getTypeparams());
}
} else if (auto index = mlir::dyn_cast<LenParamIndexOp>(op)) {
auto ty = index.getType();
mlir::Type onTy = index.getOnType();
if (typeConverter.needsConversion(ty) ||
typeConverter.needsConversion(onTy)) {
rewriter.setInsertionPoint(index);
auto toTy = typeConverter.convertType(ty);
auto toOnTy = typeConverter.convertType(onTy);
rewriter.replaceOpWithNewOp<LenParamIndexOp>(
mem, toTy, index.getFieldId(), toOnTy);
}
} else if (op->getDialect() == firDialect) {
rewriter.startRootUpdate(op);
for (auto i : llvm::enumerate(op->getResultTypes()))
if (typeConverter.needsConversion(i.value())) {
auto toTy = typeConverter.convertType(i.value());
op->getResult(i.index()).setType(toTy);
}
rewriter.finalizeRootUpdate(op);
}
});
}
// TODO: any alternative implementation. Note: currently, the default code
// gen will not be able to handle boxproc and will give an error.
}
private:
BoxedProcedureOptions options;
};
} // namespace
std::unique_ptr<mlir::Pass> fir::createBoxedProcedurePass() {
return std::make_unique<BoxedProcedurePass>();
}
std::unique_ptr<mlir::Pass> fir::createBoxedProcedurePass(bool useThunks) {
return std::make_unique<BoxedProcedurePass>(useThunks);
}

1
flang/lib/Optimizer/CodeGen/CMakeLists.txt
View File

@ -1,4 +1,5 @@
add_flang_library(FIRCodeGen
BoxedProcedure.cpp
CGOps.cpp
CodeGen.cpp
PreCGRewrite.cpp

34
flang/lib/Optimizer/CodeGen/TargetRewrite.cpp
View File

@ -18,6 +18,7 @@
#include "Target.h"
#include "flang/Lower/Todo.h"
#include "flang/Optimizer/Builder/Character.h"
#include "flang/Optimizer/Builder/FIRBuilder.h"
#include "flang/Optimizer/CodeGen/CodeGen.h"
#include "flang/Optimizer/Dialect/FIRDialect.h"
#include "flang/Optimizer/Dialect/FIROps.h"
@ -83,9 +84,8 @@ public:
if (!forcedTargetTriple.empty())
setTargetTriple(mod, forcedTargetTriple);
auto specifics = CodeGenSpecifics::get(getOperation().getContext(),
getTargetTriple(getOperation()),
getKindMapping(getOperation()));
auto specifics = CodeGenSpecifics::get(
mod.getContext(), getTargetTriple(mod), getKindMapping(mod));
setMembers(specifics.get(), &rewriter);
// Perform type conversion on signatures and call sites.
@ -272,12 +272,12 @@ public:
rewriteCallComplexInputType(cmplx, oper, newInTys, newOpers);
})
.template Case<mlir::TupleType>([&](mlir::TupleType tuple) {
if (factory::isCharacterProcedureTuple(tuple)) {
if (isCharacterProcedureTuple(tuple)) {
mlir::ModuleOp module = getModule();
if constexpr (std::is_same_v<std::decay_t<A>, fir::CallOp>) {
if (callOp.getCallee()) {
llvm::StringRef charProcAttr =
fir::getCharacterProcedureDummyAttrName();
getCharacterProcedureDummyAttrName();
// The charProcAttr attribute is only used as a safety to
// confirm that this is a dummy procedure and should be split.
// It cannot be used to match because attributes are not
@ -401,7 +401,7 @@ public:
lowerComplexSignatureArg(ty, newInTys);
})
.Case<mlir::TupleType>([&](mlir::TupleType tuple) {
if (factory::isCharacterProcedureTuple(tuple)) {
if (isCharacterProcedureTuple(tuple)) {
newInTys.push_back(tuple.getType(0));
trailingInTys.push_back(tuple.getType(1));
} else {
@ -442,7 +442,7 @@ public:
return false;
}
for (auto ty : func.getInputs())
if (((ty.isa<BoxCharType>() || factory::isCharacterProcedureTuple(ty)) &&
if (((ty.isa<BoxCharType>() || isCharacterProcedureTuple(ty)) &&
!noCharacterConversion) ||
(isa_complex(ty) && !noComplexConversion)) {
LLVM_DEBUG(llvm::dbgs() << "rewrite " << signature << " for target\n");
@ -451,11 +451,21 @@ public:
return true;
}
/// Determine if the signature has host associations. The host association
/// argument may need special target specific rewriting.
static bool hasHostAssociations(mlir::FuncOp func) {
std::size_t end = func.getFunctionType().getInputs().size();
for (std::size_t i = 0; i < end; ++i)
if (func.getArgAttrOfType<mlir::UnitAttr>(i, getHostAssocAttrName()))
return true;
return false;
}
/// Rewrite the signatures and body of the `FuncOp`s in the module for
/// the immediately subsequent target code gen.
void convertSignature(mlir::FuncOp func) {
auto funcTy = func.getFunctionType().cast<mlir::FunctionType>();
if (hasPortableSignature(funcTy))
if (hasPortableSignature(funcTy) && !hasHostAssociations(func))
return;
llvm::SmallVector<mlir::Type> newResTys;
llvm::SmallVector<mlir::Type> newInTys;
@ -526,7 +536,7 @@ public:
doComplexArg(func, cmplx, newInTys, fixups);
})
.Case<mlir::TupleType>([&](mlir::TupleType tuple) {
if (factory::isCharacterProcedureTuple(tuple)) {
if (isCharacterProcedureTuple(tuple)) {
fixups.emplace_back(FixupTy::Codes::TrailingCharProc,
newInTys.size(), trailingTys.size());
newInTys.push_back(tuple.getType(0));
@ -536,6 +546,10 @@ public:
}
})
.Default([&](mlir::Type ty) { newInTys.push_back(ty); });
if (func.getArgAttrOfType<mlir::UnitAttr>(index,
getHostAssocAttrName())) {
func.setArgAttr(index, "llvm.nest", rewriter->getUnitAttr());
}
}
if (!func.empty()) {
@ -665,7 +679,7 @@ public:
func.front().eraseArgument(fixup.index + 1);
} break;
case FixupTy::Codes::TrailingCharProc: {
// The FIR character procedure argument tuple has been split into a
// The FIR character procedure argument tuple must be split into a
// pair of distinct arguments. The first part of the pair appears in
// the original argument position. The second part of the pair is
// appended after all the original arguments.

10
flang/lib/Optimizer/CodeGen/TypeConverter.h
View File

@ -250,6 +250,16 @@ public:
.getElementType();
}
// fir.boxproc<any> --> llvm<"{ any*, i8* }">
mlir::Type convertBoxProcType(BoxProcType boxproc) {
auto funcTy = convertType(boxproc.getEleTy());
auto i8PtrTy = mlir::LLVM::LLVMPointerType::get(
mlir::IntegerType::get(&getContext(), 8));
llvm::SmallVector<mlir::Type, 2> tuple = {funcTy, i8PtrTy};
return mlir::LLVM::LLVMStructType::getLiteral(&getContext(), tuple,
/*isPacked=*/false);
}
unsigned characterBitsize(fir::CharacterType charTy) {
return kindMapping.getCharacterBitsize(charTy.getFKind());
}

52
flang/lib/Optimizer/Dialect/FIROps.cpp
View File

@ -1095,57 +1095,13 @@ mlir::LogicalResult EmboxCharOp::verify() {
// EmboxProcOp
//===----------------------------------------------------------------------===//
mlir::ParseResult EmboxProcOp::parse(mlir::OpAsmParser &parser,
mlir::OperationState &result) {
mlir::SymbolRefAttr procRef;
if (parser.parseAttribute(procRef, "funcname", result.attributes))
return mlir::failure();
bool hasTuple = false;
mlir::OpAsmParser::UnresolvedOperand tupleRef;
if (!parser.parseOptionalComma()) {
if (parser.parseOperand(tupleRef))
return mlir::failure();
hasTuple = true;
}
mlir::FunctionType type;
if (parser.parseColon() || parser.parseLParen() || parser.parseType(type))
return mlir::failure();
result.addAttribute("functype", mlir::TypeAttr::get(type));
if (hasTuple) {
mlir::Type tupleType;
if (parser.parseComma() || parser.parseType(tupleType) ||
parser.resolveOperand(tupleRef, tupleType, result.operands))
return mlir::failure();
}
mlir::Type boxType;
if (parser.parseRParen() || parser.parseArrow() ||
parser.parseType(boxType) || parser.addTypesToList(boxType, result.types))
return mlir::failure();
return mlir::success();
}
void EmboxProcOp::print(mlir::OpAsmPrinter &p) {
p << ' ' << getOperation()->getAttr("funcname");
auto h = getHost();
if (h) {
p << ", ";
p.printOperand(h);
}
p << " : (" << getOperation()->getAttr("functype");
if (h)
p << ", " << h.getType();
p << ") -> " << getType();
}
mlir::LogicalResult EmboxProcOp::verify() {
// host bindings (optional) must be a reference to a tuple
if (auto h = getHost()) {
if (auto r = h.getType().dyn_cast<ReferenceType>()) {
if (!r.getEleTy().dyn_cast<mlir::TupleType>())
return mlir::failure();
} else {
return mlir::failure();
}
if (auto r = h.getType().dyn_cast<ReferenceType>())
if (r.getEleTy().dyn_cast<mlir::TupleType>())
return mlir::success();
return mlir::failure();
}
return mlir::success();
}

27
flang/lib/Optimizer/Transforms/ExternalNameConversion.cpp
View File

@ -116,25 +116,6 @@ public:
}
};
struct MangleNameOnEmboxProcOp
: public mlir::OpRewritePattern<fir::EmboxProcOp> {
public:
using OpRewritePattern::OpRewritePattern;
mlir::LogicalResult
matchAndRewrite(fir::EmboxProcOp op,
mlir::PatternRewriter &rewriter) const override {
rewriter.startRootUpdate(op);
auto result = fir::NameUniquer::deconstruct(
op.getFuncname().getRootReference().getValue());
if (fir::NameUniquer::isExternalFacingUniquedName(result))
op.setFuncnameAttr(
SymbolRefAttr::get(op.getContext(), mangleExternalName(result)));
rewriter.finalizeRootUpdate(op);
return success();
}
};
class ExternalNameConversionPass
: public fir::ExternalNameConversionBase<ExternalNameConversionPass> {
public:
@ -149,8 +130,7 @@ void ExternalNameConversionPass::runOnOperation() {
mlir::RewritePatternSet patterns(context);
patterns.insert<MangleNameOnCallOp, MangleNameOnCallOp, MangleNameOnFuncOp,
MangleNameForCommonBlock, MangleNameOnAddrOfOp,
MangleNameOnEmboxProcOp>(context);
MangleNameForCommonBlock, MangleNameOnAddrOfOp>(context);
ConversionTarget target(*context);
target.addLegalDialect<fir::FIROpsDialect, LLVM::LLVMDialect,
@ -177,11 +157,6 @@ void ExternalNameConversionPass::runOnOperation() {
op.getSymbol().getRootReference().getValue());
});
target.addDynamicallyLegalOp<fir::EmboxProcOp>([](fir::EmboxProcOp op) {
return !fir::NameUniquer::needExternalNameMangling(
op.getFuncname().getRootReference().getValue());
});
if (failed(applyPartialConversion(op, target, std::move(patterns))))
signalPassFailure();
}

11
flang/test/Fir/Todo/emboxproc.fir
View File

@ -1,11 +0,0 @@
// RUN: %not_todo_cmd fir-opt --fir-to-llvm-ir="target=x86_64-unknown-linux-gnu" %s 2>&1 | FileCheck %s
// Test `fir.emboxproc` conversion to llvm.
// Not implemented yet.
func @emboxproc_test() {
%host_vars = fir.alloca tuple<i32,f64>
// CHECK: not yet implemented fir.emboxproc codegen
%bproc = fir.emboxproc @method_impl, %host_vars : ((i32) -> (), !fir.ref<tuple<i32,f64>>) -> !fir.boxproc<(i32) -> ()>
return
}

5
flang/test/Fir/external-mangling-emboxproc.fir
View File

@ -2,9 +2,10 @@
func @_QPfoo() {
%e6 = fir.alloca tuple<i32,f64>
%0 = fir.emboxproc @_QPfoo_impl, %e6 : ((!fir.box<!fir.type<derived3{f:f32}>>) -> (), !fir.ref<tuple<i32,f64>>) -> !fir.boxproc<(!fir.box<!fir.type<derived3{f:f32}>>) -> ()>
%ao = fir.address_of(@_QPfoo_impl) : (!fir.box<!fir.type<derived3{f:f32}>>) -> ()
%0 = fir.emboxproc %ao, %e6 : ((!fir.box<!fir.type<derived3{f:f32}>>) -> (), !fir.ref<tuple<i32,f64>>) -> !fir.boxproc<(!fir.box<!fir.type<derived3{f:f32}>>) -> ()>
return
}
func private @_QPfoo_impl(!fir.ref<i32>)
// CHECK: %{{.*}}= fir.emboxproc @foo_impl_
// CHECK: fir.address_of(@foo_impl_)

19
flang/test/Fir/fir-ops.fir
View File

@ -53,13 +53,20 @@ func @instructions() {
%6 = fir.embox %5 : (!fir.heap<!fir.array<100xf32>>) -> !fir.box<!fir.array<100xf32>>
// CHECK: [[VAL_7:%.*]] = fir.box_addr [[VAL_6]] : (!fir.box<!fir.array<100xf32>>) -> !fir.ref<!fir.array<100xf32>>
%7 = fir.box_addr %6 : (!fir.box<!fir.array<100xf32>>) -> !fir.ref<!fir.array<100xf32>>
// CHECK: %[[WAL_2:.*]] = fir.undefined !fir.boxproc<() -> ()>
%ba1 = fir.undefined !fir.boxproc<() -> ()>
// CHECK: %{{.*}} = fir.box_addr %[[WAL_2]] : (!fir.boxproc<() -> ()>) -> (() -> ())
%ba2 = fir.box_addr %ba1 : (!fir.boxproc<() -> ()>) -> (() -> ())
%ba3 = fir.undefined !fir.boxchar<1>
// CHECK: %{{.*}} = fir.box_addr %{{.*}} : (!fir.boxchar<1>) -> !fir.ref<!fir.char<1>>
%ba4 = fir.box_addr %ba3 : (!fir.boxchar<1>) -> !fir.ref<!fir.char<1>>
%c0 = arith.constant 0 : index
%d1:3 = fir.box_dims %6, %c0 : (!fir.box<!fir.array<100xf32>>, index) -> (index, index, index)
// CHECK: [[VAL_8:%.*]] = arith.constant 0 : index
// CHECK: [[VAL_9:%.*]]:3 = fir.box_dims [[VAL_6]], [[VAL_8]] : (!fir.box<!fir.array<100xf32>>, index) -> (index, index, index)
// CHECK: fir.call @print_index3([[VAL_9]]#0, [[VAL_9]]#1, [[VAL_9]]#2) : (index, index, index) -> ()
// CHECK: [[VAL_10:%.*]] = fir.call @it1() : () -> !fir.int<4>
%7 = fir.box_addr %6 : (!fir.box<!fir.array<100xf32>>) -> !fir.ref<!fir.array<100xf32>>
%c0 = arith.constant 0 : index
%d1:3 = fir.box_dims %6, %c0 : (!fir.box<!fir.array<100xf32>>, index) -> (index, index, index)
fir.call @print_index3(%d1#0, %d1#1, %d1#2) : (index, index, index) -> ()
%8 = fir.call @it1() : () -> !fir.int<4>
@ -154,7 +161,8 @@ func @boxing_match() {
// CHECK: [[VAL_53:%.*]] = arith.constant 4.213000e+01 : f64
// CHECK: [[VAL_54:%.*]] = fir.insert_value [[VAL_48]], [[VAL_53]], [1 : i32] : (!fir.type<qq2{f1:i32,f2:f64}>, f64) -> !fir.type<qq2{f1:i32,f2:f64}>
// CHECK: fir.store [[VAL_54]] to [[VAL_39]] : !fir.ref<!fir.type<qq2{f1:i32,f2:f64}>>
// CHECK: [[VAL_55:%.*]] = fir.emboxproc @method_impl, [[VAL_41]] : ((!fir.box<!fir.type<derived3{f:f32}>>) -> (), !fir.ref<tuple<i32, f64>>) -> !fir.boxproc<(!fir.box<!fir.type<derived3{f:f32}>>) -> ()>
// CHECK: %[[WAL_1:.*]] = fir.address_of(@method_impl)
// CHECK: [[VAL_55:%.*]] = fir.emboxproc %[[WAL_1]], [[VAL_41]] : ((!fir.box<!fir.type<derived3{f:f32}>>) -> (), !fir.ref<tuple<i32, f64>>) -> !fir.boxproc<(!fir.box<!fir.type<derived3{f:f32}>>) -> ()>
// CHECK: [[VAL_56:%.*]], [[VAL_57:%.*]] = fir.unboxproc [[VAL_55]] : (!fir.boxproc<(!fir.box<!fir.type<derived3{f:f32}>>) -> ()>) -> ((!fir.box<!fir.type<derived3{f:f32}>>) -> (), !fir.ref<tuple<!fir.type<qq2{f1:i32,f2:f64}>>>)
// CHECK: [[VAL_58:%.*]] = fir.call @box2() : () -> !fir.boxproc<(i32, i32) -> i64>
// CHECK: [[VAL_59:%.*]], [[VAL_60:%.*]] = fir.unboxproc [[VAL_58]] : (!fir.boxproc<(i32, i32) -> i64>) -> ((i32, i32) -> i64, !fir.ref<tuple<!fir.type<qq1{f1:i32}>>>)
@ -179,7 +187,8 @@ func @boxing_match() {
%c42 = arith.constant 42.13 : f64
%a3 = fir.insert_value %6, %c42, [1 : i32] : (!fir.type<qq2{f1:i32,f2:f64}>, f64) -> !fir.type<qq2{f1:i32,f2:f64}>
fir.store %a3 to %d6 : !fir.ref<!fir.type<qq2{f1:i32,f2:f64}>>
%7 = fir.emboxproc @method_impl, %e6 : ((!fir.box<!fir.type<derived3{f:f32}>>) -> (), !fir.ref<tuple<i32,f64>>) -> !fir.boxproc<(!fir.box<!fir.type<derived3{f:f32}>>) -> ()>
%mi = fir.address_of(@method_impl) : (!fir.box<!fir.type<derived3{f:f32}>>) -> ()
%7 = fir.emboxproc %mi, %e6 : ((!fir.box<!fir.type<derived3{f:f32}>>) -> (), !fir.ref<tuple<i32,f64>>) -> !fir.boxproc<(!fir.box<!fir.type<derived3{f:f32}>>) -> ()>
%8:2 = fir.unboxproc %7 : (!fir.boxproc<(!fir.box<!fir.type<derived3{f:f32}>>) -> ()>) -> ((!fir.box<!fir.type<derived3{f:f32}>>) -> (), !fir.ref<tuple<!fir.type<qq2{f1:i32,f2:f64}>>>)
%9 = fir.call @box2() : () -> !fir.boxproc<(i32, i32) -> i64>
%10:2 = fir.unboxproc %9 : (!fir.boxproc<(i32, i32) -> i64>) -> ((i32, i32) -> i64, !fir.ref<tuple<!fir.type<qq1{f1:i32}>>>)

177
flang/test/Lower/Intrinsics/len.f90
View File

@ -2,75 +2,108 @@
! CHECK-LABEL: len_test
subroutine len_test(i, c)
integer :: i
character(*) :: c
! CHECK: %[[c:.*]]:2 = fir.unboxchar %arg1
! CHECK: %[[xx:.*]] = fir.convert %[[c]]#1 : (index) -> i32
! CHECK: fir.store %[[xx]] to %arg0
i = len(c)
end subroutine
! CHECK-LABEL: len_test_array
! CHECK-SAME: %[[arg0:.*]]: !fir.ref<i32> {fir.bindc_name = "i"}, %[[arg1:.*]]: !fir.boxchar<1> {fir.bindc_name = "c"}
subroutine len_test_array(i, c)
integer :: i
character(*) :: c(100)
! CHECK: %[[c:.*]]:2 = fir.unboxchar %[[arg1]]
! CHECK: %[[xx:.*]] = fir.convert %[[c]]#1 : (index) -> i32
! CHECK: fir.store %[[xx]] to %[[arg0]]
i = len(c)
end subroutine
! CHECK-LABEL: func @_QPlen_test_assumed_shape_array(
! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref<i32> {fir.bindc_name = "i"},
! CHECK-SAME: %[[VAL_1:.*]]: !fir.box<!fir.array<?x!fir.char<1,?>>> {fir.bindc_name = "c"}) {
subroutine len_test_assumed_shape_array(i, c)
integer :: i
character(*) :: c(:)
! CHECK: %[[VAL_2:.*]] = fir.box_elesize %[[VAL_1]] : (!fir.box<!fir.array<?x!fir.char<1,?>>>) -> index
! CHECK: %[[VAL_3:.*]] = fir.convert %[[VAL_2]] : (index) -> i32
! CHECK: fir.store %[[VAL_3]] to %[[VAL_0]] : !fir.ref<i32>
i = len(c)
end subroutine
! CHECK-LABEL: func @_QPlen_test_array_alloc(
! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref<i32> {fir.bindc_name = "i"},
! CHECK-SAME: %[[VAL_1:.*]]: !fir.ref<!fir.box<!fir.heap<!fir.array<?x!fir.char<1,?>>>>> {fir.bindc_name = "c"}) {
subroutine len_test_array_alloc(i, c)
integer :: i
character(:), allocatable :: c(:)
! CHECK: %[[VAL_2:.*]] = fir.load %[[VAL_1]] : !fir.ref<!fir.box<!fir.heap<!fir.array<?x!fir.char<1,?>>>>>
! CHECK: %[[VAL_3:.*]] = fir.box_elesize %[[VAL_2]] : (!fir.box<!fir.heap<!fir.array<?x!fir.char<1,?>>>>) -> index
! CHECK: %[[VAL_4:.*]] = fir.convert %[[VAL_3]] : (index) -> i32
! CHECK: fir.store %[[VAL_4]] to %[[VAL_0]] : !fir.ref<i32>
i = len(c)
end subroutine
! CHECK-LABEL: func @_QPlen_test_array_local_alloc(
! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref<i32> {fir.bindc_name = "i"})
subroutine len_test_array_local_alloc(i)
integer :: i
character(:), allocatable :: c(:)
! CHECK: %[[VAL_5:.*]] = fir.alloca index {uniq_name = "_QFlen_test_array_local_allocEc.len"}
! CHECK: %[[VAL_7:.*]] = arith.constant 10 : i32
! CHECK: %[[VAL_10:.*]] = fir.convert %[[VAL_7]] : (i32) -> index
! CHECK: fir.store %[[VAL_10]] to %[[VAL_5]] : !fir.ref<index>
allocate(character(10):: c(100))
! CHECK: %[[VAL_13:.*]] = fir.load %[[VAL_5]] : !fir.ref<index>
! CHECK: %[[VAL_14:.*]] = fir.convert %[[VAL_13]] : (index) -> i32
! CHECK: fir.store %[[VAL_14]] to %[[VAL_0]] : !fir.ref<i32>
i = len(c)
end subroutine
! CHECK-LABEL: func @_QPlen_test_alloc_explicit_len(
! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref<i32> {fir.bindc_name = "i"},
! CHECK-SAME: %[[VAL_1:.*]]: !fir.ref<i32> {fir.bindc_name = "n"},
! CHECK-SAME: %[[VAL_2:.*]]: !fir.ref<!fir.box<!fir.heap<!fir.array<?x!fir.char<1,?>>>>> {fir.bindc_name = "c"}) {
subroutine len_test_alloc_explicit_len(i, n, c)
integer :: i
integer :: n
character(n), allocatable :: c(:)
! CHECK: %[[VAL_3:.*]] = fir.load %[[VAL_1]] : !fir.ref<i32>
! CHECK: fir.store %[[VAL_3]] to %[[VAL_0]] : !fir.ref<i32>
i = len(c)
end subroutine
integer :: i
character(*) :: c
! CHECK: %[[c:.*]]:2 = fir.unboxchar %arg1
! CHECK: %[[xx:.*]] = fir.convert %[[c]]#1 : (index) -> i32
! CHECK: fir.store %[[xx]] to %arg0
i = len(c)
end subroutine
! CHECK-LABEL: len_test_array
! CHECK-SAME: %[[arg0:.*]]: !fir.ref<i32> {fir.bindc_name = "i"}, %[[arg1:.*]]: !fir.boxchar<1> {fir.bindc_name = "c"}
subroutine len_test_array(i, c)
integer :: i
character(*) :: c(100)
! CHECK: %[[c:.*]]:2 = fir.unboxchar %[[arg1]]
! CHECK: %[[xx:.*]] = fir.convert %[[c]]#1 : (index) -> i32
! CHECK: fir.store %[[xx]] to %[[arg0]]
i = len(c)
end subroutine
! CHECK-LABEL: func @_QPlen_test_assumed_shape_array(
! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref<i32> {fir.bindc_name = "i"},
! CHECK-SAME: %[[VAL_1:.*]]: !fir.box<!fir.array<?x!fir.char<1,?>>> {fir.bindc_name = "c"}) {
subroutine len_test_assumed_shape_array(i, c)
integer :: i
character(*) :: c(:)
! CHECK: %[[VAL_2:.*]] = fir.box_elesize %[[VAL_1]] : (!fir.box<!fir.array<?x!fir.char<1,?>>>) -> index
! CHECK: %[[VAL_3:.*]] = fir.convert %[[VAL_2]] : (index) -> i32
! CHECK: fir.store %[[VAL_3]] to %[[VAL_0]] : !fir.ref<i32>
i = len(c)
end subroutine
! CHECK-LABEL: func @_QPlen_test_array_alloc(
! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref<i32> {fir.bindc_name = "i"},
! CHECK-SAME: %[[VAL_1:.*]]: !fir.ref<!fir.box<!fir.heap<!fir.array<?x!fir.char<1,?>>>>> {fir.bindc_name = "c"}) {
subroutine len_test_array_alloc(i, c)
integer :: i
character(:), allocatable :: c(:)
! CHECK: %[[VAL_2:.*]] = fir.load %[[VAL_1]] : !fir.ref<!fir.box<!fir.heap<!fir.array<?x!fir.char<1,?>>>>>
! CHECK: %[[VAL_3:.*]] = fir.box_elesize %[[VAL_2]] : (!fir.box<!fir.heap<!fir.array<?x!fir.char<1,?>>>>) -> index
! CHECK: %[[VAL_4:.*]] = fir.convert %[[VAL_3]] : (index) -> i32
! CHECK: fir.store %[[VAL_4]] to %[[VAL_0]] : !fir.ref<i32>
i = len(c)
end subroutine
! CHECK-LABEL: func @_QPlen_test_array_local_alloc(
! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref<i32> {fir.bindc_name = "i"})
subroutine len_test_array_local_alloc(i)
integer :: i
character(:), allocatable :: c(:)
! CHECK: %[[VAL_5:.*]] = fir.alloca index {uniq_name = "_QFlen_test_array_local_allocEc.len"}
! CHECK: %[[VAL_7:.*]] = arith.constant 10 : i32
! CHECK: %[[VAL_10:.*]] = fir.convert %[[VAL_7]] : (i32) -> index
! CHECK: fir.store %[[VAL_10]] to %[[VAL_5]] : !fir.ref<index>
allocate(character(10):: c(100))
! CHECK: %[[VAL_13:.*]] = fir.load %[[VAL_5]] : !fir.ref<index>
! CHECK: %[[VAL_14:.*]] = fir.convert %[[VAL_13]] : (index) -> i32
! CHECK: fir.store %[[VAL_14]] to %[[VAL_0]] : !fir.ref<i32>
i = len(c)
end subroutine
! CHECK-LABEL: func @_QPlen_test_alloc_explicit_len(
! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref<i32> {fir.bindc_name = "i"},
! CHECK-SAME: %[[VAL_1:.*]]: !fir.ref<i32> {fir.bindc_name = "n"},
! CHECK-SAME: %[[VAL_2:.*]]: !fir.ref<!fir.box<!fir.heap<!fir.array<?x!fir.char<1,?>>>>> {fir.bindc_name = "c"}) {
subroutine len_test_alloc_explicit_len(i, n, c)
integer :: i
integer :: n
character(n), allocatable :: c(:)
! CHECK: %[[VAL_3:.*]] = fir.load %[[VAL_1]] : !fir.ref<i32>
! CHECK: %[[c0_i32:.*]] = arith.constant 0 : i32
! CHECK: %[[cmp:.*]] = arith.cmpi sgt, %[[VAL_3]], %[[c0_i32]] : i32
! CHECK: %[[len:.*]] = arith.select %[[cmp]], %[[VAL_3]], %[[c0_i32]] : i32
! CHECK: fir.store %[[len]] to %[[VAL_0]] : !fir.ref<i32>
i = len(c)
end subroutine
! CHECK-LABEL: func @_QPlen_test_pointer_explicit_len(
! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref<i32> {fir.bindc_name = "i"},
! CHECK-SAME: %[[VAL_1:.*]]: !fir.ref<i32> {fir.bindc_name = "n"},
subroutine len_test_pointer_explicit_len(i, n, c)
integer :: i
integer :: n
character(n), pointer :: c(:)
! CHECK: %[[VAL_3:.*]] = fir.load %[[VAL_1]] : !fir.ref<i32>
! CHECK: %[[c0_i32:.*]] = arith.constant 0 : i32
! CHECK: %[[cmp:.*]] = arith.cmpi sgt, %[[VAL_3]], %[[c0_i32]] : i32
! CHECK: %[[len:.*]] = arith.select %[[cmp]], %[[VAL_3]], %[[c0_i32]] : i32
! CHECK: fir.store %[[len]] to %[[VAL_0]] : !fir.ref<i32>
i = len(c)
end subroutine
! CHECK-LABEL: func @_QPlen_test_assumed_shape_explicit_len(
! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref<i32> {fir.bindc_name = "i"},
! CHECK-SAME: %[[VAL_1:.*]]: !fir.ref<i32> {fir.bindc_name = "n"},
subroutine len_test_assumed_shape_explicit_len(i, n, c)
integer :: i
integer :: n
character(n) :: c(:)
! CHECK: %[[VAL_3:.*]] = fir.load %[[VAL_1]] : !fir.ref<i32>
! CHECK: %[[c0_i32:.*]] = arith.constant 0 : i32
! CHECK: %[[cmp:.*]] = arith.cmpi sgt, %[[VAL_3]], %[[c0_i32]] : i32
! CHECK: %[[len:.*]] = arith.select %[[cmp]], %[[VAL_3]], %[[c0_i32]] : i32
! CHECK: fir.store %[[len]] to %[[VAL_0]] : !fir.ref<i32>
i = len(c)
end subroutine

221
flang/test/Lower/allocatable-assignment.f90
View File

@ -2,6 +2,9 @@
! RUN: bbc -emit-fir %s -o - | FileCheck %s
module alloc_assign
type t
integer :: i
end type
contains
! -----------------------------------------------------------------------------
@ -174,7 +177,10 @@ end subroutine
subroutine test_dyn_char_scalar(x, n)
integer :: n
character(n), allocatable :: x
! CHECK: %[[VAL_2:.*]] = fir.load %[[VAL_1]] : !fir.ref<i32>
! CHECK: %[[VAL_2A:.*]] = fir.load %[[VAL_1]] : !fir.ref<i32>
! CHECK: %[[c0_i32:.*]] = arith.constant 0 : i32
! CHECK: %[[VAL_2B:.*]] = arith.cmpi sgt, %[[VAL_2A]], %[[c0_i32]] : i32
! CHECK: %[[VAL_2:.*]] = arith.select %[[VAL_2B]], %[[VAL_2A]], %[[c0_i32]] : i32
! CHECK: %[[VAL_3:.*]] = fir.address_of(@_QQcl.48656C6C6F20776F726C6421) : !fir.ref<!fir.char<1,12>>
! CHECK: %[[VAL_4:.*]] = arith.constant 12 : index
! CHECK: %[[VAL_5:.*]] = fir.load %[[VAL_0]] : !fir.ref<!fir.box<!fir.heap<!fir.char<1,?>>>>
@ -215,6 +221,46 @@ subroutine test_dyn_char_scalar(x, n)
x = "Hello world!"
end subroutine
! CHECK-LABEL: func @_QMalloc_assignPtest_derived_scalar(
! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref<!fir.box<!fir.heap<!fir.type<_QMalloc_assignTt{i:i32}>>>>{{.*}},
! CHECK-SAME: %[[VAL_1:.*]]: !fir.ref<!fir.type<_QMalloc_assignTt{i:i32}>>{{.*}}) {
subroutine test_derived_scalar(x, s)
type(t), allocatable :: x
type(t) :: s
x = s
! CHECK: %[[VAL_2:.*]] = fir.load %[[VAL_0]] : !fir.ref<!fir.box<!fir.heap<!fir.type<_QMalloc_assignTt{i:i32}>>>>
! CHECK: %[[VAL_3:.*]] = fir.box_addr %[[VAL_2]] : (!fir.box<!fir.heap<!fir.type<_QMalloc_assignTt{i:i32}>>>) -> !fir.heap<!fir.type<_QMalloc_assignTt{i:i32}>>
! CHECK: %[[VAL_4:.*]] = fir.convert %[[VAL_3]] : (!fir.heap<!fir.type<_QMalloc_assignTt{i:i32}>>) -> i64
! CHECK: %[[VAL_5:.*]] = arith.constant 0 : i64
! CHECK: %[[VAL_6:.*]] = arith.cmpi ne, %[[VAL_4]], %[[VAL_5]] : i64
! CHECK: %[[VAL_7:.*]]:2 = fir.if %[[VAL_6]] -> (i1, !fir.heap<!fir.type<_QMalloc_assignTt{i:i32}>>) {
! CHECK: %[[VAL_8:.*]] = arith.constant false
! CHECK: %[[VAL_9:.*]] = fir.if %[[VAL_8]] -> (!fir.heap<!fir.type<_QMalloc_assignTt{i:i32}>>) {
! CHECK: %[[VAL_10:.*]] = fir.allocmem !fir.type<_QMalloc_assignTt{i:i32}> {uniq_name = ".auto.alloc"}
! CHECK: fir.result %[[VAL_10]] : !fir.heap<!fir.type<_QMalloc_assignTt{i:i32}>>
! CHECK: } else {
! CHECK: fir.result %[[VAL_3]] : !fir.heap<!fir.type<_QMalloc_assignTt{i:i32}>>
! CHECK: }
! CHECK: fir.result %[[VAL_8]], %[[VAL_11:.*]] : i1, !fir.heap<!fir.type<_QMalloc_assignTt{i:i32}>>
! CHECK: } else {
! CHECK: %[[VAL_12:.*]] = arith.constant true
! CHECK: %[[VAL_13:.*]] = fir.allocmem !fir.type<_QMalloc_assignTt{i:i32}> {uniq_name = ".auto.alloc"}
! CHECK: fir.result %[[VAL_12]], %[[VAL_13]] : i1, !fir.heap<!fir.type<_QMalloc_assignTt{i:i32}>>
! CHECK: }
! CHECK: %[[VAL_14:.*]] = fir.field_index i, !fir.type<_QMalloc_assignTt{i:i32}>
! CHECK: %[[VAL_15:.*]] = fir.coordinate_of %[[VAL_1]], %[[VAL_14]] : (!fir.ref<!fir.type<_QMalloc_assignTt{i:i32}>>, !fir.field) -> !fir.ref<i32>
! CHECK: %[[VAL_16:.*]] = fir.coordinate_of %[[VAL_7]]#1, %[[VAL_14]] : (!fir.heap<!fir.type<_QMalloc_assignTt{i:i32}>>, !fir.field) -> !fir.ref<i32>
! CHECK: %[[VAL_17:.*]] = fir.load %[[VAL_15]] : !fir.ref<i32>
! CHECK: fir.store %[[VAL_17]] to %[[VAL_16]] : !fir.ref<i32
! CHECK: fir.if %[[VAL_7]]#0 {
! CHECK: fir.if %[[VAL_6]] {
! CHECK: fir.freemem %[[VAL_3]]
! CHECK: }
! CHECK: %[[VAL_19:.*]] = fir.embox %[[VAL_7]]#1 : (!fir.heap<!fir.type<_QMalloc_assignTt{i:i32}>>) -> !fir.box<!fir.heap<!fir.type<_QMalloc_assignTt{i:i32}>>>
! CHECK: fir.store %[[VAL_19]] to %[[VAL_0]] : !fir.ref<!fir.box<!fir.heap<!fir.type<_QMalloc_assignTt{i:i32}>>>>
! CHECK: }
end subroutine
! -----------------------------------------------------------------------------
! Test numeric/logical array RHS
! -----------------------------------------------------------------------------
@ -385,6 +431,76 @@ subroutine test_with_lbounds(x, y)
x = y
end subroutine
! CHECK-LABEL: func @_QMalloc_assignPtest_runtime_shape(
! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref<!fir.box<!fir.heap<!fir.array<?x?xf32>>>>{{.*}}) {
subroutine test_runtime_shape(x)
real, allocatable :: x(:, :)
interface
function return_pointer()
real, pointer :: return_pointer(:, :)
end function
end interface
! CHECK: %[[VAL_1:.*]] = fir.alloca !fir.box<!fir.ptr<!fir.array<?x?xf32>>> {bindc_name = ".result"}
! CHECK: %[[VAL_2:.*]] = fir.call @_QPreturn_pointer() : () -> !fir.box<!fir.ptr<!fir.array<?x?xf32>>>
! CHECK: fir.save_result %[[VAL_2]] to %[[VAL_1]] : !fir.box<!fir.ptr<!fir.array<?x?xf32>>>, !fir.ref<!fir.box<!fir.ptr<!fir.array<?x?xf32>>>>
! CHECK: %[[VAL_3:.*]] = fir.load %[[VAL_1]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?x?xf32>>>>
! CHECK: %[[VAL_4:.*]] = arith.constant 0 : index
! CHECK: %[[VAL_5:.*]]:3 = fir.box_dims %[[VAL_3]], %[[VAL_4]] : (!fir.box<!fir.ptr<!fir.array<?x?xf32>>>, index) -> (index, index, index)
! CHECK: %[[VAL_6:.*]] = arith.constant 1 : index
! CHECK: %[[VAL_7:.*]]:3 = fir.box_dims %[[VAL_3]], %[[VAL_6]] : (!fir.box<!fir.ptr<!fir.array<?x?xf32>>>, index) -> (index, index, index)
! CHECK: %[[VAL_8:.*]] = fir.shift %[[VAL_5]]#0, %[[VAL_7]]#0 : (index, index) -> !fir.shift<2>
! CHECK: %[[VAL_10:.*]] = arith.constant 0 : index
! CHECK: %[[VAL_11:.*]]:3 = fir.box_dims %[[VAL_3]], %[[VAL_10]] : (!fir.box<!fir.ptr<!fir.array<?x?xf32>>>, index) -> (index, index, index)
! CHECK: %[[VAL_12:.*]] = arith.constant 1 : index
! CHECK: %[[VAL_13:.*]]:3 = fir.box_dims %[[VAL_3]], %[[VAL_12]] : (!fir.box<!fir.ptr<!fir.array<?x?xf32>>>, index) -> (index, index, index)
! CHECK: %[[VAL_9:.*]] = fir.array_load %[[VAL_3]](%[[VAL_8]]) : (!fir.box<!fir.ptr<!fir.array<?x?xf32>>>, !fir.shift<2>) -> !fir.array<?x?xf32>
! CHECK: %[[VAL_14:.*]] = fir.load %[[VAL_0]] : !fir.ref<!fir.box<!fir.heap<!fir.array<?x?xf32>>>>
! CHECK: %[[VAL_15:.*]] = fir.box_addr %[[VAL_14]] : (!fir.box<!fir.heap<!fir.array<?x?xf32>>>) -> !fir.heap<!fir.array<?x?xf32>>
! CHECK: %[[VAL_16:.*]] = fir.convert %[[VAL_15]] : (!fir.heap<!fir.array<?x?xf32>>) -> i64
! CHECK: %[[VAL_17:.*]] = arith.constant 0 : i64
! CHECK: %[[VAL_18:.*]] = arith.cmpi ne, %[[VAL_16]], %[[VAL_17]] : i64
! CHECK: %[[VAL_19:.*]]:2 = fir.if %[[VAL_18]] -> (i1, !fir.heap<!fir.array<?x?xf32>>) {
! CHECK: %[[VAL_20:.*]] = arith.constant false
! CHECK: %[[VAL_21:.*]] = arith.constant 0 : index
! CHECK: %[[VAL_22:.*]]:3 = fir.box_dims %[[VAL_14]], %[[VAL_21]] : (!fir.box<!fir.heap<!fir.array<?x?xf32>>>, index) -> (index, index, index)
! CHECK: %[[VAL_23:.*]] = arith.constant 1 : index
! CHECK: %[[VAL_24:.*]]:3 = fir.box_dims %[[VAL_14]], %[[VAL_23]] : (!fir.box<!fir.heap<!fir.array<?x?xf32>>>, index) -> (index, index, index)
! CHECK: %[[VAL_25:.*]] = arith.cmpi ne, %[[VAL_22]]#1, %[[VAL_11]]#1 : index
! CHECK: %[[VAL_26:.*]] = arith.select %[[VAL_25]], %[[VAL_25]], %[[VAL_20]] : i1
! CHECK: %[[VAL_27:.*]] = arith.cmpi ne, %[[VAL_24]]#1, %[[VAL_13]]#1 : index
! CHECK: %[[VAL_28:.*]] = arith.select %[[VAL_27]], %[[VAL_27]], %[[VAL_26]] : i1
! CHECK: %[[VAL_29:.*]] = fir.if %[[VAL_28]] -> (!fir.heap<!fir.array<?x?xf32>>) {
! CHECK: %[[VAL_30:.*]] = fir.allocmem !fir.array<?x?xf32>, %[[VAL_11]]#1, %[[VAL_13]]#1 {uniq_name = ".auto.alloc"}
! CHECK: fir.result %[[VAL_30]] : !fir.heap<!fir.array<?x?xf32>>
! CHECK: } else {
! CHECK: fir.result %[[VAL_15]] : !fir.heap<!fir.array<?x?xf32>>
! CHECK: }
! CHECK: fir.result %[[VAL_28]], %[[VAL_31:.*]] : i1, !fir.heap<!fir.array<?x?xf32>>
! CHECK: } else {
! CHECK: %[[VAL_32:.*]] = arith.constant true
! CHECK: %[[VAL_33:.*]] = fir.allocmem !fir.array<?x?xf32>, %[[VAL_11]]#1, %[[VAL_13]]#1 {uniq_name = ".auto.alloc"}
! CHECK: fir.result %[[VAL_32]], %[[VAL_33]] : i1, !fir.heap<!fir.array<?x?xf32>>
! CHECK: }
! CHECK-NOT: fir.call @_QPreturn_pointer()
! CHECK: %[[VAL_34:.*]] = fir.shape %[[VAL_11]]#1, %[[VAL_13]]#1 : (index, index) -> !fir.shape<2>
! CHECK: %[[VAL_35:.*]] = fir.array_load %[[VAL_19]]#1(%[[VAL_34]]) : (!fir.heap<!fir.array<?x?xf32>>, !fir.shape<2>) -> !fir.array<?x?xf32>
! normal array assignment ....
! CHECK-NOT: fir.call @_QPreturn_pointer()
! CHECK: fir.array_merge_store %{{.*}}, %{{.*}} to %[[VAL_19]]#1 : !fir.array<?x?xf32>, !fir.array<?x?xf32>, !fir.heap<!fir.array<?x?xf32>>
! CHECK-NOT: fir.call @_QPreturn_pointer()
! CHECK: fir.if %[[VAL_19]]#0 {
! CHECK: fir.if %[[VAL_18]] {
! CHECK: fir.freemem %[[VAL_15]]
! CHECK: }
! CHECK: %[[VAL_56:.*]] = fir.shape %[[VAL_11]]#1, %[[VAL_13]]#1 : (index, index) -> !fir.shape<2>
! CHECK: %[[VAL_57:.*]] = fir.embox %[[VAL_19]]#1(%[[VAL_56]]) : (!fir.heap<!fir.array<?x?xf32>>, !fir.shape<2>) -> !fir.box<!fir.heap<!fir.array<?x?xf32>>>
! CHECK: fir.store %[[VAL_57]] to %[[VAL_0]] : !fir.ref<!fir.box<!fir.heap<!fir.array<?x?xf32>>>>
! CHECK: }
x = return_pointer()
end subroutine
! CHECK-LABEL: func @_QMalloc_assignPtest_scalar_rhs(
subroutine test_scalar_rhs(x, y)
real, allocatable :: x(:)
@ -405,6 +521,13 @@ end subroutine
! Test character array RHS
! -----------------------------------------------------------------------------
! Hit TODO: gathering lhs length in array expression
!subroutine test_deferred_char_rhs_scalar(x)
! character(:), allocatable :: x(:)
! x = "Hello world!"
!end subroutine
! CHECK: func @_QMalloc_assignPtest_cst_char_rhs_scalar(
subroutine test_cst_char_rhs_scalar(x)
character(10), allocatable :: x(:)
@ -413,7 +536,7 @@ subroutine test_cst_char_rhs_scalar(x)
! CHECK: fir.if %false -> {{.*}} {
! CHECK: }
! CHECK: } else {
! CHECK: fir.call @_FortranAReportFatalUserError
! TODO: runtime error if unallocated
! CHECK-NOT: allocmem
! CHECK: }
end subroutine
@ -427,11 +550,18 @@ subroutine test_dyn_char_rhs_scalar(x, n)
! CHECK: fir.if %false -> {{.*}} {
! CHECK: }
! CHECK: } else {
! CHECK: fir.call @_FortranAReportFatalUserError
! TODO: runtime error if unallocated
! CHECK-NOT: allocmem
! CHECK: }
end subroutine
! Hit TODO: gathering lhs length in array expression
!subroutine test_deferred_char(x, c)
! character(:), allocatable :: x(:)
! character(12) :: c(20)
! x = "Hello world!"
!end subroutine
! CHECK-LABEL: func @_QMalloc_assignPtest_cst_char(
! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref<!fir.box<!fir.heap<!fir.array<?x!fir.char<1,10>>>>>{{.*}},
! CHECK-SAME: %[[VAL_1:.*]]: !fir.boxchar<1>{{.*}}) {
@ -490,7 +620,10 @@ subroutine test_dyn_char(x, n, c)
! CHECK: %[[VAL_3:.*]]:2 = fir.unboxchar %[[VAL_2]] : (!fir.boxchar<1>) -> (!fir.ref<!fir.char<1,?>>, index)
! CHECK: %[[VAL_4:.*]] = fir.convert %[[VAL_3]]#0 : (!fir.ref<!fir.char<1,?>>) -> !fir.ref<!fir.array<20x!fir.char<1,?>>>
! CHECK: %[[VAL_5_0:.*]] = arith.constant 20 : index
! CHECK: %[[VAL_6:.*]] = fir.load %[[VAL_1]] : !fir.ref<i32>
! CHECK: %[[VAL_6A:.*]] = fir.load %[[VAL_1]] : !fir.ref<i32>
! CHECK: %[[c0_i32:.*]] = arith.constant 0 : i32
! CHECK: %[[VAL_6B:.*]] = arith.cmpi sgt, %[[VAL_6A]], %[[c0_i32]] : i32
! CHECK: %[[VAL_6:.*]] = arith.select %[[VAL_6B]], %[[VAL_6A]], %[[c0_i32]] : i32
! CHECK: %[[VAL_5:.*]] = arith.constant 20 : index
! CHECK: %[[VAL_7:.*]] = fir.shape %[[VAL_5_0]] : (index) -> !fir.shape<1>
! CHECK: %[[VAL_9:.*]] = fir.load %[[VAL_0]] : !fir.ref<!fir.box<!fir.heap<!fir.array<?x!fir.char<1,?>>>>>
@ -536,4 +669,84 @@ subroutine test_dyn_char(x, n, c)
x = c
end subroutine
! CHECK-LABEL: func @_QMalloc_assignPtest_derived_with_init
subroutine test_derived_with_init(x, y)
type t
integer, allocatable :: a(:)
end type
type(t), allocatable :: x
type(t) :: y
! The allocatable component of `x` need to be initialized
! during the automatic allocation (setting its rank and allocation
! status) before it is assigned with the component of `y`
x = y
! CHECK: fir.if %{{.*}} {
! CHECK: %[[VAL_11:.*]] = fir.allocmem !fir.type<_QMalloc_assignFtest_derived_with_initTt{a:!fir.box<!fir.heap<!fir.array<?xi32>>>}> {uniq_name = ".auto.alloc"}
! CHECK: %[[VAL_12:.*]] = fir.embox %[[VAL_11]] : (!fir.heap<!fir.type<_QMalloc_assignFtest_derived_with_initTt{a:!fir.box<!fir.heap<!fir.array<?xi32>>>}>>) -> !fir.box<!fir.heap<!fir.type<_QMalloc_assignFtest_derived_with_initTt{a:!fir.box<!fir.heap<!fir.array<?xi32>>>}>>>
! CHECK: %[[VAL_15:.*]] = fir.convert %[[VAL_12]] : (!fir.box<!fir.heap<!fir.type<_QMalloc_assignFtest_derived_with_initTt{a:!fir.box<!fir.heap<!fir.array<?xi32>>>}>>>) -> !fir.box<none>
! CHECK: fir.call @_FortranAInitialize(%[[VAL_15]], %{{.*}}, %{{.*}}) : (!fir.box<none>, !fir.ref<i8>, i32) -> none
! CHECK: fir.result %[[VAL_11]] : !fir.heap<!fir.type<_QMalloc_assignFtest_derived_with_initTt{a:!fir.box<!fir.heap<!fir.array<?xi32>>>}>>
! CHECK: } else {
! CHECK: fir.result %{{.*}} : !fir.heap<!fir.type<_QMalloc_assignFtest_derived_with_initTt{a:!fir.box<!fir.heap<!fir.array<?xi32>>>}>>
! CHECK: }
end subroutine
! CHECK-LABEL: func @_QMalloc_assignPtest_vector_subscript(
! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref<!fir.box<!fir.heap<!fir.array<?xi32>>>> {fir.bindc_name = "x"},
! CHECK-SAME: %[[VAL_1:.*]]: !fir.box<!fir.array<?xi32>> {fir.bindc_name = "y"},
! CHECK-SAME: %[[VAL_2:.*]]: !fir.box<!fir.array<?xi32>> {fir.bindc_name = "v"}) {
subroutine test_vector_subscript(x, y, v)
! Test that the new shape is computed correctly in presence of
! vector subscripts on the RHS and that it is used to allocate
! the new storage and to drive the implicit loop.
integer, allocatable :: x(:)
integer :: y(:), v(:)
x = y(v)
! CHECK: %[[VAL_3:.*]] = arith.constant 1 : index
! CHECK: %[[VAL_4:.*]] = arith.constant 0 : index
! CHECK: %[[VAL_5:.*]]:3 = fir.box_dims %[[VAL_1]], %[[VAL_4]] : (!fir.box<!fir.array<?xi32>>, index) -> (index, index, index)
! CHECK: %[[VAL_6:.*]] = arith.constant 0 : index
! CHECK: %[[VAL_7:.*]]:3 = fir.box_dims %[[VAL_2]], %[[VAL_6]] : (!fir.box<!fir.array<?xi32>>, index) -> (index, index, index)
! CHECK: %[[VAL_8:.*]] = fir.array_load %[[VAL_2]] : (!fir.box<!fir.array<?xi32>>) -> !fir.array<?xi32>
! CHECK: %[[VAL_9:.*]] = arith.cmpi sgt, %[[VAL_7]]#1, %[[VAL_5]]#1 : index
! CHECK: %[[VAL_10:.*]] = arith.select %[[VAL_9]], %[[VAL_5]]#1, %[[VAL_7]]#1 : index
! CHECK: fir.if {{.*}} {
! CHECK: %[[VAL_18:.*]] = arith.constant false
! CHECK: %[[VAL_20:.*]]:3 = fir.box_dims %{{.*}}, %{{.*}} : (!fir.box<!fir.heap<!fir.array<?xi32>>>, index) -> (index, index, index)
! CHECK: %[[VAL_21:.*]] = arith.cmpi ne, %[[VAL_20]]#1, %[[VAL_10]] : index
! CHECK: %[[VAL_22:.*]] = arith.select %[[VAL_21]], %[[VAL_21]], %[[VAL_18]] : i1
! CHECK: fir.if %[[VAL_22]] {{.*}} {
! CHECK: %[[VAL_24:.*]] = fir.allocmem !fir.array<?xi32>, %[[VAL_10]] {uniq_name = ".auto.alloc"}
! CHECK: fir.result %[[VAL_24]] : !fir.heap<!fir.array<?xi32>>
! CHECK: } else {
! CHECK: fir.result %{{.*}} : !fir.heap<!fir.array<?xi32>>
! CHECK: }
! CHECK: fir.result %{{.*}}, %{{.*}}
! CHECK: } else {
! CHECK: %[[VAL_27:.*]] = fir.allocmem !fir.array<?xi32>, %[[VAL_10]] {uniq_name = ".auto.alloc"}
! CHECK: fir.result %{{.*}}, %[[VAL_27]] : i1, !fir.heap<!fir.array<?xi32>>
! CHECK: }
! CHECK: %[[VAL_28:.*]] = fir.shape %[[VAL_10]] : (index) -> !fir.shape<1>
! CHECK: %[[VAL_29:.*]] = fir.array_load %[[VAL_30:.*]]#1(%[[VAL_28]]) : (!fir.heap<!fir.array<?xi32>>, !fir.shape<1>) -> !fir.array<?xi32>
! CHECK: %[[VAL_31:.*]] = arith.constant 1 : index
! CHECK: %[[VAL_32:.*]] = arith.constant 0 : index
! CHECK: %[[VAL_33:.*]] = arith.subi %[[VAL_10]], %[[VAL_31]] : index
! CHECK: %[[VAL_34:.*]] = fir.do_loop %[[VAL_35:.*]] = %[[VAL_32]] to %[[VAL_33]] step %[[VAL_31]] {{.*}} {
! CHECK: }
end subroutine
! CHECK: fir.global linkonce @[[error_message]] constant : !fir.char<1,76> {
! CHECK: %[[msg:.*]] = fir.string_lit "array left hand side must be allocated when the right hand side is a scalar\00"(76) : !fir.char<1,76>
! CHECK: fir.has_value %[[msg:.*]] : !fir.char<1,76>
! CHECK: }
end module
! use alloc_assign
! real :: y(2, 3) = reshape([1,2,3,4,5,6], [2,3])
! real, allocatable :: x (:, :)
! allocate(x(2,2))
! call test_with_lbounds(x, y)
! print *, x(10, 20)
! print *, x
!end

10
flang/test/Lower/allocatable-callee.f90
View File

@ -59,7 +59,10 @@ subroutine test_char_scalar_explicit_dynamic(c, n)
character(n), allocatable :: c
external foo1
! Check that the length expr was evaluated before the execution parts.
! CHECK: %[[len:.*]] = fir.load %arg1 : !fir.ref<i32>
! CHECK: %[[raw_len:.*]] = fir.load %arg1 : !fir.ref<i32>
! CHECK: %[[c0_i32:.*]] = arith.constant 0 : i32
! CHECK: %[[cmp:.*]] = arith.cmpi sgt, %[[raw_len]], %[[c0_i32]] : i32
! CHECK: %[[len:.*]] = arith.select %[[cmp]], %[[raw_len]], %[[c0_i32]] : i32
n = n + 1
! CHECK: fir.store {{.*}} to %arg1 : !fir.ref<i32>
call foo1(c)
@ -106,7 +109,10 @@ subroutine test_char_array_explicit_dynamic(c, n)
character(n), allocatable :: c(:)
external foo1
! Check that the length expr was evaluated before the execution parts.
! CHECK: %[[len:.*]] = fir.load %arg1 : !fir.ref<i32>
! CHECK: %[[raw_len:.*]] = fir.load %arg1 : !fir.ref<i32>
! CHECK: %[[c0_i32:.*]] = arith.constant 0 : i32
! CHECK: %[[cmp:.*]] = arith.cmpi sgt, %[[raw_len]], %[[c0_i32]] : i32
! CHECK: %[[len:.*]] = arith.select %[[cmp]], %[[raw_len]], %[[c0_i32]] : i32
n = n + 1
! CHECK: fir.store {{.*}} to %arg1 : !fir.ref<i32>
call foo1(c(1))

314
flang/test/Lower/allocatable-runtime.f90
View File

@ -3,157 +3,163 @@
! Test lowering of allocatables using runtime for allocate/deallcoate statements.
! CHECK-LABEL: _QPfoo
subroutine foo()
real, allocatable :: x(:), y(:, :), z
! CHECK: %[[xBoxAddr:.*]] = fir.alloca !fir.box<!fir.heap<!fir.array<?xf32>>> {{{.*}}uniq_name = "_QFfooEx"}
! CHECK-DAG: %[[xNullAddr:.*]] = fir.zero_bits !fir.heap<!fir.array<?xf32>>
! CHECK-DAG: %[[xNullShape:.*]] = fir.shape %c0{{.*}} : (index) -> !fir.shape<1>
! CHECK: %[[xInitEmbox:.*]] = fir.embox %[[xNullAddr]](%[[xNullShape]]) : (!fir.heap<!fir.array<?xf32>>, !fir.shape<1>) -> !fir.box<!fir.heap<!fir.array<?xf32>>>
! CHECK: fir.store %[[xInitEmbox]] to %[[xBoxAddr]] : !fir.ref<!fir.box<!fir.heap<!fir.array<?xf32>>>>
! CHECK: %[[yBoxAddr:.*]] = fir.alloca !fir.box<!fir.heap<!fir.array<?x?xf32>>> {{{.*}}uniq_name = "_QFfooEy"}
! CHECK-DAG: %[[yNullAddr:.*]] = fir.zero_bits !fir.heap<!fir.array<?x?xf32>>
! CHECK-DAG: %[[yNullShape:.*]] = fir.shape %c0{{.*}}, %c0{{.*}} : (index, index) -> !fir.shape<2>
! CHECK: %[[yInitEmbox:.*]] = fir.embox %[[yNullAddr]](%[[yNullShape]]) : (!fir.heap<!fir.array<?x?xf32>>, !fir.shape<2>) -> !fir.box<!fir.heap<!fir.array<?x?xf32>>>
! CHECK: fir.store %[[yInitEmbox]] to %[[yBoxAddr]] : !fir.ref<!fir.box<!fir.heap<!fir.array<?x?xf32>>>>
! CHECK: %[[zBoxAddr:.*]] = fir.alloca !fir.box<!fir.heap<f32>> {{{.*}}uniq_name = "_QFfooEz"}
! CHECK: %[[zNullAddr:.*]] = fir.zero_bits !fir.heap<f32>
! CHECK: %[[zInitEmbox:.*]] = fir.embox %[[zNullAddr]] : (!fir.heap<f32>) -> !fir.box<!fir.heap<f32>>
! CHECK: fir.store %[[zInitEmbox]] to %[[zBoxAddr]] : !fir.ref<!fir.box<!fir.heap<f32>>>
allocate(x(42:100), y(43:50, 51), z)
! CHECK-DAG: %[[errMsg:.*]] = fir.absent !fir.box<none>
! CHECK-DAG: %[[xlb:.*]] = arith.constant 42 : i32
! CHECK-DAG: %[[xub:.*]] = arith.constant 100 : i32
! CHECK-DAG: %[[xBoxCast2:.*]] = fir.convert %[[xBoxAddr]] : (!fir.ref<!fir.box<!fir.heap<!fir.array<?xf32>>>>) -> !fir.ref<!fir.box<none>>
! CHECK-DAG: %[[xlbCast:.*]] = fir.convert %[[xlb]] : (i32) -> i64
! CHECK-DAG: %[[xubCast:.*]] = fir.convert %[[xub]] : (i32) -> i64
! CHECK: fir.call @{{.*}}AllocatableSetBounds(%[[xBoxCast2]], %c0{{.*}}, %[[xlbCast]], %[[xubCast]]) : (!fir.ref<!fir.box<none>>, i32, i64, i64) -> none
! CHECK-DAG: %[[xBoxCast3:.*]] = fir.convert %[[xBoxAddr]] : (!fir.ref<!fir.box<!fir.heap<!fir.array<?xf32>>>>) -> !fir.ref<!fir.box<none>>
! CHECK-DAG: %[[sourceFile:.*]] = fir.convert %{{.*}} -> !fir.ref<i8>
! CHECK: fir.call @{{.*}}AllocatableAllocate(%[[xBoxCast3]], %false{{.*}}, %[[errMsg]], %[[sourceFile]], %{{.*}}) : (!fir.ref<!fir.box<none>>, i1, !fir.box<none>, !fir.ref<i8>, i32) -> i32
! Simply check that we are emitting the right numebr of set bound for y and z. Otherwise, this is just like x.
! CHECK: fir.convert %[[yBoxAddr]] : (!fir.ref<!fir.box<!fir.heap<!fir.array<?x?xf32>>>>) -> !fir.ref<!fir.box<none>>
! CHECK: fir.call @{{.*}}AllocatableSetBounds
! CHECK: fir.call @{{.*}}AllocatableSetBounds
! CHECK: fir.call @{{.*}}AllocatableAllocate
! CHECK: %[[zBoxCast:.*]] = fir.convert %[[zBoxAddr]] : (!fir.ref<!fir.box<!fir.heap<f32>>>) -> !fir.ref<!fir.box<none>>
! CHECK-NOT: fir.call @{{.*}}AllocatableSetBounds
! CHECK: fir.call @{{.*}}AllocatableAllocate
! Check that y descriptor is read when referencing it.
! CHECK: %[[yBoxLoad:.*]] = fir.load %[[yBoxAddr]] : !fir.ref<!fir.box<!fir.heap<!fir.array<?x?xf32>>>>
! CHECK: %[[yBounds1:.*]]:3 = fir.box_dims %[[yBoxLoad]], %c0{{.*}} : (!fir.box<!fir.heap<!fir.array<?x?xf32>>>, index) -> (index, index, index)
! CHECK: %[[yBounds2:.*]]:3 = fir.box_dims %[[yBoxLoad]], %c1{{.*}} : (!fir.box<!fir.heap<!fir.array<?x?xf32>>>, index) -> (index, index, index)
! CHECK: %[[yAddr:.*]] = fir.box_addr %[[yBoxLoad]] : (!fir.box<!fir.heap<!fir.array<?x?xf32>>>) -> !fir.heap<!fir.array<?x?xf32>>
print *, x, y(45, 46), z
deallocate(x, y, z)
! CHECK: %[[xBoxCast4:.*]] = fir.convert %[[xBoxAddr]] : (!fir.ref<!fir.box<!fir.heap<!fir.array<?xf32>>>>) -> !fir.ref<!fir.box<none>>
! CHECK: fir.call @{{.*}}AllocatableDeallocate(%[[xBoxCast4]], {{.*}})
! CHECK: %[[yBoxCast4:.*]] = fir.convert %[[yBoxAddr]] : (!fir.ref<!fir.box<!fir.heap<!fir.array<?x?xf32>>>>) -> !fir.ref<!fir.box<none>>
! CHECK: fir.call @{{.*}}AllocatableDeallocate(%[[yBoxCast4]], {{.*}})
! CHECK: %[[zBoxCast4:.*]] = fir.convert %[[zBoxAddr]] : (!fir.ref<!fir.box<!fir.heap<f32>>>) -> !fir.ref<!fir.box<none>>
! CHECK: fir.call @{{.*}}AllocatableDeallocate(%[[zBoxCast4]], {{.*}})
end subroutine
! test lowering of character allocatables
! CHECK-LABEL: _QPchar_deferred(
subroutine char_deferred(n)
integer :: n
character(:), allocatable :: scalar, array(:)
! CHECK-DAG: %[[sBoxAddr:.*]] = fir.alloca !fir.box<!fir.heap<!fir.char<1,?>>> {{{.*}}uniq_name = "_QFchar_deferredEscalar"}
! CHECK-DAG: %[[sNullAddr:.*]] = fir.zero_bits !fir.heap<!fir.char<1,?>>
! CHECK-DAG: %[[sInitBox:.*]] = fir.embox %[[sNullAddr]] typeparams %c0{{.*}} : (!fir.heap<!fir.char<1,?>>, index) -> !fir.box<!fir.heap<!fir.char<1,?>>>
! CHECK-DAG: fir.store %[[sInitBox]] to %[[sBoxAddr]] : !fir.ref<!fir.box<!fir.heap<!fir.char<1,?>>>>
! CHECK-DAG: %[[aBoxAddr:.*]] = fir.alloca !fir.box<!fir.heap<!fir.array<?x!fir.char<1,?>>>> {{{.*}}uniq_name = "_QFchar_deferredEarray"}
! CHECK-DAG: %[[aNullAddr:.*]] = fir.zero_bits !fir.heap<!fir.array<?x!fir.char<1,?>>>
! CHECK-DAG: %[[aNullShape:.*]] = fir.shape %c0{{.*}} : (index) -> !fir.shape<1>
! CHECK-DAG: %[[aInitBox:.*]] = fir.embox %[[aNullAddr]](%[[aNullShape]]) typeparams %c0{{.*}} : (!fir.heap<!fir.array<?x!fir.char<1,?>>>, !fir.shape<1>, index) -> !fir.box<!fir.heap<!fir.array<?x!fir.char<1,?>>>>
! CHECK-DAG: fir.store %[[aInitBox]] to %[[aBoxAddr]] : !fir.ref<!fir.box<!fir.heap<!fir.array<?x!fir.char<1,?>>>>>
allocate(character(10):: scalar, array(30))
! CHECK-DAG: %[[sBoxCast1:.*]] = fir.convert %[[sBoxAddr]] : (!fir.ref<!fir.box<!fir.heap<!fir.char<1,?>>>>) -> !fir.ref<!fir.box<none>>
! CHECK-DAG: %[[ten1:.*]] = fir.convert %c10{{.*}} : (i32) -> i64
! CHECK: fir.call @{{.*}}AllocatableInitCharacter(%[[sBoxCast1]], %[[ten1]], %c1{{.*}}, %c0{{.*}}, %c0{{.*}})
! CHECK-NOT: AllocatableSetBounds
! CHECK: %[[sBoxCast2:.*]] = fir.convert %[[sBoxAddr]] : (!fir.ref<!fir.box<!fir.heap<!fir.char<1,?>>>>) -> !fir.ref<!fir.box<none>>
! CHECK: fir.call @{{.*}}AllocatableAllocate(%[[sBoxCast2]]
! CHECK-DAG: %[[aBoxCast1:.*]] = fir.convert %[[aBoxAddr]] : (!fir.ref<!fir.box<!fir.heap<!fir.array<?x!fir.char<1,?>>>>>) -> !fir.ref<!fir.box<none>>
! CHECK-DAG: %[[ten2:.*]] = fir.convert %c10{{.*}} : (i32) -> i64
! CHECK: fir.call @{{.*}}AllocatableInitCharacter(%[[aBoxCast1]], %[[ten2]], %c1{{.*}}, %c1{{.*}}, %c0{{.*}})
! CHECK: %[[aBoxCast2:.*]] = fir.convert %[[aBoxAddr]] : (!fir.ref<!fir.box<!fir.heap<!fir.array<?x!fir.char<1,?>>>>>) -> !fir.ref<!fir.box<none>>
! CHECK: fir.call @{{.*}}AllocatableSetBounds(%[[aBoxCast2]]
! CHECK: %[[aBoxCast3:.*]] = fir.convert %[[aBoxAddr]] : (!fir.ref<!fir.box<!fir.heap<!fir.array<?x!fir.char<1,?>>>>>) -> !fir.ref<!fir.box<none>>
! CHECK: fir.call @{{.*}}AllocatableAllocate(%[[aBoxCast3]]
deallocate(scalar, array)
! CHECK: %[[sBoxCast3:.*]] = fir.convert %[[sBoxAddr]] : (!fir.ref<!fir.box<!fir.heap<!fir.char<1,?>>>>) -> !fir.ref<!fir.box<none>>
! CHECK: fir.call @{{.*}}AllocatableDeallocate(%[[sBoxCast3]]
! CHECK: %[[aBoxCast4:.*]] = fir.convert %[[aBoxAddr]] : (!fir.ref<!fir.box<!fir.heap<!fir.array<?x!fir.char<1,?>>>>>) -> !fir.ref<!fir.box<none>>
! CHECK: fir.call @{{.*}}AllocatableDeallocate(%[[aBoxCast4]]
! only testing that the correct length is set in the descriptor.
allocate(character(n):: scalar, array(40))
! CHECK: %[[n:.*]] = fir.load %arg0 : !fir.ref<i32>
! CHECK-DAG: %[[ncast1:.*]] = fir.convert %[[n]] : (i32) -> i64
! CHECK-DAG: %[[sBoxCast4:.*]] = fir.convert %[[sBoxAddr]] : (!fir.ref<!fir.box<!fir.heap<!fir.char<1,?>>>>) -> !fir.ref<!fir.box<none>>
! CHECK: fir.call @{{.*}}AllocatableInitCharacter(%[[sBoxCast4]], %[[ncast1]], %c1{{.*}}, %c0{{.*}}, %c0{{.*}})
! CHECK-DAG: %[[ncast2:.*]] = fir.convert %[[n]] : (i32) -> i64
! CHECK-DAG: %[[aBoxCast5:.*]] = fir.convert %[[aBoxAddr]] : (!fir.ref<!fir.box<!fir.heap<!fir.array<?x!fir.char<1,?>>>>>) -> !fir.ref<!fir.box<none>>
! CHECK: fir.call @{{.*}}AllocatableInitCharacter(%[[aBoxCast5]], %[[ncast2]], %c1{{.*}}, %c1{{.*}}, %c0{{.*}})
end subroutine
! CHECK-LABEL: _QPchar_explicit_cst(
subroutine char_explicit_cst(n)
integer :: n
character(10), allocatable :: scalar, array(:)
! CHECK-DAG: %[[sBoxAddr:.*]] = fir.alloca !fir.box<!fir.heap<!fir.char<1,10>>> {{{.*}}uniq_name = "_QFchar_explicit_cstEscalar"}
! CHECK-DAG: %[[sNullAddr:.*]] = fir.zero_bits !fir.heap<!fir.char<1,10>>
! CHECK-DAG: %[[sInitBox:.*]] = fir.embox %[[sNullAddr]] : (!fir.heap<!fir.char<1,10>>) -> !fir.box<!fir.heap<!fir.char<1,10>>>
! CHECK-DAG: fir.store %[[sInitBox]] to %[[sBoxAddr]] : !fir.ref<!fir.box<!fir.heap<!fir.char<1,10>>>>
! CHECK-DAG: %[[aBoxAddr:.*]] = fir.alloca !fir.box<!fir.heap<!fir.array<?x!fir.char<1,10>>>> {{{.*}}uniq_name = "_QFchar_explicit_cstEarray"}
! CHECK-DAG: %[[aNullAddr:.*]] = fir.zero_bits !fir.heap<!fir.array<?x!fir.char<1,10>>>
! CHECK-DAG: %[[aNullShape:.*]] = fir.shape %c0{{.*}} : (index) -> !fir.shape<1>
! CHECK-DAG: %[[aInitBox:.*]] = fir.embox %[[aNullAddr]](%[[aNullShape]]) : (!fir.heap<!fir.array<?x!fir.char<1,10>>>, !fir.shape<1>) -> !fir.box<!fir.heap<!fir.array<?x!fir.char<1,10>>>>
! CHECK-DAG: fir.store %[[aInitBox]] to %[[aBoxAddr]] : !fir.ref<!fir.box<!fir.heap<!fir.array<?x!fir.char<1,10>>>>>
allocate(scalar, array(20))
! CHECK-NOT: AllocatableInitCharacter
! CHECK: AllocatableAllocate
! CHECK-NOT: AllocatableInitCharacter
! CHECK: AllocatableAllocate
deallocate(scalar, array)
! CHECK: AllocatableDeallocate
! CHECK: AllocatableDeallocate
end subroutine
! CHECK-LABEL: _QPchar_explicit_dyn(
subroutine char_explicit_dyn(n, l1, l2)
integer :: n, l1, l2
character(l1), allocatable :: scalar
! CHECK-DAG: %[[l1:.*]] = fir.load %arg1 : !fir.ref<i32>
! CHECK-DAG: %[[sBoxAddr:.*]] = fir.alloca !fir.box<!fir.heap<!fir.char<1,?>>> {{{.*}}uniq_name = "_QFchar_explicit_dynEscalar"}
! CHECK-DAG: %[[sNullAddr:.*]] = fir.zero_bits !fir.heap<!fir.char<1,?>>
! CHECK-DAG: %[[sInitBox:.*]] = fir.embox %[[sNullAddr]] typeparams %[[l1]] : (!fir.heap<!fir.char<1,?>>, i32) -> !fir.box<!fir.heap<!fir.char<1,?>>>
! CHECK-DAG: fir.store %[[sInitBox]] to %[[sBoxAddr]] : !fir.ref<!fir.box<!fir.heap<!fir.char<1,?>>>>
character(l2), allocatable :: array(:)
! CHECK-DAG: %[[l2:.*]] = fir.load %arg2 : !fir.ref<i32>
! CHECK-DAG: %[[aBoxAddr:.*]] = fir.alloca !fir.box<!fir.heap<!fir.array<?x!fir.char<1,?>>>> {{{.*}}uniq_name = "_QFchar_explicit_dynEarray"}
! CHECK-DAG: %[[aNullAddr:.*]] = fir.zero_bits !fir.heap<!fir.array<?x!fir.char<1,?>>>
! CHECK-DAG: %[[aNullShape:.*]] = fir.shape %c0{{.*}} : (index) -> !fir.shape<1>
! CHECK-DAG: %[[aInitBox:.*]] = fir.embox %[[aNullAddr]](%[[aNullShape]]) typeparams %[[l2]] : (!fir.heap<!fir.array<?x!fir.char<1,?>>>, !fir.shape<1>, i32) -> !fir.box<!fir.heap<!fir.array<?x!fir.char<1,?>>>>
! CHECK-DAG: fir.store %[[aInitBox]] to %[[aBoxAddr]] : !fir.ref<!fir.box<!fir.heap<!fir.array<?x!fir.char<1,?>>>>>
allocate(scalar, array(20))
! CHECK-NOT: AllocatableInitCharacter
! CHECK: AllocatableAllocate
! CHECK-NOT: AllocatableInitCharacter
! CHECK: AllocatableAllocate
deallocate(scalar, array)
! CHECK: AllocatableDeallocate
! CHECK: AllocatableDeallocate
end subroutine
real, allocatable :: x(:), y(:, :), z
! CHECK: %[[xBoxAddr:.*]] = fir.alloca !fir.box<!fir.heap<!fir.array<?xf32>>> {{{.*}}uniq_name = "_QFfooEx"}
! CHECK-DAG: %[[xNullAddr:.*]] = fir.zero_bits !fir.heap<!fir.array<?xf32>>
! CHECK-DAG: %[[xNullShape:.*]] = fir.shape %c0{{.*}} : (index) -> !fir.shape<1>
! CHECK: %[[xInitEmbox:.*]] = fir.embox %[[xNullAddr]](%[[xNullShape]]) : (!fir.heap<!fir.array<?xf32>>, !fir.shape<1>) -> !fir.box<!fir.heap<!fir.array<?xf32>>>
! CHECK: fir.store %[[xInitEmbox]] to %[[xBoxAddr]] : !fir.ref<!fir.box<!fir.heap<!fir.array<?xf32>>>>
! CHECK: %[[yBoxAddr:.*]] = fir.alloca !fir.box<!fir.heap<!fir.array<?x?xf32>>> {{{.*}}uniq_name = "_QFfooEy"}
! CHECK-DAG: %[[yNullAddr:.*]] = fir.zero_bits !fir.heap<!fir.array<?x?xf32>>
! CHECK-DAG: %[[yNullShape:.*]] = fir.shape %c0{{.*}}, %c0{{.*}} : (index, index) -> !fir.shape<2>
! CHECK: %[[yInitEmbox:.*]] = fir.embox %[[yNullAddr]](%[[yNullShape]]) : (!fir.heap<!fir.array<?x?xf32>>, !fir.shape<2>) -> !fir.box<!fir.heap<!fir.array<?x?xf32>>>
! CHECK: fir.store %[[yInitEmbox]] to %[[yBoxAddr]] : !fir.ref<!fir.box<!fir.heap<!fir.array<?x?xf32>>>>
! CHECK: %[[zBoxAddr:.*]] = fir.alloca !fir.box<!fir.heap<f32>> {{{.*}}uniq_name = "_QFfooEz"}
! CHECK: %[[zNullAddr:.*]] = fir.zero_bits !fir.heap<f32>
! CHECK: %[[zInitEmbox:.*]] = fir.embox %[[zNullAddr]] : (!fir.heap<f32>) -> !fir.box<!fir.heap<f32>>
! CHECK: fir.store %[[zInitEmbox]] to %[[zBoxAddr]] : !fir.ref<!fir.box<!fir.heap<f32>>>
allocate(x(42:100), y(43:50, 51), z)
! CHECK-DAG: %[[errMsg:.*]] = fir.absent !fir.box<none>
! CHECK-DAG: %[[xlb:.*]] = arith.constant 42 : i32
! CHECK-DAG: %[[xub:.*]] = arith.constant 100 : i32
! CHECK-DAG: %[[xBoxCast2:.*]] = fir.convert %[[xBoxAddr]] : (!fir.ref<!fir.box<!fir.heap<!fir.array<?xf32>>>>) -> !fir.ref<!fir.box<none>>
! CHECK-DAG: %[[xlbCast:.*]] = fir.convert %[[xlb]] : (i32) -> i64
! CHECK-DAG: %[[xubCast:.*]] = fir.convert %[[xub]] : (i32) -> i64
! CHECK: fir.call @{{.*}}AllocatableSetBounds(%[[xBoxCast2]], %c0{{.*}}, %[[xlbCast]], %[[xubCast]]) : (!fir.ref<!fir.box<none>>, i32, i64, i64) -> none
! CHECK-DAG: %[[xBoxCast3:.*]] = fir.convert %[[xBoxAddr]] : (!fir.ref<!fir.box<!fir.heap<!fir.array<?xf32>>>>) -> !fir.ref<!fir.box<none>>
! CHECK-DAG: %[[sourceFile:.*]] = fir.convert %{{.*}} -> !fir.ref<i8>
! CHECK: fir.call @{{.*}}AllocatableAllocate(%[[xBoxCast3]], %false{{.*}}, %[[errMsg]], %[[sourceFile]], %{{.*}}) : (!fir.ref<!fir.box<none>>, i1, !fir.box<none>, !fir.ref<i8>, i32) -> i32
! Simply check that we are emitting the right numebr of set bound for y and z. Otherwise, this is just like x.
! CHECK: fir.convert %[[yBoxAddr]] : (!fir.ref<!fir.box<!fir.heap<!fir.array<?x?xf32>>>>) -> !fir.ref<!fir.box<none>>
! CHECK: fir.call @{{.*}}AllocatableSetBounds
! CHECK: fir.call @{{.*}}AllocatableSetBounds
! CHECK: fir.call @{{.*}}AllocatableAllocate
! CHECK: %[[zBoxCast:.*]] = fir.convert %[[zBoxAddr]] : (!fir.ref<!fir.box<!fir.heap<f32>>>) -> !fir.ref<!fir.box<none>>
! CHECK-NOT: fir.call @{{.*}}AllocatableSetBounds
! CHECK: fir.call @{{.*}}AllocatableAllocate
! Check that y descriptor is read when referencing it.
! CHECK: %[[yBoxLoad:.*]] = fir.load %[[yBoxAddr]] : !fir.ref<!fir.box<!fir.heap<!fir.array<?x?xf32>>>>
! CHECK: %[[yBounds1:.*]]:3 = fir.box_dims %[[yBoxLoad]], %c0{{.*}} : (!fir.box<!fir.heap<!fir.array<?x?xf32>>>, index) -> (index, index, index)
! CHECK: %[[yBounds2:.*]]:3 = fir.box_dims %[[yBoxLoad]], %c1{{.*}} : (!fir.box<!fir.heap<!fir.array<?x?xf32>>>, index) -> (index, index, index)
! CHECK: %[[yAddr:.*]] = fir.box_addr %[[yBoxLoad]] : (!fir.box<!fir.heap<!fir.array<?x?xf32>>>) -> !fir.heap<!fir.array<?x?xf32>>
print *, x, y(45, 46), z
deallocate(x, y, z)
! CHECK: %[[xBoxCast4:.*]] = fir.convert %[[xBoxAddr]] : (!fir.ref<!fir.box<!fir.heap<!fir.array<?xf32>>>>) -> !fir.ref<!fir.box<none>>
! CHECK: fir.call @{{.*}}AllocatableDeallocate(%[[xBoxCast4]], {{.*}})
! CHECK: %[[yBoxCast4:.*]] = fir.convert %[[yBoxAddr]] : (!fir.ref<!fir.box<!fir.heap<!fir.array<?x?xf32>>>>) -> !fir.ref<!fir.box<none>>
! CHECK: fir.call @{{.*}}AllocatableDeallocate(%[[yBoxCast4]], {{.*}})
! CHECK: %[[zBoxCast4:.*]] = fir.convert %[[zBoxAddr]] : (!fir.ref<!fir.box<!fir.heap<f32>>>) -> !fir.ref<!fir.box<none>>
! CHECK: fir.call @{{.*}}AllocatableDeallocate(%[[zBoxCast4]], {{.*}})
end subroutine
! test lowering of character allocatables
! CHECK-LABEL: _QPchar_deferred(
subroutine char_deferred(n)
integer :: n
character(:), allocatable :: scalar, array(:)
! CHECK-DAG: %[[sBoxAddr:.*]] = fir.alloca !fir.box<!fir.heap<!fir.char<1,?>>> {{{.*}}uniq_name = "_QFchar_deferredEscalar"}
! CHECK-DAG: %[[sNullAddr:.*]] = fir.zero_bits !fir.heap<!fir.char<1,?>>
! CHECK-DAG: %[[sInitBox:.*]] = fir.embox %[[sNullAddr]] typeparams %c0{{.*}} : (!fir.heap<!fir.char<1,?>>, index) -> !fir.box<!fir.heap<!fir.char<1,?>>>
! CHECK-DAG: fir.store %[[sInitBox]] to %[[sBoxAddr]] : !fir.ref<!fir.box<!fir.heap<!fir.char<1,?>>>>
! CHECK-DAG: %[[aBoxAddr:.*]] = fir.alloca !fir.box<!fir.heap<!fir.array<?x!fir.char<1,?>>>> {{{.*}}uniq_name = "_QFchar_deferredEarray"}
! CHECK-DAG: %[[aNullAddr:.*]] = fir.zero_bits !fir.heap<!fir.array<?x!fir.char<1,?>>>
! CHECK-DAG: %[[aNullShape:.*]] = fir.shape %c0{{.*}} : (index) -> !fir.shape<1>
! CHECK-DAG: %[[aInitBox:.*]] = fir.embox %[[aNullAddr]](%[[aNullShape]]) typeparams %c0{{.*}} : (!fir.heap<!fir.array<?x!fir.char<1,?>>>, !fir.shape<1>, index) -> !fir.box<!fir.heap<!fir.array<?x!fir.char<1,?>>>>
! CHECK-DAG: fir.store %[[aInitBox]] to %[[aBoxAddr]] : !fir.ref<!fir.box<!fir.heap<!fir.array<?x!fir.char<1,?>>>>>
allocate(character(10):: scalar, array(30))
! CHECK-DAG: %[[sBoxCast1:.*]] = fir.convert %[[sBoxAddr]] : (!fir.ref<!fir.box<!fir.heap<!fir.char<1,?>>>>) -> !fir.ref<!fir.box<none>>
! CHECK-DAG: %[[ten1:.*]] = fir.convert %c10{{.*}} : (i32) -> i64
! CHECK: fir.call @{{.*}}AllocatableInitCharacter(%[[sBoxCast1]], %[[ten1]], %c1{{.*}}, %c0{{.*}}, %c0{{.*}})
! CHECK-NOT: AllocatableSetBounds
! CHECK: %[[sBoxCast2:.*]] = fir.convert %[[sBoxAddr]] : (!fir.ref<!fir.box<!fir.heap<!fir.char<1,?>>>>) -> !fir.ref<!fir.box<none>>
! CHECK: fir.call @{{.*}}AllocatableAllocate(%[[sBoxCast2]]
! CHECK-DAG: %[[aBoxCast1:.*]] = fir.convert %[[aBoxAddr]] : (!fir.ref<!fir.box<!fir.heap<!fir.array<?x!fir.char<1,?>>>>>) -> !fir.ref<!fir.box<none>>
! CHECK-DAG: %[[ten2:.*]] = fir.convert %c10{{.*}} : (i32) -> i64
! CHECK: fir.call @{{.*}}AllocatableInitCharacter(%[[aBoxCast1]], %[[ten2]], %c1{{.*}}, %c1{{.*}}, %c0{{.*}})
! CHECK: %[[aBoxCast2:.*]] = fir.convert %[[aBoxAddr]] : (!fir.ref<!fir.box<!fir.heap<!fir.array<?x!fir.char<1,?>>>>>) -> !fir.ref<!fir.box<none>>
! CHECK: fir.call @{{.*}}AllocatableSetBounds(%[[aBoxCast2]]
! CHECK: %[[aBoxCast3:.*]] = fir.convert %[[aBoxAddr]] : (!fir.ref<!fir.box<!fir.heap<!fir.array<?x!fir.char<1,?>>>>>) -> !fir.ref<!fir.box<none>>
! CHECK: fir.call @{{.*}}AllocatableAllocate(%[[aBoxCast3]]
deallocate(scalar, array)
! CHECK: %[[sBoxCast3:.*]] = fir.convert %[[sBoxAddr]] : (!fir.ref<!fir.box<!fir.heap<!fir.char<1,?>>>>) -> !fir.ref<!fir.box<none>>
! CHECK: fir.call @{{.*}}AllocatableDeallocate(%[[sBoxCast3]]
! CHECK: %[[aBoxCast4:.*]] = fir.convert %[[aBoxAddr]] : (!fir.ref<!fir.box<!fir.heap<!fir.array<?x!fir.char<1,?>>>>>) -> !fir.ref<!fir.box<none>>
! CHECK: fir.call @{{.*}}AllocatableDeallocate(%[[aBoxCast4]]
! only testing that the correct length is set in the descriptor.
allocate(character(n):: scalar, array(40))
! CHECK: %[[n:.*]] = fir.load %arg0 : !fir.ref<i32>
! CHECK-DAG: %[[ncast1:.*]] = fir.convert %[[n]] : (i32) -> i64
! CHECK-DAG: %[[sBoxCast4:.*]] = fir.convert %[[sBoxAddr]] : (!fir.ref<!fir.box<!fir.heap<!fir.char<1,?>>>>) -> !fir.ref<!fir.box<none>>
! CHECK: fir.call @{{.*}}AllocatableInitCharacter(%[[sBoxCast4]], %[[ncast1]], %c1{{.*}}, %c0{{.*}}, %c0{{.*}})
! CHECK-DAG: %[[ncast2:.*]] = fir.convert %[[n]] : (i32) -> i64
! CHECK-DAG: %[[aBoxCast5:.*]] = fir.convert %[[aBoxAddr]] : (!fir.ref<!fir.box<!fir.heap<!fir.array<?x!fir.char<1,?>>>>>) -> !fir.ref<!fir.box<none>>
! CHECK: fir.call @{{.*}}AllocatableInitCharacter(%[[aBoxCast5]], %[[ncast2]], %c1{{.*}}, %c1{{.*}}, %c0{{.*}})
end subroutine
! CHECK-LABEL: _QPchar_explicit_cst(
subroutine char_explicit_cst(n)
integer :: n
character(10), allocatable :: scalar, array(:)
! CHECK-DAG: %[[sBoxAddr:.*]] = fir.alloca !fir.box<!fir.heap<!fir.char<1,10>>> {{{.*}}uniq_name = "_QFchar_explicit_cstEscalar"}
! CHECK-DAG: %[[sNullAddr:.*]] = fir.zero_bits !fir.heap<!fir.char<1,10>>
! CHECK-DAG: %[[sInitBox:.*]] = fir.embox %[[sNullAddr]] : (!fir.heap<!fir.char<1,10>>) -> !fir.box<!fir.heap<!fir.char<1,10>>>
! CHECK-DAG: fir.store %[[sInitBox]] to %[[sBoxAddr]] : !fir.ref<!fir.box<!fir.heap<!fir.char<1,10>>>>
! CHECK-DAG: %[[aBoxAddr:.*]] = fir.alloca !fir.box<!fir.heap<!fir.array<?x!fir.char<1,10>>>> {{{.*}}uniq_name = "_QFchar_explicit_cstEarray"}
! CHECK-DAG: %[[aNullAddr:.*]] = fir.zero_bits !fir.heap<!fir.array<?x!fir.char<1,10>>>
! CHECK-DAG: %[[aNullShape:.*]] = fir.shape %c0{{.*}} : (index) -> !fir.shape<1>
! CHECK-DAG: %[[aInitBox:.*]] = fir.embox %[[aNullAddr]](%[[aNullShape]]) : (!fir.heap<!fir.array<?x!fir.char<1,10>>>, !fir.shape<1>) -> !fir.box<!fir.heap<!fir.array<?x!fir.char<1,10>>>>
! CHECK-DAG: fir.store %[[aInitBox]] to %[[aBoxAddr]] : !fir.ref<!fir.box<!fir.heap<!fir.array<?x!fir.char<1,10>>>>>
allocate(scalar, array(20))
! CHECK-NOT: AllocatableInitCharacter
! CHECK: AllocatableAllocate
! CHECK-NOT: AllocatableInitCharacter
! CHECK: AllocatableAllocate
deallocate(scalar, array)
! CHECK: AllocatableDeallocate
! CHECK: AllocatableDeallocate
end subroutine
! CHECK-LABEL: _QPchar_explicit_dyn(
subroutine char_explicit_dyn(n, l1, l2)
integer :: n, l1, l2
character(l1), allocatable :: scalar
! CHECK: %[[sBoxAddr:.*]] = fir.alloca !fir.box<!fir.heap<!fir.char<1,?>>> {{{.*}}uniq_name = "_QFchar_explicit_dynEscalar"}
! CHECK: %[[raw_l1:.*]] = fir.load %arg1 : !fir.ref<i32>
! CHECK: %[[c0_i32:.*]] = arith.constant 0 : i32
! CHECK: %[[cmp1:.*]] = arith.cmpi sgt, %[[raw_l1]], %[[c0_i32]] : i32
! CHECK: %[[l1:.*]] = arith.select %[[cmp1]], %[[raw_l1]], %[[c0_i32]] : i32
! CHECK: %[[sNullAddr:.*]] = fir.zero_bits !fir.heap<!fir.char<1,?>>
! CHECK: %[[sInitBox:.*]] = fir.embox %[[sNullAddr]] typeparams %[[l1]] : (!fir.heap<!fir.char<1,?>>, i32) -> !fir.box<!fir.heap<!fir.char<1,?>>>
! CHECK: fir.store %[[sInitBox]] to %[[sBoxAddr]] : !fir.ref<!fir.box<!fir.heap<!fir.char<1,?>>>>
character(l2), allocatable :: zarray(:)
! CHECK: %[[aBoxAddr:.*]] = fir.alloca !fir.box<!fir.heap<!fir.array<?x!fir.char<1,?>>>> {{{.*}}uniq_name = "_QFchar_explicit_dynEzarray"}
! CHECK: %[[raw_l2:.*]] = fir.load %arg2 : !fir.ref<i32>
! CHECK: %[[c0_i32_2:.*]] = arith.constant 0 : i32
! CHECK: %[[cmp2:.*]] = arith.cmpi sgt, %[[raw_l2]], %[[c0_i32_2]] : i32
! CHECK: %[[l2:.*]] = arith.select %[[cmp2]], %[[raw_l2]], %[[c0_i32_2]] : i32
! CHECK: %[[aNullAddr:.*]] = fir.zero_bits !fir.heap<!fir.array<?x!fir.char<1,?>>>
! CHECK: %[[aNullShape:.*]] = fir.shape %c0{{.*}} : (index) -> !fir.shape<1>
! CHECK: %[[aInitBox:.*]] = fir.embox %[[aNullAddr]](%[[aNullShape]]) typeparams %[[l2]] : (!fir.heap<!fir.array<?x!fir.char<1,?>>>, !fir.shape<1>, i32) -> !fir.box<!fir.heap<!fir.array<?x!fir.char<1,?>>>>
! CHECK: fir.store %[[aInitBox]] to %[[aBoxAddr]] : !fir.ref<!fir.box<!fir.heap<!fir.array<?x!fir.char<1,?>>>>>
allocate(scalar, zarray(20))
! CHECK-NOT: AllocatableInitCharacter
! CHECK: AllocatableAllocate
! CHECK-NOT: AllocatableInitCharacter
! CHECK: AllocatableAllocate
deallocate(scalar, zarray)
! CHECK: AllocatableDeallocate
! CHECK: AllocatableDeallocate
end subroutine

7
flang/test/Lower/allocatables.f90
View File

@ -124,8 +124,11 @@ end subroutine
subroutine char_explicit_dyn(l1, l2)
integer :: l1, l2
character(l1), allocatable :: c
! CHECK-DAG: %[[cLen:.*]] = fir.load %arg0 : !fir.ref<i32>
! CHECK-DAG: %[[cAddrVar:.*]] = fir.alloca !fir.heap<!fir.char<1,?>> {{{.*}}uniq_name = "_QFchar_explicit_dynEc.addr"}
! CHECK: %[[l1:.*]] = fir.load %arg0 : !fir.ref<i32>
! CHECK: %[[c0_i32:.*]] = arith.constant 0 : i32
! CHECK: %[[cmp:.*]] = arith.cmpi sgt, %[[l1]], %[[c0_i32]] : i32
! CHECK: %[[cLen:.*]] = arith.select %[[cmp]], %[[l1]], %[[c0_i32]] : i32
! CHECK: %[[cAddrVar:.*]] = fir.alloca !fir.heap<!fir.char<1,?>> {{{.*}}uniq_name = "_QFchar_explicit_dynEc.addr"}
! CHECK-NOT: "_QFchar_explicit_dynEc.len"
allocate(c)
! CHECK: %[[cLenCast1:.*]] = fir.convert %[[cLen]] : (i32) -> index

254
flang/test/Lower/dummy-procedure-character.f90 Normal file
View File

@ -0,0 +1,254 @@
! Test lowering of character function dummy procedure. The length must be
! passed along the function address.
! RUN: bbc -emit-fir %s -o - | FileCheck %s
! -----------------------------------------------------------------------------
! Test passing a character function as dummy procedure
! -----------------------------------------------------------------------------
! CHECK-LABEL: func @_QPcst_len
subroutine cst_len()
interface
character(7) function bar1()
end function
end interface
call foo1(bar1)
! CHECK: %[[VAL_0:.*]] = fir.address_of(@_QPbar1) : (!fir.ref<!fir.char<1,7>>, index) -> !fir.boxchar<1>
! CHECK: %[[VAL_1:.*]] = arith.constant 7 : i64
! CHECK: %[[VAL_2:.*]] = fir.emboxproc %[[VAL_0]] : ((!fir.ref<!fir.char<1,7>>, index) -> !fir.boxchar<1>) -> !fir.boxproc<() -> ()>
! CHECK: %[[VAL_3:.*]] = fir.undefined tuple<!fir.boxproc<() -> ()>, i64>
! CHECK: %[[VAL_4:.*]] = fir.insert_value %[[VAL_3]], %[[VAL_2]], [0 : index] : (tuple<!fir.boxproc<() -> ()>, i64>, !fir.boxproc<() -> ()>) -> tuple<!fir.boxproc<() -> ()>, i64>
! CHECK: %[[VAL_5:.*]] = fir.insert_value %[[VAL_4]], %[[VAL_1]], [1 : index] : (tuple<!fir.boxproc<() -> ()>, i64>, i64) -> tuple<!fir.boxproc<() -> ()>, i64>
! CHECK: fir.call @_QPfoo1(%[[VAL_5]]) : (tuple<!fir.boxproc<() -> ()>, i64>) -> ()
end subroutine
! CHECK-LABEL: func @_QPcst_len_array
subroutine cst_len_array()
interface
function bar1_array()
character(7) :: bar1_array(10)
end function
end interface
! CHECK: %[[VAL_0:.*]] = fir.address_of(@_QPbar1_array) : () -> !fir.array<10x!fir.char<1,7>>
! CHECK: %[[VAL_1:.*]] = arith.constant 7 : i64
! CHECK: %[[VAL_2:.*]] = fir.emboxproc %[[VAL_0]] : (() -> !fir.array<10x!fir.char<1,7>>) -> !fir.boxproc<() -> ()>
! CHECK: %[[VAL_3:.*]] = fir.undefined tuple<!fir.boxproc<() -> ()>, i64>
! CHECK: %[[VAL_4:.*]] = fir.insert_value %[[VAL_3]], %[[VAL_2]], [0 : index] : (tuple<!fir.boxproc<() -> ()>, i64>, !fir.boxproc<() -> ()>) -> tuple<!fir.boxproc<() -> ()>, i64>
! CHECK: %[[VAL_5:.*]] = fir.insert_value %[[VAL_4]], %[[VAL_1]], [1 : index] : (tuple<!fir.boxproc<() -> ()>, i64>, i64) -> tuple<!fir.boxproc<() -> ()>, i64>
! CHECK: fir.call @_QPfoo1b(%[[VAL_5]]) : (tuple<!fir.boxproc<() -> ()>, i64>) -> ()
call foo1b(bar1_array)
end subroutine
! CHECK-LABEL: func @_QPcst_len_2
subroutine cst_len_2()
character(7) :: bar2
external :: bar2
! CHECK: %[[VAL_0:.*]] = fir.address_of(@_QPbar2) : (!fir.ref<!fir.char<1,7>>, index) -> !fir.boxchar<1>
! CHECK: %[[VAL_1:.*]] = arith.constant 7 : i64
! CHECK: %[[VAL_2:.*]] = fir.emboxproc %[[VAL_0]] : ((!fir.ref<!fir.char<1,7>>, index) -> !fir.boxchar<1>) -> !fir.boxproc<() -> ()>
! CHECK: %[[VAL_3:.*]] = fir.undefined tuple<!fir.boxproc<() -> ()>, i64>
! CHECK: %[[VAL_4:.*]] = fir.insert_value %[[VAL_3]], %[[VAL_2]], [0 : index] : (tuple<!fir.boxproc<() -> ()>, i64>, !fir.boxproc<() -> ()>) -> tuple<!fir.boxproc<() -> ()>, i64>
! CHECK: %[[VAL_5:.*]] = fir.insert_value %[[VAL_4]], %[[VAL_1]], [1 : index] : (tuple<!fir.boxproc<() -> ()>, i64>, i64) -> tuple<!fir.boxproc<() -> ()>, i64>
! CHECK: fir.call @_QPfoo2(%[[VAL_5]]) : (tuple<!fir.boxproc<() -> ()>, i64>) -> ()
call foo2(bar2)
end subroutine
! CHECK-LABEL: func @_QPdyn_len(
! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref<i32>{{.*}}) {
subroutine dyn_len(n)
integer :: n
character(n) :: bar3
external :: bar3
! CHECK: %[[VAL_1:.*]] = fir.address_of(@_QPbar3) : (!fir.ref<!fir.char<1,?>>, index) -> !fir.boxchar<1>
! CHECK: %[[VAL_2:.*]] = fir.load %[[VAL_0]] : !fir.ref<i32>
! CHECK: %[[VAL_3:.*]] = fir.convert %[[VAL_2]] : (i32) -> i64
! CHECK: %[[VAL_4:.*]] = arith.constant 0 : i64
! CHECK: %[[VAL_5:.*]] = arith.cmpi sgt, %[[VAL_3]], %[[VAL_4]] : i64
! CHECK: %[[VAL_6:.*]] = arith.select %[[VAL_5]], %[[VAL_3]], %[[VAL_4]] : i64
! CHECK: %[[VAL_7:.*]] = fir.emboxproc %[[VAL_1]] : ((!fir.ref<!fir.char<1,?>>, index) -> !fir.boxchar<1>) -> !fir.boxproc<() -> ()>
! CHECK: %[[VAL_8:.*]] = fir.undefined tuple<!fir.boxproc<() -> ()>, i64>
! CHECK: %[[VAL_9:.*]] = fir.insert_value %[[VAL_8]], %[[VAL_7]], [0 : index] : (tuple<!fir.boxproc<() -> ()>, i64>, !fir.boxproc<() -> ()>) -> tuple<!fir.boxproc<() -> ()>, i64>
! CHECK: %[[VAL_10:.*]] = fir.insert_value %[[VAL_9]], %[[VAL_6]], [1 : index] : (tuple<!fir.boxproc<() -> ()>, i64>, i64) -> tuple<!fir.boxproc<() -> ()>, i64>
! CHECK: fir.call @_QPfoo3(%[[VAL_10]]) : (tuple<!fir.boxproc<() -> ()>, i64>) -> ()
call foo3(bar3)
end subroutine
! CHECK-LABEL: func @_QPcannot_compute_len_yet
subroutine cannot_compute_len_yet()
interface
function bar4(n)
integer :: n
character(n) :: bar4
end function
end interface
! CHECK: %[[VAL_0:.*]] = fir.address_of(@_QPbar4) : (!fir.ref<!fir.char<1,?>>, index, !fir.ref<i32>) -> !fir.boxchar<1>
! CHECK: %[[VAL_1:.*]] = arith.constant -1 : index
! CHECK: %[[VAL_2:.*]] = fir.emboxproc %[[VAL_0]] : ((!fir.ref<!fir.char<1,?>>, index, !fir.ref<i32>) -> !fir.boxchar<1>) -> !fir.boxproc<() -> ()>
! CHECK: %[[VAL_3:.*]] = fir.convert %[[VAL_1]] : (index) -> i64
! CHECK: %[[VAL_4:.*]] = fir.undefined tuple<!fir.boxproc<() -> ()>, i64>
! CHECK: %[[VAL_5:.*]] = fir.insert_value %[[VAL_4]], %[[VAL_2]], [0 : index] : (tuple<!fir.boxproc<() -> ()>, i64>, !fir.boxproc<() -> ()>) -> tuple<!fir.boxproc<() -> ()>, i64>
! CHECK: %[[VAL_6:.*]] = fir.insert_value %[[VAL_5]], %[[VAL_3]], [1 : index] : (tuple<!fir.boxproc<() -> ()>, i64>, i64) -> tuple<!fir.boxproc<() -> ()>, i64>
! CHECK: fir.call @_QPfoo4(%[[VAL_6]]) : (tuple<!fir.boxproc<() -> ()>, i64>) -> ()
call foo4(bar4)
end subroutine
! CHECK-LABEL: func @_QPcannot_compute_len_yet_2
subroutine cannot_compute_len_yet_2()
character(*) :: bar5
external :: bar5
! CHECK: %[[VAL_0:.*]] = fir.address_of(@_QPbar5) : (!fir.ref<!fir.char<1,?>>, index) -> !fir.boxchar<1>
! CHECK: %[[VAL_1:.*]] = arith.constant -1 : index
! CHECK: %[[VAL_2:.*]] = fir.emboxproc %[[VAL_0]] : ((!fir.ref<!fir.char<1,?>>, index) -> !fir.boxchar<1>) -> !fir.boxproc<() -> ()>
! CHECK: %[[VAL_3:.*]] = fir.convert %[[VAL_1]] : (index) -> i64
! CHECK: %[[VAL_4:.*]] = fir.undefined tuple<!fir.boxproc<() -> ()>, i64>
! CHECK: %[[VAL_5:.*]] = fir.insert_value %[[VAL_4]], %[[VAL_2]], [0 : index] : (tuple<!fir.boxproc<() -> ()>, i64>, !fir.boxproc<() -> ()>) -> tuple<!fir.boxproc<() -> ()>, i64>
! CHECK: %[[VAL_6:.*]] = fir.insert_value %[[VAL_5]], %[[VAL_3]], [1 : index] : (tuple<!fir.boxproc<() -> ()>, i64>, i64) -> tuple<!fir.boxproc<() -> ()>, i64>
! CHECK: fir.call @_QPfoo5(%[[VAL_6]]) : (tuple<!fir.boxproc<() -> ()>, i64>) -> ()
call foo5(bar5)
end subroutine
! CHECK-LABEL: func @_QPforward_incoming_length
! CHECK-SAME: %[[VAL_0:.*]]: tuple<!fir.boxproc<() -> ()>, i64> {fir.char_proc}) {
subroutine forward_incoming_length(bar6)
character(*) :: bar6
external :: bar6
! CHECK: %[[VAL_1:.*]] = fir.extract_value %[[VAL_0]], [0 : index] : (tuple<!fir.boxproc<() -> ()>, i64>) -> !fir.boxproc<() -> ()>
! CHECK: %[[WAL_2:.*]] = fir.box_addr %[[VAL_1]] : (!fir.boxproc<() -> ()>) -> (() -> ())
! CHECK: %[[VAL_2:.*]] = fir.extract_value %[[VAL_0]], [1 : index] : (tuple<!fir.boxproc<() -> ()>, i64>) -> i64
! CHECK: %[[WAL_1:.*]] = fir.emboxproc %[[WAL_2]] : (() -> ()) -> !fir.boxproc<() -> ()>
! CHECK: %[[VAL_3:.*]] = fir.undefined tuple<!fir.boxproc<() -> ()>, i64>
! CHECK: %[[VAL_4:.*]] = fir.insert_value %[[VAL_3]], %[[WAL_1]], [0 : index] : (tuple<!fir.boxproc<() -> ()>, i64>, !fir.boxproc<() -> ()>) -> tuple<!fir.boxproc<() -> ()>, i64>
! CHECK: %[[VAL_5:.*]] = fir.insert_value %[[VAL_4]], %[[VAL_2]], [1 : index] : (tuple<!fir.boxproc<() -> ()>, i64>, i64) -> tuple<!fir.boxproc<() -> ()>, i64>
! CHECK: fir.call @_QPfoo6(%[[VAL_5]]) : (tuple<!fir.boxproc<() -> ()>, i64>) -> ()
call foo6(bar6)
end subroutine
! CHECK-LABEL: func @_QPoverride_incoming_length
! CHECK-SAME: %[[VAL_0:.*]]: tuple<!fir.boxproc<() -> ()>, i64> {fir.char_proc}) {
subroutine override_incoming_length(bar7)
character(7) :: bar7
external :: bar7
! CHECK: %[[VAL_1:.*]] = fir.extract_value %[[VAL_0]], [0 : index] : (tuple<!fir.boxproc<() -> ()>, i64>) -> !fir.boxproc<() -> ()>
! CHECK: %[[WAL_2:.*]] = fir.box_addr %[[VAL_1]] : (!fir.boxproc<() -> ()>) -> (() -> ())
! CHECK: %[[VAL_2:.*]] = arith.constant 7 : i64
! CHECK: %[[WAL_1:.*]] = fir.emboxproc %[[WAL_2]] : (() -> ()) -> !fir.boxproc<() -> ()>
! CHECK: %[[VAL_3:.*]] = fir.undefined tuple<!fir.boxproc<() -> ()>, i64>
! CHECK: %[[VAL_4:.*]] = fir.insert_value %[[VAL_3]], %[[WAL_1]], [0 : index] : (tuple<!fir.boxproc<() -> ()>, i64>, !fir.boxproc<() -> ()>) -> tuple<!fir.boxproc<() -> ()>, i64>
! CHECK: %[[VAL_5:.*]] = fir.insert_value %[[VAL_4]], %[[VAL_2]], [1 : index] : (tuple<!fir.boxproc<() -> ()>, i64>, i64) -> tuple<!fir.boxproc<() -> ()>, i64>
! CHECK: fir.call @_QPfoo7(%[[VAL_5]]) : (tuple<!fir.boxproc<() -> ()>, i64>) -> ()
call foo7(bar7)
end subroutine
! -----------------------------------------------------------------------------
! Test calling character dummy function
! -----------------------------------------------------------------------------
! CHECK-LABEL: func @_QPcall_assumed_length
! CHECK-SAME: %[[VAL_0:.*]]: tuple<!fir.boxproc<() -> ()>, i64> {fir.char_proc}) {
subroutine call_assumed_length(bar8)
character(*) :: bar8
external :: bar8
! CHECK: %[[VAL_3:.*]] = fir.extract_value %[[VAL_0]], [0 : index] : (tuple<!fir.boxproc<() -> ()>, i64>) -> !fir.boxproc<() -> ()>
! CHECK: %[[WAL_2:.*]] = fir.box_addr %[[VAL_3]] : (!fir.boxproc<() -> ()>) -> (() -> ())
! CHECK: %[[VAL_4:.*]] = fir.extract_value %[[VAL_0]], [1 : index] : (tuple<!fir.boxproc<() -> ()>, i64>) -> i64
! CHECK: %[[VAL_6:.*]] = fir.alloca !fir.char<1,?>(%[[VAL_4]] : i64) {bindc_name = ".result"}
! CHECK: %[[VAL_7:.*]] = fir.convert %[[WAL_2]] : (() -> ()) -> ((!fir.ref<!fir.char<1,?>>, index, !fir.ref<i32>) -> !fir.boxchar<1>)
! CHECK: %[[VAL_8:.*]] = fir.convert %[[VAL_4]] : (i64) -> index
! CHECK: fir.call %[[VAL_7]](%[[VAL_6]], %[[VAL_8]], %{{.*}}) : (!fir.ref<!fir.char<1,?>>, index, !fir.ref<i32>) -> !fir.boxchar<1>
call test(bar8(42))
end subroutine
! CHECK-LABEL: func @_QPcall_explicit_length
! CHECK-SAME: %[[VAL_0:.*]]: tuple<!fir.boxproc<() -> ()>, i64> {fir.char_proc}) {
subroutine call_explicit_length(bar9)
character(7) :: bar9
external :: bar9
! CHECK: %[[VAL_1:.*]] = fir.alloca !fir.char<1,7> {bindc_name = ".result"}
! CHECK: %[[VAL_4:.*]] = fir.extract_value %[[VAL_0]], [0 : index] : (tuple<!fir.boxproc<() -> ()>, i64>) -> !fir.boxproc<() -> ()>
! CHECK: %[[WAL_1:.*]] = fir.box_addr %[[VAL_4]] : (!fir.boxproc<() -> ()>) -> (() -> ())
! CHECK: %[[VAL_5:.*]] = arith.constant 7 : i64
! CHECK: %[[VAL_6:.*]] = fir.convert %[[VAL_5]] : (i64) -> index
! CHECK: %[[VAL_8:.*]] = fir.convert %[[WAL_1]] : (() -> ()) -> ((!fir.ref<!fir.char<1,7>>, index, !fir.ref<i32>) -> !fir.boxchar<1>)
! CHECK: fir.call %[[VAL_8]](%[[VAL_1]], %[[VAL_6]], %{{.*}}) : (!fir.ref<!fir.char<1,7>>, index, !fir.ref<i32>) -> !fir.boxchar<1>
call test(bar9(42))
end subroutine
! CHECK-LABEL: func @_QPcall_explicit_length_with_iface
! CHECK-SAME: %[[VAL_0:.*]]: tuple<!fir.boxproc<() -> ()>, i64> {fir.char_proc}) {
subroutine call_explicit_length_with_iface(bar10)
interface
function bar10(n)
integer(8) :: n
character(n) :: bar10
end function
end interface
! CHECK: %[[VAL_1:.*]] = fir.alloca i64
! CHECK: %[[VAL_2:.*]] = arith.constant 42 : i64
! CHECK: fir.store %[[VAL_2]] to %[[VAL_1]] : !fir.ref<i64>
! CHECK: %[[VAL_3:.*]] = fir.extract_value %[[VAL_0]], [0 : index] : (tuple<!fir.boxproc<() -> ()>, i64>) -> !fir.boxproc<() -> ()>
! CHECK: %[[WAL_1:.*]] = fir.box_addr %[[VAL_3]] : (!fir.boxproc<() -> ()>) -> (() -> ())
! CHECK: %[[VAL_4:.*]] = fir.load %[[VAL_1]] : !fir.ref<i64>
! CHECK: %[[VAL_5:.*]] = fir.convert %[[VAL_4]] : (i64) -> index
! CHECK: %[[VAL_6:.*]] = fir.call @llvm.stacksave() : () -> !fir.ref<i8>
! CHECK: %[[VAL_7:.*]] = fir.alloca !fir.char<1,?>(%[[VAL_5]] : index) {bindc_name = ".result"}
! CHECK: %[[VAL_8:.*]] = fir.convert %[[WAL_1]] : (() -> ()) -> ((!fir.ref<!fir.char<1,?>>, index, !fir.ref<i64>) -> !fir.boxchar<1>)
! CHECK: fir.call %[[VAL_8]](%[[VAL_7]], %[[VAL_5]], %[[VAL_1]]) : (!fir.ref<!fir.char<1,?>>, index, !fir.ref<i64>) -> !fir.boxchar<1>
call test(bar10(42_8))
end subroutine
! CHECK-LABEL: func @_QPhost(
! CHECK-SAME: %[[VAL_0:.*]]: tuple<!fir.boxproc<() -> ()>, i64>
subroutine host(f)
character*(*) :: f
external :: f
! CHECK: %[[VAL_3:.*]] = fir.coordinate_of %[[VAL_1:.*]], %{{.*}} : (!fir.ref<tuple<tuple<!fir.boxproc<() -> ()>, i64>>>, i32) -> !fir.ref<tuple<!fir.boxproc<() -> ()>, i64>>
! CHECK: fir.store %[[VAL_0]] to %[[VAL_3]] : !fir.ref<tuple<!fir.boxproc<() -> ()>, i64>>
! CHECK: fir.call @_QFhostPintern(%[[VAL_1]])
call intern()
contains
! CHECK-LABEL: func @_QFhostPintern(
! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref<tuple<tuple<!fir.boxproc<() -> ()>, i64>>> {fir.host_assoc})
subroutine intern()
! CHECK: %[[VAL_1:.*]] = arith.constant 0 : i32
! CHECK: %[[VAL_2:.*]] = fir.coordinate_of %[[VAL_0]], %[[VAL_1]] : (!fir.ref<tuple<tuple<!fir.boxproc<() -> ()>, i64>>>, i32) -> !fir.ref<tuple<!fir.boxproc<() -> ()>, i64>>
! CHECK: %[[VAL_3:.*]] = fir.load %[[VAL_2]] : !fir.ref<tuple<!fir.boxproc<() -> ()>, i64>>
! CHECK: %[[VAL_4:.*]] = fir.extract_value %[[VAL_3]], [0 : index] : (tuple<!fir.boxproc<() -> ()>, i64>) -> !fir.boxproc<() -> ()>
! CHECK: %[[WAL_1:.*]] = fir.box_addr %[[VAL_4]] : (!fir.boxproc<() -> ()>) -> (() -> ())
! CHECK: %[[VAL_5:.*]] = fir.extract_value %[[VAL_3]], [1 : index] : (tuple<!fir.boxproc<() -> ()>, i64>) -> i64
! CHECK: %[[VAL_7:.*]] = fir.alloca !fir.char<1,?>(%[[VAL_5]] : i64) {bindc_name = ".result"}
! CHECK: %[[VAL_8:.*]] = fir.convert %[[WAL_1]] : (() -> ()) -> ((!fir.ref<!fir.char<1,?>>, index) -> !fir.boxchar<1>)
! CHECK: %[[VAL_9:.*]] = fir.convert %[[VAL_5]] : (i64) -> index
! CHECK: fir.call %[[VAL_8]](%[[VAL_7]], %[[VAL_9]]) : (!fir.ref<!fir.char<1,?>>, index) -> !fir.boxchar<1>
call test(f())
end subroutine
end subroutine
! CHECK-LABEL: func @_QPhost2(
! CHECK-SAME: %[[VAL_0:.*]]: tuple<!fir.boxproc<() -> ()>, i64> {fir.char_proc})
subroutine host2(f)
! Test that dummy length is overridden by local length even when used
! in the internal procedure.
character*(42) :: f
external :: f
! CHECK: %[[VAL_3:.*]] = fir.coordinate_of %[[VAL_1:.*]], %{{.*}} : (!fir.ref<tuple<tuple<!fir.boxproc<() -> ()>, i64>>>, i32) -> !fir.ref<tuple<!fir.boxproc<() -> ()>, i64>>
! CHECK: fir.store %[[VAL_0]] to %[[VAL_3]] : !fir.ref<tuple<!fir.boxproc<() -> ()>, i64>>
! CHECK: fir.call @_QFhost2Pintern(%[[VAL_1]])
call intern()
contains
! CHECK-LABEL: func @_QFhost2Pintern(
! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref<tuple<tuple<!fir.boxproc<() -> ()>, i64>>> {fir.host_assoc})
subroutine intern()
! CHECK: %[[VAL_1:.*]] = fir.alloca !fir.char<1,42> {bindc_name = ".result"}
! CHECK: %[[VAL_2:.*]] = arith.constant 0 : i32
! CHECK: %[[VAL_3:.*]] = fir.coordinate_of %[[VAL_0]], %[[VAL_2]] : (!fir.ref<tuple<tuple<!fir.boxproc<() -> ()>, i64>>>, i32) -> !fir.ref<tuple<!fir.boxproc<() -> ()>, i64>>
! CHECK: %[[VAL_4:.*]] = fir.load %[[VAL_3]] : !fir.ref<tuple<!fir.boxproc<() -> ()>, i64>>
! CHECK: %[[VAL_5:.*]] = fir.extract_value %[[VAL_4]], [0 : index] : (tuple<!fir.boxproc<() -> ()>, i64>) -> !fir.boxproc<() -> ()>
! CHECK: %[[WAL_1:.*]] = fir.box_addr %[[VAL_5]] : (!fir.boxproc<() -> ()>) -> (() -> ())
! CHECK: %[[VAL_6:.*]] = arith.constant 42 : i64
! CHECK: %[[VAL_7:.*]] = fir.convert %[[VAL_6]] : (i64) -> index
! CHECK: %[[VAL_9:.*]] = fir.convert %[[WAL_1]] : (() -> ()) -> ((!fir.ref<!fir.char<1,42>>, index) -> !fir.boxchar<1>)
! CHECK: fir.call %[[VAL_9]](%[[VAL_1]], %[[VAL_7]]) : (!fir.ref<!fir.char<1,42>>, index) -> !fir.boxchar<1>
call test(f())
end subroutine
end subroutine

175
flang/test/Lower/dummy-procedure.f90 Normal file
View File

@ -0,0 +1,175 @@
! RUN: bbc -emit-fir %s -o - | FileCheck %s
! Test dummy procedures
! Test of dummy procedure call
! CHECK-LABEL: func @_QPfoo(
! CHECK-SAME: %{{.*}}: !fir.boxproc<() -> ()>{{.*}}) -> f32
real function foo(bar)
real :: bar, x
! CHECK: %[[x:.*]] = fir.alloca f32 {{{.*}}uniq_name = "{{.*}}Ex"}
x = 42.
! CHECK: %[[funccast:.*]] = fir.box_addr %arg0 : (!fir.boxproc<() -> ()>) -> ((!fir.ref<f32>) -> f32)
! CHECK: fir.call %[[funccast]](%[[x]]) : (!fir.ref<f32>) -> f32
foo = bar(x)
end function
! Test case where dummy procedure is only transiting.
! CHECK-LABEL: func @_QPprefoo(
! CHECK-SAME: %{{.*}}: !fir.boxproc<() -> ()>{{.*}}) -> f32
real function prefoo(bar)
external :: bar
! CHECK: fir.call @_QPfoo(%arg0) : (!fir.boxproc<() -> ()>) -> f32
prefoo = foo(bar)
end function
! Function that will be passed as dummy argument
! CHECK-LABEL: func @_QPfunc(
! CHECK-SAME: %{{.*}}: !fir.ref<f32>{{.*}}) -> f32
real function func(x)
real :: x
func = x + 0.5
end function
! Test passing functions as dummy procedure arguments
! CHECK-LABEL: func @_QPtest_func
real function test_func()
real :: func, prefoo
external :: func
!CHECK: %[[f:.*]] = fir.address_of(@_QPfunc) : (!fir.ref<f32>) -> f32
!CHECK: %[[fcast:.*]] = fir.emboxproc %[[f]] : ((!fir.ref<f32>) -> f32) -> !fir.boxproc<() -> ()>
!CHECK: fir.call @_QPprefoo(%[[fcast]]) : (!fir.boxproc<() -> ()>) -> f32
test_func = prefoo(func)
end function
! Repeat test with dummy subroutine
! CHECK-LABEL: func @_QPfoo_sub(
! CHECK-SAME: %{{.*}}: !fir.boxproc<() -> ()>{{.*}})
subroutine foo_sub(bar_sub)
! CHECK: %[[x:.*]] = fir.alloca f32 {{{.*}}uniq_name = "{{.*}}Ex"}
x = 42.
! CHECK: %[[funccast:.*]] = fir.box_addr %arg0 : (!fir.boxproc<() -> ()>) -> ((!fir.ref<f32>) -> ())
! CHECK: fir.call %[[funccast]](%[[x]]) : (!fir.ref<f32>)
call bar_sub(x)
end subroutine
! Test case where dummy procedure is only transiting.
! CHECK-LABEL: func @_QPprefoo_sub(
! CHECK-SAME: %{{.*}}: !fir.boxproc<() -> ()>{{.*}})
subroutine prefoo_sub(bar_sub)
external :: bar_sub
! CHECK: fir.call @_QPfoo_sub(%arg0) : (!fir.boxproc<() -> ()>) -> ()
call foo_sub(bar_sub)
end subroutine
! Subroutine that will be passed as dummy argument
! CHECK-LABEL: func @_QPsub(
! CHECK-SAME: %{{.*}}: !fir.ref<f32>{{.*}})
subroutine sub(x)
real :: x
print *, x
end subroutine
! Test passing functions as dummy procedure arguments
! CHECK-LABEL: func @_QPtest_sub
subroutine test_sub()
external :: sub
!CHECK: %[[f:.*]] = fir.address_of(@_QPsub) : (!fir.ref<f32>) -> ()
!CHECK: %[[fcast:.*]] = fir.emboxproc %[[f]] : ((!fir.ref<f32>) -> ()) -> !fir.boxproc<() -> ()>
!CHECK: fir.call @_QPprefoo_sub(%[[fcast]]) : (!fir.boxproc<() -> ()>) -> ()
call prefoo_sub(sub)
end subroutine
! CHECK-LABEL: func @_QPpassing_not_defined_in_file()
subroutine passing_not_defined_in_file()
external proc_not_defined_in_file
! CHECK: %[[addr:.*]] = fir.address_of(@_QPproc_not_defined_in_file) : () -> ()
! CHECK: %[[ep:.*]] = fir.emboxproc %[[addr]]
! CHECK: fir.call @_QPprefoo_sub(%[[ep]]) : (!fir.boxproc<() -> ()>) -> ()
call prefoo_sub(proc_not_defined_in_file)
end subroutine
! Test passing unrestricted intrinsics
! Intrinsic using runtime
! CHECK-LABEL: func @_QPtest_acos
subroutine test_acos(x)
intrinsic :: acos
!CHECK: %[[f:.*]] = fir.address_of(@fir.acos.f32.ref_f32) : (!fir.ref<f32>) -> f32
!CHECK: %[[fcast:.*]] = fir.emboxproc %[[f]] : ((!fir.ref<f32>) -> f32) -> !fir.boxproc<() -> ()>
!CHECK: fir.call @_QPfoo_acos(%[[fcast]]) : (!fir.boxproc<() -> ()>) -> ()
call foo_acos(acos)
end subroutine
! CHECK-LABEL: func @_QPtest_atan2
subroutine test_atan2()
intrinsic :: atan2
! CHECK: %[[f:.*]] = fir.address_of(@fir.atan2.f32.ref_f32.ref_f32) : (!fir.ref<f32>, !fir.ref<f32>) -> f32
! CHECK: %[[fcast:.*]] = fir.emboxproc %[[f]] : ((!fir.ref<f32>, !fir.ref<f32>) -> f32) -> !fir.boxproc<() -> ()>
! CHECK: fir.call @_QPfoo_atan2(%[[fcast]]) : (!fir.boxproc<() -> ()>) -> ()
call foo_atan2(atan2)
end subroutine
! Intrinsic implemented inlined
! CHECK-LABEL: func @_QPtest_aimag
subroutine test_aimag()
intrinsic :: aimag
!CHECK: %[[f:.*]] = fir.address_of(@fir.aimag.f32.ref_z4) : (!fir.ref<!fir.complex<4>>) -> f32
!CHECK: %[[fcast:.*]] = fir.emboxproc %[[f]] : ((!fir.ref<!fir.complex<4>>) -> f32) -> !fir.boxproc<() -> ()>
!CHECK: fir.call @_QPfoo_aimag(%[[fcast]]) : (!fir.boxproc<() -> ()>) -> ()
call foo_aimag(aimag)
end subroutine
! Character Intrinsic implemented inlined
! CHECK-LABEL: func @_QPtest_len
subroutine test_len()
intrinsic :: len
! CHECK: %[[f:.*]] = fir.address_of(@fir.len.i32.bc1) : (!fir.boxchar<1>) -> i32
! CHECK: %[[fcast:.*]] = fir.emboxproc %[[f]] : ((!fir.boxchar<1>) -> i32) -> !fir.boxproc<() -> ()>
!CHECK: fir.call @_QPfoo_len(%[[fcast]]) : (!fir.boxproc<() -> ()>) -> ()
call foo_len(len)
end subroutine
! Intrinsic implemented inlined with specific name different from generic
! CHECK-LABEL: func @_QPtest_iabs
subroutine test_iabs()
intrinsic :: iabs
! CHECK: %[[f:.*]] = fir.address_of(@fir.abs.i32.ref_i32) : (!fir.ref<i32>) -> i32
! CHECK: %[[fcast:.*]] = fir.emboxproc %[[f]] : ((!fir.ref<i32>) -> i32) -> !fir.boxproc<() -> ()>
! CHECK: fir.call @_QPfoo_iabs(%[[fcast]]) : (!fir.boxproc<() -> ()>) -> ()
call foo_iabs(iabs)
end subroutine
! TODO: exhaustive test of unrestricted intrinsic table 16.2
! TODO: improve dummy procedure types when interface is given.
! CHECK: func @_QPtodo3(
! CHECK-SAME: %{{.*}}: !fir.boxproc<() -> ()>{{.*}})
! SHOULD-CHECK: func @_QPtodo3(%arg0: (!fir.ref<f32>) -> f32)
subroutine todo3(dummy_proc)
intrinsic :: acos
procedure(acos) :: dummy_proc
end subroutine
! CHECK-LABEL: func private @fir.acos.f32.ref_f32(%arg0: !fir.ref<f32>) -> f32
!CHECK: %[[load:.*]] = fir.load %arg0
!CHECK: %[[res:.*]] = fir.call @__fs_acos_1(%[[load]]) : (f32) -> f32
!CHECK: return %[[res]] : f32
! CHECK-LABEL: func private @fir.atan2.f32.ref_f32.ref_f32(
! CHECK-SAME: %[[x:.*]]: !fir.ref<f32>, %[[y:.*]]: !fir.ref<f32>) -> f32
! CHECK-DAG: %[[xload:.*]] = fir.load %[[x]] : !fir.ref<f32>
! CHECK-DAG: %[[yload:.*]] = fir.load %[[y]] : !fir.ref<f32>
! CHECK: %[[atan2:.*]] = fir.call @__fs_atan2_1(%[[xload]], %[[yload]]) : (f32, f32) -> f32
! CHECK: return %[[atan2]] : f32
!CHECK-LABEL: func private @fir.aimag.f32.ref_z4(%arg0: !fir.ref<!fir.complex<4>>)
!CHECK: %[[load:.*]] = fir.load %arg0
!CHECK: %[[imag:.*]] = fir.extract_value %[[load]], [1 : index] : (!fir.complex<4>) -> f32
!CHECK: return %[[imag]] : f32
!CHECK-LABEL: func private @fir.len.i32.bc1(%arg0: !fir.boxchar<1>)
!CHECK: %[[unboxed:.*]]:2 = fir.unboxchar %arg0 : (!fir.boxchar<1>) -> (!fir.ref<!fir.char<1,?>>, index)
!CHECK: %[[len:.*]] = fir.convert %[[unboxed]]#1 : (index) -> i32
!CHECK: return %[[len]] : i32

559
flang/test/Lower/host-associated.f90
View File

@ -1,5 +1,5 @@
! Test internal procedure host association lowering.
! RUN: bbc %s -o - -emit-fir | FileCheck %s
! RUN: bbc %s -o - | FileCheck %s
! -----------------------------------------------------------------------------
! Test non character intrinsic scalars
@ -104,3 +104,560 @@ contains
c = "Hi there"
end subroutine test6_inner
end subroutine test6
! -----------------------------------------------------------------------------
! Test non allocatable and pointer arrays
! -----------------------------------------------------------------------------
! CHECK-LABEL: func @_QPtest3(
! CHECK-SAME: %[[p:[^:]+]]: !fir.box<!fir.array<?xf32>>{{.*}}, %[[q:.*]]: !fir.box<!fir.array<?xf32>>{{.*}}, %[[i:.*]]: !fir.ref<i64>
subroutine test3(p,q,i)
integer(8) :: i
real :: p(i:)
real :: q(:)
! CHECK: %[[iload:.*]] = fir.load %[[i]] : !fir.ref<i64>
! CHECK: %[[icast:.*]] = fir.convert %[[iload]] : (i64) -> index
! CHECK: %[[tup:.*]] = fir.alloca tuple<!fir.box<!fir.array<?xf32>>, !fir.box<!fir.array<?xf32>>>
! CHECK: %[[ptup:.*]] = fir.coordinate_of %[[tup]], %c0{{.*}} : (!fir.ref<tuple<!fir.box<!fir.array<?xf32>>, !fir.box<!fir.array<?xf32>>>>, i32) -> !fir.ref<!fir.box<!fir.array<?xf32>>>
! CHECK: %[[pshift:.*]] = fir.shift %[[icast]] : (index) -> !fir.shift<1>
! CHECK: %[[pbox:.*]] = fir.rebox %[[p]](%[[pshift]]) : (!fir.box<!fir.array<?xf32>>, !fir.shift<1>) -> !fir.box<!fir.array<?xf32>>
! CHECK: fir.store %[[pbox]] to %[[ptup]] : !fir.ref<!fir.box<!fir.array<?xf32>>>
! CHECK: %[[qtup:.*]] = fir.coordinate_of %[[tup]], %c1{{.*}} : (!fir.ref<tuple<!fir.box<!fir.array<?xf32>>, !fir.box<!fir.array<?xf32>>>>, i32) -> !fir.ref<!fir.box<!fir.array<?xf32>>>
! CHECK: %[[qbox:.*]] = fir.rebox %[[q]] : (!fir.box<!fir.array<?xf32>>) -> !fir.box<!fir.array<?xf32>>
! CHECK: fir.store %[[qbox]] to %[[qtup]] : !fir.ref<!fir.box<!fir.array<?xf32>>>
i = i + 1
q = -42.0
! CHECK: fir.call @_QFtest3Ptest3_inner(%[[tup]]) : (!fir.ref<tuple<!fir.box<!fir.array<?xf32>>, !fir.box<!fir.array<?xf32>>>>) -> ()
call test3_inner
if (p(2) .ne. -42.0) then
print *, "failed"
end if
contains
! CHECK-LABEL: func @_QFtest3Ptest3_inner(
! CHECK-SAME: %[[tup:.*]]: !fir.ref<tuple<!fir.box<!fir.array<?xf32>>, !fir.box<!fir.array<?xf32>>>> {fir.host_assoc}) {
subroutine test3_inner
! CHECK: %[[pcoor:.*]] = fir.coordinate_of %[[tup]], %c0{{.*}} : (!fir.ref<tuple<!fir.box<!fir.array<?xf32>>, !fir.box<!fir.array<?xf32>>>>, i32) -> !fir.ref<!fir.box<!fir.array<?xf32>>>
! CHECK: %[[p:.*]] = fir.load %[[pcoor]] : !fir.ref<!fir.box<!fir.array<?xf32>>>
! CHECK: %[[pbounds:.]]:3 = fir.box_dims %[[p]], %c0{{.*}} : (!fir.box<!fir.array<?xf32>>, index) -> (index, index, index)
! CHECK: %[[qcoor:.*]] = fir.coordinate_of %[[tup]], %c1{{.*}} : (!fir.ref<tuple<!fir.box<!fir.array<?xf32>>, !fir.box<!fir.array<?xf32>>>>, i32) -> !fir.ref<!fir.box<!fir.array<?xf32>>>
! CHECK: %[[q:.*]] = fir.load %[[qcoor]] : !fir.ref<!fir.box<!fir.array<?xf32>>>
! CHECK: %[[qbounds:.]]:3 = fir.box_dims %[[q]], %c0{{.*}} : (!fir.box<!fir.array<?xf32>>, index) -> (index, index, index)
! CHECK: %[[qlb:.*]] = fir.convert %[[qbounds]]#0 : (index) -> i64
! CHECK: %[[qoffset:.*]] = arith.subi %c1{{.*}}, %[[qlb]] : i64
! CHECK: %[[qelt:.*]] = fir.coordinate_of %[[q]], %[[qoffset]] : (!fir.box<!fir.array<?xf32>>, i64) -> !fir.ref<f32>
! CHECK: %[[qload:.*]] = fir.load %[[qelt]] : !fir.ref<f32>
! CHECK: %[[plb:.*]] = fir.convert %[[pbounds]]#0 : (index) -> i64
! CHECK: %[[poffset:.*]] = arith.subi %c2{{.*}}, %[[plb]] : i64
! CHECK: %[[pelt:.*]] = fir.coordinate_of %[[p]], %[[poffset]] : (!fir.box<!fir.array<?xf32>>, i64) -> !fir.ref<f32>
! CHECK: fir.store %[[qload]] to %[[pelt]] : !fir.ref<f32>
p(2) = q(1)
end subroutine test3_inner
end subroutine test3
! CHECK-LABEL: func @_QPtest3a(
! CHECK-SAME: %[[p:.*]]: !fir.ref<!fir.array<10xf32>>{{.*}}) {
subroutine test3a(p)
real :: p(10)
real :: q(10)
! CHECK: %[[q:.*]] = fir.alloca !fir.array<10xf32> {bindc_name = "q", uniq_name = "_QFtest3aEq"}
! CHECK: %[[tup:.*]] = fir.alloca tuple<!fir.box<!fir.array<10xf32>>, !fir.box<!fir.array<10xf32>>>
! CHECK: %[[ptup:.*]] = fir.coordinate_of %[[tup]], %c0{{.*}} : (!fir.ref<tuple<!fir.box<!fir.array<10xf32>>, !fir.box<!fir.array<10xf32>>>>, i32) -> !fir.ref<!fir.box<!fir.array<10xf32>>>
! CHECK: %[[shape:.*]] = fir.shape %c10{{.*}} : (index) -> !fir.shape<1>
! CHECK: %[[pbox:.*]] = fir.embox %[[p]](%[[shape]]) : (!fir.ref<!fir.array<10xf32>>, !fir.shape<1>) -> !fir.box<!fir.array<10xf32>>
! CHECK: fir.store %[[pbox]] to %[[ptup]] : !fir.ref<!fir.box<!fir.array<10xf32>>>
! CHECK: %[[qtup:.*]] = fir.coordinate_of %[[tup]], %c1{{.*}} : (!fir.ref<tuple<!fir.box<!fir.array<10xf32>>, !fir.box<!fir.array<10xf32>>>>, i32) -> !fir.ref<!fir.box<!fir.array<10xf32>>>
! CHECK: %[[qbox:.*]] = fir.embox %[[q]](%[[shape]]) : (!fir.ref<!fir.array<10xf32>>, !fir.shape<1>) -> !fir.box<!fir.array<10xf32>>
! CHECK: fir.store %[[qbox]] to %[[qtup]] : !fir.ref<!fir.box<!fir.array<10xf32>>>
q = -42.0
! CHECK: fir.call @_QFtest3aPtest3a_inner(%[[tup]]) : (!fir.ref<tuple<!fir.box<!fir.array<10xf32>>, !fir.box<!fir.array<10xf32>>>>) -> ()
call test3a_inner
if (p(1) .ne. -42.0) then
print *, "failed"
end if
contains
! CHECK: func @_QFtest3aPtest3a_inner(
! CHECK-SAME: %[[tup:.*]]: !fir.ref<tuple<!fir.box<!fir.array<10xf32>>, !fir.box<!fir.array<10xf32>>>> {fir.host_assoc}) {
subroutine test3a_inner
! CHECK: %[[pcoor:.*]] = fir.coordinate_of %[[tup]], %c0{{.*}} : (!fir.ref<tuple<!fir.box<!fir.array<10xf32>>, !fir.box<!fir.array<10xf32>>>>, i32) -> !fir.ref<!fir.box<!fir.array<10xf32>>>
! CHECK: %[[p:.*]] = fir.load %[[pcoor]] : !fir.ref<!fir.box<!fir.array<10xf32>>>
! CHECK: %[[paddr:.*]] = fir.box_addr %[[p]] : (!fir.box<!fir.array<10xf32>>) -> !fir.ref<!fir.array<10xf32>>
! CHECK: %[[qcoor:.*]] = fir.coordinate_of %[[tup]], %c1{{.*}} : (!fir.ref<tuple<!fir.box<!fir.array<10xf32>>, !fir.box<!fir.array<10xf32>>>>, i32) -> !fir.ref<!fir.box<!fir.array<10xf32>>>
! CHECK: %[[q:.*]] = fir.load %[[qcoor]] : !fir.ref<!fir.box<!fir.array<10xf32>>>
! CHECK: %[[qaddr:.*]] = fir.box_addr %[[q]] : (!fir.box<!fir.array<10xf32>>) -> !fir.ref<!fir.array<10xf32>>
! CHECK: %[[qelt:.*]] = fir.coordinate_of %[[qaddr]], %c0{{.*}} : (!fir.ref<!fir.array<10xf32>>, i64) -> !fir.ref<f32>
! CHECK: %[[qload:.*]] = fir.load %[[qelt]] : !fir.ref<f32>
! CHECK: %[[pelt:.*]] = fir.coordinate_of %[[paddr]], %c0{{.*}} : (!fir.ref<!fir.array<10xf32>>, i64) -> !fir.ref<f32>
! CHECK: fir.store %[[qload]] to %[[pelt]] : !fir.ref<f32>
p(1) = q(1)
end subroutine test3a_inner
end subroutine test3a
! -----------------------------------------------------------------------------
! Test allocatable and pointer scalars
! -----------------------------------------------------------------------------
! CHECK-LABEL: func @_QPtest4() {
subroutine test4
real, pointer :: p
real, allocatable, target :: ally
! CHECK: %[[ally:.*]] = fir.alloca !fir.box<!fir.heap<f32>> {bindc_name = "ally", fir.target, uniq_name = "_QFtest4Eally"}
! CHECK: %[[p:.*]] = fir.alloca !fir.box<!fir.ptr<f32>> {bindc_name = "p", uniq_name = "_QFtest4Ep"}
! CHECK: %[[tup:.*]] = fir.alloca tuple<!fir.ref<!fir.box<!fir.ptr<f32>>>, !fir.ref<!fir.box<!fir.heap<f32>>>>
! CHECK: %[[ptup:.*]] = fir.coordinate_of %[[tup]], %c0{{.*}} : (!fir.ref<tuple<!fir.ref<!fir.box<!fir.ptr<f32>>>, !fir.ref<!fir.box<!fir.heap<f32>>>>>, i32) -> !fir.llvm_ptr<!fir.ref<!fir.box<!fir.ptr<f32>>>>
! CHECK: fir.store %[[p]] to %[[ptup]] : !fir.llvm_ptr<!fir.ref<!fir.box<!fir.ptr<f32>>>>
! CHECK: %[[atup:.*]] = fir.coordinate_of %[[tup]], %c1{{.*}} : (!fir.ref<tuple<!fir.ref<!fir.box<!fir.ptr<f32>>>, !fir.ref<!fir.box<!fir.heap<f32>>>>>, i32) -> !fir.llvm_ptr<!fir.ref<!fir.box<!fir.heap<f32>>>>
! CHECK: fir.store %[[ally]] to %[[atup]] : !fir.llvm_ptr<!fir.ref<!fir.box<!fir.heap<f32>>>>
! CHECK: fir.call @_QFtest4Ptest4_inner(%[[tup]]) : (!fir.ref<tuple<!fir.ref<!fir.box<!fir.ptr<f32>>>, !fir.ref<!fir.box<!fir.heap<f32>>>>>) -> ()
allocate(ally)
ally = -42.0
call test4_inner
if (p .ne. -42.0) then
print *, "failed"
end if
contains
! CHECK-LABEL: func @_QFtest4Ptest4_inner(
! CHECK-SAME:%[[tup:.*]]: !fir.ref<tuple<!fir.ref<!fir.box<!fir.ptr<f32>>>, !fir.ref<!fir.box<!fir.heap<f32>>>>> {fir.host_assoc}) {
subroutine test4_inner
! CHECK: %[[ptup:.*]] = fir.coordinate_of %[[tup]], %c0{{.*}} : (!fir.ref<tuple<!fir.ref<!fir.box<!fir.ptr<f32>>>, !fir.ref<!fir.box<!fir.heap<f32>>>>>, i32) -> !fir.llvm_ptr<!fir.ref<!fir.box<!fir.ptr<f32>>>>
! CHECK: %[[p:.*]] = fir.load %[[ptup]] : !fir.llvm_ptr<!fir.ref<!fir.box<!fir.ptr<f32>>>>
! CHECK: %[[atup:.*]] = fir.coordinate_of %[[tup]], %c1{{.*}} : (!fir.ref<tuple<!fir.ref<!fir.box<!fir.ptr<f32>>>, !fir.ref<!fir.box<!fir.heap<f32>>>>>, i32) -> !fir.llvm_ptr<!fir.ref<!fir.box<!fir.heap<f32>>>>
! CHECK: %[[a:.*]] = fir.load %[[atup]] : !fir.llvm_ptr<!fir.ref<!fir.box<!fir.heap<f32>>>>
! CHECK: %[[abox:.*]] = fir.load %[[a]] : !fir.ref<!fir.box<!fir.heap<f32>>>
! CHECK: %[[addr:.*]] = fir.box_addr %[[abox]] : (!fir.box<!fir.heap<f32>>) -> !fir.heap<f32>
! CHECK: %[[ptr:.*]] = fir.embox %[[addr]] : (!fir.heap<f32>) -> !fir.box<!fir.ptr<f32>>
! CHECK: fir.store %[[ptr]] to %[[p]] : !fir.ref<!fir.box<!fir.ptr<f32>>>
p => ally
end subroutine test4_inner
end subroutine test4
! -----------------------------------------------------------------------------
! Test allocatable and pointer arrays
! -----------------------------------------------------------------------------
! CHECK-LABEL: func @_QPtest5() {
subroutine test5
real, pointer :: p(:)
real, allocatable, target :: ally(:)
! CHECK: %[[ally:.*]] = fir.alloca !fir.box<!fir.heap<!fir.array<?xf32>>> {bindc_name = "ally", fir.target
! CHECK: %[[p:.*]] = fir.alloca !fir.box<!fir.ptr<!fir.array<?xf32>>> {bindc_name = "p"
! CHECK: %[[tup:.*]] = fir.alloca tuple<!fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>, !fir.ref<!fir.box<!fir.heap<!fir.array<?xf32>>>>>
! CHECK: %[[ptup:.*]] = fir.coordinate_of %[[tup]], %c0{{.*}} : (!fir.ref<tuple<!fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>, !fir.ref<!fir.box<!fir.heap<!fir.array<?xf32>>>>>>, i32) -> !fir.llvm_ptr<!fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>>
! CHECK: fir.store %[[p]] to %[[ptup]] : !fir.llvm_ptr<!fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>>
! CHECK: %[[atup:.*]] = fir.coordinate_of %[[tup]], %c1{{.*}} : (!fir.ref<tuple<!fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>, !fir.ref<!fir.box<!fir.heap<!fir.array<?xf32>>>>>>, i32) -> !fir.llvm_ptr<!fir.ref<!fir.box<!fir.heap<!fir.array<?xf32>>>>>
! CHECK: fir.store %[[ally]] to %[[atup]] : !fir.llvm_ptr<!fir.ref<!fir.box<!fir.heap<!fir.array<?xf32>>>>>
! CHECK: fir.call @_QFtest5Ptest5_inner(%[[tup]]) : (!fir.ref<tuple<!fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>, !fir.ref<!fir.box<!fir.heap<!fir.array<?xf32>>>>>>) -> ()
allocate(ally(10))
ally = -42.0
call test5_inner
if (p(1) .ne. -42.0) then
print *, "failed"
end if
contains
! CHECK-LABEL: func @_QFtest5Ptest5_inner(
! CHECK-SAME:%[[tup:.*]]: !fir.ref<tuple<!fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>, !fir.ref<!fir.box<!fir.heap<!fir.array<?xf32>>>>>> {fir.host_assoc}) {
subroutine test5_inner
! CHECK: %[[ptup:.*]] = fir.coordinate_of %[[tup]], %c0{{.*}} : (!fir.ref<tuple<!fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>, !fir.ref<!fir.box<!fir.heap<!fir.array<?xf32>>>>>>, i32) -> !fir.llvm_ptr<!fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>>
! CHECK: %[[p:.*]] = fir.load %[[ptup]] : !fir.llvm_ptr<!fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>>
! CHECK: %[[atup:.*]] = fir.coordinate_of %[[tup]], %c1{{.*}} : (!fir.ref<tuple<!fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>, !fir.ref<!fir.box<!fir.heap<!fir.array<?xf32>>>>>>, i32) -> !fir.llvm_ptr<!fir.ref<!fir.box<!fir.heap<!fir.array<?xf32>>>>>
! CHECK: %[[a:.*]] = fir.load %[[atup]] : !fir.llvm_ptr<!fir.ref<!fir.box<!fir.heap<!fir.array<?xf32>>>>>
! CHECK: %[[abox:.*]] = fir.load %[[a]] : !fir.ref<!fir.box<!fir.heap<!fir.array<?xf32>>>>
! CHECK-DAG: %[[adims:.*]]:3 = fir.box_dims %[[abox]], %c0{{.*}} : (!fir.box<!fir.heap<!fir.array<?xf32>>>, index) -> (index, index, index)
! CHECK-DAG: %[[addr:.*]] = fir.box_addr %[[abox]] : (!fir.box<!fir.heap<!fir.array<?xf32>>>) -> !fir.heap<!fir.array<?xf32>>
! CHECK-DAG: %[[ashape:.*]] = fir.shape_shift %[[adims]]#0, %[[adims]]#1 : (index, index) -> !fir.shapeshift<1>
! CHECK: %[[ptr:.*]] = fir.embox %[[addr]](%[[ashape]]) : (!fir.heap<!fir.array<?xf32>>, !fir.shapeshift<1>) -> !fir.box<!fir.ptr<!fir.array<?xf32>>>
! CHECK: fir.store %[[ptr]] to %[[p]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>
p => ally
end subroutine test5_inner
end subroutine test5
! -----------------------------------------------------------------------------
! Test elemental internal procedure
! -----------------------------------------------------------------------------
! CHECK-LABEL: func @_QPtest7(
! CHECK-SAME: %[[j:.*]]: !fir.ref<i32>{{.*}}, %[[k:.*]]: !fir.box<!fir.array<?xi32>>
subroutine test7(j, k)
implicit none
integer :: j
integer :: k(:)
! CHECK: %[[tup:.*]] = fir.alloca tuple<!fir.ref<i32>>
! CHECK: %[[jtup:.*]] = fir.coordinate_of %[[tup]], %c0{{.*}} : (!fir.ref<tuple<!fir.ref<i32>>>, i32) -> !fir.llvm_ptr<!fir.ref<i32>>
! CHECK: fir.store %[[j]] to %[[jtup]] : !fir.llvm_ptr<!fir.ref<i32>>
! CHECK: %[[kelem:.*]] = fir.array_coor %[[k]] %{{.*}} : (!fir.box<!fir.array<?xi32>>, index) -> !fir.ref<i32>
! CHECK: fir.call @_QFtest7Ptest7_inner(%[[kelem]], %[[tup]]) : (!fir.ref<i32>, !fir.ref<tuple<!fir.ref<i32>>>) -> i32
k = test7_inner(k)
contains
! CHECK-LABEL: func @_QFtest7Ptest7_inner(
! CHECK-SAME: %[[i:.*]]: !fir.ref<i32>{{.*}}, %[[tup:.*]]: !fir.ref<tuple<!fir.ref<i32>>> {fir.host_assoc}) -> i32 {
elemental integer function test7_inner(i)
implicit none
integer, intent(in) :: i
! CHECK: %[[jtup:.*]] = fir.coordinate_of %[[tup]], %c0{{.*}} : (!fir.ref<tuple<!fir.ref<i32>>>, i32) -> !fir.llvm_ptr<!fir.ref<i32>>
! CHECK: %[[jptr:.*]] = fir.load %[[jtup]] : !fir.llvm_ptr<!fir.ref<i32>>
! CHECK-DAG: %[[iload:.*]] = fir.load %[[i]] : !fir.ref<i32>
! CHECK-DAG: %[[jload:.*]] = fir.load %[[jptr]] : !fir.ref<i32>
! CHECK: addi %[[iload]], %[[jload]] : i32
test7_inner = i + j
end function
end subroutine
subroutine issue990()
! Test that host symbols used in statement functions inside an internal
! procedure are correctly captured from the host.
implicit none
integer :: captured
call bar()
contains
! CHECK-LABEL: func @_QFissue990Pbar(
! CHECK-SAME: %[[tup:.*]]: !fir.ref<tuple<!fir.ref<i32>>> {fir.host_assoc}) {
subroutine bar()
integer :: stmt_func, i
stmt_func(i) = i + captured
! CHECK: %[[tupAddr:.*]] = fir.coordinate_of %[[tup]], %c0{{.*}} : (!fir.ref<tuple<!fir.ref<i32>>>, i32) -> !fir.llvm_ptr<!fir.ref<i32>>
! CHECK: %[[addr:.*]] = fir.load %[[tupAddr]] : !fir.llvm_ptr<!fir.ref<i32>>
! CHECK: %[[value:.*]] = fir.load %[[addr]] : !fir.ref<i32>
! CHECK: arith.addi %{{.*}}, %[[value]] : i32
print *, stmt_func(10)
end subroutine
end subroutine
subroutine issue990b()
! Test when an internal procedure uses a statement function from its host
! which uses host variables that are otherwise not used by the internal
! procedure.
implicit none
integer :: captured, captured_stmt_func, i
captured_stmt_func(i) = i + captured
call bar()
contains
! CHECK-LABEL: func @_QFissue990bPbar(
! CHECK-SAME: %[[tup:.*]]: !fir.ref<tuple<!fir.ref<i32>>> {fir.host_assoc}) {
subroutine bar()
! CHECK: %[[tupAddr:.*]] = fir.coordinate_of %[[tup]], %c0{{.*}} : (!fir.ref<tuple<!fir.ref<i32>>>, i32) -> !fir.llvm_ptr<!fir.ref<i32>>
! CHECK: %[[addr:.*]] = fir.load %[[tupAddr]] : !fir.llvm_ptr<!fir.ref<i32>>
! CHECK: %[[value:.*]] = fir.load %[[addr]] : !fir.ref<i32>
! CHECK: arith.addi %{{.*}}, %[[value]] : i32
print *, captured_stmt_func(10)
end subroutine
end subroutine
! Test capture of dummy procedure functions.
subroutine test8(dummy_proc)
implicit none
interface
real function dummy_proc(x)
real :: x
end function
end interface
call bar()
contains
! CHECK-LABEL: func @_QFtest8Pbar(
! CHECK-SAME: %[[tup:.*]]: !fir.ref<tuple<!fir.boxproc<() -> ()>>> {fir.host_assoc}) {
subroutine bar()
! CHECK: %[[tupAddr:.*]] = fir.coordinate_of %[[tup]], %c0{{.*}} : (!fir.ref<tuple<!fir.boxproc<() -> ()>>>, i32) -> !fir.ref<!fir.boxproc<() -> ()>>
! CHECK: %[[dummyProc:.*]] = fir.load %[[tupAddr]] : !fir.ref<!fir.boxproc<() -> ()>>
! CHECK: %[[dummyProcCast:.*]] = fir.box_addr %[[dummyProc]] : (!fir.boxproc<() -> ()>) -> ((!fir.ref<f32>) -> f32)
! CHECK: fir.call %[[dummyProcCast]](%{{.*}}) : (!fir.ref<f32>) -> f32
print *, dummy_proc(42.)
end subroutine
end subroutine
! Test capture of dummy subroutines.
subroutine test9(dummy_proc)
implicit none
interface
subroutine dummy_proc()
end subroutine
end interface
call bar()
contains
! CHECK-LABEL: func @_QFtest9Pbar(
! CHECK-SAME: %[[tup:.*]]: !fir.ref<tuple<!fir.boxproc<() -> ()>>> {fir.host_assoc}) {
subroutine bar()
! CHECK: %[[tupAddr:.*]] = fir.coordinate_of %[[tup]], %c0{{.*}} : (!fir.ref<tuple<!fir.boxproc<() -> ()>>>, i32) -> !fir.ref<!fir.boxproc<() -> ()>>
! CHECK: %[[dummyProc:.*]] = fir.load %[[tupAddr]] : !fir.ref<!fir.boxproc<() -> ()>>
! CHECK: %[[pa:.*]] = fir.box_addr %[[dummyProc]]
! CHECK: fir.call %[[pa]]() : () -> ()
call dummy_proc()
end subroutine
end subroutine
! Test capture of namelist
! CHECK-LABEL: func @_QPtest10(
! CHECK-SAME: %[[i:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.array<?xi32>>>>{{.*}}) {
subroutine test10(i)
implicit none
integer, pointer :: i(:)
namelist /a_namelist/ i
! CHECK: %[[tupAddr:.*]] = fir.coordinate_of %[[tup:.*]], %c0{{.*}} : (!fir.ref<tuple<!fir.ref<!fir.box<!fir.ptr<!fir.array<?xi32>>>>>>, i32) -> !fir.llvm_ptr<!fir.ref<!fir.box<!fir.ptr<!fir.array<?xi32>>>>>
! CHECK: fir.store %[[i]] to %[[tupAddr]] : !fir.llvm_ptr<!fir.ref<!fir.box<!fir.ptr<!fir.array<?xi32>>>>>
! CHECK: fir.call @_QFtest10Pbar(%[[tup]]) : (!fir.ref<tuple<!fir.ref<!fir.box<!fir.ptr<!fir.array<?xi32>>>>>>) -> ()
call bar()
contains
! CHECK-LABEL: func @_QFtest10Pbar(
! CHECK-SAME: %[[tup:.*]]: !fir.ref<tuple<!fir.ref<!fir.box<!fir.ptr<!fir.array<?xi32>>>>>> {fir.host_assoc}) {
subroutine bar()
! CHECK: %[[tupAddr:.*]] = fir.coordinate_of %[[tup]], %c0{{.*}} : (!fir.ref<tuple<!fir.ref<!fir.box<!fir.ptr<!fir.array<?xi32>>>>>>, i32) -> !fir.llvm_ptr<!fir.ref<!fir.box<!fir.ptr<!fir.array<?xi32>>>>>
! CHECK: fir.load %[[tupAddr]] : !fir.llvm_ptr<!fir.ref<!fir.box<!fir.ptr<!fir.array<?xi32>>>>>
read (88, NML = a_namelist)
end subroutine
end subroutine
! Test passing an internal procedure as a dummy argument.
! CHECK-LABEL: func @_QPtest_proc_dummy() {
! CHECK: %[[VAL_4:.*]] = fir.alloca i32 {bindc_name = "i", uniq_name = "_QFtest_proc_dummyEi"}
! CHECK: %[[VAL_5:.*]] = fir.alloca tuple<!fir.ref<i32>>
! CHECK: %[[VAL_7:.*]] = fir.address_of(@_QFtest_proc_dummyPtest_proc_dummy_a) : (!fir.ref<i32>, !fir.ref<tuple<!fir.ref<i32>>>) -> ()
! CHECK: %[[VAL_8:.*]] = fir.emboxproc %[[VAL_7]], %[[VAL_5]] : ((!fir.ref<i32>, !fir.ref<tuple<!fir.ref<i32>>>) -> (), !fir.ref<tuple<!fir.ref<i32>>>) -> !fir.boxproc<() -> ()>
! CHECK: fir.call @_QPtest_proc_dummy_other(%[[VAL_8]]) : (!fir.boxproc<() -> ()>) -> ()
! CHECK-LABEL: func @_QFtest_proc_dummyPtest_proc_dummy_a(
! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref<i32> {fir.bindc_name = "j"},
! CHECK-SAME: %[[VAL_1:.*]]: !fir.ref<tuple<!fir.ref<i32>>> {fir.host_assoc}) {
! CHECK: %[[VAL_2:.*]] = arith.constant 0 : i32
! CHECK: %[[VAL_3:.*]] = fir.coordinate_of %[[VAL_1]], %[[VAL_2]] : (!fir.ref<tuple<!fir.ref<i32>>>, i32) -> !fir.llvm_ptr<!fir.ref<i32>>
! CHECK: %[[VAL_4:.*]] = fir.load %[[VAL_3]] : !fir.llvm_ptr<!fir.ref<i32>>
! CHECK: %[[VAL_5:.*]] = fir.load %[[VAL_4]] : !fir.ref<i32>
! CHECK: %[[VAL_6:.*]] = fir.load %[[VAL_0]] : !fir.ref<i32>
! CHECK: %[[VAL_7:.*]] = arith.addi %[[VAL_5]], %[[VAL_6]] : i32
! CHECK: fir.store %[[VAL_7]] to %[[VAL_4]] : !fir.ref<i32>
! CHECK: return
! CHECK: }
! CHECK-LABEL: func @_QPtest_proc_dummy_other(
! CHECK-SAME: %[[VAL_0:.*]]: !fir.boxproc<() -> ()>) {
! CHECK: %[[VAL_1:.*]] = arith.constant 4 : i32
! CHECK: %[[VAL_2:.*]] = fir.alloca i32 {adapt.valuebyref}
! CHECK: fir.store %[[VAL_1]] to %[[VAL_2]] : !fir.ref<i32>
! CHECK: %[[VAL_3:.*]] = fir.box_addr %[[VAL_0]] : (!fir.boxproc<() -> ()>) -> ((!fir.ref<i32>) -> ())
! CHECK: fir.call %[[VAL_3]](%[[VAL_2]]) : (!fir.ref<i32>) -> ()
! CHECK: return
! CHECK: }
subroutine test_proc_dummy
integer i
i = 1
call test_proc_dummy_other(test_proc_dummy_a)
print *, i
contains
subroutine test_proc_dummy_a(j)
i = i + j
end subroutine test_proc_dummy_a
end subroutine test_proc_dummy
subroutine test_proc_dummy_other(proc)
call proc(4)
end subroutine test_proc_dummy_other
! CHECK-LABEL: func @_QPtest_proc_dummy_char() {
! CHECK-DAG: %[[VAL_0:.*]] = arith.constant 10 : index
! CHECK-DAG: %[[VAL_1:.*]] = arith.constant 0 : i32
! CHECK-DAG: %[[VAL_2:.*]] = arith.constant 9 : index
! CHECK-DAG: %[[VAL_3:.*]] = arith.constant false
! CHECK-DAG: %[[VAL_4:.*]] = arith.constant 1 : index
! CHECK-DAG: %[[VAL_5:.*]] = arith.constant 32 : i8
! CHECK-DAG: %[[VAL_6:.*]] = arith.constant -1 : i32
! CHECK-DAG: %[[VAL_8:.*]] = arith.constant 10 : i64
! CHECK-DAG: %[[VAL_9:.*]] = arith.constant 40 : index
! CHECK-DAG: %[[VAL_10:.*]] = arith.constant 0 : index
! CHECK: %[[VAL_11:.*]] = fir.alloca !fir.char<1,40> {bindc_name = ".result"}
! CHECK: %[[VAL_12:.*]] = fir.alloca !fir.char<1,10> {bindc_name = "message", uniq_name = "_QFtest_proc_dummy_charEmessage"}
! CHECK: %[[VAL_13:.*]] = fir.alloca tuple<!fir.boxchar<1>>
! CHECK: %[[VAL_14:.*]] = fir.coordinate_of %[[VAL_13]], %[[VAL_1]] : (!fir.ref<tuple<!fir.boxchar<1>>>, i32) -> !fir.ref<!fir.boxchar<1>>
! CHECK: %[[VAL_15:.*]] = fir.convert %[[VAL_12]] : (!fir.ref<!fir.char<1,10>>) -> !fir.ref<!fir.char<1,?>>
! CHECK: %[[VAL_16:.*]] = fir.emboxchar %[[VAL_15]], %[[VAL_0]] : (!fir.ref<!fir.char<1,?>>, index) -> !fir.boxchar<1>
! CHECK: fir.store %[[VAL_16]] to %[[VAL_14]] : !fir.ref<!fir.boxchar<1>>
! CHECK: %[[VAL_17:.*]] = fir.address_of(@_QQcl.{{.*}}) : !fir.ref<!fir.char<1,9>>
! CHECK: %[[VAL_18:.*]] = fir.convert %[[VAL_2]] : (index) -> i64
! CHECK: %[[VAL_19:.*]] = fir.convert %[[VAL_12]] : (!fir.ref<!fir.char<1,10>>) -> !fir.ref<i8>
! CHECK: %[[VAL_20:.*]] = fir.convert %[[VAL_17]] : (!fir.ref<!fir.char<1,9>>) -> !fir.ref<i8>
! CHECK: fir.call @llvm.memmove.p0i8.p0i8.i64(%[[VAL_19]], %[[VAL_20]], %[[VAL_18]], %[[VAL_3]]) : (!fir.ref<i8>, !fir.ref<i8>, i64, i1) -> ()
! CHECK: %[[VAL_21:.*]] = fir.undefined !fir.char<1>
! CHECK: %[[VAL_22:.*]] = fir.insert_value %[[VAL_21]], %[[VAL_5]], [0 : index] : (!fir.char<1>, i8) -> !fir.char<1>
! CHECK: br ^bb1(%[[VAL_2]], %[[VAL_4]] : index, index)
! CHECK: ^bb1(%[[VAL_23:.*]]: index, %[[VAL_24:.*]]: index):
! CHECK: %[[VAL_25:.*]] = arith.cmpi sgt, %[[VAL_24]], %[[VAL_10]] : index
! CHECK: cond_br %[[VAL_25]], ^bb2, ^bb3
! CHECK: ^bb2:
! CHECK: %[[VAL_26:.*]] = fir.convert %[[VAL_12]] : (!fir.ref<!fir.char<1,10>>) -> !fir.ref<!fir.array<10x!fir.char<1>>>
! CHECK: %[[VAL_27:.*]] = fir.coordinate_of %[[VAL_26]], %[[VAL_23]] : (!fir.ref<!fir.array<10x!fir.char<1>>>, index) -> !fir.ref<!fir.char<1>>
! CHECK: fir.store %[[VAL_22]] to %[[VAL_27]] : !fir.ref<!fir.char<1>>
! CHECK: %[[VAL_28:.*]] = arith.addi %[[VAL_23]], %[[VAL_4]] : index
! CHECK: %[[VAL_29:.*]] = arith.subi %[[VAL_24]], %[[VAL_4]] : index
! CHECK: br ^bb1(%[[VAL_28]], %[[VAL_29]] : index, index)
! CHECK: ^bb3:
! CHECK: %[[VAL_30:.*]] = fir.address_of(@_QQcl.{{.*}}) : !fir.ref<!fir.char<1,
! CHECK: %[[VAL_31:.*]] = fir.convert %[[VAL_30]] : (!fir.ref<!fir.char<1,{{.*}}>>) -> !fir.ref<i8>
! CHECK: %[[VAL_32:.*]] = fir.call @_FortranAioBeginExternalListOutput(%[[VAL_6]], %[[VAL_31]], %{{.*}}) : (i32, !fir.ref<i8>, i32) -> !fir.ref<i8>
! CHECK: %[[VAL_33:.*]] = fir.address_of(@_QFtest_proc_dummy_charPgen_message) : (!fir.ref<!fir.char<1,10>>, index, !fir.ref<tuple<!fir.boxchar<1>>>) -> !fir.boxchar<1>
! CHECK: %[[VAL_34:.*]] = fir.emboxproc %[[VAL_33]], %[[VAL_13]] : ((!fir.ref<!fir.char<1,10>>, index, !fir.ref<tuple<!fir.boxchar<1>>>) -> !fir.boxchar<1>, !fir.ref<tuple<!fir.boxchar<1>>>) -> !fir.boxproc<() -> ()>
! CHECK: %[[VAL_35:.*]] = fir.undefined tuple<!fir.boxproc<() -> ()>, i64>
! CHECK: %[[VAL_36:.*]] = fir.insert_value %[[VAL_35]], %[[VAL_34]], [0 : index] : (tuple<!fir.boxproc<() -> ()>, i64>, !fir.boxproc<() -> ()>) -> tuple<!fir.boxproc<() -> ()>, i64>
! CHECK: %[[VAL_37:.*]] = fir.insert_value %[[VAL_36]], %[[VAL_8]], [1 : index] : (tuple<!fir.boxproc<() -> ()>, i64>, i64) -> tuple<!fir.boxproc<() -> ()>, i64>
! CHECK: %[[VAL_38:.*]] = fir.call @llvm.stacksave() : () -> !fir.ref<i8>
! CHECK: %[[VAL_39:.*]] = fir.call @_QPget_message(%[[VAL_11]], %[[VAL_9]], %[[VAL_37]]) : (!fir.ref<!fir.char<1,40>>, index, tuple<!fir.boxproc<() -> ()>, i64>) -> !fir.boxchar<1>
! CHECK: %[[VAL_40:.*]] = fir.convert %[[VAL_11]] : (!fir.ref<!fir.char<1,40>>) -> !fir.ref<i8>
! CHECK: %[[VAL_41:.*]] = fir.convert %[[VAL_9]] : (index) -> i64
! CHECK: %[[VAL_42:.*]] = fir.call @_FortranAioOutputAscii(%[[VAL_32]], %[[VAL_40]], %[[VAL_41]]) : (!fir.ref<i8>, !fir.ref<i8>, i64) -> i1
! CHECK: fir.call @llvm.stackrestore(%[[VAL_38]]) : (!fir.ref<i8>) -> ()
! CHECK: %[[VAL_43:.*]] = fir.call @_FortranAioEndIoStatement(%[[VAL_32]]) : (!fir.ref<i8>) -> i32
! CHECK: return
! CHECK: }
! CHECK-LABEL: func @_QFtest_proc_dummy_charPgen_message(
! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref<!fir.char<1,10>>,
! CHECK-SAME: %[[VAL_1:.*]]: index,
! CHECK-SAME: %[[VAL_2:.*]]: !fir.ref<tuple<!fir.boxchar<1>>> {fir.host_assoc}) -> !fir.boxchar<1> {
! CHECK-DAG: %[[VAL_3:.*]] = arith.constant 0 : i32
! CHECK-DAG: %[[VAL_4:.*]] = arith.constant 10 : index
! CHECK-DAG: %[[VAL_5:.*]] = arith.constant false
! CHECK-DAG: %[[VAL_6:.*]] = arith.constant 1 : index
! CHECK-DAG: %[[VAL_7:.*]] = arith.constant 32 : i8
! CHECK-DAG: %[[VAL_8:.*]] = arith.constant 0 : index
! CHECK: %[[VAL_9:.*]] = fir.coordinate_of %[[VAL_2]], %[[VAL_3]] : (!fir.ref<tuple<!fir.boxchar<1>>>, i32) -> !fir.ref<!fir.boxchar<1>>
! CHECK: %[[VAL_10:.*]] = fir.load %[[VAL_9]] : !fir.ref<!fir.boxchar<1>>
! CHECK: %[[VAL_11:.*]]:2 = fir.unboxchar %[[VAL_10]] : (!fir.boxchar<1>) -> (!fir.ref<!fir.char<1,?>>, index)
! CHECK: %[[VAL_12:.*]] = fir.convert %[[VAL_0]] : (!fir.ref<!fir.char<1,10>>) -> !fir.ref<!fir.char<1,?>>
! CHECK: %[[VAL_13:.*]] = arith.cmpi slt, %[[VAL_4]], %[[VAL_11]]#1 : index
! CHECK: %[[VAL_14:.*]] = arith.select %[[VAL_13]], %[[VAL_4]], %[[VAL_11]]#1 : index
! CHECK: %[[VAL_15:.*]] = fir.convert %[[VAL_14]] : (index) -> i64
! CHECK: %[[VAL_16:.*]] = fir.convert %[[VAL_12]] : (!fir.ref<!fir.char<1,?>>) -> !fir.ref<i8>
! CHECK: %[[VAL_17:.*]] = fir.convert %[[VAL_11]]#0 : (!fir.ref<!fir.char<1,?>>) -> !fir.ref<i8>
! CHECK: fir.call @llvm.memmove.p0i8.p0i8.i64(%[[VAL_16]], %[[VAL_17]], %[[VAL_15]], %[[VAL_5]]) : (!fir.ref<i8>, !fir.ref<i8>, i64, i1) -> ()
! CHECK: %[[VAL_18:.*]] = fir.undefined !fir.char<1>
! CHECK: %[[VAL_19:.*]] = fir.insert_value %[[VAL_18]], %[[VAL_7]], [0 : index] : (!fir.char<1>, i8) -> !fir.char<1>
! CHECK: %[[VAL_20:.*]] = arith.subi %[[VAL_4]], %[[VAL_14]] : index
! CHECK: br ^bb1(%[[VAL_14]], %[[VAL_20]] : index, index)
! CHECK: ^bb1(%[[VAL_21:.*]]: index, %[[VAL_22:.*]]: index):
! CHECK: %[[VAL_23:.*]] = arith.cmpi sgt, %[[VAL_22]], %[[VAL_8]] : index
! CHECK: cond_br %[[VAL_23]], ^bb2, ^bb3
! CHECK: ^bb2:
! CHECK: %[[VAL_24:.*]] = fir.convert %[[VAL_12]] : (!fir.ref<!fir.char<1,?>>) -> !fir.ref<!fir.array<?x!fir.char<1>>>
! CHECK: %[[VAL_25:.*]] = fir.coordinate_of %[[VAL_24]], %[[VAL_21]] : (!fir.ref<!fir.array<?x!fir.char<1>>>, index) -> !fir.ref<!fir.char<1>>
! CHECK: fir.store %[[VAL_19]] to %[[VAL_25]] : !fir.ref<!fir.char<1>>
! CHECK: %[[VAL_26:.*]] = arith.addi %[[VAL_21]], %[[VAL_6]] : index
! CHECK: %[[VAL_27:.*]] = arith.subi %[[VAL_22]], %[[VAL_6]] : index
! CHECK: br ^bb1(%[[VAL_26]], %[[VAL_27]] : index, index)
! CHECK: ^bb3:
! CHECK: %[[VAL_28:.*]] = fir.emboxchar %[[VAL_12]], %[[VAL_4]] : (!fir.ref<!fir.char<1,?>>, index) -> !fir.boxchar<1>
! CHECK: return %[[VAL_28]] : !fir.boxchar<1>
! CHECK: }
! CHECK-LABEL: func @_QPget_message(
! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref<!fir.char<1,40>>,
! CHECK-SAME: %[[VAL_1:.*]]: index,
! CHECK-SAME: %[[VAL_2:.*]]: tuple<!fir.boxproc<() -> ()>, i64> {fir.char_proc}) -> !fir.boxchar<1> {
! CHECK: %[[VAL_3:.*]] = arith.constant 40 : index
! CHECK: %[[VAL_4:.*]] = arith.constant 12 : index
! CHECK: %[[VAL_5:.*]] = arith.constant false
! CHECK: %[[VAL_6:.*]] = arith.constant 1 : index
! CHECK: %[[VAL_7:.*]] = arith.constant 32 : i8
! CHECK: %[[VAL_8:.*]] = arith.constant 0 : index
! CHECK: %[[VAL_9:.*]] = fir.convert %[[VAL_0]] : (!fir.ref<!fir.char<1,40>>) -> !fir.ref<!fir.char<1,?>>
! CHECK: %[[VAL_10:.*]] = fir.address_of(@_QQcl.{{.*}}) : !fir.ref<!fir.char<1,12>>
! CHECK: %[[VAL_11:.*]] = fir.extract_value %[[VAL_2]], [0 : index] : (tuple<!fir.boxproc<() -> ()>, i64>) -> !fir.boxproc<() -> ()>
! CHECK: %[[VAL_12:.*]] = fir.box_addr %[[VAL_11]] : (!fir.boxproc<() -> ()>) -> (() -> ())
! CHECK: %[[VAL_13:.*]] = fir.extract_value %[[VAL_2]], [1 : index] : (tuple<!fir.boxproc<() -> ()>, i64>) -> i64
! CHECK: %[[VAL_14:.*]] = fir.call @llvm.stacksave() : () -> !fir.ref<i8>
! CHECK: %[[VAL_15:.*]] = fir.alloca !fir.char<1,?>(%[[VAL_13]] : i64) {bindc_name = ".result"}
! CHECK: %[[VAL_16:.*]] = fir.convert %[[VAL_12]] : (() -> ()) -> ((!fir.ref<!fir.char<1,?>>, index) -> !fir.boxchar<1>)
! CHECK: %[[VAL_17:.*]] = fir.convert %[[VAL_13]] : (i64) -> index
! CHECK: %[[VAL_18:.*]] = fir.call %[[VAL_16]](%[[VAL_15]], %[[VAL_17]]) : (!fir.ref<!fir.char<1,?>>, index) -> !fir.boxchar<1>
! CHECK: %[[VAL_19:.*]] = arith.addi %[[VAL_17]], %[[VAL_4]] : index
! CHECK: %[[VAL_20:.*]] = fir.alloca !fir.char<1,?>(%[[VAL_19]] : index) {bindc_name = ".chrtmp"}
! CHECK: %[[VAL_21:.*]] = fir.convert %[[VAL_4]] : (index) -> i64
! CHECK: %[[VAL_22:.*]] = fir.convert %[[VAL_20]] : (!fir.ref<!fir.char<1,?>>) -> !fir.ref<i8>
! CHECK: %[[VAL_23:.*]] = fir.convert %[[VAL_10]] : (!fir.ref<!fir.char<1,12>>) -> !fir.ref<i8>
! CHECK: fir.call @llvm.memmove.p0i8.p0i8.i64(%[[VAL_22]], %[[VAL_23]], %[[VAL_21]], %[[VAL_5]]) : (!fir.ref<i8>, !fir.ref<i8>, i64, i1) -> ()
! CHECK: br ^bb1(%[[VAL_4]], %[[VAL_17]] : index, index)
! CHECK: ^bb1(%[[VAL_24:.*]]: index, %[[VAL_25:.*]]: index):
! CHECK: %[[VAL_26:.*]] = arith.cmpi sgt, %[[VAL_25]], %[[VAL_8]] : index
! CHECK: cond_br %[[VAL_26]], ^bb2, ^bb3
! CHECK: ^bb2:
! CHECK: %[[VAL_27:.*]] = arith.subi %[[VAL_24]], %[[VAL_4]] : index
! CHECK: %[[VAL_28:.*]] = fir.convert %[[VAL_15]] : (!fir.ref<!fir.char<1,?>>) -> !fir.ref<!fir.array<?x!fir.char<1>>>
! CHECK: %[[VAL_29:.*]] = fir.coordinate_of %[[VAL_28]], %[[VAL_27]] : (!fir.ref<!fir.array<?x!fir.char<1>>>, index) -> !fir.ref<!fir.char<1>>
! CHECK: %[[VAL_30:.*]] = fir.load %[[VAL_29]] : !fir.ref<!fir.char<1>>
! CHECK: %[[VAL_31:.*]] = fir.convert %[[VAL_20]] : (!fir.ref<!fir.char<1,?>>) -> !fir.ref<!fir.array<?x!fir.char<1>>>
! CHECK: %[[VAL_32:.*]] = fir.coordinate_of %[[VAL_31]], %[[VAL_24]] : (!fir.ref<!fir.array<?x!fir.char<1>>>, index) -> !fir.ref<!fir.char<1>>
! CHECK: fir.store %[[VAL_30]] to %[[VAL_32]] : !fir.ref<!fir.char<1>>
! CHECK: %[[VAL_33:.*]] = arith.addi %[[VAL_24]], %[[VAL_6]] : index
! CHECK: %[[VAL_34:.*]] = arith.subi %[[VAL_25]], %[[VAL_6]] : index
! CHECK: br ^bb1(%[[VAL_33]], %[[VAL_34]] : index, index)
! CHECK: ^bb3:
! CHECK: %[[VAL_35:.*]] = arith.cmpi slt, %[[VAL_3]], %[[VAL_19]] : index
! CHECK: %[[VAL_36:.*]] = arith.select %[[VAL_35]], %[[VAL_3]], %[[VAL_19]] : index
! CHECK: %[[VAL_37:.*]] = fir.convert %[[VAL_36]] : (index) -> i64
! CHECK: %[[VAL_38:.*]] = fir.convert %[[VAL_9]] : (!fir.ref<!fir.char<1,?>>) -> !fir.ref<i8>
! CHECK: fir.call @llvm.memmove.p0i8.p0i8.i64(%[[VAL_38]], %[[VAL_22]], %[[VAL_37]], %[[VAL_5]]) : (!fir.ref<i8>, !fir.ref<i8>, i64, i1) -> ()
! CHECK: %[[VAL_39:.*]] = fir.undefined !fir.char<1>
! CHECK: %[[VAL_40:.*]] = fir.insert_value %[[VAL_39]], %[[VAL_7]], [0 : index] : (!fir.char<1>, i8) -> !fir.char<1>
! CHECK: %[[VAL_41:.*]] = arith.subi %[[VAL_3]], %[[VAL_36]] : index
! CHECK: br ^bb4(%[[VAL_36]], %[[VAL_41]] : index, index)
! CHECK: ^bb4(%[[VAL_42:.*]]: index, %[[VAL_43:.*]]: index):
! CHECK: %[[VAL_44:.*]] = arith.cmpi sgt, %[[VAL_43]], %[[VAL_8]] : index
! CHECK: cond_br %[[VAL_44]], ^bb5, ^bb6
! CHECK: ^bb5:
! CHECK: %[[VAL_45:.*]] = fir.convert %[[VAL_9]] : (!fir.ref<!fir.char<1,?>>) -> !fir.ref<!fir.array<?x!fir.char<1>>>
! CHECK: %[[VAL_46:.*]] = fir.coordinate_of %[[VAL_45]], %[[VAL_42]] : (!fir.ref<!fir.array<?x!fir.char<1>>>, index) -> !fir.ref<!fir.char<1>>
! CHECK: fir.store %[[VAL_40]] to %[[VAL_46]] : !fir.ref<!fir.char<1>>
! CHECK: %[[VAL_47:.*]] = arith.addi %[[VAL_42]], %[[VAL_6]] : index
! CHECK: %[[VAL_48:.*]] = arith.subi %[[VAL_43]], %[[VAL_6]] : index
! CHECK: br ^bb4(%[[VAL_47]], %[[VAL_48]] : index, index)
! CHECK: ^bb6:
! CHECK: fir.call @llvm.stackrestore(%[[VAL_14]]) : (!fir.ref<i8>) -> ()
! CHECK: %[[VAL_49:.*]] = fir.emboxchar %[[VAL_9]], %[[VAL_3]] : (!fir.ref<!fir.char<1,?>>, index) -> !fir.boxchar<1>
! CHECK: return %[[VAL_49]] : !fir.boxchar<1>
! CHECK: }
subroutine test_proc_dummy_char
character(40) get_message
external get_message
character(10) message
message = "Hi there!"
print *, get_message(gen_message)
contains
function gen_message
character(10) :: gen_message
gen_message = message
end function gen_message
end subroutine test_proc_dummy_char
function get_message(a)
character(40) :: get_message
character(*) :: a
get_message = "message is: " // a()
end function get_message
! CHECK-LABEL: func @_QPtest_11a() {
! CHECK: %[[a:.*]] = fir.address_of(@_QPtest_11b) : () -> ()
! CHECK: %[[b:.*]] = fir.emboxproc %[[a]] : (() -> ()) -> !fir.boxproc<() -> ()>
! CHECK: fir.call @_QPtest_11c(%[[b]], %{{.*}}) : (!fir.boxproc<() -> ()>, !fir.ref<i32>) -> ()
! CHECK: func private @_QPtest_11c(!fir.boxproc<() -> ()>, !fir.ref<i32>)
subroutine test_11a
external test_11b
call test_11c(test_11b, 3)
end subroutine test_11a

60
flang/test/Lower/procedure-declarations.f90
View File

@ -11,6 +11,13 @@
! since definition should be processed first regardless.
! pass, call, define
! CHECK-LABEL: func @_QPpass_foo() {
subroutine pass_foo()
external :: foo
! CHECK: %[[f:.*]] = fir.address_of(@_QPfoo)
! CHECK: fir.emboxproc %[[f]] : ((!fir.ref<!fir.array<2x5xi32>>) -> ()) -> !fir.boxproc<() -> ()>
call bar(foo)
end subroutine
! CHECK-LABEL: func @_QPcall_foo(
! CHECK-SAME: %{{.*}}: !fir.ref<!fir.array<10xi32>>{{.*}}) {
subroutine call_foo(i)
@ -35,6 +42,13 @@ subroutine call_foo2(i)
! fir.call @_QPfoo2(%[[argconvert]]) : (!fir.ref<!fir.array<2x5xi32>>) -> ()
call foo2(i)
end subroutine
! CHECK-LABEL: func @_QPpass_foo2() {
subroutine pass_foo2()
external :: foo2
! CHECK: %[[f:.*]] = fir.address_of(@_QPfoo2)
! CHECK: fir.emboxproc %[[f]] : ((!fir.ref<!fir.array<2x5xi32>>) -> ()) -> !fir.boxproc<() -> ()>
call bar(foo2)
end subroutine
! CHECK-LABEL: func @_QPfoo2(
! CHECK-SAME: %{{.*}}: !fir.ref<!fir.array<2x5xi32>>{{.*}}) {
subroutine foo2(i)
@ -57,6 +71,13 @@ subroutine foo3(i)
integer :: i(2, 5)
call do_something(i)
end subroutine
! CHECK-LABEL: func @_QPpass_foo3() {
subroutine pass_foo3()
external :: foo3
! CHECK: %[[f:.*]] = fir.address_of(@_QPfoo3)
! CHECK: fir.emboxproc %[[f]] : ((!fir.ref<!fir.array<2x5xi32>>) -> ()) -> !fir.boxproc<() -> ()>
call bar(foo3)
end subroutine
! define, call, pass
! CHECK-LABEL: func @_QPfoo4(
@ -73,6 +94,13 @@ subroutine call_foo4(i)
! fir.call @_QPfoo4(%[[argconvert]]) : (!fir.ref<!fir.array<2x5xi32>>) -> ()
call foo4(i)
end subroutine
! CHECK-LABEL: func @_QPpass_foo4() {
subroutine pass_foo4()
external :: foo4
! CHECK: %[[f:.*]] = fir.address_of(@_QPfoo4)
! CHECK: fir.emboxproc %[[f]] : ((!fir.ref<!fir.array<2x5xi32>>) -> ()) -> !fir.boxproc<() -> ()>
call bar(foo4)
end subroutine
! define, pass, call
! CHECK-LABEL: func @_QPfoo5(
@ -81,6 +109,13 @@ subroutine foo5(i)
integer :: i(2, 5)
call do_something(i)
end subroutine
! CHECK-LABEL: func @_QPpass_foo5() {
subroutine pass_foo5()
external :: foo5
! CHECK: %[[f:.*]] = fir.address_of(@_QPfoo5)
! CHECK: fir.emboxproc %[[f]] : ((!fir.ref<!fir.array<2x5xi32>>) -> ()) -> !fir.boxproc<() -> ()>
call bar(foo5)
end subroutine
! CHECK-LABEL: func @_QPcall_foo5(
! CHECK-SAME: %{{.*}}: !fir.ref<!fir.array<10xi32>>{{.*}}) {
subroutine call_foo5(i)
@ -101,8 +136,32 @@ subroutine call_foo6(i)
integer :: i(10)
! CHECK-NOT: convert
call foo6(i)
end subroutine
! CHECK-LABEL: func @_QPpass_foo6() {
subroutine pass_foo6()
external :: foo6
! CHECK: %[[f:.*]] = fir.address_of(@_QPfoo6) : (!fir.ref<!fir.array<10xi32>>) -> ()
! CHECK: fir.emboxproc %[[f]] : ((!fir.ref<!fir.array<10xi32>>) -> ()) -> !fir.boxproc<() -> ()>
call bar(foo6)
end subroutine
! pass, call
! CHECK-LABEL: func @_QPpass_foo7() {
subroutine pass_foo7()
external :: foo7
! CHECK-NOT: convert
call bar(foo7)
end subroutine
! CHECK-LABEL: func @_QPcall_foo7(
! CHECK-SAME: %{{.*}}: !fir.ref<!fir.array<10xi32>>{{.*}}) -> f32 {
function call_foo7(i)
integer :: i(10)
! CHECK: %[[f:.*]] = fir.address_of(@_QPfoo7) : () -> ()
! CHECK: %[[funccast:.*]] = fir.convert %[[f]] : (() -> ()) -> ((!fir.ref<!fir.array<10xi32>>) -> f32)
! CHECK: fir.call %[[funccast]](%arg0) : (!fir.ref<!fir.array<10xi32>>) -> f32
call_foo7 = foo7(i)
end function
! call, call with different type
! CHECK-LABEL: func @_QPcall_foo8(
@ -137,6 +196,7 @@ subroutine test_target_in_iface()
end subroutine
! CHECK: func private @_QPfoo6(!fir.ref<!fir.array<10xi32>>)
! CHECK: func private @_QPfoo7()
! Test declaration from test_target_in_iface
! CHECK-LABEL: func private @_QPtest_target(!fir.ref<i32> {fir.target}, !fir.box<!fir.array<?xf32>> {fir.target})