lib/Lower/ConvertProcedureDesignator.cpp

//===- ConvertProcedureDesignator.cpp -- Procedure Designator ---*- C++ -*-===//
//
// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
// See https://llvm.org/LICENSE.txt for license information.
// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
//
//===----------------------------------------------------------------------===//

#include "flang/Lower/ConvertProcedureDesignator.h"
#include "flang/Evaluate/intrinsics.h"
#include "flang/Lower/AbstractConverter.h"
#include "flang/Lower/CallInterface.h"
#include "flang/Lower/ConvertCall.h"
#include "flang/Lower/ConvertExprToHLFIR.h"
#include "flang/Lower/ConvertVariable.h"
#include "flang/Lower/Support/Utils.h"
#include "flang/Lower/SymbolMap.h"
#include "flang/Optimizer/Builder/Character.h"
#include "flang/Optimizer/Builder/IntrinsicCall.h"
#include "flang/Optimizer/Builder/Todo.h"
#include "flang/Optimizer/Dialect/FIROps.h"
#include "flang/Optimizer/HLFIR/HLFIROps.h"

static bool areAllSymbolsInExprMapped(const Fortran::evaluate::ExtentExpr &expr,
                                      Fortran::lower::SymMap &symMap) {
  for (const auto &sym : Fortran::evaluate::CollectSymbols(expr))
    if (!symMap.lookupSymbol(sym))
      return false;
  return true;
}

fir::ExtendedValue Fortran::lower::convertProcedureDesignator(
    mlir::Location loc, Fortran::lower::AbstractConverter &converter,
    const Fortran::evaluate::ProcedureDesignator &proc,
    Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx) {
  fir::FirOpBuilder &builder = converter.getFirOpBuilder();

  if (const Fortran::evaluate::SpecificIntrinsic *intrinsic =
          proc.GetSpecificIntrinsic()) {
    mlir::FunctionType signature =
        Fortran::lower::translateSignature(proc, converter);
    // Intrinsic lowering is based on the generic name, so retrieve it here in
    // case it is different from the specific name. The type of the specific
    // intrinsic is retained in the signature.
    std::string genericName =
        converter.getFoldingContext().intrinsics().GetGenericIntrinsicName(
            intrinsic->name);
    mlir::SymbolRefAttr symbolRefAttr =
        fir::getUnrestrictedIntrinsicSymbolRefAttr(builder, loc, genericName,
                                                   signature);
    mlir::Value funcPtr =
        builder.create<fir::AddrOfOp>(loc, signature, symbolRefAttr);
    return funcPtr;
  }
  const Fortran::semantics::Symbol *symbol = proc.GetSymbol();
  assert(symbol && "expected symbol in ProcedureDesignator");
  mlir::Value funcPtr;
  mlir::Value funcPtrResultLength;
  if (Fortran::semantics::IsDummy(*symbol)) {
    Fortran::lower::SymbolBox val = symMap.lookupSymbol(*symbol);
    assert(val && "Dummy procedure not in symbol map");
    funcPtr = val.getAddr();
    if (fir::isCharacterProcedureTuple(funcPtr.getType(),
                                       /*acceptRawFunc=*/false))
      std::tie(funcPtr, funcPtrResultLength) =
          fir::factory::extractCharacterProcedureTuple(builder, loc, funcPtr);
  } else {
    mlir::func::FuncOp func =
        Fortran::lower::getOrDeclareFunction(proc, converter);
    mlir::SymbolRefAttr nameAttr = builder.getSymbolRefAttr(func.getSymName());
    funcPtr =
        builder.create<fir::AddrOfOp>(loc, func.getFunctionType(), nameAttr);
  }
  if (Fortran::lower::mustPassLengthWithDummyProcedure(proc, converter)) {
    // The result length, if available here, must be propagated along the
    // procedure address so that call sites where the result length is assumed
    // can retrieve the length.
    Fortran::evaluate::DynamicType resultType = proc.GetType().value();
    if (const auto &lengthExpr = resultType.GetCharLength()) {
      // The length expression may refer to dummy argument symbols that are
      // meaningless without any actual arguments. Leave the length as
      // unknown in that case, it be resolved on the call site
      // with the actual arguments.
      if (areAllSymbolsInExprMapped(*lengthExpr, symMap)) {
        mlir::Value rawLen = fir::getBase(
            converter.genExprValue(toEvExpr(*lengthExpr), stmtCtx));
        // F2018 7.4.4.2 point 5.
        funcPtrResultLength =
            fir::factory::genMaxWithZero(builder, loc, rawLen);
      }
    }
    if (!funcPtrResultLength)
      funcPtrResultLength = builder.createIntegerConstant(
          loc, builder.getCharacterLengthType(), -1);
    return fir::CharBoxValue{funcPtr, funcPtrResultLength};
  }
  return funcPtr;
}

