1//===-- IntrinsicCall.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// Helper routines for constructing the FIR dialect of MLIR. As FIR is a
10// dialect of MLIR, it makes extensive use of MLIR interfaces and MLIR's coding
11// style (https://mlir.llvm.org/getting_started/DeveloperGuide/) is used in this
12// module.
13//
14//===----------------------------------------------------------------------===//
15
16#include "flang/Optimizer/Builder/IntrinsicCall.h"
17#include "flang/Common/static-multimap-view.h"
18#include "flang/Optimizer/Builder/BoxValue.h"
19#include "flang/Optimizer/Builder/CUFCommon.h"
20#include "flang/Optimizer/Builder/Character.h"
21#include "flang/Optimizer/Builder/Complex.h"
22#include "flang/Optimizer/Builder/FIRBuilder.h"
23#include "flang/Optimizer/Builder/MutableBox.h"
24#include "flang/Optimizer/Builder/PPCIntrinsicCall.h"
25#include "flang/Optimizer/Builder/Runtime/Allocatable.h"
26#include "flang/Optimizer/Builder/Runtime/CUDA/Descriptor.h"
27#include "flang/Optimizer/Builder/Runtime/Character.h"
28#include "flang/Optimizer/Builder/Runtime/Command.h"
29#include "flang/Optimizer/Builder/Runtime/Derived.h"
30#include "flang/Optimizer/Builder/Runtime/Exceptions.h"
31#include "flang/Optimizer/Builder/Runtime/Execute.h"
32#include "flang/Optimizer/Builder/Runtime/Inquiry.h"
33#include "flang/Optimizer/Builder/Runtime/Intrinsics.h"
34#include "flang/Optimizer/Builder/Runtime/Numeric.h"
35#include "flang/Optimizer/Builder/Runtime/RTBuilder.h"
36#include "flang/Optimizer/Builder/Runtime/Reduction.h"
37#include "flang/Optimizer/Builder/Runtime/Stop.h"
38#include "flang/Optimizer/Builder/Runtime/Transformational.h"
39#include "flang/Optimizer/Builder/Todo.h"
40#include "flang/Optimizer/Dialect/FIROps.h"
41#include "flang/Optimizer/Dialect/FIROpsSupport.h"
42#include "flang/Optimizer/Dialect/Support/FIRContext.h"
43#include "flang/Optimizer/HLFIR/HLFIROps.h"
44#include "flang/Optimizer/Support/FatalError.h"
45#include "flang/Optimizer/Support/Utils.h"
46#include "flang/Runtime/entry-names.h"
47#include "flang/Runtime/iostat-consts.h"
48#include "mlir/Dialect/Complex/IR/Complex.h"
49#include "mlir/Dialect/LLVMIR/LLVMDialect.h"
50#include "mlir/Dialect/LLVMIR/LLVMTypes.h"
51#include "mlir/Dialect/Math/IR/Math.h"
52#include "mlir/Dialect/Vector/IR/VectorOps.h"
53#include "llvm/Support/CommandLine.h"
54#include "llvm/Support/Debug.h"
55#include "llvm/Support/MathExtras.h"
56#include "llvm/Support/raw_ostream.h"
57#include <cfenv> // temporary -- only used in genIeeeGetOrSetModesOrStatus
58#include <optional>
59
60#define DEBUG_TYPE "flang-lower-intrinsic"
61
62/// This file implements lowering of Fortran intrinsic procedures and Fortran
63/// intrinsic module procedures. A call may be inlined with a mix of FIR and
64/// MLIR operations, or as a call to a runtime function or LLVM intrinsic.
65
66/// Lowering of intrinsic procedure calls is based on a map that associates
67/// Fortran intrinsic generic names to FIR generator functions.
68/// All generator functions are member functions of the IntrinsicLibrary class
69/// and have the same interface.
70/// If no generator is given for an intrinsic name, a math runtime library
71/// is searched for an implementation and, if a runtime function is found,
72/// a call is generated for it. LLVM intrinsics are handled as a math
73/// runtime library here.
74
75namespace fir {
76
77fir::ExtendedValue getAbsentIntrinsicArgument() { return fir::UnboxedValue{}; }
78
79/// Test if an ExtendedValue is absent. This is used to test if an intrinsic
80/// argument are absent at compile time.
81static bool isStaticallyAbsent(const fir::ExtendedValue &exv) {
82 return !fir::getBase(exv);
83}
84static bool isStaticallyAbsent(llvm::ArrayRef<fir::ExtendedValue> args,
85 size_t argIndex) {
86 return args.size() <= argIndex || isStaticallyAbsent(args[argIndex]);
87}
88static bool isStaticallyAbsent(llvm::ArrayRef<mlir::Value> args,
89 size_t argIndex) {
90 return args.size() <= argIndex || !args[argIndex];
91}
92
93/// Test if an ExtendedValue is present. This is used to test if an intrinsic
94/// argument is present at compile time. This does not imply that the related
95/// value may not be an absent dummy optional, disassociated pointer, or a
96/// deallocated allocatable. See `handleDynamicOptional` to deal with these
97/// cases when it makes sense.
98static bool isStaticallyPresent(const fir::ExtendedValue &exv) {
99 return !isStaticallyAbsent(exv);
100}
101
102using I = IntrinsicLibrary;
103
104/// Flag to indicate that an intrinsic argument has to be handled as
105/// being dynamically optional (e.g. special handling when actual
106/// argument is an optional variable in the current scope).
107static constexpr bool handleDynamicOptional = true;
108
109/// TODO: Move all CUDA Fortran intrinsic handlers into its own file similar to
110/// PPC.
111static const char __ldca_i4x4[] = "__ldca_i4x4_";
112static const char __ldca_i8x2[] = "__ldca_i8x2_";
113static const char __ldca_r2x2[] = "__ldca_r2x2_";
114static const char __ldca_r4x4[] = "__ldca_r4x4_";
115static const char __ldca_r8x2[] = "__ldca_r8x2_";
116static const char __ldcg_i4x4[] = "__ldcg_i4x4_";
117static const char __ldcg_i8x2[] = "__ldcg_i8x2_";
118static const char __ldcg_r2x2[] = "__ldcg_r2x2_";
119static const char __ldcg_r4x4[] = "__ldcg_r4x4_";
120static const char __ldcg_r8x2[] = "__ldcg_r8x2_";
121static const char __ldcs_i4x4[] = "__ldcs_i4x4_";
122static const char __ldcs_i8x2[] = "__ldcs_i8x2_";
123static const char __ldcs_r2x2[] = "__ldcs_r2x2_";
124static const char __ldcs_r4x4[] = "__ldcs_r4x4_";
125static const char __ldcs_r8x2[] = "__ldcs_r8x2_";
126static const char __ldcv_i4x4[] = "__ldcv_i4x4_";
127static const char __ldcv_i8x2[] = "__ldcv_i8x2_";
128static const char __ldcv_r2x2[] = "__ldcv_r2x2_";
129static const char __ldcv_r4x4[] = "__ldcv_r4x4_";
130static const char __ldcv_r8x2[] = "__ldcv_r8x2_";
131static const char __ldlu_i4x4[] = "__ldlu_i4x4_";
132static const char __ldlu_i8x2[] = "__ldlu_i8x2_";
133static const char __ldlu_r2x2[] = "__ldlu_r2x2_";
134static const char __ldlu_r4x4[] = "__ldlu_r4x4_";
135static const char __ldlu_r8x2[] = "__ldlu_r8x2_";
136
137/// Table that drives the fir generation depending on the intrinsic or intrinsic
138/// module procedure one to one mapping with Fortran arguments. If no mapping is
139/// defined here for a generic intrinsic, genRuntimeCall will be called
140/// to look for a match in the runtime a emit a call. Note that the argument
141/// lowering rules for an intrinsic need to be provided only if at least one
142/// argument must not be lowered by value. In which case, the lowering rules
143/// should be provided for all the intrinsic arguments for completeness.
144static constexpr IntrinsicHandler handlers[]{
145 {"__ldca_i4x4",
146 &I::genCUDALDXXFunc<__ldca_i4x4, 4>,
147 {{{"a", asAddr}}},
148 /*isElemental=*/false},
149 {"__ldca_i8x2",
150 &I::genCUDALDXXFunc<__ldca_i8x2, 2>,
151 {{{"a", asAddr}}},
152 /*isElemental=*/false},
153 {"__ldca_r2x2",
154 &I::genCUDALDXXFunc<__ldca_r2x2, 2>,
155 {{{"a", asAddr}}},
156 /*isElemental=*/false},
157 {"__ldca_r4x4",
158 &I::genCUDALDXXFunc<__ldca_r4x4, 4>,
159 {{{"a", asAddr}}},
160 /*isElemental=*/false},
161 {"__ldca_r8x2",
162 &I::genCUDALDXXFunc<__ldca_r8x2, 2>,
163 {{{"a", asAddr}}},
164 /*isElemental=*/false},
165 {"__ldcg_i4x4",
166 &I::genCUDALDXXFunc<__ldcg_i4x4, 4>,
167 {{{"a", asAddr}}},
168 /*isElemental=*/false},
169 {"__ldcg_i8x2",
170 &I::genCUDALDXXFunc<__ldcg_i8x2, 2>,
171 {{{"a", asAddr}}},
172 /*isElemental=*/false},
173 {"__ldcg_r2x2",
174 &I::genCUDALDXXFunc<__ldcg_r2x2, 2>,
175 {{{"a", asAddr}}},
176 /*isElemental=*/false},
177 {"__ldcg_r4x4",
178 &I::genCUDALDXXFunc<__ldcg_r4x4, 4>,
179 {{{"a", asAddr}}},
180 /*isElemental=*/false},
181 {"__ldcg_r8x2",
182 &I::genCUDALDXXFunc<__ldcg_r8x2, 2>,
183 {{{"a", asAddr}}},
184 /*isElemental=*/false},
185 {"__ldcs_i4x4",
186 &I::genCUDALDXXFunc<__ldcs_i4x4, 4>,
187 {{{"a", asAddr}}},
188 /*isElemental=*/false},
189 {"__ldcs_i8x2",
190 &I::genCUDALDXXFunc<__ldcs_i8x2, 2>,
191 {{{"a", asAddr}}},
192 /*isElemental=*/false},
193 {"__ldcs_r2x2",
194 &I::genCUDALDXXFunc<__ldcs_r2x2, 2>,
195 {{{"a", asAddr}}},
196 /*isElemental=*/false},
197 {"__ldcs_r4x4",
198 &I::genCUDALDXXFunc<__ldcs_r4x4, 4>,
199 {{{"a", asAddr}}},
200 /*isElemental=*/false},
201 {"__ldcs_r8x2",
202 &I::genCUDALDXXFunc<__ldcs_r8x2, 2>,
203 {{{"a", asAddr}}},
204 /*isElemental=*/false},
205 {"__ldcv_i4x4",
206 &I::genCUDALDXXFunc<__ldcv_i4x4, 4>,
207 {{{"a", asAddr}}},
208 /*isElemental=*/false},
209 {"__ldcv_i8x2",
210 &I::genCUDALDXXFunc<__ldcv_i8x2, 2>,
211 {{{"a", asAddr}}},
212 /*isElemental=*/false},
213 {"__ldcv_r2x2",
214 &I::genCUDALDXXFunc<__ldcv_r2x2, 2>,
215 {{{"a", asAddr}}},
216 /*isElemental=*/false},
217 {"__ldcv_r4x4",
218 &I::genCUDALDXXFunc<__ldcv_r4x4, 4>,
219 {{{"a", asAddr}}},
220 /*isElemental=*/false},
221 {"__ldcv_r8x2",
222 &I::genCUDALDXXFunc<__ldcv_r8x2, 2>,
223 {{{"a", asAddr}}},
224 /*isElemental=*/false},
225 {"__ldlu_i4x4",
226 &I::genCUDALDXXFunc<__ldlu_i4x4, 4>,
227 {{{"a", asAddr}}},
228 /*isElemental=*/false},
229 {"__ldlu_i8x2",
230 &I::genCUDALDXXFunc<__ldlu_i8x2, 2>,
231 {{{"a", asAddr}}},
232 /*isElemental=*/false},
233 {"__ldlu_r2x2",
234 &I::genCUDALDXXFunc<__ldlu_r2x2, 2>,
235 {{{"a", asAddr}}},
236 /*isElemental=*/false},
237 {"__ldlu_r4x4",
238 &I::genCUDALDXXFunc<__ldlu_r4x4, 4>,
239 {{{"a", asAddr}}},
240 /*isElemental=*/false},
241 {"__ldlu_r8x2",
242 &I::genCUDALDXXFunc<__ldlu_r8x2, 2>,
243 {{{"a", asAddr}}},
244 /*isElemental=*/false},
245 {"abort", &I::genAbort},
246 {"abs", &I::genAbs},
247 {"achar", &I::genChar},
248 {"acosd", &I::genAcosd},
249 {"adjustl",
250 &I::genAdjustRtCall<fir::runtime::genAdjustL>,
251 {{{"string", asAddr}}},
252 /*isElemental=*/true},
253 {"adjustr",
254 &I::genAdjustRtCall<fir::runtime::genAdjustR>,
255 {{{"string", asAddr}}},
256 /*isElemental=*/true},
257 {"aimag", &I::genAimag},
258 {"aint", &I::genAint},
259 {"all",
260 &I::genAll,
261 {{{"mask", asAddr}, {"dim", asValue}}},
262 /*isElemental=*/false},
263 {"all_sync",
264 &I::genVoteSync<mlir::NVVM::VoteSyncKind::all>,
265 {{{"mask", asValue}, {"pred", asValue}}},
266 /*isElemental=*/false},
267 {"allocated",
268 &I::genAllocated,
269 {{{"array", asInquired}, {"scalar", asInquired}}},
270 /*isElemental=*/false},
271 {"anint", &I::genAnint},
272 {"any",
273 &I::genAny,
274 {{{"mask", asAddr}, {"dim", asValue}}},
275 /*isElemental=*/false},
276 {"any_sync",
277 &I::genVoteSync<mlir::NVVM::VoteSyncKind::any>,
278 {{{"mask", asValue}, {"pred", asValue}}},
279 /*isElemental=*/false},
280 {"asind", &I::genAsind},
281 {"associated",
282 &I::genAssociated,
283 {{{"pointer", asInquired}, {"target", asInquired}}},
284 /*isElemental=*/false},
285 {"atan2d", &I::genAtand},
286 {"atan2pi", &I::genAtanpi},
287 {"atand", &I::genAtand},
288 {"atanpi", &I::genAtanpi},
289 {"atomicaddd", &I::genAtomicAdd, {{{"a", asAddr}, {"v", asValue}}}, false},
290 {"atomicaddf", &I::genAtomicAdd, {{{"a", asAddr}, {"v", asValue}}}, false},
291 {"atomicaddi", &I::genAtomicAdd, {{{"a", asAddr}, {"v", asValue}}}, false},
292 {"atomicaddl", &I::genAtomicAdd, {{{"a", asAddr}, {"v", asValue}}}, false},
293 {"atomicandi", &I::genAtomicAnd, {{{"a", asAddr}, {"v", asValue}}}, false},
294 {"atomiccasd",
295 &I::genAtomicCas,
296 {{{"a", asAddr}, {"v1", asValue}, {"v2", asValue}}},
297 false},
298 {"atomiccasf",
299 &I::genAtomicCas,
300 {{{"a", asAddr}, {"v1", asValue}, {"v2", asValue}}},
301 false},
302 {"atomiccasi",
303 &I::genAtomicCas,
304 {{{"a", asAddr}, {"v1", asValue}, {"v2", asValue}}},
305 false},
306 {"atomiccasul",
307 &I::genAtomicCas,
308 {{{"a", asAddr}, {"v1", asValue}, {"v2", asValue}}},
309 false},
310 {"atomicdeci", &I::genAtomicDec, {{{"a", asAddr}, {"v", asValue}}}, false},
311 {"atomicexchd",
312 &I::genAtomicExch,
313 {{{"a", asAddr}, {"v", asValue}}},
314 false},
315 {"atomicexchf",
316 &I::genAtomicExch,
317 {{{"a", asAddr}, {"v", asValue}}},
318 false},
319 {"atomicexchi",
320 &I::genAtomicExch,
321 {{{"a", asAddr}, {"v", asValue}}},
322 false},
323 {"atomicexchul",
324 &I::genAtomicExch,
325 {{{"a", asAddr}, {"v", asValue}}},
326 false},
327 {"atomicinci", &I::genAtomicInc, {{{"a", asAddr}, {"v", asValue}}}, false},
328 {"atomicmaxd", &I::genAtomicMax, {{{"a", asAddr}, {"v", asValue}}}, false},
329 {"atomicmaxf", &I::genAtomicMax, {{{"a", asAddr}, {"v", asValue}}}, false},
330 {"atomicmaxi", &I::genAtomicMax, {{{"a", asAddr}, {"v", asValue}}}, false},
331 {"atomicmaxl", &I::genAtomicMax, {{{"a", asAddr}, {"v", asValue}}}, false},
332 {"atomicmind", &I::genAtomicMin, {{{"a", asAddr}, {"v", asValue}}}, false},
333 {"atomicminf", &I::genAtomicMin, {{{"a", asAddr}, {"v", asValue}}}, false},
334 {"atomicmini", &I::genAtomicMin, {{{"a", asAddr}, {"v", asValue}}}, false},
335 {"atomicminl", &I::genAtomicMin, {{{"a", asAddr}, {"v", asValue}}}, false},
336 {"atomicori", &I::genAtomicOr, {{{"a", asAddr}, {"v", asValue}}}, false},
337 {"atomicsubd", &I::genAtomicSub, {{{"a", asAddr}, {"v", asValue}}}, false},
338 {"atomicsubf", &I::genAtomicSub, {{{"a", asAddr}, {"v", asValue}}}, false},
339 {"atomicsubi", &I::genAtomicSub, {{{"a", asAddr}, {"v", asValue}}}, false},
340 {"atomicsubl", &I::genAtomicSub, {{{"a", asAddr}, {"v", asValue}}}, false},
341 {"atomicxori", &I::genAtomicXor, {{{"a", asAddr}, {"v", asValue}}}, false},
342 {"ballot_sync",
343 &I::genVoteSync<mlir::NVVM::VoteSyncKind::ballot>,
344 {{{"mask", asValue}, {"pred", asValue}}},
345 /*isElemental=*/false},
346 {"bessel_jn",
347 &I::genBesselJn,
348 {{{"n1", asValue}, {"n2", asValue}, {"x", asValue}}},
349 /*isElemental=*/false},
350 {"bessel_yn",
351 &I::genBesselYn,
352 {{{"n1", asValue}, {"n2", asValue}, {"x", asValue}}},
353 /*isElemental=*/false},
354 {"bge", &I::genBitwiseCompare<mlir::arith::CmpIPredicate::uge>},
355 {"bgt", &I::genBitwiseCompare<mlir::arith::CmpIPredicate::ugt>},
356 {"ble", &I::genBitwiseCompare<mlir::arith::CmpIPredicate::ule>},
357 {"blt", &I::genBitwiseCompare<mlir::arith::CmpIPredicate::ult>},
358 {"btest", &I::genBtest},
359 {"c_associated_c_funptr",
360 &I::genCAssociatedCFunPtr,
361 {{{"c_ptr_1", asAddr}, {"c_ptr_2", asAddr, handleDynamicOptional}}},
362 /*isElemental=*/false},
363 {"c_associated_c_ptr",
364 &I::genCAssociatedCPtr,
365 {{{"c_ptr_1", asAddr}, {"c_ptr_2", asAddr, handleDynamicOptional}}},
366 /*isElemental=*/false},
367 {"c_devloc", &I::genCDevLoc, {{{"x", asBox}}}, /*isElemental=*/false},
368 {"c_f_pointer",
369 &I::genCFPointer,
370 {{{"cptr", asValue},
371 {"fptr", asInquired},
372 {"shape", asAddr, handleDynamicOptional}}},
373 /*isElemental=*/false},
374 {"c_f_procpointer",
375 &I::genCFProcPointer,
376 {{{"cptr", asValue}, {"fptr", asInquired}}},
377 /*isElemental=*/false},
378 {"c_funloc", &I::genCFunLoc, {{{"x", asBox}}}, /*isElemental=*/false},
379 {"c_loc", &I::genCLoc, {{{"x", asBox}}}, /*isElemental=*/false},
380 {"c_ptr_eq", &I::genCPtrCompare<mlir::arith::CmpIPredicate::eq>},
381 {"c_ptr_ne", &I::genCPtrCompare<mlir::arith::CmpIPredicate::ne>},
382 {"ceiling", &I::genCeiling},
383 {"char", &I::genChar},
384 {"chdir",
385 &I::genChdir,
386 {{{"name", asAddr}, {"status", asAddr, handleDynamicOptional}}},
387 /*isElemental=*/false},
388 {"clock64", &I::genClock64, {}, /*isElemental=*/false},
389 {"cmplx",
390 &I::genCmplx,
391 {{{"x", asValue}, {"y", asValue, handleDynamicOptional}}}},
392 {"command_argument_count", &I::genCommandArgumentCount},
393 {"conjg", &I::genConjg},
394 {"cosd", &I::genCosd},
395 {"count",
396 &I::genCount,
397 {{{"mask", asAddr}, {"dim", asValue}, {"kind", asValue}}},
398 /*isElemental=*/false},
399 {"cpu_time",
400 &I::genCpuTime,
401 {{{"time", asAddr}}},
402 /*isElemental=*/false},
403 {"cshift",
404 &I::genCshift,
405 {{{"array", asAddr}, {"shift", asAddr}, {"dim", asValue}}},
406 /*isElemental=*/false},
407 {"date_and_time",
408 &I::genDateAndTime,
409 {{{"date", asAddr, handleDynamicOptional},
410 {"time", asAddr, handleDynamicOptional},
411 {"zone", asAddr, handleDynamicOptional},
412 {"values", asBox, handleDynamicOptional}}},
413 /*isElemental=*/false},
414 {"dble", &I::genConversion},
415 {"dim", &I::genDim},
416 {"dot_product",
417 &I::genDotProduct,
418 {{{"vector_a", asBox}, {"vector_b", asBox}}},
419 /*isElemental=*/false},
420 {"dprod", &I::genDprod},
421 {"dshiftl", &I::genDshiftl},
422 {"dshiftr", &I::genDshiftr},
423 {"eoshift",
424 &I::genEoshift,
425 {{{"array", asBox},
426 {"shift", asAddr},
427 {"boundary", asBox, handleDynamicOptional},
428 {"dim", asValue}}},
429 /*isElemental=*/false},
430 {"erfc_scaled", &I::genErfcScaled},
431 {"etime",
432 &I::genEtime,
433 {{{"values", asBox}, {"time", asBox}}},
434 /*isElemental=*/false},
435 {"execute_command_line",
436 &I::genExecuteCommandLine,
437 {{{"command", asBox},
438 {"wait", asAddr, handleDynamicOptional},
439 {"exitstat", asBox, handleDynamicOptional},
440 {"cmdstat", asBox, handleDynamicOptional},
441 {"cmdmsg", asBox, handleDynamicOptional}}},
442 /*isElemental=*/false},
443 {"exit",
444 &I::genExit,
445 {{{"status", asValue, handleDynamicOptional}}},
446 /*isElemental=*/false},
447 {"exponent", &I::genExponent},
448 {"extends_type_of",
449 &I::genExtendsTypeOf,
450 {{{"a", asBox}, {"mold", asBox}}},
451 /*isElemental=*/false},
452 {"findloc",
453 &I::genFindloc,
454 {{{"array", asBox},
455 {"value", asAddr},
456 {"dim", asValue},
457 {"mask", asBox, handleDynamicOptional},
458 {"kind", asValue},
459 {"back", asValue, handleDynamicOptional}}},
460 /*isElemental=*/false},
461 {"floor", &I::genFloor},
462 {"fraction", &I::genFraction},
463 {"free", &I::genFree},
464 {"fseek",
465 &I::genFseek,
466 {{{"unit", asValue},
467 {"offset", asValue},
468 {"whence", asValue},
469 {"status", asAddr, handleDynamicOptional}}},
470 /*isElemental=*/false},
471 {"ftell",
472 &I::genFtell,
473 {{{"unit", asValue}, {"offset", asAddr}}},
474 /*isElemental=*/false},
475 {"get_command",
476 &I::genGetCommand,
477 {{{"command", asBox, handleDynamicOptional},
478 {"length", asBox, handleDynamicOptional},
479 {"status", asAddr, handleDynamicOptional},
480 {"errmsg", asBox, handleDynamicOptional}}},
481 /*isElemental=*/false},
482 {"get_command_argument",
483 &I::genGetCommandArgument,
484 {{{"number", asValue},
485 {"value", asBox, handleDynamicOptional},
486 {"length", asBox, handleDynamicOptional},
487 {"status", asAddr, handleDynamicOptional},
488 {"errmsg", asBox, handleDynamicOptional}}},
489 /*isElemental=*/false},
490 {"get_environment_variable",
491 &I::genGetEnvironmentVariable,
492 {{{"name", asBox},
493 {"value", asBox, handleDynamicOptional},
494 {"length", asBox, handleDynamicOptional},
495 {"status", asAddr, handleDynamicOptional},
496 {"trim_name", asAddr, handleDynamicOptional},
497 {"errmsg", asBox, handleDynamicOptional}}},
498 /*isElemental=*/false},
499 {"getcwd",
500 &I::genGetCwd,
501 {{{"c", asBox}, {"status", asAddr, handleDynamicOptional}}},
502 /*isElemental=*/false},
503 {"getgid", &I::genGetGID},
504 {"getpid", &I::genGetPID},
505 {"getuid", &I::genGetUID},
506 {"hostnm",
507 &I::genHostnm,
508 {{{"c", asBox}, {"status", asAddr, handleDynamicOptional}}},
509 /*isElemental=*/false},
510 {"iachar", &I::genIchar},
511 {"iall",
512 &I::genIall,
513 {{{"array", asBox},
514 {"dim", asValue},
515 {"mask", asBox, handleDynamicOptional}}},
516 /*isElemental=*/false},
517 {"iand", &I::genIand},
518 {"iany",
519 &I::genIany,
520 {{{"array", asBox},
521 {"dim", asValue},
522 {"mask", asBox, handleDynamicOptional}}},
523 /*isElemental=*/false},
524 {"ibclr", &I::genIbclr},
525 {"ibits", &I::genIbits},
526 {"ibset", &I::genIbset},
527 {"ichar", &I::genIchar},
528 {"ieee_class", &I::genIeeeClass},
529 {"ieee_class_eq", &I::genIeeeTypeCompare<mlir::arith::CmpIPredicate::eq>},
530 {"ieee_class_ne", &I::genIeeeTypeCompare<mlir::arith::CmpIPredicate::ne>},
531 {"ieee_copy_sign", &I::genIeeeCopySign},
532 {"ieee_get_flag",
533 &I::genIeeeGetFlag,
534 {{{"flag", asValue}, {"flag_value", asAddr}}}},
535 {"ieee_get_halting_mode",
536 &I::genIeeeGetHaltingMode,
537 {{{"flag", asValue}, {"halting", asAddr}}}},
538 {"ieee_get_modes",
539 &I::genIeeeGetOrSetModesOrStatus</*isGet=*/true, /*isModes=*/true>},
540 {"ieee_get_rounding_mode",
541 &I::genIeeeGetRoundingMode,
542 {{{"round_value", asAddr, handleDynamicOptional},
543 {"radix", asValue, handleDynamicOptional}}},
544 /*isElemental=*/false},
545 {"ieee_get_status",
546 &I::genIeeeGetOrSetModesOrStatus</*isGet=*/true, /*isModes=*/false>},
547 {"ieee_get_underflow_mode",
548 &I::genIeeeGetUnderflowMode,
549 {{{"gradual", asAddr}}},
550 /*isElemental=*/false},
551 {"ieee_int", &I::genIeeeInt},
552 {"ieee_is_finite", &I::genIeeeIsFinite},
553 {"ieee_is_nan", &I::genIeeeIsNan},
554 {"ieee_is_negative", &I::genIeeeIsNegative},
555 {"ieee_is_normal", &I::genIeeeIsNormal},
556 {"ieee_logb", &I::genIeeeLogb},
557 {"ieee_max",
558 &I::genIeeeMaxMin</*isMax=*/true, /*isNum=*/false, /*isMag=*/false>},
559 {"ieee_max_mag",
560 &I::genIeeeMaxMin</*isMax=*/true, /*isNum=*/false, /*isMag=*/true>},
561 {"ieee_max_num",
562 &I::genIeeeMaxMin</*isMax=*/true, /*isNum=*/true, /*isMag=*/false>},
563 {"ieee_max_num_mag",
564 &I::genIeeeMaxMin</*isMax=*/true, /*isNum=*/true, /*isMag=*/true>},
565 {"ieee_min",
566 &I::genIeeeMaxMin</*isMax=*/false, /*isNum=*/false, /*isMag=*/false>},
567 {"ieee_min_mag",
568 &I::genIeeeMaxMin</*isMax=*/false, /*isNum=*/false, /*isMag=*/true>},
569 {"ieee_min_num",
570 &I::genIeeeMaxMin</*isMax=*/false, /*isNum=*/true, /*isMag=*/false>},
571 {"ieee_min_num_mag",
572 &I::genIeeeMaxMin</*isMax=*/false, /*isNum=*/true, /*isMag=*/true>},
573 {"ieee_next_after", &I::genNearest<I::NearestProc::NextAfter>},
574 {"ieee_next_down", &I::genNearest<I::NearestProc::NextDown>},
575 {"ieee_next_up", &I::genNearest<I::NearestProc::NextUp>},
576 {"ieee_quiet_eq", &I::genIeeeQuietCompare<mlir::arith::CmpFPredicate::OEQ>},
577 {"ieee_quiet_ge", &I::genIeeeQuietCompare<mlir::arith::CmpFPredicate::OGE>},
578 {"ieee_quiet_gt", &I::genIeeeQuietCompare<mlir::arith::CmpFPredicate::OGT>},
579 {"ieee_quiet_le", &I::genIeeeQuietCompare<mlir::arith::CmpFPredicate::OLE>},
580 {"ieee_quiet_lt", &I::genIeeeQuietCompare<mlir::arith::CmpFPredicate::OLT>},
581 {"ieee_quiet_ne", &I::genIeeeQuietCompare<mlir::arith::CmpFPredicate::UNE>},
582 {"ieee_real", &I::genIeeeReal},
583 {"ieee_rem", &I::genIeeeRem},
584 {"ieee_rint", &I::genIeeeRint},
585 {"ieee_round_eq", &I::genIeeeTypeCompare<mlir::arith::CmpIPredicate::eq>},
586 {"ieee_round_ne", &I::genIeeeTypeCompare<mlir::arith::CmpIPredicate::ne>},
587 {"ieee_set_flag", &I::genIeeeSetFlagOrHaltingMode</*isFlag=*/true>},
588 {"ieee_set_halting_mode",
589 &I::genIeeeSetFlagOrHaltingMode</*isFlag=*/false>},
590 {"ieee_set_modes",
591 &I::genIeeeGetOrSetModesOrStatus</*isGet=*/false, /*isModes=*/true>},
592 {"ieee_set_rounding_mode",
593 &I::genIeeeSetRoundingMode,
594 {{{"round_value", asValue, handleDynamicOptional},
595 {"radix", asValue, handleDynamicOptional}}},
596 /*isElemental=*/false},
597 {"ieee_set_status",
598 &I::genIeeeGetOrSetModesOrStatus</*isGet=*/false, /*isModes=*/false>},
599 {"ieee_set_underflow_mode", &I::genIeeeSetUnderflowMode},
600 {"ieee_signaling_eq",
601 &I::genIeeeSignalingCompare<mlir::arith::CmpFPredicate::OEQ>},
602 {"ieee_signaling_ge",
603 &I::genIeeeSignalingCompare<mlir::arith::CmpFPredicate::OGE>},
604 {"ieee_signaling_gt",
605 &I::genIeeeSignalingCompare<mlir::arith::CmpFPredicate::OGT>},
606 {"ieee_signaling_le",
607 &I::genIeeeSignalingCompare<mlir::arith::CmpFPredicate::OLE>},
608 {"ieee_signaling_lt",
609 &I::genIeeeSignalingCompare<mlir::arith::CmpFPredicate::OLT>},
610 {"ieee_signaling_ne",
611 &I::genIeeeSignalingCompare<mlir::arith::CmpFPredicate::UNE>},
612 {"ieee_signbit", &I::genIeeeSignbit},
613 {"ieee_support_flag",
614 &I::genIeeeSupportFlag,
615 {{{"flag", asValue}, {"x", asInquired, handleDynamicOptional}}},
616 /*isElemental=*/false},
617 {"ieee_support_halting",
618 &I::genIeeeSupportHalting,
619 {{{"flag", asValue}}},
620 /*isElemental=*/false},
621 {"ieee_support_rounding",
622 &I::genIeeeSupportRounding,
623 {{{"round_value", asValue}, {"x", asInquired, handleDynamicOptional}}},
624 /*isElemental=*/false},
625 {"ieee_support_standard",
626 &I::genIeeeSupportStandard,
627 {{{"flag", asValue}, {"x", asInquired, handleDynamicOptional}}},
628 /*isElemental=*/false},
629 {"ieee_unordered", &I::genIeeeUnordered},
630 {"ieee_value", &I::genIeeeValue},
631 {"ieor", &I::genIeor},
632 {"index",
633 &I::genIndex,
634 {{{"string", asAddr},
635 {"substring", asAddr},
636 {"back", asValue, handleDynamicOptional},
637 {"kind", asValue}}}},
638 {"ior", &I::genIor},
639 {"iparity",
640 &I::genIparity,
641 {{{"array", asBox},
642 {"dim", asValue},
643 {"mask", asBox, handleDynamicOptional}}},
644 /*isElemental=*/false},
645 {"is_contiguous",
646 &I::genIsContiguous,
647 {{{"array", asBox}}},
648 /*isElemental=*/false},
649 {"is_iostat_end", &I::genIsIostatValue<Fortran::runtime::io::IostatEnd>},
650 {"is_iostat_eor", &I::genIsIostatValue<Fortran::runtime::io::IostatEor>},
651 {"ishft", &I::genIshft},
652 {"ishftc", &I::genIshftc},
653 {"isnan", &I::genIeeeIsNan},
654 {"lbound",
655 &I::genLbound,
656 {{{"array", asInquired}, {"dim", asValue}, {"kind", asValue}}},
657 /*isElemental=*/false},
658 {"leadz", &I::genLeadz},
659 {"len",
660 &I::genLen,
661 {{{"string", asInquired}, {"kind", asValue}}},
662 /*isElemental=*/false},
663 {"len_trim", &I::genLenTrim},
664 {"lge", &I::genCharacterCompare<mlir::arith::CmpIPredicate::sge>},
665 {"lgt", &I::genCharacterCompare<mlir::arith::CmpIPredicate::sgt>},
666 {"lle", &I::genCharacterCompare<mlir::arith::CmpIPredicate::sle>},
667 {"llt", &I::genCharacterCompare<mlir::arith::CmpIPredicate::slt>},
668 {"lnblnk", &I::genLenTrim},
669 {"loc", &I::genLoc, {{{"x", asBox}}}, /*isElemental=*/false},
670 {"malloc", &I::genMalloc},
671 {"maskl", &I::genMask<mlir::arith::ShLIOp>},
672 {"maskr", &I::genMask<mlir::arith::ShRUIOp>},
673 {"match_all_syncjd",
674 &I::genMatchAllSync,
675 {{{"mask", asValue}, {"value", asValue}, {"pred", asAddr}}},
676 /*isElemental=*/false},
677 {"match_all_syncjf",
678 &I::genMatchAllSync,
679 {{{"mask", asValue}, {"value", asValue}, {"pred", asAddr}}},
680 /*isElemental=*/false},
681 {"match_all_syncjj",
682 &I::genMatchAllSync,
683 {{{"mask", asValue}, {"value", asValue}, {"pred", asAddr}}},
684 /*isElemental=*/false},
685 {"match_all_syncjx",
686 &I::genMatchAllSync,
687 {{{"mask", asValue}, {"value", asValue}, {"pred", asAddr}}},
688 /*isElemental=*/false},
689 {"match_any_syncjd",
690 &I::genMatchAnySync,
691 {{{"mask", asValue}, {"value", asValue}}},
692 /*isElemental=*/false},
693 {"match_any_syncjf",
694 &I::genMatchAnySync,
695 {{{"mask", asValue}, {"value", asValue}}},
696 /*isElemental=*/false},
697 {"match_any_syncjj",
698 &I::genMatchAnySync,
699 {{{"mask", asValue}, {"value", asValue}}},
700 /*isElemental=*/false},
701 {"match_any_syncjx",
702 &I::genMatchAnySync,
703 {{{"mask", asValue}, {"value", asValue}}},
704 /*isElemental=*/false},
705 {"matmul",
706 &I::genMatmul,
707 {{{"matrix_a", asAddr}, {"matrix_b", asAddr}}},
708 /*isElemental=*/false},
709 {"matmul_transpose",
710 &I::genMatmulTranspose,
711 {{{"matrix_a", asAddr}, {"matrix_b", asAddr}}},
712 /*isElemental=*/false},
713 {"max", &I::genExtremum<Extremum::Max, ExtremumBehavior::MinMaxss>},
714 {"maxloc",
715 &I::genMaxloc,
716 {{{"array", asBox},
717 {"dim", asValue},
718 {"mask", asBox, handleDynamicOptional},
719 {"kind", asValue},
720 {"back", asValue, handleDynamicOptional}}},
721 /*isElemental=*/false},
722 {"maxval",
723 &I::genMaxval,
724 {{{"array", asBox},
725 {"dim", asValue},
726 {"mask", asBox, handleDynamicOptional}}},
727 /*isElemental=*/false},
728 {"merge", &I::genMerge},
729 {"merge_bits", &I::genMergeBits},
730 {"min", &I::genExtremum<Extremum::Min, ExtremumBehavior::MinMaxss>},
731 {"minloc",
732 &I::genMinloc,
733 {{{"array", asBox},
734 {"dim", asValue},
735 {"mask", asBox, handleDynamicOptional},
736 {"kind", asValue},
737 {"back", asValue, handleDynamicOptional}}},
738 /*isElemental=*/false},
739 {"minval",
740 &I::genMinval,
741 {{{"array", asBox},
742 {"dim", asValue},
743 {"mask", asBox, handleDynamicOptional}}},
744 /*isElemental=*/false},
745 {"mod", &I::genMod},
746 {"modulo", &I::genModulo},
747 {"move_alloc",
748 &I::genMoveAlloc,
749 {{{"from", asInquired},
750 {"to", asInquired},
751 {"status", asAddr, handleDynamicOptional},
752 {"errMsg", asBox, handleDynamicOptional}}},
753 /*isElemental=*/false},
754 {"mvbits",
755 &I::genMvbits,
756 {{{"from", asValue},
757 {"frompos", asValue},
758 {"len", asValue},
759 {"to", asAddr},
760 {"topos", asValue}}}},
761 {"nearest", &I::genNearest<I::NearestProc::Nearest>},
762 {"nint", &I::genNint},
763 {"norm2",
764 &I::genNorm2,
765 {{{"array", asBox}, {"dim", asValue}}},
766 /*isElemental=*/false},
767 {"not", &I::genNot},
768 {"null", &I::genNull, {{{"mold", asInquired}}}, /*isElemental=*/false},
769 {"pack",
770 &I::genPack,
771 {{{"array", asBox},
772 {"mask", asBox},
773 {"vector", asBox, handleDynamicOptional}}},
774 /*isElemental=*/false},
775 {"parity",
776 &I::genParity,
777 {{{"mask", asBox}, {"dim", asValue}}},
778 /*isElemental=*/false},
779 {"perror",
780 &I::genPerror,
781 {{{"string", asBox}}},
782 /*isElemental*/ false},
783 {"popcnt", &I::genPopcnt},
784 {"poppar", &I::genPoppar},
785 {"present",
786 &I::genPresent,
787 {{{"a", asInquired}}},
788 /*isElemental=*/false},
789 {"product",
790 &I::genProduct,
791 {{{"array", asBox},
792 {"dim", asValue},
793 {"mask", asBox, handleDynamicOptional}}},
794 /*isElemental=*/false},
795 {"putenv",
796 &I::genPutenv,
797 {{{"str", asAddr}, {"status", asAddr, handleDynamicOptional}}},
798 /*isElemental=*/false},
799 {"random_init",
800 &I::genRandomInit,
801 {{{"repeatable", asValue}, {"image_distinct", asValue}}},
802 /*isElemental=*/false},
803 {"random_number",
804 &I::genRandomNumber,
805 {{{"harvest", asBox}}},
806 /*isElemental=*/false},
807 {"random_seed",
808 &I::genRandomSeed,
809 {{{"size", asBox, handleDynamicOptional},
810 {"put", asBox, handleDynamicOptional},
811 {"get", asBox, handleDynamicOptional}}},
812 /*isElemental=*/false},
813 {"reduce",
814 &I::genReduce,
815 {{{"array", asBox},
816 {"operation", asAddr},
817 {"dim", asValue},
818 {"mask", asBox, handleDynamicOptional},
819 {"identity", asAddr, handleDynamicOptional},
820 {"ordered", asValue, handleDynamicOptional}}},
821 /*isElemental=*/false},
822 {"rename",
823 &I::genRename,
824 {{{"path1", asBox},
825 {"path2", asBox},
826 {"status", asBox, handleDynamicOptional}}},
827 /*isElemental=*/false},
828 {"repeat",
829 &I::genRepeat,
830 {{{"string", asAddr}, {"ncopies", asValue}}},
831 /*isElemental=*/false},
832 {"reshape",
833 &I::genReshape,
834 {{{"source", asBox},
835 {"shape", asBox},
836 {"pad", asBox, handleDynamicOptional},
837 {"order", asBox, handleDynamicOptional}}},
838 /*isElemental=*/false},
839 {"rrspacing", &I::genRRSpacing},
840 {"same_type_as",
841 &I::genSameTypeAs,
842 {{{"a", asBox}, {"b", asBox}}},
843 /*isElemental=*/false},
844 {"scale",
845 &I::genScale,
846 {{{"x", asValue}, {"i", asValue}}},
847 /*isElemental=*/true},
848 {"scan",
849 &I::genScan,
850 {{{"string", asAddr},
851 {"set", asAddr},
852 {"back", asValue, handleDynamicOptional},
853 {"kind", asValue}}},
854 /*isElemental=*/true},
855 {"second",
856 &I::genSecond,
857 {{{"time", asAddr}}},
858 /*isElemental=*/false},
859 {"selected_char_kind",
860 &I::genSelectedCharKind,
861 {{{"name", asAddr}}},
862 /*isElemental=*/false},
863 {"selected_int_kind",
864 &I::genSelectedIntKind,
865 {{{"scalar", asAddr}}},
866 /*isElemental=*/false},
867 {"selected_logical_kind",
868 &I::genSelectedLogicalKind,
869 {{{"bits", asAddr}}},
870 /*isElemental=*/false},
871 {"selected_real_kind",
872 &I::genSelectedRealKind,
873 {{{"precision", asAddr, handleDynamicOptional},
874 {"range", asAddr, handleDynamicOptional},
875 {"radix", asAddr, handleDynamicOptional}}},
876 /*isElemental=*/false},
877 {"selected_unsigned_kind",
878 &I::genSelectedIntKind, // same results as selected_int_kind
879 {{{"scalar", asAddr}}},
880 /*isElemental=*/false},
881 {"set_exponent", &I::genSetExponent},
882 {"shape",
883 &I::genShape,
884 {{{"source", asBox}, {"kind", asValue}}},
885 /*isElemental=*/false},
886 {"shifta", &I::genShiftA},
887 {"shiftl", &I::genShift<mlir::arith::ShLIOp>},
888 {"shiftr", &I::genShift<mlir::arith::ShRUIOp>},
889 {"sign", &I::genSign},
890 {"signal",
891 &I::genSignalSubroutine,
892 {{{"number", asValue}, {"handler", asAddr}, {"status", asAddr}}},
893 /*isElemental=*/false},
894 {"sind", &I::genSind},
895 {"size",
896 &I::genSize,
897 {{{"array", asBox},
898 {"dim", asAddr, handleDynamicOptional},
899 {"kind", asValue}}},
900 /*isElemental=*/false},
901 {"sizeof",
902 &I::genSizeOf,
903 {{{"a", asBox}}},
904 /*isElemental=*/false},
905 {"sleep", &I::genSleep, {{{"seconds", asValue}}}, /*isElemental=*/false},
906 {"spacing", &I::genSpacing},
907 {"spread",
908 &I::genSpread,
909 {{{"source", asBox}, {"dim", asValue}, {"ncopies", asValue}}},
910 /*isElemental=*/false},
911 {"storage_size",
912 &I::genStorageSize,
913 {{{"a", asInquired}, {"kind", asValue}}},
914 /*isElemental=*/false},
915 {"sum",
916 &I::genSum,
917 {{{"array", asBox},
918 {"dim", asValue},
919 {"mask", asBox, handleDynamicOptional}}},
920 /*isElemental=*/false},
921 {"syncthreads", &I::genSyncThreads, {}, /*isElemental=*/false},
922 {"syncthreads_and", &I::genSyncThreadsAnd, {}, /*isElemental=*/false},
923 {"syncthreads_count", &I::genSyncThreadsCount, {}, /*isElemental=*/false},
924 {"syncthreads_or", &I::genSyncThreadsOr, {}, /*isElemental=*/false},
925 {"syncwarp", &I::genSyncWarp, {}, /*isElemental=*/false},
926 {"system",
927 &I::genSystem,
928 {{{"command", asBox}, {"exitstat", asBox, handleDynamicOptional}}},
929 /*isElemental=*/false},
930 {"system_clock",
931 &I::genSystemClock,
932 {{{"count", asAddr}, {"count_rate", asAddr}, {"count_max", asAddr}}},
933 /*isElemental=*/false},
934 {"tand", &I::genTand},
935 {"threadfence", &I::genThreadFence, {}, /*isElemental=*/false},
936 {"threadfence_block", &I::genThreadFenceBlock, {}, /*isElemental=*/false},
937 {"threadfence_system", &I::genThreadFenceSystem, {}, /*isElemental=*/false},
938 {"time", &I::genTime, {}, /*isElemental=*/false},
939 {"trailz", &I::genTrailz},
940 {"transfer",
941 &I::genTransfer,
942 {{{"source", asAddr}, {"mold", asAddr}, {"size", asValue}}},
943 /*isElemental=*/false},
944 {"transpose",
945 &I::genTranspose,
946 {{{"matrix", asAddr}}},
947 /*isElemental=*/false},
948 {"trim", &I::genTrim, {{{"string", asAddr}}}, /*isElemental=*/false},
949 {"ubound",
950 &I::genUbound,
951 {{{"array", asBox}, {"dim", asValue}, {"kind", asValue}}},
952 /*isElemental=*/false},
953 {"umaskl", &I::genMask<mlir::arith::ShLIOp>},
954 {"umaskr", &I::genMask<mlir::arith::ShRUIOp>},
955 {"unlink",
956 &I::genUnlink,
957 {{{"path", asAddr}, {"status", asAddr, handleDynamicOptional}}},
958 /*isElemental=*/false},
959 {"unpack",
960 &I::genUnpack,
961 {{{"vector", asBox}, {"mask", asBox}, {"field", asBox}}},
962 /*isElemental=*/false},
963 {"verify",
964 &I::genVerify,
965 {{{"string", asAddr},
966 {"set", asAddr},
967 {"back", asValue, handleDynamicOptional},
968 {"kind", asValue}}},
969 /*isElemental=*/true},
970};
971
972template <std::size_t N>
973static constexpr bool isSorted(const IntrinsicHandler (&array)[N]) {
974 // Replace by std::sorted when C++20 is default (will be constexpr).
975 const IntrinsicHandler *lastSeen{nullptr};
976 bool isSorted{true};
977 for (const auto &x : array) {
978 if (lastSeen)
979 isSorted &= std::string_view{lastSeen->name} < std::string_view{x.name};
980 lastSeen = &x;
981 }
982 return isSorted;
983}
984static_assert(isSorted(handlers) && "map must be sorted");
985
986static const IntrinsicHandler *findIntrinsicHandler(llvm::StringRef name) {
987 auto compare = [](const IntrinsicHandler &handler, llvm::StringRef name) {
988 return name.compare(handler.name) > 0;
989 };
990 auto result = llvm::lower_bound(handlers, name, compare);
991 return result != std::end(handlers) && result->name == name ? result
992 : nullptr;
993}
994
995/// To make fir output more readable for debug, one can outline all intrinsic
996/// implementation in wrappers (overrides the IntrinsicHandler::outline flag).
997static llvm::cl::opt<bool> outlineAllIntrinsics(
998 "outline-intrinsics",
999 llvm::cl::desc(
1000 "Lower all intrinsic procedure implementation in their own functions"),
1001 llvm::cl::init(Val: false));
1002
1003//===----------------------------------------------------------------------===//
1004// Math runtime description and matching utility
1005//===----------------------------------------------------------------------===//
1006
1007/// Command line option to modify math runtime behavior used to implement
1008/// intrinsics. This option applies both to early and late math-lowering modes.
1009enum MathRuntimeVersion { fastVersion, relaxedVersion, preciseVersion };
1010llvm::cl::opt<MathRuntimeVersion> mathRuntimeVersion(
1011 "math-runtime", llvm::cl::desc("Select math operations' runtime behavior:"),
1012 llvm::cl::values(
1013 clEnumValN(fastVersion, "fast", "use fast runtime behavior"),
1014 clEnumValN(relaxedVersion, "relaxed", "use relaxed runtime behavior"),
1015 clEnumValN(preciseVersion, "precise", "use precise runtime behavior")),
1016 llvm::cl::init(Val: fastVersion));
1017
1018static llvm::cl::opt<bool>
1019 forceMlirComplex("force-mlir-complex",
1020 llvm::cl::desc("Force using MLIR complex operations "
1021 "instead of libm complex operations"),
1022 llvm::cl::init(Val: false));
1023
1024/// Return a string containing the given Fortran intrinsic name
1025/// with the type of its arguments specified in funcType
1026/// surrounded by the given prefix/suffix.
1027static std::string
1028prettyPrintIntrinsicName(fir::FirOpBuilder &builder, mlir::Location loc,
1029 llvm::StringRef prefix, llvm::StringRef name,
1030 llvm::StringRef suffix, mlir::FunctionType funcType) {
1031 std::string output = prefix.str();
1032 llvm::raw_string_ostream sstream(output);
1033 if (name == "pow") {
1034 assert(funcType.getNumInputs() == 2 && "power operator has two arguments");
1035 std::string displayName{" ** "};
1036 sstream << mlirTypeToIntrinsicFortran(builder, funcType.getInput(0), loc,
1037 displayName)
1038 << displayName
1039 << mlirTypeToIntrinsicFortran(builder, funcType.getInput(1), loc,
1040 displayName);
1041 } else {
1042 sstream << name.upper() << "(";
1043 if (funcType.getNumInputs() > 0)
1044 sstream << mlirTypeToIntrinsicFortran(builder, funcType.getInput(0), loc,
1045 name);
1046 for (mlir::Type argType : funcType.getInputs().drop_front()) {
1047 sstream << ", "
1048 << mlirTypeToIntrinsicFortran(builder, argType, loc, name);
1049 }
1050 sstream << ")";
1051 }
1052 sstream << suffix;
1053 return output;
1054}
1055
1056// Generate a call to the Fortran runtime library providing
1057// support for 128-bit float math.
1058// On 'HAS_LDBL128' targets the implementation
1059// is provided by flang_rt, otherwise, it is done via the
1060// libflang_rt.quadmath library. In the latter case the compiler
1061// has to be built with FLANG_RUNTIME_F128_MATH_LIB to guarantee
1062// proper linking actions in the driver.
1063static mlir::Value genLibF128Call(fir::FirOpBuilder &builder,
1064 mlir::Location loc,
1065 const MathOperation &mathOp,
1066 mlir::FunctionType libFuncType,
1067 llvm::ArrayRef<mlir::Value> args) {
1068 // TODO: if we knew that the C 'long double' does not have 113-bit mantissa
1069 // on the target, we could have asserted that FLANG_RUNTIME_F128_MATH_LIB
1070 // must be specified. For now just always generate the call even
1071 // if it will be unresolved.
1072 return genLibCall(builder, loc, mathOp, libFuncType, args);
1073}
1074
1075mlir::Value genLibCall(fir::FirOpBuilder &builder, mlir::Location loc,
1076 const MathOperation &mathOp,
1077 mlir::FunctionType libFuncType,
1078 llvm::ArrayRef<mlir::Value> args) {
1079 llvm::StringRef libFuncName = mathOp.runtimeFunc;
1080
1081 // On AIX, __clog is used in libm.
1082 if (fir::getTargetTriple(builder.getModule()).isOSAIX() &&
1083 libFuncName == "clog") {
1084 libFuncName = "__clog";
1085 }
1086
1087 LLVM_DEBUG(llvm::dbgs() << "Generating '" << libFuncName
1088 << "' call with type ";
1089 libFuncType.dump(); llvm::dbgs() << "\n");
1090 mlir::func::FuncOp funcOp = builder.getNamedFunction(libFuncName);
1091
1092 if (!funcOp) {
1093 funcOp = builder.createFunction(loc, libFuncName, libFuncType);
1094 // C-interoperability rules apply to these library functions.
1095 funcOp->setAttr(fir::getSymbolAttrName(),
1096 mlir::StringAttr::get(builder.getContext(), libFuncName));
1097 // Set fir.runtime attribute to distinguish the function that
1098 // was just created from user functions with the same name.
1099 funcOp->setAttr(fir::FIROpsDialect::getFirRuntimeAttrName(),
1100 builder.getUnitAttr());
1101 auto libCall = builder.create<fir::CallOp>(loc, funcOp, args);
1102 // TODO: ensure 'strictfp' setting on the call for "precise/strict"
1103 // FP mode. Set appropriate Fast-Math Flags otherwise.
1104 // TODO: we should also mark as many libm function as possible
1105 // with 'pure' attribute (of course, not in strict FP mode).
1106 LLVM_DEBUG(libCall.dump(); llvm::dbgs() << "\n");
1107 return libCall.getResult(0);
1108 }
1109
1110 // The function with the same name already exists.
1111 fir::CallOp libCall;
1112 mlir::Type soughtFuncType = funcOp.getFunctionType();
1113
1114 if (soughtFuncType == libFuncType) {
1115 libCall = builder.create<fir::CallOp>(loc, funcOp, args);
1116 } else {
1117 // A function with the same name might have been declared
1118 // before (e.g. with an explicit interface and a binding label).
1119 // It is in general incorrect to use the same definition for the library
1120 // call, but we have no other options. Type cast the function to match
1121 // the requested signature and generate an indirect call to avoid
1122 // later failures caused by the signature mismatch.
1123 LLVM_DEBUG(mlir::emitWarning(
1124 loc, llvm::Twine("function signature mismatch for '") +
1125 llvm::Twine(libFuncName) +
1126 llvm::Twine("' may lead to undefined behavior.")));
1127 mlir::SymbolRefAttr funcSymbolAttr = builder.getSymbolRefAttr(libFuncName);
1128 mlir::Value funcPointer =
1129 builder.create<fir::AddrOfOp>(loc, soughtFuncType, funcSymbolAttr);
1130 funcPointer = builder.createConvert(loc, libFuncType, funcPointer);
1131
1132 llvm::SmallVector<mlir::Value, 3> operands{funcPointer};
1133 operands.append(in_start: args.begin(), in_end: args.end());
1134 libCall = builder.create<fir::CallOp>(loc, mlir::SymbolRefAttr{},
1135 libFuncType.getResults(), operands);
1136 }
1137
1138 LLVM_DEBUG(libCall.dump(); llvm::dbgs() << "\n");
1139 return libCall.getResult(0);
1140}
1141
1142mlir::Value genLibSplitComplexArgsCall(fir::FirOpBuilder &builder,
1143 mlir::Location loc,
1144 const MathOperation &mathOp,
1145 mlir::FunctionType libFuncType,
1146 llvm::ArrayRef<mlir::Value> args) {
1147 assert(args.size() == 2 && "Incorrect #args to genLibSplitComplexArgsCall");
1148
1149 auto getSplitComplexArgsType = [&builder, &args]() -> mlir::FunctionType {
1150 mlir::Type ctype = args[0].getType();
1151 auto ftype = mlir::cast<mlir::ComplexType>(ctype).getElementType();
1152 return builder.getFunctionType({ftype, ftype, ftype, ftype}, {ctype});
1153 };
1154
1155 llvm::SmallVector<mlir::Value, 4> splitArgs;
1156 mlir::Value cplx1 = args[0];
1157 auto real1 = fir::factory::Complex{builder, loc}.extractComplexPart(
1158 cplx1, /*isImagPart=*/false);
1159 splitArgs.push_back(Elt: real1);
1160 auto imag1 = fir::factory::Complex{builder, loc}.extractComplexPart(
1161 cplx1, /*isImagPart=*/true);
1162 splitArgs.push_back(Elt: imag1);
1163 mlir::Value cplx2 = args[1];
1164 auto real2 = fir::factory::Complex{builder, loc}.extractComplexPart(
1165 cplx2, /*isImagPart=*/false);
1166 splitArgs.push_back(Elt: real2);
1167 auto imag2 = fir::factory::Complex{builder, loc}.extractComplexPart(
1168 cplx2, /*isImagPart=*/true);
1169 splitArgs.push_back(Elt: imag2);
1170
1171 return genLibCall(builder, loc, mathOp, getSplitComplexArgsType(), splitArgs);
1172}
1173
1174template <typename T>
1175mlir::Value genMathOp(fir::FirOpBuilder &builder, mlir::Location loc,
1176 const MathOperation &mathOp,
1177 mlir::FunctionType mathLibFuncType,
1178 llvm::ArrayRef<mlir::Value> args) {
1179 // TODO: we have to annotate the math operations with flags
1180 // that will allow to define FP accuracy/exception
1181 // behavior per operation, so that after early multi-module
1182 // MLIR inlining we can distiguish operation that were
1183 // compiled with different settings.
1184 // Suggestion:
1185 // * For "relaxed" FP mode set all Fast-Math Flags
1186 // (see "[RFC] FastMath flags support in MLIR (arith dialect)"
1187 // topic at discourse.llvm.org).
1188 // * For "fast" FP mode set all Fast-Math Flags except 'afn'.
1189 // * For "precise/strict" FP mode generate fir.calls to libm
1190 // entries and annotate them with an attribute that will
1191 // end up transformed into 'strictfp' LLVM attribute (TBD).
1192 // Elsewhere, "precise/strict" FP mode should also set
1193 // 'strictfp' for all user functions and calls so that
1194 // LLVM backend does the right job.
1195 // * Operations that cannot be reasonably optimized in MLIR
1196 // can be also lowered to libm calls for "fast" and "relaxed"
1197 // modes.
1198 mlir::Value result;
1199 llvm::StringRef mathLibFuncName = mathOp.runtimeFunc;
1200 if (mathRuntimeVersion == preciseVersion &&
1201 // Some operations do not have to be lowered as conservative
1202 // calls, since they do not affect strict FP behavior.
1203 // For example, purely integer operations like exponentiation
1204 // with integer operands fall into this class.
1205 !mathLibFuncName.empty()) {
1206 result = genLibCall(builder, loc, mathOp, mathLibFuncType, args);
1207 } else {
1208 LLVM_DEBUG(llvm::dbgs() << "Generating '" << mathLibFuncName
1209 << "' operation with type ";
1210 mathLibFuncType.dump(); llvm::dbgs() << "\n");
1211 result = builder.create<T>(loc, args);
1212 }
1213 LLVM_DEBUG(result.dump(); llvm::dbgs() << "\n");
1214 return result;
1215}
1216
1217template <typename T>
1218mlir::Value genComplexMathOp(fir::FirOpBuilder &builder, mlir::Location loc,
1219 const MathOperation &mathOp,
1220 mlir::FunctionType mathLibFuncType,
1221 llvm::ArrayRef<mlir::Value> args) {
1222 mlir::Value result;
1223 bool canUseApprox = mlir::arith::bitEnumContainsAny(
1224 builder.getFastMathFlags(), mlir::arith::FastMathFlags::afn);
1225
1226 // If we have libm functions, we can attempt to generate the more precise
1227 // version of the complex math operation.
1228 llvm::StringRef mathLibFuncName = mathOp.runtimeFunc;
1229 if (!mathLibFuncName.empty()) {
1230 // If we enabled MLIR complex or can use approximate operations, we should
1231 // NOT use libm.
1232 if (!forceMlirComplex && !canUseApprox) {
1233 result = genLibCall(builder, loc, mathOp, mathLibFuncType, args);
1234 LLVM_DEBUG(result.dump(); llvm::dbgs() << "\n");
1235 return result;
1236 }
1237 }
1238
1239 LLVM_DEBUG(llvm::dbgs() << "Generating '" << mathLibFuncName
1240 << "' operation with type ";
1241 mathLibFuncType.dump(); llvm::dbgs() << "\n");
1242 // Builder expects an extra return type to be provided if different to
1243 // the argument types for an operation
1244 if constexpr (T::template hasTrait<
1245 mlir::OpTrait::SameOperandsAndResultType>()) {
1246 result = builder.create<T>(loc, args);
1247 result = builder.createConvert(loc, mathLibFuncType.getResult(0), result);
1248 } else {
1249 auto complexTy = mlir::cast<mlir::ComplexType>(mathLibFuncType.getInput(0));
1250 auto realTy = complexTy.getElementType();
1251 result = builder.create<T>(loc, realTy, args);
1252 result = builder.createConvert(loc, mathLibFuncType.getResult(0), result);
1253 }
1254
1255 LLVM_DEBUG(result.dump(); llvm::dbgs() << "\n");
1256 return result;
1257}
1258
1259/// Mapping between mathematical intrinsic operations and MLIR operations
1260/// of some appropriate dialect (math, complex, etc.) or libm calls.
1261/// TODO: support remaining Fortran math intrinsics.
1262/// See https://gcc.gnu.org/onlinedocs/gcc-12.1.0/gfortran/\
1263/// Intrinsic-Procedures.html for a reference.
1264constexpr auto FuncTypeReal16Real16 = genFuncType<Ty::Real<16>, Ty::Real<16>>;
1265constexpr auto FuncTypeReal16Real16Real16 =
1266 genFuncType<Ty::Real<16>, Ty::Real<16>, Ty::Real<16>>;
1267constexpr auto FuncTypeReal16Real16Real16Real16 =
1268 genFuncType<Ty::Real<16>, Ty::Real<16>, Ty::Real<16>, Ty::Real<16>>;
1269constexpr auto FuncTypeReal16Integer4Real16 =
1270 genFuncType<Ty::Real<16>, Ty::Integer<4>, Ty::Real<16>>;
1271constexpr auto FuncTypeInteger4Real16 =
1272 genFuncType<Ty::Integer<4>, Ty::Real<16>>;
1273constexpr auto FuncTypeInteger8Real16 =
1274 genFuncType<Ty::Integer<8>, Ty::Real<16>>;
1275constexpr auto FuncTypeReal16Complex16 =
1276 genFuncType<Ty::Real<16>, Ty::Complex<16>>;
1277constexpr auto FuncTypeComplex16Complex16 =
1278 genFuncType<Ty::Complex<16>, Ty::Complex<16>>;
1279constexpr auto FuncTypeComplex16Complex16Complex16 =
1280 genFuncType<Ty::Complex<16>, Ty::Complex<16>, Ty::Complex<16>>;
1281constexpr auto FuncTypeComplex16Complex16Integer4 =
1282 genFuncType<Ty::Complex<16>, Ty::Complex<16>, Ty::Integer<4>>;
1283constexpr auto FuncTypeComplex16Complex16Integer8 =
1284 genFuncType<Ty::Complex<16>, Ty::Complex<16>, Ty::Integer<8>>;
1285
1286static constexpr MathOperation mathOperations[] = {
1287 {"abs", "fabsf", genFuncType<Ty::Real<4>, Ty::Real<4>>,
1288 genMathOp<mlir::math::AbsFOp>},
1289 {"abs", "fabs", genFuncType<Ty::Real<8>, Ty::Real<8>>,
1290 genMathOp<mlir::math::AbsFOp>},
1291 {"abs", "llvm.fabs.f128", genFuncType<Ty::Real<16>, Ty::Real<16>>,
1292 genMathOp<mlir::math::AbsFOp>},
1293 {"abs", "cabsf", genFuncType<Ty::Real<4>, Ty::Complex<4>>,
1294 genComplexMathOp<mlir::complex::AbsOp>},
1295 {"abs", "cabs", genFuncType<Ty::Real<8>, Ty::Complex<8>>,
1296 genComplexMathOp<mlir::complex::AbsOp>},
1297 {"abs", RTNAME_STRING(CAbsF128), FuncTypeReal16Complex16, genLibF128Call},
1298 {"acos", "acosf", genFuncType<Ty::Real<4>, Ty::Real<4>>,
1299 genMathOp<mlir::math::AcosOp>},
1300 {"acos", "acos", genFuncType<Ty::Real<8>, Ty::Real<8>>,
1301 genMathOp<mlir::math::AcosOp>},
1302 {"acos", RTNAME_STRING(AcosF128), FuncTypeReal16Real16, genLibF128Call},
1303 {"acos", "cacosf", genFuncType<Ty::Complex<4>, Ty::Complex<4>>, genLibCall},
1304 {"acos", "cacos", genFuncType<Ty::Complex<8>, Ty::Complex<8>>, genLibCall},
1305 {"acos", RTNAME_STRING(CAcosF128), FuncTypeComplex16Complex16,
1306 genLibF128Call},
1307 {"acosh", "acoshf", genFuncType<Ty::Real<4>, Ty::Real<4>>,
1308 genMathOp<mlir::math::AcoshOp>},
1309 {"acosh", "acosh", genFuncType<Ty::Real<8>, Ty::Real<8>>,
1310 genMathOp<mlir::math::AcoshOp>},
1311 {"acosh", RTNAME_STRING(AcoshF128), FuncTypeReal16Real16, genLibF128Call},
1312 {"acosh", "cacoshf", genFuncType<Ty::Complex<4>, Ty::Complex<4>>,
1313 genLibCall},
1314 {"acosh", "cacosh", genFuncType<Ty::Complex<8>, Ty::Complex<8>>,
1315 genLibCall},
1316 {"acosh", RTNAME_STRING(CAcoshF128), FuncTypeComplex16Complex16,
1317 genLibF128Call},
1318 // llvm.trunc behaves the same way as libm's trunc.
1319 {"aint", "llvm.trunc.f32", genFuncType<Ty::Real<4>, Ty::Real<4>>,
1320 genLibCall},
1321 {"aint", "llvm.trunc.f64", genFuncType<Ty::Real<8>, Ty::Real<8>>,
1322 genLibCall},
1323 {"aint", "llvm.trunc.f80", genFuncType<Ty::Real<10>, Ty::Real<10>>,
1324 genLibCall},
1325 {"aint", RTNAME_STRING(TruncF128), FuncTypeReal16Real16, genLibF128Call},
1326 // llvm.round behaves the same way as libm's round.
1327 {"anint", "llvm.round.f32", genFuncType<Ty::Real<4>, Ty::Real<4>>,
1328 genMathOp<mlir::LLVM::RoundOp>},
1329 {"anint", "llvm.round.f64", genFuncType<Ty::Real<8>, Ty::Real<8>>,
1330 genMathOp<mlir::LLVM::RoundOp>},
1331 {"anint", "llvm.round.f80", genFuncType<Ty::Real<10>, Ty::Real<10>>,
1332 genMathOp<mlir::LLVM::RoundOp>},
1333 {"anint", RTNAME_STRING(RoundF128), FuncTypeReal16Real16, genLibF128Call},
1334 {"asin", "asinf", genFuncType<Ty::Real<4>, Ty::Real<4>>,
1335 genMathOp<mlir::math::AsinOp>},
1336 {"asin", "asin", genFuncType<Ty::Real<8>, Ty::Real<8>>,
1337 genMathOp<mlir::math::AsinOp>},
1338 {"asin", RTNAME_STRING(AsinF128), FuncTypeReal16Real16, genLibF128Call},
1339 {"asin", "casinf", genFuncType<Ty::Complex<4>, Ty::Complex<4>>, genLibCall},
1340 {"asin", "casin", genFuncType<Ty::Complex<8>, Ty::Complex<8>>, genLibCall},
1341 {"asin", RTNAME_STRING(CAsinF128), FuncTypeComplex16Complex16,
1342 genLibF128Call},
1343 {"asinh", "asinhf", genFuncType<Ty::Real<4>, Ty::Real<4>>,
1344 genMathOp<mlir::math::AsinhOp>},
1345 {"asinh", "asinh", genFuncType<Ty::Real<8>, Ty::Real<8>>,
1346 genMathOp<mlir::math::AsinhOp>},
1347 {"asinh", RTNAME_STRING(AsinhF128), FuncTypeReal16Real16, genLibF128Call},
1348 {"asinh", "casinhf", genFuncType<Ty::Complex<4>, Ty::Complex<4>>,
1349 genLibCall},
1350 {"asinh", "casinh", genFuncType<Ty::Complex<8>, Ty::Complex<8>>,
1351 genLibCall},
1352 {"asinh", RTNAME_STRING(CAsinhF128), FuncTypeComplex16Complex16,
1353 genLibF128Call},
1354 {"atan", "atanf", genFuncType<Ty::Real<4>, Ty::Real<4>>,
1355 genMathOp<mlir::math::AtanOp>},
1356 {"atan", "atan", genFuncType<Ty::Real<8>, Ty::Real<8>>,
1357 genMathOp<mlir::math::AtanOp>},
1358 {"atan", RTNAME_STRING(AtanF128), FuncTypeReal16Real16, genLibF128Call},
1359 {"atan", "catanf", genFuncType<Ty::Complex<4>, Ty::Complex<4>>, genLibCall},
1360 {"atan", "catan", genFuncType<Ty::Complex<8>, Ty::Complex<8>>, genLibCall},
1361 {"atan", RTNAME_STRING(CAtanF128), FuncTypeComplex16Complex16,
1362 genLibF128Call},
1363 {"atan", "atan2f", genFuncType<Ty::Real<4>, Ty::Real<4>, Ty::Real<4>>,
1364 genMathOp<mlir::math::Atan2Op>},
1365 {"atan", "atan2", genFuncType<Ty::Real<8>, Ty::Real<8>, Ty::Real<8>>,
1366 genMathOp<mlir::math::Atan2Op>},
1367 {"atan", RTNAME_STRING(Atan2F128), FuncTypeReal16Real16Real16,
1368 genLibF128Call},
1369 {"atan2", "atan2f", genFuncType<Ty::Real<4>, Ty::Real<4>, Ty::Real<4>>,
1370 genMathOp<mlir::math::Atan2Op>},
1371 {"atan2", "atan2", genFuncType<Ty::Real<8>, Ty::Real<8>, Ty::Real<8>>,
1372 genMathOp<mlir::math::Atan2Op>},
1373 {"atan2", RTNAME_STRING(Atan2F128), FuncTypeReal16Real16Real16,
1374 genLibF128Call},
1375 {"atanh", "atanhf", genFuncType<Ty::Real<4>, Ty::Real<4>>,
1376 genMathOp<mlir::math::AtanhOp>},
1377 {"atanh", "atanh", genFuncType<Ty::Real<8>, Ty::Real<8>>,
1378 genMathOp<mlir::math::AtanhOp>},
1379 {"atanh", RTNAME_STRING(AtanhF128), FuncTypeReal16Real16, genLibF128Call},
1380 {"atanh", "catanhf", genFuncType<Ty::Complex<4>, Ty::Complex<4>>,
1381 genLibCall},
1382 {"atanh", "catanh", genFuncType<Ty::Complex<8>, Ty::Complex<8>>,
1383 genLibCall},
1384 {"atanh", RTNAME_STRING(CAtanhF128), FuncTypeComplex16Complex16,
1385 genLibF128Call},
1386 {"bessel_j0", "j0f", genFuncType<Ty::Real<4>, Ty::Real<4>>, genLibCall},
1387 {"bessel_j0", "j0", genFuncType<Ty::Real<8>, Ty::Real<8>>, genLibCall},
1388 {"bessel_j0", RTNAME_STRING(J0F128), FuncTypeReal16Real16, genLibF128Call},
1389 {"bessel_j1", "j1f", genFuncType<Ty::Real<4>, Ty::Real<4>>, genLibCall},
1390 {"bessel_j1", "j1", genFuncType<Ty::Real<8>, Ty::Real<8>>, genLibCall},
1391 {"bessel_j1", RTNAME_STRING(J1F128), FuncTypeReal16Real16, genLibF128Call},
1392 {"bessel_jn", "jnf", genFuncType<Ty::Real<4>, Ty::Integer<4>, Ty::Real<4>>,
1393 genLibCall},
1394 {"bessel_jn", "jn", genFuncType<Ty::Real<8>, Ty::Integer<4>, Ty::Real<8>>,
1395 genLibCall},
1396 {"bessel_jn", RTNAME_STRING(JnF128), FuncTypeReal16Integer4Real16,
1397 genLibF128Call},
1398 {"bessel_y0", "y0f", genFuncType<Ty::Real<4>, Ty::Real<4>>, genLibCall},
1399 {"bessel_y0", "y0", genFuncType<Ty::Real<8>, Ty::Real<8>>, genLibCall},
1400 {"bessel_y0", RTNAME_STRING(Y0F128), FuncTypeReal16Real16, genLibF128Call},
1401 {"bessel_y1", "y1f", genFuncType<Ty::Real<4>, Ty::Real<4>>, genLibCall},
1402 {"bessel_y1", "y1", genFuncType<Ty::Real<8>, Ty::Real<8>>, genLibCall},
1403 {"bessel_y1", RTNAME_STRING(Y1F128), FuncTypeReal16Real16, genLibF128Call},
1404 {"bessel_yn", "ynf", genFuncType<Ty::Real<4>, Ty::Integer<4>, Ty::Real<4>>,
1405 genLibCall},
1406 {"bessel_yn", "yn", genFuncType<Ty::Real<8>, Ty::Integer<4>, Ty::Real<8>>,
1407 genLibCall},
1408 {"bessel_yn", RTNAME_STRING(YnF128), FuncTypeReal16Integer4Real16,
1409 genLibF128Call},
1410 // math::CeilOp returns a real, while Fortran CEILING returns integer.
1411 {"ceil", "ceilf", genFuncType<Ty::Real<4>, Ty::Real<4>>,
1412 genMathOp<mlir::math::CeilOp>},
1413 {"ceil", "ceil", genFuncType<Ty::Real<8>, Ty::Real<8>>,
1414 genMathOp<mlir::math::CeilOp>},
1415 {"ceil", RTNAME_STRING(CeilF128), FuncTypeReal16Real16, genLibF128Call},
1416 {"cos", "cosf", genFuncType<Ty::Real<4>, Ty::Real<4>>,
1417 genMathOp<mlir::math::CosOp>},
1418 {"cos", "cos", genFuncType<Ty::Real<8>, Ty::Real<8>>,
1419 genMathOp<mlir::math::CosOp>},
1420 {"cos", RTNAME_STRING(CosF128), FuncTypeReal16Real16, genLibF128Call},
1421 {"cos", "ccosf", genFuncType<Ty::Complex<4>, Ty::Complex<4>>,
1422 genComplexMathOp<mlir::complex::CosOp>},
1423 {"cos", "ccos", genFuncType<Ty::Complex<8>, Ty::Complex<8>>,
1424 genComplexMathOp<mlir::complex::CosOp>},
1425 {"cos", RTNAME_STRING(CCosF128), FuncTypeComplex16Complex16,
1426 genLibF128Call},
1427 {"cosh", "coshf", genFuncType<Ty::Real<4>, Ty::Real<4>>,
1428 genMathOp<mlir::math::CoshOp>},
1429 {"cosh", "cosh", genFuncType<Ty::Real<8>, Ty::Real<8>>,
1430 genMathOp<mlir::math::CoshOp>},
1431 {"cosh", RTNAME_STRING(CoshF128), FuncTypeReal16Real16, genLibF128Call},
1432 {"cosh", "ccoshf", genFuncType<Ty::Complex<4>, Ty::Complex<4>>, genLibCall},
1433 {"cosh", "ccosh", genFuncType<Ty::Complex<8>, Ty::Complex<8>>, genLibCall},
1434 {"cosh", RTNAME_STRING(CCoshF128), FuncTypeComplex16Complex16,
1435 genLibF128Call},
1436 {"divc",
1437 {},
1438 genFuncType<Ty::Complex<2>, Ty::Complex<2>, Ty::Complex<2>>,
1439 genComplexMathOp<mlir::complex::DivOp>},
1440 {"divc",
1441 {},
1442 genFuncType<Ty::Complex<3>, Ty::Complex<3>, Ty::Complex<3>>,
1443 genComplexMathOp<mlir::complex::DivOp>},
1444 {"divc", "__divsc3",
1445 genFuncType<Ty::Complex<4>, Ty::Complex<4>, Ty::Complex<4>>,
1446 genLibSplitComplexArgsCall},
1447 {"divc", "__divdc3",
1448 genFuncType<Ty::Complex<8>, Ty::Complex<8>, Ty::Complex<8>>,
1449 genLibSplitComplexArgsCall},
1450 {"divc", "__divxc3",
1451 genFuncType<Ty::Complex<10>, Ty::Complex<10>, Ty::Complex<10>>,
1452 genLibSplitComplexArgsCall},
1453 {"divc", "__divtc3",
1454 genFuncType<Ty::Complex<16>, Ty::Complex<16>, Ty::Complex<16>>,
1455 genLibSplitComplexArgsCall},
1456 {"erf", "erff", genFuncType<Ty::Real<4>, Ty::Real<4>>,
1457 genMathOp<mlir::math::ErfOp>},
1458 {"erf", "erf", genFuncType<Ty::Real<8>, Ty::Real<8>>,
1459 genMathOp<mlir::math::ErfOp>},
1460 {"erf", RTNAME_STRING(ErfF128), FuncTypeReal16Real16, genLibF128Call},
1461 {"erfc", "erfcf", genFuncType<Ty::Real<4>, Ty::Real<4>>,
1462 genMathOp<mlir::math::ErfcOp>},
1463 {"erfc", "erfc", genFuncType<Ty::Real<8>, Ty::Real<8>>,
1464 genMathOp<mlir::math::ErfcOp>},
1465 {"erfc", RTNAME_STRING(ErfcF128), FuncTypeReal16Real16, genLibF128Call},
1466 {"exp", "expf", genFuncType<Ty::Real<4>, Ty::Real<4>>,
1467 genMathOp<mlir::math::ExpOp>},
1468 {"exp", "exp", genFuncType<Ty::Real<8>, Ty::Real<8>>,
1469 genMathOp<mlir::math::ExpOp>},
1470 {"exp", RTNAME_STRING(ExpF128), FuncTypeReal16Real16, genLibF128Call},
1471 {"exp", "cexpf", genFuncType<Ty::Complex<4>, Ty::Complex<4>>,
1472 genComplexMathOp<mlir::complex::ExpOp>},
1473 {"exp", "cexp", genFuncType<Ty::Complex<8>, Ty::Complex<8>>,
1474 genComplexMathOp<mlir::complex::ExpOp>},
1475 {"exp", RTNAME_STRING(CExpF128), FuncTypeComplex16Complex16,
1476 genLibF128Call},
1477 {"feclearexcept", "feclearexcept",
1478 genFuncType<Ty::Integer<4>, Ty::Integer<4>>, genLibCall},
1479 {"fedisableexcept", "fedisableexcept",
1480 genFuncType<Ty::Integer<4>, Ty::Integer<4>>, genLibCall},
1481 {"feenableexcept", "feenableexcept",
1482 genFuncType<Ty::Integer<4>, Ty::Integer<4>>, genLibCall},
1483 {"fegetenv", "fegetenv", genFuncType<Ty::Integer<4>, Ty::Address<4>>,
1484 genLibCall},
1485 {"fegetexcept", "fegetexcept", genFuncType<Ty::Integer<4>>, genLibCall},
1486 {"fegetmode", "fegetmode", genFuncType<Ty::Integer<4>, Ty::Address<4>>,
1487 genLibCall},
1488 {"feraiseexcept", "feraiseexcept",
1489 genFuncType<Ty::Integer<4>, Ty::Integer<4>>, genLibCall},
1490 {"fesetenv", "fesetenv", genFuncType<Ty::Integer<4>, Ty::Address<4>>,
1491 genLibCall},
1492 {"fesetmode", "fesetmode", genFuncType<Ty::Integer<4>, Ty::Address<4>>,
1493 genLibCall},
1494 {"fetestexcept", "fetestexcept",
1495 genFuncType<Ty::Integer<4>, Ty::Integer<4>>, genLibCall},
1496 {"feupdateenv", "feupdateenv", genFuncType<Ty::Integer<4>, Ty::Address<4>>,
1497 genLibCall},
1498 // math::FloorOp returns a real, while Fortran FLOOR returns integer.
1499 {"floor", "floorf", genFuncType<Ty::Real<4>, Ty::Real<4>>,
1500 genMathOp<mlir::math::FloorOp>},
1501 {"floor", "floor", genFuncType<Ty::Real<8>, Ty::Real<8>>,
1502 genMathOp<mlir::math::FloorOp>},
1503 {"floor", RTNAME_STRING(FloorF128), FuncTypeReal16Real16, genLibF128Call},
1504 {"fma", "llvm.fma.f32",
1505 genFuncType<Ty::Real<4>, Ty::Real<4>, Ty::Real<4>, Ty::Real<4>>,
1506 genMathOp<mlir::math::FmaOp>},
1507 {"fma", "llvm.fma.f64",
1508 genFuncType<Ty::Real<8>, Ty::Real<8>, Ty::Real<8>, Ty::Real<8>>,
1509 genMathOp<mlir::math::FmaOp>},
1510 {"fma", RTNAME_STRING(FmaF128), FuncTypeReal16Real16Real16Real16,
1511 genLibF128Call},
1512 {"gamma", "tgammaf", genFuncType<Ty::Real<4>, Ty::Real<4>>, genLibCall},
1513 {"gamma", "tgamma", genFuncType<Ty::Real<8>, Ty::Real<8>>, genLibCall},
1514 {"gamma", RTNAME_STRING(TgammaF128), FuncTypeReal16Real16, genLibF128Call},
1515 {"hypot", "hypotf", genFuncType<Ty::Real<4>, Ty::Real<4>, Ty::Real<4>>,
1516 genLibCall},
1517 {"hypot", "hypot", genFuncType<Ty::Real<8>, Ty::Real<8>, Ty::Real<8>>,
1518 genLibCall},
1519 {"hypot", RTNAME_STRING(HypotF128), FuncTypeReal16Real16Real16,
1520 genLibF128Call},
1521 {"log", "logf", genFuncType<Ty::Real<4>, Ty::Real<4>>,
1522 genMathOp<mlir::math::LogOp>},
1523 {"log", "log", genFuncType<Ty::Real<8>, Ty::Real<8>>,
1524 genMathOp<mlir::math::LogOp>},
1525 {"log", RTNAME_STRING(LogF128), FuncTypeReal16Real16, genLibF128Call},
1526 {"log", "clogf", genFuncType<Ty::Complex<4>, Ty::Complex<4>>,
1527 genComplexMathOp<mlir::complex::LogOp>},
1528 {"log", "clog", genFuncType<Ty::Complex<8>, Ty::Complex<8>>,
1529 genComplexMathOp<mlir::complex::LogOp>},
1530 {"log", RTNAME_STRING(CLogF128), FuncTypeComplex16Complex16,
1531 genLibF128Call},
1532 {"log10", "log10f", genFuncType<Ty::Real<4>, Ty::Real<4>>,
1533 genMathOp<mlir::math::Log10Op>},
1534 {"log10", "log10", genFuncType<Ty::Real<8>, Ty::Real<8>>,
1535 genMathOp<mlir::math::Log10Op>},
1536 {"log10", RTNAME_STRING(Log10F128), FuncTypeReal16Real16, genLibF128Call},
1537 {"log_gamma", "lgammaf", genFuncType<Ty::Real<4>, Ty::Real<4>>, genLibCall},
1538 {"log_gamma", "lgamma", genFuncType<Ty::Real<8>, Ty::Real<8>>, genLibCall},
1539 {"log_gamma", RTNAME_STRING(LgammaF128), FuncTypeReal16Real16,
1540 genLibF128Call},
1541 {"nearbyint", "llvm.nearbyint.f32", genFuncType<Ty::Real<4>, Ty::Real<4>>,
1542 genLibCall},
1543 {"nearbyint", "llvm.nearbyint.f64", genFuncType<Ty::Real<8>, Ty::Real<8>>,
1544 genLibCall},
1545 {"nearbyint", "llvm.nearbyint.f80", genFuncType<Ty::Real<10>, Ty::Real<10>>,
1546 genLibCall},
1547 {"nearbyint", RTNAME_STRING(NearbyintF128), FuncTypeReal16Real16,
1548 genLibF128Call},
1549 // llvm.lround behaves the same way as libm's lround.
1550 {"nint", "llvm.lround.i64.f64", genFuncType<Ty::Integer<8>, Ty::Real<8>>,
1551 genLibCall},
1552 {"nint", "llvm.lround.i64.f32", genFuncType<Ty::Integer<8>, Ty::Real<4>>,
1553 genLibCall},
1554 {"nint", RTNAME_STRING(LlroundF128), FuncTypeInteger8Real16,
1555 genLibF128Call},
1556 {"nint", "llvm.lround.i32.f64", genFuncType<Ty::Integer<4>, Ty::Real<8>>,
1557 genLibCall},
1558 {"nint", "llvm.lround.i32.f32", genFuncType<Ty::Integer<4>, Ty::Real<4>>,
1559 genLibCall},
1560 {"nint", RTNAME_STRING(LroundF128), FuncTypeInteger4Real16, genLibF128Call},
1561 {"pow",
1562 {},
1563 genFuncType<Ty::Integer<1>, Ty::Integer<1>, Ty::Integer<1>>,
1564 genMathOp<mlir::math::IPowIOp>},
1565 {"pow",
1566 {},
1567 genFuncType<Ty::Integer<2>, Ty::Integer<2>, Ty::Integer<2>>,
1568 genMathOp<mlir::math::IPowIOp>},
1569 {"pow",
1570 {},
1571 genFuncType<Ty::Integer<4>, Ty::Integer<4>, Ty::Integer<4>>,
1572 genMathOp<mlir::math::IPowIOp>},
1573 {"pow",
1574 {},
1575 genFuncType<Ty::Integer<8>, Ty::Integer<8>, Ty::Integer<8>>,
1576 genMathOp<mlir::math::IPowIOp>},
1577 {"pow", "powf", genFuncType<Ty::Real<4>, Ty::Real<4>, Ty::Real<4>>,
1578 genMathOp<mlir::math::PowFOp>},
1579 {"pow", "pow", genFuncType<Ty::Real<8>, Ty::Real<8>, Ty::Real<8>>,
1580 genMathOp<mlir::math::PowFOp>},
1581 {"pow", RTNAME_STRING(PowF128), FuncTypeReal16Real16Real16, genLibF128Call},
1582 {"pow", "cpowf",
1583 genFuncType<Ty::Complex<4>, Ty::Complex<4>, Ty::Complex<4>>,
1584 genComplexMathOp<mlir::complex::PowOp>},
1585 {"pow", "cpow", genFuncType<Ty::Complex<8>, Ty::Complex<8>, Ty::Complex<8>>,
1586 genComplexMathOp<mlir::complex::PowOp>},
1587 {"pow", RTNAME_STRING(CPowF128), FuncTypeComplex16Complex16Complex16,
1588 genLibF128Call},
1589 {"pow", RTNAME_STRING(FPow4i),
1590 genFuncType<Ty::Real<4>, Ty::Real<4>, Ty::Integer<4>>,
1591 genMathOp<mlir::math::FPowIOp>},
1592 {"pow", RTNAME_STRING(FPow8i),
1593 genFuncType<Ty::Real<8>, Ty::Real<8>, Ty::Integer<4>>,
1594 genMathOp<mlir::math::FPowIOp>},
1595 {"pow", RTNAME_STRING(FPow16i),
1596 genFuncType<Ty::Real<16>, Ty::Real<16>, Ty::Integer<4>>,
1597 genMathOp<mlir::math::FPowIOp>},
1598 {"pow", RTNAME_STRING(FPow4k),
1599 genFuncType<Ty::Real<4>, Ty::Real<4>, Ty::Integer<8>>,
1600 genMathOp<mlir::math::FPowIOp>},
1601 {"pow", RTNAME_STRING(FPow8k),
1602 genFuncType<Ty::Real<8>, Ty::Real<8>, Ty::Integer<8>>,
1603 genMathOp<mlir::math::FPowIOp>},
1604 {"pow", RTNAME_STRING(FPow16k),
1605 genFuncType<Ty::Real<16>, Ty::Real<16>, Ty::Integer<8>>,
1606 genMathOp<mlir::math::FPowIOp>},
1607 {"pow", RTNAME_STRING(cpowi),
1608 genFuncType<Ty::Complex<4>, Ty::Complex<4>, Ty::Integer<4>>, genLibCall},
1609 {"pow", RTNAME_STRING(zpowi),
1610 genFuncType<Ty::Complex<8>, Ty::Complex<8>, Ty::Integer<4>>, genLibCall},
1611 {"pow", RTNAME_STRING(cqpowi), FuncTypeComplex16Complex16Integer4,
1612 genLibF128Call},
1613 {"pow", RTNAME_STRING(cpowk),
1614 genFuncType<Ty::Complex<4>, Ty::Complex<4>, Ty::Integer<8>>, genLibCall},
1615 {"pow", RTNAME_STRING(zpowk),
1616 genFuncType<Ty::Complex<8>, Ty::Complex<8>, Ty::Integer<8>>, genLibCall},
1617 {"pow", RTNAME_STRING(cqpowk), FuncTypeComplex16Complex16Integer8,
1618 genLibF128Call},
1619 {"remainder", "remainderf",
1620 genFuncType<Ty::Real<4>, Ty::Real<4>, Ty::Real<4>>, genLibCall},
1621 {"remainder", "remainder",
1622 genFuncType<Ty::Real<8>, Ty::Real<8>, Ty::Real<8>>, genLibCall},
1623 {"remainder", "remainderl",
1624 genFuncType<Ty::Real<10>, Ty::Real<10>, Ty::Real<10>>, genLibCall},
1625 {"remainder", RTNAME_STRING(RemainderF128), FuncTypeReal16Real16Real16,
1626 genLibF128Call},
1627 {"sign", "copysignf", genFuncType<Ty::Real<4>, Ty::Real<4>, Ty::Real<4>>,
1628 genMathOp<mlir::math::CopySignOp>},
1629 {"sign", "copysign", genFuncType<Ty::Real<8>, Ty::Real<8>, Ty::Real<8>>,
1630 genMathOp<mlir::math::CopySignOp>},
1631 {"sign", "copysignl", genFuncType<Ty::Real<10>, Ty::Real<10>, Ty::Real<10>>,
1632 genMathOp<mlir::math::CopySignOp>},
1633 {"sign", "llvm.copysign.f128",
1634 genFuncType<Ty::Real<16>, Ty::Real<16>, Ty::Real<16>>,
1635 genMathOp<mlir::math::CopySignOp>},
1636 {"sin", "sinf", genFuncType<Ty::Real<4>, Ty::Real<4>>,
1637 genMathOp<mlir::math::SinOp>},
1638 {"sin", "sin", genFuncType<Ty::Real<8>, Ty::Real<8>>,
1639 genMathOp<mlir::math::SinOp>},
1640 {"sin", RTNAME_STRING(SinF128), FuncTypeReal16Real16, genLibF128Call},
1641 {"sin", "csinf", genFuncType<Ty::Complex<4>, Ty::Complex<4>>,
1642 genComplexMathOp<mlir::complex::SinOp>},
1643 {"sin", "csin", genFuncType<Ty::Complex<8>, Ty::Complex<8>>,
1644 genComplexMathOp<mlir::complex::SinOp>},
1645 {"sin", RTNAME_STRING(CSinF128), FuncTypeComplex16Complex16,
1646 genLibF128Call},
1647 {"sinh", "sinhf", genFuncType<Ty::Real<4>, Ty::Real<4>>, genLibCall},
1648 {"sinh", "sinh", genFuncType<Ty::Real<8>, Ty::Real<8>>, genLibCall},
1649 {"sinh", RTNAME_STRING(SinhF128), FuncTypeReal16Real16, genLibF128Call},
1650 {"sinh", "csinhf", genFuncType<Ty::Complex<4>, Ty::Complex<4>>, genLibCall},
1651 {"sinh", "csinh", genFuncType<Ty::Complex<8>, Ty::Complex<8>>, genLibCall},
1652 {"sinh", RTNAME_STRING(CSinhF128), FuncTypeComplex16Complex16,
1653 genLibF128Call},
1654 {"sqrt", "sqrtf", genFuncType<Ty::Real<4>, Ty::Real<4>>,
1655 genMathOp<mlir::math::SqrtOp>},
1656 {"sqrt", "sqrt", genFuncType<Ty::Real<8>, Ty::Real<8>>,
1657 genMathOp<mlir::math::SqrtOp>},
1658 {"sqrt", RTNAME_STRING(SqrtF128), FuncTypeReal16Real16, genLibF128Call},
1659 {"sqrt", "csqrtf", genFuncType<Ty::Complex<4>, Ty::Complex<4>>,
1660 genComplexMathOp<mlir::complex::SqrtOp>},
1661 {"sqrt", "csqrt", genFuncType<Ty::Complex<8>, Ty::Complex<8>>,
1662 genComplexMathOp<mlir::complex::SqrtOp>},
1663 {"sqrt", RTNAME_STRING(CSqrtF128), FuncTypeComplex16Complex16,
1664 genLibF128Call},
1665 {"tan", "tanf", genFuncType<Ty::Real<4>, Ty::Real<4>>,
1666 genMathOp<mlir::math::TanOp>},
1667 {"tan", "tan", genFuncType<Ty::Real<8>, Ty::Real<8>>,
1668 genMathOp<mlir::math::TanOp>},
1669 {"tan", RTNAME_STRING(TanF128), FuncTypeReal16Real16, genLibF128Call},
1670 {"tan", "ctanf", genFuncType<Ty::Complex<4>, Ty::Complex<4>>,
1671 genComplexMathOp<mlir::complex::TanOp>},
1672 {"tan", "ctan", genFuncType<Ty::Complex<8>, Ty::Complex<8>>,
1673 genComplexMathOp<mlir::complex::TanOp>},
1674 {"tan", RTNAME_STRING(CTanF128), FuncTypeComplex16Complex16,
1675 genLibF128Call},
1676 {"tanh", "tanhf", genFuncType<Ty::Real<4>, Ty::Real<4>>,
1677 genMathOp<mlir::math::TanhOp>},
1678 {"tanh", "tanh", genFuncType<Ty::Real<8>, Ty::Real<8>>,
1679 genMathOp<mlir::math::TanhOp>},
1680 {"tanh", RTNAME_STRING(TanhF128), FuncTypeReal16Real16, genLibF128Call},
1681 {"tanh", "ctanhf", genFuncType<Ty::Complex<4>, Ty::Complex<4>>,
1682 genComplexMathOp<mlir::complex::TanhOp>},
1683 {"tanh", "ctanh", genFuncType<Ty::Complex<8>, Ty::Complex<8>>,
1684 genComplexMathOp<mlir::complex::TanhOp>},
1685 {"tanh", RTNAME_STRING(CTanhF128), FuncTypeComplex16Complex16,
1686 genLibF128Call},
1687};
1688
1689// This helper class computes a "distance" between two function types.
1690// The distance measures how many narrowing conversions of actual arguments
1691// and result of "from" must be made in order to use "to" instead of "from".
1692// For instance, the distance between ACOS(REAL(10)) and ACOS(REAL(8)) is
1693// greater than the one between ACOS(REAL(10)) and ACOS(REAL(16)). This means
1694// if no implementation of ACOS(REAL(10)) is available, it is better to use
1695// ACOS(REAL(16)) with casts rather than ACOS(REAL(8)).
1696// Note that this is not a symmetric distance and the order of "from" and "to"
1697// arguments matters, d(foo, bar) may not be the same as d(bar, foo) because it
1698// may be safe to replace foo by bar, but not the opposite.
1699class FunctionDistance {
1700public:
1701 FunctionDistance() : infinite{true} {}
1702
1703 FunctionDistance(mlir::FunctionType from, mlir::FunctionType to) {
1704 unsigned nInputs = from.getNumInputs();
1705 unsigned nResults = from.getNumResults();
1706 if (nResults != to.getNumResults() || nInputs != to.getNumInputs()) {
1707 infinite = true;
1708 } else {
1709 for (decltype(nInputs) i = 0; i < nInputs && !infinite; ++i)
1710 addArgumentDistance(from: from.getInput(i), to: to.getInput(i));
1711 for (decltype(nResults) i = 0; i < nResults && !infinite; ++i)
1712 addResultDistance(from: to.getResult(i), to: from.getResult(i));
1713 }
1714 }
1715
1716 /// Beware both d1.isSmallerThan(d2) *and* d2.isSmallerThan(d1) may be
1717 /// false if both d1 and d2 are infinite. This implies that
1718 /// d1.isSmallerThan(d2) is not equivalent to !d2.isSmallerThan(d1)
1719 bool isSmallerThan(const FunctionDistance &d) const {
1720 return !infinite &&
1721 (d.infinite || std::lexicographical_compare(
1722 first1: conversions.begin(), last1: conversions.end(),
1723 first2: d.conversions.begin(), last2: d.conversions.end()));
1724 }
1725
1726 bool isLosingPrecision() const {
1727 return conversions[narrowingArg] != 0 || conversions[extendingResult] != 0;
1728 }
1729
1730 bool isInfinite() const { return infinite; }
1731
1732private:
1733 enum class Conversion { Forbidden, None, Narrow, Extend };
1734
1735 void addArgumentDistance(mlir::Type from, mlir::Type to) {
1736 switch (conversionBetweenTypes(from, to)) {
1737 case Conversion::Forbidden:
1738 infinite = true;
1739 break;
1740 case Conversion::None:
1741 break;
1742 case Conversion::Narrow:
1743 conversions[narrowingArg]++;
1744 break;
1745 case Conversion::Extend:
1746 conversions[nonNarrowingArg]++;
1747 break;
1748 }
1749 }
1750
1751 void addResultDistance(mlir::Type from, mlir::Type to) {
1752 switch (conversionBetweenTypes(from, to)) {
1753 case Conversion::Forbidden:
1754 infinite = true;
1755 break;
1756 case Conversion::None:
1757 break;
1758 case Conversion::Narrow:
1759 conversions[nonExtendingResult]++;
1760 break;
1761 case Conversion::Extend:
1762 conversions[extendingResult]++;
1763 break;
1764 }
1765 }
1766
1767 // Floating point can be mlir Float or Complex Type.
1768 static unsigned getFloatingPointWidth(mlir::Type t) {
1769 if (auto f{mlir::dyn_cast<mlir::FloatType>(t)})
1770 return f.getWidth();
1771 if (auto cplx{mlir::dyn_cast<mlir::ComplexType>(t)})
1772 return mlir::cast<mlir::FloatType>(cplx.getElementType()).getWidth();
1773 llvm_unreachable("not a floating-point type");
1774 }
1775
1776 static Conversion conversionBetweenTypes(mlir::Type from, mlir::Type to) {
1777 if (from == to)
1778 return Conversion::None;
1779
1780 if (auto fromIntTy{mlir::dyn_cast<mlir::IntegerType>(from)}) {
1781 if (auto toIntTy{mlir::dyn_cast<mlir::IntegerType>(to)}) {
1782 return fromIntTy.getWidth() > toIntTy.getWidth() ? Conversion::Narrow
1783 : Conversion::Extend;
1784 }
1785 }
1786
1787 if (fir::isa_real(from) && fir::isa_real(to)) {
1788 return getFloatingPointWidth(t: from) > getFloatingPointWidth(t: to)
1789 ? Conversion::Narrow
1790 : Conversion::Extend;
1791 }
1792
1793 if (fir::isa_complex(from) && fir::isa_complex(to)) {
1794 return getFloatingPointWidth(t: from) > getFloatingPointWidth(t: to)
1795 ? Conversion::Narrow
1796 : Conversion::Extend;
1797 }
1798 // Notes:
1799 // - No conversion between character types, specialization of runtime
1800 // functions should be made instead.
1801 // - It is not clear there is a use case for automatic conversions
1802 // around Logical and it may damage hidden information in the physical
1803 // storage so do not do it.
1804 return Conversion::Forbidden;
1805 }
1806
1807 // Below are indexes to access data in conversions.
1808 // The order in data does matter for lexicographical_compare
1809 enum {
1810 narrowingArg = 0, // usually bad
1811 extendingResult, // usually bad
1812 nonExtendingResult, // usually ok
1813 nonNarrowingArg, // usually ok
1814 dataSize
1815 };
1816
1817 std::array<int, dataSize> conversions = {};
1818 bool infinite = false; // When forbidden conversion or wrong argument number
1819};
1820
1821using RtMap = Fortran::common::StaticMultimapView<MathOperation>;
1822static constexpr RtMap mathOps(mathOperations);
1823static_assert(mathOps.Verify() && "map must be sorted");
1824
1825/// Look for a MathOperation entry specifying how to lower a mathematical
1826/// operation defined by \p name with its result' and operands' types
1827/// specified in the form of a FunctionType \p funcType.
1828/// If exact match for the given types is found, then the function
1829/// returns a pointer to the corresponding MathOperation.
1830/// Otherwise, the function returns nullptr.
1831/// If there is a MathOperation that can be used with additional
1832/// type casts for the operands or/and result (non-exact match),
1833/// then it is returned via \p bestNearMatch argument, and
1834/// \p bestMatchDistance specifies the FunctionDistance between
1835/// the requested operation and the non-exact match.
1836static const MathOperation *
1837searchMathOperation(fir::FirOpBuilder &builder,
1838 const IntrinsicHandlerEntry::RuntimeGeneratorRange &range,
1839 mlir::FunctionType funcType,
1840 const MathOperation **bestNearMatch,
1841 FunctionDistance &bestMatchDistance) {
1842 for (auto iter = range.first; iter != range.second && iter; ++iter) {
1843 const auto &impl = *iter;
1844 auto implType = impl.typeGenerator(builder.getContext(), builder);
1845 if (funcType == implType) {
1846 return &impl; // exact match
1847 }
1848
1849 FunctionDistance distance(funcType, implType);
1850 if (distance.isSmallerThan(d: bestMatchDistance)) {
1851 *bestNearMatch = &impl;
1852 bestMatchDistance = std::move(distance);
1853 }
1854 }
1855 return nullptr;
1856}
1857
1858/// Implementation of the operation defined by \p name with type
1859/// \p funcType is not precise, and the actual available implementation
1860/// is \p distance away from the requested. If using the available
1861/// implementation results in a precision loss, emit an error message
1862/// with the given code location \p loc.
1863static void checkPrecisionLoss(llvm::StringRef name,
1864 mlir::FunctionType funcType,
1865 const FunctionDistance &distance,
1866 fir::FirOpBuilder &builder, mlir::Location loc) {
1867 if (!distance.isLosingPrecision())
1868 return;
1869
1870 // Using this runtime version requires narrowing the arguments
1871 // or extending the result. It is not numerically safe. There
1872 // is currently no quad math library that was described in
1873 // lowering and could be used here. Emit an error and continue
1874 // generating the code with the narrowing cast so that the user
1875 // can get a complete list of the problematic intrinsic calls.
1876 std::string message = prettyPrintIntrinsicName(
1877 builder, loc, "not yet implemented: no math runtime available for '",
1878 name, "'", funcType);
1879 mlir::emitError(loc, message);
1880}
1881
1882/// Helpers to get function type from arguments and result type.
1883static mlir::FunctionType getFunctionType(std::optional<mlir::Type> resultType,
1884 llvm::ArrayRef<mlir::Value> arguments,
1885 fir::FirOpBuilder &builder) {
1886 llvm::SmallVector<mlir::Type> argTypes;
1887 for (mlir::Value arg : arguments)
1888 argTypes.push_back(Elt: arg.getType());
1889 llvm::SmallVector<mlir::Type> resTypes;
1890 if (resultType)
1891 resTypes.push_back(Elt: *resultType);
1892 return mlir::FunctionType::get(builder.getModule().getContext(), argTypes,
1893 resTypes);
1894}
1895
1896/// fir::ExtendedValue to mlir::Value translation layer
1897
1898fir::ExtendedValue toExtendedValue(mlir::Value val, fir::FirOpBuilder &builder,
1899 mlir::Location loc) {
1900 assert(val && "optional unhandled here");
1901 mlir::Type type = val.getType();
1902 mlir::Value base = val;
1903 mlir::IndexType indexType = builder.getIndexType();
1904 llvm::SmallVector<mlir::Value> extents;
1905
1906 fir::factory::CharacterExprHelper charHelper{builder, loc};
1907 // FIXME: we may want to allow non character scalar here.
1908 if (charHelper.isCharacterScalar(type))
1909 return charHelper.toExtendedValue(val);
1910
1911 if (auto refType = mlir::dyn_cast<fir::ReferenceType>(type))
1912 type = refType.getEleTy();
1913
1914 if (auto arrayType = mlir::dyn_cast<fir::SequenceType>(type)) {
1915 type = arrayType.getEleTy();
1916 for (fir::SequenceType::Extent extent : arrayType.getShape()) {
1917 if (extent == fir::SequenceType::getUnknownExtent())
1918 break;
1919 extents.emplace_back(
1920 builder.createIntegerConstant(loc, indexType, extent));
1921 }
1922 // Last extent might be missing in case of assumed-size. If more extents
1923 // could not be deduced from type, that's an error (a fir.box should
1924 // have been used in the interface).
1925 if (extents.size() + 1 < arrayType.getShape().size())
1926 mlir::emitError(loc, message: "cannot retrieve array extents from type");
1927 } else if (mlir::isa<fir::BoxType>(type) ||
1928 mlir::isa<fir::RecordType>(type)) {
1929 fir::emitFatalError(loc, "not yet implemented: descriptor or derived type");
1930 }
1931
1932 if (!extents.empty())
1933 return fir::ArrayBoxValue{base, extents};
1934 return base;
1935}
1936
1937mlir::Value toValue(const fir::ExtendedValue &val, fir::FirOpBuilder &builder,
1938 mlir::Location loc) {
1939 if (const fir::CharBoxValue *charBox = val.getCharBox()) {
1940 mlir::Value buffer = charBox->getBuffer();
1941 auto buffTy = buffer.getType();
1942 if (mlir::isa<mlir::FunctionType>(buffTy))
1943 fir::emitFatalError(
1944 loc, "A character's buffer type cannot be a function type.");
1945 if (mlir::isa<fir::BoxCharType>(buffTy))
1946 return buffer;
1947 return fir::factory::CharacterExprHelper{builder, loc}.createEmboxChar(
1948 buffer, charBox->getLen());
1949 }
1950
1951 // FIXME: need to access other ExtendedValue variants and handle them
1952 // properly.
1953 return fir::getBase(val);
1954}
1955
1956//===----------------------------------------------------------------------===//
1957// IntrinsicLibrary
1958//===----------------------------------------------------------------------===//
1959
1960static bool isIntrinsicModuleProcedure(llvm::StringRef name) {
1961 return name.starts_with(Prefix: "c_") || name.starts_with(Prefix: "compiler_") ||
1962 name.starts_with(Prefix: "ieee_") || name.starts_with(Prefix: "__ppc_");
1963}
1964
1965static bool isCoarrayIntrinsic(llvm::StringRef name) {
1966 return name.starts_with(Prefix: "atomic_") || name.starts_with(Prefix: "co_") ||
1967 name.contains(Other: "image") || name.ends_with(Suffix: "cobound") ||
1968 name == "team_number";
1969}
1970
1971/// Return the generic name of an intrinsic module procedure specific name.
1972/// Remove any "__builtin_" prefix, and any specific suffix of the form
1973/// {_[ail]?[0-9]+}*, such as _1 or _a4.
1974llvm::StringRef genericName(llvm::StringRef specificName) {
1975 const std::string builtin = "__builtin_";
1976 llvm::StringRef name = specificName.starts_with(Prefix: builtin)
1977 ? specificName.drop_front(N: builtin.size())
1978 : specificName;
1979 size_t size = name.size();
1980 if (isIntrinsicModuleProcedure(name))
1981 while (isdigit(name[size - 1]))
1982 while (name[--size] != '_')
1983 ;
1984 return name.drop_back(N: name.size() - size);
1985}
1986
1987std::optional<IntrinsicHandlerEntry::RuntimeGeneratorRange>
1988lookupRuntimeGenerator(llvm::StringRef name, bool isPPCTarget) {
1989 if (auto range = mathOps.equal_range(name); range.first != range.second)
1990 return std::make_optional<IntrinsicHandlerEntry::RuntimeGeneratorRange>(
1991 range);
1992 // Search ppcMathOps only if targetting PowerPC arch
1993 if (isPPCTarget)
1994 if (auto range = checkPPCMathOperationsRange(name);
1995 range.first != range.second)
1996 return std::make_optional<IntrinsicHandlerEntry::RuntimeGeneratorRange>(
1997 range);
1998 return std::nullopt;
1999}
2000
2001std::optional<IntrinsicHandlerEntry>
2002lookupIntrinsicHandler(fir::FirOpBuilder &builder,
2003 llvm::StringRef intrinsicName,
2004 std::optional<mlir::Type> resultType) {
2005 llvm::StringRef name = genericName(specificName: intrinsicName);
2006 if (const IntrinsicHandler *handler = findIntrinsicHandler(name))
2007 return std::make_optional<IntrinsicHandlerEntry>(handler);
2008 bool isPPCTarget = fir::getTargetTriple(builder.getModule()).isPPC();
2009 // If targeting PowerPC, check PPC intrinsic handlers.
2010 if (isPPCTarget)
2011 if (const IntrinsicHandler *ppcHandler = findPPCIntrinsicHandler(name))
2012 return std::make_optional<IntrinsicHandlerEntry>(ppcHandler);
2013 // Subroutines should have a handler.
2014 if (!resultType)
2015 return std::nullopt;
2016 // Try the runtime if no special handler was defined for the
2017 // intrinsic being called. Maths runtime only has numerical elemental.
2018 if (auto runtimeGeneratorRange = lookupRuntimeGenerator(name, isPPCTarget))
2019 return std::make_optional<IntrinsicHandlerEntry>(*runtimeGeneratorRange);
2020 return std::nullopt;
2021}
2022
2023/// Generate a TODO error message for an as yet unimplemented intrinsic.
2024void crashOnMissingIntrinsic(mlir::Location loc,
2025 llvm::StringRef intrinsicName) {
2026 llvm::StringRef name = genericName(specificName: intrinsicName);
2027 if (isIntrinsicModuleProcedure(name))
2028 TODO(loc, "intrinsic module procedure: " + llvm::Twine(name));
2029 else if (isCoarrayIntrinsic(name))
2030 TODO(loc, "coarray: intrinsic " + llvm::Twine(name));
2031 else
2032 TODO(loc, "intrinsic: " + llvm::Twine(name.upper()));
2033}
2034
2035template <typename GeneratorType>
2036fir::ExtendedValue IntrinsicLibrary::genElementalCall(
2037 GeneratorType generator, llvm::StringRef name, mlir::Type resultType,
2038 llvm::ArrayRef<fir::ExtendedValue> args, bool outline) {
2039 llvm::SmallVector<mlir::Value> scalarArgs;
2040 for (const fir::ExtendedValue &arg : args)
2041 if (arg.getUnboxed() || arg.getCharBox())
2042 scalarArgs.emplace_back(fir::getBase(arg));
2043 else
2044 fir::emitFatalError(loc, "nonscalar intrinsic argument");
2045 if (outline)
2046 return outlineInWrapper(generator, name, resultType, scalarArgs);
2047 return invokeGenerator(generator, resultType, scalarArgs);
2048}
2049
2050template <>
2051fir::ExtendedValue
2052IntrinsicLibrary::genElementalCall<IntrinsicLibrary::ExtendedGenerator>(
2053 ExtendedGenerator generator, llvm::StringRef name, mlir::Type resultType,
2054 llvm::ArrayRef<fir::ExtendedValue> args, bool outline) {
2055 for (const fir::ExtendedValue &arg : args) {
2056 auto *box = arg.getBoxOf<fir::BoxValue>();
2057 if (!arg.getUnboxed() && !arg.getCharBox() &&
2058 !(box && fir::isScalarBoxedRecordType(fir::getBase(*box).getType())))
2059 fir::emitFatalError(loc, "nonscalar intrinsic argument");
2060 }
2061 if (outline)
2062 return outlineInExtendedWrapper(generator, name, resultType, args);
2063 return std::invoke(generator, *this, resultType, args);
2064}
2065
2066template <>
2067fir::ExtendedValue
2068IntrinsicLibrary::genElementalCall<IntrinsicLibrary::SubroutineGenerator>(
2069 SubroutineGenerator generator, llvm::StringRef name, mlir::Type resultType,
2070 llvm::ArrayRef<fir::ExtendedValue> args, bool outline) {
2071 for (const fir::ExtendedValue &arg : args)
2072 if (!arg.getUnboxed() && !arg.getCharBox())
2073 // fir::emitFatalError(loc, "nonscalar intrinsic argument");
2074 crashOnMissingIntrinsic(loc, name);
2075 if (outline)
2076 return outlineInExtendedWrapper(generator, name, resultType, args);
2077 std::invoke(generator, *this, args);
2078 return mlir::Value();
2079}
2080
2081template <>
2082fir::ExtendedValue
2083IntrinsicLibrary::genElementalCall<IntrinsicLibrary::DualGenerator>(
2084 DualGenerator generator, llvm::StringRef name, mlir::Type resultType,
2085 llvm::ArrayRef<fir::ExtendedValue> args, bool outline) {
2086 assert(resultType.getImpl() && "expect elemental intrinsic to be functions");
2087
2088 for (const fir::ExtendedValue &arg : args)
2089 if (!arg.getUnboxed() && !arg.getCharBox())
2090 // fir::emitFatalError(loc, "nonscalar intrinsic argument");
2091 crashOnMissingIntrinsic(loc, name);
2092 if (outline)
2093 return outlineInExtendedWrapper(generator, name, resultType, args);
2094
2095 return std::invoke(generator, *this, std::optional<mlir::Type>{resultType},
2096 args);
2097}
2098
2099static fir::ExtendedValue
2100invokeHandler(IntrinsicLibrary::ElementalGenerator generator,
2101 const IntrinsicHandler &handler,
2102 std::optional<mlir::Type> resultType,
2103 llvm::ArrayRef<fir::ExtendedValue> args, bool outline,
2104 IntrinsicLibrary &lib) {
2105 assert(resultType && "expect elemental intrinsic to be functions");
2106 return lib.genElementalCall(generator, handler.name, *resultType, args,
2107 outline);
2108}
2109
2110static fir::ExtendedValue
2111invokeHandler(IntrinsicLibrary::ExtendedGenerator generator,
2112 const IntrinsicHandler &handler,
2113 std::optional<mlir::Type> resultType,
2114 llvm::ArrayRef<fir::ExtendedValue> args, bool outline,
2115 IntrinsicLibrary &lib) {
2116 assert(resultType && "expect intrinsic function");
2117 if (handler.isElemental)
2118 return lib.genElementalCall(generator, handler.name, *resultType, args,
2119 outline);
2120 if (outline)
2121 return lib.outlineInExtendedWrapper(generator, handler.name, *resultType,
2122 args);
2123 return std::invoke(generator, lib, *resultType, args);
2124}
2125
2126static fir::ExtendedValue
2127invokeHandler(IntrinsicLibrary::SubroutineGenerator generator,
2128 const IntrinsicHandler &handler,
2129 std::optional<mlir::Type> resultType,
2130 llvm::ArrayRef<fir::ExtendedValue> args, bool outline,
2131 IntrinsicLibrary &lib) {
2132 if (handler.isElemental)
2133 return lib.genElementalCall(generator, handler.name, mlir::Type{}, args,
2134 outline);
2135 if (outline)
2136 return lib.outlineInExtendedWrapper(generator, handler.name, resultType,
2137 args);
2138 std::invoke(generator, lib, args);
2139 return mlir::Value{};
2140}
2141
2142static fir::ExtendedValue
2143invokeHandler(IntrinsicLibrary::DualGenerator generator,
2144 const IntrinsicHandler &handler,
2145 std::optional<mlir::Type> resultType,
2146 llvm::ArrayRef<fir::ExtendedValue> args, bool outline,
2147 IntrinsicLibrary &lib) {
2148 if (handler.isElemental)
2149 return lib.genElementalCall(generator, handler.name, mlir::Type{}, args,
2150 outline);
2151 if (outline)
2152 return lib.outlineInExtendedWrapper(generator, handler.name, resultType,
2153 args);
2154
2155 return std::invoke(generator, lib, resultType, args);
2156}
2157
2158static std::pair<fir::ExtendedValue, bool> genIntrinsicCallHelper(
2159 const IntrinsicHandler *handler, std::optional<mlir::Type> resultType,
2160 llvm::ArrayRef<fir::ExtendedValue> args, IntrinsicLibrary &lib) {
2161 assert(handler && "must be set");
2162 bool outline = handler->outline || outlineAllIntrinsics;
2163 return {Fortran::common::visit(
2164 [&](auto &generator) -> fir::ExtendedValue {
2165 return invokeHandler(generator, *handler, resultType, args,
2166 outline, lib);
2167 },
2168 handler->generator),
2169 lib.resultMustBeFreed};
2170}
2171
2172static IntrinsicLibrary::RuntimeCallGenerator getRuntimeCallGeneratorHelper(
2173 const IntrinsicHandlerEntry::RuntimeGeneratorRange &, mlir::FunctionType,
2174 fir::FirOpBuilder &, mlir::Location);
2175
2176static std::pair<fir::ExtendedValue, bool> genIntrinsicCallHelper(
2177 const IntrinsicHandlerEntry::RuntimeGeneratorRange &range,
2178 std::optional<mlir::Type> resultType,
2179 llvm::ArrayRef<fir::ExtendedValue> args, IntrinsicLibrary &lib) {
2180 assert(resultType.has_value() && "RuntimeGenerator are for functions only");
2181 assert(range.first != nullptr && "range should not be empty");
2182 fir::FirOpBuilder &builder = lib.builder;
2183 mlir::Location loc = lib.loc;
2184 llvm::StringRef name = range.first->key;
2185 // FIXME: using toValue to get the type won't work with array arguments.
2186 llvm::SmallVector<mlir::Value> mlirArgs;
2187 for (const fir::ExtendedValue &extendedVal : args) {
2188 mlir::Value val = toValue(extendedVal, builder, loc);
2189 if (!val)
2190 // If an absent optional gets there, most likely its handler has just
2191 // not yet been defined.
2192 crashOnMissingIntrinsic(loc, name);
2193 mlirArgs.emplace_back(val);
2194 }
2195 mlir::FunctionType soughtFuncType =
2196 getFunctionType(*resultType, mlirArgs, builder);
2197
2198 IntrinsicLibrary::RuntimeCallGenerator runtimeCallGenerator =
2199 getRuntimeCallGeneratorHelper(range, soughtFuncType, builder, loc);
2200 return {lib.genElementalCall(runtimeCallGenerator, name, *resultType, args,
2201 /*outline=*/outlineAllIntrinsics),
2202 lib.resultMustBeFreed};
2203}
2204
2205std::pair<fir::ExtendedValue, bool>
2206genIntrinsicCall(fir::FirOpBuilder &builder, mlir::Location loc,
2207 const IntrinsicHandlerEntry &intrinsic,
2208 std::optional<mlir::Type> resultType,
2209 llvm::ArrayRef<fir::ExtendedValue> args,
2210 Fortran::lower::AbstractConverter *converter) {
2211 IntrinsicLibrary library{builder, loc, converter};
2212 return std::visit(
2213 [&](auto handler) -> auto {
2214 return genIntrinsicCallHelper(handler, resultType, args, library);
2215 },
2216 intrinsic.entry);
2217}
2218
2219std::pair<fir::ExtendedValue, bool>
2220IntrinsicLibrary::genIntrinsicCall(llvm::StringRef specificName,
2221 std::optional<mlir::Type> resultType,
2222 llvm::ArrayRef<fir::ExtendedValue> args) {
2223 std::optional<IntrinsicHandlerEntry> intrinsic =
2224 lookupIntrinsicHandler(builder, specificName, resultType);
2225 if (!intrinsic.has_value())
2226 crashOnMissingIntrinsic(loc, specificName);
2227 return std::visit(
2228 [&](auto handler) -> auto {
2229 return genIntrinsicCallHelper(handler, resultType, args, *this);
2230 },
2231 intrinsic->entry);
2232}
2233
2234mlir::Value
2235IntrinsicLibrary::invokeGenerator(ElementalGenerator generator,
2236 mlir::Type resultType,
2237 llvm::ArrayRef<mlir::Value> args) {
2238 return std::invoke(generator, *this, resultType, args);
2239}
2240
2241mlir::Value
2242IntrinsicLibrary::invokeGenerator(RuntimeCallGenerator generator,
2243 mlir::Type resultType,
2244 llvm::ArrayRef<mlir::Value> args) {
2245 return generator(builder, loc, args);
2246}
2247
2248mlir::Value
2249IntrinsicLibrary::invokeGenerator(ExtendedGenerator generator,
2250 mlir::Type resultType,
2251 llvm::ArrayRef<mlir::Value> args) {
2252 llvm::SmallVector<fir::ExtendedValue> extendedArgs;
2253 for (mlir::Value arg : args)
2254 extendedArgs.emplace_back(toExtendedValue(arg, builder, loc));
2255 auto extendedResult = std::invoke(generator, *this, resultType, extendedArgs);
2256 return toValue(extendedResult, builder, loc);
2257}
2258
2259mlir::Value
2260IntrinsicLibrary::invokeGenerator(SubroutineGenerator generator,
2261 llvm::ArrayRef<mlir::Value> args) {
2262 llvm::SmallVector<fir::ExtendedValue> extendedArgs;
2263 for (mlir::Value arg : args)
2264 extendedArgs.emplace_back(toExtendedValue(arg, builder, loc));
2265 std::invoke(generator, *this, extendedArgs);
2266 return {};
2267}
2268
2269mlir::Value
2270IntrinsicLibrary::invokeGenerator(DualGenerator generator,
2271 llvm::ArrayRef<mlir::Value> args) {
2272 llvm::SmallVector<fir::ExtendedValue> extendedArgs;
2273 for (mlir::Value arg : args)
2274 extendedArgs.emplace_back(toExtendedValue(arg, builder, loc));
2275 std::invoke(generator, *this, std::optional<mlir::Type>{}, extendedArgs);
2276 return {};
2277}
2278
2279mlir::Value
2280IntrinsicLibrary::invokeGenerator(DualGenerator generator,
2281 mlir::Type resultType,
2282 llvm::ArrayRef<mlir::Value> args) {
2283 llvm::SmallVector<fir::ExtendedValue> extendedArgs;
2284 for (mlir::Value arg : args)
2285 extendedArgs.emplace_back(toExtendedValue(arg, builder, loc));
2286
2287 if (resultType.getImpl() == nullptr) {
2288 // TODO:
2289 assert(false && "result type is null");
2290 }
2291
2292 auto extendedResult = std::invoke(
2293 generator, *this, std::optional<mlir::Type>{resultType}, extendedArgs);
2294 return toValue(extendedResult, builder, loc);
2295}
2296
2297//===----------------------------------------------------------------------===//
2298// Intrinsic Procedure Mangling
2299//===----------------------------------------------------------------------===//
2300
2301/// Helper to encode type into string for intrinsic procedure names.
2302/// Note: mlir has Type::dump(ostream) methods but it may add "!" that is not
2303/// suitable for function names.
2304static std::string typeToString(mlir::Type t) {
2305 if (auto refT{mlir::dyn_cast<fir::ReferenceType>(t)})
2306 return "ref_" + typeToString(refT.getEleTy());
2307 if (auto i{mlir::dyn_cast<mlir::IntegerType>(t)}) {
2308 return "i" + std::to_string(i.getWidth());
2309 }
2310 if (auto cplx{mlir::dyn_cast<mlir::ComplexType>(t)}) {
2311 auto eleTy = mlir::cast<mlir::FloatType>(cplx.getElementType());
2312 return "z" + std::to_string(eleTy.getWidth());
2313 }
2314 if (auto f{mlir::dyn_cast<mlir::FloatType>(t)}) {
2315 return "f" + std::to_string(f.getWidth());
2316 }
2317 if (auto logical{mlir::dyn_cast<fir::LogicalType>(t)}) {
2318 return "l" + std::to_string(logical.getFKind());
2319 }
2320 if (auto character{mlir::dyn_cast<fir::CharacterType>(t)}) {
2321 return "c" + std::to_string(character.getFKind());
2322 }
2323 if (auto boxCharacter{mlir::dyn_cast<fir::BoxCharType>(t)}) {
2324 return "bc" + std::to_string(boxCharacter.getEleTy().getFKind());
2325 }
2326 llvm_unreachable("no mangling for type");
2327}
2328
2329/// Returns a name suitable to define mlir functions for Fortran intrinsic
2330/// Procedure. These names are guaranteed to not conflict with user defined
2331/// procedures. This is needed to implement Fortran generic intrinsics as
2332/// several mlir functions specialized for the argument types.
2333/// The result is guaranteed to be distinct for different mlir::FunctionType
2334/// arguments. The mangling pattern is:
2335/// fir.<generic name>.<result type>.<arg type>...
2336/// e.g ACOS(COMPLEX(4)) is mangled as fir.acos.z4.z4
2337/// For subroutines no result type is return but in order to still provide
2338/// a unique mangled name, we use "void" as the return type. As in:
2339/// fir.<generic name>.void.<arg type>...
2340/// e.g. FREE(INTEGER(4)) is mangled as fir.free.void.i4
2341static std::string mangleIntrinsicProcedure(llvm::StringRef intrinsic,
2342 mlir::FunctionType funTy) {
2343 std::string name = "fir.";
2344 name.append(str: intrinsic.str()).append(s: ".");
2345 if (funTy.getNumResults() == 1)
2346 name.append(typeToString(funTy.getResult(0)));
2347 else if (funTy.getNumResults() == 0)
2348 name.append(s: "void");
2349 else
2350 llvm_unreachable("more than one result value for function");
2351 unsigned e = funTy.getNumInputs();
2352 for (decltype(e) i = 0; i < e; ++i)
2353 name.append(s: ".").append(typeToString(funTy.getInput(i)));
2354 return name;
2355}
2356
2357template <typename GeneratorType>
2358mlir::func::FuncOp IntrinsicLibrary::getWrapper(GeneratorType generator,
2359 llvm::StringRef name,
2360 mlir::FunctionType funcType,
2361 bool loadRefArguments) {
2362 std::string wrapperName = mangleIntrinsicProcedure(name, funcType);
2363 mlir::func::FuncOp function = builder.getNamedFunction(wrapperName);
2364 if (!function) {
2365 // First time this wrapper is needed, build it.
2366 function = builder.createFunction(loc, wrapperName, funcType);
2367 function->setAttr("fir.intrinsic", builder.getUnitAttr());
2368 fir::factory::setInternalLinkage(function);
2369 function.addEntryBlock();
2370
2371 // Create local context to emit code into the newly created function
2372 // This new function is not linked to a source file location, only
2373 // its calls will be.
2374 auto localBuilder = std::make_unique<fir::FirOpBuilder>(
2375 function, builder.getKindMap(), builder.getMLIRSymbolTable());
2376 localBuilder->setFastMathFlags(builder.getFastMathFlags());
2377 localBuilder->setInsertionPointToStart(&function.front());
2378 // Location of code inside wrapper of the wrapper is independent from
2379 // the location of the intrinsic call.
2380 mlir::Location localLoc = localBuilder->getUnknownLoc();
2381 llvm::SmallVector<mlir::Value> localArguments;
2382 for (mlir::BlockArgument bArg : function.front().getArguments()) {
2383 auto refType = mlir::dyn_cast<fir::ReferenceType>(bArg.getType());
2384 if (loadRefArguments && refType) {
2385 auto loaded = localBuilder->create<fir::LoadOp>(localLoc, bArg);
2386 localArguments.push_back(loaded);
2387 } else {
2388 localArguments.push_back(bArg);
2389 }
2390 }
2391
2392 IntrinsicLibrary localLib{*localBuilder, localLoc};
2393
2394 if constexpr (std::is_same_v<GeneratorType, SubroutineGenerator>) {
2395 localLib.invokeGenerator(generator, localArguments);
2396 localBuilder->create<mlir::func::ReturnOp>(localLoc);
2397 } else {
2398 assert(funcType.getNumResults() == 1 &&
2399 "expect one result for intrinsic function wrapper type");
2400 mlir::Type resultType = funcType.getResult(0);
2401 auto result =
2402 localLib.invokeGenerator(generator, resultType, localArguments);
2403 localBuilder->create<mlir::func::ReturnOp>(localLoc, result);
2404 }
2405 } else {
2406 // Wrapper was already built, ensure it has the sought type
2407 assert(function.getFunctionType() == funcType &&
2408 "conflict between intrinsic wrapper types");
2409 }
2410 return function;
2411}
2412
2413/// Helpers to detect absent optional (not yet supported in outlining).
2414bool static hasAbsentOptional(llvm::ArrayRef<mlir::Value> args) {
2415 for (const mlir::Value &arg : args)
2416 if (!arg)
2417 return true;
2418 return false;
2419}
2420bool static hasAbsentOptional(llvm::ArrayRef<fir::ExtendedValue> args) {
2421 for (const fir::ExtendedValue &arg : args)
2422 if (!fir::getBase(arg))
2423 return true;
2424 return false;
2425}
2426
2427template <typename GeneratorType>
2428mlir::Value
2429IntrinsicLibrary::outlineInWrapper(GeneratorType generator,
2430 llvm::StringRef name, mlir::Type resultType,
2431 llvm::ArrayRef<mlir::Value> args) {
2432 if (hasAbsentOptional(args)) {
2433 // TODO: absent optional in outlining is an issue: we cannot just ignore
2434 // them. Needs a better interface here. The issue is that we cannot easily
2435 // tell that a value is optional or not here if it is presents. And if it is
2436 // absent, we cannot tell what it type should be.
2437 TODO(loc, "cannot outline call to intrinsic " + llvm::Twine(name) +
2438 " with absent optional argument");
2439 }
2440
2441 mlir::FunctionType funcType = getFunctionType(resultType, args, builder);
2442 std::string funcName{name};
2443 llvm::raw_string_ostream nameOS{funcName};
2444 if (std::string fmfString{builder.getFastMathFlagsString()};
2445 !fmfString.empty()) {
2446 nameOS << '.' << fmfString;
2447 }
2448 mlir::func::FuncOp wrapper = getWrapper(generator, funcName, funcType);
2449 return builder.create<fir::CallOp>(loc, wrapper, args).getResult(0);
2450}
2451
2452template <typename GeneratorType>
2453fir::ExtendedValue IntrinsicLibrary::outlineInExtendedWrapper(
2454 GeneratorType generator, llvm::StringRef name,
2455 std::optional<mlir::Type> resultType,
2456 llvm::ArrayRef<fir::ExtendedValue> args) {
2457 if (hasAbsentOptional(args))
2458 TODO(loc, "cannot outline call to intrinsic " + llvm::Twine(name) +
2459 " with absent optional argument");
2460 llvm::SmallVector<mlir::Value> mlirArgs;
2461 for (const auto &extendedVal : args)
2462 mlirArgs.emplace_back(toValue(extendedVal, builder, loc));
2463 mlir::FunctionType funcType = getFunctionType(resultType, mlirArgs, builder);
2464 mlir::func::FuncOp wrapper = getWrapper(generator, name, funcType);
2465 auto call = builder.create<fir::CallOp>(loc, wrapper, mlirArgs);
2466 if (resultType)
2467 return toExtendedValue(call.getResult(0), builder, loc);
2468 // Subroutine calls
2469 return mlir::Value{};
2470}
2471
2472static IntrinsicLibrary::RuntimeCallGenerator getRuntimeCallGeneratorHelper(
2473 const IntrinsicHandlerEntry::RuntimeGeneratorRange &range,
2474 mlir::FunctionType soughtFuncType, fir::FirOpBuilder &builder,
2475 mlir::Location loc) {
2476 assert(range.first != nullptr && "range should not be empty");
2477 llvm::StringRef name = range.first->key;
2478 // Look for a dedicated math operation generator, which
2479 // normally produces a single MLIR operation implementing
2480 // the math operation.
2481 const MathOperation *bestNearMatch = nullptr;
2482 FunctionDistance bestMatchDistance;
2483 const MathOperation *mathOp = searchMathOperation(
2484 builder, range, soughtFuncType, &bestNearMatch, bestMatchDistance);
2485 if (!mathOp && bestNearMatch) {
2486 // Use the best near match, optionally issuing an error,
2487 // if types conversions cause precision loss.
2488 checkPrecisionLoss(name, soughtFuncType, bestMatchDistance, builder, loc);
2489 mathOp = bestNearMatch;
2490 }
2491
2492 if (!mathOp) {
2493 std::string nameAndType;
2494 llvm::raw_string_ostream sstream(nameAndType);
2495 sstream << name << "\nrequested type: " << soughtFuncType;
2496 crashOnMissingIntrinsic(loc, intrinsicName: nameAndType);
2497 }
2498
2499 mlir::FunctionType actualFuncType =
2500 mathOp->typeGenerator(builder.getContext(), builder);
2501
2502 assert(actualFuncType.getNumResults() == soughtFuncType.getNumResults() &&
2503 actualFuncType.getNumInputs() == soughtFuncType.getNumInputs() &&
2504 actualFuncType.getNumResults() == 1 && "Bad intrinsic match");
2505
2506 return [actualFuncType, mathOp,
2507 soughtFuncType](fir::FirOpBuilder &builder, mlir::Location loc,
2508 llvm::ArrayRef<mlir::Value> args) {
2509 llvm::SmallVector<mlir::Value> convertedArguments;
2510 for (auto [fst, snd] : llvm::zip(actualFuncType.getInputs(), args))
2511 convertedArguments.push_back(builder.createConvert(loc, fst, snd));
2512 mlir::Value result = mathOp->funcGenerator(
2513 builder, loc, *mathOp, actualFuncType, convertedArguments);
2514 mlir::Type soughtType = soughtFuncType.getResult(0);
2515 return builder.createConvert(loc, soughtType, result);
2516 };
2517}
2518
2519IntrinsicLibrary::RuntimeCallGenerator
2520IntrinsicLibrary::getRuntimeCallGenerator(llvm::StringRef name,
2521 mlir::FunctionType soughtFuncType) {
2522 bool isPPCTarget = fir::getTargetTriple(builder.getModule()).isPPC();
2523 std::optional<IntrinsicHandlerEntry::RuntimeGeneratorRange> range =
2524 lookupRuntimeGenerator(name, isPPCTarget);
2525 if (!range.has_value())
2526 crashOnMissingIntrinsic(loc, name);
2527 return getRuntimeCallGeneratorHelper(*range, soughtFuncType, builder, loc);
2528}
2529
2530mlir::SymbolRefAttr IntrinsicLibrary::getUnrestrictedIntrinsicSymbolRefAttr(
2531 llvm::StringRef name, mlir::FunctionType signature) {
2532 // Unrestricted intrinsics signature follows implicit rules: argument
2533 // are passed by references. But the runtime versions expect values.
2534 // So instead of duplicating the runtime, just have the wrappers loading
2535 // this before calling the code generators.
2536 bool loadRefArguments = true;
2537 mlir::func::FuncOp funcOp;
2538 if (const IntrinsicHandler *handler = findIntrinsicHandler(name))
2539 funcOp = Fortran::common::visit(
2540 [&](auto generator) {
2541 return getWrapper(generator, name, signature, loadRefArguments);
2542 },
2543 handler->generator);
2544
2545 if (!funcOp) {
2546 llvm::SmallVector<mlir::Type> argTypes;
2547 for (mlir::Type type : signature.getInputs()) {
2548 if (auto refType = mlir::dyn_cast<fir::ReferenceType>(type))
2549 argTypes.push_back(refType.getEleTy());
2550 else
2551 argTypes.push_back(type);
2552 }
2553 mlir::FunctionType soughtFuncType =
2554 builder.getFunctionType(argTypes, signature.getResults());
2555 IntrinsicLibrary::RuntimeCallGenerator rtCallGenerator =
2556 getRuntimeCallGenerator(name, soughtFuncType);
2557 funcOp = getWrapper(rtCallGenerator, name, signature, loadRefArguments);
2558 }
2559
2560 return mlir::SymbolRefAttr::get(funcOp);
2561}
2562
2563fir::ExtendedValue
2564IntrinsicLibrary::readAndAddCleanUp(fir::MutableBoxValue resultMutableBox,
2565 mlir::Type resultType,
2566 llvm::StringRef intrinsicName) {
2567 fir::ExtendedValue res =
2568 fir::factory::genMutableBoxRead(builder, loc, resultMutableBox);
2569 return res.match(
2570 [&](const fir::ArrayBoxValue &box) -> fir::ExtendedValue {
2571 setResultMustBeFreed();
2572 return box;
2573 },
2574 [&](const fir::BoxValue &box) -> fir::ExtendedValue {
2575 setResultMustBeFreed();
2576 return box;
2577 },
2578 [&](const fir::CharArrayBoxValue &box) -> fir::ExtendedValue {
2579 setResultMustBeFreed();
2580 return box;
2581 },
2582 [&](const mlir::Value &tempAddr) -> fir::ExtendedValue {
2583 auto load = builder.create<fir::LoadOp>(loc, resultType, tempAddr);
2584 // Temp can be freed right away since it was loaded.
2585 builder.create<fir::FreeMemOp>(loc, tempAddr);
2586 return load;
2587 },
2588 [&](const fir::CharBoxValue &box) -> fir::ExtendedValue {
2589 setResultMustBeFreed();
2590 return box;
2591 },
2592 [&](const auto &) -> fir::ExtendedValue {
2593 fir::emitFatalError(loc, "unexpected result for " + intrinsicName);
2594 });
2595}
2596
2597//===----------------------------------------------------------------------===//
2598// Code generators for the intrinsic
2599//===----------------------------------------------------------------------===//
2600
2601mlir::Value IntrinsicLibrary::genRuntimeCall(llvm::StringRef name,
2602 mlir::Type resultType,
2603 llvm::ArrayRef<mlir::Value> args) {
2604 mlir::FunctionType soughtFuncType =
2605 getFunctionType(resultType, args, builder);
2606 return getRuntimeCallGenerator(name, soughtFuncType)(builder, loc, args);
2607}
2608
2609mlir::Value IntrinsicLibrary::genConversion(mlir::Type resultType,
2610 llvm::ArrayRef<mlir::Value> args) {
2611 // There can be an optional kind in second argument.
2612 assert(args.size() >= 1);
2613 return builder.convertWithSemantics(loc, resultType, args[0]);
2614}
2615
2616// ABORT
2617void IntrinsicLibrary::genAbort(llvm::ArrayRef<fir::ExtendedValue> args) {
2618 assert(args.size() == 0);
2619 fir::runtime::genAbort(builder, loc);
2620}
2621
2622// ABS
2623mlir::Value IntrinsicLibrary::genAbs(mlir::Type resultType,
2624 llvm::ArrayRef<mlir::Value> args) {
2625 assert(args.size() == 1);
2626 mlir::Value arg = args[0];
2627 mlir::Type type = arg.getType();
2628 if (fir::isa_real(type) || fir::isa_complex(type)) {
2629 // Runtime call to fp abs. An alternative would be to use mlir
2630 // math::AbsFOp but it does not support all fir floating point types.
2631 return genRuntimeCall("abs", resultType, args);
2632 }
2633 if (auto intType = mlir::dyn_cast<mlir::IntegerType>(type)) {
2634 // At the time of this implementation there is no abs op in mlir.
2635 // So, implement abs here without branching.
2636 mlir::Value shift =
2637 builder.createIntegerConstant(loc, intType, intType.getWidth() - 1);
2638 auto mask = builder.create<mlir::arith::ShRSIOp>(loc, arg, shift);
2639 auto xored = builder.create<mlir::arith::XOrIOp>(loc, arg, mask);
2640 return builder.create<mlir::arith::SubIOp>(loc, xored, mask);
2641 }
2642 llvm_unreachable("unexpected type in ABS argument");
2643}
2644
2645// ACOSD
2646mlir::Value IntrinsicLibrary::genAcosd(mlir::Type resultType,
2647 llvm::ArrayRef<mlir::Value> args) {
2648 assert(args.size() == 1);
2649 mlir::MLIRContext *context = builder.getContext();
2650 mlir::FunctionType ftype =
2651 mlir::FunctionType::get(context, {resultType}, {args[0].getType()});
2652 llvm::APFloat pi = llvm::APFloat(llvm::numbers::pi);
2653 mlir::Value dfactor = builder.createRealConstant(
2654 loc, mlir::Float64Type::get(context), pi / llvm::APFloat(180.0));
2655 mlir::Value factor = builder.createConvert(loc, args[0].getType(), dfactor);
2656 mlir::Value arg = builder.create<mlir::arith::MulFOp>(loc, args[0], factor);
2657 return getRuntimeCallGenerator("acos", ftype)(builder, loc, {arg});
2658}
2659
2660// ADJUSTL & ADJUSTR
2661template <void (*CallRuntime)(fir::FirOpBuilder &, mlir::Location loc,
2662 mlir::Value, mlir::Value)>
2663fir::ExtendedValue
2664IntrinsicLibrary::genAdjustRtCall(mlir::Type resultType,
2665 llvm::ArrayRef<fir::ExtendedValue> args) {
2666 assert(args.size() == 1);
2667 mlir::Value string = builder.createBox(loc, args[0]);
2668 // Create a mutable fir.box to be passed to the runtime for the result.
2669 fir::MutableBoxValue resultMutableBox =
2670 fir::factory::createTempMutableBox(builder, loc, resultType);
2671 mlir::Value resultIrBox =
2672 fir::factory::getMutableIRBox(builder, loc, resultMutableBox);
2673
2674 // Call the runtime -- the runtime will allocate the result.
2675 CallRuntime(builder, loc, resultIrBox, string);
2676 // Read result from mutable fir.box and add it to the list of temps to be
2677 // finalized by the StatementContext.
2678 return readAndAddCleanUp(resultMutableBox, resultType, "ADJUSTL or ADJUSTR");
2679}
2680
2681// AIMAG
2682mlir::Value IntrinsicLibrary::genAimag(mlir::Type resultType,
2683 llvm::ArrayRef<mlir::Value> args) {
2684 assert(args.size() == 1);
2685 return fir::factory::Complex{builder, loc}.extractComplexPart(
2686 args[0], /*isImagPart=*/true);
2687}
2688
2689// AINT
2690mlir::Value IntrinsicLibrary::genAint(mlir::Type resultType,
2691 llvm::ArrayRef<mlir::Value> args) {
2692 assert(args.size() >= 1 && args.size() <= 2);
2693 // Skip optional kind argument to search the runtime; it is already reflected
2694 // in result type.
2695 return genRuntimeCall("aint", resultType, {args[0]});
2696}
2697
2698// ALL
2699fir::ExtendedValue
2700IntrinsicLibrary::genAll(mlir::Type resultType,
2701 llvm::ArrayRef<fir::ExtendedValue> args) {
2702
2703 assert(args.size() == 2);
2704 // Handle required mask argument
2705 mlir::Value mask = builder.createBox(loc, args[0]);
2706
2707 fir::BoxValue maskArry = builder.createBox(loc, args[0]);
2708 int rank = maskArry.rank();
2709 assert(rank >= 1);
2710
2711 // Handle optional dim argument
2712 bool absentDim = isStaticallyAbsent(args[1]);
2713 mlir::Value dim =
2714 absentDim ? builder.createIntegerConstant(loc, builder.getIndexType(), 1)
2715 : fir::getBase(args[1]);
2716
2717 if (rank == 1 || absentDim)
2718 return builder.createConvert(loc, resultType,
2719 fir::runtime::genAll(builder, loc, mask, dim));
2720
2721 // else use the result descriptor AllDim() intrinsic
2722
2723 // Create mutable fir.box to be passed to the runtime for the result.
2724
2725 mlir::Type resultArrayType = builder.getVarLenSeqTy(resultType, rank - 1);
2726 fir::MutableBoxValue resultMutableBox =
2727 fir::factory::createTempMutableBox(builder, loc, resultArrayType);
2728 mlir::Value resultIrBox =
2729 fir::factory::getMutableIRBox(builder, loc, resultMutableBox);
2730 // Call runtime. The runtime is allocating the result.
2731 fir::runtime::genAllDescriptor(builder, loc, resultIrBox, mask, dim);
2732 return readAndAddCleanUp(resultMutableBox, resultType, "ALL");
2733}
2734
2735// ALLOCATED
2736fir::ExtendedValue
2737IntrinsicLibrary::genAllocated(mlir::Type resultType,
2738 llvm::ArrayRef<fir::ExtendedValue> args) {
2739 assert(args.size() == 1);
2740 return args[0].match(
2741 [&](const fir::MutableBoxValue &x) -> fir::ExtendedValue {
2742 return fir::factory::genIsAllocatedOrAssociatedTest(builder, loc, x);
2743 },
2744 [&](const auto &) -> fir::ExtendedValue {
2745 fir::emitFatalError(loc,
2746 "allocated arg not lowered to MutableBoxValue");
2747 });
2748}
2749
2750// ANINT
2751mlir::Value IntrinsicLibrary::genAnint(mlir::Type resultType,
2752 llvm::ArrayRef<mlir::Value> args) {
2753 assert(args.size() >= 1 && args.size() <= 2);
2754 // Skip optional kind argument to search the runtime; it is already reflected
2755 // in result type.
2756 return genRuntimeCall("anint", resultType, {args[0]});
2757}
2758
2759// ANY
2760fir::ExtendedValue
2761IntrinsicLibrary::genAny(mlir::Type resultType,
2762 llvm::ArrayRef<fir::ExtendedValue> args) {
2763
2764 assert(args.size() == 2);
2765 // Handle required mask argument
2766 mlir::Value mask = builder.createBox(loc, args[0]);
2767
2768 fir::BoxValue maskArry = builder.createBox(loc, args[0]);
2769 int rank = maskArry.rank();
2770 assert(rank >= 1);
2771
2772 // Handle optional dim argument
2773 bool absentDim = isStaticallyAbsent(args[1]);
2774 mlir::Value dim =
2775 absentDim ? builder.createIntegerConstant(loc, builder.getIndexType(), 1)
2776 : fir::getBase(args[1]);
2777
2778 if (rank == 1 || absentDim)
2779 return builder.createConvert(loc, resultType,
2780 fir::runtime::genAny(builder, loc, mask, dim));
2781
2782 // else use the result descriptor AnyDim() intrinsic
2783
2784 // Create mutable fir.box to be passed to the runtime for the result.
2785
2786 mlir::Type resultArrayType = builder.getVarLenSeqTy(resultType, rank - 1);
2787 fir::MutableBoxValue resultMutableBox =
2788 fir::factory::createTempMutableBox(builder, loc, resultArrayType);
2789 mlir::Value resultIrBox =
2790 fir::factory::getMutableIRBox(builder, loc, resultMutableBox);
2791 // Call runtime. The runtime is allocating the result.
2792 fir::runtime::genAnyDescriptor(builder, loc, resultIrBox, mask, dim);
2793 return readAndAddCleanUp(resultMutableBox, resultType, "ANY");
2794}
2795
2796// ASIND
2797mlir::Value IntrinsicLibrary::genAsind(mlir::Type resultType,
2798 llvm::ArrayRef<mlir::Value> args) {
2799 assert(args.size() == 1);
2800 mlir::MLIRContext *context = builder.getContext();
2801 mlir::FunctionType ftype =
2802 mlir::FunctionType::get(context, {resultType}, {args[0].getType()});
2803 llvm::APFloat pi = llvm::APFloat(llvm::numbers::pi);
2804 mlir::Value dfactor = builder.createRealConstant(
2805 loc, mlir::Float64Type::get(context), pi / llvm::APFloat(180.0));
2806 mlir::Value factor = builder.createConvert(loc, args[0].getType(), dfactor);
2807 mlir::Value arg = builder.create<mlir::arith::MulFOp>(loc, args[0], factor);
2808 return getRuntimeCallGenerator("asin", ftype)(builder, loc, {arg});
2809}
2810
2811// ATAND, ATAN2D
2812mlir::Value IntrinsicLibrary::genAtand(mlir::Type resultType,
2813 llvm::ArrayRef<mlir::Value> args) {
2814 // assert for: atand(X), atand(Y,X), atan2d(Y,X)
2815 assert(args.size() >= 1 && args.size() <= 2);
2816
2817 mlir::MLIRContext *context = builder.getContext();
2818 mlir::Value atan;
2819
2820 // atand = atan * 180/pi
2821 if (args.size() == 2) {
2822 atan = builder.create<mlir::math::Atan2Op>(loc, fir::getBase(args[0]),
2823 fir::getBase(args[1]));
2824 } else {
2825 mlir::FunctionType ftype =
2826 mlir::FunctionType::get(context, {resultType}, {args[0].getType()});
2827 atan = getRuntimeCallGenerator("atan", ftype)(builder, loc, args);
2828 }
2829 llvm::APFloat pi = llvm::APFloat(llvm::numbers::pi);
2830 mlir::Value dfactor = builder.createRealConstant(
2831 loc, mlir::Float64Type::get(context), llvm::APFloat(180.0) / pi);
2832 mlir::Value factor = builder.createConvert(loc, resultType, dfactor);
2833 return builder.create<mlir::arith::MulFOp>(loc, atan, factor);
2834}
2835
2836// ATANPI, ATAN2PI
2837mlir::Value IntrinsicLibrary::genAtanpi(mlir::Type resultType,
2838 llvm::ArrayRef<mlir::Value> args) {
2839 // assert for: atanpi(X), atanpi(Y,X), atan2pi(Y,X)
2840 assert(args.size() >= 1 && args.size() <= 2);
2841
2842 mlir::Value atan;
2843 mlir::MLIRContext *context = builder.getContext();
2844
2845 // atanpi = atan / pi
2846 if (args.size() == 2) {
2847 atan = builder.create<mlir::math::Atan2Op>(loc, fir::getBase(args[0]),
2848 fir::getBase(args[1]));
2849 } else {
2850 mlir::FunctionType ftype =
2851 mlir::FunctionType::get(context, {resultType}, {args[0].getType()});
2852 atan = getRuntimeCallGenerator("atan", ftype)(builder, loc, args);
2853 }
2854 llvm::APFloat inv_pi = llvm::APFloat(llvm::numbers::inv_pi);
2855 mlir::Value dfactor =
2856 builder.createRealConstant(loc, mlir::Float64Type::get(context), inv_pi);
2857 mlir::Value factor = builder.createConvert(loc, resultType, dfactor);
2858 return builder.create<mlir::arith::MulFOp>(loc, atan, factor);
2859}
2860
2861static mlir::Value genAtomBinOp(fir::FirOpBuilder &builder, mlir::Location &loc,
2862 mlir::LLVM::AtomicBinOp binOp, mlir::Value arg0,
2863 mlir::Value arg1) {
2864 auto llvmPointerType = mlir::LLVM::LLVMPointerType::get(builder.getContext());
2865 arg0 = builder.createConvert(loc, llvmPointerType, arg0);
2866 return builder.create<mlir::LLVM::AtomicRMWOp>(
2867 loc, binOp, arg0, arg1, mlir::LLVM::AtomicOrdering::seq_cst);
2868}
2869
2870mlir::Value IntrinsicLibrary::genAtomicAdd(mlir::Type resultType,
2871 llvm::ArrayRef<mlir::Value> args) {
2872 assert(args.size() == 2);
2873
2874 mlir::LLVM::AtomicBinOp binOp =
2875 mlir::isa<mlir::IntegerType>(args[1].getType())
2876 ? mlir::LLVM::AtomicBinOp::add
2877 : mlir::LLVM::AtomicBinOp::fadd;
2878 return genAtomBinOp(builder, loc, binOp, args[0], args[1]);
2879}
2880
2881mlir::Value IntrinsicLibrary::genAtomicSub(mlir::Type resultType,
2882 llvm::ArrayRef<mlir::Value> args) {
2883 assert(args.size() == 2);
2884
2885 mlir::LLVM::AtomicBinOp binOp =
2886 mlir::isa<mlir::IntegerType>(args[1].getType())
2887 ? mlir::LLVM::AtomicBinOp::sub
2888 : mlir::LLVM::AtomicBinOp::fsub;
2889 return genAtomBinOp(builder, loc, binOp, args[0], args[1]);
2890}
2891
2892mlir::Value IntrinsicLibrary::genAtomicAnd(mlir::Type resultType,
2893 llvm::ArrayRef<mlir::Value> args) {
2894 assert(args.size() == 2);
2895 assert(mlir::isa<mlir::IntegerType>(args[1].getType()));
2896
2897 mlir::LLVM::AtomicBinOp binOp = mlir::LLVM::AtomicBinOp::_and;
2898 return genAtomBinOp(builder, loc, binOp, args[0], args[1]);
2899}
2900
2901mlir::Value IntrinsicLibrary::genAtomicOr(mlir::Type resultType,
2902 llvm::ArrayRef<mlir::Value> args) {
2903 assert(args.size() == 2);
2904 assert(mlir::isa<mlir::IntegerType>(args[1].getType()));
2905
2906 mlir::LLVM::AtomicBinOp binOp = mlir::LLVM::AtomicBinOp::_or;
2907 return genAtomBinOp(builder, loc, binOp, args[0], args[1]);
2908}
2909
2910// ATOMICCAS
2911fir::ExtendedValue
2912IntrinsicLibrary::genAtomicCas(mlir::Type resultType,
2913 llvm::ArrayRef<fir::ExtendedValue> args) {
2914 assert(args.size() == 3);
2915 auto successOrdering = mlir::LLVM::AtomicOrdering::acq_rel;
2916 auto failureOrdering = mlir::LLVM::AtomicOrdering::monotonic;
2917 auto llvmPtrTy = mlir::LLVM::LLVMPointerType::get(resultType.getContext());
2918
2919 mlir::Value arg0 = fir::getBase(args[0]);
2920 mlir::Value arg1 = fir::getBase(args[1]);
2921 mlir::Value arg2 = fir::getBase(args[2]);
2922
2923 auto bitCastFloat = [&](mlir::Value arg) -> mlir::Value {
2924 if (mlir::isa<mlir::Float32Type>(arg.getType()))
2925 return builder.create<mlir::LLVM::BitcastOp>(loc, builder.getI32Type(),
2926 arg);
2927 if (mlir::isa<mlir::Float64Type>(arg.getType()))
2928 return builder.create<mlir::LLVM::BitcastOp>(loc, builder.getI64Type(),
2929 arg);
2930 return arg;
2931 };
2932
2933 arg1 = bitCastFloat(arg1);
2934 arg2 = bitCastFloat(arg2);
2935
2936 if (arg1.getType() != arg2.getType()) {
2937 // arg1 and arg2 need to have the same type in AtomicCmpXchgOp.
2938 arg2 = builder.createConvert(loc, arg1.getType(), arg2);
2939 }
2940
2941 auto address =
2942 builder.create<mlir::UnrealizedConversionCastOp>(loc, llvmPtrTy, arg0)
2943 .getResult(0);
2944 auto cmpxchg = builder.create<mlir::LLVM::AtomicCmpXchgOp>(
2945 loc, address, arg1, arg2, successOrdering, failureOrdering);
2946 return builder.create<mlir::LLVM::ExtractValueOp>(loc, cmpxchg, 1);
2947}
2948
2949mlir::Value IntrinsicLibrary::genAtomicDec(mlir::Type resultType,
2950 llvm::ArrayRef<mlir::Value> args) {
2951 assert(args.size() == 2);
2952 assert(mlir::isa<mlir::IntegerType>(args[1].getType()));
2953
2954 mlir::LLVM::AtomicBinOp binOp = mlir::LLVM::AtomicBinOp::udec_wrap;
2955 return genAtomBinOp(builder, loc, binOp, args[0], args[1]);
2956}
2957
2958// ATOMICEXCH
2959fir::ExtendedValue
2960IntrinsicLibrary::genAtomicExch(mlir::Type resultType,
2961 llvm::ArrayRef<fir::ExtendedValue> args) {
2962 assert(args.size() == 2);
2963 mlir::Value arg0 = fir::getBase(args[0]);
2964 mlir::Value arg1 = fir::getBase(args[1]);
2965 assert(arg1.getType().isIntOrFloat());
2966
2967 mlir::LLVM::AtomicBinOp binOp = mlir::LLVM::AtomicBinOp::xchg;
2968 return genAtomBinOp(builder, loc, binOp, arg0, arg1);
2969}
2970
2971mlir::Value IntrinsicLibrary::genAtomicInc(mlir::Type resultType,
2972 llvm::ArrayRef<mlir::Value> args) {
2973 assert(args.size() == 2);
2974 assert(mlir::isa<mlir::IntegerType>(args[1].getType()));
2975
2976 mlir::LLVM::AtomicBinOp binOp = mlir::LLVM::AtomicBinOp::uinc_wrap;
2977 return genAtomBinOp(builder, loc, binOp, args[0], args[1]);
2978}
2979
2980mlir::Value IntrinsicLibrary::genAtomicMax(mlir::Type resultType,
2981 llvm::ArrayRef<mlir::Value> args) {
2982 assert(args.size() == 2);
2983
2984 mlir::LLVM::AtomicBinOp binOp =
2985 mlir::isa<mlir::IntegerType>(args[1].getType())
2986 ? mlir::LLVM::AtomicBinOp::max
2987 : mlir::LLVM::AtomicBinOp::fmax;
2988 return genAtomBinOp(builder, loc, binOp, args[0], args[1]);
2989}
2990
2991mlir::Value IntrinsicLibrary::genAtomicMin(mlir::Type resultType,
2992 llvm::ArrayRef<mlir::Value> args) {
2993 assert(args.size() == 2);
2994
2995 mlir::LLVM::AtomicBinOp binOp =
2996 mlir::isa<mlir::IntegerType>(args[1].getType())
2997 ? mlir::LLVM::AtomicBinOp::min
2998 : mlir::LLVM::AtomicBinOp::fmin;
2999 return genAtomBinOp(builder, loc, binOp, args[0], args[1]);
3000}
3001
3002// ATOMICXOR
3003fir::ExtendedValue
3004IntrinsicLibrary::genAtomicXor(mlir::Type resultType,
3005 llvm::ArrayRef<fir::ExtendedValue> args) {
3006 assert(args.size() == 2);
3007 mlir::Value arg0 = fir::getBase(args[0]);
3008 mlir::Value arg1 = fir::getBase(args[1]);
3009 return genAtomBinOp(builder, loc, mlir::LLVM::AtomicBinOp::_xor, arg0, arg1);
3010}
3011
3012// ASSOCIATED
3013fir::ExtendedValue
3014IntrinsicLibrary::genAssociated(mlir::Type resultType,
3015 llvm::ArrayRef<fir::ExtendedValue> args) {
3016 assert(args.size() == 2);
3017 mlir::Type ptrTy = fir::getBase(args[0]).getType();
3018 if (ptrTy && (fir::isBoxProcAddressType(ptrTy) ||
3019 mlir::isa<fir::BoxProcType>(ptrTy))) {
3020 mlir::Value pointerBoxProc =
3021 fir::isBoxProcAddressType(ptrTy)
3022 ? builder.create<fir::LoadOp>(loc, fir::getBase(args[0]))
3023 : fir::getBase(args[0]);
3024 mlir::Value pointerTarget =
3025 builder.create<fir::BoxAddrOp>(loc, pointerBoxProc);
3026 if (isStaticallyAbsent(args[1]))
3027 return builder.genIsNotNullAddr(loc, pointerTarget);
3028 mlir::Value target = fir::getBase(args[1]);
3029 if (fir::isBoxProcAddressType(target.getType()))
3030 target = builder.create<fir::LoadOp>(loc, target);
3031 if (mlir::isa<fir::BoxProcType>(target.getType()))
3032 target = builder.create<fir::BoxAddrOp>(loc, target);
3033 mlir::Type intPtrTy = builder.getIntPtrType();
3034 mlir::Value pointerInt =
3035 builder.createConvert(loc, intPtrTy, pointerTarget);
3036 mlir::Value targetInt = builder.createConvert(loc, intPtrTy, target);
3037 mlir::Value sameTarget = builder.create<mlir::arith::CmpIOp>(
3038 loc, mlir::arith::CmpIPredicate::eq, pointerInt, targetInt);
3039 mlir::Value zero = builder.createIntegerConstant(loc, intPtrTy, 0);
3040 mlir::Value notNull = builder.create<mlir::arith::CmpIOp>(
3041 loc, mlir::arith::CmpIPredicate::ne, zero, pointerInt);
3042 // The not notNull test covers the following two cases:
3043 // - TARGET is a procedure that is OPTIONAL and absent at runtime.
3044 // - TARGET is a procedure pointer that is NULL.
3045 // In both cases, ASSOCIATED should be false if POINTER is NULL.
3046 return builder.create<mlir::arith::AndIOp>(loc, sameTarget, notNull);
3047 }
3048 auto *pointer =
3049 args[0].match([&](const fir::MutableBoxValue &x) { return &x; },
3050 [&](const auto &) -> const fir::MutableBoxValue * {
3051 fir::emitFatalError(loc, "pointer not a MutableBoxValue");
3052 });
3053 const fir::ExtendedValue &target = args[1];
3054 if (isStaticallyAbsent(target))
3055 return fir::factory::genIsAllocatedOrAssociatedTest(builder, loc, *pointer);
3056 mlir::Value targetBox = builder.createBox(loc, target);
3057 mlir::Value pointerBoxRef =
3058 fir::factory::getMutableIRBox(builder, loc, *pointer);
3059 auto pointerBox = builder.create<fir::LoadOp>(loc, pointerBoxRef);
3060 return fir::runtime::genAssociated(builder, loc, pointerBox, targetBox);
3061}
3062
3063// BESSEL_JN
3064fir::ExtendedValue
3065IntrinsicLibrary::genBesselJn(mlir::Type resultType,
3066 llvm::ArrayRef<fir::ExtendedValue> args) {
3067 assert(args.size() == 2 || args.size() == 3);
3068
3069 mlir::Value x = fir::getBase(args.back());
3070
3071 if (args.size() == 2) {
3072 mlir::Value n = fir::getBase(args[0]);
3073
3074 return genRuntimeCall("bessel_jn", resultType, {n, x});
3075 } else {
3076 mlir::Value n1 = fir::getBase(args[0]);
3077 mlir::Value n2 = fir::getBase(args[1]);
3078
3079 mlir::Type intTy = n1.getType();
3080 mlir::Type floatTy = x.getType();
3081 mlir::Value zero = builder.createRealZeroConstant(loc, floatTy);
3082 mlir::Value one = builder.createIntegerConstant(loc, intTy, 1);
3083
3084 mlir::Type resultArrayType = builder.getVarLenSeqTy(resultType, 1);
3085 fir::MutableBoxValue resultMutableBox =
3086 fir::factory::createTempMutableBox(builder, loc, resultArrayType);
3087 mlir::Value resultBox =
3088 fir::factory::getMutableIRBox(builder, loc, resultMutableBox);
3089
3090 mlir::Value cmpXEq0 = builder.create<mlir::arith::CmpFOp>(
3091 loc, mlir::arith::CmpFPredicate::UEQ, x, zero);
3092 mlir::Value cmpN1LtN2 = builder.create<mlir::arith::CmpIOp>(
3093 loc, mlir::arith::CmpIPredicate::slt, n1, n2);
3094 mlir::Value cmpN1EqN2 = builder.create<mlir::arith::CmpIOp>(
3095 loc, mlir::arith::CmpIPredicate::eq, n1, n2);
3096
3097 auto genXEq0 = [&]() {
3098 fir::runtime::genBesselJnX0(builder, loc, floatTy, resultBox, n1, n2);
3099 };
3100
3101 auto genN1LtN2 = [&]() {
3102 // The runtime generates the values in the range using a backward
3103 // recursion from n2 to n1. (see https://dlmf.nist.gov/10.74.iv and
3104 // https://dlmf.nist.gov/10.6.E1). When n1 < n2, this requires
3105 // the values of BESSEL_JN(n2) and BESSEL_JN(n2 - 1) since they
3106 // are the anchors of the recursion.
3107 mlir::Value n2_1 = builder.create<mlir::arith::SubIOp>(loc, n2, one);
3108 mlir::Value bn2 = genRuntimeCall("bessel_jn", resultType, {n2, x});
3109 mlir::Value bn2_1 = genRuntimeCall("bessel_jn", resultType, {n2_1, x});
3110 fir::runtime::genBesselJn(builder, loc, resultBox, n1, n2, x, bn2, bn2_1);
3111 };
3112
3113 auto genN1EqN2 = [&]() {
3114 // When n1 == n2, only BESSEL_JN(n2) is needed.
3115 mlir::Value bn2 = genRuntimeCall("bessel_jn", resultType, {n2, x});
3116 fir::runtime::genBesselJn(builder, loc, resultBox, n1, n2, x, bn2, zero);
3117 };
3118
3119 auto genN1GtN2 = [&]() {
3120 // The standard requires n1 <= n2. However, we still need to allocate
3121 // a zero-length array and return it when n1 > n2, so we do need to call
3122 // the runtime function.
3123 fir::runtime::genBesselJn(builder, loc, resultBox, n1, n2, x, zero, zero);
3124 };
3125
3126 auto genN1GeN2 = [&] {
3127 builder.genIfThenElse(loc, cmpN1EqN2)
3128 .genThen(genN1EqN2)
3129 .genElse(genN1GtN2)
3130 .end();
3131 };
3132
3133 auto genXNeq0 = [&]() {
3134 builder.genIfThenElse(loc, cmpN1LtN2)
3135 .genThen(genN1LtN2)
3136 .genElse(genN1GeN2)
3137 .end();
3138 };
3139
3140 builder.genIfThenElse(loc, cmpXEq0)
3141 .genThen(genXEq0)
3142 .genElse(genXNeq0)
3143 .end();
3144 return readAndAddCleanUp(resultMutableBox, resultType, "BESSEL_JN");
3145 }
3146}
3147
3148// BESSEL_YN
3149fir::ExtendedValue
3150IntrinsicLibrary::genBesselYn(mlir::Type resultType,
3151 llvm::ArrayRef<fir::ExtendedValue> args) {
3152 assert(args.size() == 2 || args.size() == 3);
3153
3154 mlir::Value x = fir::getBase(args.back());
3155
3156 if (args.size() == 2) {
3157 mlir::Value n = fir::getBase(args[0]);
3158
3159 return genRuntimeCall("bessel_yn", resultType, {n, x});
3160 } else {
3161 mlir::Value n1 = fir::getBase(args[0]);
3162 mlir::Value n2 = fir::getBase(args[1]);
3163
3164 mlir::Type floatTy = x.getType();
3165 mlir::Type intTy = n1.getType();
3166 mlir::Value zero = builder.createRealZeroConstant(loc, floatTy);
3167 mlir::Value one = builder.createIntegerConstant(loc, intTy, 1);
3168
3169 mlir::Type resultArrayType = builder.getVarLenSeqTy(resultType, 1);
3170 fir::MutableBoxValue resultMutableBox =
3171 fir::factory::createTempMutableBox(builder, loc, resultArrayType);
3172 mlir::Value resultBox =
3173 fir::factory::getMutableIRBox(builder, loc, resultMutableBox);
3174
3175 mlir::Value cmpXEq0 = builder.create<mlir::arith::CmpFOp>(
3176 loc, mlir::arith::CmpFPredicate::UEQ, x, zero);
3177 mlir::Value cmpN1LtN2 = builder.create<mlir::arith::CmpIOp>(
3178 loc, mlir::arith::CmpIPredicate::slt, n1, n2);
3179 mlir::Value cmpN1EqN2 = builder.create<mlir::arith::CmpIOp>(
3180 loc, mlir::arith::CmpIPredicate::eq, n1, n2);
3181
3182 auto genXEq0 = [&]() {
3183 fir::runtime::genBesselYnX0(builder, loc, floatTy, resultBox, n1, n2);
3184 };
3185
3186 auto genN1LtN2 = [&]() {
3187 // The runtime generates the values in the range using a forward
3188 // recursion from n1 to n2. (see https://dlmf.nist.gov/10.74.iv and
3189 // https://dlmf.nist.gov/10.6.E1). When n1 < n2, this requires
3190 // the values of BESSEL_YN(n1) and BESSEL_YN(n1 + 1) since they
3191 // are the anchors of the recursion.
3192 mlir::Value n1_1 = builder.create<mlir::arith::AddIOp>(loc, n1, one);
3193 mlir::Value bn1 = genRuntimeCall("bessel_yn", resultType, {n1, x});
3194 mlir::Value bn1_1 = genRuntimeCall("bessel_yn", resultType, {n1_1, x});
3195 fir::runtime::genBesselYn(builder, loc, resultBox, n1, n2, x, bn1, bn1_1);
3196 };
3197
3198 auto genN1EqN2 = [&]() {
3199 // When n1 == n2, only BESSEL_YN(n1) is needed.
3200 mlir::Value bn1 = genRuntimeCall("bessel_yn", resultType, {n1, x});
3201 fir::runtime::genBesselYn(builder, loc, resultBox, n1, n2, x, bn1, zero);
3202 };
3203
3204 auto genN1GtN2 = [&]() {
3205 // The standard requires n1 <= n2. However, we still need to allocate
3206 // a zero-length array and return it when n1 > n2, so we do need to call
3207 // the runtime function.
3208 fir::runtime::genBesselYn(builder, loc, resultBox, n1, n2, x, zero, zero);
3209 };
3210
3211 auto genN1GeN2 = [&] {
3212 builder.genIfThenElse(loc, cmpN1EqN2)
3213 .genThen(genN1EqN2)
3214 .genElse(genN1GtN2)
3215 .end();
3216 };
3217
3218 auto genXNeq0 = [&]() {
3219 builder.genIfThenElse(loc, cmpN1LtN2)
3220 .genThen(genN1LtN2)
3221 .genElse(genN1GeN2)
3222 .end();
3223 };
3224
3225 builder.genIfThenElse(loc, cmpXEq0)
3226 .genThen(genXEq0)
3227 .genElse(genXNeq0)
3228 .end();
3229 return readAndAddCleanUp(resultMutableBox, resultType, "BESSEL_YN");
3230 }
3231}
3232
3233// BGE, BGT, BLE, BLT
3234template <mlir::arith::CmpIPredicate pred>
3235mlir::Value
3236IntrinsicLibrary::genBitwiseCompare(mlir::Type resultType,
3237 llvm::ArrayRef<mlir::Value> args) {
3238 assert(args.size() == 2);
3239
3240 mlir::Value arg0 = args[0];
3241 mlir::Value arg1 = args[1];
3242 mlir::Type arg0Ty = arg0.getType();
3243 mlir::Type arg1Ty = arg1.getType();
3244 int bits0 = arg0Ty.getIntOrFloatBitWidth();
3245 int bits1 = arg1Ty.getIntOrFloatBitWidth();
3246
3247 // Arguments do not have to be of the same integer type. However, if neither
3248 // of the arguments is a BOZ literal, then the shorter of the two needs
3249 // to be converted to the longer by zero-extending (not sign-extending)
3250 // to the left [Fortran 2008, 13.3.2].
3251 //
3252 // In the case of BOZ literals, the standard describes zero-extension or
3253 // truncation depending on the kind of the result [Fortran 2008, 13.3.3].
3254 // However, that seems to be relevant for the case where the type of the
3255 // result must match the type of the BOZ literal. That is not the case for
3256 // these intrinsics, so, again, zero-extend to the larger type.
3257 int widest = bits0 > bits1 ? bits0 : bits1;
3258 mlir::Type signlessType =
3259 mlir::IntegerType::get(builder.getContext(), widest,
3260 mlir::IntegerType::SignednessSemantics::Signless);
3261 if (arg0Ty.isUnsignedInteger())
3262 arg0 = builder.createConvert(loc, signlessType, arg0);
3263 else if (bits0 < widest)
3264 arg0 = builder.create<mlir::arith::ExtUIOp>(loc, signlessType, arg0);
3265 if (arg1Ty.isUnsignedInteger())
3266 arg1 = builder.createConvert(loc, signlessType, arg1);
3267 else if (bits1 < widest)
3268 arg1 = builder.create<mlir::arith::ExtUIOp>(loc, signlessType, arg1);
3269 return builder.create<mlir::arith::CmpIOp>(loc, pred, arg0, arg1);
3270}
3271
3272// BTEST
3273mlir::Value IntrinsicLibrary::genBtest(mlir::Type resultType,
3274 llvm::ArrayRef<mlir::Value> args) {
3275 // A conformant BTEST(I,POS) call satisfies:
3276 // POS >= 0
3277 // POS < BIT_SIZE(I)
3278 // Return: (I >> POS) & 1
3279 assert(args.size() == 2);
3280 mlir::Value word = args[0];
3281 mlir::Type signlessType = mlir::IntegerType::get(
3282 builder.getContext(), word.getType().getIntOrFloatBitWidth(),
3283 mlir::IntegerType::SignednessSemantics::Signless);
3284 if (word.getType().isUnsignedInteger())
3285 word = builder.createConvert(loc, signlessType, word);
3286 mlir::Value shiftCount = builder.createConvert(loc, signlessType, args[1]);
3287 mlir::Value shifted =
3288 builder.create<mlir::arith::ShRUIOp>(loc, word, shiftCount);
3289 mlir::Value one = builder.createIntegerConstant(loc, signlessType, 1);
3290 mlir::Value bit = builder.create<mlir::arith::AndIOp>(loc, shifted, one);
3291 return builder.createConvert(loc, resultType, bit);
3292}
3293
3294static mlir::Value getAddrFromBox(fir::FirOpBuilder &builder,
3295 mlir::Location loc, fir::ExtendedValue arg,
3296 bool isFunc) {
3297 mlir::Value argValue = fir::getBase(arg);
3298 mlir::Value addr{nullptr};
3299 if (isFunc) {
3300 auto funcTy = mlir::cast<fir::BoxProcType>(argValue.getType()).getEleTy();
3301 addr = builder.create<fir::BoxAddrOp>(loc, funcTy, argValue);
3302 } else {
3303 const auto *box = arg.getBoxOf<fir::BoxValue>();
3304 addr = builder.create<fir::BoxAddrOp>(loc, box->getMemTy(),
3305 fir::getBase(*box));
3306 }
3307 return addr;
3308}
3309
3310static fir::ExtendedValue
3311genCLocOrCFunLoc(fir::FirOpBuilder &builder, mlir::Location loc,
3312 mlir::Type resultType, llvm::ArrayRef<fir::ExtendedValue> args,
3313 bool isFunc = false, bool isDevLoc = false) {
3314 assert(args.size() == 1);
3315 mlir::Value res = builder.create<fir::AllocaOp>(loc, resultType);
3316 mlir::Value resAddr;
3317 if (isDevLoc)
3318 resAddr = fir::factory::genCDevPtrAddr(builder, loc, res, resultType);
3319 else
3320 resAddr = fir::factory::genCPtrOrCFunptrAddr(builder, loc, res, resultType);
3321 assert(fir::isa_box_type(fir::getBase(args[0]).getType()) &&
3322 "argument must have been lowered to box type");
3323 mlir::Value argAddr = getAddrFromBox(builder, loc, args[0], isFunc);
3324 mlir::Value argAddrVal = builder.createConvert(
3325 loc, fir::unwrapRefType(resAddr.getType()), argAddr);
3326 builder.create<fir::StoreOp>(loc, argAddrVal, resAddr);
3327 return res;
3328}
3329
3330/// C_ASSOCIATED
3331static fir::ExtendedValue
3332genCAssociated(fir::FirOpBuilder &builder, mlir::Location loc,
3333 mlir::Type resultType, llvm::ArrayRef<fir::ExtendedValue> args) {
3334 assert(args.size() == 2);
3335 mlir::Value cPtr1 = fir::getBase(args[0]);
3336 mlir::Value cPtrVal1 =
3337 fir::factory::genCPtrOrCFunptrValue(builder, loc, cPtr1);
3338 mlir::Value zero = builder.createIntegerConstant(loc, cPtrVal1.getType(), 0);
3339 mlir::Value res = builder.create<mlir::arith::CmpIOp>(
3340 loc, mlir::arith::CmpIPredicate::ne, cPtrVal1, zero);
3341
3342 if (isStaticallyPresent(args[1])) {
3343 mlir::Type i1Ty = builder.getI1Type();
3344 mlir::Value cPtr2 = fir::getBase(args[1]);
3345 mlir::Value isDynamicallyAbsent = builder.genIsNullAddr(loc, cPtr2);
3346 res =
3347 builder
3348 .genIfOp(loc, {i1Ty}, isDynamicallyAbsent, /*withElseRegion=*/true)
3349 .genThen([&]() { builder.create<fir::ResultOp>(loc, res); })
3350 .genElse([&]() {
3351 mlir::Value cPtrVal2 =
3352 fir::factory::genCPtrOrCFunptrValue(builder, loc, cPtr2);
3353 mlir::Value cmpVal = builder.create<mlir::arith::CmpIOp>(
3354 loc, mlir::arith::CmpIPredicate::eq, cPtrVal1, cPtrVal2);
3355 mlir::Value newRes =
3356 builder.create<mlir::arith::AndIOp>(loc, res, cmpVal);
3357 builder.create<fir::ResultOp>(loc, newRes);
3358 })
3359 .getResults()[0];
3360 }
3361 return builder.createConvert(loc, resultType, res);
3362}
3363
3364/// C_ASSOCIATED (C_FUNPTR [, C_FUNPTR])
3365fir::ExtendedValue IntrinsicLibrary::genCAssociatedCFunPtr(
3366 mlir::Type resultType, llvm::ArrayRef<fir::ExtendedValue> args) {
3367 return genCAssociated(builder, loc, resultType, args);
3368}
3369
3370/// C_ASSOCIATED (C_PTR [, C_PTR])
3371fir::ExtendedValue
3372IntrinsicLibrary::genCAssociatedCPtr(mlir::Type resultType,
3373 llvm::ArrayRef<fir::ExtendedValue> args) {
3374 return genCAssociated(builder, loc, resultType, args);
3375}
3376
3377// C_DEVLOC
3378fir::ExtendedValue
3379IntrinsicLibrary::genCDevLoc(mlir::Type resultType,
3380 llvm::ArrayRef<fir::ExtendedValue> args) {
3381 return genCLocOrCFunLoc(builder, loc, resultType, args, /*isFunc=*/false,
3382 /*isDevLoc=*/true);
3383}
3384
3385// C_F_POINTER
3386void IntrinsicLibrary::genCFPointer(llvm::ArrayRef<fir::ExtendedValue> args) {
3387 assert(args.size() == 3);
3388 // Handle CPTR argument
3389 // Get the value of the C address or the result of a reference to C_LOC.
3390 mlir::Value cPtr = fir::getBase(args[0]);
3391 mlir::Value cPtrAddrVal =
3392 fir::factory::genCPtrOrCFunptrValue(builder, loc, cPtr);
3393
3394 // Handle FPTR argument
3395 const auto *fPtr = args[1].getBoxOf<fir::MutableBoxValue>();
3396 assert(fPtr && "FPTR must be a pointer");
3397
3398 auto getCPtrExtVal = [&](fir::MutableBoxValue box) -> fir::ExtendedValue {
3399 mlir::Value addr =
3400 builder.createConvert(loc, fPtr->getMemTy(), cPtrAddrVal);
3401 mlir::SmallVector<mlir::Value> extents;
3402 if (box.hasRank()) {
3403 assert(isStaticallyPresent(args[2]) &&
3404 "FPTR argument must be an array if SHAPE argument exists");
3405 mlir::Value shape = fir::getBase(args[2]);
3406 int arrayRank = box.rank();
3407 mlir::Type shapeElementType =
3408 fir::unwrapSequenceType(fir::unwrapPassByRefType(shape.getType()));
3409 mlir::Type idxType = builder.getIndexType();
3410 for (int i = 0; i < arrayRank; ++i) {
3411 mlir::Value index = builder.createIntegerConstant(loc, idxType, i);
3412 mlir::Value var = builder.create<fir::CoordinateOp>(
3413 loc, builder.getRefType(shapeElementType), shape, index);
3414 mlir::Value load = builder.create<fir::LoadOp>(loc, var);
3415 extents.push_back(builder.createConvert(loc, idxType, load));
3416 }
3417 }
3418 if (box.isCharacter()) {
3419 mlir::Value len = box.nonDeferredLenParams()[0];
3420 if (box.hasRank())
3421 return fir::CharArrayBoxValue{addr, len, extents};
3422 return fir::CharBoxValue{addr, len};
3423 }
3424 if (box.isDerivedWithLenParameters())
3425 TODO(loc, "get length parameters of derived type");
3426 if (box.hasRank())
3427 return fir::ArrayBoxValue{addr, extents};
3428 return addr;
3429 };
3430
3431 fir::factory::associateMutableBox(builder, loc, *fPtr, getCPtrExtVal(*fPtr),
3432 /*lbounds=*/mlir::ValueRange{});
3433
3434 // If the pointer is a registered CUDA fortran variable, the descriptor needs
3435 // to be synced.
3436 if (auto declare = mlir::dyn_cast_or_null<hlfir::DeclareOp>(
3437 fPtr->getAddr().getDefiningOp()))
3438 if (declare.getMemref().getDefiningOp() &&
3439 mlir::isa<fir::AddrOfOp>(declare.getMemref().getDefiningOp()))
3440 if (cuf::isRegisteredDeviceAttr(declare.getDataAttr()) &&
3441 !cuf::isCUDADeviceContext(builder.getRegion()))
3442 fir::runtime::cuda::genSyncGlobalDescriptor(builder, loc,
3443 declare.getMemref());
3444}
3445
3446// C_F_PROCPOINTER
3447void IntrinsicLibrary::genCFProcPointer(
3448 llvm::ArrayRef<fir::ExtendedValue> args) {
3449 assert(args.size() == 2);
3450 mlir::Value cptr =
3451 fir::factory::genCPtrOrCFunptrValue(builder, loc, fir::getBase(args[0]));
3452 mlir::Value fptr = fir::getBase(args[1]);
3453 auto boxProcType =
3454 mlir::cast<fir::BoxProcType>(fir::unwrapRefType(fptr.getType()));
3455 mlir::Value cptrCast =
3456 builder.createConvert(loc, boxProcType.getEleTy(), cptr);
3457 mlir::Value cptrBox =
3458 builder.create<fir::EmboxProcOp>(loc, boxProcType, cptrCast);
3459 builder.create<fir::StoreOp>(loc, cptrBox, fptr);
3460}
3461
3462// C_FUNLOC
3463fir::ExtendedValue
3464IntrinsicLibrary::genCFunLoc(mlir::Type resultType,
3465 llvm::ArrayRef<fir::ExtendedValue> args) {
3466 return genCLocOrCFunLoc(builder, loc, resultType, args, /*isFunc=*/true);
3467}
3468
3469// C_LOC
3470fir::ExtendedValue
3471IntrinsicLibrary::genCLoc(mlir::Type resultType,
3472 llvm::ArrayRef<fir::ExtendedValue> args) {
3473 return genCLocOrCFunLoc(builder, loc, resultType, args);
3474}
3475
3476// C_PTR_EQ and C_PTR_NE
3477template <mlir::arith::CmpIPredicate pred>
3478fir::ExtendedValue
3479IntrinsicLibrary::genCPtrCompare(mlir::Type resultType,
3480 llvm::ArrayRef<fir::ExtendedValue> args) {
3481 assert(args.size() == 2);
3482 mlir::Value cPtr1 = fir::getBase(args[0]);
3483 mlir::Value cPtrVal1 =
3484 fir::factory::genCPtrOrCFunptrValue(builder, loc, cPtr1);
3485 mlir::Value cPtr2 = fir::getBase(args[1]);
3486 mlir::Value cPtrVal2 =
3487 fir::factory::genCPtrOrCFunptrValue(builder, loc, cPtr2);
3488 mlir::Value cmp =
3489 builder.create<mlir::arith::CmpIOp>(loc, pred, cPtrVal1, cPtrVal2);
3490 return builder.createConvert(loc, resultType, cmp);
3491}
3492
3493// CEILING
3494mlir::Value IntrinsicLibrary::genCeiling(mlir::Type resultType,
3495 llvm::ArrayRef<mlir::Value> args) {
3496 // Optional KIND argument.
3497 assert(args.size() >= 1);
3498 mlir::Value arg = args[0];
3499 // Use ceil that is not an actual Fortran intrinsic but that is
3500 // an llvm intrinsic that does the same, but return a floating
3501 // point.
3502 mlir::Value ceil = genRuntimeCall("ceil", arg.getType(), {arg});
3503 return builder.createConvert(loc, resultType, ceil);
3504}
3505
3506// CHAR
3507fir::ExtendedValue
3508IntrinsicLibrary::genChar(mlir::Type type,
3509 llvm::ArrayRef<fir::ExtendedValue> args) {
3510 // Optional KIND argument.
3511 assert(args.size() >= 1);
3512 const mlir::Value *arg = args[0].getUnboxed();
3513 // expect argument to be a scalar integer
3514 if (!arg)
3515 mlir::emitError(loc, "CHAR intrinsic argument not unboxed");
3516 fir::factory::CharacterExprHelper helper{builder, loc};
3517 fir::CharacterType::KindTy kind = helper.getCharacterType(type).getFKind();
3518 mlir::Value cast = helper.createSingletonFromCode(*arg, kind);
3519 mlir::Value len =
3520 builder.createIntegerConstant(loc, builder.getCharacterLengthType(), 1);
3521 return fir::CharBoxValue{cast, len};
3522}
3523
3524// CHDIR
3525fir::ExtendedValue
3526IntrinsicLibrary::genChdir(std::optional<mlir::Type> resultType,
3527 llvm::ArrayRef<fir::ExtendedValue> args) {
3528 assert((args.size() == 1 && resultType.has_value()) ||
3529 (args.size() >= 1 && !resultType.has_value()));
3530 mlir::Value name = fir::getBase(args[0]);
3531 mlir::Value status = fir::runtime::genChdir(builder, loc, name);
3532
3533 if (resultType.has_value()) {
3534 return status;
3535 } else {
3536 // Subroutine form, store status and return none.
3537 if (!isStaticallyAbsent(args[1])) {
3538 mlir::Value statusAddr = fir::getBase(args[1]);
3539 statusAddr.dump();
3540 mlir::Value statusIsPresentAtRuntime =
3541 builder.genIsNotNullAddr(loc, statusAddr);
3542 builder.genIfThen(loc, statusIsPresentAtRuntime)
3543 .genThen([&]() {
3544 builder.createStoreWithConvert(loc, status, statusAddr);
3545 })
3546 .end();
3547 }
3548 }
3549
3550 return {};
3551}
3552
3553// CLOCK64
3554mlir::Value IntrinsicLibrary::genClock64(mlir::Type resultType,
3555 llvm::ArrayRef<mlir::Value> args) {
3556 constexpr llvm::StringLiteral funcName = "llvm.nvvm.read.ptx.sreg.clock64";
3557 mlir::MLIRContext *context = builder.getContext();
3558 mlir::FunctionType ftype = mlir::FunctionType::get(context, {}, {resultType});
3559 auto funcOp = builder.createFunction(loc, funcName, ftype);
3560 return builder.create<fir::CallOp>(loc, funcOp, args).getResult(0);
3561}
3562
3563// CMPLX
3564mlir::Value IntrinsicLibrary::genCmplx(mlir::Type resultType,
3565 llvm::ArrayRef<mlir::Value> args) {
3566 assert(args.size() >= 1);
3567 fir::factory::Complex complexHelper(builder, loc);
3568 mlir::Type partType = complexHelper.getComplexPartType(resultType);
3569 mlir::Value real = builder.createConvert(loc, partType, args[0]);
3570 mlir::Value imag = isStaticallyAbsent(args, 1)
3571 ? builder.createRealZeroConstant(loc, partType)
3572 : builder.createConvert(loc, partType, args[1]);
3573 return fir::factory::Complex{builder, loc}.createComplex(resultType, real,
3574 imag);
3575}
3576
3577// COMMAND_ARGUMENT_COUNT
3578fir::ExtendedValue IntrinsicLibrary::genCommandArgumentCount(
3579 mlir::Type resultType, llvm::ArrayRef<fir::ExtendedValue> args) {
3580 assert(args.size() == 0);
3581 assert(resultType == builder.getDefaultIntegerType() &&
3582 "result type is not default integer kind type");
3583 return builder.createConvert(
3584 loc, resultType, fir::runtime::genCommandArgumentCount(builder, loc));
3585 ;
3586}
3587
3588// CONJG
3589mlir::Value IntrinsicLibrary::genConjg(mlir::Type resultType,
3590 llvm::ArrayRef<mlir::Value> args) {
3591 assert(args.size() == 1);
3592 if (resultType != args[0].getType())
3593 llvm_unreachable("argument type mismatch");
3594
3595 mlir::Value cplx = args[0];
3596 auto imag = fir::factory::Complex{builder, loc}.extractComplexPart(
3597 cplx, /*isImagPart=*/true);
3598 auto negImag = builder.create<mlir::arith::NegFOp>(loc, imag);
3599 return fir::factory::Complex{builder, loc}.insertComplexPart(
3600 cplx, negImag, /*isImagPart=*/true);
3601}
3602
3603// COSD
3604mlir::Value IntrinsicLibrary::genCosd(mlir::Type resultType,
3605 llvm::ArrayRef<mlir::Value> args) {
3606 assert(args.size() == 1);
3607 mlir::MLIRContext *context = builder.getContext();
3608 mlir::FunctionType ftype =
3609 mlir::FunctionType::get(context, {resultType}, {args[0].getType()});
3610 llvm::APFloat pi = llvm::APFloat(llvm::numbers::pi);
3611 mlir::Value dfactor = builder.createRealConstant(
3612 loc, mlir::Float64Type::get(context), pi / llvm::APFloat(180.0));
3613 mlir::Value factor = builder.createConvert(loc, args[0].getType(), dfactor);
3614 mlir::Value arg = builder.create<mlir::arith::MulFOp>(loc, args[0], factor);
3615 return getRuntimeCallGenerator("cos", ftype)(builder, loc, {arg});
3616}
3617
3618// COUNT
3619fir::ExtendedValue
3620IntrinsicLibrary::genCount(mlir::Type resultType,
3621 llvm::ArrayRef<fir::ExtendedValue> args) {
3622 assert(args.size() == 3);
3623
3624 // Handle mask argument
3625 fir::BoxValue mask = builder.createBox(loc, args[0]);
3626 unsigned maskRank = mask.rank();
3627
3628 assert(maskRank > 0);
3629
3630 // Handle optional dim argument
3631 bool absentDim = isStaticallyAbsent(args[1]);
3632 mlir::Value dim =
3633 absentDim ? builder.createIntegerConstant(loc, builder.getIndexType(), 0)
3634 : fir::getBase(args[1]);
3635
3636 if (absentDim || maskRank == 1) {
3637 // Result is scalar if no dim argument or mask is rank 1.
3638 // So, call specialized Count runtime routine.
3639 return builder.createConvert(
3640 loc, resultType,
3641 fir::runtime::genCount(builder, loc, fir::getBase(mask), dim));
3642 }
3643
3644 // Call general CountDim runtime routine.
3645
3646 // Handle optional kind argument
3647 bool absentKind = isStaticallyAbsent(args[2]);
3648 mlir::Value kind = absentKind ? builder.createIntegerConstant(
3649 loc, builder.getIndexType(),
3650 builder.getKindMap().defaultIntegerKind())
3651 : fir::getBase(args[2]);
3652
3653 // Create mutable fir.box to be passed to the runtime for the result.
3654 mlir::Type type = builder.getVarLenSeqTy(resultType, maskRank - 1);
3655 fir::MutableBoxValue resultMutableBox =
3656 fir::factory::createTempMutableBox(builder, loc, type);
3657
3658 mlir::Value resultIrBox =
3659 fir::factory::getMutableIRBox(builder, loc, resultMutableBox);
3660
3661 fir::runtime::genCountDim(builder, loc, resultIrBox, fir::getBase(mask), dim,
3662 kind);
3663 // Handle cleanup of allocatable result descriptor and return
3664 return readAndAddCleanUp(resultMutableBox, resultType, "COUNT");
3665}
3666
3667// CPU_TIME
3668void IntrinsicLibrary::genCpuTime(llvm::ArrayRef<fir::ExtendedValue> args) {
3669 assert(args.size() == 1);
3670 const mlir::Value *arg = args[0].getUnboxed();
3671 assert(arg && "nonscalar cpu_time argument");
3672 mlir::Value res1 = fir::runtime::genCpuTime(builder, loc);
3673 mlir::Value res2 =
3674 builder.createConvert(loc, fir::dyn_cast_ptrEleTy(arg->getType()), res1);
3675 builder.create<fir::StoreOp>(loc, res2, *arg);
3676}
3677
3678// CSHIFT
3679fir::ExtendedValue
3680IntrinsicLibrary::genCshift(mlir::Type resultType,
3681 llvm::ArrayRef<fir::ExtendedValue> args) {
3682 assert(args.size() == 3);
3683
3684 // Handle required ARRAY argument
3685 fir::BoxValue arrayBox = builder.createBox(loc, args[0]);
3686 mlir::Value array = fir::getBase(arrayBox);
3687 unsigned arrayRank = arrayBox.rank();
3688
3689 // Create mutable fir.box to be passed to the runtime for the result.
3690 mlir::Type resultArrayType = builder.getVarLenSeqTy(resultType, arrayRank);
3691 fir::MutableBoxValue resultMutableBox = fir::factory::createTempMutableBox(
3692 builder, loc, resultArrayType, {},
3693 fir::isPolymorphicType(array.getType()) ? array : mlir::Value{});
3694 mlir::Value resultIrBox =
3695 fir::factory::getMutableIRBox(builder, loc, resultMutableBox);
3696
3697 if (arrayRank == 1) {
3698 // Vector case
3699 // Handle required SHIFT argument as a scalar
3700 const mlir::Value *shiftAddr = args[1].getUnboxed();
3701 assert(shiftAddr && "nonscalar CSHIFT argument");
3702 auto shift = builder.create<fir::LoadOp>(loc, *shiftAddr);
3703
3704 fir::runtime::genCshiftVector(builder, loc, resultIrBox, array, shift);
3705 } else {
3706 // Non-vector case
3707 // Handle required SHIFT argument as an array
3708 mlir::Value shift = builder.createBox(loc, args[1]);
3709
3710 // Handle optional DIM argument
3711 mlir::Value dim =
3712 isStaticallyAbsent(args[2])
3713 ? builder.createIntegerConstant(loc, builder.getIndexType(), 1)
3714 : fir::getBase(args[2]);
3715 fir::runtime::genCshift(builder, loc, resultIrBox, array, shift, dim);
3716 }
3717 return readAndAddCleanUp(resultMutableBox, resultType, "CSHIFT");
3718}
3719
3720// __LDCA, __LDCS, __LDLU, __LDCV
3721template <const char *fctName, int extent>
3722fir::ExtendedValue
3723IntrinsicLibrary::genCUDALDXXFunc(mlir::Type resultType,
3724 llvm::ArrayRef<fir::ExtendedValue> args) {
3725 assert(args.size() == 1);
3726 mlir::Type resTy = fir::SequenceType::get(extent, resultType);
3727 mlir::Value arg = fir::getBase(args[0]);
3728 mlir::Value res = builder.create<fir::AllocaOp>(loc, resTy);
3729 if (mlir::isa<fir::BaseBoxType>(arg.getType()))
3730 arg = builder.create<fir::BoxAddrOp>(loc, arg);
3731 mlir::Type refResTy = fir::ReferenceType::get(resTy);
3732 mlir::FunctionType ftype =
3733 mlir::FunctionType::get(arg.getContext(), {refResTy, refResTy}, {});
3734 auto funcOp = builder.createFunction(loc, fctName, ftype);
3735 llvm::SmallVector<mlir::Value> funcArgs;
3736 funcArgs.push_back(res);
3737 funcArgs.push_back(arg);
3738 builder.create<fir::CallOp>(loc, funcOp, funcArgs);
3739 mlir::Value ext =
3740 builder.createIntegerConstant(loc, builder.getIndexType(), extent);
3741 return fir::ArrayBoxValue(res, {ext});
3742}
3743
3744// DATE_AND_TIME
3745void IntrinsicLibrary::genDateAndTime(llvm::ArrayRef<fir::ExtendedValue> args) {
3746 assert(args.size() == 4 && "date_and_time has 4 args");
3747 llvm::SmallVector<std::optional<fir::CharBoxValue>> charArgs(3);
3748 for (unsigned i = 0; i < 3; ++i)
3749 if (const fir::CharBoxValue *charBox = args[i].getCharBox())
3750 charArgs[i] = *charBox;
3751
3752 mlir::Value values = fir::getBase(args[3]);
3753 if (!values)
3754 values = builder.create<fir::AbsentOp>(
3755 loc, fir::BoxType::get(builder.getNoneType()));
3756
3757 fir::runtime::genDateAndTime(builder, loc, charArgs[0], charArgs[1],
3758 charArgs[2], values);
3759}
3760
3761// DIM
3762mlir::Value IntrinsicLibrary::genDim(mlir::Type resultType,
3763 llvm::ArrayRef<mlir::Value> args) {
3764 assert(args.size() == 2);
3765 if (mlir::isa<mlir::IntegerType>(resultType)) {
3766 mlir::Value zero = builder.createIntegerConstant(loc, resultType, 0);
3767 auto diff = builder.create<mlir::arith::SubIOp>(loc, args[0], args[1]);
3768 auto cmp = builder.create<mlir::arith::CmpIOp>(
3769 loc, mlir::arith::CmpIPredicate::sgt, diff, zero);
3770 return builder.create<mlir::arith::SelectOp>(loc, cmp, diff, zero);
3771 }
3772 assert(fir::isa_real(resultType) && "Only expects real and integer in DIM");
3773 mlir::Value zero = builder.createRealZeroConstant(loc, resultType);
3774 auto diff = builder.create<mlir::arith::SubFOp>(loc, args[0], args[1]);
3775 auto cmp = builder.create<mlir::arith::CmpFOp>(
3776 loc, mlir::arith::CmpFPredicate::OGT, diff, zero);
3777 return builder.create<mlir::arith::SelectOp>(loc, cmp, diff, zero);
3778}
3779
3780// DOT_PRODUCT
3781fir::ExtendedValue
3782IntrinsicLibrary::genDotProduct(mlir::Type resultType,
3783 llvm::ArrayRef<fir::ExtendedValue> args) {
3784 assert(args.size() == 2);
3785
3786 // Handle required vector arguments
3787 mlir::Value vectorA = fir::getBase(args[0]);
3788 mlir::Value vectorB = fir::getBase(args[1]);
3789 // Result type is used for picking appropriate runtime function.
3790 mlir::Type eleTy = resultType;
3791
3792 if (fir::isa_complex(eleTy)) {
3793 mlir::Value result = builder.createTemporary(loc, eleTy);
3794 fir::runtime::genDotProduct(builder, loc, vectorA, vectorB, result);
3795 return builder.create<fir::LoadOp>(loc, result);
3796 }
3797
3798 // This operation is only used to pass the result type
3799 // information to the DotProduct generator.
3800 auto resultBox = builder.create<fir::AbsentOp>(loc, fir::BoxType::get(eleTy));
3801 return fir::runtime::genDotProduct(builder, loc, vectorA, vectorB, resultBox);
3802}
3803
3804// DPROD
3805mlir::Value IntrinsicLibrary::genDprod(mlir::Type resultType,
3806 llvm::ArrayRef<mlir::Value> args) {
3807 assert(args.size() == 2);
3808 assert(fir::isa_real(resultType) &&
3809 "Result must be double precision in DPROD");
3810 mlir::Value a = builder.createConvert(loc, resultType, args[0]);
3811 mlir::Value b = builder.createConvert(loc, resultType, args[1]);
3812 return builder.create<mlir::arith::MulFOp>(loc, a, b);
3813}
3814
3815// DSHIFTL
3816mlir::Value IntrinsicLibrary::genDshiftl(mlir::Type resultType,
3817 llvm::ArrayRef<mlir::Value> args) {
3818 assert(args.size() == 3);
3819
3820 mlir::Value i = args[0];
3821 mlir::Value j = args[1];
3822 int bits = resultType.getIntOrFloatBitWidth();
3823 mlir::Type signlessType =
3824 mlir::IntegerType::get(builder.getContext(), bits,
3825 mlir::IntegerType::SignednessSemantics::Signless);
3826 if (resultType.isUnsignedInteger()) {
3827 i = builder.createConvert(loc, signlessType, i);
3828 j = builder.createConvert(loc, signlessType, j);
3829 }
3830 mlir::Value shift = builder.createConvert(loc, signlessType, args[2]);
3831 mlir::Value bitSize = builder.createIntegerConstant(loc, signlessType, bits);
3832
3833 // Per the standard, the value of DSHIFTL(I, J, SHIFT) is equal to
3834 // IOR (SHIFTL(I, SHIFT), SHIFTR(J, BIT_SIZE(J) - SHIFT))
3835 mlir::Value diff = builder.create<mlir::arith::SubIOp>(loc, bitSize, shift);
3836
3837 mlir::Value lArgs[2]{i, shift};
3838 mlir::Value lft = genShift<mlir::arith::ShLIOp>(signlessType, lArgs);
3839
3840 mlir::Value rArgs[2]{j, diff};
3841 mlir::Value rgt = genShift<mlir::arith::ShRUIOp>(signlessType, rArgs);
3842 mlir::Value result = builder.create<mlir::arith::OrIOp>(loc, lft, rgt);
3843 if (resultType.isUnsignedInteger())
3844 return builder.createConvert(loc, resultType, result);
3845 return result;
3846}
3847
3848// DSHIFTR
3849mlir::Value IntrinsicLibrary::genDshiftr(mlir::Type resultType,
3850 llvm::ArrayRef<mlir::Value> args) {
3851 assert(args.size() == 3);
3852
3853 mlir::Value i = args[0];
3854 mlir::Value j = args[1];
3855 int bits = resultType.getIntOrFloatBitWidth();
3856 mlir::Type signlessType =
3857 mlir::IntegerType::get(builder.getContext(), bits,
3858 mlir::IntegerType::SignednessSemantics::Signless);
3859 if (resultType.isUnsignedInteger()) {
3860 i = builder.createConvert(loc, signlessType, i);
3861 j = builder.createConvert(loc, signlessType, j);
3862 }
3863 mlir::Value shift = builder.createConvert(loc, signlessType, args[2]);
3864 mlir::Value bitSize = builder.createIntegerConstant(loc, signlessType, bits);
3865
3866 // Per the standard, the value of DSHIFTR(I, J, SHIFT) is equal to
3867 // IOR (SHIFTL(I, BIT_SIZE(I) - SHIFT), SHIFTR(J, SHIFT))
3868 mlir::Value diff = builder.create<mlir::arith::SubIOp>(loc, bitSize, shift);
3869
3870 mlir::Value lArgs[2]{i, diff};
3871 mlir::Value lft = genShift<mlir::arith::ShLIOp>(signlessType, lArgs);
3872
3873 mlir::Value rArgs[2]{j, shift};
3874 mlir::Value rgt = genShift<mlir::arith::ShRUIOp>(signlessType, rArgs);
3875 mlir::Value result = builder.create<mlir::arith::OrIOp>(loc, lft, rgt);
3876 if (resultType.isUnsignedInteger())
3877 return builder.createConvert(loc, resultType, result);
3878 return result;
3879}
3880
3881// EOSHIFT
3882fir::ExtendedValue
3883IntrinsicLibrary::genEoshift(mlir::Type resultType,
3884 llvm::ArrayRef<fir::ExtendedValue> args) {
3885 assert(args.size() == 4);
3886
3887 // Handle required ARRAY argument
3888 fir::BoxValue arrayBox = builder.createBox(loc, args[0]);
3889 mlir::Value array = fir::getBase(arrayBox);
3890 unsigned arrayRank = arrayBox.rank();
3891
3892 // Create mutable fir.box to be passed to the runtime for the result.
3893 mlir::Type resultArrayType = builder.getVarLenSeqTy(resultType, arrayRank);
3894 fir::MutableBoxValue resultMutableBox = fir::factory::createTempMutableBox(
3895 builder, loc, resultArrayType, {},
3896 fir::isPolymorphicType(array.getType()) ? array : mlir::Value{});
3897 mlir::Value resultIrBox =
3898 fir::factory::getMutableIRBox(builder, loc, resultMutableBox);
3899
3900 // Handle optional BOUNDARY argument
3901 mlir::Value boundary =
3902 isStaticallyAbsent(args[2])
3903 ? builder.create<fir::AbsentOp>(
3904 loc, fir::BoxType::get(builder.getNoneType()))
3905 : builder.createBox(loc, args[2]);
3906
3907 if (arrayRank == 1) {
3908 // Vector case
3909 // Handle required SHIFT argument as a scalar
3910 const mlir::Value *shiftAddr = args[1].getUnboxed();
3911 assert(shiftAddr && "nonscalar EOSHIFT SHIFT argument");
3912 auto shift = builder.create<fir::LoadOp>(loc, *shiftAddr);
3913 fir::runtime::genEoshiftVector(builder, loc, resultIrBox, array, shift,
3914 boundary);
3915 } else {
3916 // Non-vector case
3917 // Handle required SHIFT argument as an array
3918 mlir::Value shift = builder.createBox(loc, args[1]);
3919
3920 // Handle optional DIM argument
3921 mlir::Value dim =
3922 isStaticallyAbsent(args[3])
3923 ? builder.createIntegerConstant(loc, builder.getIndexType(), 1)
3924 : fir::getBase(args[3]);
3925 fir::runtime::genEoshift(builder, loc, resultIrBox, array, shift, boundary,
3926 dim);
3927 }
3928 return readAndAddCleanUp(resultMutableBox, resultType, "EOSHIFT");
3929}
3930
3931// EXECUTE_COMMAND_LINE
3932void IntrinsicLibrary::genExecuteCommandLine(
3933 llvm::ArrayRef<fir::ExtendedValue> args) {
3934 assert(args.size() == 5);
3935
3936 mlir::Value command = fir::getBase(args[0]);
3937 // Optional arguments: wait, exitstat, cmdstat, cmdmsg.
3938 const fir::ExtendedValue &wait = args[1];
3939 const fir::ExtendedValue &exitstat = args[2];
3940 const fir::ExtendedValue &cmdstat = args[3];
3941 const fir::ExtendedValue &cmdmsg = args[4];
3942
3943 if (!command)
3944 fir::emitFatalError(loc, "expected COMMAND parameter");
3945
3946 mlir::Type boxNoneTy = fir::BoxType::get(builder.getNoneType());
3947
3948 mlir::Value waitBool;
3949 if (isStaticallyAbsent(wait)) {
3950 waitBool = builder.createBool(loc, true);
3951 } else {
3952 mlir::Type i1Ty = builder.getI1Type();
3953 mlir::Value waitAddr = fir::getBase(wait);
3954 mlir::Value waitIsPresentAtRuntime =
3955 builder.genIsNotNullAddr(loc, waitAddr);
3956 waitBool = builder
3957 .genIfOp(loc, {i1Ty}, waitIsPresentAtRuntime,
3958 /*withElseRegion=*/true)
3959 .genThen([&]() {
3960 auto waitLoad = builder.create<fir::LoadOp>(loc, waitAddr);
3961 mlir::Value cast =
3962 builder.createConvert(loc, i1Ty, waitLoad);
3963 builder.create<fir::ResultOp>(loc, cast);
3964 })
3965 .genElse([&]() {
3966 mlir::Value trueVal = builder.createBool(loc, true);
3967 builder.create<fir::ResultOp>(loc, trueVal);
3968 })
3969 .getResults()[0];
3970 }
3971
3972 mlir::Value exitstatBox =
3973 isStaticallyPresent(exitstat)
3974 ? fir::getBase(exitstat)
3975 : builder.create<fir::AbsentOp>(loc, boxNoneTy).getResult();
3976 mlir::Value cmdstatBox =
3977 isStaticallyPresent(cmdstat)
3978 ? fir::getBase(cmdstat)
3979 : builder.create<fir::AbsentOp>(loc, boxNoneTy).getResult();
3980 mlir::Value cmdmsgBox =
3981 isStaticallyPresent(cmdmsg)
3982 ? fir::getBase(cmdmsg)
3983 : builder.create<fir::AbsentOp>(loc, boxNoneTy).getResult();
3984 fir::runtime::genExecuteCommandLine(builder, loc, command, waitBool,
3985 exitstatBox, cmdstatBox, cmdmsgBox);
3986}
3987
3988// ETIME
3989fir::ExtendedValue
3990IntrinsicLibrary::genEtime(std::optional<mlir::Type> resultType,
3991 llvm::ArrayRef<fir::ExtendedValue> args) {
3992 assert((args.size() == 2 && !resultType.has_value()) ||
3993 (args.size() == 1 && resultType.has_value()));
3994
3995 mlir::Value values = fir::getBase(args[0]);
3996 if (resultType.has_value()) {
3997 // function form
3998 if (!values)
3999 fir::emitFatalError(loc, "expected VALUES parameter");
4000
4001 auto timeAddr = builder.createTemporary(loc, *resultType);
4002 auto timeBox = builder.createBox(loc, timeAddr);
4003 fir::runtime::genEtime(builder, loc, values, timeBox);
4004 return builder.create<fir::LoadOp>(loc, timeAddr);
4005 } else {
4006 // subroutine form
4007 mlir::Value time = fir::getBase(args[1]);
4008 if (!values)
4009 fir::emitFatalError(loc, "expected VALUES parameter");
4010 if (!time)
4011 fir::emitFatalError(loc, "expected TIME parameter");
4012
4013 fir::runtime::genEtime(builder, loc, values, time);
4014 return {};
4015 }
4016 return {};
4017}
4018
4019// EXIT
4020void IntrinsicLibrary::genExit(llvm::ArrayRef<fir::ExtendedValue> args) {
4021 assert(args.size() == 1);
4022
4023 mlir::Value status =
4024 isStaticallyAbsent(args[0])
4025 ? builder.createIntegerConstant(loc, builder.getDefaultIntegerType(),
4026 EXIT_SUCCESS)
4027 : fir::getBase(args[0]);
4028
4029 assert(status.getType() == builder.getDefaultIntegerType() &&
4030 "STATUS parameter must be an INTEGER of default kind");
4031
4032 fir::runtime::genExit(builder, loc, status);
4033}
4034
4035// EXPONENT
4036mlir::Value IntrinsicLibrary::genExponent(mlir::Type resultType,
4037 llvm::ArrayRef<mlir::Value> args) {
4038 assert(args.size() == 1);
4039
4040 return builder.createConvert(
4041 loc, resultType,
4042 fir::runtime::genExponent(builder, loc, resultType,
4043 fir::getBase(args[0])));
4044}
4045
4046// EXTENDS_TYPE_OF
4047fir::ExtendedValue
4048IntrinsicLibrary::genExtendsTypeOf(mlir::Type resultType,
4049 llvm::ArrayRef<fir::ExtendedValue> args) {
4050 assert(args.size() == 2);
4051
4052 return builder.createConvert(
4053 loc, resultType,
4054 fir::runtime::genExtendsTypeOf(builder, loc, fir::getBase(args[0]),
4055 fir::getBase(args[1])));
4056}
4057
4058// FINDLOC
4059fir::ExtendedValue
4060IntrinsicLibrary::genFindloc(mlir::Type resultType,
4061 llvm::ArrayRef<fir::ExtendedValue> args) {
4062 assert(args.size() == 6);
4063
4064 // Handle required array argument
4065 mlir::Value array = builder.createBox(loc, args[0]);
4066 unsigned rank = fir::BoxValue(array).rank();
4067 assert(rank >= 1);
4068
4069 // Handle required value argument
4070 mlir::Value val = builder.createBox(loc, args[1]);
4071
4072 // Check if dim argument is present
4073 bool absentDim = isStaticallyAbsent(args[2]);
4074
4075 // Handle optional mask argument
4076 auto mask = isStaticallyAbsent(args[3])
4077 ? builder.create<fir::AbsentOp>(
4078 loc, fir::BoxType::get(builder.getI1Type()))
4079 : builder.createBox(loc, args[3]);
4080
4081 // Handle optional kind argument
4082 auto kind = isStaticallyAbsent(args[4])
4083 ? builder.createIntegerConstant(
4084 loc, builder.getIndexType(),
4085 builder.getKindMap().defaultIntegerKind())
4086 : fir::getBase(args[4]);
4087
4088 // Handle optional back argument
4089 auto back = isStaticallyAbsent(args[5]) ? builder.createBool(loc, false)
4090 : fir::getBase(args[5]);
4091
4092 if (!absentDim && rank == 1) {
4093 // If dim argument is present and the array is rank 1, then the result is
4094 // a scalar (since the the result is rank-1 or 0).
4095 // Therefore, we use a scalar result descriptor with FindlocDim().
4096 // Create mutable fir.box to be passed to the runtime for the result.
4097 fir::MutableBoxValue resultMutableBox =
4098 fir::factory::createTempMutableBox(builder, loc, resultType);
4099 mlir::Value resultIrBox =
4100 fir::factory::getMutableIRBox(builder, loc, resultMutableBox);
4101 mlir::Value dim = fir::getBase(args[2]);
4102
4103 fir::runtime::genFindlocDim(builder, loc, resultIrBox, array, val, dim,
4104 mask, kind, back);
4105 // Handle cleanup of allocatable result descriptor and return
4106 return readAndAddCleanUp(resultMutableBox, resultType, "FINDLOC");
4107 }
4108
4109 // The result will be an array. Create mutable fir.box to be passed to the
4110 // runtime for the result.
4111 mlir::Type resultArrayType =
4112 builder.getVarLenSeqTy(resultType, absentDim ? 1 : rank - 1);
4113 fir::MutableBoxValue resultMutableBox =
4114 fir::factory::createTempMutableBox(builder, loc, resultArrayType);
4115 mlir::Value resultIrBox =
4116 fir::factory::getMutableIRBox(builder, loc, resultMutableBox);
4117
4118 if (absentDim) {
4119 fir::runtime::genFindloc(builder, loc, resultIrBox, array, val, mask, kind,
4120 back);
4121 } else {
4122 mlir::Value dim = fir::getBase(args[2]);
4123 fir::runtime::genFindlocDim(builder, loc, resultIrBox, array, val, dim,
4124 mask, kind, back);
4125 }
4126 return readAndAddCleanUp(resultMutableBox, resultType, "FINDLOC");
4127}
4128
4129// FLOOR
4130mlir::Value IntrinsicLibrary::genFloor(mlir::Type resultType,
4131 llvm::ArrayRef<mlir::Value> args) {
4132 // Optional KIND argument.
4133 assert(args.size() >= 1);
4134 mlir::Value arg = args[0];
4135 // Use LLVM floor that returns real.
4136 mlir::Value floor = genRuntimeCall("floor", arg.getType(), {arg});
4137 return builder.createConvert(loc, resultType, floor);
4138}
4139
4140// FRACTION
4141mlir::Value IntrinsicLibrary::genFraction(mlir::Type resultType,
4142 llvm::ArrayRef<mlir::Value> args) {
4143 assert(args.size() == 1);
4144
4145 return builder.createConvert(
4146 loc, resultType,
4147 fir::runtime::genFraction(builder, loc, fir::getBase(args[0])));
4148}
4149
4150void IntrinsicLibrary::genFree(llvm::ArrayRef<fir::ExtendedValue> args) {
4151 assert(args.size() == 1);
4152
4153 fir::runtime::genFree(builder, loc, fir::getBase(args[0]));
4154}
4155
4156// FSEEK
4157fir::ExtendedValue
4158IntrinsicLibrary::genFseek(std::optional<mlir::Type> resultType,
4159 llvm::ArrayRef<fir::ExtendedValue> args) {
4160 assert((args.size() == 4 && !resultType.has_value()) ||
4161 (args.size() == 3 && resultType.has_value()));
4162 mlir::Value unit = fir::getBase(args[0]);
4163 mlir::Value offset = fir::getBase(args[1]);
4164 mlir::Value whence = fir::getBase(args[2]);
4165 if (!unit)
4166 fir::emitFatalError(loc, "expected UNIT argument");
4167 if (!offset)
4168 fir::emitFatalError(loc, "expected OFFSET argument");
4169 if (!whence)
4170 fir::emitFatalError(loc, "expected WHENCE argument");
4171 mlir::Value statusValue =
4172 fir::runtime::genFseek(builder, loc, unit, offset, whence);
4173 if (resultType.has_value()) { // function
4174 return builder.createConvert(loc, *resultType, statusValue);
4175 } else { // subroutine
4176 const fir::ExtendedValue &statusVar = args[3];
4177 if (!isStaticallyAbsent(statusVar)) {
4178 mlir::Value statusAddr = fir::getBase(statusVar);
4179 mlir::Value statusIsPresentAtRuntime =
4180 builder.genIsNotNullAddr(loc, statusAddr);
4181 builder.genIfThen(loc, statusIsPresentAtRuntime)
4182 .genThen([&]() {
4183 builder.createStoreWithConvert(loc, statusValue, statusAddr);
4184 })
4185 .end();
4186 }
4187 return {};
4188 }
4189}
4190
4191// FTELL
4192fir::ExtendedValue
4193IntrinsicLibrary::genFtell(std::optional<mlir::Type> resultType,
4194 llvm::ArrayRef<fir::ExtendedValue> args) {
4195 assert((args.size() == 2 && !resultType.has_value()) ||
4196 (args.size() == 1 && resultType.has_value()));
4197 mlir::Value unit = fir::getBase(args[0]);
4198 if (!unit)
4199 fir::emitFatalError(loc, "expected UNIT argument");
4200 mlir::Value offsetValue = fir::runtime::genFtell(builder, loc, unit);
4201 if (resultType.has_value()) { // function
4202 return offsetValue;
4203 } else { // subroutine
4204 const fir::ExtendedValue &offsetVar = args[1];
4205 if (!isStaticallyAbsent(offsetVar)) {
4206 mlir::Value offsetAddr = fir::getBase(offsetVar);
4207 mlir::Value offsetIsPresentAtRuntime =
4208 builder.genIsNotNullAddr(loc, offsetAddr);
4209 builder.genIfThen(loc, offsetIsPresentAtRuntime)
4210 .genThen([&]() {
4211 builder.createStoreWithConvert(loc, offsetValue, offsetAddr);
4212 })
4213 .end();
4214 }
4215 return {};
4216 }
4217}
4218
4219// GETCWD
4220fir::ExtendedValue
4221IntrinsicLibrary::genGetCwd(std::optional<mlir::Type> resultType,
4222 llvm::ArrayRef<fir::ExtendedValue> args) {
4223 assert((args.size() == 1 && resultType.has_value()) ||
4224 (args.size() >= 1 && !resultType.has_value()));
4225
4226 mlir::Value cwd = fir::getBase(args[0]);
4227 mlir::Value statusValue = fir::runtime::genGetCwd(builder, loc, cwd);
4228
4229 if (resultType.has_value()) {
4230 // Function form, return status.
4231 return statusValue;
4232 } else {
4233 // Subroutine form, store status and return none.
4234 const fir::ExtendedValue &status = args[1];
4235 if (!isStaticallyAbsent(status)) {
4236 mlir::Value statusAddr = fir::getBase(status);
4237 mlir::Value statusIsPresentAtRuntime =
4238 builder.genIsNotNullAddr(loc, statusAddr);
4239 builder.genIfThen(loc, statusIsPresentAtRuntime)
4240 .genThen([&]() {
4241 builder.createStoreWithConvert(loc, statusValue, statusAddr);
4242 })
4243 .end();
4244 }
4245 }
4246
4247 return {};
4248}
4249
4250// GET_COMMAND
4251void IntrinsicLibrary::genGetCommand(llvm::ArrayRef<fir::ExtendedValue> args) {
4252 assert(args.size() == 4);
4253 const fir::ExtendedValue &command = args[0];
4254 const fir::ExtendedValue &length = args[1];
4255 const fir::ExtendedValue &status = args[2];
4256 const fir::ExtendedValue &errmsg = args[3];
4257
4258 // If none of the optional parameters are present, do nothing.
4259 if (!isStaticallyPresent(command) && !isStaticallyPresent(length) &&
4260 !isStaticallyPresent(status) && !isStaticallyPresent(errmsg))
4261 return;
4262
4263 mlir::Type boxNoneTy = fir::BoxType::get(builder.getNoneType());
4264 mlir::Value commandBox =
4265 isStaticallyPresent(command)
4266 ? fir::getBase(command)
4267 : builder.create<fir::AbsentOp>(loc, boxNoneTy).getResult();
4268 mlir::Value lenBox =
4269 isStaticallyPresent(length)
4270 ? fir::getBase(length)
4271 : builder.create<fir::AbsentOp>(loc, boxNoneTy).getResult();
4272 mlir::Value errBox =
4273 isStaticallyPresent(errmsg)
4274 ? fir::getBase(errmsg)
4275 : builder.create<fir::AbsentOp>(loc, boxNoneTy).getResult();
4276 mlir::Value stat =
4277 fir::runtime::genGetCommand(builder, loc, commandBox, lenBox, errBox);
4278 if (isStaticallyPresent(status)) {
4279 mlir::Value statAddr = fir::getBase(status);
4280 mlir::Value statIsPresentAtRuntime =
4281 builder.genIsNotNullAddr(loc, statAddr);
4282 builder.genIfThen(loc, statIsPresentAtRuntime)
4283 .genThen([&]() { builder.createStoreWithConvert(loc, stat, statAddr); })
4284 .end();
4285 }
4286}
4287
4288// GETGID
4289mlir::Value IntrinsicLibrary::genGetGID(mlir::Type resultType,
4290 llvm::ArrayRef<mlir::Value> args) {
4291 assert(args.size() == 0 && "getgid takes no input");
4292 return builder.createConvert(loc, resultType,
4293 fir::runtime::genGetGID(builder, loc));
4294}
4295
4296// GETPID
4297mlir::Value IntrinsicLibrary::genGetPID(mlir::Type resultType,
4298 llvm::ArrayRef<mlir::Value> args) {
4299 assert(args.size() == 0 && "getpid takes no input");
4300 return builder.createConvert(loc, resultType,
4301 fir::runtime::genGetPID(builder, loc));
4302}
4303
4304// GETUID
4305mlir::Value IntrinsicLibrary::genGetUID(mlir::Type resultType,
4306 llvm::ArrayRef<mlir::Value> args) {
4307 assert(args.size() == 0 && "getgid takes no input");
4308 return builder.createConvert(loc, resultType,
4309 fir::runtime::genGetUID(builder, loc));
4310}
4311
4312// GET_COMMAND_ARGUMENT
4313void IntrinsicLibrary::genGetCommandArgument(
4314 llvm::ArrayRef<fir::ExtendedValue> args) {
4315 assert(args.size() == 5);
4316 mlir::Value number = fir::getBase(args[0]);
4317 const fir::ExtendedValue &value = args[1];
4318 const fir::ExtendedValue &length = args[2];
4319 const fir::ExtendedValue &status = args[3];
4320 const fir::ExtendedValue &errmsg = args[4];
4321
4322 if (!number)
4323 fir::emitFatalError(loc, "expected NUMBER parameter");
4324
4325 // If none of the optional parameters are present, do nothing.
4326 if (!isStaticallyPresent(value) && !isStaticallyPresent(length) &&
4327 !isStaticallyPresent(status) && !isStaticallyPresent(errmsg))
4328 return;
4329
4330 mlir::Type boxNoneTy = fir::BoxType::get(builder.getNoneType());
4331 mlir::Value valBox =
4332 isStaticallyPresent(value)
4333 ? fir::getBase(value)
4334 : builder.create<fir::AbsentOp>(loc, boxNoneTy).getResult();
4335 mlir::Value lenBox =
4336 isStaticallyPresent(length)
4337 ? fir::getBase(length)
4338 : builder.create<fir::AbsentOp>(loc, boxNoneTy).getResult();
4339 mlir::Value errBox =
4340 isStaticallyPresent(errmsg)
4341 ? fir::getBase(errmsg)
4342 : builder.create<fir::AbsentOp>(loc, boxNoneTy).getResult();
4343 mlir::Value stat = fir::runtime::genGetCommandArgument(
4344 builder, loc, number, valBox, lenBox, errBox);
4345 if (isStaticallyPresent(status)) {
4346 mlir::Value statAddr = fir::getBase(status);
4347 mlir::Value statIsPresentAtRuntime =
4348 builder.genIsNotNullAddr(loc, statAddr);
4349 builder.genIfThen(loc, statIsPresentAtRuntime)
4350 .genThen([&]() { builder.createStoreWithConvert(loc, stat, statAddr); })
4351 .end();
4352 }
4353}
4354
4355// GET_ENVIRONMENT_VARIABLE
4356void IntrinsicLibrary::genGetEnvironmentVariable(
4357 llvm::ArrayRef<fir::ExtendedValue> args) {
4358 assert(args.size() == 6);
4359 mlir::Value name = fir::getBase(args[0]);
4360 const fir::ExtendedValue &value = args[1];
4361 const fir::ExtendedValue &length = args[2];
4362 const fir::ExtendedValue &status = args[3];
4363 const fir::ExtendedValue &trimName = args[4];
4364 const fir::ExtendedValue &errmsg = args[5];
4365
4366 if (!name)
4367 fir::emitFatalError(loc, "expected NAME parameter");
4368
4369 // If none of the optional parameters are present, do nothing.
4370 if (!isStaticallyPresent(value) && !isStaticallyPresent(length) &&
4371 !isStaticallyPresent(status) && !isStaticallyPresent(errmsg))
4372 return;
4373
4374 // Handle optional TRIM_NAME argument
4375 mlir::Value trim;
4376 if (isStaticallyAbsent(trimName)) {
4377 trim = builder.createBool(loc, true);
4378 } else {
4379 mlir::Type i1Ty = builder.getI1Type();
4380 mlir::Value trimNameAddr = fir::getBase(trimName);
4381 mlir::Value trimNameIsPresentAtRuntime =
4382 builder.genIsNotNullAddr(loc, trimNameAddr);
4383 trim = builder
4384 .genIfOp(loc, {i1Ty}, trimNameIsPresentAtRuntime,
4385 /*withElseRegion=*/true)
4386 .genThen([&]() {
4387 auto trimLoad = builder.create<fir::LoadOp>(loc, trimNameAddr);
4388 mlir::Value cast = builder.createConvert(loc, i1Ty, trimLoad);
4389 builder.create<fir::ResultOp>(loc, cast);
4390 })
4391 .genElse([&]() {
4392 mlir::Value trueVal = builder.createBool(loc, true);
4393 builder.create<fir::ResultOp>(loc, trueVal);
4394 })
4395 .getResults()[0];
4396 }
4397
4398 mlir::Type boxNoneTy = fir::BoxType::get(builder.getNoneType());
4399 mlir::Value valBox =
4400 isStaticallyPresent(value)
4401 ? fir::getBase(value)
4402 : builder.create<fir::AbsentOp>(loc, boxNoneTy).getResult();
4403 mlir::Value lenBox =
4404 isStaticallyPresent(length)
4405 ? fir::getBase(length)
4406 : builder.create<fir::AbsentOp>(loc, boxNoneTy).getResult();
4407 mlir::Value errBox =
4408 isStaticallyPresent(errmsg)
4409 ? fir::getBase(errmsg)
4410 : builder.create<fir::AbsentOp>(loc, boxNoneTy).getResult();
4411 mlir::Value stat = fir::runtime::genGetEnvVariable(builder, loc, name, valBox,
4412 lenBox, trim, errBox);
4413 if (isStaticallyPresent(status)) {
4414 mlir::Value statAddr = fir::getBase(status);
4415 mlir::Value statIsPresentAtRuntime =
4416 builder.genIsNotNullAddr(loc, statAddr);
4417 builder.genIfThen(loc, statIsPresentAtRuntime)
4418 .genThen([&]() { builder.createStoreWithConvert(loc, stat, statAddr); })
4419 .end();
4420 }
4421}
4422
4423// HOSTNM
4424fir::ExtendedValue
4425IntrinsicLibrary::genHostnm(std::optional<mlir::Type> resultType,
4426 llvm::ArrayRef<fir::ExtendedValue> args) {
4427 assert((args.size() == 1 && resultType.has_value()) ||
4428 (args.size() >= 1 && !resultType.has_value()));
4429
4430 mlir::Value res = fir::getBase(args[0]);
4431 mlir::Value statusValue = fir::runtime::genHostnm(builder, loc, res);
4432
4433 if (resultType.has_value()) {
4434 // Function form, return status.
4435 return builder.createConvert(loc, *resultType, statusValue);
4436 }
4437
4438 // Subroutine form, store status and return none.
4439 const fir::ExtendedValue &status = args[1];
4440 if (!isStaticallyAbsent(status)) {
4441 mlir::Value statusAddr = fir::getBase(status);
4442 mlir::Value statusIsPresentAtRuntime =
4443 builder.genIsNotNullAddr(loc, statusAddr);
4444 builder.genIfThen(loc, statusIsPresentAtRuntime)
4445 .genThen([&]() {
4446 builder.createStoreWithConvert(loc, statusValue, statusAddr);
4447 })
4448 .end();
4449 }
4450
4451 return {};
4452}
4453
4454/// Process calls to Maxval, Minval, Product, Sum intrinsic functions that
4455/// take a DIM argument.
4456template <typename FD>
4457static fir::MutableBoxValue
4458genFuncDim(FD funcDim, mlir::Type resultType, fir::FirOpBuilder &builder,
4459 mlir::Location loc, mlir::Value array, fir::ExtendedValue dimArg,
4460 mlir::Value mask, int rank) {
4461
4462 // Create mutable fir.box to be passed to the runtime for the result.
4463 mlir::Type resultArrayType = builder.getVarLenSeqTy(resultType, rank - 1);
4464 fir::MutableBoxValue resultMutableBox =
4465 fir::factory::createTempMutableBox(builder, loc, resultArrayType);
4466 mlir::Value resultIrBox =
4467 fir::factory::getMutableIRBox(builder, loc, resultMutableBox);
4468
4469 mlir::Value dim =
4470 isStaticallyAbsent(dimArg)
4471 ? builder.createIntegerConstant(loc, builder.getIndexType(), 0)
4472 : fir::getBase(dimArg);
4473 funcDim(builder, loc, resultIrBox, array, dim, mask);
4474
4475 return resultMutableBox;
4476}
4477
4478/// Process calls to Product, Sum, IAll, IAny, IParity intrinsic functions
4479template <typename FN, typename FD>
4480fir::ExtendedValue
4481IntrinsicLibrary::genReduction(FN func, FD funcDim, llvm::StringRef errMsg,
4482 mlir::Type resultType,
4483 llvm::ArrayRef<fir::ExtendedValue> args) {
4484
4485 assert(args.size() == 3);
4486
4487 // Handle required array argument
4488 fir::BoxValue arryTmp = builder.createBox(loc, args[0]);
4489 mlir::Value array = fir::getBase(arryTmp);
4490 int rank = arryTmp.rank();
4491 assert(rank >= 1);
4492
4493 // Handle optional mask argument
4494 auto mask = isStaticallyAbsent(args[2])
4495 ? builder.create<fir::AbsentOp>(
4496 loc, fir::BoxType::get(builder.getI1Type()))
4497 : builder.createBox(loc, args[2]);
4498
4499 bool absentDim = isStaticallyAbsent(args[1]);
4500
4501 // We call the type specific versions because the result is scalar
4502 // in the case below.
4503 if (absentDim || rank == 1) {
4504 mlir::Type ty = array.getType();
4505 mlir::Type arrTy = fir::dyn_cast_ptrOrBoxEleTy(ty);
4506 auto eleTy = mlir::cast<fir::SequenceType>(arrTy).getElementType();
4507 if (fir::isa_complex(eleTy)) {
4508 mlir::Value result = builder.createTemporary(loc, eleTy);
4509 func(builder, loc, array, mask, result);
4510 return builder.create<fir::LoadOp>(loc, result);
4511 }
4512 auto resultBox = builder.create<fir::AbsentOp>(
4513 loc, fir::BoxType::get(builder.getI1Type()));
4514 return func(builder, loc, array, mask, resultBox);
4515 }
4516 // Handle Product/Sum cases that have an array result.
4517 auto resultMutableBox =
4518 genFuncDim(funcDim, resultType, builder, loc, array, args[1], mask, rank);
4519 return readAndAddCleanUp(resultMutableBox, resultType, errMsg);
4520}
4521
4522// IALL
4523fir::ExtendedValue
4524IntrinsicLibrary::genIall(mlir::Type resultType,
4525 llvm::ArrayRef<fir::ExtendedValue> args) {
4526 return genReduction(fir::runtime::genIAll, fir::runtime::genIAllDim, "IALL",
4527 resultType, args);
4528}
4529
4530// IAND
4531mlir::Value IntrinsicLibrary::genIand(mlir::Type resultType,
4532 llvm::ArrayRef<mlir::Value> args) {
4533 assert(args.size() == 2);
4534 return builder.createUnsigned<mlir::arith::AndIOp>(loc, resultType, args[0],
4535 args[1]);
4536}
4537
4538// IANY
4539fir::ExtendedValue
4540IntrinsicLibrary::genIany(mlir::Type resultType,
4541 llvm::ArrayRef<fir::ExtendedValue> args) {
4542 return genReduction(fir::runtime::genIAny, fir::runtime::genIAnyDim, "IANY",
4543 resultType, args);
4544}
4545
4546// IBCLR
4547mlir::Value IntrinsicLibrary::genIbclr(mlir::Type resultType,
4548 llvm::ArrayRef<mlir::Value> args) {
4549 // A conformant IBCLR(I,POS) call satisfies:
4550 // POS >= 0
4551 // POS < BIT_SIZE(I)
4552 // Return: I & (!(1 << POS))
4553 assert(args.size() == 2);
4554 mlir::Type signlessType = mlir::IntegerType::get(
4555 builder.getContext(), resultType.getIntOrFloatBitWidth(),
4556 mlir::IntegerType::SignednessSemantics::Signless);
4557 mlir::Value one = builder.createIntegerConstant(loc, signlessType, 1);
4558 mlir::Value ones = builder.createAllOnesInteger(loc, signlessType);
4559 mlir::Value pos = builder.createConvert(loc, signlessType, args[1]);
4560 mlir::Value bit = builder.create<mlir::arith::ShLIOp>(loc, one, pos);
4561 mlir::Value mask = builder.create<mlir::arith::XOrIOp>(loc, ones, bit);
4562 return builder.createUnsigned<mlir::arith::AndIOp>(loc, resultType, args[0],
4563 mask);
4564}
4565
4566// IBITS
4567mlir::Value IntrinsicLibrary::genIbits(mlir::Type resultType,
4568 llvm::ArrayRef<mlir::Value> args) {
4569 // A conformant IBITS(I,POS,LEN) call satisfies:
4570 // POS >= 0
4571 // LEN >= 0
4572 // POS + LEN <= BIT_SIZE(I)
4573 // Return: LEN == 0 ? 0 : (I >> POS) & (-1 >> (BIT_SIZE(I) - LEN))
4574 // For a conformant call, implementing (I >> POS) with a signed or an
4575 // unsigned shift produces the same result. For a nonconformant call,
4576 // the two choices may produce different results.
4577 assert(args.size() == 3);
4578 mlir::Type signlessType = mlir::IntegerType::get(
4579 builder.getContext(), resultType.getIntOrFloatBitWidth(),
4580 mlir::IntegerType::SignednessSemantics::Signless);
4581 mlir::Value word = args[0];
4582 if (word.getType().isUnsignedInteger())
4583 word = builder.createConvert(loc, signlessType, word);
4584 mlir::Value pos = builder.createConvert(loc, signlessType, args[1]);
4585 mlir::Value len = builder.createConvert(loc, signlessType, args[2]);
4586 mlir::Value bitSize = builder.createIntegerConstant(
4587 loc, signlessType, mlir::cast<mlir::IntegerType>(resultType).getWidth());
4588 mlir::Value shiftCount =
4589 builder.create<mlir::arith::SubIOp>(loc, bitSize, len);
4590 mlir::Value zero = builder.createIntegerConstant(loc, signlessType, 0);
4591 mlir::Value ones = builder.createAllOnesInteger(loc, signlessType);
4592 mlir::Value mask =
4593 builder.create<mlir::arith::ShRUIOp>(loc, ones, shiftCount);
4594 mlir::Value res1 = builder.createUnsigned<mlir::arith::ShRSIOp>(
4595 loc, signlessType, word, pos);
4596 mlir::Value res2 = builder.create<mlir::arith::AndIOp>(loc, res1, mask);
4597 mlir::Value lenIsZero = builder.create<mlir::arith::CmpIOp>(
4598 loc, mlir::arith::CmpIPredicate::eq, len, zero);
4599 mlir::Value result =
4600 builder.create<mlir::arith::SelectOp>(loc, lenIsZero, zero, res2);
4601 if (resultType.isUnsignedInteger())
4602 return builder.createConvert(loc, resultType, result);
4603 return result;
4604}
4605
4606// IBSET
4607mlir::Value IntrinsicLibrary::genIbset(mlir::Type resultType,
4608 llvm::ArrayRef<mlir::Value> args) {
4609 // A conformant IBSET(I,POS) call satisfies:
4610 // POS >= 0
4611 // POS < BIT_SIZE(I)
4612 // Return: I | (1 << POS)
4613 assert(args.size() == 2);
4614 mlir::Type signlessType = mlir::IntegerType::get(
4615 builder.getContext(), resultType.getIntOrFloatBitWidth(),
4616 mlir::IntegerType::SignednessSemantics::Signless);
4617 mlir::Value one = builder.createIntegerConstant(loc, signlessType, 1);
4618 mlir::Value pos = builder.createConvert(loc, signlessType, args[1]);
4619 mlir::Value mask = builder.create<mlir::arith::ShLIOp>(loc, one, pos);
4620 return builder.createUnsigned<mlir::arith::OrIOp>(loc, resultType, args[0],
4621 mask);
4622}
4623
4624// ICHAR
4625fir::ExtendedValue
4626IntrinsicLibrary::genIchar(mlir::Type resultType,
4627 llvm::ArrayRef<fir::ExtendedValue> args) {
4628 // There can be an optional kind in second argument.
4629 assert(args.size() == 2);
4630 const fir::CharBoxValue *charBox = args[0].getCharBox();
4631 if (!charBox)
4632 llvm::report_fatal_error("expected character scalar");
4633
4634 fir::factory::CharacterExprHelper helper{builder, loc};
4635 mlir::Value buffer = charBox->getBuffer();
4636 mlir::Type bufferTy = buffer.getType();
4637 mlir::Value charVal;
4638 if (auto charTy = mlir::dyn_cast<fir::CharacterType>(bufferTy)) {
4639 assert(charTy.singleton());
4640 charVal = buffer;
4641 } else {
4642 // Character is in memory, cast to fir.ref<char> and load.
4643 mlir::Type ty = fir::dyn_cast_ptrEleTy(bufferTy);
4644 if (!ty)
4645 llvm::report_fatal_error("expected memory type");
4646 // The length of in the character type may be unknown. Casting
4647 // to a singleton ref is required before loading.
4648 fir::CharacterType eleType = helper.getCharacterType(ty);
4649 fir::CharacterType charType =
4650 fir::CharacterType::get(builder.getContext(), eleType.getFKind(), 1);
4651 mlir::Type toTy = builder.getRefType(charType);
4652 mlir::Value cast = builder.createConvert(loc, toTy, buffer);
4653 charVal = builder.create<fir::LoadOp>(loc, cast);
4654 }
4655 LLVM_DEBUG(llvm::dbgs() << "ichar(" << charVal << ")\n");
4656 auto code = helper.extractCodeFromSingleton(charVal);
4657 if (code.getType() == resultType)
4658 return code;
4659 return builder.create<mlir::arith::ExtUIOp>(loc, resultType, code);
4660}
4661
4662// llvm floating point class intrinsic test values
4663// 0 Signaling NaN
4664// 1 Quiet NaN
4665// 2 Negative infinity
4666// 3 Negative normal
4667// 4 Negative subnormal
4668// 5 Negative zero
4669// 6 Positive zero
4670// 7 Positive subnormal
4671// 8 Positive normal
4672// 9 Positive infinity
4673static constexpr int finiteTest = 0b0111111000;
4674static constexpr int infiniteTest = 0b1000000100;
4675static constexpr int nanTest = 0b0000000011;
4676static constexpr int negativeTest = 0b0000111100;
4677static constexpr int normalTest = 0b0101101000;
4678static constexpr int positiveTest = 0b1111000000;
4679static constexpr int snanTest = 0b0000000001;
4680static constexpr int subnormalTest = 0b0010010000;
4681static constexpr int zeroTest = 0b0001100000;
4682
4683mlir::Value IntrinsicLibrary::genIsFPClass(mlir::Type resultType,
4684 llvm::ArrayRef<mlir::Value> args,
4685 int fpclass) {
4686 assert(args.size() == 1);
4687 mlir::Type i1Ty = builder.getI1Type();
4688 mlir::Value isfpclass =
4689 builder.create<mlir::LLVM::IsFPClass>(loc, i1Ty, args[0], fpclass);
4690 return builder.createConvert(loc, resultType, isfpclass);
4691}
4692
4693// Generate a quiet NaN of a given floating point type.
4694mlir::Value IntrinsicLibrary::genQNan(mlir::Type resultType) {
4695 return genIeeeValue(resultType, builder.createIntegerConstant(
4696 loc, builder.getIntegerType(8),
4697 _FORTRAN_RUNTIME_IEEE_QUIET_NAN));
4698}
4699
4700// Generate code to raise \p excepts if \p cond is absent, or present and true.
4701void IntrinsicLibrary::genRaiseExcept(int excepts, mlir::Value cond) {
4702 fir::IfOp ifOp;
4703 if (cond) {
4704 ifOp = builder.create<fir::IfOp>(loc, cond, /*withElseRegion=*/false);
4705 builder.setInsertionPointToStart(&ifOp.getThenRegion().front());
4706 }
4707 mlir::Type i32Ty = builder.getIntegerType(32);
4708 fir::runtime::genFeraiseexcept(
4709 builder, loc,
4710 fir::runtime::genMapExcept(
4711 builder, loc, builder.createIntegerConstant(loc, i32Ty, excepts)));
4712 if (cond)
4713 builder.setInsertionPointAfter(ifOp);
4714}
4715
4716// Return a reference to the contents of a derived type with one field.
4717// Also return the field type.
4718static std::pair<mlir::Value, mlir::Type>
4719getFieldRef(fir::FirOpBuilder &builder, mlir::Location loc, mlir::Value rec,
4720 unsigned index = 0) {
4721 auto recType =
4722 mlir::dyn_cast<fir::RecordType>(fir::unwrapPassByRefType(rec.getType()));
4723 assert(index < recType.getTypeList().size() && "not enough components");
4724 auto [fieldName, fieldTy] = recType.getTypeList()[index];
4725 mlir::Value field = builder.create<fir::FieldIndexOp>(
4726 loc, fir::FieldType::get(recType.getContext()), fieldName, recType,
4727 fir::getTypeParams(rec));
4728 return {builder.create<fir::CoordinateOp>(loc, builder.getRefType(fieldTy),
4729 rec, field),
4730 fieldTy};
4731}
4732
4733// IEEE_CLASS_TYPE OPERATOR(==), OPERATOR(/=)
4734// IEEE_ROUND_TYPE OPERATOR(==), OPERATOR(/=)
4735template <mlir::arith::CmpIPredicate pred>
4736mlir::Value
4737IntrinsicLibrary::genIeeeTypeCompare(mlir::Type resultType,
4738 llvm::ArrayRef<mlir::Value> args) {
4739 assert(args.size() == 2);
4740 auto [leftRef, fieldTy] = getFieldRef(builder, loc, args[0]);
4741 auto [rightRef, ignore] = getFieldRef(builder, loc, args[1]);
4742 mlir::Value left = builder.create<fir::LoadOp>(loc, fieldTy, leftRef);
4743 mlir::Value right = builder.create<fir::LoadOp>(loc, fieldTy, rightRef);
4744 return builder.create<mlir::arith::CmpIOp>(loc, pred, left, right);
4745}
4746
4747// IEEE_CLASS
4748mlir::Value IntrinsicLibrary::genIeeeClass(mlir::Type resultType,
4749 llvm::ArrayRef<mlir::Value> args) {
4750 // Classify REAL argument X as one of 11 IEEE_CLASS_TYPE values via
4751 // a table lookup on an index built from 5 values derived from X.
4752 // In indexing order, the values are:
4753 //
4754 // [s] sign bit
4755 // [e] exponent != 0
4756 // [m] exponent == 1..1 (max exponent)
4757 // [l] low-order significand != 0
4758 // [h] high-order significand (kind=10: 2 bits; other kinds: 1 bit)
4759 //
4760 // kind=10 values have an explicit high-order integer significand bit,
4761 // whereas this bit is implicit for other kinds. This requires using a 6-bit
4762 // index into a 64-slot table for kind=10 argument classification queries
4763 // vs. a 5-bit index into a 32-slot table for other argument kind queries.
4764 // The instruction sequence is the same for the two cases.
4765 //
4766 // Placing the [l] and [h] significand bits in "swapped" order rather than
4767 // "natural" order enables more efficient generated code.
4768
4769 assert(args.size() == 1);
4770 mlir::Value realVal = args[0];
4771 mlir::FloatType realType = mlir::dyn_cast<mlir::FloatType>(realVal.getType());
4772 const unsigned intWidth = realType.getWidth();
4773 mlir::Type intType = builder.getIntegerType(intWidth);
4774 mlir::Value intVal =
4775 builder.create<mlir::arith::BitcastOp>(loc, intType, realVal);
4776 llvm::StringRef tableName = RTNAME_STRING(IeeeClassTable);
4777 uint64_t highSignificandSize = (realType.getWidth() == 80) + 1;
4778
4779 // Get masks and shift counts.
4780 mlir::Value signShift, highSignificandShift, exponentMask, lowSignificandMask;
4781 auto createIntegerConstant = [&](uint64_t k) {
4782 return builder.createIntegerConstant(loc, intType, k);
4783 };
4784 auto createIntegerConstantAPI = [&](const llvm::APInt &apInt) {
4785 return builder.create<mlir::arith::ConstantOp>(
4786 loc, intType, builder.getIntegerAttr(intType, apInt));
4787 };
4788 auto getMasksAndShifts = [&](uint64_t totalSize, uint64_t exponentSize,
4789 uint64_t significandSize,
4790 bool hasExplicitBit = false) {
4791 assert(1 + exponentSize + significandSize == totalSize &&
4792 "invalid floating point fields");
4793 uint64_t lowSignificandSize = significandSize - hasExplicitBit - 1;
4794 signShift = createIntegerConstant(totalSize - 1 - hasExplicitBit - 4);
4795 highSignificandShift = createIntegerConstant(lowSignificandSize);
4796 llvm::APInt exponentMaskAPI =
4797 llvm::APInt::getBitsSet(intWidth, /*lo=*/significandSize,
4798 /*hi=*/significandSize + exponentSize);
4799 exponentMask = createIntegerConstantAPI(exponentMaskAPI);
4800 llvm::APInt lowSignificandMaskAPI =
4801 llvm::APInt::getLowBitsSet(intWidth, lowSignificandSize);
4802 lowSignificandMask = createIntegerConstantAPI(lowSignificandMaskAPI);
4803 };
4804 switch (realType.getWidth()) {
4805 case 16:
4806 if (realType.isF16()) {
4807 // kind=2: 1 sign bit, 5 exponent bits, 10 significand bits
4808 getMasksAndShifts(16, 5, 10);
4809 } else {
4810 // kind=3: 1 sign bit, 8 exponent bits, 7 significand bits
4811 getMasksAndShifts(16, 8, 7);
4812 }
4813 break;
4814 case 32: // kind=4: 1 sign bit, 8 exponent bits, 23 significand bits
4815 getMasksAndShifts(32, 8, 23);
4816 break;
4817 case 64: // kind=8: 1 sign bit, 11 exponent bits, 52 significand bits
4818 getMasksAndShifts(64, 11, 52);
4819 break;
4820 case 80: // kind=10: 1 sign bit, 15 exponent bits, 1+63 significand bits
4821 getMasksAndShifts(80, 15, 64, /*hasExplicitBit=*/true);
4822 tableName = RTNAME_STRING(IeeeClassTable_10);
4823 break;
4824 case 128: // kind=16: 1 sign bit, 15 exponent bits, 112 significand bits
4825 getMasksAndShifts(128, 15, 112);
4826 break;
4827 default:
4828 llvm_unreachable("unknown real type");
4829 }
4830
4831 // [s] sign bit
4832 int pos = 3 + highSignificandSize;
4833 mlir::Value index = builder.create<mlir::arith::AndIOp>(
4834 loc, builder.create<mlir::arith::ShRUIOp>(loc, intVal, signShift),
4835 createIntegerConstant(1ULL << pos));
4836
4837 // [e] exponent != 0
4838 mlir::Value exponent =
4839 builder.create<mlir::arith::AndIOp>(loc, intVal, exponentMask);
4840 mlir::Value zero = createIntegerConstant(0);
4841 index = builder.create<mlir::arith::OrIOp>(
4842 loc, index,
4843 builder.create<mlir::arith::SelectOp>(
4844 loc,
4845 builder.create<mlir::arith::CmpIOp>(
4846 loc, mlir::arith::CmpIPredicate::ne, exponent, zero),
4847 createIntegerConstant(1ULL << --pos), zero));
4848
4849 // [m] exponent == 1..1 (max exponent)
4850 index = builder.create<mlir::arith::OrIOp>(
4851 loc, index,
4852 builder.create<mlir::arith::SelectOp>(
4853 loc,
4854 builder.create<mlir::arith::CmpIOp>(
4855 loc, mlir::arith::CmpIPredicate::eq, exponent, exponentMask),
4856 createIntegerConstant(1ULL << --pos), zero));
4857
4858 // [l] low-order significand != 0
4859 index = builder.create<mlir::arith::OrIOp>(
4860 loc, index,
4861 builder.create<mlir::arith::SelectOp>(
4862 loc,
4863 builder.create<mlir::arith::CmpIOp>(
4864 loc, mlir::arith::CmpIPredicate::ne,
4865 builder.create<mlir::arith::AndIOp>(loc, intVal,
4866 lowSignificandMask),
4867 zero),
4868 createIntegerConstant(1ULL << --pos), zero));
4869
4870 // [h] high-order significand (1 or 2 bits)
4871 index = builder.create<mlir::arith::OrIOp>(
4872 loc, index,
4873 builder.create<mlir::arith::AndIOp>(
4874 loc,
4875 builder.create<mlir::arith::ShRUIOp>(loc, intVal,
4876 highSignificandShift),
4877 createIntegerConstant((1 << highSignificandSize) - 1)));
4878
4879 int tableSize = 1 << (4 + highSignificandSize);
4880 mlir::Type int8Ty = builder.getIntegerType(8);
4881 mlir::Type tableTy = fir::SequenceType::get(tableSize, int8Ty);
4882 if (!builder.getNamedGlobal(tableName)) {
4883 llvm::SmallVector<mlir::Attribute, 64> values;
4884 auto insert = [&](std::int8_t which) {
4885 values.push_back(builder.getIntegerAttr(int8Ty, which));
4886 };
4887 // If indexing value [e] is 0, value [m] can't be 1. (If the exponent is 0,
4888 // it can't be the max exponent). Use IEEE_OTHER_VALUE for impossible
4889 // combinations.
4890 constexpr std::int8_t impossible = _FORTRAN_RUNTIME_IEEE_OTHER_VALUE;
4891 if (tableSize == 32) {
4892 // s e m l h kinds 2,3,4,8,16
4893 // ===================================================================
4894 /* 0 0 0 0 0 */ insert(_FORTRAN_RUNTIME_IEEE_POSITIVE_ZERO);
4895 /* 0 0 0 0 1 */ insert(_FORTRAN_RUNTIME_IEEE_POSITIVE_SUBNORMAL);
4896 /* 0 0 0 1 0 */ insert(_FORTRAN_RUNTIME_IEEE_POSITIVE_SUBNORMAL);
4897 /* 0 0 0 1 1 */ insert(_FORTRAN_RUNTIME_IEEE_POSITIVE_SUBNORMAL);
4898 /* 0 0 1 0 0 */ insert(impossible);
4899 /* 0 0 1 0 1 */ insert(impossible);
4900 /* 0 0 1 1 0 */ insert(impossible);
4901 /* 0 0 1 1 1 */ insert(impossible);
4902 /* 0 1 0 0 0 */ insert(_FORTRAN_RUNTIME_IEEE_POSITIVE_NORMAL);
4903 /* 0 1 0 0 1 */ insert(_FORTRAN_RUNTIME_IEEE_POSITIVE_NORMAL);
4904 /* 0 1 0 1 0 */ insert(_FORTRAN_RUNTIME_IEEE_POSITIVE_NORMAL);
4905 /* 0 1 0 1 1 */ insert(_FORTRAN_RUNTIME_IEEE_POSITIVE_NORMAL);
4906 /* 0 1 1 0 0 */ insert(_FORTRAN_RUNTIME_IEEE_POSITIVE_INF);
4907 /* 0 1 1 0 1 */ insert(_FORTRAN_RUNTIME_IEEE_QUIET_NAN);
4908 /* 0 1 1 1 0 */ insert(_FORTRAN_RUNTIME_IEEE_SIGNALING_NAN);
4909 /* 0 1 1 1 1 */ insert(_FORTRAN_RUNTIME_IEEE_QUIET_NAN);
4910 /* 1 0 0 0 0 */ insert(_FORTRAN_RUNTIME_IEEE_NEGATIVE_ZERO);
4911 /* 1 0 0 0 1 */ insert(_FORTRAN_RUNTIME_IEEE_NEGATIVE_SUBNORMAL);
4912 /* 1 0 0 1 0 */ insert(_FORTRAN_RUNTIME_IEEE_NEGATIVE_SUBNORMAL);
4913 /* 1 0 0 1 1 */ insert(_FORTRAN_RUNTIME_IEEE_NEGATIVE_SUBNORMAL);
4914 /* 1 0 1 0 0 */ insert(impossible);
4915 /* 1 0 1 0 1 */ insert(impossible);
4916 /* 1 0 1 1 0 */ insert(impossible);
4917 /* 1 0 1 1 1 */ insert(impossible);
4918 /* 1 1 0 0 0 */ insert(_FORTRAN_RUNTIME_IEEE_NEGATIVE_NORMAL);
4919 /* 1 1 0 0 1 */ insert(_FORTRAN_RUNTIME_IEEE_NEGATIVE_NORMAL);
4920 /* 1 1 0 1 0 */ insert(_FORTRAN_RUNTIME_IEEE_NEGATIVE_NORMAL);
4921 /* 1 1 0 1 1 */ insert(_FORTRAN_RUNTIME_IEEE_NEGATIVE_NORMAL);
4922 /* 1 1 1 0 0 */ insert(_FORTRAN_RUNTIME_IEEE_NEGATIVE_INF);
4923 /* 1 1 1 0 1 */ insert(_FORTRAN_RUNTIME_IEEE_QUIET_NAN);
4924 /* 1 1 1 1 0 */ insert(_FORTRAN_RUNTIME_IEEE_SIGNALING_NAN);
4925 /* 1 1 1 1 1 */ insert(_FORTRAN_RUNTIME_IEEE_QUIET_NAN);
4926 } else {
4927 // Unlike values of other kinds, kind=10 values can be "invalid", and
4928 // can appear in code. Use IEEE_OTHER_VALUE for invalid bit patterns.
4929 // Runtime IO may print an invalid value as a NaN.
4930 constexpr std::int8_t invalid = _FORTRAN_RUNTIME_IEEE_OTHER_VALUE;
4931 // s e m l h kind 10
4932 // ===================================================================
4933 /* 0 0 0 0 00 */ insert(_FORTRAN_RUNTIME_IEEE_POSITIVE_ZERO);
4934 /* 0 0 0 0 01 */ insert(_FORTRAN_RUNTIME_IEEE_POSITIVE_SUBNORMAL);
4935 /* 0 0 0 0 10 */ insert(_FORTRAN_RUNTIME_IEEE_POSITIVE_SUBNORMAL);
4936 /* 0 0 0 0 11 */ insert(_FORTRAN_RUNTIME_IEEE_POSITIVE_SUBNORMAL);
4937 /* 0 0 0 1 00 */ insert(_FORTRAN_RUNTIME_IEEE_POSITIVE_SUBNORMAL);
4938 /* 0 0 0 1 01 */ insert(_FORTRAN_RUNTIME_IEEE_POSITIVE_SUBNORMAL);
4939 /* 0 0 0 1 10 */ insert(_FORTRAN_RUNTIME_IEEE_POSITIVE_SUBNORMAL);
4940 /* 0 0 0 1 11 */ insert(_FORTRAN_RUNTIME_IEEE_POSITIVE_SUBNORMAL);
4941 /* 0 0 1 0 00 */ insert(impossible);
4942 /* 0 0 1 0 01 */ insert(impossible);
4943 /* 0 0 1 0 10 */ insert(impossible);
4944 /* 0 0 1 0 11 */ insert(impossible);
4945 /* 0 0 1 1 00 */ insert(impossible);
4946 /* 0 0 1 1 01 */ insert(impossible);
4947 /* 0 0 1 1 10 */ insert(impossible);
4948 /* 0 0 1 1 11 */ insert(impossible);
4949 /* 0 1 0 0 00 */ insert(invalid);
4950 /* 0 1 0 0 01 */ insert(invalid);
4951 /* 0 1 0 0 10 */ insert(_FORTRAN_RUNTIME_IEEE_POSITIVE_NORMAL);
4952 /* 0 1 0 0 11 */ insert(_FORTRAN_RUNTIME_IEEE_POSITIVE_NORMAL);
4953 /* 0 1 0 1 00 */ insert(invalid);
4954 /* 0 1 0 1 01 */ insert(invalid);
4955 /* 0 1 0 1 10 */ insert(_FORTRAN_RUNTIME_IEEE_POSITIVE_NORMAL);
4956 /* 0 1 0 1 11 */ insert(_FORTRAN_RUNTIME_IEEE_POSITIVE_NORMAL);
4957 /* 0 1 1 0 00 */ insert(invalid);
4958 /* 0 1 1 0 01 */ insert(invalid);
4959 /* 0 1 1 0 10 */ insert(_FORTRAN_RUNTIME_IEEE_POSITIVE_INF);
4960 /* 0 1 1 0 11 */ insert(_FORTRAN_RUNTIME_IEEE_QUIET_NAN);
4961 /* 0 1 1 1 00 */ insert(invalid);
4962 /* 0 1 1 1 01 */ insert(invalid);
4963 /* 0 1 1 1 10 */ insert(_FORTRAN_RUNTIME_IEEE_SIGNALING_NAN);
4964 /* 0 1 1 1 11 */ insert(_FORTRAN_RUNTIME_IEEE_QUIET_NAN);
4965 /* 1 0 0 0 00 */ insert(_FORTRAN_RUNTIME_IEEE_NEGATIVE_ZERO);
4966 /* 1 0 0 0 01 */ insert(_FORTRAN_RUNTIME_IEEE_NEGATIVE_SUBNORMAL);
4967 /* 1 0 0 0 10 */ insert(_FORTRAN_RUNTIME_IEEE_NEGATIVE_SUBNORMAL);
4968 /* 1 0 0 0 11 */ insert(_FORTRAN_RUNTIME_IEEE_NEGATIVE_SUBNORMAL);
4969 /* 1 0 0 1 00 */ insert(_FORTRAN_RUNTIME_IEEE_NEGATIVE_SUBNORMAL);
4970 /* 1 0 0 1 01 */ insert(_FORTRAN_RUNTIME_IEEE_NEGATIVE_SUBNORMAL);
4971 /* 1 0 0 1 10 */ insert(_FORTRAN_RUNTIME_IEEE_NEGATIVE_SUBNORMAL);
4972 /* 1 0 0 1 11 */ insert(_FORTRAN_RUNTIME_IEEE_NEGATIVE_SUBNORMAL);
4973 /* 1 0 1 0 00 */ insert(impossible);
4974 /* 1 0 1 0 01 */ insert(impossible);
4975 /* 1 0 1 0 10 */ insert(impossible);
4976 /* 1 0 1 0 11 */ insert(impossible);
4977 /* 1 0 1 1 00 */ insert(impossible);
4978 /* 1 0 1 1 01 */ insert(impossible);
4979 /* 1 0 1 1 10 */ insert(impossible);
4980 /* 1 0 1 1 11 */ insert(impossible);
4981 /* 1 1 0 0 00 */ insert(invalid);
4982 /* 1 1 0 0 01 */ insert(invalid);
4983 /* 1 1 0 0 10 */ insert(_FORTRAN_RUNTIME_IEEE_NEGATIVE_NORMAL);
4984 /* 1 1 0 0 11 */ insert(_FORTRAN_RUNTIME_IEEE_NEGATIVE_NORMAL);
4985 /* 1 1 0 1 00 */ insert(invalid);
4986 /* 1 1 0 1 01 */ insert(invalid);
4987 /* 1 1 0 1 10 */ insert(_FORTRAN_RUNTIME_IEEE_NEGATIVE_NORMAL);
4988 /* 1 1 0 1 11 */ insert(_FORTRAN_RUNTIME_IEEE_NEGATIVE_NORMAL);
4989 /* 1 1 1 0 00 */ insert(invalid);
4990 /* 1 1 1 0 01 */ insert(invalid);
4991 /* 1 1 1 0 10 */ insert(_FORTRAN_RUNTIME_IEEE_NEGATIVE_INF);
4992 /* 1 1 1 0 11 */ insert(_FORTRAN_RUNTIME_IEEE_QUIET_NAN);
4993 /* 1 1 1 1 00 */ insert(invalid);
4994 /* 1 1 1 1 01 */ insert(invalid);
4995 /* 1 1 1 1 10 */ insert(_FORTRAN_RUNTIME_IEEE_SIGNALING_NAN);
4996 /* 1 1 1 1 11 */ insert(_FORTRAN_RUNTIME_IEEE_QUIET_NAN);
4997 }
4998 builder.createGlobalConstant(
4999 loc, tableTy, tableName, builder.createLinkOnceLinkage(),
5000 mlir::DenseElementsAttr::get(
5001 mlir::RankedTensorType::get(tableSize, int8Ty), values));
5002 }
5003
5004 return builder.create<fir::CoordinateOp>(
5005 loc, builder.getRefType(resultType),
5006 builder.create<fir::AddrOfOp>(loc, builder.getRefType(tableTy),
5007 builder.getSymbolRefAttr(tableName)),
5008 index);
5009}
5010
5011// IEEE_COPY_SIGN
5012mlir::Value
5013IntrinsicLibrary::genIeeeCopySign(mlir::Type resultType,
5014 llvm::ArrayRef<mlir::Value> args) {
5015 // Copy the sign of REAL arg Y to REAL arg X.
5016 assert(args.size() == 2);
5017 mlir::Value xRealVal = args[0];
5018 mlir::Value yRealVal = args[1];
5019 mlir::FloatType xRealType =
5020 mlir::dyn_cast<mlir::FloatType>(xRealVal.getType());
5021 mlir::FloatType yRealType =
5022 mlir::dyn_cast<mlir::FloatType>(yRealVal.getType());
5023
5024 if (yRealType == mlir::BFloat16Type::get(builder.getContext())) {
5025 // Workaround: CopySignOp and BitcastOp don't work for kind 3 arg Y.
5026 // This conversion should always preserve the sign bit.
5027 yRealVal = builder.createConvert(
5028 loc, mlir::Float32Type::get(builder.getContext()), yRealVal);
5029 yRealType = mlir::Float32Type::get(builder.getContext());
5030 }
5031
5032 // Args have the same type.
5033 if (xRealType == yRealType)
5034 return builder.create<mlir::math::CopySignOp>(loc, xRealVal, yRealVal);
5035
5036 // Args have different types.
5037 mlir::Type xIntType = builder.getIntegerType(xRealType.getWidth());
5038 mlir::Type yIntType = builder.getIntegerType(yRealType.getWidth());
5039 mlir::Value xIntVal =
5040 builder.create<mlir::arith::BitcastOp>(loc, xIntType, xRealVal);
5041 mlir::Value yIntVal =
5042 builder.create<mlir::arith::BitcastOp>(loc, yIntType, yRealVal);
5043 mlir::Value xZero = builder.createIntegerConstant(loc, xIntType, 0);
5044 mlir::Value yZero = builder.createIntegerConstant(loc, yIntType, 0);
5045 mlir::Value xOne = builder.createIntegerConstant(loc, xIntType, 1);
5046 mlir::Value ySign = builder.create<mlir::arith::ShRUIOp>(
5047 loc, yIntVal,
5048 builder.createIntegerConstant(loc, yIntType, yRealType.getWidth() - 1));
5049 mlir::Value xAbs = builder.create<mlir::arith::ShRUIOp>(
5050 loc, builder.create<mlir::arith::ShLIOp>(loc, xIntVal, xOne), xOne);
5051 mlir::Value xSign = builder.create<mlir::arith::SelectOp>(
5052 loc,
5053 builder.create<mlir::arith::CmpIOp>(loc, mlir::arith::CmpIPredicate::eq,
5054 ySign, yZero),
5055 xZero,
5056 builder.create<mlir::arith::ShLIOp>(
5057 loc, xOne,
5058 builder.createIntegerConstant(loc, xIntType,
5059 xRealType.getWidth() - 1)));
5060 return builder.create<mlir::arith::BitcastOp>(
5061 loc, xRealType, builder.create<mlir::arith::OrIOp>(loc, xAbs, xSign));
5062}
5063
5064// IEEE_GET_FLAG
5065void IntrinsicLibrary::genIeeeGetFlag(llvm::ArrayRef<fir::ExtendedValue> args) {
5066 assert(args.size() == 2);
5067 // Set FLAG_VALUE=.TRUE. if the exception specified by FLAG is signaling.
5068 mlir::Value flag = fir::getBase(args[0]);
5069 mlir::Value flagValue = fir::getBase(args[1]);
5070 mlir::Type resultTy =
5071 mlir::dyn_cast<fir::ReferenceType>(flagValue.getType()).getEleTy();
5072 mlir::Type i32Ty = builder.getIntegerType(32);
5073 mlir::Value zero = builder.createIntegerConstant(loc, i32Ty, 0);
5074 auto [fieldRef, ignore] = getFieldRef(builder, loc, flag);
5075 mlir::Value field = builder.create<fir::LoadOp>(loc, fieldRef);
5076 mlir::Value excepts = fir::runtime::genFetestexcept(
5077 builder, loc,
5078 fir::runtime::genMapExcept(
5079 builder, loc, builder.create<fir::ConvertOp>(loc, i32Ty, field)));
5080 mlir::Value logicalResult = builder.create<fir::ConvertOp>(
5081 loc, resultTy,
5082 builder.create<mlir::arith::CmpIOp>(loc, mlir::arith::CmpIPredicate::ne,
5083 excepts, zero));
5084 builder.create<fir::StoreOp>(loc, logicalResult, flagValue);
5085}
5086
5087// IEEE_GET_HALTING_MODE
5088void IntrinsicLibrary::genIeeeGetHaltingMode(
5089 llvm::ArrayRef<fir::ExtendedValue> args) {
5090 // Set HALTING=.TRUE. if the exception specified by FLAG will cause halting.
5091 assert(args.size() == 2);
5092 mlir::Value flag = fir::getBase(args[0]);
5093 mlir::Value halting = fir::getBase(args[1]);
5094 mlir::Type resultTy =
5095 mlir::dyn_cast<fir::ReferenceType>(halting.getType()).getEleTy();
5096 mlir::Type i32Ty = builder.getIntegerType(32);
5097 mlir::Value zero = builder.createIntegerConstant(loc, i32Ty, 0);
5098 auto [fieldRef, ignore] = getFieldRef(builder, loc, flag);
5099 mlir::Value field = builder.create<fir::LoadOp>(loc, fieldRef);
5100 mlir::Value haltSet = fir::runtime::genFegetexcept(builder, loc);
5101 mlir::Value intResult = builder.create<mlir::arith::AndIOp>(
5102 loc, haltSet,
5103 fir::runtime::genMapExcept(
5104 builder, loc, builder.create<fir::ConvertOp>(loc, i32Ty, field)));
5105 mlir::Value logicalResult = builder.create<fir::ConvertOp>(
5106 loc, resultTy,
5107 builder.create<mlir::arith::CmpIOp>(loc, mlir::arith::CmpIPredicate::ne,
5108 intResult, zero));
5109 builder.create<fir::StoreOp>(loc, logicalResult, halting);
5110}
5111
5112// IEEE_GET_MODES, IEEE_SET_MODES
5113// IEEE_GET_STATUS, IEEE_SET_STATUS
5114template <bool isGet, bool isModes>
5115void IntrinsicLibrary::genIeeeGetOrSetModesOrStatus(
5116 llvm::ArrayRef<fir::ExtendedValue> args) {
5117 assert(args.size() == 1);
5118#ifndef __GLIBC_USE_IEC_60559_BFP_EXT // only use of "#include <cfenv>"
5119 // No definitions of fegetmode, fesetmode
5120 llvm::StringRef func = isModes
5121 ? (isGet ? "ieee_get_modes" : "ieee_set_modes")
5122 : (isGet ? "ieee_get_status" : "ieee_set_status");
5123 TODO(loc, "intrinsic module procedure: " + func);
5124#else
5125 mlir::Type i32Ty = builder.getIntegerType(32);
5126 mlir::Type i64Ty = builder.getIntegerType(64);
5127 mlir::Type ptrTy = builder.getRefType(i32Ty);
5128 mlir::Value addr;
5129 if (fir::getTargetTriple(builder.getModule()).isSPARC()) {
5130 // Floating point environment data is larger than the __data field
5131 // allotment. Allocate data space from the heap.
5132 auto [fieldRef, fieldTy] =
5133 getFieldRef(builder, loc, fir::getBase(args[0]), 1);
5134 addr = builder.create<fir::BoxAddrOp>(
5135 loc, builder.create<fir::LoadOp>(loc, fieldRef));
5136 mlir::Type heapTy = addr.getType();
5137 mlir::Value allocated = builder.create<mlir::arith::CmpIOp>(
5138 loc, mlir::arith::CmpIPredicate::ne,
5139 builder.createConvert(loc, i64Ty, addr),
5140 builder.createIntegerConstant(loc, i64Ty, 0));
5141 auto ifOp = builder.create<fir::IfOp>(loc, heapTy, allocated,
5142 /*withElseRegion=*/true);
5143 builder.setInsertionPointToStart(&ifOp.getThenRegion().front());
5144 builder.create<fir::ResultOp>(loc, addr);
5145 builder.setInsertionPointToStart(&ifOp.getElseRegion().front());
5146 mlir::Value byteSize =
5147 isModes ? fir::runtime::genGetModesTypeSize(builder, loc)
5148 : fir::runtime::genGetStatusTypeSize(builder, loc);
5149 byteSize = builder.createConvert(loc, builder.getIndexType(), byteSize);
5150 addr =
5151 builder.create<fir::AllocMemOp>(loc, extractSequenceType(heapTy),
5152 /*typeparams=*/std::nullopt, byteSize);
5153 mlir::Value shape = builder.create<fir::ShapeOp>(loc, byteSize);
5154 builder.create<fir::StoreOp>(
5155 loc, builder.create<fir::EmboxOp>(loc, fieldTy, addr, shape), fieldRef);
5156 builder.create<fir::ResultOp>(loc, addr);
5157 builder.setInsertionPointAfter(ifOp);
5158 addr = builder.create<fir::ConvertOp>(loc, ptrTy, ifOp.getResult(0));
5159 } else {
5160 // Place floating point environment data in __data storage.
5161 addr = builder.create<fir::ConvertOp>(loc, ptrTy, getBase(args[0]));
5162 }
5163 llvm::StringRef func = isModes ? (isGet ? "fegetmode" : "fesetmode")
5164 : (isGet ? "fegetenv" : "fesetenv");
5165 genRuntimeCall(func, i32Ty, addr);
5166#endif
5167}
5168
5169// Check that an explicit ieee_[get|set]_rounding_mode call radix value is 2.
5170static void checkRadix(fir::FirOpBuilder &builder, mlir::Location loc,
5171 mlir::Value radix, std::string procName) {
5172 mlir::Value notTwo = builder.create<mlir::arith::CmpIOp>(
5173 loc, mlir::arith::CmpIPredicate::ne, radix,
5174 builder.createIntegerConstant(loc, radix.getType(), 2));
5175 auto ifOp = builder.create<fir::IfOp>(loc, notTwo,
5176 /*withElseRegion=*/false);
5177 builder.setInsertionPointToStart(&ifOp.getThenRegion().front());
5178 fir::runtime::genReportFatalUserError(builder, loc,
5179 procName + " radix argument must be 2");
5180 builder.setInsertionPointAfter(ifOp);
5181}
5182
5183// IEEE_GET_ROUNDING_MODE
5184void IntrinsicLibrary::genIeeeGetRoundingMode(
5185 llvm::ArrayRef<fir::ExtendedValue> args) {
5186 // Set arg ROUNDING_VALUE to the current floating point rounding mode.
5187 // Values are chosen to match the llvm.get.rounding encoding.
5188 // Generate an error if the value of optional arg RADIX is not 2.
5189 assert(args.size() == 1 || args.size() == 2);
5190 if (args.size() == 2)
5191 checkRadix(builder, loc, fir::getBase(args[1]), "ieee_get_rounding_mode");
5192 auto [fieldRef, fieldTy] = getFieldRef(builder, loc, fir::getBase(args[0]));
5193 mlir::func::FuncOp getRound = fir::factory::getLlvmGetRounding(builder);
5194 mlir::Value mode = builder.create<fir::CallOp>(loc, getRound).getResult(0);
5195 mode = builder.createConvert(loc, fieldTy, mode);
5196 builder.create<fir::StoreOp>(loc, mode, fieldRef);
5197}
5198
5199// IEEE_GET_UNDERFLOW_MODE
5200void IntrinsicLibrary::genIeeeGetUnderflowMode(
5201 llvm::ArrayRef<fir::ExtendedValue> args) {
5202 assert(args.size() == 1);
5203 mlir::Value flag = fir::runtime::genGetUnderflowMode(builder, loc);
5204 builder.createStoreWithConvert(loc, flag, fir::getBase(args[0]));
5205}
5206
5207// IEEE_INT
5208mlir::Value IntrinsicLibrary::genIeeeInt(mlir::Type resultType,
5209 llvm::ArrayRef<mlir::Value> args) {
5210 // Convert real argument A to an integer, with rounding according to argument
5211 // ROUND. Signal IEEE_INVALID if A is a NaN, an infinity, or out of range,
5212 // and return either the largest or smallest integer result value (*).
5213 // For valid results (when IEEE_INVALID is not signaled), signal IEEE_INEXACT
5214 // if A is not an exact integral value (*). The (*) choices are processor
5215 // dependent implementation choices not mandated by the standard.
5216 // The primary result is generated with a call to IEEE_RINT.
5217 assert(args.size() == 3);
5218 mlir::FloatType realType = mlir::cast<mlir::FloatType>(args[0].getType());
5219 mlir::Value realResult = genIeeeRint(realType, {args[0], args[1]});
5220 int intWidth = mlir::cast<mlir::IntegerType>(resultType).getWidth();
5221 mlir::Value intLBound = builder.create<mlir::arith::ConstantOp>(
5222 loc, resultType,
5223 builder.getIntegerAttr(resultType,
5224 llvm::APInt::getBitsSet(intWidth,
5225 /*lo=*/intWidth - 1,
5226 /*hi=*/intWidth)));
5227 mlir::Value intUBound = builder.create<mlir::arith::ConstantOp>(
5228 loc, resultType,
5229 builder.getIntegerAttr(resultType,
5230 llvm::APInt::getBitsSet(intWidth, /*lo=*/0,
5231 /*hi=*/intWidth - 1)));
5232 mlir::Value realLBound =
5233 builder.create<fir::ConvertOp>(loc, realType, intLBound);
5234 mlir::Value realUBound = builder.create<mlir::arith::NegFOp>(loc, realLBound);
5235 mlir::Value aGreaterThanLBound = builder.create<mlir::arith::CmpFOp>(
5236 loc, mlir::arith::CmpFPredicate::OGE, realResult, realLBound);
5237 mlir::Value aLessThanUBound = builder.create<mlir::arith::CmpFOp>(
5238 loc, mlir::arith::CmpFPredicate::OLT, realResult, realUBound);
5239 mlir::Value resultIsValid = builder.create<mlir::arith::AndIOp>(
5240 loc, aGreaterThanLBound, aLessThanUBound);
5241
5242 // Result is valid. It may be exact or inexact.
5243 mlir::Value result;
5244 fir::IfOp ifOp = builder.create<fir::IfOp>(loc, resultType, resultIsValid,
5245 /*withElseRegion=*/true);
5246 builder.setInsertionPointToStart(&ifOp.getThenRegion().front());
5247 mlir::Value inexact = builder.create<mlir::arith::CmpFOp>(
5248 loc, mlir::arith::CmpFPredicate::ONE, args[0], realResult);
5249 genRaiseExcept(_FORTRAN_RUNTIME_IEEE_INEXACT, inexact);
5250 result = builder.create<fir::ConvertOp>(loc, resultType, realResult);
5251 builder.create<fir::ResultOp>(loc, result);
5252
5253 // Result is invalid.
5254 builder.setInsertionPointToStart(&ifOp.getElseRegion().front());
5255 genRaiseExcept(_FORTRAN_RUNTIME_IEEE_INVALID);
5256 result = builder.create<mlir::arith::SelectOp>(loc, aGreaterThanLBound,
5257 intUBound, intLBound);
5258 builder.create<fir::ResultOp>(loc, result);
5259 builder.setInsertionPointAfter(ifOp);
5260 return ifOp.getResult(0);
5261}
5262
5263// IEEE_IS_FINITE
5264mlir::Value
5265IntrinsicLibrary::genIeeeIsFinite(mlir::Type resultType,
5266 llvm::ArrayRef<mlir::Value> args) {
5267 // Check if arg X is a (negative or positive) (normal, denormal, or zero).
5268 assert(args.size() == 1);
5269 return genIsFPClass(resultType, args, finiteTest);
5270}
5271
5272// IEEE_IS_NAN
5273mlir::Value IntrinsicLibrary::genIeeeIsNan(mlir::Type resultType,
5274 llvm::ArrayRef<mlir::Value> args) {
5275 // Check if arg X is a (signaling or quiet) NaN.
5276 assert(args.size() == 1);
5277 return genIsFPClass(resultType, args, nanTest);
5278}
5279
5280// IEEE_IS_NEGATIVE
5281mlir::Value
5282IntrinsicLibrary::genIeeeIsNegative(mlir::Type resultType,
5283 llvm::ArrayRef<mlir::Value> args) {
5284 // Check if arg X is a negative (infinity, normal, denormal or zero).
5285 assert(args.size() == 1);
5286 return genIsFPClass(resultType, args, negativeTest);
5287}
5288
5289// IEEE_IS_NORMAL
5290mlir::Value
5291IntrinsicLibrary::genIeeeIsNormal(mlir::Type resultType,
5292 llvm::ArrayRef<mlir::Value> args) {
5293 // Check if arg X is a (negative or positive) (normal or zero).
5294 assert(args.size() == 1);
5295 return genIsFPClass(resultType, args, normalTest);
5296}
5297
5298// IEEE_LOGB
5299mlir::Value IntrinsicLibrary::genIeeeLogb(mlir::Type resultType,
5300 llvm::ArrayRef<mlir::Value> args) {
5301 // Exponent of X, with special case treatment for some input values.
5302 // Return: X == 0
5303 // ? -infinity (and raise FE_DIVBYZERO)
5304 // : ieee_is_finite(X)
5305 // ? exponent(X) - 1 // unbiased exponent of X
5306 // : ieee_copy_sign(X, 1.0) // +infinity or NaN
5307 assert(args.size() == 1);
5308 mlir::Value realVal = args[0];
5309 mlir::FloatType realType = mlir::dyn_cast<mlir::FloatType>(realVal.getType());
5310 int bitWidth = realType.getWidth();
5311 mlir::Type intType = builder.getIntegerType(realType.getWidth());
5312 mlir::Value intVal =
5313 builder.create<mlir::arith::BitcastOp>(loc, intType, realVal);
5314 mlir::Type i1Ty = builder.getI1Type();
5315
5316 int exponentBias, significandSize, nonSignificandSize;
5317 switch (bitWidth) {
5318 case 16:
5319 if (realType.isF16()) {
5320 // kind=2: 1 sign bit, 5 exponent bits, 10 significand bits
5321 exponentBias = (1 << (5 - 1)) - 1; // 15
5322 significandSize = 10;
5323 nonSignificandSize = 6;
5324 break;
5325 }
5326 assert(realType.isBF16() && "unknown 16-bit real type");
5327 // kind=3: 1 sign bit, 8 exponent bits, 7 significand bits
5328 exponentBias = (1 << (8 - 1)) - 1; // 127
5329 significandSize = 7;
5330 nonSignificandSize = 9;
5331 break;
5332 case 32:
5333 // kind=4: 1 sign bit, 8 exponent bits, 23 significand bits
5334 exponentBias = (1 << (8 - 1)) - 1; // 127
5335 significandSize = 23;
5336 nonSignificandSize = 9;
5337 break;
5338 case 64:
5339 // kind=8: 1 sign bit, 11 exponent bits, 52 significand bits
5340 exponentBias = (1 << (11 - 1)) - 1; // 1023
5341 significandSize = 52;
5342 nonSignificandSize = 12;
5343 break;
5344 case 80:
5345 // kind=10: 1 sign bit, 15 exponent bits, 1+63 significand bits
5346 exponentBias = (1 << (15 - 1)) - 1; // 16383
5347 significandSize = 64;
5348 nonSignificandSize = 16 + 1;
5349 break;
5350 case 128:
5351 // kind=16: 1 sign bit, 15 exponent bits, 112 significand bits
5352 exponentBias = (1 << (15 - 1)) - 1; // 16383
5353 significandSize = 112;
5354 nonSignificandSize = 16;
5355 break;
5356 default:
5357 llvm_unreachable("unknown real type");
5358 }
5359
5360 mlir::Value isZero = builder.create<mlir::arith::CmpFOp>(
5361 loc, mlir::arith::CmpFPredicate::OEQ, realVal,
5362 builder.createRealZeroConstant(loc, resultType));
5363 auto outerIfOp = builder.create<fir::IfOp>(loc, resultType, isZero,
5364 /*withElseRegion=*/true);
5365 // X is zero -- result is -infinity
5366 builder.setInsertionPointToStart(&outerIfOp.getThenRegion().front());
5367 genRaiseExcept(_FORTRAN_RUNTIME_IEEE_DIVIDE_BY_ZERO);
5368 mlir::Value ones = builder.createAllOnesInteger(loc, intType);
5369 mlir::Value result = builder.create<mlir::arith::ShLIOp>(
5370 loc, ones,
5371 builder.createIntegerConstant(loc, intType,
5372 // kind=10 high-order bit is explicit
5373 significandSize - (bitWidth == 80)));
5374 result = builder.create<mlir::arith::BitcastOp>(loc, resultType, result);
5375 builder.create<fir::ResultOp>(loc, result);
5376
5377 builder.setInsertionPointToStart(&outerIfOp.getElseRegion().front());
5378 mlir::Value one = builder.createIntegerConstant(loc, intType, 1);
5379 mlir::Value shiftLeftOne =
5380 builder.create<mlir::arith::ShLIOp>(loc, intVal, one);
5381 mlir::Value isFinite = genIsFPClass(i1Ty, args, finiteTest);
5382 auto innerIfOp = builder.create<fir::IfOp>(loc, resultType, isFinite,
5383 /*withElseRegion=*/true);
5384 // X is non-zero finite -- result is unbiased exponent of X
5385 builder.setInsertionPointToStart(&innerIfOp.getThenRegion().front());
5386 mlir::Value isNormal = genIsFPClass(i1Ty, args, normalTest);
5387 auto normalIfOp = builder.create<fir::IfOp>(loc, resultType, isNormal,
5388 /*withElseRegion=*/true);
5389 // X is normal
5390 builder.setInsertionPointToStart(&normalIfOp.getThenRegion().front());
5391 mlir::Value biasedExponent = builder.create<mlir::arith::ShRUIOp>(
5392 loc, shiftLeftOne,
5393 builder.createIntegerConstant(loc, intType, significandSize + 1));
5394 result = builder.create<mlir::arith::SubIOp>(
5395 loc, biasedExponent,
5396 builder.createIntegerConstant(loc, intType, exponentBias));
5397 result = builder.create<fir::ConvertOp>(loc, resultType, result);
5398 builder.create<fir::ResultOp>(loc, result);
5399
5400 // X is denormal -- result is (-exponentBias - ctlz(significand))
5401 builder.setInsertionPointToStart(&normalIfOp.getElseRegion().front());
5402 mlir::Value significand = builder.create<mlir::arith::ShLIOp>(
5403 loc, intVal,
5404 builder.createIntegerConstant(loc, intType, nonSignificandSize));
5405 mlir::Value ctlz =
5406 builder.create<mlir::math::CountLeadingZerosOp>(loc, significand);
5407 mlir::Type i32Ty = builder.getI32Type();
5408 result = builder.create<mlir::arith::SubIOp>(
5409 loc, builder.createIntegerConstant(loc, i32Ty, -exponentBias),
5410 builder.create<fir::ConvertOp>(loc, i32Ty, ctlz));
5411 result = builder.create<fir::ConvertOp>(loc, resultType, result);
5412 builder.create<fir::ResultOp>(loc, result);
5413
5414 builder.setInsertionPointToEnd(&innerIfOp.getThenRegion().front());
5415 builder.create<fir::ResultOp>(loc, normalIfOp.getResult(0));
5416
5417 // X is infinity or NaN -- result is +infinity or NaN
5418 builder.setInsertionPointToStart(&innerIfOp.getElseRegion().front());
5419 result = builder.create<mlir::arith::ShRUIOp>(loc, shiftLeftOne, one);
5420 result = builder.create<mlir::arith::BitcastOp>(loc, resultType, result);
5421 builder.create<fir::ResultOp>(loc, result);
5422
5423 // Unwind the if nest.
5424 builder.setInsertionPointToEnd(&outerIfOp.getElseRegion().front());
5425 builder.create<fir::ResultOp>(loc, innerIfOp.getResult(0));
5426 builder.setInsertionPointAfter(outerIfOp);
5427 return outerIfOp.getResult(0);
5428}
5429
5430// IEEE_MAX, IEEE_MAX_MAG, IEEE_MAX_NUM, IEEE_MAX_NUM_MAG
5431// IEEE_MIN, IEEE_MIN_MAG, IEEE_MIN_NUM, IEEE_MIN_NUM_MAG
5432template <bool isMax, bool isNum, bool isMag>
5433mlir::Value IntrinsicLibrary::genIeeeMaxMin(mlir::Type resultType,
5434 llvm::ArrayRef<mlir::Value> args) {
5435 // Maximum/minimum of X and Y with special case treatment of NaN operands.
5436 // The f18 definitions of these procedures (where applicable) are incomplete.
5437 // And f18 results involving NaNs are different from and incompatible with
5438 // f23 results. This code implements the f23 procedures.
5439 // For IEEE_MAX_MAG and IEEE_MAX_NUM_MAG:
5440 // if (ABS(X) > ABS(Y))
5441 // return X
5442 // else if (ABS(Y) > ABS(X))
5443 // return Y
5444 // else if (ABS(X) == ABS(Y))
5445 // return IEEE_SIGNBIT(Y) ? X : Y
5446 // // X or Y or both are NaNs
5447 // if (X is an sNaN or Y is an sNaN) raise FE_INVALID
5448 // if (IEEE_MAX_NUM_MAG and X is not a NaN) return X
5449 // if (IEEE_MAX_NUM_MAG and Y is not a NaN) return Y
5450 // return a qNaN
5451 // For IEEE_MAX, IEEE_MAX_NUM: compare X vs. Y rather than ABS(X) vs. ABS(Y)
5452 // IEEE_MIN, IEEE_MIN_MAG, IEEE_MIN_NUM, IEEE_MIN_NUM_MAG: invert comparisons
5453 assert(args.size() == 2);
5454 mlir::Value x = args[0];
5455 mlir::Value y = args[1];
5456 mlir::Value x1, y1; // X or ABS(X), Y or ABS(Y)
5457 if constexpr (isMag) {
5458 mlir::Value zero = builder.createRealZeroConstant(loc, resultType);
5459 x1 = builder.create<mlir::math::CopySignOp>(loc, x, zero);
5460 y1 = builder.create<mlir::math::CopySignOp>(loc, y, zero);
5461 } else {
5462 x1 = x;
5463 y1 = y;
5464 }
5465 mlir::Type i1Ty = builder.getI1Type();
5466 mlir::arith::CmpFPredicate pred;
5467 mlir::Value cmp, result, resultIsX, resultIsY;
5468
5469 // X1 < Y1 -- MAX result is Y; MIN result is X.
5470 pred = mlir::arith::CmpFPredicate::OLT;
5471 cmp = builder.create<mlir::arith::CmpFOp>(loc, pred, x1, y1);
5472 auto ifOp1 = builder.create<fir::IfOp>(loc, resultType, cmp, true);
5473 builder.setInsertionPointToStart(&ifOp1.getThenRegion().front());
5474 result = isMax ? y : x;
5475 builder.create<fir::ResultOp>(loc, result);
5476
5477 // X1 > Y1 -- MAX result is X; MIN result is Y.
5478 builder.setInsertionPointToStart(&ifOp1.getElseRegion().front());
5479 pred = mlir::arith::CmpFPredicate::OGT;
5480 cmp = builder.create<mlir::arith::CmpFOp>(loc, pred, x1, y1);
5481 auto ifOp2 = builder.create<fir::IfOp>(loc, resultType, cmp, true);
5482 builder.setInsertionPointToStart(&ifOp2.getThenRegion().front());
5483 result = isMax ? x : y;
5484 builder.create<fir::ResultOp>(loc, result);
5485
5486 // X1 == Y1 -- MAX favors a positive result; MIN favors a negative result.
5487 builder.setInsertionPointToStart(&ifOp2.getElseRegion().front());
5488 pred = mlir::arith::CmpFPredicate::OEQ;
5489 cmp = builder.create<mlir::arith::CmpFOp>(loc, pred, x1, y1);
5490 auto ifOp3 = builder.create<fir::IfOp>(loc, resultType, cmp, true);
5491 builder.setInsertionPointToStart(&ifOp3.getThenRegion().front());
5492 resultIsX = isMax ? genIsFPClass(i1Ty, x, positiveTest)
5493 : genIsFPClass(i1Ty, x, negativeTest);
5494 result = builder.create<mlir::arith::SelectOp>(loc, resultIsX, x, y);
5495 builder.create<fir::ResultOp>(loc, result);
5496
5497 // X or Y or both are NaNs -- result may be X, Y, or a qNaN
5498 builder.setInsertionPointToStart(&ifOp3.getElseRegion().front());
5499 if constexpr (isNum) {
5500 pred = mlir::arith::CmpFPredicate::ORD; // check for a non-NaN
5501 resultIsX = builder.create<mlir::arith::CmpFOp>(loc, pred, x, x);
5502 resultIsY = builder.create<mlir::arith::CmpFOp>(loc, pred, y, y);
5503 } else {
5504 resultIsX = resultIsY = builder.createBool(loc, false);
5505 }
5506 result = builder.create<mlir::arith::SelectOp>(
5507 loc, resultIsX, x,
5508 builder.create<mlir::arith::SelectOp>(loc, resultIsY, y,
5509 genQNan(resultType)));
5510 mlir::Value hasSNaNOp = builder.create<mlir::arith::OrIOp>(
5511 loc, genIsFPClass(builder.getI1Type(), args[0], snanTest),
5512 genIsFPClass(builder.getI1Type(), args[1], snanTest));
5513 genRaiseExcept(_FORTRAN_RUNTIME_IEEE_INVALID, hasSNaNOp);
5514 builder.create<fir::ResultOp>(loc, result);
5515
5516 // Unwind the if nest.
5517 builder.setInsertionPointAfter(ifOp3);
5518 builder.create<fir::ResultOp>(loc, ifOp3.getResult(0));
5519 builder.setInsertionPointAfter(ifOp2);
5520 builder.create<fir::ResultOp>(loc, ifOp2.getResult(0));
5521 builder.setInsertionPointAfter(ifOp1);
5522 return ifOp1.getResult(0);
5523}
5524
5525// IEEE_QUIET_EQ, IEEE_QUIET_GE, IEEE_QUIET_GT,
5526// IEEE_QUIET_LE, IEEE_QUIET_LT, IEEE_QUIET_NE
5527template <mlir::arith::CmpFPredicate pred>
5528mlir::Value
5529IntrinsicLibrary::genIeeeQuietCompare(mlir::Type resultType,
5530 llvm::ArrayRef<mlir::Value> args) {
5531 // Compare X and Y with special case treatment of NaN operands.
5532 assert(args.size() == 2);
5533 mlir::Value hasSNaNOp = builder.create<mlir::arith::OrIOp>(
5534 loc, genIsFPClass(builder.getI1Type(), args[0], snanTest),
5535 genIsFPClass(builder.getI1Type(), args[1], snanTest));
5536 mlir::Value res =
5537 builder.create<mlir::arith::CmpFOp>(loc, pred, args[0], args[1]);
5538 genRaiseExcept(_FORTRAN_RUNTIME_IEEE_INVALID, hasSNaNOp);
5539 return builder.create<fir::ConvertOp>(loc, resultType, res);
5540}
5541
5542// IEEE_REAL
5543mlir::Value IntrinsicLibrary::genIeeeReal(mlir::Type resultType,
5544 llvm::ArrayRef<mlir::Value> args) {
5545 // Convert integer or real argument A to a real of a specified kind.
5546 // Round according to the current rounding mode.
5547 // Signal IEEE_INVALID if A is an sNaN, and return a qNaN.
5548 // Signal IEEE_UNDERFLOW for an inexact subnormal or zero result.
5549 // Signal IEEE_OVERFLOW if A is finite and the result is infinite.
5550 // Signal IEEE_INEXACT for an inexact result.
5551 //
5552 // if (type(a) == resultType) {
5553 // // Conversion to the same type is a nop except for sNaN processing.
5554 // result = a
5555 // } else {
5556 // result = r = real(a, kind(result))
5557 // // Conversion to a larger type is exact.
5558 // if (c_sizeof(a) >= c_sizeof(r)) {
5559 // b = (a is integer) ? int(r, kind(a)) : real(r, kind(a))
5560 // if (a == b || isNaN(a)) {
5561 // // a is {-0, +0, -inf, +inf, NaN} or exact; result is r
5562 // } else {
5563 // // odd(r) is true if the low bit of significand(r) is 1
5564 // // rounding mode ieee_other is an alias for mode ieee_nearest
5565 // if (a < b) {
5566 // if (mode == ieee_nearest && odd(r)) result = ieee_next_down(r)
5567 // if (mode == ieee_other && odd(r)) result = ieee_next_down(r)
5568 // if (mode == ieee_to_zero && a > 0) result = ieee_next_down(r)
5569 // if (mode == ieee_away && a < 0) result = ieee_next_down(r)
5570 // if (mode == ieee_down) result = ieee_next_down(r)
5571 // } else { // a > b
5572 // if (mode == ieee_nearest && odd(r)) result = ieee_next_up(r)
5573 // if (mode == ieee_other && odd(r)) result = ieee_next_up(r)
5574 // if (mode == ieee_to_zero && a < 0) result = ieee_next_up(r)
5575 // if (mode == ieee_away && a > 0) result = ieee_next_up(r)
5576 // if (mode == ieee_up) result = ieee_next_up(r)
5577 // }
5578 // }
5579 // }
5580 // }
5581
5582 assert(args.size() == 2);
5583 mlir::Type i1Ty = builder.getI1Type();
5584 mlir::Type f32Ty = mlir::Float32Type::get(builder.getContext());
5585 mlir::Value a = args[0];
5586 mlir::Type aType = a.getType();
5587
5588 // If the argument is an sNaN, raise an invalid exception and return a qNaN.
5589 // Otherwise return the argument.
5590 auto processSnan = [&](mlir::Value x) {
5591 fir::IfOp ifOp = builder.create<fir::IfOp>(loc, resultType,
5592 genIsFPClass(i1Ty, x, snanTest),
5593 /*withElseRegion=*/true);
5594 builder.setInsertionPointToStart(&ifOp.getThenRegion().front());
5595 genRaiseExcept(_FORTRAN_RUNTIME_IEEE_INVALID);
5596 builder.create<fir::ResultOp>(loc, genQNan(resultType));
5597 builder.setInsertionPointToStart(&ifOp.getElseRegion().front());
5598 builder.create<fir::ResultOp>(loc, x);
5599 builder.setInsertionPointAfter(ifOp);
5600 return ifOp.getResult(0);
5601 };
5602
5603 // Conversion is a nop, except that A may be an sNaN.
5604 if (resultType == aType)
5605 return processSnan(a);
5606
5607 // Can't directly convert between kind=2 and kind=3.
5608 mlir::Value r, r1;
5609 if ((aType.isBF16() && resultType.isF16()) ||
5610 (aType.isF16() && resultType.isBF16())) {
5611 a = builder.createConvert(loc, f32Ty, a);
5612 aType = f32Ty;
5613 }
5614 r = builder.create<fir::ConvertOp>(loc, resultType, a);
5615
5616 mlir::IntegerType aIntType = mlir::dyn_cast<mlir::IntegerType>(aType);
5617 mlir::FloatType aFloatType = mlir::dyn_cast<mlir::FloatType>(aType);
5618 mlir::FloatType resultFloatType = mlir::dyn_cast<mlir::FloatType>(resultType);
5619
5620 // Conversion from a smaller type to a larger type is exact.
5621 if ((aIntType ? aIntType.getWidth() : aFloatType.getWidth()) <
5622 resultFloatType.getWidth())
5623 return aIntType ? r : processSnan(r);
5624
5625 // A possibly inexact conversion result may need to be rounded up or down.
5626 mlir::Value b = builder.create<fir::ConvertOp>(loc, aType, r);
5627 mlir::Value aEqB;
5628 if (aIntType)
5629 aEqB = builder.create<mlir::arith::CmpIOp>(
5630 loc, mlir::arith::CmpIPredicate::eq, a, b);
5631 else
5632 aEqB = builder.create<mlir::arith::CmpFOp>(
5633 loc, mlir::arith::CmpFPredicate::UEQ, a, b);
5634
5635 // [a == b] a is a NaN or r is exact (a may be -0, +0, -inf, +inf) -- return r
5636 fir::IfOp ifOp1 = builder.create<fir::IfOp>(loc, resultType, aEqB,
5637 /*withElseRegion=*/true);
5638 builder.setInsertionPointToStart(&ifOp1.getThenRegion().front());
5639 builder.create<fir::ResultOp>(loc, aIntType ? r : processSnan(r));
5640
5641 // Code common to (a < b) and (a > b) branches.
5642 builder.setInsertionPointToStart(&ifOp1.getElseRegion().front());
5643 mlir::func::FuncOp getRound = fir::factory::getLlvmGetRounding(builder);
5644 mlir::Value mode = builder.create<fir::CallOp>(loc, getRound).getResult(0);
5645 mlir::Value aIsNegative, aIsPositive;
5646 if (aIntType) {
5647 mlir::Value zero = builder.createIntegerConstant(loc, aIntType, 0);
5648 aIsNegative = builder.create<mlir::arith::CmpIOp>(
5649 loc, mlir::arith::CmpIPredicate::slt, a, zero);
5650 aIsPositive = builder.create<mlir::arith::CmpIOp>(
5651 loc, mlir::arith::CmpIPredicate::sgt, a, zero);
5652 } else {
5653 mlir::Value zero = builder.createRealZeroConstant(loc, aFloatType);
5654 aIsNegative = builder.create<mlir::arith::CmpFOp>(
5655 loc, mlir::arith::CmpFPredicate::OLT, a, zero);
5656 aIsPositive = builder.create<mlir::arith::CmpFOp>(
5657 loc, mlir::arith::CmpFPredicate::OGT, a, zero);
5658 }
5659 mlir::Type resultIntType = builder.getIntegerType(resultFloatType.getWidth());
5660 mlir::Value resultCast =
5661 builder.create<mlir::arith::BitcastOp>(loc, resultIntType, r);
5662 mlir::Value one = builder.createIntegerConstant(loc, resultIntType, 1);
5663 mlir::Value rIsOdd = builder.create<fir::ConvertOp>(
5664 loc, i1Ty, builder.create<mlir::arith::AndIOp>(loc, resultCast, one));
5665 // Check for a rounding mode match.
5666 auto match = [&](int m) {
5667 return builder.create<mlir::arith::CmpIOp>(
5668 loc, mlir::arith::CmpIPredicate::eq, mode,
5669 builder.createIntegerConstant(loc, mode.getType(), m));
5670 };
5671 mlir::Value roundToNearestBit = builder.create<mlir::arith::OrIOp>(
5672 loc,
5673 // IEEE_OTHER is an alias for IEEE_NEAREST.
5674 match(_FORTRAN_RUNTIME_IEEE_NEAREST), match(_FORTRAN_RUNTIME_IEEE_OTHER));
5675 mlir::Value roundToNearest =
5676 builder.create<mlir::arith::AndIOp>(loc, roundToNearestBit, rIsOdd);
5677 mlir::Value roundToZeroBit = match(_FORTRAN_RUNTIME_IEEE_TO_ZERO);
5678 mlir::Value roundAwayBit = match(_FORTRAN_RUNTIME_IEEE_AWAY);
5679 mlir::Value roundToZero, roundAway, mustAdjust;
5680 fir::IfOp adjustIfOp;
5681 mlir::Value aLtB;
5682 if (aIntType)
5683 aLtB = builder.create<mlir::arith::CmpIOp>(
5684 loc, mlir::arith::CmpIPredicate::slt, a, b);
5685 else
5686 aLtB = builder.create<mlir::arith::CmpFOp>(
5687 loc, mlir::arith::CmpFPredicate::OLT, a, b);
5688 mlir::Value upResult =
5689 builder.create<mlir::arith::AddIOp>(loc, resultCast, one);
5690 mlir::Value downResult =
5691 builder.create<mlir::arith::SubIOp>(loc, resultCast, one);
5692
5693 // (a < b): r is inexact -- return r or ieee_next_down(r)
5694 fir::IfOp ifOp2 = builder.create<fir::IfOp>(loc, resultType, aLtB,
5695 /*withElseRegion=*/true);
5696 builder.setInsertionPointToStart(&ifOp2.getThenRegion().front());
5697 roundToZero =
5698 builder.create<mlir::arith::AndIOp>(loc, roundToZeroBit, aIsPositive);
5699 roundAway =
5700 builder.create<mlir::arith::AndIOp>(loc, roundAwayBit, aIsNegative);
5701 mlir::Value roundDown = match(_FORTRAN_RUNTIME_IEEE_DOWN);
5702 mustAdjust =
5703 builder.create<mlir::arith::OrIOp>(loc, roundToNearest, roundToZero);
5704 mustAdjust = builder.create<mlir::arith::OrIOp>(loc, mustAdjust, roundAway);
5705 mustAdjust = builder.create<mlir::arith::OrIOp>(loc, mustAdjust, roundDown);
5706 adjustIfOp = builder.create<fir::IfOp>(loc, resultType, mustAdjust,
5707 /*withElseRegion=*/true);
5708 builder.setInsertionPointToStart(&adjustIfOp.getThenRegion().front());
5709 if (resultType.isF80())
5710 r1 = fir::runtime::genNearest(builder, loc, r,
5711 builder.createBool(loc, false));
5712 else
5713 r1 = builder.create<mlir::arith::BitcastOp>(
5714 loc, resultType,
5715 builder.create<mlir::arith::SelectOp>(loc, aIsNegative, upResult,
5716 downResult));
5717 builder.create<fir::ResultOp>(loc, r1);
5718 builder.setInsertionPointToStart(&adjustIfOp.getElseRegion().front());
5719 builder.create<fir::ResultOp>(loc, r);
5720 builder.setInsertionPointAfter(adjustIfOp);
5721 builder.create<fir::ResultOp>(loc, adjustIfOp.getResult(0));
5722
5723 // (a > b): r is inexact -- return r or ieee_next_up(r)
5724 builder.setInsertionPointToStart(&ifOp2.getElseRegion().front());
5725 roundToZero =
5726 builder.create<mlir::arith::AndIOp>(loc, roundToZeroBit, aIsNegative);
5727 roundAway =
5728 builder.create<mlir::arith::AndIOp>(loc, roundAwayBit, aIsPositive);
5729 mlir::Value roundUp = match(_FORTRAN_RUNTIME_IEEE_UP);
5730 mustAdjust =
5731 builder.create<mlir::arith::OrIOp>(loc, roundToNearest, roundToZero);
5732 mustAdjust = builder.create<mlir::arith::OrIOp>(loc, mustAdjust, roundAway);
5733 mustAdjust = builder.create<mlir::arith::OrIOp>(loc, mustAdjust, roundUp);
5734 adjustIfOp = builder.create<fir::IfOp>(loc, resultType, mustAdjust,
5735 /*withElseRegion=*/true);
5736 builder.setInsertionPointToStart(&adjustIfOp.getThenRegion().front());
5737 if (resultType.isF80())
5738 r1 = fir::runtime::genNearest(builder, loc, r,
5739 builder.createBool(loc, true));
5740 else
5741 r1 = builder.create<mlir::arith::BitcastOp>(
5742 loc, resultType,
5743 builder.create<mlir::arith::SelectOp>(loc, aIsPositive, upResult,
5744 downResult));
5745 builder.create<fir::ResultOp>(loc, r1);
5746 builder.setInsertionPointToStart(&adjustIfOp.getElseRegion().front());
5747 builder.create<fir::ResultOp>(loc, r);
5748 builder.setInsertionPointAfter(adjustIfOp);
5749 builder.create<fir::ResultOp>(loc, adjustIfOp.getResult(0));
5750
5751 // Generate exceptions for (a < b) and (a > b) branches.
5752 builder.setInsertionPointAfter(ifOp2);
5753 r = ifOp2.getResult(0);
5754 fir::IfOp exceptIfOp1 = builder.create<fir::IfOp>(
5755 loc, genIsFPClass(i1Ty, r, infiniteTest), /*withElseRegion=*/true);
5756 builder.setInsertionPointToStart(&exceptIfOp1.getThenRegion().front());
5757 genRaiseExcept(_FORTRAN_RUNTIME_IEEE_OVERFLOW |
5758 _FORTRAN_RUNTIME_IEEE_INEXACT);
5759 builder.setInsertionPointToStart(&exceptIfOp1.getElseRegion().front());
5760 fir::IfOp exceptIfOp2 = builder.create<fir::IfOp>(
5761 loc, genIsFPClass(i1Ty, r, subnormalTest | zeroTest),
5762 /*withElseRegion=*/true);
5763 builder.setInsertionPointToStart(&exceptIfOp2.getThenRegion().front());
5764 genRaiseExcept(_FORTRAN_RUNTIME_IEEE_UNDERFLOW |
5765 _FORTRAN_RUNTIME_IEEE_INEXACT);
5766 builder.setInsertionPointToStart(&exceptIfOp2.getElseRegion().front());
5767 genRaiseExcept(_FORTRAN_RUNTIME_IEEE_INEXACT);
5768 builder.setInsertionPointAfter(exceptIfOp1);
5769 builder.create<fir::ResultOp>(loc, ifOp2.getResult(0));
5770 builder.setInsertionPointAfter(ifOp1);
5771 return ifOp1.getResult(0);
5772}
5773
5774// IEEE_REM
5775mlir::Value IntrinsicLibrary::genIeeeRem(mlir::Type resultType,
5776 llvm::ArrayRef<mlir::Value> args) {
5777 // Return the remainder of X divided by Y.
5778 // Signal IEEE_UNDERFLOW if X is subnormal and Y is infinite.
5779 // Signal IEEE_INVALID if X is infinite or Y is zero and neither is a NaN.
5780 assert(args.size() == 2);
5781 mlir::Value x = args[0];
5782 mlir::Value y = args[1];
5783 if (mlir::dyn_cast<mlir::FloatType>(resultType).getWidth() < 32) {
5784 mlir::Type f32Ty = mlir::Float32Type::get(builder.getContext());
5785 x = builder.create<fir::ConvertOp>(loc, f32Ty, x);
5786 y = builder.create<fir::ConvertOp>(loc, f32Ty, y);
5787 } else {
5788 x = builder.create<fir::ConvertOp>(loc, resultType, x);
5789 y = builder.create<fir::ConvertOp>(loc, resultType, y);
5790 }
5791 // remainder calls do not signal IEEE_UNDERFLOW.
5792 mlir::Value underflow = builder.create<mlir::arith::AndIOp>(
5793 loc, genIsFPClass(builder.getI1Type(), x, subnormalTest),
5794 genIsFPClass(builder.getI1Type(), y, infiniteTest));
5795 mlir::Value result = genRuntimeCall("remainder", x.getType(), {x, y});
5796 genRaiseExcept(_FORTRAN_RUNTIME_IEEE_UNDERFLOW, underflow);
5797 return builder.create<fir::ConvertOp>(loc, resultType, result);
5798}
5799
5800// IEEE_RINT
5801mlir::Value IntrinsicLibrary::genIeeeRint(mlir::Type resultType,
5802 llvm::ArrayRef<mlir::Value> args) {
5803 // Return the value of real argument A rounded to an integer value according
5804 // to argument ROUND if present, otherwise according to the current rounding
5805 // mode. If ROUND is not present, signal IEEE_INEXACT if A is not an exact
5806 // integral value.
5807 assert(args.size() == 2);
5808 mlir::Value a = args[0];
5809 mlir::func::FuncOp getRound = fir::factory::getLlvmGetRounding(builder);
5810 mlir::func::FuncOp setRound = fir::factory::getLlvmSetRounding(builder);
5811 mlir::Value mode;
5812 if (isStaticallyPresent(args[1])) {
5813 mode = builder.create<fir::CallOp>(loc, getRound).getResult(0);
5814 genIeeeSetRoundingMode({args[1]});
5815 }
5816 if (mlir::cast<mlir::FloatType>(resultType).getWidth() == 16)
5817 a = builder.create<fir::ConvertOp>(
5818 loc, mlir::Float32Type::get(builder.getContext()), a);
5819 mlir::Value result = builder.create<fir::ConvertOp>(
5820 loc, resultType, genRuntimeCall("nearbyint", a.getType(), a));
5821 if (isStaticallyPresent(args[1])) {
5822 builder.create<fir::CallOp>(loc, setRound, mode);
5823 } else {
5824 mlir::Value inexact = builder.create<mlir::arith::CmpFOp>(
5825 loc, mlir::arith::CmpFPredicate::ONE, args[0], result);
5826 genRaiseExcept(_FORTRAN_RUNTIME_IEEE_INEXACT, inexact);
5827 }
5828 return result;
5829}
5830
5831// IEEE_SET_FLAG, IEEE_SET_HALTING_MODE
5832template <bool isFlag>
5833void IntrinsicLibrary::genIeeeSetFlagOrHaltingMode(
5834 llvm::ArrayRef<fir::ExtendedValue> args) {
5835 // IEEE_SET_FLAG: Set an exception FLAG to a FLAG_VALUE.
5836 // IEEE_SET_HALTING: Set an exception halting mode FLAG to a HALTING value.
5837 assert(args.size() == 2);
5838 mlir::Type i1Ty = builder.getI1Type();
5839 mlir::Type i32Ty = builder.getIntegerType(32);
5840 auto [fieldRef, ignore] = getFieldRef(builder, loc, getBase(args[0]));
5841 mlir::Value field = builder.create<fir::LoadOp>(loc, fieldRef);
5842 mlir::Value except = fir::runtime::genMapExcept(
5843 builder, loc, builder.create<fir::ConvertOp>(loc, i32Ty, field));
5844 auto ifOp = builder.create<fir::IfOp>(
5845 loc, builder.create<fir::ConvertOp>(loc, i1Ty, getBase(args[1])),
5846 /*withElseRegion=*/true);
5847 builder.setInsertionPointToStart(&ifOp.getThenRegion().front());
5848 (isFlag ? fir::runtime::genFeraiseexcept : fir::runtime::genFeenableexcept)(
5849 builder, loc, builder.create<fir::ConvertOp>(loc, i32Ty, except));
5850 builder.setInsertionPointToStart(&ifOp.getElseRegion().front());
5851 (isFlag ? fir::runtime::genFeclearexcept : fir::runtime::genFedisableexcept)(
5852 builder, loc, builder.create<fir::ConvertOp>(loc, i32Ty, except));
5853 builder.setInsertionPointAfter(ifOp);
5854}
5855
5856// IEEE_SET_ROUNDING_MODE
5857void IntrinsicLibrary::genIeeeSetRoundingMode(
5858 llvm::ArrayRef<fir::ExtendedValue> args) {
5859 // Set the current floating point rounding mode to the value of arg
5860 // ROUNDING_VALUE. Values are llvm.get.rounding encoding values.
5861 // Modes ieee_to_zero, ieee_nearest, ieee_up, and ieee_down are supported.
5862 // Modes ieee_away and ieee_other are not supported, and are treated as
5863 // ieee_nearest. Generate an error if the optional RADIX arg is not 2.
5864 assert(args.size() == 1 || args.size() == 2);
5865 if (args.size() == 2)
5866 checkRadix(builder, loc, fir::getBase(args[1]), "ieee_set_rounding_mode");
5867 auto [fieldRef, fieldTy] = getFieldRef(builder, loc, fir::getBase(args[0]));
5868 mlir::func::FuncOp setRound = fir::factory::getLlvmSetRounding(builder);
5869 mlir::Value mode = builder.create<fir::LoadOp>(loc, fieldRef);
5870 static_assert(
5871 _FORTRAN_RUNTIME_IEEE_TO_ZERO >= 0 &&
5872 _FORTRAN_RUNTIME_IEEE_TO_ZERO <= 3 &&
5873 _FORTRAN_RUNTIME_IEEE_NEAREST >= 0 &&
5874 _FORTRAN_RUNTIME_IEEE_NEAREST <= 3 && _FORTRAN_RUNTIME_IEEE_UP >= 0 &&
5875 _FORTRAN_RUNTIME_IEEE_UP <= 3 && _FORTRAN_RUNTIME_IEEE_DOWN >= 0 &&
5876 _FORTRAN_RUNTIME_IEEE_DOWN <= 3 && "unexpected rounding mode mapping");
5877 mlir::Value mask = builder.create<mlir::arith::ShLIOp>(
5878 loc, builder.createAllOnesInteger(loc, fieldTy),
5879 builder.createIntegerConstant(loc, fieldTy, 2));
5880 mlir::Value modeIsSupported = builder.create<mlir::arith::CmpIOp>(
5881 loc, mlir::arith::CmpIPredicate::eq,
5882 builder.create<mlir::arith::AndIOp>(loc, mode, mask),
5883 builder.createIntegerConstant(loc, fieldTy, 0));
5884 mlir::Value nearest = builder.createIntegerConstant(
5885 loc, fieldTy, _FORTRAN_RUNTIME_IEEE_NEAREST);
5886 mode = builder.create<mlir::arith::SelectOp>(loc, modeIsSupported, mode,
5887 nearest);
5888 mode = builder.create<fir::ConvertOp>(
5889 loc, setRound.getFunctionType().getInput(0), mode);
5890 builder.create<fir::CallOp>(loc, setRound, mode);
5891}
5892
5893// IEEE_SET_UNDERFLOW_MODE
5894void IntrinsicLibrary::genIeeeSetUnderflowMode(
5895 llvm::ArrayRef<fir::ExtendedValue> args) {
5896 assert(args.size() == 1);
5897 mlir::Value gradual = builder.create<fir::ConvertOp>(loc, builder.getI1Type(),
5898 getBase(args[0]));
5899 fir::runtime::genSetUnderflowMode(builder, loc, {gradual});
5900}
5901
5902// IEEE_SIGNALING_EQ, IEEE_SIGNALING_GE, IEEE_SIGNALING_GT,
5903// IEEE_SIGNALING_LE, IEEE_SIGNALING_LT, IEEE_SIGNALING_NE
5904template <mlir::arith::CmpFPredicate pred>
5905mlir::Value
5906IntrinsicLibrary::genIeeeSignalingCompare(mlir::Type resultType,
5907 llvm::ArrayRef<mlir::Value> args) {
5908 // Compare X and Y with special case treatment of NaN operands.
5909 assert(args.size() == 2);
5910 mlir::Value hasNaNOp = genIeeeUnordered(mlir::Type{}, args);
5911 mlir::Value res =
5912 builder.create<mlir::arith::CmpFOp>(loc, pred, args[0], args[1]);
5913 genRaiseExcept(_FORTRAN_RUNTIME_IEEE_INVALID, hasNaNOp);
5914 return builder.create<fir::ConvertOp>(loc, resultType, res);
5915}
5916
5917// IEEE_SIGNBIT
5918mlir::Value IntrinsicLibrary::genIeeeSignbit(mlir::Type resultType,
5919 llvm::ArrayRef<mlir::Value> args) {
5920 // Check if the sign bit of arg X is set.
5921 assert(args.size() == 1);
5922 mlir::Value realVal = args[0];
5923 mlir::FloatType realType = mlir::dyn_cast<mlir::FloatType>(realVal.getType());
5924 int bitWidth = realType.getWidth();
5925 if (realType == mlir::BFloat16Type::get(builder.getContext())) {
5926 // Workaround: can't bitcast or convert real(3) to integer(2) or real(2).
5927 realVal = builder.createConvert(
5928 loc, mlir::Float32Type::get(builder.getContext()), realVal);
5929 bitWidth = 32;
5930 }
5931 mlir::Type intType = builder.getIntegerType(bitWidth);
5932 mlir::Value intVal =
5933 builder.create<mlir::arith::BitcastOp>(loc, intType, realVal);
5934 mlir::Value shift = builder.createIntegerConstant(loc, intType, bitWidth - 1);
5935 mlir::Value sign = builder.create<mlir::arith::ShRUIOp>(loc, intVal, shift);
5936 return builder.createConvert(loc, resultType, sign);
5937}
5938
5939// IEEE_SUPPORT_FLAG
5940fir::ExtendedValue
5941IntrinsicLibrary::genIeeeSupportFlag(mlir::Type resultType,
5942 llvm::ArrayRef<fir::ExtendedValue> args) {
5943 // Check if a floating point exception flag is supported.
5944 assert(args.size() == 1 || args.size() == 2);
5945 mlir::Type i1Ty = builder.getI1Type();
5946 mlir::Type i32Ty = builder.getIntegerType(32);
5947 auto [fieldRef, fieldTy] = getFieldRef(builder, loc, getBase(args[0]));
5948 mlir::Value flag = builder.create<fir::LoadOp>(loc, fieldRef);
5949 mlir::Value standardFlagMask = builder.createIntegerConstant(
5950 loc, fieldTy,
5951 _FORTRAN_RUNTIME_IEEE_INVALID | _FORTRAN_RUNTIME_IEEE_DIVIDE_BY_ZERO |
5952 _FORTRAN_RUNTIME_IEEE_OVERFLOW | _FORTRAN_RUNTIME_IEEE_UNDERFLOW |
5953 _FORTRAN_RUNTIME_IEEE_INEXACT);
5954 mlir::Value isStandardFlag = builder.create<mlir::arith::CmpIOp>(
5955 loc, mlir::arith::CmpIPredicate::ne,
5956 builder.create<mlir::arith::AndIOp>(loc, flag, standardFlagMask),
5957 builder.createIntegerConstant(loc, fieldTy, 0));
5958 fir::IfOp ifOp = builder.create<fir::IfOp>(loc, i1Ty, isStandardFlag,
5959 /*withElseRegion=*/true);
5960 // Standard flags are supported.
5961 builder.setInsertionPointToStart(&ifOp.getThenRegion().front());
5962 builder.create<fir::ResultOp>(loc, builder.createBool(loc, true));
5963
5964 // TargetCharacteristics information for the nonstandard ieee_denorm flag
5965 // is not available here. So use a runtime check restricted to possibly
5966 // supported kinds.
5967 builder.setInsertionPointToStart(&ifOp.getElseRegion().front());
5968 bool mayBeSupported = false;
5969 if (mlir::Value arg1 = getBase(args[1])) {
5970 mlir::Type arg1Ty = arg1.getType();
5971 if (auto eleTy = fir::dyn_cast_ptrOrBoxEleTy(arg1.getType()))
5972 arg1Ty = eleTy;
5973 if (auto seqTy = mlir::dyn_cast<fir::SequenceType>(arg1Ty))
5974 arg1Ty = seqTy.getEleTy();
5975 switch (mlir::dyn_cast<mlir::FloatType>(arg1Ty).getWidth()) {
5976 case 16:
5977 mayBeSupported = arg1Ty.isBF16(); // kind=3
5978 break;
5979 case 32: // kind=4
5980 case 64: // kind=8
5981 mayBeSupported = true;
5982 break;
5983 }
5984 }
5985 if (mayBeSupported) {
5986 mlir::Value isDenorm = builder.create<mlir::arith::CmpIOp>(
5987 loc, mlir::arith::CmpIPredicate::eq, flag,
5988 builder.createIntegerConstant(loc, fieldTy,
5989 _FORTRAN_RUNTIME_IEEE_DENORM));
5990 mlir::Value result = builder.create<mlir::arith::AndIOp>(
5991 loc, isDenorm,
5992 fir::runtime::genSupportHalting(
5993 builder, loc, builder.create<fir::ConvertOp>(loc, i32Ty, flag)));
5994 builder.create<fir::ResultOp>(loc, result);
5995 } else {
5996 builder.create<fir::ResultOp>(loc, builder.createBool(loc, false));
5997 }
5998 builder.setInsertionPointAfter(ifOp);
5999 return builder.createConvert(loc, resultType, ifOp.getResult(0));
6000}
6001
6002// IEEE_SUPPORT_HALTING
6003fir::ExtendedValue IntrinsicLibrary::genIeeeSupportHalting(
6004 mlir::Type resultType, llvm::ArrayRef<fir::ExtendedValue> args) {
6005 // Check if halting is supported for a floating point exception flag.
6006 // Standard flags are all supported. The nonstandard DENORM extension is
6007 // not supported, at least for now.
6008 assert(args.size() == 1);
6009 mlir::Type i32Ty = builder.getIntegerType(32);
6010 auto [fieldRef, ignore] = getFieldRef(builder, loc, getBase(args[0]));
6011 mlir::Value field = builder.create<fir::LoadOp>(loc, fieldRef);
6012 return builder.createConvert(
6013 loc, resultType,
6014 fir::runtime::genSupportHalting(
6015 builder, loc, builder.create<fir::ConvertOp>(loc, i32Ty, field)));
6016}
6017
6018// IEEE_SUPPORT_ROUNDING
6019fir::ExtendedValue IntrinsicLibrary::genIeeeSupportRounding(
6020 mlir::Type resultType, llvm::ArrayRef<fir::ExtendedValue> args) {
6021 // Check if floating point rounding mode ROUND_VALUE is supported.
6022 // Rounding is supported either for all type kinds or none.
6023 // An optional X kind argument is therefore ignored.
6024 // Values are chosen to match the llvm.get.rounding encoding:
6025 // 0 - toward zero [supported]
6026 // 1 - to nearest, ties to even [supported] - default
6027 // 2 - toward positive infinity [supported]
6028 // 3 - toward negative infinity [supported]
6029 // 4 - to nearest, ties away from zero [not supported]
6030 assert(args.size() == 1 || args.size() == 2);
6031 auto [fieldRef, fieldTy] = getFieldRef(builder, loc, getBase(args[0]));
6032 mlir::Value mode = builder.create<fir::LoadOp>(loc, fieldRef);
6033 mlir::Value lbOk = builder.create<mlir::arith::CmpIOp>(
6034 loc, mlir::arith::CmpIPredicate::sge, mode,
6035 builder.createIntegerConstant(loc, fieldTy,
6036 _FORTRAN_RUNTIME_IEEE_TO_ZERO));
6037 mlir::Value ubOk = builder.create<mlir::arith::CmpIOp>(
6038 loc, mlir::arith::CmpIPredicate::sle, mode,
6039 builder.createIntegerConstant(loc, fieldTy, _FORTRAN_RUNTIME_IEEE_DOWN));
6040 return builder.createConvert(
6041 loc, resultType, builder.create<mlir::arith::AndIOp>(loc, lbOk, ubOk));
6042}
6043
6044// IEEE_SUPPORT_STANDARD
6045fir::ExtendedValue IntrinsicLibrary::genIeeeSupportStandard(
6046 mlir::Type resultType, llvm::ArrayRef<fir::ExtendedValue> args) {
6047 // Check if IEEE standard support is available, which reduces to checking
6048 // if halting control is supported, as that is the only support component
6049 // that may not be available.
6050 assert(args.size() <= 1);
6051 mlir::Value overflow = builder.createIntegerConstant(
6052 loc, builder.getIntegerType(32), _FORTRAN_RUNTIME_IEEE_OVERFLOW);
6053 return builder.createConvert(
6054 loc, resultType, fir::runtime::genSupportHalting(builder, loc, overflow));
6055}
6056
6057// IEEE_UNORDERED
6058mlir::Value
6059IntrinsicLibrary::genIeeeUnordered(mlir::Type resultType,
6060 llvm::ArrayRef<mlir::Value> args) {
6061 // Check if REAL args X or Y or both are (signaling or quiet) NaNs.
6062 // If there is no result type return an i1 result.
6063 assert(args.size() == 2);
6064 if (args[0].getType() == args[1].getType()) {
6065 mlir::Value res = builder.create<mlir::arith::CmpFOp>(
6066 loc, mlir::arith::CmpFPredicate::UNO, args[0], args[1]);
6067 return resultType ? builder.createConvert(loc, resultType, res) : res;
6068 }
6069 assert(resultType && "expecting a (mixed arg type) unordered result type");
6070 mlir::Type i1Ty = builder.getI1Type();
6071 mlir::Value xIsNan = genIsFPClass(i1Ty, args[0], nanTest);
6072 mlir::Value yIsNan = genIsFPClass(i1Ty, args[1], nanTest);
6073 mlir::Value res = builder.create<mlir::arith::OrIOp>(loc, xIsNan, yIsNan);
6074 return builder.createConvert(loc, resultType, res);
6075}
6076
6077// IEEE_VALUE
6078mlir::Value IntrinsicLibrary::genIeeeValue(mlir::Type resultType,
6079 llvm::ArrayRef<mlir::Value> args) {
6080 // Return a KIND(X) REAL number of IEEE_CLASS_TYPE CLASS.
6081 // A user call has two arguments:
6082 // - arg[0] is X (ignored, since the resultType is provided)
6083 // - arg[1] is CLASS, an IEEE_CLASS_TYPE CLASS argument containing an index
6084 // A compiler generated call has one argument:
6085 // - arg[0] is an index constant
6086 assert(args.size() == 1 || args.size() == 2);
6087 mlir::FloatType realType = mlir::dyn_cast<mlir::FloatType>(resultType);
6088 int bitWidth = realType.getWidth();
6089 mlir::Type intType = builder.getIntegerType(bitWidth);
6090 mlir::Type valueTy = bitWidth <= 64 ? intType : builder.getIntegerType(64);
6091 constexpr int tableSize = _FORTRAN_RUNTIME_IEEE_OTHER_VALUE + 1;
6092 mlir::Type tableTy = fir::SequenceType::get(tableSize, valueTy);
6093 std::string tableName = RTNAME_STRING(IeeeValueTable_) +
6094 std::to_string(realType.isBF16() ? 3 : bitWidth >> 3);
6095 if (!builder.getNamedGlobal(tableName)) {
6096 llvm::SmallVector<mlir::Attribute, tableSize> values;
6097 auto insert = [&](std::int64_t v) {
6098 values.push_back(builder.getIntegerAttr(valueTy, v));
6099 };
6100 insert(0); // placeholder
6101 switch (bitWidth) {
6102 case 16:
6103 if (realType.isF16()) {
6104 // kind=2: 1 sign bit, 5 exponent bits, 10 significand bits
6105 /* IEEE_SIGNALING_NAN */ insert(0x7d00);
6106 /* IEEE_QUIET_NAN */ insert(0x7e00);
6107 /* IEEE_NEGATIVE_INF */ insert(0xfc00);
6108 /* IEEE_NEGATIVE_NORMAL */ insert(0xbc00);
6109 /* IEEE_NEGATIVE_SUBNORMAL */ insert(0x8200);
6110 /* IEEE_NEGATIVE_ZERO */ insert(0x8000);
6111 /* IEEE_POSITIVE_ZERO */ insert(0x0000);
6112 /* IEEE_POSITIVE_SUBNORMAL */ insert(0x0200);
6113 /* IEEE_POSITIVE_NORMAL */ insert(0x3c00); // 1.0
6114 /* IEEE_POSITIVE_INF */ insert(0x7c00);
6115 break;
6116 }
6117 assert(realType.isBF16() && "unknown 16-bit real type");
6118 // kind=3: 1 sign bit, 8 exponent bits, 7 significand bits
6119 /* IEEE_SIGNALING_NAN */ insert(0x7fa0);
6120 /* IEEE_QUIET_NAN */ insert(0x7fc0);
6121 /* IEEE_NEGATIVE_INF */ insert(0xff80);
6122 /* IEEE_NEGATIVE_NORMAL */ insert(0xbf80);
6123 /* IEEE_NEGATIVE_SUBNORMAL */ insert(0x8040);
6124 /* IEEE_NEGATIVE_ZERO */ insert(0x8000);
6125 /* IEEE_POSITIVE_ZERO */ insert(0x0000);
6126 /* IEEE_POSITIVE_SUBNORMAL */ insert(0x0040);
6127 /* IEEE_POSITIVE_NORMAL */ insert(0x3f80); // 1.0
6128 /* IEEE_POSITIVE_INF */ insert(0x7f80);
6129 break;
6130 case 32:
6131 // kind=4: 1 sign bit, 8 exponent bits, 23 significand bits
6132 /* IEEE_SIGNALING_NAN */ insert(0x7fa00000);
6133 /* IEEE_QUIET_NAN */ insert(0x7fc00000);
6134 /* IEEE_NEGATIVE_INF */ insert(0xff800000);
6135 /* IEEE_NEGATIVE_NORMAL */ insert(0xbf800000);
6136 /* IEEE_NEGATIVE_SUBNORMAL */ insert(0x80400000);
6137 /* IEEE_NEGATIVE_ZERO */ insert(0x80000000);
6138 /* IEEE_POSITIVE_ZERO */ insert(0x00000000);
6139 /* IEEE_POSITIVE_SUBNORMAL */ insert(0x00400000);
6140 /* IEEE_POSITIVE_NORMAL */ insert(0x3f800000); // 1.0
6141 /* IEEE_POSITIVE_INF */ insert(0x7f800000);
6142 break;
6143 case 64:
6144 // kind=8: 1 sign bit, 11 exponent bits, 52 significand bits
6145 /* IEEE_SIGNALING_NAN */ insert(0x7ff4000000000000);
6146 /* IEEE_QUIET_NAN */ insert(0x7ff8000000000000);
6147 /* IEEE_NEGATIVE_INF */ insert(0xfff0000000000000);
6148 /* IEEE_NEGATIVE_NORMAL */ insert(0xbff0000000000000);
6149 /* IEEE_NEGATIVE_SUBNORMAL */ insert(0x8008000000000000);
6150 /* IEEE_NEGATIVE_ZERO */ insert(0x8000000000000000);
6151 /* IEEE_POSITIVE_ZERO */ insert(0x0000000000000000);
6152 /* IEEE_POSITIVE_SUBNORMAL */ insert(0x0008000000000000);
6153 /* IEEE_POSITIVE_NORMAL */ insert(0x3ff0000000000000); // 1.0
6154 /* IEEE_POSITIVE_INF */ insert(0x7ff0000000000000);
6155 break;
6156 case 80:
6157 // kind=10: 1 sign bit, 15 exponent bits, 1+63 significand bits
6158 // 64 high order bits; 16 low order bits are 0.
6159 /* IEEE_SIGNALING_NAN */ insert(0x7fffa00000000000);
6160 /* IEEE_QUIET_NAN */ insert(0x7fffc00000000000);
6161 /* IEEE_NEGATIVE_INF */ insert(0xffff800000000000);
6162 /* IEEE_NEGATIVE_NORMAL */ insert(0xbfff800000000000);
6163 /* IEEE_NEGATIVE_SUBNORMAL */ insert(0x8000400000000000);
6164 /* IEEE_NEGATIVE_ZERO */ insert(0x8000000000000000);
6165 /* IEEE_POSITIVE_ZERO */ insert(0x0000000000000000);
6166 /* IEEE_POSITIVE_SUBNORMAL */ insert(0x0000400000000000);
6167 /* IEEE_POSITIVE_NORMAL */ insert(0x3fff800000000000); // 1.0
6168 /* IEEE_POSITIVE_INF */ insert(0x7fff800000000000);
6169 break;
6170 case 128:
6171 // kind=16: 1 sign bit, 15 exponent bits, 112 significand bits
6172 // 64 high order bits; 64 low order bits are 0.
6173 /* IEEE_SIGNALING_NAN */ insert(0x7fff400000000000);
6174 /* IEEE_QUIET_NAN */ insert(0x7fff800000000000);
6175 /* IEEE_NEGATIVE_INF */ insert(0xffff000000000000);
6176 /* IEEE_NEGATIVE_NORMAL */ insert(0xbfff000000000000);
6177 /* IEEE_NEGATIVE_SUBNORMAL */ insert(0x8000200000000000);
6178 /* IEEE_NEGATIVE_ZERO */ insert(0x8000000000000000);
6179 /* IEEE_POSITIVE_ZERO */ insert(0x0000000000000000);
6180 /* IEEE_POSITIVE_SUBNORMAL */ insert(0x0000200000000000);
6181 /* IEEE_POSITIVE_NORMAL */ insert(0x3fff000000000000); // 1.0
6182 /* IEEE_POSITIVE_INF */ insert(0x7fff000000000000);
6183 break;
6184 default:
6185 llvm_unreachable("unknown real type");
6186 }
6187 insert(0); // IEEE_OTHER_VALUE
6188 assert(values.size() == tableSize && "ieee value mismatch");
6189 builder.createGlobalConstant(
6190 loc, tableTy, tableName, builder.createLinkOnceLinkage(),
6191 mlir::DenseElementsAttr::get(
6192 mlir::RankedTensorType::get(tableSize, valueTy), values));
6193 }
6194
6195 mlir::Value which;
6196 if (args.size() == 2) { // user call
6197 auto [index, ignore] = getFieldRef(builder, loc, args[1]);
6198 which = builder.create<fir::LoadOp>(loc, index);
6199 } else { // compiler generated call
6200 which = args[0];
6201 }
6202 mlir::Value bits = builder.create<fir::LoadOp>(
6203 loc,
6204 builder.create<fir::CoordinateOp>(
6205 loc, builder.getRefType(valueTy),
6206 builder.create<fir::AddrOfOp>(loc, builder.getRefType(tableTy),
6207 builder.getSymbolRefAttr(tableName)),
6208 which));
6209 if (bitWidth > 64)
6210 bits = builder.create<mlir::arith::ShLIOp>(
6211 loc, builder.createConvert(loc, intType, bits),
6212 builder.createIntegerConstant(loc, intType, bitWidth - 64));
6213 return builder.create<mlir::arith::BitcastOp>(loc, realType, bits);
6214}
6215
6216// IEOR
6217mlir::Value IntrinsicLibrary::genIeor(mlir::Type resultType,
6218 llvm::ArrayRef<mlir::Value> args) {
6219 assert(args.size() == 2);
6220 return builder.createUnsigned<mlir::arith::XOrIOp>(loc, resultType, args[0],
6221 args[1]);
6222}
6223
6224// INDEX
6225fir::ExtendedValue
6226IntrinsicLibrary::genIndex(mlir::Type resultType,
6227 llvm::ArrayRef<fir::ExtendedValue> args) {
6228 assert(args.size() >= 2 && args.size() <= 4);
6229
6230 mlir::Value stringBase = fir::getBase(args[0]);
6231 fir::KindTy kind =
6232 fir::factory::CharacterExprHelper{builder, loc}.getCharacterKind(
6233 stringBase.getType());
6234 mlir::Value stringLen = fir::getLen(args[0]);
6235 mlir::Value substringBase = fir::getBase(args[1]);
6236 mlir::Value substringLen = fir::getLen(args[1]);
6237 mlir::Value back =
6238 isStaticallyAbsent(args, 2)
6239 ? builder.createIntegerConstant(loc, builder.getI1Type(), 0)
6240 : fir::getBase(args[2]);
6241 if (isStaticallyAbsent(args, 3))
6242 return builder.createConvert(
6243 loc, resultType,
6244 fir::runtime::genIndex(builder, loc, kind, stringBase, stringLen,
6245 substringBase, substringLen, back));
6246
6247 // Call the descriptor-based Index implementation
6248 mlir::Value string = builder.createBox(loc, args[0]);
6249 mlir::Value substring = builder.createBox(loc, args[1]);
6250 auto makeRefThenEmbox = [&](mlir::Value b) {
6251 fir::LogicalType logTy = fir::LogicalType::get(
6252 builder.getContext(), builder.getKindMap().defaultLogicalKind());
6253 mlir::Value temp = builder.createTemporary(loc, logTy);
6254 mlir::Value castb = builder.createConvert(loc, logTy, b);
6255 builder.create<fir::StoreOp>(loc, castb, temp);
6256 return builder.createBox(loc, temp);
6257 };
6258 mlir::Value backOpt = isStaticallyAbsent(args, 2)
6259 ? builder.create<fir::AbsentOp>(
6260 loc, fir::BoxType::get(builder.getI1Type()))
6261 : makeRefThenEmbox(fir::getBase(args[2]));
6262 mlir::Value kindVal = isStaticallyAbsent(args, 3)
6263 ? builder.createIntegerConstant(
6264 loc, builder.getIndexType(),
6265 builder.getKindMap().defaultIntegerKind())
6266 : fir::getBase(args[3]);
6267 // Create mutable fir.box to be passed to the runtime for the result.
6268 fir::MutableBoxValue mutBox =
6269 fir::factory::createTempMutableBox(builder, loc, resultType);
6270 mlir::Value resBox = fir::factory::getMutableIRBox(builder, loc, mutBox);
6271 // Call runtime. The runtime is allocating the result.
6272 fir::runtime::genIndexDescriptor(builder, loc, resBox, string, substring,
6273 backOpt, kindVal);
6274 // Read back the result from the mutable box.
6275 return readAndAddCleanUp(mutBox, resultType, "INDEX");
6276}
6277
6278// IOR
6279mlir::Value IntrinsicLibrary::genIor(mlir::Type resultType,
6280 llvm::ArrayRef<mlir::Value> args) {
6281 assert(args.size() == 2);
6282 return builder.createUnsigned<mlir::arith::OrIOp>(loc, resultType, args[0],
6283 args[1]);
6284}
6285
6286// IPARITY
6287fir::ExtendedValue
6288IntrinsicLibrary::genIparity(mlir::Type resultType,
6289 llvm::ArrayRef<fir::ExtendedValue> args) {
6290 return genReduction(fir::runtime::genIParity, fir::runtime::genIParityDim,
6291 "IPARITY", resultType, args);
6292}
6293
6294// IS_CONTIGUOUS
6295fir::ExtendedValue
6296IntrinsicLibrary::genIsContiguous(mlir::Type resultType,
6297 llvm::ArrayRef<fir::ExtendedValue> args) {
6298 assert(args.size() == 1);
6299 return builder.createConvert(
6300 loc, resultType,
6301 fir::runtime::genIsContiguous(builder, loc, fir::getBase(args[0])));
6302}
6303
6304// IS_IOSTAT_END, IS_IOSTAT_EOR
6305template <Fortran::runtime::io::Iostat value>
6306mlir::Value
6307IntrinsicLibrary::genIsIostatValue(mlir::Type resultType,
6308 llvm::ArrayRef<mlir::Value> args) {
6309 assert(args.size() == 1);
6310 return builder.create<mlir::arith::CmpIOp>(
6311 loc, mlir::arith::CmpIPredicate::eq, args[0],
6312 builder.createIntegerConstant(loc, args[0].getType(), value));
6313}
6314
6315// ISHFT
6316mlir::Value IntrinsicLibrary::genIshft(mlir::Type resultType,
6317 llvm::ArrayRef<mlir::Value> args) {
6318 // A conformant ISHFT(I,SHIFT) call satisfies:
6319 // abs(SHIFT) <= BIT_SIZE(I)
6320 // Return: abs(SHIFT) >= BIT_SIZE(I)
6321 // ? 0
6322 // : SHIFT < 0
6323 // ? I >> abs(SHIFT)
6324 // : I << abs(SHIFT)
6325 assert(args.size() == 2);
6326 int intWidth = resultType.getIntOrFloatBitWidth();
6327 mlir::Type signlessType =
6328 mlir::IntegerType::get(builder.getContext(), intWidth,
6329 mlir::IntegerType::SignednessSemantics::Signless);
6330 mlir::Value bitSize =
6331 builder.createIntegerConstant(loc, signlessType, intWidth);
6332 mlir::Value zero = builder.createIntegerConstant(loc, signlessType, 0);
6333 mlir::Value shift = builder.createConvert(loc, signlessType, args[1]);
6334 mlir::Value absShift = genAbs(signlessType, {shift});
6335 mlir::Value word = args[0];
6336 if (word.getType().isUnsignedInteger())
6337 word = builder.createConvert(loc, signlessType, word);
6338 auto left = builder.create<mlir::arith::ShLIOp>(loc, word, absShift);
6339 auto right = builder.create<mlir::arith::ShRUIOp>(loc, word, absShift);
6340 auto shiftIsLarge = builder.create<mlir::arith::CmpIOp>(
6341 loc, mlir::arith::CmpIPredicate::sge, absShift, bitSize);
6342 auto shiftIsNegative = builder.create<mlir::arith::CmpIOp>(
6343 loc, mlir::arith::CmpIPredicate::slt, shift, zero);
6344 auto sel =
6345 builder.create<mlir::arith::SelectOp>(loc, shiftIsNegative, right, left);
6346 mlir::Value result =
6347 builder.create<mlir::arith::SelectOp>(loc, shiftIsLarge, zero, sel);
6348 if (resultType.isUnsignedInteger())
6349 return builder.createConvert(loc, resultType, result);
6350 return result;
6351}
6352
6353// ISHFTC
6354mlir::Value IntrinsicLibrary::genIshftc(mlir::Type resultType,
6355 llvm::ArrayRef<mlir::Value> args) {
6356 // A conformant ISHFTC(I,SHIFT,SIZE) call satisfies:
6357 // SIZE > 0
6358 // SIZE <= BIT_SIZE(I)
6359 // abs(SHIFT) <= SIZE
6360 // if SHIFT > 0
6361 // leftSize = abs(SHIFT)
6362 // rightSize = SIZE - abs(SHIFT)
6363 // else [if SHIFT < 0]
6364 // leftSize = SIZE - abs(SHIFT)
6365 // rightSize = abs(SHIFT)
6366 // unchanged = SIZE == BIT_SIZE(I) ? 0 : (I >> SIZE) << SIZE
6367 // leftMaskShift = BIT_SIZE(I) - leftSize
6368 // rightMaskShift = BIT_SIZE(I) - rightSize
6369 // left = (I >> rightSize) & (-1 >> leftMaskShift)
6370 // right = (I & (-1 >> rightMaskShift)) << leftSize
6371 // Return: SHIFT == 0 || SIZE == abs(SHIFT) ? I : (unchanged | left | right)
6372 assert(args.size() == 3);
6373 int intWidth = resultType.getIntOrFloatBitWidth();
6374 mlir::Type signlessType =
6375 mlir::IntegerType::get(builder.getContext(), intWidth,
6376 mlir::IntegerType::SignednessSemantics::Signless);
6377 mlir::Value bitSize =
6378 builder.createIntegerConstant(loc, signlessType, intWidth);
6379 mlir::Value word = args[0];
6380 if (word.getType().isUnsignedInteger())
6381 word = builder.createConvert(loc, signlessType, word);
6382 mlir::Value shift = builder.createConvert(loc, signlessType, args[1]);
6383 mlir::Value size =
6384 args[2] ? builder.createConvert(loc, signlessType, args[2]) : bitSize;
6385 mlir::Value zero = builder.createIntegerConstant(loc, signlessType, 0);
6386 mlir::Value ones = builder.createAllOnesInteger(loc, signlessType);
6387 mlir::Value absShift = genAbs(signlessType, {shift});
6388 auto elseSize = builder.create<mlir::arith::SubIOp>(loc, size, absShift);
6389 auto shiftIsZero = builder.create<mlir::arith::CmpIOp>(
6390 loc, mlir::arith::CmpIPredicate::eq, shift, zero);
6391 auto shiftEqualsSize = builder.create<mlir::arith::CmpIOp>(
6392 loc, mlir::arith::CmpIPredicate::eq, absShift, size);
6393 auto shiftIsNop =
6394 builder.create<mlir::arith::OrIOp>(loc, shiftIsZero, shiftEqualsSize);
6395 auto shiftIsPositive = builder.create<mlir::arith::CmpIOp>(
6396 loc, mlir::arith::CmpIPredicate::sgt, shift, zero);
6397 auto leftSize = builder.create<mlir::arith::SelectOp>(loc, shiftIsPositive,
6398 absShift, elseSize);
6399 auto rightSize = builder.create<mlir::arith::SelectOp>(loc, shiftIsPositive,
6400 elseSize, absShift);
6401 auto hasUnchanged = builder.create<mlir::arith::CmpIOp>(
6402 loc, mlir::arith::CmpIPredicate::ne, size, bitSize);
6403 auto unchangedTmp1 = builder.create<mlir::arith::ShRUIOp>(loc, word, size);
6404 auto unchangedTmp2 =
6405 builder.create<mlir::arith::ShLIOp>(loc, unchangedTmp1, size);
6406 auto unchanged = builder.create<mlir::arith::SelectOp>(loc, hasUnchanged,
6407 unchangedTmp2, zero);
6408 auto leftMaskShift =
6409 builder.create<mlir::arith::SubIOp>(loc, bitSize, leftSize);
6410 auto leftMask =
6411 builder.create<mlir::arith::ShRUIOp>(loc, ones, leftMaskShift);
6412 auto leftTmp = builder.create<mlir::arith::ShRUIOp>(loc, word, rightSize);
6413 auto left = builder.create<mlir::arith::AndIOp>(loc, leftTmp, leftMask);
6414 auto rightMaskShift =
6415 builder.create<mlir::arith::SubIOp>(loc, bitSize, rightSize);
6416 auto rightMask =
6417 builder.create<mlir::arith::ShRUIOp>(loc, ones, rightMaskShift);
6418 auto rightTmp = builder.create<mlir::arith::AndIOp>(loc, word, rightMask);
6419 auto right = builder.create<mlir::arith::ShLIOp>(loc, rightTmp, leftSize);
6420 auto resTmp = builder.create<mlir::arith::OrIOp>(loc, unchanged, left);
6421 auto res = builder.create<mlir::arith::OrIOp>(loc, resTmp, right);
6422 mlir::Value result =
6423 builder.create<mlir::arith::SelectOp>(loc, shiftIsNop, word, res);
6424 if (resultType.isUnsignedInteger())
6425 return builder.createConvert(loc, resultType, result);
6426 return result;
6427}
6428
6429// LEADZ
6430mlir::Value IntrinsicLibrary::genLeadz(mlir::Type resultType,
6431 llvm::ArrayRef<mlir::Value> args) {
6432 assert(args.size() == 1);
6433
6434 mlir::Value result =
6435 builder.create<mlir::math::CountLeadingZerosOp>(loc, args);
6436
6437 return builder.createConvert(loc, resultType, result);
6438}
6439
6440// LEN
6441// Note that this is only used for an unrestricted intrinsic LEN call.
6442// Other uses of LEN are rewritten as descriptor inquiries by the front-end.
6443fir::ExtendedValue
6444IntrinsicLibrary::genLen(mlir::Type resultType,
6445 llvm::ArrayRef<fir::ExtendedValue> args) {
6446 // Optional KIND argument reflected in result type and otherwise ignored.
6447 assert(args.size() == 1 || args.size() == 2);
6448 mlir::Value len = fir::factory::readCharLen(builder, loc, args[0]);
6449 return builder.createConvert(loc, resultType, len);
6450}
6451
6452// LEN_TRIM
6453fir::ExtendedValue
6454IntrinsicLibrary::genLenTrim(mlir::Type resultType,
6455 llvm::ArrayRef<fir::ExtendedValue> args) {
6456 // Optional KIND argument reflected in result type and otherwise ignored.
6457 assert(args.size() == 1 || args.size() == 2);
6458 const fir::CharBoxValue *charBox = args[0].getCharBox();
6459 if (!charBox)
6460 TODO(loc, "intrinsic: len_trim for character array");
6461 auto len =
6462 fir::factory::CharacterExprHelper(builder, loc).createLenTrim(*charBox);
6463 return builder.createConvert(loc, resultType, len);
6464}
6465
6466// LGE, LGT, LLE, LLT
6467template <mlir::arith::CmpIPredicate pred>
6468fir::ExtendedValue
6469IntrinsicLibrary::genCharacterCompare(mlir::Type resultType,
6470 llvm::ArrayRef<fir::ExtendedValue> args) {
6471 assert(args.size() == 2);
6472 return fir::runtime::genCharCompare(
6473 builder, loc, pred, fir::getBase(args[0]), fir::getLen(args[0]),
6474 fir::getBase(args[1]), fir::getLen(args[1]));
6475}
6476
6477static bool isOptional(mlir::Value value) {
6478 auto varIface = mlir::dyn_cast_or_null<fir::FortranVariableOpInterface>(
6479 value.getDefiningOp());
6480 return varIface && varIface.isOptional();
6481}
6482
6483// LOC
6484fir::ExtendedValue
6485IntrinsicLibrary::genLoc(mlir::Type resultType,
6486 llvm::ArrayRef<fir::ExtendedValue> args) {
6487 assert(args.size() == 1);
6488 mlir::Value box = fir::getBase(args[0]);
6489 assert(fir::isa_box_type(box.getType()) &&
6490 "argument must have been lowered to box type");
6491 bool isFunc = mlir::isa<fir::BoxProcType>(box.getType());
6492 if (!isOptional(box)) {
6493 mlir::Value argAddr = getAddrFromBox(builder, loc, args[0], isFunc);
6494 return builder.createConvert(loc, resultType, argAddr);
6495 }
6496 // Optional assumed shape case. Although this is not specified in this GNU
6497 // intrinsic extension, LOC accepts absent optional and returns zero in that
6498 // case.
6499 // Note that the other OPTIONAL cases do not fall here since `box` was
6500 // created when preparing the argument cases, but the box can be safely be
6501 // used for all those cases and the address will be null if absent.
6502 mlir::Value isPresent =
6503 builder.create<fir::IsPresentOp>(loc, builder.getI1Type(), box);
6504 return builder
6505 .genIfOp(loc, {resultType}, isPresent,
6506 /*withElseRegion=*/true)
6507 .genThen([&]() {
6508 mlir::Value argAddr = getAddrFromBox(builder, loc, args[0], isFunc);
6509 mlir::Value cast = builder.createConvert(loc, resultType, argAddr);
6510 builder.create<fir::ResultOp>(loc, cast);
6511 })
6512 .genElse([&]() {
6513 mlir::Value zero = builder.createIntegerConstant(loc, resultType, 0);
6514 builder.create<fir::ResultOp>(loc, zero);
6515 })
6516 .getResults()[0];
6517}
6518
6519mlir::Value IntrinsicLibrary::genMalloc(mlir::Type resultType,
6520 llvm::ArrayRef<mlir::Value> args) {
6521 assert(args.size() == 1);
6522 return builder.createConvert(loc, resultType,
6523 fir::runtime::genMalloc(builder, loc, args[0]));
6524}
6525
6526// MASKL, MASKR, UMASKL, UMASKR
6527template <typename Shift>
6528mlir::Value IntrinsicLibrary::genMask(mlir::Type resultType,
6529 llvm::ArrayRef<mlir::Value> args) {
6530 assert(args.size() == 2);
6531
6532 int bits = resultType.getIntOrFloatBitWidth();
6533 mlir::Type signlessType =
6534 mlir::IntegerType::get(builder.getContext(), bits,
6535 mlir::IntegerType::SignednessSemantics::Signless);
6536 mlir::Value zero = builder.createIntegerConstant(loc, signlessType, 0);
6537 mlir::Value ones = builder.createAllOnesInteger(loc, signlessType);
6538 mlir::Value bitSize = builder.createIntegerConstant(loc, signlessType, bits);
6539 mlir::Value bitsToSet = builder.createConvert(loc, signlessType, args[0]);
6540
6541 // The standard does not specify what to return if the number of bits to be
6542 // set, I < 0 or I >= BIT_SIZE(KIND). The shift instruction used below will
6543 // produce a poison value which may return a possibly platform-specific and/or
6544 // non-deterministic result. Other compilers don't produce a consistent result
6545 // in this case either, so we choose the most efficient implementation.
6546 mlir::Value shift =
6547 builder.create<mlir::arith::SubIOp>(loc, bitSize, bitsToSet);
6548 mlir::Value shifted = builder.create<Shift>(loc, ones, shift);
6549 mlir::Value isZero = builder.create<mlir::arith::CmpIOp>(
6550 loc, mlir::arith::CmpIPredicate::eq, bitsToSet, zero);
6551 mlir::Value result =
6552 builder.create<mlir::arith::SelectOp>(loc, isZero, zero, shifted);
6553 if (resultType.isUnsignedInteger())
6554 return builder.createConvert(loc, resultType, result);
6555 return result;
6556}
6557
6558// MATCH_ALL_SYNC
6559mlir::Value
6560IntrinsicLibrary::genMatchAllSync(mlir::Type resultType,
6561 llvm::ArrayRef<mlir::Value> args) {
6562 assert(args.size() == 3);
6563 bool is32 = args[1].getType().isInteger(32) || args[1].getType().isF32();
6564
6565 mlir::Type i1Ty = builder.getI1Type();
6566 mlir::MLIRContext *context = builder.getContext();
6567
6568 mlir::Value arg1 = args[1];
6569 if (arg1.getType().isF32() || arg1.getType().isF64())
6570 arg1 = builder.create<fir::ConvertOp>(
6571 loc, is32 ? builder.getI32Type() : builder.getI64Type(), arg1);
6572
6573 mlir::Type retTy =
6574 mlir::LLVM::LLVMStructType::getLiteral(context, {resultType, i1Ty});
6575 auto match =
6576 builder
6577 .create<mlir::NVVM::MatchSyncOp>(loc, retTy, args[0], arg1,
6578 mlir::NVVM::MatchSyncKind::all)
6579 .getResult();
6580 auto value = builder.create<mlir::LLVM::ExtractValueOp>(loc, match, 0);
6581 auto pred = builder.create<mlir::LLVM::ExtractValueOp>(loc, match, 1);
6582 auto conv = builder.create<mlir::LLVM::ZExtOp>(loc, resultType, pred);
6583 builder.create<fir::StoreOp>(loc, conv, args[2]);
6584 return value;
6585}
6586
6587// ALL_SYNC, ANY_SYNC, BALLOT_SYNC
6588template <mlir::NVVM::VoteSyncKind kind>
6589mlir::Value IntrinsicLibrary::genVoteSync(mlir::Type resultType,
6590 llvm::ArrayRef<mlir::Value> args) {
6591 assert(args.size() == 2);
6592 mlir::Value arg1 =
6593 builder.create<fir::ConvertOp>(loc, builder.getI1Type(), args[1]);
6594 mlir::Type resTy = kind == mlir::NVVM::VoteSyncKind::ballot
6595 ? builder.getI32Type()
6596 : builder.getI1Type();
6597 auto voteRes =
6598 builder.create<mlir::NVVM::VoteSyncOp>(loc, resTy, args[0], arg1, kind)
6599 .getResult();
6600 return builder.create<fir::ConvertOp>(loc, resultType, voteRes);
6601}
6602
6603// MATCH_ANY_SYNC
6604mlir::Value
6605IntrinsicLibrary::genMatchAnySync(mlir::Type resultType,
6606 llvm::ArrayRef<mlir::Value> args) {
6607 assert(args.size() == 2);
6608 bool is32 = args[1].getType().isInteger(32) || args[1].getType().isF32();
6609
6610 mlir::Value arg1 = args[1];
6611 if (arg1.getType().isF32() || arg1.getType().isF64())
6612 arg1 = builder.create<fir::ConvertOp>(
6613 loc, is32 ? builder.getI32Type() : builder.getI64Type(), arg1);
6614
6615 return builder
6616 .create<mlir::NVVM::MatchSyncOp>(loc, resultType, args[0], arg1,
6617 mlir::NVVM::MatchSyncKind::any)
6618 .getResult();
6619}
6620
6621// MATMUL
6622fir::ExtendedValue
6623IntrinsicLibrary::genMatmul(mlir::Type resultType,
6624 llvm::ArrayRef<fir::ExtendedValue> args) {
6625 assert(args.size() == 2);
6626
6627 // Handle required matmul arguments
6628 fir::BoxValue matrixTmpA = builder.createBox(loc, args[0]);
6629 mlir::Value matrixA = fir::getBase(matrixTmpA);
6630 fir::BoxValue matrixTmpB = builder.createBox(loc, args[1]);
6631 mlir::Value matrixB = fir::getBase(matrixTmpB);
6632 unsigned resultRank =
6633 (matrixTmpA.rank() == 1 || matrixTmpB.rank() == 1) ? 1 : 2;
6634
6635 // Create mutable fir.box to be passed to the runtime for the result.
6636 mlir::Type resultArrayType = builder.getVarLenSeqTy(resultType, resultRank);
6637 fir::MutableBoxValue resultMutableBox =
6638 fir::factory::createTempMutableBox(builder, loc, resultArrayType);
6639 mlir::Value resultIrBox =
6640 fir::factory::getMutableIRBox(builder, loc, resultMutableBox);
6641 // Call runtime. The runtime is allocating the result.
6642 fir::runtime::genMatmul(builder, loc, resultIrBox, matrixA, matrixB);
6643 // Read result from mutable fir.box and add it to the list of temps to be
6644 // finalized by the StatementContext.
6645 return readAndAddCleanUp(resultMutableBox, resultType, "MATMUL");
6646}
6647
6648// MATMUL_TRANSPOSE
6649fir::ExtendedValue
6650IntrinsicLibrary::genMatmulTranspose(mlir::Type resultType,
6651 llvm::ArrayRef<fir::ExtendedValue> args) {
6652 assert(args.size() == 2);
6653
6654 // Handle required matmul_transpose arguments
6655 fir::BoxValue matrixTmpA = builder.createBox(loc, args[0]);
6656 mlir::Value matrixA = fir::getBase(matrixTmpA);
6657 fir::BoxValue matrixTmpB = builder.createBox(loc, args[1]);
6658 mlir::Value matrixB = fir::getBase(matrixTmpB);
6659 unsigned resultRank =
6660 (matrixTmpA.rank() == 1 || matrixTmpB.rank() == 1) ? 1 : 2;
6661
6662 // Create mutable fir.box to be passed to the runtime for the result.
6663 mlir::Type resultArrayType = builder.getVarLenSeqTy(resultType, resultRank);
6664 fir::MutableBoxValue resultMutableBox =
6665 fir::factory::createTempMutableBox(builder, loc, resultArrayType);
6666 mlir::Value resultIrBox =
6667 fir::factory::getMutableIRBox(builder, loc, resultMutableBox);
6668 // Call runtime. The runtime is allocating the result.
6669 fir::runtime::genMatmulTranspose(builder, loc, resultIrBox, matrixA, matrixB);
6670 // Read result from mutable fir.box and add it to the list of temps to be
6671 // finalized by the StatementContext.
6672 return readAndAddCleanUp(resultMutableBox, resultType, "MATMUL_TRANSPOSE");
6673}
6674
6675// MERGE
6676fir::ExtendedValue
6677IntrinsicLibrary::genMerge(mlir::Type,
6678 llvm::ArrayRef<fir::ExtendedValue> args) {
6679 assert(args.size() == 3);
6680 mlir::Value tsource = fir::getBase(args[0]);
6681 mlir::Value fsource = fir::getBase(args[1]);
6682 mlir::Value rawMask = fir::getBase(args[2]);
6683 mlir::Type type0 = fir::unwrapRefType(tsource.getType());
6684 bool isCharRslt = fir::isa_char(type0); // result is same as first argument
6685 mlir::Value mask = builder.createConvert(loc, builder.getI1Type(), rawMask);
6686
6687 // The result is polymorphic if and only if both TSOURCE and FSOURCE are
6688 // polymorphic. TSOURCE and FSOURCE are required to have the same type
6689 // (for both declared and dynamic types) so a simple convert op can be
6690 // used.
6691 mlir::Value tsourceCast = tsource;
6692 mlir::Value fsourceCast = fsource;
6693 auto convertToStaticType = [&](mlir::Value polymorphic,
6694 mlir::Value other) -> mlir::Value {
6695 mlir::Type otherType = other.getType();
6696 if (mlir::isa<fir::BaseBoxType>(otherType))
6697 return builder.create<fir::ReboxOp>(loc, otherType, polymorphic,
6698 /*shape*/ mlir::Value{},
6699 /*slice=*/mlir::Value{});
6700 return builder.create<fir::BoxAddrOp>(loc, otherType, polymorphic);
6701 };
6702 if (fir::isPolymorphicType(tsource.getType()) &&
6703 !fir::isPolymorphicType(fsource.getType())) {
6704 tsourceCast = convertToStaticType(tsource, fsource);
6705 } else if (!fir::isPolymorphicType(tsource.getType()) &&
6706 fir::isPolymorphicType(fsource.getType())) {
6707 fsourceCast = convertToStaticType(fsource, tsource);
6708 } else {
6709 // FSOURCE and TSOURCE are not polymorphic.
6710 // FSOURCE has the same type as TSOURCE, but they may not have the same MLIR
6711 // types (one can have dynamic length while the other has constant lengths,
6712 // or one may be a fir.logical<> while the other is an i1). Insert a cast to
6713 // fulfill mlir::SelectOp constraint that the MLIR types must be the same.
6714 fsourceCast = builder.createConvert(loc, tsource.getType(), fsource);
6715 }
6716 auto rslt = builder.create<mlir::arith::SelectOp>(loc, mask, tsourceCast,
6717 fsourceCast);
6718 if (isCharRslt) {
6719 // Need a CharBoxValue for character results
6720 const fir::CharBoxValue *charBox = args[0].getCharBox();
6721 fir::CharBoxValue charRslt(rslt, charBox->getLen());
6722 return charRslt;
6723 }
6724 return rslt;
6725}
6726
6727// MERGE_BITS
6728mlir::Value IntrinsicLibrary::genMergeBits(mlir::Type resultType,
6729 llvm::ArrayRef<mlir::Value> args) {
6730 assert(args.size() == 3);
6731
6732 mlir::Type signlessType = mlir::IntegerType::get(
6733 builder.getContext(), resultType.getIntOrFloatBitWidth(),
6734 mlir::IntegerType::SignednessSemantics::Signless);
6735 // MERGE_BITS(I, J, MASK) = IOR(IAND(I, MASK), IAND(J, NOT(MASK)))
6736 mlir::Value ones = builder.createAllOnesInteger(loc, signlessType);
6737 mlir::Value notMask = builder.createUnsigned<mlir::arith::XOrIOp>(
6738 loc, resultType, args[2], ones);
6739 mlir::Value lft = builder.createUnsigned<mlir::arith::AndIOp>(
6740 loc, resultType, args[0], args[2]);
6741 mlir::Value rgt = builder.createUnsigned<mlir::arith::AndIOp>(
6742 loc, resultType, args[1], notMask);
6743 return builder.createUnsigned<mlir::arith::OrIOp>(loc, resultType, lft, rgt);
6744}
6745
6746// MOD
6747mlir::Value IntrinsicLibrary::genMod(mlir::Type resultType,
6748 llvm::ArrayRef<mlir::Value> args) {
6749 assert(args.size() == 2);
6750 if (resultType.isUnsignedInteger()) {
6751 mlir::Type signlessType = mlir::IntegerType::get(
6752 builder.getContext(), resultType.getIntOrFloatBitWidth(),
6753 mlir::IntegerType::SignednessSemantics::Signless);
6754 return builder.createUnsigned<mlir::arith::RemUIOp>(loc, signlessType,
6755 args[0], args[1]);
6756 }
6757 if (mlir::isa<mlir::IntegerType>(resultType))
6758 return builder.create<mlir::arith::RemSIOp>(loc, args[0], args[1]);
6759
6760 // Use runtime.
6761 return builder.createConvert(
6762 loc, resultType, fir::runtime::genMod(builder, loc, args[0], args[1]));
6763}
6764
6765// MODULO
6766mlir::Value IntrinsicLibrary::genModulo(mlir::Type resultType,
6767 llvm::ArrayRef<mlir::Value> args) {
6768 // TODO: we'd better generate a runtime call here, when runtime error
6769 // checking is needed (to detect 0 divisor) or when precise math is requested.
6770 assert(args.size() == 2);
6771 // No floored modulo op in LLVM/MLIR yet. TODO: add one to MLIR.
6772 // In the meantime, use a simple inlined implementation based on truncated
6773 // modulo (MOD(A, P) implemented by RemIOp, RemFOp). This avoids making manual
6774 // division and multiplication from MODULO formula.
6775 // - If A/P > 0 or MOD(A,P)=0, then INT(A/P) = FLOOR(A/P), and MODULO = MOD.
6776 // - Otherwise, when A/P < 0 and MOD(A,P) !=0, then MODULO(A, P) =
6777 // A-FLOOR(A/P)*P = A-(INT(A/P)-1)*P = A-INT(A/P)*P+P = MOD(A,P)+P
6778 // Note that A/P < 0 if and only if A and P signs are different.
6779 if (resultType.isUnsignedInteger()) {
6780 mlir::Type signlessType = mlir::IntegerType::get(
6781 builder.getContext(), resultType.getIntOrFloatBitWidth(),
6782 mlir::IntegerType::SignednessSemantics::Signless);
6783 return builder.createUnsigned<mlir::arith::RemUIOp>(loc, signlessType,
6784 args[0], args[1]);
6785 }
6786 if (mlir::isa<mlir::IntegerType>(resultType)) {
6787 auto remainder =
6788 builder.create<mlir::arith::RemSIOp>(loc, args[0], args[1]);
6789 auto argXor = builder.create<mlir::arith::XOrIOp>(loc, args[0], args[1]);
6790 mlir::Value zero = builder.createIntegerConstant(loc, argXor.getType(), 0);
6791 auto argSignDifferent = builder.create<mlir::arith::CmpIOp>(
6792 loc, mlir::arith::CmpIPredicate::slt, argXor, zero);
6793 auto remainderIsNotZero = builder.create<mlir::arith::CmpIOp>(
6794 loc, mlir::arith::CmpIPredicate::ne, remainder, zero);
6795 auto mustAddP = builder.create<mlir::arith::AndIOp>(loc, remainderIsNotZero,
6796 argSignDifferent);
6797 auto remPlusP =
6798 builder.create<mlir::arith::AddIOp>(loc, remainder, args[1]);
6799 return builder.create<mlir::arith::SelectOp>(loc, mustAddP, remPlusP,
6800 remainder);
6801 }
6802
6803 auto fastMathFlags = builder.getFastMathFlags();
6804 // F128 arith::RemFOp may be lowered to a runtime call that may be unsupported
6805 // on the target, so generate a call to Fortran Runtime's ModuloReal16.
6806 if (resultType == mlir::Float128Type::get(builder.getContext()) ||
6807 (fastMathFlags & mlir::arith::FastMathFlags::ninf) ==
6808 mlir::arith::FastMathFlags::none)
6809 return builder.createConvert(
6810 loc, resultType,
6811 fir::runtime::genModulo(builder, loc, args[0], args[1]));
6812
6813 auto remainder = builder.create<mlir::arith::RemFOp>(loc, args[0], args[1]);
6814 mlir::Value zero = builder.createRealZeroConstant(loc, remainder.getType());
6815 auto remainderIsNotZero = builder.create<mlir::arith::CmpFOp>(
6816 loc, mlir::arith::CmpFPredicate::UNE, remainder, zero);
6817 auto aLessThanZero = builder.create<mlir::arith::CmpFOp>(
6818 loc, mlir::arith::CmpFPredicate::OLT, args[0], zero);
6819 auto pLessThanZero = builder.create<mlir::arith::CmpFOp>(
6820 loc, mlir::arith::CmpFPredicate::OLT, args[1], zero);
6821 auto argSignDifferent =
6822 builder.create<mlir::arith::XOrIOp>(loc, aLessThanZero, pLessThanZero);
6823 auto mustAddP = builder.create<mlir::arith::AndIOp>(loc, remainderIsNotZero,
6824 argSignDifferent);
6825 auto remPlusP = builder.create<mlir::arith::AddFOp>(loc, remainder, args[1]);
6826 return builder.create<mlir::arith::SelectOp>(loc, mustAddP, remPlusP,
6827 remainder);
6828}
6829
6830void IntrinsicLibrary::genMoveAlloc(llvm::ArrayRef<fir::ExtendedValue> args) {
6831 assert(args.size() == 4);
6832
6833 const fir::ExtendedValue &from = args[0];
6834 const fir::ExtendedValue &to = args[1];
6835 const fir::ExtendedValue &status = args[2];
6836 const fir::ExtendedValue &errMsg = args[3];
6837
6838 mlir::Type boxNoneTy = fir::BoxType::get(builder.getNoneType());
6839 mlir::Value errBox =
6840 isStaticallyPresent(errMsg)
6841 ? fir::getBase(errMsg)
6842 : builder.create<fir::AbsentOp>(loc, boxNoneTy).getResult();
6843
6844 const fir::MutableBoxValue *fromBox = from.getBoxOf<fir::MutableBoxValue>();
6845 const fir::MutableBoxValue *toBox = to.getBoxOf<fir::MutableBoxValue>();
6846
6847 assert(fromBox && toBox && "move_alloc parameters must be mutable arrays");
6848
6849 mlir::Value fromAddr = fir::factory::getMutableIRBox(builder, loc, *fromBox);
6850 mlir::Value toAddr = fir::factory::getMutableIRBox(builder, loc, *toBox);
6851
6852 mlir::Value hasStat = builder.createBool(loc, isStaticallyPresent(status));
6853
6854 mlir::Value stat = fir::runtime::genMoveAlloc(builder, loc, toAddr, fromAddr,
6855 hasStat, errBox);
6856
6857 fir::factory::syncMutableBoxFromIRBox(builder, loc, *fromBox);
6858 fir::factory::syncMutableBoxFromIRBox(builder, loc, *toBox);
6859
6860 if (isStaticallyPresent(status)) {
6861 mlir::Value statAddr = fir::getBase(status);
6862 mlir::Value statIsPresentAtRuntime =
6863 builder.genIsNotNullAddr(loc, statAddr);
6864 builder.genIfThen(loc, statIsPresentAtRuntime)
6865 .genThen([&]() { builder.createStoreWithConvert(loc, stat, statAddr); })
6866 .end();
6867 }
6868}
6869
6870// MVBITS
6871void IntrinsicLibrary::genMvbits(llvm::ArrayRef<fir::ExtendedValue> args) {
6872 // A conformant MVBITS(FROM,FROMPOS,LEN,TO,TOPOS) call satisfies:
6873 // FROMPOS >= 0
6874 // LEN >= 0
6875 // TOPOS >= 0
6876 // FROMPOS + LEN <= BIT_SIZE(FROM)
6877 // TOPOS + LEN <= BIT_SIZE(TO)
6878 // MASK = -1 >> (BIT_SIZE(FROM) - LEN)
6879 // TO = LEN == 0 ? TO : ((!(MASK << TOPOS)) & TO) |
6880 // (((FROM >> FROMPOS) & MASK) << TOPOS)
6881 assert(args.size() == 5);
6882 auto unbox = [&](fir::ExtendedValue exv) {
6883 const mlir::Value *arg = exv.getUnboxed();
6884 assert(arg && "nonscalar mvbits argument");
6885 return *arg;
6886 };
6887 mlir::Value from = unbox(args[0]);
6888 mlir::Type fromType = from.getType();
6889 mlir::Type signlessType = mlir::IntegerType::get(
6890 builder.getContext(), fromType.getIntOrFloatBitWidth(),
6891 mlir::IntegerType::SignednessSemantics::Signless);
6892 mlir::Value frompos =
6893 builder.createConvert(loc, signlessType, unbox(args[1]));
6894 mlir::Value len = builder.createConvert(loc, signlessType, unbox(args[2]));
6895 mlir::Value toAddr = unbox(args[3]);
6896 mlir::Type toType{fir::dyn_cast_ptrEleTy(toAddr.getType())};
6897 assert(toType.getIntOrFloatBitWidth() == fromType.getIntOrFloatBitWidth() &&
6898 "mismatched mvbits types");
6899 auto to = builder.create<fir::LoadOp>(loc, signlessType, toAddr);
6900 mlir::Value topos = builder.createConvert(loc, signlessType, unbox(args[4]));
6901 mlir::Value zero = builder.createIntegerConstant(loc, signlessType, 0);
6902 mlir::Value ones = builder.createAllOnesInteger(loc, signlessType);
6903 mlir::Value bitSize = builder.createIntegerConstant(
6904 loc, signlessType,
6905 mlir::cast<mlir::IntegerType>(signlessType).getWidth());
6906 auto shiftCount = builder.create<mlir::arith::SubIOp>(loc, bitSize, len);
6907 auto mask = builder.create<mlir::arith::ShRUIOp>(loc, ones, shiftCount);
6908 auto unchangedTmp1 = builder.create<mlir::arith::ShLIOp>(loc, mask, topos);
6909 auto unchangedTmp2 =
6910 builder.create<mlir::arith::XOrIOp>(loc, unchangedTmp1, ones);
6911 auto unchanged = builder.create<mlir::arith::AndIOp>(loc, unchangedTmp2, to);
6912 if (fromType.isUnsignedInteger())
6913 from = builder.createConvert(loc, signlessType, from);
6914 auto frombitsTmp1 = builder.create<mlir::arith::ShRUIOp>(loc, from, frompos);
6915 auto frombitsTmp2 =
6916 builder.create<mlir::arith::AndIOp>(loc, frombitsTmp1, mask);
6917 auto frombits = builder.create<mlir::arith::ShLIOp>(loc, frombitsTmp2, topos);
6918 auto resTmp = builder.create<mlir::arith::OrIOp>(loc, unchanged, frombits);
6919 auto lenIsZero = builder.create<mlir::arith::CmpIOp>(
6920 loc, mlir::arith::CmpIPredicate::eq, len, zero);
6921 mlir::Value res =
6922 builder.create<mlir::arith::SelectOp>(loc, lenIsZero, to, resTmp);
6923 if (toType.isUnsignedInteger())
6924 res = builder.createConvert(loc, toType, res);
6925 builder.create<fir::StoreOp>(loc, res, toAddr);
6926}
6927
6928// NEAREST, IEEE_NEXT_AFTER, IEEE_NEXT_DOWN, IEEE_NEXT_UP
6929template <I::NearestProc proc>
6930mlir::Value IntrinsicLibrary::genNearest(mlir::Type resultType,
6931 llvm::ArrayRef<mlir::Value> args) {
6932 // NEAREST
6933 // Return the number adjacent to arg X in the direction of the infinity
6934 // with the sign of arg S. Terminate with an error if arg S is zero.
6935 // Generate exceptions as for IEEE_NEXT_AFTER.
6936 // IEEE_NEXT_AFTER
6937 // Return isNan(Y) ? NaN : X==Y ? X : num adjacent to X in the dir of Y.
6938 // Signal IEEE_OVERFLOW, IEEE_INEXACT for finite X and infinite result.
6939 // Signal IEEE_UNDERFLOW, IEEE_INEXACT for subnormal result.
6940 // IEEE_NEXT_DOWN
6941 // Return the number adjacent to X and less than X.
6942 // Signal IEEE_INVALID when X is a signaling NaN.
6943 // IEEE_NEXT_UP
6944 // Return the number adjacent to X and greater than X.
6945 // Signal IEEE_INVALID when X is a signaling NaN.
6946 //
6947 // valueUp -- true if a finite result must be larger than X.
6948 // magnitudeUp -- true if a finite abs(result) must be larger than abs(X).
6949 //
6950 // if (isNextAfter && isNan(Y)) X = NaN // result = NaN
6951 // if (isNan(X) || (isNextAfter && X == Y) || (isInfinite(X) && magnitudeUp))
6952 // result = X
6953 // else if (isZero(X))
6954 // result = valueUp ? minPositiveSubnormal : minNegativeSubnormal
6955 // else
6956 // result = magUp ? (X + minPositiveSubnormal) : (X - minPositiveSubnormal)
6957
6958 assert(args.size() == 1 || args.size() == 2);
6959 mlir::Value x = args[0];
6960 mlir::FloatType xType = mlir::dyn_cast<mlir::FloatType>(x.getType());
6961 const unsigned xBitWidth = xType.getWidth();
6962 mlir::Type i1Ty = builder.getI1Type();
6963 if constexpr (proc == NearestProc::NextAfter) {
6964 // If isNan(Y), set X to a qNaN that will propagate to the resultIsX result.
6965 mlir::Value qNan = genQNan(xType);
6966 mlir::Value isFPClass = genIsFPClass(i1Ty, args[1], nanTest);
6967 x = builder.create<mlir::arith::SelectOp>(loc, isFPClass, qNan, x);
6968 }
6969 mlir::Value resultIsX = genIsFPClass(i1Ty, x, nanTest);
6970 mlir::Type intType = builder.getIntegerType(xBitWidth);
6971 mlir::Value one = builder.createIntegerConstant(loc, intType, 1);
6972
6973 // Set valueUp to true if a finite result must be larger than arg X.
6974 mlir::Value valueUp;
6975 if constexpr (proc == NearestProc::Nearest) {
6976 // Arg S must not be zero.
6977 fir::IfOp ifOp =
6978 builder.create<fir::IfOp>(loc, genIsFPClass(i1Ty, args[1], zeroTest),
6979 /*withElseRegion=*/false);
6980 builder.setInsertionPointToStart(&ifOp.getThenRegion().front());
6981 fir::runtime::genReportFatalUserError(
6982 builder, loc, "intrinsic nearest S argument is zero");
6983 builder.setInsertionPointAfter(ifOp);
6984 mlir::Value sSign = IntrinsicLibrary::genIeeeSignbit(intType, {args[1]});
6985 valueUp = builder.create<mlir::arith::CmpIOp>(
6986 loc, mlir::arith::CmpIPredicate::ne, sSign, one);
6987 } else if constexpr (proc == NearestProc::NextAfter) {
6988 // Convert X and Y to a common type to allow comparison. Direct conversions
6989 // between kinds 2, 3, 10, and 16 are not all supported. These conversions
6990 // are implemented by converting kind=2,3 values to kind=4, possibly
6991 // followed with a conversion of that value to a larger type.
6992 mlir::Value x1 = x;
6993 mlir::Value y = args[1];
6994 mlir::FloatType yType = mlir::dyn_cast<mlir::FloatType>(args[1].getType());
6995 const unsigned yBitWidth = yType.getWidth();
6996 if (xType != yType) {
6997 mlir::Type f32Ty = mlir::Float32Type::get(builder.getContext());
6998 if (xBitWidth < 32)
6999 x1 = builder.createConvert(loc, f32Ty, x1);
7000 if (yBitWidth > 32 && yBitWidth > xBitWidth)
7001 x1 = builder.createConvert(loc, yType, x1);
7002 if (yBitWidth < 32)
7003 y = builder.createConvert(loc, f32Ty, y);
7004 if (xBitWidth > 32 && xBitWidth > yBitWidth)
7005 y = builder.createConvert(loc, xType, y);
7006 }
7007 resultIsX = builder.create<mlir::arith::OrIOp>(
7008 loc, resultIsX,
7009 builder.create<mlir::arith::CmpFOp>(
7010 loc, mlir::arith::CmpFPredicate::OEQ, x1, y));
7011 valueUp = builder.create<mlir::arith::CmpFOp>(
7012 loc, mlir::arith::CmpFPredicate::OLT, x1, y);
7013 } else if constexpr (proc == NearestProc::NextDown) {
7014 valueUp = builder.createBool(loc, false);
7015 } else if constexpr (proc == NearestProc::NextUp) {
7016 valueUp = builder.createBool(loc, true);
7017 }
7018 mlir::Value magnitudeUp = builder.create<mlir::arith::CmpIOp>(
7019 loc, mlir::arith::CmpIPredicate::ne, valueUp,
7020 IntrinsicLibrary::genIeeeSignbit(i1Ty, {args[0]}));
7021 resultIsX = builder.create<mlir::arith::OrIOp>(
7022 loc, resultIsX,
7023 builder.create<mlir::arith::AndIOp>(
7024 loc, genIsFPClass(i1Ty, x, infiniteTest), magnitudeUp));
7025
7026 // Result is X. (For ieee_next_after with isNan(Y), X has been set to a NaN.)
7027 fir::IfOp outerIfOp = builder.create<fir::IfOp>(loc, resultType, resultIsX,
7028 /*withElseRegion=*/true);
7029 builder.setInsertionPointToStart(&outerIfOp.getThenRegion().front());
7030 if constexpr (proc == NearestProc::NextDown || proc == NearestProc::NextUp)
7031 genRaiseExcept(_FORTRAN_RUNTIME_IEEE_INVALID,
7032 genIsFPClass(i1Ty, x, snanTest));
7033 builder.create<fir::ResultOp>(loc, x);
7034
7035 // Result is minPositiveSubnormal or minNegativeSubnormal. (X is zero.)
7036 builder.setInsertionPointToStart(&outerIfOp.getElseRegion().front());
7037 mlir::Value resultIsMinSubnormal = builder.create<mlir::arith::CmpFOp>(
7038 loc, mlir::arith::CmpFPredicate::OEQ, x,
7039 builder.createRealZeroConstant(loc, xType));
7040 fir::IfOp innerIfOp =
7041 builder.create<fir::IfOp>(loc, resultType, resultIsMinSubnormal,
7042 /*withElseRegion=*/true);
7043 builder.setInsertionPointToStart(&innerIfOp.getThenRegion().front());
7044 mlir::Value minPositiveSubnormal =
7045 builder.create<mlir::arith::BitcastOp>(loc, resultType, one);
7046 mlir::Value minNegativeSubnormal = builder.create<mlir::arith::BitcastOp>(
7047 loc, resultType,
7048 builder.create<mlir::arith::ConstantOp>(
7049 loc, intType,
7050 builder.getIntegerAttr(
7051 intType, llvm::APInt::getBitsSetWithWrap(
7052 xBitWidth, /*lo=*/xBitWidth - 1, /*hi=*/1))));
7053 mlir::Value result = builder.create<mlir::arith::SelectOp>(
7054 loc, valueUp, minPositiveSubnormal, minNegativeSubnormal);
7055 if constexpr (proc == NearestProc::Nearest || proc == NearestProc::NextAfter)
7056 genRaiseExcept(_FORTRAN_RUNTIME_IEEE_UNDERFLOW |
7057 _FORTRAN_RUNTIME_IEEE_INEXACT);
7058 builder.create<fir::ResultOp>(loc, result);
7059
7060 // Result is (X + minPositiveSubnormal) or (X - minPositiveSubnormal).
7061 builder.setInsertionPointToStart(&innerIfOp.getElseRegion().front());
7062 if (xBitWidth == 80) {
7063 // Kind 10. Call std::nextafter, which generates exceptions as required
7064 // for ieee_next_after and nearest. Override this exception processing
7065 // for ieee_next_down and ieee_next_up.
7066 constexpr bool overrideExceptionGeneration =
7067 proc == NearestProc::NextDown || proc == NearestProc::NextUp;
7068 [[maybe_unused]] mlir::Type i32Ty;
7069 [[maybe_unused]] mlir::Value allExcepts, excepts, mask;
7070 if constexpr (overrideExceptionGeneration) {
7071 i32Ty = builder.getIntegerType(32);
7072 allExcepts = fir::runtime::genMapExcept(
7073 builder, loc,
7074 builder.createIntegerConstant(loc, i32Ty, _FORTRAN_RUNTIME_IEEE_ALL));
7075 excepts = genRuntimeCall("fetestexcept", i32Ty, allExcepts);
7076 mask = genRuntimeCall("fedisableexcept", i32Ty, allExcepts);
7077 }
7078 result = fir::runtime::genNearest(builder, loc, x, valueUp);
7079 if constexpr (overrideExceptionGeneration) {
7080 genRuntimeCall("feclearexcept", i32Ty, allExcepts);
7081 genRuntimeCall("feraiseexcept", i32Ty, excepts);
7082 genRuntimeCall("feenableexcept", i32Ty, mask);
7083 }
7084 builder.create<fir::ResultOp>(loc, result);
7085 } else {
7086 // Kind 2, 3, 4, 8, 16. Increment or decrement X cast to integer.
7087 mlir::Value intX = builder.create<mlir::arith::BitcastOp>(loc, intType, x);
7088 mlir::Value add = builder.create<mlir::arith::AddIOp>(loc, intX, one);
7089 mlir::Value sub = builder.create<mlir::arith::SubIOp>(loc, intX, one);
7090 result = builder.create<mlir::arith::BitcastOp>(
7091 loc, resultType,
7092 builder.create<mlir::arith::SelectOp>(loc, magnitudeUp, add, sub));
7093 if constexpr (proc == NearestProc::Nearest ||
7094 proc == NearestProc::NextAfter) {
7095 genRaiseExcept(_FORTRAN_RUNTIME_IEEE_OVERFLOW |
7096 _FORTRAN_RUNTIME_IEEE_INEXACT,
7097 genIsFPClass(i1Ty, result, infiniteTest));
7098 genRaiseExcept(_FORTRAN_RUNTIME_IEEE_UNDERFLOW |
7099 _FORTRAN_RUNTIME_IEEE_INEXACT,
7100 genIsFPClass(i1Ty, result, subnormalTest));
7101 }
7102 builder.create<fir::ResultOp>(loc, result);
7103 }
7104
7105 builder.setInsertionPointAfter(innerIfOp);
7106 builder.create<fir::ResultOp>(loc, innerIfOp.getResult(0));
7107 builder.setInsertionPointAfter(outerIfOp);
7108 return outerIfOp.getResult(0);
7109}
7110
7111// NINT
7112mlir::Value IntrinsicLibrary::genNint(mlir::Type resultType,
7113 llvm::ArrayRef<mlir::Value> args) {
7114 assert(args.size() >= 1);
7115 // Skip optional kind argument to search the runtime; it is already reflected
7116 // in result type.
7117 return genRuntimeCall("nint", resultType, {args[0]});
7118}
7119
7120// NORM2
7121fir::ExtendedValue
7122IntrinsicLibrary::genNorm2(mlir::Type resultType,
7123 llvm::ArrayRef<fir::ExtendedValue> args) {
7124 assert(args.size() == 2);
7125
7126 // Handle required array argument
7127 mlir::Value array = builder.createBox(loc, args[0]);
7128 unsigned rank = fir::BoxValue(array).rank();
7129 assert(rank >= 1);
7130
7131 // Check if the dim argument is present
7132 bool absentDim = isStaticallyAbsent(args[1]);
7133
7134 // If dim argument is absent or the array is rank 1, then the result is
7135 // a scalar (since the the result is rank-1 or 0). Otherwise, the result is
7136 // an array.
7137 if (absentDim || rank == 1) {
7138 return fir::runtime::genNorm2(builder, loc, array);
7139 } else {
7140 // Create mutable fir.box to be passed to the runtime for the result.
7141 mlir::Type resultArrayType = builder.getVarLenSeqTy(resultType, rank - 1);
7142 fir::MutableBoxValue resultMutableBox =
7143 fir::factory::createTempMutableBox(builder, loc, resultArrayType);
7144 mlir::Value resultIrBox =
7145 fir::factory::getMutableIRBox(builder, loc, resultMutableBox);
7146
7147 mlir::Value dim = fir::getBase(args[1]);
7148 fir::runtime::genNorm2Dim(builder, loc, resultIrBox, array, dim);
7149 // Handle cleanup of allocatable result descriptor and return
7150 return readAndAddCleanUp(resultMutableBox, resultType, "NORM2");
7151 }
7152}
7153
7154// NOT
7155mlir::Value IntrinsicLibrary::genNot(mlir::Type resultType,
7156 llvm::ArrayRef<mlir::Value> args) {
7157 assert(args.size() == 1);
7158 mlir::Type signlessType = mlir::IntegerType::get(
7159 builder.getContext(), resultType.getIntOrFloatBitWidth(),
7160 mlir::IntegerType::SignednessSemantics::Signless);
7161 mlir::Value allOnes = builder.createAllOnesInteger(loc, signlessType);
7162 return builder.createUnsigned<mlir::arith::XOrIOp>(loc, resultType, args[0],
7163 allOnes);
7164}
7165
7166// NULL
7167fir::ExtendedValue
7168IntrinsicLibrary::genNull(mlir::Type, llvm::ArrayRef<fir::ExtendedValue> args) {
7169 // NULL() without MOLD must be handled in the contexts where it can appear
7170 // (see table 16.5 of Fortran 2018 standard).
7171 assert(args.size() == 1 && isStaticallyPresent(args[0]) &&
7172 "MOLD argument required to lower NULL outside of any context");
7173 mlir::Type ptrTy = fir::getBase(args[0]).getType();
7174 if (ptrTy && fir::isBoxProcAddressType(ptrTy)) {
7175 auto boxProcType = mlir::cast<fir::BoxProcType>(fir::unwrapRefType(ptrTy));
7176 mlir::Value boxStorage = builder.createTemporary(loc, boxProcType);
7177 mlir::Value nullBoxProc =
7178 fir::factory::createNullBoxProc(builder, loc, boxProcType);
7179 builder.createStoreWithConvert(loc, nullBoxProc, boxStorage);
7180 return boxStorage;
7181 }
7182 const auto *mold = args[0].getBoxOf<fir::MutableBoxValue>();
7183 assert(mold && "MOLD must be a pointer or allocatable");
7184 fir::BaseBoxType boxType = mold->getBoxTy();
7185 mlir::Value boxStorage = builder.createTemporary(loc, boxType);
7186 mlir::Value box = fir::factory::createUnallocatedBox(
7187 builder, loc, boxType, mold->nonDeferredLenParams());
7188 builder.create<fir::StoreOp>(loc, box, boxStorage);
7189 return fir::MutableBoxValue(boxStorage, mold->nonDeferredLenParams(), {});
7190}
7191
7192// PACK
7193fir::ExtendedValue
7194IntrinsicLibrary::genPack(mlir::Type resultType,
7195 llvm::ArrayRef<fir::ExtendedValue> args) {
7196 [[maybe_unused]] auto numArgs = args.size();
7197 assert(numArgs == 2 || numArgs == 3);
7198
7199 // Handle required array argument
7200 mlir::Value array = builder.createBox(loc, args[0]);
7201
7202 // Handle required mask argument
7203 mlir::Value mask = builder.createBox(loc, args[1]);
7204
7205 // Handle optional vector argument
7206 mlir::Value vector = isStaticallyAbsent(args, 2)
7207 ? builder.create<fir::AbsentOp>(
7208 loc, fir::BoxType::get(builder.getI1Type()))
7209 : builder.createBox(loc, args[2]);
7210
7211 // Create mutable fir.box to be passed to the runtime for the result.
7212 mlir::Type resultArrayType = builder.getVarLenSeqTy(resultType, 1);
7213 fir::MutableBoxValue resultMutableBox = fir::factory::createTempMutableBox(
7214 builder, loc, resultArrayType, {},
7215 fir::isPolymorphicType(array.getType()) ? array : mlir::Value{});
7216 mlir::Value resultIrBox =
7217 fir::factory::getMutableIRBox(builder, loc, resultMutableBox);
7218
7219 fir::runtime::genPack(builder, loc, resultIrBox, array, mask, vector);
7220
7221 return readAndAddCleanUp(resultMutableBox, resultType, "PACK");
7222}
7223
7224// PARITY
7225fir::ExtendedValue
7226IntrinsicLibrary::genParity(mlir::Type resultType,
7227 llvm::ArrayRef<fir::ExtendedValue> args) {
7228
7229 assert(args.size() == 2);
7230 // Handle required mask argument
7231 mlir::Value mask = builder.createBox(loc, args[0]);
7232
7233 fir::BoxValue maskArry = builder.createBox(loc, args[0]);
7234 int rank = maskArry.rank();
7235 assert(rank >= 1);
7236
7237 // Handle optional dim argument
7238 bool absentDim = isStaticallyAbsent(args[1]);
7239 mlir::Value dim =
7240 absentDim ? builder.createIntegerConstant(loc, builder.getIndexType(), 1)
7241 : fir::getBase(args[1]);
7242
7243 if (rank == 1 || absentDim)
7244 return builder.createConvert(
7245 loc, resultType, fir::runtime::genParity(builder, loc, mask, dim));
7246
7247 // else use the result descriptor ParityDim() intrinsic
7248
7249 // Create mutable fir.box to be passed to the runtime for the result.
7250
7251 mlir::Type resultArrayType = builder.getVarLenSeqTy(resultType, rank - 1);
7252 fir::MutableBoxValue resultMutableBox =
7253 fir::factory::createTempMutableBox(builder, loc, resultArrayType);
7254 mlir::Value resultIrBox =
7255 fir::factory::getMutableIRBox(builder, loc, resultMutableBox);
7256
7257 // Call runtime. The runtime is allocating the result.
7258 fir::runtime::genParityDescriptor(builder, loc, resultIrBox, mask, dim);
7259 return readAndAddCleanUp(resultMutableBox, resultType, "PARITY");
7260}
7261
7262// PERROR
7263void IntrinsicLibrary::genPerror(llvm::ArrayRef<fir::ExtendedValue> args) {
7264 assert(args.size() == 1);
7265
7266 fir::ExtendedValue str = args[0];
7267 const auto *box = str.getBoxOf<fir::BoxValue>();
7268 mlir::Value addr =
7269 builder.create<fir::BoxAddrOp>(loc, box->getMemTy(), fir::getBase(*box));
7270 fir::runtime::genPerror(builder, loc, addr);
7271}
7272
7273// POPCNT
7274mlir::Value IntrinsicLibrary::genPopcnt(mlir::Type resultType,
7275 llvm::ArrayRef<mlir::Value> args) {
7276 assert(args.size() == 1);
7277
7278 mlir::Value count = builder.create<mlir::math::CtPopOp>(loc, args);
7279
7280 return builder.createConvert(loc, resultType, count);
7281}
7282
7283// POPPAR
7284mlir::Value IntrinsicLibrary::genPoppar(mlir::Type resultType,
7285 llvm::ArrayRef<mlir::Value> args) {
7286 assert(args.size() == 1);
7287
7288 mlir::Value count = genPopcnt(resultType, args);
7289 mlir::Value one = builder.createIntegerConstant(loc, resultType, 1);
7290
7291 return builder.create<mlir::arith::AndIOp>(loc, count, one);
7292}
7293
7294// PRESENT
7295fir::ExtendedValue
7296IntrinsicLibrary::genPresent(mlir::Type,
7297 llvm::ArrayRef<fir::ExtendedValue> args) {
7298 assert(args.size() == 1);
7299 return builder.create<fir::IsPresentOp>(loc, builder.getI1Type(),
7300 fir::getBase(args[0]));
7301}
7302
7303// PRODUCT
7304fir::ExtendedValue
7305IntrinsicLibrary::genProduct(mlir::Type resultType,
7306 llvm::ArrayRef<fir::ExtendedValue> args) {
7307 return genReduction(fir::runtime::genProduct, fir::runtime::genProductDim,
7308 "PRODUCT", resultType, args);
7309}
7310
7311// PUTENV
7312fir::ExtendedValue
7313IntrinsicLibrary::genPutenv(std::optional<mlir::Type> resultType,
7314 llvm::ArrayRef<fir::ExtendedValue> args) {
7315 assert((resultType.has_value() && args.size() == 1) ||
7316 (!resultType.has_value() && args.size() >= 1 && args.size() <= 2));
7317
7318 mlir::Value str = fir::getBase(args[0]);
7319 mlir::Value strLength = fir::getLen(args[0]);
7320 mlir::Value statusValue =
7321 fir::runtime::genPutEnv(builder, loc, str, strLength);
7322
7323 if (resultType.has_value()) {
7324 // Function form, return status.
7325 return builder.createConvert(loc, *resultType, statusValue);
7326 }
7327
7328 // Subroutine form, store status and return none.
7329 const fir::ExtendedValue &status = args[1];
7330 if (!isStaticallyAbsent(status)) {
7331 mlir::Value statusAddr = fir::getBase(status);
7332 mlir::Value statusIsPresentAtRuntime =
7333 builder.genIsNotNullAddr(loc, statusAddr);
7334 builder.genIfThen(loc, statusIsPresentAtRuntime)
7335 .genThen([&]() {
7336 builder.createStoreWithConvert(loc, statusValue, statusAddr);
7337 })
7338 .end();
7339 }
7340
7341 return {};
7342}
7343
7344// RANDOM_INIT
7345void IntrinsicLibrary::genRandomInit(llvm::ArrayRef<fir::ExtendedValue> args) {
7346 assert(args.size() == 2);
7347 fir::runtime::genRandomInit(builder, loc, fir::getBase(args[0]),
7348 fir::getBase(args[1]));
7349}
7350
7351// RANDOM_NUMBER
7352void IntrinsicLibrary::genRandomNumber(
7353 llvm::ArrayRef<fir::ExtendedValue> args) {
7354 assert(args.size() == 1);
7355 fir::runtime::genRandomNumber(builder, loc, fir::getBase(args[0]));
7356}
7357
7358// RANDOM_SEED
7359void IntrinsicLibrary::genRandomSeed(llvm::ArrayRef<fir::ExtendedValue> args) {
7360 assert(args.size() == 3);
7361 mlir::Type boxNoneTy = fir::BoxType::get(builder.getNoneType());
7362 auto getDesc = [&](int i) {
7363 return isStaticallyPresent(args[i])
7364 ? fir::getBase(args[i])
7365 : builder.create<fir::AbsentOp>(loc, boxNoneTy).getResult();
7366 };
7367 mlir::Value size = getDesc(0);
7368 mlir::Value put = getDesc(1);
7369 mlir::Value get = getDesc(2);
7370 fir::runtime::genRandomSeed(builder, loc, size, put, get);
7371}
7372
7373// REDUCE
7374fir::ExtendedValue
7375IntrinsicLibrary::genReduce(mlir::Type resultType,
7376 llvm::ArrayRef<fir::ExtendedValue> args) {
7377 assert(args.size() == 6);
7378
7379 fir::BoxValue arrayTmp = builder.createBox(loc, args[0]);
7380 mlir::Value array = fir::getBase(arrayTmp);
7381 mlir::Value operation = fir::getBase(args[1]);
7382 int rank = arrayTmp.rank();
7383 assert(rank >= 1);
7384
7385 // Arguements to the reduction operation are passed by reference or value?
7386 bool argByRef = true;
7387 if (!operation.getDefiningOp())
7388 TODO(loc, "Distinguigh dummy procedure arguments");
7389 if (auto embox =
7390 mlir::dyn_cast_or_null<fir::EmboxProcOp>(operation.getDefiningOp())) {
7391 auto fctTy = mlir::dyn_cast<mlir::FunctionType>(embox.getFunc().getType());
7392 argByRef = mlir::isa<fir::ReferenceType>(fctTy.getInput(0));
7393 } else if (auto load = mlir::dyn_cast_or_null<fir::LoadOp>(
7394 operation.getDefiningOp())) {
7395 auto boxProcTy = mlir::dyn_cast_or_null<fir::BoxProcType>(load.getType());
7396 assert(boxProcTy && "expect BoxProcType");
7397 auto fctTy = mlir::dyn_cast<mlir::FunctionType>(boxProcTy.getEleTy());
7398 argByRef = mlir::isa<fir::ReferenceType>(fctTy.getInput(0));
7399 }
7400
7401 mlir::Type ty = array.getType();
7402 mlir::Type arrTy = fir::dyn_cast_ptrOrBoxEleTy(ty);
7403 mlir::Type eleTy = mlir::cast<fir::SequenceType>(arrTy).getElementType();
7404
7405 // Handle optional arguments
7406 bool absentDim = isStaticallyAbsent(args[2]);
7407
7408 auto mask = isStaticallyAbsent(args[3])
7409 ? builder.create<fir::AbsentOp>(
7410 loc, fir::BoxType::get(builder.getI1Type()))
7411 : builder.createBox(loc, args[3]);
7412
7413 mlir::Value identity =
7414 isStaticallyAbsent(args[4])
7415 ? builder.create<fir::AbsentOp>(loc, fir::ReferenceType::get(eleTy))
7416 : fir::getBase(args[4]);
7417
7418 mlir::Value ordered = isStaticallyAbsent(args[5])
7419 ? builder.createBool(loc, false)
7420 : fir::getBase(args[5]);
7421
7422 // We call the type specific versions because the result is scalar
7423 // in the case below.
7424 if (absentDim || rank == 1) {
7425 if (fir::isa_complex(eleTy) || fir::isa_derived(eleTy)) {
7426 mlir::Value result = builder.createTemporary(loc, eleTy);
7427 fir::runtime::genReduce(builder, loc, array, operation, mask, identity,
7428 ordered, result, argByRef);
7429 if (fir::isa_derived(eleTy))
7430 return result;
7431 return builder.create<fir::LoadOp>(loc, result);
7432 }
7433 if (fir::isa_char(eleTy)) {
7434 auto charTy = mlir::dyn_cast_or_null<fir::CharacterType>(resultType);
7435 assert(charTy && "expect CharacterType");
7436 fir::factory::CharacterExprHelper charHelper(builder, loc);
7437 mlir::Value len;
7438 if (charTy.hasDynamicLen())
7439 len = charHelper.readLengthFromBox(fir::getBase(arrayTmp), charTy);
7440 else
7441 len = builder.createIntegerConstant(loc, builder.getI32Type(),
7442 charTy.getLen());
7443 fir::CharBoxValue temp = charHelper.createCharacterTemp(eleTy, len);
7444 fir::runtime::genReduce(builder, loc, array, operation, mask, identity,
7445 ordered, temp.getBuffer(), argByRef);
7446 return temp;
7447 }
7448 return fir::runtime::genReduce(builder, loc, array, operation, mask,
7449 identity, ordered, argByRef);
7450 }
7451 // Handle cases that have an array result.
7452 // Create mutable fir.box to be passed to the runtime for the result.
7453 mlir::Type resultArrayType = builder.getVarLenSeqTy(resultType, rank - 1);
7454 fir::MutableBoxValue resultMutableBox =
7455 fir::factory::createTempMutableBox(builder, loc, resultArrayType);
7456 mlir::Value resultIrBox =
7457 fir::factory::getMutableIRBox(builder, loc, resultMutableBox);
7458 mlir::Value dim = fir::getBase(args[2]);
7459 fir::runtime::genReduceDim(builder, loc, array, operation, dim, mask,
7460 identity, ordered, resultIrBox, argByRef);
7461 return readAndAddCleanUp(resultMutableBox, resultType, "REDUCE");
7462}
7463
7464// RENAME
7465fir::ExtendedValue
7466IntrinsicLibrary::genRename(std::optional<mlir::Type> resultType,
7467 mlir::ArrayRef<fir::ExtendedValue> args) {
7468 assert((args.size() == 3 && !resultType.has_value()) ||
7469 (args.size() == 2 && resultType.has_value()));
7470
7471 mlir::Value path1 = fir::getBase(args[0]);
7472 mlir::Value path2 = fir::getBase(args[1]);
7473 if (!path1 || !path2)
7474 fir::emitFatalError(loc, "Expected at least two dummy arguments");
7475
7476 if (resultType.has_value()) {
7477 // code-gen for the function form of RENAME
7478 auto statusAddr = builder.createTemporary(loc, *resultType);
7479 auto statusBox = builder.createBox(loc, statusAddr);
7480 fir::runtime::genRename(builder, loc, path1, path2, statusBox);
7481 return builder.create<fir::LoadOp>(loc, statusAddr);
7482 } else {
7483 // code-gen for the procedure form of RENAME
7484 mlir::Type boxNoneTy = fir::BoxType::get(builder.getNoneType());
7485 auto status = args[2];
7486 mlir::Value statusBox =
7487 isStaticallyPresent(status)
7488 ? fir::getBase(status)
7489 : builder.create<fir::AbsentOp>(loc, boxNoneTy).getResult();
7490 fir::runtime::genRename(builder, loc, path1, path2, statusBox);
7491 return {};
7492 }
7493}
7494
7495// REPEAT
7496fir::ExtendedValue
7497IntrinsicLibrary::genRepeat(mlir::Type resultType,
7498 llvm::ArrayRef<fir::ExtendedValue> args) {
7499 assert(args.size() == 2);
7500 mlir::Value string = builder.createBox(loc, args[0]);
7501 mlir::Value ncopies = fir::getBase(args[1]);
7502 // Create mutable fir.box to be passed to the runtime for the result.
7503 fir::MutableBoxValue resultMutableBox =
7504 fir::factory::createTempMutableBox(builder, loc, resultType);
7505 mlir::Value resultIrBox =
7506 fir::factory::getMutableIRBox(builder, loc, resultMutableBox);
7507 // Call runtime. The runtime is allocating the result.
7508 fir::runtime::genRepeat(builder, loc, resultIrBox, string, ncopies);
7509 // Read result from mutable fir.box and add it to the list of temps to be
7510 // finalized by the StatementContext.
7511 return readAndAddCleanUp(resultMutableBox, resultType, "REPEAT");
7512}
7513
7514// RESHAPE
7515fir::ExtendedValue
7516IntrinsicLibrary::genReshape(mlir::Type resultType,
7517 llvm::ArrayRef<fir::ExtendedValue> args) {
7518 assert(args.size() == 4);
7519
7520 // Handle source argument
7521 mlir::Value source = builder.createBox(loc, args[0]);
7522
7523 // Handle shape argument
7524 mlir::Value shape = builder.createBox(loc, args[1]);
7525 assert(fir::BoxValue(shape).rank() == 1);
7526 mlir::Type shapeTy = shape.getType();
7527 mlir::Type shapeArrTy = fir::dyn_cast_ptrOrBoxEleTy(shapeTy);
7528 auto resultRank = mlir::cast<fir::SequenceType>(shapeArrTy).getShape()[0];
7529
7530 if (resultRank == fir::SequenceType::getUnknownExtent())
7531 TODO(loc, "intrinsic: reshape requires computing rank of result");
7532
7533 // Handle optional pad argument
7534 mlir::Value pad = isStaticallyAbsent(args[2])
7535 ? builder.create<fir::AbsentOp>(
7536 loc, fir::BoxType::get(builder.getI1Type()))
7537 : builder.createBox(loc, args[2]);
7538
7539 // Handle optional order argument
7540 mlir::Value order = isStaticallyAbsent(args[3])
7541 ? builder.create<fir::AbsentOp>(
7542 loc, fir::BoxType::get(builder.getI1Type()))
7543 : builder.createBox(loc, args[3]);
7544
7545 // Create mutable fir.box to be passed to the runtime for the result.
7546 mlir::Type type = builder.getVarLenSeqTy(resultType, resultRank);
7547 fir::MutableBoxValue resultMutableBox = fir::factory::createTempMutableBox(
7548 builder, loc, type, {},
7549 fir::isPolymorphicType(source.getType()) ? source : mlir::Value{});
7550
7551 mlir::Value resultIrBox =
7552 fir::factory::getMutableIRBox(builder, loc, resultMutableBox);
7553
7554 fir::runtime::genReshape(builder, loc, resultIrBox, source, shape, pad,
7555 order);
7556
7557 return readAndAddCleanUp(resultMutableBox, resultType, "RESHAPE");
7558}
7559
7560// RRSPACING
7561mlir::Value IntrinsicLibrary::genRRSpacing(mlir::Type resultType,
7562 llvm::ArrayRef<mlir::Value> args) {
7563 assert(args.size() == 1);
7564
7565 return builder.createConvert(
7566 loc, resultType,
7567 fir::runtime::genRRSpacing(builder, loc, fir::getBase(args[0])));
7568}
7569
7570// ERFC_SCALED
7571mlir::Value IntrinsicLibrary::genErfcScaled(mlir::Type resultType,
7572 llvm::ArrayRef<mlir::Value> args) {
7573 assert(args.size() == 1);
7574
7575 return builder.createConvert(
7576 loc, resultType,
7577 fir::runtime::genErfcScaled(builder, loc, fir::getBase(args[0])));
7578}
7579
7580// SAME_TYPE_AS
7581fir::ExtendedValue
7582IntrinsicLibrary::genSameTypeAs(mlir::Type resultType,
7583 llvm::ArrayRef<fir::ExtendedValue> args) {
7584 assert(args.size() == 2);
7585
7586 return builder.createConvert(
7587 loc, resultType,
7588 fir::runtime::genSameTypeAs(builder, loc, fir::getBase(args[0]),
7589 fir::getBase(args[1])));
7590}
7591
7592// SCALE
7593mlir::Value IntrinsicLibrary::genScale(mlir::Type resultType,
7594 llvm::ArrayRef<mlir::Value> args) {
7595 assert(args.size() == 2);
7596 mlir::FloatType floatTy = mlir::dyn_cast<mlir::FloatType>(resultType);
7597 if (!floatTy.isF16() && !floatTy.isBF16()) // kind=4,8,10,16
7598 return builder.createConvert(
7599 loc, resultType,
7600 fir::runtime::genScale(builder, loc, args[0], args[1]));
7601
7602 // Convert kind=2,3 arg X to kind=4. Convert kind=4 result back to kind=2,3.
7603 mlir::Type i1Ty = builder.getI1Type();
7604 mlir::Type f32Ty = mlir::Float32Type::get(builder.getContext());
7605 mlir::Value result = builder.createConvert(
7606 loc, resultType,
7607 fir::runtime::genScale(
7608 builder, loc, builder.createConvert(loc, f32Ty, args[0]), args[1]));
7609
7610 // kind=4 runtime::genScale call may not signal kind=2,3 exceptions.
7611 // If X is finite and result is infinite, signal IEEE_OVERFLOW
7612 // If X is finite and scale(result, -I) != X, signal IEEE_UNDERFLOW
7613 fir::IfOp outerIfOp =
7614 builder.create<fir::IfOp>(loc, genIsFPClass(i1Ty, args[0], finiteTest),
7615 /*withElseRegion=*/false);
7616 builder.setInsertionPointToStart(&outerIfOp.getThenRegion().front());
7617 fir::IfOp innerIfOp =
7618 builder.create<fir::IfOp>(loc, genIsFPClass(i1Ty, result, infiniteTest),
7619 /*withElseRegion=*/true);
7620 builder.setInsertionPointToStart(&innerIfOp.getThenRegion().front());
7621 genRaiseExcept(_FORTRAN_RUNTIME_IEEE_OVERFLOW |
7622 _FORTRAN_RUNTIME_IEEE_INEXACT);
7623 builder.setInsertionPointToStart(&innerIfOp.getElseRegion().front());
7624 mlir::Value minusI = builder.create<mlir::arith::MulIOp>(
7625 loc, args[1], builder.createAllOnesInteger(loc, args[1].getType()));
7626 mlir::Value reverseResult = builder.createConvert(
7627 loc, resultType,
7628 fir::runtime::genScale(
7629 builder, loc, builder.createConvert(loc, f32Ty, result), minusI));
7630 genRaiseExcept(
7631 _FORTRAN_RUNTIME_IEEE_UNDERFLOW | _FORTRAN_RUNTIME_IEEE_INEXACT,
7632 builder.create<mlir::arith::CmpFOp>(loc, mlir::arith::CmpFPredicate::ONE,
7633 args[0], reverseResult));
7634 builder.setInsertionPointAfter(outerIfOp);
7635 return result;
7636}
7637
7638// SCAN
7639fir::ExtendedValue
7640IntrinsicLibrary::genScan(mlir::Type resultType,
7641 llvm::ArrayRef<fir::ExtendedValue> args) {
7642
7643 assert(args.size() == 4);
7644
7645 if (isStaticallyAbsent(args[3])) {
7646 // Kind not specified, so call scan/verify runtime routine that is
7647 // specialized on the kind of characters in string.
7648
7649 // Handle required string base arg
7650 mlir::Value stringBase = fir::getBase(args[0]);
7651
7652 // Handle required set string base arg
7653 mlir::Value setBase = fir::getBase(args[1]);
7654
7655 // Handle kind argument; it is the kind of character in this case
7656 fir::KindTy kind =
7657 fir::factory::CharacterExprHelper{builder, loc}.getCharacterKind(
7658 stringBase.getType());
7659
7660 // Get string length argument
7661 mlir::Value stringLen = fir::getLen(args[0]);
7662
7663 // Get set string length argument
7664 mlir::Value setLen = fir::getLen(args[1]);
7665
7666 // Handle optional back argument
7667 mlir::Value back =
7668 isStaticallyAbsent(args[2])
7669 ? builder.createIntegerConstant(loc, builder.getI1Type(), 0)
7670 : fir::getBase(args[2]);
7671
7672 return builder.createConvert(loc, resultType,
7673 fir::runtime::genScan(builder, loc, kind,
7674 stringBase, stringLen,
7675 setBase, setLen, back));
7676 }
7677 // else use the runtime descriptor version of scan/verify
7678
7679 // Handle optional argument, back
7680 auto makeRefThenEmbox = [&](mlir::Value b) {
7681 fir::LogicalType logTy = fir::LogicalType::get(
7682 builder.getContext(), builder.getKindMap().defaultLogicalKind());
7683 mlir::Value temp = builder.createTemporary(loc, logTy);
7684 mlir::Value castb = builder.createConvert(loc, logTy, b);
7685 builder.create<fir::StoreOp>(loc, castb, temp);
7686 return builder.createBox(loc, temp);
7687 };
7688 mlir::Value back = fir::isUnboxedValue(args[2])
7689 ? makeRefThenEmbox(*args[2].getUnboxed())
7690 : builder.create<fir::AbsentOp>(
7691 loc, fir::BoxType::get(builder.getI1Type()));
7692
7693 // Handle required string argument
7694 mlir::Value string = builder.createBox(loc, args[0]);
7695
7696 // Handle required set argument
7697 mlir::Value set = builder.createBox(loc, args[1]);
7698
7699 // Handle kind argument
7700 mlir::Value kind = fir::getBase(args[3]);
7701
7702 // Create result descriptor
7703 fir::MutableBoxValue resultMutableBox =
7704 fir::factory::createTempMutableBox(builder, loc, resultType);
7705 mlir::Value resultIrBox =
7706 fir::factory::getMutableIRBox(builder, loc, resultMutableBox);
7707
7708 fir::runtime::genScanDescriptor(builder, loc, resultIrBox, string, set, back,
7709 kind);
7710
7711 // Handle cleanup of allocatable result descriptor and return
7712 return readAndAddCleanUp(resultMutableBox, resultType, "SCAN");
7713}
7714
7715// SECOND
7716fir::ExtendedValue
7717IntrinsicLibrary::genSecond(std::optional<mlir::Type> resultType,
7718 mlir::ArrayRef<fir::ExtendedValue> args) {
7719 assert((args.size() == 1 && !resultType) || (args.empty() && resultType));
7720
7721 fir::ExtendedValue result;
7722
7723 if (resultType)
7724 result = builder.createTemporary(loc, *resultType);
7725 else
7726 result = args[0];
7727
7728 llvm::SmallVector<fir::ExtendedValue, 1> subroutineArgs(1, result);
7729 genCpuTime(subroutineArgs);
7730
7731 if (resultType)
7732 return builder.create<fir::LoadOp>(loc, fir::getBase(result));
7733 return {};
7734}
7735
7736// SELECTED_CHAR_KIND
7737fir::ExtendedValue
7738IntrinsicLibrary::genSelectedCharKind(mlir::Type resultType,
7739 llvm::ArrayRef<fir::ExtendedValue> args) {
7740 assert(args.size() == 1);
7741
7742 return builder.createConvert(
7743 loc, resultType,
7744 fir::runtime::genSelectedCharKind(builder, loc, fir::getBase(args[0]),
7745 fir::getLen(args[0])));
7746}
7747
7748// SELECTED_INT_KIND
7749mlir::Value
7750IntrinsicLibrary::genSelectedIntKind(mlir::Type resultType,
7751 llvm::ArrayRef<mlir::Value> args) {
7752 assert(args.size() == 1);
7753
7754 return builder.createConvert(
7755 loc, resultType,
7756 fir::runtime::genSelectedIntKind(builder, loc, fir::getBase(args[0])));
7757}
7758
7759// SELECTED_LOGICAL_KIND
7760mlir::Value
7761IntrinsicLibrary::genSelectedLogicalKind(mlir::Type resultType,
7762 llvm::ArrayRef<mlir::Value> args) {
7763 assert(args.size() == 1);
7764
7765 return builder.createConvert(loc, resultType,
7766 fir::runtime::genSelectedLogicalKind(
7767 builder, loc, fir::getBase(args[0])));
7768}
7769
7770// SELECTED_REAL_KIND
7771mlir::Value
7772IntrinsicLibrary::genSelectedRealKind(mlir::Type resultType,
7773 llvm::ArrayRef<mlir::Value> args) {
7774 assert(args.size() == 3);
7775
7776 // Handle optional precision(P) argument
7777 mlir::Value precision =
7778 isStaticallyAbsent(args[0])
7779 ? builder.create<fir::AbsentOp>(
7780 loc, fir::ReferenceType::get(builder.getI1Type()))
7781 : fir::getBase(args[0]);
7782
7783 // Handle optional range(R) argument
7784 mlir::Value range =
7785 isStaticallyAbsent(args[1])
7786 ? builder.create<fir::AbsentOp>(
7787 loc, fir::ReferenceType::get(builder.getI1Type()))
7788 : fir::getBase(args[1]);
7789
7790 // Handle optional radix(RADIX) argument
7791 mlir::Value radix =
7792 isStaticallyAbsent(args[2])
7793 ? builder.create<fir::AbsentOp>(
7794 loc, fir::ReferenceType::get(builder.getI1Type()))
7795 : fir::getBase(args[2]);
7796
7797 return builder.createConvert(
7798 loc, resultType,
7799 fir::runtime::genSelectedRealKind(builder, loc, precision, range, radix));
7800}
7801
7802// SET_EXPONENT
7803mlir::Value IntrinsicLibrary::genSetExponent(mlir::Type resultType,
7804 llvm::ArrayRef<mlir::Value> args) {
7805 assert(args.size() == 2);
7806
7807 return builder.createConvert(
7808 loc, resultType,
7809 fir::runtime::genSetExponent(builder, loc, fir::getBase(args[0]),
7810 fir::getBase(args[1])));
7811}
7812
7813/// Create a fir.box to be passed to the LBOUND/UBOUND runtime.
7814/// This ensure that local lower bounds of assumed shape are propagated and that
7815/// a fir.box with equivalent LBOUNDs.
7816static mlir::Value
7817createBoxForRuntimeBoundInquiry(mlir::Location loc, fir::FirOpBuilder &builder,
7818 const fir::ExtendedValue &array) {
7819 // Assumed-rank descriptor must always carry accurate lower bound information
7820 // in lowering since they cannot be tracked on the side in a vector at compile
7821 // time.
7822 if (array.hasAssumedRank())
7823 return builder.createBox(loc, array);
7824
7825 return array.match(
7826 [&](const fir::BoxValue &boxValue) -> mlir::Value {
7827 // This entity is mapped to a fir.box that may not contain the local
7828 // lower bound information if it is a dummy. Rebox it with the local
7829 // shape information.
7830 mlir::Value localShape = builder.createShape(loc, array);
7831 mlir::Value oldBox = boxValue.getAddr();
7832 return builder.create<fir::ReboxOp>(loc, oldBox.getType(), oldBox,
7833 localShape,
7834 /*slice=*/mlir::Value{});
7835 },
7836 [&](const auto &) -> mlir::Value {
7837 // This is a pointer/allocatable, or an entity not yet tracked with a
7838 // fir.box. For pointer/allocatable, createBox will forward the
7839 // descriptor that contains the correct lower bound information. For
7840 // other entities, a new fir.box will be made with the local lower
7841 // bounds.
7842 return builder.createBox(loc, array);
7843 });
7844}
7845
7846/// Generate runtime call to inquire about all the bounds/extents of an
7847/// array (or an assumed-rank).
7848template <typename Func>
7849static fir::ExtendedValue
7850genBoundInquiry(fir::FirOpBuilder &builder, mlir::Location loc,
7851 mlir::Type resultType, llvm::ArrayRef<fir::ExtendedValue> args,
7852 int kindPos, Func genRtCall, bool needAccurateLowerBound) {
7853 const fir::ExtendedValue &array = args[0];
7854 const bool hasAssumedRank = array.hasAssumedRank();
7855 mlir::Type resultElementType = fir::unwrapSequenceType(resultType);
7856 // For assumed-rank arrays, allocate an array with the maximum rank, that is
7857 // big enough to hold the result but still "small" (15 elements). Static size
7858 // alloca make stack analysis/manipulation easier.
7859 int rank = hasAssumedRank ? Fortran::common::maxRank : array.rank();
7860 mlir::Type allocSeqType = fir::SequenceType::get(rank, resultElementType);
7861 mlir::Value resultStorage = builder.createTemporary(loc, allocSeqType);
7862 mlir::Value arrayBox =
7863 needAccurateLowerBound
7864 ? createBoxForRuntimeBoundInquiry(loc, builder, array)
7865 : builder.createBox(loc, array);
7866 mlir::Value kind = isStaticallyAbsent(args, kindPos)
7867 ? builder.createIntegerConstant(
7868 loc, builder.getI32Type(),
7869 builder.getKindMap().defaultIntegerKind())
7870 : fir::getBase(args[kindPos]);
7871 genRtCall(builder, loc, resultStorage, arrayBox, kind);
7872 if (hasAssumedRank) {
7873 // Cast to fir.ref<array<?xik>> since the result extent is not a compile
7874 // time constant.
7875 mlir::Type baseType =
7876 fir::ReferenceType::get(builder.getVarLenSeqTy(resultElementType));
7877 mlir::Value resultBase =
7878 builder.createConvert(loc, baseType, resultStorage);
7879 mlir::Value rankValue =
7880 builder.create<fir::BoxRankOp>(loc, builder.getIndexType(), arrayBox);
7881 return fir::ArrayBoxValue{resultBase, {rankValue}};
7882 }
7883 // Result extent is a compile time constant in the other cases.
7884 mlir::Value rankValue =
7885 builder.createIntegerConstant(loc, builder.getIndexType(), rank);
7886 return fir::ArrayBoxValue{resultStorage, {rankValue}};
7887}
7888
7889// SHAPE
7890fir::ExtendedValue
7891IntrinsicLibrary::genShape(mlir::Type resultType,
7892 llvm::ArrayRef<fir::ExtendedValue> args) {
7893 assert(args.size() >= 1);
7894 const fir::ExtendedValue &array = args[0];
7895 if (array.hasAssumedRank())
7896 return genBoundInquiry(builder, loc, resultType, args,
7897 /*kindPos=*/1, fir::runtime::genShape,
7898 /*needAccurateLowerBound=*/false);
7899 int rank = array.rank();
7900 mlir::Type indexType = builder.getIndexType();
7901 mlir::Type extentType = fir::unwrapSequenceType(resultType);
7902 mlir::Type seqType = fir::SequenceType::get(
7903 {static_cast<fir::SequenceType::Extent>(rank)}, extentType);
7904 mlir::Value shapeArray = builder.createTemporary(loc, seqType);
7905 mlir::Type shapeAddrType = builder.getRefType(extentType);
7906 for (int dim = 0; dim < rank; ++dim) {
7907 mlir::Value extent = fir::factory::readExtent(builder, loc, array, dim);
7908 extent = builder.createConvert(loc, extentType, extent);
7909 auto index = builder.createIntegerConstant(loc, indexType, dim);
7910 auto shapeAddr = builder.create<fir::CoordinateOp>(loc, shapeAddrType,
7911 shapeArray, index);
7912 builder.create<fir::StoreOp>(loc, extent, shapeAddr);
7913 }
7914 mlir::Value shapeArrayExtent =
7915 builder.createIntegerConstant(loc, indexType, rank);
7916 llvm::SmallVector<mlir::Value> extents{shapeArrayExtent};
7917 return fir::ArrayBoxValue{shapeArray, extents};
7918}
7919
7920// SHIFTL, SHIFTR
7921template <typename Shift>
7922mlir::Value IntrinsicLibrary::genShift(mlir::Type resultType,
7923 llvm::ArrayRef<mlir::Value> args) {
7924 assert(args.size() == 2);
7925
7926 // If SHIFT < 0 or SHIFT >= BIT_SIZE(I), return 0. This is not required by
7927 // the standard. However, several other compilers behave this way, so try and
7928 // maintain compatibility with them to an extent.
7929
7930 unsigned bits = resultType.getIntOrFloatBitWidth();
7931 mlir::Type signlessType =
7932 mlir::IntegerType::get(builder.getContext(), bits,
7933 mlir::IntegerType::SignednessSemantics::Signless);
7934 mlir::Value bitSize = builder.createIntegerConstant(loc, signlessType, bits);
7935 mlir::Value zero = builder.createIntegerConstant(loc, signlessType, 0);
7936 mlir::Value shift = builder.createConvert(loc, signlessType, args[1]);
7937
7938 mlir::Value tooSmall = builder.create<mlir::arith::CmpIOp>(
7939 loc, mlir::arith::CmpIPredicate::slt, shift, zero);
7940 mlir::Value tooLarge = builder.create<mlir::arith::CmpIOp>(
7941 loc, mlir::arith::CmpIPredicate::sge, shift, bitSize);
7942 mlir::Value outOfBounds =
7943 builder.create<mlir::arith::OrIOp>(loc, tooSmall, tooLarge);
7944 mlir::Value word = args[0];
7945 if (word.getType().isUnsignedInteger())
7946 word = builder.createConvert(loc, signlessType, word);
7947 mlir::Value shifted = builder.create<Shift>(loc, word, shift);
7948 mlir::Value result =
7949 builder.create<mlir::arith::SelectOp>(loc, outOfBounds, zero, shifted);
7950 if (resultType.isUnsignedInteger())
7951 return builder.createConvert(loc, resultType, result);
7952 return result;
7953}
7954
7955// SHIFTA
7956mlir::Value IntrinsicLibrary::genShiftA(mlir::Type resultType,
7957 llvm::ArrayRef<mlir::Value> args) {
7958 unsigned bits = resultType.getIntOrFloatBitWidth();
7959 mlir::Type signlessType =
7960 mlir::IntegerType::get(builder.getContext(), bits,
7961 mlir::IntegerType::SignednessSemantics::Signless);
7962 mlir::Value bitSize = builder.createIntegerConstant(loc, signlessType, bits);
7963 mlir::Value shift = builder.createConvert(loc, signlessType, args[1]);
7964 mlir::Value shiftGeBitSize = builder.create<mlir::arith::CmpIOp>(
7965 loc, mlir::arith::CmpIPredicate::uge, shift, bitSize);
7966
7967 // Lowering of mlir::arith::ShRSIOp is using `ashr`. `ashr` is undefined when
7968 // the shift amount is equal to the element size.
7969 // So if SHIFT is equal to the bit width then it is handled as a special case.
7970 // When negative or larger than the bit width, handle it like other
7971 // Fortran compiler do (treat it as bit width, minus 1).
7972 mlir::Value zero = builder.createIntegerConstant(loc, signlessType, 0);
7973 mlir::Value minusOne = builder.createMinusOneInteger(loc, signlessType);
7974 mlir::Value word = args[0];
7975 if (word.getType().isUnsignedInteger())
7976 word = builder.createConvert(loc, signlessType, word);
7977 mlir::Value valueIsNeg = builder.create<mlir::arith::CmpIOp>(
7978 loc, mlir::arith::CmpIPredicate::slt, word, zero);
7979 mlir::Value specialRes =
7980 builder.create<mlir::arith::SelectOp>(loc, valueIsNeg, minusOne, zero);
7981 mlir::Value shifted = builder.create<mlir::arith::ShRSIOp>(loc, word, shift);
7982 mlir::Value result = builder.create<mlir::arith::SelectOp>(
7983 loc, shiftGeBitSize, specialRes, shifted);
7984 if (resultType.isUnsignedInteger())
7985 return builder.createConvert(loc, resultType, result);
7986 return result;
7987}
7988
7989// SIGNAL
7990void IntrinsicLibrary::genSignalSubroutine(
7991 llvm::ArrayRef<fir::ExtendedValue> args) {
7992 assert(args.size() == 2 || args.size() == 3);
7993 mlir::Value number = fir::getBase(args[0]);
7994 mlir::Value handler = fir::getBase(args[1]);
7995 mlir::Value status;
7996 if (args.size() == 3)
7997 status = fir::getBase(args[2]);
7998 fir::runtime::genSignal(builder, loc, number, handler, status);
7999}
8000
8001// SIGN
8002mlir::Value IntrinsicLibrary::genSign(mlir::Type resultType,
8003 llvm::ArrayRef<mlir::Value> args) {
8004 assert(args.size() == 2);
8005 if (mlir::isa<mlir::IntegerType>(resultType)) {
8006 mlir::Value abs = genAbs(resultType, {args[0]});
8007 mlir::Value zero = builder.createIntegerConstant(loc, resultType, 0);
8008 auto neg = builder.create<mlir::arith::SubIOp>(loc, zero, abs);
8009 auto cmp = builder.create<mlir::arith::CmpIOp>(
8010 loc, mlir::arith::CmpIPredicate::slt, args[1], zero);
8011 return builder.create<mlir::arith::SelectOp>(loc, cmp, neg, abs);
8012 }
8013 return genRuntimeCall("sign", resultType, args);
8014}
8015
8016// SIND
8017mlir::Value IntrinsicLibrary::genSind(mlir::Type resultType,
8018 llvm::ArrayRef<mlir::Value> args) {
8019 assert(args.size() == 1);
8020 mlir::MLIRContext *context = builder.getContext();
8021 mlir::FunctionType ftype =
8022 mlir::FunctionType::get(context, {resultType}, {args[0].getType()});
8023 llvm::APFloat pi = llvm::APFloat(llvm::numbers::pi);
8024 mlir::Value dfactor = builder.createRealConstant(
8025 loc, mlir::Float64Type::get(context), pi / llvm::APFloat(180.0));
8026 mlir::Value factor = builder.createConvert(loc, args[0].getType(), dfactor);
8027 mlir::Value arg = builder.create<mlir::arith::MulFOp>(loc, args[0], factor);
8028 return getRuntimeCallGenerator("sin", ftype)(builder, loc, {arg});
8029}
8030
8031// SIZE
8032fir::ExtendedValue
8033IntrinsicLibrary::genSize(mlir::Type resultType,
8034 llvm::ArrayRef<fir::ExtendedValue> args) {
8035 // Note that the value of the KIND argument is already reflected in the
8036 // resultType
8037 assert(args.size() == 3);
8038
8039 // Get the ARRAY argument
8040 mlir::Value array = builder.createBox(loc, args[0]);
8041
8042 // The front-end rewrites SIZE without the DIM argument to
8043 // an array of SIZE with DIM in most cases, but it may not be
8044 // possible in some cases like when in SIZE(function_call()).
8045 if (isStaticallyAbsent(args, 1))
8046 return builder.createConvert(loc, resultType,
8047 fir::runtime::genSize(builder, loc, array));
8048
8049 // Get the DIM argument.
8050 mlir::Value dim = fir::getBase(args[1]);
8051 if (!args[0].hasAssumedRank())
8052 if (std::optional<std::int64_t> cstDim = fir::getIntIfConstant(dim)) {
8053 // If both DIM and the rank are compile time constants, skip the runtime
8054 // call.
8055 return builder.createConvert(
8056 loc, resultType,
8057 fir::factory::readExtent(builder, loc, fir::BoxValue{array},
8058 cstDim.value() - 1));
8059 }
8060 if (!fir::isa_ref_type(dim.getType()))
8061 return builder.createConvert(
8062 loc, resultType, fir::runtime::genSizeDim(builder, loc, array, dim));
8063
8064 mlir::Value isDynamicallyAbsent = builder.genIsNullAddr(loc, dim);
8065 return builder
8066 .genIfOp(loc, {resultType}, isDynamicallyAbsent,
8067 /*withElseRegion=*/true)
8068 .genThen([&]() {
8069 mlir::Value size = builder.createConvert(
8070 loc, resultType, fir::runtime::genSize(builder, loc, array));
8071 builder.create<fir::ResultOp>(loc, size);
8072 })
8073 .genElse([&]() {
8074 mlir::Value dimValue = builder.create<fir::LoadOp>(loc, dim);
8075 mlir::Value size = builder.createConvert(
8076 loc, resultType,
8077 fir::runtime::genSizeDim(builder, loc, array, dimValue));
8078 builder.create<fir::ResultOp>(loc, size);
8079 })
8080 .getResults()[0];
8081}
8082
8083// SIZEOF
8084fir::ExtendedValue
8085IntrinsicLibrary::genSizeOf(mlir::Type resultType,
8086 llvm::ArrayRef<fir::ExtendedValue> args) {
8087 assert(args.size() == 1);
8088 mlir::Value box = fir::getBase(args[0]);
8089 mlir::Value eleSize = builder.create<fir::BoxEleSizeOp>(loc, resultType, box);
8090 if (!fir::isArray(args[0]))
8091 return eleSize;
8092 mlir::Value arraySize = builder.createConvert(
8093 loc, resultType, fir::runtime::genSize(builder, loc, box));
8094 return builder.create<mlir::arith::MulIOp>(loc, eleSize, arraySize);
8095}
8096
8097// TAND
8098mlir::Value IntrinsicLibrary::genTand(mlir::Type resultType,
8099 llvm::ArrayRef<mlir::Value> args) {
8100 assert(args.size() == 1);
8101 mlir::MLIRContext *context = builder.getContext();
8102 mlir::FunctionType ftype =
8103 mlir::FunctionType::get(context, {resultType}, {args[0].getType()});
8104 llvm::APFloat pi = llvm::APFloat(llvm::numbers::pi);
8105 mlir::Value dfactor = builder.createRealConstant(
8106 loc, mlir::Float64Type::get(context), pi / llvm::APFloat(180.0));
8107 mlir::Value factor = builder.createConvert(loc, args[0].getType(), dfactor);
8108 mlir::Value arg = builder.create<mlir::arith::MulFOp>(loc, args[0], factor);
8109 return getRuntimeCallGenerator("tan", ftype)(builder, loc, {arg});
8110}
8111
8112// TRAILZ
8113mlir::Value IntrinsicLibrary::genTrailz(mlir::Type resultType,
8114 llvm::ArrayRef<mlir::Value> args) {
8115 assert(args.size() == 1);
8116
8117 mlir::Value result =
8118 builder.create<mlir::math::CountTrailingZerosOp>(loc, args);
8119
8120 return builder.createConvert(loc, resultType, result);
8121}
8122
8123static bool hasDefaultLowerBound(const fir::ExtendedValue &exv) {
8124 return exv.match(
8125 [](const fir::ArrayBoxValue &arr) { return arr.getLBounds().empty(); },
8126 [](const fir::CharArrayBoxValue &arr) {
8127 return arr.getLBounds().empty();
8128 },
8129 [](const fir::BoxValue &arr) { return arr.getLBounds().empty(); },
8130 [](const auto &) { return false; });
8131}
8132
8133/// Compute the lower bound in dimension \p dim (zero based) of \p array
8134/// taking care of returning one when the related extent is zero.
8135static mlir::Value computeLBOUND(fir::FirOpBuilder &builder, mlir::Location loc,
8136 const fir::ExtendedValue &array, unsigned dim,
8137 mlir::Value zero, mlir::Value one) {
8138 assert(dim < array.rank() && "invalid dimension");
8139 if (hasDefaultLowerBound(array))
8140 return one;
8141 mlir::Value lb = fir::factory::readLowerBound(builder, loc, array, dim, one);
8142 mlir::Value extent = fir::factory::readExtent(builder, loc, array, dim);
8143 zero = builder.createConvert(loc, extent.getType(), zero);
8144 // Note: for assumed size, the extent is -1, and the lower bound should
8145 // be returned. It is important to test extent == 0 and not extent > 0.
8146 auto dimIsEmpty = builder.create<mlir::arith::CmpIOp>(
8147 loc, mlir::arith::CmpIPredicate::eq, extent, zero);
8148 one = builder.createConvert(loc, lb.getType(), one);
8149 return builder.create<mlir::arith::SelectOp>(loc, dimIsEmpty, one, lb);
8150}
8151
8152// LBOUND
8153fir::ExtendedValue
8154IntrinsicLibrary::genLbound(mlir::Type resultType,
8155 llvm::ArrayRef<fir::ExtendedValue> args) {
8156 assert(args.size() == 2 || args.size() == 3);
8157 const fir::ExtendedValue &array = args[0];
8158 // Semantics builds signatures for LBOUND calls as either
8159 // LBOUND(array, dim, [kind]) or LBOUND(array, [kind]).
8160 const bool dimIsAbsent = args.size() == 2 || isStaticallyAbsent(args, 1);
8161 if (array.hasAssumedRank() && dimIsAbsent) {
8162 int kindPos = args.size() == 2 ? 1 : 2;
8163 return genBoundInquiry(builder, loc, resultType, args, kindPos,
8164 fir::runtime::genLbound,
8165 /*needAccurateLowerBound=*/true);
8166 }
8167
8168 mlir::Type indexType = builder.getIndexType();
8169
8170 if (dimIsAbsent) {
8171 // DIM is absent and the rank of array is a compile time constant.
8172 mlir::Type lbType = fir::unwrapSequenceType(resultType);
8173 unsigned rank = array.rank();
8174 mlir::Type lbArrayType = fir::SequenceType::get(
8175 {static_cast<fir::SequenceType::Extent>(array.rank())}, lbType);
8176 mlir::Value lbArray = builder.createTemporary(loc, lbArrayType);
8177 mlir::Type lbAddrType = builder.getRefType(lbType);
8178 mlir::Value one = builder.createIntegerConstant(loc, lbType, 1);
8179 mlir::Value zero = builder.createIntegerConstant(loc, indexType, 0);
8180 for (unsigned dim = 0; dim < rank; ++dim) {
8181 mlir::Value lb = computeLBOUND(builder, loc, array, dim, zero, one);
8182 lb = builder.createConvert(loc, lbType, lb);
8183 auto index = builder.createIntegerConstant(loc, indexType, dim);
8184 auto lbAddr =
8185 builder.create<fir::CoordinateOp>(loc, lbAddrType, lbArray, index);
8186 builder.create<fir::StoreOp>(loc, lb, lbAddr);
8187 }
8188 mlir::Value lbArrayExtent =
8189 builder.createIntegerConstant(loc, indexType, rank);
8190 llvm::SmallVector<mlir::Value> extents{lbArrayExtent};
8191 return fir::ArrayBoxValue{lbArray, extents};
8192 }
8193 // DIM is present.
8194 mlir::Value dim = fir::getBase(args[1]);
8195
8196 // If it is a compile time constant and the rank is known, skip the runtime
8197 // call.
8198 if (!array.hasAssumedRank())
8199 if (std::optional<std::int64_t> cstDim = fir::getIntIfConstant(dim)) {
8200 mlir::Value one = builder.createIntegerConstant(loc, resultType, 1);
8201 mlir::Value zero = builder.createIntegerConstant(loc, indexType, 0);
8202 mlir::Value lb =
8203 computeLBOUND(builder, loc, array, *cstDim - 1, zero, one);
8204 return builder.createConvert(loc, resultType, lb);
8205 }
8206
8207 fir::ExtendedValue box = createBoxForRuntimeBoundInquiry(loc, builder, array);
8208 return builder.createConvert(
8209 loc, resultType,
8210 fir::runtime::genLboundDim(builder, loc, fir::getBase(box), dim));
8211}
8212
8213// UBOUND
8214fir::ExtendedValue
8215IntrinsicLibrary::genUbound(mlir::Type resultType,
8216 llvm::ArrayRef<fir::ExtendedValue> args) {
8217 assert(args.size() == 3 || args.size() == 2);
8218 const bool dimIsAbsent = args.size() == 2 || isStaticallyAbsent(args, 1);
8219 if (!dimIsAbsent) {
8220 // Handle calls to UBOUND with the DIM argument, which return a scalar
8221 mlir::Value extent = fir::getBase(genSize(resultType, args));
8222 mlir::Value lbound = fir::getBase(genLbound(resultType, args));
8223
8224 mlir::Value one = builder.createIntegerConstant(loc, resultType, 1);
8225 mlir::Value ubound = builder.create<mlir::arith::SubIOp>(loc, lbound, one);
8226 return builder.create<mlir::arith::AddIOp>(loc, ubound, extent);
8227 }
8228 // Handle calls to UBOUND without the DIM argument, which return an array
8229 int kindPos = args.size() == 2 ? 1 : 2;
8230 return genBoundInquiry(builder, loc, resultType, args, kindPos,
8231 fir::runtime::genUbound,
8232 /*needAccurateLowerBound=*/true);
8233}
8234
8235// SPACING
8236mlir::Value IntrinsicLibrary::genSpacing(mlir::Type resultType,
8237 llvm::ArrayRef<mlir::Value> args) {
8238 assert(args.size() == 1);
8239
8240 return builder.createConvert(
8241 loc, resultType,
8242 fir::runtime::genSpacing(builder, loc, fir::getBase(args[0])));
8243}
8244
8245// SPREAD
8246fir::ExtendedValue
8247IntrinsicLibrary::genSpread(mlir::Type resultType,
8248 llvm::ArrayRef<fir::ExtendedValue> args) {
8249
8250 assert(args.size() == 3);
8251
8252 // Handle source argument
8253 mlir::Value source = builder.createBox(loc, args[0]);
8254 fir::BoxValue sourceTmp = source;
8255 unsigned sourceRank = sourceTmp.rank();
8256
8257 // Handle Dim argument
8258 mlir::Value dim = fir::getBase(args[1]);
8259
8260 // Handle ncopies argument
8261 mlir::Value ncopies = fir::getBase(args[2]);
8262
8263 // Generate result descriptor
8264 mlir::Type resultArrayType =
8265 builder.getVarLenSeqTy(resultType, sourceRank + 1);
8266 fir::MutableBoxValue resultMutableBox = fir::factory::createTempMutableBox(
8267 builder, loc, resultArrayType, {},
8268 fir::isPolymorphicType(source.getType()) ? source : mlir::Value{});
8269 mlir::Value resultIrBox =
8270 fir::factory::getMutableIRBox(builder, loc, resultMutableBox);
8271
8272 fir::runtime::genSpread(builder, loc, resultIrBox, source, dim, ncopies);
8273
8274 return readAndAddCleanUp(resultMutableBox, resultType, "SPREAD");
8275}
8276
8277// STORAGE_SIZE
8278fir::ExtendedValue
8279IntrinsicLibrary::genStorageSize(mlir::Type resultType,
8280 llvm::ArrayRef<fir::ExtendedValue> args) {
8281 assert(args.size() == 2 || args.size() == 1);
8282 mlir::Value box = fir::getBase(args[0]);
8283 mlir::Type boxTy = box.getType();
8284 mlir::Type kindTy = builder.getDefaultIntegerType();
8285 bool needRuntimeCheck = false;
8286 std::string errorMsg;
8287
8288 if (fir::isUnlimitedPolymorphicType(boxTy) &&
8289 (fir::isAllocatableType(boxTy) || fir::isPointerType(boxTy))) {
8290 needRuntimeCheck = true;
8291 errorMsg =
8292 fir::isPointerType(boxTy)
8293 ? "unlimited polymorphic disassociated POINTER in STORAGE_SIZE"
8294 : "unlimited polymorphic unallocated ALLOCATABLE in STORAGE_SIZE";
8295 }
8296 const fir::MutableBoxValue *mutBox = args[0].getBoxOf<fir::MutableBoxValue>();
8297 if (needRuntimeCheck && mutBox) {
8298 mlir::Value isNotAllocOrAssoc =
8299 fir::factory::genIsNotAllocatedOrAssociatedTest(builder, loc, *mutBox);
8300 builder.genIfThen(loc, isNotAllocOrAssoc)
8301 .genThen([&]() {
8302 fir::runtime::genReportFatalUserError(builder, loc, errorMsg);
8303 })
8304 .end();
8305 }
8306
8307 // Handle optional kind argument
8308 bool absentKind = isStaticallyAbsent(args, 1);
8309 if (!absentKind) {
8310 mlir::Operation *defKind = fir::getBase(args[1]).getDefiningOp();
8311 assert(mlir::isa<mlir::arith::ConstantOp>(*defKind) &&
8312 "kind not a constant");
8313 auto constOp = mlir::dyn_cast<mlir::arith::ConstantOp>(*defKind);
8314 kindTy = builder.getIntegerType(
8315 builder.getKindMap().getIntegerBitsize(fir::toInt(constOp)));
8316 }
8317
8318 box = builder.createBox(loc, args[0],
8319 /*isPolymorphic=*/args[0].isPolymorphic());
8320 mlir::Value eleSize = builder.create<fir::BoxEleSizeOp>(loc, kindTy, box);
8321 mlir::Value c8 = builder.createIntegerConstant(loc, kindTy, 8);
8322 return builder.create<mlir::arith::MulIOp>(loc, eleSize, c8);
8323}
8324
8325// SUM
8326fir::ExtendedValue
8327IntrinsicLibrary::genSum(mlir::Type resultType,
8328 llvm::ArrayRef<fir::ExtendedValue> args) {
8329 return genReduction(fir::runtime::genSum, fir::runtime::genSumDim, "SUM",
8330 resultType, args);
8331}
8332
8333// SYNCTHREADS
8334void IntrinsicLibrary::genSyncThreads(llvm::ArrayRef<fir::ExtendedValue> args) {
8335 builder.create<mlir::NVVM::Barrier0Op>(loc);
8336}
8337
8338// SYNCTHREADS_AND
8339mlir::Value
8340IntrinsicLibrary::genSyncThreadsAnd(mlir::Type resultType,
8341 llvm::ArrayRef<mlir::Value> args) {
8342 constexpr llvm::StringLiteral funcName = "llvm.nvvm.barrier0.and";
8343 mlir::MLIRContext *context = builder.getContext();
8344 mlir::FunctionType ftype =
8345 mlir::FunctionType::get(context, {resultType}, {args[0].getType()});
8346 auto funcOp = builder.createFunction(loc, funcName, ftype);
8347 return builder.create<fir::CallOp>(loc, funcOp, args).getResult(0);
8348}
8349
8350// SYNCTHREADS_COUNT
8351mlir::Value
8352IntrinsicLibrary::genSyncThreadsCount(mlir::Type resultType,
8353 llvm::ArrayRef<mlir::Value> args) {
8354 constexpr llvm::StringLiteral funcName = "llvm.nvvm.barrier0.popc";
8355 mlir::MLIRContext *context = builder.getContext();
8356 mlir::FunctionType ftype =
8357 mlir::FunctionType::get(context, {resultType}, {args[0].getType()});
8358 auto funcOp = builder.createFunction(loc, funcName, ftype);
8359 return builder.create<fir::CallOp>(loc, funcOp, args).getResult(0);
8360}
8361
8362// SYNCTHREADS_OR
8363mlir::Value
8364IntrinsicLibrary::genSyncThreadsOr(mlir::Type resultType,
8365 llvm::ArrayRef<mlir::Value> args) {
8366 constexpr llvm::StringLiteral funcName = "llvm.nvvm.barrier0.or";
8367 mlir::MLIRContext *context = builder.getContext();
8368 mlir::FunctionType ftype =
8369 mlir::FunctionType::get(context, {resultType}, {args[0].getType()});
8370 auto funcOp = builder.createFunction(loc, funcName, ftype);
8371 return builder.create<fir::CallOp>(loc, funcOp, args).getResult(0);
8372}
8373
8374// SYNCWARP
8375void IntrinsicLibrary::genSyncWarp(llvm::ArrayRef<fir::ExtendedValue> args) {
8376 assert(args.size() == 1);
8377 constexpr llvm::StringLiteral funcName = "llvm.nvvm.bar.warp.sync";
8378 mlir::Value mask = fir::getBase(args[0]);
8379 mlir::FunctionType funcType =
8380 mlir::FunctionType::get(builder.getContext(), {mask.getType()}, {});
8381 auto funcOp = builder.createFunction(loc, funcName, funcType);
8382 llvm::SmallVector<mlir::Value> argsList{mask};
8383 builder.create<fir::CallOp>(loc, funcOp, argsList);
8384}
8385
8386// SYSTEM
8387fir::ExtendedValue
8388IntrinsicLibrary::genSystem(std::optional<mlir::Type> resultType,
8389 llvm::ArrayRef<fir::ExtendedValue> args) {
8390 assert((!resultType && (args.size() == 2)) ||
8391 (resultType && (args.size() == 1)));
8392 mlir::Value command = fir::getBase(args[0]);
8393 assert(command && "expected COMMAND parameter");
8394
8395 fir::ExtendedValue exitstat;
8396 if (resultType) {
8397 mlir::Value tmp = builder.createTemporary(loc, *resultType);
8398 exitstat = builder.createBox(loc, tmp);
8399 } else {
8400 exitstat = args[1];
8401 }
8402
8403 mlir::Type boxNoneTy = fir::BoxType::get(builder.getNoneType());
8404
8405 mlir::Value waitBool = builder.createBool(loc, true);
8406 mlir::Value exitstatBox =
8407 isStaticallyPresent(exitstat)
8408 ? fir::getBase(exitstat)
8409 : builder.create<fir::AbsentOp>(loc, boxNoneTy).getResult();
8410
8411 // Create a dummmy cmdstat to prevent EXECUTE_COMMAND_LINE terminate itself
8412 // when cmdstat is assigned with a non-zero value but not present
8413 mlir::Value tempValue =
8414 builder.createIntegerConstant(loc, builder.getI16Type(), 0);
8415 mlir::Value temp = builder.createTemporary(loc, builder.getI16Type());
8416 builder.create<fir::StoreOp>(loc, tempValue, temp);
8417 mlir::Value cmdstatBox = builder.createBox(loc, temp);
8418
8419 mlir::Value cmdmsgBox =
8420 builder.create<fir::AbsentOp>(loc, boxNoneTy).getResult();
8421
8422 fir::runtime::genExecuteCommandLine(builder, loc, command, waitBool,
8423 exitstatBox, cmdstatBox, cmdmsgBox);
8424
8425 if (resultType) {
8426 mlir::Value exitstatAddr = builder.create<fir::BoxAddrOp>(loc, exitstatBox);
8427 return builder.create<fir::LoadOp>(loc, fir::getBase(exitstatAddr));
8428 }
8429 return {};
8430}
8431
8432// SYSTEM_CLOCK
8433void IntrinsicLibrary::genSystemClock(llvm::ArrayRef<fir::ExtendedValue> args) {
8434 assert(args.size() == 3);
8435 fir::runtime::genSystemClock(builder, loc, fir::getBase(args[0]),
8436 fir::getBase(args[1]), fir::getBase(args[2]));
8437}
8438
8439// SLEEP
8440void IntrinsicLibrary::genSleep(llvm::ArrayRef<fir::ExtendedValue> args) {
8441 assert(args.size() == 1 && "SLEEP has one compulsory argument");
8442 fir::runtime::genSleep(builder, loc, fir::getBase(args[0]));
8443}
8444
8445// TRANSFER
8446fir::ExtendedValue
8447IntrinsicLibrary::genTransfer(mlir::Type resultType,
8448 llvm::ArrayRef<fir::ExtendedValue> args) {
8449
8450 assert(args.size() >= 2); // args.size() == 2 when size argument is omitted.
8451
8452 // Handle source argument
8453 mlir::Value source = builder.createBox(loc, args[0]);
8454
8455 // Handle mold argument
8456 mlir::Value mold = builder.createBox(loc, args[1]);
8457 fir::BoxValue moldTmp = mold;
8458 unsigned moldRank = moldTmp.rank();
8459
8460 bool absentSize = (args.size() == 2);
8461
8462 // Create mutable fir.box to be passed to the runtime for the result.
8463 mlir::Type type = (moldRank == 0 && absentSize)
8464 ? resultType
8465 : builder.getVarLenSeqTy(resultType, 1);
8466 fir::MutableBoxValue resultMutableBox = fir::factory::createTempMutableBox(
8467 builder, loc, type, {},
8468 fir::isPolymorphicType(mold.getType()) ? mold : mlir::Value{});
8469
8470 if (moldRank == 0 && absentSize) {
8471 // This result is a scalar in this case.
8472 mlir::Value resultIrBox =
8473 fir::factory::getMutableIRBox(builder, loc, resultMutableBox);
8474
8475 fir::runtime::genTransfer(builder, loc, resultIrBox, source, mold);
8476 } else {
8477 // The result is a rank one array in this case.
8478 mlir::Value resultIrBox =
8479 fir::factory::getMutableIRBox(builder, loc, resultMutableBox);
8480
8481 if (absentSize) {
8482 fir::runtime::genTransfer(builder, loc, resultIrBox, source, mold);
8483 } else {
8484 mlir::Value sizeArg = fir::getBase(args[2]);
8485 fir::runtime::genTransferSize(builder, loc, resultIrBox, source, mold,
8486 sizeArg);
8487 }
8488 }
8489 return readAndAddCleanUp(resultMutableBox, resultType, "TRANSFER");
8490}
8491
8492// TRANSPOSE
8493fir::ExtendedValue
8494IntrinsicLibrary::genTranspose(mlir::Type resultType,
8495 llvm::ArrayRef<fir::ExtendedValue> args) {
8496
8497 assert(args.size() == 1);
8498
8499 // Handle source argument
8500 mlir::Value source = builder.createBox(loc, args[0]);
8501
8502 // Create mutable fir.box to be passed to the runtime for the result.
8503 mlir::Type resultArrayType = builder.getVarLenSeqTy(resultType, 2);
8504 fir::MutableBoxValue resultMutableBox = fir::factory::createTempMutableBox(
8505 builder, loc, resultArrayType, {},
8506 fir::isPolymorphicType(source.getType()) ? source : mlir::Value{});
8507 mlir::Value resultIrBox =
8508 fir::factory::getMutableIRBox(builder, loc, resultMutableBox);
8509 // Call runtime. The runtime is allocating the result.
8510 fir::runtime::genTranspose(builder, loc, resultIrBox, source);
8511 // Read result from mutable fir.box and add it to the list of temps to be
8512 // finalized by the StatementContext.
8513 return readAndAddCleanUp(resultMutableBox, resultType, "TRANSPOSE");
8514}
8515
8516// THREADFENCE
8517void IntrinsicLibrary::genThreadFence(llvm::ArrayRef<fir::ExtendedValue> args) {
8518 constexpr llvm::StringLiteral funcName = "llvm.nvvm.membar.gl";
8519 mlir::FunctionType funcType =
8520 mlir::FunctionType::get(builder.getContext(), {}, {});
8521 auto funcOp = builder.createFunction(loc, funcName, funcType);
8522 llvm::SmallVector<mlir::Value> noArgs;
8523 builder.create<fir::CallOp>(loc, funcOp, noArgs);
8524}
8525
8526// THREADFENCE_BLOCK
8527void IntrinsicLibrary::genThreadFenceBlock(
8528 llvm::ArrayRef<fir::ExtendedValue> args) {
8529 constexpr llvm::StringLiteral funcName = "llvm.nvvm.membar.cta";
8530 mlir::FunctionType funcType =
8531 mlir::FunctionType::get(builder.getContext(), {}, {});
8532 auto funcOp = builder.createFunction(loc, funcName, funcType);
8533 llvm::SmallVector<mlir::Value> noArgs;
8534 builder.create<fir::CallOp>(loc, funcOp, noArgs);
8535}
8536
8537// THREADFENCE_SYSTEM
8538void IntrinsicLibrary::genThreadFenceSystem(
8539 llvm::ArrayRef<fir::ExtendedValue> args) {
8540 constexpr llvm::StringLiteral funcName = "llvm.nvvm.membar.sys";
8541 mlir::FunctionType funcType =
8542 mlir::FunctionType::get(builder.getContext(), {}, {});
8543 auto funcOp = builder.createFunction(loc, funcName, funcType);
8544 llvm::SmallVector<mlir::Value> noArgs;
8545 builder.create<fir::CallOp>(loc, funcOp, noArgs);
8546}
8547
8548// TIME
8549mlir::Value IntrinsicLibrary::genTime(mlir::Type resultType,
8550 llvm::ArrayRef<mlir::Value> args) {
8551 assert(args.size() == 0);
8552 return builder.createConvert(loc, resultType,
8553 fir::runtime::genTime(builder, loc));
8554}
8555
8556// TRIM
8557fir::ExtendedValue
8558IntrinsicLibrary::genTrim(mlir::Type resultType,
8559 llvm::ArrayRef<fir::ExtendedValue> args) {
8560 assert(args.size() == 1);
8561 mlir::Value string = builder.createBox(loc, args[0]);
8562 // Create mutable fir.box to be passed to the runtime for the result.
8563 fir::MutableBoxValue resultMutableBox =
8564 fir::factory::createTempMutableBox(builder, loc, resultType);
8565 mlir::Value resultIrBox =
8566 fir::factory::getMutableIRBox(builder, loc, resultMutableBox);
8567 // Call runtime. The runtime is allocating the result.
8568 fir::runtime::genTrim(builder, loc, resultIrBox, string);
8569 // Read result from mutable fir.box and add it to the list of temps to be
8570 // finalized by the StatementContext.
8571 return readAndAddCleanUp(resultMutableBox, resultType, "TRIM");
8572}
8573
8574// Compare two FIR values and return boolean result as i1.
8575template <Extremum extremum, ExtremumBehavior behavior>
8576static mlir::Value createExtremumCompare(mlir::Location loc,
8577 fir::FirOpBuilder &builder,
8578 mlir::Value left, mlir::Value right) {
8579 mlir::Type type = left.getType();
8580 mlir::arith::CmpIPredicate integerPredicate =
8581 type.isUnsignedInteger() ? extremum == Extremum::Max
8582 ? mlir::arith::CmpIPredicate::ugt
8583 : mlir::arith::CmpIPredicate::ult
8584 : extremum == Extremum::Max ? mlir::arith::CmpIPredicate::sgt
8585 : mlir::arith::CmpIPredicate::slt;
8586 static constexpr mlir::arith::CmpFPredicate orderedCmp =
8587 extremum == Extremum::Max ? mlir::arith::CmpFPredicate::OGT
8588 : mlir::arith::CmpFPredicate::OLT;
8589 mlir::Value result;
8590 if (fir::isa_real(type)) {
8591 // Note: the signaling/quit aspect of the result required by IEEE
8592 // cannot currently be obtained with LLVM without ad-hoc runtime.
8593 if constexpr (behavior == ExtremumBehavior::IeeeMinMaximumNumber) {
8594 // Return the number if one of the inputs is NaN and the other is
8595 // a number.
8596 auto leftIsResult =
8597 builder.create<mlir::arith::CmpFOp>(loc, orderedCmp, left, right);
8598 auto rightIsNan = builder.create<mlir::arith::CmpFOp>(
8599 loc, mlir::arith::CmpFPredicate::UNE, right, right);
8600 result =
8601 builder.create<mlir::arith::OrIOp>(loc, leftIsResult, rightIsNan);
8602 } else if constexpr (behavior == ExtremumBehavior::IeeeMinMaximum) {
8603 // Always return NaNs if one the input is NaNs
8604 auto leftIsResult =
8605 builder.create<mlir::arith::CmpFOp>(loc, orderedCmp, left, right);
8606 auto leftIsNan = builder.create<mlir::arith::CmpFOp>(
8607 loc, mlir::arith::CmpFPredicate::UNE, left, left);
8608 result = builder.create<mlir::arith::OrIOp>(loc, leftIsResult, leftIsNan);
8609 } else if constexpr (behavior == ExtremumBehavior::MinMaxss) {
8610 // If the left is a NaN, return the right whatever it is.
8611 result =
8612 builder.create<mlir::arith::CmpFOp>(loc, orderedCmp, left, right);
8613 } else if constexpr (behavior == ExtremumBehavior::PgfortranLlvm) {
8614 // If one of the operand is a NaN, return left whatever it is.
8615 static constexpr auto unorderedCmp =
8616 extremum == Extremum::Max ? mlir::arith::CmpFPredicate::UGT
8617 : mlir::arith::CmpFPredicate::ULT;
8618 result =
8619 builder.create<mlir::arith::CmpFOp>(loc, unorderedCmp, left, right);
8620 } else {
8621 // TODO: ieeeMinNum/ieeeMaxNum
8622 static_assert(behavior == ExtremumBehavior::IeeeMinMaxNum,
8623 "ieeeMinNum/ieeeMaxNum behavior not implemented");
8624 }
8625 } else if (fir::isa_integer(type)) {
8626 if (type.isUnsignedInteger()) {
8627 mlir::Type signlessType = mlir::IntegerType::get(
8628 builder.getContext(), type.getIntOrFloatBitWidth(),
8629 mlir::IntegerType::SignednessSemantics::Signless);
8630 left = builder.createConvert(loc, signlessType, left);
8631 right = builder.createConvert(loc, signlessType, right);
8632 }
8633 result =
8634 builder.create<mlir::arith::CmpIOp>(loc, integerPredicate, left, right);
8635 } else if (fir::isa_char(type) || fir::isa_char(fir::unwrapRefType(type))) {
8636 // TODO: ! character min and max is tricky because the result
8637 // length is the length of the longest argument!
8638 // So we may need a temp.
8639 TODO(loc, "intrinsic: min and max for CHARACTER");
8640 }
8641 assert(result && "result must be defined");
8642 return result;
8643}
8644
8645// UNLINK
8646fir::ExtendedValue
8647IntrinsicLibrary::genUnlink(std::optional<mlir::Type> resultType,
8648 llvm::ArrayRef<fir::ExtendedValue> args) {
8649 assert((resultType.has_value() && args.size() == 1) ||
8650 (!resultType.has_value() && args.size() >= 1 && args.size() <= 2));
8651
8652 mlir::Value path = fir::getBase(args[0]);
8653 mlir::Value pathLength = fir::getLen(args[0]);
8654 mlir::Value statusValue =
8655 fir::runtime::genUnlink(builder, loc, path, pathLength);
8656
8657 if (resultType.has_value()) {
8658 // Function form, return status.
8659 return builder.createConvert(loc, *resultType, statusValue);
8660 }
8661
8662 // Subroutine form, store status and return none.
8663 const fir::ExtendedValue &status = args[1];
8664 if (!isStaticallyAbsent(status)) {
8665 mlir::Value statusAddr = fir::getBase(status);
8666 mlir::Value statusIsPresentAtRuntime =
8667 builder.genIsNotNullAddr(loc, statusAddr);
8668 builder.genIfThen(loc, statusIsPresentAtRuntime)
8669 .genThen([&]() {
8670 builder.createStoreWithConvert(loc, statusValue, statusAddr);
8671 })
8672 .end();
8673 }
8674
8675 return {};
8676}
8677
8678// UNPACK
8679fir::ExtendedValue
8680IntrinsicLibrary::genUnpack(mlir::Type resultType,
8681 llvm::ArrayRef<fir::ExtendedValue> args) {
8682 assert(args.size() == 3);
8683
8684 // Handle required vector argument
8685 mlir::Value vector = builder.createBox(loc, args[0]);
8686
8687 // Handle required mask argument
8688 fir::BoxValue maskBox = builder.createBox(loc, args[1]);
8689 mlir::Value mask = fir::getBase(maskBox);
8690 unsigned maskRank = maskBox.rank();
8691
8692 // Handle required field argument
8693 mlir::Value field = builder.createBox(loc, args[2]);
8694
8695 // Create mutable fir.box to be passed to the runtime for the result.
8696 mlir::Type resultArrayType = builder.getVarLenSeqTy(resultType, maskRank);
8697 fir::MutableBoxValue resultMutableBox = fir::factory::createTempMutableBox(
8698 builder, loc, resultArrayType, {},
8699 fir::isPolymorphicType(vector.getType()) ? vector : mlir::Value{});
8700 mlir::Value resultIrBox =
8701 fir::factory::getMutableIRBox(builder, loc, resultMutableBox);
8702
8703 fir::runtime::genUnpack(builder, loc, resultIrBox, vector, mask, field);
8704
8705 return readAndAddCleanUp(resultMutableBox, resultType, "UNPACK");
8706}
8707
8708// VERIFY
8709fir::ExtendedValue
8710IntrinsicLibrary::genVerify(mlir::Type resultType,
8711 llvm::ArrayRef<fir::ExtendedValue> args) {
8712
8713 assert(args.size() == 4);
8714
8715 if (isStaticallyAbsent(args[3])) {
8716 // Kind not specified, so call scan/verify runtime routine that is
8717 // specialized on the kind of characters in string.
8718
8719 // Handle required string base arg
8720 mlir::Value stringBase = fir::getBase(args[0]);
8721
8722 // Handle required set string base arg
8723 mlir::Value setBase = fir::getBase(args[1]);
8724
8725 // Handle kind argument; it is the kind of character in this case
8726 fir::KindTy kind =
8727 fir::factory::CharacterExprHelper{builder, loc}.getCharacterKind(
8728 stringBase.getType());
8729
8730 // Get string length argument
8731 mlir::Value stringLen = fir::getLen(args[0]);
8732
8733 // Get set string length argument
8734 mlir::Value setLen = fir::getLen(args[1]);
8735
8736 // Handle optional back argument
8737 mlir::Value back =
8738 isStaticallyAbsent(args[2])
8739 ? builder.createIntegerConstant(loc, builder.getI1Type(), 0)
8740 : fir::getBase(args[2]);
8741
8742 return builder.createConvert(
8743 loc, resultType,
8744 fir::runtime::genVerify(builder, loc, kind, stringBase, stringLen,
8745 setBase, setLen, back));
8746 }
8747 // else use the runtime descriptor version of scan/verify
8748
8749 // Handle optional argument, back
8750 auto makeRefThenEmbox = [&](mlir::Value b) {
8751 fir::LogicalType logTy = fir::LogicalType::get(
8752 builder.getContext(), builder.getKindMap().defaultLogicalKind());
8753 mlir::Value temp = builder.createTemporary(loc, logTy);
8754 mlir::Value castb = builder.createConvert(loc, logTy, b);
8755 builder.create<fir::StoreOp>(loc, castb, temp);
8756 return builder.createBox(loc, temp);
8757 };
8758 mlir::Value back = fir::isUnboxedValue(args[2])
8759 ? makeRefThenEmbox(*args[2].getUnboxed())
8760 : builder.create<fir::AbsentOp>(
8761 loc, fir::BoxType::get(builder.getI1Type()));
8762
8763 // Handle required string argument
8764 mlir::Value string = builder.createBox(loc, args[0]);
8765
8766 // Handle required set argument
8767 mlir::Value set = builder.createBox(loc, args[1]);
8768
8769 // Handle kind argument
8770 mlir::Value kind = fir::getBase(args[3]);
8771
8772 // Create result descriptor
8773 fir::MutableBoxValue resultMutableBox =
8774 fir::factory::createTempMutableBox(builder, loc, resultType);
8775 mlir::Value resultIrBox =
8776 fir::factory::getMutableIRBox(builder, loc, resultMutableBox);
8777
8778 fir::runtime::genVerifyDescriptor(builder, loc, resultIrBox, string, set,
8779 back, kind);
8780
8781 // Handle cleanup of allocatable result descriptor and return
8782 return readAndAddCleanUp(resultMutableBox, resultType, "VERIFY");
8783}
8784
8785/// Process calls to Minloc, Maxloc intrinsic functions
8786template <typename FN, typename FD>
8787fir::ExtendedValue
8788IntrinsicLibrary::genExtremumloc(FN func, FD funcDim, llvm::StringRef errMsg,
8789 mlir::Type resultType,
8790 llvm::ArrayRef<fir::ExtendedValue> args) {
8791
8792 assert(args.size() == 5);
8793
8794 // Handle required array argument
8795 mlir::Value array = builder.createBox(loc, args[0]);
8796 unsigned rank = fir::BoxValue(array).rank();
8797 assert(rank >= 1);
8798
8799 // Handle optional mask argument
8800 auto mask = isStaticallyAbsent(args[2])
8801 ? builder.create<fir::AbsentOp>(
8802 loc, fir::BoxType::get(builder.getI1Type()))
8803 : builder.createBox(loc, args[2]);
8804
8805 // Handle optional kind argument
8806 auto kind = isStaticallyAbsent(args[3])
8807 ? builder.createIntegerConstant(
8808 loc, builder.getIndexType(),
8809 builder.getKindMap().defaultIntegerKind())
8810 : fir::getBase(args[3]);
8811
8812 // Handle optional back argument
8813 auto back = isStaticallyAbsent(args[4]) ? builder.createBool(loc, false)
8814 : fir::getBase(args[4]);
8815
8816 bool absentDim = isStaticallyAbsent(args[1]);
8817
8818 if (!absentDim && rank == 1) {
8819 // If dim argument is present and the array is rank 1, then the result is
8820 // a scalar (since the the result is rank-1 or 0).
8821 // Therefore, we use a scalar result descriptor with Min/MaxlocDim().
8822 mlir::Value dim = fir::getBase(args[1]);
8823 // Create mutable fir.box to be passed to the runtime for the result.
8824 fir::MutableBoxValue resultMutableBox =
8825 fir::factory::createTempMutableBox(builder, loc, resultType);
8826 mlir::Value resultIrBox =
8827 fir::factory::getMutableIRBox(builder, loc, resultMutableBox);
8828
8829 funcDim(builder, loc, resultIrBox, array, dim, mask, kind, back);
8830
8831 // Handle cleanup of allocatable result descriptor and return
8832 return readAndAddCleanUp(resultMutableBox, resultType, errMsg);
8833 }
8834
8835 // Note: The Min/Maxloc/val cases below have an array result.
8836
8837 // Create mutable fir.box to be passed to the runtime for the result.
8838 mlir::Type resultArrayType =
8839 builder.getVarLenSeqTy(resultType, absentDim ? 1 : rank - 1);
8840 fir::MutableBoxValue resultMutableBox =
8841 fir::factory::createTempMutableBox(builder, loc, resultArrayType);
8842 mlir::Value resultIrBox =
8843 fir::factory::getMutableIRBox(builder, loc, resultMutableBox);
8844
8845 if (absentDim) {
8846 // Handle min/maxloc/val case where there is no dim argument
8847 // (calls Min/Maxloc()/MinMaxval() runtime routine)
8848 func(builder, loc, resultIrBox, array, mask, kind, back);
8849 } else {
8850 // else handle min/maxloc case with dim argument (calls
8851 // Min/Max/loc/val/Dim() runtime routine).
8852 mlir::Value dim = fir::getBase(args[1]);
8853 funcDim(builder, loc, resultIrBox, array, dim, mask, kind, back);
8854 }
8855 return readAndAddCleanUp(resultMutableBox, resultType, errMsg);
8856}
8857
8858// MAXLOC
8859fir::ExtendedValue
8860IntrinsicLibrary::genMaxloc(mlir::Type resultType,
8861 llvm::ArrayRef<fir::ExtendedValue> args) {
8862 return genExtremumloc(fir::runtime::genMaxloc, fir::runtime::genMaxlocDim,
8863 "MAXLOC", resultType, args);
8864}
8865
8866/// Process calls to Maxval and Minval
8867template <typename FN, typename FD, typename FC>
8868fir::ExtendedValue
8869IntrinsicLibrary::genExtremumVal(FN func, FD funcDim, FC funcChar,
8870 llvm::StringRef errMsg, mlir::Type resultType,
8871 llvm::ArrayRef<fir::ExtendedValue> args) {
8872
8873 assert(args.size() == 3);
8874
8875 // Handle required array argument
8876 fir::BoxValue arryTmp = builder.createBox(loc, args[0]);
8877 mlir::Value array = fir::getBase(arryTmp);
8878 int rank = arryTmp.rank();
8879 assert(rank >= 1);
8880 bool hasCharacterResult = arryTmp.isCharacter();
8881
8882 // Handle optional mask argument
8883 auto mask = isStaticallyAbsent(args[2])
8884 ? builder.create<fir::AbsentOp>(
8885 loc, fir::BoxType::get(builder.getI1Type()))
8886 : builder.createBox(loc, args[2]);
8887
8888 bool absentDim = isStaticallyAbsent(args[1]);
8889
8890 // For Maxval/MinVal, we call the type specific versions of
8891 // Maxval/Minval because the result is scalar in the case below.
8892 if (!hasCharacterResult && (absentDim || rank == 1))
8893 return func(builder, loc, array, mask);
8894
8895 if (hasCharacterResult && (absentDim || rank == 1)) {
8896 // Create mutable fir.box to be passed to the runtime for the result.
8897 fir::MutableBoxValue resultMutableBox =
8898 fir::factory::createTempMutableBox(builder, loc, resultType);
8899 mlir::Value resultIrBox =
8900 fir::factory::getMutableIRBox(builder, loc, resultMutableBox);
8901
8902 funcChar(builder, loc, resultIrBox, array, mask);
8903
8904 // Handle cleanup of allocatable result descriptor and return
8905 return readAndAddCleanUp(resultMutableBox, resultType, errMsg);
8906 }
8907
8908 // Handle Min/Maxval cases that have an array result.
8909 auto resultMutableBox =
8910 genFuncDim(funcDim, resultType, builder, loc, array, args[1], mask, rank);
8911 return readAndAddCleanUp(resultMutableBox, resultType, errMsg);
8912}
8913
8914// MAXVAL
8915fir::ExtendedValue
8916IntrinsicLibrary::genMaxval(mlir::Type resultType,
8917 llvm::ArrayRef<fir::ExtendedValue> args) {
8918 return genExtremumVal(fir::runtime::genMaxval, fir::runtime::genMaxvalDim,
8919 fir::runtime::genMaxvalChar, "MAXVAL", resultType,
8920 args);
8921}
8922
8923// MINLOC
8924fir::ExtendedValue
8925IntrinsicLibrary::genMinloc(mlir::Type resultType,
8926 llvm::ArrayRef<fir::ExtendedValue> args) {
8927 return genExtremumloc(fir::runtime::genMinloc, fir::runtime::genMinlocDim,
8928 "MINLOC", resultType, args);
8929}
8930
8931// MINVAL
8932fir::ExtendedValue
8933IntrinsicLibrary::genMinval(mlir::Type resultType,
8934 llvm::ArrayRef<fir::ExtendedValue> args) {
8935 return genExtremumVal(fir::runtime::genMinval, fir::runtime::genMinvalDim,
8936 fir::runtime::genMinvalChar, "MINVAL", resultType,
8937 args);
8938}
8939
8940// MIN and MAX
8941template <Extremum extremum, ExtremumBehavior behavior>
8942mlir::Value IntrinsicLibrary::genExtremum(mlir::Type,
8943 llvm::ArrayRef<mlir::Value> args) {
8944 assert(args.size() >= 1);
8945 mlir::Value result = args[0];
8946 for (auto arg : args.drop_front()) {
8947 mlir::Value mask =
8948 createExtremumCompare<extremum, behavior>(loc, builder, result, arg);
8949 result = builder.create<mlir::arith::SelectOp>(loc, mask, result, arg);
8950 }
8951 return result;
8952}
8953
8954//===----------------------------------------------------------------------===//
8955// Argument lowering rules interface for intrinsic or intrinsic module
8956// procedure.
8957//===----------------------------------------------------------------------===//
8958
8959const IntrinsicArgumentLoweringRules *
8960getIntrinsicArgumentLowering(llvm::StringRef specificName) {
8961 llvm::StringRef name = genericName(specificName);
8962 if (const IntrinsicHandler *handler = findIntrinsicHandler(name))
8963 if (!handler->argLoweringRules.hasDefaultRules())
8964 return &handler->argLoweringRules;
8965 if (const IntrinsicHandler *ppcHandler = findPPCIntrinsicHandler(name))
8966 if (!ppcHandler->argLoweringRules.hasDefaultRules())
8967 return &ppcHandler->argLoweringRules;
8968 return nullptr;
8969}
8970
8971const IntrinsicArgumentLoweringRules *
8972IntrinsicHandlerEntry::getArgumentLoweringRules() const {
8973 if (const IntrinsicHandler *const *handler =
8974 std::get_if<const IntrinsicHandler *>(&entry)) {
8975 assert(*handler);
8976 if (!(*handler)->argLoweringRules.hasDefaultRules())
8977 return &(*handler)->argLoweringRules;
8978 }
8979 return nullptr;
8980}
8981
8982/// Return how argument \p argName should be lowered given the rules for the
8983/// intrinsic function.
8984fir::ArgLoweringRule
8985lowerIntrinsicArgumentAs(const IntrinsicArgumentLoweringRules &rules,
8986 unsigned position) {
8987 assert(position < sizeof(rules.args) / (sizeof(decltype(*rules.args))) &&
8988 "invalid argument");
8989 return {rules.args[position].lowerAs,
8990 rules.args[position].handleDynamicOptional};
8991}
8992
8993//===----------------------------------------------------------------------===//
8994// Public intrinsic call helpers
8995//===----------------------------------------------------------------------===//
8996
8997std::pair<fir::ExtendedValue, bool>
8998genIntrinsicCall(fir::FirOpBuilder &builder, mlir::Location loc,
8999 llvm::StringRef name, std::optional<mlir::Type> resultType,
9000 llvm::ArrayRef<fir::ExtendedValue> args,
9001 Fortran::lower::AbstractConverter *converter) {
9002 return IntrinsicLibrary{builder, loc, converter}.genIntrinsicCall(
9003 name, resultType, args);
9004}
9005
9006mlir::Value genMax(fir::FirOpBuilder &builder, mlir::Location loc,
9007 llvm::ArrayRef<mlir::Value> args) {
9008 assert(args.size() > 0 && "max requires at least one argument");
9009 return IntrinsicLibrary{builder, loc}
9010 .genExtremum<Extremum::Max, ExtremumBehavior::MinMaxss>(args[0].getType(),
9011 args);
9012}
9013
9014mlir::Value genMin(fir::FirOpBuilder &builder, mlir::Location loc,
9015 llvm::ArrayRef<mlir::Value> args) {
9016 assert(args.size() > 0 && "min requires at least one argument");
9017 return IntrinsicLibrary{builder, loc}
9018 .genExtremum<Extremum::Min, ExtremumBehavior::MinMaxss>(args[0].getType(),
9019 args);
9020}
9021
9022mlir::Value genDivC(fir::FirOpBuilder &builder, mlir::Location loc,
9023 mlir::Type type, mlir::Value x, mlir::Value y) {
9024 return IntrinsicLibrary{builder, loc}.genRuntimeCall("divc", type, {x, y});
9025}
9026
9027mlir::Value genPow(fir::FirOpBuilder &builder, mlir::Location loc,
9028 mlir::Type type, mlir::Value x, mlir::Value y) {
9029 // TODO: since there is no libm version of pow with integer exponent,
9030 // we have to provide an alternative implementation for
9031 // "precise/strict" FP mode.
9032 // One option is to generate internal function with inlined
9033 // implementation and mark it 'strictfp'.
9034 // Another option is to implement it in Fortran runtime library
9035 // (just like matmul).
9036 return IntrinsicLibrary{builder, loc}.genRuntimeCall("pow", type, {x, y});
9037}
9038
9039mlir::SymbolRefAttr
9040getUnrestrictedIntrinsicSymbolRefAttr(fir::FirOpBuilder &builder,
9041 mlir::Location loc, llvm::StringRef name,
9042 mlir::FunctionType signature) {
9043 return IntrinsicLibrary{builder, loc}.getUnrestrictedIntrinsicSymbolRefAttr(
9044 name, signature);
9045}
9046} // namespace fir
9047

source code of flang/lib/Optimizer/Builder/IntrinsicCall.cpp