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));
28   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));
39   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));
51   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));
62   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));
74   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));
85   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));
96   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));
108   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));
120   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));
131   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));
142   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));
154   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));
166   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));
178   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));
190   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));
201   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.
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.
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.
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.
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.
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 Set_exponent instrinsic runtime routine.
364 mlir::Value fir::runtime::genSetExponent(fir::FirOpBuilder &builder,
365                                          mlir::Location loc, mlir::Value x,
366                                          mlir::Value i) {
367   mlir::func::FuncOp func;
368   mlir::Type fltTy = x.getType();
369 
370   if (fltTy.isF16())
371     TODO(loc, "support for REAL with KIND = 2 in FRACTION");
372   else if (fltTy.isF32())
373     func = fir::runtime::getRuntimeFunc<mkRTKey(SetExponent4)>(loc, builder);
374   else if (fltTy.isF64())
375     func = fir::runtime::getRuntimeFunc<mkRTKey(SetExponent8)>(loc, builder);
376   else if (fltTy.isF80())
377     func = fir::runtime::getRuntimeFunc<ForcedSetExponent10>(loc, builder);
378   else if (fltTy.isF128())
379     func = fir::runtime::getRuntimeFunc<ForcedSetExponent16>(loc, builder);
380   else
381     fir::emitFatalError(loc, "unsupported real kind in FRACTION");
382 
383   auto funcTy = func.getFunctionType();
384   auto args = fir::runtime::createArguments(builder, loc, funcTy, x, i);
385 
386   return builder.create<fir::CallOp>(loc, func, args).getResult(0);
387 }
388 
389 /// Generate call to Spacing intrinsic runtime routine.
390 mlir::Value fir::runtime::genSpacing(fir::FirOpBuilder &builder,
391                                      mlir::Location loc, mlir::Value x) {
392   mlir::func::FuncOp func;
393   mlir::Type fltTy = x.getType();
394 
395   if (fltTy.isF16())
396     TODO(loc, "support for REAL with KIND = 2 in SPACING");
397   else if (fltTy.isF32())
398     func = fir::runtime::getRuntimeFunc<mkRTKey(Spacing4)>(loc, builder);
399   else if (fltTy.isF64())
400     func = fir::runtime::getRuntimeFunc<mkRTKey(Spacing8)>(loc, builder);
401   else if (fltTy.isF80())
402     func = fir::runtime::getRuntimeFunc<ForcedSpacing10>(loc, builder);
403   else if (fltTy.isF128())
404     func = fir::runtime::getRuntimeFunc<ForcedSpacing16>(loc, builder);
405   else
406     fir::emitFatalError(loc, "unsupported real kind in SPACING");
407 
408   auto funcTy = func.getFunctionType();
409   llvm::SmallVector<mlir::Value> args = {
410       builder.createConvert(loc, funcTy.getInput(0), x)};
411 
412   return builder.create<fir::CallOp>(loc, func, args).getResult(0);
413 }
414