[flang] Fix crash in structure constructor lowering (llvm#160769)

MLIR types created by lowering for structure constructors appear to be
sensitive to the ordering of their components in the typed expression
representation used for structure constructors and derived type constant
values.

At present, the components appear in source position order. When some
ancestral types are defined in modules, this ordering can cause their
components to be ordered after components defined in extended derived
types. This can lead to crashes from incompatible MLIR types.

To avoid this issue, sort structure constructor components first in
ascending order of derived type extension depth; retain source position
ordering for components in the same derived type and for error recovery
situations.

Fixes llvm#143740.

Author: klausler

flang/lib/Evaluate/constant.cpp

@@ -389,7 +389,45 @@ std::size_t Constant<SomeDerived>::CopyFrom(const Constant<SomeDerived> &source,
   return Base::CopyFrom(source, count, resultSubscripts, dimOrder);
 }
 
+static std::optional<int> DerivedTypeDepth(const semantics::Scope &scope) {
+  if (scope.IsDerivedType()) {
+    for (auto iter{scope.cbegin()}; iter != scope.cend(); ++iter) {
+      const Symbol &symbol{*iter->second};
+      if (symbol.test(Symbol::Flag::ParentComp)) {
+        if (const semantics::DeclTypeSpec *type{symbol.GetType()}) {
+          if (const semantics::DerivedTypeSpec *derived{type->AsDerived()}) {
+            const semantics::Scope *parent{derived->scope()};
+            if (!parent) {
+              parent = derived->typeSymbol().scope();
+            }
+            if (parent) {
+              if (auto parentDepth{DerivedTypeDepth(*parent)}) {
+                return 1 + *parentDepth;
+              }
+            }
+          }
+        }
+        return std::nullopt; // error recovery
+      }
+    }
+    return 0;
+  } else {
+    return std::nullopt; // error recovery
+  }
+}
+
 bool ComponentCompare::operator()(SymbolRef x, SymbolRef y) const {
+  if (&x->owner() != &y->owner()) {
+    // Not components of the same derived type; put ancestors' components first.
+    if (auto xDepth{DerivedTypeDepth(x->owner())}) {
+      if (auto yDepth{DerivedTypeDepth(y->owner())}) {
+        if (*xDepth != *yDepth) {
+          return *xDepth < *yDepth;
+        }
+      }
+    }
+  }
+  // Same derived type, distinct instantiations, or error recovery.
   return semantics::SymbolSourcePositionCompare{}(x, y);
 }
 

flang/test/Evaluate/Inputs/comporder1.mod

@@ -0,0 +1,6 @@
+!mod$ v1 sum:64657f78d85da21d
+module comporder1
+type::base
+integer(4)::c1
+end type
+end

flang/test/Evaluate/Inputs/comporder2.mod

@@ -0,0 +1,8 @@
+!mod$ v1 sum:3235f4a02cdad423
+!need$ 64657f78d85da21d n comporder1
+module comporder2
+use comporder1,only:base
+type,extends(base)::intermediate
+integer(4)::c2
+end type
+end

flang/test/Evaluate/comporder.f90

@@ -0,0 +1,41 @@
+!RUN: %flang_fc1 -fdebug-unparse -I%S/Inputs %s | FileCheck %s
+program main
+  use comporder2
+  type, extends(intermediate) :: last
+    integer c3
+  end type
+  !CHECK:PRINT *, last(c1=1_4,c2=2_4,c3=3_4)
+  print *, last(1,2,3)
+  !CHECK:PRINT *, last(c1=11_4,c2=12_4,c3=13_4)
+  print *, last(c3=13,c2=12,c1=11)
+  !CHECK:PRINT *, last(c1=21_4,c2=22_4,c3=23_4)
+  print *, last(c3=23,c1=21,c2=22)
+  !CHECK:PRINT *, last(c1=31_4,c2=32_4,c3=33_4)
+  print *, last(c2=32,c3=33,c1=31)
+  !CHECK:PRINT *, last(c1=41_4,c2=42_4,c3=43_4)
+  print *, last(c2=42,c1=41,c3=43)
+  !CHECK:PRINT *, last(c1=51_4,c2=52_4,c3=53_4)
+  print *, last(c1=51,c3=53,c2=52)
+  !CHECK:PRINT *, last(c1=61_4,c2=62_4,c3=63_4)
+  print *, last(c1=61,c2=62,c3=63)
+  !CHECK:PRINT *, last(intermediate=intermediate(c1=71_4,c2=72_4),c3=73_4)
+  print *, last(c3=73,intermediate=intermediate(c2=72,c1=71))
+  !CHECK:PRINT *, last(intermediate=intermediate(c1=81_4,c2=82_4),c3=83_4)
+  print *, last(c3=83,intermediate=intermediate(c1=81,c2=82))
+  !CHECK:PRINT *, last(intermediate=intermediate(c1=91_4,c2=92_4),c3=93_4)
+  print *, last(intermediate(c2=92,c1=91),c3=93)
+  !CHECK:PRINT *, last(intermediate=intermediate(c1=101_4,c2=102_4),c3=103_4)
+  print *, last(intermediate(c1=101,c2=102),c3=103)
+  !CHECK:PRINT *, last(intermediate=intermediate(base=base(c1=111_4),c2=112_4),c3=113_4)
+  print *, last(c3=113,intermediate=intermediate(c2=112,base=base(c1=111)))
+  !CHECK:PRINT *, last(intermediate=intermediate(base=base(c1=121_4),c2=122_4),c3=123_4)
+  print *, last(c3=123,intermediate=intermediate(base(c1=121),c2=122))
+  !CHECK:PRINT *, last(intermediate=intermediate(base=base(c1=131_4),c2=132_4),c3=133_4)
+  print *, last(intermediate(c2=132,base=base(c1=131)),c3=133)
+  !CHECK:PRINT *, last(intermediate=intermediate(base=base(c1=141_4),c2=142_4),c3=143_4)
+  print *, last(intermediate(base(c1=141),c2=142),c3=143)
+  !CHECK:PRINT *, last(base=base(c1=151_4),c2=152_4,c3=153_4)
+  print *, last(base(151),c3=153,c2=152)
+  !CHECK:PRINT *, last(base=base(c1=161_4),c2=162_4,c3=163_4)
+  print *, last(base(161),c2=162,c3=163)
+end