static hlfir::EntityWithAttributes designateProcedurePointerComponent(
    mlir::Location loc, Fortran::lower::AbstractConverter &converter,
    const Fortran::evaluate::Symbol &procComponentSym, mlir::Value base,
    Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx) {
  fir::FirOpBuilder &builder = converter.getFirOpBuilder();
  fir::FortranVariableFlagsAttr attributes =
      Fortran::lower::translateSymbolAttributes(builder.getContext(),
                                                procComponentSym);
  /// Passed argument may be a descriptor. This is a scalar reference, so the
  /// base address can be directly addressed.
  if (mlir::isa<fir::BaseBoxType>(base.getType()))
    base = builder.create<fir::BoxAddrOp>(loc, base);
  std::string fieldName = converter.getRecordTypeFieldName(procComponentSym);
  auto recordType =
      mlir::cast<fir::RecordType>(hlfir::getFortranElementType(base.getType()));
  mlir::Type fieldType = recordType.getType(fieldName);
  // Note: semantics turns x%p() into x%t%p() when the procedure pointer
  // component is part of parent component t.
  if (!fieldType)
    TODO(loc, "passing type bound procedure (extension)");
  mlir::Type designatorType = fir::ReferenceType::get(fieldType);
  mlir::Value compRef = builder.create<hlfir::DesignateOp>(
      loc, designatorType, base, fieldName,
      /*compShape=*/mlir::Value{}, hlfir::DesignateOp::Subscripts{},
      /*substring=*/mlir::ValueRange{},
      /*complexPart=*/std::nullopt,
      /*shape=*/mlir::Value{}, /*typeParams=*/mlir::ValueRange{}, attributes);
  return hlfir::EntityWithAttributes{compRef};
}

static hlfir::EntityWithAttributes convertProcedurePointerComponent(
    mlir::Location loc, Fortran::lower::AbstractConverter &converter,
    const Fortran::evaluate::Component &procComponent,
    Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx) {
  fir::ExtendedValue baseExv = Fortran::lower::convertDataRefToValue(
      loc, converter, procComponent.base(), symMap, stmtCtx);
  mlir::Value base = fir::getBase(baseExv);
  const Fortran::semantics::Symbol &procComponentSym =
      procComponent.GetLastSymbol();
  return designateProcedurePointerComponent(loc, converter, procComponentSym,
                                            base, symMap, stmtCtx);
}

hlfir::EntityWithAttributes Fortran::lower::convertProcedureDesignatorToHLFIR(
    mlir::Location loc, Fortran::lower::AbstractConverter &converter,
    const Fortran::evaluate::ProcedureDesignator &proc,
    Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx) {
  const auto *sym = proc.GetSymbol();
  if (sym) {
    if (sym->GetUltimate().attrs().test(Fortran::semantics::Attr::INTRINSIC))
      TODO(loc, "Procedure pointer with intrinsic target.");
    if (std::optional<fir::FortranVariableOpInterface> varDef =
            symMap.lookupVariableDefinition(*sym))
      return *varDef;
  }

  if (const Fortran::evaluate::Component *procComponent = proc.GetComponent())
    return convertProcedurePointerComponent(loc, converter, *procComponent,
                                            symMap, stmtCtx);

  fir::ExtendedValue procExv =
      convertProcedureDesignator(loc, converter, proc, symMap, stmtCtx);
  // Directly package the procedure address as a fir.boxproc or
  // tuple<fir.boxbroc, len> so that it can be returned as a single mlir::Value.
  fir::FirOpBuilder &builder = converter.getFirOpBuilder();

  mlir::Value funcAddr = fir::getBase(procExv);
  if (!mlir::isa<fir::BoxProcType>(funcAddr.getType())) {
    mlir::Type boxTy =
        Fortran::lower::getUntypedBoxProcType(&converter.getMLIRContext());
    if (auto host = Fortran::lower::argumentHostAssocs(converter, funcAddr))
      funcAddr = builder.create<fir::EmboxProcOp>(
          loc, boxTy, llvm::ArrayRef<mlir::Value>{funcAddr, host});
    else
      funcAddr = builder.create<fir::EmboxProcOp>(loc, boxTy, funcAddr);
  }

  mlir::Value res = procExv.match(
      [&](const fir::CharBoxValue &box) -> mlir::Value {
        mlir::Type tupleTy =
            fir::factory::getCharacterProcedureTupleType(funcAddr.getType());
        return fir::factory::createCharacterProcedureTuple(
            builder, loc, tupleTy, funcAddr, box.getLen());
      },
      [funcAddr](const auto &) { return funcAddr; });
  return hlfir::EntityWithAttributes{res};
}

mlir::Value Fortran::lower::convertProcedureDesignatorInitialTarget(
    Fortran::lower::AbstractConverter &converter, mlir::Location loc,
    const Fortran::semantics::Symbol &sym) {
  Fortran::lower::SymMap globalOpSymMap;
  Fortran::lower::StatementContext stmtCtx;
  Fortran::evaluate::ProcedureDesignator proc(sym);
  auto procVal{Fortran::lower::convertProcedureDesignatorToHLFIR(
      loc, converter, proc, globalOpSymMap, stmtCtx)};
  return fir::getBase(Fortran::lower::convertToAddress(
      loc, converter, procVal, stmtCtx, procVal.getType()));
}

mlir::Value Fortran::lower::derefPassProcPointerComponent(
    mlir::Location loc, Fortran::lower::AbstractConverter &converter,
    const Fortran::evaluate::ProcedureDesignator &proc, mlir::Value passedArg,
    Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx) {
  const Fortran::semantics::Symbol *procComponentSym = proc.GetSymbol();
  assert(procComponentSym &&
         "failed to retrieve pointer procedure component symbol");
  hlfir::EntityWithAttributes pointerComp = designateProcedurePointerComponent(
      loc, converter, *procComponentSym, passedArg, symMap, stmtCtx);
  return converter.getFirOpBuilder().create<fir::LoadOp>(loc, pointerComp);
}