1 //===-- BoxValue.cpp ------------------------------------------------------===//
2 //
3 // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
4 // See https://llvm.org/LICENSE.txt for license information.
5 // SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
6 //
7 //===----------------------------------------------------------------------===//
8 //
9 // Pretty printers for box values, etc.
10 //
11 //===----------------------------------------------------------------------===//
12 
13 #include "flang/Optimizer/Builder/BoxValue.h"
14 #include "flang/Optimizer/Builder/FIRBuilder.h"
15 #include "mlir/IR/BuiltinTypes.h"
16 #include "llvm/Support/Debug.h"
17 
18 #define DEBUG_TYPE "flang-box-value"
19 
20 mlir::Value fir::getBase(const fir::ExtendedValue &exv) {
21   return exv.match([](const fir::UnboxedValue &x) { return x; },
22                    [](const auto &x) { return x.getAddr(); });
23 }
24 
25 mlir::Value fir::getLen(const fir::ExtendedValue &exv) {
26   return exv.match(
27       [](const fir::CharBoxValue &x) { return x.getLen(); },
28       [](const fir::CharArrayBoxValue &x) { return x.getLen(); },
29       [](const fir::BoxValue &) -> mlir::Value {
30         llvm::report_fatal_error("Need to read len from BoxValue Exv");
31       },
32       [](const fir::MutableBoxValue &) -> mlir::Value {
33         llvm::report_fatal_error("Need to read len from MutableBoxValue Exv");
34       },
35       [](const auto &) { return mlir::Value{}; });
36 }
37 
38 fir::ExtendedValue fir::substBase(const fir::ExtendedValue &exv,
39                                   mlir::Value base) {
40   return exv.match(
41       [=](const fir::UnboxedValue &x) { return fir::ExtendedValue(base); },
42       [=](const auto &x) { return fir::ExtendedValue(x.clone(base)); });
43 }
44 
45 llvm::SmallVector<mlir::Value> fir::getTypeParams(const ExtendedValue &exv) {
46   using RT = llvm::SmallVector<mlir::Value>;
47   auto baseTy = fir::getBase(exv).getType();
48   if (auto t = fir::dyn_cast_ptrEleTy(baseTy))
49     baseTy = t;
50   baseTy = fir::unwrapSequenceType(baseTy);
51   if (!fir::hasDynamicSize(baseTy))
52     return {}; // type has constant size, no type parameters needed
53   [[maybe_unused]] auto loc = fir::getBase(exv).getLoc();
54   return exv.match(
55       [](const fir::CharBoxValue &x) -> RT { return {x.getLen()}; },
56       [](const fir::CharArrayBoxValue &x) -> RT { return {x.getLen()}; },
57       [&](const fir::BoxValue &) -> RT {
58         LLVM_DEBUG(mlir::emitWarning(
59             loc, "TODO: box value is missing type parameters"));
60         return {};
61       },
62       [&](const fir::MutableBoxValue &) -> RT {
63         // In this case, the type params may be bound to the variable in an
64         // ALLOCATE statement as part of a type-spec.
65         LLVM_DEBUG(mlir::emitWarning(
66             loc, "TODO: mutable box value is missing type parameters"));
67         return {};
68       },
69       [](const auto &) -> RT { return {}; });
70 }
71 
72 bool fir::isArray(const fir::ExtendedValue &exv) {
73   return exv.match(
74       [](const fir::ArrayBoxValue &) { return true; },
75       [](const fir::CharArrayBoxValue &) { return true; },
76       [](const fir::BoxValue &box) { return box.hasRank(); },
77       [](const fir::MutableBoxValue &box) { return box.hasRank(); },
78       [](auto) { return false; });
79 }
80 
81 llvm::raw_ostream &fir::operator<<(llvm::raw_ostream &os,
82                                    const fir::CharBoxValue &box) {
83   return os << "boxchar { addr: " << box.getAddr() << ", len: " << box.getLen()
84             << " }";
85 }
86 
87 llvm::raw_ostream &fir::operator<<(llvm::raw_ostream &os,
88                                    const fir::ArrayBoxValue &box) {
89   os << "boxarray { addr: " << box.getAddr();
90   if (box.getLBounds().size()) {
91     os << ", lbounds: [";
92     llvm::interleaveComma(box.getLBounds(), os);
93     os << "]";
94   } else {
95     os << ", lbounds: all-ones";
96   }
97   os << ", shape: [";
98   llvm::interleaveComma(box.getExtents(), os);
99   return os << "]}";
100 }
101 
102 llvm::raw_ostream &fir::operator<<(llvm::raw_ostream &os,
103                                    const fir::CharArrayBoxValue &box) {
104   os << "boxchararray { addr: " << box.getAddr() << ", len : " << box.getLen();
105   if (box.getLBounds().size()) {
106     os << ", lbounds: [";
107     llvm::interleaveComma(box.getLBounds(), os);
108     os << "]";
109   } else {
110     os << " lbounds: all-ones";
111   }
112   os << ", shape: [";
113   llvm::interleaveComma(box.getExtents(), os);
114   return os << "]}";
115 }
116 
117 llvm::raw_ostream &fir::operator<<(llvm::raw_ostream &os,
118                                    const fir::ProcBoxValue &box) {
119   return os << "boxproc: { procedure: " << box.getAddr()
120             << ", context: " << box.hostContext << "}";
121 }
122 
123 llvm::raw_ostream &fir::operator<<(llvm::raw_ostream &os,
124                                    const fir::BoxValue &box) {
125   os << "box: { value: " << box.getAddr();
126   if (box.lbounds.size()) {
127     os << ", lbounds: [";
128     llvm::interleaveComma(box.lbounds, os);
129     os << "]";
130   }
131   if (!box.explicitParams.empty()) {
132     os << ", explicit type params: [";
133     llvm::interleaveComma(box.explicitParams, os);
134     os << "]";
135   }
136   if (!box.extents.empty()) {
137     os << ", explicit extents: [";
138     llvm::interleaveComma(box.extents, os);
139     os << "]";
140   }
141   return os << "}";
142 }
143 
144 llvm::raw_ostream &fir::operator<<(llvm::raw_ostream &os,
145                                    const fir::MutableBoxValue &box) {
146   os << "mutablebox: { addr: " << box.getAddr();
147   if (!box.lenParams.empty()) {
148     os << ", non deferred type params: [";
149     llvm::interleaveComma(box.lenParams, os);
150     os << "]";
151   }
152   const auto &properties = box.mutableProperties;
153   if (!properties.isEmpty()) {
154     os << ", mutableProperties: { addr: " << properties.addr;
155     if (!properties.lbounds.empty()) {
156       os << ", lbounds: [";
157       llvm::interleaveComma(properties.lbounds, os);
158       os << "]";
159     }
160     if (!properties.extents.empty()) {
161       os << ", shape: [";
162       llvm::interleaveComma(properties.extents, os);
163       os << "]";
164     }
165     if (!properties.deferredParams.empty()) {
166       os << ", deferred type params: [";
167       llvm::interleaveComma(properties.deferredParams, os);
168       os << "]";
169     }
170     os << "}";
171   }
172   return os << "}";
173 }
174 
175 llvm::raw_ostream &fir::operator<<(llvm::raw_ostream &os,
176                                    const fir::ExtendedValue &exv) {
177   exv.match([&](const auto &value) { os << value; });
178   return os;
179 }
180 
181 /// Debug verifier for MutableBox ctor. There is no guarantee that this will
182 /// always be called, so it should not have any functional side effects,
183 /// the const is here to enforce that.
184 bool fir::MutableBoxValue::verify() const {
185   mlir::Type type = fir::dyn_cast_ptrEleTy(getAddr().getType());
186   if (!type)
187     return false;
188   auto box = type.dyn_cast<fir::BoxType>();
189   if (!box)
190     return false;
191   // A boxed value always takes a memory reference,
192 
193   auto nParams = lenParams.size();
194   if (isCharacter()) {
195     if (nParams > 1)
196       return false;
197   } else if (!isDerived()) {
198     if (nParams != 0)
199       return false;
200   }
201   return true;
202 }
203 
204 /// Debug verifier for BoxValue ctor. There is no guarantee this will
205 /// always be called.
206 bool fir::BoxValue::verify() const {
207   if (!addr.getType().isa<fir::BoxType>())
208     return false;
209   if (!lbounds.empty() && lbounds.size() != rank())
210     return false;
211   // Explicit extents are here to cover cases where an explicit-shape dummy
212   // argument comes as a fir.box. This can only happen with derived types and
213   // unlimited polymorphic.
214   if (!extents.empty() && !(isDerived() || isUnlimitedPolymorphic()))
215     return false;
216   if (!extents.empty() && extents.size() != rank())
217     return false;
218   if (isCharacter() && explicitParams.size() > 1)
219     return false;
220   return true;
221 }
222 
223 /// Get exactly one extent for any array-like extended value, \p exv. If \p exv
224 /// is not an array or has rank less then \p dim, the result will be a nullptr.
225 mlir::Value fir::getExtentAtDimension(const fir::ExtendedValue &exv,
226                                       fir::FirOpBuilder &builder,
227                                       mlir::Location loc, unsigned dim) {
228   auto extents = fir::factory::getExtents(builder, loc, exv);
229   if (dim < extents.size())
230     return extents[dim];
231   return {};
232 }
233