[flang] Allow large and erroneous ac-implied-do's

We sometimes unroll an ac-implied-do of an array constructor into a flat list
of values.  We then re-analyze the array constructor that contains the
resulting list of expressions.  Such a list may or may not contain errors.

But when processing an array constructor with an unrolled ac-implied-do, the
compiler was building an expression to represent the extent of the resulting
array constructor containing the list of values.  The number of operands
in this extent expression was based on the number of elements in the
unrolled list of values.  For very large lists, this created an
expression so large that it could not be evaluated by the compiler
without overflowing the stack.

I fixed this by continuously folding the extent expression as each operand is
added to it.  I added the test .../flang/test/Semantics/array-constr-big.f90
that will cause the compiler to seg fault without this change.

Also, when the unrolled ac-implied-do expression contains errors, we were
repeating the same error message referencing the same source line for every
instance of the erroneous expression in the unrolled list.  This potentially
resulted in a very long list of messages for a single error in the source code.

I fixed this by comparing the message being emitted to the previously emitted
message.  If they are the same, I do not emit the message.  This change is also
tested by the new test array-constr-big.f90.

Several of the existing tests had duplicate error messages for the same source
line, and this change caused differences in their output.  So I adjusted the
tests to match the new message emitting behavior.

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

Author: psteinfeld

flang/include/flang/Evaluate/shape.h

@@ -13,6 +13,7 @@
 #define FORTRAN_EVALUATE_SHAPE_H_
 
 #include "expression.h"
+#include "fold.h"
 #include "traverse.h"
 #include "variable.h"
 #include "flang/Common/indirection.h"
@@ -180,6 +181,11 @@ class GetShapeHelper
     for (const auto &value : values) {
       if (MaybeExtentExpr n{GetArrayConstructorValueExtent(value)}) {
         result = std::move(result) + std::move(*n);
+        if (context_) {
+          // Fold during expression creation to avoid creating an expression so
+          // large we can't evalute it without overflowing the stack.
+          result = Fold(*context_, std::move(result));
+        }
       } else {
         return std::nullopt;
       }

flang/include/flang/Parser/message.h

@@ -200,10 +200,11 @@ class Message : public common::ReferenceCounted<Message> {
     return std::holds_alternative<MessageExpectedText>(text_);
   }
   bool Merge(const Message &);
+  bool operator==(const Message &that) const;
+  bool operator!=(const Message &that) const { return !(*this == that); }
 
 private:
   bool AtSameLocation(const Message &) const;
-
   std::variant<ProvenanceRange, CharBlock> location_;
   std::variant<MessageFixedText, MessageFormattedText, MessageExpectedText>
       text_;

flang/lib/Parser/message.cpp

@@ -211,6 +211,26 @@ void Message::Emit(llvm::raw_ostream &o, const AllCookedSources &allCooked,
   }
 }
 
