futhark 0.28.1 → 0.28.2
raw patch · 127 files changed
+4601/−1464 lines, 127 files
Files
- CHANGELOG.md +51/−0
- docs/binary-data-format.rst +2/−2
- docs/c-api.rst +5/−5
- docs/language-reference.rst +12/−10
- docs/man/futhark-test.rst +11/−0
- docs/man/futhark.rst +2/−2
- docs/server-protocol.rst +1/−1
- futhark.cabal +3/−1
- prelude/math.fut +8/−8
- prelude/prelude.fut +11/−0
- rts/c/backends/c.h +1/−0
- rts/c/backends/cuda.h +9/−7
- rts/c/backends/hip.h +9/−7
- rts/c/backends/multicore.h +3/−1
- rts/c/backends/opencl.h +9/−7
- rts/c/cache.h +1/−1
- rts/c/context.h +12/−2
- rts/c/context_prototypes.h +16/−4
- rts/c/copy.h +97/−103
- rts/c/event_list.h +5/−0
- rts/c/gpu.h +56/−31
- rts/c/half.h +37/−24
- rts/c/scalar.h +230/−111
- rts/c/scalar_f16.h +14/−10
- rts/c/scheduler.h +33/−38
- rts/c/server.h +89/−36
- rts/c/tuning.h +6/−3
- rts/c/uniform.h +128/−52
- rts/c/util.h +18/−5
- rts/c/values.h +42/−60
- rts/cuda/prelude.cu +12/−0
- rts/opencl/transpose.cl +41/−25
- rts/python/memory.py +49/−49
- rts/python/opencl.py +4/−3
- rts/python/scalar.py +51/−24
- src-testing/Futhark/IR/Prop/ReshapeTests.hs +8/−0
- src-testing/Futhark/LspTests.hs +141/−12
- src/Futhark/AD/Derivatives.hs +15/−4
- src/Futhark/AD/Rev/Acc.hs +1/−1
- src/Futhark/AD/Rev/Loop.hs +1/−1
- src/Futhark/Actions.hs +43/−0
- src/Futhark/Analysis/CallGraph.hs +9/−9
- src/Futhark/Analysis/PrimExp.hs +1/−1
- src/Futhark/CLI/Dev.hs +20/−0
- src/Futhark/CLI/Eval.hs +4/−1
- src/Futhark/CLI/Literate.hs +2/−1
- src/Futhark/CLI/Test.hs +62/−7
- src/Futhark/CodeGen/Backends/CCUDA.hs +4/−3
- src/Futhark/CodeGen/Backends/COpenCL.hs +4/−3
- src/Futhark/CodeGen/Backends/GPU.hs +10/−10
- src/Futhark/CodeGen/Backends/GenericC.hs +24/−21
- src/Futhark/CodeGen/Backends/GenericC/CLI.hs +1/−2
- src/Futhark/CodeGen/Backends/GenericC/Code.hs +6/−3
- src/Futhark/CodeGen/Backends/GenericC/Fun.hs +1/−1
- src/Futhark/CodeGen/Backends/GenericC/Monad.hs +20/−13
- src/Futhark/CodeGen/Backends/GenericC/Pretty.hs +5/−0
- src/Futhark/CodeGen/Backends/GenericC/Server.hs +92/−41
- src/Futhark/CodeGen/Backends/GenericC/Types.hs +27/−20
- src/Futhark/CodeGen/Backends/GenericPython.hs +0/−1
- src/Futhark/CodeGen/Backends/GenericWASM.hs +2/−0
- src/Futhark/CodeGen/Backends/HIP.hs +4/−3
- src/Futhark/CodeGen/Backends/MulticoreC.hs +1/−1
- src/Futhark/CodeGen/Backends/MulticoreISPC.hs +13/−11
- src/Futhark/CodeGen/Backends/PyOpenCL.hs +7/−7
- src/Futhark/CodeGen/ImpCode/GPU.hs +5/−0
- src/Futhark/CodeGen/ImpCode/Kernels.hs +79/−0
- src/Futhark/CodeGen/ImpCode/OpenCL.hs +3/−74
- src/Futhark/CodeGen/ImpGen/GPU/Base.hs +27/−11
- src/Futhark/CodeGen/ImpGen/GPU/Block.hs +15/−13
- src/Futhark/CodeGen/ImpGen/GPU/SegRed.hs +7/−1
- src/Futhark/CodeGen/ImpGen/GPU/SegScan/SinglePass.hs +28/−20
- src/Futhark/CodeGen/ImpGen/GPU/ToOpenCL.hs +12/−8
- src/Futhark/Eval.hs +24/−10
- src/Futhark/IR/Aliases.hs +61/−21
- src/Futhark/IR/GPU.hs +2/−2
- src/Futhark/IR/GPU/Op.hs +10/−11
- src/Futhark/IR/GPU/Simplify.hs +5/−4
- src/Futhark/IR/GPUMem.hs +2/−2
- src/Futhark/IR/MC.hs +2/−2
- src/Futhark/IR/MC/Op.hs +7/−7
- src/Futhark/IR/MCMem.hs +2/−2
- src/Futhark/IR/Mem.hs +13/−15
- src/Futhark/IR/Parse.hs +7/−3
- src/Futhark/IR/Pretty.hs +8/−4
- src/Futhark/IR/Prop.hs +26/−2
- src/Futhark/IR/Prop/Reshape.hs +2/−2
- src/Futhark/IR/Prop/Scope.hs +3/−0
- src/Futhark/IR/Run.hs +1915/−0
- src/Futhark/IR/SOACS.hs +2/−2
- src/Futhark/IR/SOACS/SOAC.hs +7/−6
- src/Futhark/IR/SOACS/Simplify.hs +19/−11
- src/Futhark/IR/SegOp.hs +15/−16
- src/Futhark/IR/Seq.hs +4/−4
- src/Futhark/IR/SeqMem.hs +4/−4
- src/Futhark/IR/Traversals.hs +0/−18
- src/Futhark/IR/TypeCheck.hs +2/−3
- src/Futhark/Internalise/Defunctorise.hs +20/−21
- src/Futhark/Internalise/Exps.hs +25/−21
- src/Futhark/LSP/CodeLens.hs +4/−4
- src/Futhark/LSP/Compile.hs +59/−49
- src/Futhark/LSP/Diagnostic.hs +70/−54
- src/Futhark/LSP/Handlers.hs +25/−12
- src/Futhark/LSP/State.hs +16/−4
- src/Futhark/LSP/Tool.hs +7/−13
- src/Futhark/Optimise/ArrayShortCircuiting/ArrayCoalescing.hs +10/−5
- src/Futhark/Optimise/InliningDeadFun.hs +6/−4
- src/Futhark/Optimise/Simplify/Engine.hs +45/−19
- src/Futhark/Optimise/Simplify/Rule.hs +3/−1
- src/Futhark/Optimise/Simplify/Rules.hs +22/−14
- src/Futhark/Optimise/Simplify/Rules/BasicOp.hs +1/−0
- src/Futhark/Optimise/Simplify/Rules/Index.hs +11/−2
- src/Futhark/Optimise/Simplify/Rules/Loop.hs +2/−2
- src/Futhark/Optimise/Simplify/Rules/Match.hs +3/−3
- src/Futhark/Optimise/Simplify/Rules/Simple.hs +19/−17
- src/Futhark/Pass/AD.hs +5/−2
- src/Futhark/Test.hs +4/−2
- src/Futhark/Test/Property.hs +13/−5
- src/Futhark/Util/Loc.hs +4/−1
- src/Language/Futhark/Interpreter.hs +20/−4
- src/Language/Futhark/Interpreter/FFI/ServerM.hs +12/−0
- src/Language/Futhark/Interpreter/IO.hs +104/−23
- src/Language/Futhark/Interpreter/Values.hs +58/−4
- src/Language/Futhark/Parser/Lexer/Wrapper.hs +4/−1
- src/Language/Futhark/Primitive.hs +61/−67
- src/Language/Futhark/Prop.hs +8/−0
- src/Language/Futhark/Syntax.hs +4/−3
- src/Language/Futhark/TypeChecker/Modules.hs +32/−20
CHANGELOG.md view
@@ -5,6 +5,57 @@ The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/) and this project adheres to [Semantic Versioning](http://semver.org/spec/v2.0.0.html). +## [0.28.2]++### Added++* `io.savevalue` for writing a value to a file in the binary data format.++* Better detection of host OOM, although still unreliable on systems with+ overcommit.++* With GPU backends, unstructured copies are now sometimes a lot faster, as the+ run-time now dynamically tries to choose the best copying order.++### Fixed++* `futhark lsp` now handles `textDocument/semanticTokens/full` in a trivial way+ to work around a bug in the `lsp` library.++* `futhark lsp` had an off-by-one error when computing column offsets.++* Incorrect constant folding of `x %% x`.++* Signed division by -1 is now properly defined.++* A compiler crash when unifying parametric module types. (#2581)++* Invalid simplification of indexes could lead to compiler crash.++* Multicore backend contexts would become unusuable after the first failure.++* Partial arithmetic operations accessed through prelude modules (like `i32./`)+ lacked safety checks.++* `u16.f16`, `u16.f32`, and `u16.f64` was defective in the interpreter.++* Various cases where generated C code might exhibit undefined behaviour.++* Various compiler crashes (#2588, #2587, #2586).++* An invalid simplification that could lead to incorrect results (#2585).++* Various fixes to binary input validation.++* Handling of unsigned integer exponents in the interpreter.++* Bitshift operators are now fully defined, with masking of problematic shift+ amounts.++* `f16.sgn` was missing on some targets.++* Various obscure floating-point errors in the `ispc` backend.+ ## [0.28.1] ### Added
docs/binary-data-format.rst view
@@ -48,12 +48,12 @@ b <version> 0 <type> <value> -To encode an array, we encode the number of dimensions ``n`` as a+To encode an array, we encode the number of dimensions ``k`` as a single byte, each dimension ``dim_i`` as an unsigned 64-bit little endian integer, and finally all the values in row-major order in their binary little endian representation:: - b <version> <n> <type> <dim_1> <dim_2> ... <dim_n> <values...>+ b <version> <k> <type> <dim_1> <dim_2> ... <dim_k> <values...> Type Values
docs/c-api.rst view
@@ -387,11 +387,11 @@ .. c:function:: struct futhark_opaque_foo* futhark_restore_opaque_foo(struct futhark_context *ctx, const void *p) Asynchronously restore a byte sequence previously written with- :c:func:`futhark_store_opaque_foo`. Returns ``NULL`` on failure.- The byte sequence does not need to have been generated by the same- program *instance*, but it *must* have been generated by the same- Futhark program, and compiled with the same version of the Futhark- compiler.+ :c:func:`futhark_store_opaque_foo`. Returns ``NULL`` on failure. The byte+ sequence does not need to have been generated by the same program *instance*,+ but it *must* have been generated by the same Futhark program, and compiled+ with the same version of the Futhark compiler. This also implies that this+ function is not safe to call with untrusted input. .. _records:
docs/language-reference.rst view
@@ -818,13 +818,16 @@ ``x`` *binop* ``y`` ................... -Apply an operator to ``x`` and ``y``. Operators are functions like-any other, and can be user-defined. Futhark pre-defines certain-"magical" *overloaded* operators that work on several types.-Overloaded operators cannot be defined by the user. Both operands-must have the same type. The predefined operators and their semantics-are:+Apply an operator to ``x`` and ``y``. Operators are functions like any other,+and can be user-defined. Futhark pre-defines certain "magical" *overloaded*+operators that work on several types. Overloaded operators cannot be defined by+the user. Both operands must have the same type. Arithmetic is fully defined for+all numeric types, except for integer division by zero, which is an error.+Integer arithmetic uses conventional overflow/wraparound. Floating-point numbers+use IEEE 754 semantics, or the closest that the platform can achieve. +The predefined operators and their semantics are:+ ``**`` Power operator, defined for all numeric types.@@ -841,10 +844,9 @@ ``^``, ``&``, ``|``, ``>>``, ``<<`` - Bitwise operators, respectively bitwise xor, and, or, arithmetic- shift right and left, and logical shift right. **Shifting is- undefined if the right operand is negative, or greater than or- equal to the length in bits of the left operand.**+ Bitwise operators on integers, respectively bitwise xor, and, or, arithmetic+ shift right and left, and logical shift right. The shift count is taken+ modulo the bit width of the integer type. Note that, unlike in C, bitwise operators have *higher* priority than arithmetic operators. This means that ``x & y == z`` is
docs/man/futhark-test.rst view
@@ -145,6 +145,9 @@ entry points. A good rule of thumb is to do all nontrivial work inside entry points. +The expression is treated as untrusted code, so IO operations that modify the+file system, such as ``io.savevalue``, are not permitted. Reading files is allowed.+ PROPERTY-BASED TESTING ---------------------- @@ -229,6 +232,14 @@ -I Pass the program through the compiler frontend, but do not run them. This is only useful for testing the Futhark compiler itself.++--interpret-soacs+ Run the tests with the IR interpreter, using the SOACS representation. Mostly+ useful for compiler hacking.++--interpret-gpu+ Run the tests with the IR interpreter, using the GPU representation. Mostly+ useful for compiler hacking. -t Type-check the programs, but do not run them.
docs/man/futhark.rst view
@@ -77,8 +77,8 @@ futhark eval [options...] <exprs...> ------------------------------------ -Evaluates expressions given as command-line arguments. Optionally-allows a file import using ``-f``.+Evaluates expressions given as command-line arguments. Optionally allows a file+import using ``-f``. Prints results textually. If ``--backend`` is passed, the entry points of the file loaded with ``-f`` are compiled, as for :ref:`futhark-repl(1)`.
docs/server-protocol.rst view
@@ -31,7 +31,7 @@ fails, the process will terminate. If a command fails, the server will print ``%%% FAILURE`` followed by the error message, and then ``%%% OK`` when it is ready for more input. Some output may also precede ``%%% FAILURE``, e.g. logging-statements that occured before failure was detected. Fatal errors that lead to+statements that occurred before failure was detected. Fatal errors that lead to server shutdown may be printed to stderr. Variables
futhark.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: futhark-version: 0.28.1+version: 0.28.2 synopsis: An optimising compiler for a functional, array-oriented language. description: Futhark is a small programming language designed to be compiled to@@ -222,6 +222,7 @@ Futhark.CodeGen.RTS.JavaScript Futhark.CodeGen.ImpCode Futhark.CodeGen.ImpCode.GPU+ Futhark.CodeGen.ImpCode.Kernels Futhark.CodeGen.ImpCode.Multicore Futhark.CodeGen.ImpCode.OpenCL Futhark.CodeGen.ImpCode.Sequential@@ -288,6 +289,7 @@ Futhark.IR.Rep Futhark.IR.Rephrase Futhark.IR.RetType+ Futhark.IR.Run Futhark.IR.SOACS Futhark.IR.SOACS.SOAC Futhark.IR.SOACS.Simplify
prelude/math.fut view
@@ -352,7 +352,7 @@ def (-) (x: i8) (y: i8) = intrinsics.sub8 (x, y) def (*) (x: i8) (y: i8) = intrinsics.mul8 (x, y) def (/) (x: i8) (y: i8) = intrinsics.sdiv8 (x, y)- def (**) (x: i8) (y: i8) = intrinsics.pow8 (x, y)+ def (**) (x: i8) (y: i8) = intrinsics.spow8 (x, y) def (%) (x: i8) (y: i8) = intrinsics.smod8 (x, y) def (//) (x: i8) (y: i8) = intrinsics.squot8 (x, y) def (%%) (x: i8) (y: i8) = intrinsics.srem8 (x, y)@@ -427,7 +427,7 @@ def (-) (x: i16) (y: i16) = intrinsics.sub16 (x, y) def (*) (x: i16) (y: i16) = intrinsics.mul16 (x, y) def (/) (x: i16) (y: i16) = intrinsics.sdiv16 (x, y)- def (**) (x: i16) (y: i16) = intrinsics.pow16 (x, y)+ def (**) (x: i16) (y: i16) = intrinsics.spow16 (x, y) def (%) (x: i16) (y: i16) = intrinsics.smod16 (x, y) def (//) (x: i16) (y: i16) = intrinsics.squot16 (x, y) def (%%) (x: i16) (y: i16) = intrinsics.srem16 (x, y)@@ -505,7 +505,7 @@ def (-) (x: i32) (y: i32) = intrinsics.sub32 (x, y) def (*) (x: i32) (y: i32) = intrinsics.mul32 (x, y) def (/) (x: i32) (y: i32) = intrinsics.sdiv32 (x, y)- def (**) (x: i32) (y: i32) = intrinsics.pow32 (x, y)+ def (**) (x: i32) (y: i32) = intrinsics.spow32 (x, y) def (%) (x: i32) (y: i32) = intrinsics.smod32 (x, y) def (//) (x: i32) (y: i32) = intrinsics.squot32 (x, y) def (%%) (x: i32) (y: i32) = intrinsics.srem32 (x, y)@@ -583,7 +583,7 @@ def (-) (x: i64) (y: i64) = intrinsics.sub64 (x, y) def (*) (x: i64) (y: i64) = intrinsics.mul64 (x, y) def (/) (x: i64) (y: i64) = intrinsics.sdiv64 (x, y)- def (**) (x: i64) (y: i64) = intrinsics.pow64 (x, y)+ def (**) (x: i64) (y: i64) = intrinsics.spow64 (x, y) def (%) (x: i64) (y: i64) = intrinsics.smod64 (x, y) def (//) (x: i64) (y: i64) = intrinsics.squot64 (x, y) def (%%) (x: i64) (y: i64) = intrinsics.srem64 (x, y)@@ -661,7 +661,7 @@ def (-) (x: u8) (y: u8) = unsign (intrinsics.sub8 (sign x, sign y)) def (*) (x: u8) (y: u8) = unsign (intrinsics.mul8 (sign x, sign y)) def (/) (x: u8) (y: u8) = unsign (intrinsics.udiv8 (sign x, sign y))- def (**) (x: u8) (y: u8) = unsign (intrinsics.pow8 (sign x, sign y))+ def (**) (x: u8) (y: u8) = unsign (intrinsics.upow8 (sign x, sign y)) def (%) (x: u8) (y: u8) = unsign (intrinsics.umod8 (sign x, sign y)) def (//) (x: u8) (y: u8) = unsign (intrinsics.udiv8 (sign x, sign y)) def (%%) (x: u8) (y: u8) = unsign (intrinsics.umod8 (sign x, sign y))@@ -739,7 +739,7 @@ def (-) (x: u16) (y: u16) = unsign (intrinsics.sub16 (sign x, sign y)) def (*) (x: u16) (y: u16) = unsign (intrinsics.mul16 (sign x, sign y)) def (/) (x: u16) (y: u16) = unsign (intrinsics.udiv16 (sign x, sign y))- def (**) (x: u16) (y: u16) = unsign (intrinsics.pow16 (sign x, sign y))+ def (**) (x: u16) (y: u16) = unsign (intrinsics.upow16 (sign x, sign y)) def (%) (x: u16) (y: u16) = unsign (intrinsics.umod16 (sign x, sign y)) def (//) (x: u16) (y: u16) = unsign (intrinsics.udiv16 (sign x, sign y)) def (%%) (x: u16) (y: u16) = unsign (intrinsics.umod16 (sign x, sign y))@@ -817,7 +817,7 @@ def (-) (x: u32) (y: u32) = unsign (intrinsics.sub32 (sign x, sign y)) def (*) (x: u32) (y: u32) = unsign (intrinsics.mul32 (sign x, sign y)) def (/) (x: u32) (y: u32) = unsign (intrinsics.udiv32 (sign x, sign y))- def (**) (x: u32) (y: u32) = unsign (intrinsics.pow32 (sign x, sign y))+ def (**) (x: u32) (y: u32) = unsign (intrinsics.upow32 (sign x, sign y)) def (%) (x: u32) (y: u32) = unsign (intrinsics.umod32 (sign x, sign y)) def (//) (x: u32) (y: u32) = unsign (intrinsics.udiv32 (sign x, sign y)) def (%%) (x: u32) (y: u32) = unsign (intrinsics.umod32 (sign x, sign y))@@ -895,7 +895,7 @@ def (-) (x: u64) (y: u64) = unsign (intrinsics.sub64 (sign x, sign y)) def (*) (x: u64) (y: u64) = unsign (intrinsics.mul64 (sign x, sign y)) def (/) (x: u64) (y: u64) = unsign (intrinsics.udiv64 (sign x, sign y))- def (**) (x: u64) (y: u64) = unsign (intrinsics.pow64 (sign x, sign y))+ def (**) (x: u64) (y: u64) = unsign (intrinsics.upow64 (sign x, sign y)) def (%) (x: u64) (y: u64) = unsign (intrinsics.umod64 (sign x, sign y)) def (//) (x: u64) (y: u64) = unsign (intrinsics.udiv64 (sign x, sign y)) def (%%) (x: u64) (y: u64) = unsign (intrinsics.umod64 (sign x, sign y))
prelude/prelude.fut view
@@ -63,9 +63,20 @@ -- file. Only supports primitives, arrays of primitives, and tuples. If -- the type is a tuple, the file must contain one value for each element. val loadvalue 'a [k] : [k]u8 -> *a++ -- | Save a Futhark value in the specified file using the binary data+ -- format. This is obviously a rather dangerous operation if executed by+ -- untrusted code as it can write to arbitrary files, and hence it is not+ -- allowed in test specs.+ --+ -- Only primitives, arrays of primitives, and tuples of these can be+ -- saved, as for 'loadvalue'. One value is written per field of a tuple,+ -- in field order.+ val savevalue 'a [k] : [k]u8 -> a -> () } = { def loadbytes = intrinsics.io_loadbytes def loadimg = intrinsics.io_loadimg def loadaudio = intrinsics.io_loadaudio def loadvalue = intrinsics.io_loadvalue+ def savevalue = intrinsics.io_savevalue }
rts/c/backends/c.h view
@@ -41,6 +41,7 @@ lock_t lock; char *error; lock_t error_lock;+ lock_t mem_lock; // Protects the memory usage statistics. FILE *log; struct constants *constants; struct free_list free_list;
rts/c/backends/cuda.h view
@@ -200,6 +200,7 @@ lock_t lock; char *error; lock_t error_lock;+ lock_t mem_lock; // Protects the memory usage statistics. FILE *log; struct constants *constants; struct free_list free_list;@@ -699,7 +700,8 @@ } } -static int cuda_event_report(struct str_builder* sb, struct cuda_event* e) {+static int cuda_event_report(struct str_builder* sb, void* p) {+ struct cuda_event* e = (struct cuda_event*)p; float ms; CUresult err; if ((err = cuEventElapsedTime(&ms, e->start, e->end)) != CUDA_SUCCESS) {@@ -915,7 +917,7 @@ provenance, NULL, event,- (event_report_fn)cuda_event_report);+ cuda_event_report); CUDA_SUCCEED_FATAL(cuEventRecord(event->start, ctx->stream)); } CUDA_SUCCEED_OR_RETURN(cuMemcpyHtoD(dst + offset, src, size));@@ -936,7 +938,7 @@ provenance, NULL, event,- (event_report_fn)cuda_event_report);+ cuda_event_report); CUDA_SUCCEED_FATAL(cuEventRecord(event->start, ctx->stream)); } CUDA_SUCCEED_OR_RETURN(cuMemcpyDtoH(dst, src + offset, size));@@ -958,7 +960,7 @@ provenance, NULL, event,- (event_report_fn)cuda_event_report);+ cuda_event_report); CUDA_SUCCEED_FATAL(cuEventRecord(event->start, ctx->stream)); } CUDA_SUCCEED_OR_RETURN(cuMemcpyAsync(dst+dst_offset, src+src_offset, nbytes, ctx->stream));@@ -982,7 +984,7 @@ provenance, NULL, event,- (event_report_fn)cuda_event_report);+ cuda_event_report); CUDA_SUCCEED_FATAL(cuEventRecord(event->start, ctx->stream)); } if (sync) {@@ -1013,7 +1015,7 @@ provenance, NULL, event,- (event_report_fn)cuda_event_report);+ cuda_event_report); CUDA_SUCCEED_FATAL(cuEventRecord(event->start, ctx->stream)); } if (sync) {@@ -1073,7 +1075,7 @@ provenance, kvs, event,- (event_report_fn)cuda_event_report);+ cuda_event_report); } CUDA_SUCCEED_OR_RETURN
rts/c/backends/hip.h view
@@ -168,6 +168,7 @@ lock_t lock; char *error; lock_t error_lock;+ lock_t mem_lock; // Protects the memory usage statistics. FILE *log; struct constants *constants; struct free_list free_list;@@ -553,7 +554,8 @@ } } -static int hip_event_report(struct str_builder* sb, struct hip_event* e) {+static int hip_event_report(struct str_builder* sb, void* p) {+ struct hip_event* e = (struct hip_event*)p; float ms; hipError_t err; if ((err = hipEventElapsedTime(&ms, e->start, e->end)) != hipSuccess) {@@ -733,7 +735,7 @@ provenance, NULL, event,- (event_report_fn)hip_event_report);+ hip_event_report); HIP_SUCCEED_FATAL(hipEventRecord(event->start, ctx->stream)); } HIP_SUCCEED_OR_RETURN(hipMemcpyHtoD((unsigned char*)dst + offset, src, size));@@ -754,7 +756,7 @@ provenance, NULL, event,- (event_report_fn)hip_event_report);+ hip_event_report); HIP_SUCCEED_FATAL(hipEventRecord(event->start, ctx->stream)); } HIP_SUCCEED_OR_RETURN(hipMemcpyDtoH(dst, (unsigned char*)src + offset, size));@@ -776,7 +778,7 @@ provenance, NULL, event,- (event_report_fn)hip_event_report);+ hip_event_report); HIP_SUCCEED_FATAL(hipEventRecord(event->start, ctx->stream)); } HIP_SUCCEED_OR_RETURN(hipMemcpyWithStream((unsigned char*)dst+dst_offset, (unsigned char*)src+src_offset,@@ -801,7 +803,7 @@ provenance, NULL, event,- (event_report_fn)hip_event_report);+ hip_event_report); HIP_SUCCEED_FATAL(hipEventRecord(event->start, ctx->stream)); } if (sync) {@@ -835,7 +837,7 @@ provenance, NULL, event,- (event_report_fn)hip_event_report);+ hip_event_report); HIP_SUCCEED_FATAL(hipEventRecord(event->start, ctx->stream)); } if (sync) {@@ -899,7 +901,7 @@ provenance, kvs, event,- (event_report_fn)hip_event_report);+ hip_event_report); } HIP_SUCCEED_OR_RETURN
rts/c/backends/multicore.h view
@@ -48,6 +48,7 @@ lock_t lock; char *error; lock_t error_lock;+ lock_t mem_lock; // Protects the memory usage statistics. FILE *log; struct constants *constants; struct free_list free_list;@@ -117,7 +118,8 @@ } } -static int mc_event_report(struct str_builder* sb, struct mc_event* e) {+static int mc_event_report(struct str_builder* sb, void* p) {+ struct mc_event* e = (struct mc_event*)p; float ms = e->aft - e->bef; str_builder(sb, ",\"duration\":%f", ms); free(e);
rts/c/backends/opencl.h view
@@ -434,6 +434,7 @@ lock_t lock; char *error; lock_t error_lock;+ lock_t mem_lock; // Protects the memory usage statistics. FILE *log; struct constants *constants; struct free_list free_list;@@ -634,7 +635,8 @@ } } -static int opencl_event_report(struct str_builder* sb, cl_event* e) {+static int opencl_event_report(struct str_builder* sb, void* p) {+ cl_event* e = (cl_event*)p; cl_int err; cl_ulong start_t, end_t; @@ -1213,7 +1215,7 @@ provenance, NULL, event,- (event_report_fn)opencl_event_report);+ opencl_event_report); } OPENCL_SUCCEED_OR_RETURN (clEnqueueWriteBuffer@@ -1233,7 +1235,7 @@ provenance, NULL, event,- (event_report_fn)opencl_event_report);+ opencl_event_report); } OPENCL_SUCCEED_OR_RETURN (clEnqueueReadBuffer@@ -1254,7 +1256,7 @@ provenance, NULL, event,- (event_report_fn)opencl_event_report);+ opencl_event_report); } // OpenCL swaps the usual order of operands for memcpy()-like // functions. The order below is not a typo.@@ -1282,7 +1284,7 @@ provenance, NULL, event,- (event_report_fn)opencl_event_report);+ opencl_event_report); } OPENCL_SUCCEED_OR_RETURN (clEnqueueWriteBuffer(ctx->queue,@@ -1311,7 +1313,7 @@ provenance, NULL, event,- (event_report_fn)opencl_event_report);+ opencl_event_report); } OPENCL_SUCCEED_OR_RETURN (clEnqueueReadBuffer(ctx->queue, src,@@ -1361,7 +1363,7 @@ provenance, kvs, event,- (event_report_fn)opencl_event_report);+ opencl_event_report); } if (ctx->debugging) {
rts/c/cache.h view
@@ -89,7 +89,7 @@ goto error; } - if (memcmp(f_hash, hash->hash, CACHE_HASH_SIZE) != 0) {+ if (memcmp(f_hash, hash->hash, CACHE_HASH_SIZE*sizeof(int32_t)) != 0) { errno = 0; goto error; }
rts/c/context.h view
@@ -46,12 +46,18 @@ return size < 1024*1024; } -static void host_alloc(struct futhark_context* ctx,- size_t size, const char* tag, size_t* size_out, void** mem_out) {+static int host_alloc(struct futhark_context* ctx,+ size_t size, const char* tag, size_t* size_out, void** mem_out) { if (is_small_alloc(size) || free_list_find(&ctx->free_list, size, tag, size_out, (fl_mem*)mem_out) != 0) { *size_out = size; *mem_out = malloc(size);+ if (*mem_out == NULL && size != 0) {+ set_error(ctx, msgprintf("Failed to allocate %lld bytes of host memory.\n",+ (long long)size));+ return FUTHARK_OUT_OF_MEMORY;+ } }+ return FUTHARK_SUCCESS; } static void host_free(struct futhark_context* ctx,@@ -87,8 +93,10 @@ } char *futhark_context_get_error(struct futhark_context *ctx) {+ lock_lock(&ctx->error_lock); char *error = ctx->error; ctx->error = NULL;+ lock_unlock(&ctx->error_lock); return error; } @@ -170,6 +178,7 @@ ctx->cfg->in_use = 1; ctx->program_initialised = false; create_lock(&ctx->error_lock);+ create_lock(&ctx->mem_lock); create_lock(&ctx->lock); free_list_init(&ctx->free_list); event_list_init(&ctx->event_list);@@ -206,6 +215,7 @@ free(ctx->error); free_lock(&ctx->lock); free_lock(&ctx->error_lock);+ free_lock(&ctx->mem_lock); ctx->cfg->in_use = 0; free(ctx); }
rts/c/context_prototypes.h view
@@ -23,8 +23,9 @@ static void setup_program(struct futhark_context* ctx); static void teardown_program(struct futhark_context *ctx); -// Allocate host memory. Must be freed with host_free().-static void host_alloc(struct futhark_context* ctx, size_t size, const char* tag, size_t* size_out, void** mem_out);+// Allocate host memory. Must be freed with host_free(). Returns+// FUTHARK_OUT_OF_MEMORY (and sets an error) on failure.+static int host_alloc(struct futhark_context* ctx, size_t size, const char* tag, size_t* size_out, void** mem_out); // Allocate memory allocated with host_alloc(). static void host_free(struct futhark_context* ctx, size_t size, const char* tag, void* mem); @@ -37,10 +38,21 @@ int64_t src_offset, int64_t src_strides[r], int64_t shape[r]); +// A copy that is a map(transpose). There are 'num_arrays' arrays, and in each+// of them, the source has 'rows' rows of 'cols' contiguous elements, while the+// destination has 'cols' rows of 'rows' contiguous elements. Element 'j' of row+// 'i' of source array 'l' is at index l*src_array_stride + i*src_row_stride ++// j, and is copied to index l*dst_array_stride + j*dst_row_stride + i.+struct lmad_transpose {+ int64_t num_arrays, rows, cols;+ int64_t dst_array_stride, dst_row_stride;+ int64_t src_array_stride, src_row_stride;+};+ static void log_transpose(struct futhark_context* ctx,- int64_t k, int64_t m, int64_t n);+ const struct lmad_transpose *tr); -static bool lmad_map_tr(int64_t *num_arrays_out, int64_t *n_out, int64_t *m_out,+static bool lmad_map_tr(struct lmad_transpose *tr, int r, const int64_t dst_strides[r], const int64_t src_strides[r],
rts/c/copy.h view
@@ -2,33 +2,43 @@ // Cache-oblivious map-transpose function. #define GEN_MAP_TRANSPOSE(NAME, ELEM_TYPE) \- static void map_transpose_##NAME \- (ELEM_TYPE* dst, ELEM_TYPE* src, \- int64_t k, int64_t m, int64_t n, \- int64_t cb, int64_t ce, int64_t rb, int64_t re) \+ static void transpose_##NAME \+ (ELEM_TYPE* dst, int64_t dst_row_stride, \+ ELEM_TYPE* src, int64_t src_row_stride, \+ int64_t rb, int64_t re, int64_t cb, int64_t ce) \ { \- int32_t r = re - rb; \- int32_t c = ce - cb; \- if (k == 1) { \+ int64_t r = re - rb; \+ int64_t c = ce - cb; \ if (r <= 64 && c <= 64) { \- for (int64_t j = 0; j < c; j++) { \- for (int64_t i = 0; i < r; i++) { \- dst[(j + cb) * n + (i + rb)] = src[(i + rb) * m + (j + cb)]; \+ for (int64_t j = cb; j < ce; j++) { \+ for (int64_t i = rb; i < re; i++) { \+ dst[j * dst_row_stride + i] = src[i * src_row_stride + j]; \ } \ } \ } else if (c <= r) { \- map_transpose_##NAME(dst, src, k, m, n, cb, ce, rb, rb + r/2); \- map_transpose_##NAME(dst, src, k, m, n, cb, ce, rb + r/2, re); \+ transpose_##NAME(dst, dst_row_stride, src, src_row_stride, \+ rb, rb + r/2, cb, ce); \+ transpose_##NAME(dst, dst_row_stride, src, src_row_stride, \+ rb + r/2, re, cb, ce); \ } else { \- map_transpose_##NAME(dst, src, k, m, n, cb, cb + c/2, rb, re); \- map_transpose_##NAME(dst, src, k, m, n, cb + c/2, ce, rb, re); \+ transpose_##NAME(dst, dst_row_stride, src, src_row_stride, \+ rb, re, cb, cb + c/2); \+ transpose_##NAME(dst, dst_row_stride, src, src_row_stride, \+ rb, re, cb + c/2, ce); \ } \- } else { \- for (int64_t i = 0; i < k; i++) { \- map_transpose_##NAME(dst + i * m * n, src + i * m * n, 1, m, n, cb, ce, rb, re); \- }\-} \-}+ } \+ \+ static void map_transpose_##NAME \+ (ELEM_TYPE* dst, ELEM_TYPE* src, const struct lmad_transpose *tr) \+ { \+ for (int64_t k = 0; k < tr->num_arrays; k++) { \+ transpose_##NAME(dst + k * tr->dst_array_stride, \+ tr->dst_row_stride, \+ src + k * tr->src_array_stride, \+ tr->src_row_stride, \+ 0, tr->rows, 0, tr->cols); \+ } \+ } // Straightforward LMAD copy function. #define GEN_LMAD_COPY_ELEMENTS(NAME, ELEM_TYPE) \@@ -37,11 +47,11 @@ ELEM_TYPE *src, int64_t src_strides[r], \ int64_t shape[r]) { \ if (r == 1) { \- for (int i = 0; i < shape[0]; i++) { \+ for (int64_t i = 0; i < shape[0]; i++) { \ dst[i*dst_strides[0]] = src[i*src_strides[0]]; \ } \ } else if (r > 1) { \- for (int i = 0; i < shape[0]; i++) { \+ for (int64_t i = 0; i < shape[0]; i++) { \ lmad_copy_elements_##NAME(r-1, \ dst+i*dst_strides[0], dst_strides+1, \ src+i*src_strides[0], src_strides+1, \@@ -50,92 +60,74 @@ } \ } \ -// Check whether this LMAD can be seen as a transposed 2D array. This-// is done by checking every possible splitting point.-static bool lmad_is_tr(int64_t *n_out, int64_t *m_out,- int r,- const int64_t strides[r],- const int64_t shape[r]) {- for (int i = 1; i < r; i++) {- int n = 1, m = 1;- bool ok = true;- int64_t expected = 1;- // Check strides before 'i'.- for (int j = i-1; j >= 0; j--) {- ok = ok && strides[j] == expected;- expected *= shape[j];- n *= shape[j];- }- // Check strides after 'i'.- for (int j = r-1; j >= i; j--) {- ok = ok && strides[j] == expected;- expected *= shape[j];- m *= shape[j];- }- if (ok) {- *n_out = n;- *m_out = m;- return true;- }- }- return false;-}--// This function determines whether the a 'dst' LMAD is row-major and-// 'src' LMAD is column-major. Both LMADs are for arrays of the same-// shape. Both LMADs are allowed to have additional dimensions "on-// top". Essentially, this function determines whether a copy from-// 'src' to 'dst' is a "map(transpose)" that we know how to implement-// efficiently. The LMADs can have arbitrary rank, and the main-// challenge here is checking whether the src LMAD actually-// corresponds to a 2D column-major layout by morally collapsing-// dimensions. There is a lot of looping here, but the actual trip-// count is going to be very low in practice.-//-// Returns true if this is indeed a map(transpose), and writes the-// number of arrays, and moral array size to appropriate output-// parameters.-static bool lmad_map_tr(int64_t *num_arrays_out, int64_t *n_out, int64_t *m_out,+// Determine whether a copy is a map(transpose), and if so, describe it in 'tr'.+// We first drop dimensions of size 1, and merge adjacent dimensions that can be+// expressed as a single dimension in both LMADs. If this leaves two or three+// dimensions, then the copy is a map(transpose) if one of the innermost two has+// unit stride in the source, and the other has unit stride in the destination.+// Only those strides are constrained; in particular the arrays need not be+// contiguous.+static bool lmad_map_tr(struct lmad_transpose *tr, int r, const int64_t dst_strides[r], const int64_t src_strides[r], const int64_t shape[r]) {- int64_t rowmajor_strides[r];- rowmajor_strides[r-1] = 1;-- for (int i = r-2; i >= 0; i--) {- rowmajor_strides[i] = rowmajor_strides[i+1] * shape[i+1];- }+ int64_t c_shape[3], c_dst_strides[3], c_src_strides[3];+ int c_r = 0; - // map_r will be the number of mapped dimensions on top.- int map_r = 0;- int64_t num_arrays = 1; for (int i = 0; i < r; i++) {- if (dst_strides[i] != rowmajor_strides[i] ||- src_strides[i] != rowmajor_strides[i]) {- break;+ if (shape[i] == 1) {+ continue;+ }+ if (c_r > 0 &&+ c_dst_strides[c_r-1] == dst_strides[i] * shape[i] &&+ c_src_strides[c_r-1] == src_strides[i] * shape[i]) {+ c_shape[c_r-1] *= shape[i];+ c_dst_strides[c_r-1] = dst_strides[i];+ c_src_strides[c_r-1] = src_strides[i];+ } else if (c_r == 3) {+ // More than three dimensions, so not a map(transpose).+ return false; } else {- num_arrays *= shape[i];- map_r++;+ c_shape[c_r] = shape[i];+ c_dst_strides[c_r] = dst_strides[i];+ c_src_strides[c_r] = src_strides[i];+ c_r++; } } - *num_arrays_out = num_arrays;+ // Here c_r is at most 3.+ if (c_r < 2) {+ return false;+ } - if (r==map_r) {+ // The innermost two dimensions are transposed, and the outermost one (if+ // any) is the map.+ int a = c_r-2, b = c_r-1;+ if (c_dst_strides[b] == 1 && c_src_strides[a] == 1) {+ tr->rows = c_shape[b];+ tr->cols = c_shape[a];+ tr->dst_row_stride = c_dst_strides[a];+ tr->src_row_stride = c_src_strides[b];+ } else if (c_dst_strides[a] == 1 && c_src_strides[b] == 1) {+ tr->rows = c_shape[a];+ tr->cols = c_shape[b];+ tr->dst_row_stride = c_dst_strides[b];+ tr->src_row_stride = c_src_strides[a];+ } else { return false; } - if (memcmp(&rowmajor_strides[map_r],- &dst_strides[map_r],- sizeof(int64_t)*(r-map_r)) == 0) {- return lmad_is_tr(n_out, m_out, r-map_r, src_strides+map_r, shape+map_r);- } else if (memcmp(&rowmajor_strides[map_r],- &src_strides[map_r],- sizeof(int64_t)*(r-map_r)) == 0) {- return lmad_is_tr(m_out, n_out, r-map_r, dst_strides+map_r, shape+map_r);+ if (c_r == 3) {+ tr->num_arrays = c_shape[0];+ tr->dst_array_stride = c_dst_strides[0];+ tr->src_array_stride = c_src_strides[0];+ } else {+ tr->num_arrays = 1;+ tr->dst_array_stride = 0;+ tr->src_array_stride = 0; }- return false;+ return true; } // Check if the strides correspond to row-major strides of *any*@@ -211,12 +203,16 @@ } static void log_transpose(struct futhark_context* ctx,- int64_t k, int64_t n, int64_t m) {+ const struct lmad_transpose *tr) { if (ctx->logging) { fprintf(ctx->log, "## Transpose\n");- fprintf(ctx->log, "Arrays : %ld\n", (long int)k);- fprintf(ctx->log, "X elements : %ld\n", (long int)m);- fprintf(ctx->log, "Y elements : %ld\n", (long int)n);+ fprintf(ctx->log, "Arrays : %ld\n", (long int)tr->num_arrays);+ fprintf(ctx->log, "X elements : %ld\n", (long int)tr->cols);+ fprintf(ctx->log, "Y elements : %ld\n", (long int)tr->rows);+ fprintf(ctx->log, "Dst strides: %ld %ld\n",+ (long int)tr->dst_array_stride, (long int)tr->dst_row_stride);+ fprintf(ctx->log, "Src strides: %ld %ld\n",+ (long int)tr->src_array_stride, (long int)tr->src_row_stride); fprintf(ctx->log, "\n"); } }@@ -232,12 +228,10 @@ int64_t size = 1; \ for (int i = 0; i < r; i++) { size *= shape[i]; } \ if (size == 0) { return; } \- int64_t k, n, m; \- if (lmad_map_tr(&k, &n, &m, \- r, dst_strides, src_strides, shape)) { \- log_transpose(ctx, k, n, m); \- map_transpose_##NAME \- (dst+dst_offset, src+src_offset, k, n, m, 0, n, 0, m); \+ struct lmad_transpose tr; \+ if (lmad_map_tr(&tr, r, dst_strides, src_strides, shape)) { \+ log_transpose(ctx, &tr); \+ map_transpose_##NAME(dst+dst_offset, src+src_offset, &tr); \ } else if (lmad_memcpyable(r, dst_strides, src_strides, shape)) { \ if (ctx->logging) {fprintf(ctx->log, "## Flat copy\n\n");} \ memcpy(dst+dst_offset, src+src_offset, size*sizeof(*dst)); \
rts/c/event_list.h view
@@ -47,11 +47,15 @@ return kvs; } +void kvs_printf(struct kvs* kvs, const char* key, const char* fmt, ...)+ __attribute__((format(printf, 3, 4)));+ void kvs_printf(struct kvs* kvs, const char* key, const char* fmt, ...) { va_list vl; va_start(vl, fmt); size_t needed = 1 + (size_t)vsnprintf(NULL, 0, fmt, vl);+ va_end(vl); while (kvs->buf_used+needed > kvs->buf_size) { kvs->buf_size *= 2;@@ -70,6 +74,7 @@ va_start(vl, fmt); // Must re-init. vsnprintf(&kvs->buf[kvs->vals[kvs->n]], needed, fmt, vl);+ va_end(vl); kvs->n++; }
rts/c/gpu.h view
@@ -345,27 +345,46 @@ const char *name, size_t elem_size, gpu_mem dst, int64_t dst_offset, gpu_mem src, int64_t src_offset,- int64_t k, int64_t n, int64_t m) {+ const struct lmad_transpose *tr) {+ int64_t k = tr->num_arrays;+ int64_t n = tr->rows;+ int64_t m = tr->cols; int64_t mulx = TR_BLOCK_DIM / n; int64_t muly = TR_BLOCK_DIM / m;+ int64_t strides[4] = { tr->dst_array_stride, tr->dst_row_stride,+ tr->src_array_stride, tr->src_row_stride }; int32_t mulx32 = mulx; int32_t muly32 = muly; int32_t k32 = k; int32_t n32 = n; int32_t m32 = m;+ int32_t strides32[4] = { strides[0], strides[1], strides[2], strides[3] }; + // Bounds on the magnitude of every partial index computed by the+ // kernels, used to decide whether 32-bit arithmetic suffices.+ int64_t dst_extent = dst_offset+ + (k-1) * llabs(tr->dst_array_stride)+ + (m-1) * llabs(tr->dst_row_stride) + n;+ int64_t src_extent = src_offset+ + (k-1) * llabs(tr->src_array_stride)+ + (n-1) * llabs(tr->src_row_stride) + m;+ gpu_kernel kernel = kernel_default; int32_t grid[3]; int32_t block[3]; - void* args[11];- size_t args_sizes[11] = {+ void* args[15];+ size_t args_sizes[15] = { sizeof(gpu_mem), sizeof(int64_t), sizeof(gpu_mem), sizeof(int64_t), sizeof(int32_t), sizeof(int32_t), sizeof(int32_t), sizeof(int32_t),+ sizeof(int32_t),+ sizeof(int32_t),+ sizeof(int32_t),+ sizeof(int32_t), sizeof(int32_t) }; @@ -373,11 +392,8 @@ args[1] = &dst_offset; args[2] = &src; args[3] = &src_offset;- args[7] = &mulx;- args[8] = &muly; - if (dst_offset + k * n * m <= 2147483647L &&- src_offset + k * n * m <= 2147483647L) {+ if (dst_extent <= 2147483647L && src_extent <= 2147483647L) { if (m <= TR_BLOCK_DIM/2 && n <= TR_BLOCK_DIM/2) { if (ctx->logging) { fprintf(ctx->log, "Using small kernel\n"); } kernel = kernel_small;@@ -422,8 +438,9 @@ args[4] = &k32; args[5] = &m32; args[6] = &n32;- args[7] = &mulx32;- args[8] = &muly32;+ for (int i = 0; i < 4; i++) { args[7+i] = &strides32[i]; }+ args[11] = &mulx32;+ args[12] = &muly32; } else { if (ctx->logging) { fprintf(ctx->log, "Using large kernel\n"); } kernel = kernel_large;@@ -436,13 +453,10 @@ args[4] = &k; args[5] = &m; args[6] = &n;- args[7] = &mulx;- args[8] = &muly;- args_sizes[4] = sizeof(int64_t);- args_sizes[5] = sizeof(int64_t);- args_sizes[6] = sizeof(int64_t);- args_sizes[7] = sizeof(int64_t);- args_sizes[8] = sizeof(int64_t);+ for (int i = 0; i < 4; i++) { args[7+i] = &strides[i]; }+ args[11] = &mulx;+ args[12] = &muly;+ for (int i = 4; i < 13; i++) { args_sizes[i] = sizeof(int64_t); } } // Cap the number of thead blocks we launch and figure out how many@@ -451,10 +465,10 @@ int32_t repeat_2 = grid[2] / MAX_TR_THREAD_BLOCKS; grid[1] = repeat_1 > 0 ? MAX_TR_THREAD_BLOCKS : grid[1]; grid[2] = repeat_2 > 0 ? MAX_TR_THREAD_BLOCKS : grid[2];- args[9] = &repeat_1;- args[10] = &repeat_2;- args_sizes[9] = sizeof(repeat_1);- args_sizes[10] = sizeof(repeat_2);+ args[13] = &repeat_1;+ args[14] = &repeat_2;+ args_sizes[13] = sizeof(repeat_1);+ args_sizes[14] = sizeof(repeat_2); if (ctx->logging) { fprintf(ctx->log, "\n");@@ -470,7 +484,7 @@ (struct futhark_context* ctx, const char* provenance, \ gpu_mem dst, int64_t dst_offset, \ gpu_mem src, int64_t src_offset, \- int64_t k, int64_t m, int64_t n) \+ const struct lmad_transpose *tr) \ { \ return \ gpu_map_transpose \@@ -482,8 +496,7 @@ ctx->kernels->map_transpose_##NAME##_small, \ ctx->kernels->map_transpose_##NAME##_large, \ "map_transpose_" #NAME, sizeof(ELEM_TYPE), \- dst, dst_offset, src, src_offset, \- k, n, m); \+ dst, dst_offset, src, src_offset, tr); \ } static int gpu_lmad_copy(struct futhark_context* ctx, const char* provenance,@@ -517,14 +530,27 @@ int64_t zero = 0; + // To improve the odds of coalesced memory accesses, we pass the dimensions in+ // order of increasing source stride, and secondarily destination stride, as+ // uncoalesced reads are much more costly than uncoalesced writes.+ int perm[8];+ for (int i = 0; i < r; i++) {+ int j = i;+ while (j > 0 && llabs(src_strides[perm[j-1]]) > llabs(src_strides[i])) {+ perm[j] = perm[j-1];+ j--;+ }+ perm[j] = i;+ }+ for (int i = 0; i < 8; i++) { args_sizes[6+i*3] = sizeof(int64_t); args_sizes[6+i*3+1] = sizeof(int64_t); args_sizes[6+i*3+2] = sizeof(int64_t); if (i < r) {- args[6+i*3] = &shape[i];- args[6+i*3+1] = &dst_strides[i];- args[6+i*3+2] = &src_strides[i];+ args[6+i*3] = &shape[perm[i]];+ args[6+i*3+1] = &dst_strides[perm[i]];+ args[6+i*3+2] = &src_strides[perm[i]]; } else { args[6+i*3] = &zero; args[6+i*3+1] = &zero;@@ -566,12 +592,11 @@ int64_t size = 1; \ for (int i = 0; i < r; i++) { size *= shape[i]; } \ if (size == 0) { return FUTHARK_SUCCESS; } \- int64_t k, n, m; \- if (lmad_map_tr(&k, &n, &m, \- r, dst_strides, src_strides, shape)) { \- log_transpose(ctx, k, n, m); \+ struct lmad_transpose tr; \+ if (lmad_map_tr(&tr, r, dst_strides, src_strides, shape)) { \+ log_transpose(ctx, &tr); \ return map_transpose_gpu2gpu_##NAME \- (ctx, provenance, dst, dst_offset, src, src_offset, k, n, m); \+ (ctx, provenance, dst, dst_offset, src, src_offset, &tr); \ } else if (lmad_memcpyable(r, dst_strides, src_strides, shape)) { \ if (ctx->logging) {fprintf(ctx->log, "## Flat copy\n\n");} \ return gpu_memcpy(ctx, \
rts/c/half.h view
@@ -34,9 +34,9 @@ 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,- 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0001, 0x0002, 0x0004, 0x0008, 0x0010, 0x0020, 0x0040, 0x0080, 0x0100,- 0x0200, 0x0400, 0x0800, 0x0C00, 0x1000, 0x1400, 0x1800, 0x1C00, 0x2000, 0x2400, 0x2800, 0x2C00, 0x3000, 0x3400, 0x3800, 0x3C00,- 0x4000, 0x4400, 0x4800, 0x4C00, 0x5000, 0x5400, 0x5800, 0x5C00, 0x6000, 0x6400, 0x6800, 0x6C00, 0x7000, 0x7400, 0x7800, 0x7C00,+ 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,+ 0x0000, 0x0000, 0x0400, 0x0800, 0x0C00, 0x1000, 0x1400, 0x1800, 0x1C00, 0x2000, 0x2400, 0x2800, 0x2C00, 0x3000, 0x3400, 0x3800,+ 0x3C00, 0x4000, 0x4400, 0x4800, 0x4C00, 0x5000, 0x5400, 0x5800, 0x5C00, 0x6000, 0x6400, 0x6800, 0x6C00, 0x7000, 0x7400, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00, 0x7C00,@@ -50,9 +50,9 @@ 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000,- 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8001, 0x8002, 0x8004, 0x8008, 0x8010, 0x8020, 0x8040, 0x8080, 0x8100,- 0x8200, 0x8400, 0x8800, 0x8C00, 0x9000, 0x9400, 0x9800, 0x9C00, 0xA000, 0xA400, 0xA800, 0xAC00, 0xB000, 0xB400, 0xB800, 0xBC00,- 0xC000, 0xC400, 0xC800, 0xCC00, 0xD000, 0xD400, 0xD800, 0xDC00, 0xE000, 0xE400, 0xE800, 0xEC00, 0xF000, 0xF400, 0xF800, 0xFC00,+ 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000, 0x8000,+ 0x8000, 0x8000, 0x8400, 0x8800, 0x8C00, 0x9000, 0x9400, 0x9800, 0x9C00, 0xA000, 0xA400, 0xA800, 0xAC00, 0xB000, 0xB400, 0xB800,+ 0xBC00, 0xC000, 0xC400, 0xC800, 0xCC00, 0xD000, 0xD400, 0xD800, 0xDC00, 0xE000, 0xE400, 0xE800, 0xEC00, 0xF000, 0xF400, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00,@@ -62,22 +62,22 @@ 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00, 0xFC00 }; __constant static const unsigned char shift_table[512] = {- 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24,- 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24,- 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24,- 24, 24, 24, 24, 24, 24, 24, 23, 22, 21, 20, 19, 18, 17, 16, 15, 14, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13,- 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24,- 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24,- 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24,- 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 13,- 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24,- 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24,- 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24,- 24, 24, 24, 24, 24, 24, 24, 23, 22, 21, 20, 19, 18, 17, 16, 15, 14, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13,- 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24,- 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24,- 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24,- 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 13 };+ 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25,+ 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25,+ 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25,+ 25, 25, 25, 25, 25, 25, 24, 23, 22, 21, 20, 19, 18, 17, 16, 15, 14, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13,+ 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25,+ 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25,+ 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25,+ 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25,+ 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25,+ 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25,+ 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25,+ 25, 25, 25, 25, 25, 25, 24, 23, 22, 21, 20, 19, 18, 17, 16, 15, 14, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13,+ 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25,+ 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25,+ 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25,+ 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25 }; __constant static const uint32_t mantissa_table[2048] = { 0x00000000, 0x33800000, 0x34000000, 0x34400000, 0x34800000, 0x34A00000, 0x34C00000, 0x34E00000, 0x35000000, 0x35100000, 0x35200000, 0x35300000, 0x35400000, 0x35500000, 0x35600000, 0x35700000,@@ -217,14 +217,27 @@ 0, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 0, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024 }; +// Rounds to nearest, ties to even, by adding just under half plus the+// low bit of the result before shifting. The mantissa includes the+// implicit bit, as it matters for rounding just below the smallest+// subnormal, so base_table does not include it. Rounding may carry+// into the exponent, which also turns values close to 2**16 into+// infinity. The shift is 25 where the result is zero or infinity,+// which discards the entire mantissa. SCALAR_FUN_ATTR uint16_t float2halfbits(float value) { union { float x; uint32_t y; } u; u.x = value; uint32_t bits = u.y; - uint16_t hbits = base_table[bits>>23] + (uint16_t)((bits&0x7FFFFF)>>shift_table[bits>>23]);;+ if ((bits & 0x7FFFFFFF) > 0x7F800000) {+ // NaN - keep the high payload bits and make sure it stays a NaN.+ return (uint16_t)(((bits >> 16) & 0x8000) | 0x7E00 | ((bits >> 13) & 0x3FF));+ } - return hbits;+ uint32_t m = (bits & 0x7FFFFF) | 0x800000;+ uint32_t s = shift_table[bits>>23];+ m += (1u << (s - 1)) - 1 + ((m >> s) & 1);+ return (uint16_t)(base_table[bits>>23] + (m >> s)); } SCALAR_FUN_ATTR float halfbits2float(uint16_t value) {
rts/c/scalar.h view
@@ -35,7 +35,7 @@ SCALAR_FUN_ATTR uint64_t sub64(uint64_t x, uint64_t y) { return x - y; } SCALAR_FUN_ATTR uint8_t mul8(uint8_t x, uint8_t y) { return x * y; }-SCALAR_FUN_ATTR uint16_t mul16(uint16_t x, uint16_t y) { return x * y; }+SCALAR_FUN_ATTR uint16_t mul16(uint16_t x, uint16_t y) { return (uint32_t)x * y; } SCALAR_FUN_ATTR uint32_t mul32(uint32_t x, uint32_t y) { return x * y; } SCALAR_FUN_ATTR uint64_t mul64(uint64_t x, uint64_t y) { return x * y; } @@ -69,28 +69,31 @@ return x / ys; } +// Unsigned ceiling division rounds the quotient up when the remainder+// is nonzero. Unlike (x + y - 1) / y, this cannot overflow.+ SCALAR_FUN_ATTR uint8_t uceil_div8(uint8_t x, uint8_t y) { uint8_t ys = 1; foreach_active(i) { ys = y; }- return (x + y - 1) / ys;+ return x / ys + (x % ys != 0 ? 1 : 0); } SCALAR_FUN_ATTR uint16_t uceil_div16(uint16_t x, uint16_t y) { uint16_t ys = 1; foreach_active(i) { ys = y; }- return (x + y - 1) / ys;+ return x / ys + (x % ys != 0 ? 1 : 0); } SCALAR_FUN_ATTR uint32_t uceil_div32(uint32_t x, uint32_t y) { uint32_t ys = 1; foreach_active(i) { ys = y; }- return (x + y - 1) / ys;+ return x / ys + (x % ys != 0 ? 1 : 0); } SCALAR_FUN_ATTR uint64_t uceil_div64(uint64_t x, uint64_t y) { uint64_t ys = 1; foreach_active(i) { ys = y; }- return (x + y - 1) / ys;+ return x / ys + (x % ys != 0 ? 1 : 0); } SCALAR_FUN_ATTR uint8_t umod8(uint8_t x, uint8_t y) {@@ -142,27 +145,19 @@ } SCALAR_FUN_ATTR uint8_t uceil_div_safe8(uint8_t x, uint8_t y) {- uint8_t ys = 1;- foreach_active(i) { ys = y; }- return y == 0 ? 0 : (x + y - 1) / ys;+ return y == 0 ? 0 : uceil_div8(x, y); } SCALAR_FUN_ATTR uint16_t uceil_div_safe16(uint16_t x, uint16_t y) {- uint16_t ys = 1;- foreach_active(i) { ys = y; }- return y == 0 ? 0 : (x + y - 1) / ys;+ return y == 0 ? 0 : uceil_div16(x, y); } SCALAR_FUN_ATTR uint32_t uceil_div_safe32(uint32_t x, uint32_t y) {- uint32_t ys = 1;- foreach_active(i) { ys = y; }- return y == 0 ? 0 : (x + y - 1) / ys;+ return y == 0 ? 0 : uceil_div32(x, y); } SCALAR_FUN_ATTR uint64_t uceil_div_safe64(uint64_t x, uint64_t y) {- uint64_t ys = 1;- foreach_active(i) { ys = y; }- return y == 0 ? 0 : (x + y - 1) / ys;+ return y == 0 ? 0 : uceil_div64(x, y); } SCALAR_FUN_ATTR uint8_t umod_safe8(uint8_t x, uint8_t y) {@@ -189,46 +184,100 @@ return y == 0 ? 0 : x % ys; } +// Signed division of the most negative value by -1 overflows, which+// traps on x86. Futhark defines the result to wrap (x / -1 == -x and+// x % -1 == 0), so we divide by 1 instead and negate the quotient+// where necessary.+ SCALAR_FUN_ATTR int8_t sdiv8(int8_t x, int8_t y) { int8_t ys = 1; foreach_active(i) { ys = y; }+ ys = ys == -1 ? 1 : ys; int8_t q = x / ys; int8_t r = x % ys;- return q - ((r != 0 && r < 0 != y < 0) ? 1 : 0);+ int8_t d = q - ((r != 0 && r < 0 != y < 0) ? 1 : 0);+ return y == -1 ? (int8_t)(0 - (uint8_t)x) : d; } SCALAR_FUN_ATTR int16_t sdiv16(int16_t x, int16_t y) { int16_t ys = 1; foreach_active(i) { ys = y; }+ ys = ys == -1 ? 1 : ys; int16_t q = x / ys; int16_t r = x % ys;- return q - ((r != 0 && r < 0 != y < 0) ? 1 : 0);+ int16_t d = q - ((r != 0 && r < 0 != y < 0) ? 1 : 0);+ return y == -1 ? (int16_t)(0 - (uint16_t)x) : d; } SCALAR_FUN_ATTR int32_t sdiv32(int32_t x, int32_t y) { int32_t ys = 1; foreach_active(i) { ys = y; }+ ys = ys == -1 ? 1 : ys; int32_t q = x / ys; int32_t r = x % ys;- return q - ((r != 0 && r < 0 != y < 0) ? 1 : 0);+ int32_t d = q - ((r != 0 && r < 0 != y < 0) ? 1 : 0);+ return y == -1 ? (int32_t)(0 - (uint32_t)x) : d; } SCALAR_FUN_ATTR int64_t sdiv64(int64_t x, int64_t y) { int64_t ys = 1; foreach_active(i) { ys = y; }+ ys = ys == -1 ? 1 : ys; int64_t q = x / ys; int64_t r = x % ys;- return q - ((r != 0 && r < 0 != y < 0) ? 1 : 0);+ int64_t d = q - ((r != 0 && r < 0 != y < 0) ? 1 : 0);+ return y == -1 ? (int64_t)(0 - (uint64_t)x) : d; } -SCALAR_FUN_ATTR int8_t sceil_div8(int8_t x, int8_t y) { return sdiv8(x + y - 1, y); }-SCALAR_FUN_ATTR int16_t sceil_div16(int16_t x, int16_t y) { return sdiv16(x + y - 1, y); }-SCALAR_FUN_ATTR int32_t sceil_div32(int32_t x, int32_t y) { return sdiv32(x + y - 1, y); }-SCALAR_FUN_ATTR int64_t sceil_div64(int64_t x, int64_t y) { return sdiv64(x + y - 1, y); }+// Ceiling division rounds the truncated quotient up when it is inexact+// and positive, i.e. when the remainder is nonzero and has the same+// sign as the divisor. Unlike (x + y - 1) / y, this cannot overflow+// and is also correct for negative divisors. +SCALAR_FUN_ATTR int8_t sceil_div8(int8_t x, int8_t y) {+ int8_t ys = 1;+ foreach_active(i) { ys = y; }+ ys = ys == -1 ? 1 : ys;+ int8_t q = x / ys;+ int8_t r = x % ys;+ int8_t d = q + ((r != 0 && (r > 0) == (y > 0)) ? 1 : 0);+ return y == -1 ? (int8_t)(0 - (uint8_t)x) : d;+}++SCALAR_FUN_ATTR int16_t sceil_div16(int16_t x, int16_t y) {+ int16_t ys = 1;+ foreach_active(i) { ys = y; }+ ys = ys == -1 ? 1 : ys;+ int16_t q = x / ys;+ int16_t r = x % ys;+ int16_t d = q + ((r != 0 && (r > 0) == (y > 0)) ? 1 : 0);+ return y == -1 ? (int16_t)(0 - (uint16_t)x) : d;+}++SCALAR_FUN_ATTR int32_t sceil_div32(int32_t x, int32_t y) {+ int32_t ys = 1;+ foreach_active(i) { ys = y; }+ ys = ys == -1 ? 1 : ys;+ int32_t q = x / ys;+ int32_t r = x % ys;+ int32_t d = q + ((r != 0 && (r > 0) == (y > 0)) ? 1 : 0);+ return y == -1 ? (int32_t)(0 - (uint32_t)x) : d;+}++SCALAR_FUN_ATTR int64_t sceil_div64(int64_t x, int64_t y) {+ int64_t ys = 1;+ foreach_active(i) { ys = y; }+ ys = ys == -1 ? 1 : ys;+ int64_t q = x / ys;+ int64_t r = x % ys;+ int64_t d = q + ((r != 0 && (r > 0) == (y > 0)) ? 1 : 0);+ return y == -1 ? (int64_t)(0 - (uint64_t)x) : d;+}+ SCALAR_FUN_ATTR int8_t smod8(int8_t x, int8_t y) { int8_t ys = 1; foreach_active(i) { ys = y; }+ ys = ys == -1 ? 1 : ys; int8_t r = x % ys; return r + (r == 0 || (x > 0 && y > 0) || (x < 0 && y < 0) ? 0 : y); }@@ -236,6 +285,7 @@ SCALAR_FUN_ATTR int16_t smod16(int16_t x, int16_t y) { int16_t ys = 1; foreach_active(i) { ys = y; }+ ys = ys == -1 ? 1 : ys; int16_t r = x % ys; return r + (r == 0 || (x > 0 && y > 0) || (x < 0 && y < 0) ? 0 : y); }@@ -243,6 +293,7 @@ SCALAR_FUN_ATTR int32_t smod32(int32_t x, int32_t y) { int32_t ys = 1; foreach_active(i) { ys = y; }+ ys = ys == -1 ? 1 : ys; int32_t r = x % ys; return r + (r == 0 || (x > 0 && y > 0) || (x < 0 && y < 0) ? 0 : y); }@@ -250,6 +301,7 @@ SCALAR_FUN_ATTR int64_t smod64(int64_t x, int64_t y) { int64_t ys = 1; foreach_active(i) { ys = y; }+ ys = ys == -1 ? 1 : ys; int64_t r = x % ys; return r + (r == 0 || (x > 0 && y > 0) || (x < 0 && y < 0) ? 0 : y); }@@ -259,10 +311,10 @@ SCALAR_FUN_ATTR int32_t sdiv_safe32(int32_t x, int32_t y) { return y == 0 ? 0 : sdiv32(x, y); } SCALAR_FUN_ATTR int64_t sdiv_safe64(int64_t x, int64_t y) { return y == 0 ? 0 : sdiv64(x, y); } -SCALAR_FUN_ATTR int8_t sceil_div_safe8(int8_t x, int8_t y) { return sdiv_safe8(x + y - 1, y); }-SCALAR_FUN_ATTR int16_t sceil_div_safe16(int16_t x, int16_t y) { return sdiv_safe16(x + y - 1, y); }-SCALAR_FUN_ATTR int32_t sceil_div_safe32(int32_t x, int32_t y) { return sdiv_safe32(x + y - 1, y); }-SCALAR_FUN_ATTR int64_t sceil_div_safe64(int64_t x, int64_t y) { return sdiv_safe64(x + y - 1, y); }+SCALAR_FUN_ATTR int8_t sceil_div_safe8(int8_t x, int8_t y) { return y == 0 ? 0 : sceil_div8(x, y); }+SCALAR_FUN_ATTR int16_t sceil_div_safe16(int16_t x, int16_t y) { return y == 0 ? 0 : sceil_div16(x, y); }+SCALAR_FUN_ATTR int32_t sceil_div_safe32(int32_t x, int32_t y) { return y == 0 ? 0 : sceil_div32(x, y); }+SCALAR_FUN_ATTR int64_t sceil_div_safe64(int64_t x, int64_t y) { return y == 0 ? 0 : sceil_div64(x, y); } SCALAR_FUN_ATTR int8_t smod_safe8(int8_t x, int8_t y) { return y == 0 ? 0 : smod8(x, y); } SCALAR_FUN_ATTR int16_t smod_safe16(int16_t x, int16_t y) { return y == 0 ? 0 : smod16(x, y); }@@ -272,96 +324,112 @@ SCALAR_FUN_ATTR int8_t squot8(int8_t x, int8_t y) { int8_t ys = 1; foreach_active(i) { ys = y; }- return x / ys;+ ys = ys == -1 ? 1 : ys;+ return y == -1 ? (int8_t)(0 - (uint8_t)x) : x / ys; } SCALAR_FUN_ATTR int16_t squot16(int16_t x, int16_t y) { int16_t ys = 1; foreach_active(i) { ys = y; }- return x / ys;+ ys = ys == -1 ? 1 : ys;+ return y == -1 ? (int16_t)(0 - (uint16_t)x) : x / ys; } SCALAR_FUN_ATTR int32_t squot32(int32_t x, int32_t y) { int32_t ys = 1; foreach_active(i) { ys = y; }- return x / ys;+ ys = ys == -1 ? 1 : ys;+ return y == -1 ? (int32_t)(0 - (uint32_t)x) : x / ys; } SCALAR_FUN_ATTR int64_t squot64(int64_t x, int64_t y) { int64_t ys = 1; foreach_active(i) { ys = y; }- return x / ys;+ ys = ys == -1 ? 1 : ys;+ return y == -1 ? (int64_t)(0 - (uint64_t)x) : x / ys; } SCALAR_FUN_ATTR int8_t srem8(int8_t x, int8_t y) { int8_t ys = 1; foreach_active(i) { ys = y; }+ ys = ys == -1 ? 1 : ys; return x % ys; } SCALAR_FUN_ATTR int16_t srem16(int16_t x, int16_t y) { int16_t ys = 1; foreach_active(i) { ys = y; }+ ys = ys == -1 ? 1 : ys; return x % ys; } SCALAR_FUN_ATTR int32_t srem32(int32_t x, int32_t y) { int32_t ys = 1; foreach_active(i) { ys = y; }+ ys = ys == -1 ? 1 : ys; return x % ys; } SCALAR_FUN_ATTR int64_t srem64(int64_t x, int64_t y) {- int8_t ys = 1;+ int64_t ys = 1; foreach_active(i) { ys = y; }+ ys = ys == -1 ? 1 : ys; return x % ys; } SCALAR_FUN_ATTR int8_t squot_safe8(int8_t x, int8_t y) { int8_t ys = 1; foreach_active(i) { ys = y; }- return y == 0 ? 0 : x / ys;+ ys = ys == -1 ? 1 : ys;+ return y == 0 ? 0 : y == -1 ? (int8_t)(0 - (uint8_t)x) : x / ys; } SCALAR_FUN_ATTR int16_t squot_safe16(int16_t x, int16_t y) { int16_t ys = 1; foreach_active(i) { ys = y; }- return y == 0 ? 0 : x / ys;+ ys = ys == -1 ? 1 : ys;+ return y == 0 ? 0 : y == -1 ? (int16_t)(0 - (uint16_t)x) : x / ys; } SCALAR_FUN_ATTR int32_t squot_safe32(int32_t x, int32_t y) { int32_t ys = 1; foreach_active(i) { ys = y; }- return y == 0 ? 0 : x / ys;+ ys = ys == -1 ? 1 : ys;+ return y == 0 ? 0 : y == -1 ? (int32_t)(0 - (uint32_t)x) : x / ys; } SCALAR_FUN_ATTR int64_t squot_safe64(int64_t x, int64_t y) { int64_t ys = 1; foreach_active(i) { ys = y; }- return y == 0 ? 0 : x / ys;+ ys = ys == -1 ? 1 : ys;+ return y == 0 ? 0 : y == -1 ? (int64_t)(0 - (uint64_t)x) : x / ys; } SCALAR_FUN_ATTR int8_t srem_safe8(int8_t x, int8_t y) { int8_t ys = 1; foreach_active(i) { ys = y; }+ ys = ys == -1 ? 1 : ys; return y == 0 ? 0 : x % ys; } SCALAR_FUN_ATTR int16_t srem_safe16(int16_t x, int16_t y) { int16_t ys = 1; foreach_active(i) { ys = y; }+ ys = ys == -1 ? 1 : ys; return y == 0 ? 0 : x % ys; } SCALAR_FUN_ATTR int32_t srem_safe32(int32_t x, int32_t y) { int32_t ys = 1; foreach_active(i) { ys = y; }+ ys = ys == -1 ? 1 : ys; return y == 0 ? 0 : x % ys; } SCALAR_FUN_ATTR int64_t srem_safe64(int64_t x, int64_t y) { int64_t ys = 1; foreach_active(i) { ys = y; }+ ys = ys == -1 ? 1 : ys; return y == 0 ? 0 : x % ys; } @@ -372,11 +440,14 @@ SCALAR_FUN_ATTR uint32_t udiv32(uint32_t x, uint32_t y) { return x / y; } SCALAR_FUN_ATTR uint64_t udiv64(uint64_t x, uint64_t y) { return x / y; } -SCALAR_FUN_ATTR uint8_t uceil_div8(uint8_t x, uint8_t y) { return (x + y - 1) / y; }-SCALAR_FUN_ATTR uint16_t uceil_div16(uint16_t x, uint16_t y) { return (x + y - 1) / y; }-SCALAR_FUN_ATTR uint32_t uceil_div32(uint32_t x, uint32_t y) { return (x + y - 1) / y; }-SCALAR_FUN_ATTR uint64_t uceil_div64(uint64_t x, uint64_t y) { return (x + y - 1) / y; }+// Unsigned ceiling division rounds the quotient up when the remainder+// is nonzero. Unlike (x + y - 1) / y, this cannot overflow. +SCALAR_FUN_ATTR uint8_t uceil_div8(uint8_t x, uint8_t y) { return x / y + (x % y != 0 ? 1 : 0); }+SCALAR_FUN_ATTR uint16_t uceil_div16(uint16_t x, uint16_t y) { return x / y + (x % y != 0 ? 1 : 0); }+SCALAR_FUN_ATTR uint32_t uceil_div32(uint32_t x, uint32_t y) { return x / y + (x % y != 0 ? 1 : 0); }+SCALAR_FUN_ATTR uint64_t uceil_div64(uint64_t x, uint64_t y) { return x / y + (x % y != 0 ? 1 : 0); }+ SCALAR_FUN_ATTR uint8_t umod8(uint8_t x, uint8_t y) { return x % y; } SCALAR_FUN_ATTR uint16_t umod16(uint16_t x, uint16_t y) { return x % y; } SCALAR_FUN_ATTR uint32_t umod32(uint32_t x, uint32_t y) { return x % y; }@@ -387,16 +458,22 @@ SCALAR_FUN_ATTR uint32_t udiv_safe32(uint32_t x, uint32_t y) { return y == 0 ? 0 : x / y; } SCALAR_FUN_ATTR uint64_t udiv_safe64(uint64_t x, uint64_t y) { return y == 0 ? 0 : x / y; } -SCALAR_FUN_ATTR uint8_t uceil_div_safe8(uint8_t x, uint8_t y) { return y == 0 ? 0 : (x + y - 1) / y; }-SCALAR_FUN_ATTR uint16_t uceil_div_safe16(uint16_t x, uint16_t y) { return y == 0 ? 0 : (x + y - 1) / y; }-SCALAR_FUN_ATTR uint32_t uceil_div_safe32(uint32_t x, uint32_t y) { return y == 0 ? 0 : (x + y - 1) / y; }-SCALAR_FUN_ATTR uint64_t uceil_div_safe64(uint64_t x, uint64_t y) { return y == 0 ? 0 : (x + y - 1) / y; }+SCALAR_FUN_ATTR uint8_t uceil_div_safe8(uint8_t x, uint8_t y) { return y == 0 ? 0 : uceil_div8(x, y); }+SCALAR_FUN_ATTR uint16_t uceil_div_safe16(uint16_t x, uint16_t y) { return y == 0 ? 0 : uceil_div16(x, y); }+SCALAR_FUN_ATTR uint32_t uceil_div_safe32(uint32_t x, uint32_t y) { return y == 0 ? 0 : uceil_div32(x, y); }+SCALAR_FUN_ATTR uint64_t uceil_div_safe64(uint64_t x, uint64_t y) { return y == 0 ? 0 : uceil_div64(x, y); } SCALAR_FUN_ATTR uint8_t umod_safe8(uint8_t x, uint8_t y) { return y == 0 ? 0 : x % y; } SCALAR_FUN_ATTR uint16_t umod_safe16(uint16_t x, uint16_t y) { return y == 0 ? 0 : x % y; } SCALAR_FUN_ATTR uint32_t umod_safe32(uint32_t x, uint32_t y) { return y == 0 ? 0 : x % y; } SCALAR_FUN_ATTR uint64_t umod_safe64(uint64_t x, uint64_t y) { return y == 0 ? 0 : x % y; } +// Signed division of the most negative value by -1 overflows, which+// is undefined behaviour in C and traps on x86. Futhark defines the+// result to wrap (x / -1 == -x and x % -1 == 0). The 8- and 16-bit+// operands are promoted to int before dividing, so only the 32- and+// 64-bit operations need to check for this.+ SCALAR_FUN_ATTR int8_t sdiv8(int8_t x, int8_t y) { int8_t q = x / y; int8_t r = x % y;@@ -410,22 +487,58 @@ } SCALAR_FUN_ATTR int32_t sdiv32(int32_t x, int32_t y) {+ if (y == -1) {+ return (int32_t)(0 - (uint32_t)x);+ } int32_t q = x / y; int32_t r = x % y; return q - ((r != 0 && r < 0 != y < 0) ? 1 : 0); } SCALAR_FUN_ATTR int64_t sdiv64(int64_t x, int64_t y) {+ if (y == -1) {+ return (int64_t)(0 - (uint64_t)x);+ } int64_t q = x / y; int64_t r = x % y; return q - ((r != 0 && r < 0 != y < 0) ? 1 : 0); } -SCALAR_FUN_ATTR int8_t sceil_div8(int8_t x, int8_t y) { return sdiv8(x + y - 1, y); }-SCALAR_FUN_ATTR int16_t sceil_div16(int16_t x, int16_t y) { return sdiv16(x + y - 1, y); }-SCALAR_FUN_ATTR int32_t sceil_div32(int32_t x, int32_t y) { return sdiv32(x + y - 1, y); }-SCALAR_FUN_ATTR int64_t sceil_div64(int64_t x, int64_t y) { return sdiv64(x + y - 1, y); }+// Ceiling division rounds the truncated quotient up when it is inexact+// and positive, i.e. when the remainder is nonzero and has the same+// sign as the divisor. Unlike (x + y - 1) / y, this cannot overflow+// and is also correct for negative divisors. +SCALAR_FUN_ATTR int8_t sceil_div8(int8_t x, int8_t y) {+ int8_t q = x / y;+ int8_t r = x % y;+ return q + ((r != 0 && (r > 0) == (y > 0)) ? 1 : 0);+}++SCALAR_FUN_ATTR int16_t sceil_div16(int16_t x, int16_t y) {+ int16_t q = x / y;+ int16_t r = x % y;+ return q + ((r != 0 && (r > 0) == (y > 0)) ? 1 : 0);+}++SCALAR_FUN_ATTR int32_t sceil_div32(int32_t x, int32_t y) {+ if (y == -1) {+ return (int32_t)(0 - (uint32_t)x);+ }+ int32_t q = x / y;+ int32_t r = x % y;+ return q + ((r != 0 && (r > 0) == (y > 0)) ? 1 : 0);+}++SCALAR_FUN_ATTR int64_t sceil_div64(int64_t x, int64_t y) {+ if (y == -1) {+ return (int64_t)(0 - (uint64_t)x);+ }+ int64_t q = x / y;+ int64_t r = x % y;+ return q + ((r != 0 && (r > 0) == (y > 0)) ? 1 : 0);+}+ SCALAR_FUN_ATTR int8_t smod8(int8_t x, int8_t y) { int8_t r = x % y; return r + (r == 0 || (x > 0 && y > 0) || (x < 0 && y < 0) ? 0 : y);@@ -437,11 +550,17 @@ } SCALAR_FUN_ATTR int32_t smod32(int32_t x, int32_t y) {+ if (y == -1) {+ return 0;+ } int32_t r = x % y; return r + (r == 0 || (x > 0 && y > 0) || (x < 0 && y < 0) ? 0 : y); } SCALAR_FUN_ATTR int64_t smod64(int64_t x, int64_t y) {+ if (y == -1) {+ return 0;+ } int64_t r = x % y; return r + (r == 0 || (x > 0 && y > 0) || (x < 0 && y < 0) ? 0 : y); }@@ -451,10 +570,10 @@ SCALAR_FUN_ATTR int32_t sdiv_safe32(int32_t x, int32_t y) { return y == 0 ? 0 : sdiv32(x, y); } SCALAR_FUN_ATTR int64_t sdiv_safe64(int64_t x, int64_t y) { return y == 0 ? 0 : sdiv64(x, y); } -SCALAR_FUN_ATTR int8_t sceil_div_safe8(int8_t x, int8_t y) { return sdiv_safe8(x + y - 1, y);}-SCALAR_FUN_ATTR int16_t sceil_div_safe16(int16_t x, int16_t y) { return sdiv_safe16(x + y - 1, y); }-SCALAR_FUN_ATTR int32_t sceil_div_safe32(int32_t x, int32_t y) { return sdiv_safe32(x + y - 1, y); }-SCALAR_FUN_ATTR int64_t sceil_div_safe64(int64_t x, int64_t y) { return sdiv_safe64(x + y - 1, y); }+SCALAR_FUN_ATTR int8_t sceil_div_safe8(int8_t x, int8_t y) { return y == 0 ? 0 : sceil_div8(x, y); }+SCALAR_FUN_ATTR int16_t sceil_div_safe16(int16_t x, int16_t y) { return y == 0 ? 0 : sceil_div16(x, y); }+SCALAR_FUN_ATTR int32_t sceil_div_safe32(int32_t x, int32_t y) { return y == 0 ? 0 : sceil_div32(x, y); }+SCALAR_FUN_ATTR int64_t sceil_div_safe64(int64_t x, int64_t y) { return y == 0 ? 0 : sceil_div64(x, y); } SCALAR_FUN_ATTR int8_t smod_safe8(int8_t x, int8_t y) { return y == 0 ? 0 : smod8(x, y); } SCALAR_FUN_ATTR int16_t smod_safe16(int16_t x, int16_t y) { return y == 0 ? 0 : smod16(x, y); }@@ -463,23 +582,27 @@ SCALAR_FUN_ATTR int8_t squot8(int8_t x, int8_t y) { return x / y; } SCALAR_FUN_ATTR int16_t squot16(int16_t x, int16_t y) { return x / y; }-SCALAR_FUN_ATTR int32_t squot32(int32_t x, int32_t y) { return x / y; }-SCALAR_FUN_ATTR int64_t squot64(int64_t x, int64_t y) { return x / y; }+SCALAR_FUN_ATTR int32_t squot32(int32_t x, int32_t y) {+ return y == -1 ? (int32_t)(0 - (uint32_t)x) : x / y;+}+SCALAR_FUN_ATTR int64_t squot64(int64_t x, int64_t y) {+ return y == -1 ? (int64_t)(0 - (uint64_t)x) : x / y;+} SCALAR_FUN_ATTR int8_t srem8(int8_t x, int8_t y) { return x % y; } SCALAR_FUN_ATTR int16_t srem16(int16_t x, int16_t y) { return x % y; }-SCALAR_FUN_ATTR int32_t srem32(int32_t x, int32_t y) { return x % y; }-SCALAR_FUN_ATTR int64_t srem64(int64_t x, int64_t y) { return x % y; }+SCALAR_FUN_ATTR int32_t srem32(int32_t x, int32_t y) { return y == -1 ? 0 : x % y; }+SCALAR_FUN_ATTR int64_t srem64(int64_t x, int64_t y) { return y == -1 ? 0 : x % y; } SCALAR_FUN_ATTR int8_t squot_safe8(int8_t x, int8_t y) { return y == 0 ? 0 : x / y; } SCALAR_FUN_ATTR int16_t squot_safe16(int16_t x, int16_t y) { return y == 0 ? 0 : x / y; }-SCALAR_FUN_ATTR int32_t squot_safe32(int32_t x, int32_t y) { return y == 0 ? 0 : x / y; }-SCALAR_FUN_ATTR int64_t squot_safe64(int64_t x, int64_t y) { return y == 0 ? 0 : x / y; }+SCALAR_FUN_ATTR int32_t squot_safe32(int32_t x, int32_t y) { return y == 0 ? 0 : squot32(x, y); }+SCALAR_FUN_ATTR int64_t squot_safe64(int64_t x, int64_t y) { return y == 0 ? 0 : squot64(x, y); } SCALAR_FUN_ATTR int8_t srem_safe8(int8_t x, int8_t y) { return y == 0 ? 0 : x % y; } SCALAR_FUN_ATTR int16_t srem_safe16(int16_t x, int16_t y) { return y == 0 ? 0 : x % y; }-SCALAR_FUN_ATTR int32_t srem_safe32(int32_t x, int32_t y) { return y == 0 ? 0 : x % y; }-SCALAR_FUN_ATTR int64_t srem_safe64(int64_t x, int64_t y) { return y == 0 ? 0 : x % y; }+SCALAR_FUN_ATTR int32_t srem_safe32(int32_t x, int32_t y) { return y == 0 ? 0 : srem32(x, y); }+SCALAR_FUN_ATTR int64_t srem_safe64(int64_t x, int64_t y) { return y == 0 ? 0 : srem64(x, y); } #endif @@ -503,20 +626,23 @@ SCALAR_FUN_ATTR uint32_t umax32(uint32_t x, uint32_t y) { return x < y ? y : x; } SCALAR_FUN_ATTR uint64_t umax64(uint64_t x, uint64_t y) { return x < y ? y : x; } -SCALAR_FUN_ATTR uint8_t shl8(uint8_t x, uint8_t y) { return (uint8_t)(x << y); }-SCALAR_FUN_ATTR uint16_t shl16(uint16_t x, uint16_t y) { return (uint16_t)(x << y); }-SCALAR_FUN_ATTR uint32_t shl32(uint32_t x, uint32_t y) { return x << y; }-SCALAR_FUN_ATTR uint64_t shl64(uint64_t x, uint64_t y) { return x << y; }+// The shift amount is masked to the bit width, which gives defined+// behaviour for all shift amounts, and which compilers know how to+// recognise as part of rotation idioms.+SCALAR_FUN_ATTR uint8_t shl8(uint8_t x, uint8_t y) { return (uint8_t)(x << (y & 7)); }+SCALAR_FUN_ATTR uint16_t shl16(uint16_t x, uint16_t y) { return (uint16_t)(x << (y & 15)); }+SCALAR_FUN_ATTR uint32_t shl32(uint32_t x, uint32_t y) { return x << (y & 31); }+SCALAR_FUN_ATTR uint64_t shl64(uint64_t x, uint64_t y) { return x << (y & 63); } -SCALAR_FUN_ATTR uint8_t lshr8(uint8_t x, uint8_t y) { return x >> y; }-SCALAR_FUN_ATTR uint16_t lshr16(uint16_t x, uint16_t y) { return x >> y; }-SCALAR_FUN_ATTR uint32_t lshr32(uint32_t x, uint32_t y) { return x >> y; }-SCALAR_FUN_ATTR uint64_t lshr64(uint64_t x, uint64_t y) { return x >> y; }+SCALAR_FUN_ATTR uint8_t lshr8(uint8_t x, uint8_t y) { return x >> (y & 7); }+SCALAR_FUN_ATTR uint16_t lshr16(uint16_t x, uint16_t y) { return x >> (y & 15); }+SCALAR_FUN_ATTR uint32_t lshr32(uint32_t x, uint32_t y) { return x >> (y & 31); }+SCALAR_FUN_ATTR uint64_t lshr64(uint64_t x, uint64_t y) { return x >> (y & 63); } -SCALAR_FUN_ATTR int8_t ashr8(int8_t x, int8_t y) { return x >> y; }-SCALAR_FUN_ATTR int16_t ashr16(int16_t x, int16_t y) { return x >> y; }-SCALAR_FUN_ATTR int32_t ashr32(int32_t x, int32_t y) { return x >> y; }-SCALAR_FUN_ATTR int64_t ashr64(int64_t x, int64_t y) { return x >> y; }+SCALAR_FUN_ATTR int8_t ashr8(int8_t x, int8_t y) { return x >> (y & 7); }+SCALAR_FUN_ATTR int16_t ashr16(int16_t x, int16_t y) { return x >> (y & 15); }+SCALAR_FUN_ATTR int32_t ashr32(int32_t x, int32_t y) { return x >> (y & 31); }+SCALAR_FUN_ATTR int64_t ashr64(int64_t x, int64_t y) { return x >> (y & 63); } SCALAR_FUN_ATTR uint8_t and8(uint8_t x, uint8_t y) { return x & y; } SCALAR_FUN_ATTR uint16_t and16(uint16_t x, uint16_t y) { return x & y; }@@ -553,7 +679,7 @@ SCALAR_FUN_ATTR bool sle32(int32_t x, int32_t y) { return x <= y; } SCALAR_FUN_ATTR bool sle64(int64_t x, int64_t y) { return x <= y; } -SCALAR_FUN_ATTR uint8_t pow8(uint8_t x, uint8_t y) {+SCALAR_FUN_ATTR uint8_t upow8(uint8_t x, uint8_t y) { uint8_t res = 1, rem = y; while (rem != 0) { if (rem & 1)@@ -564,18 +690,18 @@ return res; } -SCALAR_FUN_ATTR uint16_t pow16(uint16_t x, uint16_t y) {+SCALAR_FUN_ATTR uint16_t upow16(uint16_t x, uint16_t y) { uint16_t res = 1, rem = y; while (rem != 0) { if (rem & 1)- res *= x;+ res = mul16(res, x); rem >>= 1;- x *= x;+ x = mul16(x, x); } return res; } -SCALAR_FUN_ATTR uint32_t pow32(uint32_t x, uint32_t y) {+SCALAR_FUN_ATTR uint32_t upow32(uint32_t x, uint32_t y) { uint32_t res = 1, rem = y; while (rem != 0) { if (rem & 1)@@ -586,7 +712,7 @@ return res; } -SCALAR_FUN_ATTR uint64_t pow64(uint64_t x, uint64_t y) {+SCALAR_FUN_ATTR uint64_t upow64(uint64_t x, uint64_t y) { uint64_t res = 1, rem = y; while (rem != 0) { if (rem & 1)@@ -597,6 +723,11 @@ return res; } +SCALAR_FUN_ATTR int8_t spow8(int8_t x, int8_t y) { return (int8_t)upow8((uint8_t)x, (uint8_t)y); }+SCALAR_FUN_ATTR int16_t spow16(int16_t x, int16_t y) { return (int16_t)upow16((uint16_t)x, (uint16_t)y); }+SCALAR_FUN_ATTR int32_t spow32(int32_t x, int32_t y) { return (int32_t)upow32((uint32_t)x, (uint32_t)y); }+SCALAR_FUN_ATTR int64_t spow64(int64_t x, int64_t y) { return (int64_t)upow64((uint64_t)x, (uint64_t)y); }+ SCALAR_FUN_ATTR bool itob_i8_bool(int8_t x) { return x != 0; } SCALAR_FUN_ATTR bool itob_i16_bool(int16_t x) { return x != 0; } SCALAR_FUN_ATTR bool itob_i32_bool(int32_t x) { return x != 0; }@@ -642,14 +773,13 @@ SCALAR_FUN_ATTR int8_t abs8(int8_t x) { return (int8_t)abs(x); } SCALAR_FUN_ATTR int16_t abs16(int16_t x) { return (int16_t)abs(x); }+#if defined(__OPENCL_VERSION__) SCALAR_FUN_ATTR int32_t abs32(int32_t x) { return abs(x); }-SCALAR_FUN_ATTR int64_t abs64(int64_t x) {-#if defined(__OPENCL_VERSION__) || defined(ISPC)- return abs(x);+SCALAR_FUN_ATTR int64_t abs64(int64_t x) { return abs(x); } #else- return llabs(x);+SCALAR_FUN_ATTR int32_t abs32(int32_t x) { return x < 0 ? (int32_t)sub32(0, x) : x; }+SCALAR_FUN_ATTR int64_t abs64(int64_t x) { return x < 0 ? (int64_t)sub64(0, x) : x; } #endif-} #if defined(__OPENCL_VERSION__) @@ -792,8 +922,8 @@ SCALAR_FUN_ATTR uint64_t futrts_umad_hi64(uint64_t a, uint64_t b, uint64_t c) { return futrts_umul_hi64(a, b) + c; } SCALAR_FUN_ATTR uint8_t futrts_smad_hi8 ( int8_t a, int8_t b, int8_t c) { return futrts_smul_hi8(a, b) + c; } SCALAR_FUN_ATTR uint16_t futrts_smad_hi16(int16_t a, int16_t b, int16_t c) { return futrts_smul_hi16(a, b) + c; }-SCALAR_FUN_ATTR uint32_t futrts_smad_hi32(int32_t a, int32_t b, int32_t c) { return futrts_smul_hi32(a, b) + c; }-SCALAR_FUN_ATTR uint64_t futrts_smad_hi64(int64_t a, int64_t b, int64_t c) { return futrts_smul_hi64(a, b) + c; }+SCALAR_FUN_ATTR uint32_t futrts_smad_hi32(int32_t a, int32_t b, int32_t c) { return (uint32_t)futrts_smul_hi32(a, b) + (uint32_t)c; }+SCALAR_FUN_ATTR uint64_t futrts_smad_hi64(int64_t a, int64_t b, int64_t c) { return (uint64_t)futrts_smul_hi64(a, b) + (uint64_t)c; } #endif #if defined(__OPENCL_VERSION__)@@ -1222,9 +1352,9 @@ } SCALAR_FUN_ATTR float futrts_copysign32(float x, float y) {- int32_t xb = fptobits_f32_i32(x);- int32_t yb = fptobits_f32_i32(y);- return bitstofp_i32_f32((xb & ~(1<<31)) | (yb & (1<<31)));+ uint32_t xb = (uint32_t)fptobits_f32_i32(x);+ uint32_t yb = (uint32_t)fptobits_f32_i32(y);+ return bitstofp_i32_f32((int32_t)((xb & 0x7fffffffu) | (yb & 0x80000000u))); } SCALAR_FUN_ATTR float futrts_mad32(float a, float b, float c) {@@ -1360,9 +1490,9 @@ SCALAR_FUN_ATTR double fmin64(double x, double y) { return isnan(x) ? y : isnan(y) ? x : min(x, y); } SCALAR_FUN_ATTR double fpow64(double a, double b) {- float ret;+ double ret; foreach_active (i) {- uniform float r = pow(extract(a, i), extract(b, i));+ uniform double r = pow(extract(a, i), extract(b, i)); ret = insert(ret, i, r); } return ret;@@ -1384,7 +1514,7 @@ SCALAR_FUN_ATTR double futrts_cbrt64(double x) { double res; foreach_active (i) {- uniform double r = cbrtf(extract(x, i));+ uniform double r = cbrt(extract(x, i)); res = insert(res, i, r); } return res;@@ -1479,7 +1609,7 @@ SCALAR_FUN_ATTR double futrts_round64(double x) { return round(x); } SCALAR_FUN_ATTR double futrts_ceil64(double x) { return ceil(x); } -extern "C" unmasked uniform double nextafter(uniform float x, uniform double y);+extern "C" unmasked uniform double nextafter(uniform double x, uniform double y); SCALAR_FUN_ATTR double futrts_nextafter64(double x, double y) { double res; foreach_active (i) {@@ -1560,23 +1690,11 @@ SCALAR_FUN_ATTR double btof_bool_f64(bool x) { return x ? 1.0 : 0.0; } SCALAR_FUN_ATTR int64_t fptobits_f64_i64(double x) {- int64_t res;- foreach_active (i) {- uniform double tmp = extract(x, i);- uniform int64_t r = *((uniform int64_t* uniform)&tmp);- res = insert(res, i, r);- }- return res;+ return intbits(x); } SCALAR_FUN_ATTR double bitstofp_i64_f64(int64_t x) {- double res;- foreach_active (i) {- uniform int64_t tmp = extract(x, i);- uniform double r = *((uniform double* uniform)&tmp);- res = insert(res, i, r);- }- return res;+ return doublebits(x); } SCALAR_FUN_ATTR uniform int64_t fptobits_f64_i64(uniform double x) {@@ -1604,9 +1722,10 @@ } SCALAR_FUN_ATTR double futrts_copysign64(double x, double y) {- int64_t xb = fptobits_f64_i64(x);- int64_t yb = fptobits_f64_i64(y);- return bitstofp_i64_f64((xb & ~(((int64_t)1)<<63)) | (yb & (((int64_t)1)<<63)));+ uint64_t sign = ((uint64_t)1) << 63;+ uint64_t xb = (uint64_t)fptobits_f64_i64(x);+ uint64_t yb = (uint64_t)fptobits_f64_i64(y);+ return bitstofp_i64_f64((int64_t)((xb & ~sign) | (yb & sign))); } SCALAR_FUN_ATTR double futrts_mad64(double a, double b, double c) { return a * b + c; }
rts/c/scalar_f16.h view
@@ -55,13 +55,13 @@ SCALAR_FUN_ATTR f16 uitofp_i32_f16(uint32_t x) { return (f16) x; } SCALAR_FUN_ATTR f16 uitofp_i64_f16(uint64_t x) { return (f16) x; } SCALAR_FUN_ATTR int8_t fptosi_f16_i8(f16 x) { return fptosi_f32_i8((float) x); }-SCALAR_FUN_ATTR int16_t fptosi_f16_i16(f16 x) { return (int16_t) x; }-SCALAR_FUN_ATTR int32_t fptosi_f16_i32(f16 x) { return (int32_t) x; }-SCALAR_FUN_ATTR int64_t fptosi_f16_i64(f16 x) { return (int64_t) x; }+SCALAR_FUN_ATTR int16_t fptosi_f16_i16(f16 x) { return fptosi_f32_i16((float) x); }+SCALAR_FUN_ATTR int32_t fptosi_f16_i32(f16 x) { return fptosi_f32_i32((float) x); }+SCALAR_FUN_ATTR int64_t fptosi_f16_i64(f16 x) { return fptosi_f32_i64((float) x); } SCALAR_FUN_ATTR uint8_t fptoui_f16_i8(f16 x) { return fptoui_f32_i8((float) x); }-SCALAR_FUN_ATTR uint16_t fptoui_f16_i16(f16 x) { return (uint16_t) x; }-SCALAR_FUN_ATTR uint32_t fptoui_f16_i32(f16 x) { return (uint32_t) x; }-SCALAR_FUN_ATTR uint64_t fptoui_f16_i64(f16 x) { return (uint64_t) x; }+SCALAR_FUN_ATTR uint16_t fptoui_f16_i16(f16 x) { return fptoui_f32_i16((float) x); }+SCALAR_FUN_ATTR uint32_t fptoui_f16_i32(f16 x) { return fptoui_f32_i32((float) x); }+SCALAR_FUN_ATTR uint64_t fptoui_f16_i64(f16 x) { return fptoui_f32_i64((float) x); } SCALAR_FUN_ATTR bool ftob_f16_bool(f16 x) { return x != (f16)0; } SCALAR_FUN_ATTR f16 btof_bool_f16(bool x) { return x ? 1 : 0; } @@ -293,9 +293,8 @@ SCALAR_FUN_ATTR int16_t fptobits_f16_i16(f16 x) { return __half_as_ushort(x); } SCALAR_FUN_ATTR f16 bitstofp_i16_f16(int16_t x) { return __ushort_as_half(x); } #elif defined(ISPC)-SCALAR_FUN_ATTR int16_t fptobits_f16_i16(f16 x) { varying int16_t y = *((varying int16_t * uniform)&x); return y;-}-SCALAR_FUN_ATTR f16 bitstofp_i16_f16(int16_t x) { varying f16 y = *((varying f16 * uniform)&x); return y; }+SCALAR_FUN_ATTR int16_t fptobits_f16_i16(f16 x) { return intbits(x); }+SCALAR_FUN_ATTR f16 bitstofp_i16_f16(int16_t x) { return float16bits(x); } #else SCALAR_FUN_ATTR int16_t fptobits_f16_i16(f16 x) { union {@@ -392,11 +391,16 @@ #else SCALAR_FUN_ATTR int16_t fptobits_f16_i16(f16 x) { return (int16_t)float2halfbits(x); } SCALAR_FUN_ATTR f16 bitstofp_i16_f16(int16_t x) { return halfbits2float((uint16_t)x); }-SCALAR_FUN_ATTR f16 fsignum16(f16 x) { return futrts_isnan16(x) ? x : (x > 0 ? 1 : 0) - (x < 0 ? 1 : 0); } #endif #endif++SCALAR_FUN_ATTR f16 fsignum16(f16 x) {+ f16 zero = (f16)0.0f;+ return futrts_isnan16(x) ? x+ : (f16)(float)((cmplt16(zero, x) ? 1 : 0) - (cmplt16(x, zero) ? 1 : 0));+} SCALAR_FUN_ATTR float fpconv_f16_f16(f16 x) { return x; } SCALAR_FUN_ATTR float fpconv_f16_f32(f16 x) { return x; }
rts/c/scheduler.h view
@@ -226,6 +226,8 @@ /* Shared variables across subtasks */ volatile int *counter; // Counter for ongoing subtasks+ volatile int *error;+ // Shared task timers and iterators int64_t *task_time; int64_t *task_iter;@@ -514,11 +516,6 @@ // If there is work to steal => active_work > 0 volatile int active_work; - // Only one error can be returned at the time now. Maybe we can- // provide a stack like structure for pushing errors onto if we wish- // to backpropagte multiple errors- volatile int error;- // kappa time unit in nanoseconds double kappa; };@@ -551,7 +548,8 @@ static inline int64_t compute_chunk_size(int64_t minimum_chunk_size, double kappa, struct subtask* subtask) {- double C = (double)*subtask->task_time / (double)*subtask->task_iter;+ double C = (double)__atomic_load_n(subtask->task_time, __ATOMIC_RELAXED)+ / (double)__atomic_load_n(subtask->task_iter, __ATOMIC_RELAXED); if (C == 0.0F) C += DBL_EPSILON; return smax64((int64_t)(kappa / C), minimum_chunk_size); }@@ -562,7 +560,7 @@ { if (subtask->chunkable) { // Do we have information from previous runs avaliable- if (*subtask->task_iter > 0) {+ if (__atomic_load_n(subtask->task_iter, __ATOMIC_RELAXED) > 0) { subtask->chunk_size = compute_chunk_size(worker->scheduler->minimum_chunk_size, worker->scheduler->kappa, subtask);@@ -600,17 +598,11 @@ subtask->id, worker->tid); worker->nested--;- // Some error occured during some other subtask- // so we just clean-up and return- if (worker->scheduler->error != 0) {- // Even a failed task counts as finished.- __atomic_fetch_sub(subtask->counter, 1, __ATOMIC_RELAXED);- free(subtask);- return 0;- }+ if (err != 0) {- __atomic_store_n(&worker->scheduler->error, err, __ATOMIC_RELAXED);+ __atomic_store_n(subtask->error, err, __ATOMIC_RELAXED); }+ // Total sequential time spent int64_t time_elapsed = total_now(worker->total, worker->timer); #if defined(MCPROFILE)@@ -621,10 +613,10 @@ // These updates should really be done using a single atomic CAS operation __atomic_fetch_add(subtask->task_time, time_elapsed, __ATOMIC_RELAXED); __atomic_fetch_add(subtask->task_iter, iter, __ATOMIC_RELAXED);- // We need a fence here, since if the counter is decremented before either- // of the two above are updated bad things can happen, e.g. if they are stack-allocated- __atomic_thread_fence(__ATOMIC_SEQ_CST);- __atomic_fetch_sub(subtask->counter, 1, __ATOMIC_RELAXED);+ // The decrement releases everything this subtask has written (results,+ // the error, and the timers above, which may be stack-allocated) to the+ // thread waiting for the counter to reach zero.+ __atomic_fetch_sub(subtask->counter, 1, __ATOMIC_RELEASE); free(subtask); return 0; }@@ -632,8 +624,8 @@ static inline int is_small(struct scheduler_segop *task, struct scheduler *scheduler, int *nsubtasks) {- int64_t time = *task->task_time;- int64_t iter = *task->task_iter;+ int64_t time = __atomic_load_n(task->task_time, __ATOMIC_RELAXED);+ int64_t iter = __atomic_load_n(task->task_iter, __ATOMIC_RELAXED); if (task->sched == DYNAMIC || iter == 0) { *nsubtasks = scheduler->num_threads;@@ -664,6 +656,7 @@ void* args, const char* name, volatile int* counter,+ volatile int* error, int64_t *timer, int64_t *iter, int64_t start, int64_t end,@@ -680,6 +673,7 @@ subtask->args = args; subtask->counter = counter;+ subtask->error = error; subtask->task_time = timer; subtask->task_iter = iter; @@ -694,6 +688,7 @@ } static int dummy_counter = 0;+static int dummy_error = 0; static int64_t dummy_timer = 0; static int64_t dummy_iter = 0; @@ -716,17 +711,18 @@ #endif for (int i = start_tid; i < end_tid; i++) { struct subtask *subtask = create_subtask(dummy_fn, NULL, "dummy_fn",- &dummy_counter,- &dummy_timer, &dummy_iter,- 0, 0,- 0, 0,- 0);+ &dummy_counter,+ &dummy_error,+ &dummy_timer, &dummy_iter,+ 0, 0,+ 0, 0,+ 0); CHECK_ERR(subtask_queue_enqueue(&scheduler->workers[i], subtask), "subtask_queue_enqueue"); } } static inline int is_finished(struct worker *worker) {- return worker->dead && subtask_queue_is_empty(&worker->q);+ return __atomic_load_n(&worker->dead, __ATOMIC_RELAXED) && subtask_queue_is_empty(&worker->q); } // Try to steal from a random queue@@ -797,6 +793,7 @@ int64_t remainder = info.remainder; int nsubtasks = info.nsubtasks; volatile int join_counter = nsubtasks;+ volatile int error = 0; // Shared timer used to sum up all // sequential work from each subtask@@ -816,11 +813,11 @@ int64_t end = iter_pr_subtask + (int64_t)(remainder != 0); for (int subtask_id = 0; subtask_id < nsubtasks; subtask_id++) { struct subtask *subtask = create_subtask(task->fn, task->args, task->name,- &join_counter,- &task_timer, &task_iter,- start, end,- chunkable, chunk_size,- subtask_id);+ &join_counter, &error,+ &task_timer, &task_iter,+ start, end,+ chunkable, chunk_size,+ subtask_id); assert(subtask != NULL); // In most cases we will never have more subtasks than workers, // but there can be exceptions (e.g. the kappa tuning function).@@ -840,7 +837,7 @@ } // Join (wait for subtasks to finish)- while(join_counter != 0) {+ while (__atomic_load_n(&join_counter, __ATOMIC_ACQUIRE) != 0) { if (!subtask_queue_is_empty(&worker->q)) { struct subtask *subtask = NULL; int err = subtask_queue_dequeue(worker, &subtask, 0);@@ -865,10 +862,9 @@ // Write back timing results of all sequential work (*timer) += task_timer;- return scheduler->error;+ return error; } - static inline int scheduler_execute_task(struct scheduler *scheduler, struct scheduler_parloop *task) {@@ -1104,7 +1100,6 @@ scheduler->kappa = kappa; scheduler->num_threads = num_workers; scheduler->active_work = 0;- scheduler->error = 0; scheduler->workers = calloc(num_workers, sizeof(struct worker)); @@ -1143,7 +1138,7 @@ // First mark them all as dead. for (int i = 1; i < scheduler->num_threads; i++) { struct worker *cur_worker = &scheduler->workers[i];- cur_worker->dead = 1;+ __atomic_store_n(&cur_worker->dead, 1, __ATOMIC_RELAXED); } // Then destroy their task queues (this will wake up the threads and
rts/c/server.h view
@@ -18,7 +18,7 @@ typedef void (*store_fn)(const void*, FILE*, struct futhark_context*, void*); typedef int (*free_fn)(const void*, struct futhark_context*, void*); typedef int (*array_new_fn)(struct futhark_context *, void**, const void*, const int64_t*);-typedef int (*array_set_fn)(struct futhark_context *, const void*, const void*, const int64_t*);+typedef int (*array_set_fn)(struct futhark_context *, const void*, void*, const int64_t*); typedef const int64_t* (*array_shape_fn)(struct futhark_context*, const void*); typedef int (*array_index_fn)(struct futhark_context*, void*, const void*, const int64_t*); typedef int (*array_values_fn)(struct futhark_context*, const void*, void*);@@ -476,6 +476,7 @@ if (v == NULL) { failure(); printf("Unknown variable: %s\n", vname);+ fclose(f); return; } @@ -762,14 +763,7 @@ if (type == NULL) { return; }- struct variable *to = create_variable(s, to_name, type); - if (to == NULL) {- failure();- printf("Variable already exists: %s\n", to_name);- return;- }- if (type->kind != ARRAY) { failure(); printf("Not an array type\n");@@ -805,6 +799,12 @@ return; } + if (size != 0 && n_values > INT64_MAX / size) {+ failure();+ printf("Array with %d dimensions has too many elements.\n", a->rank);+ return;+ }+ dims[i] = size; n_values *= size; }@@ -868,6 +868,16 @@ } } + struct variable *to = create_variable(s, to_name, type);++ if (to == NULL) {+ failure();+ printf("Variable already exists: %s\n", to_name);+ free(value_ptrs);+ free(values);+ return;+ }+ // The copy from 'values' may be asynchronous, so we must synchronise // before freeing it. int err = a->new(s->ctx, value_ptr(&to->value), a->info != NULL ? (void*)values : value_ptrs, dims);@@ -875,6 +885,9 @@ free(value_ptrs); free(values); error_check(s, err);+ if (err != 0) {+ drop_variable(s, to);+ } } void cmd_set(struct server_state *s, const char *args[]) {@@ -999,7 +1012,12 @@ return; } - a->index(s->ctx, value_ptr(&to->value), from->value.value.v_ptr, indices);+ int err = a->index(s->ctx, value_ptr(&to->value), from->value.value.v_ptr, indices);+ err |= futhark_context_sync(s->ctx);+ error_check(s, err);+ if (err != 0) {+ drop_variable(s, to);+ } } void cmd_zip(struct server_state *s, const char *args[]) {@@ -1238,6 +1256,7 @@ if (field == NULL) { failure(); printf("No such field\n");+ return; } struct variable *to = create_variable(s, to_name, field->type);@@ -1248,7 +1267,12 @@ return; } - field->project(s->ctx, value_ptr(&to->value), from->value.value.v_ptr);+ int err = field->project(s->ctx, value_ptr(&to->value), from->value.value.v_ptr);+ err |= futhark_context_sync(s->ctx);+ error_check(s, err);+ if (err != 0) {+ drop_variable(s, to);+ } } void cmd_new(struct server_state *s, const char *args[]) {@@ -1258,14 +1282,7 @@ if (type == NULL) { return; }- struct variable *to = create_variable(s, to_name, type); - if (to == NULL) {- failure();- printf("Variable already exists: %s\n", to_name);- return;- }- if (type->kind != RECORD) { failure(); printf("Not a record type\n");@@ -1281,7 +1298,7 @@ if (num_args != r->num_fields) { failure();- printf("%d fields expected but %d values provided.\n", num_args, r->num_fields);+ printf("%d fields expected but %d values provided.\n", r->num_fields, num_args); return; } @@ -1306,7 +1323,20 @@ value_ptrs[i] = value_ptr(&v->value); } - r->new(s->ctx, value_ptr(&to->value), value_ptrs);+ struct variable *to = create_variable(s, to_name, type);++ if (to == NULL) {+ failure();+ printf("Variable already exists: %s\n", to_name);+ return;+ }++ int err = r->new(s->ctx, value_ptr(&to->value), value_ptrs);+ err |= futhark_context_sync(s->ctx);+ error_check(s, err);+ if (err != 0) {+ drop_variable(s, to);+ } } void cmd_construct(struct server_state *s, const char *args[]) {@@ -1317,14 +1347,7 @@ if (type == NULL) { return; }- struct variable *to = create_variable(s, to_name, type); - if (to == NULL) {- failure();- printf("Variable already exists: %s\n", to_name);- return;- }- if (type->kind != SUM) { failure(); printf("Not a sum type\n");@@ -1369,7 +1392,20 @@ value_ptrs[i] = value_ptr(&v->value); } - var->new(s->ctx, value_ptr(&to->value), value_ptrs);+ struct variable *to = create_variable(s, to_name, type);++ if (to == NULL) {+ failure();+ printf("Variable already exists: %s\n", to_name);+ return;+ }++ int err = var->new(s->ctx, value_ptr(&to->value), value_ptrs);+ err |= futhark_context_sync(s->ctx);+ error_check(s, err);+ if (err != 0) {+ drop_variable(s, to);+ } return; } }@@ -1408,7 +1444,8 @@ return; } - const void **value_ptrs = alloca(num_args * sizeof(struct variable*));+ struct variable **outs = alloca(num_args * sizeof(struct variable*));+ const void **value_ptrs = alloca(num_args * sizeof(void*)); for (int i = 0; i < num_args; i++) { const char *vname = get_arg(args, i+1);@@ -1416,13 +1453,23 @@ if (vn == NULL) { failure(); printf("Variable already exists: %s\n", vname);+ for (int j = 0; j < i; j++) {+ drop_variable(s, outs[j]);+ } return; }+ outs[i] = vn; value_ptrs[i] = value_ptr(&vn->value); } - var->destruct(s->ctx, value_ptrs, v->value.value.v_ptr);- return;+ int err = var->destruct(s->ctx, value_ptrs, v->value.value.v_ptr);+ err |= futhark_context_sync(s->ctx);+ error_check(s, err);+ if (err != 0) {+ for (int i = 0; i < num_args; i++) {+ drop_variable(s, outs[i]);+ }+ } } void cmd_entry_points(struct server_state *s, const char *args[]) {@@ -1603,8 +1650,9 @@ // The aux struct lets us write generic method implementations without // code duplication. -int restore_array(const struct array *a, FILE *f,+int restore_array(const void *aux, FILE *f, struct futhark_context *ctx, void *p) {+ const struct array *a = (const struct array*)aux; void *data = NULL; int64_t shape[a->rank]; if (read_array(f, a->info, &data, shape, a->rank) != 0) {@@ -1617,8 +1665,9 @@ return err; } -void store_array(const struct array *a, FILE *f,+void store_array(const void *aux, FILE *f, struct futhark_context *ctx, void *p) {+ const struct array *a = (const struct array*)aux; void *arr = *(void**)p; const int64_t *shape = a->shape(ctx, arr); int64_t size = a->info->size;@@ -1632,8 +1681,9 @@ free(data); } -int free_array(const struct array *a,+int free_array(const void *aux, struct futhark_context *ctx, void *p) {+ const struct array *a = (const struct array*)aux; void *arr = *(void**)p; return a->free(ctx, arr); }@@ -1648,8 +1698,9 @@ opaque_free_fn free; }; -int restore_opaque(const struct opaque_aux *aux, FILE *f,+int restore_opaque(const void *aux_p, FILE *f, struct futhark_context *ctx, void *p) {+ const struct opaque_aux *aux = (const struct opaque_aux*)aux_p; // We have a problem: we need to load data from 'f', since the // restore function takes a pointer, but we don't know how much we // need (and cannot possibly). So we do something hacky: we read@@ -1674,8 +1725,9 @@ } } -void store_opaque(const struct opaque_aux *aux, FILE *f,+void store_opaque(const void *aux_p, FILE *f, struct futhark_context *ctx, void *p) {+ const struct opaque_aux *aux = (const struct opaque_aux*)aux_p; void *obj = *(void**)p; size_t obj_size; void *data = NULL;@@ -1685,8 +1737,9 @@ free(data); } -int free_opaque(const struct opaque_aux *aux,+int free_opaque(const void *aux_p, struct futhark_context *ctx, void *p) {+ const struct opaque_aux *aux = (const struct opaque_aux*)aux_p; void *obj = *(void**)p; return aux->free(ctx, obj); }
rts/c/tuning.h view
@@ -8,8 +8,7 @@ } static char* load_tuning_file(const char *fname,- void *cfg,- int (*set_tuning_param)(void*, const char*, size_t)) {+ struct futhark_context_config *cfg) { const int max_line_len = 1024; char* line = (char*) malloc(max_line_len); @@ -34,22 +33,26 @@ if (*endptr && *endptr != '\n') { snprintf(line, max_line_len, "Invalid line %d (must be of form 'name=int').", lineno);+ fclose(f); return line; }- if (set_tuning_param(cfg, line, (size_t)value) != 0) {+ if (futhark_context_config_set_tuning_param(cfg, line, (size_t)value) != 0) { char* err = (char*) malloc(max_line_len + 50); snprintf(err, max_line_len + 50, "Unknown name '%s' on line %d.", line, lineno); free(line);+ fclose(f); return err; } } else { snprintf(line, max_line_len, "Invalid line %d (must be of form 'name=int').", lineno);+ fclose(f); return line; } } free(line);+ fclose(f); return NULL; }
rts/c/uniform.h view
@@ -69,20 +69,23 @@ return x / y; } +// Unsigned ceiling division rounds the quotient up when the remainder+// is nonzero. Unlike (x + y - 1) / y, this cannot overflow.+ static inline uniform uint8_t uceil_div8(uniform uint8_t x, uniform uint8_t y) {- return (x + y - 1) / y;+ return x / y + (x % y != 0 ? 1 : 0); } static inline uniform uint16_t uceil_div16(uniform uint16_t x, uniform uint16_t y) {- return (x + y - 1) / y;+ return x / y + (x % y != 0 ? 1 : 0); } static inline uniform uint32_t uceil_div32(uniform uint32_t x, uniform uint32_t y) {- return (x + y - 1) / y;+ return x / y + (x % y != 0 ? 1 : 0); } static inline uniform uint64_t uceil_div64(uniform uint64_t x, uniform uint64_t y) {- return (x + y - 1) / y;+ return x / y + (x % y != 0 ? 1 : 0); } static inline uniform uint8_t umod8(uniform uint8_t x, uniform uint8_t y) {@@ -118,19 +121,19 @@ } static inline uniform uint8_t uceil_div_safe8(uniform uint8_t x, uniform uint8_t y) {- return y == 0 ? 0 : (x + y - 1) / y;+ return y == 0 ? 0 : uceil_div8(x, y); } static inline uniform uint16_t uceil_div_safe16(uniform uint16_t x, uniform uint16_t y) {- return y == 0 ? 0 : (x + y - 1) / y;+ return y == 0 ? 0 : uceil_div16(x, y); } static inline uniform uint32_t uceil_div_safe32(uniform uint32_t x, uniform uint32_t y) {- return y == 0 ? 0 : (x + y - 1) / y;+ return y == 0 ? 0 : uceil_div32(x, y); } static inline uniform uint64_t uceil_div_safe64(uniform uint64_t x, uniform uint64_t y) {- return y == 0 ? 0 : (x + y - 1) / y;+ return y == 0 ? 0 : uceil_div64(x, y); } static inline uniform uint8_t umod_safe8(uniform uint8_t x, uniform uint8_t y) {@@ -149,7 +152,14 @@ return y == 0 ? 0 : x % y; } +// Signed division of the most negative value by -1 overflows, which+// traps on x86. Futhark defines the result to wrap (x / -1 == -x and+// x % -1 == 0).+ static inline uniform int8_t sdiv8(uniform int8_t x, uniform int8_t y) {+ if (y == -1) {+ return (uniform int8_t)(0 - (uniform uint8_t)x);+ } uniform int8_t q = x / y; uniform int8_t r = x % y; @@ -157,6 +167,9 @@ } static inline uniform int16_t sdiv16(uniform int16_t x, uniform int16_t y) {+ if (y == -1) {+ return (uniform int16_t)(0 - (uniform uint16_t)x);+ } uniform int16_t q = x / y; uniform int16_t r = x % y; @@ -164,6 +177,9 @@ } static inline uniform int32_t sdiv32(uniform int32_t x, uniform int32_t y) {+ if (y == -1) {+ return (uniform int32_t)(0 - (uniform uint32_t)x);+ } uniform int32_t q = x / y; uniform int32_t r = x % y; @@ -171,47 +187,91 @@ } static inline uniform int64_t sdiv64(uniform int64_t x, uniform int64_t y) {+ if (y == -1) {+ return (uniform int64_t)(0 - (uniform uint64_t)x);+ } uniform int64_t q = x / y; uniform int64_t r = x % y; return q - ((r != 0 && r < 0 != y < 0) ? 1 : 0); } +// Ceiling division rounds the truncated quotient up when it is inexact+// and positive, i.e. when the remainder is nonzero and has the same+// sign as the divisor. Unlike (x + y - 1) / y, this cannot overflow+// and is also correct for negative divisors.+ static inline uniform int8_t sceil_div8(uniform int8_t x, uniform int8_t y) {- return sdiv8(x + y - 1, y);+ if (y == -1) {+ return (uniform int8_t)(0 - (uniform uint8_t)x);+ }+ uniform int8_t q = x / y;+ uniform int8_t r = x % y;++ return q + ((r != 0 && (r > 0) == (y > 0)) ? 1 : 0); } static inline uniform int16_t sceil_div16(uniform int16_t x, uniform int16_t y) {- return sdiv16(x + y - 1, y);+ if (y == -1) {+ return (uniform int16_t)(0 - (uniform uint16_t)x);+ }+ uniform int16_t q = x / y;+ uniform int16_t r = x % y;++ return q + ((r != 0 && (r > 0) == (y > 0)) ? 1 : 0); } static inline uniform int32_t sceil_div32(uniform int32_t x, uniform int32_t y) {- return sdiv32(x + y - 1, y);+ if (y == -1) {+ return (uniform int32_t)(0 - (uniform uint32_t)x);+ }+ uniform int32_t q = x / y;+ uniform int32_t r = x % y;++ return q + ((r != 0 && (r > 0) == (y > 0)) ? 1 : 0); } static inline uniform int64_t sceil_div64(uniform int64_t x, uniform int64_t y) {- return sdiv64(x + y - 1, y);+ if (y == -1) {+ return (uniform int64_t)(0 - (uniform uint64_t)x);+ }+ uniform int64_t q = x / y;+ uniform int64_t r = x % y;++ return q + ((r != 0 && (r > 0) == (y > 0)) ? 1 : 0); } static inline uniform int8_t smod8(uniform int8_t x, uniform int8_t y) {+ if (y == -1) {+ return 0;+ } uniform int8_t r = x % y; return r + (r == 0 || (x > 0 && y > 0) || (x < 0 && y < 0) ? 0 : y); } static inline uniform int16_t smod16(uniform int16_t x, uniform int16_t y) {+ if (y == -1) {+ return 0;+ } uniform int16_t r = x % y; return r + (r == 0 || (x > 0 && y > 0) || (x < 0 && y < 0) ? 0 : y); } static inline uniform int32_t smod32(uniform int32_t x, uniform int32_t y) {+ if (y == -1) {+ return 0;+ } uniform int32_t r = x % y; return r + (r == 0 || (x > 0 && y > 0) || (x < 0 && y < 0) ? 0 : y); } static inline uniform int64_t smod64(uniform int64_t x, uniform int64_t y) {+ if (y == -1) {+ return 0;+ } uniform int64_t r = x % y; return r + (r == 0 || (x > 0 && y > 0) || (x < 0 && y < 0) ? 0 : y);@@ -234,19 +294,19 @@ } static inline uniform int8_t sceil_div_safe8(uniform int8_t x, uniform int8_t y) {- return sdiv_safe8(x + y - 1, y);+ return y == 0 ? 0 : sceil_div8(x, y); } static inline uniform int16_t sceil_div_safe16(uniform int16_t x, uniform int16_t y) {- return sdiv_safe16(x + y - 1, y);+ return y == 0 ? 0 : sceil_div16(x, y); } static inline uniform int32_t sceil_div_safe32(uniform int32_t x, uniform int32_t y) {- return sdiv_safe32(x + y - 1, y);+ return y == 0 ? 0 : sceil_div32(x, y); } static inline uniform int64_t sceil_div_safe64(uniform int64_t x, uniform int64_t y) {- return sdiv_safe64(x + y - 1, y);+ return y == 0 ? 0 : sceil_div64(x, y); } static inline uniform int8_t smod_safe8(uniform int8_t x, uniform int8_t y) {@@ -266,67 +326,67 @@ } static inline uniform int8_t squot8(uniform int8_t x, uniform int8_t y) {- return x / y;+ return y == -1 ? (uniform int8_t)(0 - (uniform uint8_t)x) : x / y; } static inline uniform int16_t squot16(uniform int16_t x, uniform int16_t y) {- return x / y;+ return y == -1 ? (uniform int16_t)(0 - (uniform uint16_t)x) : x / y; } static inline uniform int32_t squot32(uniform int32_t x, uniform int32_t y) {- return x / y;+ return y == -1 ? (uniform int32_t)(0 - (uniform uint32_t)x) : x / y; } static inline uniform int64_t squot64(uniform int64_t x, uniform int64_t y) {- return x / y;+ return y == -1 ? (uniform int64_t)(0 - (uniform uint64_t)x) : x / y; } static inline uniform int8_t srem8(uniform int8_t x, uniform int8_t y) {- return x % y;+ return y == -1 ? 0 : x % y; } static inline uniform int16_t srem16(uniform int16_t x, uniform int16_t y) {- return x % y;+ return y == -1 ? 0 : x % y; } static inline uniform int32_t srem32(uniform int32_t x, uniform int32_t y) {- return x % y;+ return y == -1 ? 0 : x % y; } static inline uniform int64_t srem64(uniform int64_t x, uniform int64_t y) {- return x % y;+ return y == -1 ? 0 : x % y; } static inline uniform int8_t squot_safe8(uniform int8_t x, uniform int8_t y) {- return y == 0 ? 0 : x / y;+ return y == 0 ? 0 : squot8(x, y); } static inline uniform int16_t squot_safe16(uniform int16_t x, uniform int16_t y) {- return y == 0 ? 0 : x / y;+ return y == 0 ? 0 : squot16(x, y); } static inline uniform int32_t squot_safe32(uniform int32_t x, uniform int32_t y) {- return y == 0 ? 0 : x / y;+ return y == 0 ? 0 : squot32(x, y); } static inline uniform int64_t squot_safe64(uniform int64_t x, uniform int64_t y) {- return y == 0 ? 0 : x / y;+ return y == 0 ? 0 : squot64(x, y); } static inline uniform int8_t srem_safe8(uniform int8_t x, uniform int8_t y) {- return y == 0 ? 0 : x % y;+ return y == 0 ? 0 : srem8(x, y); } static inline uniform int16_t srem_safe16(uniform int16_t x, uniform int16_t y) {- return y == 0 ? 0 : x % y;+ return y == 0 ? 0 : srem16(x, y); } static inline uniform int32_t srem_safe32(uniform int32_t x, uniform int32_t y) {- return y == 0 ? 0 : x % y;+ return y == 0 ? 0 : srem32(x, y); } static inline uniform int64_t srem_safe64(uniform int64_t x, uniform int64_t y) {- return y == 0 ? 0 : x % y;+ return y == 0 ? 0 : srem64(x, y); } static inline uniform int8_t smin8(uniform int8_t x, uniform int8_t y) {@@ -394,51 +454,51 @@ } static inline uniform uint8_t shl8(uniform uint8_t x, uniform uint8_t y) {- return (uniform uint8_t)(x << y);+ return (uniform uint8_t)(x << (y & 7)); } static inline uniform uint16_t shl16(uniform uint16_t x, uniform uint16_t y) {- return (uniform uint16_t)(x << y);+ return (uniform uint16_t)(x << (y & 15)); } static inline uniform uint32_t shl32(uniform uint32_t x, uniform uint32_t y) {- return x << y;+ return x << (y & 31); } static inline uniform uint64_t shl64(uniform uint64_t x, uniform uint64_t y) {- return x << y;+ return x << (y & 63); } static inline uniform uint8_t lshr8(uniform uint8_t x, uniform uint8_t y) {- return x >> y;+ return x >> (y & 7); } static inline uniform uint16_t lshr16(uniform uint16_t x, uniform uint16_t y) {- return x >> y;+ return x >> (y & 15); } static inline uniform uint32_t lshr32(uniform uint32_t x, uniform uint32_t y) {- return x >> y;+ return x >> (y & 31); } static inline uniform uint64_t lshr64(uniform uint64_t x, uniform uint64_t y) {- return x >> y;+ return x >> (y & 63); } static inline uniform int8_t ashr8(uniform int8_t x, uniform int8_t y) {- return x >> y;+ return x >> (y & 7); } static inline uniform int16_t ashr16(uniform int16_t x, uniform int16_t y) {- return x >> y;+ return x >> (y & 15); } static inline uniform int32_t ashr32(uniform int32_t x, uniform int32_t y) {- return x >> y;+ return x >> (y & 31); } static inline uniform int64_t ashr64(uniform int64_t x, uniform int64_t y) {- return x >> y;+ return x >> (y & 63); } static inline uniform uint8_t and8(uniform uint8_t x, uniform uint8_t y) {@@ -553,7 +613,7 @@ return x <= y; } -static inline uniform uint8_t pow8(uniform uint8_t x, uniform uint8_t y) {+static inline uniform uint8_t upow8(uniform uint8_t x, uniform uint8_t y) { uniform uint8_t res = 1, rem = y; while (rem != 0) {@@ -565,7 +625,7 @@ return res; } -static inline uniform uint16_t pow16(uniform uint16_t x, uniform uint16_t y) {+static inline uniform uint16_t upow16(uniform uint16_t x, uniform uint16_t y) { uniform uint16_t res = 1, rem = y; while (rem != 0) {@@ -577,7 +637,7 @@ return res; } -static inline uniform uint32_t pow32(uniform uint32_t x, uniform uint32_t y) {+static inline uniform uint32_t upow32(uniform uint32_t x, uniform uint32_t y) { uniform uint32_t res = 1, rem = y; while (rem != 0) {@@ -589,7 +649,7 @@ return res; } -static inline uniform uint64_t pow64(uniform uint64_t x, uniform uint64_t y) {+static inline uniform uint64_t upow64(uniform uint64_t x, uniform uint64_t y) { uniform uint64_t res = 1, rem = y; while (rem != 0) {@@ -601,6 +661,22 @@ return res; } +static inline uniform int8_t spow8(uniform int8_t x, uniform int8_t y) {+ return (uniform int8_t)upow8((uniform uint8_t)x, (uniform uint8_t)y);+}++static inline uniform int16_t spow16(uniform int16_t x, uniform int16_t y) {+ return (uniform int16_t)upow16((uniform uint16_t)x, (uniform uint16_t)y);+}++static inline uniform int32_t spow32(uniform int32_t x, uniform int32_t y) {+ return (uniform int32_t)upow32((uniform uint32_t)x, (uniform uint32_t)y);+}++static inline uniform int64_t spow64(uniform int64_t x, uniform int64_t y) {+ return (uniform int64_t)upow64((uniform uint64_t)x, (uniform uint64_t)y);+}+ static inline uniform bool itob_i8_bool(uniform int8_t x) { return x != 0; }@@ -1396,11 +1472,11 @@ } static inline uniform int64_t futrts_to_bits64(uniform double x) {- return *((uniform int64_t* uniform)&x);+ return intbits(x); } static inline uniform double futrts_from_bits64(uniform int64_t x) {- return *((uniform double* uniform)&x);+ return doublebits(x); } static inline uniform double fmod64(uniform double x, uniform double y) {@@ -1733,11 +1809,11 @@ } static inline uniform int16_t fptobits_f16_i16(uniform f16 x) {- return *((uniform int16_t *)&x);+ return intbits(x); } static inline uniform f16 bitstofp_i16_f16(uniform int16_t x) {- return *((uniform f16 *)&x);+ return float16bits(x); } static inline uniform float fpconv_f16_f16(uniform f16 x) {
rts/c/util.h view
@@ -7,13 +7,19 @@ static const char *fut_progname = "(embedded Futhark)"; -static void futhark_panic(int eval, const char *fmt, ...) __attribute__((noreturn));-static char* msgprintf(const char *s, ...);+static void futhark_panic(int eval, const char *fmt, ...)+ __attribute__((noreturn, format(printf, 2, 3)));+static char* msgprintf(const char *s, ...)+ __attribute__((format(printf, 1, 2)));+static inline void check_err(int errval, int sets_errno, const char *fun, int line,+ const char *msg, ...)+ __attribute__((format(printf, 5, 6))); static void* slurp_file(const char *filename, size_t *size); static int dump_file(const char *file, const void *buf, size_t n); struct str_builder; static void str_builder_init(struct str_builder *b);-static void str_builder(struct str_builder *b, const char *s, ...);+static void str_builder(struct str_builder *b, const char *s, ...)+ __attribute__((format(printf, 2, 3))); static char *strclone(const char *str); static void futhark_panic(int eval, const char *fmt, ...) {@@ -31,22 +37,26 @@ va_list vl; va_start(vl, s); size_t needed = 1 + (size_t)vsnprintf(NULL, 0, s, vl);+ va_end(vl); char *buffer = (char*) malloc(needed); va_start(vl, s); // Must re-init. vsnprintf(buffer, needed, s, vl);+ va_end(vl); return buffer; } static inline void check_err(int errval, int sets_errno, const char *fun, int line, const char *msg, ...) { if (errval) {- char errnum[10];+ char errnum[12];+ (void)snprintf(errnum, sizeof(errnum), "%d", errval); va_list vl; va_start(vl, msg); fprintf(stderr, "ERROR: "); vfprintf(stderr, msg, vl);+ va_end(vl); fprintf(stderr, " in %s() at line %d with error code %s\n", fun, line, sets_errno ? strerror(errno) : errnum);@@ -98,6 +108,7 @@ } if (fwrite(buf, sizeof(char), n, f) != n) {+ fclose(f); return 1; } @@ -125,6 +136,7 @@ va_list vl; va_start(vl, s); size_t needed = (size_t)vsnprintf(NULL, 0, s, vl);+ va_end(vl); while (b->capacity < b->used + needed + 1) { b->capacity *= 2;@@ -133,12 +145,13 @@ va_start(vl, s); // Must re-init. vsnprintf(b->str+b->used, b->capacity-b->used, s, vl);+ va_end(vl); b->used += needed; } static void str_builder_str(struct str_builder *b, const char *s) { size_t needed = strlen(s);- if (b->capacity < b->used + needed + 1) {+ while (b->capacity < b->used + needed + 1) { b->capacity *= 2; b->str = realloc(b->str, b->capacity); }
rts/c/values.h view
@@ -411,7 +411,7 @@ return fprintf(out, "%huu16", *(const uint16_t*)src); } -static int write_str_i32(FILE *out, const int32_t *src) {+static int write_str_i32(FILE *out, const void *src) { return fprintf(out, "%di32", *(const int32_t*)src); } @@ -495,17 +495,10 @@ //// Binary I/O -#define BINARY_FORMAT_VERSION 2-#define IS_BIG_ENDIAN (!*(unsigned char *)&(uint16_t){1})+// The binary format is little-endian, and we assume that the host is+// as well. -static void flip_bytes(size_t elem_size, unsigned char *elem) {- for (size_t j=0; j<elem_size/2; j++) {- unsigned char head = elem[j];- size_t tail_index = elem_size-1-j;- elem[j] = elem[tail_index];- elem[tail_index] = head;- }-}+#define BINARY_FORMAT_VERSION 2 // On Windows we need to explicitly set the file mode to not mangle // newline characters. On *nix there is no difference.@@ -538,43 +531,43 @@ static const struct primtype_info_t i8_info = {.binname = " i8", .type_name = "i8", .size = 1,- .write_str = (writer)write_str_i8, .read_str = (str_reader)read_str_i8};+ .write_str = write_str_i8, .read_str = read_str_i8}; static const struct primtype_info_t i16_info = {.binname = " i16", .type_name = "i16", .size = 2,- .write_str = (writer)write_str_i16, .read_str = (str_reader)read_str_i16};+ .write_str = write_str_i16, .read_str = read_str_i16}; static const struct primtype_info_t i32_info = {.binname = " i32", .type_name = "i32", .size = 4,- .write_str = (writer)write_str_i32, .read_str = (str_reader)read_str_i32};+ .write_str = write_str_i32, .read_str = read_str_i32}; static const struct primtype_info_t i64_info = {.binname = " i64", .type_name = "i64", .size = 8,- .write_str = (writer)write_str_i64, .read_str = (str_reader)read_str_i64};+ .write_str = write_str_i64, .read_str = read_str_i64}; static const struct primtype_info_t u8_info = {.binname = " u8", .type_name = "u8", .size = 1,- .write_str = (writer)write_str_u8, .read_str = (str_reader)read_str_u8};+ .write_str = write_str_u8, .read_str = read_str_u8}; static const struct primtype_info_t u16_info = {.binname = " u16", .type_name = "u16", .size = 2,- .write_str = (writer)write_str_u16, .read_str = (str_reader)read_str_u16};+ .write_str = write_str_u16, .read_str = read_str_u16}; static const struct primtype_info_t u32_info = {.binname = " u32", .type_name = "u32", .size = 4,- .write_str = (writer)write_str_u32, .read_str = (str_reader)read_str_u32};+ .write_str = write_str_u32, .read_str = read_str_u32}; static const struct primtype_info_t u64_info = {.binname = " u64", .type_name = "u64", .size = 8,- .write_str = (writer)write_str_u64, .read_str = (str_reader)read_str_u64};+ .write_str = write_str_u64, .read_str = read_str_u64}; static const struct primtype_info_t f16_info = {.binname = " f16", .type_name = "f16", .size = 2,- .write_str = (writer)write_str_f16, .read_str = (str_reader)read_str_f16};+ .write_str = write_str_f16, .read_str = read_str_f16}; static const struct primtype_info_t f32_info = {.binname = " f32", .type_name = "f32", .size = 4,- .write_str = (writer)write_str_f32, .read_str = (str_reader)read_str_f32};+ .write_str = write_str_f32, .read_str = read_str_f32}; static const struct primtype_info_t f64_info = {.binname = " f64", .type_name = "f64", .size = 8,- .write_str = (writer)write_str_f64, .read_str = (str_reader)read_str_f64};+ .write_str = write_str_f64, .read_str = read_str_f64}; static const struct primtype_info_t bool_info = {.binname = "bool", .type_name = "bool", .size = 1,- .write_str = (writer)write_str_bool, .read_str = (str_reader)read_str_bool};+ .write_str = write_str_bool, .read_str = read_str_bool}; static const struct primtype_info_t unit_info = {.binname = "bool", .type_name = "unit", .size = 1,- .write_str = (writer)write_str_unit, .read_str = (str_reader)read_str_unit};+ .write_str = write_str_unit, .read_str = read_str_unit}; static const struct primtype_info_t* primtypes[] = { &i8_info, &i16_info, &i32_info, &i64_info,@@ -584,8 +577,7 @@ NULL // NULL-terminated }; -// General value interface. All endian business taken care of at-// lower layers.+// General value interface. static int read_is_binary(FILE *f) { skipspaces(f);@@ -608,7 +600,7 @@ } static const struct primtype_info_t* read_bin_read_type_enum(FILE *f) {- char read_binname[4];+ char read_binname[5] = { 0 }; int num_matched = fscanf(f, "%4c", read_binname); if (num_matched != 1) { futhark_panic(1, "binary-input: Couldn't read element type.\n"); }@@ -655,48 +647,50 @@ if (ret != 0) { futhark_panic(1, "binary-input: Couldn't get dims.\n"); } if (bin_dims != dims) {- futhark_panic(1, "binary-input: Expected %i dimensions, but got array with %i dimensions.\n",- dims, bin_dims);+ futhark_panic(1, "binary-input: Expected %d dimensions, but got array with %d dimensions.\n",+ (int)dims, (int)bin_dims); } const struct primtype_info_t *bin_primtype = read_bin_read_type_enum(f); if (expected_type != bin_primtype) {- futhark_panic(1, "binary-input: Expected %iD-array with element type '%s' but got %iD-array with element type '%s'.\n",- dims, expected_type->type_name, dims, bin_primtype->type_name);+ futhark_panic(1, "binary-input: Expected %dD-array with element type '%s' but got %dD-array with element type '%s'.\n",+ (int)dims, expected_type->type_name,+ (int)dims, bin_primtype->type_name); } int64_t elem_count = 1; for (int i=0; i<dims; i++) {- int64_t bin_shape;+ uint64_t bin_shape; ret = (int)fread(&bin_shape, sizeof(bin_shape), 1, f); if (ret != 1) { futhark_panic(1, "binary-input: Couldn't read size for dimension %i of array.\n", i); }- if (IS_BIG_ENDIAN) {- flip_bytes(sizeof(bin_shape), (unsigned char*) &bin_shape);+ if (bin_shape > INT64_MAX) {+ futhark_panic(1, "binary-input: dimension %i does not fit in signed 64-bit integer.\n", i); }+ if (bin_shape != 0 && elem_count > INT64_MAX / (int64_t)bin_shape) {+ futhark_panic(1, "binary-input: array with %d dimensions has too many elements.\n", (int)dims);+ } elem_count *= bin_shape; shape[i] = bin_shape; } int64_t elem_size = expected_type->size;+ if (elem_count > INT64_MAX / elem_size) {+ futhark_panic(1, "binary-input: array too large.\n");+ } void* tmp = realloc(*data, (size_t)(elem_count * elem_size)); if (tmp == NULL) {- futhark_panic(1, "binary-input: Failed to allocate array of size %i.\n",- elem_count * elem_size);+ futhark_panic(1, "binary-input: Failed to allocate array of size %lld.\n",+ (long long int)(elem_count * elem_size)); } *data = tmp; - int64_t num_elems_read = (int64_t)fread(*data, (size_t)elem_size, (size_t)elem_count, f);- if (num_elems_read != elem_count) {- futhark_panic(1, "binary-input: tried to read %i elements of an array, but only got %i elements.\n",- elem_count, num_elems_read);- }-- // If we're on big endian platform we must change all multibyte elements- // from using little endian to big endian- if (IS_BIG_ENDIAN && elem_size != 1) {- flip_bytes((size_t)elem_size, (unsigned char*) *data);+ uint64_t num_elems_read = (uint64_t)fread(*data, (size_t)elem_size, (size_t)elem_count, f);+ if (num_elems_read != (uint64_t)elem_count) {+ futhark_panic(1, "binary-input: tried to read %lld elements of an array, but only got %lld elements.\n",+ (long long int)elem_count,+ (long long int)num_elems_read); } return 0;@@ -704,7 +698,7 @@ static int read_array(FILE *f, const struct primtype_info_t *expected_type, void **data, int64_t *shape, int64_t dims) { if (!read_is_binary(f)) {- return read_str_array(f, expected_type->size, (str_reader)expected_type->read_str, expected_type->type_name, data, shape, dims);+ return read_str_array(f, expected_type->size, expected_type->read_str, expected_type->type_name, data, shape, dims); } else { return read_bin_array(f, expected_type, data, shape, dims); }@@ -785,16 +779,7 @@ fwrite(shape, sizeof(int64_t), (size_t)rank, out); } - if (IS_BIG_ENDIAN) {- for (int64_t i = 0; i < num_elems; i++) {- const unsigned char *elem = data+i*elem_type->size;- for (int64_t j = 0; j < elem_type->size; j++) {- fwrite(&elem[elem_type->size-j], 1, 1, out);- }- }- } else {- fwrite(data, (size_t)elem_type->size, (size_t)num_elems, out);- }+ fwrite(data, (size_t)elem_type->size, (size_t)num_elems, out); return 0; }@@ -821,9 +806,6 @@ read_bin_ensure_scalar(f, expected_type); size_t elem_size = (size_t)expected_type->size; size_t num_elems_read = fread(dest, elem_size, 1, f);- if (IS_BIG_ENDIAN) {- flip_bytes(elem_size, (unsigned char*) dest);- } return num_elems_read == 1 ? 0 : 1; } }
rts/cuda/prelude.cu view
@@ -111,6 +111,18 @@ __syncthreads(); } +// Make the memory effects of each thread in the warp visible to the+// others. Must be executed by all threads of the warp.+static inline __device__ void warp_sync() {+#ifdef FUTHARK_HIP+ __builtin_amdgcn_fence(__ATOMIC_RELEASE, "wavefront");+ __builtin_amdgcn_wave_barrier();+ __builtin_amdgcn_fence(__ATOMIC_ACQUIRE, "wavefront");+#else+ __syncwarp();+#endif+}+ #if defined(__CUDACC_RTC__) || defined(__HIPCC_RTC__) #define NAN (0.0/0.0) #define INFINITY (1.0/0.0)
rts/opencl/transpose.cl view
@@ -10,6 +10,10 @@ int32_t num_arrays, \ int32_t x_elems, \ int32_t y_elems, \+ int32_t dst_array_stride, \+ int32_t dst_row_stride, \+ int32_t src_array_stride, \+ int32_t src_row_stride, \ int32_t mulx, \ int32_t muly, \ int32_t repeat_1, \@@ -25,14 +29,13 @@ int global_id_2 = get_global_id(2); \ for (int i2 = 0; i2 <= repeat_2; i2++) { \ if (tblock_id_2 >= num_arrays) { break; } \- int32_t our_array_offset = tblock_id_2 * x_elems * y_elems; \- int32_t odata_offset = dst_offset + our_array_offset; \- int32_t idata_offset = src_offset + our_array_offset; \+ int32_t odata_offset = dst_offset + tblock_id_2 * dst_array_stride; \+ int32_t idata_offset = src_offset + tblock_id_2 * src_array_stride; \ int32_t x_index = global_id_0; \ int32_t y_index = tblock_id_1 * TR_TILE_DIM + get_local_id(1); \ if (x_index < x_elems) { \ for (int32_t j = 0; j < TR_ELEMS_PER_THREAD; j++) { \- int32_t index_i = (y_index + j * (TR_TILE_DIM/TR_ELEMS_PER_THREAD)) * x_elems + x_index; \+ int32_t index_i = (y_index + j * (TR_TILE_DIM/TR_ELEMS_PER_THREAD)) * src_row_stride + x_index; \ if (y_index + j * (TR_TILE_DIM/TR_ELEMS_PER_THREAD) < y_elems) { \ block[(get_local_id(1) + j * (TR_TILE_DIM/TR_ELEMS_PER_THREAD)) * (TR_TILE_DIM+1) + \ get_local_id(0)] = \@@ -45,7 +48,7 @@ y_index = tblock_id_0 * TR_TILE_DIM + get_local_id(1); \ if (x_index < y_elems) { \ for (int32_t j = 0; j < TR_ELEMS_PER_THREAD; j++) { \- int32_t index_out = (y_index + j * (TR_TILE_DIM/TR_ELEMS_PER_THREAD)) * y_elems + x_index; \+ int32_t index_out = (y_index + j * (TR_TILE_DIM/TR_ELEMS_PER_THREAD)) * dst_row_stride + x_index; \ if (y_index + j * (TR_TILE_DIM/TR_ELEMS_PER_THREAD) < x_elems) { \ dst_mem[(odata_offset + index_out)] = \ block[get_local_id(0) * (TR_TILE_DIM+1) + \@@ -70,6 +73,10 @@ int32_t num_arrays, \ int32_t x_elems, \ int32_t y_elems, \+ int32_t dst_array_stride, \+ int32_t dst_row_stride, \+ int32_t src_array_stride, \+ int32_t src_row_stride, \ int32_t mulx, \ int32_t muly, \ int32_t repeat_1, \@@ -84,15 +91,14 @@ int global_id_2 = get_global_id(2); \ for (int i2 = 0; i2 <= repeat_2; i2++) { \ if (tblock_id_2 >= num_arrays) { break; } \- int32_t our_array_offset = tblock_id_2 * x_elems * y_elems; \- int32_t odata_offset = dst_offset + our_array_offset; \- int32_t idata_offset = src_offset + our_array_offset; \+ int32_t odata_offset = dst_offset + tblock_id_2 * dst_array_stride; \+ int32_t idata_offset = src_offset + tblock_id_2 * src_array_stride; \ int32_t x_index = \ tblock_id_0 * TR_BLOCK_DIM * mulx + \ get_local_id(0) + \ get_local_id(1)%mulx * TR_BLOCK_DIM; \ int32_t y_index = tblock_id_1 * TR_BLOCK_DIM + get_local_id(1)/mulx; \- int32_t index_in = y_index * x_elems + x_index; \+ int32_t index_in = y_index * src_row_stride + x_index; \ if (x_index < x_elems && y_index < y_elems) { \ block[get_local_id(1) * (TR_BLOCK_DIM+1) + get_local_id(0)] = \ src_mem[idata_offset + index_in]; \@@ -103,7 +109,7 @@ tblock_id_0 * TR_BLOCK_DIM * mulx + \ get_local_id(1) + \ (get_local_id(0)%mulx) * TR_BLOCK_DIM; \- int32_t index_out = y_index * y_elems + x_index; \+ int32_t index_out = y_index * dst_row_stride + x_index; \ if (x_index < y_elems && y_index < x_elems) { \ dst_mem[odata_offset + index_out] = \ block[get_local_id(0) * (TR_BLOCK_DIM+1) + get_local_id(1)]; \@@ -125,6 +131,10 @@ int32_t num_arrays, \ int32_t x_elems, \ int32_t y_elems, \+ int32_t dst_array_stride, \+ int32_t dst_row_stride, \+ int32_t src_array_stride, \+ int32_t src_row_stride, \ int32_t mulx, \ int32_t muly, \ int32_t repeat_1, \@@ -139,14 +149,13 @@ int global_id_2 = get_global_id(2); \ for (int i2 = 0; i2 <= repeat_2; i2++) { \ if (tblock_id_2 >= num_arrays) { break; } \- int32_t our_array_offset = tblock_id_2 * x_elems * y_elems; \- int32_t odata_offset = dst_offset + our_array_offset; \- int32_t idata_offset = src_offset + our_array_offset; \+ int32_t odata_offset = dst_offset + tblock_id_2 * dst_array_stride; \+ int32_t idata_offset = src_offset + tblock_id_2 * src_array_stride; \ int32_t x_index = tblock_id_0 * TR_BLOCK_DIM + get_local_id(0)/muly; \ int32_t y_index = \ tblock_id_1 * TR_BLOCK_DIM * muly + \ get_local_id(1) + (get_local_id(0)%muly) * TR_BLOCK_DIM; \- int32_t index_in = y_index * x_elems + x_index; \+ int32_t index_in = y_index * src_row_stride + x_index; \ if (x_index < x_elems && y_index < y_elems) { \ block[get_local_id(1) * (TR_BLOCK_DIM+1) + get_local_id(0)] = \ src_mem[idata_offset + index_in]; \@@ -155,7 +164,7 @@ x_index = tblock_id_1 * TR_BLOCK_DIM * muly + \ get_local_id(0) + (get_local_id(1)%muly) * TR_BLOCK_DIM; \ y_index = tblock_id_0 * TR_BLOCK_DIM + get_local_id(1)/muly; \- int32_t index_out = y_index * y_elems + x_index; \+ int32_t index_out = y_index * dst_row_stride + x_index; \ if (x_index < y_elems && y_index < x_elems) { \ dst_mem[odata_offset + index_out] = \ block[get_local_id(0) * (TR_BLOCK_DIM+1) + get_local_id(1)]; \@@ -177,6 +186,10 @@ int32_t num_arrays, \ int32_t x_elems, \ int32_t y_elems, \+ int32_t dst_array_stride, \+ int32_t dst_row_stride, \+ int32_t src_array_stride, \+ int32_t src_row_stride, \ int32_t mulx, \ int32_t muly, \ int32_t repeat_1, \@@ -191,13 +204,13 @@ int tblock_id_2 = get_tblock_id(2); \ int global_id_2 = get_global_id(2); \ for (int i2 = 0; i2 <= repeat_2; i2++) { \- int32_t our_array_offset = global_id_0/(y_elems * x_elems) * y_elems * x_elems; \+ int32_t array = global_id_0/(y_elems * x_elems); \ int32_t x_index = (global_id_0 % (y_elems * x_elems))/y_elems; \ int32_t y_index = global_id_0%y_elems; \- int32_t odata_offset = dst_offset + our_array_offset; \- int32_t idata_offset = src_offset + our_array_offset; \- int32_t index_in = y_index * x_elems + x_index; \- int32_t index_out = x_index * y_elems + y_index; \+ int32_t odata_offset = dst_offset + array * dst_array_stride; \+ int32_t idata_offset = src_offset + array * src_array_stride; \+ int32_t index_in = y_index * src_row_stride + x_index; \+ int32_t index_out = x_index * dst_row_stride + y_index; \ if (global_id_0 < x_elems * y_elems * num_arrays) { \ dst_mem[odata_offset + index_out] = src_mem[idata_offset + index_in]; \ } \@@ -218,6 +231,10 @@ int64_t num_arrays, \ int64_t x_elems, \ int64_t y_elems, \+ int64_t dst_array_stride, \+ int64_t dst_row_stride, \+ int64_t src_array_stride, \+ int64_t src_row_stride, \ int64_t mulx, \ int64_t muly, \ int32_t repeat_1, \@@ -233,14 +250,13 @@ int global_id_2 = get_global_id(2); \ for (int i2 = 0; i2 <= repeat_2; i2++) { \ if (tblock_id_2 >= num_arrays) { break; } \- int64_t our_array_offset = tblock_id_2 * x_elems * y_elems; \- int64_t odata_offset = dst_offset + our_array_offset; \- int64_t idata_offset = src_offset + our_array_offset; \+ int64_t odata_offset = dst_offset + tblock_id_2 * dst_array_stride; \+ int64_t idata_offset = src_offset + tblock_id_2 * src_array_stride; \ int64_t x_index = global_id_0; \ int64_t y_index = tblock_id_1 * TR_TILE_DIM + get_local_id(1); \ if (x_index < x_elems) { \ for (int64_t j = 0; j < TR_ELEMS_PER_THREAD; j++) { \- int64_t index_i = (y_index + j * (TR_TILE_DIM/TR_ELEMS_PER_THREAD)) * x_elems + x_index; \+ int64_t index_i = (y_index + j * (TR_TILE_DIM/TR_ELEMS_PER_THREAD)) * src_row_stride + x_index; \ if (y_index + j * (TR_TILE_DIM/TR_ELEMS_PER_THREAD) < y_elems) { \ block[(get_local_id(1) + j * (TR_TILE_DIM/TR_ELEMS_PER_THREAD)) * (TR_TILE_DIM+1) + \ get_local_id(0)] = \@@ -253,7 +269,7 @@ y_index = tblock_id_0 * TR_TILE_DIM + get_local_id(1); \ if (x_index < y_elems) { \ for (int64_t j = 0; j < TR_ELEMS_PER_THREAD; j++) { \- int64_t index_out = (y_index + j * (TR_TILE_DIM/TR_ELEMS_PER_THREAD)) * y_elems + x_index; \+ int64_t index_out = (y_index + j * (TR_TILE_DIM/TR_ELEMS_PER_THREAD)) * dst_row_stride + x_index; \ if (y_index + j * (TR_TILE_DIM/TR_ELEMS_PER_THREAD) < x_elems) { \ dst_mem[(odata_offset + index_out)] = \ block[get_local_id(0) * (TR_TILE_DIM+1) + \
rts/python/memory.py view
@@ -99,60 +99,60 @@ return True -def lmad_is_tr(strides, shape):- r = len(shape)- for i in range(1, r):- n = 1- m = 1- ok = True- expected = 1- # Check strides before 'i'.- for j in range(i - 1, -1, -1):- ok = ok and strides[j] == expected- expected *= shape[j]- n *= shape[j]- # Check strides after 'i'.- for j in range(r - 1, i - 1, -1):- ok = ok and strides[j] == expected- expected *= shape[j]- m *= shape[j]- if ok:- return (n, m)- return None--+# See lmad_map_tr() in rts/c/copy.h. Returns a tuple (num_arrays,+# rows, cols, dst_array_stride, dst_row_stride, src_array_stride,+# src_row_stride), or None if the copy is not a map(transpose). def lmad_map_tr(dst_strides, src_strides, shape):- r = len(dst_strides)- rowmajor_strides = [0] * r- rowmajor_strides[r - 1] = 1-- for i in range(r - 2, -1, -1):- rowmajor_strides[i] = rowmajor_strides[i + 1] * shape[i + 1]-- # map_r will be the number of mapped dimensions on top.- map_r = 0- k = 1- for i in range(r):+ c_shape = []+ c_dst_strides = []+ c_src_strides = []+ for d, s, n in zip(dst_strides, src_strides, shape):+ if n == 1:+ continue if (- dst_strides[i] != rowmajor_strides[i]- or src_strides[i] != rowmajor_strides[i]+ c_shape+ and c_dst_strides[-1] == d * n+ and c_src_strides[-1] == s * n ):- break+ c_shape[-1] *= n+ c_dst_strides[-1] = d+ c_src_strides[-1] = s else:- k *= shape[i]- map_r += 1+ c_shape.append(n)+ c_dst_strides.append(d)+ c_src_strides.append(s) - if rowmajor_strides[map_r:] == dst_strides[map_r:]:- r = lmad_is_tr(src_strides[map_r:], shape[map_r:])- if r is not None:- n, m = r- return (k, n, m)- elif rowmajor_strides[map_r:] == src_strides[map_r:]:- r = lmad_is_tr(dst_strides[map_r:], shape[map_r:])- if r is not None:- n, m = r- return (k, m, n) # Sic!- return None+ if len(c_shape) not in (2, 3):+ return None++ a, b = len(c_shape) - 2, len(c_shape) - 1+ if c_dst_strides[b] == 1 and c_src_strides[a] == 1:+ rows, cols = c_shape[b], c_shape[a]+ dst_row_stride, src_row_stride = c_dst_strides[a], c_src_strides[b]+ elif c_dst_strides[a] == 1 and c_src_strides[b] == 1:+ rows, cols = c_shape[a], c_shape[b]+ dst_row_stride, src_row_stride = c_dst_strides[b], c_src_strides[a]+ else:+ return None++ if len(c_shape) == 3:+ k, dst_array_stride, src_array_stride = (+ c_shape[0],+ c_dst_strides[0],+ c_src_strides[0],+ )+ else:+ k, dst_array_stride, src_array_stride = 1, 0, 0++ return (+ k,+ rows,+ cols,+ dst_array_stride,+ dst_row_stride,+ src_array_stride,+ src_row_stride,+ ) def lmad_copy_elements(
rts/python/opencl.py view
@@ -418,8 +418,9 @@ def map_transpose_gpu2gpu(- self, elem_size, dst, dst_offset, src, src_offset, k, n, m+ self, elem_size, dst, dst_offset, src, src_offset, tr ):+ k, n, m = tr[0:3] kernels = self.transpose_kernels[elem_size] kernel = kernels["default"] mulx = TR_BLOCK_DIM / n@@ -447,6 +448,7 @@ k32, m32, n32,+ *[np.int32(x) for x in tr[3:]], mulx32, muly32, np.int32(0),@@ -521,9 +523,8 @@ else: tr = lmad_map_tr(dst_strides, src_strides, shape) if tr is not None:- k, n, m = tr map_transpose_gpu2gpu(- self, elem_size, dst, dst_offset, src, src_offset, k, m, n+ self, elem_size, dst, dst_offset, src, src_offset, tr ) else: copy_elements_gpu2gpu(
rts/python/scalar.py view
@@ -42,14 +42,6 @@ return np.uint64(x) -def shlN(x, y):- return x << y---def ashrN(x, y):- return x >> y-- # Python is so slow that we just make all the unsafe operations safe, # always. @@ -65,7 +57,7 @@ if y == 0: return intlit(type(x), 0) else:- return (x + y - intlit(type(x), 1)) // y+ return x // y + intlit(type(x), 1 if x % y != 0 else 0) def smodN(x, y):@@ -86,9 +78,9 @@ if y == 0: return intlit(type(x), 0) else:+ ux, uy = unsigned(x), unsigned(y) return signed(- (unsigned(x) + unsigned(y) - unsigned(intlit(type(x), 1)))- // unsigned(y)+ ux // uy + unsigned(intlit(type(x), 1 if ux % uy != 0 else 0)) ) @@ -138,7 +130,8 @@ def powN(x, y):- return x**y+ # The exponent is interpreted as unsigned.+ return signed(unsigned(x) ** unsigned(y)) def fpowN(x, y):@@ -161,20 +154,55 @@ return unsigned(x) < unsigned(y) +# Shift amounts are masked to the bit width.+++def shl8(x, y):+ return x << (y & 7)+++def shl16(x, y):+ return x << (y & 15)+++def shl32(x, y):+ return x << (y & 31)+++def shl64(x, y):+ return x << (y & 63)+++def ashr8(x, y):+ return x >> (y & 7)+++def ashr16(x, y):+ return x >> (y & 15)+++def ashr32(x, y):+ return x >> (y & 31)+++def ashr64(x, y):+ return x >> (y & 63)++ def lshr8(x, y):- return np.int8(np.uint8(x) >> np.uint8(y))+ return np.int8(np.uint8(x) >> np.uint8(y & 7)) def lshr16(x, y):- return np.int16(np.uint16(x) >> np.uint16(y))+ return np.int16(np.uint16(x) >> np.uint16(y & 15)) def lshr32(x, y):- return np.int32(np.uint32(x) >> np.uint32(y))+ return np.int32(np.uint32(x) >> np.uint32(y & 31)) def lshr64(x, y):- return np.int64(np.uint64(x) >> np.uint64(y))+ return np.int64(np.uint64(x) >> np.uint64(y & 63)) def sext_T_i8(x):@@ -294,16 +322,16 @@ sdiv8 = sdiv16 = sdiv32 = sdiv64 = sdivN-sceil_div8 = sdiv1_up6 = sceil_div32 = sceil_div64 = sceil_divN-sdiv_safe8 = sdiv1_safe6 = sdiv_safe32 = sdiv_safe64 = sdivN-sceil_div_safe8 = sceil_div1_safe6 = sceil_div_safe32 = sceil_div_safe64 = (+sceil_div8 = sceil_div16 = sceil_div32 = sceil_div64 = sceil_divN+sdiv_safe8 = sdiv_safe16 = sdiv_safe32 = sdiv_safe64 = sdivN+sceil_div_safe8 = sceil_div_safe16 = sceil_div_safe32 = sceil_div_safe64 = ( sceil_divN ) smod8 = smod16 = smod32 = smod64 = smodN smod_safe8 = smod_safe16 = smod_safe32 = smod_safe64 = smodN udiv8 = udiv16 = udiv32 = udiv64 = udivN-uceil_div8 = uceil_div16 = uceil_div32 = uceil_div64 = udivN-udiv_safe8 = udiv_safe16 = udiv_safe32 = udiv_safe64 = uceil_divN+uceil_div8 = uceil_div16 = uceil_div32 = uceil_div64 = uceil_divN+udiv_safe8 = udiv_safe16 = udiv_safe32 = udiv_safe64 = udivN uceil_div_safe8 = uceil_div_safe16 = uceil_div_safe32 = uceil_div_safe64 = ( uceil_divN )@@ -314,13 +342,12 @@ srem8 = srem16 = srem32 = srem64 = sremN srem_safe8 = srem_safe16 = srem_safe32 = srem_safe64 = sremN -shl8 = shl16 = shl32 = shl64 = shlN-ashr8 = ashr16 = ashr32 = ashr64 = ashrN smax8 = smax16 = smax32 = smax64 = smaxN smin8 = smin16 = smin32 = smin64 = sminN umax8 = umax16 = umax32 = umax64 = umaxN umin8 = umin16 = umin32 = umin64 = uminN-pow8 = pow16 = pow32 = pow64 = powN+spow8 = spow16 = spow32 = spow64 = powN+upow8 = upow16 = upow32 = upow64 = powN fpow16 = fpow32 = fpow64 = fpowN fmax16 = fmax32 = fmax64 = fmaxN fmin16 = fmin32 = fmin64 = fminN
src-testing/Futhark/IR/Prop/ReshapeTests.hs view
@@ -138,6 +138,14 @@ ["A", "B", "C"] [dimSplice 0 2 ["AB", "1"], dimUnflatten 0 ["A", "B"]] @?= Nothing,+ testCase "Move unflatten past later flatten" $+ lhs+ ["AB", "C", "D", "E"]+ [ dimUnflatten 0 ["A", "B"],+ dimFlatten 3 2 "DE",+ dimFlatten 0 2 "AB"+ ]+ @?= Just [dimFlatten 2 2 "DE"], testCase "Inverse flatten and unflatten - simple case" $ lhs ["A", "B"]
src-testing/Futhark/LspTests.hs view
@@ -7,40 +7,60 @@ module Futhark.LspTests (tests, main) where import Colog.Core (LogAction (LogAction))+import Control.Applicative ((<|>)) import Control.Concurrent (forkIO) import Control.Lens ((^.)) import Control.Monad (zipWithM_) import Control.Monad.IO.Class (liftIO) import Data.Foldable (for_) import Data.Functor (void)+import Data.List (sortOn) import Data.Maybe (mapMaybe) import Data.Text (Text) import Data.Text qualified as T import Futhark.CLI.LSP (serverDefinition) import Futhark.Fmt.Printer (fmtToText) import Language.Futhark.Parser.Monad (SyntaxError (..))-import Language.LSP.Protocol.Lens (uri)-import Language.LSP.Protocol.Message (SMethod (SMethod_WorkspaceApplyEdit))+import Language.LSP.Protocol.Lens (uri, version)+import Language.LSP.Protocol.Message+ ( SMethod (SMethod_TextDocumentFormatting, SMethod_TextDocumentPublishDiagnostics, SMethod_WindowShowMessage, SMethod_WorkspaceApplyEdit),+ TNotificationMessage (TNotificationMessage),+ TResponseError (TResponseError),+ TResponseMessage (TResponseMessage),+ ) import Language.LSP.Protocol.Types ( CodeAction (..), CodeLens (CodeLens), Definition (Definition),+ Diagnostic (..),+ DiagnosticSeverity (DiagnosticSeverity_Error, DiagnosticSeverity_Warning),+ DocumentFormattingParams (DocumentFormattingParams), FormattingOptions (FormattingOptions), Hover (Hover), InlayHint (..), InlayHintKind (InlayHintKind_Type),+ LSPErrorCodes (LSPErrorCodes_RequestFailed), LanguageKind (LanguageKind_Custom), Location (..), MarkupContent (..), MarkupKind (MarkupKind_PlainText),+ MessageType (MessageType_Error), Position (..),+ PublishDiagnosticsParams (..), Range (..),+ SemanticTokens (..),+ ShowMessageParams (ShowMessageParams),+ TextDocumentContentChangeEvent (..),+ TextDocumentContentChangeWholeDocument (..), TextDocumentIdentifier, type (|?) (..), ) import Language.LSP.Server (runServerWithHandles) import Language.LSP.Test ( Session,+ SessionConfig (..),+ anyMessage,+ changeDoc, createDoc, defaultConfig, documentContents,@@ -53,17 +73,24 @@ getCodeActions, getDefinitions, getHover,+ getSemanticTokens,+ getVersionedDoc, message,+ request, runSessionWithHandles,+ waitForDiagnostics, ) import NeatInterpolation (text) import System.IO (hClose) import System.Process (createPipe) import Test.Tasty (TestName, TestTree, defaultMain, testGroup)-import Test.Tasty.HUnit (assertFailure, testCase, (@?=))+import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=)) runServerSessionPair :: Session a -> IO a-runServerSessionPair session = do+runServerSessionPair = runServerSessionPairWith defaultConfig++runServerSessionPairWith :: SessionConfig -> Session a -> IO a+runServerSessionPairWith config session = do (serverIn, clientOut) <- createPipe (clientIn, serverOut) <- createPipe futharkServer <- serverDefinition@@ -74,7 +101,7 @@ forkIO . void $ runServerWithHandles ignoreLog ignoreLog serverIn serverOut futharkServer - result <- runSessionWithHandles clientOut clientIn defaultConfig fullLatestClientCaps "." session+ result <- runSessionWithHandles clientOut clientIn config fullLatestClientCaps "." session for_ [serverIn, clientOut, clientIn, serverOut] hClose @@ -89,6 +116,63 @@ serverTestCase :: TestName -> Session () -> TestTree serverTestCase testName = testCase testName . runServerSessionPair +testDiagnosticsOnOpen :: TestTree+testDiagnosticsOnOpen = serverTestCase "Diagnostics on open" $ do+ _ <- createMainDoc "def main = 1i32 + true"+ diags <- waitForDiagnostics+ liftIO $ map severityAndRange diags @?= [(Just DiagnosticSeverity_Error, expectedRange)]+ where+ expectedRange =+ Range+ { _start = Position {_line = 0, _character = 18},+ _end = Position {_line = 0, _character = 22}+ }++ severityAndRange Diagnostic {..} = (_severity, _range)++testWarningsWithErrors :: TestTree+testWarningsWithErrors = serverTestCase "Warnings with errors" $ do+ _ <- createMainDoc "def f (x: i32) = let y = x in x\ndef g (x: i32) = x + true"+ diags <- waitForDiagnostics+ liftIO $+ sortOn fst (map lineAndSeverity diags)+ @?= [(0, Just DiagnosticSeverity_Warning), (1, Just DiagnosticSeverity_Error)]+ where+ lineAndSeverity Diagnostic {..} = (_line (_start _range), _severity)++-- The clearing of fixed diagnostics must carry the current document+-- version, or clients may discard it as stale. A client that has+-- since changed the document discards it anyway, so every+-- compilation must also publish for every open document.+testDiagnosticsClearedOnFix :: TestTree+testDiagnosticsClearedOnFix = serverTestCase "Diagnostics cleared on fix" $ do+ docIdent <- createMainDoc "def main = 1i32 + true"+ _ <- waitForDiagnostics+ changeTo docIdent "def main = 1i32 + 2"+ expectCleared docIdent+ changeTo docIdent "def main = 1i32 + 3"+ expectCleared docIdent+ where+ changeTo docIdent s =+ changeDoc docIdent [TextDocumentContentChangeEvent $ InR $ TextDocumentContentChangeWholeDocument s]+ expectCleared docIdent = do+ TNotificationMessage _ _ (PublishDiagnosticsParams _ diags_version diags) <- publishedDiagnostics+ doc <- getVersionedDoc docIdent+ liftIO $ (diags_version, diags) @?= (Just (doc ^. version), [])+ publishedDiagnostics =+ message SMethod_TextDocumentPublishDiagnostics <|> (anyMessage *> publishedDiagnostics)++testUnlocatedError :: TestTree+testUnlocatedError = testCase "Error without location" . runServerSessionPairWith config $ do+ _ <- createDoc "main.txt" (LanguageKind_Custom "Futhark") "def main = 0i32"+ TNotificationMessage _ _ (ShowMessageParams message_type msg) <- showMessage+ liftIO $ message_type @?= MessageType_Error+ liftIO $ assertBool "Mentions extension" $ ".fut extension" `T.isInfixOf` msg+ where+ -- By default, lsp-test discards window/showMessage.+ config = defaultConfig {ignoreLogNotifications = False}+ showMessage = message SMethod_WindowShowMessage <|> (anyMessage *> showMessage)+ testHoverInformation :: TestTree testHoverInformation = serverTestCase "Hover" $ do docIdent <- createMainDoc "def main = let xyz = 42i32 in xyz"@@ -107,7 +191,7 @@ expectedRange = Range { _start = Position {_line = 0, _character = 30},- _end = Position {_line = 0, _character = 34}+ _end = Position {_line = 0, _character = 33} } testDefinition :: TestTree@@ -122,7 +206,7 @@ { _uri = docIdent ^. uri, _range = Range- { _end = Position 0 15,+ { _end = Position 0 14, _start = Position 0 0 } }@@ -142,6 +226,12 @@ _character = 12 } +testSemanticTokens :: TestTree+testSemanticTokens = serverTestCase "Semantic tokens" $ do+ docIdent <- createMainDoc "def main = 0i32"+ tokens <- getSemanticTokens docIdent+ liftIO $ tokens @?= InL (SemanticTokens Nothing [])+ testFormatting :: TestTree testFormatting = serverTestCase "Formatting" $ do docIdent <- createMainDoc mainContents@@ -164,12 +254,28 @@ 0i32 |] +testFormattingSyntaxError :: TestTree+testFormattingSyntaxError = serverTestCase "Formatting syntax error" $ do+ docIdent <- createMainDoc "def main = ("+ TResponseMessage _ _ result <-+ request SMethod_TextDocumentFormatting $+ DocumentFormattingParams Nothing docIdent formattingOptions+ liftIO $ case result of+ Left (TResponseError code msg _) -> do+ code @?= InL LSPErrorCodes_RequestFailed+ assertBool ("Unexpected message: " <> T.unpack msg) $+ "main.fut:" `T.isInfixOf` msg+ Right edits ->+ assertFailure $ "Expected an error, got: " <> show edits+ where+ formattingOptions = FormattingOptions 0 False Nothing Nothing Nothing+ main :: IO () main = defaultMain testEvaluationComment -testEvaluationComment :: TestTree-testEvaluationComment = serverTestCase "Evaluation Comment" $ do- docIdent <- createMainDoc mainContents+-- | Evaluate the single evaluation comment in the document.+evaluateComment :: TextDocumentIdentifier -> Session ()+evaluateComment docIdent = do lensCommand <- getAndResolveCodeLenses docIdent >>= \case [CodeLens _ (Just command) _] -> pure command@@ -178,8 +284,12 @@ executeCommand lensCommand -- this is important, it crashes with an IOError otherwise- _workspaceEdit <- message SMethod_WorkspaceApplyEdit+ void $ message SMethod_WorkspaceApplyEdit +testEvaluationComment :: TestTree+testEvaluationComment = serverTestCase "Evaluation Comment" $ do+ docIdent <- createMainDoc mainContents+ evaluateComment docIdent newContents <- documentContents docIdent liftIO $ newContents @?= expectedContents where@@ -192,6 +302,18 @@ -- >>> x + 5 |] +testEvaluationCommentReplacesResult :: TestTree+testEvaluationCommentReplacesResult =+ serverTestCase "Evaluation Comment replaces result" $ do+ docIdent <- createMainDoc mainContents+ evaluateComment docIdent+ evaluateComment docIdent+ newContents <- documentContents docIdent+ liftIO $ newContents @?= expectedContents+ where+ mainContents = "def x = 42i32\n-- >>> x + 5\ndef y = x\n"+ expectedContents = "def x = 42i32\n-- >>> x + 5\n-- 47\ndef y = x\n"+ fullRange :: Range fullRange = Range@@ -356,10 +478,17 @@ tests = testGroup "Futhark.LspTests"- [ testHoverInformation,+ [ testDiagnosticsOnOpen,+ testWarningsWithErrors,+ testDiagnosticsClearedOnFix,+ testUnlocatedError,+ testHoverInformation, testDefinition,+ testSemanticTokens, testFormatting,+ testFormattingSyntaxError, testEvaluationComment,+ testEvaluationCommentReplacesResult, testInlayTypeHint, testTypeCompletionCodeAction ]
src/Futhark/AD/Derivatives.hs view
@@ -69,10 +69,14 @@ pdBinOp (Add it _) _ _ = (iConst it 1, iConst it 1) pdBinOp (Sub it _) _ _ = (iConst it 1, iConst it (-1)) pdBinOp (Mul _ _) x y = (y, x)-pdBinOp (Pow it) a b =+pdBinOp (SPow it) a b = intBinOp derivs derivs derivs derivs it a b where derivs x y = ((x `pow` (y - 1)) * y, 0) -- FIXME (wrt y)+pdBinOp (UPow it) a b =+ intBinOp derivs derivs derivs derivs it a b+ where+ derivs x y = ((x `pow` (y - 1)) * y, 0) -- FIXME (wrt y) pdBinOp (SDiv it _) a b = intBinOp derivs derivs derivs derivs it a b where@@ -115,11 +119,11 @@ derivs x y = (fromBoolExp (x .<=. y), fromBoolExp (x .>. y)) -- pdBinOp (Shl it) a b =- pdBinOp (Mul it OverflowWrap) a $ BinOpExp (Pow it) (iConst it 2) b+ pdBinOp (Mul it OverflowWrap) a $ shiftFactor it b pdBinOp (LShr it) a b =- pdBinOp (UDiv it Unsafe) a $ BinOpExp (Pow it) (iConst it 2) b+ pdBinOp (UDiv it Unsafe) a $ shiftFactor it b pdBinOp (AShr it) a b =- pdBinOp (SDiv it Unsafe) a $ BinOpExp (Pow it) (iConst it 2) b+ pdBinOp (SDiv it Unsafe) a $ shiftFactor it b pdBinOp (And it) _a _b = (iConst it 0, iConst it 0) -- FIXME pdBinOp (Or it) _a _b = (iConst it 0, iConst it 0) -- FIXME pdBinOp (Xor it) _a _b = (iConst it 0, iConst it 0) -- FIXME@@ -486,3 +490,10 @@ pdBuiltin "popc32" [_] = Just [iConst Int32 0] pdBuiltin "popc64" [_] = Just [iConst Int32 0] pdBuiltin _ _ = Nothing++-- The factor corresponding to shifting by the given amount, which is+-- masked to the bit width.+shiftFactor :: IntType -> PrimExp VName -> PrimExp VName+shiftFactor it b =+ BinOpExp (UPow it) (iConst it 2) $+ BinOpExp (And it) b (iConst it (8 * intByteSize it - 1))
src/Futhark/AD/Rev/Acc.hs view
@@ -226,7 +226,7 @@ where mapper = (identityMapper :: (Monad m) => Mapper SOACS SOACS m)- { mapOnOp = traverseSOACStms (\_ stms -> pure $ onStms stms),+ { mapOnOp = traverseSOACBodies (\_ body -> pure body {bodyStms = onStms $ bodyStms body}), mapOnBody = \_ body -> pure $ onBody body } onStms = fmap onStm
src/Futhark/AD/Rev/Loop.hs view
@@ -151,7 +151,7 @@ bound_int <- letSubExp "bound_int" $ BasicOp $ ConvOp (FPToUI Float64 it) bound' total_iters <- letSubExp "total_iters" . BasicOp $- BinOp (Pow it) bound_int (Constant $ IntValue $ intValue it n)+ BinOp (UPow it) bound_int (Constant $ IntValue $ intValue it n) remain_iters <- letSubExp "remain_iters" $ BasicOp $ BinOp (Sub it OverflowUndef) bound total_iters mined_loop <- nestifyLoop bound_int n loop
src/Futhark/Actions.hs view
@@ -25,6 +25,8 @@ compileMulticoreToWASMAction, compilePythonAction, compilePyOpenCLAction,+ runSOACSAction,+ runGPUAction, ) where @@ -32,6 +34,7 @@ import Control.Monad.IO.Class import Control.Monad.State (get) import Data.Bifunctor+import Data.ByteString.Lazy.Char8 qualified as BS import Data.List (intercalate) import Data.Map qualified as M import Data.Maybe (fromMaybe)@@ -58,9 +61,13 @@ import Futhark.CodeGen.ImpGen.Multicore qualified as ImpGenMulticore import Futhark.CodeGen.ImpGen.Sequential qualified as ImpGenSequential import Futhark.Compiler.CLI+import Futhark.Data qualified as V+import Futhark.Data.Reader (readValues) import Futhark.IR+import Futhark.IR.GPU (GPU) import Futhark.IR.GPUMem (GPUMem) import Futhark.IR.MCMem (MCMem)+import Futhark.IR.Run (runGPU, runSOACS) import Futhark.IR.SOACS (SOACS) import Futhark.IR.SeqMem (SeqMem) import Futhark.Optimise.Fusion.GraphRep qualified@@ -70,6 +77,7 @@ import System.Directory import System.Exit import System.FilePath hiding ((</>))+import System.IO import System.Info qualified -- | Convert the program and compiler state to a textual form.@@ -631,3 +639,38 @@ hpath = outpath `addExtension` "h" mjspath = outpath `addExtension` "mjs" classpath = outpath `addExtension` ".class.js"++runWith ::+ Name ->+ (Prog rep -> Name -> [V.Value] -> IO (Either T.Text [V.Value])) ->+ Prog rep ->+ FutharkM ()+runWith entry_name f prog = do+ maybe_vs <- readValues <$> liftIO BS.getContents+ case maybe_vs of+ Nothing -> liftIO $ do+ hPutStrLn stderr "Malformed data on standard input."+ exitFailure+ Just vs -> do+ result <- liftIO $ f prog entry_name vs+ case result of+ Left err -> liftIO $ do+ T.hPutStrLn stderr err+ exitFailure+ Right vs' -> liftIO $ mapM_ (T.putStrLn . V.valueText) vs'++runSOACSAction :: Name -> Action SOACS+runSOACSAction entry_name =+ Action+ { actionName = "Run SOACS program",+ actionDescription = "Run program through the IR interpreter",+ actionProcedure = runWith entry_name runSOACS+ }++runGPUAction :: Name -> Action GPU+runGPUAction entry_name =+ Action+ { actionName = "Run GPU program",+ actionDescription = "Run program through the IR interpreter",+ actionProcedure = runWith entry_name runGPU+ }
src/Futhark/Analysis/CallGraph.hs view
@@ -75,7 +75,7 @@ allCalledBy f = maybe mempty fcAllCalled . M.lookup f . cgCalledByFuns -- | Build the program's call graph.-buildCallGraph :: (TraverseOpStms rep) => Prog rep -> CallGraph+buildCallGraph :: (TraverseOpBodies rep) => Prog rep -> CallGraph buildCallGraph prog = CallGraph fg cg where@@ -99,7 +99,7 @@ -- | @buildCallGraph ftable fg fname@ updates @fg@ with the -- contributions of function @fname@.-buildFGfun :: (TraverseOpStms rep) => FunctionTable rep -> FunGraph -> Name -> FunGraph+buildFGfun :: (TraverseOpBodies rep) => FunctionTable rep -> FunGraph -> Name -> FunGraph buildFGfun ftable fg fname = -- Check if function is a non-builtin that we have not already -- processed.@@ -111,20 +111,20 @@ foldl' (buildFGfun ftable) fg' $ fcAllCalled callees _ -> fg -buildFGStms :: (TraverseOpStms rep) => Stms rep -> FunCalls+buildFGStms :: (TraverseOpBodies rep) => Stms rep -> FunCalls buildFGStms = mconcat . map buildFGstm . stmsToList -buildFGBody :: (TraverseOpStms rep) => Body rep -> FunCalls+buildFGBody :: (TraverseOpBodies rep) => Body rep -> FunCalls buildFGBody = buildFGStms . bodyStms -buildFGstm :: (TraverseOpStms rep) => Stm rep -> FunCalls+buildFGstm :: (TraverseOpBodies rep) => Stm rep -> FunCalls buildFGstm (Let (Pat (p : _)) aux (Apply fname _ _ _)) = FunCalls (M.singleton (patElemName p) (stmAuxAttrs aux, fname)) (S.singleton fname)-buildFGstm (Let _ _ (Op op)) = execWriter $ traverseOpStms onStms op+buildFGstm (Let _ _ (Op op)) = execWriter $ traverseOpBodies onBody op where- onStms _ stms = do- tell $ buildFGStms stms- pure stms+ onBody _ body = do+ tell $ buildFGStms $ bodyStms body+ pure body buildFGstm (Let _ _ e) = execWriter $ mapExpM folder e where folder =
src/Futhark/Analysis/PrimExp.hs view
@@ -468,7 +468,7 @@ TPrimExp x `pow` TPrimExp y | Just z <- msum- [ asIntOp Pow x y,+ [ asIntOp SPow x y, asFloatOp FPow x y ] = TPrimExp $ constFoldPrimExp z
src/Futhark/CLI/Dev.hs view
@@ -647,6 +647,26 @@ "Print AST metrics of the resulting internal representation on standard output.", Option []+ ["run-soacs"]+ ( OptArg+ ( \fname -> Right $ \opts ->+ opts {futharkAction = SOACSAction (runSOACSAction (maybe "main" nameFromString fname))}+ )+ "NAME"+ )+ "Run SOACS program with input from stdin",+ Option+ []+ ["run-gpu"]+ ( OptArg+ ( \fname -> Right $ \opts ->+ opts {futharkAction = GPUAction (runGPUAction (maybe "main" nameFromString fname))}+ )+ "NAME"+ )+ "Run GPU program with input from stdin",+ Option+ [] ["defunctorise"] (NoArg $ Right $ \opts -> opts {futharkPipeline = Defunctorise}) "Partially evaluate all module constructs and print the residual program.",
src/Futhark/CLI/Eval.hs view
@@ -11,6 +11,7 @@ evalConfig, evalServerOptions, newInterpreterState,+ prettyValue, runExpr, ) import Futhark.Util.Options@@ -41,7 +42,9 @@ hPutDocLn stderr reason exitWith $ ExitFailure 2 Right s -> pure s- forM_ exprs $ \expr -> putDocLn =<< runExpr interpreter_state (T.pack expr)+ forM_ exprs $ \expr ->+ putDocLn . prettyValue+ =<< runExpr interpreter_state (T.pack expr) options :: [FunOptDescr EvalConfig] options =
src/Futhark/CLI/Literate.hs view
@@ -29,6 +29,7 @@ import Futhark.Error (prettyCompilerError) import Futhark.Eval ( EvalConfig (..),+ Trust (Trusted), evalConfig, forceValue, initialiseInterpreter,@@ -665,7 +666,7 @@ runInterpreter :: Env -> F I.ExtOp a -> LiterateM a runInterpreter env = either (throwError . PP.docText . I.prettyInterpreterError) pure- <=< runInterpreterWith report (Just (envServer env)) Nothing+ <=< runInterpreterWith Trusted report (Just (envServer env)) Nothing where report d = when (scriptVerbose (envOpts env) > 0) $
src/Futhark/CLI/Test.hs view
@@ -47,6 +47,14 @@ -- the monadic level - a test failing should be handled explicitly. type TestM = ExceptT [T.Text] IO +data IRInterpreter = SOACSInterpreter | GPUInterpreter++interpreterOptions :: IRInterpreter -> String -> [String]+interpreterOptions SOACSInterpreter entry =+ ["--run-soacs=" <> entry]+interpreterOptions GPUInterpreter entry =+ ["--gpu", "--run-gpu=" <> entry]+ -- Taken from transformers-0.5.5.0. eitherToErrors :: Either e a -> Errors e a eitherToErrors = either failure Pure@@ -146,6 +154,10 @@ Compiled | -- | Test interpreted code. Interpreted+ | -- | Test code interpreted after internalisation to SOACS.+ InterpretedSOACS+ | -- | Test code interpreted after internalisation to GPU IR+ InterpretedGPU | -- | Perform structure tests. Structure deriving (Eq, Show)@@ -272,6 +284,29 @@ runResult program code output err in accErrors_ $ map runInterpretedCase run_cases +runIRInterpretedEntry :: FutharkExe -> IRInterpreter -> FilePath -> InputOutputs -> TestM ()+runIRInterpretedEntry (FutharkExe futhark) interpreter program (InputOutputs entry run_cases) =+ let dir = takeDirectory program+ runInterpretedCase run@(TestRun _ inputValues _ index _) =+ unless (any (`elem` runTags run) ["compiled", "script"]) $+ context ("Entry point: " <> entry <> "; dataset: " <> runDescription run) $ do+ input <- T.unlines . map valueText <$> getValues (FutharkExe futhark) dir inputValues+ expectedResult' <- getExpectedResult (FutharkExe futhark) program entry run+ (code, output, err) <-+ liftIO $+ readProcessWithExitCode+ futhark+ (["dev"] <> interpreterOptions interpreter (T.unpack entry) <> [program])+ (T.encodeUtf8 input)+ case code of+ ExitFailure 127 ->+ throwError $ progNotFound $ T.pack futhark+ _ ->+ liftExcept $+ compareResult entry index program expectedResult' $+ runResult program code output err+ in accErrors_ $ map runInterpretedCase run_cases+ runTestCase :: TestCase -> TestM () runTestCase (TestCase mode program testcase progs pbtConfig) = do futhark <- liftIO $ maybe getExecutablePath pure $ configFuthark progs@@ -326,7 +361,7 @@ phaseRandom = Nothing } - when (mode `elem` [Compiled, Interpreted]) $+ when (mode `elem` [Compiled, Interpreted, InterpretedSOACS, InterpretedGPU]) $ context "Generating reference outputs" $ -- We probably get the concurrency at the test program level, -- so force just one data set at a time here.@@ -358,24 +393,35 @@ let verifiedProps = selectRequestedPropSpecs properties propSpecs pbt_resultE <- runPBT pbtConfig server verifiedProps phaseRef program - let allResults = flip map pbt_resultE $ \case+ let pbt_results = flip map pbt_resultE $ \case Left err -> Failure [err] Right (Just e) -> Failure [e] Right Nothing -> Success - let hasFailures = any (\case Failure _ -> True; _ -> False) allResults+ let isFailure (Failure _) = True+ isFailure Success = False - when hasFailures $+ when (any isFailure pbt_results) $ liftIO $- propToFile program allResults+ propToFile program pbt_results - pure $ normal_test_result ++ allResults+ pure $ normal_test_result ++ pbt_results when (mode == Interpreted) $ context "Interpreting" $ accErrors_ $ map (runInterpretedEntry (FutharkExe futhark) program) ios + when (mode == InterpretedSOACS) $+ context "Interpreting SOACS" $+ accErrors_ $+ map (runIRInterpretedEntry (FutharkExe futhark) SOACSInterpreter program) ios++ when (mode == InterpretedGPU) $+ context "Interpreting GPU IR" $+ accErrors_ $+ map (runIRInterpretedEntry (FutharkExe futhark) GPUInterpreter program) ios+ liftCommand :: (MonadError T.Text m, MonadIO m) => IO (Maybe CmdFailure) ->@@ -618,7 +664,6 @@ all_tests <- map (makeTestCase config mode) <$> testSpecsFromPathsOrDie paths- -- putStrLn $ "Test cases are: " ++ show (map testCaseProgram all_tests) testmvar <- newEmptyMVar reportmvar <- newEmptyMVar concurrency <- maybe getNumCapabilities pure $ configConcurrency config@@ -813,6 +858,16 @@ ["interpreted"] (NoArg $ Right $ \config -> config {configTestMode = Interpreted}) "Only interpret",+ Option+ []+ ["interpret-soacs"]+ (NoArg $ Right $ \config -> config {configTestMode = InterpretedSOACS})+ "Only interpret SOACS IR",+ Option+ []+ ["interpret-gpu"]+ (NoArg $ Right $ \config -> config {configTestMode = InterpretedGPU})+ "Only interpret GPU IR", Option "c" ["compiled"]
src/Futhark/CodeGen/Backends/CCUDA.hs view
@@ -22,6 +22,7 @@ ( CmpSizeLe, GetSize, GetSizeMax,+ HostOp, ) import Futhark.MonadFreshNames import Language.C.Quote.OpenCL qualified as C@@ -33,7 +34,7 @@ M.Map Name KernelSafety -> [PrimType] -> [FailureMsg] ->- GC.CompilerM OpenCL () ()+ GC.CompilerM HostOp () () mkBoilerplate cuda_program macros kernels types failures = do generateGPUBoilerplate cuda_program@@ -110,7 +111,7 @@ } ] -cudaMemoryType :: GC.MemoryType OpenCL ()+cudaMemoryType :: GC.MemoryType HostOp () cudaMemoryType "device" = pure [C.cty|typename CUdeviceptr|] cudaMemoryType space = error $ "GPU backend does not support '" ++ space ++ "' memory space." @@ -132,7 +133,7 @@ cliOptions prog' where- operations :: GC.Operations OpenCL ()+ operations :: GC.Operations HostOp () operations = gpuOperations { GC.opsMemoryType = cudaMemoryType,
src/Futhark/CodeGen/Backends/COpenCL.hs view
@@ -24,6 +24,7 @@ ( CmpSizeLe, GetSize, GetSizeMax,+ HostOp, ) import Futhark.MonadFreshNames import Language.C.Quote.OpenCL qualified as C@@ -81,7 +82,7 @@ M.Map Name KernelSafety -> [PrimType] -> [FailureMsg] ->- GC.CompilerM OpenCL () ()+ GC.CompilerM HostOp () () mkBoilerplate opencl_program macros kernels types failures = do generateGPUBoilerplate opencl_program@@ -176,7 +177,7 @@ } ] -openclMemoryType :: GC.MemoryType OpenCL ()+openclMemoryType :: GC.MemoryType HostOp () openclMemoryType "device" = pure [C.cty|typename cl_mem|] openclMemoryType space = error $ "GPU backend does not support '" ++ space ++ "' memory space." @@ -198,7 +199,7 @@ cliOptions prog' where- operations :: GC.Operations OpenCL ()+ operations :: GC.Operations HostOp () operations = gpuOperations { GC.opsMemoryType = openclMemoryType
src/Futhark/CodeGen/Backends/GPU.hs view
@@ -20,7 +20,7 @@ import Futhark.CodeGen.Backends.GenericC.Options import Futhark.CodeGen.Backends.GenericC.Pretty (expText, idText) import Futhark.CodeGen.Backends.SimpleRep (primStorageType, toStorage)-import Futhark.CodeGen.ImpCode.OpenCL+import Futhark.CodeGen.ImpCode.Kernels import Futhark.CodeGen.RTS.C (gpuH, gpuPrototypesH) import Futhark.MonadFreshNames import Futhark.Util (chunk)@@ -141,7 +141,7 @@ v' ) -callKernel :: GC.OpCompiler OpenCL ()+callKernel :: GC.OpCompiler HostOp () callKernel (GetSize v key) = GC.stm [C.cstm|$id:v = $exp:(getParamByKey key).val;|] callKernel (CmpSizeLe v key x) = do@@ -251,10 +251,10 @@ allocateGPU :: GC.Allocate op () allocateGPU mem size tag "device" =- GC.stm- [C.cstm|(void)gpu_alloc(ctx, ctx->log,- (size_t)$exp:size, $exp:tag,- &$exp:mem, (size_t*)&$exp:size);|]+ pure+ [C.cexp|gpu_alloc(ctx, ctx->log,+ (size_t)$exp:size, $exp:tag,+ &$exp:mem, (size_t*)&$exp:size)|] allocateGPU _ _ _ space = error $ "Cannot allocate in '" ++ space ++ "' memory space." @@ -302,7 +302,7 @@ syncArg GC.CopyBarrier = [C.cexp|true|] syncArg GC.CopyNoBarrier = [C.cexp|false|] -copyGPU :: GC.Copy OpenCL ()+copyGPU :: GC.Copy HostOp () copyGPU _ dstmem dstidx (Space "device") srcmem srcidx (Space "device") nbytes = do p <- GC.provenanceExp GC.stm@@ -318,7 +318,7 @@ copyGPU _ _ _ destspace _ _ srcspace _ = error $ "Cannot copy to " ++ show destspace ++ " from " ++ show srcspace -gpuOperations :: GC.Operations OpenCL ()+gpuOperations :: GC.Operations HostOp () gpuOperations = GC.defaultOperations { GC.opsCompiler = callKernel,@@ -427,7 +427,7 @@ onPart ErrorVal {} = "%lld" onFailure i (FailureMsg emsg@(ErrorMsg parts) backtrace) = let msg = concatMap onPart parts ++ "\n" ++ printfEscape backtrace- msgargs = [[C.cexp|args[$int:j]|] | j <- [0 .. errorMsgNumArgs emsg - 1]]+ msgargs = [[C.cexp|(long long int)args[$int:j]|] | j <- [0 .. errorMsgNumArgs emsg - 1]] in [C.cstm|case $int:i: {return msgprintf($string:msg, $args:msgargs); break;}|] failure_cases = zipWith onFailure [(0 :: Int) ..] failures@@ -449,7 +449,7 @@ [Name] -> [PrimType] -> [FailureMsg] ->- GC.CompilerM OpenCL () ()+ GC.CompilerM HostOp () () generateGPUBoilerplate gpu_program macros backendH kernels types failures = do createKernels kernels let gpu_program_fragments =
src/Futhark/CodeGen/Backends/GenericC.hs view
@@ -175,12 +175,15 @@ desc, block->desc, $string:spacedesc, *(block->references)); } if (*(block->references) == 0) {+ lock_lock(&ctx->mem_lock); ctx->$id:usagename -= block->size;+ long long new_usage = ctx->$id:usagename;+ lock_unlock(&ctx->mem_lock); $items:free free(block->references); if (ctx->detail_memory) { fprintf(ctx->log, "%lld bytes freed (now allocated: %lld bytes)\n",- (long long) block->size, (long long) ctx->$id:usagename);+ (long long) block->size, new_usage); } } block->references = NULL;@@ -189,14 +192,14 @@ }|] -- When allocating a memory block we initialise the reference count to 1.- alloc <-- collect $+ (alloc, alloc_items) <-+ collect' $ allocRawMem [C.cexp|block->mem|] [C.cexp|size|] space [C.cexp|desc|] let allocdef = [C.cedecl|int $id:(fatMemAlloc space) ($ty:ctx_ty *ctx, $ty:mty *block, typename int64_t size, const char *desc) { if (size < 0) { futhark_panic(1, "Negative allocation of %lld bytes attempted for %s in %s.\n",- (long long)size, desc, $string:spacedesc, ctx->$id:usagename);+ (long long int)size, desc, $string:spacedesc); } int ret = $id:(fatMemUnRef space)(ctx, block, desc); @@ -211,27 +214,25 @@ (long long) ctx->$id:usagename); } - $items:alloc+ $items:alloc_items - if (ctx->error == NULL) {+ if ($exp:alloc == FUTHARK_SUCCESS) { block->references = (int*) malloc(sizeof(int)); *(block->references) = 1; block->size = size; block->desc = desc;- long long new_usage = ctx->$id:usagename + size;- if (ctx->detail_memory) {- fprintf(ctx->log, "Received block of %lld bytes; now allocated: %lld bytes",- (long long)block->size, new_usage);- }- ctx->$id:usagename = new_usage;- if (new_usage > ctx->$id:peakname) {+ lock_lock(&ctx->mem_lock);+ ctx->$id:usagename += size;+ long long new_usage = ctx->$id:usagename;+ int new_peak = new_usage > ctx->$id:peakname;+ if (new_peak) { ctx->$id:peakname = new_usage;- if (ctx->detail_memory) {- fprintf(ctx->log, " (new peak).\n");- }- } else if (ctx->detail_memory) {- fprintf(ctx->log, ".\n"); }+ lock_unlock(&ctx->mem_lock);+ if (ctx->detail_memory) {+ fprintf(ctx->log, "Received block of %lld bytes; now allocated: %lld bytes%s",+ (long long)block->size, new_usage, new_peak ? " (new peak).\n" : ".\n");+ } return FUTHARK_SUCCESS; } else { // We are naively assuming that any memory allocation error is due to OOM.@@ -245,7 +246,7 @@ $string:spacedesc, (long long) size, (long long) ctx->$id:usagename,- old_error);+ old_error != NULL ? old_error : ""); free(old_error); lock_unlock(&ctx->error_lock); return FUTHARK_OUT_OF_MEMORY;@@ -674,8 +675,9 @@ libDecl [C.cedecl|static int free_constants($ty:ctx_ty *ctx) { (void)ctx;+ int err = 0; $items:free_consts- return 0;+ return err; }|] mapM getConst ps@@ -697,7 +699,8 @@ resetMemConst (MemParam name space) = resetMem name space freeConst ScalarParam {} = pure ()- freeConst (MemParam name space) = unRefMem [C.cexp|ctx->constants->$id:name|] space+ freeConst (MemParam name space) =+ unRefMem [C.cexp|ctx->constants->$id:name|] space [C.cstm|err = 1;|] getConst (ScalarParam name bt) = do let ctp = primTypeToCType bt
src/Futhark/CodeGen/Backends/GenericC/CLI.hs view
@@ -139,8 +139,7 @@ optionDescription = "Read size=value assignments from the given file.", optionAction = [C.cstm|{- char *ret = load_tuning_file(optarg, cfg, (int(*)(void*, const char*, size_t))- futhark_context_config_set_tuning_param);+ char *ret = load_tuning_file(optarg, cfg); if (ret != NULL) { futhark_panic(1, "When loading tuning file '%s': %s\n", optarg, ret); }}|]
src/Futhark/CodeGen/Backends/GenericC/Code.hs view
@@ -65,8 +65,11 @@ compilePrimExp f (UnOpExp (Neg Bool) x) = do x' <- compilePrimExp f x pure [C.cexp|!$exp:x'|]-compilePrimExp f (UnOpExp Neg {} x) = do+compilePrimExp f (UnOpExp (Neg (IntType t)) x) = do x' <- compilePrimExp f x+ pure [C.cexp|($ty:(intTypeToCType t))$id:(prettyString (Sub t OverflowWrap))(0, $exp:x')|]+compilePrimExp f (UnOpExp (Neg (FloatType _)) x) = do+ x' <- compilePrimExp f x pure [C.cexp|-$exp:x'|] compilePrimExp f (UnOpExp op x) = do x' <- compilePrimExp f x@@ -303,7 +306,7 @@ allocMem name size space [C.cstm|{err = 1; goto cleanup;}|] compileCode (Free name space) = do cached <- isJust <$> cacheMem name- unless cached $ unRefMem name space+ unless cached $ unRefMem name space [C.cstm|{err = 1; goto cleanup;}|] compileCode (For i bound body) = do let i' = C.toIdent i t = primTypeToCType $ primExpType bound@@ -400,7 +403,7 @@ src' <- compileExp src stm [C.cstm|$id:dest = $exp:src';|] compileCode (SetMem dest src space) =- setMem dest src space+ setMem dest src space [C.cstm|{err = 1; goto cleanup;}|] compileCode (Call [dest] fname args) | isBuiltInFunction fname = do args' <- mapM compileArg args
src/Futhark/CodeGen/Backends/GenericC/Fun.hs view
@@ -32,7 +32,7 @@ setRetVal' p (MemParam name space) = -- It is required that the memory block is already initialised -- (although it may be NULL).- setMem [C.cexp|*$exp:p|] name space+ setMem [C.cexp|*$exp:p|] name space [C.cstm|{err = 1; goto cleanup;}|] setRetVal' p (ScalarParam name _) = stm [C.cstm|*$exp:p = $id:name;|]
src/Futhark/CodeGen/Backends/GenericC/Monad.hs view
@@ -170,13 +170,14 @@ -- | Allocate a memory block of the given size and with the given tag -- in the given memory space, saving a reference in the given variable--- name.+-- name. Produces an @int@ expression that is @FUTHARK_SUCCESS@ if+-- the allocation succeeded. type Allocate op s = C.Exp -> C.Exp -> C.Exp -> SpaceId ->- CompilerM op s ()+ CompilerM op s C.Exp -- | De-allocate the given memory block, with the given tag, with the -- given size,, which is in the given memory space.@@ -245,8 +246,13 @@ opsGetParam :: Name -> (C.Exp, C.Exp) } +-- | Unreference all declared memory. The result is placed after the+-- @cleanup@ label, so a failure is recorded in @err@ rather than+-- jumping to @cleanup@ again. freeAllocatedMem :: CompilerM op s [C.BlockItem]-freeAllocatedMem = collect $ mapM_ (uncurry unRefMem) =<< gets compDeclaredMem+freeAllocatedMem = collect $ mapM_ free =<< gets compDeclaredMem+ where+ free (name, space) = unRefMem name space [C.cstm|err = 1;|] declAllocatedMem :: CompilerM op s [C.BlockItem] declAllocatedMem = collect $ mapM_ f =<< gets compDeclaredMem@@ -533,7 +539,7 @@ b -> Space -> c ->- CompilerM op s ()+ CompilerM op s C.Exp allocRawMem dest size space desc = case space of Space sid -> join $@@ -543,8 +549,8 @@ <*> pure [C.cexp|$exp:desc|] <*> pure sid _ ->- stm- [C.cstm|host_alloc(ctx, (size_t)$exp:size, $exp:desc, (size_t*)&$exp:size, (void*)&$exp:dest);|]+ pure+ [C.cexp|host_alloc(ctx, (size_t)$exp:size, $exp:desc, (size_t*)&$exp:size, (void*)&$exp:dest)|] freeRawMem :: (C.ToExp a, C.ToExp b, C.ToExp c) =>@@ -583,8 +589,8 @@ when refcount $ stm [C.cstm|$exp:mem.references = NULL;|] -setMem :: (C.ToExp a, C.ToExp b) => a -> b -> Space -> CompilerM op s ()-setMem dest src space = do+setMem :: (C.ToExp a, C.ToExp b) => a -> b -> Space -> C.Stm -> CompilerM op s ()+setMem dest src space on_failure = do refcount <- fatMemory space let src_s = T.unpack $ expText $ C.toExp src noLoc if refcount@@ -592,7 +598,7 @@ stm [C.cstm|if ($id:(fatMemSet space)(ctx, &$exp:dest, &$exp:src, $string:src_s) != 0) {- return 1;+ $stm:on_failure }|] else case space of ScalarSpace ds _ -> do@@ -607,15 +613,15 @@ }|] _ -> stm [C.cstm|$exp:dest = $exp:src;|] -unRefMem :: (C.ToExp a) => a -> Space -> CompilerM op s ()-unRefMem mem space = do+unRefMem :: (C.ToExp a) => a -> Space -> C.Stm -> CompilerM op s ()+unRefMem mem space on_failure = do refcount <- fatMemory space cached <- isJust <$> cacheMem mem let mem_s = T.unpack $ expText $ C.toExp mem noLoc when (refcount && not cached) $ stm [C.cstm|if ($id:(fatMemUnRef space)(ctx, &$exp:mem, $string:mem_s) != 0) {- return 1;+ $stm:on_failure }|] allocMem ::@@ -637,7 +643,8 @@ }|] else do freeRawMem mem size space mem_s- allocRawMem mem size space [C.cexp|desc|]+ alloc <- allocRawMem mem size space [C.cexp|desc|]+ stm [C.cstm|if ($exp:alloc != FUTHARK_SUCCESS) { $stm:on_failure }|] copyMemoryDefaultSpace :: C.Exp ->
src/Futhark/CodeGen/Backends/GenericC/Pretty.hs view
@@ -9,6 +9,7 @@ idText, funcText, funcsText,+ stmText, ) where @@ -44,3 +45,7 @@ -- | Prettyprint a list of functions. funcsText :: [C.Func] -> T.Text funcsText = T.unlines . map funcText++-- | Prettyprint a single statement.+stmText :: C.Stm -> T.Text+stmText = T.pack . render . MPP.ppr
src/Futhark/CodeGen/Backends/GenericC/Server.hs view
@@ -98,8 +98,7 @@ optionDescription = "Read size=value assignments from the given file.", optionAction = [C.cstm|{- char *ret = load_tuning_file(optarg, cfg, (int(*)(void*, const char*, size_t))- futhark_context_config_set_tuning_param);+ char *ret = load_tuning_file(optarg, cfg); if (ret != NULL) { futhark_panic(1, "When loading tuning file '%s': %s\n", optarg, ret); }}|]@@ -151,6 +150,9 @@ array_new_wrap = arrayNew ops <> "_wrap" array_set_wrap = arraySet ops <> "_wrap" array_index_wrap = arrayIndex ops <> "_wrap"+ array_shape_wrap = arrayShape ops <> "_wrap"+ array_values_wrap = arrayValues ops <> "_wrap"+ array_free_wrap = arrayFree ops <> "_wrap" shape_args = [[C.cexp|shape[$int:i]|] | i <- [0 .. rank - 1]] is_args = [[C.cexp|is[$int:i]|] | i <- [0 .. rank - 1]] in ( [C.cedecl|const struct type $id:type_name;|],@@ -165,17 +167,30 @@ return 0; } int $id:array_set_wrap(struct futhark_context *ctx,- typename $id:c_type_name arr,- $ty:element_c_type *val,+ const void *arr,+ void *val, const typename int64_t *is) {- return $id:(arraySet ops)(ctx, arr, *val, $args:is_args);+ return $id:(arraySet ops)(ctx, (typename $id:c_type_name)arr,+ *($ty:element_c_type*)val, $args:is_args); }+ const typename int64_t* $id:array_shape_wrap(struct futhark_context *ctx,+ const void *arr) {+ return $id:(arrayShape ops)(ctx, (typename $id:c_type_name)arr);+ } int $id:array_index_wrap(struct futhark_context *ctx, void *dest,- typename $id:c_type_name arr,+ const void *arr, const typename int64_t *is) {- return $id:(arrayIndex ops)(ctx, dest, arr, $args:is_args);+ return $id:(arrayIndex ops)(ctx, dest, (typename $id:c_type_name)arr, $args:is_args); }+ int $id:array_values_wrap(struct futhark_context *ctx,+ const void *arr,+ void *data) {+ return $id:(arrayValues ops)(ctx, (typename $id:c_type_name)arr, data);+ }+ int $id:array_free_wrap(struct futhark_context *ctx, void *arr) {+ return $id:(arrayFree ops)(ctx, arr);+ } const struct array $id:array_name = { .rank = $int:rank, .element_type = &$id:element_type_name,@@ -183,19 +198,19 @@ .name = $string:(T.unpack tname), .num_fields = 0, .fields = NULL,- .new = (typename array_new_fn)$id:array_new_wrap,- .set = (typename array_set_fn)$id:array_set_wrap,- .shape = (typename array_shape_fn)$id:(arrayShape ops),- .index = (typename array_index_fn)$id:array_index_wrap,- .values = (typename array_values_fn)$id:(arrayValues ops),- .free = (typename array_free_data_fn)$id:(arrayFree ops),+ .new = $id:array_new_wrap,+ .set = $id:array_set_wrap,+ .shape = $id:array_shape_wrap,+ .index = $id:array_index_wrap,+ .values = $id:array_values_wrap,+ .free = $id:array_free_wrap, .zip = NULL, }; const struct type $id:type_name = { .name = $string:(T.unpack tname),- .restore = (typename restore_fn)restore_array,- .store = (typename store_fn)store_array,- .free = (typename free_fn)free_array,+ .restore = restore_array,+ .store = store_array,+ .free = free_array, .aux = &$id:array_name, .kind = $exp:(cKind Array), .info = &$id:array_name@@ -204,21 +219,34 @@ typeBoilerplate manifest (tname, TypeOpaque c_type_name ops extra_ops _) = let type_name = typeStructName tname aux_name = type_name <> "_aux"+ store_wrap = opaqueStore ops <> "_wrap"+ restore_wrap = opaqueRestore ops <> "_wrap"+ free_wrap = opaqueFree ops <> "_wrap" (transparent_edecls, transparent_init, kind) = transparentDefs type_name extra_ops in ( [C.cedecl|const struct type $id:type_name;|], [C.cinit|&$id:type_name|], transparent_edecls ++ [C.cunit|+ int $id:store_wrap(struct futhark_context *ctx, const void *obj,+ void **p, size_t *n) {+ return $id:(opaqueStore ops)(ctx, obj, p, n);+ }+ void* $id:restore_wrap(struct futhark_context *ctx, void *p) {+ return $id:(opaqueRestore ops)(ctx, p);+ }+ int $id:free_wrap(struct futhark_context *ctx, void *obj) {+ return $id:(opaqueFree ops)(ctx, obj);+ } const struct opaque_aux $id:aux_name = {- .store = (typename opaque_store_fn)$id:(opaqueStore ops),- .restore = (typename opaque_restore_fn)$id:(opaqueRestore ops),- .free = (typename opaque_free_fn)$id:(opaqueFree ops)+ .store = $id:store_wrap,+ .restore = $id:restore_wrap,+ .free = $id:free_wrap }; const struct type $id:type_name = { .name = $string:(T.unpack tname),- .restore = (typename restore_fn)restore_opaque,- .store = (typename store_fn)store_opaque,- .free = (typename free_fn)free_opaque,+ .restore = restore_opaque,+ .store = store_opaque,+ .free = free_opaque, .aux = &$id:aux_name, .kind = $exp:(cKind kind), .info = $init:transparent_init@@ -234,14 +262,15 @@ field_v = "v" <> show (i :: Int) in ( [C.cinit|{.name = $string:(T.unpack name), .type = &$id:(typeStructName field_tname),- .project = (typename project_fn)$id:project+ .project = $id:(projectWrapName project) }|], [C.citem|const $ty:field_c_type $id:field_v = *(const $ty:field_c_type*)fields[$int:i];|], [C.cexp|$id:field_v|] ) (field_inits, get_fields, field_args) = unzip3 $ zipWith onField [0 ..] fields- in ( [C.cunit|+ in ( concatMap (projectWrap . recordFieldProject) fields+ ++ [C.cunit| const struct field $id:fields_name[] = { $inits:field_inits };@@ -298,16 +327,20 @@ }|] ) + variant_wrap = variant <> "_wrap" (variant_inits, variant_wraps) = unzip $ map onVariant variants in ( foldl1 (++) variant_wraps ++ [C.cunit|+ int $id:variant_wrap(struct futhark_context *ctx, const void *v) {+ return $id:variant(ctx, v);+ } const struct variant $id:variants_name[] = { $inits:variant_inits }; const struct sum $id:sum_name = { .num_variants = $int:(length variants), .variants = $id:variants_name,- .variant = (int (*)(struct futhark_context *, const void *))$id:variant+ .variant = $id:variant_wrap };|], [C.cinit|&$id:sum_name|], Sum@@ -351,6 +384,7 @@ new_wrap = new <> "_wrap" set_wrap = set <> "_wrap" index_wrap = index <> "_wrap"+ shape_wrap = shape <> "_wrap" shape_args = [[C.cexp|shape[$int:i]|] | i <- [0 .. rank - 1]] is_args = [[C.cexp|is[$int:i]|] | i <- [0 .. rank - 1]] (zip_defs, fields_init, num_fields, zip_init) =@@ -369,14 +403,15 @@ field_v = "f" <> prettyText i in ( [C.cinit|{ .name = $string:(T.unpack (recordFieldName field)), .type = &$id:(typeStructName (recordFieldType field)),- .project = (typename project_fn)$id:(recordFieldProject field)+ .project = $id:(projectWrapName (recordFieldProject field)) }|], [C.citem|const $ty:field_type $id:field_v = (const $ty:field_type)f[$int:i];|], [C.cexp|$id:field_v|] ) (field_inits, get_fields, zip_args) = unzip3 $ zipWith onField [0 :: Int ..] fields- in ( [C.cunit|const struct field $id:fields_name[] = {+ in ( concatMap (projectWrap . recordFieldProject) fields+ ++ [C.cunit|const struct field $id:fields_name[] = { $inits:field_inits };|] ++ [C.cunit|int $id:zip_wrap(struct futhark_context *ctx,@@ -388,14 +423,16 @@ }|], [C.cexp|$id:fields_name|], length fields,- [C.cexp|(typename array_zip_fn)$id:zip_wrap|]+ [C.cexp|$id:zip_wrap|] ) in ( zip_defs ++ [C.cunit| int $id:new_wrap(struct futhark_context *ctx,- typename $id:c_type_name *outp,- $ty:element_c_type *ps[],- const typename int64_t shape[]) {+ void **outp,+ const void *p,+ const typename int64_t *shape) {+ typename $id:c_type_name *out = (typename $id:c_type_name*) outp;+ $ty:element_c_type **ps = ($ty:element_c_type **) p; typename int64_t n_values = 1; for (int i = 0; i < $int:rank; ++i) { n_values *= shape[i];@@ -404,19 +441,24 @@ for (typename int64_t i = 0; i < n_values; ++i) { values[i] = *ps[i]; }- return $id:new(ctx, outp, values, $args:shape_args);+ return $id:new(ctx, out, values, $args:shape_args); } int $id:set_wrap(struct futhark_context *ctx,- typename $id:c_type_name arr,- $ty:element_c_type *val,+ const void *arr,+ void *val, const typename int64_t *is) {- return $id:set(ctx, arr, *val, $args:is_args);+ return $id:set(ctx, (typename $id:c_type_name)arr,+ *($ty:element_c_type*)val, $args:is_args); }+ const typename int64_t* $id:shape_wrap(struct futhark_context *ctx,+ const void *arr) {+ return $id:shape(ctx, (typename $id:c_type_name)arr);+ } int $id:index_wrap(struct futhark_context *ctx, void *dest,- typename $id:c_type_name arr,+ const void *arr, const typename int64_t *is) {- return $id:index(ctx, dest, arr, $args:is_args);+ return $id:index(ctx, dest, (typename $id:c_type_name)arr, $args:is_args); } const struct array $id:array_name = { .rank = $int:rank,@@ -425,10 +467,10 @@ .name = $string:(T.unpack tname), .num_fields = $int:num_fields, .fields = $exp:fields_init,- .new = (typename array_new_fn)$id:new_wrap,- .set = (typename array_set_fn)$id:set_wrap,- .shape = (typename array_shape_fn)$id:shape,- .index = (typename array_index_fn)$id:index_wrap,+ .new = $id:new_wrap,+ .set = $id:set_wrap,+ .shape = $id:shape_wrap,+ .index = $id:index_wrap, .values = NULL, .free = NULL, .zip = $exp:zip_init,@@ -436,6 +478,15 @@ [C.cinit|&$id:array_name|], Array )++projectWrapName :: CFuncName -> CFuncName+projectWrapName project = project <> "_wrap"++projectWrap :: CFuncName -> [C.Definition]+projectWrap project =+ [C.cunit|int $id:(projectWrapName project)(struct futhark_context *ctx, void *out, const void *obj) {+ return $id:project(ctx, out, obj);+ }|] entryTypeBoilerplate :: Manifest -> ([C.Definition], [C.Initializer], [C.Definition]) entryTypeBoilerplate manifest =
src/Futhark/CodeGen/Backends/GenericC/Types.hs view
@@ -94,15 +94,18 @@ new_body <- collect $ do prepareNewMem [C.cexp|arr|] space shape pt- copy- CopyNoBarrier- [C.cexp|arr->mem.mem|]- [C.cexp|0|]- space- [C.cexp|(const unsigned char*)data|]- [C.cexp|0|]- DefaultSpace- [C.cexp|((size_t)$exp:arr_size) * $int:(primByteSize pt::Int)|]+ copy_items <-+ collect $+ copy+ CopyNoBarrier+ [C.cexp|arr->mem.mem|]+ [C.cexp|0|]+ space+ [C.cexp|(const unsigned char*)data|]+ [C.cexp|0|]+ DefaultSpace+ [C.cexp|((size_t)$exp:arr_size) * $int:(primByteSize pt::Int)|]+ stm [C.cstm|if (err == 0) { $items:copy_items }|] new_raw_body <- collect $ do resetMem [C.cexp|arr->mem|] space@@ -111,7 +114,7 @@ let dim_s = "dim" ++ show i in stm [C.cstm|arr->shape[$int:i] = $id:dim_s;|] - free_body <- collect $ unRefMem [C.cexp|arr->mem|] space+ free_body <- collect $ unRefMem [C.cexp|arr->mem|] space [C.cstm|ret = 1;|] values_body <- collect $@@ -221,9 +224,10 @@ } int $id:free_array($ty:ctx_ty *ctx, $ty:array_type *arr) {+ int ret = 0; $items:(criticalSection ops free_body) free(arr);- return 0;+ return ret; } int $id:values_array($ty:ctx_ty *ctx, $ty:array_type *arr, $ty:pt' *data) {@@ -601,15 +605,18 @@ stm [C.cstm|v->$id:(tupleField j) = malloc(sizeof(*v->$id:(tupleField j)));|] prepareNewMem [C.cexp|v->$id:(tupleField j)|] space shape pt -- Now we can copy into the freshly allocated memory.- copy- CopyNoBarrier- [C.cexp|v->$id:(tupleField j)->mem.mem|]- [C.cexp|0|]- space- [C.cexp|arr->$id:(tupleField j)->mem.mem|]- (indexExp pt r [C.cexp|arr->$id:(tupleField j)->shape|])- space- $ cproduct ([C.cexp|$int:(primByteSize pt::Int)|] : shape)+ copy_items <-+ collect+ $ copy+ CopyNoBarrier+ [C.cexp|v->$id:(tupleField j)->mem.mem|]+ [C.cexp|0|]+ space+ [C.cexp|arr->$id:(tupleField j)->mem.mem|]+ (indexExp pt r [C.cexp|arr->$id:(tupleField j)->shape|])+ space+ $ cproduct ([C.cexp|$int:(primByteSize pt::Int)|] : shape)+ stm [C.cstm|if (err == 0) { $items:copy_items }|] recordArraySetFunction :: Space ->
src/Futhark/CodeGen/Backends/GenericPython.hs view
@@ -1214,7 +1214,6 @@ Xor {} -> simple "^" And {} -> simple "&" Or {} -> simple "|"- Shl {} -> simple "<<" LogAnd {} -> simple "and" LogOr {} -> simple "or" _ -> pure $ simpleCall (prettyString op) [x', y']
src/Futhark/CodeGen/Backends/GenericWASM.hs view
@@ -10,6 +10,7 @@ JSRecordField (..), JSOpaqueType (..), emccExportNames,+ manifestFunctions, javascriptWrapper, extToString, opaqueToJS,@@ -138,6 +139,7 @@ "_futhark_context_unpause_profiling" ] +-- | Every C function named in the manifest. manifestFunctions :: Manifest -> [CFuncName] manifestFunctions manifest = map entryPointCFun (M.elems $ manifestEntryPoints manifest)
src/Futhark/CodeGen/Backends/HIP.hs view
@@ -22,6 +22,7 @@ ( CmpSizeLe, GetSize, GetSizeMax,+ HostOp, ) import Futhark.MonadFreshNames import Language.C.Quote.OpenCL qualified as C@@ -33,7 +34,7 @@ M.Map Name KernelSafety -> [PrimType] -> [FailureMsg] ->- GC.CompilerM OpenCL () ()+ GC.CompilerM HostOp () () mkBoilerplate hip_program macros kernels types failures = do generateGPUBoilerplate hip_program@@ -84,7 +85,7 @@ } ] -hipMemoryType :: GC.MemoryType OpenCL ()+hipMemoryType :: GC.MemoryType HostOp () hipMemoryType "device" = pure [C.cty|typename hipDeviceptr_t|] hipMemoryType space = error $ "GPU backend does not support '" ++ space ++ "' memory space." @@ -106,7 +107,7 @@ cliOptions prog' where- operations :: GC.Operations OpenCL ()+ operations :: GC.Operations HostOp () operations = gpuOperations { GC.opsMemoryType = hipMemoryType
src/Futhark/CodeGen/Backends/MulticoreC.hs view
@@ -236,7 +236,7 @@ $exp:provenance, NULL, $id:event,- (typename event_report_fn)mc_event_report);+ mc_event_report); lock_unlock(&ctx->event_list_lock); }|]
src/Futhark/CodeGen/Backends/MulticoreISPC.hs view
@@ -365,20 +365,21 @@ -- | Handle logging an error message in ISPC. handleError :: ErrorMsg Exp -> String -> ISPCCompilerM () handleError msg stacktrace = do- -- Get format sting- (formatstr, formatargs) <- GC.errorMsgString msg- let formatstr' = "Error: " <> formatstr <> "\n\nBacktrace:\n%s" -- Get args types and names for shim let arg_types = errorMsgArgTypes msg arg_names <- mapM (newVName . const "arg") arg_types let params = zipWith (\ty name -> [C.cparam|$ty:(GC.primTypeToCType ty) $id:name|]) arg_types arg_names let params_uni = zipWith (\ty name -> [C.cparam|$tyqual:uniform $ty:(GC.primTypeToCType ty) $id:name|]) arg_types arg_names+ -- Get format string. The shim formats its own parameters, so the+ -- error values are replaced by references to them.+ (formatstr, formatargs) <-+ GC.errorMsgString $ shimMsg msg $ zip arg_names arg_types+ let formatstr' = "Error: " <> formatstr <> "\n\nBacktrace:\n%s" -- Make shim- let formatargs' = mapArgNames msg formatargs arg_names shim <- MC.multicoreDef "assert_shim" $ \s -> do pure [C.cedecl|void $id:s(struct futhark_context* ctx, $params:params) {- set_error(ctx, msgprintf($string:formatstr', $args:formatargs', $string:stacktrace));+ set_error(ctx, msgprintf($string:formatstr', $args:formatargs, $string:stacktrace)); }|] ispcDecl [C.cedecl|extern "C" $tyqual:unmasked void $id:shim($tyqual:uniform struct futhark_context* $tyqual:uniform, $params:params_uni);|]@@ -400,13 +401,11 @@ getErrorValExps (ErrorMsg m) = mapM compileExp $ mapMaybe getErrorVal m - mapArgNames' (x : xs) (y : ys) (t : ts)- | isJust $ getErrorVal x = [C.cexp|$id:t|] : mapArgNames' xs ys ts- | otherwise = y : mapArgNames' xs ys (t : ts)- mapArgNames' _ ys [] = ys- mapArgNames' _ _ _ = []+ shimMsg (ErrorMsg parts) = ErrorMsg . shimParts parts - mapArgNames (ErrorMsg parts) = mapArgNames' parts+ shimParts (ErrorVal _ _ : ps) ((v, t) : vs) = ErrorVal t (LeafExp v t) : shimParts ps vs+ shimParts (p : ps) vs = p : shimParts ps vs+ shimParts [] _ = [] -- | Is this a space whose memory blocks we can address directly from ISPC -- code, and for which 'readHostMem'/'writeHostMem' know the layout?@@ -470,6 +469,9 @@ compileExp (UnOpExp (Neg Bool) x) = do x' <- compileExp x pure [C.cexp|!$exp:x'|]+compileExp (UnOpExp (Neg (IntType t)) x) = do+ x' <- compileExp x+ pure [C.cexp|($ty:(intTypeToCType t))$id:(prettyString (Sub t OverflowWrap))(0, $exp:x')|] compileExp (UnOpExp Neg {} x) = do x' <- compileExp x pure [C.cexp|-$exp:x'|]
src/Futhark/CodeGen/Backends/PyOpenCL.hs view
@@ -184,7 +184,7 @@ options prog' where- operations :: Operations Imp.OpenCL ()+ operations :: Operations Imp.HostOp () operations = Operations { opsCompiler = callKernel,@@ -222,7 +222,7 @@ compileBlockDim (Left e) = asLong <$> compileExp e compileBlockDim (Right e) = pure $ compileConstExp e -callKernel :: OpCompiler Imp.OpenCL ()+callKernel :: OpCompiler Imp.HostOp () callKernel (Imp.GetSize v key) = do v' <- compileVar v stm $ Assign v' $ Index (getParamByKey key) (IdxExp (String "value"))@@ -285,7 +285,7 @@ processKernelArg (Imp.ValueKArg e bt) = toStorage bt <$> compileExp e processKernelArg (Imp.MemKArg v) = compileVar v -writeOpenCLScalar :: WriteScalar Imp.OpenCL ()+writeOpenCLScalar :: WriteScalar Imp.HostOp () writeOpenCLScalar mem i bt "device" val = do let nparr = Call@@ -304,7 +304,7 @@ writeOpenCLScalar _ _ _ space _ = error $ "Cannot write to '" ++ space ++ "' memory space." -readOpenCLScalar :: ReadScalar Imp.OpenCL ()+readOpenCLScalar :: ReadScalar Imp.HostOp () readOpenCLScalar mem i bt "device" = do val <- newVName "read_res" let val' = Var $ prettyString val@@ -329,7 +329,7 @@ readOpenCLScalar _ _ _ space = error $ "Cannot read from '" ++ space ++ "' memory space." -allocateOpenCLBuffer :: Allocate Imp.OpenCL ()+allocateOpenCLBuffer :: Allocate Imp.HostOp () allocateOpenCLBuffer mem size "device" = stm $ Assign mem $@@ -337,7 +337,7 @@ allocateOpenCLBuffer _ _ space = error $ "Cannot allocate in '" ++ space ++ "' space" -packArrayOutput :: EntryOutput Imp.OpenCL ()+packArrayOutput :: EntryOutput Imp.HostOp () packArrayOutput mem "device" bt ept dims = do mem' <- compileVar mem dims' <- mapM compileDim dims@@ -352,7 +352,7 @@ packArrayOutput _ sid _ _ _ = error $ "Cannot return array from " ++ sid ++ " space." -unpackArrayInput :: EntryInput Imp.OpenCL ()+unpackArrayInput :: EntryInput Imp.HostOp () unpackArrayInput mem "device" t s dims e = do let type_is_ok = BinOp
src/Futhark/CodeGen/ImpCode/GPU.hs view
@@ -177,6 +177,9 @@ | Atomic Space AtomicOp | Barrier Fence | MemFence Fence+ | -- | Basically a warp-level barrier. Must be executed by all threads of+ -- warp. Only supported for CUDA and HIP.+ WarpSync | SharedAlloc VName (Count Bytes (TExp Int64)) | -- | Perform a barrier and also check whether any -- threads have failed an assertion. Make sure all@@ -250,6 +253,8 @@ "mem_fence_local()" pretty (MemFence FenceGlobal) = "mem_fence_global()"+ pretty WarpSync =+ "warp_sync()" pretty (SharedAlloc name size) = pretty name <+> equals <+> "shared_alloc" <> parens (pretty size) pretty (ErrorSync FenceLocal) =
+ src/Futhark/CodeGen/ImpCode/Kernels.hs view
@@ -0,0 +1,79 @@+-- | Common definitions for imperative code augmented with the ability to launch+-- kernels.+module Futhark.CodeGen.ImpCode.Kernels+ ( KernelName,+ KernelArg (..),+ HostCode,+ HostOp (..),+ KernelSafety (..),+ numFailureParams,+ FailureMsg (..),+ BlockDim,+ KernelConst (..),+ KernelConstExp,+ module Futhark.CodeGen.ImpCode,+ module Futhark.IR.GPU.Sizes,+ )+where++import Futhark.CodeGen.ImpCode+import Futhark.CodeGen.ImpCode.GPU (BlockDim, KernelConst (..), KernelConstExp)+import Futhark.IR.GPU.Sizes+import Futhark.Util.Pretty++-- | Something that can go wrong in a kernel. Part of the machinery+-- for reporting error messages from within kernels.+data FailureMsg = FailureMsg+ { failureError :: ErrorMsg Exp,+ failureBacktrace :: String+ }++-- | A piece of code calling kernels.+type HostCode = Code HostOp++-- | The name of a kernel.+type KernelName = Name++-- | An argument to be passed to a kernel.+data KernelArg+ = -- | Pass the value of this scalar expression as argument.+ ValueKArg Exp PrimType+ | -- | Pass this pointer as argument.+ MemKArg VName+ deriving (Show)++-- | Whether a kernel can potentially fail (because it contains bounds+-- checks and such).+data MayFail = MayFail | CannotFail+ deriving (Show)++-- | Information about bounds checks and how sensitive it is to+-- errors. Ordered by least demanding to most.+data KernelSafety+ = -- | Does not need to know if we are in a failing state, and also+ -- cannot fail.+ SafetyNone+ | -- | Needs to be told if there's a global failure, and that's it,+ -- and cannot fail.+ SafetyCheap+ | -- | Needs all parameters, may fail itself.+ SafetyFull+ deriving (Eq, Ord, Show)++-- | How many leading failure arguments we must pass when launching a+-- kernel with these safety characteristics.+numFailureParams :: KernelSafety -> Int+numFailureParams SafetyNone = 0+numFailureParams SafetyCheap = 1+numFailureParams SafetyFull = 3++-- | Host-level kernel operation.+data HostOp+ = LaunchKernel KernelSafety KernelName (Count Bytes (TExp Int64)) [KernelArg] [Exp] [BlockDim]+ | GetSize VName Name+ | CmpSizeLe VName Name Exp+ | GetSizeMax VName SizeClass+ deriving (Show)++instance Pretty HostOp where+ pretty = pretty . show
src/Futhark/CodeGen/ImpCode/OpenCL.hs view
@@ -8,28 +8,14 @@ -- operation that allows one to execute an OpenCL kernel. module Futhark.CodeGen.ImpCode.OpenCL ( Program (..),- KernelName,- KernelArg (..),- CLCode,- OpenCL (..),- KernelSafety (..),- numFailureParams, KernelTarget (..),- FailureMsg (..),- BlockDim,- KernelConst (..),- KernelConstExp,- module Futhark.CodeGen.ImpCode,- module Futhark.IR.GPU.Sizes,+ module Futhark.CodeGen.ImpCode.Kernels, ) where import Data.Map qualified as M import Data.Text qualified as T-import Futhark.CodeGen.ImpCode-import Futhark.CodeGen.ImpCode.GPU (BlockDim, KernelConst (..), KernelConstExp)-import Futhark.IR.GPU.Sizes-import Futhark.Util.Pretty+import Futhark.CodeGen.ImpCode.Kernels -- | A program calling OpenCL kernels. data Program = Program@@ -44,69 +30,12 @@ openClUsedTypes :: [PrimType], -- | Assertion failure error messages. openClFailures :: [FailureMsg],- hostDefinitions :: Definitions OpenCL- }---- | Something that can go wrong in a kernel. Part of the machinery--- for reporting error messages from within kernels.-data FailureMsg = FailureMsg- { failureError :: ErrorMsg Exp,- failureBacktrace :: String+ hostDefinitions :: Definitions HostOp } --- | A piece of code calling OpenCL.-type CLCode = Code OpenCL---- | The name of a kernel.-type KernelName = Name---- | An argument to be passed to a kernel.-data KernelArg- = -- | Pass the value of this scalar expression as argument.- ValueKArg Exp PrimType- | -- | Pass this pointer as argument.- MemKArg VName- deriving (Show)---- | Whether a kernel can potentially fail (because it contains bounds--- checks and such).-data MayFail = MayFail | CannotFail- deriving (Show)---- | Information about bounds checks and how sensitive it is to--- errors. Ordered by least demanding to most.-data KernelSafety- = -- | Does not need to know if we are in a failing state, and also- -- cannot fail.- SafetyNone- | -- | Needs to be told if there's a global failure, and that's it,- -- and cannot fail.- SafetyCheap- | -- | Needs all parameters, may fail itself.- SafetyFull- deriving (Eq, Ord, Show)---- | How many leading failure arguments we must pass when launching a--- kernel with these safety characteristics.-numFailureParams :: KernelSafety -> Int-numFailureParams SafetyNone = 0-numFailureParams SafetyCheap = 1-numFailureParams SafetyFull = 3---- | Host-level OpenCL operation.-data OpenCL- = LaunchKernel KernelSafety KernelName (Count Bytes (TExp Int64)) [KernelArg] [Exp] [BlockDim]- | GetSize VName Name- | CmpSizeLe VName Name Exp- | GetSizeMax VName SizeClass- deriving (Show)- -- | The target platform when compiling imperative code to a 'Program' data KernelTarget = TargetOpenCL | TargetCUDA | TargetHIP deriving (Eq)--instance Pretty OpenCL where- pretty = pretty . show
src/Futhark/CodeGen/ImpGen/GPU/Base.hs view
@@ -15,6 +15,7 @@ Target (..), KernelEnv (..), blockReduce,+ warpLocal, blockScan, blockLoop, isActive,@@ -84,6 +85,7 @@ data KernelEnv = KernelEnv { kernelAtomics :: AtomicBinOp,+ kernelTarget :: Target, kernelConstants :: KernelConstants, kernelLocks :: M.Map VName Locks }@@ -299,6 +301,19 @@ emit $ Imp.GetUserParam v name $ isInt64 def' pure v +-- | Run code where threads within a warp communicate directly through shared+-- memory. On OpenCL we rely on lockstep execution make all memory accesses+-- volatile; on CUDA and HIP we explicitly synchronise the warp afterwards with+-- 'Imp.WarpSync'. Like a barrier, this must be reached by all threads of the+-- warp.+warpLocal :: InKernelGen () -> InKernelGen ()+warpLocal m = do+ target <- kernelTarget <$> askEnv+ case target of+ OpenCL -> everythingVolatile m+ CUDA -> m >> sOp Imp.WarpSync+ HIP -> m >> sOp Imp.WarpSync+ inChunkScan :: KernelConstants -> Maybe (Imp.TExp Int32 -> Imp.TExp Int32 -> Imp.TExp Bool) ->@@ -310,7 +325,7 @@ InKernelGen () -> Lambda GPUMem -> InKernelGen ()-inChunkScan constants seg_flag arrs_full_size lockstep_width block_size active arrs barrier scan_lam = everythingVolatile $ do+inChunkScan constants seg_flag arrs_full_size lockstep_width block_size active arrs barrier scan_lam = do skip_threads <- dPrim "skip_threads" let actual_params = lambdaParams scan_lam (x_params, y_params) =@@ -362,13 +377,14 @@ thread_active <- dPrimVE "thread_active" $ tvExp skip_threads .<=. in_block_id .&&. active - sWhen thread_active . sComment "read operands" $- zipWithM_ (readParam (sExt64 $ tvExp skip_threads)) x_params arrs- sComment "perform operation" $ op_to_x thread_active+ warpLocal $ do+ sWhen thread_active . sComment "read operands" $+ zipWithM_ (readParam (sExt64 $ tvExp skip_threads)) x_params arrs+ sComment "perform operation" $ op_to_x thread_active maybeBarrier - sWhen thread_active . sComment "write result" $+ warpLocal . sWhen thread_active . sComment "write result" $ sequence_ $ zipWith3 writeResult x_params y_params arrs @@ -605,7 +621,6 @@ lambdaBody lam sComment "write result of operation" $ zipWithM_ writeReduceOpResult reduce_acc_params arrs- in_wave_reduce = everythingVolatile do_reduce wave_size = kernelWaveSize constants tblock_size = kernelBlockSize constants@@ -621,9 +636,10 @@ in_wave_reductions = do offset <-- (1 :: Imp.TExp Int32) sWhile doing_in_wave_reductions $ do- sWhen- (arg_in_bounds .&&. apply_in_in_wave_iteration)- in_wave_reduce+ warpLocal $+ sWhen+ (arg_in_bounds .&&. apply_in_in_wave_iteration)+ do_reduce offset <-- tvExp offset * 2 doing_cross_wave_reductions =@@ -1224,8 +1240,8 @@ InKernelGen () -> CallKernelGen () sKernelOp attrs constants ops name m = do- HostEnv atomics _ locks <- askEnv- body <- makeAllMemoryGlobal $ subImpM_ (KernelEnv atomics constants locks) ops m+ HostEnv atomics target locks <- askEnv+ body <- makeAllMemoryGlobal $ subImpM_ (KernelEnv atomics target constants locks) ops m uses <- computeKernelUses body $ M.keys $ kAttrConstExps attrs tblock_size <- onBlockSize $ kernelBlockSize constants -- XXX: the provenance of the kernel itself is usually boring (it just points
src/Futhark/CodeGen/ImpGen/GPU/Block.hs view
@@ -115,6 +115,14 @@ dPrimV "chunk_size" $ sExt64 $ chunk_end - chunk_start m chunk_start chunk_size +-- | Whether two indices into a flattened in-block space, segmented along its+-- innermost dimension of the given size, are in different segments. We know+-- these must fit in 32-bit integers, which means we can use much cheaper 32-bit+-- divisions.+crossesSegment :: Imp.TExp Int64 -> Imp.TExp Int32 -> Imp.TExp Int32 -> Imp.TExp Bool+crossesSegment segment_size from to =+ (to - from) .>. (to `rem` sExt32 segment_size)+ virtualisedBlockScan :: Maybe (Imp.TExp Int32 -> Imp.TExp Int32 -> Imp.TExp Bool) -> Imp.TExp Int32 ->@@ -406,9 +414,9 @@ sOp $ Imp.ErrorSync Imp.FenceLocal - let segment_size = last dims'- crossesSegment from to =- (sExt64 to - sExt64 from) .>. (sExt64 to `rem` segment_size)+ let seg_flag = case dims' of+ [_] -> Nothing -- Nonsegmented.+ _ -> Just $ crossesSegment $ last dims' -- blockScan needs to treat the scan output as a one-dimensional -- array of scan elements, so we invent some new flattened arrays@@ -420,13 +428,13 @@ case segVirt lvl of SegVirt -> virtualisedBlockScan- (Just crossesSegment)+ seg_flag (sExt32 $ tvExp dims_flat) (segBinOpLambda scan) arrs_flat _ -> blockScan- (Just crossesSegment)+ seg_flag (product dims') (product dims') (segBinOpLambda scan)@@ -501,14 +509,11 @@ -- virtCase dims' tmps_for_ops = do dims_flat <- dPrimV "dims_flat" $ product dims'- let segment_size = last dims'- crossesSegment from to =- (sExt64 to - sExt64 from) .>. (sExt64 to `rem` sExt64 segment_size) forM_ (zip ops tmps_for_ops) $ \(op, tmps) -> do tmps_flat <- mapM (flattenArray (length dims') dims_flat) tmps virtualisedBlockScan- (Just crossesSegment)+ (Just $ crossesSegment $ last dims') (sExt32 $ tvExp dims_flat) (segBinOpLambda op) tmps_flat@@ -544,14 +549,11 @@ -- involve copying anything; merely playing with the index -- function. dims_flat <- dPrimV "dims_flat" $ product dims'- let segment_size = last dims'- crossesSegment from to =- (sExt64 to - sExt64 from) .>. (sExt64 to `rem` sExt64 segment_size) forM_ (zip ops tmps_for_ops) $ \(op, tmps) -> do tmps_flat <- mapM (flattenArray (length dims') dims_flat) tmps blockScan- (Just crossesSegment)+ (Just $ crossesSegment $ last dims') (product dims') (product dims') (segBinOpLambda op)
src/Futhark/CodeGen/ImpGen/GPU/SegRed.hs view
@@ -75,6 +75,11 @@ -- | Given available register and a list of parameter types, compute -- the largest available chunk size given the parameters for which we -- want chunking and the available resources.+--+-- The chunk size is always odd. The collective copies go through+-- shared memory, where each thread accesses its chunk with a stride of+-- the chunk size. With an even chunk size, and particularly a power of+-- two, these accesses suffer from bank conflicts. getRedChunkSize :: [Type] -> Imp.KernelConstExp getRedChunkSize types = do let max_tblock_size = Imp.SizeMaxConst SizeThreadBlock@@ -91,7 +96,8 @@ mem_constraint = max k_mem sum_sizes `quot` max_size reg_constraint = (k_reg - 1 - sum_sizes') `quot` (2 * sum_sizes')- untyped $ sMax64 1 $ sMin64 mem_constraint reg_constraint+ chunk = sMax64 1 $ sMin64 mem_constraint reg_constraint+ untyped $ chunk - (1 - chunk `rem` 2) -- | Code generation for the body of the SegRed, taking a continuation -- for saving the results of the body. The results should be
src/Futhark/CodeGen/ImpGen/GPU/SegScan/SinglePass.hs view
@@ -29,6 +29,11 @@ -- types, and map parameter types, compute the largest available chunk -- size given the parameters for which we want chunking and the -- available resources.+--+-- The chunk size is always odd. The inputs and outputs are transposed+-- through shared memory, where each thread accesses its chunk with a+-- stride of the chunk size. With an even chunk size, and particularly+-- a power of two, these accesses suffer from bank conflicts. getScanChunkSize :: [Type] -> Imp.KernelConstExp getScanChunkSize types = let max_tblock_size = Imp.SizeMaxConst SizeThreadBlock@@ -45,7 +50,8 @@ mem_constraint = max k_mem sum_sizes `quot` max_size reg_constraint = (k_reg - 1 - sum_sizes') `quot` (2 * sum_sizes')- in untyped $ sMax64 1 $ sMin64 mem_constraint reg_constraint+ chunk = sMax64 1 $ sMin64 mem_constraint reg_constraint+ in untyped $ chunk - (1 - chunk `rem` 2) createLocalArrays :: Count BlockSize SubExp ->@@ -137,7 +143,7 @@ [VName] -> Lambda GPUMem -> InKernelGen ()-inBlockScanLookback constants arrs_full_size flag_arr arrs scan_lam = everythingVolatile $ do+inBlockScanLookback constants arrs_full_size flag_arr arrs scan_lam = do flg_x :: TV Int8 <- dPrim "flg_x" flg_y :: TV Int8 <- dPrim "flg_y" let flg_param_x = Param mempty (tvVar flg_x) (MemPrim p_int8)@@ -185,7 +191,7 @@ skip_threads <-- 1 sWhile (tvExp skip_threads .<. block_size) $ do- sWhen in_block_thread_active $ do+ warpLocal . sWhen in_block_thread_active $ do sComment "read operands" $ zipWithM_ (readParam (sExt64 $ tvExp skip_threads))@@ -193,13 +199,13 @@ (flag_arr : arrs) sComment "perform operation" op_to_x - sComment "write result" $- sequence_ $- zipWith3- writeResult- (flg_param_x : x_params)- (flg_param_y : y_params)- (flag_arr : arrs)+ warpLocal . sWhen in_block_thread_active . sComment "write result" $+ sequence_ $+ zipWith3+ writeResult+ (flg_param_x : x_params)+ (flg_param_y : y_params)+ (flag_arr : arrs) skip_threads <-- tvExp skip_threads * 2 where@@ -639,7 +645,7 @@ let warp_size = kernelWaveSize constants sWhen (bNot blockNewSgm .&&. ltid32 .<. warp_size) $ do- sWhen (ltid32 .==. 0) $ do+ warpLocal . sWhen (ltid32 .==. 0) $ do sIf (not_segmented_e .||. boundary .==. sExt32 (tblock_size_e * chunk)) ( do@@ -661,10 +667,9 @@ everythingVolatile $ copyDWIMFix warpscan [0] (Var statusFlags) [tvExp dyn_id - 1] -- sWhen- sOp local_fence status :: TV Int8 <- dPrim "status"- copyDWIMFix (tvVar status) [] (Var warpscan) [0]+ warpLocal $ copyDWIMFix (tvVar status) [] (Var warpscan) [0] sIf (tvExp status .==. statusP)@@ -708,12 +713,14 @@ -- end sIf -- end sWhen - forM_ (zip exchanges aggrs) $ \(exchange, aggr) ->- copyDWIMFix exchange [ltid] (tvSize aggr) []- copyDWIMFix warpscan [ltid] (tvSize flag) []+ warpLocal $ do+ forM_ (zip exchanges aggrs) $ \(exchange, aggr) ->+ copyDWIMFix exchange [ltid] (tvSize aggr) []+ copyDWIMFix warpscan [ltid] (tvSize flag) [] -- execute warp-parallel reduction but only if the last read flag in not STATUS_P- copyDWIMFix (tvVar flag) [] (Var warpscan) [sExt64 warp_size - 1]+ warpLocal $+ copyDWIMFix (tvVar flag) [] (Var warpscan) [sExt64 warp_size - 1] sWhen (tvExp flag .<. statusP) $ do lam' <- renameLambda scan_op1 inBlockScanLookback@@ -724,9 +731,10 @@ lam' -- all threads of the warp read the result of reduction- copyDWIMFix (tvVar flag) [] (Var warpscan) [sExt64 warp_size - 1]- forM_ (zip aggrs exchanges) $ \(aggr, exchange) ->- copyDWIMFix (tvVar aggr) [] (Var exchange) [sExt64 warp_size - 1]+ warpLocal $ do+ copyDWIMFix (tvVar flag) [] (Var warpscan) [sExt64 warp_size - 1]+ forM_ (zip aggrs exchanges) $ \(aggr, exchange) ->+ copyDWIMFix (tvVar aggr) [] (Var exchange) [sExt64 warp_size - 1] -- update read offset sIf (tvExp flag .==. statusP)
src/Futhark/CodeGen/ImpGen/GPU/ToOpenCL.hs view
@@ -24,6 +24,7 @@ import Futhark.CodeGen.Backends.SimpleRep import Futhark.CodeGen.ImpCode.GPU hiding (Program) import Futhark.CodeGen.ImpCode.GPU qualified as ImpGPU+import Futhark.CodeGen.ImpCode.Kernels qualified as ImpKernels import Futhark.CodeGen.ImpCode.OpenCL hiding (Program) import Futhark.CodeGen.ImpCode.OpenCL qualified as ImpOpenCL import Futhark.CodeGen.RTS.C (atomicsH, halfH)@@ -114,7 +115,7 @@ findParamUsers :: Env ->- Definitions ImpOpenCL.OpenCL ->+ Definitions ImpOpenCL.HostOp -> ParamMap -> ParamMap findParamUsers env defs = M.mapWithKey onParam@@ -218,7 +219,7 @@ funs = defFuns prog cg = ImpGPU.callGraph calledInHostOp funs -lookupFunction :: Name -> Env -> Maybe (ImpGPU.Function HostOp)+lookupFunction :: Name -> Env -> Maybe (ImpGPU.Function ImpGPU.HostOp) lookupFunction fname = lookup fname . unFunctions . envFuns functionMayFail :: Name -> Env -> Bool@@ -226,7 +227,7 @@ type OnKernelM = ReaderT Env (State ToOpenCL) -onHostOp :: KernelTarget -> HostOp -> OnKernelM OpenCL+onHostOp :: KernelTarget -> ImpGPU.HostOp -> OnKernelM ImpKernels.HostOp onHostOp target (CallKernel k) = onKernel target k onHostOp _ (ImpGPU.GetSize v key _) = pure $ ImpOpenCL.GetSize v key@@ -297,7 +298,7 @@ exists <- gets $ M.member fname . clDevFuns unless exists $ generateDeviceFun fname host_func -calledInHostOp :: HostOp -> S.Set Name+calledInHostOp :: ImpGPU.HostOp -> S.Set Name calledInHostOp (CallKernel k) = calledFuncs calledInKernelOp $ kernelBody k calledInHostOp _ = mempty @@ -321,7 +322,7 @@ Nothing -> pure Nothing where bad = compilerLimitationS "Cannot generate GPU functions that contain parallelism."- toDevice :: HostOp -> KernelOp+ toDevice :: ImpGPU.HostOp -> KernelOp toDevice _ = bad isConst :: BlockDim -> Maybe KernelConstExp@@ -331,7 +332,7 @@ Just e isConst _ = Nothing -onKernel :: KernelTarget -> Kernel -> OnKernelM OpenCL+onKernel :: KernelTarget -> Kernel -> OnKernelM ImpOpenCL.HostOp onKernel target kernel = do called <- ensureDeviceFuns $ kernelBody kernel @@ -634,6 +635,8 @@ GC.stm [C.cstm|mem_fence_local();|] kernelOps (MemFence FenceGlobal) = GC.stm [C.cstm|mem_fence_global();|]+ kernelOps WarpSync =+ GC.stm [C.cstm|warp_sync();|] kernelOps (SharedAlloc name size) = do name' <- newVName $ nameFromText $ prettyText name <> "_backing" GC.modifyUserState $ \s ->@@ -874,8 +877,9 @@ typesInCode (DeclareArray _ t _) = S.singleton t typesInCode (Allocate _ (Count (TPrimExp e)) _) = typesInExp e typesInCode Free {} = mempty-typesInCode (Copy _ shape _ (Count (TPrimExp dstoffset), dststrides) _ (Count (TPrimExp srcoffset), srcstrides)) =- foldMap (typesInExp . untyped . unCount) shape+typesInCode (Copy t shape _ (Count (TPrimExp dstoffset), dststrides) _ (Count (TPrimExp srcoffset), srcstrides)) =+ S.singleton t+ <> foldMap (typesInExp . untyped . unCount) shape <> typesInExp dstoffset <> foldMap (typesInExp . untyped . unCount) dststrides <> typesInExp srcoffset
src/Futhark/Eval.hs view
@@ -13,12 +13,14 @@ forceValue, externaliseLast, runInterpreterWith,+ Trust (..), interpretImports, initialiseInterpreter, newInterpreterState, Evaluation (..), EvalRecordRef, runEvalRecordRef,+ I.prettyValue, ) where @@ -44,7 +46,7 @@ import Futhark.Test.Compile (FutharkExe (..), compileProgram, futharkServerCfg) import Futhark.Util (showText) import Futhark.Util.Options (ArgDescr (..), FunOptDescr, OptDescr (..))-import Futhark.Util.Pretty (commasep, hPutDoc, hPutDocLn, hardline, putDocLn)+import Futhark.Util.Pretty (commasep, hPutDoc, hPutDocLn, putDocLn) import Language.Futhark.Core (locText) import Language.Futhark.Interpreter qualified as I import Language.Futhark.Interpreter.FFI.Push qualified as FFI@@ -111,7 +113,7 @@ (Evaluation m, MonadIO m) => InterpreterState -> T.Text ->- m (Doc AnsiStyle)+ m I.Value runExpr state str = case parseExp "" str of Left (SyntaxError _ serr) -> abort $ pretty serr@@ -123,7 +125,7 @@ (Evaluation m, MonadIO m) => InterpreterState -> UncheckedExp ->- m (Doc AnsiStyle)+ m I.Value runParsedExpr (InterpreterState (src, env, ctx, s)) uexp = do fexp <- case T.checkExp [] src env uexp of (_, Left terr) -> do@@ -136,14 +138,14 @@ "The following types are ambiguous: " <> commasep (map (pretty . nameToText . toName . typeParamName) tparams) ]- pval <- runInterpreterWith trace s Nothing $ I.interpretExp ctx fexp+ pval <- runInterpreterWith Trusted trace s Nothing $ I.interpretExp ctx fexp case pval of Left err -> abort $ I.prettyInterpreterError err Right val -> do forced <- liftIO $ forceValue s val case forced of Left err -> abort $ I.prettyInterpreterError err- Right val' -> pure $ I.prettyValue val' <> hardline+ Right val' -> pure val' data EvalConfig = EvalConfig { evalPrintWarnings :: Bool,@@ -332,8 +334,14 @@ evalWith s = runExceptT . fmap (\(tenv, ienv) -> (s, tenv, ienv))- . interpretImports (runInterpreterWith trace s Nothing)+ . interpretImports (runInterpreterWith Trusted trace s Nothing) +-- | Whether the code we are interpreting is trusted to perform any IO+-- operation it likes, or is untrusted code for which only the operations+-- deemed safe by 'I.safeIO' are permitted.+data Trust = Trusted | Untrusted+ deriving (Eq, Show)+ -- | Run an interpreter action non-interactively. Breakpoints are ignored, as -- there is no way to enter a debugging prompt. Traces, and the breakpoints -- that are ignored, are reported with the given function. External calls are@@ -342,12 +350,13 @@ -- the working directory. runInterpreterWith :: (MonadIO m) =>+ Trust -> (Doc AnsiStyle -> m ()) -> Maybe FFI.Server -> Maybe FilePath -> F I.ExtOp a -> m (Either I.InterpreterError a)-runInterpreterWith report s dir m = runF m (pure . Right) intOp+runInterpreterWith trust report s dir m = runF m (pure . Right) intOp where intOp (I.ExtOpError err) = pure $ Left err intOp (I.ExtOpTrace w v c) = do@@ -358,6 +367,11 @@ report $ pretty (locText w) <> ": ignoring breakpoint." c intOp (I.ExtOpFFI sm c) = either (pure . Left) c =<< liftIO (runFFI s sm)- intOp (I.ExtOpIO op c) =- either (pure . Left . I.InterpreterError) c- =<< liftIO (I.doIOOp s (maybe id I.ioRelativeTo dir op))+ intOp (I.ExtOpIO op c)+ | trust == Untrusted,+ not $ I.safeIO op =+ pure . Left . I.InterpreterError $+ "This IO operation is not permitted in untrusted code."+ | otherwise =+ either (pure . Left . I.InterpreterError) c+ =<< liftIO (I.doIOOp s (maybe id I.ioRelativeTo dir op))
src/Futhark/IR/Aliases.hs view
@@ -39,7 +39,10 @@ removeBodyAliases, removeLambdaAliases, removePatAliases,- removeScopeAliases,+ removeNameInfoAliases,+ WithoutAliases,+ runWithoutAliases,+ withoutAliases, -- * Tracking aliases AliasesAndConsumed,@@ -51,6 +54,7 @@ import Control.Monad.Identity import Control.Monad.Reader+import Data.Bifunctor (first) import Data.Kind qualified import Data.Map.Strict qualified as M import Data.Maybe@@ -121,14 +125,6 @@ instance FreeDec AliasDec -withoutAliases ::- (HasScope (Aliases rep) m, Monad m) =>- ReaderT (Scope rep) m a ->- m a-withoutAliases m = do- scope <- asksScope removeScopeAliases- runReaderT m scope- instance ( ASTRep rep, AliasedOp (OpC rep),@@ -209,15 +205,61 @@ rephraseOp = rephraseInOp removeAliases } --- | Remove alias information from an aliased scope.-removeScopeAliases :: Scope (Aliases rep) -> Scope rep-removeScopeAliases = M.map unAlias+-- | Remove alias information from a single scope entry.+removeNameInfoAliases :: NameInfo (Aliases rep) -> NameInfo rep+removeNameInfoAliases (LetName (_, dec)) = LetName dec+removeNameInfoAliases (FParamName dec) = FParamName dec+removeNameInfoAliases (LParamName dec) = LParamName dec+removeNameInfoAliases (IndexName it) = IndexName it++-- | A reader monad transformer that presents a scope of @'Aliases' rep@ as a+-- scope of @rep@. An entry is converted when it is looked up, so the cost does+-- not depend on the size of the scope. Scope added with 'localScope' is kept+-- apart from the aliased scope.+newtype WithoutAliases rep m a+ = WithoutAliases (ReaderT (Scope rep, Scope (Aliases rep)) m a)+ deriving (Functor, Applicative, Monad)++instance+ (Monad m, RepTypes rep, RepTypes (Aliases rep)) =>+ HasScope rep (WithoutAliases rep m) where- unAlias (LetName (_, dec)) = LetName dec- unAlias (FParamName dec) = FParamName dec- unAlias (LParamName dec) = LParamName dec- unAlias (IndexName it) = IndexName it+ lookupInfo name = WithoutAliases . asks $ \(extra, scope) ->+ case M.lookup name extra of+ Just info -> info+ Nothing ->+ maybe notFound removeNameInfoAliases $ M.lookup name scope+ where+ notFound =+ error $+ "WithoutAliases.lookupInfo: Name "+ ++ prettyString name+ ++ " not found in type environment."+ askScope =+ WithoutAliases . asks $ \(extra, scope) ->+ extra <> M.map removeNameInfoAliases scope +instance+ (Monad m, RepTypes rep, RepTypes (Aliases rep)) =>+ LocalScope rep (WithoutAliases rep m)+ where+ localScope scope (WithoutAliases m) =+ WithoutAliases $ local (first (scope <>)) m++instance (MonadFreshNames m) => MonadFreshNames (WithoutAliases rep m) where+ getNameSource = WithoutAliases $ lift getNameSource+ putNameSource = WithoutAliases . lift . putNameSource++-- | Run a 'WithoutAliases' computation in the given aliased scope.+runWithoutAliases :: WithoutAliases rep m a -> Scope (Aliases rep) -> m a+runWithoutAliases (WithoutAliases m) scope = runReaderT m (mempty, scope)++withoutAliases ::+ (HasScope (Aliases rep) m, Monad m) =>+ WithoutAliases rep m a ->+ m a+withoutAliases m = runWithoutAliases m =<< askScope+ -- | Remove alias information from a program. removeProgAliases :: (RephraseOp (OpC rep)) =>@@ -404,11 +446,9 @@ mkExpPat ids e = mkAliasedPat (mkExpPat ids $ removeExpAliases e) e - mkLetNames names e = do- env <- asksScope removeScopeAliases- flip runReaderT env $ do- Let pat dec _ <- mkLetNames names $ removeExpAliases e- pure $ mkAliasedStm pat dec e+ mkLetNames names e = withoutAliases $ do+ Let pat dec _ <- mkLetNames names $ removeExpAliases e+ pure $ mkAliasedStm pat dec e mkBody stms res = let Body bodyrep _ _ = mkBody (fmap removeStmAliases stms) res
src/Futhark/IR/GPU.hs view
@@ -63,8 +63,8 @@ asSegOp _ = Nothing segOp = SegOp -instance TraverseOpStms GPU where- traverseOpStms = traverseHostOpStms traverseSOACStms+instance TraverseOpBodies GPU where+ traverseOpBodies = traverseHostOpBodies traverseSOACBodies -- Note [GPU Terminology] --
src/Futhark/IR/GPU/Op.hs view
@@ -7,7 +7,7 @@ -- * Host operations HostOp (..),- traverseHostOpStms,+ traverseHostOpBodies, simplifyKernelOp, typeCheckHostOp, @@ -241,17 +241,16 @@ GPUBody [Type] (Body rep) deriving (Eq, Ord, Show) --- | A helper for defining 'TraverseOpStms'.-traverseHostOpStms ::+-- | A helper for defining 'TraverseOpBodies'.+traverseHostOpBodies :: (Monad m) =>- OpStmsTraverser m (op rep) rep ->- OpStmsTraverser m (HostOp op rep) rep-traverseHostOpStms _ f (SegOp segop) = SegOp <$> traverseSegOpStms f segop-traverseHostOpStms _ _ (SizeOp sizeop) = pure $ SizeOp sizeop-traverseHostOpStms onOtherOp f (OtherOp other) = OtherOp <$> onOtherOp f other-traverseHostOpStms _ f (GPUBody ts body) = do- stms <- f mempty $ bodyStms body- pure $ GPUBody ts $ body {bodyStms = stms}+ OpBodyTraverser m (op rep) rep ->+ OpBodyTraverser m (HostOp op rep) rep+traverseHostOpBodies _ f (SegOp segop) = SegOp <$> traverseSegOpBodies f segop+traverseHostOpBodies _ _ (SizeOp sizeop) = pure $ SizeOp sizeop+traverseHostOpBodies onOtherOp f (OtherOp other) = OtherOp <$> onOtherOp f other+traverseHostOpBodies _ f (GPUBody ts body) =+ GPUBody ts <$> f mempty body instance (ASTRep rep, Substitute (op rep)) => Substitute (HostOp op rep) where substituteNames substs (SegOp op) =
src/Futhark/IR/GPU/Simplify.hs view
@@ -39,8 +39,8 @@ simplifyLambda = Simplify.simplifyLambda simpleGPU kernelRules Engine.noExtraHoistBlockers -instance TraverseOpStms (Wise GPU) where- traverseOpStms = traverseHostOpStms traverseSOACStms+instance TraverseOpBodies (Wise GPU) where+ traverseOpBodies = traverseHostOpBodies traverseSOACBodies instance BuilderOps (Wise GPU) @@ -85,8 +85,9 @@ pick = map snd . filter fst . zip pat_used pat' = pick (patElems pat) types' = pick types- body' = body {bodyResult = pick (bodyResult body)}- in Simplify $ auxing aux $ letBind (Pat pat') $ Op $ GPUBody types' body'+ in Simplify . auxing aux $ do+ body' <- mkBodyM (bodyStms body) (pick (bodyResult body))+ letBind (Pat pat') $ Op $ GPUBody types' body' | otherwise = Skip removeDeadGPUBodyResult _ _ _ _ = Skip
src/Futhark/IR/GPUMem.hs view
@@ -74,8 +74,8 @@ mkBodyB stms res = pure $ Engine.mkWiseBody () stms res mkLetNamesB = mkLetNamesB'' (Space "device") -instance TraverseOpStms (Engine.Wise GPUMem) where- traverseOpStms = traverseMemOpStms (traverseHostOpStms (const pure))+instance TraverseOpBodies (Engine.Wise GPUMem) where+ traverseOpBodies = traverseMemOpBodies (traverseHostOpBodies (\_ -> pure)) simplifyProg :: Prog GPUMem -> PassM (Prog GPUMem) simplifyProg = simplifyProgGeneric memRuleBook simpleGPUMem
src/Futhark/IR/MC.hs view
@@ -57,8 +57,8 @@ instance PrettyRep MC -instance TraverseOpStms (Engine.Wise MC) where- traverseOpStms = traverseMCOpStms traverseSOACStms+instance TraverseOpBodies (Engine.Wise MC) where+ traverseOpBodies = traverseMCOpBodies traverseSOACBodies simpleMC :: Simplify.SimpleOps MC simpleMC = Simplify.bindableSimpleOps $ simplifyMCOp SOAC.simplifySOAC
src/Futhark/IR/MC/Op.hs view
@@ -7,7 +7,7 @@ -- also re-exported from here. module Futhark.IR.MC.Op ( MCOp (..),- traverseMCOpStms,+ traverseMCOpBodies, typeCheckMCOp, simplifyMCOp, module Futhark.IR.SegOp,@@ -50,13 +50,13 @@ OtherOp (op rep) deriving (Eq, Ord, Show) -traverseMCOpStms ::+traverseMCOpBodies :: (Monad m) =>- OpStmsTraverser m (op rep) rep ->- OpStmsTraverser m (MCOp op rep) rep-traverseMCOpStms _ f (ParOp par_op op) =- ParOp <$> traverse (traverseSegOpStms f) par_op <*> traverseSegOpStms f op-traverseMCOpStms onInner f (OtherOp op) = OtherOp <$> onInner f op+ OpBodyTraverser m (op rep) rep ->+ OpBodyTraverser m (MCOp op rep) rep+traverseMCOpBodies _ f (ParOp par_op op) =+ ParOp <$> traverse (traverseSegOpBodies f) par_op <*> traverseSegOpBodies f op+traverseMCOpBodies onInner f (OtherOp op) = OtherOp <$> onInner f op instance (ASTRep rep, Substitute (op rep)) => Substitute (MCOp op rep) where substituteNames substs (ParOp par_op op) =
src/Futhark/IR/MCMem.hs view
@@ -66,8 +66,8 @@ mkBodyB stms res = pure $ Engine.mkWiseBody () stms res mkLetNamesB = mkLetNamesB'' DefaultSpace -instance TraverseOpStms (Engine.Wise MCMem) where- traverseOpStms = traverseMemOpStms (traverseMCOpStms (const pure))+instance TraverseOpBodies (Engine.Wise MCMem) where+ traverseOpBodies = traverseMemOpBodies (traverseMCOpBodies (\_ -> pure)) simplifyProg :: Prog MCMem -> PassM (Prog MCMem) simplifyProg = simplifyProgGeneric memRuleBook simpleMCMem
src/Futhark/IR/Mem.hs view
@@ -57,7 +57,7 @@ RetTypeMem, BranchTypeMem, MemOp (..),- traverseMemOpStms,+ traverseMemOpBodies, MemInfo (..), MemBound, MemBind (..),@@ -103,7 +103,6 @@ import Control.Category import Control.Monad import Control.Monad.Except-import Control.Monad.Reader import Control.Monad.State import Data.Foldable (traverse_) import Data.Function ((&))@@ -121,7 +120,8 @@ CanBeAliased (..), removeExpAliases, removePatAliases,- removeScopeAliases,+ runWithoutAliases,+ withoutAliases, ) import Futhark.IR.Mem.LMAD qualified as LMAD import Futhark.IR.Pretty@@ -193,14 +193,14 @@ | Inner (inner rep) deriving (Eq, Ord, Show) --- | A helper for defining 'TraverseOpStms'.-traverseMemOpStms ::+-- | A helper for defining 'TraverseOpBodies'.+traverseMemOpBodies :: (Monad m) =>- OpStmsTraverser m (inner rep) rep ->- OpStmsTraverser m (MemOp inner rep) rep-traverseMemOpStms _ _ op@Alloc {} = pure op-traverseMemOpStms _ _ op@EnsureDirect {} = pure op-traverseMemOpStms onInner f (Inner inner) = Inner <$> onInner f inner+ OpBodyTraverser m (inner rep) rep ->+ OpBodyTraverser m (MemOp inner rep) rep+traverseMemOpBodies _ _ op@Alloc {} = pure op+traverseMemOpBodies _ _ op@EnsureDirect {} = pure op+traverseMemOpBodies onInner f (Inner inner) = Inner <$> onInner f inner instance (RephraseOp inner) => RephraseOp (MemOp inner) where rephraseInOp _ (Alloc e space) = pure (Alloc e space)@@ -597,8 +597,7 @@ Result -> TC.TypeM rep () matchRetTypeToResult rettype result = do- scope <- askScope- result_ts <- runReaderT (mapM (subExpMemInfo . resSubExp) result) $ removeScopeAliases scope+ result_ts <- withoutAliases $ mapM (subExpMemInfo . resSubExp) result matchReturnType rettype (map resSubExp result) result_ts matchFunctionReturnType ::@@ -671,7 +670,7 @@ TC.TypeM rep () matchBranchReturnType rettype (Body _ stms res) = do scope <- askScope- ts <- runReaderT (mapM (subExpMemInfo . resSubExp) res) $ removeScopeAliases (scope <> scopeOf stms)+ ts <- runWithoutAliases (mapM (subExpMemInfo . resSubExp) res) (scope <> scopeOf stms) matchReturnType rettype (map resSubExp res) ts -- | Helper function for index function unification.@@ -807,8 +806,7 @@ Exp (Aliases rep) -> TC.TypeM rep () matchPatToExp pat e = do- scope <- asksScope removeScopeAliases- rt <- maybe illformed pure $ runReader (expReturns $ removeExpAliases e) scope+ rt <- maybe illformed pure =<< withoutAliases (expReturns $ removeExpAliases e) let (ctx_ids, val_ts) = unzip $ bodyReturnsFromPat $ removePatAliases pat (ctx_map_ids, ctx_map_exts) = getExtMaps $ zip ctx_ids [0 .. 1]
src/Futhark/IR/Parse.hs view
@@ -255,7 +255,7 @@ pPos :: Parser L.Pos pPos = L.Pos- <$> manyTill L.charLiteral (char ':')+ <$> (T.unpack <$> takeWhileP (Just "file name") (/= ':') <* char ':') <*> lInt <*> (char ':' *> lInt) <*> pure (-1) -- Cannot recover offset.@@ -688,7 +688,11 @@ where pEntryPointInputs = braces (pEntryPointInput `sepBy` pComma) pEntryPointInput =- EntryParam <$> pName <* pColon <*> pDiet <*> pEntryPointType+ EntryParam+ <$> (nameFromText <$> pStringLiteral)+ <* pColon+ <*> pDiet+ <*> pEntryPointType pEntryPointResult = EntryResult <$> pDiet <*> pEntryPointType @@ -712,7 +716,7 @@ <$> (keyword "type" *> (nameFromText <$> pStringLiteral) <* pEqual) <*> ((,Nothing) <$> choice [pRecord, pSum, pRecordArray, pOpaqueArray]) where- pFieldName = choice [pName, nameFromString . show <$> pInt]+ pFieldName = choice [nameFromText <$> pStringLiteral] pField = (,) <$> pFieldName <* pColon <*> pEntryPointType pRecord = keyword "record" $> OpaqueRecord <*> braces (many pField)
src/Futhark/IR/Pretty.hs view
@@ -399,7 +399,8 @@ pretty (TypeOpaque desc) = "opaque" <+> dquotes (pretty desc) instance Pretty EntryParam where- pretty (EntryParam name o t) = pretty name <> colon <+> pretty o <> pretty t+ pretty (EntryParam name o t) =+ dquotes (pretty name) <> colon <+> pretty o <> pretty t instance Pretty EntryResult where pretty (EntryResult o t) = pretty o <> pretty t@@ -431,7 +432,7 @@ pretty (OpaqueRecord fs) = "record" <+> nestedBlock (stack $ map p fs) where- p (f, et) = pretty f <> ":" <+> pretty et+ p (f, et) = dquotes (pretty f) <> ":" <+> pretty et pretty (OpaqueSum ts cs) = "sum" <+> nestedBlock (stack $ pretty ts : map p cs) where@@ -442,9 +443,12 @@ <+> dquotes (pretty v) <+> nestedBlock (stack $ map pretty ts) pretty (OpaqueRecordArray r v fs) =- "record_array" <+> pretty r <> "d" <+> dquotes (pretty v) <+> nestedBlock (stack $ map p fs)+ "record_array" <+> pretty r+ <> "d"+ <+> dquotes (pretty v)+ <+> nestedBlock (stack $ map p fs) where- p (f, et) = pretty f <> ":" <+> pretty et+ p (f, et) = dquotes (pretty f) <> ":" <+> pretty et instance Pretty OpaqueTypes where pretty (OpaqueTypes ts) = "types" <+> nestedBlock (stack $ map p ts)
src/Futhark/IR/Prop.hs view
@@ -40,6 +40,9 @@ IsOp (..), ASTRep (..), IsResult (..),+ OpBodyTraverser,+ TraverseOpBodies (..),+ traverseLambdaBodies, ) where @@ -128,8 +131,8 @@ safeBasicOp (BinOp SQuot {} _ _) = False safeBasicOp (BinOp SRem {} _ (Constant y)) = not $ zeroIsh y safeBasicOp (BinOp SRem {} _ _) = False- safeBasicOp (BinOp Pow {} _ (Constant y)) = not $ negativeIsh y- safeBasicOp (BinOp Pow {} _ _) = False+ safeBasicOp (BinOp SPow {} _ (Constant y)) = not $ negativeIsh y+ safeBasicOp (BinOp SPow {} _ _) = False safeBasicOp ArrayLit {} = True safeBasicOp BinOp {} = True safeBasicOp SubExp {} = True@@ -324,3 +327,24 @@ -- | Is this a builtin name, and if so, what is the underlying name? isBuiltinName :: Name -> Maybe T.Text isBuiltinName v = "builtin/" `T.stripPrefix` nameToText v++-- | A function for monadically traversing the immediate sub-bodies of the+-- given op for some representation. The function is given the scope of the+-- names bound by the op that are visible in the body. A function that modifies+-- the body is responsible for constructing it properly, e.g. with 'mkBody',+-- such that its decoration is up to date.+type OpBodyTraverser m op rep =+ (forall res. (IsResult res) => Scope rep -> GBody rep res -> m (GBody rep res)) ->+ op ->+ m op++-- | This representation supports an 'OpBodyTraverser' for its t'Op'.+-- This is used for some simplification rules.+class TraverseOpBodies rep where+ -- | Transform every sub-'Body' of this op.+ traverseOpBodies :: (Monad m) => OpBodyTraverser m (Op rep) rep++-- | A helper for defining 'traverseOpBodies'.+traverseLambdaBodies :: (Monad m) => OpBodyTraverser m (GLambda rep t) rep+traverseLambdaBodies f (Lambda ps ret body) =+ Lambda ps ret <$> f (scopeOfLParams ps) body
src/Futhark/IR/Prop/Reshape.hs view
@@ -372,8 +372,8 @@ move (shape, DimSplice i1 n1 s1) (DimSplice i2 n2 s2 : ss) | i1 > i2 + n2 = next shape (DimSplice i2 n2 s2) (DimSplice (i1 - n2 + length s2) n1 s1) ss- | i2 > i1 + n1 =- next shape (DimSplice (i2 - n1 + length s1) n2 s2) (DimSplice i1 n2 s1) ss+ | i2 > i1 + length s1 =+ next shape (DimSplice (i2 - length s1 + n1) n2 s2) (DimSplice i1 n1 s1) ss | otherwise = Nothing -- This is a quadratic-time function that looks for a DimSplice that can be
src/Futhark/IR/Prop/Scope.hs view
@@ -260,6 +260,9 @@ lookupType name = do res <- asks $ fmap typeOf . M.lookup name maybe (ExtendedScope $ lift $ lookupType name) pure res+ lookupInfo name = do+ res <- asks $ M.lookup name+ maybe (ExtendedScope $ lift $ lookupInfo name) pure res askScope = asks M.union <*> ExtendedScope (lift askScope) -- | Run a computation in the extended type environment.
+ src/Futhark/IR/Run.hs view
@@ -0,0 +1,1915 @@+-- | Interpreter for the IR.+--+-- Running an IR program requires specifying the name of an entry point along+-- with values for the entry point parameters. Top level statements+-- ('progConsts') are evaluated first, and then the specified entry point is+-- invoked with the provided values.+--+-- The goal of this interpreter is not performance, but operational clarity.+-- Hence you should not expect programs to run fast at all.+module Futhark.IR.Run (runSOACS, runGPU) where++import Control.Monad (foldM, forM, when, zipWithM, zipWithM_, (>=>))+import Control.Monad.Error.Class+import Control.Monad.Except (ExceptT, runExceptT)+import Control.Monad.IO.Class+import Control.Monad.Reader (MonadReader, ReaderT, asks, local, runReaderT)+import Data.Int qualified as I+import Data.List qualified as L+import Data.List.NonEmpty qualified as NE+import Data.Map qualified as M+import Data.Maybe (mapMaybe)+import Data.Text qualified as T+import Data.Text.IO qualified as TIO+import Data.Vector.Storable qualified as SVec+import Data.Vector.Storable.Mutable qualified as MSVec+import Foreign.Storable (Storable)+import Futhark.Data qualified as V+import Futhark.IR+import Futhark.IR.GPU+ ( GPU,+ HostOp (..),+ SizeClass (..),+ SizeOp (..),+ )+import Futhark.IR.SOACS (HistOp (..), Reduce (..), SOAC (..), SOACS, Scan (..), ScremaForm (..), flatMapNonuniform)+import Futhark.IR.SegOp qualified as Seg+import Futhark.Util (showText)+import Language.Futhark.Primitive qualified as P+import Numeric.Half qualified as H+import System.IO (stderr)++data Val+ = PrimVal PrimValue+ | ArrayValue [Int] ArrayValues+ | AccValue Accumulator++-- The operator of an accumulator is looked up in 'interpAccOps' by+-- its certificate.+data Accumulator = Accumulator+ { accCert :: VName,+ accShape :: [Int],+ accArrays :: [Val]+ }++data ArrayValues+ = I8ArrayValues (MSVec.IOVector I.Int8)+ | I16ArrayValues (MSVec.IOVector I.Int16)+ | I32ArrayValues (MSVec.IOVector I.Int32)+ | I64ArrayValues (MSVec.IOVector I.Int64)+ | F16ArrayValues (MSVec.IOVector H.Half)+ | F32ArrayValues (MSVec.IOVector Float)+ | F64ArrayValues (MSVec.IOVector Double)+ | BoolArrayValues (MSVec.IOVector Bool)+ | UnitArrayValues (MSVec.IOVector ())++arrayValuesType :: ArrayValues -> PrimType+arrayValuesType I8ArrayValues {} = IntType Int8+arrayValuesType I16ArrayValues {} = IntType Int16+arrayValuesType I32ArrayValues {} = IntType Int32+arrayValuesType I64ArrayValues {} = IntType Int64+arrayValuesType F16ArrayValues {} = FloatType Float16+arrayValuesType F32ArrayValues {} = FloatType Float32+arrayValuesType F64ArrayValues {} = FloatType Float64+arrayValuesType BoolArrayValues {} = Bool+arrayValuesType UnitArrayValues {} = Unit++data KernelResultValue+ = KernelValue Val+ | KernelTile [(Int, Int)] Val+ | KernelRegTile [(Int, Int, Int)] Val++type Env = M.Map VName Val++type FunEnv rep = M.Map Name (FunDef rep)++type OpEvaluator rep =+ FunEnv rep -> Env -> Op rep -> InterpM rep [Val]++data InterpEnv rep = InterpEnv+ { interpOpEvaluator :: OpEvaluator rep,+ -- | Accumulator operators, keyed by certificate, together with the+ -- environments of the 'WithAcc' that defined them. The operator+ -- receives (indices <> old values <> new values).+ interpAccOps :: M.Map VName (FunEnv rep, Env, Lambda rep)+ }++newtype InterpM rep a = InterpM+ { unInterpM :: ReaderT (InterpEnv rep) (ExceptT T.Text IO) a+ }+ deriving+ (Functor, Applicative, Monad, MonadReader (InterpEnv rep), MonadError T.Text, MonadIO)++interpError :: T.Text -> InterpM rep a+interpError = throwError++newArrayValue :: [Int] -> PrimType -> [PrimValue] -> InterpM rep Val+newArrayValue shape element_type values =+ ArrayValue shape <$> newValues element_type+ where+ newValues (IntType Int8) = I8ArrayValues <$> newPrimVector expectInt8+ newValues (IntType Int16) = I16ArrayValues <$> newPrimVector expectInt16+ newValues (IntType Int32) = I32ArrayValues <$> newPrimVector expectInt32+ newValues (IntType Int64) = I64ArrayValues <$> newPrimVector expectInt64+ newValues (FloatType Float16) = F16ArrayValues <$> newPrimVector expectFloat16+ newValues (FloatType Float32) = F32ArrayValues <$> newPrimVector expectFloat32+ newValues (FloatType Float64) = F64ArrayValues <$> newPrimVector expectFloat64+ newValues Bool = BoolArrayValues <$> newPrimVector expectBool+ newValues Unit = UnitArrayValues <$> newPrimVector expectUnit++ newPrimVector unwrap = liftIO $ do+ vector <- MSVec.new (length values)+ zipWithM_ (MSVec.write vector) [0 ..] (map unwrap values)+ pure vector++ expectInt8 (IntValue (Int8Value element)) = element+ expectInt8 _ = error "expected an i8 value"+ expectInt16 (IntValue (Int16Value element)) = element+ expectInt16 _ = error "expected an i16 value"+ expectInt32 (IntValue (Int32Value element)) = element+ expectInt32 _ = error "expected an i32 value"+ expectInt64 (IntValue (Int64Value element)) = element+ expectInt64 _ = error "expected an i64 value"+ expectFloat16 (FloatValue (Float16Value element)) = element+ expectFloat16 _ = error "expected an f16 value"+ expectFloat32 (FloatValue (Float32Value element)) = element+ expectFloat32 _ = error "expected an f32 value"+ expectFloat64 (FloatValue (Float64Value element)) = element+ expectFloat64 _ = error "expected an f64 value"+ expectBool (BoolValue element) = element+ expectBool _ = error "expected a bool value"+ expectUnit UnitValue = ()+ expectUnit _ = error "expected a unit value"++arrayValues :: ArrayValues -> InterpM rep [PrimValue]+arrayValues values =+ mapM (readArrayValue values) [0 .. arrayValuesLength values - 1]++arrayValuesLength :: ArrayValues -> Int+arrayValuesLength (I8ArrayValues values) = MSVec.length values+arrayValuesLength (I16ArrayValues values) = MSVec.length values+arrayValuesLength (I32ArrayValues values) = MSVec.length values+arrayValuesLength (I64ArrayValues values) = MSVec.length values+arrayValuesLength (F16ArrayValues values) = MSVec.length values+arrayValuesLength (F32ArrayValues values) = MSVec.length values+arrayValuesLength (F64ArrayValues values) = MSVec.length values+arrayValuesLength (BoolArrayValues values) = MSVec.length values+arrayValuesLength (UnitArrayValues values) = MSVec.length values++readArrayValue :: ArrayValues -> Int -> InterpM rep PrimValue+readArrayValue vector index+ | index < 0 || index >= arrayValuesLength vector =+ interpError "array index out of bounds"+readArrayValue (I8ArrayValues values) index =+ IntValue . Int8Value <$> liftIO (MSVec.read values index)+readArrayValue (I16ArrayValues values) index =+ IntValue . Int16Value <$> liftIO (MSVec.read values index)+readArrayValue (I32ArrayValues values) index =+ IntValue . Int32Value <$> liftIO (MSVec.read values index)+readArrayValue (I64ArrayValues values) index =+ IntValue . Int64Value <$> liftIO (MSVec.read values index)+readArrayValue (F16ArrayValues values) index =+ FloatValue . Float16Value <$> liftIO (MSVec.read values index)+readArrayValue (F32ArrayValues values) index =+ FloatValue . Float32Value <$> liftIO (MSVec.read values index)+readArrayValue (F64ArrayValues values) index =+ FloatValue . Float64Value <$> liftIO (MSVec.read values index)+readArrayValue (BoolArrayValues values) index =+ BoolValue <$> liftIO (MSVec.read values index)+readArrayValue (UnitArrayValues values) index =+ UnitValue <$ liftIO (MSVec.read values index)++writeArrayValue :: ArrayValues -> Int -> PrimValue -> InterpM rep ()+writeArrayValue (I8ArrayValues values) index (IntValue (Int8Value element)) =+ liftIO $ MSVec.write values index element+writeArrayValue (I16ArrayValues values) index (IntValue (Int16Value element)) =+ liftIO $ MSVec.write values index element+writeArrayValue (I32ArrayValues values) index (IntValue (Int32Value element)) =+ liftIO $ MSVec.write values index element+writeArrayValue (I64ArrayValues values) index (IntValue (Int64Value element)) =+ liftIO $ MSVec.write values index element+writeArrayValue (F16ArrayValues values) index (FloatValue (Float16Value element)) =+ liftIO $ MSVec.write values index element+writeArrayValue (F32ArrayValues values) index (FloatValue (Float32Value element)) =+ liftIO $ MSVec.write values index element+writeArrayValue (F64ArrayValues values) index (FloatValue (Float64Value element)) =+ liftIO $ MSVec.write values index element+writeArrayValue (BoolArrayValues values) index (BoolValue element) =+ liftIO $ MSVec.write values index element+writeArrayValue (UnitArrayValues values) index UnitValue =+ liftIO $ MSVec.write values index ()+writeArrayValue _ _ _ =+ error "array element type mismatch"++cloneArrayValues :: ArrayValues -> IO ArrayValues+cloneArrayValues (I8ArrayValues values) = I8ArrayValues <$> MSVec.clone values+cloneArrayValues (I16ArrayValues values) = I16ArrayValues <$> MSVec.clone values+cloneArrayValues (I32ArrayValues values) = I32ArrayValues <$> MSVec.clone values+cloneArrayValues (I64ArrayValues values) = I64ArrayValues <$> MSVec.clone values+cloneArrayValues (F16ArrayValues values) = F16ArrayValues <$> MSVec.clone values+cloneArrayValues (F32ArrayValues values) = F32ArrayValues <$> MSVec.clone values+cloneArrayValues (F64ArrayValues values) = F64ArrayValues <$> MSVec.clone values+cloneArrayValues (BoolArrayValues values) = BoolArrayValues <$> MSVec.clone values+cloneArrayValues (UnitArrayValues values) = UnitArrayValues <$> MSVec.clone values++evalStms :: FunEnv rep -> Env -> Stms rep -> InterpM rep Env+evalStms funs env stms =+ foldM (evalStm funs) env (stmsToList stms)++evalBody :: FunEnv rep -> Env -> Body rep -> InterpM rep [Val]+evalBody funs env (Body _ stms results) = do+ env' <- evalStms funs env stms+ mapM (evalSubExp env' . resSubExp) results++evalKernelBody ::+ FunEnv rep -> Env -> Seg.KernelBody rep -> InterpM rep [KernelResultValue]+evalKernelBody funs env (Body _ stms results) = do+ env' <- evalStms funs env stms+ mapM (evalKernelResult env') results+ where+ evalKernelResult env' (Seg.Returns _ _ result) =+ KernelValue <$> evalSubExp env' result+ evalKernelResult env' (Seg.TileReturns _ dimensions tile) =+ KernelTile <$> mapM (evalPair env') dimensions <*> evalVar env' tile+ evalKernelResult env' (Seg.RegTileReturns _ dimensions tile) =+ KernelRegTile <$> mapM (evalTriple env') dimensions <*> evalVar env' tile++ evalPair env' (size, tile_size) =+ (,) <$> evalInt env' size <*> evalInt env' tile_size+ evalTriple env' (size, block_tile, reg_tile) =+ (,,)+ <$> evalInt env' size+ <*> evalInt env' block_tile+ <*> evalInt env' reg_tile++-- Evaluate the expression then bind the pattern names to its results+evalStm :: FunEnv rep -> Env -> Stm rep -> InterpM rep Env+evalStm funs env (Let pat aux expression) = do+ vals <-+ evalExp funs env expression `catchError` \err ->+ interpError $ addProvenance (stmAuxLoc aux) err++ let names = map patElemName $ patElems pat+ pure $ M.union (M.fromList $ zip names vals) env++addProvenance :: Provenance -> T.Text -> T.Text+addProvenance (Provenance locations location) message+ | location == mempty = message+ | otherwise =+ message+ <> "\n"+ <> prettyStacktrace+ 0+ (map locText $ location : reverse locations)++-- Produce one Val per pattern element the expression is expected to bind.+evalExp :: FunEnv rep -> Env -> Exp rep -> InterpM rep [Val]+evalExp _ env (BasicOp op) = evalBasicOp env op+evalExp funs env (Match ses cases default_body _) = do+ values <- mapM (evalSubExp env >=> expectPrimVal) ses+ evalBody funs env $ selectCase values cases+ where+ selectCase values (Case patterns body : remaining)+ | matches patterns values = body+ | otherwise = selectCase values remaining+ selectCase _ [] = default_body++ matches patterns values = and $ zipWith matchesValue patterns values++ matchesValue Nothing _ = True+ matchesValue (Just expected) actual = expected == actual+evalExp funs env (Loop params_and_inits (ForLoop iterator int_type bound_exp) body) = do+ initial_values <- mapM (evalSubExp env . snd) params_and_inits+ bound_value <- evalSubExp env bound_exp >>= expectPrimVal+ bound <- expectInt bound_value+ runIterations 0 bound initial_values+ where+ param_names = map (paramName . fst) params_and_inits++ runIterations iteration bound current_values+ | iteration >= bound =+ pure current_values+ | otherwise = do+ let iterator_value =+ PrimVal $ IntValue $ P.intValue int_type iteration+ loop_bindings =+ M.fromList $+ (iterator, iterator_value)+ : zip param_names current_values+ iteration_env =+ M.union loop_bindings env++ next_values <- evalBody funs iteration_env body+ runIterations (iteration + 1) bound next_values+evalExp funs env (Loop params_and_inits (WhileLoop condition) body) = do+ initial_values <- mapM (evalSubExp env . snd) params_and_inits+ runWhile initial_values+ where+ param_names = map (paramName . fst) params_and_inits++ runWhile current_values = do+ let loop_env =+ M.union+ (M.fromList $ zip param_names current_values)+ env++ condition_value <- evalVar loop_env condition++ case condition_value of+ PrimVal (BoolValue False) ->+ pure current_values+ PrimVal (BoolValue True) ->+ runWhile =<< evalBody funs loop_env body+ _ ->+ error "while-loop condition is not boolean"+evalExp funs env (Apply fname args _ _) = do+ arg_vals <- mapM (evalSubExp env . fst) args++ case M.lookup fname funs of+ Just callee ->+ let bindings = M.fromList $ zip (map paramName $ funDefParams callee) arg_vals+ in evalBody funs (M.union bindings env) (funDefBody callee)+ Nothing ->+ evalPrimitiveFunction fname arg_vals+evalExp funs env (Op op) = do+ eval_op <- asks interpOpEvaluator+ eval_op funs env op -- map/reduction/scan+evalExp funs env (WithAcc inputs lambda) =+ evalWithAcc funs env inputs lambda++evalPrimitiveFunction ::+ Name ->+ [Val] ->+ InterpM rep [Val]+evalPrimitiveFunction fname args =+ case M.lookup (nameToText fname) P.primFuns of+ Nothing ->+ error $ "function not found: " <> prettyString fname+ Just (_, _, function) -> do+ values <- mapM expectPrimVal args+ case function values of+ Just result -> pure [PrimVal result]+ Nothing ->+ error $ "invalid arguments to primitive function: " <> prettyString fname++evalWithAcc ::+ FunEnv rep ->+ Env ->+ [WithAccInput rep] ->+ Lambda rep ->+ InterpM rep [Val]+evalWithAcc funs env inputs lambda = do+ evaluated_inputs <- mapM evaluateInput inputs++ let accumulator_count = length inputs+ (certificate_params, accumulator_params) =+ splitAt accumulator_count $ lambdaParams lambda+ certificates = map paramName certificate_params+ accumulators = zipWith mkAccumulator certificates evaluated_inputs+ operators =+ M.fromList . mapMaybe accOperator $ zip certificates evaluated_inputs+ -- Certificates are bound to their accumulator so that zero-iteration+ -- maps can recover it from the result type 'Acc c ...'.+ bindings =+ M.fromList $+ zip certificates accumulators+ <> zip (map paramName accumulator_params) accumulators++ results <-+ local (withAccOps operators) $+ evalBody funs (M.union bindings env) (lambdaBody lambda)+ pure $+ concatMap (\(_, arrays, _) -> arrays) evaluated_inputs+ <> drop accumulator_count results+ where+ mkAccumulator certificate (index_shape, arrays, _) =+ AccValue $ Accumulator certificate index_shape arrays++ accOperator (certificate, (_, _, Just (operator_lambda, _))) =+ Just (certificate, (funs, env, operator_lambda))+ accOperator _ = Nothing++ withAccOps new_operators interp_env =+ interp_env {interpAccOps = new_operators <> interpAccOps interp_env}++ evaluateInput (shape, array_names, operator) = do+ index_shape <- evalShape env shape+ arrays <- mapM (evalVar env) array_names+ pure (index_shape, arrays, operator)++evalVar :: Env -> VName -> InterpM rep Val+evalVar env v =+ maybe (error $ "unbound variable: " <> prettyString v) pure $ M.lookup v env++evalSubExp :: Env -> SubExp -> InterpM rep Val+evalSubExp _ (Constant pv) = pure $ PrimVal pv+evalSubExp env (Var v) = evalVar env v++expectPrimVal :: Val -> InterpM rep PrimValue+expectPrimVal (PrimVal pv) = pure pv+expectPrimVal _ = error "expected a primitive value"++expectInt :: PrimValue -> InterpM rep Int+expectInt (IntValue i) = pure $ P.valueIntegral i+expectInt _ = error "expected an integer value"++evalInt :: Env -> SubExp -> InterpM rep Int+evalInt env = evalSubExp env >=> expectPrimVal >=> expectInt++-- Safe division-like operations yield zero on a zero divisor, like the code generators.+evalBinOp :: BinOp -> PrimValue -> PrimValue -> Maybe PrimValue+evalBinOp op x y+ | safeDivision op, P.zeroIsh y = Just $ P.blankPrimValue $ P.binOpType op+ | otherwise = P.doBinOp op x y+ where+ safeDivision (UDiv _ Safe) = True+ safeDivision (UCeilDiv _ Safe) = True+ safeDivision (SDiv _ Safe) = True+ safeDivision (SCeilDiv _ Safe) = True+ safeDivision (UMod _ Safe) = True+ safeDivision (SMod _ Safe) = True+ safeDivision (SQuot _ Safe) = True+ safeDivision (SRem _ Safe) = True+ safeDivision _ = False++evalBasicOp :: Env -> BasicOp -> InterpM rep [Val]+evalBasicOp env (SubExp se) = pure <$> evalSubExp env se+evalBasicOp env (BinOp op x y) = do+ xv <- expectPrimVal =<< evalSubExp env x+ yv <- expectPrimVal =<< evalSubExp env y+ case evalBinOp op xv yv of+ Just result -> pure [PrimVal result]+ Nothing -> interpError "invalid binary operation"+evalBasicOp env (UnOp op x) = do+ xv <- expectPrimVal =<< evalSubExp env x+ case P.doUnOp op xv of+ Just result -> pure [PrimVal result]+ Nothing -> error "invalid unary operation"+evalBasicOp env (CmpOp op x y) = do+ xv <- expectPrimVal =<< evalSubExp env x+ yv <- expectPrimVal =<< evalSubExp env y+ case P.doCmpOp op xv yv of+ Just result -> pure [PrimVal $ BoolValue result]+ Nothing -> error "invalid comparison operation"+evalBasicOp env (ConvOp op x) = do+ xv <- expectPrimVal =<< evalSubExp env x+ case P.doConvOp op xv of+ Just result -> pure [PrimVal result]+ Nothing -> error "invalid conversion operation"+evalBasicOp env (ArrayLit elements (Prim element_type)) = do+ values <- mapM (evalSubExp env) elements+ primitive_values <- mapM expectPrimVal values+ pure <$> newArrayValue [length elements] element_type primitive_values+evalBasicOp env (ArrayLit elements (Array element_type row_shape_exps _)) = do+ row_shape <- evalShape env row_shape_exps+ rows <- mapM (evalSubExp env) elements+ row_values <- mapM valElements rows+ pure+ <$> newArrayValue+ (length elements : row_shape)+ element_type+ (concat row_values)+evalBasicOp _ (ArrayLit _ Acc {}) =+ error "accumulator array literals are not implemented"+evalBasicOp _ (ArrayLit _ Mem {}) =+ error "memory array literals are unsupported"+evalBasicOp _ (ArrayVal values element_type) =+ pure <$> newArrayValue [length values] element_type values+evalBasicOp env (Assert condition message) = do+ condition_value <- evalSubExp env condition >>= expectPrimVal+ case condition_value of+ BoolValue True -> pure [PrimVal UnitValue]+ BoolValue False -> interpError =<< evalErrorMsg env message+ _ -> error "assert condition is not boolean"+evalBasicOp env (Index array_name slice_exp) = do+ array <- evalVar env array_name+ slice <- evalSlice env slice_exp+ case array of+ ArrayValue shape values ->+ pure <$> indexArray shape values slice+ _ ->+ error "cannot index a non-array value"+evalBasicOp env (Reshape array_name reshape) = do+ array <- evalVar env array_name+ dimensions <- evalShape env $ newShape reshape+ case array of+ ArrayValue old_shape values ->+ case reshapeKind reshape of+ ReshapeCoerce+ | dimensions == old_shape ->+ pure [ArrayValue dimensions values]+ | otherwise ->+ error "coercion to a different shape"+ ReshapeArbitrary+ | product dimensions == arrayValuesLength values ->+ pure [ArrayValue dimensions values]+ | otherwise ->+ error "reshape element count mismatch"+ _ ->+ error "cannot reshape a non-array value"+evalBasicOp env (Opaque OpaqueNil se) =+ pure <$> evalSubExp env se+evalBasicOp env (Opaque (OpaqueTrace t) se) = do+ liftIO $ TIO.hPutStrLn stderr t+ pure <$> evalSubExp env se+evalBasicOp env (Manifest array_name _) = do+ array <- evalVar env array_name+ case array of+ ArrayValue shape values ->+ pure . ArrayValue shape <$> liftIO (cloneArrayValues values)+ _ ->+ error "cannot manifest a non-array value"+evalBasicOp env (Iota count_sub_exp start_sub_exp stride_sub_exp int_type) = do+ count <- evalInt env count_sub_exp+ stride <- evalInt env stride_sub_exp+ start <- evalInt env start_sub_exp++ if count < 0+ then interpError "iota length cannot be negative"+ else do+ let values = do+ i <- [0 .. count - 1]+ pure $ IntValue $ P.intValue int_type $ start + i * stride+ pure <$> newArrayValue [count] (IntType int_type) values+evalBasicOp env (Replicate (Shape shape_exps) val_exp) = do+ dimensions <- mapM (evalInt env) shape_exps+ if any (< 0) dimensions+ then interpError " replicate dimensions cannot be negative"+ else do+ val <- evalSubExp env val_exp+ let copies = product dimensions++ case (dimensions, val) of+ ([], ArrayValue shape values) ->+ pure . ArrayValue shape <$> liftIO (cloneArrayValues values)+ ([], _) -> pure [val]+ (_, PrimVal primitive_value) ->+ pure <$> newArrayValue dimensions (P.primValueType primitive_value) (replicate copies primitive_value)+ (_, ArrayValue old_shape values) -> do+ primitive_values <- arrayValues values+ pure <$> newArrayValue (dimensions <> old_shape) (arrayValuesType values) (concat $ replicate copies primitive_values)+ (_, AccValue {}) ->+ error "cannot replicate an accumulator value"+evalBasicOp env (Rearrange array_name permutation) = do+ array <- evalVar env array_name+ case array of+ ArrayValue old_shape values -> do+ let new_shape = rearrangeShape permutation old_shape+ oldCoordinate = rearrangeShape $ rearrangeInverse permutation+ new_values <-+ mapM+ (readArrayValue values . linearIndex old_shape . oldCoordinate)+ (allCoordinates new_shape)+ pure <$> newArrayValue new_shape (arrayValuesType values) new_values+ _ -> error "cannot rearrange a non-array value"+evalBasicOp env (Concat concat_dim array_names result_size_exp) = do+ arrays <- mapM lookupArray $ NE.toList array_names+ declared_size <- evalInt env result_size_exp++ case arrays of+ [] ->+ error "concat requires at least one array"+ (first_shape, first_values) : _+ | declared_size /= actualSize arrays ->+ error "concat result size mismatch"+ | otherwise -> do+ let result_shape =+ replaceAt concat_dim declared_size first_shape++ result_values <- mapM (valueAt arrays) $ allCoordinates result_shape+ pure <$> newArrayValue result_shape (arrayValuesType first_values) result_values+ where+ lookupArray name = do+ array <- evalVar env name+ case array of+ ArrayValue shape values -> pure (shape, values)+ _ -> error "cannot concatenate a non-array value"++ actualSize =+ sum . map ((!! concat_dim) . fst)++ valueAt arrays coordinate = do+ let concat_index = coordinate !! concat_dim+ (source_shape, source_values, local_index) =+ findSource concat_index arrays+ source_coordinate =+ replaceAt concat_dim local_index coordinate+ offset =+ linearIndex source_shape source_coordinate++ readArrayValue source_values offset++ findSource _ [] =+ error "invalid concat coordinate"+ findSource index ((shape, values) : arrays)+ | index < size =+ (shape, values, index)+ | otherwise =+ findSource (index - size) arrays+ where+ size = shape !! concat_dim+evalBasicOp env (Update safety array_name slice_exp value_exp) = do+ array <- evalVar env array_name+ slice <- evalSlice env slice_exp+ replacement <- evalSubExp env value_exp++ case array of+ ArrayValue shape values -> do+ in_bounds <-+ case safety of+ Safe -> pure $ sliceInBounds shape slice+ Unsafe -> True <$ checkSlice shape slice+ when in_bounds $ do+ replacement_values <- valElements replacement+ zipWithM_+ (writeArrayValue values)+ (map (linearIndex shape) $ sliceCoordinates slice)+ replacement_values+ pure [array]+ _ ->+ error "cannot update a non-array value"+evalBasicOp env (FlatIndex array_name flat_slice) = do+ array <- evalVar env array_name+ (result_shape, offsets) <- evalFlatSlice env flat_slice++ case array of+ ArrayValue _ values -> do+ selected_values <- mapM (readArrayValue values) offsets+ case (result_shape, selected_values) of+ ([], [primitive_value]) -> pure [PrimVal primitive_value]+ ([], _) -> error "invalid scalar flat index"+ _ -> pure <$> newArrayValue result_shape (arrayValuesType values) selected_values+ _ ->+ error "cannot flat-index a non-array value"+evalBasicOp env (FlatUpdate source_name flat_slice replacement_name) = do+ source <- evalVar env source_name+ replacement <- evalVar env replacement_name+ (_, offsets) <- evalFlatSlice env flat_slice+ case source of+ ArrayValue _ source_values+ | not $ all (validOffset source_values) offsets ->+ interpError "flat update out of bounds"+ | otherwise -> do+ replacement_values <- valElements replacement+ zipWithM_ (writeArrayValue source_values) offsets replacement_values+ pure [source]+ _ ->+ error "cannot flat-update a non-array value"+ where+ validOffset values offset =+ offset >= 0 && offset < arrayValuesLength values+evalBasicOp env (Scratch element_type dimension_exps) = do+ dimensions <- mapM (evalInt env) dimension_exps+ if any (< 0) dimensions+ then interpError "scratch dimensions cannot be negative"+ else+ let element_count = product dimensions+ blank_value = P.blankPrimValue element_type+ in pure <$> newArrayValue dimensions element_type (replicate element_count blank_value)+evalBasicOp env (UserParam _ default_sub_exp) =+ pure <$> evalSubExp env default_sub_exp+evalBasicOp env (UpdateAcc safety accumulator_name index_exps value_exps) =+ evalUpdateAcc env safety accumulator_name index_exps value_exps++evalUpdateAcc ::+ Env ->+ Safety ->+ VName ->+ [SubExp] ->+ [SubExp] ->+ InterpM rep [Val]+evalUpdateAcc env safety accumulator_name index_exps value_exps = do+ accumulator <- evalVar env accumulator_name+ indices <- mapM (evalInt env) index_exps+ values <- mapM (evalSubExp env) value_exps++ case accumulator of+ AccValue acc -> do+ updateAccumulator acc indices values+ pure [accumulator]+ _ ->+ error "UpdateAcc argument is not an accumulator"+ where+ updateAccumulator acc indices new_values+ | not $ indicesInBounds (accShape acc) indices =+ case safety of+ Safe -> pure ()+ Unsafe -> interpError "unsafe accumulator update out of bounds"+ | otherwise = do+ operator <- asks $ M.lookup (accCert acc) . interpAccOps+ replacement_values <-+ case operator of+ Nothing -> pure new_values+ Just (operator_funs, operator_env, operator_lambda) -> do+ old_values <-+ mapM (readAccumulatorElement indices) $ accArrays acc+ evalLambda operator_funs operator_env operator_lambda $+ map int64Val indices <> old_values <> new_values++ zipWithM_+ (writeAccumulatorElementInPlace indices)+ (accArrays acc)+ replacement_values++ indicesInBounds shape indices =+ and $ zipWith (\size index -> index >= 0 && index < size) shape indices++evalErrorMsg :: Env -> ErrorMsg SubExp -> InterpM rep T.Text+evalErrorMsg env (ErrorMsg parts) = do+ evaluatedParts <- mapM evalPart parts+ pure $ T.concat ("Error " : evaluatedParts)+ where+ evalPart (ErrorString text) = pure text+ evalPart (ErrorVal _ sub_exp) =+ renderErrorValue <$> (evalSubExp env sub_exp >>= expectPrimVal)++renderErrorValue :: PrimValue -> T.Text+renderErrorValue (IntValue val) =+ showText (P.valueIntegral val :: Integer)+renderErrorValue (FloatValue (Float16Value val)) =+ showText val+renderErrorValue (FloatValue (Float32Value val)) =+ showText val+renderErrorValue (FloatValue (Float64Value val)) =+ showText val+renderErrorValue (BoolValue True) = "true"+renderErrorValue (BoolValue False) = "false"+renderErrorValue UnitValue = "()"++evalFlatSlice :: Env -> FlatSlice SubExp -> InterpM rep ([Int], [Int])+evalFlatSlice env (FlatSlice offset_exp dimensions) = do+ offset <- evalInt env offset_exp+ evaluated_dimensions <- mapM evalDimension dimensions++ let result_shape = map fst evaluated_dimensions+ strides = map snd evaluated_dimensions+ offsets = map ((offset +) . sum . zipWith (*) strides) $ allCoordinates result_shape+ if any (< 0) result_shape+ then interpError "flat slice dimensions cannot be negative"+ else pure (result_shape, offsets)+ where+ evalDimension (FlatDimIndex size_exp stride_exp) = do+ size <- evalInt env size_exp+ stride <- evalInt env stride_exp+ pure (size, stride)++replaceAt :: Int -> a -> [a] -> [a]+replaceAt index val xs =+ take index xs <> [val] <> drop (index + 1) xs++-- The elements of a value in row-major order.+valElements :: Val -> InterpM rep [PrimValue]+valElements (PrimVal primitive_value) = pure [primitive_value]+valElements (ArrayValue _ values) = arrayValues values+valElements AccValue {} = error "accumulators have no elements"++-- All coordinates of an array with the given shape, in row-major order.+allCoordinates :: [Int] -> [[Int]]+allCoordinates = mapM $ \size -> [0 .. size - 1]++evalSlice :: Env -> Slice SubExp -> InterpM rep (Slice Int)+evalSlice env = traverse $ evalInt env++sliceInBounds :: [Int] -> Slice Int -> Bool+sliceInBounds shape (Slice dimensions) =+ and $ zipWith dimensionInBounds shape dimensions+ where+ dimensionInBounds size (DimFix index) =+ validIndex size index+ dimensionInBounds size (DimSlice start count stride) =+ count == 0+ || (count > 0 && validIndex size start && validIndex size (start + (count - 1) * stride))++ validIndex size index = index >= 0 && index < size++checkSlice :: [Int] -> Slice Int -> InterpM rep ()+checkSlice shape slice+ | any (< 0) $ sliceDims slice =+ interpError "slice length cannot be negative"+ | not $ sliceInBounds shape slice =+ interpError "array index out of bounds"+ | otherwise =+ pure ()++-- The coordinates in the source array selected by a slice, in row-major order+-- of the result.+sliceCoordinates :: Slice Int -> [[Int]]+sliceCoordinates slice =+ map (fixSlice slice) $ allCoordinates $ sliceDims slice++indexArray :: [Int] -> ArrayValues -> Slice Int -> InterpM rep Val+indexArray shape values slice = do+ checkSlice shape slice+ selected_values <-+ mapM (readArrayValue values . linearIndex shape) $ sliceCoordinates slice+ case (sliceDims slice, selected_values) of+ ([], [primitive_value]) -> pure $ PrimVal primitive_value+ ([], _) -> error "invalid scalar index"+ (result_shape, _) ->+ newArrayValue result_shape (arrayValuesType values) selected_values++linearIndex :: [Int] -> [Int] -> Int+linearIndex shape indices =+ foldl (\acc (dim_size, index) -> acc * dim_size + index) 0 $ zip shape indices++evalSOAC :: FunEnv rep -> Env -> SOAC rep -> InterpM rep [Val]+evalSOAC funs env (Screma width_exp input_names form) =+ evalScrema funs env width_exp input_names form+evalSOAC funs env (Stream width_exp input_names initial_accumulators lambda) =+ evalStream funs env width_exp input_names initial_accumulators lambda+evalSOAC funs env (Hist width_exp input_names hist_ops lambda) = evalHist funs env width_exp input_names hist_ops lambda+evalSOAC funs env (FlatMap width_exp input_names lambda) = evalFlatMap funs env width_exp input_names lambda+evalSOAC _ _ JVP {} = error "evalSOAC: JVP is not implemented"+evalSOAC _ _ VJP {} = error "evalSOAC: VJP is not implemented"+evalSOAC _ _ WithVJP {} = error "evalSOAC: WithVJP is not implemented"++evalFlatMap ::+ FunEnv rep ->+ Env ->+ SubExp ->+ [VName] ->+ ExtLambda rep ->+ InterpM rep [Val]+evalFlatMap funs env width_exp input_names lambda = do+ width <- evalInt env width_exp+ inputs <- mapM (evalVar env) input_names+ rows <- mapM (runIteration inputs) [0 .. width - 1]+ let sizes = map fst rows+ value_rows = map snd rows+ offsets = init $ scanl (+) 0 sizes+ total_size = sum sizes+ return_types = drop 1 $ lambdaReturnType lambda+ columns+ | null value_rows = replicate (length return_types) []+ | otherwise = L.transpose value_rows+ values <-+ zipWithM+ (collectFlatMapOutput env total_size)+ return_types+ columns+ let flags = concatMap segmentFlags sizes+ sizes_array <- newArrayValue [width] int64_type $ map int64Prim sizes+ flags_array <- newArrayValue [total_size] Bool $ map BoolValue flags+ offsets_array <- newArrayValue [width] int64_type $ map int64Prim offsets++ pure $+ [int64Val total_size, sizes_array, flags_array, offsets_array]+ <> values+ where+ runIteration inputs index = do+ input_rows <- mapM (rowAt index) inputs+ results <- evalLambda funs env lambda input_rows++ case results of+ size_value : values -> do+ size <- expectPrimVal size_value >>= expectInt+ if size < 0+ then interpError "FlatMap segment size cannot be negative"+ else pure (size, values)+ [] ->+ error "FlatMap lambda returned no segment size"++ segmentFlags size+ | size > 0 = True : replicate (size - 1) False+ | otherwise = []++ int64_type = IntType Int64+ int64Prim = IntValue . Int64Value . fromIntegral++evalHist ::+ FunEnv rep ->+ Env ->+ SubExp ->+ [VName] ->+ [HistOp rep] ->+ Lambda rep ->+ InterpM rep [Val]+evalHist funs env width_exp input_names hist_ops bucket_lambda = do+ width <- evalInt env width_exp+ inputs <- mapM (evalVar env) input_names+ initial_histograms <- mapM (mapM (evalVar env) . histDest) hist_ops+ final_histograms <-+ foldM+ (runIteration inputs)+ initial_histograms+ [0 .. width - 1]++ pure $ concat final_histograms+ where+ index_counts = map (shapeRank . histShape) hist_ops+ value_counts = map (length . histDest) hist_ops++ runIteration inputs histograms iteration = do+ input_rows <- mapM (rowAt iteration) inputs+ bucket_results <- evalLambda funs env bucket_lambda input_rows++ let (index_groups, remaining) = splitGroups index_counts bucket_results+ (value_groups, _) = splitGroups value_counts remaining++ index_groups' <-+ mapM+ (mapM (expectPrimVal >=> expectInt))+ index_groups++ forM (zip3 hist_ops index_groups' (zip value_groups histograms)) $+ \(hist_operation, indices, value_and_histograms) ->+ updateHistogram hist_operation indices value_and_histograms++ updateHistogram hist_operation indices (values, histograms)+ | not (inBounds indices histograms) =+ pure histograms+ | otherwise = do+ old_bins <- mapM (readHistogramBin indices) histograms+ new_bins <-+ evalLambda funs env (histOp hist_operation) (old_bins <> values)+ zipWithM (writeHistogramBin indices) histograms new_bins++ inBounds indices histograms =+ case histograms of+ [] -> False+ ArrayValue shape _ : _ ->+ length indices <= length shape+ && and (zipWith validIndex indices shape)+ _ -> False++ validIndex index dimension =+ index >= 0 && index < dimension++evalStream :: FunEnv rep -> Env -> SubExp -> [VName] -> [SubExp] -> Lambda rep -> InterpM rep [Val]+evalStream funs env width_exp input_names initial_accumulators lambda = do+ width <- evalSubExp env width_exp+ inputs <- mapM (evalVar env) input_names+ accumulators <- mapM (evalSubExp env) initial_accumulators+ evalLambda funs env lambda $ width : accumulators <> inputs++evalScrema :: FunEnv rep -> Env -> SubExp -> [VName] -> ScremaForm rep -> InterpM rep [Val]+evalScrema funs env width_exp input_names (ScremaForm pre_lambda scans reductions post_lambda) = do+ width <- evalInt env width_exp+ inputs <- mapM (evalVar env) input_names+ initial_scan_states <- mapM (mapM (evalSubExp env) . scanNeutral) scans+ initial_reduction_states <- mapM (mapM (evalSubExp env) . redNeutral) reductions+ (_, final_reduction_states, reversed_output_rows) <-+ foldM+ (runIteration inputs)+ (initial_scan_states, initial_reduction_states, [])+ [0 .. width - 1]+ collected_outputs <-+ collectScremaOutputs+ env+ width+ (lambdaReturnType post_lambda)+ (reverse reversed_output_rows)++ pure $ concat final_reduction_states <> collected_outputs+ where+ scan_sizes =+ map (length . scanNeutral) scans+ reduction_sizes =+ map (length . redNeutral) reductions++ runIteration+ inputs+ (scan_states, reduction_states, output_rows)+ index = do+ input_rows <- mapM (rowAt index) inputs+ pre_results <- evalLambda funs env pre_lambda input_rows+ let (scan_contributions, after_scans) = splitGroups scan_sizes pre_results+ (reduction_contributions, map_values) = splitGroups reduction_sizes after_scans+ next_scan_states <- updateScanStates funs env scans scan_states scan_contributions+ next_reduction_states <- updateReductionStates funs env reductions reduction_states reduction_contributions+ post_results <- evalLambda funs env post_lambda (concat next_scan_states <> map_values)+ pure (next_scan_states, next_reduction_states, post_results : output_rows)++int64Val :: Int -> Val+int64Val = PrimVal . IntValue . Int64Value . fromIntegral++evalSegSpace :: FunEnv rep -> M.Map VName Val -> Seg.SegSpace -> Seg.KernelBody rep -> InterpM rep ([Int], [([Int], [KernelResultValue])])+evalSegSpace funs env space@(Seg.SegSpace _ dimensions) body = do+ sizes <- mapM (evalInt env . snd) dimensions+ rows <- mapM (runWorker sizes) $ allCoordinates sizes+ pure (sizes, rows)+ where+ runWorker sizes coordinate = do+ let worker_env = segSpaceEnv env space sizes coordinate+ values <- evalKernelBody funs worker_env body+ pure (coordinate, values)++segSpaceEnv :: Env -> Seg.SegSpace -> [Int] -> [Int] -> Env+segSpaceEnv env (Seg.SegSpace flat dimensions) shape coordinate =+ M.union bindings env+ where+ bindings =+ M.fromList $+ (flat, int64Val $ linearIndex shape coordinate)+ : zip (map fst dimensions) (map int64Val coordinate)++evalShape :: Env -> Shape -> InterpM rep [Int]+evalShape env = mapM (evalInt env) . shapeDims++expectKernelValue :: KernelResultValue -> InterpM rep Val+expectKernelValue (KernelValue result_value) = pure result_value+expectKernelValue KernelTile {} =+ error "TileReturns cannot be used as a segmented contribution"+expectKernelValue KernelRegTile {} =+ error "RegTileReturns cannot be used as a segmented contribution"++segmentRows :: Int -> Int -> [a] -> [[a]]+segmentRows segment_count segment_width =+ go segment_count+ where+ go remaining rows+ | remaining <= 0 = []+ | otherwise =+ let (segment, rest) = splitAt segment_width rows+ in segment : go (remaining - 1) rest++splitSegContributions :: [Seg.SegBinOp rep] -> [Val] -> [[Val]]+splitSegContributions operators =+ fst . splitGroups (map (length . Seg.segBinOpNeutral) operators)++initialSegBinOp ::+ Env ->+ Seg.SegBinOp rep ->+ InterpM rep [Val]+initialSegBinOp env operator = do+ neutral <- mapM (evalSubExp env) $ Seg.segBinOpNeutral operator+ vector_shape <- evalShape env $ Seg.segBinOpShape operator++ if null vector_shape+ then pure neutral+ else+ collectOutputs+ env+ vector_shape+ (lambdaReturnType $ Seg.segBinOpLambda operator)+ (replicate (product vector_shape) neutral)++applySegBinOp ::+ FunEnv rep ->+ Env ->+ Seg.SegBinOp rep ->+ [Val] ->+ [Val] ->+ InterpM rep [Val]+applySegBinOp funs env operator state contribution = do+ vector_shape <- evalShape env $ Seg.segBinOpShape operator+ let operator_lambda = Seg.segBinOpLambda operator++ if null vector_shape+ then evalLambda funs env operator_lambda $ state <> contribution+ else do+ result_rows <-+ forM (allCoordinates vector_shape) $ \coordinate -> do+ state_elements <-+ mapM (readAccumulatorElement coordinate) state+ contribution_elements <-+ mapM (readAccumulatorElement coordinate) contribution+ evalLambda+ funs+ env+ operator_lambda+ (state_elements <> contribution_elements)++ collectOutputs+ env+ vector_shape+ (lambdaReturnType operator_lambda)+ result_rows++initialSegStates ::+ Env ->+ [Seg.SegBinOp rep] ->+ InterpM rep [[Val]]+initialSegStates env =+ mapM $ initialSegBinOp env++updateSegStates ::+ FunEnv rep ->+ Env ->+ [Seg.SegBinOp rep] ->+ [[Val]] ->+ [[Val]] ->+ InterpM rep [[Val]]+updateSegStates funs env operators states contributions =+ forM (zip3 operators states contributions) $ \(operator, state, contribution) ->+ applySegBinOp funs env operator state contribution++evalSegOp ::+ FunEnv rep -> Env -> Seg.SegOp level rep -> InterpM rep [Val]+evalSegOp funs env (Seg.SegMap _ space types body) =+ evalSegMap funs env space types body+evalSegOp funs env (Seg.SegRed _ space types body operators) =+ evalSegRed funs env space types body operators+evalSegOp funs env (Seg.SegScan _ space _ body operators post_operator) =+ evalSegScan funs env space body operators post_operator+evalSegOp funs env (Seg.SegHist _ space _ body operators) =+ evalSegHist funs env space body operators++evalSegMap ::+ FunEnv rep ->+ Env ->+ Seg.SegSpace ->+ [Type] ->+ Seg.KernelBody rep ->+ InterpM rep [Val]+evalSegMap funs env space types body = do+ (shape, indexed_rows) <- evalSegSpace funs env space body+ collectSegOutputs env shape types (bodyResult body) indexed_rows++evalSegRed ::+ FunEnv rep ->+ Env ->+ Seg.SegSpace ->+ [Type] ->+ Seg.KernelBody rep ->+ [Seg.SegBinOp rep] ->+ InterpM rep [Val]+evalSegRed funs env space types body operators = do+ (shape, indexed_rows) <- evalSegSpace funs env space body++ let segment_shape = init shape+ segment_width = last shape+ segment_count = product segment_shape+ reduction_count = Seg.segBinOpResults operators+ reduction_types = take reduction_count types+ map_types = drop reduction_count types+ reduction_result_rows =+ map (take reduction_count . snd) indexed_rows++ reduction_rows <-+ mapM (mapM expectKernelValue) reduction_result_rows++ let segments =+ segmentRows+ segment_count+ segment_width+ reduction_rows++ reduced_rows <- mapM reduceSegment segments++ reduction_outputs <-+ collectOutputs+ env+ segment_shape+ reduction_types+ reduced_rows++ map_outputs <-+ collectSegOutputs+ env+ shape+ map_types+ (drop reduction_count $ bodyResult body)+ (map (fmap $ drop reduction_count) indexed_rows)++ pure $ reduction_outputs <> map_outputs+ where+ reduceSegment rows = do+ initial_states <- initialSegStates env operators+ final_states <- foldM reduceRow initial_states rows+ pure $ concat final_states++ reduceRow states values =+ updateSegStates funs env operators states $+ splitSegContributions operators values++evalSegScan ::+ FunEnv rep ->+ Env ->+ Seg.SegSpace ->+ Seg.KernelBody rep ->+ [Seg.SegBinOp rep] ->+ Seg.SegPostOp rep ->+ InterpM rep [Val]+evalSegScan funs env space body operators post_operator = do+ (shape, indexed_rows) <- evalSegSpace funs env space body+ worker_rows <- mapM evaluateWorker indexed_rows++ let segment_shape = init shape+ segment_width = last shape+ segment_count = product segment_shape+ segments =+ segmentRows+ segment_count+ segment_width+ worker_rows++ output_rows <- concat <$> mapM (scanSegment shape) segments++ collectOutputs+ env+ shape+ (lambdaReturnType post_lambda)+ output_rows+ where+ evaluateWorker (coordinate, values) = do+ values' <- mapM expectKernelValue values+ pure (coordinate, values')++ contribution_count = Seg.segBinOpResults operators+ post_lambda =+ Seg.segPostOpLambda post_operator+ scanSegment shape rows = do+ initial_states <- initialSegStates env operators+ (_, reversed_outputs) <-+ foldM+ (scanRow shape)+ (initial_states, [])+ rows+ pure $ reverse reversed_outputs++ scanRow shape (states, outputs) (coordinate, values) = do+ let (contribution_values, map_values) =+ splitAt contribution_count values++ next_states <-+ updateSegStates+ funs+ env+ operators+ states+ (splitSegContributions operators contribution_values)++ post_results <-+ evalLambda+ funs+ (segSpaceEnv env space shape coordinate)+ post_lambda+ (concat next_states <> map_values)++ pure (next_states, post_results : outputs)++evalSegHist ::+ FunEnv rep ->+ Env ->+ Seg.SegSpace ->+ Seg.KernelBody rep ->+ [Seg.HistOp rep] ->+ InterpM rep [Val]+evalSegHist funs env space body operators = do+ (_, indexed_rows) <- evalSegSpace funs env space body+ initial_histograms <- mapM (mapM (evalVar env) . Seg.histDest) operators+ final_histograms <- foldM updateFromWorker initial_histograms indexed_rows+ pure $ concat final_histograms+ where+ index_counts = map (shapeRank . Seg.histShape) operators+ value_counts = map (length . Seg.histDest) operators++ updateFromWorker histograms (coordinate, worker_values) = do+ let segment_indices = init coordinate++ worker_values' <- mapM expectKernelValue worker_values++ let (index_groups, remaining) = splitGroups index_counts worker_values'+ (value_groups, _) = splitGroups value_counts remaining++ evaluated_indices <-+ mapM (mapM (expectPrimVal >=> expectInt)) index_groups++ forM (zip3 operators evaluated_indices (zip value_groups histograms)) $+ \(operator, bucket_indices, values_and_histograms) ->+ updateHistogram+ segment_indices+ operator+ bucket_indices+ values_and_histograms++ updateHistogram+ segment_indices+ operator+ bucket_indices+ (new_values, histograms)+ | not $ indicesInBounds full_indices histograms =+ pure histograms+ | otherwise = do+ vector_shape <- evalShape env $ Seg.histOpShape operator+ old_values <- mapM (readHistogramBin full_indices) histograms++ replacement_values <-+ if null vector_shape+ then+ evalLambda+ funs+ env+ (Seg.histOp operator)+ (old_values <> new_values)+ else do+ result_rows <-+ forM (allCoordinates vector_shape) $ \coordinate -> do+ old_elements <-+ mapM (readAccumulatorElement coordinate) old_values+ new_elements <-+ mapM (readAccumulatorElement coordinate) new_values+ evalLambda+ funs+ env+ (Seg.histOp operator)+ (old_elements <> new_elements)++ collectOutputs+ env+ vector_shape+ (lambdaReturnType $ Seg.histOp operator)+ result_rows++ zipWithM+ (writeHistogramBin full_indices)+ histograms+ replacement_values+ where+ full_indices =+ segment_indices <> bucket_indices++ indicesInBounds indices =+ all $ histogramIndicesInBounds indices++ histogramIndicesInBounds+ indices+ (ArrayValue histogram_shape _) =+ length indices <= length histogram_shape+ && and+ (zipWith validIndex indices histogram_shape)+ histogramIndicesInBounds _ _ =+ False++ validIndex index dimension =+ index >= 0 && index < dimension++splitGroups :: [Int] -> [a] -> ([[a]], [a])+splitGroups [] values = ([], values)+splitGroups (size : sizes) values =+ let (group, rest) = splitAt size values+ (groups, remaining) = splitGroups sizes rest+ in (group : groups, remaining)++evalLambda ::+ FunEnv rep ->+ Env ->+ GLambda rep return_type ->+ [Val] ->+ InterpM rep [Val]+evalLambda funs env (Lambda params _ body) args =+ evalBody funs (M.union (M.fromList $ zip (map paramName params) args) env) body++updateScanStates ::+ FunEnv rep ->+ Env ->+ [Scan rep] ->+ [[Val]] ->+ [[Val]] ->+ InterpM rep [[Val]]+updateScanStates funs env scans states contributions =+ zipWithM updateOne scans (zip states contributions)+ where+ updateOne scan (state, contribution) =+ evalLambda funs env (scanLambda scan) (state <> contribution)++updateReductionStates ::+ FunEnv rep ->+ Env ->+ [Reduce rep] ->+ [[Val]] ->+ [[Val]] ->+ InterpM rep [[Val]]+updateReductionStates funs env reductions states contributions =+ zipWithM updateOne reductions (zip states contributions)+ where+ updateOne reduction (state, contribution) =+ evalLambda funs env (redLambda reduction) (state <> contribution)++rowAt :: Int -> Val -> InterpM rep Val+rowAt index (ArrayValue (_ : row_shape) values)+ | null row_shape =+ PrimVal <$> readArrayValue values index+ | otherwise = do+ let row_size = product row_shape+ offset = index * row_size+ row_values <-+ mapM (readArrayValue values) [offset .. offset + row_size - 1]+ newArrayValue row_shape (arrayValuesType values) row_values+rowAt _ accumulator@AccValue {} =+ pure accumulator+rowAt _ _ =+ error "cannot extract a row from this value"++readAccumulatorElement :: [Int] -> Val -> InterpM rep Val+readAccumulatorElement indices (ArrayValue shape values) = do+ let index_rank = length indices+ element_shape = drop index_rank shape+ element_size = product element_shape+ offset = linearIndex (take index_rank shape) indices * element_size+ case element_shape of+ [] -> PrimVal <$> readArrayValue values offset+ _ -> do+ element_values <- mapM (readArrayValue values) [offset .. offset + element_size - 1]+ newArrayValue element_shape (arrayValuesType values) element_values+readAccumulatorElement _ _ =+ error "accumulator backing value must be an array"++writeAccumulatorElementInPlace :: [Int] -> Val -> Val -> InterpM rep ()+writeAccumulatorElementInPlace indices (ArrayValue shape values) replacement = do+ let index_rank = length indices+ element_size = product $ drop index_rank shape+ offset = linearIndex (take index_rank shape) indices * element_size+ replacement_values <- valElements replacement+ zipWithM_ (writeArrayValue values) [offset ..] replacement_values+writeAccumulatorElementInPlace _ _ _ =+ error "accumulator backing value must be an array"++readHistogramBin :: [Int] -> Val -> InterpM rep Val+readHistogramBin indices (ArrayValue shape values) = do+ let rank = length indices+ bin_shape = drop rank shape+ bin_size = product bin_shape+ offset = linearIndex (take rank shape) indices * bin_size+ case bin_shape of+ [] -> PrimVal <$> readArrayValue values offset+ _ -> do+ bin_values <- mapM (readArrayValue values) [offset .. offset + bin_size - 1]+ newArrayValue bin_shape (arrayValuesType values) bin_values+readHistogramBin _ _ =+ error "Hist destination must be an array"++writeHistogramBin :: [Int] -> Val -> Val -> InterpM rep Val+writeHistogramBin indices histogram@(ArrayValue shape values) replacement = do+ let rank = length indices+ bin_size = product $ drop rank shape+ offset = linearIndex (take rank shape) indices * bin_size+ replacement_values <- valElements replacement+ zipWithM_ (writeArrayValue values) [offset ..] replacement_values+ pure histogram+writeHistogramBin _ _ _ =+ error "Hist destination must be an array"++collectFlatMapOutput ::+ Env ->+ Int ->+ ExtType ->+ [Val] ->+ InterpM rep Val+collectFlatMapOutput env total_size result_type rows+ | flatMapNonuniform result_type =+ case rows of+ ArrayValue (_ : row_shape) values : _ -> do+ element_values <- concat <$> mapM valElements rows+ newArrayValue (total_size : row_shape) (arrayValuesType values) element_values+ _ -> do+ (element_type, row_shape) <- emptyArrayType True+ newArrayValue (total_size : row_shape) element_type []+ | otherwise =+ case result_type of+ Prim element_type ->+ newArrayValue [length rows] element_type =<< mapM expectPrimVal rows+ Array element_type _ _ ->+ case rows of+ ArrayValue row_shape _ : _ -> do+ element_values <- concat <$> mapM valElements rows+ newArrayValue (length rows : row_shape) element_type element_values+ _ -> do+ (_, row_shape) <- emptyArrayType False+ newArrayValue (0 : row_shape) element_type []+ Acc {} ->+ error "FlatMap accumulator outputs are unsupported"+ Mem {} ->+ error "FlatMap memory outputs are unsupported"+ where+ emptyArrayType drop_existential =+ case result_type of+ Array element_type (Shape dimensions) _ -> do+ let dimensions'+ | drop_existential = drop 1 dimensions+ | otherwise = dimensions+ shape <- mapM evalFreeDimension dimensions'+ pure (element_type, shape)+ _ ->+ error "nonuniform FlatMap result must be an array"++ evalFreeDimension (Free dimension) =+ evalInt env dimension+ evalFreeDimension (Ext _) =+ error "unexpected existential FlatMap result dimension"++collectOutputs ::+ Env ->+ [Int] ->+ [Type] ->+ [[Val]] ->+ InterpM rep [Val]+collectOutputs env outer_shape return_types iteration_results =+ zipWithM collectOne return_types columns+ where+ columns+ | null iteration_results =+ replicate (length return_types) []+ | otherwise =+ L.transpose iteration_results++ collectOne (Prim element_type) rows = do+ values <- mapM expectPrimVal rows+ case (outer_shape, values) of+ ([], [val]) -> pure $ PrimVal val+ ([], _) -> error "invalid scalar output count"+ _ -> newArrayValue outer_shape element_type values+ collectOne (Array element_type annotated_shape _) [] = do+ row_shape <- evalShape env annotated_shape+ newArrayValue (outer_shape <> row_shape) element_type []+ collectOne (Array element_type _ _) rows@(ArrayValue row_shape _ : _) = do+ element_values <- concat <$> mapM valElements rows+ newArrayValue (outer_shape <> row_shape) element_type element_values+ collectOne Array {} _ =+ error "expected array output"+ collectOne (Acc certificate _ _) [] =+ expectAccValue =<< evalVar env certificate+ collectOne Acc {} (row : _) =+ pure row+ collectOne Mem {} _ =+ error "memory outputs are unsupported"++ expectAccValue accumulator@AccValue {} = pure accumulator+ expectAccValue _ = error "accumulator output has no backing storage"++collectScremaOutputs :: Env -> Int -> [Type] -> [[Val]] -> InterpM rep [Val]+collectScremaOutputs env width = collectOutputs env [width]++collectSegOutputs ::+ Env ->+ [Int] ->+ [Type] ->+ [Seg.KernelResult] ->+ [([Int], [KernelResultValue])] ->+ InterpM rep [Val]+collectSegOutputs env worker_shape return_types result_specs worker_rows+ | null worker_rows =+ zipWithM collectEmpty return_types result_specs+ | otherwise =+ zipWithM collectOne return_types columns+ where+ columns = do+ result_index <- [0 .. length return_types - 1]+ pure $ map (fmap (!! result_index)) worker_rows++ collectEmpty result_type result_spec = do+ output_shape <- resultShape result_spec+ collectOutputs env output_shape [result_type] [] >>= expectOne++ collectOne result_type rows =+ case rows of+ [] -> error "internal empty segmented output"+ (_, KernelValue {}) : _ -> do+ values <- mapM (expectOrdinary . snd) rows+ collectOutputs env worker_shape [result_type] (map pure values)+ >>= expectOne+ (_, KernelTile dimensions _) : _ -> do+ let output_shape = map fst dimensions+ tile_sizes = map snd dimensions+ collectTiled+ result_type+ output_shape+ rows+ (tileSourceIndices tile_sizes)+ (_, KernelRegTile dimensions _) : _ -> do+ let output_shape = map firstOf3 dimensions+ block_sizes = map secondOf3 dimensions+ reg_sizes = map thirdOf3 dimensions+ collectTiled+ result_type+ output_shape+ rows+ (regTileSourceIndices block_sizes reg_sizes)++ collectTiled result_type output_shape rows source_indices = do+ values <-+ mapM (tiledValueAt rows source_indices) $ allCoordinates output_shape+ collectOutputs env output_shape [result_type] (map pure values)+ >>= expectOne++ tiledValueAt rows source_indices output_coordinate = do+ let (worker_coordinate, source_coordinate) =+ source_indices output_coordinate+ tile = case lookup worker_coordinate rows of+ Just (KernelTile _ tile_value) -> tile_value+ Just (KernelRegTile _ tile_value) -> tile_value+ _ -> error "inconsistent segmented result layout"+ readAccumulatorElement source_coordinate tile++ tileSourceIndices tile_sizes output_coordinate =+ ( zipWith div output_coordinate tile_sizes,+ zipWith mod output_coordinate tile_sizes+ )++ regTileSourceIndices block_sizes reg_sizes output_coordinate =+ (workers, block_indices <> reg_indices)+ where+ tile_sizes = zipWith (*) block_sizes reg_sizes+ workers = zipWith div output_coordinate tile_sizes+ within_tiles = zipWith mod output_coordinate tile_sizes+ block_indices = zipWith div within_tiles reg_sizes+ reg_indices = zipWith mod within_tiles reg_sizes++ resultShape Seg.Returns {} = pure worker_shape+ resultShape (Seg.TileReturns _ dimensions _) =+ mapM (evalInt env . fst) dimensions+ resultShape (Seg.RegTileReturns _ dimensions _) =+ mapM (evalInt env . firstOf3) dimensions++ expectOrdinary (KernelValue result_value) = pure result_value+ expectOrdinary _ = error "inconsistent segmented result layout"++ expectOne [result_value] = pure result_value+ expectOne _ = error "invalid segmented output count"++ firstOf3 (first, _, _) = first+ secondOf3 (_, second, _) = second+ thirdOf3 (_, _, third) = third++-- | Run a program in the IR specified by rep.+runProgram ::+ (Typed (FParamInfo rep)) =>+ OpEvaluator rep ->+ Prog rep ->+ Name ->+ [V.Value] ->+ IO (Either T.Text [V.Value])+runProgram eval_op prog entry inputs = runExceptT $ flip runReaderT initial_interp_env . unInterpM $ do+ let funs = M.fromList [(funDefName fun, fun) | fun <- progFuns prog]+ consts_env <- foldConsts funs mempty (stmsToList (progConsts prog)) -- top-level consts+ fun <- findEntry prog entry+ converted_inputs <- mapM fromValue inputs+ let params = funDefParams fun+ value_count = length converted_inputs+ context_count = length params - value_count+ if context_count < 0+ then interpError "entry point argument count mismatch"+ else do+ let (context_params, value_params) = splitAt context_count params+ shape_bindings <-+ foldM bindInputShape mempty $ zip value_params converted_inputs+ context_args <- mapM (lookupContextArg shape_bindings) context_params+ let value_args = map snd converted_inputs+ arg_vals = context_args <> value_args+ env =+ M.union+ (M.fromList $ zip (map paramName params) arg_vals)+ consts_env+ results <- evalBody funs env (funDefBody fun)+ result_signedness <- entryResultSignedness prog fun+ zipWithM+ toValue+ result_signedness+ (drop (length results - length result_signedness) results)+ where+ initial_interp_env =+ InterpEnv+ { interpOpEvaluator = eval_op,+ interpAccOps = mempty+ }++ foldConsts _ e [] = pure e+ foldConsts funs e (s : ss) = evalStm funs e s >>= \e' -> foldConsts funs e' ss++ bindInputShape bindings (param, (actual_dims, _))+ | length expected_dims /= length actual_dims =+ interpError "entry point input rank mismatch"+ | otherwise =+ foldM bindDimension bindings $ zip expected_dims actual_dims+ where+ expected_dims = arrayDims $ paramType param++ bindDimension bindings (Var name, actual_dim) =+ case M.lookup name bindings of+ Nothing -> pure $ M.insert name actual_dim bindings+ Just expected_dim+ | sameDimension expected_dim actual_dim -> pure bindings+ | otherwise -> interpError "entry point input shape mismatch"+ bindDimension bindings (Constant expected, PrimVal actual)+ | expected == actual = pure bindings+ | otherwise = interpError "entry point input shape mismatch"+ bindDimension _ _ =+ error "invalid entry point input dimension"++ lookupContextArg bindings param =+ maybe+ (error "unbound entry point shape parameter")+ pure+ (M.lookup (paramName param) bindings)++ sameDimension (PrimVal x) (PrimVal y) = x == y+ sameDimension _ _ = False++entryResultSignedness :: Prog rep -> FunDef rep -> InterpM rep [Signedness]+entryResultSignedness prog fun =+ case funDefEntryPoint fun of+ Just (_, _, result, _) ->+ entryPointTypeSignedness (progTypes prog) $ entryResultType result+ Nothing ->+ error "function is not an entry point"+ where+ entryPointTypeSignedness _ (TypeTransparent value_type) =+ pure [valueTypeSignedness value_type]+ entryPointTypeSignedness types@(OpaqueTypes opaque_types) (TypeOpaque name) =+ case lookup name opaque_types of+ Nothing -> error $ "unknown opaque type: " <> prettyString name+ Just (opaque_type, _) -> opaqueTypeSignedness types opaque_type++ opaqueTypeSignedness _ (OpaqueArray _ _ value_types) =+ pure $ map valueTypeSignedness value_types+ opaqueTypeSignedness types (OpaqueRecordArray _ _ fields) =+ concat <$> mapM (entryPointTypeSignedness types . snd) fields+ opaqueTypeSignedness _ (OpaqueRecord []) =+ pure [Signed]+ opaqueTypeSignedness types (OpaqueRecord fields) =+ concat <$> mapM (entryPointTypeSignedness types . snd) fields+ opaqueTypeSignedness _ (OpaqueSum value_types _) =+ pure $ map valueTypeSignedness value_types++ valueTypeSignedness (ValueType signedness _ _) = signedness++findEntry :: Prog rep -> Name -> InterpM rep (FunDef rep)+findEntry prog name =+ maybe+ (interpError $ "entry point not found: " <> prettyText name)+ pure+ $ lookup+ name+ [ (entry_name, fun)+ | fun <- progFuns prog,+ Just (entry_name, _, _, _) <- [funDefEntryPoint fun]+ ]++fromValue :: V.Value -> InterpM rep ([Val], Val)+fromValue (V.I8Value shape values) =+ fromPrimitiveVector shape (IntType Int8) (IntValue . Int8Value) values+fromValue (V.I16Value shape values) =+ fromPrimitiveVector shape (IntType Int16) (IntValue . Int16Value) values+fromValue (V.I32Value shape values) =+ fromPrimitiveVector shape (IntType Int32) (IntValue . Int32Value) values+fromValue (V.I64Value shape values) =+ fromPrimitiveVector shape (IntType Int64) (IntValue . Int64Value) values+fromValue (V.U8Value shape values) =+ fromPrimitiveVector shape (IntType Int8) (IntValue . Int8Value . fromIntegral) values+fromValue (V.U16Value shape values) =+ fromPrimitiveVector shape (IntType Int16) (IntValue . Int16Value . fromIntegral) values+fromValue (V.U32Value shape values) =+ fromPrimitiveVector shape (IntType Int32) (IntValue . Int32Value . fromIntegral) values+fromValue (V.U64Value shape values) =+ fromPrimitiveVector shape (IntType Int64) (IntValue . Int64Value . fromIntegral) values+fromValue (V.F16Value shape values) =+ fromPrimitiveVector shape (FloatType Float16) (FloatValue . Float16Value) values+fromValue (V.F32Value shape values) =+ fromPrimitiveVector shape (FloatType Float32) (FloatValue . Float32Value) values+fromValue (V.F64Value shape values) =+ fromPrimitiveVector shape (FloatType Float64) (FloatValue . Float64Value) values+fromValue (V.BoolValue shape values) =+ fromPrimitiveVector shape Bool BoolValue values++fromPrimitiveVector ::+ (Storable a) =>+ SVec.Vector Int ->+ PrimType ->+ (a -> PrimValue) ->+ SVec.Vector a ->+ InterpM rep ([Val], Val)+fromPrimitiveVector shape element_type wrap values+ | any (< 0) dimensions =+ interpError "input array dimensions cannot be negative"+ | null dimensions =+ case primitive_values of+ [primitive_value] -> pure ([], PrimVal primitive_value)+ _ -> interpError "invalid scalar input storage"+ | length primitive_values /= product dimensions =+ interpError "invalid input array storage"+ | otherwise = do+ array <- newArrayValue dimensions element_type primitive_values+ pure+ ( map+ (PrimVal . IntValue . Int64Value . fromIntegral)+ dimensions,+ array+ )+ where+ dimensions = SVec.toList shape+ primitive_values = map wrap $ SVec.toList values++toValue :: Signedness -> Val -> InterpM rep V.Value+toValue signedness (PrimVal primitive_value) =+ toPrimitiveValue signedness [] (P.primValueType primitive_value) [primitive_value]+toValue signedness (ArrayValue shape values) = do+ primitive_values <- arrayValues values+ toPrimitiveValue signedness shape (arrayValuesType values) primitive_values+toValue _ AccValue {} =+ error "accumulators cannot be represented as external values"++toPrimitiveValue :: Signedness -> [Int] -> PrimType -> [PrimValue] -> InterpM rep V.Value+toPrimitiveValue Signed shape (IntType Int8) values =+ pure $ V.I8Value (shapeVector shape) $ SVec.fromList $ map expectInt8 values+ where+ expectInt8 (IntValue (Int8Value element)) = element+ expectInt8 _ = error "expected an i8 value"+toPrimitiveValue Signed shape (IntType Int16) values =+ pure $ V.I16Value (shapeVector shape) $ SVec.fromList $ map expectInt16 values+ where+ expectInt16 (IntValue (Int16Value element)) = element+ expectInt16 _ = error "expected an i16 value"+toPrimitiveValue Signed shape (IntType Int32) values =+ pure $ V.I32Value (shapeVector shape) $ SVec.fromList $ map expectInt32 values+ where+ expectInt32 (IntValue (Int32Value element)) = element+ expectInt32 _ = error "expected an i32 value"+toPrimitiveValue Signed shape (IntType Int64) values =+ pure $ V.I64Value (shapeVector shape) $ SVec.fromList $ map expectInt64 values+ where+ expectInt64 (IntValue (Int64Value element)) = element+ expectInt64 _ = error "expected an i64 value"+toPrimitiveValue Unsigned shape (IntType Int8) values =+ pure $ V.U8Value (shapeVector shape) $ SVec.fromList $ map expectUInt8 values+ where+ expectUInt8 (IntValue (Int8Value element)) = fromIntegral element+ expectUInt8 _ = error "expected a u8 value"+toPrimitiveValue Unsigned shape (IntType Int16) values =+ pure $ V.U16Value (shapeVector shape) $ SVec.fromList $ map expectUInt16 values+ where+ expectUInt16 (IntValue (Int16Value element)) = fromIntegral element+ expectUInt16 _ = error "expected a u16 value"+toPrimitiveValue Unsigned shape (IntType Int32) values =+ pure $ V.U32Value (shapeVector shape) $ SVec.fromList $ map expectUInt32 values+ where+ expectUInt32 (IntValue (Int32Value element)) = fromIntegral element+ expectUInt32 _ = error "expected a u32 value"+toPrimitiveValue Unsigned shape (IntType Int64) values =+ pure $ V.U64Value (shapeVector shape) $ SVec.fromList $ map expectUInt64 values+ where+ expectUInt64 (IntValue (Int64Value element)) = fromIntegral element+ expectUInt64 _ = error "expected a u64 value"+toPrimitiveValue _ shape (FloatType Float16) values =+ pure $ V.F16Value (shapeVector shape) $ SVec.fromList $ map expectFloat16 values+ where+ expectFloat16 (FloatValue (Float16Value element)) = element+ expectFloat16 _ = error "expected an f16 value"+toPrimitiveValue _ shape (FloatType Float32) values =+ pure $ V.F32Value (shapeVector shape) $ SVec.fromList $ map expectFloat32 values+ where+ expectFloat32 (FloatValue (Float32Value element)) = element+ expectFloat32 _ = error "expected an f32 value"+toPrimitiveValue _ shape (FloatType Float64) values =+ pure $ V.F64Value (shapeVector shape) $ SVec.fromList $ map expectFloat64 values+ where+ expectFloat64 (FloatValue (Float64Value element)) = element+ expectFloat64 _ = error "expected an f64 value"+toPrimitiveValue _ shape Bool values =+ pure $ V.BoolValue (shapeVector shape) $ SVec.fromList $ map expectBool values+ where+ expectBool (BoolValue element) = element+ expectBool _ = error "expected a bool value"+toPrimitiveValue _ _ Unit _ =+ interpError "unit values cannot be represented as external values"++shapeVector :: [Int] -> SVec.Vector Int+shapeVector = SVec.fromList++-- | Run a program in the SOAC IR+runSOACS :: Prog SOACS -> Name -> [V.Value] -> IO (Either T.Text [V.Value])+runSOACS = runProgram evalSOAC++evalGPUOp :: OpEvaluator GPU+evalGPUOp funs env (SegOp op) = evalSegOp funs env op+evalGPUOp _ env (SizeOp op) = evalSizeOp env op+evalGPUOp funs env (OtherOp op) = evalSOAC funs env op+evalGPUOp funs env (GPUBody types body) = do+ values <- evalBody funs env body+ collectOutputs env [1] types [values]++sizeValue :: SizeClass -> Int+sizeValue (SizeThreshold _ (Just n)) = fromIntegral n+sizeValue SizeThreadBlock = 256+sizeValue SizeGrid = 65535+sizeValue SizeTile = 32+sizeValue SizeRegTile = 4+sizeValue SizeSharedMemory = 48 * 1024+sizeValue SizeRegisters = 65536+sizeValue SizeCache = 4 * 1024 * 1024+sizeValue _ = 32768++evalSizeOp :: Env -> SizeOp -> InterpM rep [Val]+evalSizeOp _ (GetSize _ cls) =+ pure [int64Val $ sizeValue cls]+evalSizeOp _ (GetSizeMax cls) =+ pure [int64Val $ sizeValue cls]+evalSizeOp env (CmpSizeLe _ cls x) = do+ limit <- evalInt env x+ pure [PrimVal $ BoolValue $ sizeValue cls <= limit]+evalSizeOp env (CalcNumBlocks width_exp _ block_size_exp) = do+ width <- evalInt env width_exp+ block_size <- evalInt env block_size_exp+ if block_size <= 0+ then error "thread-block size must be positive"+ else+ pure+ [ int64Val $+ max 1 $+ min (sizeValue SizeGrid) $+ (width + block_size - 1) `div` block_size+ ]++-- | Run a program in the GPU IR.+runGPU :: Prog GPU -> Name -> [V.Value] -> IO (Either T.Text [V.Value])+runGPU = runProgram evalGPUOp
src/Futhark/IR/SOACS.hs view
@@ -45,8 +45,8 @@ instance PrettyRep SOACS -instance TraverseOpStms SOACS where- traverseOpStms = traverseSOACStms+instance TraverseOpBodies SOACS where+ traverseOpBodies = traverseSOACBodies usesAD :: Prog SOACS -> Bool usesAD prog = any stmUsesAD (progConsts prog) || any funUsesAD (progFuns prog)
src/Futhark/IR/SOACS/SOAC.hs view
@@ -46,7 +46,7 @@ SOACMapper (..), identitySOACMapper, mapSOACM,- traverseSOACStms,+ traverseSOACBodies, ) where @@ -499,14 +499,14 @@ <$> mapOnSOACLambda tv red_lam <*> mapM (mapOnSOACSubExp tv) red_nes --- | A helper for defining 'TraverseOpStms'.-traverseSOACStms :: (Monad m) => OpStmsTraverser m (SOAC rep) rep-traverseSOACStms f = mapSOACM mapper+-- | A helper for defining 'TraverseOpBodies'.+traverseSOACBodies :: (Monad m) => OpBodyTraverser m (SOAC rep) rep+traverseSOACBodies f = mapSOACM mapper where mapper = identitySOACMapper- { mapOnSOACLambda = traverseLambdaStms f,- mapOnSOACExtLambda = traverseLambdaStms f+ { mapOnSOACLambda = traverseLambdaBodies f,+ mapOnSOACExtLambda = traverseLambdaBodies f } instance (ASTRep rep) => FreeIn (Scan rep) where@@ -802,6 +802,7 @@ pure (lam, se, drop num_accs $ lambdaParams lam, arrs) arrIndex p arr = do+ guard $ primType $ paramType p ST.Indexed cs pe <- ST.index' arr [i] vtable pure (paramName p, (pe, cs))
src/Futhark/IR/SOACS/Simplify.hs view
@@ -165,8 +165,8 @@ instance BuilderOps (Wise SOACS) -instance TraverseOpStms (Wise SOACS) where- traverseOpStms = traverseSOACStms+instance TraverseOpBodies (Wise SOACS) where+ traverseOpBodies = traverseSOACBodies fixLambdaParams :: (MonadBuilder m, Buildable (Rep m), BuilderOps (Rep m)) =>@@ -191,7 +191,7 @@ maybeFix p (Just x) = letBindNames [paramName p] $ BasicOp $ SubExp x maybeFix _ Nothing = pure () -removeLambdaResults :: [Bool] -> Lambda rep -> Lambda rep+removeLambdaResults :: (Buildable rep) => [Bool] -> Lambda rep -> Lambda rep removeLambdaResults keep lam = lam { lambdaBody = lam_body',@@ -201,7 +201,7 @@ keep' :: [a] -> [a] keep' = map snd . filter fst . zip (keep ++ repeat True) lam_body = lambdaBody lam- lam_body' = lam_body {bodyResult = keep' $ bodyResult lam_body}+ lam_body' = mkBody (bodyStms lam_body) (keep' $ bodyResult lam_body) ret = keep' $ lambdaReturnType lam {-# NOINLINE soacRules #-}@@ -317,7 +317,7 @@ let (pat', ses') = unzip mapresult fun' = fun- { lambdaBody = (lambdaBody fun) {bodyResult = subExpsRes ses'},+ { lambdaBody = mkBody (bodyStms (lambdaBody fun)) (subExpsRes ses'), lambdaReturnType = rettype' } auxing aux $ do@@ -337,7 +337,7 @@ let (variant_map_ts, variant_map_pes, variant_map_res) = unzip3 variant_map lam' = lam- { lambdaBody = (lambdaBody lam) {bodyResult = fold_res ++ variant_map_res},+ { lambdaBody = mkBody (bodyStms (lambdaBody lam)) (fold_res ++ variant_map_res), lambdaReturnType = fold_ts ++ variant_map_ts } @@ -474,7 +474,7 @@ (lambdaReturnType pre_lam) pre_lam' = pre_lam- { lambdaBody = (lambdaBody pre_lam) {bodyResult = pre_lam_new_res},+ { lambdaBody = mkBody (bodyStms (lambdaBody pre_lam)) pre_lam_new_res, lambdaReturnType = pre_lam_new_ts } post_lam' =@@ -511,7 +511,7 @@ let (ses', ts', pes') = unzip3 ses_ts_pes' fun' = fun- { lambdaBody = (lambdaBody fun) {bodyResult = ses'},+ { lambdaBody = mkBody (bodyStms (lambdaBody fun)) ses', lambdaReturnType = ts' } auxing aux $ do@@ -729,8 +729,11 @@ simplifyClosedFormReduce _ pat _ (Screma (Constant w) _ form) | Just nes <- concatMap redNeutral . fst <$> isRedomapSOAC form, zeroIsh w =- Simplify . forM_ (zip (patNames pat) nes) $ \(v, ne) ->- letBindNames [v] $ BasicOp $ SubExp ne+ Simplify . forM_ (zip (patElems pat) nes) $ \(pe, ne) ->+ letBindNames [patElemName pe] . BasicOp $+ case patElemType pe of+ Array {} -> Replicate mempty ne+ _ -> SubExp ne simplifyClosedFormReduce vtable pat _ (Screma _ arrs form) | Just [Reduce _ red_fun nes] <- isReduceSOAC form = Simplify $ foldClosedForm (`ST.lookupExp` vtable) pat red_fun nes arrs@@ -761,6 +764,11 @@ patElemType pe bindResult name (SubExpRes cs se) = certifying cs $ letBindNames [name] $ BasicOp $ SubExp se+ bindRedResult pe (SubExpRes cs se) =+ certifying cs . letBindNames [patElemName pe] . BasicOp $+ case patElemType pe of+ Array {} -> Replicate mempty se+ _ -> SubExp se zipWithM_ bindMapParam (lambdaParams map_lam) arrs (to_scan, to_red, map_res) <-@@ -769,7 +777,7 @@ scan_res <- eLambda scan_lam $ map eSubExp $ scan_nes ++ map resSubExp to_scan red_res <- eLambda red_lam $ map eSubExp $ red_nes ++ map resSubExp to_red - zipWithM_ bindResult (patElemName <$> red_pes) red_res+ zipWithM_ bindRedResult red_pes red_res let par_names = paramName <$> lambdaParams post_lam zipWithM_ bindResult par_names (scan_res <> map_res)
src/Futhark/IR/SegOp.hs view
@@ -32,7 +32,7 @@ SegOpMapper (..), identitySegOpMapper, mapSegOpM,- traverseSegOpStms,+ traverseSegOpBodies, -- * Simplification simplifySegOp,@@ -726,19 +726,18 @@ onOp (HistOp w rf arrs nes shape op) = HistOp w rf arrs nes shape <$> rephraseLambda r op --- | A helper for defining 'TraverseOpStms'.-traverseSegOpStms :: (Monad m) => OpStmsTraverser m (SegOp lvl rep) rep-traverseSegOpStms f segop = mapSegOpM mapper segop+-- | A helper for defining 'TraverseOpBodies'.+traverseSegOpBodies :: forall m lvl rep. (Monad m) => OpBodyTraverser m (SegOp lvl rep) rep+traverseSegOpBodies f segop = mapSegOpM mapper segop where seg_scope = scopeOfSegSpace (segSpace segop)+ f' :: (IsResult res) => Scope rep -> GBody rep res -> m (GBody rep res) f' scope = f (seg_scope <> scope) mapper = identitySegOpMapper- { mapOnSegBinOpLambda = traverseLambdaStms f',- mapOnSegOpBody = onBody+ { mapOnSegBinOpLambda = traverseLambdaBodies f',+ mapOnSegOpBody = f seg_scope }- onBody (Body dec stms res) =- Body dec <$> f seg_scope stms <*> pure res instance (ASTRep rep, Substitute lvl) =>@@ -1230,7 +1229,7 @@ when (kres == kres') cannotSimplify kbody <- mkBodyM kstms kres'- addStm $ Let (Pat kpes') dec $ Op $ segOp $ SegMap lvl space ts' kbody+ auxing dec . letBind (Pat kpes') $ Op $ segOp $ SegMap lvl space ts' kbody where isInvariant Constant {} = True isInvariant (Var v) = isJust $ ST.lookup v vtable@@ -1261,7 +1260,7 @@ (red_pes', red_ts', red_res') = unzip3 $ concat aux pes' = red_pes' ++ map_pes ts' = red_ts' ++ map_ts- kbody' = kbody {bodyResult = red_res' ++ map_res}+ kbody' <- mkBodyM (bodyStms kbody) (red_res' ++ map_res) letBind (Pat pes') $ Op $ segOp $ SegRed lvl space ts' kbody' ops' where (red_pes, map_pes) = splitAt (segBinOpResults ops) pes@@ -1307,9 +1306,10 @@ topDownSegOp _ pat aux op | SegScan lvl space ts kbody seg_op post_op <- op, -- Figure out which of the names in 'pat' are used...- Just (new_kbody, new_ts, m_new_post_op) <-+ Just (new_res, new_ts, m_new_post_op) <- newKbodyPostOp kbody ts seg_op post_op = Simplify $ do new_post_op <- m_new_post_op+ new_kbody <- mkBodyM (bodyStms kbody) new_res auxing aux . letBind pat . Op@@ -1319,7 +1319,7 @@ newKbodyPostOp kbody ts seg_op post_op = if null sub_map_res_ts_pars then Nothing- else Just (new_kbody, new_ts, new_post_op)+ else Just (new_res, new_ts, new_post_op) where res = bodyResult kbody post_lam = segPostOpLambda post_op@@ -1330,7 +1330,6 @@ [Ident (paramName p) t] (BasicOp $ SubExp $ kernelResultSubExp r) - new_kbody = kbody {bodyResult = new_res} new_post_op = do let sub_res = map (\(r, _, _, _) -> r) sub_map_res_ts_pars temp_body <- renameBody $ kbody {bodyResult = sub_res}@@ -1403,7 +1402,7 @@ postlam' <- mkLambda (lambdaParams postlam) $ do addStms $ bodyStms $ lambdaBody postlam pure res'- addStm $ Let (Pat kpes') aux $ Op $ segOp $ SegScan lvl space kts body ops (SegPostOp postlam')+ auxing aux . letBind (Pat kpes') $ Op $ segOp $ SegScan lvl space kts body ops (SegPostOp postlam') | otherwise = Skip where keep (pe, _) = patElemName pe `UT.used` used@@ -1413,7 +1412,7 @@ | (_, kpes', kts', kres') <- unzip4 $ filter keep $ zip4 [0 ..] kpes kts kres, kpes' /= kpes = Simplify $ do kbody' <- localScope (scopeOfSegSpace space) $ mkBodyM kstms kres'- addStm $ Let (Pat kpes') dec $ Op $ segOp $ mk_segop kts' kbody'+ auxing dec . letBind (Pat kpes') $ Op $ segOp $ mk_segop kts' kbody' where space = segSpace segop (kts, Body _ kstms kres, num_nonmap_results, mk_segop) =@@ -1437,7 +1436,7 @@ kbody' <- localScope (scopeOfSegSpace space) $ mkBodyM kstms' kres' - addStm $ Let (Pat kpes') dec $ Op $ segOp $ mk_segop kts' kbody'+ auxing dec . letBind (Pat kpes') $ Op $ segOp $ mk_segop kts' kbody' where (kts, Body _ kstms kres, num_nonmap_results, mk_segop) = segOpGuts segop
src/Futhark/IR/Seq.hs view
@@ -46,15 +46,15 @@ instance BuilderOps Seq -instance TraverseOpStms Seq where- traverseOpStms _ = pure+instance TraverseOpBodies Seq where+ traverseOpBodies _ = pure instance PrettyRep Seq instance BuilderOps (Engine.Wise Seq) -instance TraverseOpStms (Engine.Wise Seq) where- traverseOpStms _ = pure+instance TraverseOpBodies (Engine.Wise Seq) where+ traverseOpBodies _ = pure simpleSeq :: Simplify.SimpleOps Seq simpleSeq = Simplify.bindableSimpleOps (const $ pure (NoOp, mempty))
src/Futhark/IR/SeqMem.hs view
@@ -54,16 +54,16 @@ mkBodyB stms res = pure $ Body () stms res mkLetNamesB = mkLetNamesB' DefaultSpace () -instance TraverseOpStms SeqMem where- traverseOpStms _ = pure+instance TraverseOpBodies SeqMem where+ traverseOpBodies _ = pure instance BuilderOps (Engine.Wise SeqMem) where mkExpDecB pat e = pure $ Engine.mkWiseExpDec pat () e mkBodyB stms res = pure $ Engine.mkWiseBody () stms res mkLetNamesB = mkLetNamesB'' DefaultSpace -instance TraverseOpStms (Engine.Wise SeqMem) where- traverseOpStms _ = pure+instance TraverseOpBodies (Engine.Wise SeqMem) where+ traverseOpBodies _ = pure simplifyProg :: Prog SeqMem -> PassM (Prog SeqMem) simplifyProg = simplifyProgGeneric memRuleBook simpleSeqMem
src/Futhark/IR/Traversals.hs view
@@ -34,9 +34,6 @@ walkExpM, -- * Ops- TraverseOpStms (..),- OpStmsTraverser,- traverseLambdaStms, ) where @@ -355,18 +352,3 @@ (params, args) = unzip merge walkExpM tv (Op op) = walkOnOp tv op---- | A function for monadically traversing any sub-statements of the--- given op for some representation.-type OpStmsTraverser m op rep = (Scope rep -> Stms rep -> m (Stms rep)) -> op -> m op---- | This representation supports an 'OpStmsTraverser' for its t'Op'.--- This is used for some simplification rules.-class TraverseOpStms rep where- -- | Transform every sub-'Stms' of this op.- traverseOpStms :: (Monad m) => OpStmsTraverser m (Op rep) rep---- | A helper for defining 'traverseOpStms'.-traverseLambdaStms :: (Monad m) => OpStmsTraverser m (GLambda rep t) rep-traverseLambdaStms f (Lambda ps ret (Body dec stms res)) =- Lambda ps ret <$> (Body dec <$> f (scopeOfLParams ps) stms <*> pure res)
src/Futhark/IR/TypeCheck.hs view
@@ -287,9 +287,8 @@ HasScope (Aliases rep) (TypeM rep) where lookupType = fmap typeOf . lookupVar- askScope = asks $ M.fromList . mapMaybe varType . M.toList . envVtable- where- varType (name, dec) = Just (name, dec)+ lookupInfo = lookupVar+ askScope = asks envVtable runTypeM :: Env rep ->
src/Futhark/Internalise/Defunctorise.hs view
@@ -6,7 +6,6 @@ import Control.Monad.RWS.Strict import Data.DList qualified as DL import Data.Map qualified as M-import Data.Maybe import Data.Set qualified as S import Futhark.MonadFreshNames import Language.Futhark@@ -15,14 +14,19 @@ import Prelude hiding (abs, mod) -- | A substitution from names in the original program to names in the--- generated/residual program.+-- generated/residual program. Entries are accumulated rather than composed, so+-- resolving a name may require following several, as we do in lookupSubst. type Substitutions = M.Map VName VName lookupSubst :: VName -> Substitutions -> VName lookupSubst v substs = case M.lookup v substs of- Just v' | v' /= v -> lookupSubst v' substs- _ -> v+ Just v' -> lookupSubst v' substs+ Nothing -> v +-- | Resolve the values of a substitution through another.+resolveSubsts :: Substitutions -> Substitutions -> Substitutions+resolveSubsts through = M.map (`lookupSubst` through)+ data Mod = -- | A pairing of a lexical closure and a module function. ModFun TySet Scope ModParam ModExp@@ -47,7 +51,8 @@ q : qs -> let q' = lookupSubst q substs in case M.lookup q' mods of- Just (ModMod mod_scope) -> lookupSubstInScope (QualName qs name) mod_scope+ Just (ModMod (Scope mod_substs mod_mods)) ->+ lookupSubstInScope (QualName qs name) (Scope (mod_substs <> substs) mod_mods) _ -> (qn, scope) instance Semigroup Scope where@@ -87,11 +92,9 @@ extendScope :: Scope -> TransformM a -> TransformM a extendScope (Scope substs mods) = localScope $ \scope -> scope- { scopeSubsts = M.map (forward (scopeSubsts scope)) substs <> scopeSubsts scope,+ { scopeSubsts = resolveSubsts (scopeSubsts scope) substs <> scopeSubsts scope, scopeMods = mods <> scopeMods scope }- where- forward old_substs v = fromMaybe v $ M.lookup v old_substs substituting :: Substitutions -> TransformM a -> TransformM a substituting substs = extendScope mempty {scopeSubsts = substs}@@ -104,7 +107,7 @@ bindingNames :: [VName] -> TransformM Scope -> TransformM Scope bindingNames names m = do names' <- mapM boundName names- let substs = M.fromList (zip names names')+ let substs = M.fromList $ filter (uncurry (/=)) $ zip names names' substituting substs $ mappend <$> m <*> pure (Scope substs mempty) generating :: TransformM a -> TransformM a@@ -157,15 +160,11 @@ substituteInMod :: Substitutions -> Mod -> Mod substituteInMod substs (ModMod (Scope mod_substs mod_mods)) = -- Forward all substitutions.- ModMod $ Scope substs' $ M.map (substituteInMod substs) mod_mods- where- forward v = lookupSubst v $ mod_substs <> substs- substs' = M.map forward substs+ ModMod+ (Scope (resolveSubsts (mod_substs <> substs) substs) (M.map (substituteInMod substs) mod_mods)) substituteInMod substs (ModFun abs (Scope mod_substs mod_mods) mparam mbody) =- ModFun abs (Scope (substs' <> mod_substs) mod_mods) mparam mbody- where- forward v = lookupSubst v mod_substs- substs' = M.map forward substs+ -- Keep 'mod_substs': the body still refers to the names it binds.+ ModFun abs (Scope (resolveSubsts mod_substs substs <> mod_substs) mod_mods) mparam mbody extendAbsTypes :: Substitutions -> TransformM a -> TransformM a extendAbsTypes ascript_substs m = do@@ -202,7 +201,7 @@ let keep k _ = k `M.member` p_substs || k `S.member` abs abs_substs = M.filterWithKey keep $- M.map (`lookupSubst` scopeSubsts (modScope arg_mod)) p_substs+ resolveSubsts (scopeSubsts (modScope arg_mod)) p_substs <> scopeSubsts f_closure <> scopeSubsts (modScope arg_mod) extendScope@@ -216,7 +215,7 @@ substs <- scopeSubsts <$> askScope x <- evalModExp f_body pure $- addSubsts abs abs_substs $+ addSubsts abs (abs_substs `M.withoutKeys` M.keysSet b_substs) $ -- The next one is dubious, but is necessary to -- propagate substitutions from the argument (see -- modules/functor24.fut).@@ -227,8 +226,8 @@ ModFun (abs <> mabs) (Scope (substs <> msubsts) mods) mp me addSubsts _ substs (ModMod (Scope msubsts mods)) = ModMod $ Scope (substs <> msubsts) mods- addSubstsModMod substs (ModMod (Scope msubsts mods)) =- ModMod $ Scope (substs <> msubsts) mods+ -- As 'addSubsts', but leaves a parametric module alone.+ addSubstsModMod substs m@ModMod {} = addSubsts mempty substs m addSubstsModMod _ m = m evalModExp (ModLambda p ascript e loc) = do scope <- askScope
src/Futhark/Internalise/Exps.hs view
@@ -1536,6 +1536,18 @@ c <- assert "nonzero_cert" nonnegative "negative exponent" certifying c m +protectBinOp :: I.BinOp -> SubExp -> SubExp -> InternaliseM a -> InternaliseM a+protectBinOp (I.SDiv t Unsafe) _ y = certifyingNonzero t y+protectBinOp (I.SQuot t Unsafe) _ y = certifyingNonzero t y+protectBinOp (I.SMod t Unsafe) _ y = certifyingNonzero t y+protectBinOp (I.SRem t Unsafe) _ y = certifyingNonzero t y+protectBinOp (I.UDiv t Unsafe) _ y = certifyingNonzero t y+protectBinOp (I.UMod t Unsafe) _ y = certifyingNonzero t y+protectBinOp (I.UCeilDiv t Unsafe) _ y = certifyingNonzero t y+protectBinOp (I.SCeilDiv t Unsafe) _ y = certifyingNonzero t y+protectBinOp (I.SPow t) _ y = certifyingNonnegative t y+protectBinOp _ _ _ = id+ internaliseBinOp :: Name -> E.BinOp ->@@ -1567,40 +1579,31 @@ internaliseBinOp desc E.Times x y (E.FloatType t) _ = simpleBinOp desc (I.FMul t) x y internaliseBinOp desc E.Divide x y (E.Signed t) _ =- certifyingNonzero t y $- simpleBinOp desc (I.SDiv t I.Unsafe) x y+ simpleBinOp desc (I.SDiv t I.Unsafe) x y internaliseBinOp desc E.Divide x y (E.Unsigned t) _ =- certifyingNonzero t y $- simpleBinOp desc (I.UDiv t I.Unsafe) x y+ simpleBinOp desc (I.UDiv t I.Unsafe) x y internaliseBinOp desc E.Divide x y (E.FloatType t) _ = simpleBinOp desc (I.FDiv t) x y internaliseBinOp desc E.Pow x y (E.FloatType t) _ = simpleBinOp desc (I.FPow t) x y internaliseBinOp desc E.Pow x y (E.Signed t) _ =- certifyingNonnegative t y $- simpleBinOp desc (I.Pow t) x y+ simpleBinOp desc (I.SPow t) x y internaliseBinOp desc E.Pow x y (E.Unsigned t) _ =- simpleBinOp desc (I.Pow t) x y+ simpleBinOp desc (I.UPow t) x y internaliseBinOp desc E.Mod x y (E.Signed t) _ =- certifyingNonzero t y $- simpleBinOp desc (I.SMod t I.Unsafe) x y+ simpleBinOp desc (I.SMod t I.Unsafe) x y internaliseBinOp desc E.Mod x y (E.Unsigned t) _ =- certifyingNonzero t y $- simpleBinOp desc (I.UMod t I.Unsafe) x y+ simpleBinOp desc (I.UMod t I.Unsafe) x y internaliseBinOp desc E.Mod x y (E.FloatType t) _ = simpleBinOp desc (I.FMod t) x y internaliseBinOp desc E.Quot x y (E.Signed t) _ =- certifyingNonzero t y $- simpleBinOp desc (I.SQuot t I.Unsafe) x y+ simpleBinOp desc (I.SQuot t I.Unsafe) x y internaliseBinOp desc E.Quot x y (E.Unsigned t) _ =- certifyingNonzero t y $- simpleBinOp desc (I.UDiv t I.Unsafe) x y+ simpleBinOp desc (I.UDiv t I.Unsafe) x y internaliseBinOp desc E.Rem x y (E.Signed t) _ =- certifyingNonzero t y $- simpleBinOp desc (I.SRem t I.Unsafe) x y+ simpleBinOp desc (I.SRem t I.Unsafe) x y internaliseBinOp desc E.Rem x y (E.Unsigned t) _ =- certifyingNonzero t y $- simpleBinOp desc (I.UMod t I.Unsafe) x y+ simpleBinOp desc (I.UMod t I.Unsafe) x y internaliseBinOp desc E.ShiftR x y (E.Signed t) _ = simpleBinOp desc (I.AShr t) x y internaliseBinOp desc E.ShiftR x y (E.Unsigned t) _ =@@ -1676,7 +1679,8 @@ I.SubExp -> InternaliseM [I.SubExp] simpleBinOp desc bop x y =- letTupExp' desc $ I.BasicOp $ I.BinOp bop x y+ protectBinOp bop x y $+ letTupExp' desc (I.BasicOp $ I.BinOp bop x y) simpleCmpOp :: Name ->@@ -1904,7 +1908,7 @@ | Just bop <- find ((== s) . nameFromText . prettyText) allBinOps = Just $ \desc -> do x' <- internaliseExp1 "x" x y' <- internaliseExp1 "y" y- fmap pure $ letSubExp desc $ I.BasicOp $ I.BinOp bop x' y'+ simpleBinOp desc bop x' y' | Just cmp <- find ((== s) . nameFromText . prettyText) allCmpOps = Just $ \desc -> do x' <- internaliseExp1 "x" x y' <- internaliseExp1 "y" y
src/Futhark/LSP/CodeLens.hs view
@@ -26,7 +26,7 @@ import Data.Text qualified as T import Data.Text.Mixed.Rope qualified as R import Futhark.Compiler.Program (VFS)-import Futhark.Eval (EvalConfig (evalFile, evalPrintWarnings), Evaluation (abort), evalConfig, newInterpreterState, runEvalRecordRef, runExpr)+import Futhark.Eval (EvalConfig (evalFile, evalPrintWarnings), Evaluation (abort), evalConfig, newInterpreterState, prettyValue, runEvalRecordRef, runExpr) import Futhark.LSP.CommandType qualified as CommandType import Futhark.LSP.Tool (Execute, transformVFS) import Futhark.Util (showText)@@ -236,13 +236,13 @@ { _newText = insertText, _range = Range- { _end =+ { _start = Position { _character = 0, -- insert below the evaluation comment _line = line + 1 },- _start =+ _end = Position { _line = -- replace the entire comment range@@ -300,7 +300,7 @@ liftIO setupLimits - runExpr interpreterState expressionText+ prettyValue <$> runExpr interpreterState expressionText where -- TODO: Configurable allocation limit handleOom AllocationLimitExceeded =
src/Futhark/LSP/Compile.hs view
@@ -7,10 +7,11 @@ import Colog.Core (Severity (Debug, Warning), (<&)) import Control.Monad.IO.Class (MonadIO (liftIO)) import Data.IORef (IORef, readIORef, writeIORef)-import Data.Maybe (fromMaybe)+import Data.Int (Int32)+import Data.Maybe (fromMaybe, isJust) import Futhark.Compiler.Program (LoadedProg, lpFilePaths, lpWarnings, noLoadedProg, reloadProg)-import Futhark.LSP.Diagnostic (diagnosticSource, maxDiagnostic, publishErrorDiagnostics, publishWarningDiagnostics)-import Futhark.LSP.State (State (..), emptyState, updateStaleContent, updateStaleMapping)+import Futhark.LSP.Diagnostic (errorDiagnostics, publishDiagnostics, showUnlocatedErrors, warningDiagnostics)+import Futhark.LSP.State (State (..), updateStaleContent, updateStaleMapping) import Futhark.LSP.Tool (computeMapping, logWithSeverity, transformVFS) import Futhark.Util (showText) import Language.Futhark.Warnings (listWarnings)@@ -18,73 +19,82 @@ ( filePathToUri, toNormalizedUri, )-import Language.LSP.Server (LspT, flushDiagnosticsBySource, getVirtualFile, getVirtualFiles)+import Language.LSP.Server (LspT, getVirtualFile, getVirtualFiles)+import Language.LSP.VFS (virtualFileVersion) --- | Try to take state from IORef, if it's empty, try to compile.+-- | Get the current state. If the given file is not part of the+-- current program, first try to compile the program rooted at that+-- file, unless that already failed for this version of the file. tryTakeStateFromIORef :: IORef State -> Maybe FilePath -> LspT () IO State-tryTakeStateFromIORef state_mvar file_path = do+tryTakeStateFromIORef state_mvar Nothing = liftIO $ readIORef state_mvar+tryTakeStateFromIORef state_mvar (Just file_path) = do old_state <- liftIO $ readIORef state_mvar case stateProgram old_state of- Nothing -> do- new_state <- tryCompile old_state file_path noLoadedProg- liftIO $ writeIORef state_mvar new_state- pure new_state- Just prog -> do- -- If this is in the context of some file that is not part of- -- the program, try to reload the program from that file.- let files = lpFilePaths prog- state <- case file_path of- Just file_path'- | file_path' `notElem` files -> do- logWithSeverity Warning <& ("File not part of program: " <> showText file_path')- logWithSeverity Warning <& ("Program contains: " <> showText files)- tryCompile old_state file_path noLoadedProg- _ -> pure old_state- liftIO $ writeIORef state_mvar state- pure state+ Just prog+ | file_path `elem` lpFilePaths prog -> pure old_state+ | otherwise -> do+ logWithSeverity Warning <& ("File not part of program: " <> showText file_path)+ logWithSeverity Warning <& ("Program contains: " <> showText (lpFilePaths prog))+ compileUnlessFailed old_state+ Nothing -> compileUnlessFailed old_state+ where+ compileUnlessFailed old_state = do+ attempt <- compileAttempt file_path+ if isJust attempt && attempt == stateFailed old_state+ then pure old_state+ else do+ new_state <- either id id <$> tryCompile old_state file_path noLoadedProg+ liftIO $ writeIORef state_mvar new_state+ pure new_state -- | Try to (re)-compile, replace old state if successful. tryReCompile :: IORef State -> Maybe FilePath -> LspT () IO ()-tryReCompile state_mvar file_path = do+tryReCompile _ Nothing = pure ()+tryReCompile state_mvar (Just file_path) = do logWithSeverity Debug <& "(Re)-compiling ..." old_state <- liftIO $ readIORef state_mvar- let loaded_prog = getLoadedProg old_state- new_state <- tryCompile old_state file_path loaded_prog- case stateProgram new_state of- Nothing -> do+ result <- tryCompile old_state file_path $ getLoadedProg old_state+ case result of+ Left failed_state -> do logWithSeverity Debug <& "Failed to (re)-compile, using old state or Nothing" logWithSeverity Debug <& "Computing PositionMapping for: " <> showText file_path- mapping <- computeMapping old_state file_path- liftIO $ writeIORef state_mvar $ updateStaleMapping file_path mapping old_state- Just _ -> do+ mapping <- computeMapping failed_state (Just file_path)+ liftIO $ writeIORef state_mvar $ updateStaleMapping (Just file_path) mapping failed_state+ Right new_state -> do logWithSeverity Debug <& "(Re)-compile successful" liftIO $ writeIORef state_mvar new_state --- | Try to compile, publish diagnostics on warnings and errors, return newly compiled state.--- Single point where the compilation is done, and shouldn't be exported.-tryCompile :: State -> Maybe FilePath -> LoadedProg -> LspT () IO State-tryCompile _ Nothing _ = pure emptyState-tryCompile state (Just path) old_loaded_prog = do+-- | The file and its current version, as recorded in 'stateFailed'.+compileAttempt :: FilePath -> LspT () IO (Maybe (FilePath, Int32))+compileAttempt file_path =+ fmap ((file_path,) . virtualFileVersion)+ <$> getVirtualFile (toNormalizedUri $ filePathToUri file_path)++-- | Try to compile and publish diagnostics on warnings and errors.+-- Returns the new state on success, and on failure the old state+-- with the failed attempt recorded. Single point where the+-- compilation is done, and shouldn't be exported.+tryCompile :: State -> FilePath -> LoadedProg -> LspT () IO (Either State State)+tryCompile state path old_loaded_prog = do logWithSeverity Debug <& "Reloading program from " <> showText path vfs <- getVirtualFiles res <- liftIO $ reloadProg old_loaded_prog [path] (transformVFS vfs) -- NOTE: vfs only keeps track of current opened files- flushDiagnosticsBySource maxDiagnostic diagnosticSource+ diagnosed <-+ publishDiagnostics vfs (stateDiagnosed state) $+ either errorDiagnostics (warningDiagnostics . listWarnings . lpWarnings) res case res of Right new_loaded_prog -> do- logWithSeverity Debug <& "Successfully compiled, publishing warnings"- publishWarningDiagnostics $ listWarnings $ lpWarnings new_loaded_prog+ logWithSeverity Debug <& "Successfully compiled" maybe_virtual_file <- getVirtualFile $ toNormalizedUri $ filePathToUri path- case maybe_virtual_file of- Nothing -> pure $ State (Just new_loaded_prog) (staleData state) -- should never happen- Just virtual_file ->- pure $ updateStaleContent path virtual_file new_loaded_prog state- -- Preserve files that have been opened should be enoguth.- -- But still might need an update on re-compile logic, don't discard all state afterwards,- -- try to compile from root file, if there is a depencency relatetion, improve performance and provide more dignostic.+ let new_state = case maybe_virtual_file of+ Nothing -> state {stateProgram = Just new_loaded_prog} -- should never happen+ Just virtual_file -> updateStaleContent path virtual_file new_loaded_prog state+ pure $ Right new_state {stateFailed = Nothing, stateDiagnosed = diagnosed} Left prog_error -> do- logWithSeverity Debug <& "Compilation failed, publishing diagnostics"- publishErrorDiagnostics prog_error- pure emptyState+ logWithSeverity Debug <& "Compilation failed"+ showUnlocatedErrors prog_error+ attempt <- compileAttempt path+ pure $ Left state {stateFailed = attempt, stateDiagnosed = diagnosed} getLoadedProg :: State -> LoadedProg getLoadedProg state = fromMaybe noLoadedProg (stateProgram state)
src/Futhark/LSP/Diagnostic.hs view
@@ -1,10 +1,17 @@ -- | Handling of diagnostics in the language server - things like -- warnings and errors.+--+-- Every compilation produces the diagnostics for the entire program,+-- so publishing them replaces everything previously published. We+-- do not use the incremental diagnostic store of the lsp library, as+-- its notion of replacement depends on document versions recorded+-- at earlier publications. module Futhark.LSP.Diagnostic- ( publishWarningDiagnostics,- publishErrorDiagnostics,- diagnosticSource,- maxDiagnostic,+ ( Diagnostics,+ warningDiagnostics,+ errorDiagnostics,+ showUnlocatedErrors,+ publishDiagnostics, ) where @@ -13,17 +20,21 @@ import Data.Foldable (for_) import Data.List.NonEmpty qualified as NE import Data.Map qualified as M+import Data.Set qualified as S import Data.Text qualified as T import Futhark.Compiler.Program (ProgError (..)) import Futhark.LSP.Tool (logWithSeverity, posToUri, rangeFromLoc) import Futhark.Util (showText) import Futhark.Util.Loc (Loc (..)) import Futhark.Util.Pretty (Doc, docText)-import Language.LSP.Diagnostics (partitionBySource)-import Language.LSP.Protocol.Lens (HasVersion (version))+import Language.LSP.Protocol.Message (SMethod (SMethod_TextDocumentPublishDiagnostics, SMethod_WindowShowMessage)) import Language.LSP.Protocol.Types-import Language.LSP.Server (LspT, getVersionedTextDoc, publishDiagnostics)+import Language.LSP.Server (LspT, sendNotification)+import Language.LSP.VFS (VFS, VirtualFileEntry (..), vfsMap, virtualFileVersion) +-- | The diagnostics of every file that has any.+type Diagnostics = M.Map NormalizedUri [Diagnostic]+ mkDiagnostic :: Range -> DiagnosticSeverity -> T.Text -> Diagnostic mkDiagnostic range severity msg = Diagnostic@@ -37,58 +48,63 @@ Nothing Nothing --- | Publish diagnostics from a Uri to Diagnostics mapping.-publish :: [(Uri, [Diagnostic])] -> LspT () IO ()-publish uri_diags_map = for_ uri_diags_map $ \(uri, diags) -> do- doc <- getVersionedTextDoc $ TextDocumentIdentifier uri- logWithSeverity Debug- <& ("Publishing diagnostics for " <> showText uri <> " Version: " <> showText (doc ^. version))- publishDiagnostics- maxDiagnostic- (toNormalizedUri uri)- (Just $ doc ^. version)- (partitionBySource diags)+-- | A diagnostic for the file containing the given location, if it+-- has one.+diagnosticAt :: Loc -> DiagnosticSeverity -> Doc a -> Diagnostics+diagnosticAt NoLoc _ _ = mempty+diagnosticAt loc@(Loc pos _) severity msg =+ M.singleton+ (toNormalizedUri $ posToUri pos)+ [mkDiagnostic (rangeFromLoc loc) severity (docText msg)] --- | Send warning diagnostics to the client.-publishWarningDiagnostics :: [(Loc, Doc a)] -> LspT () IO ()-publishWarningDiagnostics warnings = do- publish $ M.assocs $ M.unionsWith (++) $ map onWarn warnings+-- | Diagnostics for the warnings of a successful compilation.+warningDiagnostics :: [(Loc, Doc a)] -> Diagnostics+warningDiagnostics = M.unionsWith (++) . map onWarn where- onWarn (NoLoc, _) = mempty- onWarn (loc@(Loc pos _), msg) =- M.singleton- (posToUri pos)- [ mkDiagnostic- (rangeFromLoc loc)- DiagnosticSeverity_Warning- (docText msg)- ]+ onWarn (loc, msg) = diagnosticAt loc DiagnosticSeverity_Warning msg --- | Send error diagnostics to the client.-publishErrorDiagnostics :: NE.NonEmpty ProgError -> LspT () IO ()-publishErrorDiagnostics errors =- publish $ M.assocs $ M.unionsWith (++) $ map onDiag $ NE.toList errors+-- | Diagnostics for the problems of a failed compilation.+errorDiagnostics :: NE.NonEmpty ProgError -> Diagnostics+errorDiagnostics = M.unionsWith (++) . map onDiag . NE.toList where- onDiag (ProgError NoLoc _) = mempty- onDiag (ProgError loc@(Loc pos _) msg) =- M.singleton- (posToUri pos)- [ mkDiagnostic- (rangeFromLoc loc)- DiagnosticSeverity_Error- (docText msg)- ]- onDiag (ProgWarning NoLoc _) = mempty- onDiag (ProgWarning loc@(Loc pos _) msg) =- M.singleton- (posToUri pos)- [ mkDiagnostic- (rangeFromLoc loc)- DiagnosticSeverity_Error- (docText msg)- ]+ onDiag (ProgError loc msg) = diagnosticAt loc DiagnosticSeverity_Error msg+ onDiag (ProgWarning loc msg) = diagnosticAt loc DiagnosticSeverity_Warning msg --- | The maximum number of diagnostics to report.+-- | Errors without a location cannot be attached to a file, so they+-- are shown as messages.+showUnlocatedErrors :: NE.NonEmpty ProgError -> LspT () IO ()+showUnlocatedErrors = mapM_ showUnlocated+ where+ showUnlocated (ProgError NoLoc msg) = showMessage MessageType_Error msg+ showUnlocated (ProgWarning NoLoc msg) = showMessage MessageType_Warning msg+ showUnlocated _ = pure ()++ showMessage message_type msg =+ sendNotification SMethod_WindowShowMessage $+ ShowMessageParams message_type (docText msg)++-- | Publish the diagnostics of a compilation of the given VFS, for+-- every open file and every file in the given set of files that were+-- previously published for. Returns the files that now have+-- diagnostics. A client may discard a publication for a document it+-- has since changed, so open files are published for even when they+-- have no diagnostics.+publishDiagnostics :: VFS -> S.Set NormalizedUri -> Diagnostics -> LspT () IO (S.Set NormalizedUri)+publishDiagnostics vfs previous diagnostics = do+ let versions = M.mapMaybe openVersion $ vfs ^. vfsMap+ targets = previous <> M.keysSet versions+ for_ (M.toList $ diagnostics <> M.fromSet (const []) targets) $ \(uri, diags) -> do+ let version = M.lookup uri versions+ logWithSeverity Debug+ <& ("Publishing diagnostics for " <> showText uri <> " Version: " <> showText version)+ sendNotification SMethod_TextDocumentPublishDiagnostics $+ PublishDiagnosticsParams (fromNormalizedUri uri) version (take maxDiagnostic diags)+ pure $ M.keysSet diagnostics+ where+ openVersion (Open file) = Just $ virtualFileVersion file+ openVersion (Closed _) = Nothing++-- | The maximum number of diagnostics to report for a file. maxDiagnostic :: Int maxDiagnostic = 100
src/Futhark/LSP/Handlers.hs view
@@ -15,6 +15,7 @@ import Data.Bifunctor (bimap, first) import Data.Function ((&)) import Data.IORef (IORef)+import Data.Maybe (fromMaybe) import Data.Proxy (Proxy (..)) import Data.Text (Text) import Data.Text qualified as T@@ -48,14 +49,15 @@ DidChangeTextDocumentParams (DidChangeTextDocumentParams), DidSaveTextDocumentParams (DidSaveTextDocumentParams), DocumentFormattingParams (DocumentFormattingParams),- ErrorCodes (ErrorCodes_InvalidParams, ErrorCodes_InvalidRequest, ErrorCodes_ParseError),+ ErrorCodes (ErrorCodes_InvalidParams, ErrorCodes_InvalidRequest), HoverParams (HoverParams),- LSPErrorCodes,+ LSPErrorCodes (LSPErrorCodes_RequestFailed), Null (..), Position (Position, _character, _line), Range (Range, _end, _start),+ SemanticTokens (SemanticTokens, _data_, _resultId), TextEdit (TextEdit, _newText, _range),- Uri (Uri),+ Uri (..), toNormalizedUri, uriToFilePath, type (|?) (..),@@ -114,11 +116,13 @@ file_path = uriToFilePath $ doc ^. uri tryReCompile state_mvar file_path --- Some clients (Eglot) sends open/close events whether we want them--- or not, so we better be prepared to ignore them.-onDocumentOpenHandler :: Handlers (LspM ())-onDocumentOpenHandler = notificationHandler SMethod_TextDocumentDidOpen $ \_ -> pure ()+onDocumentOpenHandler :: IORef State -> Handlers (LspM ())+onDocumentOpenHandler state_mvar =+ notificationHandler SMethod_TextDocumentDidOpen $ \msg ->+ tryReCompile state_mvar $ uriToFilePath $ msg ^. params . textDocument . uri +-- Nothing to do when a document is closed, but we ask for the+-- notification, so we must handle it. onDocumentCloseHandler :: Handlers (LspM ()) onDocumentCloseHandler = notificationHandler SMethod_TextDocumentDidClose $ \_msg -> pure () @@ -139,13 +143,12 @@ result <- runExceptT $ do virtualFile <- getVirtualFile' fileUri let fileText = R.toText $ virtualFile ^. file_text- formattedText <- fmtToText' (show fileUri) fileText+ formattedText <- fmtToText' (fromMaybe (T.unpack (getUri fileUri)) (uriToFilePath fileUri)) fileText pure $ if formattedText == fileText then InR Null else InL [fullTextEdit formattedText] - logWithSeverity Debug <& showText result report result where fullTextEdit newText =@@ -180,8 +183,8 @@ syntaxErrorResponse (SyntaxError loc msg) = TResponseError- { _code = InR ErrorCodes_ParseError,- _message = "Syntax Error at " <> locText loc <> ":\n" <> prettyText msg,+ { _code = InL LSPErrorCodes_RequestFailed,+ _message = "Syntax error at " <> locText loc <> ":\n" <> prettyText msg, _xdata = Nothing } @@ -192,6 +195,15 @@ _code = InR ErrorCodes_InvalidParams } +-- The lsp library always advertises the semanticTokens capability,+-- and some clients (Eglot) then request full semantic tokens whether+-- we registered a handler or not. We do not compute semantic tokens,+-- so we answer with none.+onDocumentSemanticTokensFull :: Handlers (LspM ())+onDocumentSemanticTokensFull =+ requestHandler SMethod_TextDocumentSemanticTokensFull $ \_ respond ->+ respond $ Right $ InL $ SemanticTokens {_resultId = Nothing, _data_ = []}+ onDocumentCodeLenses :: Handlers (LspM ()) onDocumentCodeLenses = requestHandler SMethod_TextDocumentCodeLens $ \request respond -> do@@ -292,11 +304,12 @@ handlers state_mvar _ = mconcat [ onInitializeHandler,- onDocumentOpenHandler,+ onDocumentOpenHandler state_mvar, onDocumentCloseHandler, onDocumentCodeLenses, onDocumentCodeLensResolve, onDocumentFormattingHandler,+ onDocumentSemanticTokensFull, onTextDocumentInlayHint state_mvar, onTextDocumentCodeAction state_mvar, onDocumentSaveHandler state_mvar,
src/Futhark/LSP/State.hs view
@@ -9,9 +9,12 @@ ) where +import Data.Int (Int32) import Data.Map qualified as M+import Data.Set qualified as S import Futhark.Compiler.Program (LoadedProg) import Futhark.LSP.PositionMapping (PositionMapping, StaleFile (..))+import Language.LSP.Protocol.Types (NormalizedUri) import Language.LSP.VFS (VirtualFile) -- | The state of the language server.@@ -20,12 +23,18 @@ stateProgram :: Maybe LoadedProg, -- | The stale data, stored to provide PositionMapping when requested. -- All files that have been opened have an entry.- staleData :: M.Map FilePath StaleFile+ staleData :: M.Map FilePath StaleFile,+ -- | The file and version of the most recent compilation, if it+ -- failed. Used to avoid recompiling unchanged files.+ stateFailed :: Maybe (FilePath, Int32),+ -- | The files for which the most recent compilation published+ -- diagnostics. These must be cleared by the next compilation.+ stateDiagnosed :: S.Set NormalizedUri } -- | Initial state. emptyState :: State-emptyState = State Nothing M.empty+emptyState = State Nothing M.empty Nothing S.empty -- | Get the contents of a stale (last successfully complied) file's contents. getStaleContent :: State -> FilePath -> Maybe VirtualFile@@ -42,7 +51,10 @@ -- NOTE: insert will replace the old value if the key already exists. -- updateStaleContent is only called after a successful type-check, -- so the PositionsMapping should be Nothing here, it's calculated after failed type-check.- State (Just loadedProg) (M.insert file_path (StaleFile file_content Nothing) (staleData state))+ state+ { stateProgram = Just loadedProg,+ staleData = M.insert file_path (StaleFile file_content Nothing) (staleData state)+ } -- | Update the state with another pair of file_path and PositionMapping. updateStaleMapping :: Maybe FilePath -> Maybe PositionMapping -> State -> State@@ -50,5 +62,5 @@ case M.lookup file_path (staleData state) of Nothing -> state -- Only happends when the file have never been successfully type-checked before. Just (StaleFile file_content _mapping) ->- State (stateProgram state) (M.insert file_path (StaleFile file_content mapping) (staleData state))+ state {staleData = M.insert file_path (StaleFile file_content mapping) (staleData state)} updateStaleMapping _ _ state = state
src/Futhark/LSP/Tool.hs view
@@ -36,7 +36,7 @@ toStalePos, ) import Futhark.LSP.State (State (..), getStaleContent, getStaleMapping)-import Futhark.Util.Loc (Loc (Loc, NoLoc), Pos (Pos), contains, locOf)+import Futhark.Util.Loc (Loc (Loc, NoLoc), Pos (Pos), locOf) import Futhark.Util.Pretty (prettyText) import Language.Futhark.Core (VName, isBuiltinLoc) import Language.Futhark.Query@@ -153,19 +153,13 @@ posToUri :: Pos -> Uri posToUri (Pos file _ _ _) = filePathToUri file --- Futhark's parser has a slightly different notion of locations than--- LSP; so we tweak the positions here.-getStartPos :: Pos -> Position-getStartPos (Pos _ l c _) =+toLspPosition :: Pos -> Position+toLspPosition (Pos _ l c _) = Position (toEnum l - 1) (toEnum c - 1) -getEndPos :: Pos -> Position-getEndPos (Pos _ l c _) =- Position (toEnum l - 1) (toEnum c)- -- | Create an LSP 'Range' from a Futhark 'Loc'. rangeFromLoc :: Loc -> Range-rangeFromLoc (Loc start end) = Range (getStartPos start) (getEndPos end)+rangeFromLoc (Loc start end) = Range (toLspPosition start) (toLspPosition end) rangeFromLoc NoLoc = Range (Position 0 0) (Position 0 5) -- only when file not found, throw error after moving to vfs -- | Transform VFS to a map of file paths to file contents.@@ -206,11 +200,11 @@ posEnd <- toStalePos mapping $ mkPos l2 c2 pure $ F.toList t- & filter (isInRange (Loc posStart posEnd) . f)+ & filter (isInRange posStart posEnd . f) where- isInRange locRange pos = case pos of+ isInRange range_start range_end loc = case loc of NoLoc -> False- Loc start _ -> locRange `contains` start+ Loc start _ -> start >= range_start && start <= range_end -- increment by one: Pos counts from one onwards, LSP starts at zero mkPos :: UInt -> UInt -> Pos mkPos l c = Pos filepath (1 + fromIntegral l) (1 + fromIntegral c) (-1)
src/Futhark/Optimise/ArrayShortCircuiting/ArrayCoalescing.hs view
@@ -12,6 +12,7 @@ import Control.Exception.Base qualified as Exc import Control.Monad+import Control.Monad.Identity import Control.Monad.Reader import Control.Monad.State.Strict import Data.Function ((&))@@ -539,11 +540,11 @@ | Just (MemBlock tp return_shp return_mem _) <- getScopeMemInfo return_name $ scope td_env <> scopeOf (bodyStms kernel_body), lvlOK lvl,- MemMem pat_space <- runReader (lookupMemInfo pat_mem) $ removeScopeAliases $ scope td_env,+ MemMem pat_space <- memInfo (scope td_env) pat_mem, MemMem return_space <-- scope td_env <> scopeOf (bodyStms kernel_body) <> scopeOfSegSpace space- & removeScopeAliases- & runReader (lookupMemInfo return_mem),+ memInfo+ (scope td_env <> scopeOf (bodyStms kernel_body) <> scopeOfSegSpace space)+ return_mem, pat_space == return_space = case M.lookup pat_mem active of Nothing ->@@ -1665,11 +1666,15 @@ Just FParamName {} -> True _ -> False +-- | The memory information of a name, which must be in scope.+memInfo :: (Coalesceable rep inner) => ScopeTab rep -> VName -> MemInfo SubExp NoMode MemBind+memInfo scope v = runIdentity $ runWithoutAliases (lookupMemInfo v) scope+ -- | The space of a memory block, if it is in scope. memSpace :: (Coalesceable rep inner) => TopdownEnv rep -> VName -> Maybe Space memSpace td_env m | Just (MemMem space) <-- nameInfoToMemInfo <$> M.lookup m (removeScopeAliases (scope td_env)) =+ nameInfoToMemInfo . removeNameInfoAliases <$> M.lookup m (scope td_env) = Just space | otherwise = Nothing
src/Futhark/Optimise/InliningDeadFun.hs view
@@ -144,7 +144,7 @@ onExp (Just u) (Apply fname _ _ _) = modify $ M.insertWith max fname u onExp Nothing Apply {} = pure () onExp u e = walkExpM (walker u) e- onSOAC u soac = void $ traverseSOACStms (const (traverse (onStm u'))) soac+ onSOAC u soac = void $ traverseSOACBodies (\_ body -> body <$ traverse (onStm u') (bodyStms body)) soac where u' = max u $ Just $ usage soac usage JVP {} = InAD@@ -294,7 +294,9 @@ inliner = (identityMapper @SOACS) { mapOnBody = const onBody,- mapOnOp = traverseOpStms $ \_ -> inline . stmsToList+ mapOnOp = traverseOpBodies $ \_ body -> do+ stms <- inline $ stmsToList $ bodyStms body+ pure body {bodyStms = stms} } traceLocs :: Provenance -> StmAux () -> StmAux ()@@ -357,7 +359,7 @@ -- | Remove functions not ultimately called from an entry point or a -- constant.-removeDeadFunctionsF :: (TraverseOpStms rep) => Prog rep -> Prog rep+removeDeadFunctionsF :: (TraverseOpBodies rep) => Prog rep -> Prog rep removeDeadFunctionsF prog = let cg = buildCallGraph prog live_funs = filter ((`isFunInCallGraph` cg) . funDefName) $ progFuns prog@@ -385,7 +387,7 @@ -- | @removeDeadFunctions prog@ removes the functions that are unreachable from -- the main function from the program.-removeDeadFunctions :: (TraverseOpStms rep) => Pass rep rep+removeDeadFunctions :: (TraverseOpBodies rep) => Pass rep rep removeDeadFunctions = Pass { passName = "Remove dead functions",
src/Futhark/Optimise/Simplify/Engine.hs view
@@ -221,11 +221,24 @@ put (a, b, mempty) pure (x, cs) --- | Mark that we have changed something and it would be a good idea--- to re-run the simplifier.+-- | Mark that we have changed something so we can run the simplifier again, to+-- a fixed point. changed :: SimpleM rep () changed = modify $ \(src, _, cs) -> (src, True, cs) +-- | Run the computation and report whether it changed anything. If not, we can+-- reuse the original code, along with its precomputed information. This saves+-- on redundantly recomputing annotations, although the savings are likely+-- marginal.+collectChanged :: SimpleM rep a -> SimpleM rep (a, Bool)+collectChanged m = do+ (src, old, cs) <- get+ put (src, False, cs)+ x <- m+ (src', new, cs') <- get+ put (src', old || new, cs')+ pure (x, new)+ usedCerts :: Certs -> SimpleM rep () usedCerts cs = modify $ \(a, b, c) -> (a, b, cs <> c) @@ -427,12 +440,14 @@ (SimplifiableRep rep) => Stm (Wise rep) -> SimpleM rep (Stm (Wise rep))-nonrecSimplifyStm (Let pat (StmAux cs attrs loc (_, dec)) e) = do- cs' <- simplify cs- e' <- simplifyExpBase e- (pat', pat_cs) <- collectCerts $ traverse (simplify . snd) pat- let aux' = StmAux (cs' <> pat_cs) attrs loc dec- pure $ mkWiseStm pat' aux' e'+nonrecSimplifyStm stm@(Let pat (StmAux cs attrs loc (_, dec)) e) = do+ (stm', changed') <- collectChanged $ do+ cs' <- simplify cs+ e' <- simplifyExpBase e+ (pat', pat_cs) <- collectCerts $ traverse (simplify . snd) pat+ let aux' = StmAux (cs' <> pat_cs) attrs loc dec+ pure $ mkWiseStm pat' aux' e'+ pure $ if changed' then stm' else stm -- Bottom-up simplify a statement. Recurses into sub-Bodies and Ops. -- Does not copy-propagate into the pattern and similar, as it is@@ -443,10 +458,14 @@ Stm (Wise rep) -> UT.UsageTable -> SimpleM rep (Stms (Wise rep), Stm (Wise rep))-recSimplifyStm (Let pat (StmAux cs attrs loc (_, dec)) e) usage = do- ((e', e_hoisted), e_cs) <- collectCerts $ simplifyExp (usage <> UT.usageInPat pat) pat e+recSimplifyStm stm@(Let pat (StmAux cs attrs loc (_, dec)) e) usage = do+ (((e', e_hoisted), e_cs), changed') <-+ collectChanged . collectCerts $ simplifyExp (usage <> UT.usageInPat pat) pat e let aux' = StmAux (cs <> e_cs) attrs loc dec- pure (e_hoisted, mkWiseStm (removePatWisdom pat) aux' e')+ pure $+ if changed' || e_cs /= mempty+ then (e_hoisted, mkWiseStm (removePatWisdom pat) aux' e')+ else (mempty, stm) hoistStms :: (SimplifiableRep rep) =>@@ -524,7 +543,9 @@ localVtable (ST.insertStm stms_h') $ hoistableStms usageInStm stms_t if not $ any (`UT.isUsedDirectly` usage) $ provides stms_h'- then -- Dead statement.+ then do+ -- Dead statement.+ changed pure (x, usage, stms_t') else do (stms_h_stms, stms_h'') <- recSimplifyStm stms_h' usage@@ -736,13 +757,14 @@ [UT.Usages] -> Body (Wise rep) -> SimpleM rep (Stms (Wise rep), Body (Wise rep))-simplifyBody blocker usage res_usages (Body _ stms res) = do- (res', stms', hoisted) <-- blockIf blocker stms $ do+simplifyBody blocker usage res_usages body@(Body _ stms res) = do+ ((res', stms', hoisted), changed') <-+ collectChanged . blockIf blocker stms $ do (res', res_usage) <- simplifyResult res_usages res pure (res', res_usage <> usage)- body' <- constructBody stms' res'- pure (hoisted, body')+ if changed'+ then (hoisted,) <$> constructBody stms' res'+ else pure (mempty, body) -- | Simplify a single body. simplifyBodyNoHoisting ::@@ -951,6 +973,7 @@ | commutativeBinOp op = do x' <- simplify x y' <- simplify y+ when (x' > y') changed pure $ BasicOp $ BinOp op (min x' y') (max x' y') simplifyExpBase e = mapExpM hoist e where@@ -969,7 +992,7 @@ Simplifiable (LParamInfo rep), Simplifiable (RetType rep), Simplifiable (BranchType rep),- TraverseOpStms (Wise rep),+ TraverseOpBodies (Wise rep), CanBeWise (OpC rep), ST.IndexOp (Op (Wise rep)), IsOp (OpC rep),@@ -1115,7 +1138,10 @@ instance Simplifiable Certs where simplify (Certs []) = pure (Certs [])- simplify (Certs ocs) = Certs . nubOrd . concat <$> mapM check ocs+ simplify (Certs ocs) = do+ ocs' <- nubOrd . concat <$> mapM check ocs+ when (ocs' /= ocs) changed+ pure $ Certs ocs' where check idd = do vv <- ST.lookupSubExp idd <$> askVtable
src/Futhark/Optimise/Simplify/Rule.hs view
@@ -143,7 +143,9 @@ Rule rep -- | A simplification rule takes some argument and a statement, and--- tries to simplify the statement.+-- tries to simplify the statement. Rules must construct new bodies and+-- statements with e.g. 'mkBodyM' and 'letBind', not by modifying+-- existing ones, as their precomputed information would then be wrong. data SimplificationRule rep a = RuleGeneric (RuleGeneric rep a) | RuleBasicOp (RuleBasicOp rep a)
src/Futhark/Optimise/Simplify/Rules.hs view
@@ -41,7 +41,7 @@ RuleGeneric toScratch ] -bottomUpRules :: (BuilderOps rep, TraverseOpStms rep) => [BottomUpRule rep]+bottomUpRules :: (BuilderOps rep, TraverseOpBodies rep) => [BottomUpRule rep] bottomUpRules = [ RuleGeneric withAccBottomUp, RuleBasicOp simplifyIndex@@ -50,7 +50,7 @@ -- | A set of standard simplification rules. These assume pure -- functional semantics, and so probably should not be applied after -- memory block merging.-standardRules :: (BuilderOps rep, TraverseOpStms rep) => RuleBook rep+standardRules :: (BuilderOps rep, TraverseOpBodies rep) => RuleBook rep standardRules = ruleBook topDownRules bottomUpRules <> loopRules@@ -222,28 +222,36 @@ pure $ Just x withAccTopDown _ _ = Skip -elimUpdates :: forall rep. (ASTRep rep, TraverseOpStms rep) => [VName] -> Body rep -> (Body rep, [VName])-elimUpdates get_rid_of = flip runState mempty . onBody+elimUpdates ::+ forall rep.+ (BuilderOps rep, TraverseOpBodies rep) =>+ [VName] ->+ Body rep ->+ RuleM rep (Body rep, [VName])+elimUpdates get_rid_of = flip runStateT mempty . onBody where+ onBody :: (IsResult res) => GBody rep res -> StateT [VName] (RuleM rep) (GBody rep res) onBody body = do- stms' <- onStms $ bodyStms body- pure body {bodyStms = stms'}- onStms = traverse onStm+ stms' <- traverse onStm $ bodyStms body+ lift $ mkBodyM stms' $ bodyResult body onStm (Let pat@(Pat [PatElem _ dec]) aux (BasicOp (UpdateAcc _ acc _ _))) | Acc c _ _ <- typeOf dec, c `elem` get_rid_of = do modify (insert c)- pure $ Let pat aux $ BasicOp $ SubExp $ Var acc- onStm (Let pat aux e) = Let pat aux <$> onExp e+ mkStm pat aux $ BasicOp $ SubExp $ Var acc+ onStm (Let pat aux e) = mkStm pat aux =<< onExp e+ mkStm pat aux e = do+ dec <- lift $ mkExpDecM pat e+ pure $ Let pat aux {stmAuxDec = dec} e onExp = mapExpM mapper where mapper =- (identityMapper :: forall m. (Monad m) => Mapper rep rep m)- { mapOnOp = traverseOpStms (\_ stms -> onStms stms),- mapOnBody = \_ body -> onBody body+ (identityMapper :: Mapper rep rep (StateT [VName] (RuleM rep)))+ { mapOnOp = traverseOpBodies (const onBody),+ mapOnBody = const onBody } -withAccBottomUp :: (TraverseOpStms rep, BuilderOps rep) => BottomUpRuleGeneric rep+withAccBottomUp :: (TraverseOpBodies rep, BuilderOps rep) => BottomUpRuleGeneric rep -- Eliminate dead results. See Note [Dead Code Elimination for WithAcc] withAccBottomUp (_, utable) (Let pat aux (WithAcc inputs lam)) | not $ all (`UT.used` utable) $ patNames pat = Simplify $ do@@ -267,7 +275,7 @@ when (null get_rid_of && nonacc_pes' == nonacc_pes) cannotSimplify - let (body', eliminated) = elimUpdates get_rid_of $ lambdaBody lam+ (body', eliminated) <- elimUpdates get_rid_of $ lambdaBody lam when (null eliminated && nonacc_pes' == nonacc_pes) cannotSimplify
src/Futhark/Optimise/Simplify/Rules/BasicOp.hs view
@@ -160,6 +160,7 @@ ruleBasicOp vtable pat aux (Update safety src (Slice [DimSlice i n s]) (Var v)) | isCt1 n, isCt1 s,+ Just 1 <- arrayRank <$> ST.lookupType v vtable, Just (ST.Indexed cs e) <- ST.index v [intConst Int64 0] vtable = Simplify $ do e' <- toSubExp "update_elem" e
src/Futhark/Optimise/Simplify/Rules/Index.hs view
@@ -9,6 +9,7 @@ import Control.Monad (guard) import Data.Bifunctor (first)+import Data.Bits qualified as Bits import Data.List qualified as L import Data.List.NonEmpty (NonEmpty (..)) import Data.Maybe@@ -178,7 +179,7 @@ pure $ IndexResult cs arr $ Slice $ ds_inds' ++ rest_inds where index DimFix {} = Nothing- index (DimSlice _ n s) = Just (n, DimSlice (constant (0 :: Int64)) n s)+ index (DimSlice _ n _) = Just (n, DimSlice (constant (0 :: Int64)) n (constant (1 :: Int64))) Just (Replicate (Shape []) (Var src), cs) | Just dims <- arrayDims <$> seType (Var src), length inds == length dims,@@ -266,7 +267,12 @@ worthInlining e | primExpSizeAtLeast 20 e = False -- totally ad-hoc. | otherwise = worthInlining' e- worthInlining' (BinOpExp Pow {} _ _) = False+ worthInlining' (BinOpExp SPow {} (ValueExp (IntValue x)) _) =+ isPowOf2 (valueIntegral x)+ worthInlining' (BinOpExp SPow {} _ _) = False+ worthInlining' (BinOpExp UPow {} (ValueExp (IntValue x)) _) =+ isPowOf2 (valueIntegral x)+ worthInlining' (BinOpExp UPow {} _ _) = False worthInlining' (BinOpExp FPow {} _ _) = False worthInlining' (BinOpExp _ x y) = worthInlining' x && worthInlining' y worthInlining' (CmpOpExp _ x y) = worthInlining' x && worthInlining' y@@ -278,6 +284,9 @@ | isJust $ isCondFun f = all worthInlining' args | otherwise = False worthInlining' _ = True++ isPowOf2 :: Integer -> Bool+ isPowOf2 x = x > 0 && x Bits..&. (x - 1) == 0 isConcat v | Just (Concat {}, _) <- defOf v =
src/Futhark/Optimise/Simplify/Rules/Loop.hs view
@@ -95,8 +95,8 @@ Skip (invariant, explpat', merge', res') -> Simplify . auxing aux $ do -- We have moved something invariant out of the loop.- let loopbody' = loopbody {bodyResult = res'}- explpat'' = map fst explpat'+ loopbody' <- mkBodyM (bodyStms loopbody) res'+ let explpat'' = map fst explpat' forM_ invariant $ \(v1, (v2, cs)) -> certifying cs $ letBindNames [identName v1] $ BasicOp $ SubExp v2 letBind (Pat explpat'') $ Loop merge' form loopbody'
src/Futhark/Optimise/Simplify/Rules/Match.hs view
@@ -148,10 +148,10 @@ then Skip else Simplify $ do ctx_fixes <- sequence hoistings- let onCase (Case vs body) case_res = Case vs $ body {bodyResult = case_res}- cases' = zipWith onCase cases $ transpose case_reses_tr- defbody' = defbody {bodyResult = defbody_res'}+ let onCase (Case vs body) case_res = Case vs <$> mkBodyM (bodyStms body) case_res ret' = foldr (uncurry fixExt) ts ctx_fixes+ cases' <- zipWithM onCase cases $ transpose case_reses_tr+ defbody' <- mkBodyM (bodyStms defbody) defbody_res' -- We may have to add some reshapes if we made the type -- less existential. cases'' <- mapM (traverse $ reshapeBodyResults $ map extTypeOf ret') cases'
src/Futhark/Optimise/Simplify/Rules/Simple.hs view
@@ -141,13 +141,10 @@ | isCt0 e2 = Nothing simplifyBinOp _ _ (BinOp (SRem t _) e1 e2) | isCt1 e2 = constRes $ IntValue $ intValue t (0 :: Int)- | e1 == e2 = constRes $ IntValue $ intValue t (1 :: Int)+ | e1 == e2 = constRes $ IntValue $ intValue t (0 :: Int) simplifyBinOp _ _ (BinOp SQuot {} e1 e2) | isCt1 e2 = resIsSubExp e1 | isCt0 e2 = Nothing-simplifyBinOp _ _ (BinOp (Pow t) e1 e2)- | e1 == intConst t 2 =- Just (BinOp (Shl t) (intConst t 1) e2, mempty) simplifyBinOp _ _ (BinOp (FPow t) e1 e2) | isCt0 e2 = resIsSubExp $ floatConst t 1 | isCt0 e1 || isCt1 e1 || isCt1 e2 = resIsSubExp e1@@ -338,25 +335,30 @@ Just (Update safety dest slice' $ Var v', v_cs) simplifyUpdateReshape _ _ _ = Nothing --- | If we are replicating a scratch array (possibly indirectly), just--- turn it into a scratch by itself.+-- | If we are replicating or manifesting a scratch array (possibly+-- indirectly), just turn it into a scratch by itself. repScratchToScratch :: SimpleRule rep repScratchToScratch defOf seType (Replicate shape (Var src)) = do t <- seType $ Var src- cs <- isActuallyScratch src+ cs <- isActuallyScratch defOf src pure (Scratch (elemType t) (shapeDims shape <> arrayDims t), cs)- where- isActuallyScratch v =- case defOf v of- Just (BasicOp Scratch {}, cs) ->- Just cs- Just (BasicOp (Rearrange v' _), cs) ->- (cs <>) <$> isActuallyScratch v'- Just (BasicOp (Reshape v' _), cs) ->- (cs <>) <$> isActuallyScratch v'- _ -> Nothing+repScratchToScratch defOf seType (Manifest src _) = do+ t <- seType $ Var src+ cs <- isActuallyScratch defOf src+ pure (Scratch (elemType t) (arrayDims t), cs) repScratchToScratch _ _ _ = Nothing++isActuallyScratch :: VarLookup rep -> VName -> Maybe Certs+isActuallyScratch defOf v =+ case defOf v of+ Just (BasicOp Scratch {}, cs) ->+ Just cs+ Just (BasicOp (Rearrange v' _), cs) ->+ (cs <>) <$> isActuallyScratch defOf v'+ Just (BasicOp (Reshape v' _), cs) ->+ (cs <>) <$> isActuallyScratch defOf v'+ _ -> Nothing simpleRules :: [SimpleRule rep] simpleRules =
src/Futhark/Pass/AD.hs view
@@ -32,8 +32,11 @@ Array {} -> Replicate mempty arg _ -> SubExp arg res <- bodyBind body- forM_ (zip (patNames pat) res) $ \(v, SubExpRes cs se) ->- certifying cs $ letBindNames [v] $ BasicOp $ SubExp se+ forM_ (zip (patElems pat) res) $ \(pe, SubExpRes cs se) ->+ certifying cs . letBindNames [patElemName pe] . BasicOp $+ case patElemType pe of+ Array {} -> Replicate mempty se+ _ -> SubExp se onStm :: Bool -> Mode -> Scope SOACS -> Stm SOACS -> PassM (Stms SOACS) onStm _ mode scope (Let pat aux (Op (VJP shape args vec lam))) = do
src/Futhark/Test.hs view
@@ -47,7 +47,7 @@ import Data.Text.IO qualified as T import Futhark.Compiler (readProgramFilesExceptKnown) import Futhark.Error (prettyCompilerError)-import Futhark.Eval (externaliseLast, interpretImports, runInterpreterWith)+import Futhark.Eval (Trust (Untrusted), externaliseLast, interpretImports, runInterpreterWith) import Futhark.FreshNames (VNameSource) import Futhark.Server import Futhark.Server.Values@@ -151,7 +151,9 @@ -- are dispatched to the server, files are read relative to the given directory, -- and traces and breakpoints are ignored. runScript :: FFI.Server -> FilePath -> F I.ExtOp a -> IO (Either I.InterpreterError a)-runScript server dir = runInterpreterWith (const $ pure ()) (Just server) (Just dir)+runScript server dir =+ -- Script expressions come from test specifications, which we do not trust.+ runInterpreterWith Untrusted (const $ pure ()) (Just server) (Just dir) -- | The entry points of the program (the last import). programEntryPoints :: Imports -> M.Map Name EntryPoint
src/Futhark/Test/Property.hs view
@@ -472,7 +472,7 @@ <> propName <> " failed with candidate=" <> valuePPrint- <> " with error: "+ <> " with error:\n" <> err if ok then loop i@@ -646,7 +646,7 @@ <> showText size <> " and seed=" <> showText seed- <> " with error: "+ <> " with error:\n" <> err liftIO $ renameVar srv serverIn genOut@@ -894,13 +894,15 @@ handleRuntimeError :: EntryName -> CmdFailure -> Maybe PBTFailure handleRuntimeError entry err- | isRuntimeError err = Just $ "Runtime error: " <> showText (failureMsg err)+ | isRuntimeError err =+ Just $+ "Runtime error: " <> T.intercalate "\n" (failureMsg err) | otherwise = unexpectedFailure $ "Fatal Error on " <> entry <> ": "- <> showText (failureMsg err)+ <> T.intercalate "\n" (failureMsg err) callKeepIns :: Server -> EntryName -> VarName -> [VarName] -> IO (Maybe PBTFailure) callKeepIns s entry out ins = do@@ -1042,7 +1044,13 @@ -- | Run a list of property specifications, returning a list of results. -- Each result is either a failure with an error message or a success.-runPBT :: PBTConfig -> Server -> [PropSpec] -> IORef PBTPhase -> FilePath -> IO [Either PBTFailure PBTOutput]+runPBT ::+ PBTConfig ->+ Server ->+ [PropSpec] ->+ IORef PBTPhase ->+ FilePath ->+ IO [Either PBTFailure PBTOutput] runPBT config srv specs entryNameRef program = forM specs $ \spec -> runOne spec config srv entryNameRef program
src/Futhark/Util/Loc.hs view
@@ -3,8 +3,11 @@ import Data.Loc +-- | Does the location of the given thing contain the given position?+-- The end of a 'Loc' is exclusive: it is the position just after the+-- last character. contains :: (Located a) => a -> Pos -> Bool contains a pos = case locOf a of- Loc start end -> pos >= start && pos <= end+ Loc start end -> pos >= start && pos < end NoLoc -> False
src/Language/Futhark/Interpreter.hs view
@@ -31,6 +31,7 @@ -- * IO IOOp,+ safeIO, determineIO, doIOOp, ioRelativeTo,@@ -1819,7 +1820,8 @@ breakOnNaN [x', y'] z pure $ ValuePrim z _- | Just x' <- getAD x,+ | not (isPrim x && isPrim y),+ Just x' <- getAD x, Just y' <- getAD y, Just (z, i') <- msum $ map (`bopDefAD` (x', y', i)) fs -> do putCounter i'@@ -1838,6 +1840,10 @@ y' <- valf y retf =<< op x' y' bopDefAD (_, _, _, dop) (x, y, i) = dop x y i+ -- The AD operators do not check signedness, so we must not+ -- fall back to them for ordinary values.+ isPrim ValuePrim {} = True+ isPrim _ = False unopDef fs = fun1 $ \x -> do i <- getCounter@@ -1918,7 +1924,12 @@ def "+" = arithOp (`P.Add` P.OverflowWrap) P.FAdd def "-" = arithOp (`P.Sub` P.OverflowWrap) P.FSub def "*" = arithOp (`P.Mul` P.OverflowWrap) P.FMul- def "**" = arithOp P.Pow P.FPow+ def "**" =+ Just $+ bopDef $+ sintOp P.SPow+ ++ uintOp P.UPow+ ++ floatOp P.FPow def "/" = Just $ bopDef $@@ -2462,8 +2473,13 @@ def fname | nameFromText fname `M.member` namesToPrimTypes = Nothing | Just op <- determineIO fname =- Just $ TermPoly Nothing $ \t ->- pure $ ValueFun $ doIO <=< op (evalTypeFully t) <=< force+ Just $ TermPoly Nothing $ \t -> pure $ case op of+ IOUnary f ->+ ValueFun $ doIO <=< f (evalTypeFully t) <=< force+ IOBinary f ->+ ValueFun $ \x -> pure $ ValueFun $ \y -> do+ x' <- force x+ doIO =<< f (evalTypeFully t) x' y def s = error $ "Missing intrinsic: " ++ T.unpack s tdef :: Name -> Maybe TypeBinding
src/Language/Futhark/Interpreter/FFI/ServerM.hs view
@@ -35,6 +35,8 @@ variants, mkSum, destruct,+ -- Files+ store, -- Error handling convenience throwNothing, )@@ -272,6 +274,16 @@ s <- askServer n <- varName vr either (const Nothing) Just <$> liftIO (FS.getValue s n)++-- | Write these values to this file, in the binary data format. Only values+-- that can be represented in that format can be written; an opaque value is+-- instead written in a form that only the same program can read back.+store :: FilePath -> [ValueRef] -> ServerM ()+store f vrs = do+ s <- askServer+ vns <- mapM varName vrs+ liftIO (FS.cmdStore s f vns)+ >>= throwServerJust ("cmdStore failed on file " ++ f ++ " with variables " ++ csList (map T.unpack vns) ++ ".") index :: [Int64] -> ValueRef -> ServerM ValueRef index is src = do
src/Language/Futhark/Interpreter/IO.hs view
@@ -1,6 +1,8 @@ -- | IO operations exposed through the interpreter. module Language.Futhark.Interpreter.IO ( IOOp (..),+ safeIO,+ IOIntrinsic (..), determineIO, doIOOp, ioRelativeTo,@@ -10,7 +12,10 @@ import Codec.BMP qualified as BMP import Control.Exception (SomeException, displayException, try) import Control.Monad+import Control.Monad.Except (ExceptT (..), liftEither, runExceptT) import Control.Monad.IO.Class+import Data.Bifunctor (first)+import Data.Binary qualified as Bin import Data.Bits import Data.ByteString qualified as BS import Data.ByteString.Lazy qualified as LBS@@ -35,6 +40,7 @@ prettyString, toStruct, )+import Language.Futhark.Interpreter.FFI.Push qualified as FFI import Language.Futhark.Interpreter.FFI.ServerM qualified as FFI import Language.Futhark.Interpreter.Values import System.Exit@@ -49,14 +55,42 @@ | LoadAudio FilePath | -- | Load a value of this type. LoadValue ValueType FilePath+ | -- | Write a value of this type to this file.+ forall m. SaveValue FilePath ValueType (Value m) +-- | Is this IO operation something that we allow in untrusted code, namely+-- @script input@. This is not a completely firm security boundary, as even safe+-- IO operations allow /reading/ of arbitrary files, but the idea is to make it+-- possible to benchmark untrusted Futhark programs (assuming you also use+-- @--safe@, of course).+safeIO :: IOOp -> Bool+safeIO SaveValue {} = False+safeIO _ = True++-- | An IO intrinsic, which determines its operation from the type at which it+-- is instantiated and its arguments, of which the first is always a file name.+-- The file name is fetched in full before the intrinsic sees it, but any other+-- argument is passed as-is, and so may contain references to values residing+-- on a server.+data IOIntrinsic m+ = IOUnary (m ValueType -> Value m -> m IOOp)+ | IOBinary (m ValueType -> Value m -> Value m -> m IOOp)++valueFilePath :: Value m -> FilePath+valueFilePath v = case asByteString v of+ Nothing -> error "IO operation: file name is not a string"+ Just v' -> T.unpack $ T.decodeUtf8 v'+ load :: (m ValueType -> FilePath -> m IOOp) ->- Maybe (m ValueType -> Value m -> m IOOp)-load c = Just $ \t v -> case asByteString v of- Nothing -> error "loadbytes: not a string"- Just v' -> c t $ T.unpack $ T.decodeUtf8 v'+ Maybe (IOIntrinsic m)+load c = Just $ IOUnary $ \t v -> c t $ valueFilePath v +save ::+ (m ValueType -> FilePath -> Value m -> m IOOp) ->+ Maybe (IOIntrinsic m)+save c = Just $ IOBinary $ \t fname v -> c t (valueFilePath fname) v+ primTypeToValueType :: PrimType -> V.PrimType primTypeToValueType (Signed Int8) = V.I8 primTypeToValueType (Signed Int16) = V.I16@@ -71,8 +105,9 @@ primTypeToValueType (FloatType Float64) = V.F64 primTypeToValueType Bool = V.Bool --- | The types of the values in a data file that can be loaded as a value of--- this type. A tuple corresponds to one value per element.+-- | The types of the values in a data file that a value of this type is+-- stored as, and that can be loaded as one. A tuple corresponds to one value+-- per element. typeToValueTypes :: ValueType -> Maybe [V.ValueType] typeToValueTypes t = mapM onValue $ fromMaybe [t] $ isTupleRecord t where@@ -87,17 +122,25 @@ loadResType t = error $ "loadResType: invalid type " <> prettyString t +saveArgType :: ValueType -> ValueType+saveArgType (Scalar (Arrow _ _ _ _ (RetType _ (Scalar (Arrow _ _ _ t _))))) = t+saveArgType t =+ error $ "saveArgType: invalid type " <> prettyString t+ -- | Determine which IO operation this is. -- -- If you want to add a new one, then remember to also add it as an intrinsic in -- the type checker, and probably also to the prelude.-determineIO :: (Monad m) => T.Text -> Maybe (m ValueType -> Value m -> m IOOp)+determineIO :: (Monad m) => T.Text -> Maybe (IOIntrinsic m) determineIO "io_loadbytes" = load $ const $ pure . LoadBytes determineIO "io_loadimg" = load $ const $ pure . LoadImg determineIO "io_loadaudio" = load $ const $ pure . LoadAudio determineIO "io_loadvalue" = load $ \t fname -> do t' <- t pure $ LoadValue (loadResType t') fname+determineIO "io_savevalue" = save $ \t fname v -> do+ t' <- t+ pure $ SaveValue fname (saveArgType t') v determineIO _ = Nothing {-# NOINLINE determineIO #-} @@ -204,6 +247,7 @@ ioRelativeTo dir (LoadImg f) = LoadImg $ dir </> f ioRelativeTo dir (LoadAudio f) = LoadAudio $ dir </> f ioRelativeTo dir (LoadValue t f) = LoadValue t $ dir </> f+ioRelativeTo dir (SaveValue f t v) = SaveValue (dir </> f) t v -- | Turn a loaded value into an interpreter value. Arrays are put on the server, -- if there is one, as they are very expensive to represent in the interpreter,@@ -220,6 +264,58 @@ =<< FFI.runServerM s (FFI.gc >> FFI.putData v) fromData _ v = pure $ fromDataValue v +doLoadValue :: Maybe FFI.Server -> [V.ValueType] -> FilePath -> IO (Either T.Text (Value m))+doLoadValue s ts fname = tryIO $ do+ vs <- loadValues fname+ let vs_ts = map V.valueType vs+ when (vs_ts /= ts) . fail $+ "Expected file \""+ <> fname+ <> "\" to contain data of types "+ <> unwords (map prettyString ts)+ <> " but found data of types "+ <> unwords (map prettyString vs_ts)+ asValue <$> mapM (fromData s) vs+ where+ asValue [v] = v+ asValue vs = toTuple vs++-- | Save a value of this type to this file. If the whole value resides on the+-- server, the server writes the file itself, so the data never passes through+-- us; otherwise we fetch whatever part of it is on the server (an array at a+-- time) and write the file ourselves.+doSaveValue ::+ Maybe FFI.Server ->+ FilePath ->+ ValueType ->+ Value m1 ->+ IO (Either T.Text (Value m2))+doSaveValue s fname t v = runExceptT $ do+ ts <-+ liftEither . maybe (Left cannot) Right $+ typeToValueTypes t+ let vs = fromMaybe [v] $ fromTuple v+ case mapM onServerArray vs of+ Just refs@(_ : _) -> onServer $ FFI.store fname refs+ _ -> do+ vs' <- if any FFI.hasLazy vs then mapM (onServer . FFI.getLazy) vs else pure vs+ ExceptT . tryIO . LBS.writeFile fname . foldMap Bin.encode $+ zipWith toDataValue ts vs'+ pure $ toTuple []+ where+ cannot =+ T.pack $+ "Cannot save a value of type "+ <> prettyString t+ <> ": only primitives, arrays of primitives, and tuples of these can be saved."+ -- An array that resides on the server in its entirety is one the server+ -- can write by itself. A partially indexed one must be fetched.+ onServerArray (ValueLazyFFI _ ref []) = Just ref+ onServerArray _ = Nothing+ onServer m = ExceptT $ case s of+ Nothing -> pure $ Left "No server to perform IO operation."+ Just server -> first T.pack <$> FFI.runServerM server m+ -- | Run an IO operation. Arrays are put on the server, if one is given. doIOOp :: Maybe FFI.Server -> IOOp -> IO (Either T.Text (Value m)) doIOOp s (LoadBytes fname) =@@ -236,20 +332,5 @@ <> prettyString t <> ": only primitives, arrays of primitives, and tuples of these can be loaded." Just ts -> doLoadValue s ts fname+doIOOp s (SaveValue fname t v) = doSaveValue s fname t v {-# NOINLINE doIOOp #-}--doLoadValue :: Maybe FFI.Server -> [V.ValueType] -> FilePath -> IO (Either T.Text (Value m))-doLoadValue s ts fname = tryIO $ do- vs <- loadValues fname- let vs_ts = map V.valueType vs- when (vs_ts /= ts) . fail $- "Expected file \""- <> fname- <> "\" to contain data of types "- <> unwords (map prettyString ts)- <> " but found data of types "- <> unwords (map prettyString vs_ts)- asValue <$> mapM (fromData s) vs- where- asValue [v] = v- asValue vs = toTuple vs
src/Language/Futhark/Interpreter/Values.hs view
@@ -26,6 +26,7 @@ -- * Conversion fromDataValue,+ toDataValue, asByteString, ) where@@ -171,10 +172,11 @@ pprElem v@ValueArray {} = pprPrec 0 v pprElem v = group $ pprPrec 0 v - putV (P.IntValue x) = SignedValue x- putV (P.FloatValue x) = FloatValue x- putV (P.BoolValue x) = BoolValue x- putV P.UnitValue = BoolValue True+putV :: P.PrimValue -> PrimValue+putV (P.IntValue x) = SignedValue x+putV (P.FloatValue x) = FloatValue x+putV (P.BoolValue x) = BoolValue x+putV P.UnitValue = BoolValue True -- | Prettyprint value. prettyValue :: Value m -> Doc a@@ -334,6 +336,58 @@ fromDataValueWith (FloatValue . Float64Value) shape vector fromDataValue (V.BoolValue shape vector) = fromDataValueWith BoolValue shape vector++-- | Convert a value to a value in the externally observable data format, which+-- must have the given data format type. Only primitives and arrays of+-- primitives can be converted, and the type is needed because the shape and+-- element type of an empty array cannot be determined from the value alone. It+-- is an error to pass a value that resides on a server, which must be fetched+-- (see 'Language.Futhark.Interpreter.FFI.Push.getLazy') first.+toDataValue :: V.ValueType -> Value m -> V.Value+toDataValue (V.ValueType dims pt) v+ | product dims /= length vs =+ error $+ "toDataValue: "+ <> show (length vs)+ <> " values do not fill an array of shape "+ <> show dims+ | otherwise =+ case pt of+ V.I8 -> V.I8Value shape $ conv $ P.valueIntegral . asInt+ V.I16 -> V.I16Value shape $ conv $ P.valueIntegral . asInt+ V.I32 -> V.I32Value shape $ conv $ P.valueIntegral . asInt+ V.I64 -> V.I64Value shape $ conv $ P.valueIntegral . asInt+ V.U8 -> V.U8Value shape $ conv $ P.valueIntegral . asInt+ V.U16 -> V.U16Value shape $ conv $ P.valueIntegral . asInt+ V.U32 -> V.U32Value shape $ conv $ P.valueIntegral . asInt+ V.U64 -> V.U64Value shape $ conv $ P.valueIntegral . asInt+ V.F16 -> V.F16Value shape $ conv asF16+ V.F32 -> V.F32Value shape $ conv asF32+ V.F64 -> V.F64Value shape $ conv asF64+ V.Bool -> V.BoolValue shape $ conv asBool+ where+ shape = SVec.fromList dims+ conv :: (SVec.Storable a) => (PrimValue -> a) -> SVec.Vector a+ conv f = SVec.fromList $ map f vs+ -- The elements of the value, in row-major order.+ vs = prims v+ prims (ValuePrim p) = [p]+ prims (ValueAD _ var) = [putV $ AD.varPrimal var]+ prims (ValueArray _ arr) = concatMap prims $ elems arr+ prims v' = error $ "toDataValue: cannot convert " <> show v'+ asInt (SignedValue x) = x+ asInt (UnsignedValue x) = x+ asInt p = wrong "an integer" p+ asF16 (FloatValue (Float16Value x)) = x+ asF16 p = wrong "an f16" p+ asF32 (FloatValue (Float32Value x)) = x+ asF32 p = wrong "an f32" p+ asF64 (FloatValue (Float64Value x)) = x+ asF64 p = wrong "an f64" p+ asBool (BoolValue x) = x+ asBool p = wrong "a bool" p+ wrong what p =+ error $ "toDataValue: expected " <> what <> ", but found " <> show p -- | If the value represents an array of type @[]u8@, then return those bytes. asByteString :: Value m -> Maybe BS.ByteString
src/Language/Futhark/Parser/Lexer/Wrapper.hs view
@@ -62,7 +62,10 @@ alexMove :: Pos -> Char -> Pos alexMove (Pos !f !l !c !a) '\t' = Pos f l (c + tabSize - ((c - 1) `mod` tabSize)) (a + 1) alexMove (Pos !f !l _ !a) '\n' = Pos f (l + 1) 1 (a + 1)-alexMove (Pos !f !l !c !a) _ = Pos f l (c + 1) (a + 1)+alexMove (Pos !f !l !c !a) b+ -- Do not advance column for UTF-8 continuation bytes.+ | b >= '\x80' && b < '\xC0' = Pos f l c (a + 1)+ | otherwise = Pos f l (c + 1) (a + 1) initialLexerState :: Pos -> BS.ByteString -> AlexInput initialLexerState start_pos input =
src/Language/Futhark/Primitive.hs view
@@ -60,7 +60,8 @@ doMul, doSDiv, doSMod,- doPow,+ doSPow,+ doUPow, -- ** Conversion Operations doConvOp,@@ -123,7 +124,7 @@ countLeadingZeros, countTrailingZeros, popCount,- shift,+ shiftL, shiftR, xor, (.&.),@@ -451,14 +452,14 @@ | -- | Floating-point multiplication. FMul FloatType | -- | Unsigned integer division. Rounds towards- -- negativity infinity. Note: this is different+ -- negative infinity. Note: this is different -- from LLVM. UDiv IntType Safety | -- | Unsigned integer division. Rounds towards positive -- infinity. UCeilDiv IntType Safety | -- | Signed integer division. Rounds towards- -- negativity infinity. Note: this is different+ -- negative infinity. Note: this is different -- from LLVM. SDiv IntType Safety | -- | Signed integer division. Rounds towards positive@@ -492,11 +493,13 @@ UMax IntType | -- | Returns the greatest of two floating-point numbers. FMax FloatType- | -- | Left-shift.+ | -- | Left-shift. The shift amount is masked to the bit width. Shl IntType- | -- | Logical right-shift, zero-extended.+ | -- | Logical right-shift, zero-extended. The shift amount is+ -- masked to the bit width. LShr IntType- | -- | Arithmetic right-shift, sign-extended.+ | -- | Arithmetic right-shift, sign-extended. The shift amount is+ -- masked to the bit width. AShr IntType | -- | Bitwise and. And IntType@@ -504,8 +507,11 @@ Or IntType | -- | Bitwise exclusive-or. Xor IntType- | -- | Integer exponentiation.- Pow IntType+ | -- | Signed integer exponentiation. Undefined for negative+ -- exponents.+ SPow IntType+ | -- | Unsigned integer exponentiation.+ UPow IntType | -- | Floating-point exponentiation. FPow FloatType | -- | Boolean and - not short-circuiting.@@ -629,7 +635,8 @@ map And allIntTypes, map Or allIntTypes, map Xor allIntTypes,- map Pow allIntTypes,+ map SPow allIntTypes,+ map UPow allIntTypes, map FPow allFloatTypes, [LogAnd, LogOr] ]@@ -762,7 +769,8 @@ doBinOp And {} = doIntBinOp doAnd doBinOp Or {} = doIntBinOp doOr doBinOp Xor {} = doIntBinOp doXor-doBinOp Pow {} = doRiskyIntBinOp doPow+doBinOp SPow {} = doRiskyIntBinOp doSPow+doBinOp UPow {} = doIntBinOp doUPow doBinOp FPow {} = doFloatBinOp (**) (**) (**) doBinOp LogAnd {} = doBoolBinOp (&&) doBinOp LogOr {} = doBoolBinOp (||)@@ -821,7 +829,7 @@ doMul :: IntValue -> IntValue -> IntValue doMul v1 v2 = intValue (intValueType v1) $ intToInt64 v1 * intToInt64 v2 --- | Unsigned integer division. Rounds towards negativity infinity.+-- | Unsigned integer division. Rounds towards negative infinity. -- Note: this is different from LLVM. doUDiv :: IntValue -> IntValue -> Maybe IntValue doUDiv v1 v2@@ -836,9 +844,12 @@ | zeroIshInt v2 = Nothing | otherwise = Just . intValue (intValueType v1) $- (intToWord64 v1 + intToWord64 v2 - 1) `div` intToWord64 v2+ (x + y - 1) `div` y+ where+ x = toInteger $ intToWord64 v1+ y = toInteger $ intToWord64 v2 --- | Signed integer division. Rounds towards negativity infinity.+-- | Signed integer division. Rounds towards negative infinity. -- Note: this is different from LLVM. doSDiv :: IntValue -> IntValue -> Maybe IntValue doSDiv v1 v2@@ -846,7 +857,7 @@ | otherwise = Just $ intValue (intValueType v1) $- intToInt64 v1 `div` intToInt64 v2+ valueIntegral v1 `div` (valueIntegral v2 :: Integer) -- | Signed integer division. Rounds towards positive infinity. doSCeilDiv :: IntValue -> IntValue -> Maybe IntValue@@ -854,7 +865,8 @@ | zeroIshInt v2 = Nothing | otherwise = Just . intValue (intValueType v1) $- (intToInt64 v1 + intToInt64 v2 - 1) `div` intToInt64 v2+ negate $+ negate (valueIntegral v1) `div` (valueIntegral v2 :: Integer) -- | Unsigned integer modulus; the countepart to 'UDiv'. doUMod :: IntValue -> IntValue -> Maybe IntValue@@ -869,11 +881,15 @@ | otherwise = Just $ intValue (intValueType v1) $ intToInt64 v1 `mod` intToInt64 v2 -- | Signed integer division. Rounds towards zero.--- This corresponds to the @sdiv@ instruction in LLVM.+-- This corresponds to the @sdiv@ instruction in LLVM, except that+-- dividing the most negative value by -1 wraps around. doSQuot :: IntValue -> IntValue -> Maybe IntValue doSQuot v1 v2 | zeroIshInt v2 = Nothing- | otherwise = Just $ intValue (intValueType v1) $ intToInt64 v1 `quot` intToInt64 v2+ | otherwise =+ Just $+ intValue (intValueType v1) $+ valueIntegral v1 `quot` (valueIntegral v2 :: Integer) -- | Signed integer division. Rounds towards zero. -- This corresponds to the @srem@ instruction in LLVM.@@ -898,17 +914,23 @@ doUMax :: IntValue -> IntValue -> IntValue doUMax v1 v2 = intValue (intValueType v1) $ intToWord64 v1 `max` intToWord64 v2 +-- | The shift amount for shifting the first operand by the second,+-- masked to the bit width.+shiftAmount :: IntValue -> IntValue -> Int+shiftAmount v1 v2 =+ fromIntegral (intToWord64 v2) .&. (8 * intByteSize (intValueType v1) - 1)+ -- | Left-shift. doShl :: IntValue -> IntValue -> IntValue-doShl v1 v2 = intValue (intValueType v1) $ intToInt64 v1 `shift` intToInt v2+doShl v1 v2 = intValue (intValueType v1) $ intToInt64 v1 `shiftL` shiftAmount v1 v2 -- | Logical right-shift, zero-extended. doLShr :: IntValue -> IntValue -> IntValue-doLShr v1 v2 = intValue (intValueType v1) $ intToWord64 v1 `shift` negate (intToInt v2)+doLShr v1 v2 = intValue (intValueType v1) $ intToWord64 v1 `shiftR` shiftAmount v1 v2 -- | Arithmetic right-shift, sign-extended. doAShr :: IntValue -> IntValue -> IntValue-doAShr v1 v2 = intValue (intValueType v1) $ intToInt64 v1 `shift` negate (intToInt v2)+doAShr v1 v2 = intValue (intValueType v1) $ intToInt64 v1 `shiftR` shiftAmount v1 v2 -- | Bitwise and. doAnd :: IntValue -> IntValue -> IntValue@@ -922,12 +944,16 @@ doXor :: IntValue -> IntValue -> IntValue doXor v1 v2 = intValue (intValueType v1) $ intToWord64 v1 `xor` intToWord64 v2 --- | Signed integer exponentatation.-doPow :: IntValue -> IntValue -> Maybe IntValue-doPow v1 v2+-- | Signed integer exponentiation. Fails for negative exponents.+doSPow :: IntValue -> IntValue -> Maybe IntValue+doSPow v1 v2 | negativeIshInt v2 = Nothing- | otherwise = Just $ intValue (intValueType v1) $ intToInt64 v1 ^ intToInt64 v2+ | otherwise = Just $ doUPow v1 v2 +-- | Unsigned integer exponentiation.+doUPow :: IntValue -> IntValue -> IntValue+doUPow v1 v2 = intValue (intValueType v1) $ intToInt64 v1 ^ intToWord64 v2+ -- | Apply a 'ConvOp' to an operand. Returns 'Nothing' if the -- application is mistyped. doConvOp :: ConvOp -> PrimValue -> Maybe PrimValue@@ -1004,59 +1030,29 @@ doFPConv v Float32 = Float32Value $ floatToFloat v doFPConv v Float64 = Float64Value $ floatToDouble v --- | Minimum and maximum value of this signed integer type.-signedMinMax :: (Num a) => IntType -> (a, a)-signedMinMax Int8 =- ( fromIntegral (minBound :: Int8),- fromIntegral (maxBound :: Int8)- )-signedMinMax Int16 =- ( fromIntegral (minBound :: Int16),- fromIntegral (maxBound :: Int16)- )-signedMinMax Int32 =- ( fromIntegral (minBound :: Int32),- fromIntegral (maxBound :: Int32)- )-signedMinMax Int64 =- ( fromIntegral (minBound :: Int64),- fromIntegral (maxBound :: Int64)- )---- | Maximum value of this unsigned integer type.-unsignedMax :: (Num a) => IntType -> a-unsignedMax Int8 =- fromIntegral (maxBound :: Word8)-unsignedMax Int16 =- fromIntegral (minBound :: Word16)-unsignedMax Int32 =- fromIntegral (maxBound :: Word32)-unsignedMax Int64 =- fromIntegral (maxBound :: Word64)- -- | Convert a floating-point value to the nearest -- unsigned integer (rounding towards zero). doFPToUI :: FloatValue -> IntType -> IntValue doFPToUI v t = intValue t $- if v' < 0 || v' > high || isNaN v'+ if v' < 0 || v' >= 2 ^ bits || isNaN v' then 0- else truncate v' :: Word64+ else truncate v' :: Integer where v' = floatToDouble v- high = unsignedMax t+ bits = 8 * intByteSize t :: Int -- | Convert a floating-point value to the nearest -- signed integer (rounding towards zero). doFPToSI :: FloatValue -> IntType -> IntValue doFPToSI v t = intValue t $- if v' < low || v' > high || isNaN v'+ if v' < -(2 ^ (bits - 1)) || v' >= 2 ^ (bits - 1) || isNaN v' then 0- else truncate v' :: Word64+ else truncate v' :: Integer where v' = floatToDouble v- (low, high) = signedMinMax t+ bits = 8 * intByteSize t :: Int -- | Convert an unsigned integer to a floating-point value. doUIToFP :: IntValue -> FloatType -> FloatValue@@ -1125,10 +1121,6 @@ intToInt64 (Int32Value v) = fromIntegral v intToInt64 (Int64Value v) = fromIntegral v --- | Careful - there is no guarantee this will fit.-intToInt :: IntValue -> Int-intToInt = fromIntegral . intToInt64- floatToDouble :: FloatValue -> Double floatToDouble (Float16Value v) | isInfinite v, v > 0 = 1 / 0@@ -1193,7 +1185,8 @@ binOpType (And t) = IntType t binOpType (Or t) = IntType t binOpType (Xor t) = IntType t-binOpType (Pow t) = IntType t+binOpType (SPow t) = IntType t+binOpType (UPow t) = IntType t binOpType (FPow t) = FloatType t binOpType LogAnd = Bool binOpType LogOr = Bool@@ -1935,7 +1928,8 @@ pretty (And t) = taggedI "and" t pretty (Or t) = taggedI "or" t pretty (Xor t) = taggedI "xor" t- pretty (Pow t) = taggedI "pow" t+ pretty (SPow t) = taggedI "spow" t+ pretty (UPow t) = taggedI "upow" t pretty (FPow t) = taggedF "fpow" t pretty LogAnd = "logand" pretty LogOr = "logor"
src/Language/Futhark/Prop.hs view
@@ -1070,6 +1070,14 @@ $ RetType [] $ Scalar $ t_a Fresh+ ),+ ( "io_savevalue",+ IntrinsicPolyFun+ [sp_k, tp_a]+ [ Array Observe (shape [k]) (Prim $ Unsigned Int8),+ Scalar $ t_a Observe+ ]+ $ RetType [] (Scalar $ tupleRecord []) ) ] ++
src/Language/Futhark/Syntax.hs view
@@ -1306,9 +1306,10 @@ | -- | The contents of another file as a module. ModImport FilePath (f ImportName) SrcLoc | ModDecs [DecBase f vn] SrcLoc- | -- | Functor application. The first mapping is from parameter- -- names to argument names, while the second maps names in the- -- constructed module to the names inside the functor.+ | -- | Functor application. The first mapping is from parameter names to+ -- argument names, while the second maps names in the constructed module to+ -- the names inside the functor (and the other way around for names bound in+ -- the parameters of a parametric module). ModApply (ModExpBase f vn) (ModExpBase f vn)
src/Language/Futhark/TypeChecker/Modules.hs view
@@ -15,6 +15,7 @@ import Data.Maybe import Data.Ord import Data.Set qualified as S+import Data.Tuple (swap) import Futhark.Util.Pretty import Language.Futhark import Language.Futhark.Semantic@@ -55,43 +56,54 @@ let RetType dims t' = applySubst substs $ RetType [] t in (dims, BoundV (tps <> map (`TypeParamDim` mempty) dims) t') --- | All names defined anywhere in the 'Env'.-allNamesInEnv :: Env -> S.Set VName+-- | All names defined anywhere in the 'Env', split into those in positive and+-- those in negative position (i.e. in parameters of parametric modules).+allNamesInEnv :: Env -> (S.Set VName, S.Set VName) allNamesInEnv (Env vtable ttable stable modtable _names) =- S.unions- [ M.keysSet vtable,- M.keysSet ttable,- M.keysSet stable,- M.keysSet modtable,- foldMap allNamesInVal (M.elems vtable),- foldMap allNamesInMTy (M.elems stable),- foldMap allNamesInMod (M.elems modtable),- foldMap allNamesInType (M.elems ttable)- ]+ ( S.unions+ [ M.keysSet vtable,+ M.keysSet ttable,+ M.keysSet stable,+ M.keysSet modtable,+ foldMap allNamesInVal (M.elems vtable),+ foldMap allNamesInType (M.elems ttable)+ ],+ mempty+ )+ <> foldMap allNamesInMTy (M.elems stable)+ <> foldMap allNamesInMod (M.elems modtable) where allNamesInType (TypeAbbr _ ps _) = S.fromList $ map typeParamName ps allNamesInVal (BoundV ps _) = S.fromList $ map typeParamName ps -allNamesInMod :: Mod -> S.Set VName+allNamesInMod :: Mod -> (S.Set VName, S.Set VName) allNamesInMod (ModEnv env) = allNamesInEnv env-allNamesInMod ModFun {} = mempty+allNamesInMod (ModFun (FunModType abs mod mty)) =+ swap ((S.fromList (map qualLeaf $ M.keys abs), mempty) <> allNamesInMod mod)+ <> allNamesInMTy mty -allNamesInMTy :: MTy -> S.Set VName+allNamesInMTy :: MTy -> (S.Set VName, S.Set VName) allNamesInMTy (MTy abs mod) =- S.fromList (map qualLeaf $ M.keys abs) <> allNamesInMod mod+ (S.fromList (map qualLeaf $ M.keys abs), mempty) <> allNamesInMod mod -- | Create unique renames for the module type. This is used for--- e.g. generative functor application.+-- e.g. generative functor application. The returned substitution maps+-- references to what they resolve to: new names to old names, except in+-- negative position, where it maps old names to new names. newNamesForMTy :: MTy -> TypeM (MTy, M.Map VName VName) newNamesForMTy orig_mty = do- pairs <- forM (S.toList $ allNamesInMTy orig_mty) $ \v -> do+ let (pos, neg) = allNamesInMTy orig_mty+ pairs <- forM (S.toList $ pos <> neg) $ \v -> do v' <- newName v pure (v, v') let substs = M.fromList pairs- rev_substs = M.fromList $ map (uncurry $ flip (,)) pairs+ resolve (v, v')+ | v `S.member` neg = (v, v')+ | otherwise = (v', v)+ resolve_substs = M.fromList $ map resolve pairs new_mty = substituteInMTy substs orig_mty addTySet $ mtyAbs new_mty- pure (new_mty, rev_substs)+ pure (new_mty, resolve_substs) where substituteInMTy :: M.Map VName VName -> MTy -> MTy substituteInMTy substs (MTy mty_abs mty_mod) =