810 lines · cpp
1//===-- lib/Semantics/check-cuda.cpp ----------------------------*- C++ -*-===//2//3// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.4// See https://llvm.org/LICENSE.txt for license information.5// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception6//7//===----------------------------------------------------------------------===//8 9#include "check-cuda.h"10#include "flang/Common/template.h"11#include "flang/Evaluate/fold.h"12#include "flang/Evaluate/tools.h"13#include "flang/Evaluate/traverse.h"14#include "flang/Parser/parse-tree-visitor.h"15#include "flang/Parser/parse-tree.h"16#include "flang/Parser/tools.h"17#include "flang/Semantics/expression.h"18#include "flang/Semantics/symbol.h"19#include "flang/Semantics/tools.h"20#include "llvm/ADT/StringSet.h"21 22// Once labeled DO constructs have been canonicalized and their parse subtrees23// transformed into parser::DoConstructs, scan the parser::Blocks of the program24// and merge adjacent CUFKernelDoConstructs and DoConstructs whenever the25// CUFKernelDoConstruct doesn't already have an embedded DoConstruct. Also26// emit errors about improper or missing DoConstructs.27 28namespace Fortran::parser {29struct Mutator {30 template <typename A> bool Pre(A &) { return true; }31 template <typename A> void Post(A &) {}32 bool Pre(Block &);33};34 35bool Mutator::Pre(Block &block) {36 for (auto iter{block.begin()}; iter != block.end(); ++iter) {37 if (auto *kernel{Unwrap<CUFKernelDoConstruct>(*iter)}) {38 auto &nested{std::get<std::optional<DoConstruct>>(kernel->t)};39 if (!nested) {40 if (auto next{iter}; ++next != block.end()) {41 if (auto *doConstruct{Unwrap<DoConstruct>(*next)}) {42 nested = std::move(*doConstruct);43 block.erase(next);44 }45 }46 }47 } else {48 Walk(*iter, *this);49 }50 }51 return false;52}53} // namespace Fortran::parser54 55namespace Fortran::semantics {56 57bool CanonicalizeCUDA(parser::Program &program) {58 parser::Mutator mutator;59 parser::Walk(program, mutator);60 return true;61}62 63using MaybeMsg = std::optional<parser::MessageFormattedText>;64 65static const llvm::StringSet<> warpFunctions_ = {"match_all_syncjj",66 "match_all_syncjx", "match_all_syncjf", "match_all_syncjd",67 "match_any_syncjj", "match_any_syncjx", "match_any_syncjf",68 "match_any_syncjd"};69 70// Traverses an evaluate::Expr<> in search of unsupported operations71// on the device.72 73struct DeviceExprChecker74 : public evaluate::AnyTraverse<DeviceExprChecker, MaybeMsg> {75 using Result = MaybeMsg;76 using Base = evaluate::AnyTraverse<DeviceExprChecker, Result>;77 explicit DeviceExprChecker(SemanticsContext &c) : Base(*this), context_{c} {}78 using Base::operator();79 Result operator()(const evaluate::ProcedureDesignator &x) const {80 if (const Symbol * sym{x.GetInterfaceSymbol()}) {81 const auto *subp{82 sym->GetUltimate().detailsIf<semantics::SubprogramDetails>()};83 if (subp) {84 if (auto attrs{subp->cudaSubprogramAttrs()}) {85 if (*attrs == common::CUDASubprogramAttrs::HostDevice ||86 *attrs == common::CUDASubprogramAttrs::Device) {87 if (warpFunctions_.contains(sym->name().ToString()) &&88 !context_.languageFeatures().IsEnabled(89 Fortran::common::LanguageFeature::CudaWarpMatchFunction)) {90 return parser::MessageFormattedText(91 "warp match function disabled"_err_en_US);92 }93 return {};94 }95 }96 }97 98 const Symbol &ultimate{sym->GetUltimate()};99 const Scope &scope{ultimate.owner()};100 const Symbol *mod{scope.IsModule() ? scope.symbol() : nullptr};101 // Allow ieee_arithmetic module functions to be called on the device.102 // TODO: Check for unsupported ieee_arithmetic on the device.103 if (mod && mod->name() == "ieee_arithmetic") {104 return {};105 }106 } else if (x.GetSpecificIntrinsic()) {107 // TODO(CUDA): Check for unsupported intrinsics here108 return {};109 }110 111 return parser::MessageFormattedText(112 "'%s' may not be called in device code"_err_en_US, x.GetName());113 }114 115 SemanticsContext &context_;116};117 118struct FindHostArray119 : public evaluate::AnyTraverse<FindHostArray, const Symbol *> {120 using Result = const Symbol *;121 using Base = evaluate::AnyTraverse<FindHostArray, Result>;122 FindHostArray() : Base(*this) {}123 using Base::operator();124 Result operator()(const evaluate::Component &x) const {125 const Symbol &symbol{x.GetLastSymbol()};126 if (IsAllocatableOrPointer(symbol)) {127 if (Result hostArray{(*this)(symbol)}) {128 return hostArray;129 }130 }131 return (*this)(x.base());132 }133 Result operator()(const Symbol &symbol) const {134 if (symbol.IsFuncResult()) {135 return nullptr;136 }137 if (const auto *details{138 symbol.GetUltimate().detailsIf<semantics::ObjectEntityDetails>()}) {139 if (details->IsArray() &&140 !symbol.attrs().test(Fortran::semantics::Attr::PARAMETER) &&141 (!details->cudaDataAttr() ||142 (details->cudaDataAttr() &&143 *details->cudaDataAttr() != common::CUDADataAttr::Device &&144 *details->cudaDataAttr() != common::CUDADataAttr::Constant &&145 *details->cudaDataAttr() != common::CUDADataAttr::Managed &&146 *details->cudaDataAttr() != common::CUDADataAttr::Shared &&147 *details->cudaDataAttr() != common::CUDADataAttr::Unified))) {148 return &symbol;149 }150 }151 return nullptr;152 }153};154 155template <typename A>156static MaybeMsg CheckUnwrappedExpr(SemanticsContext &context, const A &x) {157 if (const auto *expr{parser::Unwrap<parser::Expr>(x)}) {158 return DeviceExprChecker{context}(expr->typedExpr);159 }160 return {};161}162 163template <typename A>164static void CheckUnwrappedExpr(165 SemanticsContext &context, SourceName at, const A &x) {166 if (const auto *expr{parser::Unwrap<parser::Expr>(x)}) {167 if (auto msg{DeviceExprChecker{context}(expr->typedExpr)}) {168 context.Say(at, std::move(*msg));169 }170 }171}172 173template <bool CUF_KERNEL> struct ActionStmtChecker {174 template <typename A>175 static MaybeMsg WhyNotOk(SemanticsContext &context, const A &x) {176 if constexpr (ConstraintTrait<A>) {177 return WhyNotOk(context, x.thing);178 } else if constexpr (WrapperTrait<A>) {179 return WhyNotOk(context, x.v);180 } else if constexpr (UnionTrait<A>) {181 return WhyNotOk(context, x.u);182 } else if constexpr (TupleTrait<A>) {183 return WhyNotOk(context, x.t);184 } else {185 return parser::MessageFormattedText{186 "Statement may not appear in device code"_err_en_US};187 }188 }189 template <typename A>190 static MaybeMsg WhyNotOk(191 SemanticsContext &context, const common::Indirection<A> &x) {192 return WhyNotOk(context, x.value());193 }194 template <typename... As>195 static MaybeMsg WhyNotOk(196 SemanticsContext &context, const std::variant<As...> &x) {197 return common::visit(198 [&context](const auto &x) { return WhyNotOk(context, x); }, x);199 }200 template <std::size_t J = 0, typename... As>201 static MaybeMsg WhyNotOk(202 SemanticsContext &context, const std::tuple<As...> &x) {203 if constexpr (J == sizeof...(As)) {204 return {};205 } else if (auto msg{WhyNotOk(context, std::get<J>(x))}) {206 return msg;207 } else {208 return WhyNotOk<(J + 1)>(context, x);209 }210 }211 template <typename A>212 static MaybeMsg WhyNotOk(SemanticsContext &context, const std::list<A> &x) {213 for (const auto &y : x) {214 if (MaybeMsg result{WhyNotOk(context, y)}) {215 return result;216 }217 }218 return {};219 }220 template <typename A>221 static MaybeMsg WhyNotOk(222 SemanticsContext &context, const std::optional<A> &x) {223 if (x) {224 return WhyNotOk(context, *x);225 } else {226 return {};227 }228 }229 template <typename A>230 static MaybeMsg WhyNotOk(231 SemanticsContext &context, const parser::UnlabeledStatement<A> &x) {232 return WhyNotOk(context, x.statement);233 }234 template <typename A>235 static MaybeMsg WhyNotOk(236 SemanticsContext &context, const parser::Statement<A> &x) {237 return WhyNotOk(context, x.statement);238 }239 static MaybeMsg WhyNotOk(240 SemanticsContext &context, const parser::AllocateStmt &) {241 return {}; // AllocateObjects are checked elsewhere242 }243 static MaybeMsg WhyNotOk(244 SemanticsContext &context, const parser::AllocateCoarraySpec &) {245 return parser::MessageFormattedText(246 "A coarray may not be allocated on the device"_err_en_US);247 }248 static MaybeMsg WhyNotOk(249 SemanticsContext &context, const parser::DeallocateStmt &) {250 return {}; // AllocateObjects are checked elsewhere251 }252 static MaybeMsg WhyNotOk(253 SemanticsContext &context, const parser::AssignmentStmt &x) {254 return DeviceExprChecker{context}(x.typedAssignment);255 }256 static MaybeMsg WhyNotOk(257 SemanticsContext &context, const parser::CallStmt &x) {258 return DeviceExprChecker{context}(x.typedCall);259 }260 static MaybeMsg WhyNotOk(261 SemanticsContext &context, const parser::ContinueStmt &) {262 return {};263 }264 static MaybeMsg WhyNotOk(SemanticsContext &context, const parser::IfStmt &x) {265 if (auto result{CheckUnwrappedExpr(266 context, std::get<parser::ScalarLogicalExpr>(x.t))}) {267 return result;268 }269 return WhyNotOk(context,270 std::get<parser::UnlabeledStatement<parser::ActionStmt>>(x.t)271 .statement);272 }273 static MaybeMsg WhyNotOk(274 SemanticsContext &context, const parser::NullifyStmt &x) {275 for (const auto &y : x.v) {276 if (MaybeMsg result{DeviceExprChecker{context}(y.typedExpr)}) {277 return result;278 }279 }280 return {};281 }282 static MaybeMsg WhyNotOk(283 SemanticsContext &context, const parser::PointerAssignmentStmt &x) {284 return DeviceExprChecker{context}(x.typedAssignment);285 }286};287 288template <bool IsCUFKernelDo> class DeviceContextChecker {289public:290 explicit DeviceContextChecker(SemanticsContext &c) : context_{c} {}291 void CheckSubprogram(const parser::Name &name, const parser::Block &body) {292 if (name.symbol) {293 const auto *subp{294 name.symbol->GetUltimate().detailsIf<SubprogramDetails>()};295 if (subp && subp->moduleInterface()) {296 subp = subp->moduleInterface()297 ->GetUltimate()298 .detailsIf<SubprogramDetails>();299 }300 if (subp &&301 subp->cudaSubprogramAttrs().value_or(302 common::CUDASubprogramAttrs::Host) !=303 common::CUDASubprogramAttrs::Host) {304 isHostDevice = subp->cudaSubprogramAttrs() &&305 subp->cudaSubprogramAttrs() ==306 common::CUDASubprogramAttrs::HostDevice;307 Check(body);308 }309 }310 }311 void Check(const parser::Block &block) {312 for (const auto &epc : block) {313 Check(epc);314 }315 }316 317private:318 void Check(const parser::ExecutionPartConstruct &epc) {319 common::visit(320 common::visitors{321 [&](const parser::ExecutableConstruct &x) { Check(x); },322 [&](const parser::Statement<common::Indirection<parser::EntryStmt>>323 &x) {324 context_.Say(x.source,325 "Device code may not contain an ENTRY statement"_err_en_US);326 },327 [](const parser::Statement<common::Indirection<parser::FormatStmt>>328 &) {},329 [](const parser::Statement<common::Indirection<parser::DataStmt>>330 &) {},331 [](const parser::Statement<332 common::Indirection<parser::NamelistStmt>> &) {},333 [](const parser::ErrorRecovery &) {},334 },335 epc.u);336 }337 void Check(const parser::ExecutableConstruct &ec) {338 common::visit(339 common::visitors{340 [&](const parser::Statement<parser::ActionStmt> &stmt) {341 Check(stmt.statement, stmt.source);342 },343 [&](const common::Indirection<parser::DoConstruct> &x) {344 if (const std::optional<parser::LoopControl> &control{345 x.value().GetLoopControl()}) {346 common::visit([&](const auto &y) { Check(y); }, control->u);347 }348 Check(std::get<parser::Block>(x.value().t));349 },350 [&](const common::Indirection<parser::BlockConstruct> &x) {351 Check(std::get<parser::Block>(x.value().t));352 },353 [&](const common::Indirection<parser::IfConstruct> &x) {354 Check(x.value());355 },356 [&](const common::Indirection<parser::CaseConstruct> &x) {357 const auto &caseList{358 std::get<std::list<parser::CaseConstruct::Case>>(359 x.value().t)};360 for (const parser::CaseConstruct::Case &c : caseList) {361 Check(std::get<parser::Block>(c.t));362 }363 },364 [&](const common::Indirection<parser::CompilerDirective> &x) {365 // TODO(CUDA): Check for unsupported compiler directive here.366 },367 [&](const auto &x) {368 if (auto source{parser::GetSource(x)}) {369 context_.Say(*source,370 "Statement may not appear in device code"_err_en_US);371 }372 },373 },374 ec.u);375 }376 template <typename SEEK, typename A>377 static const SEEK *GetIOControl(const A &stmt) {378 for (const auto &spec : stmt.controls) {379 if (const auto *result{std::get_if<SEEK>(&spec.u)}) {380 return result;381 }382 }383 return nullptr;384 }385 template <typename A> static bool IsInternalIO(const A &stmt) {386 if (stmt.iounit.has_value()) {387 return std::holds_alternative<Fortran::parser::Variable>(stmt.iounit->u);388 }389 if (auto *unit{GetIOControl<Fortran::parser::IoUnit>(stmt)}) {390 return std::holds_alternative<Fortran::parser::Variable>(unit->u);391 }392 return false;393 }394 void WarnOnIoStmt(const parser::CharBlock &source) {395 context_.Warn(common::UsageWarning::CUDAUsage, source,396 "I/O statement might not be supported on device"_warn_en_US);397 }398 template <typename A>399 void WarnIfNotInternal(const A &stmt, const parser::CharBlock &source) {400 if (!IsInternalIO(stmt)) {401 WarnOnIoStmt(source);402 }403 }404 template <typename A>405 void ErrorIfHostSymbol(const A &expr, parser::CharBlock source) {406 if (isHostDevice)407 return;408 if (const Symbol * hostArray{FindHostArray{}(expr)}) {409 context_.Say(source,410 "Host array '%s' cannot be present in device context"_err_en_US,411 hostArray->name());412 }413 }414 void ErrorInCUFKernel(parser::CharBlock source) {415 if (IsCUFKernelDo) {416 context_.Say(417 source, "Statement may not appear in cuf kernel code"_err_en_US);418 }419 }420 void Check(const parser::ActionStmt &stmt, const parser::CharBlock &source) {421 common::visit(422 common::visitors{423 [&](const common::Indirection<parser::CycleStmt> &) {424 ErrorInCUFKernel(source);425 },426 [&](const common::Indirection<parser::ExitStmt> &) {427 ErrorInCUFKernel(source);428 },429 [&](const common::Indirection<parser::GotoStmt> &) {430 ErrorInCUFKernel(source);431 },432 [&](const common::Indirection<parser::StopStmt> &) { return; },433 [&](const common::Indirection<parser::PrintStmt> &) {},434 [&](const common::Indirection<parser::WriteStmt> &x) {435 if (x.value().format) { // Formatted write to '*' or '6'436 if (std::holds_alternative<Fortran::parser::Star>(437 x.value().format->u)) {438 if (x.value().iounit) {439 if (std::holds_alternative<Fortran::parser::Star>(440 x.value().iounit->u)) {441 return;442 }443 }444 }445 }446 WarnIfNotInternal(x.value(), source);447 },448 [&](const common::Indirection<parser::CloseStmt> &x) {449 WarnOnIoStmt(source);450 },451 [&](const common::Indirection<parser::EndfileStmt> &x) {452 WarnOnIoStmt(source);453 },454 [&](const common::Indirection<parser::OpenStmt> &x) {455 WarnOnIoStmt(source);456 },457 [&](const common::Indirection<parser::ReadStmt> &x) {458 WarnIfNotInternal(x.value(), source);459 },460 [&](const common::Indirection<parser::InquireStmt> &x) {461 WarnOnIoStmt(source);462 },463 [&](const common::Indirection<parser::RewindStmt> &x) {464 WarnOnIoStmt(source);465 },466 [&](const common::Indirection<parser::BackspaceStmt> &x) {467 WarnOnIoStmt(source);468 },469 [&](const common::Indirection<parser::IfStmt> &x) {470 Check(x.value());471 },472 [&](const common::Indirection<parser::AssignmentStmt> &x) {473 if (const evaluate::Assignment *474 assign{semantics::GetAssignment(x.value())}) {475 ErrorIfHostSymbol(assign->lhs, source);476 ErrorIfHostSymbol(assign->rhs, source);477 }478 if (auto msg{ActionStmtChecker<IsCUFKernelDo>::WhyNotOk(479 context_, x)}) {480 context_.Say(source, std::move(*msg));481 }482 },483 [&](const auto &x) {484 if (auto msg{ActionStmtChecker<IsCUFKernelDo>::WhyNotOk(485 context_, x)}) {486 context_.Say(source, std::move(*msg));487 }488 },489 },490 stmt.u);491 }492 void Check(const parser::IfConstruct &ic) {493 const auto &ifS{std::get<parser::Statement<parser::IfThenStmt>>(ic.t)};494 CheckUnwrappedExpr(context_, ifS.source,495 std::get<parser::ScalarLogicalExpr>(ifS.statement.t));496 Check(std::get<parser::Block>(ic.t));497 for (const auto &eib :498 std::get<std::list<parser::IfConstruct::ElseIfBlock>>(ic.t)) {499 const auto &eIfS{std::get<parser::Statement<parser::ElseIfStmt>>(eib.t)};500 CheckUnwrappedExpr(context_, eIfS.source,501 std::get<parser::ScalarLogicalExpr>(eIfS.statement.t));502 Check(std::get<parser::Block>(eib.t));503 }504 if (const auto &eb{505 std::get<std::optional<parser::IfConstruct::ElseBlock>>(ic.t)}) {506 Check(std::get<parser::Block>(eb->t));507 }508 }509 void Check(const parser::IfStmt &is) {510 const auto &uS{511 std::get<parser::UnlabeledStatement<parser::ActionStmt>>(is.t)};512 CheckUnwrappedExpr(513 context_, uS.source, std::get<parser::ScalarLogicalExpr>(is.t));514 Check(uS.statement, uS.source);515 }516 void Check(const parser::LoopControl::Bounds &bounds) {517 Check(bounds.lower);518 Check(bounds.upper);519 if (bounds.step) {520 Check(*bounds.step);521 }522 }523 void Check(const parser::LoopControl::Concurrent &x) {524 const auto &header{std::get<parser::ConcurrentHeader>(x.t)};525 for (const auto &cc :526 std::get<std::list<parser::ConcurrentControl>>(header.t)) {527 Check(std::get<1>(cc.t));528 Check(std::get<2>(cc.t));529 if (const auto &step{530 std::get<std::optional<parser::ScalarIntExpr>>(cc.t)}) {531 Check(*step);532 }533 }534 if (const auto &mask{535 std::get<std::optional<parser::ScalarLogicalExpr>>(header.t)}) {536 Check(*mask);537 }538 }539 void Check(const parser::ScalarLogicalExpr &x) {540 Check(DEREF(parser::Unwrap<parser::Expr>(x)));541 }542 void Check(const parser::ScalarIntExpr &x) {543 Check(DEREF(parser::Unwrap<parser::Expr>(x)));544 }545 void Check(const parser::ScalarExpr &x) {546 Check(DEREF(parser::Unwrap<parser::Expr>(x)));547 }548 void Check(const parser::Expr &expr) {549 if (MaybeMsg msg{DeviceExprChecker{context_}(expr.typedExpr)}) {550 context_.Say(expr.source, std::move(*msg));551 }552 }553 554 SemanticsContext &context_;555 bool isHostDevice{false};556};557 558void CUDAChecker::Enter(const parser::SubroutineSubprogram &x) {559 DeviceContextChecker<false>{context_}.CheckSubprogram(560 std::get<parser::Name>(561 std::get<parser::Statement<parser::SubroutineStmt>>(x.t).statement.t),562 std::get<parser::ExecutionPart>(x.t).v);563}564 565void CUDAChecker::Enter(const parser::FunctionSubprogram &x) {566 DeviceContextChecker<false>{context_}.CheckSubprogram(567 std::get<parser::Name>(568 std::get<parser::Statement<parser::FunctionStmt>>(x.t).statement.t),569 std::get<parser::ExecutionPart>(x.t).v);570}571 572void CUDAChecker::Enter(const parser::SeparateModuleSubprogram &x) {573 DeviceContextChecker<false>{context_}.CheckSubprogram(574 std::get<parser::Statement<parser::MpSubprogramStmt>>(x.t).statement.v,575 std::get<parser::ExecutionPart>(x.t).v);576}577 578// !$CUF KERNEL DO semantic checks579 580static int DoConstructTightNesting(581 const parser::DoConstruct *doConstruct, const parser::Block *&innerBlock) {582 if (!doConstruct ||583 (!doConstruct->IsDoNormal() && !doConstruct->IsDoConcurrent())) {584 return 0;585 }586 innerBlock = &std::get<parser::Block>(doConstruct->t);587 if (doConstruct->IsDoConcurrent()) {588 const auto &loopControl = doConstruct->GetLoopControl();589 if (loopControl) {590 if (const auto *concurrentControl{591 std::get_if<parser::LoopControl::Concurrent>(&loopControl->u)}) {592 const auto &concurrentHeader =593 std::get<Fortran::parser::ConcurrentHeader>(concurrentControl->t);594 const auto &controls =595 std::get<std::list<Fortran::parser::ConcurrentControl>>(596 concurrentHeader.t);597 return controls.size();598 }599 }600 return 0;601 }602 if (innerBlock->size() == 1) {603 if (const auto *execConstruct{604 std::get_if<parser::ExecutableConstruct>(&innerBlock->front().u)}) {605 if (const auto *next{606 std::get_if<common::Indirection<parser::DoConstruct>>(607 &execConstruct->u)}) {608 return 1 + DoConstructTightNesting(&next->value(), innerBlock);609 }610 }611 }612 return 1;613}614 615static void CheckReduce(616 SemanticsContext &context, const parser::CUFReduction &reduce) {617 auto op{std::get<parser::CUFReduction::Operator>(reduce.t).v};618 for (const auto &var :619 std::get<std::list<parser::Scalar<parser::Variable>>>(reduce.t)) {620 if (const auto &typedExprPtr{var.thing.typedExpr};621 typedExprPtr && typedExprPtr->v) {622 const auto &expr{*typedExprPtr->v};623 if (auto type{expr.GetType()}) {624 auto cat{type->category()};625 bool isOk{false};626 switch (op) {627 case parser::ReductionOperator::Operator::Plus:628 case parser::ReductionOperator::Operator::Multiply:629 case parser::ReductionOperator::Operator::Max:630 case parser::ReductionOperator::Operator::Min:631 isOk = cat == TypeCategory::Integer || cat == TypeCategory::Real ||632 cat == TypeCategory::Complex;633 break;634 case parser::ReductionOperator::Operator::Iand:635 case parser::ReductionOperator::Operator::Ior:636 case parser::ReductionOperator::Operator::Ieor:637 isOk = cat == TypeCategory::Integer;638 break;639 case parser::ReductionOperator::Operator::And:640 case parser::ReductionOperator::Operator::Or:641 case parser::ReductionOperator::Operator::Eqv:642 case parser::ReductionOperator::Operator::Neqv:643 isOk = cat == TypeCategory::Logical;644 break;645 }646 if (!isOk) {647 context.Say(var.thing.GetSource(),648 "!$CUF KERNEL DO REDUCE operation is not acceptable for a variable with type %s"_err_en_US,649 type->AsFortran());650 }651 }652 }653 }654}655 656void CUDAChecker::Enter(const parser::CUFKernelDoConstruct &x) {657 auto source{std::get<parser::CUFKernelDoConstruct::Directive>(x.t).source};658 const auto &directive{std::get<parser::CUFKernelDoConstruct::Directive>(x.t)};659 std::int64_t depth{1};660 if (auto expr{AnalyzeExpr(context_,661 std::get<std::optional<parser::ScalarIntConstantExpr>>(662 directive.t))}) {663 depth = evaluate::ToInt64(expr).value_or(0);664 if (depth <= 0) {665 context_.Say(source,666 "!$CUF KERNEL DO (%jd): loop nesting depth must be positive"_err_en_US,667 std::intmax_t{depth});668 depth = 1;669 }670 }671 const parser::DoConstruct *doConstruct{common::GetPtrFromOptional(672 std::get<std::optional<parser::DoConstruct>>(x.t))};673 const parser::Block *innerBlock{nullptr};674 if (DoConstructTightNesting(doConstruct, innerBlock) < depth) {675 if (doConstruct && doConstruct->IsDoConcurrent())676 context_.Say(source,677 "!$CUF KERNEL DO (%jd) must be followed by a DO CONCURRENT construct with at least %jd indices"_err_en_US,678 std::intmax_t{depth}, std::intmax_t{depth});679 else680 context_.Say(source,681 "!$CUF KERNEL DO (%jd) must be followed by a DO construct with tightly nested outer levels of counted DO loops"_err_en_US,682 std::intmax_t{depth});683 }684 if (innerBlock) {685 DeviceContextChecker<true>{context_}.Check(*innerBlock);686 }687 for (const auto &reduce :688 std::get<std::list<parser::CUFReduction>>(directive.t)) {689 CheckReduce(context_, reduce);690 }691 ++deviceConstructDepth_;692}693 694static bool IsOpenACCComputeConstruct(const parser::OpenACCBlockConstruct &x) {695 const auto &beginBlockDirective =696 std::get<Fortran::parser::AccBeginBlockDirective>(x.t);697 const auto &blockDirective =698 std::get<Fortran::parser::AccBlockDirective>(beginBlockDirective.t);699 if (blockDirective.v == llvm::acc::ACCD_parallel ||700 blockDirective.v == llvm::acc::ACCD_serial ||701 blockDirective.v == llvm::acc::ACCD_kernels) {702 return true;703 }704 return false;705}706 707void CUDAChecker::Leave(const parser::CUFKernelDoConstruct &) {708 --deviceConstructDepth_;709}710void CUDAChecker::Enter(const parser::OpenACCBlockConstruct &x) {711 if (IsOpenACCComputeConstruct(x)) {712 ++deviceConstructDepth_;713 }714}715void CUDAChecker::Leave(const parser::OpenACCBlockConstruct &x) {716 if (IsOpenACCComputeConstruct(x)) {717 --deviceConstructDepth_;718 }719}720void CUDAChecker::Enter(const parser::OpenACCCombinedConstruct &) {721 ++deviceConstructDepth_;722}723void CUDAChecker::Leave(const parser::OpenACCCombinedConstruct &) {724 --deviceConstructDepth_;725}726void CUDAChecker::Enter(const parser::OpenACCLoopConstruct &) {727 ++deviceConstructDepth_;728}729void CUDAChecker::Leave(const parser::OpenACCLoopConstruct &) {730 --deviceConstructDepth_;731}732void CUDAChecker::Enter(const parser::DoConstruct &x) {733 if (x.IsDoConcurrent() &&734 context_.foldingContext().languageFeatures().IsEnabled(735 common::LanguageFeature::DoConcurrentOffload)) {736 ++deviceConstructDepth_;737 }738}739void CUDAChecker::Leave(const parser::DoConstruct &x) {740 if (x.IsDoConcurrent() &&741 context_.foldingContext().languageFeatures().IsEnabled(742 common::LanguageFeature::DoConcurrentOffload)) {743 --deviceConstructDepth_;744 }745}746 747void CUDAChecker::Enter(const parser::AssignmentStmt &x) {748 auto lhsLoc{std::get<parser::Variable>(x.t).GetSource()};749 const auto &scope{context_.FindScope(lhsLoc)};750 const Scope &progUnit{GetProgramUnitContaining(scope)};751 if (IsCUDADeviceContext(&progUnit) || deviceConstructDepth_ > 0) {752 return; // Data transfer with assignment is only perform on host.753 }754 755 const evaluate::Assignment *assign{semantics::GetAssignment(x)};756 if (!assign) {757 return;758 }759 760 int nbLhs{evaluate::GetNbOfCUDADeviceSymbols(assign->lhs)};761 int nbRhs{evaluate::GetNbOfCUDADeviceSymbols(assign->rhs)};762 763 // device to host transfer with more than one device object on the rhs is not764 // legal.765 if (nbLhs == 0 && nbRhs > 1) {766 context_.Say(lhsLoc,767 "More than one reference to a CUDA object on the right hand side of the assignment"_err_en_US);768 }769 770 if (evaluate::HasCUDADeviceAttrs(assign->lhs) &&771 evaluate::HasCUDAImplicitTransfer(assign->rhs)) {772 if (GetNbOfCUDAManagedOrUnifiedSymbols(assign->lhs) == 1 &&773 GetNbOfCUDAManagedOrUnifiedSymbols(assign->rhs) == 1 && nbRhs == 1) {774 return; // This is a special case handled on the host.775 }776 context_.Say(lhsLoc, "Unsupported CUDA data transfer"_err_en_US);777 }778}779 780void CUDAChecker::Enter(const parser::PrintStmt &x) {781 CHECK(context_.location());782 const Scope &scope{context_.FindScope(*context_.location())};783 const Scope &progUnit{GetProgramUnitContaining(scope)};784 if (IsCUDADeviceContext(&progUnit) || deviceConstructDepth_ > 0) {785 return;786 }787 788 auto &outputItemList{std::get<std::list<Fortran::parser::OutputItem>>(x.t)};789 for (const auto &item : outputItemList) {790 if (const auto *x{std::get_if<parser::Expr>(&item.u)}) {791 if (const auto *expr{GetExpr(context_, *x)}) {792 for (const Symbol &sym : CollectCudaSymbols(*expr)) {793 if (const auto *details = sym.GetUltimate()794 .detailsIf<semantics::ObjectEntityDetails>()) {795 if (details->cudaDataAttr() &&796 (*details->cudaDataAttr() == common::CUDADataAttr::Device ||797 *details->cudaDataAttr() ==798 common::CUDADataAttr::Constant)) {799 context_.Say(parser::FindSourceLocation(*x),800 "device data not allowed in I/O statements"_err_en_US);801 }802 }803 }804 }805 }806 }807}808 809} // namespace Fortran::semantics810