diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/docs/binary-data-format.rst b/docs/binary-data-format.rst --- a/docs/binary-data-format.rst +++ b/docs/binary-data-format.rst @@ -48,12 +48,12 @@ b 0 -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 ... + b ... Type Values diff --git a/docs/c-api.rst b/docs/c-api.rst --- a/docs/c-api.rst +++ b/docs/c-api.rst @@ -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: diff --git a/docs/language-reference.rst b/docs/language-reference.rst --- a/docs/language-reference.rst +++ b/docs/language-reference.rst @@ -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 diff --git a/docs/man/futhark-test.rst b/docs/man/futhark-test.rst --- a/docs/man/futhark-test.rst +++ b/docs/man/futhark-test.rst @@ -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. diff --git a/docs/man/futhark.rst b/docs/man/futhark.rst --- a/docs/man/futhark.rst +++ b/docs/man/futhark.rst @@ -77,8 +77,8 @@ futhark eval [options...] ------------------------------------ -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)`. diff --git a/docs/server-protocol.rst b/docs/server-protocol.rst --- a/docs/server-protocol.rst +++ b/docs/server-protocol.rst @@ -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 diff --git a/futhark.cabal b/futhark.cabal --- a/futhark.cabal +++ b/futhark.cabal @@ -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 diff --git a/prelude/math.fut b/prelude/math.fut --- a/prelude/math.fut +++ b/prelude/math.fut @@ -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)) diff --git a/prelude/prelude.fut b/prelude/prelude.fut --- a/prelude/prelude.fut +++ b/prelude/prelude.fut @@ -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 } diff --git a/rts/c/backends/c.h b/rts/c/backends/c.h --- a/rts/c/backends/c.h +++ b/rts/c/backends/c.h @@ -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; diff --git a/rts/c/backends/cuda.h b/rts/c/backends/cuda.h --- a/rts/c/backends/cuda.h +++ b/rts/c/backends/cuda.h @@ -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 diff --git a/rts/c/backends/hip.h b/rts/c/backends/hip.h --- a/rts/c/backends/hip.h +++ b/rts/c/backends/hip.h @@ -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 diff --git a/rts/c/backends/multicore.h b/rts/c/backends/multicore.h --- a/rts/c/backends/multicore.h +++ b/rts/c/backends/multicore.h @@ -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); diff --git a/rts/c/backends/opencl.h b/rts/c/backends/opencl.h --- a/rts/c/backends/opencl.h +++ b/rts/c/backends/opencl.h @@ -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) { diff --git a/rts/c/cache.h b/rts/c/cache.h --- a/rts/c/cache.h +++ b/rts/c/cache.h @@ -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; } diff --git a/rts/c/context.h b/rts/c/context.h --- a/rts/c/context.h +++ b/rts/c/context.h @@ -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); } diff --git a/rts/c/context_prototypes.h b/rts/c/context_prototypes.h --- a/rts/c/context_prototypes.h +++ b/rts/c/context_prototypes.h @@ -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], diff --git a/rts/c/copy.h b/rts/c/copy.h --- a/rts/c/copy.h +++ b/rts/c/copy.h @@ -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)); \ diff --git a/rts/c/event_list.h b/rts/c/event_list.h --- a/rts/c/event_list.h +++ b/rts/c/event_list.h @@ -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++; } diff --git a/rts/c/gpu.h b/rts/c/gpu.h --- a/rts/c/gpu.h +++ b/rts/c/gpu.h @@ -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, \ diff --git a/rts/c/half.h b/rts/c/half.h --- a/rts/c/half.h +++ b/rts/c/half.h @@ -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) { diff --git a/rts/c/scalar.h b/rts/c/scalar.h --- a/rts/c/scalar.h +++ b/rts/c/scalar.h @@ -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; } diff --git a/rts/c/scalar_f16.h b/rts/c/scalar_f16.h --- a/rts/c/scalar_f16.h +++ b/rts/c/scalar_f16.h @@ -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; } diff --git a/rts/c/scheduler.h b/rts/c/scheduler.h --- a/rts/c/scheduler.h +++ b/rts/c/scheduler.h @@ -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 diff --git a/rts/c/server.h b/rts/c/server.h --- a/rts/c/server.h +++ b/rts/c/server.h @@ -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); } diff --git a/rts/c/tuning.h b/rts/c/tuning.h --- a/rts/c/tuning.h +++ b/rts/c/tuning.h @@ -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; } diff --git a/rts/c/uniform.h b/rts/c/uniform.h --- a/rts/c/uniform.h +++ b/rts/c/uniform.h @@ -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) { diff --git a/rts/c/util.h b/rts/c/util.h --- a/rts/c/util.h +++ b/rts/c/util.h @@ -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); } diff --git a/rts/c/values.h b/rts/c/values.h --- a/rts/c/values.h +++ b/rts/c/values.h @@ -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; jtype_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 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; } } diff --git a/rts/cuda/prelude.cu b/rts/cuda/prelude.cu --- a/rts/cuda/prelude.cu +++ b/rts/cuda/prelude.cu @@ -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) diff --git a/rts/opencl/transpose.cl b/rts/opencl/transpose.cl --- a/rts/opencl/transpose.cl +++ b/rts/opencl/transpose.cl @@ -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) + \ diff --git a/rts/python/memory.py b/rts/python/memory.py --- a/rts/python/memory.py +++ b/rts/python/memory.py @@ -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( diff --git a/rts/python/opencl.py b/rts/python/opencl.py --- a/rts/python/opencl.py +++ b/rts/python/opencl.py @@ -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( diff --git a/rts/python/scalar.py b/rts/python/scalar.py --- a/rts/python/scalar.py +++ b/rts/python/scalar.py @@ -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 diff --git a/src-testing/Futhark/IR/Prop/ReshapeTests.hs b/src-testing/Futhark/IR/Prop/ReshapeTests.hs --- a/src-testing/Futhark/IR/Prop/ReshapeTests.hs +++ b/src-testing/Futhark/IR/Prop/ReshapeTests.hs @@ -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"] diff --git a/src-testing/Futhark/LspTests.hs b/src-testing/Futhark/LspTests.hs --- a/src-testing/Futhark/LspTests.hs +++ b/src-testing/Futhark/LspTests.hs @@ -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 ] diff --git a/src/Futhark/AD/Derivatives.hs b/src/Futhark/AD/Derivatives.hs --- a/src/Futhark/AD/Derivatives.hs +++ b/src/Futhark/AD/Derivatives.hs @@ -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)) diff --git a/src/Futhark/AD/Rev/Acc.hs b/src/Futhark/AD/Rev/Acc.hs --- a/src/Futhark/AD/Rev/Acc.hs +++ b/src/Futhark/AD/Rev/Acc.hs @@ -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 diff --git a/src/Futhark/AD/Rev/Loop.hs b/src/Futhark/AD/Rev/Loop.hs --- a/src/Futhark/AD/Rev/Loop.hs +++ b/src/Futhark/AD/Rev/Loop.hs @@ -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 diff --git a/src/Futhark/Actions.hs b/src/Futhark/Actions.hs --- a/src/Futhark/Actions.hs +++ b/src/Futhark/Actions.hs @@ -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 + } diff --git a/src/Futhark/Analysis/CallGraph.hs b/src/Futhark/Analysis/CallGraph.hs --- a/src/Futhark/Analysis/CallGraph.hs +++ b/src/Futhark/Analysis/CallGraph.hs @@ -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 = diff --git a/src/Futhark/Analysis/PrimExp.hs b/src/Futhark/Analysis/PrimExp.hs --- a/src/Futhark/Analysis/PrimExp.hs +++ b/src/Futhark/Analysis/PrimExp.hs @@ -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 diff --git a/src/Futhark/CLI/Dev.hs b/src/Futhark/CLI/Dev.hs --- a/src/Futhark/CLI/Dev.hs +++ b/src/Futhark/CLI/Dev.hs @@ -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.", diff --git a/src/Futhark/CLI/Eval.hs b/src/Futhark/CLI/Eval.hs --- a/src/Futhark/CLI/Eval.hs +++ b/src/Futhark/CLI/Eval.hs @@ -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 = diff --git a/src/Futhark/CLI/Literate.hs b/src/Futhark/CLI/Literate.hs --- a/src/Futhark/CLI/Literate.hs +++ b/src/Futhark/CLI/Literate.hs @@ -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) $ diff --git a/src/Futhark/CLI/Test.hs b/src/Futhark/CLI/Test.hs --- a/src/Futhark/CLI/Test.hs +++ b/src/Futhark/CLI/Test.hs @@ -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"] diff --git a/src/Futhark/CodeGen/Backends/CCUDA.hs b/src/Futhark/CodeGen/Backends/CCUDA.hs --- a/src/Futhark/CodeGen/Backends/CCUDA.hs +++ b/src/Futhark/CodeGen/Backends/CCUDA.hs @@ -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, diff --git a/src/Futhark/CodeGen/Backends/COpenCL.hs b/src/Futhark/CodeGen/Backends/COpenCL.hs --- a/src/Futhark/CodeGen/Backends/COpenCL.hs +++ b/src/Futhark/CodeGen/Backends/COpenCL.hs @@ -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 diff --git a/src/Futhark/CodeGen/Backends/GPU.hs b/src/Futhark/CodeGen/Backends/GPU.hs --- a/src/Futhark/CodeGen/Backends/GPU.hs +++ b/src/Futhark/CodeGen/Backends/GPU.hs @@ -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 = diff --git a/src/Futhark/CodeGen/Backends/GenericC.hs b/src/Futhark/CodeGen/Backends/GenericC.hs --- a/src/Futhark/CodeGen/Backends/GenericC.hs +++ b/src/Futhark/CodeGen/Backends/GenericC.hs @@ -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 diff --git a/src/Futhark/CodeGen/Backends/GenericC/CLI.hs b/src/Futhark/CodeGen/Backends/GenericC/CLI.hs --- a/src/Futhark/CodeGen/Backends/GenericC/CLI.hs +++ b/src/Futhark/CodeGen/Backends/GenericC/CLI.hs @@ -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); }}|] diff --git a/src/Futhark/CodeGen/Backends/GenericC/Code.hs b/src/Futhark/CodeGen/Backends/GenericC/Code.hs --- a/src/Futhark/CodeGen/Backends/GenericC/Code.hs +++ b/src/Futhark/CodeGen/Backends/GenericC/Code.hs @@ -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 diff --git a/src/Futhark/CodeGen/Backends/GenericC/Fun.hs b/src/Futhark/CodeGen/Backends/GenericC/Fun.hs --- a/src/Futhark/CodeGen/Backends/GenericC/Fun.hs +++ b/src/Futhark/CodeGen/Backends/GenericC/Fun.hs @@ -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;|] diff --git a/src/Futhark/CodeGen/Backends/GenericC/Monad.hs b/src/Futhark/CodeGen/Backends/GenericC/Monad.hs --- a/src/Futhark/CodeGen/Backends/GenericC/Monad.hs +++ b/src/Futhark/CodeGen/Backends/GenericC/Monad.hs @@ -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 -> diff --git a/src/Futhark/CodeGen/Backends/GenericC/Pretty.hs b/src/Futhark/CodeGen/Backends/GenericC/Pretty.hs --- a/src/Futhark/CodeGen/Backends/GenericC/Pretty.hs +++ b/src/Futhark/CodeGen/Backends/GenericC/Pretty.hs @@ -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 diff --git a/src/Futhark/CodeGen/Backends/GenericC/Server.hs b/src/Futhark/CodeGen/Backends/GenericC/Server.hs --- a/src/Futhark/CodeGen/Backends/GenericC/Server.hs +++ b/src/Futhark/CodeGen/Backends/GenericC/Server.hs @@ -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 = diff --git a/src/Futhark/CodeGen/Backends/GenericC/Types.hs b/src/Futhark/CodeGen/Backends/GenericC/Types.hs --- a/src/Futhark/CodeGen/Backends/GenericC/Types.hs +++ b/src/Futhark/CodeGen/Backends/GenericC/Types.hs @@ -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 -> diff --git a/src/Futhark/CodeGen/Backends/GenericPython.hs b/src/Futhark/CodeGen/Backends/GenericPython.hs --- a/src/Futhark/CodeGen/Backends/GenericPython.hs +++ b/src/Futhark/CodeGen/Backends/GenericPython.hs @@ -1214,7 +1214,6 @@ Xor {} -> simple "^" And {} -> simple "&" Or {} -> simple "|" - Shl {} -> simple "<<" LogAnd {} -> simple "and" LogOr {} -> simple "or" _ -> pure $ simpleCall (prettyString op) [x', y'] diff --git a/src/Futhark/CodeGen/Backends/GenericWASM.hs b/src/Futhark/CodeGen/Backends/GenericWASM.hs --- a/src/Futhark/CodeGen/Backends/GenericWASM.hs +++ b/src/Futhark/CodeGen/Backends/GenericWASM.hs @@ -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) diff --git a/src/Futhark/CodeGen/Backends/HIP.hs b/src/Futhark/CodeGen/Backends/HIP.hs --- a/src/Futhark/CodeGen/Backends/HIP.hs +++ b/src/Futhark/CodeGen/Backends/HIP.hs @@ -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 diff --git a/src/Futhark/CodeGen/Backends/MulticoreC.hs b/src/Futhark/CodeGen/Backends/MulticoreC.hs --- a/src/Futhark/CodeGen/Backends/MulticoreC.hs +++ b/src/Futhark/CodeGen/Backends/MulticoreC.hs @@ -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); }|] diff --git a/src/Futhark/CodeGen/Backends/MulticoreISPC.hs b/src/Futhark/CodeGen/Backends/MulticoreISPC.hs --- a/src/Futhark/CodeGen/Backends/MulticoreISPC.hs +++ b/src/Futhark/CodeGen/Backends/MulticoreISPC.hs @@ -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'|] diff --git a/src/Futhark/CodeGen/Backends/PyOpenCL.hs b/src/Futhark/CodeGen/Backends/PyOpenCL.hs --- a/src/Futhark/CodeGen/Backends/PyOpenCL.hs +++ b/src/Futhark/CodeGen/Backends/PyOpenCL.hs @@ -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 diff --git a/src/Futhark/CodeGen/ImpCode/GPU.hs b/src/Futhark/CodeGen/ImpCode/GPU.hs --- a/src/Futhark/CodeGen/ImpCode/GPU.hs +++ b/src/Futhark/CodeGen/ImpCode/GPU.hs @@ -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) = diff --git a/src/Futhark/CodeGen/ImpCode/Kernels.hs b/src/Futhark/CodeGen/ImpCode/Kernels.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/CodeGen/ImpCode/Kernels.hs @@ -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 diff --git a/src/Futhark/CodeGen/ImpCode/OpenCL.hs b/src/Futhark/CodeGen/ImpCode/OpenCL.hs --- a/src/Futhark/CodeGen/ImpCode/OpenCL.hs +++ b/src/Futhark/CodeGen/ImpCode/OpenCL.hs @@ -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 diff --git a/src/Futhark/CodeGen/ImpGen/GPU/Base.hs b/src/Futhark/CodeGen/ImpGen/GPU/Base.hs --- a/src/Futhark/CodeGen/ImpGen/GPU/Base.hs +++ b/src/Futhark/CodeGen/ImpGen/GPU/Base.hs @@ -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 diff --git a/src/Futhark/CodeGen/ImpGen/GPU/Block.hs b/src/Futhark/CodeGen/ImpGen/GPU/Block.hs --- a/src/Futhark/CodeGen/ImpGen/GPU/Block.hs +++ b/src/Futhark/CodeGen/ImpGen/GPU/Block.hs @@ -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) diff --git a/src/Futhark/CodeGen/ImpGen/GPU/SegRed.hs b/src/Futhark/CodeGen/ImpGen/GPU/SegRed.hs --- a/src/Futhark/CodeGen/ImpGen/GPU/SegRed.hs +++ b/src/Futhark/CodeGen/ImpGen/GPU/SegRed.hs @@ -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 diff --git a/src/Futhark/CodeGen/ImpGen/GPU/SegScan/SinglePass.hs b/src/Futhark/CodeGen/ImpGen/GPU/SegScan/SinglePass.hs --- a/src/Futhark/CodeGen/ImpGen/GPU/SegScan/SinglePass.hs +++ b/src/Futhark/CodeGen/ImpGen/GPU/SegScan/SinglePass.hs @@ -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) diff --git a/src/Futhark/CodeGen/ImpGen/GPU/ToOpenCL.hs b/src/Futhark/CodeGen/ImpGen/GPU/ToOpenCL.hs --- a/src/Futhark/CodeGen/ImpGen/GPU/ToOpenCL.hs +++ b/src/Futhark/CodeGen/ImpGen/GPU/ToOpenCL.hs @@ -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 diff --git a/src/Futhark/Eval.hs b/src/Futhark/Eval.hs --- a/src/Futhark/Eval.hs +++ b/src/Futhark/Eval.hs @@ -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)) diff --git a/src/Futhark/IR/Aliases.hs b/src/Futhark/IR/Aliases.hs --- a/src/Futhark/IR/Aliases.hs +++ b/src/Futhark/IR/Aliases.hs @@ -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 diff --git a/src/Futhark/IR/GPU.hs b/src/Futhark/IR/GPU.hs --- a/src/Futhark/IR/GPU.hs +++ b/src/Futhark/IR/GPU.hs @@ -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] -- diff --git a/src/Futhark/IR/GPU/Op.hs b/src/Futhark/IR/GPU/Op.hs --- a/src/Futhark/IR/GPU/Op.hs +++ b/src/Futhark/IR/GPU/Op.hs @@ -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) = diff --git a/src/Futhark/IR/GPU/Simplify.hs b/src/Futhark/IR/GPU/Simplify.hs --- a/src/Futhark/IR/GPU/Simplify.hs +++ b/src/Futhark/IR/GPU/Simplify.hs @@ -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 diff --git a/src/Futhark/IR/GPUMem.hs b/src/Futhark/IR/GPUMem.hs --- a/src/Futhark/IR/GPUMem.hs +++ b/src/Futhark/IR/GPUMem.hs @@ -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 diff --git a/src/Futhark/IR/MC.hs b/src/Futhark/IR/MC.hs --- a/src/Futhark/IR/MC.hs +++ b/src/Futhark/IR/MC.hs @@ -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 diff --git a/src/Futhark/IR/MC/Op.hs b/src/Futhark/IR/MC/Op.hs --- a/src/Futhark/IR/MC/Op.hs +++ b/src/Futhark/IR/MC/Op.hs @@ -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) = diff --git a/src/Futhark/IR/MCMem.hs b/src/Futhark/IR/MCMem.hs --- a/src/Futhark/IR/MCMem.hs +++ b/src/Futhark/IR/MCMem.hs @@ -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 diff --git a/src/Futhark/IR/Mem.hs b/src/Futhark/IR/Mem.hs --- a/src/Futhark/IR/Mem.hs +++ b/src/Futhark/IR/Mem.hs @@ -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] diff --git a/src/Futhark/IR/Parse.hs b/src/Futhark/IR/Parse.hs --- a/src/Futhark/IR/Parse.hs +++ b/src/Futhark/IR/Parse.hs @@ -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) diff --git a/src/Futhark/IR/Pretty.hs b/src/Futhark/IR/Pretty.hs --- a/src/Futhark/IR/Pretty.hs +++ b/src/Futhark/IR/Pretty.hs @@ -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) diff --git a/src/Futhark/IR/Prop.hs b/src/Futhark/IR/Prop.hs --- a/src/Futhark/IR/Prop.hs +++ b/src/Futhark/IR/Prop.hs @@ -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 diff --git a/src/Futhark/IR/Prop/Reshape.hs b/src/Futhark/IR/Prop/Reshape.hs --- a/src/Futhark/IR/Prop/Reshape.hs +++ b/src/Futhark/IR/Prop/Reshape.hs @@ -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 diff --git a/src/Futhark/IR/Prop/Scope.hs b/src/Futhark/IR/Prop/Scope.hs --- a/src/Futhark/IR/Prop/Scope.hs +++ b/src/Futhark/IR/Prop/Scope.hs @@ -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. diff --git a/src/Futhark/IR/Run.hs b/src/Futhark/IR/Run.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/IR/Run.hs @@ -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 diff --git a/src/Futhark/IR/SOACS.hs b/src/Futhark/IR/SOACS.hs --- a/src/Futhark/IR/SOACS.hs +++ b/src/Futhark/IR/SOACS.hs @@ -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) diff --git a/src/Futhark/IR/SOACS/SOAC.hs b/src/Futhark/IR/SOACS/SOAC.hs --- a/src/Futhark/IR/SOACS/SOAC.hs +++ b/src/Futhark/IR/SOACS/SOAC.hs @@ -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)) diff --git a/src/Futhark/IR/SOACS/Simplify.hs b/src/Futhark/IR/SOACS/Simplify.hs --- a/src/Futhark/IR/SOACS/Simplify.hs +++ b/src/Futhark/IR/SOACS/Simplify.hs @@ -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) diff --git a/src/Futhark/IR/SegOp.hs b/src/Futhark/IR/SegOp.hs --- a/src/Futhark/IR/SegOp.hs +++ b/src/Futhark/IR/SegOp.hs @@ -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 diff --git a/src/Futhark/IR/Seq.hs b/src/Futhark/IR/Seq.hs --- a/src/Futhark/IR/Seq.hs +++ b/src/Futhark/IR/Seq.hs @@ -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)) diff --git a/src/Futhark/IR/SeqMem.hs b/src/Futhark/IR/SeqMem.hs --- a/src/Futhark/IR/SeqMem.hs +++ b/src/Futhark/IR/SeqMem.hs @@ -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 diff --git a/src/Futhark/IR/Traversals.hs b/src/Futhark/IR/Traversals.hs --- a/src/Futhark/IR/Traversals.hs +++ b/src/Futhark/IR/Traversals.hs @@ -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) diff --git a/src/Futhark/IR/TypeCheck.hs b/src/Futhark/IR/TypeCheck.hs --- a/src/Futhark/IR/TypeCheck.hs +++ b/src/Futhark/IR/TypeCheck.hs @@ -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 -> diff --git a/src/Futhark/Internalise/Defunctorise.hs b/src/Futhark/Internalise/Defunctorise.hs --- a/src/Futhark/Internalise/Defunctorise.hs +++ b/src/Futhark/Internalise/Defunctorise.hs @@ -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 diff --git a/src/Futhark/Internalise/Exps.hs b/src/Futhark/Internalise/Exps.hs --- a/src/Futhark/Internalise/Exps.hs +++ b/src/Futhark/Internalise/Exps.hs @@ -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 diff --git a/src/Futhark/LSP/CodeLens.hs b/src/Futhark/LSP/CodeLens.hs --- a/src/Futhark/LSP/CodeLens.hs +++ b/src/Futhark/LSP/CodeLens.hs @@ -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 = diff --git a/src/Futhark/LSP/Compile.hs b/src/Futhark/LSP/Compile.hs --- a/src/Futhark/LSP/Compile.hs +++ b/src/Futhark/LSP/Compile.hs @@ -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) diff --git a/src/Futhark/LSP/Diagnostic.hs b/src/Futhark/LSP/Diagnostic.hs --- a/src/Futhark/LSP/Diagnostic.hs +++ b/src/Futhark/LSP/Diagnostic.hs @@ -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 diff --git a/src/Futhark/LSP/Handlers.hs b/src/Futhark/LSP/Handlers.hs --- a/src/Futhark/LSP/Handlers.hs +++ b/src/Futhark/LSP/Handlers.hs @@ -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, diff --git a/src/Futhark/LSP/State.hs b/src/Futhark/LSP/State.hs --- a/src/Futhark/LSP/State.hs +++ b/src/Futhark/LSP/State.hs @@ -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 diff --git a/src/Futhark/LSP/Tool.hs b/src/Futhark/LSP/Tool.hs --- a/src/Futhark/LSP/Tool.hs +++ b/src/Futhark/LSP/Tool.hs @@ -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) diff --git a/src/Futhark/Optimise/ArrayShortCircuiting/ArrayCoalescing.hs b/src/Futhark/Optimise/ArrayShortCircuiting/ArrayCoalescing.hs --- a/src/Futhark/Optimise/ArrayShortCircuiting/ArrayCoalescing.hs +++ b/src/Futhark/Optimise/ArrayShortCircuiting/ArrayCoalescing.hs @@ -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 diff --git a/src/Futhark/Optimise/InliningDeadFun.hs b/src/Futhark/Optimise/InliningDeadFun.hs --- a/src/Futhark/Optimise/InliningDeadFun.hs +++ b/src/Futhark/Optimise/InliningDeadFun.hs @@ -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", diff --git a/src/Futhark/Optimise/Simplify/Engine.hs b/src/Futhark/Optimise/Simplify/Engine.hs --- a/src/Futhark/Optimise/Simplify/Engine.hs +++ b/src/Futhark/Optimise/Simplify/Engine.hs @@ -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 diff --git a/src/Futhark/Optimise/Simplify/Rule.hs b/src/Futhark/Optimise/Simplify/Rule.hs --- a/src/Futhark/Optimise/Simplify/Rule.hs +++ b/src/Futhark/Optimise/Simplify/Rule.hs @@ -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) diff --git a/src/Futhark/Optimise/Simplify/Rules.hs b/src/Futhark/Optimise/Simplify/Rules.hs --- a/src/Futhark/Optimise/Simplify/Rules.hs +++ b/src/Futhark/Optimise/Simplify/Rules.hs @@ -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 diff --git a/src/Futhark/Optimise/Simplify/Rules/BasicOp.hs b/src/Futhark/Optimise/Simplify/Rules/BasicOp.hs --- a/src/Futhark/Optimise/Simplify/Rules/BasicOp.hs +++ b/src/Futhark/Optimise/Simplify/Rules/BasicOp.hs @@ -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 diff --git a/src/Futhark/Optimise/Simplify/Rules/Index.hs b/src/Futhark/Optimise/Simplify/Rules/Index.hs --- a/src/Futhark/Optimise/Simplify/Rules/Index.hs +++ b/src/Futhark/Optimise/Simplify/Rules/Index.hs @@ -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 = diff --git a/src/Futhark/Optimise/Simplify/Rules/Loop.hs b/src/Futhark/Optimise/Simplify/Rules/Loop.hs --- a/src/Futhark/Optimise/Simplify/Rules/Loop.hs +++ b/src/Futhark/Optimise/Simplify/Rules/Loop.hs @@ -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' diff --git a/src/Futhark/Optimise/Simplify/Rules/Match.hs b/src/Futhark/Optimise/Simplify/Rules/Match.hs --- a/src/Futhark/Optimise/Simplify/Rules/Match.hs +++ b/src/Futhark/Optimise/Simplify/Rules/Match.hs @@ -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' diff --git a/src/Futhark/Optimise/Simplify/Rules/Simple.hs b/src/Futhark/Optimise/Simplify/Rules/Simple.hs --- a/src/Futhark/Optimise/Simplify/Rules/Simple.hs +++ b/src/Futhark/Optimise/Simplify/Rules/Simple.hs @@ -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 = diff --git a/src/Futhark/Pass/AD.hs b/src/Futhark/Pass/AD.hs --- a/src/Futhark/Pass/AD.hs +++ b/src/Futhark/Pass/AD.hs @@ -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 diff --git a/src/Futhark/Test.hs b/src/Futhark/Test.hs --- a/src/Futhark/Test.hs +++ b/src/Futhark/Test.hs @@ -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 diff --git a/src/Futhark/Test/Property.hs b/src/Futhark/Test/Property.hs --- a/src/Futhark/Test/Property.hs +++ b/src/Futhark/Test/Property.hs @@ -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 diff --git a/src/Futhark/Util/Loc.hs b/src/Futhark/Util/Loc.hs --- a/src/Futhark/Util/Loc.hs +++ b/src/Futhark/Util/Loc.hs @@ -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 diff --git a/src/Language/Futhark/Interpreter.hs b/src/Language/Futhark/Interpreter.hs --- a/src/Language/Futhark/Interpreter.hs +++ b/src/Language/Futhark/Interpreter.hs @@ -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 diff --git a/src/Language/Futhark/Interpreter/FFI/ServerM.hs b/src/Language/Futhark/Interpreter/FFI/ServerM.hs --- a/src/Language/Futhark/Interpreter/FFI/ServerM.hs +++ b/src/Language/Futhark/Interpreter/FFI/ServerM.hs @@ -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 diff --git a/src/Language/Futhark/Interpreter/IO.hs b/src/Language/Futhark/Interpreter/IO.hs --- a/src/Language/Futhark/Interpreter/IO.hs +++ b/src/Language/Futhark/Interpreter/IO.hs @@ -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 diff --git a/src/Language/Futhark/Interpreter/Values.hs b/src/Language/Futhark/Interpreter/Values.hs --- a/src/Language/Futhark/Interpreter/Values.hs +++ b/src/Language/Futhark/Interpreter/Values.hs @@ -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 diff --git a/src/Language/Futhark/Parser/Lexer/Wrapper.hs b/src/Language/Futhark/Parser/Lexer/Wrapper.hs --- a/src/Language/Futhark/Parser/Lexer/Wrapper.hs +++ b/src/Language/Futhark/Parser/Lexer/Wrapper.hs @@ -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 = diff --git a/src/Language/Futhark/Primitive.hs b/src/Language/Futhark/Primitive.hs --- a/src/Language/Futhark/Primitive.hs +++ b/src/Language/Futhark/Primitive.hs @@ -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" diff --git a/src/Language/Futhark/Prop.hs b/src/Language/Futhark/Prop.hs --- a/src/Language/Futhark/Prop.hs +++ b/src/Language/Futhark/Prop.hs @@ -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 []) ) ] ++ diff --git a/src/Language/Futhark/Syntax.hs b/src/Language/Futhark/Syntax.hs --- a/src/Language/Futhark/Syntax.hs +++ b/src/Language/Futhark/Syntax.hs @@ -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) diff --git a/src/Language/Futhark/TypeChecker/Modules.hs b/src/Language/Futhark/TypeChecker/Modules.hs --- a/src/Language/Futhark/TypeChecker/Modules.hs +++ b/src/Language/Futhark/TypeChecker/Modules.hs @@ -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) =