/
ConvertExpr.cpp
7469 lines (7013 loc) · 332 KB
/
ConvertExpr.cpp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
//===-- ConvertExpr.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/Lower/ConvertExpr.h"
#include "flang/Common/default-kinds.h"
#include "flang/Common/unwrap.h"
#include "flang/Evaluate/fold.h"
#include "flang/Evaluate/real.h"
#include "flang/Evaluate/traverse.h"
#include "flang/Lower/Allocatable.h"
#include "flang/Lower/Bridge.h"
#include "flang/Lower/BuiltinModules.h"
#include "flang/Lower/CallInterface.h"
#include "flang/Lower/Coarray.h"
#include "flang/Lower/ComponentPath.h"
#include "flang/Lower/ConvertCall.h"
#include "flang/Lower/ConvertConstant.h"
#include "flang/Lower/ConvertType.h"
#include "flang/Lower/ConvertVariable.h"
#include "flang/Lower/CustomIntrinsicCall.h"
#include "flang/Lower/DumpEvaluateExpr.h"
#include "flang/Lower/IntrinsicCall.h"
#include "flang/Lower/Mangler.h"
#include "flang/Lower/Runtime.h"
#include "flang/Lower/Support/Utils.h"
#include "flang/Optimizer/Builder/Character.h"
#include "flang/Optimizer/Builder/Complex.h"
#include "flang/Optimizer/Builder/Factory.h"
#include "flang/Optimizer/Builder/Runtime/Assign.h"
#include "flang/Optimizer/Builder/Runtime/Character.h"
#include "flang/Optimizer/Builder/Runtime/Derived.h"
#include "flang/Optimizer/Builder/Runtime/Inquiry.h"
#include "flang/Optimizer/Builder/Runtime/RTBuilder.h"
#include "flang/Optimizer/Builder/Runtime/Ragged.h"
#include "flang/Optimizer/Builder/Todo.h"
#include "flang/Optimizer/Dialect/FIRAttr.h"
#include "flang/Optimizer/Dialect/FIRDialect.h"
#include "flang/Optimizer/Dialect/FIROpsSupport.h"
#include "flang/Optimizer/Support/FatalError.h"
#include "flang/Runtime/support.h"
#include "flang/Semantics/expression.h"
#include "flang/Semantics/symbol.h"
#include "flang/Semantics/tools.h"
#include "flang/Semantics/type.h"
#include "mlir/Dialect/Func/IR/FuncOps.h"
#include "llvm/ADT/TypeSwitch.h"
#include "llvm/Support/CommandLine.h"
#include "llvm/Support/Debug.h"
#include "llvm/Support/ErrorHandling.h"
#include "llvm/Support/raw_ostream.h"
#include <algorithm>
#include <optional>
#define DEBUG_TYPE "flang-lower-expr"
using namespace Fortran::runtime;
//===----------------------------------------------------------------------===//
// The composition and structure of Fortran::evaluate::Expr is defined in
// the various header files in include/flang/Evaluate. You are referred
// there for more information on these data structures. Generally speaking,
// these data structures are a strongly typed family of abstract data types
// that, composed as trees, describe the syntax of Fortran expressions.
//
// This part of the bridge can traverse these tree structures and lower them
// to the correct FIR representation in SSA form.
//===----------------------------------------------------------------------===//
static llvm::cl::opt<bool> generateArrayCoordinate(
"gen-array-coor",
llvm::cl::desc("in lowering create ArrayCoorOp instead of CoordinateOp"),
llvm::cl::init(false));
// The default attempts to balance a modest allocation size with expected user
// input to minimize bounds checks and reallocations during dynamic array
// construction. Some user codes may have very large array constructors for
// which the default can be increased.
static llvm::cl::opt<unsigned> clInitialBufferSize(
"array-constructor-initial-buffer-size",
llvm::cl::desc(
"set the incremental array construction buffer size (default=32)"),
llvm::cl::init(32u));
// Lower TRANSPOSE as an "elemental" function that swaps the array
// expression's iteration space, so that no runtime call is needed.
// This lowering may help get rid of unnecessary creation of temporary
// arrays. Note that the runtime TRANSPOSE implementation may be different
// from the "inline" FIR, e.g. it may diagnose out-of-memory conditions
// during the temporary allocation whereas the inline implementation
// relies on AllocMemOp that will silently return null in case
// there is not enough memory.
//
// If it is set to false, then TRANSPOSE will be lowered using
// a runtime call. If it is set to true, then the lowering is controlled
// by LoweringOptions::optimizeTranspose bit (see isTransposeOptEnabled
// function in this file).
static llvm::cl::opt<bool> optimizeTranspose(
"opt-transpose",
llvm::cl::desc("lower transpose without using a runtime call"),
llvm::cl::init(true));
// When copy-in/copy-out is generated for a boxed object we may
// either produce loops to copy the data or call the Fortran runtime's
// Assign function. Since the data copy happens under a runtime check
// (for IsContiguous) the copy loops can hardly provide any value
// to optimizations, instead, the optimizer just wastes compilation
// time on these loops.
//
// This internal option will force the loops generation, when set
// to true. It is false by default.
//
// Note that for copy-in/copy-out of non-boxed objects (e.g. for passing
// arguments by value) we always generate loops. Since the memory for
// such objects is contiguous, it may be better to expose them
// to the optimizer.
static llvm::cl::opt<bool> inlineCopyInOutForBoxes(
"inline-copyinout-for-boxes",
llvm::cl::desc(
"generate loops for copy-in/copy-out of objects with descriptors"),
llvm::cl::init(false));
/// The various semantics of a program constituent (or a part thereof) as it may
/// appear in an expression.
///
/// Given the following Fortran declarations.
/// ```fortran
/// REAL :: v1, v2, v3
/// REAL, POINTER :: vp1
/// REAL :: a1(c), a2(c)
/// REAL ELEMENTAL FUNCTION f1(arg) ! array -> array
/// FUNCTION f2(arg) ! array -> array
/// vp1 => v3 ! 1
/// v1 = v2 * vp1 ! 2
/// a1 = a1 + a2 ! 3
/// a1 = f1(a2) ! 4
/// a1 = f2(a2) ! 5
/// ```
///
/// In line 1, `vp1` is a BoxAddr to copy a box value into. The box value is
/// constructed from the DataAddr of `v3`.
/// In line 2, `v1` is a DataAddr to copy a value into. The value is constructed
/// from the DataValue of `v2` and `vp1`. DataValue is implicitly a double
/// dereference in the `vp1` case.
/// In line 3, `a1` and `a2` on the rhs are RefTransparent. The `a1` on the lhs
/// is CopyInCopyOut as `a1` is replaced elementally by the additions.
/// In line 4, `a2` can be RefTransparent, ByValueArg, RefOpaque, or BoxAddr if
/// `arg` is declared as C-like pass-by-value, VALUE, INTENT(?), or ALLOCATABLE/
/// POINTER, respectively. `a1` on the lhs is CopyInCopyOut.
/// In line 5, `a2` may be DataAddr or BoxAddr assuming f2 is transformational.
/// `a1` on the lhs is again CopyInCopyOut.
enum class ConstituentSemantics {
// Scalar data reference semantics.
//
// For these let `v` be the location in memory of a variable with value `x`
DataValue, // refers to the value `x`
DataAddr, // refers to the address `v`
BoxValue, // refers to a box value containing `v`
BoxAddr, // refers to the address of a box value containing `v`
// Array data reference semantics.
//
// For these let `a` be the location in memory of a sequence of value `[xs]`.
// Let `x_i` be the `i`-th value in the sequence `[xs]`.
// Referentially transparent. Refers to the array's value, `[xs]`.
RefTransparent,
// Refers to an ephemeral address `tmp` containing value `x_i` (15.5.2.3.p7
// note 2). (Passing a copy by reference to simulate pass-by-value.)
ByValueArg,
// Refers to the merge of array value `[xs]` with another array value `[ys]`.
// This merged array value will be written into memory location `a`.
CopyInCopyOut,
// Similar to CopyInCopyOut but `a` may be a transient projection (rather than
// a whole array).
ProjectedCopyInCopyOut,
// Similar to ProjectedCopyInCopyOut, except the merge value is not assigned
// automatically by the framework. Instead, and address for `[xs]` is made
// accessible so that custom assignments to `[xs]` can be implemented.
CustomCopyInCopyOut,
// Referentially opaque. Refers to the address of `x_i`.
RefOpaque
};
/// Convert parser's INTEGER relational operators to MLIR. TODO: using
/// unordered, but we may want to cons ordered in certain situation.
static mlir::arith::CmpIPredicate
translateRelational(Fortran::common::RelationalOperator rop) {
switch (rop) {
case Fortran::common::RelationalOperator::LT:
return mlir::arith::CmpIPredicate::slt;
case Fortran::common::RelationalOperator::LE:
return mlir::arith::CmpIPredicate::sle;
case Fortran::common::RelationalOperator::EQ:
return mlir::arith::CmpIPredicate::eq;
case Fortran::common::RelationalOperator::NE:
return mlir::arith::CmpIPredicate::ne;
case Fortran::common::RelationalOperator::GT:
return mlir::arith::CmpIPredicate::sgt;
case Fortran::common::RelationalOperator::GE:
return mlir::arith::CmpIPredicate::sge;
}
llvm_unreachable("unhandled INTEGER relational operator");
}
/// Convert parser's REAL relational operators to MLIR.
/// The choice of order (O prefix) vs unorder (U prefix) follows Fortran 2018
/// requirements in the IEEE context (table 17.1 of F2018). This choice is
/// also applied in other contexts because it is easier and in line with
/// other Fortran compilers.
/// FIXME: The signaling/quiet aspect of the table 17.1 requirement is not
/// fully enforced. FIR and LLVM `fcmp` instructions do not give any guarantee
/// whether the comparison will signal or not in case of quiet NaN argument.
static mlir::arith::CmpFPredicate
translateFloatRelational(Fortran::common::RelationalOperator rop) {
switch (rop) {
case Fortran::common::RelationalOperator::LT:
return mlir::arith::CmpFPredicate::OLT;
case Fortran::common::RelationalOperator::LE:
return mlir::arith::CmpFPredicate::OLE;
case Fortran::common::RelationalOperator::EQ:
return mlir::arith::CmpFPredicate::OEQ;
case Fortran::common::RelationalOperator::NE:
return mlir::arith::CmpFPredicate::UNE;
case Fortran::common::RelationalOperator::GT:
return mlir::arith::CmpFPredicate::OGT;
case Fortran::common::RelationalOperator::GE:
return mlir::arith::CmpFPredicate::OGE;
}
llvm_unreachable("unhandled REAL relational operator");
}
static mlir::Value genActualIsPresentTest(fir::FirOpBuilder &builder,
mlir::Location loc,
fir::ExtendedValue actual) {
if (const auto *ptrOrAlloc = actual.getBoxOf<fir::MutableBoxValue>())
return fir::factory::genIsAllocatedOrAssociatedTest(builder, loc,
*ptrOrAlloc);
// Optional case (not that optional allocatable/pointer cannot be absent
// when passed to CMPLX as per 15.5.2.12 point 3 (7) and (8)). It is
// therefore possible to catch them in the `then` case above.
return builder.create<fir::IsPresentOp>(loc, builder.getI1Type(),
fir::getBase(actual));
}
/// Convert the array_load, `load`, to an extended value. If `path` is not
/// empty, then traverse through the components designated. The base value is
/// `newBase`. This does not accept an array_load with a slice operand.
static fir::ExtendedValue
arrayLoadExtValue(fir::FirOpBuilder &builder, mlir::Location loc,
fir::ArrayLoadOp load, llvm::ArrayRef<mlir::Value> path,
mlir::Value newBase, mlir::Value newLen = {}) {
// Recover the extended value from the load.
if (load.getSlice())
fir::emitFatalError(loc, "array_load with slice is not allowed");
mlir::Type arrTy = load.getType();
if (!path.empty()) {
mlir::Type ty = fir::applyPathToType(arrTy, path);
if (!ty)
fir::emitFatalError(loc, "path does not apply to type");
if (!ty.isa<fir::SequenceType>()) {
if (fir::isa_char(ty)) {
mlir::Value len = newLen;
if (!len)
len = fir::factory::CharacterExprHelper{builder, loc}.getLength(
load.getMemref());
if (!len) {
assert(load.getTypeparams().size() == 1 &&
"length must be in array_load");
len = load.getTypeparams()[0];
}
return fir::CharBoxValue{newBase, len};
}
return newBase;
}
arrTy = ty.cast<fir::SequenceType>();
}
auto arrayToExtendedValue =
[&](const llvm::SmallVector<mlir::Value> &extents,
const llvm::SmallVector<mlir::Value> &origins) -> fir::ExtendedValue {
mlir::Type eleTy = fir::unwrapSequenceType(arrTy);
if (fir::isa_char(eleTy)) {
mlir::Value len = newLen;
if (!len)
len = fir::factory::CharacterExprHelper{builder, loc}.getLength(
load.getMemref());
if (!len) {
assert(load.getTypeparams().size() == 1 &&
"length must be in array_load");
len = load.getTypeparams()[0];
}
return fir::CharArrayBoxValue(newBase, len, extents, origins);
}
return fir::ArrayBoxValue(newBase, extents, origins);
};
// Use the shape op, if there is one.
mlir::Value shapeVal = load.getShape();
if (shapeVal) {
if (!mlir::isa<fir::ShiftOp>(shapeVal.getDefiningOp())) {
auto extents = fir::factory::getExtents(shapeVal);
auto origins = fir::factory::getOrigins(shapeVal);
return arrayToExtendedValue(extents, origins);
}
if (!fir::isa_box_type(load.getMemref().getType()))
fir::emitFatalError(loc, "shift op is invalid in this context");
}
// If we're dealing with the array_load op (not a subobject) and the load does
// not have any type parameters, then read the extents from the original box.
// The origin may be either from the box or a shift operation. Create and
// return the array extended value.
if (path.empty() && load.getTypeparams().empty()) {
auto oldBox = load.getMemref();
fir::ExtendedValue exv = fir::factory::readBoxValue(builder, loc, oldBox);
auto extents = fir::factory::getExtents(loc, builder, exv);
auto origins = fir::factory::getNonDefaultLowerBounds(builder, loc, exv);
if (shapeVal) {
// shapeVal is a ShiftOp and load.memref() is a boxed value.
newBase = builder.create<fir::ReboxOp>(loc, oldBox.getType(), oldBox,
shapeVal, /*slice=*/mlir::Value{});
origins = fir::factory::getOrigins(shapeVal);
}
return fir::substBase(arrayToExtendedValue(extents, origins), newBase);
}
TODO(loc, "path to a POINTER, ALLOCATABLE, or other component that requires "
"dereferencing; generating the type parameters is a hard "
"requirement for correctness.");
}
/// Place \p exv in memory if it is not already a memory reference. If
/// \p forceValueType is provided, the value is first casted to the provided
/// type before being stored (this is mainly intended for logicals whose value
/// may be `i1` but needed to be stored as Fortran logicals).
static fir::ExtendedValue
placeScalarValueInMemory(fir::FirOpBuilder &builder, mlir::Location loc,
const fir::ExtendedValue &exv,
mlir::Type storageType) {
mlir::Value valBase = fir::getBase(exv);
if (fir::conformsWithPassByRef(valBase.getType()))
return exv;
assert(!fir::hasDynamicSize(storageType) &&
"only expect statically sized scalars to be by value");
// Since `a` is not itself a valid referent, determine its value and
// create a temporary location at the beginning of the function for
// referencing.
mlir::Value val = builder.createConvert(loc, storageType, valBase);
mlir::Value temp = builder.createTemporary(
loc, storageType,
llvm::ArrayRef<mlir::NamedAttribute>{
Fortran::lower::getAdaptToByRefAttr(builder)});
builder.create<fir::StoreOp>(loc, val, temp);
return fir::substBase(exv, temp);
}
// Copy a copy of scalar \p exv in a new temporary.
static fir::ExtendedValue
createInMemoryScalarCopy(fir::FirOpBuilder &builder, mlir::Location loc,
const fir::ExtendedValue &exv) {
assert(exv.rank() == 0 && "input to scalar memory copy must be a scalar");
if (exv.getCharBox() != nullptr)
return fir::factory::CharacterExprHelper{builder, loc}.createTempFrom(exv);
if (fir::isDerivedWithLenParameters(exv))
TODO(loc, "copy derived type with length parameters");
mlir::Type type = fir::unwrapPassByRefType(fir::getBase(exv).getType());
fir::ExtendedValue temp = builder.createTemporary(loc, type);
fir::factory::genScalarAssignment(builder, loc, temp, exv);
return temp;
}
// An expression with non-zero rank is an array expression.
template <typename A>
static bool isArray(const A &x) {
return x.Rank() != 0;
}
/// Is this a variable wrapped in parentheses?
template <typename A>
static bool isParenthesizedVariable(const A &) {
return false;
}
template <typename T>
static bool isParenthesizedVariable(const Fortran::evaluate::Expr<T> &expr) {
using ExprVariant = decltype(Fortran::evaluate::Expr<T>::u);
using Parentheses = Fortran::evaluate::Parentheses<T>;
if constexpr (Fortran::common::HasMember<Parentheses, ExprVariant>) {
if (const auto *parentheses = std::get_if<Parentheses>(&expr.u))
return Fortran::evaluate::IsVariable(parentheses->left());
return false;
} else {
return std::visit([&](const auto &x) { return isParenthesizedVariable(x); },
expr.u);
}
}
/// Does \p expr only refer to symbols that are mapped to IR values in \p symMap
/// ?
static bool allSymbolsInExprPresentInMap(const Fortran::lower::SomeExpr &expr,
Fortran::lower::SymMap &symMap) {
for (const auto &sym : Fortran::evaluate::CollectSymbols(expr))
if (!symMap.lookupSymbol(sym))
return false;
return true;
}
/// Generate a load of a value from an address. Beware that this will lose
/// any dynamic type information for polymorphic entities (note that unlimited
/// polymorphic cannot be loaded and must not be provided here).
static fir::ExtendedValue genLoad(fir::FirOpBuilder &builder,
mlir::Location loc,
const fir::ExtendedValue &addr) {
return addr.match(
[](const fir::CharBoxValue &box) -> fir::ExtendedValue { return box; },
[&](const fir::PolymorphicValue &p) -> fir::ExtendedValue {
if (fir::unwrapRefType(fir::getBase(p).getType())
.isa<fir::RecordType>())
return p;
return builder.create<fir::LoadOp>(loc, fir::getBase(p));
},
[&](const fir::UnboxedValue &v) -> fir::ExtendedValue {
if (fir::unwrapRefType(fir::getBase(v).getType())
.isa<fir::RecordType>())
return v;
return builder.create<fir::LoadOp>(loc, fir::getBase(v));
},
[&](const fir::MutableBoxValue &box) -> fir::ExtendedValue {
return genLoad(builder, loc,
fir::factory::genMutableBoxRead(builder, loc, box));
},
[&](const fir::BoxValue &box) -> fir::ExtendedValue {
if (box.isUnlimitedPolymorphic())
fir::emitFatalError(
loc, "attempting to load an unlimited polymorphic entity");
return genLoad(builder, loc,
fir::factory::readBoxValue(builder, loc, box));
},
[&](const auto &) -> fir::ExtendedValue {
fir::emitFatalError(
loc, "attempting to load whole array or procedure address");
});
}
/// Create an optional dummy argument value from entity \p exv that may be
/// absent. This can only be called with numerical or logical scalar \p exv.
/// If \p exv is considered absent according to 15.5.2.12 point 1., the returned
/// value is zero (or false), otherwise it is the value of \p exv.
static fir::ExtendedValue genOptionalValue(fir::FirOpBuilder &builder,
mlir::Location loc,
const fir::ExtendedValue &exv,
mlir::Value isPresent) {
mlir::Type eleType = fir::getBaseTypeOf(exv);
assert(exv.rank() == 0 && fir::isa_trivial(eleType) &&
"must be a numerical or logical scalar");
return builder
.genIfOp(loc, {eleType}, isPresent,
/*withElseRegion=*/true)
.genThen([&]() {
mlir::Value val = fir::getBase(genLoad(builder, loc, exv));
builder.create<fir::ResultOp>(loc, val);
})
.genElse([&]() {
mlir::Value zero = fir::factory::createZeroValue(builder, loc, eleType);
builder.create<fir::ResultOp>(loc, zero);
})
.getResults()[0];
}
/// Create an optional dummy argument address from entity \p exv that may be
/// absent. If \p exv is considered absent according to 15.5.2.12 point 1., the
/// returned value is a null pointer, otherwise it is the address of \p exv.
static fir::ExtendedValue genOptionalAddr(fir::FirOpBuilder &builder,
mlir::Location loc,
const fir::ExtendedValue &exv,
mlir::Value isPresent) {
// If it is an exv pointer/allocatable, then it cannot be absent
// because it is passed to a non-pointer/non-allocatable.
if (const auto *box = exv.getBoxOf<fir::MutableBoxValue>())
return fir::factory::genMutableBoxRead(builder, loc, *box);
// If this is not a POINTER or ALLOCATABLE, then it is already an OPTIONAL
// address and can be passed directly.
return exv;
}
/// Create an optional dummy argument address from entity \p exv that may be
/// absent. If \p exv is considered absent according to 15.5.2.12 point 1., the
/// returned value is an absent fir.box, otherwise it is a fir.box describing \p
/// exv.
static fir::ExtendedValue genOptionalBox(fir::FirOpBuilder &builder,
mlir::Location loc,
const fir::ExtendedValue &exv,
mlir::Value isPresent) {
// Non allocatable/pointer optional box -> simply forward
if (exv.getBoxOf<fir::BoxValue>())
return exv;
fir::ExtendedValue newExv = exv;
// Optional allocatable/pointer -> Cannot be absent, but need to translate
// unallocated/diassociated into absent fir.box.
if (const auto *box = exv.getBoxOf<fir::MutableBoxValue>())
newExv = fir::factory::genMutableBoxRead(builder, loc, *box);
// createBox will not do create any invalid memory dereferences if exv is
// absent. The created fir.box will not be usable, but the SelectOp below
// ensures it won't be.
mlir::Value box = builder.createBox(loc, newExv);
mlir::Type boxType = box.getType();
auto absent = builder.create<fir::AbsentOp>(loc, boxType);
auto boxOrAbsent = builder.create<mlir::arith::SelectOp>(
loc, boxType, isPresent, box, absent);
return fir::BoxValue(boxOrAbsent);
}
/// Is this a call to an elemental procedure with at least one array argument?
static bool
isElementalProcWithArrayArgs(const Fortran::evaluate::ProcedureRef &procRef) {
if (procRef.IsElemental())
for (const std::optional<Fortran::evaluate::ActualArgument> &arg :
procRef.arguments())
if (arg && arg->Rank() != 0)
return true;
return false;
}
template <typename T>
static bool isElementalProcWithArrayArgs(const Fortran::evaluate::Expr<T> &) {
return false;
}
template <>
bool isElementalProcWithArrayArgs(const Fortran::lower::SomeExpr &x) {
if (const auto *procRef = std::get_if<Fortran::evaluate::ProcedureRef>(&x.u))
return isElementalProcWithArrayArgs(*procRef);
return false;
}
/// \p argTy must be a tuple (pair) of boxproc and integral types. Convert the
/// \p funcAddr argument to a boxproc value, with the host-association as
/// required. Call the factory function to finish creating the tuple value.
static mlir::Value
createBoxProcCharTuple(Fortran::lower::AbstractConverter &converter,
mlir::Type argTy, mlir::Value funcAddr,
mlir::Value charLen) {
auto boxTy =
argTy.cast<mlir::TupleType>().getType(0).cast<fir::BoxProcType>();
mlir::Location loc = converter.getCurrentLocation();
auto &builder = converter.getFirOpBuilder();
auto boxProc = [&]() -> mlir::Value {
if (auto host = Fortran::lower::argumentHostAssocs(converter, funcAddr))
return builder.create<fir::EmboxProcOp>(
loc, boxTy, llvm::ArrayRef<mlir::Value>{funcAddr, host});
return builder.create<fir::EmboxProcOp>(loc, boxTy, funcAddr);
}();
return fir::factory::createCharacterProcedureTuple(builder, loc, argTy,
boxProc, charLen);
}
/// Given an optional fir.box, returns an fir.box that is the original one if
/// it is present and it otherwise an unallocated box.
/// Absent fir.box are implemented as a null pointer descriptor. Generated
/// code may need to unconditionally read a fir.box that can be absent.
/// This helper allows creating a fir.box that can be read in all cases
/// outside of a fir.if (isPresent) region. However, the usages of the value
/// read from such box should still only be done in a fir.if(isPresent).
static fir::ExtendedValue
absentBoxToUnallocatedBox(fir::FirOpBuilder &builder, mlir::Location loc,
const fir::ExtendedValue &exv,
mlir::Value isPresent) {
mlir::Value box = fir::getBase(exv);
mlir::Type boxType = box.getType();
assert(boxType.isa<fir::BoxType>() && "argument must be a fir.box");
mlir::Value emptyBox =
fir::factory::createUnallocatedBox(builder, loc, boxType, std::nullopt);
auto safeToReadBox =
builder.create<mlir::arith::SelectOp>(loc, isPresent, box, emptyBox);
return fir::substBase(exv, safeToReadBox);
}
// Helper to get the ultimate first symbol. This works around the fact that
// symbol resolution in the front end doesn't always resolve a symbol to its
// ultimate symbol but may leave placeholder indirections for use and host
// associations.
template <typename A>
const Fortran::semantics::Symbol &getFirstSym(const A &obj) {
return obj.GetFirstSymbol().GetUltimate();
}
// Helper to get the ultimate last symbol.
template <typename A>
const Fortran::semantics::Symbol &getLastSym(const A &obj) {
return obj.GetLastSymbol().GetUltimate();
}
static bool
isIntrinsicModuleProcRef(const Fortran::evaluate::ProcedureRef &procRef) {
const Fortran::semantics::Symbol *symbol = procRef.proc().GetSymbol();
if (!symbol)
return false;
const Fortran::semantics::Symbol *module =
symbol->GetUltimate().owner().GetSymbol();
return module && module->attrs().test(Fortran::semantics::Attr::INTRINSIC) &&
module->name().ToString().find("omp_lib") == std::string::npos;
}
// Return true if TRANSPOSE should be lowered without a runtime call.
static bool
isTransposeOptEnabled(const Fortran::lower::AbstractConverter &converter) {
return optimizeTranspose &&
converter.getLoweringOptions().getOptimizeTranspose();
}
// A set of visitors to detect if the given expression
// is a TRANSPOSE call that should be lowered without using
// runtime TRANSPOSE implementation.
template <typename T>
static bool isOptimizableTranspose(const T &,
const Fortran::lower::AbstractConverter &) {
return false;
}
static bool
isOptimizableTranspose(const Fortran::evaluate::ProcedureRef &procRef,
const Fortran::lower::AbstractConverter &converter) {
const Fortran::evaluate::SpecificIntrinsic *intrin =
procRef.proc().GetSpecificIntrinsic();
return isTransposeOptEnabled(converter) && intrin &&
intrin->name == "transpose";
}
template <typename T>
static bool
isOptimizableTranspose(const Fortran::evaluate::FunctionRef<T> &funcRef,
const Fortran::lower::AbstractConverter &converter) {
return isOptimizableTranspose(
static_cast<const Fortran::evaluate::ProcedureRef &>(funcRef), converter);
}
template <typename T>
static bool
isOptimizableTranspose(Fortran::evaluate::Expr<T> expr,
const Fortran::lower::AbstractConverter &converter) {
// If optimizeTranspose is not enabled, return false right away.
if (!isTransposeOptEnabled(converter))
return false;
return std::visit(
[&](const auto &e) { return isOptimizableTranspose(e, converter); },
expr.u);
}
namespace {
/// Lowering of Fortran::evaluate::Expr<T> expressions
class ScalarExprLowering {
public:
using ExtValue = fir::ExtendedValue;
explicit ScalarExprLowering(mlir::Location loc,
Fortran::lower::AbstractConverter &converter,
Fortran::lower::SymMap &symMap,
Fortran::lower::StatementContext &stmtCtx,
bool inInitializer = false)
: location{loc}, converter{converter},
builder{converter.getFirOpBuilder()}, stmtCtx{stmtCtx}, symMap{symMap},
inInitializer{inInitializer} {}
ExtValue genExtAddr(const Fortran::lower::SomeExpr &expr) {
return gen(expr);
}
/// Lower `expr` to be passed as a fir.box argument. Do not create a temp
/// for the expr if it is a variable that can be described as a fir.box.
ExtValue genBoxArg(const Fortran::lower::SomeExpr &expr) {
bool saveUseBoxArg = useBoxArg;
useBoxArg = true;
ExtValue result = gen(expr);
useBoxArg = saveUseBoxArg;
return result;
}
ExtValue genExtValue(const Fortran::lower::SomeExpr &expr) {
return genval(expr);
}
/// Lower an expression that is a pointer or an allocatable to a
/// MutableBoxValue.
fir::MutableBoxValue
genMutableBoxValue(const Fortran::lower::SomeExpr &expr) {
// Pointers and allocatables can only be:
// - a simple designator "x"
// - a component designator "a%b(i,j)%x"
// - a function reference "foo()"
// - result of NULL() or NULL(MOLD) intrinsic.
// NULL() requires some context to be lowered, so it is not handled
// here and must be lowered according to the context where it appears.
ExtValue exv = std::visit(
[&](const auto &x) { return genMutableBoxValueImpl(x); }, expr.u);
const fir::MutableBoxValue *mutableBox =
exv.getBoxOf<fir::MutableBoxValue>();
if (!mutableBox)
fir::emitFatalError(getLoc(), "expr was not lowered to MutableBoxValue");
return *mutableBox;
}
template <typename T>
ExtValue genMutableBoxValueImpl(const T &) {
// NULL() case should not be handled here.
fir::emitFatalError(getLoc(), "NULL() must be lowered in its context");
}
/// A `NULL()` in a position where a mutable box is expected has the same
/// semantics as an absent optional box value.
ExtValue genMutableBoxValueImpl(const Fortran::evaluate::NullPointer &) {
mlir::Location loc = getLoc();
auto nullConst = builder.createNullConstant(loc);
auto noneTy = mlir::NoneType::get(builder.getContext());
auto polyRefTy = fir::LLVMPointerType::get(noneTy);
// MutableBoxValue will dereference the box, so create a bogus temporary for
// the `nullptr`. The LLVM optimizer will garbage collect the temp.
auto temp =
builder.createTemporary(loc, polyRefTy, /*shape=*/mlir::ValueRange{});
auto nullPtr = builder.createConvert(loc, polyRefTy, nullConst);
builder.create<fir::StoreOp>(loc, nullPtr, temp);
auto nullBoxTy = builder.getRefType(fir::BoxType::get(noneTy));
return fir::MutableBoxValue(builder.createConvert(loc, nullBoxTy, temp),
/*lenParameters=*/mlir::ValueRange{},
/*mutableProperties=*/{});
}
template <typename T>
ExtValue
genMutableBoxValueImpl(const Fortran::evaluate::FunctionRef<T> &funRef) {
return genRawProcedureRef(funRef, converter.genType(toEvExpr(funRef)));
}
template <typename T>
ExtValue
genMutableBoxValueImpl(const Fortran::evaluate::Designator<T> &designator) {
return std::visit(
Fortran::common::visitors{
[&](const Fortran::evaluate::SymbolRef &sym) -> ExtValue {
return symMap.lookupSymbol(*sym).toExtendedValue();
},
[&](const Fortran::evaluate::Component &comp) -> ExtValue {
return genComponent(comp);
},
[&](const auto &) -> ExtValue {
fir::emitFatalError(getLoc(),
"not an allocatable or pointer designator");
}},
designator.u);
}
template <typename T>
ExtValue genMutableBoxValueImpl(const Fortran::evaluate::Expr<T> &expr) {
return std::visit([&](const auto &x) { return genMutableBoxValueImpl(x); },
expr.u);
}
mlir::Location getLoc() { return location; }
template <typename A>
mlir::Value genunbox(const A &expr) {
ExtValue e = genval(expr);
if (const fir::UnboxedValue *r = e.getUnboxed())
return *r;
fir::emitFatalError(getLoc(), "unboxed expression expected");
}
/// Generate an integral constant of `value`
template <int KIND>
mlir::Value genIntegerConstant(mlir::MLIRContext *context,
std::int64_t value) {
mlir::Type type =
converter.genType(Fortran::common::TypeCategory::Integer, KIND);
return builder.createIntegerConstant(getLoc(), type, value);
}
/// Generate a logical/boolean constant of `value`
mlir::Value genBoolConstant(bool value) {
return builder.createBool(getLoc(), value);
}
mlir::Type getSomeKindInteger() { return builder.getIndexType(); }
mlir::func::FuncOp getFunction(llvm::StringRef name,
mlir::FunctionType funTy) {
if (mlir::func::FuncOp func = builder.getNamedFunction(name))
return func;
return builder.createFunction(getLoc(), name, funTy);
}
template <typename OpTy>
mlir::Value createCompareOp(mlir::arith::CmpIPredicate pred,
const ExtValue &left, const ExtValue &right) {
if (const fir::UnboxedValue *lhs = left.getUnboxed())
if (const fir::UnboxedValue *rhs = right.getUnboxed())
return builder.create<OpTy>(getLoc(), pred, *lhs, *rhs);
fir::emitFatalError(getLoc(), "array compare should be handled in genarr");
}
template <typename OpTy, typename A>
mlir::Value createCompareOp(const A &ex, mlir::arith::CmpIPredicate pred) {
ExtValue left = genval(ex.left());
return createCompareOp<OpTy>(pred, left, genval(ex.right()));
}
template <typename OpTy>
mlir::Value createFltCmpOp(mlir::arith::CmpFPredicate pred,
const ExtValue &left, const ExtValue &right) {
if (const fir::UnboxedValue *lhs = left.getUnboxed())
if (const fir::UnboxedValue *rhs = right.getUnboxed())
return builder.create<OpTy>(getLoc(), pred, *lhs, *rhs);
fir::emitFatalError(getLoc(), "array compare should be handled in genarr");
}
template <typename OpTy, typename A>
mlir::Value createFltCmpOp(const A &ex, mlir::arith::CmpFPredicate pred) {
ExtValue left = genval(ex.left());
return createFltCmpOp<OpTy>(pred, left, genval(ex.right()));
}
/// Create a call to the runtime to compare two CHARACTER values.
/// Precondition: This assumes that the two values have `fir.boxchar` type.
mlir::Value createCharCompare(mlir::arith::CmpIPredicate pred,
const ExtValue &left, const ExtValue &right) {
return fir::runtime::genCharCompare(builder, getLoc(), pred, left, right);
}
template <typename A>
mlir::Value createCharCompare(const A &ex, mlir::arith::CmpIPredicate pred) {
ExtValue left = genval(ex.left());
return createCharCompare(pred, left, genval(ex.right()));
}
/// Returns a reference to a symbol or its box/boxChar descriptor if it has
/// one.
ExtValue gen(Fortran::semantics::SymbolRef sym) {
if (Fortran::lower::SymbolBox val = symMap.lookupSymbol(sym))
return val.match(
[&](const Fortran::lower::SymbolBox::PointerOrAllocatable &boxAddr) {
return fir::factory::genMutableBoxRead(builder, getLoc(), boxAddr);
},
[&val](auto &) { return val.toExtendedValue(); });
LLVM_DEBUG(llvm::dbgs()
<< "unknown symbol: " << sym << "\nmap: " << symMap << '\n');
fir::emitFatalError(getLoc(), "symbol is not mapped to any IR value");
}
ExtValue genLoad(const ExtValue &exv) {
return ::genLoad(builder, getLoc(), exv);
}
ExtValue genval(Fortran::semantics::SymbolRef sym) {
mlir::Location loc = getLoc();
ExtValue var = gen(sym);
if (const fir::UnboxedValue *s = var.getUnboxed())
if (fir::isa_ref_type(s->getType())) {
// A function with multiple entry points returning different types
// tags all result variables with one of the largest types to allow
// them to share the same storage. A reference to a result variable
// of one of the other types requires conversion to the actual type.
fir::UnboxedValue addr = *s;
if (Fortran::semantics::IsFunctionResult(sym)) {
mlir::Type resultType = converter.genType(*sym);
if (addr.getType() != resultType)
addr = builder.createConvert(loc, builder.getRefType(resultType),
addr);
}
return genLoad(addr);
}
return var;
}
ExtValue genval(const Fortran::evaluate::BOZLiteralConstant &) {
TODO(getLoc(), "BOZ");
}
/// Return indirection to function designated in ProcedureDesignator.
/// The type of the function indirection is not guaranteed to match the one
/// of the ProcedureDesignator due to Fortran implicit typing rules.
ExtValue genval(const Fortran::evaluate::ProcedureDesignator &proc) {
mlir::Location loc = getLoc();
if (const Fortran::evaluate::SpecificIntrinsic *intrinsic =
proc.GetSpecificIntrinsic()) {
mlir::FunctionType signature =
Fortran::lower::translateSignature(proc, converter);
// Intrinsic lowering is based on the generic name, so retrieve it here in
// case it is different from the specific name. The type of the specific
// intrinsic is retained in the signature.
std::string genericName =
converter.getFoldingContext().intrinsics().GetGenericIntrinsicName(
intrinsic->name);
mlir::SymbolRefAttr symbolRefAttr =
Fortran::lower::getUnrestrictedIntrinsicSymbolRefAttr(
builder, loc, genericName, signature);
mlir::Value funcPtr =
builder.create<fir::AddrOfOp>(loc, signature, symbolRefAttr);
return funcPtr;
}
const Fortran::semantics::Symbol *symbol = proc.GetSymbol();
assert(symbol && "expected symbol in ProcedureDesignator");
mlir::Value funcPtr;
mlir::Value funcPtrResultLength;
if (Fortran::semantics::IsDummy(*symbol)) {
Fortran::lower::SymbolBox val = symMap.lookupSymbol(*symbol);
assert(val && "Dummy procedure not in symbol map");
funcPtr = val.getAddr();
if (fir::isCharacterProcedureTuple(funcPtr.getType(),
/*acceptRawFunc=*/false))
std::tie(funcPtr, funcPtrResultLength) =
fir::factory::extractCharacterProcedureTuple(builder, loc, funcPtr);
} else {
std::string name = converter.mangleName(*symbol);
mlir::func::FuncOp func =
Fortran::lower::getOrDeclareFunction(name, proc, converter);
funcPtr = builder.create<fir::AddrOfOp>(loc, func.getFunctionType(),
builder.getSymbolRefAttr(name));
}
if (Fortran::lower::mustPassLengthWithDummyProcedure(proc, converter)) {
// The result length, if available here, must be propagated along the
// procedure address so that call sites where the result length is assumed
// can retrieve the length.
Fortran::evaluate::DynamicType resultType = proc.GetType().value();
if (const auto &lengthExpr = resultType.GetCharLength()) {
// The length expression may refer to dummy argument symbols that are
// meaningless without any actual arguments. Leave the length as
// unknown in that case, it be resolved on the call site
// with the actual arguments.
if (allSymbolsInExprPresentInMap(toEvExpr(*lengthExpr), symMap)) {
mlir::Value rawLen = fir::getBase(genval(*lengthExpr));
// F2018 7.4.4.2 point 5.
funcPtrResultLength =
fir::factory::genMaxWithZero(builder, getLoc(), rawLen);
}
}
if (!funcPtrResultLength)
funcPtrResultLength = builder.createIntegerConstant(
loc, builder.getCharacterLengthType(), -1);
return fir::CharBoxValue{funcPtr, funcPtrResultLength};
}
return funcPtr;
}
ExtValue genval(const Fortran::evaluate::NullPointer &) {
return builder.createNullConstant(getLoc());
}
static bool
isDerivedTypeWithLenParameters(const Fortran::semantics::Symbol &sym) {
if (const Fortran::semantics::DeclTypeSpec *declTy = sym.GetType())
if (const Fortran::semantics::DerivedTypeSpec *derived =
declTy->AsDerived())
return Fortran::semantics::CountLenParameters(*derived) > 0;
return false;
}
/// A structure constructor is lowered two ways. In an initializer context,
/// the entire structure must be constant, so the aggregate value is
/// constructed inline. This allows it to be the body of a GlobalOp.
/// Otherwise, the structure constructor is in an expression. In that case, a
/// temporary object is constructed in the stack frame of the procedure.
ExtValue genval(const Fortran::evaluate::StructureConstructor &ctor) {
mlir::Location loc = getLoc();
if (inInitializer)
return Fortran::lower::genInlinedStructureCtorLit(converter, loc, ctor);
mlir::Type ty = translateSomeExprToFIRType(converter, toEvExpr(ctor));
auto recTy = ty.cast<fir::RecordType>();
auto fieldTy = fir::FieldType::get(ty.getContext());
mlir::Value res = builder.createTemporary(loc, recTy);
mlir::Value box = builder.createBox(loc, fir::ExtendedValue{res});
fir::runtime::genDerivedTypeInitialize(builder, loc, box);
for (const auto &value : ctor.values()) {
const Fortran::semantics::Symbol &sym = *value.first;
const Fortran::lower::SomeExpr &expr = value.second.value();
if (sym.test(Fortran::semantics::Symbol::Flag::ParentComp)) {
ExtValue from = gen(expr);
mlir::Type fromTy = fir::unwrapPassByRefType(
fir::unwrapRefType(fir::getBase(from).getType()));
mlir::Value resCast =
builder.createConvert(loc, builder.getRefType(fromTy), res);
fir::factory::genRecordAssignment(builder, loc, resCast, from);
continue;
}
if (isDerivedTypeWithLenParameters(sym))
TODO(loc, "component with length parameters in structure constructor");
llvm::StringRef name = toStringRef(sym.name());
// FIXME: type parameters must come from the derived-type-spec
mlir::Value field = builder.create<fir::FieldIndexOp>(
loc, fieldTy, name, ty,
/*typeParams=*/mlir::ValueRange{} /*TODO*/);
mlir::Type coorTy = builder.getRefType(recTy.getType(name));
auto coor = builder.create<fir::CoordinateOp>(loc, coorTy,