1 //===-- Numeric.cpp -- runtime API for numeric intrinsics -----------------===//
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 #include "flang/Optimizer/Builder/Runtime/Numeric.h"
10 #include "flang/Optimizer/Builder/BoxValue.h"
11 #include "flang/Optimizer/Builder/Character.h"
12 #include "flang/Optimizer/Builder/FIRBuilder.h"
13 #include "flang/Optimizer/Builder/Runtime/RTBuilder.h"
14 #include "flang/Optimizer/Builder/Todo.h"
15 #include "flang/Runtime/numeric.h"
16 #include "mlir/Dialect/Func/IR/FuncOps.h"
17
18 using namespace Fortran::runtime;
19
20 // The real*10 and real*16 placeholders below are used to force the
21 // compilation of the real*10 and real*16 method names on systems that
22 // may not have them in their runtime library. This can occur in the
23 // case of cross compilation, for example.
24
25 /// Placeholder for real*10 version of Exponent Intrinsic
26 struct ForcedExponent10_4 {
27 static constexpr const char *name = ExpandAndQuoteKey(RTNAME(Exponent10_4));
getTypeModelForcedExponent10_428 static constexpr fir::runtime::FuncTypeBuilderFunc getTypeModel() {
29 return [](mlir::MLIRContext *ctx) {
30 auto fltTy = mlir::FloatType::getF80(ctx);
31 auto intTy = mlir::IntegerType::get(ctx, 32);
32 return mlir::FunctionType::get(ctx, fltTy, intTy);
33 };
34 }
35 };
36
37 struct ForcedExponent10_8 {
38 static constexpr const char *name = ExpandAndQuoteKey(RTNAME(Exponent10_8));
getTypeModelForcedExponent10_839 static constexpr fir::runtime::FuncTypeBuilderFunc getTypeModel() {
40 return [](mlir::MLIRContext *ctx) {
41 auto fltTy = mlir::FloatType::getF80(ctx);
42 auto intTy = mlir::IntegerType::get(ctx, 64);
43 return mlir::FunctionType::get(ctx, fltTy, intTy);
44 };
45 }
46 };
47
48 /// Placeholder for real*16 version of Exponent Intrinsic
49 struct ForcedExponent16_4 {
50 static constexpr const char *name = ExpandAndQuoteKey(RTNAME(Exponent16_4));
getTypeModelForcedExponent16_451 static constexpr fir::runtime::FuncTypeBuilderFunc getTypeModel() {
52 return [](mlir::MLIRContext *ctx) {
53 auto fltTy = mlir::FloatType::getF128(ctx);
54 auto intTy = mlir::IntegerType::get(ctx, 32);
55 return mlir::FunctionType::get(ctx, fltTy, intTy);
56 };
57 }
58 };
59
60 struct ForcedExponent16_8 {
61 static constexpr const char *name = ExpandAndQuoteKey(RTNAME(Exponent16_8));
getTypeModelForcedExponent16_862 static constexpr fir::runtime::FuncTypeBuilderFunc getTypeModel() {
63 return [](mlir::MLIRContext *ctx) {
64 auto fltTy = mlir::FloatType::getF128(ctx);
65 auto intTy = mlir::IntegerType::get(ctx, 64);
66 return mlir::FunctionType::get(ctx, fltTy, intTy);
67 };
68 }
69 };
70
71 /// Placeholder for real*10 version of Fraction Intrinsic
72 struct ForcedFraction10 {
73 static constexpr const char *name = ExpandAndQuoteKey(RTNAME(Fraction10));
getTypeModelForcedFraction1074 static constexpr fir::runtime::FuncTypeBuilderFunc getTypeModel() {
75 return [](mlir::MLIRContext *ctx) {
76 auto ty = mlir::FloatType::getF80(ctx);
77 return mlir::FunctionType::get(ctx, {ty}, {ty});
78 };
79 }
80 };
81
82 /// Placeholder for real*16 version of Fraction Intrinsic
83 struct ForcedFraction16 {
84 static constexpr const char *name = ExpandAndQuoteKey(RTNAME(Fraction16));
getTypeModelForcedFraction1685 static constexpr fir::runtime::FuncTypeBuilderFunc getTypeModel() {
86 return [](mlir::MLIRContext *ctx) {
87 auto ty = mlir::FloatType::getF128(ctx);
88 return mlir::FunctionType::get(ctx, {ty}, {ty});
89 };
90 }
91 };
92
93 /// Placeholder for real*10 version of Nearest Intrinsic
94 struct ForcedNearest10 {
95 static constexpr const char *name = ExpandAndQuoteKey(RTNAME(Nearest10));
getTypeModelForcedNearest1096 static constexpr fir::runtime::FuncTypeBuilderFunc getTypeModel() {
97 return [](mlir::MLIRContext *ctx) {
98 auto fltTy = mlir::FloatType::getF80(ctx);
99 auto boolTy = mlir::IntegerType::get(ctx, 1);
100 return mlir::FunctionType::get(ctx, {fltTy, boolTy}, {fltTy});
101 };
102 }
103 };
104
105 /// Placeholder for real*16 version of Nearest Intrinsic
106 struct ForcedNearest16 {
107 static constexpr const char *name = ExpandAndQuoteKey(RTNAME(Nearest16));
getTypeModelForcedNearest16108 static constexpr fir::runtime::FuncTypeBuilderFunc getTypeModel() {
109 return [](mlir::MLIRContext *ctx) {
110 auto fltTy = mlir::FloatType::getF128(ctx);
111 auto boolTy = mlir::IntegerType::get(ctx, 1);
112 return mlir::FunctionType::get(ctx, {fltTy, boolTy}, {fltTy});
113 };
114 }
115 };
116
117 /// Placeholder for real*10 version of RRSpacing Intrinsic
118 struct ForcedRRSpacing10 {
119 static constexpr const char *name = ExpandAndQuoteKey(RTNAME(RRSpacing10));
getTypeModelForcedRRSpacing10120 static constexpr fir::runtime::FuncTypeBuilderFunc getTypeModel() {
121 return [](mlir::MLIRContext *ctx) {
122 auto ty = mlir::FloatType::getF80(ctx);
123 return mlir::FunctionType::get(ctx, {ty}, {ty});
124 };
125 }
126 };
127
128 /// Placeholder for real*16 version of RRSpacing Intrinsic
129 struct ForcedRRSpacing16 {
130 static constexpr const char *name = ExpandAndQuoteKey(RTNAME(RRSpacing16));
getTypeModelForcedRRSpacing16131 static constexpr fir::runtime::FuncTypeBuilderFunc getTypeModel() {
132 return [](mlir::MLIRContext *ctx) {
133 auto ty = mlir::FloatType::getF128(ctx);
134 return mlir::FunctionType::get(ctx, {ty}, {ty});
135 };
136 }
137 };
138
139 /// Placeholder for real*10 version of Scale Intrinsic
140 struct ForcedScale10 {
141 static constexpr const char *name = ExpandAndQuoteKey(RTNAME(Scale10));
getTypeModelForcedScale10142 static constexpr fir::runtime::FuncTypeBuilderFunc getTypeModel() {
143 return [](mlir::MLIRContext *ctx) {
144 auto fltTy = mlir::FloatType::getF80(ctx);
145 auto intTy = mlir::IntegerType::get(ctx, 64);
146 return mlir::FunctionType::get(ctx, {fltTy, intTy}, {fltTy});
147 };
148 }
149 };
150
151 /// Placeholder for real*16 version of Scale Intrinsic
152 struct ForcedScale16 {
153 static constexpr const char *name = ExpandAndQuoteKey(RTNAME(Scale16));
getTypeModelForcedScale16154 static constexpr fir::runtime::FuncTypeBuilderFunc getTypeModel() {
155 return [](mlir::MLIRContext *ctx) {
156 auto fltTy = mlir::FloatType::getF128(ctx);
157 auto intTy = mlir::IntegerType::get(ctx, 64);
158 return mlir::FunctionType::get(ctx, {fltTy, intTy}, {fltTy});
159 };
160 }
161 };
162
163 /// Placeholder for real*10 version of RRSpacing Intrinsic
164 struct ForcedSetExponent10 {
165 static constexpr const char *name = ExpandAndQuoteKey(RTNAME(SetExponent10));
getTypeModelForcedSetExponent10166 static constexpr fir::runtime::FuncTypeBuilderFunc getTypeModel() {
167 return [](mlir::MLIRContext *ctx) {
168 auto fltTy = mlir::FloatType::getF80(ctx);
169 auto intTy = mlir::IntegerType::get(ctx, 64);
170 return mlir::FunctionType::get(ctx, {fltTy, intTy}, {fltTy});
171 };
172 }
173 };
174
175 /// Placeholder for real*10 version of RRSpacing Intrinsic
176 struct ForcedSetExponent16 {
177 static constexpr const char *name = ExpandAndQuoteKey(RTNAME(SetExponent16));
getTypeModelForcedSetExponent16178 static constexpr fir::runtime::FuncTypeBuilderFunc getTypeModel() {
179 return [](mlir::MLIRContext *ctx) {
180 auto fltTy = mlir::FloatType::getF128(ctx);
181 auto intTy = mlir::IntegerType::get(ctx, 64);
182 return mlir::FunctionType::get(ctx, {fltTy, intTy}, {fltTy});
183 };
184 }
185 };
186
187 /// Placeholder for real*10 version of Spacing Intrinsic
188 struct ForcedSpacing10 {
189 static constexpr const char *name = ExpandAndQuoteKey(RTNAME(Spacing10));
getTypeModelForcedSpacing10190 static constexpr fir::runtime::FuncTypeBuilderFunc getTypeModel() {
191 return [](mlir::MLIRContext *ctx) {
192 auto ty = mlir::FloatType::getF80(ctx);
193 return mlir::FunctionType::get(ctx, {ty}, {ty});
194 };
195 }
196 };
197
198 /// Placeholder for real*16 version of Spacing Intrinsic
199 struct ForcedSpacing16 {
200 static constexpr const char *name = ExpandAndQuoteKey(RTNAME(Spacing16));
getTypeModelForcedSpacing16201 static constexpr fir::runtime::FuncTypeBuilderFunc getTypeModel() {
202 return [](mlir::MLIRContext *ctx) {
203 auto ty = mlir::FloatType::getF128(ctx);
204 return mlir::FunctionType::get(ctx, {ty}, {ty});
205 };
206 }
207 };
208
209 /// Generate call to Exponent instrinsic runtime routine.
genExponent(fir::FirOpBuilder & builder,mlir::Location loc,mlir::Type resultType,mlir::Value x)210 mlir::Value fir::runtime::genExponent(fir::FirOpBuilder &builder,
211 mlir::Location loc, mlir::Type resultType,
212 mlir::Value x) {
213 mlir::func::FuncOp func;
214 mlir::Type fltTy = x.getType();
215
216 if (fltTy.isF16()) {
217 TODO(loc, "support for REAL with KIND = 2 in EXPONENT");
218 } else if (fltTy.isF32()) {
219 if (resultType.isInteger(32))
220 func = fir::runtime::getRuntimeFunc<mkRTKey(Exponent4_4)>(loc, builder);
221 else if (resultType.isInteger(64))
222 func = fir::runtime::getRuntimeFunc<mkRTKey(Exponent4_8)>(loc, builder);
223 } else if (fltTy.isF64()) {
224 if (resultType.isInteger(32))
225 func = fir::runtime::getRuntimeFunc<mkRTKey(Exponent8_4)>(loc, builder);
226 else if (resultType.isInteger(64))
227 func = fir::runtime::getRuntimeFunc<mkRTKey(Exponent8_8)>(loc, builder);
228 } else if (fltTy.isF80()) {
229 if (resultType.isInteger(32))
230 func = fir::runtime::getRuntimeFunc<ForcedExponent10_4>(loc, builder);
231 else if (resultType.isInteger(64))
232 func = fir::runtime::getRuntimeFunc<ForcedExponent10_8>(loc, builder);
233 } else if (fltTy.isF128()) {
234 if (resultType.isInteger(32))
235 func = fir::runtime::getRuntimeFunc<ForcedExponent16_4>(loc, builder);
236 else if (resultType.isInteger(64))
237 func = fir::runtime::getRuntimeFunc<ForcedExponent16_8>(loc, builder);
238 } else
239 fir::emitFatalError(loc, "unsupported REAL kind in EXPONENT");
240
241 auto funcTy = func.getFunctionType();
242 llvm::SmallVector<mlir::Value> args = {
243 builder.createConvert(loc, funcTy.getInput(0), x)};
244
245 return builder.create<fir::CallOp>(loc, func, args).getResult(0);
246 }
247
248 /// Generate call to Fraction instrinsic runtime routine.
genFraction(fir::FirOpBuilder & builder,mlir::Location loc,mlir::Value x)249 mlir::Value fir::runtime::genFraction(fir::FirOpBuilder &builder,
250 mlir::Location loc, mlir::Value x) {
251 mlir::func::FuncOp func;
252 mlir::Type fltTy = x.getType();
253 if (fltTy.isF16())
254 TODO(loc, "support for REAL with KIND = 2 in FRACTION");
255 else if (fltTy.isF32())
256 func = fir::runtime::getRuntimeFunc<mkRTKey(Fraction4)>(loc, builder);
257 else if (fltTy.isF64())
258 func = fir::runtime::getRuntimeFunc<mkRTKey(Fraction8)>(loc, builder);
259 else if (fltTy.isF80())
260 func = fir::runtime::getRuntimeFunc<ForcedFraction10>(loc, builder);
261 else if (fltTy.isF128())
262 func = fir::runtime::getRuntimeFunc<ForcedFraction16>(loc, builder);
263 else
264 fir::emitFatalError(loc, "unsupported REAL kind in FRACTION");
265
266 auto funcTy = func.getFunctionType();
267 llvm::SmallVector<mlir::Value> args = {
268 builder.createConvert(loc, funcTy.getInput(0), x)};
269
270 return builder.create<fir::CallOp>(loc, func, args).getResult(0);
271 }
272
273 /// Generate call to Nearest intrinsic runtime routine.
genNearest(fir::FirOpBuilder & builder,mlir::Location loc,mlir::Value x,mlir::Value s)274 mlir::Value fir::runtime::genNearest(fir::FirOpBuilder &builder,
275 mlir::Location loc, mlir::Value x,
276 mlir::Value s) {
277 mlir::func::FuncOp func;
278 mlir::Type fltTy = x.getType();
279
280 if (fltTy.isF16())
281 TODO(loc, "support for REAL with KIND = 2 in NEAREST");
282 else if (fltTy.isF32())
283 func = fir::runtime::getRuntimeFunc<mkRTKey(Nearest4)>(loc, builder);
284 else if (fltTy.isF64())
285 func = fir::runtime::getRuntimeFunc<mkRTKey(Nearest8)>(loc, builder);
286 else if (fltTy.isF80())
287 func = fir::runtime::getRuntimeFunc<ForcedNearest10>(loc, builder);
288 else if (fltTy.isF128())
289 func = fir::runtime::getRuntimeFunc<ForcedNearest16>(loc, builder);
290 else
291 fir::emitFatalError(loc, "unsupported REAL kind in NEAREST");
292
293 auto funcTy = func.getFunctionType();
294
295 mlir::Type sTy = s.getType();
296 mlir::Value zero = builder.createRealZeroConstant(loc, sTy);
297 auto cmp = builder.create<mlir::arith::CmpFOp>(
298 loc, mlir::arith::CmpFPredicate::OGT, s, zero);
299
300 mlir::Type boolTy = mlir::IntegerType::get(builder.getContext(), 1);
301 mlir::Value False = builder.createIntegerConstant(loc, boolTy, 0);
302 mlir::Value True = builder.createIntegerConstant(loc, boolTy, 1);
303
304 mlir::Value positive =
305 builder.create<mlir::arith::SelectOp>(loc, cmp, True, False);
306 auto args = fir::runtime::createArguments(builder, loc, funcTy, x, positive);
307
308 return builder.create<fir::CallOp>(loc, func, args).getResult(0);
309 }
310
311 /// Generate call to RRSpacing intrinsic runtime routine.
genRRSpacing(fir::FirOpBuilder & builder,mlir::Location loc,mlir::Value x)312 mlir::Value fir::runtime::genRRSpacing(fir::FirOpBuilder &builder,
313 mlir::Location loc, mlir::Value x) {
314 mlir::func::FuncOp func;
315 mlir::Type fltTy = x.getType();
316
317 if (fltTy.isF16())
318 TODO(loc, "support for REAL with KIND = 2 in RRSPACING");
319 else if (fltTy.isF32())
320 func = fir::runtime::getRuntimeFunc<mkRTKey(RRSpacing4)>(loc, builder);
321 else if (fltTy.isF64())
322 func = fir::runtime::getRuntimeFunc<mkRTKey(RRSpacing8)>(loc, builder);
323 else if (fltTy.isF80())
324 func = fir::runtime::getRuntimeFunc<ForcedRRSpacing10>(loc, builder);
325 else if (fltTy.isF128())
326 func = fir::runtime::getRuntimeFunc<ForcedRRSpacing16>(loc, builder);
327 else
328 fir::emitFatalError(loc, "unsupported REAL kind in RRSPACING");
329
330 auto funcTy = func.getFunctionType();
331 llvm::SmallVector<mlir::Value> args = {
332 builder.createConvert(loc, funcTy.getInput(0), x)};
333
334 return builder.create<fir::CallOp>(loc, func, args).getResult(0);
335 }
336
337 /// Generate call to Scale intrinsic runtime routine.
genScale(fir::FirOpBuilder & builder,mlir::Location loc,mlir::Value x,mlir::Value i)338 mlir::Value fir::runtime::genScale(fir::FirOpBuilder &builder,
339 mlir::Location loc, mlir::Value x,
340 mlir::Value i) {
341 mlir::func::FuncOp func;
342 mlir::Type fltTy = x.getType();
343
344 if (fltTy.isF16())
345 TODO(loc, "support for REAL with KIND = 2 in SCALE");
346 else if (fltTy.isF32())
347 func = fir::runtime::getRuntimeFunc<mkRTKey(Scale4)>(loc, builder);
348 else if (fltTy.isF64())
349 func = fir::runtime::getRuntimeFunc<mkRTKey(Scale8)>(loc, builder);
350 else if (fltTy.isF80())
351 func = fir::runtime::getRuntimeFunc<ForcedScale10>(loc, builder);
352 else if (fltTy.isF128())
353 func = fir::runtime::getRuntimeFunc<ForcedScale16>(loc, builder);
354 else
355 fir::emitFatalError(loc, "unsupported REAL kind in SCALE");
356
357 auto funcTy = func.getFunctionType();
358 auto args = fir::runtime::createArguments(builder, loc, funcTy, x, i);
359
360 return builder.create<fir::CallOp>(loc, func, args).getResult(0);
361 }
362
363 /// Generate call to Selected_int_kind intrinsic runtime routine.
genSelectedIntKind(fir::FirOpBuilder & builder,mlir::Location loc,mlir::Value x)364 mlir::Value fir::runtime::genSelectedIntKind(fir::FirOpBuilder &builder,
365 mlir::Location loc,
366 mlir::Value x) {
367 mlir::func::FuncOp func =
368 fir::runtime::getRuntimeFunc<mkRTKey(SelectedIntKind)>(loc, builder);
369 auto fTy = func.getFunctionType();
370 auto sourceFile = fir::factory::locationToFilename(builder, loc);
371 auto sourceLine =
372 fir::factory::locationToLineNo(builder, loc, fTy.getInput(1));
373 if (!fir::isa_ref_type(x.getType()))
374 fir::emitFatalError(loc, "argument address for runtime not found");
375 mlir::Type eleTy = fir::unwrapRefType(x.getType());
376 mlir::Value xKind = builder.createIntegerConstant(
377 loc, fTy.getInput(3), eleTy.getIntOrFloatBitWidth() / 8);
378 auto args = fir::runtime::createArguments(builder, loc, fTy, sourceFile,
379 sourceLine, x, xKind);
380
381 return builder.create<fir::CallOp>(loc, func, args).getResult(0);
382 }
383
384 /// Generate call to Selected_real_kind intrinsic runtime routine.
genSelectedRealKind(fir::FirOpBuilder & builder,mlir::Location loc,mlir::Value precision,mlir::Value range,mlir::Value radix)385 mlir::Value fir::runtime::genSelectedRealKind(fir::FirOpBuilder &builder,
386 mlir::Location loc,
387 mlir::Value precision,
388 mlir::Value range,
389 mlir::Value radix) {
390 mlir::func::FuncOp func =
391 fir::runtime::getRuntimeFunc<mkRTKey(SelectedRealKind)>(loc, builder);
392 auto fTy = func.getFunctionType();
393 auto getArgKinds = [&](mlir::Value arg, int argKindIndex) -> mlir::Value {
394 if (fir::isa_ref_type(arg.getType())) {
395 mlir::Type eleTy = fir::unwrapRefType(arg.getType());
396 return builder.createIntegerConstant(loc, fTy.getInput(argKindIndex),
397 eleTy.getIntOrFloatBitWidth() / 8);
398 } else {
399 return builder.createIntegerConstant(loc, fTy.getInput(argKindIndex), 0);
400 }
401 };
402
403 auto sourceFile = fir::factory::locationToFilename(builder, loc);
404 auto sourceLine =
405 fir::factory::locationToLineNo(builder, loc, fTy.getInput(1));
406 mlir::Value pKind = getArgKinds(precision, 3);
407 mlir::Value rKind = getArgKinds(range, 5);
408 mlir::Value dKind = getArgKinds(radix, 7);
409 auto args = fir::runtime::createArguments(builder, loc, fTy, sourceFile,
410 sourceLine, precision, pKind, range,
411 rKind, radix, dKind);
412
413 return builder.create<fir::CallOp>(loc, func, args).getResult(0);
414 }
415
416 /// Generate call to Set_exponent instrinsic runtime routine.
genSetExponent(fir::FirOpBuilder & builder,mlir::Location loc,mlir::Value x,mlir::Value i)417 mlir::Value fir::runtime::genSetExponent(fir::FirOpBuilder &builder,
418 mlir::Location loc, mlir::Value x,
419 mlir::Value i) {
420 mlir::func::FuncOp func;
421 mlir::Type fltTy = x.getType();
422
423 if (fltTy.isF16())
424 TODO(loc, "support for REAL with KIND = 2 in FRACTION");
425 else if (fltTy.isF32())
426 func = fir::runtime::getRuntimeFunc<mkRTKey(SetExponent4)>(loc, builder);
427 else if (fltTy.isF64())
428 func = fir::runtime::getRuntimeFunc<mkRTKey(SetExponent8)>(loc, builder);
429 else if (fltTy.isF80())
430 func = fir::runtime::getRuntimeFunc<ForcedSetExponent10>(loc, builder);
431 else if (fltTy.isF128())
432 func = fir::runtime::getRuntimeFunc<ForcedSetExponent16>(loc, builder);
433 else
434 fir::emitFatalError(loc, "unsupported REAL kind in FRACTION");
435
436 auto funcTy = func.getFunctionType();
437 auto args = fir::runtime::createArguments(builder, loc, funcTy, x, i);
438
439 return builder.create<fir::CallOp>(loc, func, args).getResult(0);
440 }
441
442 /// Generate call to Spacing intrinsic runtime routine.
genSpacing(fir::FirOpBuilder & builder,mlir::Location loc,mlir::Value x)443 mlir::Value fir::runtime::genSpacing(fir::FirOpBuilder &builder,
444 mlir::Location loc, mlir::Value x) {
445 mlir::func::FuncOp func;
446 mlir::Type fltTy = x.getType();
447
448 if (fltTy.isF16())
449 TODO(loc, "support for REAL with KIND = 2 in SPACING");
450 else if (fltTy.isF32())
451 func = fir::runtime::getRuntimeFunc<mkRTKey(Spacing4)>(loc, builder);
452 else if (fltTy.isF64())
453 func = fir::runtime::getRuntimeFunc<mkRTKey(Spacing8)>(loc, builder);
454 else if (fltTy.isF80())
455 func = fir::runtime::getRuntimeFunc<ForcedSpacing10>(loc, builder);
456 else if (fltTy.isF128())
457 func = fir::runtime::getRuntimeFunc<ForcedSpacing16>(loc, builder);
458 else
459 fir::emitFatalError(loc, "unsupported REAL kind in SPACING");
460
461 auto funcTy = func.getFunctionType();
462 llvm::SmallVector<mlir::Value> args = {
463 builder.createConvert(loc, funcTy.getInput(0), x)};
464
465 return builder.create<fir::CallOp>(loc, func, args).getResult(0);
466 }
467