[flang] Lower computed and assigned goto

[clementval]

Summary

This patch lowers the computed and assigned goto statements.

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

[PeteSteinfeld]

All builds and tests correctly and looks good.

flang/lib/Lower/Bridge.cpp

 #include "flang/Lower/PFTBuilder.h"
 #include "flang/Lower/Runtime.h"
 #include "flang/Lower/StatementContext.h"
 #include "flang/Lower/SymbolMap.h"
 #include "flang/Lower/Todo.h"
 #include "flang/Optimizer/Builder/BoxValue.h"
 #include "flang/Optimizer/Builder/Character.h"
 #include "flang/Optimizer/Builder/MutableBox.h"
+#include "flang/Optimizer/Dialect/FIRAttr.h"
 #include "flang/Optimizer/Support/FIRContext.h"
 #include "flang/Optimizer/Support/InternalNames.h"
 #include "flang/Runtime/iostat.h"
 #include "flang/Semantics/tools.h"
 #include "mlir/Dialect/ControlFlow/IR/ControlFlowOps.h"
 #include "mlir/IR/PatternMatch.h"
 #include "mlir/Transforms/RegionUtils.h"
 #include "llvm/Support/CommandLine.h"
void genFIR(const Fortran::parser::CallStmt &stmt) {
     // Call statement lowering shares code with function call lowering.
     mlir::Value res = Fortran::lower::createSubroutineCall(
         *this, *stmt.typedCall, localSymbols, stmtCtx);
     if (!res)
       return; // "Normal" subroutine call.
   }
 
   void genFIR(const Fortran::parser::ComputedGotoStmt &stmt) {
-    TODO(toLocation(), "ComputedGotoStmt lowering");
+    Fortran::lower::StatementContext stmtCtx;
+    Fortran::lower::pft::Evaluation &eval = getEval();
+    mlir::Value selectExpr =
+        createFIRExpr(toLocation(),
+                      Fortran::semantics::GetExpr(
+                          std::get<Fortran::parser::ScalarIntExpr>(stmt.t)),
+                      stmtCtx);
+    stmtCtx.finalize();
+    llvm::SmallVector<int64_t> indexList;
+    llvm::SmallVector<mlir::Block *> blockList;
+    int64_t index = 0;
+    for (Fortran::parser::Label label :
+         std::get<std::list<Fortran::parser::Label>>(stmt.t)) {
+      indexList.push_back(++index);
+      blockList.push_back(blockOfLabel(eval, label));
+    }
+    blockList.push_back(eval.nonNopSuccessor().block); // default
+    builder->create<fir::SelectOp>(toLocation(), selectExpr, indexList,
+                                   blockList);
   }
 
   void genFIR(const Fortran::parser::ArithmeticIfStmt &stmt) {
-    TODO(toLocation(), "ArithmeticIfStmt lowering");
+    Fortran::lower::StatementContext stmtCtx;
+    Fortran::lower::pft::Evaluation &eval = getEval();
+    mlir::Value expr = createFIRExpr(
+        toLocation(),
+        Fortran::semantics::GetExpr(std::get<Fortran::parser::Expr>(stmt.t)),
+        stmtCtx);
+    stmtCtx.finalize();
+    mlir::Type exprType = expr.getType();
+    mlir::Location loc = toLocation();
+    if (exprType.isSignlessInteger()) {
+      // Arithmetic expression has Integer type.  Generate a SelectCaseOp
+      // with ranges {(-inf:-1], 0=default, [1:inf)}.
+      MLIRContext *context = builder->getContext();
+      llvm::SmallVector<mlir::Attribute> attrList;
+      llvm::SmallVector<mlir::Value> valueList;
+      llvm::SmallVector<mlir::Block *> blockList;
+      attrList.push_back(fir::UpperBoundAttr::get(context));
+      valueList.push_back(builder->createIntegerConstant(loc, exprType, -1));
+      blockList.push_back(blockOfLabel(eval, std::get<1>(stmt.t)));
+      attrList.push_back(fir::LowerBoundAttr::get(context));
+      valueList.push_back(builder->createIntegerConstant(loc, exprType, 1));
+      blockList.push_back(blockOfLabel(eval, std::get<3>(stmt.t)));
+      attrList.push_back(mlir::UnitAttr::get(context)); // 0 is the "default"
+      blockList.push_back(blockOfLabel(eval, std::get<2>(stmt.t)));
+      builder->create<fir::SelectCaseOp>(loc, expr, attrList, valueList,
+                                         blockList);
+      return;
+    }
+    // Arithmetic expression has Real type.  Generate
+    //   sum = expr + expr  [ raise an exception if expr is a NaN ]
+    //   if (sum < 0.0) goto L1 else if (sum > 0.0) goto L3 else goto L2
+    auto sum = builder->create<mlir::arith::AddFOp>(loc, expr, expr);
+    auto zero = builder->create<mlir::arith::ConstantOp>(
+        loc, exprType, builder->getFloatAttr(exprType, 0.0));
+    auto cond1 = builder->create<mlir::arith::CmpFOp>(
+        loc, mlir::arith::CmpFPredicate::OLT, sum, zero);
+    mlir::Block *elseIfBlock =
+        builder->getBlock()->splitBlock(builder->getInsertionPoint());
+    genFIRConditionalBranch(cond1, blockOfLabel(eval, std::get<1>(stmt.t)),
+                            elseIfBlock);
+    startBlock(elseIfBlock);
+    auto cond2 = builder->create<mlir::arith::CmpFOp>(
+        loc, mlir::arith::CmpFPredicate::OGT, sum, zero);
+    genFIRConditionalBranch(cond2, blockOfLabel(eval, std::get<3>(stmt.t)),
+                            blockOfLabel(eval, std::get<2>(stmt.t)));
   }
 
   void genFIR(const Fortran::parser::AssignedGotoStmt &stmt) {
-    TODO(toLocation(), "AssignedGotoStmt lowering");
+    // Program requirement 1990 8.2.4 -
+    //
+    //   At the time of execution of an assigned GOTO statement, the integer
+    //   variable must be defined with the value of a statement label of a
+    //   branch target statement that appears in the same scoping unit.
+    //   Note that the variable may be defined with a statement label value
+    //   only by an ASSIGN statement in the same scoping unit as the assigned
+    //   GOTO statement.
+
+    mlir::Location loc = toLocation();
+    Fortran::lower::pft::Evaluation &eval = getEval();
+    const Fortran::lower::pft::SymbolLabelMap &symbolLabelMap =
+        eval.getOwningProcedure()->assignSymbolLabelMap;
+    const Fortran::semantics::Symbol &symbol =
+        *std::get<Fortran::parser::Name>(stmt.t).symbol;
+    auto selectExpr =
+        builder->create<fir::LoadOp>(loc, getSymbolAddress(symbol));
+    auto iter = symbolLabelMap.find(symbol);
+    if (iter == symbolLabelMap.end()) {
+      // Fail for a nonconforming program unit that does not have any ASSIGN
+      // statements.  The front end should check for this.
+      mlir::emitError(loc, "(semantics issue) no assigned goto targets");
+      exit(1);
+    }
+    auto labelSet = iter->second;
+    llvm::SmallVector<int64_t> indexList;
+    llvm::SmallVector<mlir::Block *> blockList;
+    auto addLabel = [&](Fortran::parser::Label label) {
+      indexList.push_back(label);
+      blockList.push_back(blockOfLabel(eval, label));
+    };
+    // Add labels from an explicit list.  The list may have duplicates.
+    for (Fortran::parser::Label label :
+         std::get<std::list<Fortran::parser::Label>>(stmt.t)) {
+      if (labelSet.count(label) &&
+          std::find(indexList.begin(), indexList.end(), label) ==
+              indexList.end()) { // ignore duplicates
+        addLabel(label);
+      }
+    }
+    // Absent an explicit list, add all possible label targets.
+    if (indexList.empty())
+      for (auto &label : labelSet)
+        addLabel(label);
+    // Add a nop/fallthrough branch to the switch for a nonconforming program
+    // unit that violates the program requirement above.
+    blockList.push_back(eval.nonNopSuccessor().block); // default
+    builder->create<fir::SelectOp>(loc, selectExpr, indexList, blockList);
   }
 
   void genFIR(const Fortran::parser::DoConstruct &doConstruct) {
     TODO(toLocation(), "DoConstruct lowering");
   }
 
   void genFIR(const Fortran::parser::IfConstruct &) {
     mlir::Location loc = toLocation();
void genFIR(const Fortran::parser::SyncTeamStmt &stmt) {
     TODO(toLocation(), "SyncTeamStmt lowering");
   }
 
   void genFIR(const Fortran::parser::UnlockStmt &stmt) {
     TODO(toLocation(), "UnlockStmt lowering");
   }
 
   void genFIR(const Fortran::parser::AssignStmt &stmt) {
-    TODO(toLocation(), "AssignStmt lowering");
+    const Fortran::semantics::Symbol &symbol =
+        *std::get<Fortran::parser::Name>(stmt.t).symbol;
+    mlir::Location loc = toLocation();
+    mlir::Value labelValue = builder->createIntegerConstant(
+        loc, genType(symbol), std::get<Fortran::parser::Label>(stmt.t));
+    builder->create<fir::StoreOp>(loc, labelValue, getSymbolAddress(symbol));
   }
 
   void genFIR(const Fortran::parser::FormatStmt &) {
     TODO(toLocation(), "FormatStmt lowering");
   }
 
   void genFIR(const Fortran::parser::PauseStmt &stmt) {
     genPauseStatement(*this, stmt);

flang/test/Lower/arithmetic-goto.f90

+! RUN: bbc -emit-fir -o - %s | FileCheck %s
+
+! CHECK-LABEL: func @_QPkagi
+function kagi(index)
+    ! CHECK: fir.select_case %{{.}} : i32 [#fir.upper, %c-1_i32, ^bb{{.}}, #fir.lower, %c1_i32, ^bb{{.}}, unit, ^bb{{.}}]
+    if (index) 7, 8, 9
+    kagi = 0; return
+  7 kagi = 1; return
+  8 kagi = 2; return
+  9 kagi = 3; return
+  end
+  
+  ! CHECK-LABEL: func @_QPkagf
+  function kagf(findex)
+    ! CHECK: %[[zero:.+]] = arith.constant 0.0
+    ! CHECK: %{{.+}} = arith.cmpf olt, %{{.+}}, %[[zero]] : f32
+    ! CHECK: cond_br %
+    ! CHECK: %{{.+}} = arith.cmpf ogt, %{{.+}}, %[[zero]] : f32
+    ! CHECK: cond_br %
+    ! CHECK: br ^
+    if (findex+findex) 7, 8, 9
+    kagf = 0; return
+  7 kagf = 1; return
+  8 kagf = 2; return
+  9 kagf = 3; return
+  end
+  
+  ! CHECK-LABEL: func @_QQmain
+  
+    print*, kagf(-2.0)
+    print*, kagf(-1.0)
+    print*, kagf(-0.0)
+    print*, kagf( 0.0)
+    print*, kagf(+0.0)
+    print*, kagf(+1.0)
+    print*, kagf(+2.0)
+  end

flang/test/Lower/assigned-goto.f90

+! RUN: bbc -emit-fir -o - %s | FileCheck %s
+
+  ! CHECK-LABEL: func @_QPnolist
+  subroutine nolist
+    integer L, V
+ 11 V = 1
+    ! CHECK: fir.store %c31{{.*}} to %{{.}}
+    assign 31 to L
+    ! CHECK: fir.select %{{.}} : i32 [31, ^bb{{.}}, unit, ^bb{{.}}]
+    goto L ! no list
+ 21 V = 2
+    go to 41
+ 31 V = 3
+ 41 print*, 3, V
+ end
+
+ ! CHECK-LABEL: func @_QPlist
+ subroutine list
+    integer L, V
+    ! CHECK: fir.store %c22{{.*}} to %{{.}}
+    assign 22 to L
+ 12 V = 100
+    ! CHECK: fir.store %c32{{.*}} to %{{.}}
+    assign 32 to L
+    ! CHECK: fir.select %{{.}} : i32 [32, ^bb{{.}}, 22, ^bb{{.}}, unit, ^bb{{.}}]
+    goto L (42, 32, 22, 32, 32) ! duplicate labels are allowed
+ 22 V = 200
+    go to 42
+ 32 V = 300
+ 42 print*, 300, V
+ end
+
+    call nolist
+    call list
+ end