[fir] Add array value copy pass

[clementval]

Summary

This patch upstream the array value copy pass.

Transform the set of array value primitives to a memory-based array
representation.

The Ops array_load, array_store, array_fetch, and array_update are
used to manage abstract aggregate array values. A simple analysis is done
to determine if there are potential dependences between these operations.
If not, these array operations can be lowered to work directly on the memory
representation. If there is a potential conflict, a temporary is created
along with appropriate copy-in/copy-out operations. Here, a more refined
analysis might be deployed, such as using the affine framework.

This pass is required before code gen to the LLVM IR dialect.

This patch is part of the upstreaming effort from fir-dev branch. The
pass is bringing quite a lot of file with it.

Co-authored-by: Jean Perier <[e-mail]>
Co-authored-by: Eric Schweitz <[e-mail]>
Co-authored-by: V Donaldson <[e-mail]>

[mehdi_amini]

flang/lib/Optimizer/Transforms/ArrayValueCopy.cpp

553

This condition does not seem tested

584

This case seems untested.

598

I can delete the 4 lines above (the if and its body) and the test still passes

618

This condition doesn't seem tested

619

This condition doesn't seem tested.

636

Actually this entire method isn't covered by the test

662

The reverse can be deleted here and the test still pass.

[clementval]

In D111337#3089322, @mehdi_amini wrote:

I took a few minutes to evaluate more precisely the level of testing, see inline: we're very far from covering our bases here (and this is far from exhaustive!).

I would suggest going back to first principles in terms of testing and building some solid and minimal tests for the passes you're trying to upstream.
I know you're not necessarily the author of the passes, and I suggest to involve the author(s) of the code ahead of time to improve the testing before attempting to upstream all of this.

I agree with you that this test does not cover 100% of the pass. We have more extensive tests but they cannot be upstream right now since they are using another tool not upstreamed yet. This is the problem with upstreaming small chunk. Of course I'm trying to add tests where I can but this one can have some more. I'll rework on this patch and add more fir to fir tests.

[mehdi_amini]

We have more extensive tests but they cannot be upstream right now since they are using another tool not upstreamed yet. This is the problem with upstreaming small chunk.

I'm not really sure what "other tool" is supposed to provide the basic coverage for testing a pass? In general it is "IR in, IR out" just like the test here.

I'm wary by the view that the issue is with the "small chunk" while on the contrary, the "small chunk" is working exactly as intended here: it points as fairly important testing issues for example.

[clementval]

Add more extensive tests in flang/test/Fir/array-value-copy.fir

flang/test/Fir/array-modify.fir has been merged with the new
test file.

Remove some code in the pass that cannot be tested now with
the current upstreaming state.

[clementval]

The latest update to this patch add a new flang/test/Fir/array-value-copy.fir file that cover the array-value-copy in more details.

flang/lib/Optimizer/Transforms/ArrayValueCopy.cpp

553

Test added in flang/test/Fir/array-value-copy.fir cover this part as well.

584

Test added in flang/test/Fir/array-value-copy.fir cover this code.

598

The test added in flang/test/Fir/array-value-copy.fir that uses array of derived types is covering this part of the code.

618

This will require fir.array_acccess/fir.array_amend to be tested correctly with character arrays. Remove it from this upstreaming patch for now.

619

This will require fir.array_acccess/fir.array_amend to be tested correctly with character arrays. Remove it from this upstreaming patch for now.

636

This will require fir.array_acccess/fir.array_amend to be tested correctly with character arrays. Remove it from this upstreaming patch for now.

662

The test with multidimensional array added in flang/test/Fir/array-value-copy.fir make sure the reverse indices is tested correctly.

834

This cannot be tested currently with what is upstreamed. Remove it for the moment.

861

Test covering fir.array_update conversion have been added in flang/test/Fir/array-value-copy.fir.

[clementval]

@mehdi_amini Can we move on with this one now that we have better test coverage?

[mehdi_amini]

Testing is better now, thanks!
I haven't seen a follow up on https://reviews.llvm.org/D111288#inline-1071935 ; but this is a recurring issue that affects this revision as well.

[clementval]

In D111337#3100539, @mehdi_amini wrote:

Testing is better now, thanks!
I haven't seen a follow up on https://reviews.llvm.org/D111288#inline-1071935 ; but this is a recurring issue that affects this revision as well.

I replied on D111288 about the next steps for auto. I'll update this patch where it makes sense.

[clementval]

Replace some auto occurences + rebase

[clementval]

In D111337#3100539, @mehdi_amini wrote:

Testing is better now, thanks!
I haven't seen a follow up on https://reviews.llvm.org/D111288#inline-1071935 ; but this is a recurring issue that affects this revision as well.

@mehdi_amini I have updated this patch and removed some auto occurrences. As mentioned we will post soon a small guideline for Flang doc that precise that we are using the MLIR style in folder related to MLIR (Optimizer, Lower) and precise how we use auto. Don't worry it is not a "use auto everywhere" but rather a clarification of the LLVM guidelines that is somewhat open. I have looked through the MLIR codebase and I think we are pretty much on par with the use of auto.
I hope we can move forward with this patch now.

[mehdi_amini]

Thanks for the update, the size makes it tractable now, and the test helps to figure out the corner cases when the code isn't straightforward.

I mostly looked at ArrayCopyAnalysis here.

One thing that can be problematic for future patches: the control flow in general should be handled with the ControlFlowInterface which may not be yet implemented on the relevant FIR ops. But that had a significant impact on the code inside the passes, so likely something to consider prioritizing downstream.

flang/include/flang/Optimizer/Builder/FIRBuilder.h

403

Is there a use for this method? (same for the other above)

417

No definition added for this declaration?

467

Is this method used somewhere? (Same for the two above)

flang/include/flang/Optimizer/Transforms/Factory.h

146

Do you know why this is returning a vector instead of an OperandRange? (this is a question for the ShapeOp definition).

It seems strange to force copy on all the accessors when they may just want to iterate on the Values...

flang/include/flang/Optimizer/Transforms/Passes.td

37

Can you just let me know what fails if you remove any of these?

flang/lib/Optimizer/Builder/FIRBuilder.cpp

289

Why the commented out code? Can it just be removed?

363

Is this method used?

flang/lib/Optimizer/Transforms/ArrayValueCopy.cpp

90

I don't understand this comment (I read it 4 times though).

Edit: the comment on the implementation is actually much more clear:

/// Find all the array operations that access the array value that is loaded by
/// the array load operation, `load`.

109

A comment around the constructor (or the member variable definition) would be helpful to say:

If provided, the `loopRegion` is the body of a loop that produces the array of interest.

(or something like that)

117

121

I am very concerned about a recursive algorithm on def-use chain: this is a ticking bomb for a stack overflow in the compiler.
Can you make this an iterative algorithm with an explicit stack?

147

(here and elsewhere)

156

Of all the if above, only the DoLoopOp seems tested. There are some specific cases for the treatment of EmboxOp and ArrayMergeStoreOp that likely should be covered

230

This is the only method actually accessed outside of the class, can you make sure it is the only one in the public section?

Everything else could be private (constructor included)

235

Should this also support other kind of loops? (if so add a TODO)

251

Isn't this whole function isAncestor?

return loopRegion->isAncestor(op->getParentRegion());

Edit: actually, loopRegion may be null here but it isn't obvious from the class invariant. So instead:

return loopRegion && loopRegion->isAncestor(op->getParentRegion());

260

261

Same recursion issue here.

278

279

290

303

304

305

I don't understand how this can happen: an OpOperand does not have a lifetime outside of its owner operation IIRC

309

Make the type explicit (you're doing arithmetic arg - 1 on the next line, I shouldn't have to think about the impact of signedness here)

310

The finalValue() check here is also another case not covered in the test.

finalValue isn't documented in ODS and initArgs isn't documented either, it'd be great if this could be addressed (separately from this revision of course)

310

315

316–320

This loop isn't great when you already have everything to compute offsets.

In general all the special casing for the Loop, branches, and the control flow in general should be handled with the ControlFlowInterface: https://github.com/llvm/llvm-project/blob/main/mlir/include/mlir/Interfaces/ControlFlowInterfaces.td

This would make the code entirely uniform, and any new op that has to do with the control flow would not require to modify the pass.

I'm fine if you want to handle this later for this pass (please add a big // TODO: this need to be updated to use the control-flow interface), but I'm not sure we should upstream many other passes that would be implemented without going through interfaces.

329–330

361

Seems like we're storing much more than what we need actually, I tried locally to change loadMapSets to store the SmallVector of "accesses" and it is just enough (and it makes subsequent call even easier).

Here is a patch: https://gist.github.com/joker-eph/8f00e79783688bf6349b6b5d9d44a480

372

This is a complex body, worth using braces here

373

In general, early continue reduces indentation:

374–376

If this is a pattern that repeats, it'll be worth having a helper (potentially a method on ArrayLoadOp : Type getUnboxedLoadedType() or something like that)

390

This would be worth a comment I think

417

Seems like this should be an assert

419–422

SmallVector has an operator==, is this different?

439–443

Isn't this entire loop nest + recursion just a walk?