+// Messages are equal if they're for the same location and text, and the user
+// visible aspects of their attachments are the same
+bool Message::operator==(const Message &that) const {
+  if (!AtSameLocation(that) || ToString() != that.ToString()) {
+    return false;
+  }
+  const Message *thatAttachment{that.attachment_.get()};
+  for (const Message *attachment{attachment_.get()}; attachment;
+       attachment = attachment->attachment_.get()) {
+    if (!thatAttachment ||
+        attachment->attachmentIsContext_ !=
+            thatAttachment->attachmentIsContext_ ||
+        *attachment != *thatAttachment) {
+      return false;
+    }
+    thatAttachment = thatAttachment->attachment_.get();
+  }
+  return true;
+}
+
 bool Message::Merge(const Message &that) {
   return AtSameLocation(that) &&
       (!that.attachment_.get() ||
@@ -305,8 +325,14 @@ void Messages::Emit(llvm::raw_ostream &o, const AllCookedSources &allCooked,
   }
   std::stable_sort(sorted.begin(), sorted.end(),
       [](const Message *x, const Message *y) { return x->SortBefore(*y); });
+  const Message *lastMsg{nullptr};
   for (const Message *msg : sorted) {
+    if (lastMsg && *msg == *lastMsg) {
+      // Don't emit two identical messages for the same location
+      continue;
+    }
     msg->Emit(o, allCooked, echoSourceLines);
+    lastMsg = msg;
   }
 }
 

flang/test/Semantics/allocate02.f90

@@ -44,6 +44,5 @@ subroutine C943_C944(src, src2)
   !ERROR: At most one of source-expr and type-spec may appear in a ALLOCATE statement
   allocate(y3, source=src, stat=stat, errmsg=msg, mold=mld)
   !ERROR: At most one of source-expr and type-spec may appear in a ALLOCATE statement
-  !ERROR: At most one of source-expr and type-spec may appear in a ALLOCATE statement
   allocate(real:: y4, source=src, stat=stat, errmsg=msg, mold=mld)
 end subroutine

flang/test/Semantics/array-constr-big.f90

@@ -0,0 +1,28 @@
+! RUN: %S/test_errors.sh %s %t %flang_fc1
+! Ensure that evaluating a very large array constructor does not crash the
+! compiler
+program BigArray
+  integer, parameter :: limit = 30
+  !ERROR: Must be a constant value
+  integer(foo),parameter :: jval4(limit,limit,limit) = &
+    !ERROR: Must be a constant value
+    reshape( (/ &
+      ( &
+        ( &
+          (0,ii=1,limit), &
+          jj=-limit,kk &
+          ), &
+          ( &
+            i4,jj=-kk,kk &
+          ), &
+          ( &
+            ( &
+              !ERROR: Must be a constant value
+              0_foo,ii=1,limit &
+            ),
+            jj=kk,limit &
+          ), &
+        kk=1,limit &
+      ) /), &
+             (/ limit /) )
+end

flang/test/Semantics/io06.f90

@@ -35,7 +35,6 @@
   !ERROR: REWIND statement must have a UNIT number specifier
   rewind(iostat=stat2)
 
-  !ERROR: Duplicate ERR specifier
   !ERROR: Duplicate ERR specifier
   flush(err=9, unit=10, &
         err=9, &

flang/test/Semantics/omp-atomic.f90

@@ -27,7 +27,6 @@
   a = a + 1
   !$omp end atomic
 
-  !ERROR: expected end of line
   !ERROR: expected end of line
   !$omp atomic read write
   a = a + 1
@@ -41,7 +40,6 @@
   !$omp atomic num_threads(4)
   a = a + 1
 
-  !ERROR: expected end of line
   !ERROR: expected end of line
   !$omp atomic capture num_threads(4)
   a = a + 1

flang/test/Semantics/omp-clause-validity01.f90

@@ -215,7 +215,6 @@
      a = 3.14
   enddo
 
-  !ERROR: Clause LINEAR is not allowed if clause ORDERED appears on the DO directive
   !ERROR: Clause LINEAR is not allowed if clause ORDERED appears on the DO directive
   !ERROR: The parameter of the ORDERED clause must be a constant positive integer expression
   !$omp do ordered(1-1) private(b) linear(b) linear(a)

flang/test/Semantics/omp-flush01.f90

@@ -22,16 +22,13 @@
     array = (/1, 2, 3, 4, 5, 6, 7, 8, 9, 10/)
     !$omp flush acquire
 
-    !ERROR: expected end of line
     !ERROR: expected end of line
     !$omp flush private(array)
     !ERROR: expected end of line
-    !ERROR: expected end of line
     !$omp flush num_threads(4)
 
     ! Mix allowed and not allowed clauses.
     !ERROR: expected end of line
-    !ERROR: expected end of line
     !$omp flush num_threads(4) acquire
   end if
   !$omp end parallel

flang/test/Semantics/resolve70.f90

@@ -24,7 +24,6 @@ subroutine s()
 
   ! ac-spec for an array constructor
   !ERROR: ABSTRACT derived type may not be used here
-  !ERROR: ABSTRACT derived type may not be used here
   type (abstractType), parameter :: abstractArray(*) = (/ abstractType :: /)
 
   class(*), allocatable :: selector