Also, I'd change the signature of the construct method to be:
void ArrayCopyAnalysis::construct(Operation *topLevelOp) {

So that you can just write topLevelOp->walk([&] (Operation *op) {

(the only reason for the current signature was the recursion as far as I can tell)

440

Non trivial nesting should use braces ( https://llvm.org/docs/CodingStandards.html#don-t-use-braces-on-simple-single-statement-bodies-of-if-else-loop-statements )

445

It may be worth moving all the temporary storage outside of the walk, and then just calling .clear() before using them here (which is already done inside arrayAccesses() by the way, even though it is for nothing right now). That way they would "grow" only once and the memory can be reused over and over.

449

Where is the guarantee that this cast will always succeed coming from?
The doc for ArrayMergeStoreOp does not mention anything, and there is no verifier for ArrayMergeStoreOp

469

Can this check fail? Right now the contract of arrayAccesses() is to only return these three operations, and conflictOnMerge would fail if there were any other op.
Can this be replace with an assert here?

470

Same (I think) but with a single map lookup if (!useMap.insert({acc, &op}).second) {

475

Seems like this should signal an error? Is this conservative to just "continue" here?

660

In general, use llvm::function_ref instead of std::function when you don't take ownership (this avoid potential heap allocation and copies)

663

Alternatively: auto loadOp = mlir::cast<ArrayLoadOp>(useMap.lookup(op)); and use loadOp everywhere instead of having load and loadOp

674

681

700

795

824

(typo)

[clementval]

In D111337#3105093, @mehdi_amini wrote:

Thanks for the update, the size makes it tractable now, and the test helps to figure out the corner cases when the code isn't straightforward.

I mostly looked at ArrayCopyAnalysis here.

One thing that can be problematic for future patches: the control flow in general should be handled with the ControlFlowInterface which may not be yet implemented on the relevant FIR ops. But that had a significant impact on the code inside the passes, so likely something to consider prioritizing downstream.

Tried to address most of the comments. I think we will need couple of follow up patches to make it easier to move foward (and sync back in between).

flang/include/flang/Optimizer/Builder/FIRBuilder.h

403

This one is not used currently (removed from this patch). The one above is.

417

Mistake of the rebase. It's the same as the one just above. Removed.

flang/include/flang/Optimizer/Transforms/Factory.h

146

I don't think there is a good reason for this. Will add a TODO so we can address this in a follow up patch since it touches the op definiton and probably other places in the code.

flang/include/flang/Optimizer/Transforms/Passes.td

37

These were artifact from the time it didn't work without it. Looks like it is now fine to remove them.

flang/lib/Optimizer/Builder/FIRBuilder.cpp

289

Yeah will be added later anyway.

flang/lib/Optimizer/Transforms/ArrayValueCopy.cpp

90

Updated.

121

Would it be ok to address this in a follow up patch? I just added a todo right now.

316–320

I think it is better to handle this later (switch to control flow interface) as it will bring lots of changes with it.

361

Thanks for the patch. look like it does the trick.

439–443

Thanks for the inputs here. Replace by a simple walk.

449

ArrayMergeStoreOp verifier has this:

if (!isa<ArrayLoadOp>(op.original().getDefiningOp()))
    return op.emitOpError("operand #0 must be result of a fir.array_load op");

824

Thanks.

[clementval]

flang/lib/Optimizer/Transforms/ArrayValueCopy.cpp

156

Added some test and removed the IterWhileOp and EmboxOp special case since they will be added later when we can add better test coverage.

235

From a practical point of view, array operations are normally generated with DoLoopOp so there is no real code that need the other loops. From a purely FIR point of view, of course someone could write some IterWhileOp with array operations but we do not have use cases in mind for that.
I added a comment to make precise this in the code.

261

Same here. Would be great if we can address that in a follow up patch directly after finishing this one.

310

They are loops with finalValue and iterArgs in the tests. Will add the documentation in another path. Added on my todo list.

[mehdi_amini]

I think you haven't updated the revision yet.

flang/lib/Optimizer/Transforms/ArrayValueCopy.cpp

121

How to we track that this get addressed though? I'm wary of TODO that will stay here for a while.
Is someone gonna commit to work on this ASAP?

[clementval]

Address various review comments + rebase

[clementval]

In D111337#3147981, @mehdi_amini wrote:

I think you haven't updated the revision yet.

Sorry, it was stuck on the arc lint phase :(

flang/lib/Optimizer/Transforms/ArrayValueCopy.cpp

121

I can work on that in the next 2-3 weeks probably.

[mehdi_amini]

Looks fine overall, thanks!

There are still a few minor issues: dead code in particular, but also the code documentation is a bit on the light side for something that really does not seem trivial to me.
(+ some inline comments)

flang/include/flang/Optimizer/Builder/FIRBuilder.h

66

Seems unused in this patch?

350

Unused in this patch?

423

This is unused in this patch?

434

Same

443

Unused as well (and undocumented)

flang/include/flang/Optimizer/Builder/Runtime/RTBuilder.h

360

Can you document all this macro system?
Does it need to in header? In general macros defined in header is "dangerous", should these be prefixed with Fir or something?

364

You could add this in the function body if this is really needed, or what do I misse?

flang/include/flang/Optimizer/Transforms/Factory.h

45

This method isn't used anywhere either

148

I don't see a call-site for this either

191–193

Move this assert with the one a few lines above? They seem related.
Using the assert(!shapeVal || form like above you can avoid the if and the nesting

254

The createLoopNest functions seem unused as well

flang/lib/Optimizer/Builder/FIRBuilder.cpp

347

353

Seems like there should be a llvm_unreachable after this error is emitted

355

I don't quite find what the .match( call resolves to on the fir::ExtendedValue class? Any tip?

357

(same below)

382

Can you comment on what this is supposed to match?

flang/lib/Optimizer/Transforms/ArrayValueCopy.cpp

356

not sure if it is a Value here?

454–463

I commented on this before I believe: you have two map lookup when one would be enough I think:

469

You marked it done, but I don't see it done in the code.

645

672

(previous use of useMap.lookup() in this function spelled out the type)

717

This branch may be worth a comment.

In general the entire pattern is a bit light on documentation.

731

You can reduce the indentation in the code by inverting the else and the then branch:

if (!inEleTy.isa<fir::RecordType>())
   llvm::report_fatal_error("not a legal reference type");

Also, I'm not sure why it isn't an assertion here? If this can't be then shouldn't we degrade more gracefully?

assert(inEleTy.isa<fir::RecordType>());

[kiranchandramohan]

flang/lib/Optimizer/Transforms/ArrayValueCopy.cpp

121

I have created an issue to capture this in the upstreaming FIR Passes board.
https://github.com/flang-compiler/f18-llvm-project/projects/7
https://github.com/flang-compiler/f18-llvm-project/issues/1268

@clementval if this is just about converting to an iterative version then we can help.

[clementval]

Address review comments

flang/lib/Optimizer/Builder/FIRBuilder.cpp

355

https://github.com/llvm/llvm-project/blob/102d2a8a99057b2f54ca97661f862e33d055171a/flang/include/flang/Optimizer/Builder/BoxValue.h#L406

flang/lib/Optimizer/Transforms/ArrayValueCopy.cpp

121

Yeah this is it. With all the changes (compare to fir-dev) in this patch it would be nice to be able to make a sync before this kind of refactoring.

454–463

Yeah sorry I thought I made the update. Must have been lost in an other branch.

645

Sorry missed this update as well. It's updated.

717

ArrayUpdateOp is actually not supported for reference type anymore since there is a new op for it. This code is removed.

731

Replaced with an assert and remove the if-else

[mehdi_amini]

@kiranchandramohan do you plan on reviewing/approving the current version of the patch?

I don't have any more comment than before, there are just a few that are still pending.

flang/include/flang/Optimizer/Builder/FIRBuilder.h

423

Missed this one?

flang/include/flang/Optimizer/Builder/Runtime/RTBuilder.h

360

Marked done, but I don't see a change here?

flang/lib/Optimizer/Builder/FIRBuilder.cpp

30

This is marked done, but you actually extracted it as-is and landed it in https://reviews.llvm.org/D112057 ; can you address that as well (in a separate patch, but I'm wary of losing track of this).

46

Same here: you marked it done without commenting and landed it separately.

355

Thanks!

Something really confusing is that there is another class with the same name, and located in a header with the same filename!
(in include/flang/Lower/Support/BoxValue.h)

flang/lib/Optimizer/Transforms/ArrayValueCopy.cpp

469

Yet again
(line 452 by now)

[clementval]

Address missed comments

[clementval]

flang/include/flang/Optimizer/Builder/FIRBuilder.h

423

My bad. I thought I removed it.

flang/include/flang/Optimizer/Builder/Runtime/RTBuilder.h

360

No idea why it was mark done since I don't even remember reading this one. I have added some comments and prefixed the macros. I kept mkRTKey without prefix since it is used outside.

flang/lib/Optimizer/Builder/FIRBuilder.cpp

30

Sorry, I marked it as done here to be able to navigate more easily in the comments since it was not part of this part anymore. I'll look at it in another patch.

46

Is this really important? If so I'll update it.

flang/lib/Optimizer/Transforms/ArrayValueCopy.cpp

469

My bad. I'm sure I made the change but I probably mixed up my branches and it was not in this update. Updated now.

[clementval]

flang/lib/Optimizer/Builder/FIRBuilder.cpp

30

Patch here: https://reviews.llvm.org/D114630

[kiranchandramohan]

In D111337#3154805, @mehdi_amini wrote:

@kiranchandramohan do you plan on reviewing/approving the current version of the patch?

I don't have any more comment than before, there are just a few that are still pending.

The patch LGTM. Thanks for going through the patch in detail and pointing out various issues. And thanks to @clementval for addressing most of the issues. I agree that the remaining issues can be dealt with later. I have created a few github issues to follow up on later work.

Nit: The changes in the following files are in other patches or have been merged. How are you planning to handle this?
flang/lib/Optimizer/Dialect/FIRType.cpp
flang/include/flang/Optimizer/Builder/Runtime/RTBuilder.h
flang/include/flang/Optimizer/Builder/Runtime/Assign.h
flang/lib/Optimizer/Builder/Runtime/Assign.cpp

flang/lib/Optimizer/Builder/FIRBuilder.cpp

30

Raised an issue for this https://github.com/flang-compiler/f18-llvm-project/issues/1273

46

Might be easier to read for newcomers.

355

I think there is some refactoring going on, where code in Lower is moved to the Optimizer/Builder directory. I think once all the code is moved the code in Lower can be deleted.

flang/lib/Optimizer/Transforms/ArrayValueCopy.cpp

121

OK. I have moved this to the post-upstream board.

310

Raised https://github.com/flang-compiler/f18-llvm-project/issues/1274

316–320

Raised https://github.com/flang-compiler/f18-llvm-project/issues/1275 to look into this later.

[clementval]

In D111337#3155551, @kiranchandramohan wrote:

In D111337#3154805, @mehdi_amini wrote:

@kiranchandramohan do you plan on reviewing/approving the current version of the patch?

I don't have any more comment than before, there are just a few that are still pending.

The patch LGTM. Thanks for going through the patch in detail and pointing out various issues. And thanks to @clementval for addressing most of the issues. I agree that the remaining issues can be dealt with later. I have created a few github issues to follow up on later work.

Nit: The changes in the following files are in other patches or have been merged. How are you planning to handle this?
flang/lib/Optimizer/Dialect/FIRType.cpp
flang/include/flang/Optimizer/Builder/Runtime/RTBuilder.h
flang/include/flang/Optimizer/Builder/Runtime/Assign.h
flang/lib/Optimizer/Builder/Runtime/Assign.cpp

@kiranchandramohan I'm just gonna rebase on main since some of the patch have landed and I'll merge in the change requested from this review.

[clementval]

Rebase

[clementval]

@kiranchandramohan I just did a rebase. Let me know if it is still ok for you.

[mehdi_amini]

flang/include/flang/Optimizer/Builder/FIRBuilder.h

25

Can you double check that these are needed in this header? It's not clear from the change in this file

[clementval]

Remove extra headers

[clementval]

flang/include/flang/Optimizer/Builder/FIRBuilder.h

25

Removed

[kiranchandramohan]

LGTM.

flang/lib/Optimizer/Builder/FIRBuilder.cpp

119

Nit: Is this change necessary?

[clementval]

Revert useless change

flang/include/flang/Optimizer/Builder/BoxValue.h

+//===-- BoxValue.h -- internal box values -----------------------*- 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
+//
+//===----------------------------------------------------------------------===//
+//
+// Coding style: https://mlir.llvm.org/getting_started/DeveloperGuide/
+//
+//===----------------------------------------------------------------------===//
+
+#ifndef FORTRAN_OPTIMIZER_BUILDER_BOXVALUE_H
+#define FORTRAN_OPTIMIZER_BUILDER_BOXVALUE_H
+
+#include "flang/Optimizer/Dialect/FIRType.h"
+#include "flang/Optimizer/Support/FatalError.h"
+#include "flang/Optimizer/Support/Matcher.h"
+#include "mlir/IR/OperationSupport.h"
+#include "mlir/IR/Value.h"
+#include "llvm/ADT/SmallVector.h"
+#include "llvm/Support/Compiler.h"
+#include "llvm/Support/raw_ostream.h"
+#include <utility>
+
+namespace fir {
+class CharBoxValue;
+class ArrayBoxValue;
+class CharArrayBoxValue;
+class ProcBoxValue;
+class MutableBoxValue;
+class BoxValue;
+
+llvm::raw_ostream &operator<<(llvm::raw_ostream &, const CharBoxValue &);
+llvm::raw_ostream &operator<<(llvm::raw_ostream &, const ArrayBoxValue &);
+llvm::raw_ostream &operator<<(llvm::raw_ostream &, const CharArrayBoxValue &);
+llvm::raw_ostream &operator<<(llvm::raw_ostream &, const ProcBoxValue &);
+llvm::raw_ostream &operator<<(llvm::raw_ostream &, const MutableBoxValue &);
+llvm::raw_ostream &operator<<(llvm::raw_ostream &, const BoxValue &);
+
+//===----------------------------------------------------------------------===//
+//
+// Boxed values
+//
+// Define a set of containers used internally by the lowering bridge to keep
+// track of extended values associated with a Fortran subexpression. These
+// associations are maintained during the construction of FIR.
+//
+//===----------------------------------------------------------------------===//
+
+/// Most expressions of intrinsic type can be passed unboxed. Their properties
+/// are known statically.
+using UnboxedValue = mlir::Value;
+
+/// Abstract base class.
+class AbstractBox {
+public:
+  AbstractBox() = delete;
+  AbstractBox(mlir::Value addr) : addr{addr} {}
+
+  /// FIXME: this comment is not true anymore since genLoad
+  /// is loading constant length characters. What is the impact  /// ?
+  /// An abstract box always contains a memory reference to a value.
+  mlir::Value getAddr() const { return addr; }
+
+protected:
+  mlir::Value addr;
+};
+
+/// Expressions of CHARACTER type have an associated, possibly dynamic LEN
+/// value.
+class CharBoxValue : public AbstractBox {
+public:
+  CharBoxValue(mlir::Value addr, mlir::Value len)
+      : AbstractBox{addr}, len{len} {
+    if (addr && addr.getType().template isa<fir::BoxCharType>())
+      fir::emitFatalError(addr.getLoc(),
+                          "BoxChar should not be in CharBoxValue");
+  }
+
+  CharBoxValue clone(mlir::Value newBase) const { return {newBase, len}; }
+
+  /// Convenience alias to get the memory reference to the buffer.
+  mlir::Value getBuffer() const { return getAddr(); }
+
+  mlir::Value getLen() const { return len; }
+  friend llvm::raw_ostream &operator<<(llvm::raw_ostream &,
+                                       const CharBoxValue &);
+  LLVM_DUMP_METHOD void dump() const { llvm::errs() << *this; }
+
+protected:
+  mlir::Value len;
+};
+
+/// Abstract base class.
+/// Expressions of type array have at minimum a shape. These expressions may
+/// have lbound attributes (dynamic values) that affect the interpretation of
+/// indexing expressions.
+class AbstractArrayBox {
+public:
+  AbstractArrayBox() = default;
+  AbstractArrayBox(llvm::ArrayRef<mlir::Value> extents,
+                   llvm::ArrayRef<mlir::Value> lbounds)
+      : extents{extents.begin(), extents.end()}, lbounds{lbounds.begin(),
+                                                         lbounds.end()} {}
+
+  // Every array has extents that describe its shape.
+  const llvm::SmallVectorImpl<mlir::Value> &getExtents() const {
+    return extents;
+  }
+
+  // An array expression may have user-defined lower bound values.
+  // If this vector is empty, the default in all dimensions in `1`.
+  const llvm::SmallVectorImpl<mlir::Value> &getLBounds() const {
+    return lbounds;
+  }
+
+  bool lboundsAllOne() const { return lbounds.empty(); }
+  std::size_t rank() const { return extents.size(); }
+
+protected:
+  llvm::SmallVector<mlir::Value, 4> extents;
+  llvm::SmallVector<mlir::Value, 4> lbounds;
+};
+
+/// Expressions with rank > 0 have extents. They may also have lbounds that are
+/// not 1.
+class ArrayBoxValue : public AbstractBox, public AbstractArrayBox {
+public:
+  ArrayBoxValue(mlir::Value addr, llvm::ArrayRef<mlir::Value> extents,
+                llvm::ArrayRef<mlir::Value> lbounds = {})
+      : AbstractBox{addr}, AbstractArrayBox{extents, lbounds} {}
+
+  ArrayBoxValue clone(mlir::Value newBase) const {
+    return {newBase, extents, lbounds};
+  }
+
+  friend llvm::raw_ostream &operator<<(llvm::raw_ostream &,
+                                       const ArrayBoxValue &);
+  LLVM_DUMP_METHOD void dump() const { llvm::errs() << *this; }
+};
+
+/// Expressions of type CHARACTER and with rank > 0.
+class CharArrayBoxValue : public CharBoxValue, public AbstractArrayBox {
+public:
+  CharArrayBoxValue(mlir::Value addr, mlir::Value len,
+                    llvm::ArrayRef<mlir::Value> extents,
+                    llvm::ArrayRef<mlir::Value> lbounds = {})
+      : CharBoxValue{addr, len}, AbstractArrayBox{extents, lbounds} {}
+
+  CharArrayBoxValue clone(mlir::Value newBase) const {
+    return {newBase, len, extents, lbounds};
+  }
+
+  CharBoxValue cloneElement(mlir::Value newBase) const {
+    return {newBase, len};
+  }
+
+  friend llvm::raw_ostream &operator<<(llvm::raw_ostream &,
+                                       const CharArrayBoxValue &);
+  LLVM_DUMP_METHOD void dump() const { llvm::errs() << *this; }
+};
+
+/// Expressions that are procedure POINTERs may need a set of references to
+/// variables in the host scope.
+class ProcBoxValue : public AbstractBox {
+public:
+  ProcBoxValue(mlir::Value addr, mlir::Value context)
+      : AbstractBox{addr}, hostContext{context} {}
+
+  ProcBoxValue clone(mlir::Value newBase) const {
+    return {newBase, hostContext};
+  }
+
+  mlir::Value getHostContext() const { return hostContext; }
+
+  friend llvm::raw_ostream &operator<<(llvm::raw_ostream &,
+                                       const ProcBoxValue &);
+  LLVM_DUMP_METHOD void dump() const { llvm::errs() << *this; }
+
+protected:
+  mlir::Value hostContext;
+};
+
+/// Base class for values associated to a fir.box or fir.ref<fir.box>.
+class AbstractIrBox : public AbstractBox, public AbstractArrayBox {
+public:
+  AbstractIrBox(mlir::Value addr) : AbstractBox{addr} {}
+  AbstractIrBox(mlir::Value addr, llvm::ArrayRef<mlir::Value> lbounds,
+                llvm::ArrayRef<mlir::Value> extents)
+      : AbstractBox{addr}, AbstractArrayBox(extents, lbounds) {}
+  /// Get the fir.box<type> part of the address type.
+  fir::BoxType getBoxTy() const {
+    auto type = getAddr().getType();
+    if (auto pointedTy = fir::dyn_cast_ptrEleTy(type))
+      type = pointedTy;
+    return type.cast<fir::BoxType>();
+  }
+  /// Return the part of the address type after memory and box types. That is
+  /// the element type, maybe wrapped in a fir.array type.
+  mlir::Type getBaseTy() const {
+    return fir::dyn_cast_ptrOrBoxEleTy(getBoxTy());
+  }
+
+  /// Return the memory type of the data address inside the box:
+  /// - for fir.box<fir.ptr<T>>, return fir.ptr<T>
+  /// - for fir.box<fir.heap<T>>, return fir.heap<T>
+  /// - for fir.box<T>, return fir.ref<T>
+  mlir::Type getMemTy() const {
+    auto ty = getBoxTy().getEleTy();
+    if (fir::isa_ref_type(ty))
+      return ty;
+    return fir::ReferenceType::get(ty);
+  }
+
+  /// Get the scalar type related to the described entity
+  mlir::Type getEleTy() const {
+    auto type = getBaseTy();
+    if (auto seqTy = type.dyn_cast<fir::SequenceType>())
+      return seqTy.getEleTy();
+    return type;
+  }
+
+  /// Is the entity an array or an assumed rank ?
+  bool hasRank() const { return getBaseTy().isa<fir::SequenceType>(); }
+  /// Is this an assumed rank ?
+  bool hasAssumedRank() const {
+    auto seqTy = getBaseTy().dyn_cast<fir::SequenceType>();
+    return seqTy && seqTy.hasUnknownShape();
+  }
+  /// Returns the rank of the entity. Beware that zero will be returned for
+  /// both scalars and assumed rank.
+  unsigned rank() const {
+    if (auto seqTy = getBaseTy().dyn_cast<fir::SequenceType>())
+      return seqTy.getDimension();
+    return 0;
+  }
+  /// Is this a character entity ?
+  bool isCharacter() const { return fir::isa_char(getEleTy()); };
+  /// Is this a derived type entity ?
+  bool isDerived() const { return getEleTy().isa<fir::RecordType>(); };
+
+  bool isDerivedWithLengthParameters() const {
+    auto record = getEleTy().dyn_cast<fir::RecordType>();
+    return record && record.getNumLenParams() != 0;
+  };
+  /// Is this a CLASS(*)/TYPE(*) ?
+  bool isUnlimitedPolymorphic() const {
+    return getEleTy().isa<mlir::NoneType>();
+  }
+};
+
+/// An entity described by a fir.box value that cannot be read into
+/// another ExtendedValue category, either because the fir.box may be an
+/// absent optional and we need to wait until the user is referencing it
+/// to read it, or because it contains important information that cannot
+/// be exposed in FIR (e.g. non contiguous byte stride).
+/// It may also store explicit bounds or length parameters that were specified
+/// for the entity.
+class BoxValue : public AbstractIrBox {
+public:
+  BoxValue(mlir::Value addr) : AbstractIrBox{addr} { assert(verify()); }
+  BoxValue(mlir::Value addr, llvm::ArrayRef<mlir::Value> lbounds,
+           llvm::ArrayRef<mlir::Value> explicitParams,
+           llvm::ArrayRef<mlir::Value> explicitExtents = {})
+      : AbstractIrBox{addr, lbounds, explicitExtents},
+        explicitParams{explicitParams.begin(), explicitParams.end()} {
+    assert(verify());
+  }
+  // TODO: check contiguous attribute of addr
+  bool isContiguous() const { return false; }
+
+  friend llvm::raw_ostream &operator<<(llvm::raw_ostream &, const BoxValue &);
+  LLVM_DUMP_METHOD void dump() const { llvm::errs() << *this; }
+
+  llvm::ArrayRef<mlir::Value> getLBounds() const { return lbounds; }
+
+  // The extents member is not guaranteed to be field for arrays. It is only
+  // guaranteed to be field for explicit shape arrays. In general,
+  // explicit-shape will not come as descriptors, so this field will be empty in
+  // most cases. The exception are derived types with length parameters and
+  // polymorphic dummy argument arrays. It may be possible for the explicit
+  // extents to conflict with the shape information that is in the box according
+  // to 15.5.2.11 sequence association rules.
+  llvm::ArrayRef<mlir::Value> getExplicitExtents() const { return extents; }
+
+  llvm::ArrayRef<mlir::Value> getExplicitParameters() const {
+    return explicitParams;
+  }
+
+protected:
+  // Verify constructor invariants.
+  bool verify() const;
+
+  // Only field when the BoxValue has explicit length parameters.
+  // Otherwise, the length parameters are in the fir.box.
+  llvm::SmallVector<mlir::Value, 2> explicitParams;
+};
+
+/// Set of variables (addresses) holding the allocatable properties. These may
+/// be empty in case it is not deemed safe to duplicate the descriptor
+/// information locally (For instance, a volatile allocatable will always be
+/// lowered to a descriptor to preserve the integrity of the entity and its
+/// associated properties. As such, all references to the entity and its
+/// property will go through the descriptor explicitly.).
+class MutableProperties {
+public:
+  bool isEmpty() const { return !addr; }
+  mlir::Value addr;
+  llvm::SmallVector<mlir::Value, 2> extents;
+  llvm::SmallVector<mlir::Value, 2> lbounds;
+  /// Only keep track of the deferred length parameters through variables, since
+  /// they are the only ones that can change as per the deferred type parameters
+  /// definition in F2018 standard section 3.147.12.2.
+  /// Non-deferred values are returned by
+  /// MutableBoxValue.nonDeferredLenParams().
+  llvm::SmallVector<mlir::Value, 2> deferredParams;
+};
+
+/// MutableBoxValue is used for entities that are represented by the address of
+/// a box. This is intended to be used for entities whose base address, shape
+/// and type are not constant in the entity lifetime (e.g Allocatables and
+/// Pointers).
+class MutableBoxValue : public AbstractIrBox {
+public:
+  /// Create MutableBoxValue given the address \p addr of the box and the non
+  /// deferred length parameters \p lenParameters. The non deferred length
+  /// parameters must always be provided, even if they are constant and already
+  /// reflected in the address type.
+  MutableBoxValue(mlir::Value addr, mlir::ValueRange lenParameters,
+                  MutableProperties mutableProperties)
+      : AbstractIrBox(addr), lenParams{lenParameters.begin(),
+                                       lenParameters.end()},
+        mutableProperties{mutableProperties} {
+    // Currently only accepts fir.(ref/ptr/heap)<fir.box<type>> mlir::Value for
+    // the address. This may change if we accept
+    // fir.(ref/ptr/heap)<fir.heap<type>> for scalar without length parameters.
+    assert(verify() &&
+           "MutableBoxValue requires mem ref to fir.box<fir.[heap|ptr]<type>>");
+  }
+  /// Is this a Fortran pointer ?
+  bool isPointer() const {
+    return getBoxTy().getEleTy().isa<fir::PointerType>();
+  }
+  /// Is this an allocatable ?
+  bool isAllocatable() const {
+    return getBoxTy().getEleTy().isa<fir::HeapType>();
+  }
+  /// Does this entity has any non deferred length parameters ?
+  bool hasNonDeferredLenParams() const { return !lenParams.empty(); }
+  /// Return the non deferred length parameters.
+  llvm::ArrayRef<mlir::Value> nonDeferredLenParams() const { return lenParams; }
+  friend llvm::raw_ostream &operator<<(llvm::raw_ostream &,
+                                       const MutableBoxValue &);
+  LLVM_DUMP_METHOD void dump() const { llvm::errs() << *this; }
+
+  /// Set of variable is used instead of a descriptor to hold the entity
+  /// properties instead of a fir.ref<fir.box<>>.
+  bool isDescribedByVariables() const { return !mutableProperties.isEmpty(); }
+
+  const MutableProperties &getMutableProperties() const {
+    return mutableProperties;
+  }
+
+protected:
+  /// Validate the address type form in the constructor.
+  bool verify() const;
+  /// Hold the non-deferred length parameter values  (both for characters and
+  /// derived). Non-deferred length parameters cannot change dynamically, as
+  /// opposed to deferred type parameters (3.147.12.2).
+  llvm::SmallVector<mlir::Value, 2> lenParams;
+  /// Set of variables holding the extents, lower bounds and
+  /// base address when it is deemed safe to work with these variables rather
+  /// than directly with a descriptor.
+  MutableProperties mutableProperties;
+};
+
+class ExtendedValue;
+
+/// Get the base value of an extended value. Every type of extended value has a
+/// base value or is null.
+mlir::Value getBase(const ExtendedValue &exv);
+
+/// Get the LEN property value of an extended value. CHARACTER values have a LEN
+/// property.
+mlir::Value getLen(const ExtendedValue &exv);
+
+/// Pretty-print an extended value.
+llvm::raw_ostream &operator<<(llvm::raw_ostream &, const ExtendedValue &);
+
+/// Return a clone of the extended value `exv` with the base value `base`
+/// substituted.
+ExtendedValue substBase(const ExtendedValue &exv, mlir::Value base);
+
+/// Is the extended value `exv` an array?
+bool isArray(const ExtendedValue &exv);
+
+/// Get the type parameters for `exv`.
+llvm::SmallVector<mlir::Value> getTypeParams(const ExtendedValue &exv);
+
+/// An extended value is a box of values pertaining to a discrete entity. It is
+/// used in lowering to track all the runtime values related to an entity. For
+/// example, an entity may have an address in memory that contains its value(s)
+/// as well as various attribute values that describe the shape and starting
+/// indices if it is an array entity.
+class ExtendedValue : public details::matcher<ExtendedValue> {
+public:
+  using VT =
+      std::variant<UnboxedValue, CharBoxValue, ArrayBoxValue, CharArrayBoxValue,
+                   ProcBoxValue, BoxValue, MutableBoxValue>;
+
+  ExtendedValue() : box{UnboxedValue{}} {}
+  template <typename A, typename = std::enable_if_t<
+                            !std::is_same_v<std::decay_t<A>, ExtendedValue>>>
+  constexpr ExtendedValue(A &&a) : box{std::forward<A>(a)} {
+    if (const auto *b = getUnboxed()) {
+      if (*b) {
+        auto type = b->getType();
+        if (type.template isa<fir::BoxCharType>())
+          fir::emitFatalError(b->getLoc(), "BoxChar should be unboxed");
+        if (auto refType = type.template dyn_cast<fir::ReferenceType>())
+          type = refType.getEleTy();
+        if (auto seqType = type.template dyn_cast<fir::SequenceType>())
+          type = seqType.getEleTy();
+        if (fir::isa_char(type))
+          fir::emitFatalError(b->getLoc(),
+                              "character buffer should be in CharBoxValue");
+      }
+    }
+  }
+
+  template <typename A>
+  constexpr const A *getBoxOf() const {
+    return std::get_if<A>(&box);
+  }
+
+  constexpr const CharBoxValue *getCharBox() const {
+    return getBoxOf<CharBoxValue>();
+  }
+
+  constexpr const UnboxedValue *getUnboxed() const {
+    return getBoxOf<UnboxedValue>();
+  }
+
+  unsigned rank() const {
+    return match([](const fir::UnboxedValue &box) -> unsigned { return 0; },
+                 [](const fir::CharBoxValue &box) -> unsigned { return 0; },
+                 [](const fir::ProcBoxValue &box) -> unsigned { return 0; },
+                 [](const auto &box) -> unsigned { return box.rank(); });
+  }
+
+  /// LLVM style debugging of extended values
+  LLVM_DUMP_METHOD void dump() const { llvm::errs() << *this << '\n'; }
+
+  friend llvm::raw_ostream &operator<<(llvm::raw_ostream &,
+                                       const ExtendedValue &);
+
+  const VT &matchee() const { return box; }
+
+private:
+  VT box;
+};
+
+/// Is the extended value `exv` unboxed and non-null?
+inline bool isUnboxedValue(const ExtendedValue &exv) {
+  return exv.match(
+      [](const fir::UnboxedValue &box) { return box ? true : false; },
+      [](const auto &) { return false; });
+}
+} // namespace fir
+
+#endif // FORTRAN_OPTIMIZER_BUILDER_BOXVALUE_H
 No newline at end of file

flang/include/flang/Optimizer/Builder/Character.h

+//===-- Character.h -- lowering of characters -------------------*- 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
+//
+//===----------------------------------------------------------------------===//
+//
+// Coding style: https://mlir.llvm.org/getting_started/DeveloperGuide/
+//
+//===----------------------------------------------------------------------===//
+
+#ifndef FORTRAN_OPTIMIZER_BUILDER_CHARACTER_H
+#define FORTRAN_OPTIMIZER_BUILDER_CHARACTER_H
+
+#include "flang/Optimizer/Builder/BoxValue.h"
+#include "flang/Optimizer/Builder/FIRBuilder.h"
+
+namespace fir::factory {
+
+/// Helper to facilitate lowering of CHARACTER in FIR.
+class CharacterExprHelper {
+public:
+  /// Constructor.
+  explicit CharacterExprHelper(FirOpBuilder &builder, mlir::Location loc)
+      : builder{builder}, loc{loc} {}
+  CharacterExprHelper(const CharacterExprHelper &) = delete;
+
+  /// Copy the \p count first characters of \p src into \p dest.
+  /// \p count can have any integer type.
+  void createCopy(const fir::CharBoxValue &dest, const fir::CharBoxValue &src,
+                  mlir::Value count);
+
+  /// Set characters of \p str at position [\p lower, \p upper) to blanks.
+  /// \p lower and \upper bounds are zero based.
+  /// If \p upper <= \p lower, no padding is done.
+  /// \p upper and \p lower can have any integer type.
+  void createPadding(const fir::CharBoxValue &str, mlir::Value lower,
+                     mlir::Value upper);
+
+  /// Create str(lb:ub), lower bounds must always be specified, upper
+  /// bound is optional.
+  fir::CharBoxValue createSubstring(const fir::CharBoxValue &str,
+                                    llvm::ArrayRef<mlir::Value> bounds);
+
+  /// Return blank character of given \p type !fir.char<kind>
+  mlir::Value createBlankConstant(fir::CharacterType type);
+
+  /// Lower \p lhs = \p rhs where \p lhs and \p rhs are scalar characters.
+  /// It handles cases where \p lhs and \p rhs may overlap.
+  void createAssign(const fir::ExtendedValue &lhs,
+                    const fir::ExtendedValue &rhs);
+
+  /// Create lhs // rhs in temp obtained with fir.alloca
+  fir::CharBoxValue createConcatenate(const fir::CharBoxValue &lhs,
+                                      const fir::CharBoxValue &rhs);
+
+  /// LEN_TRIM intrinsic.
+  mlir::Value createLenTrim(const fir::CharBoxValue &str);
+
+  /// Embox \p addr and \p len and return fir.boxchar.
+  /// Take care of type conversions before emboxing.
+  /// \p len is converted to the integer type for character lengths if needed.
+  mlir::Value createEmboxChar(mlir::Value addr, mlir::Value len);
+  /// Create a fir.boxchar for \p str. If \p str is not in memory, a temp is
+  /// allocated to create the fir.boxchar.
+  mlir::Value createEmbox(const fir::CharBoxValue &str);
+  /// Embox a string array. Note that the size/shape of the array is not
+  /// retrievable from the resulting mlir::Value.
+  mlir::Value createEmbox(const fir::CharArrayBoxValue &str);
+
+  /// Convert character array to a scalar by reducing the extents into the
+  /// length. Will fail if call on non reference like base.
+  fir::CharBoxValue toScalarCharacter(const fir::CharArrayBoxValue &);
+
+  /// Unbox \p boxchar into (fir.ref<fir.char<kind>>, character length type).
+  std::pair<mlir::Value, mlir::Value> createUnboxChar(mlir::Value boxChar);
+
+  /// Allocate a temp of fir::CharacterType type and length len.
+  /// Returns related fir.ref<fir.array<? x fir.char<kind>>>.
+  fir::CharBoxValue createCharacterTemp(mlir::Type type, mlir::Value len);
+
+  /// Allocate a temp of compile time constant length.
+  /// Returns related fir.ref<fir.array<len x fir.char<kind>>>.
+  fir::CharBoxValue createCharacterTemp(mlir::Type type, int len);
+
+  /// Create a temporary with the same kind, length, and value as source.
+  fir::CharBoxValue createTempFrom(const fir::ExtendedValue &source);
+
+  /// Return true if \p type is a character literal type (is
+  /// `fir.array<len x fir.char<kind>>`).;
+  static bool isCharacterLiteral(mlir::Type type);
+
+  /// Return true if \p type is one of the following type
+  /// - fir.boxchar<kind>
+  /// - fir.ref<fir.char<kind,len>>
+  /// - fir.char<kind,len>
+  static bool isCharacterScalar(mlir::Type type);
+
+  /// Does this extended value base type is fir.char<kind,len>
+  /// where len is not the unknown extent ?
+  static bool hasConstantLengthInType(const fir::ExtendedValue &);
+
+  /// Extract the kind of a character type
+  static fir::KindTy getCharacterKind(mlir::Type type);
+
+  /// Extract the kind of a character or array of character type.
+  static fir::KindTy getCharacterOrSequenceKind(mlir::Type type);
+
+  /// Determine the base character type
+  static fir::CharacterType getCharacterType(mlir::Type type);
+  static fir::CharacterType getCharacterType(const fir::CharBoxValue &box);
+  static fir::CharacterType getCharacterType(mlir::Value str);
+
+  /// Create an extended value from a value of type:
+  /// - fir.boxchar<kind>
+  /// - fir.ref<fir.char<kind,len>>
+  /// - fir.char<kind,len>
+  /// or the array versions:
+  /// - fir.ref<fir.array<n x...x fir.char<kind,len>>>
+  /// - fir.array<n x...x fir.char<kind,len>>
+  ///
+  /// Does the heavy lifting of converting the value \p character (along with an
+  /// optional \p len value) to an extended value. If \p len is null, a length
+  /// value is extracted from \p character (or its type). This will produce an
+  /// error if it's not possible. The returned value is a CharBoxValue if \p
+  /// character is a scalar, otherwise it is a CharArrayBoxValue.
+  fir::ExtendedValue toExtendedValue(mlir::Value character,
+                                     mlir::Value len = {});
+
+  /// Is `type` a sequence (array) of CHARACTER type? Return true for any of the
+  /// following cases:
+  ///   - !fir.array<dim x ... x !fir.char<kind, len>>
+  ///   - !fir.ref<T>  where T is either of the first case
+  ///   - !fir.box<T>  where T is either of the first case
+  ///
+  /// In certain contexts, Fortran allows an array of CHARACTERs to be treated
+  /// as if it were one longer CHARACTER scalar, each element append to the
+  /// previous.
+  static bool isArray(mlir::Type type);
+
+  /// Temporary helper to help migrating towards properties of
+  /// ExtendedValue containing characters.
+  /// Mainly, this ensure that characters are always CharArrayBoxValue,
+  /// CharBoxValue, or BoxValue and that the base address is not a boxchar.
+  /// Return the argument if this is not a character.
+  /// TODO: Create and propagate ExtendedValue according to properties listed
+  /// above instead of fixing it when needed.
+  fir::ExtendedValue cleanUpCharacterExtendedValue(const fir::ExtendedValue &);
+
+  /// Create fir.char<kind> singleton from \p code integer value.
+  mlir::Value createSingletonFromCode(mlir::Value code, int kind);
+  /// Returns integer value held in a character singleton.
+  mlir::Value extractCodeFromSingleton(mlir::Value singleton);
+
+  /// Create a value for the length of a character based on its memory reference
+  /// that may be a boxchar, box or !fir.[ptr|ref|heap]<fir.char<kind, len>>. If
+  /// the memref is a simple address and the length is not constant in type, the
+  /// returned length will be empty.
+  mlir::Value getLength(mlir::Value memref);
+
+  /// Compute length given a fir.box describing a character entity.
+  /// It adjusts the length from the number of bytes per the descriptor
+  /// to the number of characters per the Fortran KIND.
+  mlir::Value readLengthFromBox(mlir::Value box);
+
+private:
+  /// FIXME: the implementation also needs a clean-up now that
+  /// CharBoxValue are better propagated.
+  fir::CharBoxValue materializeValue(mlir::Value str);
+  mlir::Value getCharBoxBuffer(const fir::CharBoxValue &box);
+  mlir::Value createElementAddr(mlir::Value buffer, mlir::Value index);
+  mlir::Value createLoadCharAt(mlir::Value buff, mlir::Value index);
+  void createStoreCharAt(mlir::Value str, mlir::Value index, mlir::Value c);
+  void createLengthOneAssign(const fir::CharBoxValue &lhs,
+                             const fir::CharBoxValue &rhs);
+  void createAssign(const fir::CharBoxValue &lhs, const fir::CharBoxValue &rhs);
+  mlir::Value createBlankConstantCode(fir::CharacterType type);
+
+private:
+  FirOpBuilder &builder;
+  mlir::Location loc;
+};
+
+// FIXME: Move these to Optimizer
+mlir::FuncOp getLlvmMemcpy(FirOpBuilder &builder);
+mlir::FuncOp getLlvmMemmove(FirOpBuilder &builder);
+mlir::FuncOp getLlvmMemset(FirOpBuilder &builder);
+mlir::FuncOp getRealloc(FirOpBuilder &builder);
+
+} // namespace fir::factory
+
+#endif // FORTRAN_OPTIMIZER_BUILDER_CHARACTER_H

flang/include/flang/Optimizer/Builder/DoLoopHelper.h

+//===-- DoLoopHelper.h -- gen fir.do_loop ops -------------------*- 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
+//
+//===----------------------------------------------------------------------===//
+//
+// Coding style: https://mlir.llvm.org/getting_started/DeveloperGuide/
+//
+//===----------------------------------------------------------------------===//
+
+#ifndef FORTRAN_OPTIMIZER_BUILDER_DOLOOPHELPER_H
+#define FORTRAN_OPTIMIZER_BUILDER_DOLOOPHELPER_H
+
+#include "flang/Optimizer/Builder/FIRBuilder.h"
+
+namespace fir::factory {
+
+/// Helper to build fir.do_loop Ops.
+class DoLoopHelper {
+public:
+  explicit DoLoopHelper(fir::FirOpBuilder &builder, mlir::Location loc)
+      : builder(builder), loc(loc) {}
+  DoLoopHelper(const DoLoopHelper &) = delete;
+
+  /// Type of a callback to generate the loop body.
+  using BodyGenerator = std::function<void(fir::FirOpBuilder &, mlir::Value)>;
+
+  /// Build loop [\p lb, \p ub] with step \p step.
+  /// If \p step is an empty value, 1 is used for the step.
+  void createLoop(mlir::Value lb, mlir::Value ub, mlir::Value step,
+                  const BodyGenerator &bodyGenerator);
+
+  /// Build loop [\p lb,  \p ub] with step 1.
+  void createLoop(mlir::Value lb, mlir::Value ub,
+                  const BodyGenerator &bodyGenerator);
+
+  /// Build loop [0, \p count) with step 1.
+  void createLoop(mlir::Value count, const BodyGenerator &bodyGenerator);
+
+private:
+  fir::FirOpBuilder &builder;
+  mlir::Location loc;
+};
+
+} // namespace fir::factory
+
+#endif // FORTRAN_OPTIMIZER_BUILDER_DOLOOPHELPER_H

flang/include/flang/Optimizer/Builder/FIRBuilder.h

+//===-- FirBuilder.h -- FIR operation builder -------------------*- 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
+//
+//===----------------------------------------------------------------------===//
+//
+// Builder routines for constructing the FIR dialect of MLIR. As FIR is a
+// dialect of MLIR, it makes extensive use of MLIR interfaces and MLIR's coding
+// style (https://mlir.llvm.org/getting_started/DeveloperGuide/) is used in this
+// module.
+//
+//===----------------------------------------------------------------------===//
+
+#ifndef FORTRAN_OPTIMIZER_BUILDER_FIRBUILDER_H
+#define FORTRAN_OPTIMIZER_BUILDER_FIRBUILDER_H
+
+#include "flang/Optimizer/Dialect/FIROps.h"
+#include "flang/Optimizer/Dialect/FIRType.h"
+#include "flang/Optimizer/Support/KindMapping.h"
+#include "mlir/IR/Builders.h"
+#include "mlir/IR/BuiltinOps.h"
+#include "llvm/ADT/DenseMap.h"
+#include "llvm/ADT/Optional.h"
+
+namespace fir {
+class AbstractArrayBox;
+class ExtendedValue;
+class BoxValue;
+
+//===----------------------------------------------------------------------===//
+// FirOpBuilder
+//===----------------------------------------------------------------------===//
+
+/// Extends the MLIR OpBuilder to provide methods for building common FIR
+/// patterns.
+class FirOpBuilder : public mlir::OpBuilder {
+public:
+  explicit FirOpBuilder(mlir::Operation *op, const fir::KindMapping &kindMap)
+      : OpBuilder{op}, kindMap{kindMap} {}
+  explicit FirOpBuilder(mlir::OpBuilder &builder,
+                        const fir::KindMapping &kindMap)
+      : OpBuilder{builder}, kindMap{kindMap} {}
+
+  /// Get the current Region of the insertion point.
+  mlir::Region &getRegion() { return *getBlock()->getParent(); }
+
+  /// Get the current Module
+  mlir::ModuleOp getModule() {
+    return getRegion().getParentOfType<mlir::ModuleOp>();
+  }
+
+  /// Get the current Function
+  mlir::FuncOp getFunction() {
+    return getRegion().getParentOfType<mlir::FuncOp>();
+  }
+
+  /// Get a reference to the kind map.
+  const fir::KindMapping &getKindMap() { return kindMap; }
+
+  /// The LHS and RHS are not always in agreement in terms of
+  /// type. In some cases, the disagreement is between COMPLEX and other scalar
+  /// types. In that case, the conversion must insert/extract out of a COMPLEX
+  /// value to have the proper semantics and be strongly typed.
+  mlir::Value convertWithSemantics(mlir::Location loc, mlir::Type toTy,
+                                   mlir::Value val);
+
+  /// Get the entry block of the current Function
+  mlir::Block *getEntryBlock() { return &getFunction().front(); }
+
+  /// Get the block for adding Allocas. If OpenMP is enabled then get the
+  /// the alloca block from an Operation which can be Outlined. Otherwise
+  /// use the entry block of the current Function
+  mlir::Block *getAllocaBlock();
+
+  /// Safely create a reference type to the type `eleTy`.
+  mlir::Type getRefType(mlir::Type eleTy);
+
+  /// Create a sequence of `eleTy` with `rank` dimensions of unknown size.
+  mlir::Type getVarLenSeqTy(mlir::Type eleTy, unsigned rank = 1);
+
+  /// Get character length type
+  mlir::Type getCharacterLengthType() { return getIndexType(); }
+
+  /// Get the integer type whose bit width corresponds to the width of pointer
+  /// types, or is bigger.
+  mlir::Type getIntPtrType() {
+    // TODO: Delay the need of such type until codegen or find a way to use
+    // llvm::DataLayout::getPointerSizeInBits here.
+    return getI64Type();
+  }
+
+  /// Get the mlir real type that implements fortran REAL(kind).
+  mlir::Type getRealType(int kind);
+
+  /// Create a null constant memory reference of type \p ptrType.
+  /// If \p ptrType is not provided, !fir.ref<none> type will be used.
+  mlir::Value createNullConstant(mlir::Location loc, mlir::Type ptrType = {});
+
+  /// Create an integer constant of type \p type and value \p i.
+  mlir::Value createIntegerConstant(mlir::Location loc, mlir::Type integerType,
+                                    std::int64_t i);
+
+  /// Create a real constant from an integer value.
+  mlir::Value createRealConstant(mlir::Location loc, mlir::Type realType,
+                                 llvm::APFloat::integerPart val);
+
+  /// Create a real constant from an APFloat value.
+  mlir::Value createRealConstant(mlir::Location loc, mlir::Type realType,
+                                 const llvm::APFloat &val);
+
+  /// Create a real constant of type \p realType with a value zero.
+  mlir::Value createRealZeroConstant(mlir::Location loc, mlir::Type realType) {
+    return createRealConstant(loc, realType, 0u);
+  }
+
+  /// Create a slot for a local on the stack. Besides the variable's type and
+  /// shape, it may be given name, pinned, or target attributes.
+  mlir::Value allocateLocal(mlir::Location loc, mlir::Type ty,
+                            llvm::StringRef uniqName, llvm::StringRef name,
+                            bool pinned, llvm::ArrayRef<mlir::Value> shape,
+                            llvm::ArrayRef<mlir::Value> lenParams,
+                            bool asTarget = false);
+  mlir::Value allocateLocal(mlir::Location loc, mlir::Type ty,
+                            llvm::StringRef uniqName, llvm::StringRef name,
+                            llvm::ArrayRef<mlir::Value> shape,
+                            llvm::ArrayRef<mlir::Value> lenParams,
+                            bool asTarget = false);
+
+  /// Create a temporary. A temp is allocated using `fir.alloca` and can be read
+  /// and written using `fir.load` and `fir.store`, resp.  The temporary can be
+  /// given a name via a front-end `Symbol` or a `StringRef`.
+  mlir::Value createTemporary(mlir::Location loc, mlir::Type type,
+                              llvm::StringRef name = {},
+                              mlir::ValueRange shape = {},
+                              mlir::ValueRange lenParams = {},
+                              llvm::ArrayRef<mlir::NamedAttribute> attrs = {});
+
+  /// Create an unnamed and untracked temporary on the stack.
+  mlir::Value createTemporary(mlir::Location loc, mlir::Type type,
+                              mlir::ValueRange shape) {
+    return createTemporary(loc, type, llvm::StringRef{}, shape);
+  }
+
+  mlir::Value createTemporary(mlir::Location loc, mlir::Type type,
+                              llvm::ArrayRef<mlir::NamedAttribute> attrs) {
+    return createTemporary(loc, type, llvm::StringRef{}, {}, {}, attrs);
+  }
+
+  mlir::Value createTemporary(mlir::Location loc, mlir::Type type,
+                              llvm::StringRef name,
+                              llvm::ArrayRef<mlir::NamedAttribute> attrs) {
+    return createTemporary(loc, type, name, {}, {}, attrs);
+  }
+
+  /// Create a global value.
+  fir::GlobalOp createGlobal(mlir::Location loc, mlir::Type type,
+                             llvm::StringRef name,
+                             mlir::StringAttr linkage = {},
+                             mlir::Attribute value = {}, bool isConst = false);
+
+  fir::GlobalOp createGlobal(mlir::Location loc, mlir::Type type,
+                             llvm::StringRef name, bool isConst,
+                             std::function<void(FirOpBuilder &)> bodyBuilder,
+                             mlir::StringAttr linkage = {});
+
+  /// Create a global constant (read-only) value.
+  fir::GlobalOp createGlobalConstant(mlir::Location loc, mlir::Type type,
+                                     llvm::StringRef name,
+                                     mlir::StringAttr linkage = {},
+                                     mlir::Attribute value = {}) {
+    return createGlobal(loc, type, name, linkage, value, /*isConst=*/true);
+  }
+
+  fir::GlobalOp
+  createGlobalConstant(mlir::Location loc, mlir::Type type,
+                       llvm::StringRef name,
+                       std::function<void(FirOpBuilder &)> bodyBuilder,
+                       mlir::StringAttr linkage = {}) {
+    return createGlobal(loc, type, name, /*isConst=*/true, bodyBuilder,
+                        linkage);
+  }
+
+  /// Convert a StringRef string into a fir::StringLitOp.
+  fir::StringLitOp createStringLitOp(mlir::Location loc,
+                                     llvm::StringRef string);
+
+  //===--------------------------------------------------------------------===//
+  // Linkage helpers (inline). The default linkage is external.
+  //===--------------------------------------------------------------------===//
+
+  mlir::StringAttr createCommonLinkage() { return getStringAttr("common"); }
+
+  mlir::StringAttr createInternalLinkage() { return getStringAttr("internal"); }
+
+  mlir::StringAttr createLinkOnceLinkage() { return getStringAttr("linkonce"); }
+
+  mlir::StringAttr createWeakLinkage() { return getStringAttr("weak"); }
+
+  /// Get a function by name. If the function exists in the current module, it
+  /// is returned. Otherwise, a null FuncOp is returned.
+  mlir::FuncOp getNamedFunction(llvm::StringRef name) {
+    return getNamedFunction(getModule(), name);
+  }
+
+  static mlir::FuncOp getNamedFunction(mlir::ModuleOp module,
+                                       llvm::StringRef name);
+
+  fir::GlobalOp getNamedGlobal(llvm::StringRef name) {
+    return getNamedGlobal(getModule(), name);
+  }
+
+  static fir::GlobalOp getNamedGlobal(mlir::ModuleOp module,
+                                      llvm::StringRef name);
+
+  /// Lazy creation of fir.convert op.
+  mlir::Value createConvert(mlir::Location loc, mlir::Type toTy,
+                            mlir::Value val);
+
+  /// Create a new FuncOp. If the function may have already been created, use
+  /// `addNamedFunction` instead.
+  mlir::FuncOp createFunction(mlir::Location loc, llvm::StringRef name,
+                              mlir::FunctionType ty) {
+    return createFunction(loc, getModule(), name, ty);
+  }
+
+  static mlir::FuncOp createFunction(mlir::Location loc, mlir::ModuleOp module,
+                                     llvm::StringRef name,
+                                     mlir::FunctionType ty);
+
+  /// Determine if the named function is already in the module. Return the
+  /// instance if found, otherwise add a new named function to the module.
+  mlir::FuncOp addNamedFunction(mlir::Location loc, llvm::StringRef name,
+                                mlir::FunctionType ty) {
+    if (auto func = getNamedFunction(name))
+      return func;
+    return createFunction(loc, name, ty);
+  }
+
+  static mlir::FuncOp addNamedFunction(mlir::Location loc,
+                                       mlir::ModuleOp module,
+                                       llvm::StringRef name,
+                                       mlir::FunctionType ty) {
+    if (auto func = getNamedFunction(module, name))
+      return func;
+    return createFunction(loc, module, name, ty);
+  }
+
+  /// Cast the input value to IndexType.
+  mlir::Value convertToIndexType(mlir::Location loc, mlir::Value val) {
+    return createConvert(loc, getIndexType(), val);
+  }
+
+  /// Construct one of the two forms of shape op from an array box.
+  mlir::Value genShape(mlir::Location loc, const fir::AbstractArrayBox &arr);
+  mlir::Value genShape(mlir::Location loc, llvm::ArrayRef<mlir::Value> shift,
+                       llvm::ArrayRef<mlir::Value> exts);
+  mlir::Value genShape(mlir::Location loc, llvm::ArrayRef<mlir::Value> exts);
+
+  /// Create one of the shape ops given an extended value. For a boxed value,
+  /// this may create a `fir.shift` op.
+  mlir::Value createShape(mlir::Location loc, const fir::ExtendedValue &exv);
+
+  /// Create a slice op extended value. The value to be sliced, `exv`, must be
+  /// an array.
+  mlir::Value createSlice(mlir::Location loc, const fir::ExtendedValue &exv,
+                          mlir::ValueRange triples, mlir::ValueRange path);
+
+  /// Create a boxed value (Fortran descriptor) to be passed to the runtime.
+  /// \p exv is an extended value holding a memory reference to the object that
+  /// must be boxed. This function will crash if provided something that is not
+  /// a memory reference type.
+  /// Array entities are boxed with a shape and character with their length.
+  mlir::Value createBox(mlir::Location loc, const fir::ExtendedValue &exv);
+
+  /// Create constant i1 with value 1. if \p b is true or 0. otherwise
+  mlir::Value createBool(mlir::Location loc, bool b) {
+    return createIntegerConstant(loc, getIntegerType(1), b ? 1 : 0);
+  }
+
+  //===--------------------------------------------------------------------===//
+  // If-Then-Else generation helper
+  //===--------------------------------------------------------------------===//
+
+  /// Helper class to create if-then-else in a structured way:
+  /// Usage: genIfOp().then([&](){...}).else([&](){...}).end();
+  /// Alternatively, getResults() can be used instead of end() to end the ifOp
+  /// and get the ifOp results.
+  class IfBuilder {
+  public:
+    IfBuilder(fir::IfOp ifOp, FirOpBuilder &builder)
+        : ifOp{ifOp}, builder{builder} {}
+    template <typename CC>
+    IfBuilder &genThen(CC func) {
+      builder.setInsertionPointToStart(&ifOp.thenRegion().front());
+      func();
+      return *this;
+    }
+    template <typename CC>
+    IfBuilder &genElse(CC func) {
+      assert(!ifOp.elseRegion().empty() && "must have else region");
+      builder.setInsertionPointToStart(&ifOp.elseRegion().front());
+      func();
+      return *this;
+    }
+    void end() { builder.setInsertionPointAfter(ifOp); }
+
+    /// End the IfOp and return the results if any.
+    mlir::Operation::result_range getResults() {
+      end();
+      return ifOp.getResults();
+    }
+
+  private:
+    fir::IfOp ifOp;
+    FirOpBuilder &builder;
+  };
+
+  /// Create an IfOp and returns an IfBuilder that can generate the else/then
+  /// bodies.
+  IfBuilder genIfOp(mlir::Location loc, mlir::TypeRange results,
+                    mlir::Value cdt, bool withElseRegion) {
+    auto op = create<fir::IfOp>(loc, results, cdt, withElseRegion);
+    return IfBuilder(op, *this);
+  }
+
+  /// Create an IfOp with no "else" region, and no result values.
+  /// Usage: genIfThen(loc, cdt).genThen(lambda).end();
+  IfBuilder genIfThen(mlir::Location loc, mlir::Value cdt) {
+    auto op = create<fir::IfOp>(loc, llvm::None, cdt, false);
+    return IfBuilder(op, *this);
+  }
+
+  /// Create an IfOp with an "else" region, and no result values.
+  /// Usage: genIfThenElse(loc, cdt).genThen(lambda).genElse(lambda).end();
+  IfBuilder genIfThenElse(mlir::Location loc, mlir::Value cdt) {
+    auto op = create<fir::IfOp>(loc, llvm::None, cdt, true);
+    return IfBuilder(op, *this);
+  }
+
+  /// Generate code testing \p addr is not a null address.
+  mlir::Value genIsNotNull(mlir::Location loc, mlir::Value addr);
+
+  /// Generate code testing \p addr is a null address.
+  mlir::Value genIsNull(mlir::Location loc, mlir::Value addr);
+
+  /// Compute the extent of (lb:ub:step) as max((ub-lb+step)/step, 0). See
+  /// Fortran 2018 9.5.3.3.2 section for more details.
+  mlir::Value genExtentFromTriplet(mlir::Location loc, mlir::Value lb,
+                                   mlir::Value ub, mlir::Value step,
+                                   mlir::Type type);
+
+private:
+  const KindMapping &kindMap;
+};
+
+} // namespace fir
+
+namespace fir::factory {
+
+//===--------------------------------------------------------------------===//
+// ExtendedValue inquiry helpers
+//===--------------------------------------------------------------------===//
+
+/// Read or get character length from \p box that must contain a character
+/// entity. If the length value is contained in the ExtendedValue, this will
+/// not generate any code, otherwise this will generate a read of the fir.box
+/// describing the entity.
+mlir::Value readCharLen(fir::FirOpBuilder &builder, mlir::Location loc,
+                        const fir::ExtendedValue &box);
+
+/// Read or get the extent in dimension \p dim of the array described by \p box.
+mlir::Value readExtent(fir::FirOpBuilder &builder, mlir::Location loc,
+                       const fir::ExtendedValue &box, unsigned dim);
+
+/// Read or get the lower bound in dimension \p dim of the array described by
+/// \p box. If the lower bound is left default in the ExtendedValue,
+/// \p defaultValue will be returned.
+mlir::Value readLowerBound(fir::FirOpBuilder &builder, mlir::Location loc,
+                           const fir::ExtendedValue &box, unsigned dim,
+                           mlir::Value defaultValue);
+
+/// Read extents from \p box.
+llvm::SmallVector<mlir::Value> readExtents(fir::FirOpBuilder &builder,
+                                           mlir::Location loc,
+                                           const fir::BoxValue &box);
+
+/// Get extents from \p box. For fir::BoxValue and
+/// fir::MutableBoxValue, this will generate code to read the extents.
+llvm::SmallVector<mlir::Value> getExtents(fir::FirOpBuilder &builder,
+                                          mlir::Location loc,
+                                          const fir::ExtendedValue &box);
+
+/// Read a fir::BoxValue into an fir::UnboxValue, a fir::ArrayBoxValue or a
+/// fir::CharArrayBoxValue. This should only be called if the fir::BoxValue is
+/// known to be contiguous given the context (or if the resulting address will
+/// not be used). If the value is polymorphic, its dynamic type will be lost.
+/// This must not be used on unlimited polymorphic and assumed rank entities.
+fir::ExtendedValue readBoxValue(fir::FirOpBuilder &builder, mlir::Location loc,
+                                const fir::BoxValue &box);
+
+//===--------------------------------------------------------------------===//
+// String literal helper helpers
+//===--------------------------------------------------------------------===//
+
+/// Create a !fir.char<1> string literal global and returns a
+/// fir::CharBoxValue with its address en length.
+fir::ExtendedValue createStringLiteral(fir::FirOpBuilder &, mlir::Location,
+                                       llvm::StringRef string);
+
+/// Unique a compiler generated identifier. A short prefix should be provided
+/// to hint at the origin of the identifier.
+std::string uniqueCGIdent(llvm::StringRef prefix, llvm::StringRef name);
+
+/// Lowers the extents from the sequence type to Values.
+/// Any unknown extents are lowered to undefined values.
+llvm::SmallVector<mlir::Value> createExtents(fir::FirOpBuilder &builder,
+                                             mlir::Location loc,
+                                             fir::SequenceType seqTy);
+
+//===--------------------------------------------------------------------===//
+// Location helpers
+//===--------------------------------------------------------------------===//
+
+/// Generate a string literal containing the file name and return its address
+mlir::Value locationToFilename(fir::FirOpBuilder &, mlir::Location);
+/// Generate a constant of the given type with the location line number
+mlir::Value locationToLineNo(fir::FirOpBuilder &, mlir::Location, mlir::Type);
+
+//===--------------------------------------------------------------------===//
+// ExtendedValue helpers
+//===--------------------------------------------------------------------===//
+
+/// Return the extended value for a component of a derived type instance given
+/// the extended value \p obj of the derived type instance and the address of
+/// the component.
+fir::ExtendedValue componentToExtendedValue(fir::FirOpBuilder &builder,
+                                            mlir::Location loc,
+                                            mlir::Value component);
+
+/// Given the address of an array element and the ExtendedValue describing the
+/// array, returns the ExtendedValue describing the array element. The purpose
+/// is to propagate the length parameters of the array to the element.
+/// This can be used for elements of `array` or `array(i:j:k)`. If \p element
+/// belongs to an array section `array%x` whose base is \p array,
+/// arraySectionElementToExtendedValue must be used instead.
+fir::ExtendedValue arrayElementToExtendedValue(fir::FirOpBuilder &builder,
+                                               mlir::Location loc,
+                                               const fir::ExtendedValue &array,
+                                               mlir::Value element);
+
+/// Build the ExtendedValue for \p element that is an element of an array or
+/// array section with \p array base (`array` or `array(i:j:k)%x%y`).
+/// If it is an array section, \p slice must be provided and be a fir::SliceOp
+/// that describes the section.
+fir::ExtendedValue arraySectionElementToExtendedValue(
+    fir::FirOpBuilder &builder, mlir::Location loc,
+    const fir::ExtendedValue &array, mlir::Value element, mlir::Value slice);
+
+/// Assign \p rhs to \p lhs. Both \p rhs and \p lhs must be scalar derived
+/// types. The assignment follows Fortran intrinsic assignment semantic for
+/// derived types (10.2.1.3 point 13).
+void genRecordAssignment(fir::FirOpBuilder &builder, mlir::Location loc,
+                         const fir::ExtendedValue &lhs,
+                         const fir::ExtendedValue &rhs);
+
+mlir::TupleType getRaggedArrayHeaderType(fir::FirOpBuilder &builder);
+
+} // namespace fir::factory
+
+#endif // FORTRAN_OPTIMIZER_BUILDER_FIRBUILDER_H

flang/include/flang/Optimizer/Builder/MutableBox.h

+//===-- MutableBox.h -- MutableBox utilities  -----------------------------===//
+//
+// 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
+//
+//===----------------------------------------------------------------------===//
+//
+// Coding style: https://mlir.llvm.org/getting_started/DeveloperGuide/
+//
+//===----------------------------------------------------------------------===//
+
+#ifndef FORTRAN_OPTIMIZER_BUILDER_MUTABLEBOX_H
+#define FORTRAN_OPTIMIZER_BUILDER_MUTABLEBOX_H
+
+#include "llvm/ADT/StringRef.h"
+
+namespace mlir {
+class Value;
+class ValueRange;
+class Type;
+class Location;
+} // namespace mlir
+
+namespace fir {
+class FirOpBuilder;
+class MutableBoxValue;
+class ExtendedValue;
+} // namespace fir
+
+namespace fir::factory {
+
+/// Create a fir.box of type \p boxType that can be used to initialize an
+/// allocatable variable. Initialization of such variable has to be done at the
+/// beginning of the variable lifetime by storing the created box in the memory
+/// for the variable box.
+/// \p nonDeferredParams must provide the non deferred length parameters so that
+/// they can already be placed in the unallocated box (inquiries about these
+/// parameters are legal even in unallocated state).
+mlir::Value createUnallocatedBox(fir::FirOpBuilder &builder, mlir::Location loc,
+                                 mlir::Type boxType,
+                                 mlir::ValueRange nonDeferredParams);
+
+/// Create a MutableBoxValue for a temporary allocatable.
+/// The created MutableBoxValue wraps a fir.ref<fir.box<fir.heap<type>>> and is
+/// initialized to unallocated/diassociated status. An optional name can be
+/// given to the created !fir.ref<fir.box>.
+fir::MutableBoxValue createTempMutableBox(fir::FirOpBuilder &builder,
+                                          mlir::Location loc, mlir::Type type,
+                                          llvm::StringRef name = {});
+
+/// Update a MutableBoxValue to describe entity \p source (that must be in
+/// memory). If \lbounds is not empty, it is used to defined the MutableBoxValue
+/// lower bounds, otherwise, the lower bounds from \p source are used.
+void associateMutableBox(fir::FirOpBuilder &builder, mlir::Location loc,
+                         const fir::MutableBoxValue &box,
+                         const fir::ExtendedValue &source,
+                         mlir::ValueRange lbounds);
+
+/// Update a MutableBoxValue to describe entity \p source (that must be in
+/// memory) with a new array layout given by \p lbounds and \p ubounds.
+/// \p source must be known to be contiguous at compile time, or it must have
+/// rank 1 (constraint from Fortran 2018 standard 10.2.2.3 point 9).
+void associateMutableBoxWithRemap(fir::FirOpBuilder &builder,
+                                  mlir::Location loc,
+                                  const fir::MutableBoxValue &box,
+                                  const fir::ExtendedValue &source,
+                                  mlir::ValueRange lbounds,
+                                  mlir::ValueRange ubounds);
+
+/// Set the association status of a MutableBoxValue to
+/// disassociated/unallocated. Nothing is done with the entity that was
+/// previously associated/allocated. The function generates code that sets the
+/// address field of the MutableBoxValue to zero.
+void disassociateMutableBox(fir::FirOpBuilder &builder, mlir::Location loc,
+                            const fir::MutableBoxValue &box);
+
+/// Generate code to conditionally reallocate a MutableBoxValue with a new
+/// shape, lower bounds, and length parameters if it is unallocated or if its
+/// current shape or deferred  length parameters do not match the provided ones.
+/// Lower bounds are only used if the entity needs to be allocated, otherwise,
+/// the MutableBoxValue will keep its current lower bounds.
+/// If the MutableBoxValue is an array, the provided shape can be empty, in
+/// which case the MutableBoxValue must already be allocated at runtime and its
+/// shape and lower bounds will be kept. If \p shape is empty, only a length
+/// parameter mismatch can trigger a reallocation. See Fortran 10.2.1.3 point 3
+/// that this function is implementing for more details. The polymorphic
+/// requirements are not yet covered by this function.
+void genReallocIfNeeded(fir::FirOpBuilder &builder, mlir::Location loc,
+                        const fir::MutableBoxValue &box,
+                        mlir::ValueRange lbounds, mlir::ValueRange shape,
+                        mlir::ValueRange lengthParams);
+
+/// Finalize a mutable box if it is allocated or associated. This includes both
+/// calling the finalizer, if any, and deallocating the storage.
+void genFinalization(fir::FirOpBuilder &builder, mlir::Location loc,
+                     const fir::MutableBoxValue &box);
+
+void genInlinedAllocation(fir::FirOpBuilder &builder, mlir::Location loc,
+                          const fir::MutableBoxValue &box,
+                          mlir::ValueRange lbounds, mlir::ValueRange extents,
+                          mlir::ValueRange lenParams,
+                          llvm::StringRef allocName);
+
+void genInlinedDeallocate(fir::FirOpBuilder &builder, mlir::Location loc,
+                          const fir::MutableBoxValue &box);
+
+/// When the MutableBoxValue was passed as a fir.ref<fir.box> to a call that may
+/// have modified it, update the MutableBoxValue according to the
+/// fir.ref<fir.box> value.
+void syncMutableBoxFromIRBox(fir::FirOpBuilder &builder, mlir::Location loc,
+                             const fir::MutableBoxValue &box);
+
+/// Read all mutable properties into a normal symbol box.
+/// It is OK to call this on unassociated/unallocated boxes but any use of the
+/// resulting values will be undefined (only the base address will be guaranteed
+/// to be null).
+fir::ExtendedValue genMutableBoxRead(fir::FirOpBuilder &builder,
+                                     mlir::Location loc,
+                                     const fir::MutableBoxValue &box,
+                                     bool mayBePolymorphic = true);
+
+/// Returns the fir.ref<fir.box<T>> of a MutableBoxValue filled with the current
+/// association / allocation properties. If the fir.ref<fir.box> already exists
+/// and is-up to date, this is a no-op, otherwise, code will be generated to
+/// fill the it.
+mlir::Value getMutableIRBox(fir::FirOpBuilder &builder, mlir::Location loc,
+                            const fir::MutableBoxValue &box);
+
+/// Generate allocation or association status test and returns the resulting
+/// i1. This is testing this for a valid/non-null base address value.
+mlir::Value genIsAllocatedOrAssociatedTest(fir::FirOpBuilder &builder,
+                                           mlir::Location loc,
+                                           const fir::MutableBoxValue &box);
+
+} // namespace fir::factory
+
+#endif // FORTRAN_OPTIMIZER_BUILDER_MUTABLEBOX_H

flang/include/flang/Optimizer/Builder/Runtime/Assign.h

+//===-- Assign.h - generate assignment runtime API calls     ----*- 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
+//
+//===----------------------------------------------------------------------===//
+
+#ifndef FORTRAN_OPTIMIZER_BUILDER_RUNTIME_ASSIGN_H
+#define FORTRAN_OPTIMIZER_BUILDER_RUNTIME_ASSIGN_H
+
+namespace mlir {
+class Value;
+class Location;
+} // namespace mlir
+
+namespace fir {
+class FirOpBuilder;
+} // namespace fir
+
+namespace fir::runtime {
+
+/// Generate runtime call to assign \p sourceBox to \p destBox.
+/// \p destBox must be a fir.ref<fir.box<T>> and \p sourceBox a fir.box<T>.
+/// \p destBox Fortran descriptor may be modified if destBox is an allocatable
+/// according to Fortran allocatable assignment rules, otherwise it is not
+/// modified.
+void genAssign(fir::FirOpBuilder &builder, mlir::Location loc,
+               mlir::Value destBox, mlir::Value sourceBox);
+
+} // namespace fir::runtime
+#endif // FORTRAN_OPTIMIZER_BUILDER_RUNTIME_ASSIGN_H

flang/include/flang/Optimizer/Builder/Runtime/RTBuilder.h

+//===-- RTBuilder.h ---------------------------------------------*- 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
+//
+//===----------------------------------------------------------------------===//
+///
+/// \file
+/// This file defines some C++17 template classes that are used to convert the
+/// signatures of plain old C functions into a model that can be used to
+/// generate MLIR calls to those functions. This can be used to autogenerate
+/// tables at compiler compile-time to call runtime support code.
+///
+//===----------------------------------------------------------------------===//
+
+#ifndef FORTRAN_OPTIMIZER_BUILDER_RUNTIME_RTBUILDER_H
+#define FORTRAN_OPTIMIZER_BUILDER_RUNTIME_RTBUILDER_H
+
+#include "flang/Common/Fortran.h"
+#include "flang/Optimizer/Builder/FIRBuilder.h"
+#include "flang/Optimizer/Dialect/FIRType.h"
+#include "mlir/IR/BuiltinTypes.h"
+#include "mlir/IR/MLIRContext.h"
+#include "llvm/ADT/SmallVector.h"
+#include <functional>
+
+// Incomplete type indicating C99 complex ABI in interfaces. Beware, _Complex
+// and std::complex are layout compatible, but not compatible in all ABI call
+// interface (e.g. X86 32 bits). _Complex is not standard C++, so do not use
+// it here.
+struct c_float_complex_t;
+struct c_double_complex_t;
+
+namespace Fortran::runtime {
+class Descriptor;
+} // namespace Fortran::runtime
+
+namespace fir::runtime {
+
+using TypeBuilderFunc = mlir::Type (*)(mlir::MLIRContext *);
+using FuncTypeBuilderFunc = mlir::FunctionType (*)(mlir::MLIRContext *);
+
+//===----------------------------------------------------------------------===//
+// Type builder models
+//===----------------------------------------------------------------------===//
+
+// TODO: all usages of sizeof in this file assume build ==  host == target.
+// This will need to be re-visited for cross compilation.
+
+/// Return a function that returns the type signature model for the type `T`
+/// when provided an MLIRContext*. This allows one to translate C(++) function
+/// signatures from runtime header files to MLIR signatures into a static table
+/// at compile-time.
+///
+/// For example, when `T` is `int`, return a function that returns the MLIR
+/// standard type `i32` when `sizeof(int)` is 4.
+template <typename T>
+static constexpr TypeBuilderFunc getModel();
+template <>
+constexpr TypeBuilderFunc getModel<short int>() {
+  return [](mlir::MLIRContext *context) -> mlir::Type {
+    return mlir::IntegerType::get(context, 8 * sizeof(short int));
+  };
+}
+template <>
+constexpr TypeBuilderFunc getModel<int>() {
+  return [](mlir::MLIRContext *context) -> mlir::Type {
+    return mlir::IntegerType::get(context, 8 * sizeof(int));
+  };
+}
+template <>
+constexpr TypeBuilderFunc getModel<int &>() {
+  return [](mlir::MLIRContext *context) -> mlir::Type {
+    TypeBuilderFunc f{getModel<int>()};
+    return fir::ReferenceType::get(f(context));
+  };
+}
+template <>
+constexpr TypeBuilderFunc getModel<char *>() {
+  return [](mlir::MLIRContext *context) -> mlir::Type {
+    return fir::ReferenceType::get(mlir::IntegerType::get(context, 8));
+  };
+}
+template <>
+constexpr TypeBuilderFunc getModel<const char *>() {
+  return getModel<char *>();
+}
+template <>
+constexpr TypeBuilderFunc getModel<const char16_t *>() {
+  return [](mlir::MLIRContext *context) -> mlir::Type {
+    return fir::ReferenceType::get(mlir::IntegerType::get(context, 16));
+  };
+}
+template <>
+constexpr TypeBuilderFunc getModel<const char32_t *>() {
+  return [](mlir::MLIRContext *context) -> mlir::Type {
+    return fir::ReferenceType::get(mlir::IntegerType::get(context, 32));
+  };
+}
+template <>
+constexpr TypeBuilderFunc getModel<signed char>() {
+  return [](mlir::MLIRContext *context) -> mlir::Type {
+    return mlir::IntegerType::get(context, 8 * sizeof(signed char));
+  };
+}
+template <>
+constexpr TypeBuilderFunc getModel<void *>() {
+  return [](mlir::MLIRContext *context) -> mlir::Type {
+    return fir::LLVMPointerType::get(mlir::IntegerType::get(context, 8));
+  };
+}
+template <>
+constexpr TypeBuilderFunc getModel<void **>() {
+  return [](mlir::MLIRContext *context) -> mlir::Type {
+    return fir::ReferenceType::get(
+        fir::LLVMPointerType::get(mlir::IntegerType::get(context, 8)));
+  };
+}
+template <>
+constexpr TypeBuilderFunc getModel<long>() {
+  return [](mlir::MLIRContext *context) -> mlir::Type {
+    return mlir::IntegerType::get(context, 8 * sizeof(long));
+  };
+}
+template <>
+constexpr TypeBuilderFunc getModel<long &>() {
+  return [](mlir::MLIRContext *context) -> mlir::Type {
+    TypeBuilderFunc f{getModel<long>()};
+    return fir::ReferenceType::get(f(context));
+  };
+}
+template <>
+constexpr TypeBuilderFunc getModel<long *>() {
+  return getModel<long &>();
+}
+template <>
+constexpr TypeBuilderFunc getModel<long long>() {
+  return [](mlir::MLIRContext *context) -> mlir::Type {
+    return mlir::IntegerType::get(context, 8 * sizeof(std::size_t));
+  };
+}
+template <>
+constexpr TypeBuilderFunc getModel<long long &>() {
+  return [](mlir::MLIRContext *context) -> mlir::Type {
+    TypeBuilderFunc f{getModel<long long>()};
+    return fir::ReferenceType::get(f(context));
+  };
+}
+template <>
+constexpr TypeBuilderFunc getModel<long long *>() {
+  return getModel<long long &>();
+}
+template <>
+constexpr TypeBuilderFunc getModel<unsigned long>() {
+  return [](mlir::MLIRContext *context) -> mlir::Type {
+    return mlir::IntegerType::get(context, 8 * sizeof(unsigned long));
+  };
+}
+template <>
+constexpr TypeBuilderFunc getModel<unsigned long long>() {
+  return [](mlir::MLIRContext *context) -> mlir::Type {
+    return mlir::IntegerType::get(context, 8 * sizeof(unsigned long long));
+  };
+}
+template <>
+constexpr TypeBuilderFunc getModel<double>() {
+  return [](mlir::MLIRContext *context) -> mlir::Type {
+    return mlir::FloatType::getF64(context);
+  };
+}
+template <>
+constexpr TypeBuilderFunc getModel<double &>() {
+  return [](mlir::MLIRContext *context) -> mlir::Type {
+    TypeBuilderFunc f{getModel<double>()};
+    return fir::ReferenceType::get(f(context));
+  };
+}
+template <>
+constexpr TypeBuilderFunc getModel<double *>() {
+  return getModel<double &>();
+}
+template <>
+constexpr TypeBuilderFunc getModel<float>() {
+  return [](mlir::MLIRContext *context) -> mlir::Type {
+    return mlir::FloatType::getF32(context);
+  };
+}
+template <>
+constexpr TypeBuilderFunc getModel<float &>() {
+  return [](mlir::MLIRContext *context) -> mlir::Type {
+    TypeBuilderFunc f{getModel<float>()};
+    return fir::ReferenceType::get(f(context));
+  };
+}
+template <>
+constexpr TypeBuilderFunc getModel<float *>() {
+  return getModel<float &>();
+}
+template <>
+constexpr TypeBuilderFunc getModel<bool>() {
+  return [](mlir::MLIRContext *context) -> mlir::Type {
+    return mlir::IntegerType::get(context, 1);
+  };
+}
+template <>
+constexpr TypeBuilderFunc getModel<bool &>() {
+  return [](mlir::MLIRContext *context) -> mlir::Type {
+    TypeBuilderFunc f{getModel<bool>()};
+    return fir::ReferenceType::get(f(context));
+  };
+}
+template <>
+constexpr TypeBuilderFunc getModel<std::complex<float> &>() {
+  return [](mlir::MLIRContext *context) -> mlir::Type {
+    auto ty = mlir::ComplexType::get(mlir::FloatType::getF32(context));
+    return fir::ReferenceType::get(ty);
+  };
+}
+template <>
+constexpr TypeBuilderFunc getModel<std::complex<double> &>() {
+  return [](mlir::MLIRContext *context) -> mlir::Type {
+    auto ty = mlir::ComplexType::get(mlir::FloatType::getF64(context));
+    return fir::ReferenceType::get(ty);
+  };
+}
+template <>
+constexpr TypeBuilderFunc getModel<c_float_complex_t>() {
+  return [](mlir::MLIRContext *context) -> mlir::Type {
+    return fir::ComplexType::get(context, sizeof(float));
+  };
+}
+template <>
+constexpr TypeBuilderFunc getModel<c_double_complex_t>() {
+  return [](mlir::MLIRContext *context) -> mlir::Type {
+    return fir::ComplexType::get(context, sizeof(double));
+  };
+}
+template <>
+constexpr TypeBuilderFunc getModel<const Fortran::runtime::Descriptor &>() {
+  return [](mlir::MLIRContext *context) -> mlir::Type {
+    return fir::BoxType::get(mlir::NoneType::get(context));
+  };
+}
+template <>
+constexpr TypeBuilderFunc getModel<Fortran::runtime::Descriptor &>() {
+  return [](mlir::MLIRContext *context) -> mlir::Type {
+    return fir::ReferenceType::get(
+        fir::BoxType::get(mlir::NoneType::get(context)));
+  };
+}
+template <>
+constexpr TypeBuilderFunc getModel<const Fortran::runtime::Descriptor *>() {
+  return getModel<const Fortran::runtime::Descriptor &>();
+}
+template <>
+constexpr TypeBuilderFunc getModel<Fortran::runtime::Descriptor *>() {
+  return getModel<Fortran::runtime::Descriptor &>();
+}
+template <>
+constexpr TypeBuilderFunc getModel<Fortran::common::TypeCategory>() {
+  return [](mlir::MLIRContext *context) -> mlir::Type {
+    return mlir::IntegerType::get(context,
+                                  sizeof(Fortran::common::TypeCategory) * 8);
+  };
+}
+template <>
+constexpr TypeBuilderFunc getModel<void>() {
+  return [](mlir::MLIRContext *context) -> mlir::Type {
+    return mlir::NoneType::get(context);
+  };
+}
+
+template <typename...>
+struct RuntimeTableKey;
+template <typename RT, typename... ATs>
+struct RuntimeTableKey<RT(ATs...)> {
+  static constexpr FuncTypeBuilderFunc getTypeModel() {
+    return [](mlir::MLIRContext *ctxt) {
+      TypeBuilderFunc ret = getModel<RT>();
+      std::array<TypeBuilderFunc, sizeof...(ATs)> args = {getModel<ATs>()...};
+      mlir::Type retTy = ret(ctxt);
+      llvm::SmallVector<mlir::Type, sizeof...(ATs)> argTys;
+      for (auto f : args)
+        argTys.push_back(f(ctxt));
+      return mlir::FunctionType::get(ctxt, argTys, {retTy});
+    };
+  }
+};
+
+//===----------------------------------------------------------------------===//
+// Runtime table building (constexpr folded)
+//===----------------------------------------------------------------------===//
+
+template <char... Cs>
+using RuntimeIdentifier = std::integer_sequence<char, Cs...>;
+
+namespace details {
+template <typename T, T... As, T... Bs>
+static constexpr std::integer_sequence<T, As..., Bs...>
+concat(std::integer_sequence<T, As...>, std::integer_sequence<T, Bs...>) {
+  return {};
+}
+template <typename T, T... As, T... Bs, typename... Cs>
+static constexpr auto concat(std::integer_sequence<T, As...>,
+                             std::integer_sequence<T, Bs...>, Cs...) {
+  return concat(std::integer_sequence<T, As..., Bs...>{}, Cs{}...);
+}
+template <typename T>
+static constexpr std::integer_sequence<T> concat(std::integer_sequence<T>) {
+  return {};
+}
+template <typename T, T a>
+static constexpr auto filterZero(std::integer_sequence<T, a>) {
+  if constexpr (a != 0) {
+    return std::integer_sequence<T, a>{};
+  } else {
+    return std::integer_sequence<T>{};
+  }
+}
+template <typename T, T... b>
+static constexpr auto filter(std::integer_sequence<T, b...>) {
+  if constexpr (sizeof...(b) > 0) {
+    return details::concat(filterZero(std::integer_sequence<T, b>{})...);
+  } else {
+    return std::integer_sequence<T>{};
+  }
+}
+} // namespace details
+
+template <typename...>
+struct RuntimeTableEntry;
+template <typename KT, char... Cs>
+struct RuntimeTableEntry<RuntimeTableKey<KT>, RuntimeIdentifier<Cs...>> {
+  static constexpr FuncTypeBuilderFunc getTypeModel() {
+    return RuntimeTableKey<KT>::getTypeModel();
+  }
+  static constexpr const char name[sizeof...(Cs) + 1] = {Cs..., '\0'};
+};
+
+#undef E
+#define E(L, I) (I < sizeof(L) / sizeof(*L) ? L[I] : 0)
+#define QuoteKey(X) #X
+#define ExpandAndQuoteKey(X) QuoteKey(X)
+#define MacroExpandKey(X)                                                      \
+  E(X, 0), E(X, 1), E(X, 2), E(X, 3), E(X, 4), E(X, 5), E(X, 6), E(X, 7),      \
+      E(X, 8), E(X, 9), E(X, 10), E(X, 11), E(X, 12), E(X, 13), E(X, 14),      \
+      E(X, 15), E(X, 16), E(X, 17), E(X, 18), E(X, 19), E(X, 20), E(X, 21),    \
+      E(X, 22), E(X, 23), E(X, 24), E(X, 25), E(X, 26), E(X, 27), E(X, 28),    \
+      E(X, 29), E(X, 30), E(X, 31), E(X, 32), E(X, 33), E(X, 34), E(X, 35),    \
+      E(X, 36), E(X, 37), E(X, 38), E(X, 39), E(X, 40), E(X, 41), E(X, 42),    \
+      E(X, 43), E(X, 44), E(X, 45), E(X, 46), E(X, 47), E(X, 48), E(X, 49)
+#define ExpandKey(X) MacroExpandKey(QuoteKey(X))
+#define FullSeq(X) std::integer_sequence<char, ExpandKey(X)>
+#define AsSequence(X) decltype(fir::runtime::details::filter(FullSeq(X){}))
+#define mkKey(X)                                                               \
+  fir::runtime::RuntimeTableEntry<fir::runtime::RuntimeTableKey<decltype(X)>,  \
+                                  AsSequence(X)>
+#define mkRTKey(X) mkKey(RTNAME(X))
+
+/// Get (or generate) the MLIR FuncOp for a given runtime function. Its template
+/// argument is intended to be of the form: <mkRTKey(runtime function name)>
+/// Clients should add "using namespace Fortran::runtime"
+/// in order to use this function.
+template <typename RuntimeEntry>
+static mlir::FuncOp getRuntimeFunc(mlir::Location loc,
+                                   fir::FirOpBuilder &builder) {
+  auto name = RuntimeEntry::name;
+  auto func = builder.getNamedFunction(name);
+  if (func)
+    return func;
+  auto funTy = RuntimeEntry::getTypeModel()(builder.getContext());
+  func = builder.createFunction(loc, name, funTy);
+  func->setAttr("fir.runtime", builder.getUnitAttr());
+  return func;
+}
+
+namespace helper {
+template <int N, typename A>
+void createArguments(llvm::SmallVectorImpl<mlir::Value> &result,
+                     fir::FirOpBuilder &builder, mlir::Location loc,
+                     mlir::FunctionType fTy, A arg) {
+  result.emplace_back(builder.createConvert(loc, fTy.getInput(N), arg));
+}
+
+template <int N, typename A, typename... As>
+void createArguments(llvm::SmallVectorImpl<mlir::Value> &result,
+                     fir::FirOpBuilder &builder, mlir::Location loc,
+                     mlir::FunctionType fTy, A arg, As... args) {
+  result.emplace_back(builder.createConvert(loc, fTy.getInput(N), arg));
+  createArguments<N + 1>(result, builder, loc, fTy, args...);
+}
+} // namespace helper
+
+/// Create a SmallVector of arguments for a runtime call.
+template <typename... As>
+llvm::SmallVector<mlir::Value>
+createArguments(fir::FirOpBuilder &builder, mlir::Location loc,
+                mlir::FunctionType fTy, As... args) {
+  llvm::SmallVector<mlir::Value> result;
+  helper::createArguments<0>(result, builder, loc, fTy, args...);
+  return result;
+}
+
+} // namespace fir::runtime
+
+#endif // FORTRAN_OPTIMIZER_BUILDER_RUNTIME_RTBUILDER_H

flang/include/flang/Optimizer/Dialect/FIROpsSupport.h

 
 /// Get or create a GlobalOp in a module.
 fir::GlobalOp createGlobalOp(mlir::Location loc, mlir::ModuleOp module,
                              llvm::StringRef name, mlir::Type type,
                              llvm::ArrayRef<mlir::NamedAttribute> attrs = {});
 
 /// Attribute to mark Fortran entities with the CONTIGUOUS attribute.
 constexpr llvm::StringRef getContiguousAttrName() { return "fir.contiguous"; }
+
 /// Attribute to mark Fortran entities with the OPTIONAL attribute.
 constexpr llvm::StringRef getOptionalAttrName() { return "fir.optional"; }
 
+/// Attribute to mark Fortran entities with the TARGET attribute.
+static constexpr llvm::StringRef getTargetAttrName() { return "fir.target"; }
+
 /// Tell if \p value is:
 ///   - a function argument that has attribute \p attributeName
 ///   - or, the result of fir.alloca/fir.allocamem op that has attribute \p
 ///     attributeName
 ///   - or, the result of a fir.address_of of a fir.global that has attribute \p
 ///     attributeName
 ///   - or, a fir.box loaded from a fir.ref<fir.box> that matches one of the
 ///     previous cases.
 bool valueHasFirAttribute(mlir::Value value, llvm::StringRef attributeName);
 
 } // namespace fir
 
 #endif // FORTRAN_OPTIMIZER_DIALECT_FIROPSSUPPORT_H

flang/include/flang/Optimizer/Dialect/FIRType.h

inline bool isa_char_string(mlir::Type t) {
   return false;
 }
 
 /// Is `t` a box type for which it is not possible to deduce the box size?
 /// It is not possible to deduce the size of a box that describes an entity
 /// of unknown rank or type.
 bool isa_unknown_size_box(mlir::Type t);
 
+/// Returns true iff `t` is a fir.char type and has an unknown length.
+inline bool characterWithDynamicLen(mlir::Type t) {
+  if (auto charTy = t.dyn_cast<fir::CharacterType>())
+    return charTy.hasDynamicLen();
+  return false;
+}
+
+/// Returns true iff `seqTy` has either an unknown shape or a non-constant shape
+/// (where rank > 0).
+inline bool sequenceWithNonConstantShape(fir::SequenceType seqTy) {
+  return seqTy.hasUnknownShape() || !seqTy.hasConstantShape();
+}
+
+/// Returns true iff the type `t` does not have a constant size.
+bool hasDynamicSize(mlir::Type t);
+
 /// If `t` is a SequenceType return its element type, otherwise return `t`.
 inline mlir::Type unwrapSequenceType(mlir::Type t) {
   if (auto seqTy = t.dyn_cast<fir::SequenceType>())
     return seqTy.getEleTy();
   return t;
 }
 
+inline mlir::Type unwrapRefType(mlir::Type t) {
+  if (auto eleTy = dyn_cast_ptrEleTy(t))
+    return eleTy;
+  return t;
+}
+
 #ifndef NDEBUG
 // !fir.ptr<X> and !fir.heap<X> where X is !fir.ptr, !fir.heap, or !fir.ref
 // is undefined and disallowed.
 inline bool singleIndirectionLevel(mlir::Type ty) {
   return !fir::isa_ref_type(ty);
 }
 #endif
 
 /// Apply the components specified by `path` to `rootTy` to determine the type
 /// of the resulting component element. `rootTy` should be an aggregate type.
 /// Returns null on error.
 mlir::Type applyPathToType(mlir::Type rootTy, mlir::ValueRange path);
 
 } // namespace fir
 
 #endif // FORTRAN_OPTIMIZER_DIALECT_FIRTYPE_H

flang/include/flang/Optimizer/Dialect/FIRTypes.td

def fir_LogicalType : FIR_Type<"Logical", "logical"> {
 
   let parameters = (ins "KindTy":$fKind);
 
   let extraClassDeclaration = [{
     using KindTy = unsigned;
   }];
 }
 
+def fir_LLVMPointerType : FIR_Type<"LLVMPointer", "llvm_ptr"> {
+  let summary = "Like LLVM pointer type";
+
+  let description = [{
+    A pointer type that does not have any of the constraints and semantics
+    of other FIR pointer types and that translates to llvm pointer types.
+    It is meant to implement indirection that cannot be expressed directly
+    in Fortran, but are needed to implement some Fortran features (e.g,
+    double indirections).
+  }];
+
+  let parameters = (ins "mlir::Type":$eleTy);
+
+  let skipDefaultBuilders = 1;
+
+  let builders = [
+    TypeBuilderWithInferredContext<(ins "mlir::Type":$elementType), [{
+      return Base::get(elementType.getContext(), elementType);
+    }]>,
+  ];
+}
+
 def fir_PointerType : FIR_Type<"Pointer", "ptr"> {
   let summary = "Reference to a POINTER attribute type";
 
   let description = [{
     The type of entities with the POINTER attribute.  These pointers are
     explicitly distinguished to disallow the composition of multiple levels of
     indirection. For example, an ALLOCATABLE POINTER is invalid.
   }];
def fir_SequenceType : FIR_Type<"Sequence", "array"> {
   let genVerifyDecl = 1;
 
   let builders = [
     TypeBuilderWithInferredContext<(ins
         "llvm::ArrayRef<int64_t>":$shape,
         "mlir::Type":$eleTy), [{
       return get(eleTy.getContext(), shape, eleTy, {});
     }]>,
+    TypeBuilderWithInferredContext<(ins
+        "mlir::Type":$eleTy,
+        "size_t":$dimensions), [{
+      llvm::SmallVector<int64_t> shape(dimensions, getUnknownExtent());
+      return get(eleTy.getContext(), shape, eleTy, {});
+    }]>
   ];
 
   let extraClassDeclaration = [{
     using Extent = int64_t;
     using Shape = llvm::SmallVector<Extent, 8>;
     using ShapeRef = llvm::ArrayRef<int64_t>;
     unsigned getConstantRows() const;
 

flang/include/flang/Optimizer/Support/Matcher.h

+//===-- Optimizer/Support/Matcher.h -----------------------------*- 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
+//
+//===----------------------------------------------------------------------===//
+//
+// Coding style: https://mlir.llvm.org/getting_started/DeveloperGuide/
+//
+//===----------------------------------------------------------------------===//
+
+#ifndef FORTRAN_OPTIMIZER_SUPPORT_MATCHER_H
+#define FORTRAN_OPTIMIZER_SUPPORT_MATCHER_H
+
+#include <variant>
+
+// Boilerplate CRTP class for a simplified type-casing syntactic sugar. This
+// lets one write pattern matchers using a more compact syntax.
+namespace fir::details {
+// clang-format off
+template<class... Ts> struct matches : Ts... { using Ts::operator()...; };
+template<class... Ts> matches(Ts...) -> matches<Ts...>;
+template<typename N> struct matcher {
+  template<typename... Ts> auto match(Ts... ts) {
+    return std::visit(matches{ts...}, static_cast<N*>(this)->matchee());
+  }
+  template<typename... Ts> auto match(Ts... ts) const {
+    return std::visit(matches{ts...}, static_cast<N const*>(this)->matchee());
+  }
+};
+// clang-format on
+} // namespace fir::details
+
+#endif // FORTRAN_OPTIMIZER_SUPPORT_MATCHER_H

flang/include/flang/Optimizer/Transforms/Factory.h

+//===-- Optimizer/Transforms/Factory.h --------------------------*- 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
+//
+//===----------------------------------------------------------------------===//
+//
+// Templates to generate more complex code patterns in transformation passes.
+// In transformation passes, front-end information such as is available in
+// lowering is not available.
+//
+//===----------------------------------------------------------------------===//
+
+#ifndef FORTRAN_OPTIMIZER_TRANSFORMS_FACTORY_H
+#define FORTRAN_OPTIMIZER_TRANSFORMS_FACTORY_H
+
+#include "flang/Optimizer/Dialect/FIROps.h"
+#include "flang/Optimizer/Dialect/FIRType.h"
+#include "mlir/Dialect/StandardOps/IR/Ops.h"
+#include "llvm/ADT/iterator_range.h"
+
+namespace mlir {
+class Location;
+class Value;
+} // namespace mlir
+
+namespace fir::factory {
+
+constexpr llvm::StringRef attrFortranArrayOffsets() {
+  return "Fortran.offsets";
+}
+
+/// Generate a character copy with optimized forms.
+///
+/// If the lengths are constant and equal, use load/store rather than a loop.
+/// Otherwise, if the lengths are constant and the input is longer than the
+/// output, generate a loop to move a truncated portion of the source to the
+/// destination. Finally, if the lengths are runtime values or the destination
+/// is longer than the source, move the entire source character and pad the
+/// destination with spaces as needed.
+template <typename B>
+void genCharacterCopy(mlir::Value src, mlir::Value srcLen, mlir::Value dst,
+                      mlir::Value dstLen, B &builder, mlir::Location loc) {
+  auto srcTy =
+      fir::dyn_cast_ptrEleTy(src.getType()).template cast<fir::CharacterType>();
+  auto dstTy =
+      fir::dyn_cast_ptrEleTy(dst.getType()).template cast<fir::CharacterType>();
+  if (!srcLen && !dstLen && srcTy.getFKind() == dstTy.getFKind() &&
+      srcTy.getLen() == dstTy.getLen()) {
+    // same size, so just use load and store
+    auto load = builder.template create<fir::LoadOp>(loc, src);
+    builder.template create<fir::StoreOp>(loc, load, dst);
+    return;
+  }
+  auto zero = builder.template create<mlir::ConstantIndexOp>(loc, 0);
+  auto one = builder.template create<mlir::ConstantIndexOp>(loc, 1);
+  auto toArrayTy = [&](fir::CharacterType ty) {
+    return fir::ReferenceType::get(fir::SequenceType::get(
+        fir::SequenceType::ShapeRef{fir::SequenceType::getUnknownExtent()},
+        fir::CharacterType::getSingleton(ty.getContext(), ty.getFKind())));
+  };
+  auto toEleTy = [&](fir::ReferenceType ty) {
+    auto seqTy = ty.getEleTy().cast<fir::SequenceType>();
+    return seqTy.getEleTy().cast<fir::CharacterType>();
+  };
+  auto toCoorTy = [&](fir::ReferenceType ty) {
+    return fir::ReferenceType::get(toEleTy(ty));
+  };
+  if (!srcLen && !dstLen && srcTy.getLen() >= dstTy.getLen()) {
+    auto upper =
+        builder.template create<mlir::ConstantIndexOp>(loc, dstTy.getLen() - 1);
+    auto loop = builder.template create<fir::DoLoopOp>(loc, zero, upper, one);
+    auto insPt = builder.saveInsertionPoint();
+    builder.setInsertionPointToStart(loop.getBody());
+    auto csrcTy = toArrayTy(srcTy);
+    auto csrc = builder.template create<fir::ConvertOp>(loc, csrcTy, src);
+    auto in = builder.template create<fir::CoordinateOp>(
+        loc, toCoorTy(csrcTy), csrc, loop.getInductionVar());
+    auto load = builder.template create<fir::LoadOp>(loc, in);
+    auto cdstTy = toArrayTy(dstTy);
+    auto cdst = builder.template create<fir::ConvertOp>(loc, cdstTy, dst);
+    auto out = builder.template create<fir::CoordinateOp>(
+        loc, toCoorTy(cdstTy), cdst, loop.getInductionVar());
+    mlir::Value cast =
+        srcTy.getFKind() == dstTy.getFKind()
+            ? load.getResult()
+            : builder
+                  .template create<fir::ConvertOp>(loc, toEleTy(cdstTy), load)
+                  .getResult();
+    builder.template create<fir::StoreOp>(loc, cast, out);
+    builder.restoreInsertionPoint(insPt);
+    return;
+  }
+  auto minusOne = [&](mlir::Value v) -> mlir::Value {
+    return builder.template create<mlir::SubIOp>(
+        loc, builder.template create<fir::ConvertOp>(loc, one.getType(), v),
+        one);
+  };
+  mlir::Value len =
+      dstLen
+          ? minusOne(dstLen)
+          : builder
+                .template create<mlir::ConstantIndexOp>(loc, dstTy.getLen() - 1)
+                .getResult();
+  auto loop = builder.template create<fir::DoLoopOp>(loc, zero, len, one);
+  auto insPt = builder.saveInsertionPoint();
+  builder.setInsertionPointToStart(loop.getBody());
+  mlir::Value slen =
+      srcLen
+          ? builder.template create<fir::ConvertOp>(loc, one.getType(), srcLen)
+                .getResult()
+          : builder.template create<mlir::ConstantIndexOp>(loc, srcTy.getLen())
+                .getResult();
+  auto cond = builder.template create<mlir::CmpIOp>(
+      loc, mlir::CmpIPredicate::slt, loop.getInductionVar(), slen);
+  auto ifOp = builder.template create<fir::IfOp>(loc, cond, /*withElse=*/true);
+  builder.setInsertionPointToStart(&ifOp.thenRegion().front());
+  auto csrcTy = toArrayTy(srcTy);
+  auto csrc = builder.template create<fir::ConvertOp>(loc, csrcTy, src);
+  auto in = builder.template create<fir::CoordinateOp>(
+      loc, toCoorTy(csrcTy), csrc, loop.getInductionVar());
+  auto load = builder.template create<fir::LoadOp>(loc, in);
+  auto cdstTy = toArrayTy(dstTy);
+  auto cdst = builder.template create<fir::ConvertOp>(loc, cdstTy, dst);
+  auto out = builder.template create<fir::CoordinateOp>(
+      loc, toCoorTy(cdstTy), cdst, loop.getInductionVar());
+  mlir::Value cast =
+      srcTy.getFKind() == dstTy.getFKind()
+          ? load.getResult()
+          : builder.template create<fir::ConvertOp>(loc, toEleTy(cdstTy), load)
+                .getResult();
+  builder.template create<fir::StoreOp>(loc, cast, out);
+  builder.setInsertionPointToStart(&ifOp.elseRegion().front());
+  auto space = builder.template create<fir::StringLitOp>(
+      loc, toEleTy(cdstTy), llvm::ArrayRef<char>{' '});
+  auto cdst2 = builder.template create<fir::ConvertOp>(loc, cdstTy, dst);
+  auto out2 = builder.template create<fir::CoordinateOp>(
+      loc, toCoorTy(cdstTy), cdst2, loop.getInductionVar());
+  builder.template create<fir::StoreOp>(loc, space, out2);
+  builder.restoreInsertionPoint(insPt);
+}
+
+/// Get extents from fir.shape/fir.shape_shift op. Empty result if
+/// \p shapeVal is empty or is a fir.shift.
+inline std::vector<mlir::Value> getExtents(mlir::Value shapeVal) {
+  if (shapeVal)
+    if (auto *shapeOp = shapeVal.getDefiningOp()) {
+      if (auto shOp = mlir::dyn_cast<fir::ShapeOp>(shapeOp))
+        return shOp.getExtents();
+      if (auto shOp = mlir::dyn_cast<fir::ShapeShiftOp>(shapeOp))
+        return shOp.getExtents();
+    }
+  return {};
+}
+
+/// Get origins from fir.shape_shift/fir.shift op. Empty result if
+/// \p shapeVal is empty or is a fir.shape.
+inline std::vector<mlir::Value> getOrigins(mlir::Value shapeVal) {
+  if (shapeVal)
+    if (auto *shapeOp = shapeVal.getDefiningOp()) {
+      if (auto shOp = mlir::dyn_cast<fir::ShapeShiftOp>(shapeOp))
+        return shOp.getOrigins();
+      if (auto shOp = mlir::dyn_cast<fir::ShiftOp>(shapeOp))
+        return shOp.getOrigins();
+    }
+  return {};
+}
+
+/// Convert the normalized indices on array_fetch and array_update to the
+/// dynamic (and non-zero) origin required by array_coor.
+/// Do not adjust any trailing components in the path as they specify a
+/// particular path into the array value and must already correspond to the
+/// structure of an element.
+template <typename B>
+llvm::SmallVector<mlir::Value>
+originateIndices(mlir::Location loc, B &builder, mlir::Type memTy,
+                 mlir::Value shapeVal, mlir::ValueRange indices) {
+  llvm::SmallVector<mlir::Value> result;
+  auto origins = getOrigins(shapeVal);
+  if (origins.empty()) {
+    assert(!shapeVal || mlir::isa<fir::ShapeOp>(shapeVal.getDefiningOp()));
+    auto ty = fir::dyn_cast_ptrOrBoxEleTy(memTy);
+    assert(ty && ty.isa<fir::SequenceType>());
+    auto seqTy = ty.cast<fir::SequenceType>();
+    auto one = builder.template create<mlir::ConstantIndexOp>(loc, 1);
+    const auto dimension = seqTy.getDimension();
+    if (shapeVal) {
+      assert(dimension == mlir::cast<fir::ShapeOp>(shapeVal.getDefiningOp())
+                              .getType()
+                              .getRank());
+    }
+    for (auto i : llvm::enumerate(indices)) {
+      if (i.index() < dimension) {
+        assert(fir::isa_integer(i.value().getType()));
+        result.push_back(
+            builder.template create<mlir::AddIOp>(loc, i.value(), one));
+      } else {
+        result.push_back(i.value());
+      }
+    }
+    return result;
+  }
+  const auto dimension = origins.size();
+  unsigned origOff = 0;
+  for (auto i : llvm::enumerate(indices)) {
+    if (i.index() < dimension)
+      result.push_back(builder.template create<mlir::AddIOp>(
+          loc, i.value(), origins[origOff++]));
+    else
+      result.push_back(i.value());
+  }
+  return result;
+}
+
+template <typename B, typename Iter>
+llvm::SmallVector<fir::DoLoopOp> createLoopNest(
+    mlir::Location loc, B &builder, llvm::iterator_range<Iter> lows,
+    llvm::iterator_range<Iter> highs, llvm::iterator_range<Iter> steps,
+    llvm::ArrayRef<mlir::Value> threadedVals, bool unordered = false) {
+  llvm::SmallVector<fir::DoLoopOp> loops;
+  llvm::SmallVector<mlir::Value> inners(threadedVals.begin(),
+                                        threadedVals.end());
+  for (auto iter0 = lows.begin(), iter1 = highs.begin(), iter2 = steps.begin();
+       iter1 != highs.end(); ++iter0, ++iter1, ++iter2) {
+    auto lp = builder.template create<fir::DoLoopOp>(
+        loc, *iter0, *iter1, *iter2, unordered,
+        /*finalCount=*/false, inners);
+    loops.push_back(lp);
+    inners.assign(lp.getRegionIterArgs().begin(), lp.getRegionIterArgs().end());
+    builder.setInsertionPointToStart(lp.getBody());
+  }
+  auto numLoops = loops.size();
+  for (decltype(numLoops) i = 0; i + 1 < numLoops; ++i) {
+    builder.setInsertionPointToEnd(loops[i].getBody());
+    builder.template create<fir::ResultOp>(loc, loops[i + 1].getResults());
+  }
+  builder.setInsertionPointAfter(loops[0]);
+  llvm::errs() << loops[0] << '\n';
+  return loops;
+}
+
+template <typename B>
+llvm::SmallVector<fir::DoLoopOp> createLoopNest(
+    mlir::Location loc, B &builder, llvm::ArrayRef<mlir::Value> lows,
+    llvm::ArrayRef<mlir::Value> highs, llvm::ArrayRef<mlir::Value> steps,
+    llvm::ArrayRef<mlir::Value> threadedVals, bool unordered = false) {
+  return createLoopNest(
+      loc, builder, llvm::make_range(lows.begin(), lows.end()),
+      llvm::make_range(highs.begin(), highs.end()),
+      llvm::make_range(steps.begin(), steps.end()), threadedVals, unordered);
+}
+
+} // namespace fir::factory
+
+#endif // FORTRAN_OPTIMIZER_TRANSFORMS_FACTORY_H

flang/include/flang/Optimizer/Transforms/Passes.h

 class BlockAndValueMapping;
 class Operation;
 class Pass;
 class Region;
 } // namespace mlir
 
 namespace fir {
 
+std::unique_ptr<mlir::Pass> createArrayValueCopyPass();
 std::unique_ptr<mlir::Pass> createExternalNameConversionPass();
 
 /// Support for inlining on FIR.
 bool canLegallyInline(mlir::Operation *op, mlir::Region *reg,
                       mlir::BlockAndValueMapping &map);
 
 // declarative passes
 #define GEN_PASS_REGISTRATION
 #include "flang/Optimizer/Transforms/Passes.h.inc"
 
 } // namespace fir
 
 #endif // OPTIMIZER_TRANSFORMS_PASSES_H

flang/include/flang/Optimizer/Transforms/Passes.td

 //
 //===----------------------------------------------------------------------===//
 
 #ifndef FLANG_OPTIMIZER_TRANSFORMS_PASSES
 #define FLANG_OPTIMIZER_TRANSFORMS_PASSES
 
 include "mlir/Pass/PassBase.td"
 
+def ArrayValueCopy : FunctionPass<"array-value-copy"> {
+  let summary = "Convert array value operations to memory operations.";
+  let description = [{
+    Transform the set of array value primitives to a memory-based array
+    representation.
+
+    The Ops `array_load`, `array_store`, `array_fetch`, and `array_update` are
+    used to manage abstract aggregate array values. A simple analysis is done
+    to determine if there are potential dependences between these operations.
+    If not, these array operations can be lowered to work directly on the memory
+    representation. If there is a potential conflict, a temporary is created
+    along with appropriate copy-in/copy-out operations. Here, a more refined
+    analysis might be deployed, such as using the affine framework.
+
+    This pass is required before code gen to the LLVM IR dialect.
+  }];
+  let constructor = "::fir::createArrayValueCopyPass()";
+  let dependentDialects = [
+    "fir::FIROpsDialect", "mlir::StandardOpsDialect"
+  ];
+}
+
 def ExternalNameConversion : Pass<"external-name-interop", "mlir::ModuleOp"> {
   let summary = "Convert name for external interoperability";
   let description = [{
     Demangle FIR internal name and mangle them for external interoperability.
   }];
   let constructor = "::fir::createExternalNameConversionPass()";
 }
 
 #endif // FLANG_OPTIMIZER_TRANSFORMS_PASSES

flang/lib/Optimizer/Builder/BoxValue.cpp

+//===-- BoxValue.cpp ------------------------------------------------------===//
+//
+// 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
+//
+//===----------------------------------------------------------------------===//
+//
+// Pretty printers for box values, etc.
+//
+//===----------------------------------------------------------------------===//
+
+#include "flang/Optimizer/Builder/BoxValue.h"
+#include "mlir/IR/BuiltinTypes.h"
+#include "llvm/Support/Debug.h"
+
+#define DEBUG_TYPE "flang-box-value"
+
+mlir::Value fir::getBase(const fir::ExtendedValue &exv) {
+  return exv.match([](const fir::UnboxedValue &x) { return x; },
+                   [](const auto &x) { return x.getAddr(); });
+}
+
+mlir::Value fir::getLen(const fir::ExtendedValue &exv) {
+  return exv.match(
+      [](const fir::CharBoxValue &x) { return x.getLen(); },
+      [](const fir::CharArrayBoxValue &x) { return x.getLen(); },
+      [](const fir::BoxValue &) -> mlir::Value {
+        llvm::report_fatal_error("Need to read len from BoxValue Exv");
+      },
+      [](const fir::MutableBoxValue &) -> mlir::Value {
+        llvm::report_fatal_error("Need to read len from MutableBoxValue Exv");
+      },
+      [](const auto &) { return mlir::Value{}; });
+}
+
+fir::ExtendedValue fir::substBase(const fir::ExtendedValue &exv,
+                                  mlir::Value base) {
+  return exv.match(
+      [=](const fir::UnboxedValue &x) { return fir::ExtendedValue(base); },
+      [=](const fir::BoxValue &) -> fir::ExtendedValue {
+        llvm::report_fatal_error("TODO: substbase of BoxValue");
+      },
+      [=](const fir::MutableBoxValue &) -> fir::ExtendedValue {
+        llvm::report_fatal_error("TODO: substbase of MutableBoxValue");
+      },
+      [=](const auto &x) { return fir::ExtendedValue(x.clone(base)); });
+}
+
+llvm::SmallVector<mlir::Value> fir::getTypeParams(const ExtendedValue &exv) {
+  using RT = llvm::SmallVector<mlir::Value>;
+  auto baseTy = fir::getBase(exv).getType();
+  if (auto t = fir::dyn_cast_ptrEleTy(baseTy))
+    baseTy = t;
+  baseTy = fir::unwrapSequenceType(baseTy);
+  if (!fir::hasDynamicSize(baseTy))
+    return {}; // type has constant size, no type parameters needed
+  [[maybe_unused]] auto loc = fir::getBase(exv).getLoc();
+  return exv.match(
+      [](const fir::CharBoxValue &x) -> RT { return {x.getLen()}; },
+      [](const fir::CharArrayBoxValue &x) -> RT { return {x.getLen()}; },
+      [&](const fir::BoxValue &) -> RT {
+        LLVM_DEBUG(mlir::emitWarning(
+            loc, "TODO: box value is missing type parameters"));
+        return {};
+      },
+      [&](const fir::MutableBoxValue &) -> RT {
+        // In this case, the type params may be bound to the variable in an
+        // ALLOCATE statement as part of a type-spec.
+        LLVM_DEBUG(mlir::emitWarning(
+            loc, "TODO: mutable box value is missing type parameters"));
+        return {};
+      },
+      [](const auto &) -> RT { return {}; });
+}
+
+bool fir::isArray(const fir::ExtendedValue &exv) {
+  return exv.match(
+      [](const fir::ArrayBoxValue &) { return true; },
+      [](const fir::CharArrayBoxValue &) { return true; },
+      [](const fir::BoxValue &box) { return box.hasRank(); },
+      [](const fir::MutableBoxValue &box) { return box.hasRank(); },
+      [](auto) { return false; });
+}
+
+llvm::raw_ostream &fir::operator<<(llvm::raw_ostream &os,
+                                   const fir::CharBoxValue &box) {
+  return os << "boxchar { addr: " << box.getAddr() << ", len: " << box.getLen()
+            << " }";
+}
+
+llvm::raw_ostream &fir::operator<<(llvm::raw_ostream &os,
+                                   const fir::ArrayBoxValue &box) {
+  os << "boxarray { addr: " << box.getAddr();
+  if (box.getLBounds().size()) {
+    os << ", lbounds: [";
+    llvm::interleaveComma(box.getLBounds(), os);
+    os << "]";
+  } else {
+    os << ", lbounds: all-ones";
+  }
+  os << ", shape: [";
+  llvm::interleaveComma(box.getExtents(), os);
+  return os << "]}";
+}
+
+llvm::raw_ostream &fir::operator<<(llvm::raw_ostream &os,
+                                   const fir::CharArrayBoxValue &box) {
+  os << "boxchararray { addr: " << box.getAddr() << ", len : " << box.getLen();
+  if (box.getLBounds().size()) {
+    os << ", lbounds: [";
+    llvm::interleaveComma(box.getLBounds(), os);
+    os << "]";
+  } else {
+    os << " lbounds: all-ones";
+  }
+  os << ", shape: [";
+  llvm::interleaveComma(box.getExtents(), os);
+  return os << "]}";
+}
+
+llvm::raw_ostream &fir::operator<<(llvm::raw_ostream &os,
+                                   const fir::ProcBoxValue &box) {
+  return os << "boxproc: { procedure: " << box.getAddr()
+            << ", context: " << box.hostContext << "}";
+}
+
+llvm::raw_ostream &fir::operator<<(llvm::raw_ostream &os,
+                                   const fir::BoxValue &box) {
+  os << "box: { value: " << box.getAddr();
+  if (box.lbounds.size()) {
+    os << ", lbounds: [";
+    llvm::interleaveComma(box.lbounds, os);
+    os << "]";
+  }
+  if (!box.explicitParams.empty()) {
+    os << ", explicit type params: [";
+    llvm::interleaveComma(box.explicitParams, os);
+    os << "]";
+  }
+  if (!box.extents.empty()) {
+    os << ", explicit extents: [";
+    llvm::interleaveComma(box.extents, os);
+    os << "]";
+  }
+  return os << "}";
+}
+
+llvm::raw_ostream &fir::operator<<(llvm::raw_ostream &os,
+                                   const fir::MutableBoxValue &box) {
+  os << "mutablebox: { addr: " << box.getAddr();
+  if (!box.lenParams.empty()) {
+    os << ", non deferred type params: [";
+    llvm::interleaveComma(box.lenParams, os);
+    os << "]";
+  }
+  const auto &properties = box.mutableProperties;
+  if (!properties.isEmpty()) {
+    os << ", mutableProperties: { addr: " << properties.addr;
+    if (!properties.lbounds.empty()) {
+      os << ", lbounds: [";
+      llvm::interleaveComma(properties.lbounds, os);
+      os << "]";
+    }
+    if (!properties.extents.empty()) {
+      os << ", shape: [";
+      llvm::interleaveComma(properties.extents, os);
+      os << "]";
+    }
+    if (!properties.deferredParams.empty()) {
+      os << ", deferred type params: [";
+      llvm::interleaveComma(properties.deferredParams, os);
+      os << "]";
+    }
+    os << "}";
+  }
+  return os << "}";
+}
+
+llvm::raw_ostream &fir::operator<<(llvm::raw_ostream &os,
+                                   const fir::ExtendedValue &exv) {
+  exv.match([&](const auto &value) { os << value; });
+  return os;
+}
+
+/// Debug verifier for MutableBox ctor. There is no guarantee that this will
+/// always be called, so it should not have any functional side effects,
+/// the const is here to enforce that.
+bool fir::MutableBoxValue::verify() const {
+  auto type = fir::dyn_cast_ptrEleTy(getAddr().getType());
+  if (!type)
+    return false;
+  auto box = type.dyn_cast<fir::BoxType>();
+  if (!box)
+    return false;
+  auto eleTy = box.getEleTy();
+  if (!eleTy.isa<fir::PointerType>() && !eleTy.isa<fir::HeapType>())
+    return false;
+
+  auto nParams = lenParams.size();
+  if (isCharacter()) {
+    if (nParams > 1)
+      return false;
+  } else if (!isDerived()) {
+    if (nParams != 0)
+      return false;
+  }
+  return true;
+}
+
+/// Debug verifier for BoxValue ctor. There is no guarantee this will
+/// always be called.
+bool fir::BoxValue::verify() const {
+  if (!addr.getType().isa<fir::BoxType>())
+    return false;
+  if (!lbounds.empty() && lbounds.size() != rank())
+    return false;
+  // Explicit extents are here to cover cases where an explicit-shape dummy
+  // argument comes as a fir.box. This can only happen with derived types and
+  // unlimited polymorphic.
+  if (!extents.empty() && !(isDerived() || isUnlimitedPolymorphic()))
+    return false;
+  if (!extents.empty() && extents.size() != rank())
+    return false;
+  if (isCharacter() && explicitParams.size() > 1)
+    return false;
+  return true;
+}

flang/lib/Optimizer/Builder/CMakeLists.txt

+get_property(dialect_libs GLOBAL PROPERTY MLIR_DIALECT_LIBS)
+add_flang_library(FIRBuilder
+  BoxValue.cpp
+  Character.cpp
+  DoLoopHelper.cpp
+  FIRBuilder.cpp
+  MutableBox.cpp
+  Runtime/Assign.cpp
+
+  DEPENDS
+  FIRDialect
+  FIRSupport
+  ${dialect_libs}
+
+  LINK_LIBS
+  FIRDialect
+  FIRSupport
+  ${dialect_libs}
+)

flang/lib/Optimizer/Builder/Character.cpp

+//===-- Character.cpp -----------------------------------------------------===//
+//
+// 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
+//
+//===----------------------------------------------------------------------===//
+//
+// Coding style: https://mlir.llvm.org/getting_started/DeveloperGuide/
+//
+//===----------------------------------------------------------------------===//
+
+#include "flang/Optimizer/Builder/Character.h"
+#include "flang/Lower/Todo.h"
+#include "flang/Optimizer/Builder/DoLoopHelper.h"
+#include "llvm/Support/Debug.h"
+
+#define DEBUG_TYPE "flang-lower-character"
+
+//===----------------------------------------------------------------------===//
+// CharacterExprHelper implementation
+//===----------------------------------------------------------------------===//
+
+/// Unwrap base fir.char<kind,len> type.
+static fir::CharacterType recoverCharacterType(mlir::Type type) {
+  if (auto boxType = type.dyn_cast<fir::BoxCharType>())
+    return boxType.getEleTy();
+  while (true) {
+    type = fir::unwrapRefType(type);
+    if (auto boxTy = type.dyn_cast<fir::BoxType>())
+      type = boxTy.getEleTy();
+    else
+      break;
+  }
+  return fir::unwrapSequenceType(type).cast<fir::CharacterType>();
+}
+
+/// Get fir.char<kind> type with the same kind as inside str.
+fir::CharacterType
+fir::factory::CharacterExprHelper::getCharacterType(mlir::Type type) {
+  assert(isCharacterScalar(type) && "expected scalar character");
+  return recoverCharacterType(type);
+}
+
+fir::CharacterType fir::factory::CharacterExprHelper::getCharacterType(
+    const fir::CharBoxValue &box) {
+  return getCharacterType(box.getBuffer().getType());
+}
+
+fir::CharacterType
+fir::factory::CharacterExprHelper::getCharacterType(mlir::Value str) {
+  return getCharacterType(str.getType());
+}
+
+/// Determine the static size of the character. Returns the computed size, not
+/// an IR Value.
+static std::optional<fir::CharacterType::LenType>
+getCompileTimeLength(const fir::CharBoxValue &box) {
+  auto len = recoverCharacterType(box.getBuffer().getType()).getLen();
+  if (len == fir::CharacterType::unknownLen())
+    return {};
+  return len;
+}
+
+/// Detect the precondition that the value `str` does not reside in memory. Such
+/// values will have a type `!fir.array<...x!fir.char<N>>` or `!fir.char<N>`.
+LLVM_ATTRIBUTE_UNUSED static bool needToMaterialize(mlir::Value str) {
+  return str.getType().isa<fir::SequenceType>() || fir::isa_char(str.getType());
+}
+
+/// Unwrap integer constant from mlir::Value.
+static llvm::Optional<std::int64_t> getIntIfConstant(mlir::Value value) {
+  if (auto *definingOp = value.getDefiningOp())
+    if (auto cst = mlir::dyn_cast<mlir::ConstantOp>(definingOp))
+      if (auto intAttr = cst.getValue().dyn_cast<mlir::IntegerAttr>())
+        return intAttr.getInt();
+  return {};
+}
+
+/// This is called only if `str` does not reside in memory. Such a bare string
+/// value will be converted into a memory-based temporary and an extended
+/// boxchar value returned.
+fir::CharBoxValue
+fir::factory::CharacterExprHelper::materializeValue(mlir::Value str) {
+  assert(needToMaterialize(str));
+  auto ty = str.getType();
+  assert(isCharacterScalar(ty) && "expected scalar character");
+  auto charTy = ty.dyn_cast<fir::CharacterType>();
+  if (!charTy || charTy.getLen() == fir::CharacterType::unknownLen()) {
+    LLVM_DEBUG(llvm::dbgs() << "cannot materialize: " << str << '\n');
+    llvm_unreachable("must be a !fir.char<N> type");
+  }
+  auto len = builder.createIntegerConstant(
+      loc, builder.getCharacterLengthType(), charTy.getLen());
+  auto temp = builder.create<fir::AllocaOp>(loc, charTy);
+  builder.create<fir::StoreOp>(loc, str, temp);
+  LLVM_DEBUG(llvm::dbgs() << "materialized as local: " << str << " -> (" << temp
+                          << ", " << len << ")\n");
+  return {temp, len};
+}
+
+fir::ExtendedValue
+fir::factory::CharacterExprHelper::toExtendedValue(mlir::Value character,
+                                                   mlir::Value len) {
+  auto lenType = builder.getCharacterLengthType();
+  auto type = character.getType();
+  auto base = fir::isa_passbyref_type(type) ? character : mlir::Value{};
+  auto resultLen = len;
+  llvm::SmallVector<mlir::Value> extents;
+
+  if (auto eleType = fir::dyn_cast_ptrEleTy(type))
+    type = eleType;
+
+  if (auto arrayType = type.dyn_cast<fir::SequenceType>()) {
+    type = arrayType.getEleTy();
+    auto indexType = builder.getIndexType();
+    for (auto extent : arrayType.getShape()) {
+      if (extent == fir::SequenceType::getUnknownExtent())
+        break;
+      extents.emplace_back(
+          builder.createIntegerConstant(loc, indexType, extent));
+    }
+    // Last extent might be missing in case of assumed-size. If more extents
+    // could not be deduced from type, that's an error (a fir.box should
+    // have been used in the interface).
+    if (extents.size() + 1 < arrayType.getShape().size())
+      mlir::emitError(loc, "cannot retrieve array extents from type");
+  }
+
+  if (auto charTy = type.dyn_cast<fir::CharacterType>()) {
+    if (!resultLen && charTy.getLen() != fir::CharacterType::unknownLen())
+      resultLen = builder.createIntegerConstant(loc, lenType, charTy.getLen());
+  } else if (auto boxCharType = type.dyn_cast<fir::BoxCharType>()) {
+    auto refType = builder.getRefType(boxCharType.getEleTy());
+    // If the embox is accessible, use its operand to avoid filling
+    // the generated fir with embox/unbox.
+    mlir::Value boxCharLen;
+    if (auto *definingOp = character.getDefiningOp()) {
+      if (auto box = dyn_cast<fir::EmboxCharOp>(definingOp)) {
+        base = box.memref();
+        boxCharLen = box.len();
+      }
+    }
+    if (!boxCharLen) {
+      auto unboxed =
+          builder.create<fir::UnboxCharOp>(loc, refType, lenType, character);
+      base = builder.createConvert(loc, refType, unboxed.getResult(0));
+      boxCharLen = unboxed.getResult(1);
+    }
+    if (!resultLen) {
+      resultLen = boxCharLen;
+    }
+  } else if (type.isa<fir::BoxType>()) {
+    mlir::emitError(loc, "descriptor or derived type not yet handled");
+  } else {
+    llvm_unreachable("Cannot translate mlir::Value to character ExtendedValue");
+  }
+
+  if (!base) {
+    if (auto load =
+            mlir::dyn_cast_or_null<fir::LoadOp>(character.getDefiningOp())) {
+      base = load.getOperand();
+    } else {
+      return materializeValue(fir::getBase(character));
+    }
+  }
+  if (!resultLen)
+    llvm::report_fatal_error("no dynamic length found for character");
+  if (!extents.empty())
+    return fir::CharArrayBoxValue{base, resultLen, extents};
+  return fir::CharBoxValue{base, resultLen};
+}
+
+static mlir::Type getSingletonCharType(mlir::MLIRContext *ctxt, int kind) {
+  return fir::CharacterType::getSingleton(ctxt, kind);
+}
+
+mlir::Value
+fir::factory::CharacterExprHelper::createEmbox(const fir::CharBoxValue &box) {
+  // Base CharBoxValue of CharArrayBoxValue are ok here (do not require a scalar
+  // type)
+  auto charTy = recoverCharacterType(box.getBuffer().getType());
+  auto boxCharType =
+      fir::BoxCharType::get(builder.getContext(), charTy.getFKind());
+  auto refType = fir::ReferenceType::get(boxCharType.getEleTy());
+  mlir::Value buff = box.getBuffer();
+  // fir.boxchar requires a memory reference. Allocate temp if the character is
+  // not in memory.
+  if (!fir::isa_ref_type(buff.getType())) {
+    auto temp = builder.createTemporary(loc, buff.getType());
+    builder.create<fir::StoreOp>(loc, buff, temp);
+    buff = temp;
+  }
+  buff = builder.createConvert(loc, refType, buff);
+  // Convert in case the provided length is not of the integer type that must
+  // be used in boxchar.
+  auto len = builder.createConvert(loc, builder.getCharacterLengthType(),
+                                   box.getLen());
+  return builder.create<fir::EmboxCharOp>(loc, boxCharType, buff, len);
+}
+
+fir::CharBoxValue fir::factory::CharacterExprHelper::toScalarCharacter(
+    const fir::CharArrayBoxValue &box) {
+  if (box.getBuffer().getType().isa<fir::PointerType>())
+    TODO(loc, "concatenating non contiguous character array into a scalar");
+
+  // TODO: add a fast path multiplying new length at compile time if the info is
+  // in the array type.
+  auto lenType = builder.getCharacterLengthType();
+  auto len = builder.createConvert(loc, lenType, box.getLen());
+  for (auto extent : box.getExtents())
+    len = builder.create<mlir::MulIOp>(
+        loc, len, builder.createConvert(loc, lenType, extent));
+
+  // TODO: typeLen can be improved in compiled constant cases
+  // TODO: allow bare fir.array<> (no ref) conversion here ?
+  auto typeLen = fir::CharacterType::unknownLen();
+  auto kind = recoverCharacterType(box.getBuffer().getType()).getFKind();
+  auto charTy = fir::CharacterType::get(builder.getContext(), kind, typeLen);
+  auto type = fir::ReferenceType::get(charTy);
+  auto buffer = builder.createConvert(loc, type, box.getBuffer());
+  return {buffer, len};
+}
+
+mlir::Value fir::factory::CharacterExprHelper::createEmbox(
+    const fir::CharArrayBoxValue &box) {
+  // Use same embox as for scalar. It's losing the actual data size information
+  // (We do not multiply the length by the array size), but that is what Fortran
+  // call interfaces using boxchar expect.
+  return createEmbox(static_cast<const fir::CharBoxValue &>(box));
+}
+
+/// Get the address of the element at position \p index of the scalar character
+/// \p buffer.
+/// \p buffer must be of type !fir.ref<fir.char<k, len>>. The length may be
+/// unknown. \p index must have any integer type, and is zero based. The return
+/// value is a singleton address (!fir.ref<!fir.char<kind>>)
+mlir::Value
+fir::factory::CharacterExprHelper::createElementAddr(mlir::Value buffer,
+                                                     mlir::Value index) {
+  // The only way to address an element of a fir.ref<char<kind, len>> is to cast
+  // it to a fir.array<len x fir.char<kind>> and use fir.coordinate_of.
+  auto bufferType = buffer.getType();
+  assert(fir::isa_ref_type(bufferType));
+  assert(isCharacterScalar(bufferType));
+  auto charTy = recoverCharacterType(bufferType);
+  auto singleTy = getSingletonCharType(builder.getContext(), charTy.getFKind());
+  auto singleRefTy = builder.getRefType(singleTy);
+  auto extent = fir::SequenceType::getUnknownExtent();
+  if (charTy.getLen() != fir::CharacterType::unknownLen())
+    extent = charTy.getLen();
+  auto coorTy = builder.getRefType(fir::SequenceType::get({extent}, singleTy));
+
+  auto coor = builder.createConvert(loc, coorTy, buffer);
+  auto i = builder.createConvert(loc, builder.getIndexType(), index);
+  return builder.create<fir::CoordinateOp>(loc, singleRefTy, coor, i);
+}
+
+/// Load a character out of `buff` from offset `index`.
+/// `buff` must be a reference to memory.
+mlir::Value
+fir::factory::CharacterExprHelper::createLoadCharAt(mlir::Value buff,
+                                                    mlir::Value index) {
+  LLVM_DEBUG(llvm::dbgs() << "load a char: " << buff << " type: "
+                          << buff.getType() << " at: " << index << '\n');
+  return builder.create<fir::LoadOp>(loc, createElementAddr(buff, index));
+}
+
+/// Store the singleton character `c` to `str` at offset `index`.
+/// `str` must be a reference to memory.
+void fir::factory::CharacterExprHelper::createStoreCharAt(mlir::Value str,
+                                                          mlir::Value index,
+                                                          mlir::Value c) {
+  LLVM_DEBUG(llvm::dbgs() << "store the char: " << c << " into: " << str
+                          << " type: " << str.getType() << " at: " << index
+                          << '\n');
+  auto addr = createElementAddr(str, index);
+  builder.create<fir::StoreOp>(loc, c, addr);
+}
+
+// FIXME: this temp is useless... either fir.coordinate_of needs to
+// work on "loaded" characters (!fir.array<len x fir.char<kind>>) or
+// character should never be loaded.
+// If this is a fir.array<>, allocate and store the value so that
+// fir.cooridnate_of can be use on the value.
+mlir::Value fir::factory::CharacterExprHelper::getCharBoxBuffer(
+    const fir::CharBoxValue &box) {
+  auto buff = box.getBuffer();
+  if (fir::isa_char(buff.getType())) {
+    auto newBuff = builder.create<fir::AllocaOp>(loc, buff.getType());
+    builder.create<fir::StoreOp>(loc, buff, newBuff);
+    return newBuff;
+  }
+  return buff;
+}
+
+/// Get the LLVM intrinsic for `memcpy`. Use the 64 bit version.
+mlir::FuncOp fir::factory::getLlvmMemcpy(fir::FirOpBuilder &builder) {
+  auto ptrTy = builder.getRefType(builder.getIntegerType(8));
+  llvm::SmallVector<mlir::Type> args = {ptrTy, ptrTy, builder.getI64Type(),
+                                        builder.getI1Type()};
+  auto memcpyTy =
+      mlir::FunctionType::get(builder.getContext(), args, llvm::None);
+  return builder.addNamedFunction(builder.getUnknownLoc(),
+                                  "llvm.memcpy.p0i8.p0i8.i64", memcpyTy);
+}
+
+/// Get the LLVM intrinsic for `memmove`. Use the 64 bit version.
+mlir::FuncOp fir::factory::getLlvmMemmove(fir::FirOpBuilder &builder) {
+  auto ptrTy = builder.getRefType(builder.getIntegerType(8));
+  llvm::SmallVector<mlir::Type> args = {ptrTy, ptrTy, builder.getI64Type(),
+                                        builder.getI1Type()};
+  auto memmoveTy =
+      mlir::FunctionType::get(builder.getContext(), args, llvm::None);
+  return builder.addNamedFunction(builder.getUnknownLoc(),
+                                  "llvm.memmove.p0i8.p0i8.i64", memmoveTy);
+}
+
+/// Get the LLVM intrinsic for `memset`. Use the 64 bit version.
+mlir::FuncOp fir::factory::getLlvmMemset(fir::FirOpBuilder &builder) {
+  auto ptrTy = builder.getRefType(builder.getIntegerType(8));
+  llvm::SmallVector<mlir::Type> args = {ptrTy, ptrTy, builder.getI64Type(),
+                                        builder.getI1Type()};
+  auto memsetTy =
+      mlir::FunctionType::get(builder.getContext(), args, llvm::None);
+  return builder.addNamedFunction(builder.getUnknownLoc(),
+                                  "llvm.memset.p0i8.p0i8.i64", memsetTy);
+}
+
+/// Get the standard `realloc` function.
+mlir::FuncOp fir::factory::getRealloc(fir::FirOpBuilder &builder) {
+  auto ptrTy = builder.getRefType(builder.getIntegerType(8));
+  llvm::SmallVector<mlir::Type> args = {ptrTy, builder.getI64Type()};
+  auto reallocTy = mlir::FunctionType::get(builder.getContext(), args, {ptrTy});
+  return builder.addNamedFunction(builder.getUnknownLoc(), "realloc",
+                                  reallocTy);
+}
+
+/// Create a loop to copy `count` characters from `src` to `dest`. Note that the
+/// KIND indicates the number of bits in a code point. (ASCII, UCS-2, or UCS-4.)
+void fir::factory::CharacterExprHelper::createCopy(
+    const fir::CharBoxValue &dest, const fir::CharBoxValue &src,
+    mlir::Value count) {
+  auto fromBuff = getCharBoxBuffer(src);
+  auto toBuff = getCharBoxBuffer(dest);
+  LLVM_DEBUG(llvm::dbgs() << "create char copy from: "; src.dump();
+             llvm::dbgs() << " to: "; dest.dump();
+             llvm::dbgs() << " count: " << count << '\n');
+  auto kind = getCharacterKind(src.getBuffer().getType());
+  // If the src and dest are the same KIND, then use memmove to move the bits.
+  // We don't have to worry about overlapping ranges with memmove.
+  if (getCharacterKind(dest.getBuffer().getType()) == kind) {
+    auto bytes = builder.getKindMap().getCharacterBitsize(kind) / 8;
+    auto i64Ty = builder.getI64Type();
+    auto kindBytes = builder.createIntegerConstant(loc, i64Ty, bytes);
+    auto castCount = builder.createConvert(loc, i64Ty, count);
+    auto totalBytes = builder.create<mlir::MulIOp>(loc, kindBytes, castCount);
+    auto notVolatile = builder.createBool(loc, false);
+    auto memmv = getLlvmMemmove(builder);
+    auto argTys = memmv.getType().getInputs();
+    auto toPtr = builder.createConvert(loc, argTys[0], toBuff);
+    auto fromPtr = builder.createConvert(loc, argTys[1], fromBuff);
+    builder.create<fir::CallOp>(
+        loc, memmv, mlir::ValueRange{toPtr, fromPtr, totalBytes, notVolatile});
+    return;
+  }
+
+  // Convert a CHARACTER of one KIND into a CHARACTER of another KIND.
+  builder.create<fir::CharConvertOp>(loc, src.getBuffer(), count,
+                                     dest.getBuffer());
+}
+
+void fir::factory::CharacterExprHelper::createPadding(
+    const fir::CharBoxValue &str, mlir::Value lower, mlir::Value upper) {
+  auto blank = createBlankConstant(getCharacterType(str));
+  // Always create the loop, if upper < lower, no iteration will be
+  // executed.
+  auto toBuff = getCharBoxBuffer(str);
+  fir::factory::DoLoopHelper{builder, loc}.createLoop(
+      lower, upper, [&](fir::FirOpBuilder &, mlir::Value index) {
+        createStoreCharAt(toBuff, index, blank);
+      });
+}
+
+fir::CharBoxValue
+fir::factory::CharacterExprHelper::createCharacterTemp(mlir::Type type,
+                                                       mlir::Value len) {
+  auto kind = recoverCharacterType(type).getFKind();
+  auto typeLen = fir::CharacterType::unknownLen();
+  // If len is a constant, reflect the length in the type.
+  if (auto cstLen = getIntIfConstant(len))
+    typeLen = *cstLen;
+  auto *ctxt = builder.getContext();
+  auto charTy = fir::CharacterType::get(ctxt, kind, typeLen);
+  llvm::SmallVector<mlir::Value> lenParams;
+  if (typeLen == fir::CharacterType::unknownLen())
+    lenParams.push_back(len);
+  auto ref = builder.allocateLocal(loc, charTy, "", ".chrtmp",
+                                   /*shape=*/llvm::None, lenParams);
+  return {ref, len};
+}
+
+fir::CharBoxValue fir::factory::CharacterExprHelper::createTempFrom(
+    const fir::ExtendedValue &source) {
+  const auto *charBox = source.getCharBox();
+  if (!charBox)
+    fir::emitFatalError(loc, "source must be a fir::CharBoxValue");
+  auto len = charBox->getLen();
+  auto sourceTy = charBox->getBuffer().getType();
+  auto temp = createCharacterTemp(sourceTy, len);
+  if (fir::isa_ref_type(sourceTy)) {
+    createCopy(temp, *charBox, len);
+  } else {
+    auto ref = builder.createConvert(loc, builder.getRefType(sourceTy),
+                                     temp.getBuffer());
+    builder.create<fir::StoreOp>(loc, charBox->getBuffer(), ref);
+  }
+  return temp;
+}
+
+// Simple length one character assignment without loops.
+void fir::factory::CharacterExprHelper::createLengthOneAssign(
+    const fir::CharBoxValue &lhs, const fir::CharBoxValue &rhs) {
+  auto addr = lhs.getBuffer();
+  mlir::Value val = builder.create<fir::LoadOp>(loc, rhs.getBuffer());
+  auto addrTy = builder.getRefType(val.getType());
+  addr = builder.createConvert(loc, addrTy, addr);
+  builder.create<fir::StoreOp>(loc, val, addr);
+}
+
+/// Returns the minimum of integer mlir::Value \p a and \b.
+mlir::Value genMin(fir::FirOpBuilder &builder, mlir::Location loc,
+                   mlir::Value a, mlir::Value b) {
+  auto cmp = builder.create<mlir::CmpIOp>(loc, mlir::CmpIPredicate::slt, a, b);
+  return builder.create<mlir::SelectOp>(loc, cmp, a, b);
+}
+
+void fir::factory::CharacterExprHelper::createAssign(
+    const fir::CharBoxValue &lhs, const fir::CharBoxValue &rhs) {
+  auto rhsCstLen = getCompileTimeLength(rhs);
+  auto lhsCstLen = getCompileTimeLength(lhs);
+  bool compileTimeSameLength =
+      lhsCstLen && rhsCstLen && *lhsCstLen == *rhsCstLen;
+
+  if (compileTimeSameLength && *lhsCstLen == 1) {
+    createLengthOneAssign(lhs, rhs);
+    return;
+  }
+
+  // Copy the minimum of the lhs and rhs lengths and pad the lhs remainder
+  // if needed.
+  auto copyCount = lhs.getLen();
+  auto idxTy = builder.getIndexType();
+  if (!compileTimeSameLength) {
+    auto lhsLen = builder.createConvert(loc, idxTy, lhs.getLen());
+    auto rhsLen = builder.createConvert(loc, idxTy, rhs.getLen());
+    copyCount = genMin(builder, loc, lhsLen, rhsLen);
+  }
+
+  // Actual copy
+  createCopy(lhs, rhs, copyCount);
+
+  // Pad if needed.
+  if (!compileTimeSameLength) {
+    auto one = builder.createIntegerConstant(loc, lhs.getLen().getType(), 1);
+    auto maxPadding = builder.create<mlir::SubIOp>(loc, lhs.getLen(), one);
+    createPadding(lhs, copyCount, maxPadding);
+  }
+}
+
+fir::CharBoxValue fir::factory::CharacterExprHelper::createConcatenate(
+    const fir::CharBoxValue &lhs, const fir::CharBoxValue &rhs) {
+  auto lhsLen = builder.createConvert(loc, builder.getCharacterLengthType(),
+                                      lhs.getLen());
+  auto rhsLen = builder.createConvert(loc, builder.getCharacterLengthType(),
+                                      rhs.getLen());
+  mlir::Value len = builder.create<mlir::AddIOp>(loc, lhsLen, rhsLen);
+  auto temp = createCharacterTemp(getCharacterType(rhs), len);
+  createCopy(temp, lhs, lhsLen);
+  auto one = builder.createIntegerConstant(loc, len.getType(), 1);
+  auto upperBound = builder.create<mlir::SubIOp>(loc, len, one);
+  auto lhsLenIdx = builder.createConvert(loc, builder.getIndexType(), lhsLen);
+  auto fromBuff = getCharBoxBuffer(rhs);
+  auto toBuff = getCharBoxBuffer(temp);
+  fir::factory::DoLoopHelper{builder, loc}.createLoop(
+      lhsLenIdx, upperBound, one,
+      [&](fir::FirOpBuilder &bldr, mlir::Value index) {
+        auto rhsIndex = bldr.create<mlir::SubIOp>(loc, index, lhsLenIdx);
+        auto charVal = createLoadCharAt(fromBuff, rhsIndex);
+        createStoreCharAt(toBuff, index, charVal);
+      });
+  return temp;
+}
+
+fir::CharBoxValue fir::factory::CharacterExprHelper::createSubstring(
+    const fir::CharBoxValue &box, llvm::ArrayRef<mlir::Value> bounds) {
+  // Constant need to be materialize in memory to use fir.coordinate_of.
+  auto nbounds = bounds.size();
+  if (nbounds < 1 || nbounds > 2) {
+    mlir::emitError(loc, "Incorrect number of bounds in substring");
+    return {mlir::Value{}, mlir::Value{}};
+  }
+  mlir::SmallVector<mlir::Value> castBounds;
+  // Convert bounds to length type to do safe arithmetic on it.
+  for (auto bound : bounds)
+    castBounds.push_back(
+        builder.createConvert(loc, builder.getCharacterLengthType(), bound));
+  auto lowerBound = castBounds[0];
+  // FIR CoordinateOp is zero based but Fortran substring are one based.
+  auto one = builder.createIntegerConstant(loc, lowerBound.getType(), 1);
+  auto offset = builder.create<mlir::SubIOp>(loc, lowerBound, one).getResult();
+  auto addr = createElementAddr(box.getBuffer(), offset);
+  auto kind = getCharacterKind(box.getBuffer().getType());
+  auto charTy = fir::CharacterType::getUnknownLen(builder.getContext(), kind);
+  auto resultType = builder.getRefType(charTy);
+  auto substringRef = builder.createConvert(loc, resultType, addr);
+
+  // Compute the length.
+  mlir::Value substringLen;
+  if (nbounds < 2) {
+    substringLen =
+        builder.create<mlir::SubIOp>(loc, box.getLen(), castBounds[0]);
+  } else {
+    substringLen =
+        builder.create<mlir::SubIOp>(loc, castBounds[1], castBounds[0]);
+  }
+  substringLen = builder.create<mlir::AddIOp>(loc, substringLen, one);
+
+  // Set length to zero if bounds were reversed (Fortran 2018 9.4.1)
+  auto zero = builder.createIntegerConstant(loc, substringLen.getType(), 0);
+  auto cdt = builder.create<mlir::CmpIOp>(loc, mlir::CmpIPredicate::slt,
+                                          substringLen, zero);
+  substringLen = builder.create<mlir::SelectOp>(loc, cdt, zero, substringLen);
+
+  return {substringRef, substringLen};
+}
+
+mlir::Value
+fir::factory::CharacterExprHelper::createLenTrim(const fir::CharBoxValue &str) {
+  // Note: Runtime for LEN_TRIM should also be available at some
+  // point. For now use an inlined implementation.
+  auto indexType = builder.getIndexType();
+  auto len = builder.createConvert(loc, indexType, str.getLen());
+  auto one = builder.createIntegerConstant(loc, indexType, 1);
+  auto minusOne = builder.createIntegerConstant(loc, indexType, -1);
+  auto zero = builder.createIntegerConstant(loc, indexType, 0);
+  auto trueVal = builder.createIntegerConstant(loc, builder.getI1Type(), 1);
+  auto blank = createBlankConstantCode(getCharacterType(str));
+  mlir::Value lastChar = builder.create<mlir::SubIOp>(loc, len, one);
+
+  auto iterWhile =
+      builder.create<fir::IterWhileOp>(loc, lastChar, zero, minusOne, trueVal,
+                                       /*returnFinalCount=*/false, lastChar);
+  auto insPt = builder.saveInsertionPoint();
+  builder.setInsertionPointToStart(iterWhile.getBody());
+  auto index = iterWhile.getInductionVar();
+  // Look for first non-blank from the right of the character.
+  auto fromBuff = getCharBoxBuffer(str);
+  auto elemAddr = createElementAddr(fromBuff, index);
+  auto codeAddr =
+      builder.createConvert(loc, builder.getRefType(blank.getType()), elemAddr);
+  auto c = builder.create<fir::LoadOp>(loc, codeAddr);
+  auto isBlank =
+      builder.create<mlir::CmpIOp>(loc, mlir::CmpIPredicate::eq, blank, c);
+  llvm::SmallVector<mlir::Value> results = {isBlank, index};
+  builder.create<fir::ResultOp>(loc, results);
+  builder.restoreInsertionPoint(insPt);
+  // Compute length after iteration (zero if all blanks)
+  mlir::Value newLen =
+      builder.create<mlir::AddIOp>(loc, iterWhile.getResult(1), one);
+  auto result =
+      builder.create<mlir::SelectOp>(loc, iterWhile.getResult(0), zero, newLen);
+  return builder.createConvert(loc, builder.getCharacterLengthType(), result);
+}
+
+fir::CharBoxValue
+fir::factory::CharacterExprHelper::createCharacterTemp(mlir::Type type,
+                                                       int len) {
+  assert(len >= 0 && "expected positive length");
+  auto kind = recoverCharacterType(type).getFKind();
+  auto charType = fir::CharacterType::get(builder.getContext(), kind, len);
+  auto addr = builder.create<fir::AllocaOp>(loc, charType);
+  auto mlirLen =
+      builder.createIntegerConstant(loc, builder.getCharacterLengthType(), len);
+  return {addr, mlirLen};
+}
+
+// Returns integer with code for blank. The integer has the same
+// size as the character. Blank has ascii space code for all kinds.
+mlir::Value fir::factory::CharacterExprHelper::createBlankConstantCode(
+    fir::CharacterType type) {
+  auto bits = builder.getKindMap().getCharacterBitsize(type.getFKind());
+  auto intType = builder.getIntegerType(bits);
+  return builder.createIntegerConstant(loc, intType, ' ');
+}
+
+mlir::Value fir::factory::CharacterExprHelper::createBlankConstant(
+    fir::CharacterType type) {
+  return createSingletonFromCode(createBlankConstantCode(type),
+                                 type.getFKind());
+}
+
+void fir::factory::CharacterExprHelper::createAssign(
+    const fir::ExtendedValue &lhs, const fir::ExtendedValue &rhs) {
+  if (auto *str = rhs.getBoxOf<fir::CharBoxValue>()) {
+    if (auto *to = lhs.getBoxOf<fir::CharBoxValue>()) {
+      createAssign(*to, *str);
+      return;
+    }
+  }
+  TODO(loc, "character array assignment");
+  // Note that it is not sure the array aspect should be handled
+  // by this utility.
+}
+
+mlir::Value
+fir::factory::CharacterExprHelper::createEmboxChar(mlir::Value addr,
+                                                   mlir::Value len) {
+  return createEmbox(fir::CharBoxValue{addr, len});
+}
+
+std::pair<mlir::Value, mlir::Value>
+fir::factory::CharacterExprHelper::createUnboxChar(mlir::Value boxChar) {
+  using T = std::pair<mlir::Value, mlir::Value>;
+  return toExtendedValue(boxChar).match(
+      [](const fir::CharBoxValue &b) -> T {
+        return {b.getBuffer(), b.getLen()};
+      },
+      [](const fir::CharArrayBoxValue &b) -> T {
+        return {b.getBuffer(), b.getLen()};
+      },
+      [](const auto &) -> T { llvm::report_fatal_error("not a character"); });
+}
+
+bool fir::factory::CharacterExprHelper::isCharacterLiteral(mlir::Type type) {
+  if (auto seqType = type.dyn_cast<fir::SequenceType>())
+    return (seqType.getShape().size() == 1) &&
+           fir::isa_char(seqType.getEleTy());
+  return false;
+}
+
+bool fir::factory::CharacterExprHelper::isCharacterScalar(mlir::Type type) {
+  if (type.isa<fir::BoxCharType>())
+    return true;
+  type = fir::unwrapRefType(type);
+  if (auto boxTy = type.dyn_cast<fir::BoxType>())
+    type = boxTy.getEleTy();
+  type = fir::unwrapRefType(type);
+  return !type.isa<fir::SequenceType>() && fir::isa_char(type);
+}
+
+fir::KindTy
+fir::factory::CharacterExprHelper::getCharacterKind(mlir::Type type) {
+  assert(isCharacterScalar(type) && "expected scalar character");
+  return recoverCharacterType(type).getFKind();
+}
+
+fir::KindTy
+fir::factory::CharacterExprHelper::getCharacterOrSequenceKind(mlir::Type type) {
+  return recoverCharacterType(type).getFKind();
+}
+
+bool fir::factory::CharacterExprHelper::isArray(mlir::Type type) {
+  return !isCharacterScalar(type);
+}
+
+bool fir::factory::CharacterExprHelper::hasConstantLengthInType(
+    const fir::ExtendedValue &exv) {
+  auto charTy = recoverCharacterType(fir::getBase(exv).getType());
+  return charTy.hasConstantLen();
+}
+
+mlir::Value
+fir::factory::CharacterExprHelper::createSingletonFromCode(mlir::Value code,
+                                                           int kind) {
+  auto charType = fir::CharacterType::get(builder.getContext(), kind, 1);
+  auto bits = builder.getKindMap().getCharacterBitsize(kind);
+  auto intType = builder.getIntegerType(bits);
+  auto cast = builder.createConvert(loc, intType, code);
+  auto undef = builder.create<fir::UndefOp>(loc, charType);
+  auto zero = builder.createIntegerConstant(loc, builder.getIndexType(), 0);
+  return builder.create<fir::InsertValueOp>(loc, charType, undef, cast, zero);
+}
+
+mlir::Value fir::factory::CharacterExprHelper::extractCodeFromSingleton(
+    mlir::Value singleton) {
+  auto type = getCharacterType(singleton);
+  assert(type.getLen() == 1);
+  auto bits = builder.getKindMap().getCharacterBitsize(type.getFKind());
+  auto intType = builder.getIntegerType(bits);
+  auto zero = builder.createIntegerConstant(loc, builder.getIndexType(), 0);
+  return builder.create<fir::ExtractValueOp>(loc, intType, singleton, zero);
+}
+
+mlir::Value
+fir::factory::CharacterExprHelper::readLengthFromBox(mlir::Value box) {
+  auto lenTy = builder.getCharacterLengthType();
+  auto size = builder.create<fir::BoxEleSizeOp>(loc, lenTy, box);
+  auto charTy = recoverCharacterType(box.getType());
+  auto bits = builder.getKindMap().getCharacterBitsize(charTy.getFKind());
+  auto width = bits / 8;
+  if (width > 1) {
+    auto widthVal = builder.createIntegerConstant(loc, lenTy, width);
+    return builder.create<mlir::SignedDivIOp>(loc, size, widthVal);
+  }
+  return size;
+}
+
+mlir::Value fir::factory::CharacterExprHelper::getLength(mlir::Value memref) {
+  auto memrefType = memref.getType();
+  auto charType = recoverCharacterType(memrefType);
+  assert(charType && "must be a character type");
+  if (charType.hasConstantLen())
+    return builder.createIntegerConstant(loc, builder.getCharacterLengthType(),
+                                         charType.getLen());
+  if (memrefType.isa<fir::BoxType>())
+    return readLengthFromBox(memref);
+  if (memrefType.isa<fir::BoxCharType>())
+    return createUnboxChar(memref).second;
+
+  // Length cannot be deduced from memref.
+  return {};
+}

flang/lib/Optimizer/Builder/DoLoopHelper.cpp

+//===-- DoLoopHelper.cpp --------------------------------------------------===//
+//
+// 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/Optimizer/Builder/DoLoopHelper.h"
+
+//===----------------------------------------------------------------------===//
+// DoLoopHelper implementation
+//===----------------------------------------------------------------------===//
+
+void fir::factory::DoLoopHelper::createLoop(
+    mlir::Value lb, mlir::Value ub, mlir::Value step,
+    const BodyGenerator &bodyGenerator) {
+  auto lbi = builder.convertToIndexType(loc, lb);
+  auto ubi = builder.convertToIndexType(loc, ub);
+  assert(step && "step must be an actual Value");
+  auto inc = builder.convertToIndexType(loc, step);
+  auto loop = builder.create<fir::DoLoopOp>(loc, lbi, ubi, inc);
+  auto insertPt = builder.saveInsertionPoint();
+  builder.setInsertionPointToStart(loop.getBody());
+  auto index = loop.getInductionVar();
+  bodyGenerator(builder, index);
+  builder.restoreInsertionPoint(insertPt);
+}
+
+void fir::factory::DoLoopHelper::createLoop(
+    mlir::Value lb, mlir::Value ub, const BodyGenerator &bodyGenerator) {
+  createLoop(lb, ub,
+             builder.createIntegerConstant(loc, builder.getIndexType(), 1),
+             bodyGenerator);
+}
+
+void fir::factory::DoLoopHelper::createLoop(
+    mlir::Value count, const BodyGenerator &bodyGenerator) {
+  auto indexType = builder.getIndexType();
+  auto zero = builder.createIntegerConstant(loc, indexType, 0);
+  auto one = builder.createIntegerConstant(loc, count.getType(), 1);
+  auto up = builder.create<mlir::SubIOp>(loc, count, one);
+  createLoop(zero, up, one, bodyGenerator);
+}

flang/lib/Optimizer/Builder/FIRBuilder.cpp

+//===-- FIRBuilder.cpp ----------------------------------------------------===//
+//
+// 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/Optimizer/Builder/FIRBuilder.h"
+#include "flang/Lower/Todo.h"
+#include "flang/Optimizer/Builder/BoxValue.h"
+#include "flang/Optimizer/Builder/MutableBox.h"
+#include "flang/Optimizer/Builder/Runtime/Assign.h"
+#include "flang/Optimizer/Dialect/FIRAttr.h"
+#include "flang/Optimizer/Dialect/FIROpsSupport.h"
+#include "flang/Optimizer/Support/FatalError.h"
+#include "flang/Optimizer/Support/InternalNames.h"
+#include "mlir/Dialect/OpenMP/OpenMPDialect.h"
+#include "llvm/ADT/ArrayRef.h"
+#include "llvm/ADT/StringExtras.h"
+#include "llvm/Support/CommandLine.h"
+#include "llvm/Support/ErrorHandling.h"
+#include "llvm/Support/MD5.h"
+
+static llvm::cl::opt<std::size_t>
+    nameLengthHashSize("length-to-hash-string-literal",
+                       llvm::cl::desc("string literals that exceed this length"
+                                      " will use a hash value as their symbol "
+                                      "name"),
+                       llvm::cl::init(32));
+
+mlir::FuncOp fir::FirOpBuilder::createFunction(mlir::Location loc,
+                                               mlir::ModuleOp module,
+                                               llvm::StringRef name,
+                                               mlir::FunctionType ty) {
+  return fir::createFuncOp(loc, module, name, ty);
+}
+
+mlir::FuncOp fir::FirOpBuilder::getNamedFunction(mlir::ModuleOp modOp,
+                                                 llvm::StringRef name) {
+  return modOp.lookupSymbol<mlir::FuncOp>(name);
+}
+
+fir::GlobalOp fir::FirOpBuilder::getNamedGlobal(mlir::ModuleOp modOp,
+                                                llvm::StringRef name) {
+  return modOp.lookupSymbol<fir::GlobalOp>(name);
+}
+
+mlir::Type fir::FirOpBuilder::getRefType(mlir::Type eleTy) {
+  assert(!eleTy.isa<fir::ReferenceType>() && "cannot be a reference type");
+  return fir::ReferenceType::get(eleTy);
+}
+
+mlir::Type fir::FirOpBuilder::getVarLenSeqTy(mlir::Type eleTy, unsigned rank) {
+  fir::SequenceType::Shape shape(rank, fir::SequenceType::getUnknownExtent());
+  return fir::SequenceType::get(shape, eleTy);
+}
+
+mlir::Type fir::FirOpBuilder::getRealType(int kind) {
+  switch (kindMap.getRealTypeID(kind)) {
+  case llvm::Type::TypeID::HalfTyID:
+    return mlir::FloatType::getF16(getContext());
+  case llvm::Type::TypeID::FloatTyID:
+    return mlir::FloatType::getF32(getContext());
+  case llvm::Type::TypeID::DoubleTyID:
+    return mlir::FloatType::getF64(getContext());
+  case llvm::Type::TypeID::X86_FP80TyID:
+    return mlir::FloatType::getF80(getContext());
+  case llvm::Type::TypeID::FP128TyID:
+    return mlir::FloatType::getF128(getContext());
+  default:
+    fir::emitFatalError(UnknownLoc::get(getContext()),
+                        "unsupported type !fir.real<kind>");
+  }
+}
+
+mlir::Value fir::FirOpBuilder::createNullConstant(mlir::Location loc,
+                                                  mlir::Type ptrType) {
+  auto ty = ptrType ? ptrType : getRefType(getNoneType());
+  return create<fir::ZeroOp>(loc, ty);
+}
+
+mlir::Value fir::FirOpBuilder::createIntegerConstant(mlir::Location loc,
+                                                     mlir::Type ty,
+                                                     std::int64_t cst) {
+  return create<mlir::ConstantOp>(loc, ty, getIntegerAttr(ty, cst));
+}
+
+mlir::Value
+fir::FirOpBuilder::createRealConstant(mlir::Location loc, mlir::Type fltTy,
+                                      llvm::APFloat::integerPart val) {
+  auto apf = [&]() -> llvm::APFloat {
+    if (auto ty = fltTy.dyn_cast<fir::RealType>())
+      return llvm::APFloat(kindMap.getFloatSemantics(ty.getFKind()), val);
+    if (fltTy.isF16())
+      return llvm::APFloat(llvm::APFloat::IEEEhalf(), val);
+    if (fltTy.isBF16())
+      return llvm::APFloat(llvm::APFloat::BFloat(), val);
+    if (fltTy.isF32())
+      return llvm::APFloat(llvm::APFloat::IEEEsingle(), val);
+    if (fltTy.isF64())
+      return llvm::APFloat(llvm::APFloat::IEEEdouble(), val);
+    if (fltTy.isF80())
+      return llvm::APFloat(llvm::APFloat::x87DoubleExtended(), val);
+    if (fltTy.isF128())
+      return llvm::APFloat(llvm::APFloat::IEEEquad(), val);
+    llvm_unreachable("unhandled MLIR floating-point type");
+  };
+  return createRealConstant(loc, fltTy, apf());
+}
+
+mlir::Value fir::FirOpBuilder::createRealConstant(mlir::Location loc,
+                                                  mlir::Type fltTy,
+                                                  const llvm::APFloat &value) {
+  if (fltTy.isa<mlir::FloatType>()) {
+    auto attr = getFloatAttr(fltTy, value);
+    return create<mlir::ConstantOp>(loc, fltTy, attr);
+  }
+  llvm_unreachable("should use builtin floating-point type");
+}
+
+static llvm::SmallVector<mlir::Value>
+elideExtentsAlreadyInType(mlir::Type type, mlir::ValueRange shape) {
+  auto arrTy = type.dyn_cast<fir::SequenceType>();
+  if (shape.empty() || !arrTy)
+    return {};
+  // elide the constant dimensions before construction
+  assert(shape.size() == arrTy.getDimension());
+  llvm::SmallVector<mlir::Value> dynamicShape;
+  auto typeShape = arrTy.getShape();
+  for (unsigned i = 0, end = arrTy.getDimension(); i < end; ++i)
+    if (typeShape[i] == fir::SequenceType::getUnknownExtent())
+      dynamicShape.push_back(shape[i]);
+  return dynamicShape;
+}
+
+static llvm::SmallVector<mlir::Value>
+elideLengthsAlreadyInType(mlir::Type type, mlir::ValueRange lenParams) {
+  if (lenParams.empty())
+    return {};
+  if (auto arrTy = type.dyn_cast<fir::SequenceType>())
+    type = arrTy.getEleTy();
+  if (fir::hasDynamicSize(type))
+    return lenParams;
+  return {};
+}
+
+/// Allocate a local variable.
+/// A local variable ought to have a name in the source code.
+mlir::Value fir::FirOpBuilder::allocateLocal(
+    mlir::Location loc, mlir::Type ty, llvm::StringRef uniqName,
+    llvm::StringRef name, bool pinned, llvm::ArrayRef<mlir::Value> shape,
+    llvm::ArrayRef<mlir::Value> lenParams, bool asTarget) {
+  // Convert the shape extents to `index`, as needed.
+  llvm::SmallVector<mlir::Value> indices;
+  llvm::SmallVector<mlir::Value> elidedShape =
+      elideExtentsAlreadyInType(ty, shape);
+  llvm::SmallVector<mlir::Value> elidedLenParams =
+      elideLengthsAlreadyInType(ty, lenParams);
+  auto idxTy = getIndexType();
+  llvm::for_each(elidedShape, [&](mlir::Value sh) {
+    indices.push_back(createConvert(loc, idxTy, sh));
+  });
+  // Add a target attribute, if needed.
+  llvm::SmallVector<mlir::NamedAttribute> attrs;
+  if (asTarget)
+    attrs.emplace_back(
+        mlir::Identifier::get(fir::getTargetAttrName(), getContext()),
+        getUnitAttr());
+  // Create the local variable.
+  if (name.empty()) {
+    if (uniqName.empty())
+      return create<fir::AllocaOp>(loc, ty, pinned, elidedLenParams, indices,
+                                   attrs);
+    return create<fir::AllocaOp>(loc, ty, uniqName, pinned, elidedLenParams,
+                                 indices, attrs);
+  }
+  return create<fir::AllocaOp>(loc, ty, uniqName, name, pinned, elidedLenParams,
+                               indices, attrs);
+}
+
+mlir::Value fir::FirOpBuilder::allocateLocal(
+    mlir::Location loc, mlir::Type ty, llvm::StringRef uniqName,
+    llvm::StringRef name, llvm::ArrayRef<mlir::Value> shape,
+    llvm::ArrayRef<mlir::Value> lenParams, bool asTarget) {
+  return allocateLocal(loc, ty, uniqName, name, /*pinned=*/false, shape,
+                       lenParams, asTarget);
+}
+
+/// Get the block for adding Allocas.
+mlir::Block *fir::FirOpBuilder::getAllocaBlock() {
+  // auto iface =
+  //     getRegion().getParentOfType<mlir::omp::OutlineableOpenMPOpInterface>();
+  // return iface ? iface.getAllocaBlock() : getEntryBlock();
+  return getEntryBlock();
+}
+
+/// Create a temporary variable on the stack. Anonymous temporaries have no
+/// `name` value. Temporaries do not require a uniqued name.
+mlir::Value
+fir::FirOpBuilder::createTemporary(mlir::Location loc, mlir::Type type,
+                                   llvm::StringRef name, mlir::ValueRange shape,
+                                   mlir::ValueRange lenParams,
+                                   llvm::ArrayRef<mlir::NamedAttribute> attrs) {
+  llvm::SmallVector<mlir::Value> dynamicShape =
+      elideExtentsAlreadyInType(type, shape);
+  llvm::SmallVector<mlir::Value> dynamicLength =
+      elideLengthsAlreadyInType(type, lenParams);
+  InsertPoint insPt;
+  const bool hoistAlloc = dynamicShape.empty() && dynamicLength.empty();
+  if (hoistAlloc) {
+    insPt = saveInsertionPoint();
+    setInsertionPointToStart(getAllocaBlock());
+  }
+
+  // If the alloca is inside an OpenMP Op which will be outlined then pin the
+  // alloca here.
+  const bool pinned =
+      getRegion().getParentOfType<mlir::omp::OutlineableOpenMPOpInterface>();
+  assert(!type.isa<fir::ReferenceType>() && "cannot be a reference");
+  auto ae =
+      create<fir::AllocaOp>(loc, type, /*unique_name=*/llvm::StringRef{}, name,
+                            pinned, dynamicLength, dynamicShape, attrs);
+  if (hoistAlloc)
+    restoreInsertionPoint(insPt);
+  return ae;
+}
+
+/// Create a global variable in the (read-only) data section. A global variable
+/// must have a unique name to identify and reference it.
+fir::GlobalOp
+fir::FirOpBuilder::createGlobal(mlir::Location loc, mlir::Type type,
+                                llvm::StringRef name, mlir::StringAttr linkage,
+                                mlir::Attribute value, bool isConst) {
+  auto module = getModule();
+  auto insertPt = saveInsertionPoint();
+  if (auto glob = module.lookupSymbol<fir::GlobalOp>(name))
+    return glob;
+  setInsertionPoint(module.getBody(), module.getBody()->end());
+  auto glob = create<fir::GlobalOp>(loc, name, isConst, type, value, linkage);
+  restoreInsertionPoint(insertPt);
+  return glob;
+}
+
+fir::GlobalOp fir::FirOpBuilder::createGlobal(
+    mlir::Location loc, mlir::Type type, llvm::StringRef name, bool isConst,
+    std::function<void(FirOpBuilder &)> bodyBuilder, mlir::StringAttr linkage) {
+  auto module = getModule();
+  auto insertPt = saveInsertionPoint();
+  if (auto glob = module.lookupSymbol<fir::GlobalOp>(name))
+    return glob;
+  setInsertionPoint(module.getBody(), module.getBody()->end());
+  auto glob = create<fir::GlobalOp>(loc, name, isConst, type, mlir::Attribute{},
+                                    linkage);
+  auto &region = glob.getRegion();
+  region.push_back(new mlir::Block);
+  auto &block = glob.getRegion().back();
+  setInsertionPointToStart(&block);
+  bodyBuilder(*this);
+  restoreInsertionPoint(insertPt);
+  return glob;
+}
+
+mlir::Value fir::FirOpBuilder::convertWithSemantics(mlir::Location loc,
+                                                    mlir::Type toTy,
+                                                    mlir::Value val) {
+  assert(toTy && "store location must be typed");
+  auto fromTy = val.getType();
+  if (fromTy == toTy)
+    return val;
+  // fir::factory::ComplexExprHelper helper{*this, loc};
+  // if ((fir::isa_real(fromTy) || fir::isa_integer(fromTy)) &&
+  //     fir::isa_complex(toTy)) {
+  //   // imaginary part is zero
+  //   auto eleTy = helper.getComplexPartType(toTy);
+  //   auto cast = createConvert(loc, eleTy, val);
+  //   llvm::APFloat zero{
+  //       kindMap.getFloatSemantics(toTy.cast<fir::ComplexType>().getFKind()),
+  //       0};
+  //   auto imag = createRealConstant(loc, eleTy, zero);
+  //   return helper.createComplex(toTy, cast, imag);
+  // }
+  // if (fir::isa_complex(fromTy) &&
+  //     (fir::isa_integer(toTy) || fir::isa_real(toTy))) {
+  //   // drop the imaginary part
+  //   auto rp = helper.extractComplexPart(val, /*isImagPart=*/false);
+  //   return createConvert(loc, toTy, rp);
+  // }
+  return createConvert(loc, toTy, val);
+}
+
+mlir::Value fir::FirOpBuilder::createConvert(mlir::Location loc,
+                                             mlir::Type toTy, mlir::Value val) {
+  if (val.getType() != toTy) {
+    assert(!fir::isa_derived(toTy));
+    return create<fir::ConvertOp>(loc, toTy, val);
+  }
+  return val;
+}
+
+fir::StringLitOp fir::FirOpBuilder::createStringLitOp(mlir::Location loc,
+                                                      llvm::StringRef data) {
+  auto type = fir::CharacterType::get(getContext(), 1, data.size());
+  auto strAttr = mlir::StringAttr::get(getContext(), data);
+  auto valTag = mlir::Identifier::get(fir::StringLitOp::value(), getContext());
+  mlir::NamedAttribute dataAttr(valTag, strAttr);
+  auto sizeTag = mlir::Identifier::get(fir::StringLitOp::size(), getContext());
+  mlir::NamedAttribute sizeAttr(sizeTag, getI64IntegerAttr(data.size()));
+  llvm::SmallVector<mlir::NamedAttribute> attrs{dataAttr, sizeAttr};
+  return create<fir::StringLitOp>(loc, llvm::ArrayRef<mlir::Type>{type},
+                                  llvm::None, attrs);
+}
+
+mlir::Value fir::FirOpBuilder::genShape(mlir::Location loc,
+                                        llvm::ArrayRef<mlir::Value> exts) {
+  auto shapeType = fir::ShapeType::get(getContext(), exts.size());
+  return create<fir::ShapeOp>(loc, shapeType, exts);
+}
+
+mlir::Value fir::FirOpBuilder::genShape(mlir::Location loc,
+                                        llvm::ArrayRef<mlir::Value> shift,
+                                        llvm::ArrayRef<mlir::Value> exts) {
+  auto shapeType = fir::ShapeShiftType::get(getContext(), exts.size());
+  llvm::SmallVector<mlir::Value> shapeArgs;
+  auto idxTy = getIndexType();
+  for (auto [lbnd, ext] : llvm::zip(shift, exts)) {
+    auto lb = createConvert(loc, idxTy, lbnd);
+    shapeArgs.push_back(lb);
+    shapeArgs.push_back(ext);
+  }
+  return create<fir::ShapeShiftOp>(loc, shapeType, shapeArgs);
+}
+
+mlir::Value fir::FirOpBuilder::genShape(mlir::Location loc,
+                                        const fir::AbstractArrayBox &arr) {
+  if (arr.lboundsAllOne())
+    return genShape(loc, arr.getExtents());
+  return genShape(loc, arr.getLBounds(), arr.getExtents());
+}
+
+mlir::Value fir::FirOpBuilder::createShape(mlir::Location loc,
+                                           const fir::ExtendedValue &exv) {
+  return exv.match(
+      [&](const fir::ArrayBoxValue &box) { return genShape(loc, box); },
+      [&](const fir::CharArrayBoxValue &box) { return genShape(loc, box); },
+      [&](const fir::BoxValue &box) -> mlir::Value {
+        if (!box.getLBounds().empty()) {
+          auto shiftType =
+              fir::ShiftType::get(getContext(), box.getLBounds().size());
+          return create<fir::ShiftOp>(loc, shiftType, box.getLBounds());
+        }
+        return {};
+      },
+      [&](const fir::MutableBoxValue &) -> mlir::Value {
+        // MutableBoxValue must be read into another category to work with them
+        // outside of allocation/assignment contexts.
+        fir::emitFatalError(loc, "createShape on MutableBoxValue");
+      },
+      [&](auto) -> mlir::Value { fir::emitFatalError(loc, "not an array"); });
+}
+
+mlir::Value fir::FirOpBuilder::createSlice(mlir::Location loc,
+                                           const fir::ExtendedValue &exv,
+                                           mlir::ValueRange triples,
+                                           mlir::ValueRange path) {
+  if (triples.empty()) {
+    // If there is no slicing by triple notation, then take the whole array.
+    auto fullShape = [&](const llvm::ArrayRef<mlir::Value> lbounds,
+                         llvm::ArrayRef<mlir::Value> extents) -> mlir::Value {
+      llvm::SmallVector<mlir::Value> trips;
+      auto idxTy = getIndexType();
+      auto one = createIntegerConstant(loc, idxTy, 1);
+      auto sliceTy = fir::SliceType::get(getContext(), extents.size());
+      if (lbounds.empty()) {
+        for (auto v : extents) {
+          trips.push_back(one);
+          trips.push_back(v);
+          trips.push_back(one);
+        }
+        return create<fir::SliceOp>(loc, sliceTy, trips, path);
+      }
+      for (auto [lbnd, ext] : llvm::zip(lbounds, extents)) {
+        auto lb = createConvert(loc, idxTy, lbnd);
+        trips.push_back(lb);
+        trips.push_back(ext);
+        trips.push_back(one);
+      }
+      return create<fir::SliceOp>(loc, sliceTy, trips, path);
+    };
+    return exv.match(
+        [&](const fir::ArrayBoxValue &box) {
+          return fullShape(box.getLBounds(), box.getExtents());
+        },
+        [&](const fir::CharArrayBoxValue &box) {
+          return fullShape(box.getLBounds(), box.getExtents());
+        },
+        [&](const fir::BoxValue &box) {
+          auto extents = fir::factory::readExtents(*this, loc, box);
+          return fullShape(box.getLBounds(), extents);
+        },
+        [&](const fir::MutableBoxValue &) -> mlir::Value {
+          // MutableBoxValue must be read into another category to work with
+          // them outside of allocation/assignment contexts.
+          fir::emitFatalError(loc, "createSlice on MutableBoxValue");
+        },
+        [&](auto) -> mlir::Value { fir::emitFatalError(loc, "not an array"); });
+  }
+  auto rank = exv.rank();
+  auto sliceTy = fir::SliceType::get(getContext(), rank);
+  return create<fir::SliceOp>(loc, sliceTy, triples, path);
+}
+
+mlir::Value fir::FirOpBuilder::createBox(mlir::Location loc,
+                                         const fir::ExtendedValue &exv) {
+  auto itemAddr = fir::getBase(exv);
+  if (itemAddr.getType().isa<fir::BoxType>())
+    return itemAddr;
+  auto elementType = fir::dyn_cast_ptrEleTy(itemAddr.getType());
+  if (!elementType)
+    mlir::emitError(loc, "internal: expected a memory reference type ")
+        << itemAddr.getType();
+  auto boxTy = fir::BoxType::get(elementType);
+  return exv.match(
+      [&](const fir::ArrayBoxValue &box) -> mlir::Value {
+        auto s = createShape(loc, exv);
+        return create<fir::EmboxOp>(loc, boxTy, itemAddr, s);
+      },
+      // [&](const fir::CharArrayBoxValue &box) -> mlir::Value {
+      //   auto s = createShape(loc, exv);
+      //   if (fir::factory::CharacterExprHelper::hasConstantLengthInType(exv))
+      //     return create<fir::EmboxOp>(loc, boxTy, itemAddr, s);
+
+      //   mlir::Value emptySlice;
+      //   llvm::SmallVector<mlir::Value> lenParams{box.getLen()};
+      //   return create<fir::EmboxOp>(loc, boxTy, itemAddr, s, emptySlice,
+      //                               lenParams);
+      // },
+      // [&](const fir::CharBoxValue &box) -> mlir::Value {
+      //   if (fir::factory::CharacterExprHelper::hasConstantLengthInType(exv))
+      //     return create<fir::EmboxOp>(loc, boxTy, itemAddr);
+      //   mlir::Value emptyShape, emptySlice;
+      //   llvm::SmallVector<mlir::Value> lenParams{box.getLen()};
+      //   return create<fir::EmboxOp>(loc, boxTy, itemAddr, emptyShape,
+      //                               emptySlice, lenParams);
+      // },
+      [&](const fir::MutableBoxValue &x) -> mlir::Value {
+        return create<fir::LoadOp>(
+            loc, fir::factory::getMutableIRBox(*this, loc, x));
+      },
+      [&](const auto &) -> mlir::Value {
+        return create<fir::EmboxOp>(loc, boxTy, itemAddr);
+      });
+}
+
+static mlir::Value genNullPointerComparison(fir::FirOpBuilder &builder,
+                                            mlir::Location loc,
+                                            mlir::Value addr,
+                                            mlir::CmpIPredicate condition) {
+  auto intPtrTy = builder.getIntPtrType();
+  auto ptrToInt = builder.createConvert(loc, intPtrTy, addr);
+  auto c0 = builder.createIntegerConstant(loc, intPtrTy, 0);
+  return builder.create<mlir::CmpIOp>(loc, condition, ptrToInt, c0);
+}
+
+mlir::Value fir::FirOpBuilder::genIsNotNull(mlir::Location loc,
+                                            mlir::Value addr) {
+  return genNullPointerComparison(*this, loc, addr, mlir::CmpIPredicate::ne);
+}
+
+mlir::Value fir::FirOpBuilder::genIsNull(mlir::Location loc, mlir::Value addr) {
+  return genNullPointerComparison(*this, loc, addr, mlir::CmpIPredicate::eq);
+}
+
+mlir::Value fir::FirOpBuilder::genExtentFromTriplet(mlir::Location loc,
+                                                    mlir::Value lb,
+                                                    mlir::Value ub,
+                                                    mlir::Value step,
+                                                    mlir::Type type) {
+  auto zero = createIntegerConstant(loc, type, 0);
+  lb = createConvert(loc, type, lb);
+  ub = createConvert(loc, type, ub);
+  step = createConvert(loc, type, step);
+  auto diff = create<mlir::SubIOp>(loc, ub, lb);
+  auto add = create<mlir::AddIOp>(loc, diff, step);
+  auto div = create<mlir::SignedDivIOp>(loc, add, step);
+  auto cmp = create<mlir::CmpIOp>(loc, mlir::CmpIPredicate::sgt, div, zero);
+  return create<mlir::SelectOp>(loc, cmp, div, zero);
+}
+
+//===--------------------------------------------------------------------===//
+// ExtendedValue inquiry helper implementation
+//===--------------------------------------------------------------------===//
+
+mlir::Value fir::factory::readCharLen(fir::FirOpBuilder &builder,
+                                      mlir::Location loc,
+                                      const fir::ExtendedValue &box) {
+  return box.match(
+      [&](const fir::CharBoxValue &x) -> mlir::Value { return x.getLen(); },
+      [&](const fir::CharArrayBoxValue &x) -> mlir::Value {
+        return x.getLen();
+      },
+      // [&](const fir::BoxValue &x) -> mlir::Value {
+      //   assert(x.isCharacter());
+      //   if (!x.getExplicitParameters().empty())
+      //     return x.getExplicitParameters()[0];
+      //   return fir::factory::CharacterExprHelper{builder, loc}
+      //       .readLengthFromBox(x.getAddr());
+      // },
+      [&](const fir::MutableBoxValue &) -> mlir::Value {
+        // MutableBoxValue must be read into another category to work with them
+        // outside of allocation/assignment contexts.
+        fir::emitFatalError(loc, "readCharLen on MutableBoxValue");
+      },
+      [&](const auto &) -> mlir::Value {
+        fir::emitFatalError(
+            loc, "Character length inquiry on a non-character entity");
+      });
+}
+
+mlir::Value fir::factory::readExtent(fir::FirOpBuilder &builder,
+                                     mlir::Location loc,
+                                     const fir::ExtendedValue &box,
+                                     unsigned dim) {
+  assert(box.rank() > dim);
+  return box.match(
+      [&](const fir::ArrayBoxValue &x) -> mlir::Value {
+        return x.getExtents()[dim];
+      },
+      [&](const fir::CharArrayBoxValue &x) -> mlir::Value {
+        return x.getExtents()[dim];
+      },
+      [&](const fir::BoxValue &x) -> mlir::Value {
+        if (!x.getExplicitExtents().empty())
+          return x.getExplicitExtents()[dim];
+        auto idxTy = builder.getIndexType();
+        auto dimVal = builder.createIntegerConstant(loc, idxTy, dim);
+        return builder
+            .create<fir::BoxDimsOp>(loc, idxTy, idxTy, idxTy, x.getAddr(),
+                                    dimVal)
+            .getResult(1);
+      },
+      [&](const fir::MutableBoxValue &x) -> mlir::Value {
+        // MutableBoxValue must be read into another category to work with them
+        // outside of allocation/assignment contexts.
+        fir::emitFatalError(loc, "readExtents on MutableBoxValue");
+      },
+      [&](const auto &) -> mlir::Value {
+        fir::emitFatalError(loc, "extent inquiry on scalar");
+      });
+}
+
+mlir::Value fir::factory::readLowerBound(fir::FirOpBuilder &,
+                                         mlir::Location loc,
+                                         const fir::ExtendedValue &box,
+                                         unsigned dim,
+                                         mlir::Value defaultValue) {
+  assert(box.rank() > dim);
+  auto lb = box.match(
+      [&](const fir::ArrayBoxValue &x) -> mlir::Value {
+        return x.getLBounds().empty() ? mlir::Value{} : x.getLBounds()[dim];
+      },
+      [&](const fir::CharArrayBoxValue &x) -> mlir::Value {
+        return x.getLBounds().empty() ? mlir::Value{} : x.getLBounds()[dim];
+      },
+      [&](const fir::BoxValue &x) -> mlir::Value {
+        return x.getLBounds().empty() ? mlir::Value{} : x.getLBounds()[dim];
+      },
+      [&](const fir::MutableBoxValue &) -> mlir::Value {
+        // MutableBoxValue must be read into another category to work with them
+        // outside of allocation/assignment contexts.
+        fir::emitFatalError(loc, "readLowerBound on MutableBoxValue");
+      },
+      [&](const auto &) -> mlir::Value {
+        fir::emitFatalError(loc, "lower bound inquiry on scalar");
+      });
+  if (lb)
+    return lb;
+  return defaultValue;
+}
+
+llvm::SmallVector<mlir::Value>
+fir::factory::readExtents(fir::FirOpBuilder &builder, mlir::Location loc,
+                          const fir::BoxValue &box) {
+  llvm::SmallVector<mlir::Value> result;
+  auto explicitExtents = box.getExplicitExtents();
+  if (!explicitExtents.empty()) {
+    result.append(explicitExtents.begin(), explicitExtents.end());
+    return result;
+  }
+  auto rank = box.rank();
+  auto idxTy = builder.getIndexType();
+  for (decltype(rank) dim = 0; dim < rank; ++dim) {
+    auto dimVal = builder.createIntegerConstant(loc, idxTy, dim);
+    auto dimInfo = builder.create<fir::BoxDimsOp>(loc, idxTy, idxTy, idxTy,
+                                                  box.getAddr(), dimVal);
+    result.emplace_back(dimInfo.getResult(1));
+  }
+  return result;
+}
+
+llvm::SmallVector<mlir::Value>
+fir::factory::getExtents(fir::FirOpBuilder &builder, mlir::Location loc,
+                         const fir::ExtendedValue &box) {
+  return box.match(
+      [&](const fir::ArrayBoxValue &x) -> llvm::SmallVector<mlir::Value> {
+        return {x.getExtents().begin(), x.getExtents().end()};
+      },
+      [&](const fir::CharArrayBoxValue &x) -> llvm::SmallVector<mlir::Value> {
+        return {x.getExtents().begin(), x.getExtents().end()};
+      },
+      [&](const fir::BoxValue &x) -> llvm::SmallVector<mlir::Value> {
+        return fir::factory::readExtents(builder, loc, x);
+      },
+      [&](const fir::MutableBoxValue &x) -> llvm::SmallVector<mlir::Value> {
+        auto load = fir::factory::genMutableBoxRead(builder, loc, x);
+        return fir::factory::getExtents(builder, loc, load);
+      },
+      [&](const auto &) -> llvm::SmallVector<mlir::Value> { return {}; });
+}
+
+fir::ExtendedValue fir::factory::readBoxValue(fir::FirOpBuilder &builder,
+                                              mlir::Location loc,
+                                              const fir::BoxValue &box) {
+  assert(!box.isUnlimitedPolymorphic() && !box.hasAssumedRank() &&
+         "cannot read unlimited polymorphic or assumed rank fir.box");
+  auto addr =
+      builder.create<fir::BoxAddrOp>(loc, box.getMemTy(), box.getAddr());
+  if (box.isCharacter()) {
+    auto len = fir::factory::readCharLen(builder, loc, box);
+    if (box.rank() == 0)
+      return fir::CharBoxValue(addr, len);
+    return fir::CharArrayBoxValue(addr, len,
+                                  fir::factory::readExtents(builder, loc, box),
+                                  box.getLBounds());
+  }
+  if (box.isDerivedWithLengthParameters())
+    TODO(loc, "read fir.box with length parameters");
+  if (box.rank() == 0)
+    return addr;
+  return fir::ArrayBoxValue(addr, fir::factory::readExtents(builder, loc, box),
+                            box.getLBounds());
+}
+
+std::string fir::factory::uniqueCGIdent(llvm::StringRef prefix,
+                                        llvm::StringRef name) {
+  // For "long" identifiers use a hash value
+  if (name.size() > nameLengthHashSize) {
+    llvm::MD5 hash;
+    hash.update(name);
+    llvm::MD5::MD5Result result;
+    hash.final(result);
+    llvm::SmallString<32> str;
+    llvm::MD5::stringifyResult(result, str);
+    std::string hashName = prefix.str();
+    hashName.append(".").append(str.c_str());
+    return fir::NameUniquer::doGenerated(hashName);
+  }
+  // "Short" identifiers use a reversible hex string
+  std::string nm = prefix.str();
+  return fir::NameUniquer::doGenerated(
+      nm.append(".").append(llvm::toHex(name)));
+}
+
+mlir::Value fir::factory::locationToFilename(fir::FirOpBuilder &builder,
+                                             mlir::Location loc) {
+  if (auto flc = loc.dyn_cast<mlir::FileLineColLoc>()) {
+    // must be encoded as asciiz, C string
+    auto fn = flc.getFilename().str() + '\0';
+    return fir::getBase(createStringLiteral(builder, loc, fn));
+  }
+  return builder.createNullConstant(loc);
+}
+
+mlir::Value fir::factory::locationToLineNo(fir::FirOpBuilder &builder,
+                                           mlir::Location loc,
+                                           mlir::Type type) {
+  if (auto flc = loc.dyn_cast<mlir::FileLineColLoc>())
+    return builder.createIntegerConstant(loc, type, flc.getLine());
+  return builder.createIntegerConstant(loc, type, 0);
+}
+
+fir::ExtendedValue fir::factory::createStringLiteral(fir::FirOpBuilder &builder,
+                                                     mlir::Location loc,
+                                                     llvm::StringRef str) {
+  std::string globalName = fir::factory::uniqueCGIdent("cl", str);
+  auto type = fir::CharacterType::get(builder.getContext(), 1, str.size());
+  auto global = builder.getNamedGlobal(globalName);
+  if (!global)
+    global = builder.createGlobalConstant(
+        loc, type, globalName,
+        [&](fir::FirOpBuilder &builder) {
+          auto stringLitOp = builder.createStringLitOp(loc, str);
+          builder.create<fir::HasValueOp>(loc, stringLitOp);
+        },
+        builder.createLinkOnceLinkage());
+  auto addr = builder.create<fir::AddrOfOp>(loc, global.resultType(),
+                                            global.getSymbol());
+  auto len = builder.createIntegerConstant(
+      loc, builder.getCharacterLengthType(), str.size());
+  return fir::CharBoxValue{addr, len};
+}
+
+llvm::SmallVector<mlir::Value>
+fir::factory::createExtents(fir::FirOpBuilder &builder, mlir::Location loc,
+                            fir::SequenceType seqTy) {
+  llvm::SmallVector<mlir::Value> extents;
+  auto idxTy = builder.getIndexType();
+  for (auto ext : seqTy.getShape())
+    extents.emplace_back(
+        ext == fir::SequenceType::getUnknownExtent()
+            ? builder.create<fir::UndefOp>(loc, idxTy).getResult()
+            : builder.createIntegerConstant(loc, idxTy, ext));
+  return extents;
+}
+
+// FIXME: This needs some work. To correctly determine the extended value of a
+// component, one needs the base object, its type, and its type parameters. (An
+// alternative would be to provide an already computed address of the final
+// component rather than the base object's address, the point being the result
+// will require the address of the final component to create the extended
+// value.) One further needs the full path of components being applied. One
+// needs to apply type-based expressions to type parameters along this said
+// path. (See applyPathToType for a type-only derivation.) Finally, one needs to
+// compose the extended value of the terminal component, including all of its
+// parameters: array lower bounds expressions, extents, type parameters, etc.
+// Any of these properties may be deferred until runtime in Fortran. This
+// operation may therefore generate a sizeable block of IR, including calls to
+// type-based helper functions, so caching the result of this operation in the
+// client would be advised as well.
+fir::ExtendedValue fir::factory::componentToExtendedValue(
+    fir::FirOpBuilder &builder, mlir::Location loc, mlir::Value component) {
+  auto fieldTy = component.getType();
+  if (auto ty = fir::dyn_cast_ptrEleTy(fieldTy))
+    fieldTy = ty;
+  if (fieldTy.isa<fir::BoxType>()) {
+    llvm::SmallVector<mlir::Value> nonDeferredTypeParams;
+    auto eleTy = fir::unwrapSequenceType(fir::dyn_cast_ptrOrBoxEleTy(fieldTy));
+    if (auto charTy = eleTy.dyn_cast<fir::CharacterType>()) {
+      auto lenTy = builder.getCharacterLengthType();
+      if (charTy.hasConstantLen())
+        nonDeferredTypeParams.emplace_back(
+            builder.createIntegerConstant(loc, lenTy, charTy.getLen()));
+      // TODO: Starting, F2003, the dynamic character length might be dependent
+      // on a PDT length parameter. There is no way to make a difference with
+      // deferred length here yet.
+    }
+    if (auto recTy = eleTy.dyn_cast<fir::RecordType>())
+      if (recTy.getNumLenParams() > 0)
+        TODO(loc, "allocatable and pointer components non deferred length "
+                  "parameters");
+
+    return fir::MutableBoxValue(component, nonDeferredTypeParams,
+                                /*mutableProperties=*/{});
+  }
+  llvm::SmallVector<mlir::Value> extents;
+  if (auto seqTy = fieldTy.dyn_cast<fir::SequenceType>()) {
+    fieldTy = seqTy.getEleTy();
+    auto idxTy = builder.getIndexType();
+    for (auto extent : seqTy.getShape()) {
+      if (extent == fir::SequenceType::getUnknownExtent())
+        TODO(loc, "array component shape depending on length parameters");
+      extents.emplace_back(builder.createIntegerConstant(loc, idxTy, extent));
+    }
+  }
+  if (auto charTy = fieldTy.dyn_cast<fir::CharacterType>()) {
+    auto cstLen = charTy.getLen();
+    if (cstLen == fir::CharacterType::unknownLen())
+      TODO(loc, "get character component length from length type parameters");
+    auto len = builder.createIntegerConstant(
+        loc, builder.getCharacterLengthType(), cstLen);
+    if (!extents.empty())
+      return fir::CharArrayBoxValue{component, len, extents};
+    return fir::CharBoxValue{component, len};
+  }
+  if (auto recordTy = fieldTy.dyn_cast<fir::RecordType>())
+    if (recordTy.getNumLenParams() != 0)
+      TODO(loc,
+           "lower component ref that is a derived type with length parameter");
+  if (!extents.empty())
+    return fir::ArrayBoxValue{component, extents};
+  return component;
+}
+
+fir::ExtendedValue fir::factory::arrayElementToExtendedValue(
+    fir::FirOpBuilder &builder, mlir::Location loc,
+    const fir::ExtendedValue &array, mlir::Value element) {
+  return array.match(
+      [&](const fir::CharBoxValue &cb) -> fir::ExtendedValue {
+        return cb.clone(element);
+      },
+      [&](const fir::CharArrayBoxValue &bv) -> fir::ExtendedValue {
+        return bv.cloneElement(element);
+      },
+      [&](const fir::BoxValue &box) -> fir::ExtendedValue {
+        if (box.isCharacter()) {
+          auto len = fir::factory::readCharLen(builder, loc, box);
+          return fir::CharBoxValue{element, len};
+        }
+        if (box.isDerivedWithLengthParameters())
+          TODO(loc, "get length parameters from derived type BoxValue");
+        return element;
+      },
+      [&](const auto &) -> fir::ExtendedValue { return element; });
+}
+
+fir::ExtendedValue fir::factory::arraySectionElementToExtendedValue(
+    fir::FirOpBuilder &builder, mlir::Location loc,
+    const fir::ExtendedValue &array, mlir::Value element, mlir::Value slice) {
+  if (!slice)
+    return arrayElementToExtendedValue(builder, loc, array, element);
+  auto sliceOp = mlir::dyn_cast_or_null<fir::SliceOp>(slice.getDefiningOp());
+  assert(sliceOp && "slice must be a sliceOp");
+  if (sliceOp.fields().empty())
+    return arrayElementToExtendedValue(builder, loc, array, element);
+  // For F95, using componentToExtendedValue will work, but when PDTs are
+  // lowered. It will be required to go down the slice to propagate the length
+  // parameters.
+  return fir::factory::componentToExtendedValue(builder, loc, element);
+}
+
+/// Can the assignment of this record type be implement with a simple memory
+/// copy ?
+static bool recordTypeCanBeMemCopied(fir::RecordType recordType) {
+  if (fir::hasDynamicSize(recordType))
+    return false;
+  for (auto [_, fieldType] : recordType.getTypeList()) {
+    // Derived type component may have user assignment (so far, we cannot tell
+    // in FIR, so assume it is always the case, TODO: get the actual info).
+    if (fir::unwrapSequenceType(fieldType).isa<fir::RecordType>())
+      return false;
+    // Allocatable components need deep copy.
+    if (auto boxType = fieldType.dyn_cast<fir::BoxType>())
+      if (boxType.getEleTy().isa<fir::HeapType>())
+        return false;
+  }
+  // Constant size components without user defined assignment and pointers can
+  // be memcopied.
+  return true;
+}
+
+void fir::factory::genRecordAssignment(fir::FirOpBuilder &builder,
+                                       mlir::Location loc,
+                                       const fir::ExtendedValue &lhs,
+                                       const fir::ExtendedValue &rhs) {
+  assert(lhs.rank() == 0 && rhs.rank() == 0 && "assume scalar assignment");
+  auto baseTy = fir::dyn_cast_ptrOrBoxEleTy(fir::getBase(lhs).getType());
+  assert(baseTy && "must be a memory type");
+  // Box operands may be polymorphic, it is not entirely clear from 10.2.1.3
+  // if the assignment is performed on the dynamic of declared type. Use the
+  // runtime assuming it is performed on the dynamic type.
+  bool hasBoxOperands = fir::getBase(lhs).getType().isa<fir::BoxType>() ||
+                        fir::getBase(rhs).getType().isa<fir::BoxType>();
+  auto recTy = baseTy.dyn_cast<fir::RecordType>();
+  assert(recTy && "must be a record type");
+  if (hasBoxOperands || !recordTypeCanBeMemCopied(recTy)) {
+    auto to = fir::getBase(builder.createBox(loc, lhs));
+    auto from = fir::getBase(builder.createBox(loc, rhs));
+    // The runtime entry point may modify the LHS descriptor if it is
+    // an allocatable. Allocatable assignment is handle elsewhere in lowering,
+    // so just create a fir.ref<fir.box<>> from the fir.box to comply with the
+    // runtime interface, but assume the fir.box is unchanged.
+    // TODO: does this holds true with polymorphic entities ?
+    auto toMutableBox = builder.createTemporary(loc, to.getType());
+    builder.create<fir::StoreOp>(loc, to, toMutableBox);
+    fir::runtime::genAssign(builder, loc, toMutableBox, from);
+    return;
+  }
+  // Otherwise, the derived type has compile time constant size and for which
+  // the component by component assignment can be replaced by a memory copy.
+  auto load = builder.create<fir::LoadOp>(loc, fir::getBase(rhs));
+  builder.create<fir::StoreOp>(loc, load, fir::getBase(lhs));
+}
+
+mlir::TupleType
+fir::factory::getRaggedArrayHeaderType(fir::FirOpBuilder &builder) {
+  auto i64Ty = builder.getIntegerType(64);
+  auto arrTy = fir::SequenceType::get(builder.getIntegerType(8), 1);
+  auto buffTy = fir::HeapType::get(arrTy);
+  auto extTy = fir::SequenceType::get(i64Ty, 1);
+  auto shTy = fir::HeapType::get(extTy);
+  return mlir::TupleType::get(builder.getContext(), {i64Ty, buffTy, shTy});
+}

flang/lib/Optimizer/Builder/MutableBox.cpp

+//===-- MutableBox.cpp -- MutableBox utilities ----------------------------===//
+//
+// 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
+//
+//===----------------------------------------------------------------------===//
+//
+// Coding style: https://mlir.llvm.org/getting_started/DeveloperGuide/
+//
+//===----------------------------------------------------------------------===//
+
+#include "flang/Optimizer/Builder/MutableBox.h"
+#include "flang/Lower/Todo.h"
+#include "flang/Optimizer/Builder/Character.h"
+#include "flang/Optimizer/Builder/FIRBuilder.h"
+#include "flang/Optimizer/Dialect/FIROps.h"
+#include "flang/Optimizer/Dialect/FIROpsSupport.h"
+#include "flang/Optimizer/Support/FatalError.h"
+
+//===----------------------------------------------------------------------===//
+// MutableBoxValue writer and reader
+//===----------------------------------------------------------------------===//
+
+namespace {
+/// MutablePropertyWriter and MutablePropertyReader implementations are the only
+/// places that depend on how the properties of MutableBoxValue (pointers and
+/// allocatables) that can be modified in the lifetime of the entity (address,
+/// extents, lower bounds, length parameters) are represented.
+/// That is, the properties may be only stored in a fir.box in memory if we
+/// need to enforce a single point of truth for the properties across calls.
+/// Or, they can be tracked as independent local variables when it is safe to
+/// do so. Using bare variables benefits from all optimization passes, even
+/// when they are not aware of what a fir.box is and fir.box have not been
+/// optimized out yet.
+
+/// MutablePropertyWriter allows reading the properties of a MutableBoxValue.
+class MutablePropertyReader {
+public:
+  MutablePropertyReader(fir::FirOpBuilder &builder, mlir::Location loc,
+                        const fir::MutableBoxValue &box,
+                        bool forceIRBoxRead = false)
+      : builder{builder}, loc{loc}, box{box} {
+    if (forceIRBoxRead || !box.isDescribedByVariables())
+      irBox = builder.create<fir::LoadOp>(loc, box.getAddr());
+  }
+  /// Get base address of allocated/associated entity.
+  mlir::Value readBaseAddress() {
+    if (irBox) {
+      auto heapOrPtrTy = box.getBoxTy().getEleTy();
+      return builder.create<fir::BoxAddrOp>(loc, heapOrPtrTy, irBox);
+    }
+    auto addrVar = box.getMutableProperties().addr;
+    return builder.create<fir::LoadOp>(loc, addrVar);
+  }
+  /// Return {lbound, extent} values read from the MutableBoxValue given
+  /// the dimension.
+  std::pair<mlir::Value, mlir::Value> readShape(unsigned dim) {
+    auto idxTy = builder.getIndexType();
+    if (irBox) {
+      auto dimVal = builder.createIntegerConstant(loc, idxTy, dim);
+      auto dimInfo = builder.create<fir::BoxDimsOp>(loc, idxTy, idxTy, idxTy,
+                                                    irBox, dimVal);
+      return {dimInfo.getResult(0), dimInfo.getResult(1)};
+    }
+    const auto &mutableProperties = box.getMutableProperties();
+    auto lb = builder.create<fir::LoadOp>(loc, mutableProperties.lbounds[dim]);
+    auto ext = builder.create<fir::LoadOp>(loc, mutableProperties.extents[dim]);
+    return {lb, ext};
+  }
+
+  /// Return the character length. If the length was not deferred, the value
+  /// that was specified is returned (The mutable fields is not read).
+  mlir::Value readCharacterLength() {
+    if (box.hasNonDeferredLenParams())
+      return box.nonDeferredLenParams()[0];
+    if (irBox)
+      return fir::factory::CharacterExprHelper{builder, loc}.readLengthFromBox(
+          irBox);
+    const auto &deferred = box.getMutableProperties().deferredParams;
+    if (deferred.empty())
+      fir::emitFatalError(loc, "allocatable entity has no length property");
+    return builder.create<fir::LoadOp>(loc, deferred[0]);
+  }
+
+  /// Read and return all extents. If \p lbounds vector is provided, lbounds are
+  /// also read into it.
+  llvm::SmallVector<mlir::Value>
+  readShape(llvm::SmallVectorImpl<mlir::Value> *lbounds = nullptr) {
+    llvm::SmallVector<mlir::Value> extents;
+    auto rank = box.rank();
+    for (decltype(rank) dim = 0; dim < rank; ++dim) {
+      auto [lb, extent] = readShape(dim);
+      if (lbounds)
+        lbounds->push_back(lb);
+      extents.push_back(extent);
+    }
+    return extents;
+  }
+
+  /// Read all mutable properties. Return the base address.
+  mlir::Value read(llvm::SmallVectorImpl<mlir::Value> &lbounds,
+                   llvm::SmallVectorImpl<mlir::Value> &extents,
+                   llvm::SmallVectorImpl<mlir::Value> &lengths) {
+    extents = readShape(&lbounds);
+    if (box.isCharacter())
+      lengths.emplace_back(readCharacterLength());
+    else if (box.isDerivedWithLengthParameters())
+      TODO(loc, "read allocatable or pointer derived type LEN parameters");
+    return readBaseAddress();
+  }
+
+  /// Return the loaded fir.box.
+  mlir::Value getIrBox() const {
+    assert(irBox);
+    return irBox;
+  }
+
+  /// Read the lower bounds
+  void getLowerBounds(llvm::SmallVectorImpl<mlir::Value> &lbounds) {
+    auto rank = box.rank();
+    for (decltype(rank) dim = 0; dim < rank; ++dim)
+      lbounds.push_back(std::get<0>(readShape(dim)));
+  }
+
+private:
+  fir::FirOpBuilder &builder;
+  mlir::Location loc;
+  fir::MutableBoxValue box;
+  mlir::Value irBox;
+};
+
+/// MutablePropertyWriter allows modifying the properties of a MutableBoxValue.
+class MutablePropertyWriter {
+public:
+  MutablePropertyWriter(fir::FirOpBuilder &builder, mlir::Location loc,
+                        const fir::MutableBoxValue &box)
+      : builder{builder}, loc{loc}, box{box} {}
+  /// Update MutableBoxValue with new address, shape and length parameters.
+  /// Extents and lbounds must all have index type.
+  /// lbounds can be empty in which case all ones is assumed.
+  /// Length parameters must be provided for the length parameters that are
+  /// deferred.
+  void updateMutableBox(mlir::Value addr, mlir::ValueRange lbounds,
+                        mlir::ValueRange extents, mlir::ValueRange lengths) {
+    if (box.isDescribedByVariables())
+      updateMutableProperties(addr, lbounds, extents, lengths);
+    else
+      updateIRBox(addr, lbounds, extents, lengths);
+  }
+
+  /// Update MutableBoxValue with a new fir.box. This requires that the mutable
+  /// box is not described by a set of variables, since they could not describe
+  /// all that can be described in the new fir.box (e.g. non contiguous entity).
+  void updateWithIrBox(mlir::Value newBox) {
+    assert(!box.isDescribedByVariables());
+    builder.create<fir::StoreOp>(loc, newBox, box.getAddr());
+  }
+  /// Set unallocated/disassociated status for the entity described by
+  /// MutableBoxValue. Deallocation is not performed by this helper.
+  void setUnallocatedStatus() {
+    if (box.isDescribedByVariables()) {
+      auto addrVar = box.getMutableProperties().addr;
+      auto nullTy = fir::dyn_cast_ptrEleTy(addrVar.getType());
+      builder.create<fir::StoreOp>(loc, builder.createNullConstant(loc, nullTy),
+                                   addrVar);
+    } else {
+      // Note that the dynamic type of polymorphic entities must be reset to the
+      // declaration type of the mutable box. See Fortran 2018 7.8.2 NOTE 1.
+      // For those, we cannot simply set the address to zero. The way we are
+      // currently unallocating fir.box guarantees that we are resetting the
+      // type to the declared type. Beware if changing this.
+      // Note: the standard is not clear in Deallocate and p => NULL semantics
+      // regarding the new dynamic type the entity must have. So far, assume
+      // this is just like NULLIFY and the dynamic type must be set to the
+      // declared type, not retain the previous dynamic type.
+      auto deallocatedBox = fir::factory::createUnallocatedBox(
+          builder, loc, box.getBoxTy(), box.nonDeferredLenParams());
+      builder.create<fir::StoreOp>(loc, deallocatedBox, box.getAddr());
+    }
+  }
+
+  /// Copy Values from the fir.box into the property variables if any.
+  void syncMutablePropertiesFromIRBox() {
+    if (!box.isDescribedByVariables())
+      return;
+    llvm::SmallVector<mlir::Value> lbounds;
+    llvm::SmallVector<mlir::Value> extents;
+    llvm::SmallVector<mlir::Value> lengths;
+    auto addr =
+        MutablePropertyReader{builder, loc, box, /*forceIRBoxRead=*/true}.read(
+            lbounds, extents, lengths);
+    updateMutableProperties(addr, lbounds, extents, lengths);
+  }
+
+  /// Copy Values from property variables, if any, into the fir.box.
+  void syncIRBoxFromMutableProperties() {
+    if (!box.isDescribedByVariables())
+      return;
+    llvm::SmallVector<mlir::Value> lbounds;
+    llvm::SmallVector<mlir::Value> extents;
+    llvm::SmallVector<mlir::Value> lengths;
+    auto addr = MutablePropertyReader{builder, loc, box}.read(lbounds, extents,
+                                                              lengths);
+    updateIRBox(addr, lbounds, extents, lengths);
+  }
+
+private:
+  /// Update the IR box (fir.ref<fir.box<T>>) of the MutableBoxValue.
+  void updateIRBox(mlir::Value addr, mlir::ValueRange lbounds,
+                   mlir::ValueRange extents, mlir::ValueRange lengths) {
+    mlir::Value shape;
+    if (!extents.empty()) {
+      if (lbounds.empty()) {
+        auto shapeType =
+            fir::ShapeType::get(builder.getContext(), extents.size());
+        shape = builder.create<fir::ShapeOp>(loc, shapeType, extents);
+      } else {
+        llvm::SmallVector<mlir::Value> shapeShiftBounds;
+        for (auto [lb, extent] : llvm::zip(lbounds, extents)) {
+          shapeShiftBounds.emplace_back(lb);
+          shapeShiftBounds.emplace_back(extent);
+        }
+        auto shapeShiftType =
+            fir::ShapeShiftType::get(builder.getContext(), extents.size());
+        shape = builder.create<fir::ShapeShiftOp>(loc, shapeShiftType,
+                                                  shapeShiftBounds);
+      }
+    }
+    mlir::Value emptySlice;
+    // Ignore lengths if already constant in the box type (this would trigger an
+    // error in the embox).
+    llvm::SmallVector<mlir::Value> cleanedLengths;
+    mlir::Value irBox;
+    if (addr.getType().isa<fir::BoxType>()) {
+      // The entity is already boxed.
+      irBox = builder.createConvert(loc, box.getBoxTy(), addr);
+    } else {
+      auto cleanedAddr = addr;
+      if (auto charTy = box.getEleTy().dyn_cast<fir::CharacterType>()) {
+        // Cast address to box type so that both input and output type have
+        // unknown or constant lengths.
+        auto bt = box.getBaseTy();
+        auto addrTy = addr.getType();
+        auto type = addrTy.isa<fir::HeapType>()      ? fir::HeapType::get(bt)
+                    : addrTy.isa<fir::PointerType>() ? fir::PointerType::get(bt)
+                                                     : builder.getRefType(bt);
+        cleanedAddr = builder.createConvert(loc, type, addr);
+        if (charTy.getLen() == fir::CharacterType::unknownLen())
+          cleanedLengths.append(lengths.begin(), lengths.end());
+      } else if (box.isDerivedWithLengthParameters()) {
+        TODO(loc, "updating mutablebox of derived type with length parameters");
+        cleanedLengths = lengths;
+      }
+      irBox = builder.create<fir::EmboxOp>(loc, box.getBoxTy(), cleanedAddr,
+                                           shape, emptySlice, cleanedLengths);
+    }
+    builder.create<fir::StoreOp>(loc, irBox, box.getAddr());
+  }
+
+  /// Update the set of property variables of the MutableBoxValue.
+  void updateMutableProperties(mlir::Value addr, mlir::ValueRange lbounds,
+                               mlir::ValueRange extents,
+                               mlir::ValueRange lengths) {
+    auto castAndStore = [&](mlir::Value val, mlir::Value addr) {
+      auto type = fir::dyn_cast_ptrEleTy(addr.getType());
+      builder.create<fir::StoreOp>(loc, builder.createConvert(loc, type, val),
+                                   addr);
+    };
+    const auto &mutableProperties = box.getMutableProperties();
+    castAndStore(addr, mutableProperties.addr);
+    for (auto [extent, extentVar] :
+         llvm::zip(extents, mutableProperties.extents))
+      castAndStore(extent, extentVar);
+    if (!mutableProperties.lbounds.empty()) {
+      if (lbounds.empty()) {
+        auto one =
+            builder.createIntegerConstant(loc, builder.getIndexType(), 1);
+        for (auto lboundVar : mutableProperties.lbounds)
+          castAndStore(one, lboundVar);
+      } else {
+        for (auto [lbound, lboundVar] :
+             llvm::zip(lbounds, mutableProperties.lbounds))
+          castAndStore(lbound, lboundVar);
+      }
+    }
+    if (box.isCharacter())
+      // llvm::zip account for the fact that the length only needs to be stored
+      // when it is specified in the allocation and deferred in the
+      // MutableBoxValue.
+      for (auto [len, lenVar] :
+           llvm::zip(lengths, mutableProperties.deferredParams))
+        castAndStore(len, lenVar);
+    else if (box.isDerivedWithLengthParameters())
+      TODO(loc, "update allocatable derived type length parameters");
+  }
+  fir::FirOpBuilder &builder;
+  mlir::Location loc;
+  fir::MutableBoxValue box;
+};
+
+} // namespace
+
+mlir::Value
+fir::factory::createUnallocatedBox(fir::FirOpBuilder &builder,
+                                   mlir::Location loc, mlir::Type boxType,
+                                   mlir::ValueRange nonDeferredParams) {
+  auto heapType = boxType.dyn_cast<fir::BoxType>().getEleTy();
+  auto type = fir::dyn_cast_ptrEleTy(heapType);
+  auto eleTy = type;
+  if (auto seqType = eleTy.dyn_cast<fir::SequenceType>())
+    eleTy = seqType.getEleTy();
+  if (auto recTy = eleTy.dyn_cast<fir::RecordType>())
+    if (recTy.getNumLenParams() > 0)
+      TODO(loc, "creating unallocated fir.box of derived type with length "
+                "parameters");
+  auto nullAddr = builder.createNullConstant(loc, heapType);
+  mlir::Value shape;
+  if (auto seqTy = type.dyn_cast<fir::SequenceType>()) {
+    auto zero = builder.createIntegerConstant(loc, builder.getIndexType(), 0);
+    llvm::SmallVector<mlir::Value> extents(seqTy.getDimension(), zero);
+    shape = builder.createShape(
+        loc, fir::ArrayBoxValue{nullAddr, extents, /*lbounds=*/llvm::None});
+  }
+  // Provide dummy length parameters if they are dynamic. If a length parameter
+  // is deferred. it is set to zero here and will be set on allocation.
+  llvm::SmallVector<mlir::Value> lenParams;
+  if (auto charTy = eleTy.dyn_cast<fir::CharacterType>()) {
+    if (charTy.getLen() == fir::CharacterType::unknownLen()) {
+      if (!nonDeferredParams.empty()) {
+        lenParams.push_back(nonDeferredParams[0]);
+      } else {
+        auto zero = builder.createIntegerConstant(
+            loc, builder.getCharacterLengthType(), 0);
+        lenParams.push_back(zero);
+      }
+    }
+  }
+  mlir::Value emptySlice;
+  return builder.create<fir::EmboxOp>(loc, boxType, nullAddr, shape, emptySlice,
+                                      lenParams);
+}
+
+fir::MutableBoxValue
+fir::factory::createTempMutableBox(fir::FirOpBuilder &builder,
+                                   mlir::Location loc, mlir::Type type,
+                                   llvm::StringRef name) {
+  auto boxType = fir::BoxType::get(fir::HeapType::get(type));
+  auto boxAddr = builder.createTemporary(loc, boxType, name);
+  auto box =
+      fir::MutableBoxValue(boxAddr, /*nonDeferredParams=*/mlir::ValueRange(),
+                           /*mutableProperties=*/{});
+  MutablePropertyWriter{builder, loc, box}.setUnallocatedStatus();
+  return box;
+}
+
+/// Helper to decide if a MutableBoxValue must be read to an BoxValue or
+/// can be read to a reified box value.
+static bool readToBoxValue(const fir::MutableBoxValue &box,
+                           bool mayBePolymorphic) {
+  // If this is described by a set of local variables, the value
+  // should not be tracked as a fir.box.
+  if (box.isDescribedByVariables())
+    return false;
+  // Polymorphism might be a source of discontiguity, even on allocatables.
+  // Track value as fir.box
+  if ((box.isDerived() && mayBePolymorphic) || box.isUnlimitedPolymorphic())
+    return true;
+  // Intrinsic alloctables are contiguous, no need to track the value by
+  // fir.box.
+  if (box.isAllocatable() || box.rank() == 0)
+    return false;
+  // Pointer are known to be contiguous at compile time iff they have the
+  // CONTIGUOUS attribute.
+  return !fir::valueHasFirAttribute(box.getAddr(),
+                                    fir::getContiguousAttrName());
+}
+
+fir::ExtendedValue
+fir::factory::genMutableBoxRead(fir::FirOpBuilder &builder, mlir::Location loc,
+                                const fir::MutableBoxValue &box,
+                                bool mayBePolymorphic) {
+  if (box.hasAssumedRank())
+    TODO(loc, "Assumed rank allocatables or pointers");
+  llvm::SmallVector<mlir::Value> lbounds;
+  llvm::SmallVector<mlir::Value> extents;
+  llvm::SmallVector<mlir::Value> lengths;
+  if (readToBoxValue(box, mayBePolymorphic)) {
+    auto reader = MutablePropertyReader(builder, loc, box);
+    reader.getLowerBounds(lbounds);
+    return fir::BoxValue{reader.getIrBox(), lbounds,
+                         box.nonDeferredLenParams()};
+  }
+  // Contiguous intrinsic type entity: all the data can be extracted from the
+  // fir.box.
+  auto addr =
+      MutablePropertyReader(builder, loc, box).read(lbounds, extents, lengths);
+  auto rank = box.rank();
+  if (box.isCharacter()) {
+    auto len = lengths.empty() ? mlir::Value{} : lengths[0];
+    if (rank)
+      return fir::CharArrayBoxValue{addr, len, extents, lbounds};
+    return fir::CharBoxValue{addr, len};
+  }
+  if (rank)
+    return fir::ArrayBoxValue{addr, extents, lbounds};
+  return addr;
+}
+
+mlir::Value
+fir::factory::genIsAllocatedOrAssociatedTest(fir::FirOpBuilder &builder,
+                                             mlir::Location loc,
+                                             const fir::MutableBoxValue &box) {
+  auto addr = MutablePropertyReader(builder, loc, box).readBaseAddress();
+  return builder.genIsNotNull(loc, addr);
+}
+
+/// Generate finalizer call and inlined free. This does not check that the
+/// address was allocated.
+static void genFinalizeAndFree(fir::FirOpBuilder &builder, mlir::Location loc,
+                               mlir::Value addr) {
+  // TODO: call finalizer if any.
+
+  // A heap (ALLOCATABLE) object may have been converted to a ptr (POINTER),
+  // so make sure the heap type is restored before deallocation.
+  auto cast = builder.createConvert(
+      loc, fir::HeapType::get(fir::dyn_cast_ptrEleTy(addr.getType())), addr);
+  builder.create<fir::FreeMemOp>(loc, cast);
+}
+
+void fir::factory::genFinalization(fir::FirOpBuilder &builder,
+                                   mlir::Location loc,
+                                   const fir::MutableBoxValue &box) {
+  auto addr = MutablePropertyReader(builder, loc, box).readBaseAddress();
+  auto isAllocated = builder.genIsNotNull(loc, addr);
+  auto ifOp = builder.create<fir::IfOp>(loc, isAllocated,
+                                        /*withElseRegion=*/false);
+  auto insPt = builder.saveInsertionPoint();
+  builder.setInsertionPointToStart(&ifOp.thenRegion().front());
+  genFinalizeAndFree(builder, loc, addr);
+  builder.restoreInsertionPoint(insPt);
+}
+
+//===----------------------------------------------------------------------===//
+// MutableBoxValue writing interface implementation
+//===----------------------------------------------------------------------===//
+
+void fir::factory::associateMutableBox(fir::FirOpBuilder &builder,
+                                       mlir::Location loc,
+                                       const fir::MutableBoxValue &box,
+                                       const fir::ExtendedValue &source,
+                                       mlir::ValueRange lbounds) {
+  MutablePropertyWriter writer(builder, loc, box);
+  source.match(
+      [&](const fir::UnboxedValue &addr) {
+        writer.updateMutableBox(addr, /*lbounds=*/llvm::None,
+                                /*extents=*/llvm::None, /*lengths=*/llvm::None);
+      },
+      [&](const fir::CharBoxValue &ch) {
+        writer.updateMutableBox(ch.getAddr(), /*lbounds=*/llvm::None,
+                                /*extents=*/llvm::None, {ch.getLen()});
+      },
+      [&](const fir::ArrayBoxValue &arr) {
+        writer.updateMutableBox(arr.getAddr(),
+                                lbounds.empty() ? arr.getLBounds() : lbounds,
+                                arr.getExtents(), /*lengths=*/llvm::None);
+      },
+      [&](const fir::CharArrayBoxValue &arr) {
+        writer.updateMutableBox(arr.getAddr(),
+                                lbounds.empty() ? arr.getLBounds() : lbounds,
+                                arr.getExtents(), {arr.getLen()});
+      },
+      [&](const fir::BoxValue &arr) {
+        // Rebox array fir.box to the pointer type and apply potential new lower
+        // bounds.
+        mlir::ValueRange newLbounds = lbounds.empty()
+                                          ? mlir::ValueRange{arr.getLBounds()}
+                                          : mlir::ValueRange{lbounds};
+        if (box.isDescribedByVariables()) {
+          // LHS is a contiguous pointer described by local variables. Open RHS
+          // fir.box to update the LHS.
+          auto rawAddr = builder.create<fir::BoxAddrOp>(loc, arr.getMemTy(),
+                                                        arr.getAddr());
+          auto extents = fir::factory::getExtents(builder, loc, source);
+          llvm::SmallVector<mlir::Value> lenParams;
+          if (arr.isCharacter()) {
+            lenParams.emplace_back(
+                fir::factory::readCharLen(builder, loc, source));
+          } else if (arr.isDerivedWithLengthParameters()) {
+            TODO(loc, "pointer assignment to derived with length parameters");
+          }
+          writer.updateMutableBox(rawAddr, newLbounds, extents, lenParams);
+        } else {
+          mlir::Value shift;
+          if (!newLbounds.empty()) {
+            auto shiftType =
+                fir::ShiftType::get(builder.getContext(), newLbounds.size());
+            shift = builder.create<fir::ShiftOp>(loc, shiftType, newLbounds);
+          }
+          auto reboxed =
+              builder.create<fir::ReboxOp>(loc, box.getBoxTy(), arr.getAddr(),
+                                           shift, /*slice=*/mlir::Value());
+          writer.updateWithIrBox(reboxed);
+        }
+      },
+      [&](const fir::MutableBoxValue &) {
+        // No point implementing this, if right-hand side is a
+        // pointer/allocatable, the related MutableBoxValue has been read into
+        // another ExtendedValue category.
+        fir::emitFatalError(loc,
+                            "Cannot write MutableBox to another MutableBox");
+      },
+      [&](const fir::ProcBoxValue &) {
+        TODO(loc, "Procedure pointer assignment");
+      });
+}
+
+void fir::factory::associateMutableBoxWithRemap(
+    fir::FirOpBuilder &builder, mlir::Location loc,
+    const fir::MutableBoxValue &box, const fir::ExtendedValue &source,
+    mlir::ValueRange lbounds, mlir::ValueRange ubounds) {
+  // Compute new extents
+  llvm::SmallVector<mlir::Value> extents;
+  auto idxTy = builder.getIndexType();
+  if (!lbounds.empty()) {
+    auto one = builder.createIntegerConstant(loc, idxTy, 1);
+    for (auto [lb, ub] : llvm::zip(lbounds, ubounds)) {
+      auto lbi = builder.createConvert(loc, idxTy, lb);
+      auto ubi = builder.createConvert(loc, idxTy, ub);
+      auto diff = builder.create<mlir::SubIOp>(loc, idxTy, ubi, lbi);
+      extents.emplace_back(builder.create<mlir::AddIOp>(loc, idxTy, diff, one));
+    }
+  } else {
+    // lbounds are default. Upper bounds and extents are the same.
+    for (auto ub : ubounds) {
+      auto cast = builder.createConvert(loc, idxTy, ub);
+      extents.emplace_back(cast);
+    }
+  }
+  const auto newRank = extents.size();
+  auto cast = [&](mlir::Value addr) -> mlir::Value {
+    // Cast base addr to new sequence type.
+    auto ty = fir::dyn_cast_ptrEleTy(addr.getType());
+    if (auto seqTy = ty.dyn_cast<fir::SequenceType>()) {
+      fir::SequenceType::Shape shape(newRank,
+                                     fir::SequenceType::getUnknownExtent());
+      ty = fir::SequenceType::get(shape, seqTy.getEleTy());
+    }
+    return builder.createConvert(loc, builder.getRefType(ty), addr);
+  };
+  MutablePropertyWriter writer(builder, loc, box);
+  source.match(
+      [&](const fir::UnboxedValue &addr) {
+        writer.updateMutableBox(cast(addr), lbounds, extents,
+                                /*lengths=*/llvm::None);
+      },
+      [&](const fir::CharBoxValue &ch) {
+        writer.updateMutableBox(cast(ch.getAddr()), lbounds, extents,
+                                {ch.getLen()});
+      },
+      [&](const fir::ArrayBoxValue &arr) {
+        writer.updateMutableBox(cast(arr.getAddr()), lbounds, extents,
+                                /*lengths=*/llvm::None);
+      },
+      [&](const fir::CharArrayBoxValue &arr) {
+        writer.updateMutableBox(cast(arr.getAddr()), lbounds, extents,
+                                {arr.getLen()});
+      },
+      [&](const fir::BoxValue &arr) {
+        // Rebox right-hand side fir.box with a new shape and type.
+        if (box.isDescribedByVariables()) {
+          // LHS is a contiguous pointer described by local variables. Open RHS
+          // fir.box to update the LHS.
+          auto rawAddr = builder.create<fir::BoxAddrOp>(loc, arr.getMemTy(),
+                                                        arr.getAddr());
+          llvm::SmallVector<mlir::Value> lenParams;
+          if (arr.isCharacter()) {
+            lenParams.emplace_back(
+                fir::factory::readCharLen(builder, loc, source));
+          } else if (arr.isDerivedWithLengthParameters()) {
+            TODO(loc, "pointer assignment to derived with length parameters");
+          }
+          writer.updateMutableBox(rawAddr, lbounds, extents, lenParams);
+        } else {
+          auto shapeType =
+              fir::ShapeShiftType::get(builder.getContext(), extents.size());
+          llvm::SmallVector<mlir::Value> shapeArgs;
+          auto idxTy = builder.getIndexType();
+          for (auto [lbnd, ext] : llvm::zip(lbounds, extents)) {
+            auto lb = builder.createConvert(loc, idxTy, lbnd);
+            shapeArgs.push_back(lb);
+            shapeArgs.push_back(ext);
+          }
+          auto shape =
+              builder.create<fir::ShapeShiftOp>(loc, shapeType, shapeArgs);
+          auto reboxed =
+              builder.create<fir::ReboxOp>(loc, box.getBoxTy(), arr.getAddr(),
+                                           shape, /*slice=*/mlir::Value());
+          writer.updateWithIrBox(reboxed);
+        }
+      },
+      [&](const fir::MutableBoxValue &) {
+        // No point implementing this, if right-hand side is a pointer or
+        // allocatable, the related MutableBoxValue has already been read into
+        // another ExtendedValue category.
+        fir::emitFatalError(loc,
+                            "Cannot write MutableBox to another MutableBox");
+      },
+      [&](const fir::ProcBoxValue &) {
+        TODO(loc, "Procedure pointer assignment");
+      });
+}
+
+void fir::factory::disassociateMutableBox(fir::FirOpBuilder &builder,
+                                          mlir::Location loc,
+                                          const fir::MutableBoxValue &box) {
+  MutablePropertyWriter{builder, loc, box}.setUnallocatedStatus();
+}
+
+void fir::factory::genInlinedAllocation(fir::FirOpBuilder &builder,
+                                        mlir::Location loc,
+                                        const fir::MutableBoxValue &box,
+                                        mlir::ValueRange lbounds,
+                                        mlir::ValueRange extents,
+                                        mlir::ValueRange lenParams,
+                                        llvm::StringRef allocName) {
+  auto idxTy = builder.getIndexType();
+  llvm::SmallVector<mlir::Value> lengths;
+  if (auto charTy = box.getEleTy().dyn_cast<fir::CharacterType>()) {
+    if (charTy.getLen() == fir::CharacterType::unknownLen()) {
+      if (box.hasNonDeferredLenParams())
+        lengths.emplace_back(
+            builder.createConvert(loc, idxTy, box.nonDeferredLenParams()[0]));
+      else if (!lenParams.empty())
+        lengths.emplace_back(builder.createConvert(loc, idxTy, lenParams[0]));
+      else
+        fir::emitFatalError(
+            loc, "could not deduce character lengths in character allocation");
+    }
+  }
+  mlir::Value heap = builder.create<fir::AllocMemOp>(
+      loc, box.getBaseTy(), allocName, lengths, extents);
+  // TODO: run initializer if any. Currently, there is no way to know this is
+  // required here.
+  MutablePropertyWriter{builder, loc, box}.updateMutableBox(heap, lbounds,
+                                                            extents, lengths);
+}
+
+void fir::factory::genInlinedDeallocate(fir::FirOpBuilder &builder,
+                                        mlir::Location loc,
+                                        const fir::MutableBoxValue &box) {
+  auto addr = MutablePropertyReader(builder, loc, box).readBaseAddress();
+  genFinalizeAndFree(builder, loc, addr);
+  MutablePropertyWriter{builder, loc, box}.setUnallocatedStatus();
+}
+
+void fir::factory::genReallocIfNeeded(fir::FirOpBuilder &builder,
+                                      mlir::Location loc,
+                                      const fir::MutableBoxValue &box,
+                                      mlir::ValueRange lbounds,
+                                      mlir::ValueRange shape,
+                                      mlir::ValueRange lengthParams) {
+  // Implement 10.2.1.3 point 3 logic when lhs is an array.
+  auto reader = MutablePropertyReader(builder, loc, box);
+  auto addr = reader.readBaseAddress();
+  auto isAllocated = builder.genIsNotNull(loc, addr);
+  builder.genIfThenElse(loc, isAllocated)
+      .genThen([&]() {
+        // The box is allocated. Check if it must be reallocated and reallocate.
+        mlir::Value mustReallocate = builder.createBool(loc, false);
+        auto compareProperty = [&](mlir::Value previous, mlir::Value required) {
+          auto castPrevious =
+              builder.createConvert(loc, required.getType(), previous);
+          // reallocate = reallocate || previous != required
+          auto cmp = builder.create<mlir::CmpIOp>(loc, mlir::CmpIPredicate::ne,
+                                                  castPrevious, required);
+          mustReallocate =
+              builder.create<mlir::SelectOp>(loc, cmp, cmp, mustReallocate);
+        };
+        llvm::SmallVector<mlir::Value> previousLbounds;
+        llvm::SmallVector<mlir::Value> previousExtents =
+            reader.readShape(&previousLbounds);
+        if (!shape.empty())
+          for (auto [previousExtent, requested] :
+               llvm::zip(previousExtents, shape))
+            compareProperty(previousExtent, requested);
+
+        if (box.isCharacter() && !box.hasNonDeferredLenParams()) {
+          // When the allocatable length is not deferred, it must not be
+          // reallocated in case of length mismatch, instead, padding/trimming
+          // will ocur in later assignment to it.
+          assert(!lengthParams.empty() &&
+                 "must provide length parameters for character");
+          compareProperty(reader.readCharacterLength(), lengthParams[0]);
+        } else if (box.isDerivedWithLengthParameters()) {
+          TODO(loc,
+               "automatic allocation of derived type allocatable with length "
+               "parameters");
+        }
+        builder.genIfThen(loc, mustReallocate)
+            .genThen([&]() {
+              // If shape or length mismatch, deallocate and reallocate.
+              genFinalizeAndFree(builder, loc, addr);
+              // When rhs is a scalar, keep the previous shape
+              auto extents =
+                  shape.empty() ? mlir::ValueRange(previousExtents) : shape;
+              auto lbs =
+                  shape.empty() ? mlir::ValueRange(previousLbounds) : lbounds;
+              genInlinedAllocation(builder, loc, box, lbs, extents,
+                                   lengthParams, ".auto.alloc");
+            })
+            .end();
+      })
+      .genElse([&]() {
+        // The box is not yet allocated, simply allocate it.
+        if (shape.empty() && box.rank() != 0) {
+          // TODO:
+          // runtime error: right hand side must be allocated if right hand
+          // side is a scalar and the box is an array.
+        } else {
+          genInlinedAllocation(builder, loc, box, lbounds, shape, lengthParams,
+                               ".auto.alloc");
+        }
+      })
+      .end();
+}
+
+//===----------------------------------------------------------------------===//
+// MutableBoxValue syncing implementation
+//===----------------------------------------------------------------------===//
+
+/// Depending on the implementation, allocatable/pointer descriptor and the
+/// MutableBoxValue need to be synced before and after calls passing the
+/// descriptor. These calls will generate the syncing if needed and be no-op
+mlir::Value fir::factory::getMutableIRBox(fir::FirOpBuilder &builder,
+                                          mlir::Location loc,
+                                          const fir::MutableBoxValue &box) {
+  MutablePropertyWriter{builder, loc, box}.syncIRBoxFromMutableProperties();
+  return box.getAddr();
+}
+void fir::factory::syncMutableBoxFromIRBox(fir::FirOpBuilder &builder,
+                                           mlir::Location loc,
+                                           const fir::MutableBoxValue &box) {
+  MutablePropertyWriter{builder, loc, box}.syncMutablePropertiesFromIRBox();
+}

flang/lib/Optimizer/Builder/Runtime/Assign.cpp

+//===-- Assign.cpp -- generate assignment runtime API calls ---------------===//
+//
+// 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/Optimizer/Builder/Runtime/Assign.h"
+#include "flang/Optimizer/Builder/FIRBuilder.h"
+#include "flang/Optimizer/Builder/Runtime/RTBuilder.h"
+#include "flang/Runtime/assign.h"
+
+using namespace Fortran::runtime;
+
+void fir::runtime::genAssign(fir::FirOpBuilder &builder, mlir::Location loc,
+                             mlir::Value destBox, mlir::Value sourceBox) {
+  auto func = fir::runtime::getRuntimeFunc<mkRTKey(Assign)>(loc, builder);
+  auto fTy = func.getType();
+  auto sourceFile = fir::factory::locationToFilename(builder, loc);
+  auto sourceLine =
+      fir::factory::locationToLineNo(builder, loc, fTy.getInput(3));
+  auto args = fir::runtime::createArguments(builder, loc, fTy, destBox,
+                                            sourceBox, sourceFile, sourceLine);
+  builder.create<fir::CallOp>(loc, func, args);
+}

flang/lib/Optimizer/CMakeLists.txt

+add_subdirectory(Builder)
 add_subdirectory(CodeGen)
 add_subdirectory(Dialect)
 add_subdirectory(Support)
 add_subdirectory(Transforms)

flang/lib/Optimizer/Dialect/FIROps.cpp

static mlir::LogicalResult verify(fir::GenTypeDescOp &op) {
   }
   return mlir::success();
 }
 
 //===----------------------------------------------------------------------===//
 // GlobalOp
 //===----------------------------------------------------------------------===//
 
+mlir::Type fir::GlobalOp::resultType() {
+  return wrapAllocaResultType(getType());
+}
+
 static ParseResult parseGlobalOp(OpAsmParser &parser, OperationState &result) {
   // Parse the optional linkage
   llvm::StringRef linkage;
   auto &builder = parser.getBuilder();
   if (mlir::succeeded(parser.parseOptionalKeyword(&linkage))) {
     if (fir::GlobalOp::verifyValidLinkage(linkage))
       return mlir::failure();
     mlir::StringAttr linkAttr = builder.getStringAttr(linkage);

flang/lib/Optimizer/Dialect/FIRType.cpp

bool isa_fir_or_std_type(mlir::Type t) {
   if (auto funcType = t.dyn_cast<mlir::FunctionType>())
     return llvm::all_of(funcType.getInputs(), isa_fir_or_std_type) &&
            llvm::all_of(funcType.getResults(), isa_fir_or_std_type);
   return isa_fir_type(t) || isa_std_type(t);
 }
 
 mlir::Type dyn_cast_ptrEleTy(mlir::Type t) {
   return llvm::TypeSwitch<mlir::Type, mlir::Type>(t)
-      .Case<fir::ReferenceType, fir::PointerType, fir::HeapType>(
-          [](auto p) { return p.getEleTy(); })
+      .Case<fir::ReferenceType, fir::PointerType, fir::HeapType,
+            fir::LLVMPointerType>([](auto p) { return p.getEleTy(); })
       .Default([](mlir::Type) { return mlir::Type{}; });
 }
 
 mlir::Type dyn_cast_ptrOrBoxEleTy(mlir::Type t) {
   return llvm::TypeSwitch<mlir::Type, mlir::Type>(t)
-      .Case<fir::ReferenceType, fir::PointerType, fir::HeapType>(
-          [](auto p) { return p.getEleTy(); })
+      .Case<fir::ReferenceType, fir::PointerType, fir::HeapType,
+            fir::LLVMPointerType>([](auto p) { return p.getEleTy(); })
       .Case<fir::BoxType>([](auto p) {
         auto eleTy = p.getEleTy();
         if (auto ty = fir::dyn_cast_ptrEleTy(eleTy))
           return ty;
         return eleTy;
       })
       .Default([](mlir::Type) { return mlir::Type{}; });
 }
 
+static bool hasDynamicSize(fir::RecordType recTy) {
+  for (auto field : recTy.getTypeList()) {
+    if (auto arr = field.second.dyn_cast<fir::SequenceType>()) {
+      if (sequenceWithNonConstantShape(arr))
+        return true;
+    } else if (characterWithDynamicLen(field.second)) {
+      return true;
+    } else if (auto rec = field.second.dyn_cast<fir::RecordType>()) {
+      if (hasDynamicSize(rec))
+        return true;
+    }
+  }
+  return false;
+}
+
+bool hasDynamicSize(mlir::Type t) {
+  if (auto arr = t.dyn_cast<fir::SequenceType>()) {
+    if (sequenceWithNonConstantShape(arr))
+      return true;
+    t = arr.getEleTy();
+  }
+  if (characterWithDynamicLen(t))
+    return true;
+  if (auto rec = t.dyn_cast<fir::RecordType>())
+    return hasDynamicSize(rec);
+  return false;
+}
+
 } // namespace fir
 
 namespace {
 
 static llvm::SmallPtrSet<detail::RecordTypeStorage const *, 4>
     recordTypeVisited;
 
 } // namespace
mlir::Type fir::LogicalType::parse(mlir::DialectAsmParser &parser) {
   return parseKindSingleton<fir::LogicalType>(parser);
 }
 
 void fir::LogicalType::print(mlir::DialectAsmPrinter &printer) const {
   printer << getMnemonic() << "<" << getFKind() << '>';
 }
 
 //===----------------------------------------------------------------------===//
+// LLVMPointerType
+//===----------------------------------------------------------------------===//
+
+// `llvm_ptr` `<` type `>`
+mlir::Type fir::LLVMPointerType::parse(mlir::DialectAsmParser &parser) {
+  return parseTypeSingleton<fir::LLVMPointerType>(parser);
+}
+
+void fir::LLVMPointerType::print(mlir::DialectAsmPrinter &printer) const {
+  printer << getMnemonic() << "<" << getEleTy() << '>';
+}
+
+//===----------------------------------------------------------------------===//
 // PointerType
 //===----------------------------------------------------------------------===//
 
 // `ptr` `<` type `>`
 mlir::Type fir::PointerType::parse(mlir::DialectAsmParser &parser) {
   return parseTypeSingleton<fir::PointerType>(parser);
 }
 

 
 //===----------------------------------------------------------------------===//
 // FIROpsDialect
 //===----------------------------------------------------------------------===//
 
 void FIROpsDialect::registerTypes() {
   addTypes<BoxType, BoxCharType, BoxProcType, CharacterType, fir::ComplexType,
            FieldType, HeapType, fir::IntegerType, LenType, LogicalType,
-           PointerType, RealType, RecordType, ReferenceType, SequenceType,
-           ShapeType, ShapeShiftType, ShiftType, SliceType, TypeDescType,
-           fir::VectorType>();
+           LLVMPointerType, PointerType, RealType, RecordType, ReferenceType,
+           SequenceType, ShapeType, ShapeShiftType, ShiftType, SliceType,
+           TypeDescType, fir::VectorType>();
 }

flang/lib/Optimizer/Transforms/ArrayValueCopy.cpp

+//===-- ArrayValueCopy.cpp ------------------------------------------------===//
+//
+// 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 "PassDetail.h"
+#include "flang/Optimizer/Builder/BoxValue.h"
+#include "flang/Optimizer/Builder/FIRBuilder.h"
+#include "flang/Optimizer/Dialect/FIRDialect.h"
+#include "flang/Optimizer/Support/FIRContext.h"
+#include "flang/Optimizer/Transforms/Factory.h"
+#include "flang/Optimizer/Transforms/Passes.h"
+#include "mlir/Dialect/SCF/SCF.h"
+#include "mlir/Transforms/DialectConversion.h"
+#include "llvm/Support/Debug.h"
+
+#define DEBUG_TYPE "flang-array-value-copy"
+
+using namespace fir;
+
+using OperationUseMapT = llvm::DenseMap<mlir::Operation *, mlir::Operation *>;
+
+namespace {
+
+/// Array copy analysis.
+/// Perform an interference analysis between array values.
+///
+/// Lowering will generate a sequence of the following form.
+/// ```mlir
+///   %a_1 = fir.array_load %array_1(%shape) : ...
+///   ...
+///   %a_j = fir.array_load %array_j(%shape) : ...
+///   ...
+///   %a_n = fir.array_load %array_n(%shape) : ...
+///     ...
+///     %v_i = fir.array_fetch %a_i, ...
+///     %a_j1 = fir.array_update %a_j, ...
+///     ...
+///   fir.array_merge_store %a_j, %a_jn to %array_j : ...
+/// ```
+///
+/// The analysis is to determine if there are any conflicts. A conflict is when
+/// one the following cases occurs.
+///
+/// 1. There is an `array_update` to an array value, a_j, such that a_j was
+/// loaded from the same array memory reference (array_j) but with a different
+/// shape as the other array values a_i, where i != j. [Possible overlapping
+/// arrays.]
+///
+/// 2. There is either an array_fetch or array_update of a_j with a different
+/// set of index values. [Possible loop-carried dependence.]
+///
+/// If none of the array values overlap in storage and the accesses are not
+/// loop-carried, then the arrays are conflict-free and no copies are required.
+class ArrayCopyAnalysis {
+public:
+  using ConflictSetT = llvm::SmallPtrSet<mlir::Operation *, 16>;
+  using UseSetT = llvm::SmallPtrSet<mlir::OpOperand *, 8>;
+  using LoadMapSetsT = llvm::DenseMap<mlir::Operation *, UseSetT>;
+
+  ArrayCopyAnalysis(mlir::Operation *op) : operation{op} {
+    construct(op->getRegions());
+  }
+
+  mlir::Operation *getOperation() const { return operation; }
+
+  /// Return true iff the `array_merge_store` has potential conflicts.
+  bool hasPotentialConflict(mlir::Operation *op) const {
+    LLVM_DEBUG(llvm::dbgs()
+               << "looking for a conflict on " << *op
+               << " and the set has a total of " << conflicts.size() << '\n');
+    return conflicts.contains(op);
+  }
+
+  /// Return the use map. The use map maps array fetch and update operations
+  /// back to the array load that is the original source of the array value.
+  const OperationUseMapT &getUseMap() const { return useMap; }
+
+  /// For ArrayLoad `load`, return the transitive set of all OpOperands.
+  UseSetT getLoadUseSet(mlir::Operation *load) const {
+    assert(loadMapSets.count(load) && "analysis missed an array load?");
+    return loadMapSets.lookup(load);
+  }
+
+  /// Get all the array value operations that use the original array value
+  /// as passed to `store`.
+  void arrayAccesses(llvm::SmallVectorImpl<mlir::Operation *> &accesses,
+                     ArrayLoadOp load);
+
+private:
+  void construct(mlir::MutableArrayRef<mlir::Region> regions);
+
+  mlir::Operation *operation; // operation that analysis ran upon
+  ConflictSetT conflicts;     // set of conflicts (loads and merge stores)
+  OperationUseMapT useMap;
+  LoadMapSetsT loadMapSets;
+};
+} // namespace
+
+namespace {
+/// Helper class to collect all array operations that produced an array value.
+class ReachCollector {
+public:
+  ReachCollector(llvm::SmallVectorImpl<mlir::Operation *> &reach,
+                 mlir::Region *loopRegion)
+      : reach{reach}, loopRegion{loopRegion} {}
+
+  void collectArrayAccessFrom(mlir::Operation *op, mlir::ValueRange range) {
+    if (range.empty()) {
+      collectArrayAccessFrom(op, mlir::Value{});
+      return;
+    }
+    for (auto v : range)
+      collectArrayAccessFrom(v);
+  }
+
+  void collectArrayAccessFrom(mlir::Operation *op, mlir::Value val) {
+    // `val` is defined by an Op, process the defining Op.
+    // If `val` is defined by a region containing Op, we want to drill down
+    // and through that Op's region(s).
+    LLVM_DEBUG(llvm::dbgs() << "popset: " << *op << '\n');
+    auto popFn = [&](auto rop) {
+      assert(val && "op must have a result value");
+      auto resNum = val.cast<mlir::OpResult>().getResultNumber();
+      llvm::SmallVector<mlir::Value> results;
+      rop.resultToSourceOps(results, resNum);
+      for (auto u : results)
+        collectArrayAccessFrom(u);
+    };
+    if (auto rop = mlir::dyn_cast<DoLoopOp>(op)) {
+      popFn(rop);
+      return;
+    }
+    if (auto rop = mlir::dyn_cast<IterWhileOp>(op)) {
+      popFn(rop);
+      return;
+    }
+    if (auto rop = mlir::dyn_cast<fir::IfOp>(op)) {
+      popFn(rop);
+      return;
+    }
+    if (auto box = mlir::dyn_cast<EmboxOp>(op)) {
+      for (auto *user : box.memref().getUsers())
+        if (user != op)
+          collectArrayAccessFrom(user, user->getResults());
+      return;
+    }
+    if (auto mergeStore = mlir::dyn_cast<ArrayMergeStoreOp>(op)) {
+      if (opIsInsideLoops(mergeStore))
+        collectArrayAccessFrom(mergeStore.sequence());
+      return;
+    }
+
+    if (mlir::isa<AllocaOp, AllocMemOp>(op)) {
+      // Look for any stores inside the loops, and collect an array operation
+      // that produced the value being stored to it.
+      for (auto *user : op->getUsers())
+        if (auto store = mlir::dyn_cast<fir::StoreOp>(user))
+          if (opIsInsideLoops(store))
+            collectArrayAccessFrom(store.value());
+      return;
+    }
+
+    // Otherwise, Op does not contain a region so just chase its operands.
+    if (mlir::isa<ArrayLoadOp, ArrayUpdateOp, ArrayModifyOp, ArrayFetchOp>(
+            op)) {
+      LLVM_DEBUG(llvm::dbgs() << "add " << *op << " to reachable set\n");
+      reach.emplace_back(op);
+    }
+    // Array modify assignment is performed on the result. So the analysis
+    // must look at the what is done with the result.
+    if (mlir::isa<ArrayModifyOp>(op))
+      for (auto *user : op->getResult(0).getUsers())
+        followUsers(user);
+
+    for (auto u : op->getOperands())
+      collectArrayAccessFrom(u);
+  }
+
+  void collectArrayAccessFrom(mlir::BlockArgument ba) {
+    auto *parent = ba.getOwner()->getParentOp();
+    // If inside an Op holding a region, the block argument corresponds to an
+    // argument passed to the containing Op.
+    auto popFn = [&](auto rop) {
+      collectArrayAccessFrom(rop.blockArgToSourceOp(ba.getArgNumber()));
+    };
+    if (auto rop = mlir::dyn_cast<DoLoopOp>(parent)) {
+      popFn(rop);
+      return;
+    }
+    if (auto rop = mlir::dyn_cast<IterWhileOp>(parent)) {
+      popFn(rop);
+      return;
+    }
+    // Otherwise, a block argument is provided via the pred blocks.
+    for (auto *pred : ba.getOwner()->getPredecessors()) {
+      auto u = pred->getTerminator()->getOperand(ba.getArgNumber());
+      collectArrayAccessFrom(u);
+    }
+  }
+
+  // Recursively trace operands to find all array operations relating to the
+  // values merged.
+  void collectArrayAccessFrom(mlir::Value val) {
+    if (!val || visited.contains(val))
+      return;
+    visited.insert(val);
+
+    // Process a block argument.
+    if (auto ba = val.dyn_cast<mlir::BlockArgument>()) {
+      collectArrayAccessFrom(ba);
+      return;
+    }
+
+    // Process an Op.
+    if (auto *op = val.getDefiningOp()) {
+      collectArrayAccessFrom(op, val);
+      return;
+    }
+
+    fir::emitFatalError(val.getLoc(), "unhandled value");
+  }
+
+  /// Return all ops that produce the array value that is stored into the
+  /// `array_merge_store`.
+  static void reachingValues(llvm::SmallVectorImpl<mlir::Operation *> &reach,
+                             mlir::Value seq) {
+    reach.clear();
+    mlir::Region *loopRegion = nullptr;
+    if (auto doLoop =
+            mlir::dyn_cast_or_null<fir::DoLoopOp>(seq.getDefiningOp()))
+      loopRegion = &doLoop->getRegion(0);
+    ReachCollector collector(reach, loopRegion);
+    collector.collectArrayAccessFrom(seq);
+  }
+
+private:
+  /// Is \op inside the loop nest region ?
+  /// FIXME: replace this structural dependence with graph properties.
+  bool opIsInsideLoops(mlir::Operation *op) const {
+    auto *region = op->getParentRegion();
+    while (region) {
+      if (region == loopRegion)
+        return true;
+      region = region->getParentRegion();
+    }
+    return false;
+  }
+
+  /// Recursively trace the use of an operation results, calling
+  /// collectArrayAccessFrom on the direct and indirect user operands.
+  void followUsers(mlir::Operation *op) {
+    for (auto userOperand : op->getOperands())
+      collectArrayAccessFrom(userOperand);
+    // Go through potential converts/coordinate_op.
+    for (auto indirectUser : op->getUsers())
+      followUsers(indirectUser);
+  }
+
+  llvm::SmallVectorImpl<mlir::Operation *> &reach;
+  llvm::SmallPtrSet<mlir::Value, 16> visited;
+  /// Region of the loops nest that produced the array value.
+  mlir::Region *loopRegion;
+};
+} // namespace
+
+/// Find all the array operations that access the array value that is loaded by
+/// the array load operation, `load`.
+void ArrayCopyAnalysis::arrayAccesses(
+    llvm::SmallVectorImpl<mlir::Operation *> &accesses, ArrayLoadOp load) {
+  accesses.clear();
+  auto lmIter = loadMapSets.find(load);
+  if (lmIter != loadMapSets.end()) {
+    for (auto *opnd : lmIter->second) {
+      auto *owner = opnd->getOwner();
+      if (mlir::isa<ArrayFetchOp, ArrayUpdateOp, ArrayModifyOp>(owner))
+        accesses.push_back(owner);
+    }
+    return;
+  }
+
+  UseSetT visited;
+  llvm::SmallVector<mlir::OpOperand *> queue; // uses of ArrayLoad[orig]
+
+  auto appendToQueue = [&](mlir::Value val) {
+    for (auto &use : val.getUses())
+      if (!visited.count(&use)) {
+        visited.insert(&use);
+        queue.push_back(&use);
+      }
+  };
+
+  // Build the set of uses of `original`.
+  // let USES = { uses of original fir.load }
+  appendToQueue(load);
+
+  // Process the worklist until done.
+  while (!queue.empty()) {
+    auto *operand = queue.pop_back_val();
+    auto *owner = operand->getOwner();
+    if (!owner)
+      continue;
+    auto structuredLoop = [&](auto ro) {
+      if (auto blockArg = ro.iterArgToBlockArg(operand->get())) {
+        auto arg = blockArg.getArgNumber();
+        auto output = ro.getResult(ro.finalValue() ? arg : arg - 1);
+        appendToQueue(output);
+        appendToQueue(blockArg);
+      }
+    };
+    auto branchOp = [&](mlir::Block *dest, auto operands) {
+      for (auto i : llvm::enumerate(operands))
+        if (operand->get() == i.value()) {
+          auto blockArg = dest->getArgument(i.index());
+          appendToQueue(blockArg);
+        }
+    };
+    // Thread uses into structured loop bodies and return value uses.
+    if (auto ro = mlir::dyn_cast<DoLoopOp>(owner)) {
+      structuredLoop(ro);
+    } else if (auto ro = mlir::dyn_cast<IterWhileOp>(owner)) {
+      structuredLoop(ro);
+    } else if (auto rs = mlir::dyn_cast<ResultOp>(owner)) {
+      // Thread any uses of fir.if that return the marked array value.
+      auto *parent = rs->getParentRegion()->getParentOp();
+      if (auto ifOp = mlir::dyn_cast<fir::IfOp>(parent))
+        appendToQueue(ifOp.getResult(operand->getOperandNumber()));
+    } else if (mlir::isa<ArrayFetchOp>(owner)) {
+      // Keep track of array value fetches.
+      LLVM_DEBUG(llvm::dbgs()
+                 << "add fetch {" << *owner << "} to array value set\n");
+      accesses.push_back(owner);
+    } else if (auto update = mlir::dyn_cast<ArrayUpdateOp>(owner)) {
+      // Keep track of array value updates and thread the return value uses.
+      LLVM_DEBUG(llvm::dbgs()
+                 << "add update {" << *owner << "} to array value set\n");
+      accesses.push_back(owner);
+      appendToQueue(update.getResult());
+    } else if (auto update = mlir::dyn_cast<ArrayModifyOp>(owner)) {
+      // Keep track of array value modification and thread the return value
+      // uses.
+      LLVM_DEBUG(llvm::dbgs()
+                 << "add modify {" << *owner << "} to array value set\n");
+      accesses.push_back(owner);
+      appendToQueue(update.getResult(1));
+    } else if (auto br = mlir::dyn_cast<mlir::BranchOp>(owner)) {
+      branchOp(br.getDest(), br.destOperands());
+    } else if (auto br = mlir::dyn_cast<mlir::CondBranchOp>(owner)) {
+      branchOp(br.getTrueDest(), br.getTrueOperands());
+      branchOp(br.getFalseDest(), br.getFalseOperands());
+    } else if (mlir::isa<ArrayMergeStoreOp>(owner)) {
+      // do nothing
+    } else {
+      llvm::report_fatal_error("array value reached unexpected op");
+    }
+  }
+  loadMapSets.insert({load, visited});
+}
+
+/// Is there a conflict between the array value that was updated and to be
+/// stored to `st` and the set of arrays loaded (`reach`) and used to compute
+/// the updated value?
+static bool conflictOnLoad(llvm::ArrayRef<mlir::Operation *> reach,
+                           ArrayMergeStoreOp st) {
+  mlir::Value load;
+  auto addr = st.memref();
+  auto stEleTy = fir::dyn_cast_ptrOrBoxEleTy(addr.getType());
+  for (auto *op : reach)
+    if (auto ld = mlir::dyn_cast<ArrayLoadOp>(op)) {
+      auto ldTy = ld.memref().getType();
+      if (auto boxTy = ldTy.dyn_cast<fir::BoxType>())
+        ldTy = boxTy.getEleTy();
+      if (ldTy.isa<fir::PointerType>() && stEleTy == dyn_cast_ptrEleTy(ldTy))
+        return true;
+      if (ld.memref() == addr) {
+        if (ld.getResult() != st.original())
+          return true;
+        if (load)
+          return true;
+        load = ld;
+      }
+    }
+  return false;
+}
+
+static bool conflictOnMerge(llvm::ArrayRef<mlir::Operation *> accesses) {
+  if (accesses.size() < 2)
+    return false;
+  llvm::SmallVector<mlir::Value> indices;
+  LLVM_DEBUG(llvm::dbgs() << "check merge conflict on with " << accesses.size()
+                          << " accesses on the list\n");
+  for (auto *op : accesses) {
+    llvm::SmallVector<mlir::Value> compareVector;
+    if (auto u = mlir::dyn_cast<ArrayUpdateOp>(op)) {
+      if (indices.empty()) {
+        indices = u.indices();
+        continue;
+      }
+      compareVector = u.indices();
+    } else if (auto f = mlir::dyn_cast<ArrayModifyOp>(op)) {
+      if (indices.empty()) {
+        indices = f.indices();
+        continue;
+      }
+      compareVector = f.indices();
+    } else if (auto f = mlir::dyn_cast<ArrayFetchOp>(op)) {
+      if (indices.empty()) {
+        indices = f.indices();
+        continue;
+      }
+      compareVector = f.indices();
+    } else {
+      mlir::emitError(op->getLoc(), "unexpected operation in analysis");
+    }
+    if (compareVector.size() != indices.size() ||
+        llvm::any_of(llvm::zip(compareVector, indices), [&](auto pair) {
+          return std::get<0>(pair) != std::get<1>(pair);
+        }))
+      return true;
+    LLVM_DEBUG(llvm::dbgs() << "vectors compare equal\n");
+  }
+  return false;
+}
+
+// Are either of types of conflicts present?
+inline bool conflictDetected(llvm::ArrayRef<mlir::Operation *> reach,
+                             llvm::ArrayRef<mlir::Operation *> accesses,
+                             ArrayMergeStoreOp st) {
+  return conflictOnLoad(reach, st) || conflictOnMerge(accesses);
+}
+
+/// Constructor of the array copy analysis.
+/// This performs the analysis and saves the intermediate results.
+void ArrayCopyAnalysis::construct(mlir::MutableArrayRef<mlir::Region> regions) {
+  for (auto &region : regions)
+    for (auto &block : region.getBlocks())
+      for (auto &op : block.getOperations()) {
+        if (op.getNumRegions())
+          construct(op.getRegions());
+        if (auto st = mlir::dyn_cast<fir::ArrayMergeStoreOp>(op)) {
+          llvm::SmallVector<Operation *> values;
+          ReachCollector::reachingValues(values, st.sequence());
+          llvm::SmallVector<Operation *> accesses;
+          arrayAccesses(accesses,
+                        mlir::cast<ArrayLoadOp>(st.original().getDefiningOp()));
+          if (conflictDetected(values, accesses, st)) {
+            LLVM_DEBUG(llvm::dbgs()
+                       << "CONFLICT: copies required for " << st << '\n'
+                       << "   adding conflicts on: " << op << " and "
+                       << st.original() << '\n');
+            conflicts.insert(&op);
+            conflicts.insert(st.original().getDefiningOp());
+          }
+          auto *ld = st.original().getDefiningOp();
+          LLVM_DEBUG(llvm::dbgs()
+                     << "map: adding {" << *ld << " -> " << st << "}\n");
+          useMap.insert({ld, &op});
+        } else if (auto load = mlir::dyn_cast<ArrayLoadOp>(op)) {
+          llvm::SmallVector<mlir::Operation *> accesses;
+          arrayAccesses(accesses, load);
+          LLVM_DEBUG(llvm::dbgs() << "process load: " << load
+                                  << ", accesses: " << accesses.size() << '\n');
+          for (auto *acc : accesses) {
+            LLVM_DEBUG(llvm::dbgs() << " access: " << *acc << '\n');
+            if (mlir::isa<ArrayFetchOp, ArrayUpdateOp, ArrayModifyOp>(acc)) {
+              if (useMap.count(acc)) {
+                mlir::emitError(
+                    load.getLoc(),
+                    "The parallel semantics of multiple array_merge_stores per "
+                    "array_load are not supported.");
+                continue;
+              }
+              LLVM_DEBUG(llvm::dbgs() << "map: adding {" << *acc << "} -> {"
+                                      << load << "}\n");
+              useMap.insert({acc, &op});
+            }
+          }
+        }
+      }
+}
+
+namespace {
+class ArrayLoadConversion : public mlir::OpRewritePattern<ArrayLoadOp> {
+public:
+  using OpRewritePattern::OpRewritePattern;
+
+  mlir::LogicalResult
+  matchAndRewrite(ArrayLoadOp load,
+                  mlir::PatternRewriter &rewriter) const override {
+    LLVM_DEBUG(llvm::dbgs() << "replace load " << load << " with undef.\n");
+    rewriter.replaceOpWithNewOp<UndefOp>(load, load.getType());
+    return mlir::success();
+  }
+};
+
+class ArrayMergeStoreConversion
+    : public mlir::OpRewritePattern<ArrayMergeStoreOp> {
+public:
+  using OpRewritePattern::OpRewritePattern;
+
+  mlir::LogicalResult
+  matchAndRewrite(ArrayMergeStoreOp store,
+                  mlir::PatternRewriter &rewriter) const override {
+    LLVM_DEBUG(llvm::dbgs() << "marking store " << store << " as dead.\n");
+    rewriter.eraseOp(store);
+    return mlir::success();
+  }
+};
+} // namespace
+
+static mlir::Type getEleTy(mlir::Type ty) {
+  if (auto t = dyn_cast_ptrEleTy(ty))
+    ty = t;
+  if (auto t = ty.dyn_cast<SequenceType>())
+    ty = t.getEleTy();
+  // FIXME: keep ptr/heap/ref information.
+  return ReferenceType::get(ty);
+}
+
+// Extract extents from the ShapeOp/ShapeShiftOp into the result vector.
+static void getExtents(llvm::SmallVectorImpl<mlir::Value> &result,
+                       mlir::Value shape) {
+  auto *shapeOp = shape.getDefiningOp();
+  if (auto s = mlir::dyn_cast<fir::ShapeOp>(shapeOp)) {
+    auto e = s.getExtents();
+    result.insert(result.end(), e.begin(), e.end());
+    return;
+  }
+  if (auto s = mlir::dyn_cast<fir::ShapeShiftOp>(shapeOp)) {
+    auto e = s.getExtents();
+    result.insert(result.end(), e.begin(), e.end());
+    return;
+  }
+  llvm::report_fatal_error("not a fir.shape/fir.shape_shift op");
+}
+
+// Place the extents of the array loaded by an ArrayLoadOp into the result
+// vector and return a ShapeOp/ShapeShiftOp with the corresponding extents. If
+// the ArrayLoadOp is loading a fir.box, code will be generated to read the
+// extents from the fir.box, and a the retunred ShapeOp is built with the read
+// extents.
+// Otherwise, the extents will be extracted from the ShapeOp/ShapeShiftOp
+// argument of the ArrayLoadOp that is returned.
+static mlir::Value
+getOrReadExtentsAndShapeOp(mlir::Location loc, mlir::PatternRewriter &rewriter,
+                           fir::ArrayLoadOp loadOp,
+                           llvm::SmallVectorImpl<mlir::Value> &result) {
+  assert(result.empty());
+  if (auto boxTy = loadOp.memref().getType().dyn_cast<fir::BoxType>()) {
+    auto rank = fir::dyn_cast_ptrOrBoxEleTy(boxTy)
+                    .cast<fir::SequenceType>()
+                    .getDimension();
+    auto idxTy = rewriter.getIndexType();
+    for (decltype(rank) dim = 0; dim < rank; ++dim) {
+      auto dimVal = rewriter.create<mlir::ConstantIndexOp>(loc, dim);
+      auto dimInfo = rewriter.create<fir::BoxDimsOp>(loc, idxTy, idxTy, idxTy,
+                                                     loadOp.memref(), dimVal);
+      result.emplace_back(dimInfo.getResult(1));
+    }
+    auto shapeType = fir::ShapeType::get(rewriter.getContext(), rank);
+    return rewriter.create<fir::ShapeOp>(loc, shapeType, result);
+  }
+  getExtents(result, loadOp.shape());
+  return loadOp.shape();
+}
+
+static mlir::Type toRefType(mlir::Type ty) {
+  if (fir::isa_ref_type(ty))
+    return ty;
+  return fir::ReferenceType::get(ty);
+}
+
+static mlir::Value
+genCoorOp(mlir::PatternRewriter &rewriter, mlir::Location loc, mlir::Type eleTy,
+          mlir::Type resTy, mlir::Value alloc, mlir::Value shape,
+          mlir::Value slice, mlir::ValueRange indices,
+          mlir::ValueRange typeparams, bool skipOrig = false) {
+  llvm::SmallVector<mlir::Value> originated;
+  if (skipOrig)
+    originated.assign(indices.begin(), indices.end());
+  else
+    originated = fir::factory::originateIndices(loc, rewriter, alloc.getType(),
+                                                shape, indices);
+  auto seqTy = fir::dyn_cast_ptrOrBoxEleTy(alloc.getType());
+  assert(seqTy && seqTy.isa<fir::SequenceType>());
+  const auto dimension = seqTy.cast<fir::SequenceType>().getDimension();
+  mlir::Value result = rewriter.create<fir::ArrayCoorOp>(
+      loc, eleTy, alloc, shape, slice,
+      llvm::ArrayRef<mlir::Value>{originated}.take_front(dimension),
+      typeparams);
+  if (dimension < originated.size())
+    result = rewriter.create<fir::CoordinateOp>(
+        loc, resTy, result,
+        llvm::ArrayRef<mlir::Value>{originated}.drop_front(dimension));
+  return result;
+}
+
+namespace {
+/// Conversion of fir.array_update and fir.array_modify Ops.
+/// If there is a conflict for the update, then we need to perform a
+/// copy-in/copy-out to preserve the original values of the array. If there is
+/// no conflict, then it is save to eschew making any copies.
+template <typename ArrayOp>
+class ArrayUpdateConversionBase : public mlir::OpRewritePattern<ArrayOp> {
+public:
+  explicit ArrayUpdateConversionBase(mlir::MLIRContext *ctx,
+                                     const ArrayCopyAnalysis &a,
+                                     const OperationUseMapT &m)
+      : mlir::OpRewritePattern<ArrayOp>{ctx}, analysis{a}, useMap{m} {}
+
+  static llvm::SmallVector<mlir::Value> recoverTypeParams(mlir::Value val) {
+    auto *op = val.getDefiningOp();
+    if (!fir::hasDynamicSize(fir::dyn_cast_ptrEleTy(val.getType())))
+      return {};
+    if (auto co = mlir::dyn_cast<fir::ConvertOp>(op))
+      return recoverTypeParams(co.value());
+    if (auto ao = mlir::dyn_cast<fir::ArrayFetchOp>(op))
+      return {ao.typeparams().begin(), ao.typeparams().end()};
+    if (auto ao = mlir::dyn_cast<fir::ArrayUpdateOp>(op))
+      return {ao.typeparams().begin(), ao.typeparams().end()};
+    if (auto ao = mlir::dyn_cast<fir::ArrayModifyOp>(op))
+      return {ao.typeparams().begin(), ao.typeparams().end()};
+    if (auto ao = mlir::dyn_cast<fir::ArrayLoadOp>(op))
+      return {ao.typeparams().begin(), ao.typeparams().end()};
+    if (auto ao = mlir::dyn_cast<fir::ArrayCoorOp>(op))
+      return {ao.typeparams().begin(), ao.typeparams().end()};
+    if (auto ao = mlir::dyn_cast<fir::AllocaOp>(op))
+      return {ao.typeparams().begin(), ao.typeparams().end()};
+    if (auto ao = mlir::dyn_cast<fir::AllocMemOp>(op))
+      return {ao.typeparams().begin(), ao.typeparams().end()};
+    llvm::report_fatal_error("unexpected buffer");
+  }
+
+  static mlir::Value recoverCharLen(mlir::Value val) {
+    auto params = recoverTypeParams(val);
+    return params.empty() ? mlir::Value{} : params[0];
+  }
+
+  void genArrayCopy(mlir::Location loc, mlir::PatternRewriter &rewriter,
+                    mlir::Value dst, mlir::Value src, mlir::Value shapeOp,
+                    mlir::Type arrTy) const {
+    auto insPt = rewriter.saveInsertionPoint();
+    llvm::SmallVector<mlir::Value> indices;
+    llvm::SmallVector<mlir::Value> extents;
+    getExtents(extents, shapeOp);
+    // Build loop nest from column to row.
+    for (auto sh : llvm::reverse(extents)) {
+      auto idxTy = rewriter.getIndexType();
+      auto ubi = rewriter.create<fir::ConvertOp>(loc, idxTy, sh);
+      auto zero = rewriter.create<mlir::ConstantIndexOp>(loc, 0);
+      auto one = rewriter.create<mlir::ConstantIndexOp>(loc, 1);
+      auto ub = rewriter.create<mlir::SubIOp>(loc, idxTy, ubi, one);
+      auto loop = rewriter.create<fir::DoLoopOp>(loc, zero, ub, one);
+      rewriter.setInsertionPointToStart(loop.getBody());
+      indices.push_back(loop.getInductionVar());
+    }
+    // Reverse the indices so they are in column-major order.
+    std::reverse(indices.begin(), indices.end());
+    auto ty = getEleTy(arrTy);
+    auto fromAddr = rewriter.create<fir::ArrayCoorOp>(
+        loc, ty, src, shapeOp, mlir::Value{},
+        fir::factory::originateIndices(loc, rewriter, src.getType(), shapeOp,
+                                       indices),
+        mlir::ValueRange{});
+    auto load = rewriter.create<fir::LoadOp>(loc, fromAddr);
+    auto toAddr = rewriter.create<fir::ArrayCoorOp>(
+        loc, ty, dst, shapeOp, mlir::Value{},
+        fir::factory::originateIndices(loc, rewriter, dst.getType(), shapeOp,
+                                       indices),
+        mlir::ValueRange{});
+    rewriter.create<fir::StoreOp>(loc, load, toAddr);
+    rewriter.restoreInsertionPoint(insPt);
+  }
+
+  /// Copy the RHS element into the LHS and insert copy-in/copy-out between a
+  /// temp and the LHS if the analysis found potential overlaps between the RHS
+  /// and LHS arrays. The element copy generator must be provided through \p
+  /// assignElement. \p update must be the ArrayUpdateOp or the ArrayModifyOp.
+  /// Returns the address of the LHS element inside the loop and the LHS
+  /// ArrayLoad result.
+  std::pair<mlir::Value, mlir::Value>
+  materializeAssignment(mlir::Location loc, mlir::PatternRewriter &rewriter,
+                        ArrayOp update,
+                        const std::function<void(mlir::Value)> &assignElement,
+                        mlir::Type lhsEltRefType) const {
+    auto *op = update.getOperation();
+    auto *loadOp = useMap.lookup(op);
+    auto load = mlir::cast<ArrayLoadOp>(loadOp);
+    LLVM_DEBUG(llvm::outs() << "does " << load << " have a conflict?\n");
+    if (analysis.hasPotentialConflict(loadOp)) {
+      // If there is a conflict between the arrays, then we copy the lhs array
+      // to a temporary, update the temporary, and copy the temporary back to
+      // the lhs array. This yields Fortran's copy-in copy-out array semantics.
+      LLVM_DEBUG(llvm::outs() << "Yes, conflict was found\n");
+      rewriter.setInsertionPoint(loadOp);
+      // Copy in.
+      llvm::SmallVector<mlir::Value> extents;
+      auto shapeOp = getOrReadExtentsAndShapeOp(loc, rewriter, load, extents);
+      auto allocmem = rewriter.create<AllocMemOp>(
+          loc, dyn_cast_ptrOrBoxEleTy(load.memref().getType()),
+          load.typeparams(), extents);
+      genArrayCopy(load.getLoc(), rewriter, allocmem, load.memref(), shapeOp,
+                   load.getType());
+      rewriter.setInsertionPoint(op);
+      auto coor = genCoorOp(
+          rewriter, loc, getEleTy(load.getType()), lhsEltRefType, allocmem,
+          shapeOp, load.slice(), update.indices(), load.typeparams(),
+          update->hasAttr(fir::factory::attrFortranArrayOffsets()));
+      assignElement(coor);
+      auto *storeOp = useMap.lookup(loadOp);
+      auto store = mlir::cast<ArrayMergeStoreOp>(storeOp);
+      rewriter.setInsertionPoint(storeOp);
+      // Copy out.
+      genArrayCopy(store.getLoc(), rewriter, store.memref(), allocmem, shapeOp,
+                   load.getType());
+      rewriter.create<FreeMemOp>(loc, allocmem);
+      return {coor, load.getResult()};
+    }
+    // Otherwise, when there is no conflict (a possible loop-carried
+    // dependence), the lhs array can be updated in place.
+    LLVM_DEBUG(llvm::outs() << "No, conflict wasn't found\n");
+    rewriter.setInsertionPoint(op);
+    auto coorTy = getEleTy(load.getType());
+    auto coor = genCoorOp(
+        rewriter, loc, coorTy, lhsEltRefType, load.memref(), load.shape(),
+        load.slice(), update.indices(), load.typeparams(),
+        update->hasAttr(fir::factory::attrFortranArrayOffsets()));
+    assignElement(coor);
+    return {coor, load.getResult()};
+  }
+
+private:
+  const ArrayCopyAnalysis &analysis;
+  const OperationUseMapT &useMap;
+};
+
+class ArrayUpdateConversion : public ArrayUpdateConversionBase<ArrayUpdateOp> {
+public:
+  explicit ArrayUpdateConversion(mlir::MLIRContext *ctx,
+                                 const ArrayCopyAnalysis &a,
+                                 const OperationUseMapT &m)
+      : ArrayUpdateConversionBase{ctx, a, m} {}
+
+  mlir::LogicalResult
+  matchAndRewrite(ArrayUpdateOp update,
+                  mlir::PatternRewriter &rewriter) const override {
+    auto loc = update.getLoc();
+    auto assignElement = [&](mlir::Value coor) {
+      auto input = update.merge();
+      if (auto inEleTy = fir::dyn_cast_ptrEleTy(input.getType())) {
+        [[maybe_unused]] auto outEleTy =
+            fir::unwrapSequenceType(update.getType());
+        if (auto inChrTy = inEleTy.dyn_cast<fir::CharacterType>()) {
+          assert(outEleTy.isa<fir::CharacterType>());
+          fir::factory::genCharacterCopy(input, recoverCharLen(input), coor,
+                                         recoverCharLen(coor), rewriter, loc);
+        } else if (inEleTy.isa<fir::RecordType>()) {
+          fir::FirOpBuilder builder(
+              rewriter,
+              fir::getKindMapping(update->getParentOfType<mlir::ModuleOp>()));
+          if (!update.typeparams().empty()) {
+            auto boxTy = fir::BoxType::get(inEleTy);
+            mlir::Value emptyShape, emptySlice;
+            auto lhs = rewriter.create<EmboxOp>(
+                loc, boxTy, coor, emptyShape, emptySlice, update.typeparams());
+            auto rhs = rewriter.create<EmboxOp>(
+                loc, boxTy, input, emptyShape, emptySlice, update.typeparams());
+            fir::factory::genRecordAssignment(builder, loc, fir::BoxValue(lhs),
+                                              fir::BoxValue(rhs));
+          } else {
+            fir::factory::genRecordAssignment(builder, loc, coor, input);
+          }
+        } else {
+          llvm::report_fatal_error("not a legal reference type");
+        }
+      } else {
+        rewriter.create<fir::StoreOp>(loc, input, coor);
+      }
+    };
+    auto lhsEltRefType = toRefType(update.merge().getType());
+    auto [_, lhsLoadResult] = materializeAssignment(
+        loc, rewriter, update, assignElement, lhsEltRefType);
+    update.replaceAllUsesWith(lhsLoadResult);
+    rewriter.replaceOp(update, lhsLoadResult);
+    return mlir::success();
+  }
+};
+
+class ArrayModifyConversion : public ArrayUpdateConversionBase<ArrayModifyOp> {
+public:
+  explicit ArrayModifyConversion(mlir::MLIRContext *ctx,
+                                 const ArrayCopyAnalysis &a,
+                                 const OperationUseMapT &m)
+      : ArrayUpdateConversionBase{ctx, a, m} {}
+
+  mlir::LogicalResult
+  matchAndRewrite(ArrayModifyOp modify,
+                  mlir::PatternRewriter &rewriter) const override {
+    auto loc = modify.getLoc();
+    auto assignElement = [](mlir::Value) {
+      // Assignment already materialized by lowering using lhs element address.
+    };
+    auto lhsEltRefType = modify.getResult(0).getType();
+    auto [lhsEltCoor, lhsLoadResult] = materializeAssignment(
+        loc, rewriter, modify, assignElement, lhsEltRefType);
+    modify.replaceAllUsesWith(mlir::ValueRange{lhsEltCoor, lhsLoadResult});
+    rewriter.replaceOp(modify, mlir::ValueRange{lhsEltCoor, lhsLoadResult});
+    return mlir::success();
+  }
+};
+
+class ArrayFetchConversion : public mlir::OpRewritePattern<ArrayFetchOp> {
+public:
+  explicit ArrayFetchConversion(mlir::MLIRContext *ctx,
+                                const OperationUseMapT &m)
+      : OpRewritePattern{ctx}, useMap{m} {}
+
+  mlir::LogicalResult
+  matchAndRewrite(ArrayFetchOp fetch,
+                  mlir::PatternRewriter &rewriter) const override {
+    auto *op = fetch.getOperation();
+    rewriter.setInsertionPoint(op);
+    auto load = mlir::cast<ArrayLoadOp>(useMap.lookup(op));
+    auto loc = fetch.getLoc();
+    auto coor =
+        genCoorOp(rewriter, loc, getEleTy(load.getType()),
+                  toRefType(fetch.getType()), load.memref(), load.shape(),
+                  load.slice(), fetch.indices(), load.typeparams(),
+                  fetch->hasAttr(fir::factory::attrFortranArrayOffsets()));
+    if (fir::isa_ref_type(fetch.getType()))
+      rewriter.replaceOp(fetch, coor);
+    else
+      rewriter.replaceOpWithNewOp<fir::LoadOp>(fetch, coor);
+    return mlir::success();
+  }
+
+private:
+  const OperationUseMapT &useMap;
+};
+} // namespace
+
+namespace {
+class ArrayValueCopyConverter
+    : public ArrayValueCopyBase<ArrayValueCopyConverter> {
+public:
+  void runOnFunction() override {
+    auto func = getFunction();
+    LLVM_DEBUG(llvm::dbgs() << "\n\narray-value-copy pass on function '"
+                            << func.getName() << "'\n");
+    auto *context = &getContext();
+
+    // Perform the conflict analysis.
+    auto &analysis = getAnalysis<ArrayCopyAnalysis>();
+    const auto &useMap = analysis.getUseMap();
+
+    mlir::OwningRewritePatternList patterns1(context);
+    patterns1.insert<ArrayFetchConversion>(context, useMap);
+    patterns1.insert<ArrayUpdateConversion>(context, analysis, useMap);
+    patterns1.insert<ArrayModifyConversion>(context, analysis, useMap);
+    mlir::ConversionTarget target(*context);
+    target.addLegalDialect<FIROpsDialect, mlir::scf::SCFDialect,
+                           mlir::StandardOpsDialect>();
+    target.addIllegalOp<ArrayFetchOp, ArrayUpdateOp, ArrayModifyOp>();
+    // Rewrite the array fetch and array update ops.
+    if (mlir::failed(
+            mlir::applyPartialConversion(func, target, std::move(patterns1)))) {
+      mlir::emitError(mlir::UnknownLoc::get(context),
+                      "failure in array-value-copy pass, phase 1");
+      signalPassFailure();
+    }
+
+    mlir::OwningRewritePatternList patterns2(context);
+    patterns2.insert<ArrayLoadConversion>(context);
+    patterns2.insert<ArrayMergeStoreConversion>(context);
+    target.addIllegalOp<ArrayLoadOp, ArrayMergeStoreOp>();
+    if (mlir::failed(
+            mlir::applyPartialConversion(func, target, std::move(patterns2)))) {
+      mlir::emitError(mlir::UnknownLoc::get(context),
+                      "failure in array-value-copy pass, phase 2");
+      signalPassFailure();
+    }
+  }
+};
+} // namespace
+
+std::unique_ptr<mlir::Pass> fir::createArrayValueCopyPass() {
+  return std::make_unique<ArrayValueCopyConverter>();
+}

flang/lib/Optimizer/Transforms/CMakeLists.txt

 add_flang_library(FIRTransforms
+  ArrayValueCopy.cpp
   Inliner.cpp
   ExternalNameConversion.cpp
 
   DEPENDS
+  FIRBuilder
   FIRDialect
   FIRSupport
   FIROptTransformsPassIncGen
 
   LINK_LIBS
+  FIRBuilder
   FIRDialect
   MLIRAffineToStandard
   MLIRLLVMIR
   MLIROpenACC
   MLIROpenMP
   FIRSupport
 )

flang/test/Fir/array-modify.f90

+// Test array-copy-value pass (copy elision) with fir.array_modify
+// RUN: fir-opt %s --array-value-copy | FileCheck %s
+
+// Test user_defined_assignment(arg0(:), arg1(:))
+func @no_overlap(%arg0: !fir.ref<!fir.array<100xf32>>, %arg1: !fir.ref<!fir.array<100xf32>>) {
+  %c100 = constant 100 : index
+  %c99 = constant 99 : index
+  %c1 = constant 1 : index
+  %c0 = constant 0 : index
+  %0 = fir.alloca f32
+  %1 = fir.shape %c100 : (index) -> !fir.shape<1>
+  %2 = fir.array_load %arg0(%1) : (!fir.ref<!fir.array<100xf32>>, !fir.shape<1>) -> !fir.array<100xf32>
+  %3 = fir.array_load %arg1(%1) : (!fir.ref<!fir.array<100xf32>>, !fir.shape<1>) -> !fir.array<100xf32>
+  %4 = fir.do_loop %arg2 = %c0 to %c99 step %c1 unordered iter_args(%arg3 = %2) -> (!fir.array<100xf32>) {
+    %5 = fir.array_fetch %3, %arg2 : (!fir.array<100xf32>, index) -> f32
+    %6:2 = fir.array_modify %arg3, %arg2 : (!fir.array<100xf32>, index) -> (!fir.ref<f32>, !fir.array<100xf32>)
+    fir.store %5 to %0 : !fir.ref<f32>
+    fir.call @user_defined_assignment(%6#0, %0) : (!fir.ref<f32>, !fir.ref<f32>) -> ()
+    fir.result %6#1 : !fir.array<100xf32>
+  }
+  fir.array_merge_store %2, %4 to %arg0 : !fir.array<100xf32>, !fir.array<100xf32>, !fir.ref<!fir.array<100xf32>>
+  return
+}
+// CHECK-LABEL:   func @no_overlap(
+// CHECK-SAME:                     %[[VAL_0:.*]]: !fir.ref<!fir.array<100xf32>>,
+// CHECK-SAME:                     %[[VAL_1:.*]]: !fir.ref<!fir.array<100xf32>>) {
+// CHECK-DAG:           %[[VAL_2:.*]] = constant 100 : index
+// CHECK-DAG:           %[[VAL_3:.*]] = constant 99 : index
+// CHECK-DAG:           %[[VAL_4:.*]] = constant 1 : index
+// CHECK-DAG:           %[[VAL_5:.*]] = constant 0 : index
+// CHECK:           %[[VAL_6:.*]] = fir.alloca f32
+// CHECK:           %[[VAL_7:.*]] = fir.shape %[[VAL_2]] : (index) -> !fir.shape<1>
+// CHECK:           %[[VAL_8:.*]] = fir.undefined !fir.array<100xf32>
+// CHECK:           %[[VAL_9:.*]] = fir.undefined !fir.array<100xf32>
+// CHECK:           %[[VAL_10:.*]] = fir.do_loop %[[VAL_11:.*]] = %[[VAL_5]] to %[[VAL_3]] step %[[VAL_4]] unordered iter_args(%[[VAL_12:.*]] = %[[VAL_8]]) -> (!fir.array<100xf32>) {
+// CHECK:             %[[VAL_13:.*]] = constant 1 : index
+// CHECK:             %[[VAL_14:.*]] = addi %[[VAL_11]], %[[VAL_13]] : index
+// CHECK:             %[[VAL_15:.*]] = fir.array_coor %[[VAL_1]](%[[VAL_7]]) %[[VAL_14]] : (!fir.ref<!fir.array<100xf32>>, !fir.shape<1>, index) -> !fir.ref<f32>
+// CHECK:             %[[VAL_16:.*]] = fir.load %[[VAL_15]] : !fir.ref<f32>
+// CHECK:             %[[VAL_17:.*]] = constant 1 : index
+// CHECK:             %[[VAL_18:.*]] = addi %[[VAL_11]], %[[VAL_17]] : index
+// CHECK:             %[[VAL_19:.*]] = fir.array_coor %[[VAL_0]](%[[VAL_7]]) %[[VAL_18]] : (!fir.ref<!fir.array<100xf32>>, !fir.shape<1>, index) -> !fir.ref<f32>
+// CHECK:             fir.store %[[VAL_16]] to %[[VAL_6]] : !fir.ref<f32>
+// CHECK:             fir.call @user_defined_assignment(%[[VAL_19]], %[[VAL_6]]) : (!fir.ref<f32>, !fir.ref<f32>) -> ()
+// CHECK:             fir.result %[[VAL_8]] : !fir.array<100xf32>
+// CHECK:           }
+// CHECK:           return
+// CHECK:         }
+
+
+// Test user_defined_assignment(arg0(:), arg0(100:1:-1))
+func @overlap(%arg0: !fir.ref<!fir.array<100xf32>>) {
+  %c100 = constant 100 : index
+  %c99 = constant 99 : index
+  %c1 = constant 1 : index
+  %c-1 = constant -1 : index
+  %c0 = constant 0 : index
+  %0 = fir.alloca f32
+  %1 = fir.shape %c100 : (index) -> !fir.shape<1>
+  %2 = fir.array_load %arg0(%1) : (!fir.ref<!fir.array<100xf32>>, !fir.shape<1>) -> !fir.array<100xf32>
+  %3 = fir.slice %c100, %c1, %c-1 : (index, index, index) -> !fir.slice<1>
+  %4 = fir.array_load %arg0(%1) [%3] : (!fir.ref<!fir.array<100xf32>>, !fir.shape<1>, !fir.slice<1>) -> !fir.array<100xf32>
+  %5 = fir.do_loop %arg1 = %c0 to %c99 step %c1 unordered iter_args(%arg2 = %2) -> (!fir.array<100xf32>) {
+    %6 = fir.array_fetch %4, %arg1 : (!fir.array<100xf32>, index) -> f32
+    %7:2 = fir.array_modify %arg2, %arg1 : (!fir.array<100xf32>, index) -> (!fir.ref<f32>, !fir.array<100xf32>)
+    fir.store %6 to %0 : !fir.ref<f32>
+    fir.call @user_defined_assignment(%7#0, %0) : (!fir.ref<f32>, !fir.ref<f32>) -> ()
+    fir.result %7#1 : !fir.array<100xf32>
+  }
+  fir.array_merge_store %2, %5 to %arg0 : !fir.array<100xf32>, !fir.array<100xf32>, !fir.ref<!fir.array<100xf32>>
+  return
+}
+// CHECK-LABEL:   func @overlap(
+// CHECK-SAME:                  %[[VAL_0:.*]]: !fir.ref<!fir.array<100xf32>>) {
+// CHECK-DAG:           %[[VAL_1:.*]] = constant 100 : index
+// CHECK-DAG:           %[[VAL_2:.*]] = constant 99 : index
+// CHECK-DAG:           %[[VAL_3:.*]] = constant 1 : index
+// CHECK-DAG:           %[[VAL_4:.*]] = constant -1 : index
+// CHECK-DAG:           %[[VAL_5:.*]] = constant 0 : index
+// CHECK:           %[[VAL_6:.*]] = fir.alloca f32
+// CHECK:           %[[VAL_7:.*]] = fir.shape %[[VAL_1]] : (index) -> !fir.shape<1>
+// CHECK:           %[[VAL_8:.*]] = fir.allocmem !fir.array<100xf32>, %[[VAL_1]]
+// CHECK:           %[[VAL_9:.*]] = fir.convert %[[VAL_1]] : (index) -> index
+// CHECK:           %[[VAL_10:.*]] = constant 0 : index
+// CHECK:           %[[VAL_11:.*]] = constant 1 : index
+// CHECK:           %[[VAL_12:.*]] = subi %[[VAL_9]], %[[VAL_11]] : index
+// CHECK:           fir.do_loop %[[VAL_13:.*]] = %[[VAL_10]] to %[[VAL_12]] step %[[VAL_11]] {
+// CHECK:             %[[VAL_14:.*]] = constant 1 : index
+// CHECK:             %[[VAL_15:.*]] = addi %[[VAL_13]], %[[VAL_14]] : index
+// CHECK:             %[[VAL_16:.*]] = fir.array_coor %[[VAL_0]](%[[VAL_7]]) %[[VAL_15]] : (!fir.ref<!fir.array<100xf32>>, !fir.shape<1>, index) -> !fir.ref<f32>
+// CHECK:             %[[VAL_17:.*]] = fir.load %[[VAL_16]] : !fir.ref<f32>
+// CHECK:             %[[VAL_18:.*]] = constant 1 : index
+// CHECK:             %[[VAL_19:.*]] = addi %[[VAL_13]], %[[VAL_18]] : index
+// CHECK:             %[[VAL_20:.*]] = fir.array_coor %[[VAL_8]](%[[VAL_7]]) %[[VAL_19]] : (!fir.heap<!fir.array<100xf32>>, !fir.shape<1>, index) -> !fir.ref<f32>
+// CHECK:             fir.store %[[VAL_17]] to %[[VAL_20]] : !fir.ref<f32>
+// CHECK:           }
+// CHECK:           %[[VAL_21:.*]] = fir.undefined !fir.array<100xf32>
+// CHECK:           %[[VAL_22:.*]] = fir.slice %[[VAL_1]], %[[VAL_3]], %[[VAL_4]] : (index, index, index) -> !fir.slice<1>
+// CHECK:           %[[VAL_23:.*]] = fir.undefined !fir.array<100xf32>
+// CHECK:           %[[VAL_24:.*]] = fir.do_loop %[[VAL_25:.*]] = %[[VAL_5]] to %[[VAL_2]] step %[[VAL_3]] unordered iter_args(%[[VAL_26:.*]] = %[[VAL_21]]) -> (!fir.array<100xf32>) {
+// CHECK:             %[[VAL_27:.*]] = constant 1 : index
+// CHECK:             %[[VAL_28:.*]] = addi %[[VAL_25]], %[[VAL_27]] : index
+// CHECK:             %[[VAL_29:.*]] = fir.array_coor %[[VAL_0]](%[[VAL_7]]) {{\[}}%[[VAL_22]]] %[[VAL_28]] : (!fir.ref<!fir.array<100xf32>>, !fir.shape<1>, !fir.slice<1>, index) -> !fir.ref<f32>
+// CHECK:             %[[VAL_30:.*]] = fir.load %[[VAL_29]] : !fir.ref<f32>
+// CHECK:             %[[VAL_31:.*]] = constant 1 : index
+// CHECK:             %[[VAL_32:.*]] = addi %[[VAL_25]], %[[VAL_31]] : index
+// CHECK:             %[[VAL_33:.*]] = fir.array_coor %[[VAL_8]](%[[VAL_7]]) %[[VAL_32]] : (!fir.heap<!fir.array<100xf32>>, !fir.shape<1>, index) -> !fir.ref<f32>
+// CHECK:             fir.store %[[VAL_30]] to %[[VAL_6]] : !fir.ref<f32>
+// CHECK:             fir.call @user_defined_assignment(%[[VAL_33]], %[[VAL_6]]) : (!fir.ref<f32>, !fir.ref<f32>) -> ()
+// CHECK:             fir.result %[[VAL_21]] : !fir.array<100xf32>
+// CHECK:           }
+// CHECK:           %[[VAL_34:.*]] = fir.convert %[[VAL_1]] : (index) -> index
+// CHECK:           %[[VAL_35:.*]] = constant 0 : index
+// CHECK:           %[[VAL_36:.*]] = constant 1 : index
+// CHECK:           %[[VAL_37:.*]] = subi %[[VAL_34]], %[[VAL_36]] : index
+// CHECK:           fir.do_loop %[[VAL_38:.*]] = %[[VAL_35]] to %[[VAL_37]] step %[[VAL_36]] {
+// CHECK:             %[[VAL_39:.*]] = constant 1 : index
+// CHECK:             %[[VAL_40:.*]] = addi %[[VAL_38]], %[[VAL_39]] : index
+// CHECK:             %[[VAL_41:.*]] = fir.array_coor %[[VAL_8]](%[[VAL_7]]) %[[VAL_40]] : (!fir.heap<!fir.array<100xf32>>, !fir.shape<1>, index) -> !fir.ref<f32>
+// CHECK:             %[[VAL_42:.*]] = fir.load %[[VAL_41]] : !fir.ref<f32>
+// CHECK:             %[[VAL_43:.*]] = constant 1 : index
+// CHECK:             %[[VAL_44:.*]] = addi %[[VAL_38]], %[[VAL_43]] : index
+// CHECK:             %[[VAL_45:.*]] = fir.array_coor %[[VAL_0]](%[[VAL_7]]) %[[VAL_44]] : (!fir.ref<!fir.array<100xf32>>, !fir.shape<1>, index) -> !fir.ref<f32>
+// CHECK:             fir.store %[[VAL_42]] to %[[VAL_45]] : !fir.ref<f32>
+// CHECK:           }
+// CHECK:           fir.freemem %[[VAL_8]] : !fir.heap<!fir.array<100xf32>>
+// CHECK:           return
+// CHECK:         }
+
+func private @user_defined_assignment(!fir.ref<f32>, !fir.ref<f32>)