diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -5,6 +5,47 @@ 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.25.32] + +### Added + +* `futhark doc` now prints warnings about errors in doc comments (mostly + references to unknown names). + +* FutharkScript now permits chained `let` without `in`, just as in Futhark. + +* `futhark pkg` now allows the `~` character in package paths. + +* `cuda` backend: explicitly support CC 8.9, 9.0, 10.0, 10.1, and 12.0. + +* Profiling now provides source locations for the profiled events. Some things + are not yet accurately tracked, and only the static location is reported + (i.e., no full call stack). + +* The AD transformation is now more diligent about propagating attributes from + SOACs in the primal code to SOACs in the differentiated code. + +### Fixed + +* `f64` atomics on NVIDIA GPUs with less than CC 6.0 (Maxwell and older). + +* Infinite loop in fusion (#2276). + +* Rare compiler crash during internalisation code that does size coercions on + opaque size-lifted types. + +* Missing fusion inside reduction and scan operators (#2283). + +* Incorrect aliasing for memory blocks could cause some optimisations to be + misapplied. (#2288) + +* `to_bits`/`from_bits` not handled by AD (#2292). + +* For GPU backends, incorrect code generation for accumulator updates (produced + by AD) for thread-local arrays (#2294). + +* Missing consumption check in the termination condition for `while` loops (#2300). + ## [0.25.31] ### Added diff --git a/docs/c-api.rst b/docs/c-api.rst --- a/docs/c-api.rst +++ b/docs/c-api.rst @@ -206,12 +206,14 @@ .. c:function:: char *futhark_context_report(struct futhark_context *ctx) Produce a C string encoding a JSON object with debug and profiling - information collected during program runtime. It is the caller's - responsibility to free the returned string. It is likely to only - contain interesting information if + information collected during program runtime. It is the caller's + responsibility to free the returned string. The format of the string is + intentionally undocumented and is not a stable format, but can be passed to + ``futhark profile`` to produce human-readable information. The report is + likely to only contain interesting information if :c:func:`futhark_context_config_set_debugging` or - :c:func:`futhark_context_config_set_profiling` has been called - previously. Returns ``NULL`` on failure. + :c:func:`futhark_context_config_set_profiling` has been called previously. + Returns ``NULL`` on failure. .. c:function:: int futhark_context_clear_caches(struct futhark_context *ctx) diff --git a/docs/man/futhark-profile.rst b/docs/man/futhark-profile.rst --- a/docs/man/futhark-profile.rst +++ b/docs/man/futhark-profile.rst @@ -14,13 +14,13 @@ DESCRIPTION =========== -This tool produces human-readable profiling information based on -information collected with :ref:`futhark bench`. -Futhark has only rudimentary support for profiling. While the system -can collect information about the run-time behaviour of the program, -there is currently no automatic way to connect the information to the -program source code. However, the collected information can still be -useful for estimating the source of inefficiencies. +This tool produces human-readable profiling information based on information +collected with :ref:`futhark bench`. Futhark has basic support +for profiling. The system can collect information about the run-time behaviour +of the program, and connects it as best it is able to the program source code. +This works best for the GPU backends, and not at all for the sequential +backends. The collected information can then be used to estimate the source of +inefficiencies. USAGE ===== @@ -49,17 +49,19 @@ Supposing a dataset ``foo``, ``futhark profile`` will produce the following files in the top level directory. -* ``foo.log``: the running log produced during execution. Contains - many details on dynamic behaviour, depending on the exact backend. +* ``foo.log``: the running log produced during execution. Contains many details + on dynamic behaviour, depending on the exact backend. -* ``foo.summary``: a summary of memory usage and cost centres. For - the GPU backends, the cost centres are kernel executions and memory - copies. +* ``foo.summary``: a summary of memory usage and cost centres. For the GPU + backends, the cost centres are kernel executions and memory copies. -* ``foo.timeline``: a list of all recorded profiling events, in the - order in which they occurred, along with their runtime and other - available information +* ``foo.timeline``: a list of all recorded profiling events, in the order in + which they occurred, along with their runtime and other available information, + most importantly the source locations. +The log file is often too verbose to be useful, but the summary and timeline +should be inspected, even if the latter is sometimes fairly large. + Technicalities -------------- @@ -73,10 +75,10 @@ Raw reports ----------- -Alternatively, the JSON can also contain a raw profiling report as -produced by the C API function ``futhark_context_report()``. A -directory is still created, but it will only contain a single set of -files, and it will not contain a log. +Alternatively, the JSON file passed to ``futhark profile`` may also be a raw +profiling report as produced by the C API function ``futhark_context_report()``. +A directory is still created, but it will only contain a single set of files, +and it will not contain a log. EXAMPLES ======== 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 @@ -37,7 +37,8 @@ [tags { tags... }] [entry: names...] - ["name..."] [compiled|nobench|random|script] input ({ values... } | @ filename) + ["name..."] [ tags... ] + random input { types ... } | script input { ... } | input ({ values... } | @ filename) output { values... } | auto output | error: regex If a test case begins with a quoted string, that string is reported as @@ -95,11 +96,6 @@ This is used to test the type checker. -Tuple syntax is not supported when specifying input and output values. -Instead, you can write an N-tuple as its constituent N values. Beware -of syntax errors in the values - the errors reported by -``futhark test`` are very poor. - An optional tags specification is permitted in the first test block. This section can contain arbitrary tags that classify the benchmark:: @@ -122,6 +118,23 @@ For many usage examples, see the ``tests`` directory in the Futhark source directory. A simple example can be found in ``EXAMPLES`` below. + +VALUES +------ + +The notation used for specifying values in ``input`` and ``output`` blocks is a +small subset of Futhark syntax. + +Tuple syntax is not supported. Instead, you can write an *N*-tuple as its +constituent *N* values. Beware of syntax errors in the values - the errors +reported by ``futhark test`` are very poor. When comparing the output of an +entry point with the values in an ``output`` block, the tuple is implicitly +unpacked and compared to the expected values. + +The element type of an array value is determined by the first primitive element +of the array. You therefore only need to provide a type suffix on the first +element. If no suffix is provided, integer arrays have element type ``i32`` and +decimal arrays have type ``f64``. OPTIONS ======= diff --git a/futhark.cabal b/futhark.cabal --- a/futhark.cabal +++ b/futhark.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: futhark -version: 0.25.31 +version: 0.25.32 synopsis: An optimising compiler for a functional, array-oriented language. description: Futhark is a small programming language designed to be compiled to @@ -466,7 +466,7 @@ , file-embed >=0.0.14.0 , filepath >=1.4.1.1 , free >=5.1.10 - , futhark-data >= 1.1.1.0 + , futhark-data >= 1.1.2.0 , futhark-server >= 1.2.3.0 , futhark-manifest >= 1.5.0.0 , githash >=0.1.6.1 @@ -506,12 +506,10 @@ ghc-options: -threaded -rtsopts "-with-rtsopts=-maxN16 -qg1 -A16M" build-depends: base, futhark -test-suite unit +library futhark-testing import: common - type: exitcode-stdio-1.0 - main-is: futhark_tests.hs - hs-source-dirs: unittests - other-modules: + hs-source-dirs: src-testing + exposed-modules: Futhark.AD.DerivativesTests Futhark.Analysis.AlgSimplifyTests Futhark.Analysis.PrimExp.TableTests @@ -535,6 +533,8 @@ Futhark.Pkg.SolveTests Futhark.ProfileTests Language.Futhark.CoreTests + Language.Futhark.PrettyTests + Language.Futhark.ParserBenchmarks Language.Futhark.PrimitiveTests Language.Futhark.SemanticTests Language.Futhark.SyntaxTests @@ -542,13 +542,33 @@ Language.Futhark.TypeCheckerTests build-depends: QuickCheck >=2.8 - , mtl >=2.2.1 + , criterion + , mtl >=2.2.1 , base , containers , free , futhark , megaparsec + , srcloc , tasty , tasty-hunit , tasty-quickcheck , text + +test-suite unit + import: common + type: exitcode-stdio-1.0 + main-is: src-testing/futhark_tests.hs + build-depends: + base + , futhark-testing + , tasty + +benchmark benchmarks + import: common + type: exitcode-stdio-1.0 + main-is: src-testing/futhark_benchmarks.hs + build-depends: + base + , criterion + , futhark-testing diff --git a/prelude/math.fut b/prelude/math.fut --- a/prelude/math.fut +++ b/prelude/math.fut @@ -81,12 +81,12 @@ module type integral = { include numeric - -- | Like `/`@term, but rounds towards zero. This only matters when - -- one of the operands is negative. May be more efficient. + -- | Like `/`, but rounds towards zero. This only matters when one of the + -- operands is negative. May be more efficient. val (//) : t -> t -> t - -- | Like `%`@term, but rounds towards zero. This only matters when - -- one of the operands is negative. May be more efficient. + -- | Like `%`, but rounds towards zero. This only matters when one of the + -- operands is negative. May be more efficient. val (%%) : t -> t -> t -- | Bitwise and. @@ -204,7 +204,7 @@ -- | The true Gamma function. val gamma : t -> t - -- | The natural logarithm of the absolute value of `gamma`@term. + -- | The natural logarithm of the absolute value of `gamma`. val lgamma : t -> t -- | The error function. @@ -245,7 +245,7 @@ -- | Computes `a*b+c`. Depending on the compiler backend, this may -- be fused into a single operation that is faster but less - -- accurate. Do not confuse it with `fma`@term. + -- accurate. Do not confuse it with `fma`. val mad : (a: t) -> (b: t) -> (c: t) -> t -- | Computes `a*b+c`, with `a*b` being rounded with infinite @@ -1036,8 +1036,8 @@ def ldexp x y = intrinsics.ldexp64 (x, y) def copysign x y = intrinsics.copysign64 (x, y) - def to_bits (x: f64) : u64 = u64m.i64 (intrinsics.to_bits64 x) - def from_bits (x: u64) : f64 = intrinsics.from_bits64 (intrinsics.sign_i64 x) + def to_bits (x: f64) : u64 = u64m.i64 (intrinsics.fptobits_f64_i64 x) + def from_bits (x: u64) : f64 = intrinsics.bitstofp_i64_f64 (intrinsics.sign_i64 x) def num_bits = 64i32 def get_bit (bit: i32) (x: t) = u64m.get_bit bit (to_bits x) @@ -1161,8 +1161,8 @@ def ldexp x y = intrinsics.ldexp32 (x, y) def copysign x y = intrinsics.copysign32 (x, y) - def to_bits (x: f32) : u32 = u32m.i32 (intrinsics.to_bits32 x) - def from_bits (x: u32) : f32 = intrinsics.from_bits32 (intrinsics.sign_i32 x) + def to_bits (x: f32) : u32 = u32m.i32 (intrinsics.fptobits_f32_i32 x) + def from_bits (x: u32) : f32 = intrinsics.bitstofp_i32_f32 (intrinsics.sign_i32 x) def num_bits = 32i32 def get_bit (bit: i32) (x: t) = u32m.get_bit bit (to_bits x) @@ -1290,8 +1290,8 @@ def ldexp x y = intrinsics.ldexp16 (x, y) def copysign x y = intrinsics.copysign16 (x, y) - def to_bits (x: f16) : u16 = u16m.i16 (intrinsics.to_bits16 x) - def from_bits (x: u16) : f16 = intrinsics.from_bits16 (intrinsics.sign_i16 x) + def to_bits (x: f16) : u16 = u16m.i16 (intrinsics.fptobits_f16_i16 x) + def from_bits (x: u16) : f16 = intrinsics.bitstofp_i16_f16 (intrinsics.sign_i16 x) def num_bits = 16i32 def get_bit (bit: i32) (x: t) = u16m.get_bit bit (to_bits x) diff --git a/rts/c/atomics16.h b/rts/c/atomics16.h --- a/rts/c/atomics16.h +++ b/rts/c/atomics16.h @@ -150,13 +150,13 @@ int shift = offset * 16; int32_t mask = 0xffff << shift; int32_t old = 0; - int32_t upd = mask & ((int32_t)futrts_to_bits16(val) << shift); + int32_t upd = mask & ((int32_t)fptobits_f16_i16(val) << shift); int32_t saw; while ((saw=atomic_cmpxchg_i32_global(p32, old, upd)) != old) { old = saw; - upd = (old & ~mask) | (int32_t)futrts_to_bits16(futrts_from_bits16((uint32_t)old >> shift) + val) << shift; + upd = (old & ~mask) | (int32_t)fptobits_f16_i16(bitstofp_i16_f16((uint32_t)old >> shift) + val) << shift; } - return futrts_from_bits16((uint32_t)old >> shift); + return bitstofp_i16_f16((uint32_t)old >> shift); } SCALAR_FUN_ATTR f16 atomic_fadd_f16_shared(volatile __local uint16_t *p, f16 val) { @@ -165,13 +165,13 @@ int shift = offset * 16; int32_t mask = 0xffff << shift; int32_t old = 0; - int32_t upd = mask & ((int32_t)futrts_to_bits16(val) << shift); + int32_t upd = mask & ((int32_t)fptobits_f16_i16(val) << shift); int32_t saw; while ((saw=atomic_cmpxchg_i32_shared(p32, old, upd)) != old) { old = saw; - upd = (old & ~mask) | (int32_t)futrts_to_bits16(futrts_from_bits16((uint32_t)old >> shift) + val) << shift; + upd = (old & ~mask) | (int32_t)fptobits_f16_i16(bitstofp_i16_f16((uint32_t)old >> shift) + val) << shift; } - return futrts_from_bits16((uint32_t)old >> shift); + return bitstofp_i16_f16((uint32_t)old >> shift); } // End of atomics16.h diff --git a/rts/c/atomics64.h b/rts/c/atomics64.h --- a/rts/c/atomics64.h +++ b/rts/c/atomics64.h @@ -34,7 +34,7 @@ #if defined(FUTHARK_CUDA) || defined(FUTHARK_HIP) return atomicExch((unsigned long long*)p, x); #else - return atom_xor(p, x); + return atom_xchg(p, x); #endif } @@ -42,7 +42,7 @@ #if defined(FUTHARK_CUDA) || defined(FUTHARK_HIP) return atomicExch((unsigned long long*)p, x); #else - return atom_xor(p, x); + return atom_xchg(p, x); #endif } @@ -103,9 +103,9 @@ union {int64_t i; double f;} ret; old.f = x; while (1) { - ret.i = atom_xchg((volatile __global int64_t*)p, (int64_t)0); + ret.i = atomic_xchg_i64_global((volatile __global int64_t*)p, (int64_t)0); ret.f += old.f; - old.i = atom_xchg((volatile __global int64_t*)p, ret.i); + old.i = atomic_xchg_i64_global((volatile __global int64_t*)p, ret.i); if (old.i == 0) { break; } 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 @@ -339,7 +339,12 @@ { 7, 5, "compute_75" }, { 8, 0, "compute_80" }, { 8, 6, "compute_80" }, - { 8, 7, "compute_80" } + { 8, 7, "compute_80" }, + { 8, 9, "compute_80" }, + { 9, 0, "compute_90" }, + { 10, 0, "compute_100" }, + { 10, 1, "compute_101" }, + { 12, 0, "compute_120" } }; int major = device_query(dev, COMPUTE_CAPABILITY_MAJOR); @@ -877,13 +882,15 @@ } static int gpu_scalar_to_device(struct futhark_context* ctx, + const char *provenance, gpu_mem dst, size_t offset, size_t size, void *src) { struct cuda_event *event = cuda_event_new(ctx); if (event != NULL) { add_event(ctx, "copy_scalar_to_dev", - strdup(""), + provenance, + NULL, event, (event_report_fn)cuda_event_report); CUDA_SUCCEED_FATAL(cuEventRecord(event->start, ctx->stream)); @@ -896,13 +903,15 @@ } static int gpu_scalar_from_device(struct futhark_context* ctx, + const char *provenance, void *dst, gpu_mem src, size_t offset, size_t size) { struct cuda_event *event = cuda_event_new(ctx); if (event != NULL) { add_event(ctx, "copy_scalar_from_dev", - strdup(""), + provenance, + NULL, event, (event_report_fn)cuda_event_report); CUDA_SUCCEED_FATAL(cuEventRecord(event->start, ctx->stream)); @@ -915,6 +924,7 @@ } static int gpu_memcpy(struct futhark_context* ctx, + const char *provenance, gpu_mem dst, int64_t dst_offset, gpu_mem src, int64_t src_offset, int64_t nbytes) { @@ -922,7 +932,8 @@ if (event != NULL) { add_event(ctx, "copy_dev_to_dev", - strdup(""), + provenance, + NULL, event, (event_report_fn)cuda_event_report); CUDA_SUCCEED_FATAL(cuEventRecord(event->start, ctx->stream)); @@ -934,7 +945,9 @@ return FUTHARK_SUCCESS; } -static int memcpy_host2gpu(struct futhark_context* ctx, bool sync, +static int memcpy_host2gpu(struct futhark_context* ctx, + const char *provenance, + bool sync, gpu_mem dst, int64_t dst_offset, const unsigned char* src, int64_t src_offset, int64_t nbytes) { @@ -943,7 +956,8 @@ if (event != NULL) { add_event(ctx, "copy_host_to_dev", - strdup(""), + provenance, + NULL, event, (event_report_fn)cuda_event_report); CUDA_SUCCEED_FATAL(cuEventRecord(event->start, ctx->stream)); @@ -962,7 +976,9 @@ return FUTHARK_SUCCESS; } -static int memcpy_gpu2host(struct futhark_context* ctx, bool sync, +static int memcpy_gpu2host(struct futhark_context* ctx, + const char *provenance, + bool sync, unsigned char* dst, int64_t dst_offset, gpu_mem src, int64_t src_offset, int64_t nbytes) { @@ -971,7 +987,8 @@ if (event != NULL) { add_event(ctx, "copy_dev_to_host", - strdup(""), + provenance, + NULL, event, (event_report_fn)cuda_event_report); CUDA_SUCCEED_FATAL(cuEventRecord(event->start, ctx->stream)); @@ -996,7 +1013,8 @@ } static int gpu_launch_kernel(struct futhark_context* ctx, - gpu_kernel kernel, const char *name, + gpu_kernel kernel, + const char *name, const char *provenance, const int32_t grid[3], const int32_t block[3], unsigned int shared_mem_bytes, @@ -1020,16 +1038,17 @@ if (event != NULL) { CUDA_SUCCEED_FATAL(cuEventRecord(event->start, ctx->stream)); + + struct kvs *kvs = kvs_new(); + kvs_printf(kvs, "kernel", "\"%s\"", name); + kvs_printf(kvs, "grid", "[%d,%d,%d]", grid[0], grid[1], grid[2]); + kvs_printf(kvs, "block", "[%d,%d,%d]", block[0], block[1], block[2]); + kvs_printf(kvs, "shared memory", "%d", shared_mem_bytes); + add_event(ctx, name, - msgprintf("Kernel %s with\n" - " grid=(%d,%d,%d)\n" - " block=(%d,%d,%d)\n" - " shared memory=%d", - name, - grid[0], grid[1], grid[2], - block[0], block[1], block[2], - shared_mem_bytes), + provenance, + kvs, event, (event_report_fn)cuda_event_report); } 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 @@ -720,13 +720,15 @@ } static int gpu_scalar_to_device(struct futhark_context* ctx, + const char *provenance, gpu_mem dst, size_t offset, size_t size, void *src) { struct hip_event *event = hip_event_new(ctx); if (event != NULL) { add_event(ctx, "copy_scalar_to_dev", - strdup(""), + provenance, + NULL, event, (event_report_fn)hip_event_report); HIP_SUCCEED_FATAL(hipEventRecord(event->start, ctx->stream)); @@ -739,13 +741,15 @@ } static int gpu_scalar_from_device(struct futhark_context* ctx, + const char *provenance, void *dst, gpu_mem src, size_t offset, size_t size) { struct hip_event *event = hip_event_new(ctx); if (event != NULL) { add_event(ctx, "copy_scalar_from_dev", - strdup(""), + provenance, + NULL, event, (event_report_fn)hip_event_report); HIP_SUCCEED_FATAL(hipEventRecord(event->start, ctx->stream)); @@ -758,6 +762,7 @@ } static int gpu_memcpy(struct futhark_context* ctx, + const char *provenance, gpu_mem dst, int64_t dst_offset, gpu_mem src, int64_t src_offset, int64_t nbytes) { @@ -765,7 +770,8 @@ if (event != NULL) { add_event(ctx, "copy_dev_to_dev", - strdup(""), + provenance, + NULL, event, (event_report_fn)hip_event_report); HIP_SUCCEED_FATAL(hipEventRecord(event->start, ctx->stream)); @@ -778,7 +784,9 @@ return FUTHARK_SUCCESS; } -static int memcpy_host2gpu(struct futhark_context* ctx, bool sync, +static int memcpy_host2gpu(struct futhark_context* ctx, + const char *provenance, + bool sync, gpu_mem dst, int64_t dst_offset, const unsigned char* src, int64_t src_offset, int64_t nbytes) { @@ -787,7 +795,8 @@ if (event != NULL) { add_event(ctx, "copy_host_to_dev", - strdup(""), + provenance, + NULL, event, (event_report_fn)hip_event_report); HIP_SUCCEED_FATAL(hipEventRecord(event->start, ctx->stream)); @@ -809,7 +818,9 @@ return FUTHARK_SUCCESS; } -static int memcpy_gpu2host(struct futhark_context* ctx, bool sync, +static int memcpy_gpu2host(struct futhark_context* ctx, + const char *provenance, + bool sync, unsigned char* dst, int64_t dst_offset, gpu_mem src, int64_t src_offset, int64_t nbytes) { @@ -818,7 +829,8 @@ if (event != NULL) { add_event(ctx, "copy_dev_to_host", - strdup(""), + provenance, + NULL, event, (event_report_fn)hip_event_report); HIP_SUCCEED_FATAL(hipEventRecord(event->start, ctx->stream)); @@ -847,7 +859,8 @@ } static int gpu_launch_kernel(struct futhark_context* ctx, - gpu_kernel kernel, const char *name, + gpu_kernel kernel, + const char *name, const char *provenance, const int32_t grid[3], const int32_t block[3], unsigned int shared_mem_bytes, @@ -871,16 +884,17 @@ if (event != NULL) { HIP_SUCCEED_FATAL(hipEventRecord(event->start, ctx->stream)); + + struct kvs *kvs = kvs_new(); + kvs_printf(kvs, "kernel", "\"%s\"", name); + kvs_printf(kvs, "grid", "[%d,%d,%d]", grid[0], grid[1], grid[2]); + kvs_printf(kvs, "block", "[%d,%d,%d]", block[0], block[1], block[2]); + kvs_printf(kvs, "shared memory", "%d", shared_mem_bytes); + add_event(ctx, name, - msgprintf("Kernel %s with\n" - " grid=(%d,%d,%d)\n" - " block=(%d,%d,%d)\n" - " shared memory=%d", - name, - grid[0], grid[1], grid[2], - block[0], block[1], block[2], - shared_mem_bytes), + provenance, + kvs, event, (event_report_fn)hip_event_report); } 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 @@ -1157,13 +1157,15 @@ } static int gpu_scalar_to_device(struct futhark_context* ctx, + const char *provenance, gpu_mem dst, size_t offset, size_t size, void *src) { cl_event* event = opencl_event_new(ctx); if (event != NULL) { add_event(ctx, "copy_scalar_to_dev", - strdup(""), + provenance, + NULL, event, (event_report_fn)opencl_event_report); } @@ -1175,13 +1177,15 @@ } static int gpu_scalar_from_device(struct futhark_context* ctx, + const char *provenance, void *dst, gpu_mem src, size_t offset, size_t size) { cl_event* event = opencl_event_new(ctx); if (event != NULL) { add_event(ctx, "copy_scalar_from_dev", - strdup(""), + provenance, + NULL, event, (event_report_fn)opencl_event_report); } @@ -1192,7 +1196,7 @@ return 0; } -static int gpu_memcpy(struct futhark_context* ctx, +static int gpu_memcpy(struct futhark_context* ctx, const char *provenance, gpu_mem dst, int64_t dst_offset, gpu_mem src, int64_t src_offset, int64_t nbytes) { @@ -1201,7 +1205,8 @@ if (event != NULL) { add_event(ctx, "copy_dev_to_dev", - strdup(""), + provenance, + NULL, event, (event_report_fn)opencl_event_report); } @@ -1218,7 +1223,8 @@ return FUTHARK_SUCCESS; } -static int memcpy_host2gpu(struct futhark_context* ctx, bool sync, +static int memcpy_host2gpu(struct futhark_context* ctx, const char *provenance, + bool sync, gpu_mem dst, int64_t dst_offset, const unsigned char* src, int64_t src_offset, int64_t nbytes) { @@ -1227,7 +1233,8 @@ if (event != NULL) { add_event(ctx, "copy_host_to_dev", - strdup(""), + provenance, + NULL, event, (event_report_fn)opencl_event_report); } @@ -1245,7 +1252,8 @@ return FUTHARK_SUCCESS; } -static int memcpy_gpu2host(struct futhark_context* ctx, bool sync, +static int memcpy_gpu2host(struct futhark_context* ctx, const char *provenance, + bool sync, unsigned char* dst, int64_t dst_offset, gpu_mem src, int64_t src_offset, int64_t nbytes) { @@ -1254,7 +1262,8 @@ if (event != NULL) { add_event(ctx, "copy_dev_to_host", - strdup(""), + provenance, + NULL, event, (event_report_fn)opencl_event_report); } @@ -1275,7 +1284,9 @@ } static int gpu_launch_kernel(struct futhark_context* ctx, - gpu_kernel kernel, const char *name, + gpu_kernel kernel, + const char *name, + const char *provenance, const int32_t grid[3], const int32_t block[3], unsigned int shared_mem_bytes, @@ -1292,16 +1303,17 @@ cl_event* event = opencl_event_new(ctx); if (event != NULL) { + + struct kvs *kvs = kvs_new(); + kvs_printf(kvs, "kernel", "\"%s\"", name); + kvs_printf(kvs, "grid", "[%d,%d,%d]", grid[0], grid[1], grid[2]); + kvs_printf(kvs, "block", "[%d,%d,%d]", block[0], block[1], block[2]); + kvs_printf(kvs, "shared memory", "%d", shared_mem_bytes); + add_event(ctx, name, - msgprintf("Kernel %s with\n" - " grid=(%d,%d,%d)\n" - " block=(%d,%d,%d)\n" - " shared memory=%d", - name, - grid[0], grid[1], grid[2], - block[0], block[1], block[2], - shared_mem_bytes), + provenance, + kvs, event, (event_report_fn)opencl_event_report); } diff --git a/rts/c/context.h b/rts/c/context.h --- a/rts/c/context.h +++ b/rts/c/context.h @@ -70,13 +70,20 @@ static void add_event(struct futhark_context* ctx, const char* name, - char* description, + const char* provenance, + struct kvs *kvs, void* data, event_report_fn f) { + if (provenance == NULL) { + provenance = "unknown"; + } if (ctx->logging) { - fprintf(ctx->log, "Event: %s\n%s\n", name, description); + fprintf(ctx->log, "Event: %s\n at: %s\n", name, provenance); + if (kvs) { + kvs_log(kvs, " ", ctx->log); + } } - add_event_to_list(&ctx->event_list, name, description, data, f); + add_event_to_list(&ctx->event_list, name, provenance, kvs, data, f); } char *futhark_context_get_error(struct futhark_context *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 @@ -20,9 +20,11 @@ // Allocate memory allocated with host_alloc(). static void host_free(struct futhark_context* ctx, size_t size, const char* tag, void* mem); -// Log that a copy has occurred. +// Log that a copy has occurred. The provenance may be NULL, if we do not know +// where this came from. static void log_copy(struct futhark_context* ctx, - const char *kind, int r, + const char *kind, const char *provenance, + int r, int64_t dst_offset, int64_t dst_strides[r], int64_t src_offset, int64_t src_strides[r], int64_t shape[r]); @@ -43,7 +45,8 @@ static void add_event(struct futhark_context* ctx, const char* name, - char* description, + const char* provenance, + struct kvs *kvs, void* data, event_report_fn f); diff --git a/rts/c/copy.h b/rts/c/copy.h --- a/rts/c/copy.h +++ b/rts/c/copy.h @@ -188,12 +188,14 @@ static void log_copy(struct futhark_context* ctx, - const char *kind, int r, + const char *kind, const char *provenance, + int r, int64_t dst_offset, int64_t dst_strides[r], int64_t src_offset, int64_t src_strides[r], int64_t shape[r]) { if (ctx->logging) { fprintf(ctx->log, "\n# Copy %s\n", kind); + if (provenance) { fprintf(ctx->log, "At: %s\n", provenance); } fprintf(ctx->log, "Shape: "); for (int i = 0; i < r; i++) { fprintf(ctx->log, "[%ld]", (long int)shape[i]); } fprintf(ctx->log, "\n"); @@ -225,7 +227,7 @@ ELEM_TYPE* dst, int64_t dst_offset, int64_t dst_strides[r], \ ELEM_TYPE *src, int64_t src_offset, int64_t src_strides[r], \ int64_t shape[r]) { \ - log_copy(ctx, "CPU to CPU", r, dst_offset, dst_strides, \ + log_copy(ctx, "CPU to CPU", NULL, r, dst_offset, dst_strides, \ src_offset, src_strides, shape); \ int64_t size = 1; \ for (int i = 0; i < r; i++) { size *= shape[i]; } \ 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 @@ -2,11 +2,114 @@ typedef int (*event_report_fn)(struct str_builder*, void*); +// A collection of key-value associations. Used to associate extra data with +// events. +struct kvs { + // A buffer that contains all value data. Must be freed when the struct kvs is + // no longer used. + char *buf; + + // Size of buf in bytes. + size_t buf_size; + + // Number of bytes used in buf. + size_t buf_used; + + // Number of associations stored. + size_t n; + + // Capacity of vals. + size_t vals_capacity; + + // An array of keys. + const char* *keys; + + // Indexes into 'buf' that contains the values as zero-terminated strings. + size_t *vals; +}; + +static const size_t KVS_INIT_BUF_SIZE = 128; +static const size_t KVS_INIT_NUMKEYS = 8; + +void kvs_init(struct kvs* kvs) { + kvs->buf = malloc(KVS_INIT_BUF_SIZE); + kvs->buf_size = KVS_INIT_BUF_SIZE; + kvs->buf_used = 0; + kvs->vals_capacity = KVS_INIT_NUMKEYS; + kvs->keys = calloc(kvs->vals_capacity, sizeof(const char*)); + kvs->vals = calloc(kvs->vals_capacity, sizeof(size_t)); + kvs->n = 0; +} + +struct kvs* kvs_new(void) { + struct kvs *kvs = malloc(sizeof(struct kvs)); + kvs_init(kvs); + return kvs; +} + +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); + + while (kvs->buf_used+needed > kvs->buf_size) { + kvs->buf_size *= 2; + kvs->buf = realloc(kvs->buf, kvs->buf_size * sizeof(const char*)); + } + + if (kvs->n == kvs->vals_capacity) { + kvs->vals_capacity *= 2; + kvs->vals = realloc(kvs->vals, kvs->vals_capacity * sizeof(size_t)); + kvs->keys = realloc(kvs->keys, kvs->vals_capacity * sizeof(char*)); + } + + kvs->keys[kvs->n] = key; + kvs->vals[kvs->n] = kvs->buf_used; + kvs->buf_used += needed; + + va_start(vl, fmt); // Must re-init. + vsnprintf(&kvs->buf[kvs->vals[kvs->n]], needed, fmt, vl); + + kvs->n++; +} + +void kvs_free(struct kvs* kvs) { + free(kvs->vals); + free(kvs->keys); + free(kvs->buf); +} + +// Assumes all of the values are valid JSON objects. +void kvs_json(const struct kvs* kvs, struct str_builder *sb) { + str_builder_char(sb, '{'); + for (size_t i = 0; i < kvs->n; i++) { + if (i != 0) { + str_builder_str(sb, ","); + } + str_builder_json_str(sb, kvs->keys[i]); + str_builder_str(sb, ":"); + str_builder_str(sb, &kvs->buf[kvs->vals[i]]); + } + str_builder_char(sb, '}'); +} + +void kvs_log(const struct kvs* kvs, const char* prefix, FILE* f) { + for (size_t i = 0; i < kvs->n; i++) { + fprintf(f, "%s%s: %s\n", + prefix, + kvs->keys[i], + &kvs->buf[kvs->vals[i]]); + } +} + struct event { void* data; event_report_fn f; const char* name; - char *description; + const char *provenance; + // Key-value information that is also to be printed. + struct kvs *kvs; }; struct event_list { @@ -27,7 +130,8 @@ static void add_event_to_list(struct event_list *l, const char* name, - char* description, + const char* provenance, + struct kvs *kvs, void* data, event_report_fn f) { if (l->num_events == l->capacity) { @@ -35,7 +139,9 @@ l->events = realloc(l->events, l->capacity * sizeof(struct event)); } l->events[l->num_events].name = name; - l->events[l->num_events].description = description; + l->events[l->num_events].provenance = + provenance ? provenance : "unknown"; + l->events[l->num_events].kvs = kvs; l->events[l->num_events].data = data; l->events[l->num_events].f = f; l->num_events++; @@ -50,13 +156,21 @@ } str_builder_str(sb, "{\"name\":"); str_builder_json_str(sb, l->events[i].name); - str_builder_str(sb, ",\"description\":"); - str_builder_json_str(sb, l->events[i].description); - free(l->events[i].description); + str_builder_str(sb, ",\"provenance\":"); + str_builder_json_str(sb, l->events[i].provenance); if (l->events[i].f(sb, l->events[i].data) != 0) { ret = 1; break; } + + str_builder_str(sb, ",\"details\":"); + if (l->events[i].kvs) { + kvs_json(l->events[i].kvs, sb); + kvs_free(l->events[i].kvs); + } else { + str_builder_str(sb, "{}"); + } + str_builder(sb, "}"); } event_list_free(l); diff --git a/rts/c/gpu.h b/rts/c/gpu.h --- a/rts/c/gpu.h +++ b/rts/c/gpu.h @@ -7,21 +7,22 @@ static int gpu_free_actual(struct futhark_context *ctx, gpu_mem mem); static int gpu_alloc_actual(struct futhark_context *ctx, size_t size, gpu_mem *mem_out); int gpu_launch_kernel(struct futhark_context* ctx, - gpu_kernel kernel, const char *name, + gpu_kernel kernel, + const char *name, const char *provenance, const int32_t grid[3], const int32_t block[3], unsigned int shared_mem_bytes, int num_args, void* args[num_args], size_t args_sizes[num_args]); -int gpu_memcpy(struct futhark_context* ctx, +int gpu_memcpy(struct futhark_context* ctx, const char* provenance, gpu_mem dst, int64_t dst_offset, gpu_mem src, int64_t src_offset, int64_t nbytes); -int gpu_scalar_from_device(struct futhark_context* ctx, +int gpu_scalar_from_device(struct futhark_context* ctx, const char* provenance, void *dst, gpu_mem src, size_t offset, size_t size); -int gpu_scalar_to_device(struct futhark_context* ctx, +int gpu_scalar_to_device(struct futhark_context* ctx, const char* provenance, gpu_mem dst, size_t offset, size_t size, void *src); void gpu_create_kernel(struct futhark_context *ctx, @@ -329,6 +330,7 @@ } static int gpu_map_transpose(struct futhark_context* ctx, + const char* provenance, gpu_kernel kernel_default, gpu_kernel kernel_low_height, gpu_kernel kernel_low_width, @@ -452,14 +454,14 @@ fprintf(ctx->log, "\n"); } - return gpu_launch_kernel(ctx, kernel, name, grid, block, + return gpu_launch_kernel(ctx, kernel, name, provenance, grid, block, TR_TILE_DIM*(TR_TILE_DIM+1)*elem_size, sizeof(args)/sizeof(args[0]), args, args_sizes); } #define GEN_MAP_TRANSPOSE_GPU2GPU(NAME, ELEM_TYPE) \ static int map_transpose_gpu2gpu_##NAME \ - (struct futhark_context* ctx, \ + (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) \ @@ -467,6 +469,7 @@ return \ gpu_map_transpose \ (ctx, \ + provenance, \ ctx->kernels->map_transpose_##NAME, \ ctx->kernels->map_transpose_##NAME##_low_height, \ ctx->kernels->map_transpose_##NAME##_low_width, \ @@ -477,7 +480,7 @@ k, n, m); \ } -static int gpu_lmad_copy(struct futhark_context* ctx, +static int gpu_lmad_copy(struct futhark_context* ctx, const char* provenance, gpu_kernel kernel, int r, gpu_mem dst, int64_t dst_offset, int64_t dst_strides[r], gpu_mem src, int64_t src_offset, int64_t src_strides[r], @@ -524,7 +527,7 @@ } const size_t w = 256; // XXX: hardcoded thread block size. - return gpu_launch_kernel(ctx, kernel, "copy_lmad_dev_to_dev", + return gpu_launch_kernel(ctx, kernel, "copy_lmad_dev_to_dev", provenance, (const int32_t[3]) {(n+w-1)/w,1,1}, (const int32_t[3]) {w,1,1}, 0, 6+(8*3), args, args_sizes); @@ -532,12 +535,14 @@ #define GEN_LMAD_COPY_ELEMENTS_GPU2GPU(NAME, ELEM_TYPE) \ static int lmad_copy_elements_gpu2gpu_##NAME \ - (struct futhark_context* ctx, \ + (struct futhark_context* ctx, const char* provenance, \ int r, \ gpu_mem dst, int64_t dst_offset, int64_t dst_strides[r], \ gpu_mem src, int64_t src_offset, int64_t src_strides[r], \ int64_t shape[r]) { \ - return gpu_lmad_copy(ctx, ctx->kernels->lmad_copy_##NAME, r, \ + return gpu_lmad_copy(ctx, provenance, \ + ctx->kernels->lmad_copy_##NAME, \ + r, \ dst, dst_offset, dst_strides, \ src, src_offset, src_strides, \ shape); \ @@ -545,32 +550,34 @@ #define GEN_LMAD_COPY_GPU2GPU(NAME, ELEM_TYPE) \ static int lmad_copy_gpu2gpu_##NAME \ - (struct futhark_context* ctx, \ + (struct futhark_context* ctx, const char* provenance, \ int r, \ gpu_mem dst, int64_t dst_offset, int64_t dst_strides[r], \ gpu_mem src, int64_t src_offset, int64_t src_strides[r], \ int64_t shape[r]) { \ - log_copy(ctx, "GPU to GPU", r, dst_offset, dst_strides, \ + log_copy(ctx, "GPU to GPU", provenance, r, dst_offset, dst_strides, \ src_offset, src_strides, shape); \ 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)) { \ + r, dst_strides, src_strides, shape)) { \ log_transpose(ctx, k, n, m); \ return map_transpose_gpu2gpu_##NAME \ - (ctx, dst, dst_offset, src, src_offset, k, n, m); \ + (ctx, provenance, dst, dst_offset, src, src_offset, k, n, m); \ } else if (lmad_memcpyable(r, dst_strides, src_strides, shape)) { \ if (ctx->logging) {fprintf(ctx->log, "## Flat copy\n\n");} \ return gpu_memcpy(ctx, \ + provenance, \ dst, dst_offset*sizeof(ELEM_TYPE), \ src, src_offset*sizeof(ELEM_TYPE), \ size * sizeof(ELEM_TYPE)); \ } else { \ if (ctx->logging) {fprintf(ctx->log, "## General copy\n\n");} \ return lmad_copy_elements_gpu2gpu_##NAME \ - (ctx, r, \ + (ctx, provenance, \ + r, \ dst, dst_offset, dst_strides, \ src, src_offset, src_strides, \ shape); \ @@ -578,12 +585,13 @@ } static int -lmad_copy_elements_host2gpu(struct futhark_context *ctx, size_t elem_size, +lmad_copy_elements_host2gpu(struct futhark_context *ctx, const char *provenance, + size_t elem_size, int r, gpu_mem dst, int64_t dst_offset, int64_t dst_strides[r], unsigned char* src, int64_t src_offset, int64_t src_strides[r], int64_t shape[r]) { - (void)ctx; (void)elem_size; (void)r; + (void)ctx; (void)provenance; (void)elem_size; (void)r; (void)dst; (void)dst_offset; (void)dst_strides; (void)src; (void)src_offset; (void)src_strides; (void)shape; @@ -592,12 +600,13 @@ } static int -lmad_copy_elements_gpu2host (struct futhark_context *ctx, size_t elem_size, +lmad_copy_elements_gpu2host (struct futhark_context *ctx, const char *provenance, + size_t elem_size, int r, unsigned char* dst, int64_t dst_offset, int64_t dst_strides[r], gpu_mem src, int64_t src_offset, int64_t src_strides[r], int64_t shape[r]) { - (void)ctx; (void)elem_size; (void)r; + (void)ctx; (void)provenance; (void)elem_size; (void)r; (void)dst; (void)dst_offset; (void)dst_strides; (void)src; (void)src_offset; (void)src_strides; (void)shape; @@ -605,26 +614,13 @@ return 1; } -#define GEN_LMAD_COPY_ELEMENTS_HOSTGPU(NAME, ELEM_TYPE) \ - static int lmad_copy_elements_gpu2gpu_##NAME \ - (struct futhark_context* ctx, \ - int r, \ - gpu_mem dst, int64_t dst_offset, int64_t dst_strides[r], \ - gpu_mem src, int64_t src_offset, int64_t src_strides[r], \ - int64_t shape[r]) { \ - return (ctx, ctx->kernels->lmad_copy_##NAME, r, \ - dst, dst_offset, dst_strides, \ - src, src_offset, src_strides, \ - shape); \ - } \ - - -static int lmad_copy_host2gpu(struct futhark_context* ctx, size_t elem_size, bool sync, +static int lmad_copy_host2gpu(struct futhark_context* ctx, const char* provenance, + size_t elem_size, bool sync, int r, gpu_mem dst, int64_t dst_offset, int64_t dst_strides[r], unsigned char* src, int64_t src_offset, int64_t src_strides[r], int64_t shape[r]) { - log_copy(ctx, "Host to GPU", r, dst_offset, dst_strides, + log_copy(ctx, "Host to GPU", provenance, r, dst_offset, dst_strides, src_offset, src_strides, shape); int64_t size = elem_size; for (int i = 0; i < r; i++) { size *= shape[i]; } @@ -632,7 +628,8 @@ int64_t k, n, m; if (lmad_memcpyable(r, dst_strides, src_strides, shape)) { if (ctx->logging) {fprintf(ctx->log, "## Flat copy\n\n");} - return memcpy_host2gpu(ctx, sync, + return memcpy_host2gpu(ctx, provenance, + sync, dst, dst_offset*elem_size, src, src_offset*elem_size, size); @@ -640,7 +637,8 @@ if (ctx->logging) {fprintf(ctx->log, "## General copy\n\n");} int error; error = lmad_copy_elements_host2gpu - (ctx, elem_size, r, + (ctx, provenance, + elem_size, r, dst, dst_offset, dst_strides, src, src_offset, src_strides, shape); @@ -651,12 +649,13 @@ } } -static int lmad_copy_gpu2host(struct futhark_context* ctx, size_t elem_size, bool sync, +static int lmad_copy_gpu2host(struct futhark_context* ctx, const char* provenance, + size_t elem_size, bool sync, int r, unsigned char* dst, int64_t dst_offset, int64_t dst_strides[r], gpu_mem src, int64_t src_offset, int64_t src_strides[r], int64_t shape[r]) { - log_copy(ctx, "Host to GPU", r, dst_offset, dst_strides, + log_copy(ctx, "Host to GPU", provenance, r, dst_offset, dst_strides, src_offset, src_strides, shape); int64_t size = elem_size; for (int i = 0; i < r; i++) { size *= shape[i]; } @@ -664,7 +663,8 @@ int64_t k, n, m; if (lmad_memcpyable(r, dst_strides, src_strides, shape)) { if (ctx->logging) {fprintf(ctx->log, "## Flat copy\n\n");} - return memcpy_gpu2host(ctx, sync, + return memcpy_gpu2host(ctx, provenance, + sync, dst, dst_offset*elem_size, src, src_offset*elem_size, size); @@ -672,7 +672,7 @@ if (ctx->logging) {fprintf(ctx->log, "## General copy\n\n");} int error; error = lmad_copy_elements_gpu2host - (ctx, elem_size, r, + (ctx, provenance, elem_size, r, dst, dst_offset, dst_strides, src, src_offset, src_strides, shape); diff --git a/rts/c/scalar.h b/rts/c/scalar.h --- a/rts/c/scalar.h +++ b/rts/c/scalar.h @@ -21,8 +21,8 @@ #define M_PI 3.141592653589793 #endif -SCALAR_FUN_ATTR int32_t futrts_to_bits32(float x); -SCALAR_FUN_ATTR float futrts_from_bits32(int32_t x); +SCALAR_FUN_ATTR int32_t fptobits_f32_i32(float x); +SCALAR_FUN_ATTR float bitstofp_i32_f32(int32_t x); SCALAR_FUN_ATTR uint8_t add8(uint8_t x, uint8_t y) { return x + y; } SCALAR_FUN_ATTR uint16_t add16(uint16_t x, uint16_t y) { return x + y; } @@ -1222,9 +1222,9 @@ } SCALAR_FUN_ATTR float futrts_copysign32(float x, float y) { - int32_t xb = futrts_to_bits32(x); - int32_t yb = futrts_to_bits32(y); - return futrts_from_bits32((xb & ~(1<<31)) | (yb & (1<<31))); + int32_t xb = fptobits_f32_i32(x); + int32_t yb = fptobits_f32_i32(y); + return bitstofp_i32_f32((xb & ~(1<<31)) | (yb & (1<<31))); } SCALAR_FUN_ATTR float futrts_mad32(float a, float b, float c) { @@ -1300,12 +1300,14 @@ #if defined(ISPC) -SCALAR_FUN_ATTR int32_t futrts_to_bits32(float x) { return intbits(x); } -SCALAR_FUN_ATTR float futrts_from_bits32(int32_t x) { return floatbits(x); } +SCALAR_FUN_ATTR int32_t fptobits_f32_i32(float x) { return intbits(x); } +SCALAR_FUN_ATTR float bitstofp_i32_f32(int32_t x) { return floatbits(x); } +SCALAR_FUN_ATTR uniform int32_t fptobits_f32_i32(uniform float x) { return intbits(x); } +SCALAR_FUN_ATTR uniform float bitstofp_i32_f32(uniform int32_t x) { return floatbits(x); } #else -SCALAR_FUN_ATTR int32_t futrts_to_bits32(float x) { +SCALAR_FUN_ATTR int32_t fptobits_f32_i32(float x) { union { float f; int32_t t; @@ -1315,7 +1317,7 @@ return p.t; } -SCALAR_FUN_ATTR float futrts_from_bits32(int32_t x) { +SCALAR_FUN_ATTR float bitstofp_i32_f32(int32_t x) { union { int32_t f; float t; @@ -1332,8 +1334,8 @@ #ifdef FUTHARK_F64_ENABLED -SCALAR_FUN_ATTR double futrts_from_bits64(int64_t x); -SCALAR_FUN_ATTR int64_t futrts_to_bits64(double x); +SCALAR_FUN_ATTR double bitstofp_i64_f64(int64_t x); +SCALAR_FUN_ATTR int64_t fptobits_f64_i64(double x); #if defined(ISPC) @@ -1379,7 +1381,6 @@ SCALAR_FUN_ATTR double futrts_sqrt64(double x) { return sqrt(x); } SCALAR_FUN_ATTR double futrts_rsqrt64(double x) { return 1/sqrt(x); } -extern "C" unmasked uniform double cbrt(uniform double); SCALAR_FUN_ATTR double futrts_cbrt64(double x) { double res; foreach_active (i) { @@ -1560,7 +1561,7 @@ SCALAR_FUN_ATTR bool ftob_f64_bool(double x) { return x != 0.0; } SCALAR_FUN_ATTR double btof_bool_f64(bool x) { return x ? 1.0 : 0.0; } -SCALAR_FUN_ATTR int64_t futrts_to_bits64(double x) { +SCALAR_FUN_ATTR int64_t fptobits_f64_i64(double x) { int64_t res; foreach_active (i) { uniform double tmp = extract(x, i); @@ -1570,7 +1571,7 @@ return res; } -SCALAR_FUN_ATTR double futrts_from_bits64(int64_t x) { +SCALAR_FUN_ATTR double bitstofp_i64_f64(int64_t x) { double res; foreach_active (i) { uniform int64_t tmp = extract(x, i); @@ -1580,6 +1581,14 @@ return res; } +SCALAR_FUN_ATTR uniform int64_t fptobits_f64_i64(uniform double x) { + return intbits(x); +} + +SCALAR_FUN_ATTR uniform double bitstofp_i64_f64(uniform int64_t x) { + return doublebits(x); +} + SCALAR_FUN_ATTR double fmod64(double x, double y) { return x - y * trunc(x/y); } @@ -1597,9 +1606,9 @@ } SCALAR_FUN_ATTR double futrts_copysign64(double x, double y) { - int64_t xb = futrts_to_bits64(x); - int64_t yb = futrts_to_bits64(y); - return futrts_from_bits64((xb & ~(((int64_t)1)<<63)) | (yb & (((int64_t)1)<<63))); + 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))); } SCALAR_FUN_ATTR double futrts_mad64(double a, double b, double c) { return a * b + c; } @@ -1806,7 +1815,7 @@ SCALAR_FUN_ATTR bool ftob_f64_bool(double x) { return x != 0; } SCALAR_FUN_ATTR double btof_bool_f64(bool x) { return x ? 1 : 0; } -SCALAR_FUN_ATTR int64_t futrts_to_bits64(double x) { +SCALAR_FUN_ATTR int64_t fptobits_f64_i64(double x) { union { double f; int64_t t; @@ -1816,7 +1825,7 @@ return p.t; } -SCALAR_FUN_ATTR double futrts_from_bits64(int64_t x) { +SCALAR_FUN_ATTR double bitstofp_i64_f64(int64_t x) { union { int64_t f; double t; 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 @@ -273,14 +273,14 @@ // The CUDA __half type cannot be put in unions for some reason, so we // use bespoke conversion functions instead. #ifdef __CUDA_ARCH__ -SCALAR_FUN_ATTR int16_t futrts_to_bits16(f16 x) { return __half_as_ushort(x); } -SCALAR_FUN_ATTR f16 futrts_from_bits16(int16_t x) { return __ushort_as_half(x); } +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 futrts_to_bits16(f16 x) { varying int16_t y = *((varying int16_t * uniform)&x); return y; +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 futrts_from_bits16(int16_t x) { varying f16 y = *((varying f16 * uniform)&x); return y; } +SCALAR_FUN_ATTR f16 bitstofp_i16_f16(int16_t x) { varying f16 y = *((varying f16 * uniform)&x); return y; } #else -SCALAR_FUN_ATTR int16_t futrts_to_bits16(f16 x) { +SCALAR_FUN_ATTR int16_t fptobits_f16_i16(f16 x) { union { f16 f; int16_t t; @@ -290,7 +290,7 @@ return p.t; } -SCALAR_FUN_ATTR f16 futrts_from_bits16(int16_t x) { +SCALAR_FUN_ATTR f16 bitstofp_i16_f16(int16_t x) { union { int16_t f; f16 t; @@ -359,20 +359,20 @@ // float. Similarly for vstore_half. #ifdef __OPENCL_VERSION__ -SCALAR_FUN_ATTR int16_t futrts_to_bits16(f16 x) { +SCALAR_FUN_ATTR int16_t fptobits_f16_i16(f16 x) { int16_t y; // Violating strict aliasing here. vstore_half((float)x, 0, (half*)&y); return y; } -SCALAR_FUN_ATTR f16 futrts_from_bits16(int16_t x) { +SCALAR_FUN_ATTR f16 bitstofp_i16_f16(int16_t x) { return (f16)vload_half(0, (half*)&x); } #else -SCALAR_FUN_ATTR int16_t futrts_to_bits16(f16 x) { return (int16_t)float2halfbits(x); } -SCALAR_FUN_ATTR f16 futrts_from_bits16(int16_t x) { return halfbits2float((uint16_t)x); } +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 diff --git a/rts/c/uniform.h b/rts/c/uniform.h --- a/rts/c/uniform.h +++ b/rts/c/uniform.h @@ -1206,7 +1206,6 @@ return sqrt(x); } -extern "C" unmasked uniform double cbrt(uniform double); static inline uniform double futrts_cbrt64(uniform double x) { return cbrt(x); } @@ -1704,11 +1703,11 @@ return a * b + c; } -static inline uniform int16_t futrts_to_bits16(uniform f16 x) { +static inline uniform int16_t fptobits_f16_i16(uniform f16 x) { return *((uniform int16_t *)&x); } -static inline uniform f16 futrts_from_bits16(uniform int16_t x) { +static inline uniform f16 bitstofp_i16_f16(uniform int16_t x) { return *((uniform f16 *)&x); } diff --git a/rts/python/scalar.py b/rts/python/scalar.py --- a/rts/python/scalar.py +++ b/rts/python/scalar.py @@ -736,14 +736,12 @@ return np.isinf(x) -def futhark_to_bits64(x): - s = struct.pack(">d", x) - return np.int64(struct.unpack(">q", s)[0]) +def fptobits_f64_i64(x): + return x.view(np.int64) -def futhark_from_bits64(x): - s = struct.pack(">q", x) - return np.float64(struct.unpack(">d", s)[0]) +def bitstofp_i64_f64(x): + return x.view(np.float64) def futhark_log32(x): @@ -902,14 +900,12 @@ return np.isinf(x) -def futhark_to_bits32(x): - s = struct.pack(">f", x) - return np.int32(struct.unpack(">l", s)[0]) +def fptobits_f32_i32(x): + return x.view(np.int32) -def futhark_from_bits32(x): - s = struct.pack(">l", x) - return np.float32(struct.unpack(">f", s)[0]) +def bitstofp_i32_f32(x): + return x.view(np.float32) def futhark_log16(x): @@ -1068,14 +1064,12 @@ return np.isinf(x) -def futhark_to_bits16(x): - s = struct.pack(">e", x) - return np.int16(struct.unpack(">H", s)[0]) +def fptobits_f16_i16(x): + return x.view(np.int16) -def futhark_from_bits16(x): - s = struct.pack(">H", np.uint16(x)) - return np.float16(struct.unpack(">e", s)[0]) +def bitstofp_i16_f16(x): + return x.view(np.float16) def futhark_lerp16(v0, v1, t): diff --git a/src-testing/Futhark/AD/DerivativesTests.hs b/src-testing/Futhark/AD/DerivativesTests.hs new file mode 100644 --- /dev/null +++ b/src-testing/Futhark/AD/DerivativesTests.hs @@ -0,0 +1,52 @@ +module Futhark.AD.DerivativesTests (tests) where + +import Data.Map qualified as M +import Data.Text qualified as T +import Futhark.AD.Derivatives +import Futhark.Analysis.PrimExp +import Futhark.IR.Syntax.Core (nameFromText) +import Futhark.Util.Pretty (prettyString) +import Test.Tasty +import Test.Tasty.HUnit + +tests :: TestTree +tests = + testGroup + "Futhark.AD.DerivativesTests" + [ testGroup "Primitive functions" $ + map primFunTest $ + filter (not . (`elem` missing_primfuns) . fst) $ + M.toList primFuns, + testGroup "BinOps" $ map binOpTest allBinOps, + testGroup "UnOps" $ map unOpTest allUnOps + ] + where + blank = ValueExp . blankPrimValue + + primFunTest (f, (ts, ret, _)) = + testCase (T.unpack f) $ + case pdBuiltin (nameFromText f) (map blank ts) of + Nothing -> assertFailure "pdBuiltin gives Nothing" + Just v -> map primExpType v @?= replicate (length ts) ret + + -- We know we have no derivatives for these... and they are not + -- coming any time soon. + missing_primfuns = + [ "gamma16", + "gamma32", + "gamma64", + "lgamma16", + "lgamma32", + "lgamma64" + ] + + binOpTest bop = + testCase (prettyString bop) $ + let t = binOpType bop + (dx, dy) = pdBinOp bop (blank t) (blank t) + in (primExpType dx, primExpType dy) @?= (t, t) + + unOpTest bop = + testCase (prettyString bop) $ + let t = unOpType bop + in primExpType (pdUnOp bop $ blank t) @?= t diff --git a/src-testing/Futhark/Analysis/AlgSimplifyTests.hs b/src-testing/Futhark/Analysis/AlgSimplifyTests.hs new file mode 100644 --- /dev/null +++ b/src-testing/Futhark/Analysis/AlgSimplifyTests.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +{-# OPTIONS_GHC -fno-warn-unused-matches #-} +{-# OPTIONS_GHC -fno-warn-unused-top-binds #-} + +module Futhark.Analysis.AlgSimplifyTests + ( tests, + ) +where + +import Control.Monad +import Data.Function ((&)) +import Data.List (subsequences) +import Data.Map qualified as M +import Data.Maybe (fromMaybe, mapMaybe) +import Futhark.Analysis.AlgSimplify hiding (add, sub) +import Futhark.Analysis.PrimExp +import Futhark.IR.Syntax.Core +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck + +tests :: TestTree +tests = + testGroup + "AlgSimplifyTests" + [ testProperty "simplify is idempotent" $ \(TestableExp e) -> simplify e == simplify (simplify e), + testProperty "simplify doesn't change exp evalutation result" $ + \(TestableExp e) -> + evalPrimExp (\_ -> Nothing) e + == evalPrimExp (\_ -> Nothing) (simplify e) + ] + +eval :: TestableExp -> Int64 +eval (TestableExp e) = evalExp e + +evalExp :: PrimExp VName -> Int64 +evalExp (ValueExp (IntValue (Int64Value i))) = i +evalExp (BinOpExp (Add Int64 OverflowUndef) e1 e2) = evalExp e1 + evalExp e2 +evalExp (BinOpExp (Sub Int64 OverflowUndef) e1 e2) = evalExp e1 - evalExp e2 +evalExp (BinOpExp (Mul Int64 OverflowUndef) e1 e2) = evalExp e1 * evalExp e2 +evalExp _ = undefined + +add :: PrimExp VName -> PrimExp VName -> PrimExp VName +add = BinOpExp (Add Int64 OverflowUndef) + +sub :: PrimExp VName -> PrimExp VName -> PrimExp VName +sub = BinOpExp (Sub Int64 OverflowUndef) + +mul :: PrimExp VName -> PrimExp VName -> PrimExp VName +mul = BinOpExp (Mul Int64 OverflowUndef) + +neg :: PrimExp VName -> PrimExp VName +neg = BinOpExp (Sub Int64 OverflowUndef) (val 0) + +l :: Int -> PrimExp VName +l i = LeafExp (VName (nameFromString $ show i) i) (IntType Int64) + +val :: Int64 -> PrimExp VName +val = ValueExp . IntValue . Int64Value + +generateExp :: Gen (PrimExp VName) +generateExp = do + n <- getSize + if n <= 1 + then val <$> arbitrary + else + oneof + [ scale (`div` 2) $ generateBinOp add, + scale (`div` 2) $ generateBinOp sub, + scale (`div` 2) $ generateBinOp mul, + scale (`div` 2) generateNeg, + val <$> arbitrary + ] + +generateBinOp :: (PrimExp VName -> PrimExp VName -> PrimExp VName) -> Gen (PrimExp VName) +generateBinOp op = do + t1 <- generateExp + op t1 <$> generateExp + +generateNeg :: Gen (PrimExp VName) +generateNeg = + do neg <$> generateExp + +newtype TestableExp = TestableExp (PrimExp VName) + deriving (Show) + +instance Arbitrary TestableExp where + arbitrary = TestableExp <$> generateExp diff --git a/src-testing/Futhark/Analysis/PrimExp/TableTests.hs b/src-testing/Futhark/Analysis/PrimExp/TableTests.hs new file mode 100644 --- /dev/null +++ b/src-testing/Futhark/Analysis/PrimExp/TableTests.hs @@ -0,0 +1,257 @@ +module Futhark.Analysis.PrimExp.TableTests (tests) where + +import Control.Monad.State.Strict +import Data.Map.Strict qualified as M +import Futhark.Analysis.PrimExp +import Futhark.Analysis.PrimExp.Table +import Futhark.IR.GPU +import Futhark.IR.GPUTests () +import Futhark.IR.MC +import Futhark.IR.MCTests () +import Test.Tasty +import Test.Tasty.HUnit + +tests :: TestTree +tests = testGroup "AnalyzePrim" [stmToPrimExpsTests] + +stmToPrimExpsTests :: TestTree +stmToPrimExpsTests = + testGroup + "stmToPrimExps" + [stmToPrimExpsTestsGPU, stmToPrimExpsTestsMC] + +stmToPrimExpsTestsGPU :: TestTree +stmToPrimExpsTestsGPU = + testGroup + "GPU" + $ do + let scope = + M.fromList + [ ("n_5142", FParamName "i64"), + ("m_5143", FParamName "i64"), + ("xss_5144", FParamName "[n_5142][m_5143]i64"), + ("segmap_group_size_5201", LetName "i64"), + ("segmap_usable_groups_5202", LetName "i64"), + ("defunc_0_map_res_5203", LetName "[n_5142]i64"), + ("defunc_0_f_res_5207", LetName "i64"), + ("i_5208", IndexName Int64), + ("acc_5209", FParamName "i64"), + ("b_5210", LetName "i64"), + ("defunc_0_f_res_5211", LetName "i64") + ] + [ testCase "BinOp" $ do + let stm = "let {defunc_0_f_res_5211 : i64} = add64(acc_5209, b_5210)" + let res = execState (stmToPrimExps scope stm) mempty + let expected = + M.fromList + [ ( "defunc_0_f_res_5211", + Just + ( BinOpExp + (Add Int64 OverflowWrap) + (LeafExp "acc_5209" (IntType Int64)) + (LeafExp "b_5210" (IntType Int64)) + ) + ) + ] + res @?= expected, + testCase "Index" $ do + let stm = "let {b_5210 : i64} = xss_5144[gtid_5204, i_5208]" + let res = execState (stmToPrimExps scope stm) mempty + let expected = M.fromList [("b_5210", Nothing)] + res @?= expected, + testCase "Loop" $ do + let stm = "let {defunc_0_f_res_5207 : i64} = loop {acc_5209 : i64} = {0i64} for i_5208:i64 < m_5143 do { {defunc_0_f_res_5211} }" + let res = execState (stmToPrimExps scope stm) mempty + let expected = + M.fromList + [ ("defunc_0_f_res_5207", Nothing), + ("i_5208", Just (LeafExp "i_5208" (IntType Int64))), + ("acc_5209", Just (LeafExp "acc_5209" (IntType Int64))) + ] + res @?= expected, + testCase "Loop body" $ do + let stm = "let {defunc_0_f_res_5207 : i64} = loop {acc_5209 : i64} = {0i64} for i_5208:i64 < m_5143 do { let {b_5210 : i64} = xss_5144[gtid_5204, i_5208] let {defunc_0_f_res_5211 : i64} = add64(acc_5209, b_5210) in {defunc_0_f_res_5211} }" + let res = execState (stmToPrimExps scope stm) mempty + let expected = + M.fromList + [ ("defunc_0_f_res_5207", Nothing), + ("i_5208", Just (LeafExp "i_5208" (IntType Int64))), + ("acc_5209", Just (LeafExp "acc_5209" (IntType Int64))), + ("b_5210", Nothing), + ( "defunc_0_f_res_5211", + Just + ( BinOpExp + (Add Int64 OverflowWrap) + (LeafExp "acc_5209" (IntType Int64)) + (LeafExp "b_5210" (IntType Int64)) + ) + ) + ] + res @?= expected, + testCase "SegMap" $ + do + let stm = + "let {defunc_0_map_res_5125 : [n_5142]i64} =\ + \ segmap(thread; ; grid=segmap_usable_groups_5124; blocksize=segmap_group_size_5123)\ + \ (gtid_5126 < n_5142) (~phys_tid_5127) : {i64} {\ + \ return {returns lifted_lambda_res_5129} \ + \}" + let res = execState (stmToPrimExps scope stm) mempty + let expected = + M.fromList + [ ("defunc_0_map_res_5125", Nothing), + ("gtid_5126", Just (LeafExp "gtid_5126" (IntType Int64))) + ] + res @?= expected, + testCase "SegMap body" $ + do + let stm :: Stm GPU + stm = + "let {defunc_0_map_res_5125 : [n_5142]i64} =\ + \ segmap(thread; ; grid=segmap_usable_groups_5124; blocksize=segmap_group_size_5123)\ + \ (gtid_5126 < n_5142) (~phys_tid_5127) : {i64} {\ + \ let {eta_p_5128 : i64} =\ + \ xs_5093[gtid_5126]\ + \ let {lifted_lambda_res_5129 : i64} =\ + \ add64(2i64, eta_p_5128)\ + \ return {returns lifted_lambda_res_5129}\ + \ }" + let res = execState (stmToPrimExps scope stm) mempty + let expected = + M.fromList + [ ("defunc_0_map_res_5125", Nothing), + ("gtid_5126", Just (LeafExp "gtid_5126" (IntType Int64))), + ("eta_p_5128", Nothing), + ( "lifted_lambda_res_5129", + Just + ( BinOpExp + (Add Int64 OverflowWrap) + (ValueExp (IntValue (Int64Value 2))) + (LeafExp "eta_p_5128" (IntType Int64)) + ) + ) + ] + res @?= expected + ] + +stmToPrimExpsTestsMC :: TestTree +stmToPrimExpsTestsMC = + testGroup + "MC" + $ do + let scope = + M.fromList + [ ("n_5142", FParamName "i64"), + ("m_5143", FParamName "i64"), + ("xss_5144", FParamName "[n_5142][5143]i64"), + ("segmap_group_size_5201", LetName "i64"), + ("segmap_usable_groups_5202", LetName "i64"), + ("defunc_0_map_res_5203", LetName "[n_5142]i64"), + ("defunc_0_f_res_5207", LetName "i64"), + ("i_5208", IndexName Int64), + ("acc_5209", FParamName "i64"), + ("b_5210", LetName "i64"), + ("defunc_0_f_res_5211", LetName "i64") + ] + [ testCase "BinOp" $ do + let stm = "let {defunc_0_f_res_5211 : i64} = add64(acc_5209, b_5210)" + let res = execState (stmToPrimExps scope stm) mempty + let expected = + M.fromList + [ ( "defunc_0_f_res_5211", + Just + ( BinOpExp + (Add Int64 OverflowWrap) + (LeafExp "acc_5209" (IntType Int64)) + (LeafExp "b_5210" (IntType Int64)) + ) + ) + ] + res @?= expected, + testCase "Index" $ do + let stm = "let {b_5210 : i64} = xss_5144[gtid_5204, i_5208]" + let res = execState (stmToPrimExps scope stm) mempty + let expected = M.fromList [("b_5210", Nothing)] + res @?= expected, + testCase "Loop" $ do + let stm = "let {defunc_0_f_res_5207 : i64} = loop {acc_5209 : i64} = {0i64} for i_5208:i64 < m_5143 do { {defunc_0_f_res_5211} }" + let res = execState (stmToPrimExps scope stm) mempty + let expected = + M.fromList + [ ("defunc_0_f_res_5207", Nothing), + ("i_5208", Just (LeafExp "i_5208" (IntType Int64))), + ("acc_5209", Just (LeafExp "acc_5209" (IntType Int64))) + ] + res @?= expected, + testCase "Loop body" $ do + let stm = + "\ + \let {defunc_0_f_res_5207 : i64} =\ + \ loop {acc_5209 : i64} = {0i64}\ + \ for i_5208:i64 < m_5143 do {\ + \ let {b_5210 : i64} =\ + \ xss_5144[gtid_5204, i_5208]\ + \ let {defunc_0_f_res_5211 : i64} =\ + \ add64(acc_5209, b_5210)\ + \ in {defunc_0_f_res_5211}\ + \ }" + let res = execState (stmToPrimExps scope stm) mempty + let expected = + M.fromList + [ ("defunc_0_f_res_5207", Nothing), + ("i_5208", Just (LeafExp "i_5208" (IntType Int64))), + ("acc_5209", Just (LeafExp "acc_5209" (IntType Int64))), + ("b_5210", Nothing), + ( "defunc_0_f_res_5211", + Just + ( BinOpExp + (Add Int64 OverflowWrap) + (LeafExp "acc_5209" (IntType Int64)) + (LeafExp "b_5210" (IntType Int64)) + ) + ) + ] + res @?= expected, + testCase "SegMap" $ do + let stm = + "let {defunc_0_map_res_5125 : [n_5142]i64} =\ + \ segmap()\ + \ (gtid_5126 < n_5142) (~flat_tid_5112) : {i64} {\ + \ return {returns lifted_lambda_res_5129}\ + \ }" + let res = execState (stmToPrimExps scope stm) mempty + let expected = + M.fromList + [ ("defunc_0_map_res_5125", Nothing), + ("gtid_5126", Just (LeafExp "gtid_5126" (IntType Int64))) + ] + res @?= expected, + testCase "SegMap body" $ do + let stm :: Stm MC + stm = + "let {defunc_0_map_res_5125 : [n_5142]i64} =\ + \ segmap()\ + \ (gtid_5126 < n_5142) (~flat_tid_5112) : {i64} {\ + \ let {eta_p_5128 : i64} =\ + \ xs_5093[gtid_5126]\ + \ let {lifted_lambda_res_5129 : i64} =\ + \ add64(2i64, eta_p_5128)\ + \ return {returns lifted_lambda_res_5129}\ + \ }" + let res = execState (stmToPrimExps scope stm) mempty + let expected = + M.fromList + [ ("defunc_0_map_res_5125", Nothing), + ("gtid_5126", Just (LeafExp "gtid_5126" (IntType Int64))), + ("eta_p_5128", Nothing), + ( "lifted_lambda_res_5129", + Just + ( BinOpExp + (Add Int64 OverflowWrap) + (ValueExp (IntValue (Int64Value 2))) + (LeafExp "eta_p_5128" (IntType Int64)) + ) + ) + ] + res @?= expected + ] diff --git a/src-testing/Futhark/BenchTests.hs b/src-testing/Futhark/BenchTests.hs new file mode 100644 --- /dev/null +++ b/src-testing/Futhark/BenchTests.hs @@ -0,0 +1,48 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Futhark.BenchTests (tests) where + +import Data.Map qualified as M +import Data.Text qualified as T +import Futhark.Bench +import Futhark.ProfileTests () +import Test.Tasty +import Test.Tasty.QuickCheck + +instance Arbitrary RunResult where + arbitrary = RunResult . getPositive <$> arbitrary + +printable :: Gen String +printable = getASCIIString <$> arbitrary + +instance Arbitrary DataResult where + arbitrary = + DataResult + <$> (T.pack <$> printable) + <*> oneof + [ Left <$> arbText, + Right + <$> ( Result + <$> arbitrary + <*> arbMap + <*> oneof [pure Nothing, Just <$> arbText] + <*> arbitrary + ) + ] + where + arbText = T.pack <$> printable + arbMap = M.fromList <$> listOf ((,) <$> arbText <*> arbitrary) + +-- XXX: we restrict this generator to single datasets to we don't have +-- to worry about duplicates. +instance Arbitrary BenchResult where + arbitrary = BenchResult <$> printable <*> (pure <$> arbitrary) + +encodeDecodeJSON :: TestTree +encodeDecodeJSON = testProperty "encoding and decoding are inverse" prop + where + prop :: BenchResult -> Bool + prop brs = decodeBenchResults (encodeBenchResults [brs]) == Right [brs] + +tests :: TestTree +tests = testGroup "Futhark.BenchTests" [encodeDecodeJSON] diff --git a/src-testing/Futhark/IR/GPUTests.hs b/src-testing/Futhark/IR/GPUTests.hs new file mode 100644 --- /dev/null +++ b/src-testing/Futhark/IR/GPUTests.hs @@ -0,0 +1,20 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Futhark.IR.GPUTests () where + +import Data.String +import Futhark.IR.GPU +import Futhark.IR.Parse +import Futhark.IR.SyntaxTests (parseString) + +-- There isn't anything to test in this module, but we define some +-- convenience instances. + +instance IsString (Stm GPU) where + fromString = parseString "Stm GPU" parseStmGPU + +instance IsString (Body GPU) where + fromString = parseString "Body GPU" parseBodyGPU + +instance IsString (Prog GPU) where + fromString = parseString "Prog GPU" parseGPU diff --git a/src-testing/Futhark/IR/MCTests.hs b/src-testing/Futhark/IR/MCTests.hs new file mode 100644 --- /dev/null +++ b/src-testing/Futhark/IR/MCTests.hs @@ -0,0 +1,20 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Futhark.IR.MCTests () where + +import Data.String +import Futhark.IR.MC +import Futhark.IR.Parse +import Futhark.IR.SyntaxTests (parseString) + +-- There isn't anything to test in this module, but we define some +-- convenience instances. + +instance IsString (Stm MC) where + fromString = parseString "Stm MC" parseStmMC + +instance IsString (Body MC) where + fromString = parseString "Body MC" parseBodyMC + +instance IsString (Prog MC) where + fromString = parseString "Prog MC" parseMC diff --git a/src-testing/Futhark/IR/Mem/IntervalTests.hs b/src-testing/Futhark/IR/Mem/IntervalTests.hs new file mode 100644 --- /dev/null +++ b/src-testing/Futhark/IR/Mem/IntervalTests.hs @@ -0,0 +1,68 @@ +module Futhark.IR.Mem.IntervalTests + ( tests, + ) +where + +import Futhark.Analysis.AlgSimplify +import Futhark.Analysis.PrimExp.Convert +import Futhark.IR.Mem.Interval +import Futhark.IR.Syntax +import Futhark.IR.Syntax.Core () +import Test.Tasty +import Test.Tasty.HUnit + +-- Actual tests. +tests :: TestTree +tests = + testGroup + "IntervalTests" + testDistributeOffset + +name :: String -> Int -> VName +name s = VName (nameFromString s) + +testDistributeOffset :: [TestTree] +testDistributeOffset = + [ testCase "Stride is (nb-b)" $ do + let n = TPrimExp $ LeafExp (name "n" 1) $ IntType Int64 + b = TPrimExp $ LeafExp (name "b" 2) $ IntType Int64 + res <- + distributeOffset + [Prod False [untyped (n * b - b :: TPrimExp Int64 VName)]] + [ Interval 0 1 (n * b - b), + Interval 0 b b, + Interval 0 b 1 + ] + res == [Interval 1 1 (n * b - b), Interval 0 b b, Interval 0 b 1] @? "Failed", + testCase "Stride is 1024r" $ do + let r = TPrimExp $ LeafExp (name "r" 1) $ IntType Int64 + res <- + distributeOffset + [Prod False [untyped (1024 :: TPrimExp Int64 VName), untyped r]] + [ Interval 0 1 (1024 * r), + Interval 0 32 32, + Interval 0 32 1 + ] + res == [Interval 1 1 (1024 * r), Interval 0 32 32, Interval 0 32 1] @? "Failed. Got " <> show res, + testCase "Stride is 32, offsets are multples of 32" $ do + let n = TPrimExp $ LeafExp (name "n" 0) $ IntType Int64 + let g1 = TPrimExp $ LeafExp (name "g" 1) $ IntType Int64 + let g2 = TPrimExp $ LeafExp (name "g" 2) $ IntType Int64 + res <- + distributeOffset + [ Prod False [untyped (1024 :: TPrimExp Int64 VName)], + Prod False [untyped (1024 :: TPrimExp Int64 VName), untyped g1], + Prod False [untyped (32 :: TPrimExp Int64 VName), untyped g2] + ] + [ Interval 0 1 (1024 * n), + Interval 0 1 32, + Interval 0 32 1 + ] + res + == [ Interval 0 1 (1024 * n), + Interval (32 + 32 * g1 + g2) 1 32, + Interval 0 32 1 + ] + @? "Failed. Got " + <> show res + ] diff --git a/src-testing/Futhark/IR/Mem/IxFun/Alg.hs b/src-testing/Futhark/IR/Mem/IxFun/Alg.hs new file mode 100644 --- /dev/null +++ b/src-testing/Futhark/IR/Mem/IxFun/Alg.hs @@ -0,0 +1,176 @@ +-- | A simple index operation representation. Every operation corresponds to a +-- constructor. +module Futhark.IR.Mem.IxFun.Alg + ( IxFun (..), + iota, + offsetIndex, + permute, + reshape, + coerce, + slice, + flatSlice, + expand, + shape, + index, + disjoint, + ) +where + +import Data.List qualified as L +import Data.Set qualified as S +import Futhark.IR.Pretty () +import Futhark.IR.Prop +import Futhark.IR.Syntax + ( DimIndex (..), + FlatDimIndex (..), + FlatSlice (..), + Slice (..), + flatSliceDims, + sliceDims, + unitSlice, + ) +import Futhark.Util.IntegralExp +import Futhark.Util.Pretty +import Prelude hiding (div, mod, span) + +type Shape num = [num] + +type Indices num = [num] + +type Permutation = [Int] + +data IxFun num + = Direct (Shape num) + | Permute (IxFun num) Permutation + | Index (IxFun num) (Slice num) + | FlatIndex (IxFun num) (FlatSlice num) + | Reshape (IxFun num) (Shape num) + | Coerce (IxFun num) (Shape num) + | OffsetIndex (IxFun num) num + | Expand num num (IxFun num) + deriving (Eq, Show) + +instance (Pretty num) => Pretty (IxFun num) where + pretty (Direct dims) = + "Direct" <> parens (commasep $ map pretty dims) + pretty (Permute fun perm) = pretty fun <> pretty perm + pretty (Index fun is) = pretty fun <> pretty is + pretty (FlatIndex fun is) = pretty fun <> pretty is + pretty (Reshape fun oldshape) = + pretty fun + <> "->reshape" + <> parens (pretty oldshape) + pretty (Coerce fun oldshape) = + pretty fun + <> "->coerce" + <> parens (pretty oldshape) + pretty (OffsetIndex fun i) = + pretty fun <> "->offset_index" <> parens (pretty i) + pretty (Expand o p fun) = + "expand(" <> pretty o <> "," <+> pretty p <> "," <+> pretty fun <> ")" + +iota :: Shape num -> IxFun num +iota = Direct + +offsetIndex :: IxFun num -> num -> IxFun num +offsetIndex = OffsetIndex + +permute :: IxFun num -> Permutation -> IxFun num +permute = Permute + +slice :: IxFun num -> Slice num -> IxFun num +slice = Index + +flatSlice :: IxFun num -> FlatSlice num -> IxFun num +flatSlice = FlatIndex + +expand :: num -> num -> IxFun num -> IxFun num +expand = Expand + +reshape :: IxFun num -> Shape num -> IxFun num +reshape = Reshape + +coerce :: IxFun num -> Shape num -> IxFun num +coerce = Reshape + +shape :: + (IntegralExp num) => + IxFun num -> + Shape num +shape (Direct dims) = + dims +shape (Permute ixfun perm) = + rearrangeShape perm $ shape ixfun +shape (Index _ how) = + sliceDims how +shape (FlatIndex ixfun how) = + flatSliceDims how <> tail (shape ixfun) +shape (Reshape _ dims) = + dims +shape (Coerce _ dims) = + dims +shape (OffsetIndex ixfun _) = + shape ixfun +shape (Expand _ _ ixfun) = + shape ixfun + +index :: + (Eq num, IntegralExp num) => + IxFun num -> + Indices num -> + num +index (Direct dims) is = + sum $ zipWith (*) is slicesizes + where + slicesizes = drop 1 $ sliceSizes dims +index (Permute fun perm) is_new = + index fun is_old + where + is_old = rearrangeShape (rearrangeInverse perm) is_new +index (Index fun (Slice js)) is = + index fun (adjust js is) + where + adjust (DimFix j : js') is' = j : adjust js' is' + adjust (DimSlice j _ s : js') (i : is') = j + i * s : adjust js' is' + adjust _ _ = [] +index (FlatIndex fun (FlatSlice offset js)) is = + index fun $ sum (offset : zipWith f is js) : drop (length js) is + where + f i (FlatDimIndex _ s) = i * s +index (Reshape fun newshape) is = + let new_indices = reshapeIndex (shape fun) newshape is + in index fun new_indices +index (Coerce fun _) is = + index fun is +index (OffsetIndex fun i) is = + case shape fun of + d : ds -> + index (Index fun (Slice (DimSlice i (d - i) 1 : map (unitSlice 0) ds))) is + [] -> error "index: OffsetIndex: underlying index function has rank zero" +index (Expand o p ixfun) is = + o + p * index ixfun is + +allPoints :: (IntegralExp num, Enum num) => [num] -> [[num]] +allPoints dims = + let total = product dims + strides = drop 1 $ L.reverse $ scanl (*) 1 $ L.reverse dims + in map (unflatInd strides) [0 .. total - 1] + where + unflatInd strides x = + fst $ + foldl + ( \(res, acc) span -> + (res ++ [acc `div` span], acc `mod` span) + ) + ([], x) + strides + +disjoint :: (IntegralExp num, Ord num, Enum num) => IxFun num -> IxFun num -> Bool +disjoint ixf1 ixf2 = + let shp1 = shape ixf1 + points1 = S.fromList $ allPoints shp1 + allIdxs1 = S.map (index ixf1) points1 + shp2 = shape ixf2 + points2 = S.fromList $ allPoints shp2 + allIdxs2 = S.map (index ixf2) points2 + in S.disjoint allIdxs1 allIdxs2 diff --git a/src-testing/Futhark/IR/Mem/IxFunTests.hs b/src-testing/Futhark/IR/Mem/IxFunTests.hs new file mode 100644 --- /dev/null +++ b/src-testing/Futhark/IR/Mem/IxFunTests.hs @@ -0,0 +1,571 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Futhark.IR.Mem.IxFunTests + ( tests, + ) +where + +import Data.Bifunctor +import Data.Function ((&)) +import Data.List qualified as L +import Data.Map qualified as M +import Data.Text qualified as T +import Futhark.Analysis.PrimExp.Convert +import Futhark.IR.Mem.IxFun.Alg qualified as IxFunAlg +import Futhark.IR.Mem.IxFunWrapper +import Futhark.IR.Mem.IxFunWrapper qualified as IxFunWrap +import Futhark.IR.Mem.LMAD qualified as IxFunLMAD +import Futhark.IR.Prop +import Futhark.IR.Syntax +import Futhark.IR.Syntax.Core () +import Futhark.Util.IntegralExp qualified as IE +import Futhark.Util.Pretty +import Test.Tasty +import Test.Tasty.HUnit +import Prelude hiding (span) +import Prelude qualified as P + +instance IE.IntegralExp Int where + quot = P.quot + rem = P.rem + div = P.div + mod = P.mod + pow = (P.^) + sgn = Just . P.signum + +allPoints :: [Int] -> [[Int]] +allPoints dims = + let total = product dims + strides = drop 1 $ L.reverse $ scanl (*) 1 $ L.reverse dims + in map (unflatInd strides) [0 .. total - 1] + where + unflatInd :: [Int] -> Int -> [Int] + unflatInd strides x = + fst $ + foldl + ( \(res, acc) span -> + (res ++ [acc `P.div` span], acc `P.mod` span) + ) + ([], x) + strides + +compareIxFuns :: Maybe (IxFunLMAD.LMAD Int) -> IxFunAlg.IxFun Int -> Assertion +compareIxFuns (Just ixfunLMAD) ixfunAlg = + let lmadShape = IxFunLMAD.shape ixfunLMAD + algShape = IxFunAlg.shape ixfunAlg + points = allPoints lmadShape + resLMAD = map (IxFunLMAD.index ixfunLMAD) points + resAlg = map (IxFunAlg.index ixfunAlg) points + errorMessage = + T.unpack . docText $ + "lmad ixfun: " + <> pretty ixfunLMAD + "alg ixfun: " + <> pretty ixfunAlg + "lmad shape: " + <> pretty lmadShape + "alg shape: " + <> pretty algShape + "lmad points length: " + <> pretty (length resLMAD) + "alg points length: " + <> pretty (length resAlg) + "lmad points: " + <> pretty resLMAD + "alg points: " + <> pretty resAlg + in (lmadShape == algShape && resLMAD == resAlg) @? errorMessage +compareIxFuns Nothing ixfunAlg = + assertFailure $ + unlines + [ "lmad ixfun: Nothing", + "alg ixfun: " <> prettyString ixfunAlg + ] + +compareOps :: IxFunWrap.IxFun Int -> Assertion +compareOps (ixfunLMAD, ixfunAlg) = compareIxFuns ixfunLMAD ixfunAlg + +compareOpsFailure :: IxFunWrap.IxFun Int -> Assertion +compareOpsFailure (Nothing, _) = pure () +compareOpsFailure (Just ixfunLMAD, ixfunAlg) = + assertFailure . T.unpack . docText $ + "Not supposed to be representable as LMAD." + "lmad ixfun: " + <> pretty ixfunLMAD + "alg ixfun: " + <> pretty ixfunAlg + +-- XXX: Clean this up. +n :: Int +n = 19 + +slice3 :: Slice Int +slice3 = + Slice + [ DimSlice 2 (n `P.div` 3) 3, + DimFix (n `P.div` 2), + DimSlice 1 (n `P.div` 2) 2 + ] + +-- Actual tests. +tests :: TestTree +tests = + testGroup "IxFunTests" $ + concat + [ test_iota, + test_slice_iota, + test_slice_reshape_iota1, + test_permute_slice_iota, + test_reshape_iota, + test_reshape_permute_iota, + test_slice_reshape_iota2, + test_reshape_slice_iota3, + test_flatten_strided, + test_complex1, + test_complex2, + test_expand1, + test_expand2, + test_expand3, + test_expand4, + test_flatSlice_iota, + test_slice_flatSlice_iota, + test_flatSlice_flatSlice_iota, + test_flatSlice_slice_iota, + test_flatSlice_transpose_slice_iota + -- TODO: Without z3, these tests fail. Ideally, our internal simplifier + -- should be able to handle them: + -- + -- test_disjoint3 + ] + +singleton :: TestTree -> [TestTree] +singleton = (: []) + +test_iota :: [TestTree] +test_iota = + singleton . testCase "iota" . compareOps $ + iota [n] + +test_slice_iota :: [TestTree] +test_slice_iota = + singleton . testCase "slice . iota" . compareOps $ + slice (iota [n, n, n]) slice3 + +test_slice_reshape_iota1 :: [TestTree] +test_slice_reshape_iota1 = + singleton . testCase "slice . reshape . iota 1" . compareOps $ + slice (reshape (iota [n, n, n]) [n `P.div` 2, n `P.div` 3, 1]) slice3 + +test_permute_slice_iota :: [TestTree] +test_permute_slice_iota = + singleton . testCase "permute . slice . iota" . compareOps $ + permute (slice (iota [n, n, n]) slice3) [1, 0] + +test_reshape_iota :: [TestTree] +test_reshape_iota = + -- This tests a pattern that occurs with ScalarSpace. + singleton . testCase "reshape . zeroslice . iota" . compareOps $ + let s = Slice [DimSlice 0 n 0, DimSlice 0 n 1] + in reshape (slice (iota [n, n]) s) [1, n, 1, n] + +test_reshape_permute_iota :: [TestTree] +test_reshape_permute_iota = + -- negative reshape test + singleton . testCase "reshape . permute . iota" . compareOpsFailure $ + let newdims = [n * n, n] + in reshape (permute (iota [n, n, n]) [1, 2, 0]) newdims + +test_slice_reshape_iota2 :: [TestTree] +test_slice_reshape_iota2 = + singleton . testCase "slice . reshape . iota 2" . compareOps $ + let newdims = [n * n, n] + slc = + Slice + [ DimFix (n `P.div` 2), + DimSlice 0 n 1 + ] + in slice (reshape (iota [n, n, n, n]) newdims) slc + +test_reshape_slice_iota3 :: [TestTree] +test_reshape_slice_iota3 = + -- negative reshape test + singleton . testCase "reshape . slice . iota 3" . compareOpsFailure $ + let newdims = [n * n, n] + slc = + Slice + [ DimFix (n `P.div` 2), + DimSlice 0 n 1, + DimSlice 0 (n `P.div` 2) 1, + DimSlice 0 n 1 + ] + in reshape (slice (iota [n, n, n, n]) slc) newdims + +-- Tests flattening something that is strided - this can occur after +-- memory expansion. +test_flatten_strided :: [TestTree] +test_flatten_strided = + singleton . testCase "reshape . fix . iota 3d" . compareOps $ + let slc = Slice [DimSlice 0 n 1, DimSlice 0 2 1, DimFix 1] + in reshape (slice (iota [n, 2, n * n]) slc) [2 * 10] + +test_complex1 :: [TestTree] +test_complex1 = + singleton . testCase "permute . slice . permute . slice . iota 1" . compareOps $ + let slice33 = + Slice + [ DimSlice (n - 1) (n `P.div` 3) (-1), + DimSlice (n - 1) n (-1), + DimSlice (n - 1) n (-1), + DimSlice 0 n 1 + ] + ixfun = permute (slice (iota [n, n, n, n, n]) slice33) [3, 1, 2, 0] + m = n `P.div` 3 + slice1 = + Slice + [ DimSlice 0 n 1, + DimSlice (n - 1) n (-1), + DimSlice (n - 1) n (-1), + DimSlice 1 (m - 2) (-1) + ] + ixfun' = slice ixfun slice1 + in ixfun' + +test_complex2 :: [TestTree] +test_complex2 = + singleton . testCase "permute . slice . permute . slice . iota 2" . compareOps $ + let slc2 = + Slice + [ DimFix (n `P.div` 2), + DimSlice (n - 1) (n `P.div` 3) (-1), + DimSlice (n - 1) n (-1), + DimSlice (n - 1) n (-1), + DimSlice 0 n 1 + ] + ixfun = permute (slice (iota [n, n, n, n, n]) slc2) [3, 1, 2, 0] + m = n `P.div` 3 + slice1 = + Slice + [ DimSlice 0 n 1, + DimSlice (n - 1) n (-1), + DimSlice (n - 1) n (-1), + DimSlice 1 (m - 2) (-1) + ] + ixfun' = slice ixfun slice1 + in ixfun' + +-- Imitates a case from memory expansion. +test_expand1 :: [TestTree] +test_expand1 = + [ testCase "expand . iota1d" . compareOps $ + expand t nt (iota [n]) + ] + where + t = 3 + nt = 7 + +-- Imitates another case from memory expansion. +test_expand2 :: [TestTree] +test_expand2 = + [ testCase "expand . iota2d" . compareOps $ + expand t nt (iota [n, n]) + ] + where + t = 3 + nt = 7 + +test_expand3 :: [TestTree] +test_expand3 = + [ testCase "expand . permute . iota2d" . compareOps $ + expand t nt (permute (iota [n, n `div` 2]) [1, 0]) + ] + where + t = 3 + nt = 7 + +test_expand4 :: [TestTree] +test_expand4 = + [ testCase "expand . slice . iota1d" . compareOps $ + expand t nt (slice (iota [n]) (Slice [DimSlice (n `div` 2) (n `div` 2) 1])) + ] + where + t = 3 + nt = 7 + +test_flatSlice_iota :: [TestTree] +test_flatSlice_iota = + singleton . testCase "flatSlice . iota" . compareOps $ + flatSlice (iota [n * n * n * n]) $ + FlatSlice 2 [FlatDimIndex (n * 2) 4, FlatDimIndex n 3, FlatDimIndex 1 2] + +test_slice_flatSlice_iota :: [TestTree] +test_slice_flatSlice_iota = + singleton . testCase "slice . flatSlice . iota " . compareOps $ + slice (flatSlice (iota [2 + n * n * n]) flat_slice) $ + Slice [DimFix 2, DimSlice 0 n 1, DimFix 0] + where + flat_slice = FlatSlice 2 [FlatDimIndex (n * n) 1, FlatDimIndex n 1, FlatDimIndex 1 1] + +test_flatSlice_flatSlice_iota :: [TestTree] +test_flatSlice_flatSlice_iota = + singleton . testCase "flatSlice . flatSlice . iota " . compareOps $ + flatSlice (flatSlice (iota [10 * 10]) flat_slice_1) flat_slice_2 + where + flat_slice_1 = FlatSlice 17 [FlatDimIndex 3 27, FlatDimIndex 3 10, FlatDimIndex 3 1] + flat_slice_2 = FlatSlice 2 [FlatDimIndex 2 (-2)] + +test_flatSlice_slice_iota :: [TestTree] +test_flatSlice_slice_iota = + singleton . testCase "flatSlice . slice . iota " . compareOps $ + flatSlice (slice (iota [210, 100]) $ Slice [DimSlice 10 100 2, DimFix 10]) flat_slice_1 + where + flat_slice_1 = FlatSlice 17 [FlatDimIndex 3 27, FlatDimIndex 3 10, FlatDimIndex 3 1] + +test_flatSlice_transpose_slice_iota :: [TestTree] +test_flatSlice_transpose_slice_iota = + singleton . testCase "flatSlice . transpose . slice . iota " . compareOps $ + flatSlice (permute (slice (iota [20, 20]) $ Slice [DimSlice 1 5 2, DimSlice 0 5 2]) [1, 0]) flat_slice_1 + where + flat_slice_1 = FlatSlice 1 [FlatDimIndex 2 2] + +-- test_disjoint2 :: [TestTree] +-- test_disjoint2 = +-- let add_nw64 = (+) + +-- mul_nw64 = (*) + +-- sub64 = (-) + +-- vname s i = VName (nameFromString s) i +-- in [ let gtid_8472 = TPrimExp $ LeafExp (vname "gtid" 8472) $ IntType Int64 + +-- gtid_8473 = TPrimExp $ LeafExp (vname "gtid" 8473) $ IntType Int64 + +-- gtid_8474 = TPrimExp $ LeafExp (vname "gtid" 8474) $ IntType Int64 + +-- num_blocks_8284 = TPrimExp $ LeafExp (vname "num_blocks" 8284) $ IntType Int64 + +-- nonnegs = freeIn [gtid_8472, gtid_8473, gtid_8474, num_blocks_8284] + +-- j_m_i_8287 :: TPrimExp Int64 VName +-- j_m_i_8287 = num_blocks_8284 - 1 + +-- lessthans :: [(VName, PrimExp VName)] +-- lessthans = +-- [ (head $ namesToList $ freeIn gtid_8472, untyped j_m_i_8287), +-- (head $ namesToList $ freeIn gtid_8473, untyped j_m_i_8287), +-- (head $ namesToList $ freeIn gtid_8474, untyped (16 :: TPrimExp Int64 VName)) +-- ] + +-- lm1 :: IxFunLMAD.LMAD (TPrimExp Int64 VName) +-- lm1 = +-- IxFunLMAD.LMAD +-- 256 +-- [ IxFunLMAD.LMADDim 256 0 (sub64 (num_blocks_8284) 1) 0 , +-- IxFunLMAD.LMADDim 1 0 16 1 , +-- IxFunLMAD.LMADDim 16 0 16 2 +-- ] +-- lm2 :: IxFunLMAD.LMAD (TPrimExp Int64 VName) +-- lm2 = +-- IxFunLMAD.LMAD +-- (add_nw64 (add_nw64 (add_nw64 (add_nw64 (mul_nw64 (256) (num_blocks_8284)) (256)) (mul_nw64 (gtid_8472) (mul_nw64 (256) (num_blocks_8284)))) (mul_nw64 (gtid_8473) (256))) (mul_nw64 (gtid_8474) (16))) +-- [IxFunLMAD.LMADDim 1 0 16 0 ] +-- in testCase (pretty lm1 <> " and " <> pretty lm2) $ IxFunLMAD.disjoint2 lessthans nonnegs lm1 lm2 @? "Failed" +-- ] + +-- test_lessThanish :: [TestTree] +-- test_lessThanish = +-- [testCase "0 < 1" $ IxFunLMAD.lessThanish mempty mempty 0 1 @? "Failed"] + +-- test_lessThanOrEqualish :: [TestTree] +-- test_lessThanOrEqualish = +-- [testCase "1 <= 1" $ IxFunLMAD.lessThanOrEqualish mempty mempty 1 1 @? "Failed"] + +_test_disjoint3 :: [TestTree] +_test_disjoint3 = + let foo s = VName (nameFromString s) + add_nw64 = (+) + add64 = (+) + mul_nw64 = (*) + mul64 = (*) + sub64 = (-) + sdiv64 = IE.div + sub_nw64 = (-) + disjointTester asserts lessthans lm1 lm2 = + let nonnegs = map (`LeafExp` IntType Int64) $ namesToList $ freeIn lm1 <> freeIn lm2 + + scmap = + M.fromList $ + map (\x -> (x, Prim $ IntType Int64)) $ + namesToList $ + freeIn lm1 <> freeIn lm2 <> freeIn lessthans <> freeIn asserts + in IxFunLMAD.disjoint3 scmap asserts lessthans nonnegs lm1 lm2 + in [ testCase "lm1 and lm2" $ + let lessthans = + [ ( i_12214, + sdiv64 (sub64 n_blab 1) block_size_12121 + ), + (gtid_12553, add64 1 i_12214) + ] + & map (\(v, p) -> (head $ namesToList $ freeIn v, untyped p)) + + asserts = + [ untyped ((2 * block_size_12121 :: TPrimExp Int64 VName) .<. n_blab :: TPrimExp Bool VName), + untyped ((3 :: TPrimExp Int64 VName) .<. n_blab :: TPrimExp Bool VName) + ] + + block_size_12121 = TPrimExp $ LeafExp (foo "block_size" 12121) $ IntType Int64 + i_12214 = TPrimExp $ LeafExp (foo "i" 12214) $ IntType Int64 + n_blab = TPrimExp $ LeafExp (foo "n" 1337) $ IntType Int64 + gtid_12553 = TPrimExp $ LeafExp (foo "gtid" 12553) $ IntType Int64 + + lm1 = + IxFunLMAD.LMAD + (add_nw64 (mul64 block_size_12121 i_12214) (mul_nw64 (add_nw64 gtid_12553 1) (sub64 (mul64 block_size_12121 n_blab) block_size_12121))) + [ IxFunLMAD.LMADDim (add_nw64 (mul_nw64 block_size_12121 n_blab) (mul_nw64 (-1) block_size_12121)) (sub_nw64 (sub_nw64 (add64 1 i_12214) gtid_12553) 1), + IxFunLMAD.LMADDim 1 (block_size_12121 + 1) + ] + + lm2 = + IxFunLMAD.LMAD + (block_size_12121 * i_12214) + [ IxFunLMAD.LMADDim (add_nw64 (mul_nw64 block_size_12121 n_blab) (mul_nw64 (-1) block_size_12121)) gtid_12553, + IxFunLMAD.LMADDim 1 (1 + block_size_12121) + ] + + lm_w = + IxFunLMAD.LMAD + (add_nw64 (add64 (add64 1 n_blab) (mul64 block_size_12121 i_12214)) (mul_nw64 gtid_12553 (sub64 (mul64 block_size_12121 n_blab) block_size_12121))) + [ IxFunLMAD.LMADDim n_blab block_size_12121, + IxFunLMAD.LMADDim 1 block_size_12121 + ] + + lm_blocks = + IxFunLMAD.LMAD + (block_size_12121 * i_12214 + n_blab + 1) + [ IxFunLMAD.LMADDim (add_nw64 (mul_nw64 block_size_12121 n_blab) (mul_nw64 (-1) block_size_12121)) (i_12214 + 1), + IxFunLMAD.LMADDim n_blab block_size_12121, + IxFunLMAD.LMADDim 1 block_size_12121 + ] + + lm_lower_per = + IxFunLMAD.LMAD + (block_size_12121 * i_12214) + [ IxFunLMAD.LMADDim (add_nw64 (mul_nw64 block_size_12121 n_blab) (mul_nw64 (-1) block_size_12121)) (i_12214 + 1), + IxFunLMAD.LMADDim 1 (block_size_12121 + 1) + ] + + res1 = disjointTester asserts lessthans lm1 lm_w + res2 = disjointTester asserts lessthans lm2 lm_w + res3 = disjointTester asserts lessthans lm_lower_per lm_blocks + in res1 && res2 && res3 @? "Failed", + testCase "nw second half" $ do + let lessthans = + [ ( i_12214, + sdiv64 (sub64 n_blab 1) block_size_12121 + ), + (gtid_12553, add64 1 i_12214) + ] + & map (\(v, p) -> (head $ namesToList $ freeIn v, untyped p)) + + asserts = + [ untyped ((2 * block_size_12121 :: TPrimExp Int64 VName) .<. n_blab :: TPrimExp Bool VName), + untyped ((3 :: TPrimExp Int64 VName) .<. n_blab :: TPrimExp Bool VName) + ] + + block_size_12121 = TPrimExp $ LeafExp (foo "block_size" 12121) $ IntType Int64 + i_12214 = TPrimExp $ LeafExp (foo "i" 12214) $ IntType Int64 + n_blab = TPrimExp $ LeafExp (foo "n" 1337) $ IntType Int64 + gtid_12553 = TPrimExp $ LeafExp (foo "gtid" 12553) $ IntType Int64 + + lm1 = + IxFunLMAD.LMAD + (add_nw64 (add64 n_blab (sub64 (sub64 (mul64 n_blab (add64 1 (mul64 block_size_12121 (add64 1 i_12214)))) block_size_12121) 1)) (mul_nw64 (add_nw64 gtid_12553 1) (sub64 (mul64 block_size_12121 n_blab) block_size_12121))) + [ IxFunLMAD.LMADDim (add_nw64 (mul_nw64 block_size_12121 n_blab) (mul_nw64 (-1) block_size_12121)) (sub_nw64 (sub_nw64 (sub64 (sub64 (sdiv64 (sub64 n_blab 1) block_size_12121) i_12214) 1) gtid_12553) 1), + IxFunLMAD.LMADDim n_blab block_size_12121 + ] + + lm2 = + IxFunLMAD.LMAD + (add_nw64 (sub64 (sub64 (mul64 n_blab (add64 1 (mul64 block_size_12121 (add64 1 i_12214)))) block_size_12121) 1) (mul_nw64 (add_nw64 gtid_12553 1) (sub64 (mul64 block_size_12121 n_blab) block_size_12121))) + [ IxFunLMAD.LMADDim (add_nw64 (mul_nw64 block_size_12121 n_blab) (mul_nw64 (-1) block_size_12121)) (sub_nw64 (sub_nw64 (sub64 (sub64 (sdiv64 (sub64 n_blab 1) block_size_12121) i_12214) 1) gtid_12553) 1), + IxFunLMAD.LMADDim 1 (1 + block_size_12121) + ] + + lm3 = + IxFunLMAD.LMAD + (add64 n_blab (sub64 (sub64 (mul64 n_blab (add64 1 (mul64 block_size_12121 (add64 1 i_12214)))) block_size_12121) 1)) + [ IxFunLMAD.LMADDim (add_nw64 (mul_nw64 block_size_12121 n_blab) (mul_nw64 (-1) block_size_12121)) gtid_12553, + IxFunLMAD.LMADDim n_blab block_size_12121 + ] + + lm4 = + IxFunLMAD.LMAD + (sub64 (sub64 (mul64 n_blab (add64 1 (mul64 block_size_12121 (add64 1 i_12214)))) block_size_12121) 1) + [ IxFunLMAD.LMADDim + (add_nw64 (mul_nw64 block_size_12121 n_blab) (mul_nw64 (-1) block_size_12121)) + gtid_12553, + IxFunLMAD.LMADDim + 1 + (1 + block_size_12121) + ] + + lm_w = + IxFunLMAD.LMAD + (add_nw64 (sub64 (mul64 n_blab (add64 2 (mul64 block_size_12121 (add64 1 i_12214)))) block_size_12121) (mul_nw64 gtid_12553 (sub64 (mul64 block_size_12121 n_blab) block_size_12121))) + [ IxFunLMAD.LMADDim n_blab block_size_12121, + IxFunLMAD.LMADDim 1 block_size_12121 + ] + + res1 = disjointTester asserts lessthans lm1 lm_w + res2 = disjointTester asserts lessthans lm2 lm_w + res3 = disjointTester asserts lessthans lm3 lm_w + res4 = disjointTester asserts lessthans lm4 lm_w + in res1 && res2 && res3 && res4 @? "Failed " <> show [res1, res2, res3, res4], + testCase "lud long" $ + let lessthans = + [ bimap + (head . namesToList . freeIn) + untyped + (step, num_blocks - 1 :: TPrimExp Int64 VName) + ] + + step = TPrimExp $ LeafExp (foo "step" 1337) $ IntType Int64 + + num_blocks = TPrimExp $ LeafExp (foo "n" 1338) $ IntType Int64 + + lm1 = + IxFunLMAD.LMAD + (1024 * num_blocks * (1 + step) + 1024 * step) + [ IxFunLMAD.LMADDim (1024 * num_blocks) (num_blocks - step - 1), + IxFunLMAD.LMADDim 32 32, + IxFunLMAD.LMADDim 1 32 + ] + + lm_w1 = + IxFunLMAD.LMAD + (1024 * num_blocks * step + 1024 * step) + [ IxFunLMAD.LMADDim 32 32, + IxFunLMAD.LMADDim 1 32 + ] + + lm_w2 = + IxFunLMAD.LMAD + ((1 + step) * 1024 * num_blocks + (1 + step) * 1024) + [ IxFunLMAD.LMADDim (1024 * num_blocks) (num_blocks - step - 1), + IxFunLMAD.LMADDim 1024 (num_blocks - step - 1), + IxFunLMAD.LMADDim 1024 1, + IxFunLMAD.LMADDim 32 1, + IxFunLMAD.LMADDim 128 8, + IxFunLMAD.LMADDim 4 8, + IxFunLMAD.LMADDim 32 4, + IxFunLMAD.LMADDim 1 4 + ] + + asserts = + [ untyped ((1 :: TPrimExp Int64 VName) .<. num_blocks :: TPrimExp Bool VName) + ] + + res1 = disjointTester asserts lessthans lm1 lm_w1 + res2 = disjointTester asserts lessthans lm1 lm_w2 + in res1 && res2 @? "Failed" + ] diff --git a/src-testing/Futhark/IR/Mem/IxFunWrapper.hs b/src-testing/Futhark/IR/Mem/IxFunWrapper.hs new file mode 100644 --- /dev/null +++ b/src-testing/Futhark/IR/Mem/IxFunWrapper.hs @@ -0,0 +1,72 @@ +-- | Perform index function operations in both algebraic and LMAD +-- representations. +module Futhark.IR.Mem.IxFunWrapper + ( IxFun, + iota, + permute, + reshape, + coerce, + slice, + flatSlice, + expand, + ) +where + +import Control.Monad (join) +import Futhark.IR.Mem.IxFun.Alg qualified as IA +import Futhark.IR.Mem.LMAD qualified as I +import Futhark.IR.Syntax (FlatSlice, Slice) +import Futhark.Util.IntegralExp + +type Shape num = [num] + +type Permutation = [Int] + +type IxFun num = (Maybe (I.LMAD num), IA.IxFun num) + +iota :: + (IntegralExp num) => + Shape num -> + IxFun num +iota x = (Just $ I.iota 0 x, IA.iota x) + +permute :: + IxFun num -> + Permutation -> + IxFun num +permute (l, a) x = (I.permute <$> l <*> pure x, IA.permute a x) + +reshape :: + (Eq num, IntegralExp num) => + IxFun num -> + Shape num -> + IxFun num +reshape (l, a) x = (join (I.reshape <$> l <*> pure x), IA.reshape a x) + +coerce :: + IxFun num -> + Shape num -> + IxFun num +coerce (l, a) x = (I.coerce <$> l <*> pure x, IA.coerce a x) + +slice :: + (Eq num, IntegralExp num) => + IxFun num -> + Slice num -> + IxFun num +slice (l, a) x = (I.slice <$> l <*> pure x, IA.slice a x) + +flatSlice :: + (IntegralExp num) => + IxFun num -> + FlatSlice num -> + IxFun num +flatSlice (l, a) x = (I.flatSlice <$> l <*> pure x, IA.flatSlice a x) + +expand :: + (IntegralExp num) => + num -> + num -> + IxFun num -> + IxFun num +expand o p (lf, af) = (Just . I.expand o p =<< lf, IA.expand o p af) diff --git a/src-testing/Futhark/IR/Prop/RearrangeTests.hs b/src-testing/Futhark/IR/Prop/RearrangeTests.hs new file mode 100644 --- /dev/null +++ b/src-testing/Futhark/IR/Prop/RearrangeTests.hs @@ -0,0 +1,54 @@ +module Futhark.IR.Prop.RearrangeTests (tests) where + +import Control.Applicative +import Futhark.IR.Prop.Rearrange +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck +import Prelude + +tests :: TestTree +tests = + testGroup "RearrangeTests" $ + isMapTransposeTests + ++ [isMapTransposeProp] + +isMapTransposeTests :: [TestTree] +isMapTransposeTests = + [ testCase (unwords ["isMapTranspose", show perm, "==", show dres]) $ + isMapTranspose perm @?= dres + | (perm, dres) <- + [ ([0, 1, 4, 5, 2, 3], Just (2, 2, 2)), + ([1, 0, 4, 5, 2, 3], Nothing), + ([1, 0], Just (0, 1, 1)), + ([0, 2, 1], Just (1, 1, 1)), + ([0, 1, 2], Nothing), + ([1, 0, 2], Nothing) + ] + ] + +newtype Permutation = Permutation [Int] + deriving (Eq, Ord, Show) + +instance Arbitrary Permutation where + arbitrary = do + Positive n <- arbitrary + Permutation <$> shuffle [0 .. n - 1] + +isMapTransposeProp :: TestTree +isMapTransposeProp = testProperty "isMapTranspose corresponds to a map of transpose" prop + where + prop :: Permutation -> Bool + prop (Permutation perm) = + case isMapTranspose perm of + Nothing -> True + Just (r1, r2, r3) -> + and + [ r1 >= 0, + r2 > 0, + r3 > 0, + r1 + r2 + r3 == length perm, + let (mapped, notmapped) = splitAt r1 perm + (pretrans, posttrans) = splitAt r2 notmapped + in mapped ++ posttrans ++ pretrans == [0 .. length perm - 1] + ] diff --git a/src-testing/Futhark/IR/Prop/ReshapeTests.hs b/src-testing/Futhark/IR/Prop/ReshapeTests.hs new file mode 100644 --- /dev/null +++ b/src-testing/Futhark/IR/Prop/ReshapeTests.hs @@ -0,0 +1,236 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Futhark.IR.Prop.ReshapeTests + ( tests, + ) +where + +import Data.List qualified as L +import Futhark.IR.Prop.Constants +import Futhark.IR.Prop.Reshape +import Futhark.IR.Syntax +import Futhark.IR.SyntaxTests () +import Test.Tasty +import Test.Tasty.HUnit + +intShape :: [Int] -> Shape +intShape = Shape . map (intConst Int32 . toInteger) + +reshapeOuterTests :: [TestTree] +reshapeOuterTests = + [ testCase (unwords ["reshapeOuter", show sc, show n, show shape, "==", show sc_res]) $ + reshapeOuter (intShape sc) n (intShape shape) @?= intShape sc_res + | (sc, n, shape, sc_res) <- + [ ([1], 1, [4, 3], [1, 3]), + ([1], 2, [4, 3], [1]), + ([2, 2], 1, [4, 3], [2, 2, 3]), + ([2, 2], 2, [4, 3], [2, 2]) + ] + ] + +reshapeInnerTests :: [TestTree] +reshapeInnerTests = + [ testCase (unwords ["reshapeInner", show sc, show n, show shape, "==", show sc_res]) $ + reshapeInner (intShape sc) n (intShape shape) @?= intShape sc_res + | (sc, n, shape, sc_res) <- + [ ([1], 1, [4, 3], [4, 1]), + ([1], 0, [4, 3], [1]), + ([2, 2], 1, [4, 3], [4, 2, 2]), + ([2, 2], 0, [4, 3], [2, 2]) + ] + ] + +dimFlatten :: Int -> Int -> d -> DimSplice d +dimFlatten i k w = DimSplice i k (Shape [w]) + +dimUnflatten :: Int -> [d] -> DimSplice d +dimUnflatten i ws = DimSplice i 1 (Shape ws) + +dimCoerce :: Int -> d -> DimSplice d +dimCoerce i w = DimSplice i 1 (Shape [w]) + +dimSplice :: Int -> Int -> [d] -> DimSplice d +dimSplice i n s = DimSplice i n $ Shape s + +flipReshapeRearrangeTests :: [TestTree] +flipReshapeRearrangeTests = + [ testCase + ( unwords + [ "flipReshapeRearrange", + show v0_shape, + show v1_shape, + show perm + ] + ) + $ flipReshapeRearrange v0_shape v1_shape perm @?= res + | (v0_shape :: [String], v1_shape, perm, res) <- + [ ( ["A", "B", "C"], + ["A", "BC"], + [1, 0], + Just [1, 2, 0] + ), + ( ["A", "B", "C", "D"], + ["A", "BCD"], + [1, 0], + Just [1, 2, 3, 0] + ), + ( ["A"], + ["B", "C"], + [1, 0], + Nothing + ), + ( ["A", "B", "C"], + ["AB", "C"], + [1, 0], + Just [2, 0, 1] + ), + ( ["A", "B", "C", "D"], + ["ABC", "D"], + [1, 0], + Just [3, 0, 1, 2] + ) + ] + ] + +flipRearrangeReshapeTests :: [TestTree] +flipRearrangeReshapeTests = + [ testCase + ( unwords + [ "flipRearrangeReshape", + show perm, + prettyStringOneLine newshape + ] + ) + $ flipRearrangeReshape perm newshape @?= res + | (perm, newshape :: NewShape String, res) <- + [ ( [1, 0], + NewShape + [dimUnflatten 1 ["B", "C"]] + (Shape ["A", "B", "C"]), + Just + ( NewShape + [dimUnflatten 0 ["B", "C"]] + (Shape ["B", "C", "A"]), + [2, 0, 1] + ) + ), + ( [1, 0], + NewShape + [dimFlatten 0 2 "AB"] + (Shape ["AB"]), + Nothing + ) + ] + ] + +simplifyTests :: TestTree +simplifyTests = + testGroup + "simplifyNewShape" + [ testCase "Inverse flatten and unflatten - simple case" $ + lhs + ["A", "B"] + [dimFlatten 0 2 "AB", dimUnflatten 0 ["A", "B"]] + @?= Just [], + testCase "Non-inverse flatten and unflatten - simple case" $ + lhs + ["A", "B"] + [dimFlatten 0 2 "AB", dimUnflatten 0 ["C", "D"]] + @?= Just [dimSplice 0 2 ["C", "D"]], + testCase "Inverse flatten and unflatten - separated by coercion" $ + lhs + ["A", "B"] + [ dimFlatten 0 2 "AB", + dimCoerce 0 "CD", + dimUnflatten 0 ["C", "D"] + ] + @?= Just [dimSplice 0 2 ["C", "D"]], + testCase "Two unflattens - simple case" $ + lhs + ["ABC"] + [dimUnflatten 0 ["A", "BC"], dimUnflatten 1 ["B", "C"]] + @?= Just [dimUnflatten 0 ["A", "B", "C"]], + testCase "Two unflattens with unchanged prefix" $ + lhs + ["A", "B", "C", "D", "E"] + [ DimSplice 3 2 $ Shape ["DE"], + DimSplice 2 2 $ Shape ["CDE"] + ] + @?= Just [dimFlatten 2 3 "CDE"], + testCase "Identity coerce" $ + lhs + ["A", "B", "C"] + [dimCoerce 1 "B", dimCoerce 2 "C"] + @?= Just [], + testCase "Identity coerce (multiple dimensions)" $ + lhs + ["A", "B", "C"] + [DimSplice 1 2 (Shape ["B", "C"])] + @?= Just [], + testCase "Identity coerce (with non-identity stuff afterwards)" $ + lhs + ["B", "CD"] + [dimCoerce 0 "B", dimUnflatten 1 ["C", "D"]] + @?= Just [dimUnflatten 1 ["C", "D"]], + testCase "Get rid of a coerce before an unflatten" $ + lhs + ["CD"] + [dimCoerce 0 "AB", dimUnflatten 0 ["A", "B"]] + @?= Just [dimUnflatten 0 ["A", "B"]], + testCase "Get rid of a coerce after a flatten" $ + lhs + ["A", "B", "C"] + [dimFlatten 0 2 "ABC", dimCoerce 0 "K"] + @?= Just [dimFlatten 0 2 "K"], + testCase "Flatten and unflatten (invariant suffix)" $ + lhs + ["A", "B", "C"] + [dimFlatten 0 3 "ABC", dimUnflatten 0 ["D", "E", "C"]] + @?= Just [dimSplice 0 2 ["D", "E"]], + testCase "Flatten and unflatten (invariant prefix)" $ + lhs + ["A", "B", "C"] + [dimFlatten 0 3 "ABC", dimUnflatten 0 ["A", "D", "E"]] + @?= Just [dimSplice 1 2 ["D", "E"]], + testCase "Invariant part of splice" $ + lhs + ["A", "B", "C", "D"] + [DimSplice 1 3 $ Shape ["BC", "D"]] + @?= Just [DimSplice 1 2 $ Shape ["BC"]], + testCase "Necessary coercion" $ + lhs + ["A", "B"] + [dimCoerce 0 "C", dimCoerce 1 "D"] + @?= Nothing, + testCase "Another necessary coercion" $ + lhs + ["A", "B", "C"] + [dimCoerce 0 "A'", dimCoerce 1 "A'", dimCoerce 2 "A'"] + @?= Nothing, + testCase "Long with redundancies" $ + lhs + ["A", "B", "C", "D"] + [ DimSplice 1 3 $ Shape ["BC", "D"], + dimCoerce 1 "BC", + dimCoerce 2 "D", + dimFlatten 1 2 "BCD", + dimFlatten 0 2 "ABCD" + ] + @?= Just [dimFlatten 0 4 "ABCD"] + ] + where + lhs orig_shape ss = + let res_shape :: ShapeBase String = + L.foldl' applySplice (Shape orig_shape) ss + in dimSplices + <$> simplifyNewShape (Shape orig_shape) (NewShape ss res_shape) + +tests :: TestTree +tests = + testGroup "ReshapeTests" . mconcat $ + [ reshapeOuterTests, + reshapeInnerTests, + flipReshapeRearrangeTests, + flipRearrangeReshapeTests, + [simplifyTests] + ] diff --git a/src-testing/Futhark/IR/PropTests.hs b/src-testing/Futhark/IR/PropTests.hs new file mode 100644 --- /dev/null +++ b/src-testing/Futhark/IR/PropTests.hs @@ -0,0 +1,18 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Futhark.IR.PropTests + ( tests, + ) +where + +import Futhark.IR.Prop.RearrangeTests qualified +import Futhark.IR.Prop.ReshapeTests qualified +import Test.Tasty + +tests :: TestTree +tests = + testGroup + "PropTests" + [ Futhark.IR.Prop.ReshapeTests.tests, + Futhark.IR.Prop.RearrangeTests.tests + ] diff --git a/src-testing/Futhark/IR/Syntax/CoreTests.hs b/src-testing/Futhark/IR/Syntax/CoreTests.hs new file mode 100644 --- /dev/null +++ b/src-testing/Futhark/IR/Syntax/CoreTests.hs @@ -0,0 +1,100 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Futhark.IR.Syntax.CoreTests (tests) where + +import Control.Applicative +import Data.Loc (Loc (..), Pos (..)) +import Futhark.IR.Pretty (prettyString) +import Futhark.IR.Syntax.Core +import Language.Futhark.CoreTests () +import Language.Futhark.PrimitiveTests () +import Test.QuickCheck +import Test.Tasty +import Test.Tasty.HUnit +import Prelude + +instance Arbitrary NoUniqueness where + arbitrary = pure NoUniqueness + +instance (Arbitrary shape, Arbitrary u) => Arbitrary (TypeBase shape u) where + arbitrary = + oneof + [ Prim <$> arbitrary, + Array <$> arbitrary <*> arbitrary <*> arbitrary + ] + +instance Arbitrary Ident where + arbitrary = Ident <$> arbitrary <*> arbitrary + +instance Arbitrary Rank where + arbitrary = Rank <$> elements [1 .. 9] + +instance Arbitrary Shape where + arbitrary = Shape . map intconst <$> listOf1 (elements [1 .. 9]) + where + intconst = Constant . IntValue . Int32Value + +subShapeTests :: [TestTree] +subShapeTests = + [ shape [free 1, free 2] `isSubShapeOf` shape [free 1, free 2], + shape [free 1, free 3] `isNotSubShapeOf` shape [free 1, free 2], + shape [free 1] `isNotSubShapeOf` shape [free 1, free 2], + shape [free 1, free 2] `isSubShapeOf` shape [free 1, Ext 3], + shape [Ext 1, Ext 2] `isNotSubShapeOf` shape [Ext 1, Ext 1], + shape [Ext 1, Ext 1] `isSubShapeOf` shape [Ext 1, Ext 2] + ] + where + shape :: [ExtSize] -> ExtShape + shape = Shape + + free :: Int -> ExtSize + free = Free . Constant . IntValue . Int32Value . fromIntegral + + isSubShapeOf shape1 shape2 = + subShapeTest shape1 shape2 True + isNotSubShapeOf shape1 shape2 = + subShapeTest shape1 shape2 False + + subShapeTest :: ExtShape -> ExtShape -> Bool -> TestTree + subShapeTest shape1 shape2 expected = + testCase + ( "subshapeOf " + ++ prettyString shape1 + ++ " " + ++ prettyString shape2 + ++ " == " + ++ show expected + ) + $ shape1 `subShapeOf` shape2 @?= expected + +provenanceTests :: [TestTree] +provenanceTests = + [ testGroup + "<>" + [ testCase "simple" $ + (Provenance [] line1 <> Provenance [] line0) @?= Provenance [] lines01, + testCase "mempty left" $ + (Provenance [] mempty <> Provenance [] line0) @?= Provenance [] line0, + testCase "mempty right" $ + (Provenance [] line1 <> Provenance [] mempty) @?= Provenance [] line1 + ], + testGroup + "stackProvenance" + [ testCase "encloses" $ + (Provenance [] line0 `stackProvenance` Provenance [] line0_sub) + @?= Provenance [] line0_sub + ] + ] + where + line0 = Loc (Pos "" 0 1 0) (Pos "" 0 10 10) + line0_sub = Loc (Pos "" 0 2 1) (Pos "" 0 9 9) + line1 = Loc (Pos "" 1 1 0) (Pos "" 1 10 20) + lines01 = Loc (Pos "" 0 1 0) (Pos "" 1 10 20) + +tests :: TestTree +tests = + testGroup + "Internal CoreTests" + [ testGroup "subShape" subShapeTests, + testGroup "Provenance" provenanceTests + ] diff --git a/src-testing/Futhark/IR/SyntaxTests.hs b/src-testing/Futhark/IR/SyntaxTests.hs new file mode 100644 --- /dev/null +++ b/src-testing/Futhark/IR/SyntaxTests.hs @@ -0,0 +1,33 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Futhark.IR.SyntaxTests (parseString) where + +import Data.String +import Data.Text qualified as T +import Futhark.IR.Parse +import Futhark.IR.Syntax + +-- There isn't anything to test in this module, but we define some +-- convenience instances. + +parseString :: String -> (FilePath -> T.Text -> Either T.Text a) -> String -> a +parseString desc p = + either (error . T.unpack) id . p ("IsString " <> desc) . T.pack + +instance IsString Type where + fromString = parseString "Type" parseType + +instance IsString DeclExtType where + fromString = parseString "DeclExtType" parseDeclExtType + +instance IsString DeclType where + fromString = parseString "DeclType" parseDeclType + +instance IsString VName where + fromString = parseString "VName" parseVName + +instance IsString SubExp where + fromString = parseString "SubExp" parseSubExp + +instance IsString SubExpRes where + fromString = parseString "SubExpRes" parseSubExpRes diff --git a/src-testing/Futhark/Internalise/TypesValuesTests.hs b/src-testing/Futhark/Internalise/TypesValuesTests.hs new file mode 100644 --- /dev/null +++ b/src-testing/Futhark/Internalise/TypesValuesTests.hs @@ -0,0 +1,170 @@ +module Futhark.Internalise.TypesValuesTests (tests) where + +import Control.Monad.Free (Free (..)) +import Data.Map qualified as M +import Data.String (fromString) +import Futhark.IR.Syntax hiding (Free) +import Futhark.IR.SyntaxTests () +import Futhark.Internalise.TypesValues +import Language.Futhark.SyntaxTests () +import Test.Tasty +import Test.Tasty.HUnit + +internaliseTypeTests :: TestTree +internaliseTypeTests = + testGroup + "internaliseType" + [ mkTest + "[0]()" + [Free [Pure "[0i64]unit"]], + mkTest + "{a: [t_7447][n_7448](f32, f32), b: i64, c: i64}" + [Free [Pure "[t_7447][n_7448]f32", Pure "[t_7447][n_7448]f32"], Pure "i64", Pure "i64"], + mkTest + "([0]i32, {a: f32, b: f32, c: f32, d: [0]((f32, f32), (f32, f32))})" + [ Free [Pure "[0i64]i32"], + Pure "f32", + Pure "f32", + Pure "f32", + Free [Pure "[0i64]f32", Pure "[0i64]f32", Pure "[0i64]f32", Pure "[0i64]f32"] + ], + mkTest + "[0]([1]i32, f32)" + [Free [Free [Pure "[0i64][1i64]i32"], Pure "[0i64]f32"]] + ] + where + mkTest x y = + testCase (prettyString x) $ internaliseType x @?= y + +sumTypeTests :: TestTree +sumTypeTests = + testGroup + "internaliseConstructors" + [ testCase "Dedup of primitives" $ + internaliseConstructors + ( M.fromList + [ ("foo", [Pure "i64"]), + ("bar", [Pure "i64"]) + ] + ) + @?= ( [Pure "i64"], + [ ("bar", [0]), + ("foo", [0]) + ] + ), + testCase "Dedup of array" $ + internaliseConstructors + ( M.fromList + [ ("foo", [Pure "[?0]i64"]), + ("bar", [Pure "[?0]i64"]) + ] + ) + @?= ( [Pure "[?0]i64", Pure "[?0]i64"], + [ ("bar", [0]), + ("foo", [1]) + ] + ), + testCase + "Dedup of array of tuple" + $ internaliseConstructors + ( M.fromList + [ ("foo", [Free [Pure "[?0]i64", Pure "[?0]i64"]]), + ("bar", [Pure "[?0]i64"]) + ] + ) + @?= ( [Pure "[?0]i64", Free [Pure "[?0]i64", Pure "[?0]i64"]], + [ ("bar", [0]), + ("foo", [1, 2]) + ] + ) + ] + +-- Be aware that some of these tests simply reinforce current +-- behaviour - it may be that we want to restrict aliasing even +-- further in the future; these tests would have to be updated in such +-- cases. +inferAliasesTests :: TestTree +inferAliasesTests = + testGroup + "inferAliases" + [ mkTest + [Free [Pure "[0i64]i32"]] + [Free [Pure "[?0]i32"]] + [[("[?0]i32", RetAls [0] [0])]], + mkTest + [Free [Pure "[0i64]i32", Pure "[0i64]i32"]] + [Free [Pure "[0i64]i32", Pure "[0i64]i32"]] + [ [ ("[0i64]i32", RetAls [0] [0]), + ("[0i64]i32", RetAls [1] [1]) + ] + ], + -- Basically zip. + mkTest + [Free [Pure "[n_0]i32"], Free [Pure "[n_0]i32"]] + [Free [Pure "[n_0]i32", Pure "[n_0]i32"]] + [ [ ("[n_0]i32", RetAls [] [0]), + ("[n_0]i32", RetAls [] [1]) + ] + ], + mkTest + [Free [Pure "[0i64]i32"], Free [Pure "[0i64]i32", Pure "[0i64]i32"]] + [Free [Pure "[?0]i32", Pure "[?0]i32"]] + [ [ ("[?0]i32", RetAls [1] [0]), + ("[?0]i32", RetAls [2] [1]) + ] + ], + mkTest + [Free [Pure "[0i64][1i64]i32", Pure "[0i64][1i64]i32"]] + [Free [Pure "[?0]i32", Pure "[?0]i32"]] + [ [ ("[?0]i32", RetAls [0] [0]), + ("[?0]i32", RetAls [1] [1]) + ] + ], + -- Basically unzip. + mkTest + [Free [Pure "[n_0][n_1]i32", Pure "[n_0][n_1]i32"]] + [Free [Pure "[?0]i32"], Free [Pure "[?0]i32"]] + [ [("[?0]i32", RetAls [] [0, 1])], + [("[?0]i32", RetAls [] [0, 1])] + ], + mkTest + [ Free [Pure "*[n_0][n_1]i32"], + Free [Pure "[n_2]i64"], + Free [Pure "[n_3]i64"] + ] + [Free [Pure "*[n_0][n_1]i32"]] + [[("*[n_0][n_1]i32", RetAls [] [])]], + mkTest + [Free [Pure "[n_0]i32", Free [Pure "[n_0][n_1]i32"]]] + [Free [Pure "[n_0]i32"]] + [[("[n_0]i32", RetAls [1] [0])]], + mkTest + [] + [ Free [Pure "[n_0]i32", Free [Pure "[n_0][n_1]i32"]], + Free [Pure "[n_0]i32"] + ] + [ [("[n_0]i32", RetAls [] [0]), ("[n_0][n_1]i32", RetAls [] [1])], + [("[n_0]i32", RetAls [] [1, 2])] + ], + mkTest + [Free [Pure "[n_0]i32"]] + [Free [Pure "[m_1][m_1]i32"]] + [ [("[m_1][m_1]i32", RetAls [0] [0])] + ] + ] + where + mkTest all_param_ts all_res_ts expected = + testCase (show all_param_ts <> " " <> show all_res_ts) $ + inferAliases + (map (fmap fromString) all_param_ts) + (map (fmap fromString) all_res_ts) + @?= expected + +tests :: TestTree +tests = + testGroup + "Futhark.Internalise.TypesValuesTests" + [ internaliseTypeTests, + sumTypeTests, + inferAliasesTests + ] diff --git a/src-testing/Futhark/Optimise/ArrayLayout/AnalyseTests.hs b/src-testing/Futhark/Optimise/ArrayLayout/AnalyseTests.hs new file mode 100644 --- /dev/null +++ b/src-testing/Futhark/Optimise/ArrayLayout/AnalyseTests.hs @@ -0,0 +1,241 @@ +module Futhark.Optimise.ArrayLayout.AnalyseTests (tests) where + +import Data.Map.Strict qualified as M +import Futhark.Analysis.AccessPattern +import Futhark.IR.GPU +import Futhark.IR.GPUTests () +import Futhark.IR.SyntaxTests () +import Test.Tasty +import Test.Tasty.HUnit + +tests :: TestTree +tests = testGroup "Analyse" [analyseStmTests] + +analyseStmTests :: TestTree +analyseStmTests = + testGroup + "analyseStm" + [analyseIndexTests, analyseDimAccessesTests] + +analyseIndexTests :: TestTree +analyseIndexTests = + testGroup + "analyseIndex" + $ do + let arr_name = "xss_5144" + -- ============================= TestCase0 ============================= + -- Most simple case where we want to manifest an array, hence, we record + -- the Index in the IndexTable. + let testCase0 = testCase "2D manifest" $ do + let ctx = + mempty + { parents = + [ SegOpName (SegmentedMap "defunc_0_map_res_5204"), + LoopBodyName "defunc_0_f_res_5208" + ], + assignments = + M.fromList + [ ("gtid_5205", VariableInfo mempty 0 mempty ThreadID), + ("i_5209", VariableInfo mempty 1 mempty LoopVar) + ] + } + let patternNames = ["b_5211"] + let dimFixes = + [ DimFix (Var "gtid_5205"), + DimFix (Var "i_5209") + ] + let indexTable = + M.fromList + [ ( SegmentedMap "defunc_0_map_res_5204", + M.fromList + [ ( (arr_name, [], [0 .. 1]), + M.fromList + [ ( "b_5211", + [ DimAccess (M.fromList [("gtid_5205", Dependency 0 ThreadID)]) (Just "gtid_5205"), + DimAccess (M.fromList [("i_5209", Dependency 1 LoopVar)]) (Just "i_5209") + ] + ) + ] + ) + ] + ) + ] + let (_, indexTable') = analyseIndex ctx patternNames arr_name dimFixes + indexTable' @?= indexTable + + -- ============================= TestCase2 ============================= + -- We don't want to manifest an array with only one dimension, so we don't + -- record anything in the IndexTable. + let testCase1 = testCase "1D manifest" $ do + let ctx = + mempty + { parents = + [ SegOpName (SegmentedMap "defunc_0_map_res_5204"), + LoopBodyName "defunc_0_f_res_5208" + ] + } + let patternNames = ["b_5211"] + let dimFixes = [DimFix "i_5209"] + + let (_, indexTable') = analyseIndex ctx patternNames arr_name dimFixes + indexTable' @?= mempty + + -- ============================= TestCase1 ============================= + -- We don't want to record anything to the IndexTable when the array is + -- not accessed inside a SegMap + -- TODO: Create a similar one for MC with loops + let testCase2 = testCase "Not inside SegMap" $ do + let ctx = mempty + let patternNames = ["b_5211"] + let dimFixes = + [ DimFix "gtid_5205", + DimFix "i_5209" + ] + let (_, indexTable') = analyseIndex ctx patternNames arr_name dimFixes + indexTable' @?= mempty + + -- ============================= TestCase3 ============================= + -- If an array is allocated inside a loop or SegMap, we want to record that + -- information in the ArrayName of the IndexTable. + let testCase3 = testCase "Allocated inside SegMap" $ do + let parents' = + [ SegOpName (SegmentedMap "defunc_0_map_res_5204"), + LoopBodyName "defunc_0_f_res_5208" + ] + let ctx = + mempty + { parents = parents', + assignments = + M.fromList + [ ("gtid_5205", VariableInfo mempty 0 mempty ThreadID), + ("i_5209", VariableInfo mempty 1 mempty LoopVar), + (arr_name, VariableInfo mempty 0 parents' Variable) + ] + } + let patternNames = ["b_5211"] + let dimFixes = + [ DimFix "gtid_5205", + DimFix "i_5209" + ] + let indexTable = + M.fromList + [ ( SegmentedMap "defunc_0_map_res_5204", + M.fromList + [ ( (arr_name, parents', [0 .. 1]), + M.fromList + [ ( "b_5211", + [ DimAccess (M.fromList [("gtid_5205", Dependency 0 ThreadID)]) (Just "gtid_5205"), + DimAccess (M.fromList [("i_5209", Dependency 1 LoopVar)]) (Just "i_5209") + ] + ) + ] + ) + ] + ) + ] + let (_, indexTable') = analyseIndex ctx patternNames arr_name dimFixes + indexTable' @?= indexTable + + -- ============================= TestCase4 ============================= + -- If the vars in the index are temporaries, we want to reduce them to + -- to the thread IDs and or loop counters they are functions of. + let testCase4 = testCase "Reduce dependencies" $ do + let ctx = + mempty + { parents = + [ SegOpName (SegmentedMap "defunc_0_map_res_5204"), + LoopBodyName "defunc_0_f_res_5208" + ], + assignments = + M.fromList + [ ("gtid_5205", VariableInfo mempty 0 mempty ThreadID), + ("i_5209", VariableInfo mempty 1 mempty LoopVar), + ("tmp0_5210", VariableInfo (namesFromList ["gtid_5205"]) 2 mempty Variable), + ("tmp1_5211", VariableInfo (namesFromList ["i_5209"]) 3 mempty Variable), + ("k_5212", VariableInfo mempty 1 mempty ConstType) + ] + } + let patternNames = ["b_5211"] + let dimFixes = + [ DimFix "tmp0_5210", + DimFix "tmp1_5211", + DimFix "k_5212" + ] + let indexTable = + M.fromList + [ ( SegmentedMap "defunc_0_map_res_5204", + M.fromList + [ ( (arr_name, [], [0 .. 2]), + M.fromList + [ ( "b_5211", + [ DimAccess (M.fromList [("gtid_5205", Dependency 0 ThreadID)]) (Just "tmp0_5210"), + DimAccess (M.fromList [("i_5209", Dependency 1 LoopVar)]) (Just "tmp1_5211"), + DimAccess mempty (Just "k_5212") + ] + ) + ] + ) + ] + ) + ] + let (_, indexTable') = analyseIndex ctx patternNames arr_name dimFixes + indexTable' @?= indexTable + + [testCase0, testCase1, testCase2, testCase3, testCase4] + +analyseDimAccessesTests :: TestTree +analyseDimAccessesTests = testGroup + "analyseDimAccesses" + $ do + let testCase0 = testCase "Fold" $ do + let indexTable = + M.fromList + [ ( SegmentedMap "defunc_0_map_res_5204", + M.fromList + [ ( ("xss_5144", [], [0, 1]), + M.fromList + [ ( "b_5211", + [ DimAccess (M.fromList [("gtid_5205", Dependency 0 ThreadID)]) (Just "gtid_5205"), + DimAccess (M.fromList [("i_5209", Dependency 1 LoopVar)]) (Just "i_5209") + ] + ) + ] + ) + ] + ) + ] + let indexTable' = (analyseDimAccesses @GPU) prog0 + indexTable' @?= indexTable + + [testCase0] + where + prog0 :: Prog GPU + prog0 = + "\ + \entry(\"main\",\ + \ {xss: [][]i64},\ + \ {[]i64})\ + \ entry_main (n_5142 : i64,\ + \ m_5143 : i64,\ + \ xss_5144 : [n_5142][m_5143]i64)\ + \ : {[n_5142]i64#([2], [0])} = {\ + \ let {segmap_group_size_5202 : i64} =\ + \ get_size(segmap_group_size_5190, thread_block_size)\ + \ let {segmap_usable_groups_5203 : i64} =\ + \ sdiv_up64(n_5142, segmap_group_size_5202)\ + \ let {defunc_0_map_res_5204 : [n_5142]i64} =\ + \ segmap(thread; ; grid=segmap_usable_groups_5203; blocksize=segmap_group_size_5202)\ + \ (gtid_5205 < n_5142) (~phys_tid_5206) : {i64} {\ + \ let {defunc_0_f_res_5208 : i64} =\ + \ loop {acc_5210 : i64} = {0i64}\ + \ for i_5209:i64 < m_5143 do {\ + \ let {b_5211 : i64} =\ + \ xss_5144[gtid_5205, i_5209]\ + \ let {defunc_0_f_res_5212 : i64} =\ + \ add64(acc_5210, b_5211)\ + \ in {defunc_0_f_res_5212}\ + \ }\ + \ return {returns defunc_0_f_res_5208}\ + \ }\ + \ in {defunc_0_map_res_5204}\ + \}" diff --git a/src-testing/Futhark/Optimise/ArrayLayout/LayoutTests.hs b/src-testing/Futhark/Optimise/ArrayLayout/LayoutTests.hs new file mode 100644 --- /dev/null +++ b/src-testing/Futhark/Optimise/ArrayLayout/LayoutTests.hs @@ -0,0 +1,163 @@ +module Futhark.Optimise.ArrayLayout.LayoutTests (tests) where + +import Data.Map.Strict qualified as M +import Futhark.Analysis.AccessPattern +import Futhark.Analysis.PrimExp +import Futhark.FreshNames +import Futhark.IR.GPU (GPU) +import Futhark.IR.GPUTests () +import Futhark.Optimise.ArrayLayout.Layout +import Language.Futhark.Core +import Test.Tasty +import Test.Tasty.HUnit + +tests :: TestTree +tests = + testGroup + "Layout" + [commonPermutationEliminatorsTests] + +commonPermutationEliminatorsTests :: TestTree +commonPermutationEliminatorsTests = + testGroup + "commonPermutationEliminators" + [permutationTests, nestTests, dimAccessTests, constIndexElimTests] + +permutationTests :: TestTree +permutationTests = + testGroup "Permutations" $ + do + -- This isn't the way to test this, in reality we should provide realistic + -- access patterns that might result in the given permutations. + -- Luckily we only use the original access for one check atm. + [ testCase (unwords [show perm, "->", show res]) $ + commonPermutationEliminators perm [] @?= res + | (perm, res) <- + [ ([0], True), + ([1, 0], False), + ([0, 1], True), + ([0, 0], True), + ([1, 1], True), + ([1, 2, 0], False), + ([2, 0, 1], False), + ([0, 1, 2], True), + ([1, 0, 2], True), + ([2, 1, 0], True), + ([2, 2, 0], True), + ([2, 1, 1], True), + ([1, 0, 1], True), + ([0, 0, 0], True), + ([0, 1, 2, 3, 4], True), + ([1, 0, 2, 3, 4], True), + ([2, 3, 0, 1, 4], True), + ([3, 4, 2, 0, 1], True), + ([2, 3, 4, 0, 1], False), + ([1, 2, 3, 4, 0], False), + ([3, 4, 0, 1, 2], False) + ] + ] + +nestTests :: TestTree +nestTests = testGroup "Nests" $ + do + let names = generateNames 2 + [ testCase (unwords [args, "->", show res]) $ + commonPermutationEliminators [1, 0] nest @?= res + | (args, nest, res) <- + [ ("[]", [], False), + ("[CondBodyName]", [CondBodyName] <*> names, False), + ("[SegOpName]", [SegOpName . SegmentedMap] <*> names, True), + ("[LoopBodyName]", [LoopBodyName] <*> names, False), + ("[SegOpName, CondBodyName]", [SegOpName . SegmentedMap, CondBodyName] <*> names, True), + ("[CondBodyName, LoopBodyName]", [CondBodyName, LoopBodyName] <*> names, False) + ] + ] + +dimAccessTests :: TestTree +dimAccessTests = testGroup "DimAccesses" [] -- TODO: Write tests for the part of commonPermutationEliminators that checks the complexity of the DimAccesses. + +constIndexElimTests :: TestTree +constIndexElimTests = + testGroup + "constIndexElimTests" + [ testCase "gpu eliminates indexes with constant in any dim" $ do + let primExpTable = + M.fromList + [ ("gtid_4", Just (LeafExp "n_4" (IntType Int64))), + ("i_5", Just (LeafExp "n_4" (IntType Int64))) + ] + layoutTableFromIndexTable primExpTable accessTableGPU @?= mempty, + testCase "gpu ignores when not last" $ do + let primExpTable = + M.fromList + [ ("gtid_4", Just (LeafExp "gtid_4" (IntType Int64))), + ("gtid_5", Just (LeafExp "gtid_5" (IntType Int64))), + ("i_6", Just (LeafExp "i_6" (IntType Int64))) + ] + layoutTableFromIndexTable primExpTable accessTableGPUrev + @?= M.fromList + [ ( SegmentedMap "mapres_1", + M.fromList + [ ( ("a_2", [], [0, 1, 2, 3]), + M.fromList [("A_3", [2, 3, 0, 1])] + ) + ] + ) + ] + ] + where + accessTableGPU :: IndexTable GPU + accessTableGPU = + singleAccess + [ singleParAccess 0 "gtid_4", + DimAccess mempty Nothing, + singleSeqAccess 1 "i_5" + ] + + accessTableGPUrev :: IndexTable GPU + accessTableGPUrev = + singleAccess + [ singleParAccess 1 "gtid_4", + singleParAccess 2 "gtid_5", + singleSeqAccess 0 "i_5", + singleSeqAccess 2 "gtid_4" + ] + +singleAccess :: [DimAccess rep] -> IndexTable rep +singleAccess dims = + M.fromList + [ ( sgOp, + M.fromList + [ ( ("A_2", [], [0, 1, 2, 3]), + M.fromList + [ ( "a_3", + dims + ) + ] + ) + ] + ) + ] + where + sgOp = SegmentedMap {vnameFromSegOp = "mapres_1"} + +singleParAccess :: Int -> VName -> DimAccess rep +singleParAccess level name = + DimAccess + (M.singleton name $ Dependency level ThreadID) + (Just name) + +singleSeqAccess :: Int -> VName -> DimAccess rep +singleSeqAccess level name = + DimAccess + (M.singleton name $ Dependency level LoopVar) + (Just name) + +generateNames :: Int -> [VName] +generateNames count = do + let (name, source) = newName blankNameSource "i_0" + fst $ foldl f ([name], source) [1 .. count - 1] + where + f (names, source) _ = do + let (name, source') = newName source (last names) + (names ++ [name], source') diff --git a/src-testing/Futhark/Optimise/ArrayLayoutTests.hs b/src-testing/Futhark/Optimise/ArrayLayoutTests.hs new file mode 100644 --- /dev/null +++ b/src-testing/Futhark/Optimise/ArrayLayoutTests.hs @@ -0,0 +1,15 @@ +module Futhark.Optimise.ArrayLayoutTests (tests) where + +import Futhark.Analysis.PrimExp.TableTests qualified +import Futhark.Optimise.ArrayLayout.AnalyseTests qualified +import Futhark.Optimise.ArrayLayout.LayoutTests qualified +import Test.Tasty + +tests :: TestTree +tests = + testGroup + "OptimizeArrayLayoutTests" + [ Futhark.Optimise.ArrayLayout.AnalyseTests.tests, + Futhark.Optimise.ArrayLayout.LayoutTests.tests, + Futhark.Analysis.PrimExp.TableTests.tests + ] diff --git a/src-testing/Futhark/Optimise/MemoryBlockMerging/GreedyColoringTests.hs b/src-testing/Futhark/Optimise/MemoryBlockMerging/GreedyColoringTests.hs new file mode 100644 --- /dev/null +++ b/src-testing/Futhark/Optimise/MemoryBlockMerging/GreedyColoringTests.hs @@ -0,0 +1,80 @@ +module Futhark.Optimise.MemoryBlockMerging.GreedyColoringTests + ( tests, + ) +where + +import Control.Arrow ((***)) +import Data.Function ((&)) +import Data.Map qualified as M +import Data.Set qualified as S +import Futhark.Optimise.MemoryBlockMerging.GreedyColoring qualified as GreedyColoring +import Test.Tasty +import Test.Tasty.HUnit + +tests :: TestTree +tests = + testGroup + "GreedyColoringTests" + [psumTest, allIntersect, emptyGraph, noIntersections, differentSpaces] + +psumTest :: TestTree +psumTest = + testCase "psumTest" + $ assertEqual + "Color simple 1-2-3 using two colors" + ( [(0, "shared"), (1, "shared")] :: [(Int, String)], + [(1 :: Int, 0), (2, 1), (3, 0)] + ) + $ (M.toList *** M.toList) + $ GreedyColoring.colorGraph + (M.fromList [(1, "shared"), (2, "shared"), (3, "shared")]) + $ S.fromList [(1, 2), (2, 3)] + +allIntersect :: TestTree +allIntersect = + testCase "allIntersect" + $ assertEqual + "Color a graph where all values intersect" + ( [(0, "shared"), (1, "shared"), (2, "shared")] :: [(Int, String)], + [(1 :: Int, 2), (2, 1), (3, 0)] + ) + $ (M.toList *** M.toList) + $ GreedyColoring.colorGraph + (M.fromList [(1, "shared"), (2, "shared"), (3, "shared")]) + $ S.fromList [(1, 2), (2, 3), (1, 3)] + +emptyGraph :: TestTree +emptyGraph = + testCase "emptyGraph" + $ assertEqual + "Color an empty graph" + ([] :: [(Int, Char)], [] :: [(Int, Int)]) + $ (M.toList *** M.toList) + $ GreedyColoring.colorGraph M.empty + $ S.fromList [] + +noIntersections :: TestTree +noIntersections = + GreedyColoring.colorGraph + (M.fromList [(1, "shared"), (2, "shared"), (3, "shared")]) + (S.fromList []) + & M.toList *** M.toList + & assertEqual + "Color nodes with no intersections" + ( [(0, "shared")] :: [(Int, String)], + [(1, 0), (2, 0), (3, 0)] :: [(Int, Int)] + ) + & testCase "noIntersections" + +differentSpaces :: TestTree +differentSpaces = + GreedyColoring.colorGraph + (M.fromList [(1, "a"), (2, "b"), (3, "c")]) + (S.fromList []) + & M.toList *** M.toList + & assertEqual + "Color nodes with no intersections but in different spaces" + ( [(0, "c"), (1, "b"), (2, "a")] :: [(Int, String)], + [(1, 2), (2, 1), (3, 0)] :: [(Int, Int)] + ) + & testCase "differentSpaces" diff --git a/src-testing/Futhark/Pkg/SolveTests.hs b/src-testing/Futhark/Pkg/SolveTests.hs new file mode 100644 --- /dev/null +++ b/src-testing/Futhark/Pkg/SolveTests.hs @@ -0,0 +1,142 @@ +module Futhark.Pkg.SolveTests (tests) where + +import Data.Map qualified as M +import Data.Monoid +import Data.Text qualified as T +import Futhark.Pkg.Solve +import Futhark.Pkg.Types +import Test.Tasty +import Test.Tasty.HUnit +import Prelude + +semverE :: T.Text -> SemVer +semverE s = case parseVersion s of + Left err -> + error $ + T.unpack s + <> " is not a valid version number: " + <> errorBundlePretty err + Right x -> x + +-- | A world of packages and interdependencies for testing the solver +-- without touching the outside world. +testEnv :: PkgRevDepInfo +testEnv = + M.fromList $ + concatMap + frob + [ ( "athas", + [ ( "foo", + [ ("0.1.0", []), + ("0.2.0", [("athas/bar", "1.0.0")]), + ("0.3.0", []) + ] + ), + ("foo@v2", [("2.0.0", [("athas/quux", "0.1.0")])]), + ("bar", [("1.0.0", [])]), + ("baz", [("0.1.0", [("athas/foo", "0.3.0")])]), + ( "quux", + [ ( "0.1.0", + [ ("athas/foo", "0.2.0"), + ("athas/baz", "0.1.0") + ] + ) + ] + ), + ( "quux_perm", + [ ( "0.1.0", + [ ("athas/baz", "0.1.0"), + ("athas/foo", "0.2.0") + ] + ) + ] + ), + ("x_bar", [("1.0.0", [("athas/bar", "1.0.0")])]), + ("x_foo", [("1.0.0", [("athas/foo", "0.3.0")])]), + ( "tricky", + [ ( "1.0.0", + [ ("athas/foo", "0.2.0"), + ("athas/x_foo", "1.0.0") + ] + ) + ] + ) + ] + ), + -- Some mutually recursive packages. + ( "nasty", + [ ("foo", [("1.0.0", [("nasty/bar", "1.0.0")])]), + ("bar", [("1.0.0", [("nasty/foo", "1.0.0")])]) + ] + ) + ] + where + frob (user, repos) = do + (repo, repo_revs) <- repos + (rev, deps) <- repo_revs + let rev' = semverE rev + onDep (dp, dv) = (dp, (semverE dv, Nothing)) + deps' = PkgRevDeps $ M.fromList $ map onDep deps + pure ((user <> "/" <> repo, rev'), deps') + +newtype SolverRes = SolverRes BuildList + deriving (Eq) + +instance Show SolverRes where + show (SolverRes bl) = T.unpack $ prettyBuildList bl + +solverTest :: PkgPath -> T.Text -> Either T.Text [(PkgPath, T.Text)] -> TestTree +solverTest p v expected = + testCase (T.unpack $ p <> "-" <> prettySemVer v') $ + fmap SolverRes (solveDepsPure testEnv target) + @?= expected' + where + target = PkgRevDeps $ M.singleton p (v', Nothing) + v' = semverE v + expected' = SolverRes . BuildList . M.fromList . map onRes <$> expected + onRes (dp, dv) = (dp, semverE dv) + +tests :: TestTree +tests = + testGroup + "SolveTests" + [ solverTest "athas/foo" "0.1.0" $ + Right [("athas/foo", "0.1.0")], + solverTest "athas/foo" "0.2.0" $ + Right + [ ("athas/foo", "0.2.0"), + ("athas/bar", "1.0.0") + ], + solverTest "athas/quux" "0.1.0" $ + Right + [ ("athas/quux", "0.1.0"), + ("athas/foo", "0.3.0"), + ("athas/baz", "0.1.0") + ], + solverTest "athas/quux_perm" "0.1.0" $ + Right + [ ("athas/quux_perm", "0.1.0"), + ("athas/foo", "0.3.0"), + ("athas/baz", "0.1.0") + ], + solverTest "athas/foo@v2" "2.0.0" $ + Right + [ ("athas/foo@v2", "2.0.0"), + ("athas/quux", "0.1.0"), + ("athas/foo", "0.3.0"), + ("athas/baz", "0.1.0") + ], + solverTest "athas/foo@v3" "3.0.0" $ + Left "Unknown package/version: athas/foo@v3-3.0.0", + solverTest "nasty/foo" "1.0.0" $ + Right + [ ("nasty/foo", "1.0.0"), + ("nasty/bar", "1.0.0") + ], + solverTest "athas/tricky" "1.0.0" $ + Right + [ ("athas/tricky", "1.0.0"), + ("athas/foo", "0.3.0"), + ("athas/x_foo", "1.0.0") + ] + ] diff --git a/src-testing/Futhark/ProfileTests.hs b/src-testing/Futhark/ProfileTests.hs new file mode 100644 --- /dev/null +++ b/src-testing/Futhark/ProfileTests.hs @@ -0,0 +1,23 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Futhark.ProfileTests () where + +import Data.Map qualified as M +import Data.Text qualified as T +import Futhark.Profile +import Test.Tasty.QuickCheck + +printable :: Gen String +printable = getPrintableString <$> arbitrary + +arbText :: Gen T.Text +arbText = T.pack <$> printable + +instance Arbitrary ProfilingEvent where + arbitrary = ProfilingEvent <$> arbText <*> arbitrary <*> arbText <*> arbitrary + +instance Arbitrary ProfilingReport where + arbitrary = + ProfilingReport + <$> arbitrary + <*> (M.fromList <$> listOf ((,) <$> arbText <*> arbitrary)) diff --git a/src-testing/Language/Futhark/CoreTests.hs b/src-testing/Language/Futhark/CoreTests.hs new file mode 100644 --- /dev/null +++ b/src-testing/Language/Futhark/CoreTests.hs @@ -0,0 +1,13 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Language.Futhark.CoreTests () where + +import Language.Futhark.Core +import Language.Futhark.PrimitiveTests () +import Test.QuickCheck + +instance Arbitrary Name where + arbitrary = nameFromString <$> listOf1 (elements ['a' .. 'z']) + +instance Arbitrary VName where + arbitrary = VName <$> arbitrary <*> arbitrary diff --git a/src-testing/Language/Futhark/ParserBenchmarks.hs b/src-testing/Language/Futhark/ParserBenchmarks.hs new file mode 100644 --- /dev/null +++ b/src-testing/Language/Futhark/ParserBenchmarks.hs @@ -0,0 +1,23 @@ +module Language.Futhark.ParserBenchmarks (benchmarks) where + +import Criterion (Benchmark, bench, bgroup, whnf) +import Data.Either (fromRight) +import Data.Text qualified as T +import Futhark.Util (showText) +import Language.Futhark.Parser (parseExp) + +bigArray :: Int -> T.Text +bigArray n = "[" <> T.intercalate "," (map ((<> "i32") . showText) [0 .. n - 1]) <> "]" + +benchmarks :: Benchmark +benchmarks = + bgroup + "Language.Futhark.Parser" + [ benchIntArray 10000, + benchIntArray 100000, + benchIntArray 1000000 + ] + where + benchIntArray n = + bench ("[" <> show n <> "]i32") $ + whnf (fromRight (error "parse error") . parseExp "") (bigArray n) diff --git a/src-testing/Language/Futhark/PrettyTests.hs b/src-testing/Language/Futhark/PrettyTests.hs new file mode 100644 --- /dev/null +++ b/src-testing/Language/Futhark/PrettyTests.hs @@ -0,0 +1,35 @@ +module Language.Futhark.PrettyTests (tests) where + +import Data.Text qualified as T +import Language.Futhark +import Language.Futhark.SyntaxTests () +import Test.Tasty +import Test.Tasty.HUnit +import Prelude + +var :: QualName Name -> UncheckedExp +var x = Var x NoInfo mempty + +binOp :: QualName Name -> UncheckedExp -> UncheckedExp -> UncheckedExp +binOp op x y = AppExp (BinOp (op, mempty) NoInfo (x, NoInfo) (y, NoInfo) mempty) NoInfo + +tests :: TestTree +tests = + testGroup + "Language.Futhark.Pretty" + [ testCase "No outer parens" $ + p (binOp "+" (var "x") (var "y")) + @?= "x + y", + testCase "No redundant parens" $ + p (binOp "+" "x+y" (var "z")) + @?= "x + y + z", + testCase "Necessary parens" $ + p (binOp "+" (var "x") "y+z") + @?= "x + (y + z)", + testCase "Explicit but redundant parens" $ + p "(x+y)+z" + @?= "(x + y) + z" + ] + where + p :: UncheckedExp -> T.Text + p = prettyText diff --git a/src-testing/Language/Futhark/PrimitiveTests.hs b/src-testing/Language/Futhark/PrimitiveTests.hs new file mode 100644 --- /dev/null +++ b/src-testing/Language/Futhark/PrimitiveTests.hs @@ -0,0 +1,76 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Language.Futhark.PrimitiveTests + ( tests, + arbitraryPrimValOfType, + ) +where + +import Control.Applicative +import Futhark.Util (convFloat) +import Language.Futhark.Primitive +import Test.QuickCheck +import Test.Tasty +import Test.Tasty.HUnit +import Prelude + +tests :: TestTree +tests = testGroup "PrimitiveTests" [propPrimValuesHaveRightType] + +propPrimValuesHaveRightType :: TestTree +propPrimValuesHaveRightType = + testGroup + "propPrimValuesHaveRightTypes" + [ testCase (show t ++ " has blank of right type") $ + primValueType (blankPrimValue t) @?= t + | t <- [minBound .. maxBound] + ] + +instance Arbitrary IntType where + arbitrary = elements [minBound .. maxBound] + +instance Arbitrary FloatType where + arbitrary = elements [minBound .. maxBound] + +instance Arbitrary PrimType where + arbitrary = elements [minBound .. maxBound] + +instance Arbitrary IntValue where + arbitrary = + oneof + [ Int8Value <$> arbitrary, + Int16Value <$> arbitrary, + Int32Value <$> arbitrary, + Int64Value <$> arbitrary + ] + +instance Arbitrary Half where + arbitrary = (convFloat :: Float -> Half) <$> arbitrary + +instance Arbitrary FloatValue where + arbitrary = + oneof + [ Float16Value <$> arbitrary, + Float32Value <$> arbitrary, + Float64Value <$> arbitrary + ] + +instance Arbitrary PrimValue where + arbitrary = + oneof + [ IntValue <$> arbitrary, + FloatValue <$> arbitrary, + BoolValue <$> arbitrary, + pure UnitValue + ] + +arbitraryPrimValOfType :: PrimType -> Gen PrimValue +arbitraryPrimValOfType (IntType Int8) = IntValue . Int8Value <$> arbitrary +arbitraryPrimValOfType (IntType Int16) = IntValue . Int16Value <$> arbitrary +arbitraryPrimValOfType (IntType Int32) = IntValue . Int32Value <$> arbitrary +arbitraryPrimValOfType (IntType Int64) = IntValue . Int64Value <$> arbitrary +arbitraryPrimValOfType (FloatType Float16) = FloatValue . Float16Value <$> arbitrary +arbitraryPrimValOfType (FloatType Float32) = FloatValue . Float32Value <$> arbitrary +arbitraryPrimValOfType (FloatType Float64) = FloatValue . Float32Value <$> arbitrary +arbitraryPrimValOfType Bool = BoolValue <$> arbitrary +arbitraryPrimValOfType Unit = pure UnitValue diff --git a/src-testing/Language/Futhark/SemanticTests.hs b/src-testing/Language/Futhark/SemanticTests.hs new file mode 100644 --- /dev/null +++ b/src-testing/Language/Futhark/SemanticTests.hs @@ -0,0 +1,24 @@ +module Language.Futhark.SemanticTests (tests) where + +import Language.Futhark (ImportName (..)) +import Language.Futhark.Semantic +import Test.Tasty +import Test.Tasty.HUnit + +tests :: TestTree +tests = + testGroup + "Semantic objects" + [ testCase "a" $ + mkInitialImport "a" @?= ImportName "a", + testCase "./a" $ + mkInitialImport "./a" @?= ImportName "a", + testCase "a/b -> ../c" $ + mkImportFrom (mkInitialImport "a/b") "../c" @?= ImportName "c", + testCase "a/b -> ../../c" $ + mkImportFrom (mkInitialImport "a/b") "../../c" @?= ImportName "../c", + testCase "../a -> b" $ + mkImportFrom (mkInitialImport "../a") "b" @?= ImportName "../b", + testCase "../a -> ../b" $ + mkImportFrom (mkInitialImport "../a") "../b" @?= ImportName "../../b" + ] diff --git a/src-testing/Language/Futhark/SyntaxTests.hs b/src-testing/Language/Futhark/SyntaxTests.hs new file mode 100644 --- /dev/null +++ b/src-testing/Language/Futhark/SyntaxTests.hs @@ -0,0 +1,211 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Language.Futhark.SyntaxTests (tests) where + +import Control.Applicative hiding (many, some) +import Data.Bifunctor +import Data.Char (isAlpha) +import Data.Functor +import Data.Map qualified as M +import Data.String +import Data.Text qualified as T +import Data.Void +import Language.Futhark +import Language.Futhark.Parser (SyntaxError (syntaxErrorMsg), parseExp, parseType) +import Language.Futhark.Primitive.Parse (constituent, keyword, lexeme) +import Language.Futhark.PrimitiveTests () +import Test.QuickCheck +import Test.Tasty +import Text.Megaparsec +import Text.Megaparsec.Char.Lexer qualified as L +import Prelude + +tests :: TestTree +tests = testGroup "Source SyntaxTests" [] + +instance Arbitrary BinOp where + arbitrary = elements [minBound .. maxBound] + +instance Arbitrary Uniqueness where + arbitrary = elements [Unique, Nonunique] + +instance Arbitrary PrimType where + arbitrary = + oneof + [ Signed <$> arbitrary, + Unsigned <$> arbitrary, + FloatType <$> arbitrary, + pure Bool + ] + +instance Arbitrary PrimValue where + arbitrary = + oneof + [ SignedValue <$> arbitrary, + UnsignedValue <$> arbitrary, + FloatValue <$> arbitrary, + BoolValue <$> arbitrary + ] + +-- The following dirty instances make it slightly nicer to write unit tests. + +instance IsString VName where + fromString s = + let (s', '_' : tag) = span (/= '_') s + in VName (fromString s') (read tag) + +instance (IsString v) => IsString (QualName v) where + fromString = QualName [] . fromString + +instance IsString UncheckedTypeExp where + fromString = + either (error . T.unpack . syntaxErrorMsg) id + . parseType "IsString UncheckedTypeExp" + . fromString + +type Parser = Parsec Void T.Text + +braces, brackets, parens :: Parser a -> Parser a +braces = between (lexeme "{") (lexeme "}") +brackets = between (lexeme "[") (lexeme "]") +parens = between (lexeme "(") (lexeme ")") + +pName :: Parser Name +pName = + lexeme . fmap nameFromString $ + (:) <$> satisfy isAlpha <*> many (satisfy constituent) + +pVName :: Parser VName +pVName = lexeme $ do + (s, tag) <- + satisfy constituent + `manyTill_` try pTag + "variable name" + pure $ VName (nameFromString s) tag + where + pTag = + "_" *> L.decimal <* notFollowedBy (satisfy constituent) + +pQualName :: Parser (QualName VName) +pQualName = QualName [] <$> pVName + +pPrimType :: Parser PrimType +pPrimType = + choice $ + map + f + [ Bool, + Signed Int8, + Signed Int16, + Signed Int32, + Signed Int64, + Unsigned Int8, + Unsigned Int16, + Unsigned Int32, + Unsigned Int64, + FloatType Float32, + FloatType Float64 + ] + where + f t = keyword (prettyText t) $> t + +pUniqueness :: Parser Uniqueness +pUniqueness = choice [lexeme "*" $> Unique, pure Nonunique] + +pSize :: Parser Size +pSize = + brackets $ + choice + [ flip sizeFromInteger mempty <$> lexeme L.decimal, + flip sizeFromName mempty <$> pQualName + ] + +pScalarNonFun :: Parser (ScalarTypeBase Size Uniqueness) +pScalarNonFun = + choice + [ Prim <$> pPrimType, + pTypeVar, + tupleRecord <$> parens (pType `sepBy` lexeme ","), + Record . M.fromList <$> braces (pField `sepBy1` lexeme ",") + ] + where + pField = (,) <$> pName <* lexeme ":" <*> pType + pTypeVar = TypeVar <$> pUniqueness <*> pQualName <*> many pTypeArg + pTypeArg = + choice + [ TypeArgDim <$> pSize, + TypeArgType . second (const NoUniqueness) <$> pTypeArgType + ] + pTypeArgType = + choice + [ Scalar . Prim <$> pPrimType, + parens pType + ] + +pArrayType :: Parser ResType +pArrayType = + Array + <$> pUniqueness + <*> (Shape <$> some pSize) + <*> (second (const NoUniqueness) <$> pScalarNonFun) + +pNonFunType :: Parser ResType +pNonFunType = + choice + [ try pArrayType, + try $ parens pType, + Scalar <$> pScalarNonFun + ] + +pScalarType :: Parser (ScalarTypeBase Size Uniqueness) +pScalarType = choice [try pFun, pScalarNonFun] + where + pFun = + pParam <* lexeme "->" <*> pRetType + pParam = + choice + [ try pNamedParam, + do + t <- pNonFunType + pure $ Arrow Nonunique Unnamed (diet $ resToParam t) (toStruct t) + ] + pNamedParam = parens $ do + v <- pVName <* lexeme ":" + t <- pType + pure $ Arrow Nonunique (Named v) (diet $ resToParam t) (toStruct t) + +pRetType :: Parser ResRetType +pRetType = + choice + [ lexeme "?" *> (RetType <$> some (brackets pVName) <* lexeme "." <*> pType), + RetType [] <$> pType + ] + +pType :: Parser ResType +pType = + choice [try $ Scalar <$> pScalarType, pArrayType, parens pType] + +fromStringParse :: Parser a -> String -> String -> a +fromStringParse p what s = + either onError id $ parse (p <* eof) "" (T.pack s) + where + onError e = + error $ "not a " <> what <> ": " <> s <> "\n" <> errorBundlePretty e + +instance IsString (ScalarTypeBase Size NoUniqueness) where + fromString = + fromStringParse (second (const NoUniqueness) <$> pScalarType) "ScalarType" + +instance IsString StructType where + fromString = + fromStringParse (second (const NoUniqueness) <$> pType) "StructType" + +instance IsString StructRetType where + fromString = + fromStringParse (second (pure NoUniqueness) <$> pRetType) "StructRetType" + +instance IsString ResRetType where + fromString = fromStringParse pRetType "ResRetType" + +instance IsString UncheckedExp where + fromString = either (error . T.unpack . syntaxErrorMsg) id . parseExp "string literal" . T.pack diff --git a/src-testing/Language/Futhark/TypeChecker/TypesTests.hs b/src-testing/Language/Futhark/TypeChecker/TypesTests.hs new file mode 100644 --- /dev/null +++ b/src-testing/Language/Futhark/TypeChecker/TypesTests.hs @@ -0,0 +1,185 @@ +module Language.Futhark.TypeChecker.TypesTests (tests) where + +import Data.Bifunctor +import Data.List (isInfixOf) +import Data.Map qualified as M +import Data.Text qualified as T +import Futhark.FreshNames +import Futhark.Util.Pretty (docText, prettyTextOneLine) +import Language.Futhark +import Language.Futhark.Semantic +import Language.Futhark.SyntaxTests () +import Language.Futhark.TypeChecker (initialEnv) +import Language.Futhark.TypeChecker.Monad +import Language.Futhark.TypeChecker.Names (resolveTypeExp) +import Language.Futhark.TypeChecker.Terms +import Language.Futhark.TypeChecker.Types +import Test.Tasty +import Test.Tasty.HUnit + +evalTest :: TypeExp (ExpBase NoInfo Name) Name -> Either String ([VName], ResRetType) -> TestTree +evalTest te expected = + testCase (prettyString te) $ + case (fmap (extract . fst) (run (checkTypeExp checkSizeExp =<< resolveTypeExp te)), expected) of + (Left got_e, Left expected_e) -> + let got_e_s = T.unpack $ docText $ prettyTypeError got_e + in (expected_e `isInfixOf` got_e_s) @? got_e_s + (Left got_e, Right _) -> + let got_e_s = T.unpack $ docText $ prettyTypeError got_e + in assertFailure $ "Failed: " <> got_e_s + (Right actual_t, Right expected_t) -> + actual_t @?= expected_t + (Right actual_t, Left _) -> + assertFailure $ "Expected error, got: " <> show actual_t + where + extract (_, svars, t, _) = (svars, t) + run = snd . runTypeM env mempty (mkInitialImport "") (newNameSource 100) + -- We hack up an environment with some predefined type + -- abbreviations for testing. This is all pretty sensitive to the + -- specific unique names, so we have to be careful! + env = + initialEnv + { envTypeTable = + M.fromList + [ ( "square_1000", + TypeAbbr + Unlifted + [TypeParamDim "n_1001" mempty] + "[n_1001][n_1001]i32" + ), + ( "fun_1100", + TypeAbbr + Lifted + [ TypeParamType Lifted "a_1101" mempty, + TypeParamType Lifted "b_1102" mempty + ] + "a_1101 -> b_1102" + ), + ( "pair_1200", + TypeAbbr + SizeLifted + [] + "?[n_1201][m_1202].([n_1201]i64, [m_1202]i64)" + ) + ] + <> envTypeTable initialEnv, + envNameMap = + M.fromList + [ ((Type, "square"), "square_1000"), + ((Type, "fun"), "fun_1100"), + ((Type, "pair"), "pair_1200") + ] + <> envNameMap initialEnv + } + +evalTests :: TestTree +evalTests = + testGroup + "Type expression elaboration" + [ testGroup "Positive tests" (map mkPos pos), + testGroup "Negative tests" (map mkNeg neg) + ] + where + mkPos (x, y) = evalTest x (Right y) + mkNeg (x, y) = evalTest x (Left y) + pos = + [ ( "[]i32", + ([], "?[d_100].[d_100]i32") + ), + ( "[][]i32", + ([], "?[d_100][d_101].[d_100][d_101]i32") + ), + ( "bool -> []i32", + ([], "bool -> ?[d_100].[d_100]i32") + ), + ( "bool -> []f32 -> []i32", + (["d_100"], "bool -> [d_100]f32 -> ?[d_101].[d_101]i32") + ), + ( "([]i32,[]i32)", + ([], "?[d_100][d_101].([d_100]i32, [d_101]i32)") + ), + ( "{a:[]i32,b:[]i32}", + ([], "?[d_100][d_101].{a:[d_100]i32, b:[d_101]i32}") + ), + ( "?[n].[n][n]bool", + ([], "?[n_100].[n_100][n_100]bool") + ), + ( "([]i32 -> []i32) -> bool -> []i32", + (["d_100"], "([d_100]i32 -> ?[d_101].[d_101]i32) -> bool -> ?[d_102].[d_102]i32") + ), + ( "((k: i64) -> [k]i32 -> [k]i32) -> []i32 -> bool", + (["d_101"], "((k_100: i64) -> [k_100]i32 -> [k_100]i32) -> [d_101]i32 -> bool") + ), + ( "square [10]", + ([], "[10][10]i32") + ), + ( "square []", + ([], "?[d_100].[d_100][d_100]i32") + ), + ( "bool -> square []", + ([], "bool -> ?[d_100].[d_100][d_100]i32") + ), + ( "(k: i64) -> square [k]", + ([], "(k_100: i64) -> [k_100][k_100]i32") + ), + ( "fun i32 bool", + ([], "i32 -> bool") + ), + ( "fun ([]i32) bool", + ([], "?[d_100].[d_100]i32 -> bool") + ), + ( "fun bool ([]i32)", + ([], "?[d_100].bool -> [d_100]i32") + ), + ( "bool -> fun ([]i32) bool", + ([], "bool -> ?[d_100].[d_100]i32 -> bool") + ), + ( "bool -> fun bool ([]i32)", + ([], "bool -> ?[d_100].bool -> [d_100]i32") + ), + ( "pair", + ([], "?[n_100][m_101].([n_100]i64, [m_101]i64)") + ), + ( "(pair,pair)", + ([], "?[n_100][m_101][n_102][m_103].(([n_100]i64, [m_101]i64), ([n_102]i64, [m_103]i64))") + ) + ] + neg = + [ ("?[n].bool", "Existential size \"n\""), + ("?[n].bool -> [n]bool", "Existential size \"n\""), + ("?[n].[n]bool -> [n]bool", "Existential size \"n\""), + ("?[n].[n]bool -> bool", "Existential size \"n\"") + ] + +substTest :: M.Map VName (Subst StructRetType) -> StructRetType -> StructRetType -> TestTree +substTest m t expected = + testCase (pretty_m <> ": " <> T.unpack (prettyTextOneLine t)) $ + applySubst (`M.lookup` m) t @?= expected + where + pretty_m = T.unpack $ prettyText $ map (first toName) $ M.toList m + +-- Some of these tests may be a bit fragile, in that they depend on +-- internal renumbering, which can be arbitrary. +substTests :: TestTree +substTests = + testGroup + "Type substitution" + [ substTest m0 "t_0" "i64", + substTest m0 "[1]t_0" "[1]i64", + substTest m0 "?[n_10].[n_10]t_0" "?[n_10].[n_10]i64", + -- + substTest m1 "t_0" "?[n_1].[n_1]bool", + substTest m1 "f32 -> t_0" "f32 -> ?[n_1].[n_1]bool", + substTest m1 "f32 -> f64 -> t_0" "f32 -> f64 -> ?[n_1].[n_1]bool", + substTest m1 "f32 -> t_0 -> bool" "?[n_1].f32 -> [n_1]bool -> bool", + substTest m1 "f32 -> t_0 -> t_0" "?[n_1].f32 -> [n_1]bool -> ?[n_2].[n_2]bool" + ] + where + m0 = + M.fromList [("t_0", Subst [] "i64")] + + m1 = + M.fromList [("t_0", Subst [] "?[n_1].[n_1]bool")] + +tests :: TestTree +tests = testGroup "Basic type operations" [evalTests, substTests] diff --git a/src-testing/Language/Futhark/TypeCheckerTests.hs b/src-testing/Language/Futhark/TypeCheckerTests.hs new file mode 100644 --- /dev/null +++ b/src-testing/Language/Futhark/TypeCheckerTests.hs @@ -0,0 +1,11 @@ +module Language.Futhark.TypeCheckerTests (tests) where + +import Language.Futhark.TypeChecker.TypesTests qualified +import Test.Tasty + +tests :: TestTree +tests = + testGroup + "Source type checker tests" + [ Language.Futhark.TypeChecker.TypesTests.tests + ] diff --git a/src-testing/futhark_benchmarks.hs b/src-testing/futhark_benchmarks.hs new file mode 100644 --- /dev/null +++ b/src-testing/futhark_benchmarks.hs @@ -0,0 +1,10 @@ +module Main (main) where + +import Criterion.Main +import Language.Futhark.ParserBenchmarks qualified + +main :: IO () +main = + defaultMain + [ Language.Futhark.ParserBenchmarks.benchmarks + ] diff --git a/src-testing/futhark_tests.hs b/src-testing/futhark_tests.hs new file mode 100644 --- /dev/null +++ b/src-testing/futhark_tests.hs @@ -0,0 +1,44 @@ +module Main (main) where + +import Futhark.AD.DerivativesTests qualified +import Futhark.Analysis.AlgSimplifyTests qualified +import Futhark.BenchTests qualified +import Futhark.IR.Mem.IntervalTests qualified +import Futhark.IR.Mem.IxFunTests qualified +import Futhark.IR.PropTests qualified +import Futhark.IR.Syntax.CoreTests qualified +import Futhark.Internalise.TypesValuesTests qualified +import Futhark.Optimise.ArrayLayoutTests qualified +import Futhark.Optimise.MemoryBlockMerging.GreedyColoringTests qualified +import Futhark.Pkg.SolveTests qualified +import Language.Futhark.PrettyTests qualified +import Language.Futhark.PrimitiveTests qualified +import Language.Futhark.SemanticTests qualified +import Language.Futhark.SyntaxTests qualified +import Language.Futhark.TypeCheckerTests qualified +import Test.Tasty + +allTests :: TestTree +allTests = + testGroup + "" + [ Language.Futhark.SyntaxTests.tests, + Language.Futhark.PrettyTests.tests, + Futhark.AD.DerivativesTests.tests, + Futhark.BenchTests.tests, + Futhark.IR.PropTests.tests, + Futhark.IR.Syntax.CoreTests.tests, + Futhark.Pkg.SolveTests.tests, + Futhark.Internalise.TypesValuesTests.tests, + Futhark.IR.Mem.IntervalTests.tests, + Futhark.IR.Mem.IxFunTests.tests, + Language.Futhark.PrimitiveTests.tests, + Futhark.Optimise.MemoryBlockMerging.GreedyColoringTests.tests, + Futhark.Analysis.AlgSimplifyTests.tests, + Language.Futhark.TypeCheckerTests.tests, + Language.Futhark.SemanticTests.tests, + Futhark.Optimise.ArrayLayoutTests.tests + ] + +main :: IO () +main = defaultMain allTests 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 @@ -357,18 +357,6 @@ Just [b, a, fConst Float32 1] pdBuiltin "mad64" [a, b, _c] = Just [b, a, fConst Float64 1] -pdBuiltin "from_bits16" [_] = - Just [fConst Float16 1] -pdBuiltin "from_bits32" [_] = - Just [fConst Float32 1] -pdBuiltin "from_bits64" [_] = - Just [fConst Float64 1] -pdBuiltin "to_bits16" [_] = - Just [iConst Int16 1] -pdBuiltin "to_bits32" [_] = - Just [iConst Int32 1] -pdBuiltin "to_bits64" [_] = - Just [iConst Int64 1] pdBuiltin "hypot16" [x, y] = Just [ untyped $ isF16 x / isF16 (FunExp "hypot16" [x, y] $ FloatType Float16), diff --git a/src/Futhark/AD/Rev.hs b/src/Futhark/AD/Rev.hs --- a/src/Futhark/AD/Rev.hs +++ b/src/Futhark/AD/Rev.hs @@ -264,7 +264,14 @@ forM_ (zip branches_free branches_free_adj) $ \(v, v_adj) -> insAdj v =<< copyIfArray v_adj diffStm (Let pat aux (Op soac)) m = - vjpSOAC vjpOps pat aux soac m + -- We add the attributes from 'aux' to every SOAC (but only SOAC) produced. We + -- could do this on *every* stm, but it would be very verbose. + censorStms (fmap addAttrs) $ vjpSOAC vjpOps pat aux soac m + where + addAttrs stm + | Op _ <- stmExp stm = + attribute (stmAuxAttrs aux) stm + | otherwise = stm diffStm (Let pat aux loop@Loop {}) m = diffLoop diffStms pat aux loop m -- See Note [Adjoints of accumulators] diff --git a/src/Futhark/Analysis/AccessPattern.hs b/src/Futhark/Analysis/AccessPattern.hs --- a/src/Futhark/Analysis/AccessPattern.hs +++ b/src/Futhark/Analysis/AccessPattern.hs @@ -228,7 +228,7 @@ -- | Analyse the op for this representation. analyseOp :: Op rep -> Context rep -> [VName] -> (Context rep, IndexTable rep) --- | Analyse each `entry` and accumulate the results. +-- | Analyse each entry and accumulate the results. analyseDimAccesses :: (Analyse rep) => Prog rep -> IndexTable rep analyseDimAccesses = foldMap' analyseFunction . progFuns @@ -308,7 +308,6 @@ then result <> oneName a else -- Otherwise, recurse on its dependencies; -- 0. Add dependencies in ctx to result - let (deps_in_ctx, deps_not_in_ctx) = L.partition (`M.member` local_assignments) $ namesToList (deps var_info) @@ -471,7 +470,7 @@ BinOp _ lsubexp rsubexp -> concatVariableInfos mempty [lsubexp, rsubexp] CmpOp _ lsubexp rsubexp -> concatVariableInfos mempty [lsubexp, rsubexp] ConvOp _ se -> varInfoFromSubExp se - Assert se _ _ -> varInfoFromSubExp se + Assert se _ -> varInfoFromSubExp se Index name _ -> error $ "unhandled: Index (This should NEVER happen) into " ++ prettyString name Update _ name _slice _subexp -> diff --git a/src/Futhark/Analysis/Alias.hs b/src/Futhark/Analysis/Alias.hs --- a/src/Futhark/Analysis/Alias.hs +++ b/src/Futhark/Analysis/Alias.hs @@ -82,11 +82,11 @@ AliasTable -> Stm rep -> Stm (Aliases rep) -analyseStm aliases (Let pat (StmAux cs attrs dec) e) = +analyseStm aliases (Let pat aux e) = let e' = analyseExp aliases e pat' = mkAliasedPat pat e' - rep' = (AliasDec $ consumedInExp e', dec) - in Let pat' (StmAux cs attrs rep') e' + aux' = (AliasDec (consumedInExp e'),) <$> aux + in Let pat' aux' e' -- | Perform alias analysis on expression. analyseExp :: diff --git a/src/Futhark/Analysis/LastUse.hs b/src/Futhark/Analysis/LastUse.hs --- a/src/Futhark/Analysis/LastUse.hs +++ b/src/Futhark/Analysis/LastUse.hs @@ -428,7 +428,7 @@ else aliasTransitiveClosure res -- | For each 'PatElem' in the 'Pat', add its aliases to the 'AliasTab' in --- 'LastUseM'. Additionally, 'Names' are added as aliases of all the 'PatElemT'. +-- 'LastUseM'. Additionally, 'Names' are added as aliases of all the 'PatElem'. updateAliasing :: (AliasesOf dec) => -- | Extra names that all 'PatElem' should alias. diff --git a/src/Futhark/Analysis/PrimExp/Convert.hs b/src/Futhark/Analysis/PrimExp/Convert.hs --- a/src/Futhark/Analysis/PrimExp/Convert.hs +++ b/src/Futhark/Analysis/PrimExp/Convert.hs @@ -48,7 +48,7 @@ Apply (nameFromText h) <$> args' <*> pure [(primRetType t, mempty)] - <*> pure (Safe, mempty, []) + <*> pure Safe where args' = zip <$> mapM (toSubExp "apply_arg") args <*> pure (repeat Observe) toExp (LeafExp v _) = diff --git a/src/Futhark/Builder/Class.hs b/src/Futhark/Builder/Class.hs --- a/src/Futhark/Builder/Class.hs +++ b/src/Futhark/Builder/Class.hs @@ -11,6 +11,7 @@ MonadBuilder (..), insertStms, insertStm, + censorStms, letBind, letBindNames, collectStms_, @@ -103,23 +104,29 @@ -- | Add the given attributes to any statements added by this action. attributing :: (MonadBuilder m) => Attrs -> m a -> m a -attributing attrs = censorStms $ fmap onStm - where - onStm (Let pat aux e) = - Let pat aux {stmAuxAttrs = attrs <> stmAuxAttrs aux} e +attributing attrs = censorStms $ fmap $ attribute attrs -- | Add the certificates and attributes to any statements added by -- this action. auxing :: (MonadBuilder m) => StmAux anyrep -> m a -> m a -auxing (StmAux cs attrs _) = censorStms $ fmap onStm +auxing outer + | stmAuxCerts outer == mempty, + stmAuxAttrs outer == mempty, + stmAuxLoc outer == mempty = + id + | otherwise = censorStms $ fmap onStm where onStm (Let pat aux e) = Let pat aux' e where aux' = aux - { stmAuxAttrs = attrs <> stmAuxAttrs aux, - stmAuxCerts = cs <> stmAuxCerts aux + { stmAuxAttrs = stmAuxAttrs outer <> stmAuxAttrs aux, + stmAuxCerts = stmAuxCerts outer <> stmAuxCerts aux, + stmAuxLoc = + if stmAuxLoc aux == mempty + then stmAuxLoc outer + else stmAuxLoc aux } -- | Add a statement with the given pattern and expression. @@ -142,10 +149,10 @@ -- | Like mkLet, but also take attributes and certificates from the -- given 'StmAux'. mkLet' :: (Buildable rep) => [Ident] -> StmAux a -> Exp rep -> Stm rep -mkLet' ids (StmAux cs attrs _) e = +mkLet' ids (StmAux cs attrs loc _) e = let pat = mkExpPat ids e dec = mkExpDec pat e - in Let pat (StmAux cs attrs dec) e + in Let pat (StmAux cs attrs loc dec) e -- | Add a statement with the given pattern element names and -- expression. diff --git a/src/Futhark/CLI/Doc.hs b/src/Futhark/CLI/Doc.hs --- a/src/Futhark/CLI/Doc.hs +++ b/src/Futhark/CLI/Doc.hs @@ -16,8 +16,10 @@ import Futhark.Pipeline (FutharkM, Verbosity (..), runFutharkM) import Futhark.Util (directoryContents) import Futhark.Util.Options +import Futhark.Util.Pretty (hPutDoc) import Language.Futhark.Semantic (mkInitialImport) import Language.Futhark.Syntax (DocComment (..), progDoc) +import Language.Futhark.Warnings (prettyWarnings) import System.Directory (createDirectoryIfMissing) import System.Exit import System.FilePath @@ -43,9 +45,10 @@ printDecs cfg dir files imports = do let direct_imports = map (mkInitialImport . normalise . dropExtension) files - (file_htmls, _warnings) = + (file_htmls, warnings) = do renderFiles direct_imports $ filter (not . ignored) imports + hPutDoc stderr $ prettyWarnings warnings mapM_ (write . fmap (LT.toStrict . renderHtml)) file_htmls write ("style.css", cssFile) where diff --git a/src/Futhark/CLI/Misc.hs b/src/Futhark/CLI/Misc.hs --- a/src/Futhark/CLI/Misc.hs +++ b/src/Futhark/CLI/Misc.hs @@ -22,8 +22,8 @@ import Futhark.Util (hashText, interactWithFileSafely) import Futhark.Util.Options import Futhark.Util.Pretty (prettyTextOneLine) +import Language.Futhark.Core (isBuiltin) import Language.Futhark.Parser.Lexer (scanTokensText) -import Language.Futhark.Prop (isBuiltin) import Language.Futhark.Semantic (includeToString) import System.Environment (getExecutablePath) import System.Exit diff --git a/src/Futhark/CLI/Profile.hs b/src/Futhark/CLI/Profile.hs --- a/src/Futhark/CLI/Profile.hs +++ b/src/Futhark/CLI/Profile.hs @@ -48,7 +48,7 @@ tabulateEvents :: [ProfilingEvent] -> T.Text tabulateEvents = mkRows . M.toList . M.fromListWith comb . map pair where - pair (ProfilingEvent name dur _) = (name, EvSummary 1 dur dur dur) + pair (ProfilingEvent name dur _ _details) = (name, EvSummary 1 dur dur dur) comb (EvSummary xn xdur xmin xmax) (EvSummary yn ydur ymin ymax) = EvSummary (xn + yn) (xdur + ydur) (min xmin ymin) (max xmax ymax) numpad = 15 @@ -92,8 +92,11 @@ timeline :: [ProfilingEvent] -> T.Text timeline = T.unlines . L.intercalate [""] . map onEvent where - onEvent (ProfilingEvent name duration description) = - [name, "Duration: " <> showText duration <> " μs"] <> T.lines description + onEvent (ProfilingEvent name duration provenance _details) = + [ name, + "Duration: " <> showText duration <> " μs", + "At: " <> provenance + ] data TargetFiles = TargetFiles { summaryFile :: FilePath, 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 @@ -36,6 +36,7 @@ GC.CompilerM op s Name genKernelFunction kernel_name safety arg_params arg_set = do let kernel_fname = "gpu_kernel_" <> kernel_name + provenance <- GC.provenanceExp GC.libDecl [C.cedecl|static int $id:kernel_fname (struct futhark_context* ctx, @@ -46,7 +47,7 @@ void* args[$int:num_args] = { $inits:(failure_inits<>args_inits) }; size_t args_sizes[$int:num_args] = { $inits:(failure_sizes<>args_sizes) }; return gpu_launch_kernel(ctx, ctx->program->$id:kernel_name, - $string:(prettyString kernel_name), + $string:(prettyString kernel_name), $exp:provenance, (const typename int32_t[]){grid_x, grid_y, grid_z}, (const typename int32_t[]){block_x, block_y, block_z}, shared_bytes, @@ -162,10 +163,11 @@ dststride_inits = [[C.cinit|$exp:e|] | Count e <- dststride] srcstride_inits = [[C.cinit|$exp:e|] | Count e <- srcstride] shape_inits = [[C.cinit|$exp:e|] | Count e <- shape] + provenance <- GC.provenanceExp GC.stm [C.cstm| if ((err = - $id:fname(ctx, $int:r, + $id:fname(ctx, $exp:provenance, $int:r, $exp:dst, $exp:(unCount dstoffset), (typename int64_t[]){ $inits:dststride_inits }, $exp:src, $exp:(unCount srcoffset), @@ -181,11 +183,13 @@ dststride_inits = [[C.cinit|$exp:e|] | Count e <- dststride] srcstride_inits = [[C.cinit|$exp:e|] | Count e <- srcstride] shape_inits = [[C.cinit|$exp:e|] | Count e <- shape] + provenance <- GC.provenanceExp GC.stm [C.cstm| if ((err = lmad_copy_host2gpu - (ctx, $int:(primByteSize t::Int), $exp:sync', $int:r, + (ctx, $exp:provenance, + $int:(primByteSize t::Int), $exp:sync', $int:r, $exp:dst, $exp:(unCount dstoffset), (typename int64_t[]){ $inits:dststride_inits }, $exp:src, $exp:(unCount srcoffset), @@ -262,8 +266,11 @@ readScalarGPU mem i t "device" _ = do val <- newVName "read_res" GC.decl [C.cdecl|$ty:t $id:val;|] + p <- GC.provenanceExp GC.stm - [C.cstm|if ((err = gpu_scalar_from_device(ctx, &$id:val, $exp:mem, $exp:i * sizeof($ty:t), sizeof($ty:t))) != 0) { goto cleanup; }|] + [C.cstm|if ((err = gpu_scalar_from_device(ctx, $exp:p, &$id:val, $exp:mem, + $exp:i * sizeof($ty:t), sizeof($ty:t))) != 0) + { goto cleanup; }|] GC.stm [C.cstm|if (ctx->failure_is_an_option && futhark_context_sync(ctx) != 0) { err = 1; goto cleanup; }|] @@ -277,8 +284,11 @@ writeScalarGPU mem i t "device" _ val = do val' <- newVName "write_tmp" GC.item [C.citem|$ty:t $id:val' = $exp:val;|] + p <- GC.provenanceExp GC.stm - [C.cstm|if ((err = gpu_scalar_to_device(ctx, $exp:mem, $exp:i * sizeof($ty:t), sizeof($ty:t), &$id:val')) != 0) { goto cleanup; }|] + [C.cstm|if ((err = gpu_scalar_to_device(ctx, $exp:p, $exp:mem, + $exp:i * sizeof($ty:t), sizeof($ty:t), &$id:val')) != 0) + { goto cleanup; }|] writeScalarGPU _ _ _ space _ _ = error $ "Cannot write to '" ++ space ++ "' memory space." @@ -287,15 +297,18 @@ syncArg GC.CopyNoBarrier = [C.cexp|false|] copyGPU :: GC.Copy OpenCL () -copyGPU _ dstmem dstidx (Space "device") srcmem srcidx (Space "device") nbytes = +copyGPU _ dstmem dstidx (Space "device") srcmem srcidx (Space "device") nbytes = do + p <- GC.provenanceExp GC.stm - [C.cstm|err = gpu_memcpy(ctx, $exp:dstmem, $exp:dstidx, $exp:srcmem, $exp:srcidx, $exp:nbytes);|] -copyGPU b dstmem dstidx DefaultSpace srcmem srcidx (Space "device") nbytes = + [C.cstm|err = gpu_memcpy(ctx, $exp:p, $exp:dstmem, $exp:dstidx, $exp:srcmem, $exp:srcidx, $exp:nbytes);|] +copyGPU b dstmem dstidx DefaultSpace srcmem srcidx (Space "device") nbytes = do + p <- GC.provenanceExp GC.stm - [C.cstm|err = memcpy_gpu2host(ctx, $exp:(syncArg b), $exp:dstmem, $exp:dstidx, $exp:srcmem, $exp:srcidx, $exp:nbytes);|] -copyGPU b dstmem dstidx (Space "device") srcmem srcidx DefaultSpace nbytes = + [C.cstm|err = memcpy_gpu2host(ctx, $exp:p, $exp:(syncArg b), $exp:dstmem, $exp:dstidx, $exp:srcmem, $exp:srcidx, $exp:nbytes);|] +copyGPU b dstmem dstidx (Space "device") srcmem srcidx DefaultSpace nbytes = do + p <- GC.provenanceExp GC.stm - [C.cstm|err = memcpy_host2gpu(ctx, $exp:(syncArg b), $exp:dstmem, $exp:dstidx, $exp:srcmem, $exp:srcidx, $exp:nbytes);|] + [C.cstm|err = memcpy_host2gpu(ctx, $exp:p, $exp:(syncArg b), $exp:dstmem, $exp:dstidx, $exp:srcmem, $exp:srcidx, $exp:nbytes);|] copyGPU _ _ _ destspace _ _ srcspace _ = error $ "Cannot copy to " ++ show destspace ++ " from " ++ show srcspace 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 @@ -221,13 +221,10 @@ compileCode (Op op) = join $ asks (opsCompiler . envOperations) <*> pure op compileCode Skip = pure () -compileCode (Comment s code) = do - xs <- collect $ compileCode code - let comment = "// " ++ T.unpack s - stm - [C.cstm|$comment:comment - { $items:xs } - |] +compileCode (Meta (MetaComment s)) = do + comment s +compileCode (Meta (MetaProvenance (Provenance _ l))) = + unless (l == mempty) $ comment $ locText l compileCode (TracePrint msg) = do (formatstr, formatargs) <- errorMsgString msg stm [C.cstm|fprintf(ctx->log, $string:formatstr, $args:formatargs);|] @@ -271,6 +268,9 @@ args' <- mapM compileArg args item [C.citem|$tyquals:(volQuals vol) $ty:ct $id:name = $id:(funName fname)($args:args');|] go code + go (x@(Meta (MetaProvenance p)) : xs) = do + compileCode x + localProvenance p $ go xs go (x : xs) = compileCode x >> go xs go [] = pure () compileCode (Assert e msg (loc, locs)) = do 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 @@ -36,6 +36,7 @@ items, stm, stms, + comment, decl, headerDecl, publicDef, @@ -60,6 +61,9 @@ collect', contextType, configType, + localProvenance, + askProvenance, + provenanceExp, -- * Building Blocks copyMemoryDefaultSpace, @@ -258,7 +262,9 @@ -- pressure, we keep these allocations around for a long time, and -- record their sizes so we can reuse them if possible (and -- realloc() when needed). - envCachedMem :: M.Map C.Exp VName + envCachedMem :: M.Map C.Exp VName, + -- | The provenance of an enclosing 'Imp.MetaProvenance', if any. + envProvenance :: Provenance } contextContents :: CompilerM op s ([C.FieldGroup], [C.Stm], [C.Stm]) @@ -322,7 +328,7 @@ (a, CompilerState s) runCompilerM ops src userstate (CompilerM m) = runState - (runReaderT m (CompilerEnv ops mempty)) + (runReaderT m (CompilerEnv ops mempty mempty)) (newCompilerState src userstate) getUserState :: CompilerM op s s @@ -344,6 +350,23 @@ modify $ \s -> s {compItems = old} pure (x, DL.toList new) +-- | Locally replace (not extend!) the provenance. +localProvenance :: Provenance -> CompilerM op s a -> CompilerM op s a +localProvenance p = local $ \env -> env {envProvenance = p} + +-- | The provenance of the closest enclosing 'Imp.MetaProvenance'. +askProvenance :: CompilerM op s Provenance +askProvenance = asks envProvenance + +-- | A C expression corresponding to the current provenance. +provenanceExp :: CompilerM op s C.Exp +provenanceExp = do + p <- askProvenance + pure $ + if p == mempty + then [C.cexp|NULL|] + else [C.cexp|$string:(prettyString p)|] + -- | Used when we, inside an existing 'CompilerM' action, want to -- generate code for a new function. Use this so that the compiler -- understands that previously declared memory doesn't need to be @@ -358,12 +381,20 @@ where noCached env = env {envCachedMem = mempty} +-- | Insert a block item in the generated code at this point. item :: C.BlockItem -> CompilerM op s () item x = modify $ \s -> s {compItems = DL.snoc (compItems s) x} items :: [C.BlockItem] -> CompilerM op s () items xs = modify $ \s -> s {compItems = DL.append (compItems s) (DL.fromList xs)} +-- | Insert a comment in the generated code at this point. The comment may +-- contain linebreaks, and must not contain any comment markers. +comment :: T.Text -> CompilerM op s () +comment = mapM_ (f . ("// " <>)) . T.lines + where + f s = stm [C.cstm|$escstm:(T.unpack s)|] + fatMemory :: Space -> CompilerM op s Bool fatMemory ScalarSpace {} = pure False fatMemory _ = asks $ opsFatMemory . envOperations @@ -425,6 +456,7 @@ onClear x = modify $ \s -> s {compClearItems = compClearItems s <> DL.singleton x} +-- | Insert a statement in the generated code at this point. stm :: C.Stm -> CompilerM op s () stm s = item [C.citem|$stm:s|] 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 @@ -1062,13 +1062,13 @@ -- | Convert from scalar to storage representation for the given type. toStorage :: PrimType -> PyExp -> PyExp toStorage (FloatType Float16) e = - simpleCall "ct.c_int16" [simpleCall "futhark_to_bits16" [e]] + simpleCall "ct.c_int16" [simpleCall "fptobits_f16_i16" [e]] toStorage t e = simpleCall (compilePrimType t) [e] -- | Convert from storage to scalar representation for the given type. fromStorage :: PrimType -> PyExp -> PyExp fromStorage (FloatType Float16) e = - simpleCall "futhark_from_bits16" [simpleCall "np.int16" [e]] + simpleCall "bitstofp_i16_f16" [simpleCall "np.int16" [e]] fromStorage t e = simpleCall (compilePrimToNp t) [e] compilePrimValue :: Imp.PrimValue -> PyExp @@ -1306,9 +1306,10 @@ ] name' <- compileVar name stm $ Assign name' $ simpleCall "unwrapArray" [Var arr_name] -compileCode (Imp.Comment s code) = do - code' <- collect $ compileCode code - stm $ Comment (T.unpack s) code' +compileCode (Imp.Meta (Imp.MetaComment s)) = + stm $ Comment (T.unpack s) [] +compileCode (Imp.Meta {}) = + pure () compileCode (Imp.Assert e msg (loc, locs)) = do e' <- compileExp e (formatstr, formatargs) <- errorMsgString msg 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 @@ -203,6 +203,7 @@ benchmarkCode :: Name -> [C.BlockItem] -> GC.CompilerM op s [C.BlockItem] benchmarkCode name code = do event <- newVName "event" + provenance <- GC.provenanceExp pure [C.citems| struct mc_event* $id:event = mc_event_new(ctx); @@ -215,7 +216,8 @@ lock_lock(&ctx->event_list_lock); add_event(ctx, $string:(nameToString name), - strdup("nothing further"), + $exp:provenance, + NULL, $id:event, (typename event_report_fn)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 @@ -474,13 +474,8 @@ -- All recursive constructors are duplicated here, since not doing so -- would cause use to enter regular generic C codegen with no escape. compileCode :: MCCode -> ISPCCompilerM () -compileCode (Comment s code) = do - xs <- GC.collect $ compileCode code - let comment = "// " ++ T.unpack s - GC.stm - [C.cstm|$comment:comment - { $items:xs } - |] +compileCode (Meta (MetaComment s)) = do + GC.comment s compileCode (DeclareScalar name _ t) = do let ct = GC.primTypeToCType t quals <- getVariabilityQuals name @@ -729,7 +724,6 @@ mayProduceError (If _ x y) = mayProduceError x || mayProduceError y mayProduceError (For _ _ x) = mayProduceError x mayProduceError (While _ x) = mayProduceError x -mayProduceError (Comment _ x) = mayProduceError x mayProduceError (Op (ForEachActive _ body)) = mayProduceError body mayProduceError (Op (ForEach _ _ _ body)) = mayProduceError body mayProduceError (Op SegOp {}) = True @@ -1015,8 +1009,6 @@ free = freeIn bound findDeps (While cond x) = do local (<> freeIn cond) $ findDeps x -findDeps (Comment _ x) = - findDeps x findDeps (Op (SegOp _ free _ _ retvals _)) = mapM_ ( \x -> @@ -1064,7 +1056,6 @@ findVarying (If _ x y) = findVarying x ++ findVarying y findVarying (For _ _ x) = findVarying x findVarying (While _ x) = findVarying x -findVarying (Comment _ x) = findVarying x findVarying (Op (ForEachActive _ body)) = findVarying body findVarying (Op (ForEach idx _ _ body)) = idx : findVarying body findVarying (DeclareMem mem _) = [mem] diff --git a/src/Futhark/CodeGen/Backends/SimpleRep.hs b/src/Futhark/CodeGen/Backends/SimpleRep.hs --- a/src/Futhark/CodeGen/Backends/SimpleRep.hs +++ b/src/Futhark/CodeGen/Backends/SimpleRep.hs @@ -88,12 +88,12 @@ -- | Convert from scalar to storage representation for the given type. toStorage :: PrimType -> C.Exp -> C.Exp -toStorage (FloatType Float16) e = [C.cexp|futrts_to_bits16($exp:e)|] +toStorage (FloatType Float16) e = [C.cexp|fptobits_f16_i16($exp:e)|] toStorage _ e = e -- | Convert from storage to scalar representation for the given type. fromStorage :: PrimType -> C.Exp -> C.Exp -fromStorage (FloatType Float16) e = [C.cexp|futrts_from_bits16($exp:e)|] +fromStorage (FloatType Float16) e = [C.cexp|bitstofp_i16_f16($exp:e)|] fromStorage _ e = e -- | @tupleField i@ is the name of field number @i@ in a tuple. diff --git a/src/Futhark/CodeGen/ImpCode.hs b/src/Futhark/CodeGen/ImpCode.hs --- a/src/Futhark/CodeGen/ImpCode.hs +++ b/src/Futhark/CodeGen/ImpCode.hs @@ -64,6 +64,7 @@ MemSize, DimSize, Code (..), + Metadata (..), PrimValue (..), Exp, TExp, @@ -77,6 +78,7 @@ calledFuncs, callGraph, ParamMap, + foldProvenances, -- * Typed enumerations Bytes, @@ -116,6 +118,7 @@ ErrorMsgPart (..), OpaqueType (..), OpaqueTypes (..), + Provenance (..), Rank (..), Signedness (..), Space (..), @@ -241,6 +244,15 @@ ArrayZeros Int deriving (Show) +-- | A piece of additional information attached to a piece of code, which should +-- not have any effect on how it is executed. +data Metadata + = -- | An informative comment that can be inserted into generated code. + MetaComment T.Text + | -- | Where this bit of code came from. + MetaProvenance Provenance + deriving (Eq, Ord, Show) + -- | A block of imperative code. Parameterised by an 'Op', which -- allows extensibility. Concrete uses of this type will instantiate -- the type parameter with e.g. a construct for launching GPU kernels. @@ -257,6 +269,11 @@ | -- | While loop. The conditional is (of course) -- re-evaluated before every iteration of the loop. While (TExp Bool) (Code a) + | -- | Conditional execution. + If (TExp Bool) (Code a) (Code a) + | -- | No semantics; just some information about what code is being generated + -- here. + Meta Metadata | -- | Declare a memory block variable that will point to -- memory in the given memory space. Note that this is -- distinct from allocation. The memory block must be the @@ -308,16 +325,10 @@ | -- | Function call. The results are written to the -- provided 'VName' variables. Call [VName] Name [Arg] - | -- | Conditional execution. - If (TExp Bool) (Code a) (Code a) | -- | Assert that something must be true. Should it turn -- out not to be true, then report a failure along with -- the given error message. - Assert Exp (ErrorMsg Exp) (SrcLoc, [SrcLoc]) - | -- | Has the same semantics as the contained code, but - -- the comment should show up in generated code for ease - -- of inspection. - Comment T.Text (Code a) + Assert Exp (ErrorMsg Exp) (Loc, [Loc]) | -- | Print the given value to the screen, somehow -- annotated with the given string as a description. If -- no type/value pair, just print the string. This has @@ -369,7 +380,6 @@ go f (If _ x y) = f x <> f y go f (For _ _ x) = f x go f (While _ x) = f x - go f (Comment _ x) = f x go _ _ = mempty declared (DeclareMem mem space) = @@ -409,7 +419,6 @@ calledFuncs f (If _ x y) = calledFuncs f x <> calledFuncs f y calledFuncs f (For _ _ x) = calledFuncs f x calledFuncs f (While _ x) = calledFuncs f x -calledFuncs f (Comment _ x) = calledFuncs f x calledFuncs _ _ = mempty -- | Compute call graph, as per 'calledFuncs', but also include @@ -423,6 +432,16 @@ next = M.map (foldMap grow) cur in if next == cur then cur else loop next +-- | Combine the provenances of all the 'Imp.MetaProvenance' in the provided code. +foldProvenances :: (op -> Provenance) -> Code op -> Provenance +foldProvenances _ (Meta (MetaProvenance p)) = p +foldProvenances f (x :>>: y) = foldProvenances f x <> foldProvenances f y +foldProvenances f (For _ _ c) = foldProvenances f c +foldProvenances f (While _ c) = foldProvenances f c +foldProvenances f (If _ x y) = foldProvenances f x <> foldProvenances f y +foldProvenances f (Op x) = f x +foldProvenances _ _ = mempty + -- | A mapping from names of tuning parameters to their class, as well -- as which functions make use of them (including transitively). type ParamMap = M.Map Name (SizeClass, S.Set Name) @@ -643,8 +662,10 @@ <+> "<-" <+> pretty fname <> parens (commasep $ map pretty args) - pretty (Comment s code) = - "--" <+> pretty s pretty code + pretty (Meta (MetaComment s)) = + "--" <+> pretty s + pretty (Meta (MetaProvenance l)) = + "@" <+> align (pretty l) pretty (DebugPrint desc (Just e)) = "debug" <+> parens (commasep [pretty (show desc), pretty e]) pretty (DebugPrint desc Nothing) = @@ -721,8 +742,8 @@ pure $ Assert e msg loc traverse _ (Call dests fname args) = pure $ Call dests fname args - traverse f (Comment s code) = - Comment s <$> traverse f code + traverse _ (Meta s) = + pure $ Meta s traverse _ (DebugPrint s v) = pure $ DebugPrint s v traverse _ (TracePrint msg) = @@ -738,7 +759,6 @@ declaredIn (x :>>: y) = declaredIn x <> declaredIn y declaredIn (For i _ body) = oneName i <> declaredIn body declaredIn (While _ body) = declaredIn body -declaredIn (Comment _ body) = declaredIn body declaredIn _ = mempty instance FreeIn EntryPoint where @@ -799,8 +819,8 @@ freeIn' e <> foldMap freeIn' msg freeIn' (Op op) = freeIn' op - freeIn' (Comment _ code) = - freeIn' code + freeIn' (Meta {}) = + mempty freeIn' (DebugPrint _ v) = maybe mempty freeIn' v freeIn' (TracePrint msg) = diff --git a/src/Futhark/CodeGen/ImpCode/Multicore.hs b/src/Futhark/CodeGen/ImpCode/Multicore.hs --- a/src/Futhark/CodeGen/ImpCode/Multicore.hs +++ b/src/Futhark/CodeGen/ImpCode/Multicore.hs @@ -194,7 +194,6 @@ go f (If _ x y) = f x <> f y go f (For _ _ x) = f x go f (While _ x) = f x - go f (Comment _ x) = f x go f (Op op) = goOp f op go _ _ = mempty diff --git a/src/Futhark/CodeGen/ImpGen.hs b/src/Futhark/CodeGen/ImpGen.hs --- a/src/Futhark/CodeGen/ImpGen.hs +++ b/src/Futhark/CodeGen/ImpGen.hs @@ -48,6 +48,7 @@ lookupMemory, lookupAcc, askAttrs, + askProvenance, -- * Building Blocks TV, @@ -145,6 +146,7 @@ import Futhark.IR.Mem import Futhark.IR.Mem.LMAD qualified as LMAD import Futhark.IR.SOACS (SOACS) +import Futhark.Transform.Rename (renameLambda) import Futhark.Util import Futhark.Util.IntegralExp import Futhark.Util.Pretty hiding (nest, space) @@ -257,7 +259,10 @@ envFunction :: Maybe Name, -- | The set of attributes that are active on the enclosing -- statements (including the one we are currently compiling). - envAttrs :: Attrs + envAttrs :: Attrs, + -- | The provenance of whatever we are currently generating code for. This + -- can be used to insert information in the generated code. + envProvenance :: Provenance } newEnv :: r -> Operations rep r op -> Imp.Space -> Env rep r op @@ -272,7 +277,8 @@ envVolatility = Imp.Nonvolatile, envEnv = r, envFunction = Nothing, - envAttrs = mempty + envAttrs = mempty, + envProvenance = mempty } -- | The symbol table used during compilation. @@ -731,6 +737,12 @@ cb <- asks envStmsCompiler cb alive_after_stms all_stms m +attachProvenance :: Provenance -> Imp.Code op -> Imp.Code op +attachProvenance _ Imp.Skip = Imp.Skip +attachProvenance p c + | p == mempty = c + | otherwise = Imp.Meta (Imp.MetaProvenance p) <> c + defCompileStms :: (Mem rep inner, FreeIn op) => Names -> @@ -745,12 +757,13 @@ void $ compileStms' mempty $ stmsToList all_stms where compileStms' allocs (Let pat aux e : bs) = do - dVars (Just e) (patElems pat) - - e_code <- - localAttrs (stmAuxAttrs aux) $ - collect $ - compileExp pat e + e_code <- fmap (attachProvenance (stmAuxLoc aux)) + . localAttrs (stmAuxAttrs aux) + . collect + . localProvenance (stmAuxLoc aux) + $ do + dVars (Just e) (patElems pat) + compileExp pat e (live_after, bs_code) <- collect' $ compileStms' (patternAllocs pat <> allocs) bs let dies_here v = (v `notNameIn` live_after) && (v `nameIn` freeIn e_code) @@ -895,14 +908,15 @@ x' <- toExp x y' <- toExp y patElemName pe <~~ Imp.CmpOpExp bop x' y' -defCompileBasicOp _ (Assert e msg loc) = do +defCompileBasicOp _ (Assert e msg) = do e' <- toExp e msg' <- traverse toExp msg - emit $ Imp.Assert e' msg' loc + Imp.Provenance locs loc <- askProvenance + emit $ Imp.Assert e' msg' (loc, reverse locs) attrs <- askAttrs when (AttrComp "warn" ["safety_checks"] `inAttrs` attrs) $ - uncurry warn loc "Safety check required at run-time." + warn loc (reverse locs) "Safety check required at run-time." defCompileBasicOp (Pat [pe]) (Index src slice) | Just idxs <- sliceIndices slice = copyDWIM (patElemName pe) [] (Var src) $ map (DimFix . pe64) idxs @@ -981,11 +995,6 @@ defCompileBasicOp _ Reshape {} = pure () defCompileBasicOp _ (UpdateAcc safety acc is vs) = sComment "UpdateAcc" $ do - -- We are abusing the comment mechanism to wrap the operator in - -- braces when we end up generating code. This is necessary because - -- we might otherwise end up declaring lambda parameters (if any) - -- multiple times, as they are duplicated every time we do an - -- UpdateAcc for the same accumulator. let is' = map pe64 is -- We need to figure out whether we are updating a scatter-like @@ -1326,6 +1335,25 @@ localAttrs :: Attrs -> ImpM rep r op a -> ImpM rep r op a localAttrs attrs = local $ \env -> env {envAttrs = attrs <> envAttrs env} +-- | The provenance of whatever we are currently generating code for. +askProvenance :: ImpM rep r op Provenance +askProvenance = asks envProvenance + +-- | Wrap any code emitted in the enclosed section with the current provenance, +-- if any. +withProvenance :: ImpM rep r op () -> ImpM rep r op () +withProvenance m = do + p <- askProvenance + if p == mempty + then m + else do + c <- collect m + emit $ Imp.Meta (Imp.MetaProvenance p) <> c + +-- | Replace (*not* extend) the provenance while executing some action. +localProvenance :: Provenance -> ImpM rep r op a -> ImpM rep r op a +localProvenance p = local $ \env -> env {envProvenance = p} + localOps :: Operations rep r op -> ImpM rep r op a -> ImpM rep r op a localOps ops = local $ \env -> env @@ -1383,6 +1411,7 @@ -- | In the case of a histogram-like accumulator, also sets the index -- parameters. lookupAcc :: + (Mem rep inner) => VName -> [Imp.TExp Int64] -> ImpM rep r op (VName, Space, [VName], [Imp.TExp Int64], Maybe (Lambda rep)) @@ -1394,8 +1423,11 @@ case acc' of Just ([], _) -> error $ "Accumulator with no arrays: " ++ prettyString name - Just (arrs@(arr : _), Just (op, _)) -> do + Just (arrs@(arr : _), Just (op_orig, _)) -> do space <- lookupArraySpace arr + -- We must rename the lambda in order to avoid duplicate names in the + -- likely case where the accumulator is used multiple times. + op <- renameLambda op_orig let (i_params, ps) = splitAt (length is) $ lambdaParams op zipWithM_ dPrimV_ (map paramName i_params) is pure @@ -1478,7 +1510,7 @@ srclmad = memLocLMAD srcloc srcspace <- entryMemSpace <$> lookupMemory srcmem dstspace <- entryMemSpace <$> lookupMemory dstmem - emit $ + withProvenance . emit $ Imp.Copy t (elements <$> LMAD.shape dstlmad) @@ -1733,11 +1765,11 @@ emit $ Imp.While cond body' -- | Execute a code generation action, wrapping the generated code --- within a 'Imp.Comment' with the given description. +-- within a 'Imp.MetaComment' with the given description. sComment :: T.Text -> ImpM rep r op () -> ImpM rep r op () sComment s code = do code' <- collect code - emit $ Imp.Comment s code' + emit $ Imp.Meta (Imp.MetaComment s) <> code' sIf :: Imp.TExp Bool -> ImpM rep r op () -> ImpM rep r op () -> ImpM rep r op () sIf cond tbranch fbranch = do 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 @@ -146,30 +146,38 @@ case safety of Safe -> sWhen (inBounds (Slice (map DimFix is')) dims) _ -> id - boundsCheck $ - case op of - Nothing -> - forM_ (zip arrs vs) $ \(arr, v) -> copyDWIMFix arr is' v [] - Just lam -> do - dLParams $ lambdaParams lam - let (_x_params, y_params) = - splitAt (length vs) $ map paramName $ lambdaParams lam - forM_ (zip y_params vs) $ \(yp, v) -> copyDWIM yp [] v [] - atomics <- kernelAtomics <$> askEnv - case atomicUpdateLocking atomics lam of - AtomicPrim f -> f space arrs is' - AtomicCAS f -> f space arrs is' - AtomicLocking f -> do - c_locks <- M.lookup c . kernelLocks <$> askEnv - case c_locks of - Just (Locks locks num_locks) -> do - let locking = - Locking locks 0 1 0 $ - pure . (`rem` fromIntegral num_locks) . flattenIndex dims - f locking space arrs is' - Nothing -> - error $ "Missing locks for " ++ prettyString acc + boundsCheck $ case op of + Nothing -> + forM_ (zip arrs vs) $ \(arr, v) -> copyDWIMFix arr is' v [] + Just lam -> do + dLParams $ lambdaParams lam + let (x_params, y_params) = + splitAt (length vs) $ map paramName $ lambdaParams lam + forM_ (zip y_params vs) $ \(yp, v) -> copyDWIM yp [] v [] + atomics <- kernelAtomics <$> askEnv + case (space, atomicUpdateLocking atomics lam) of + (ScalarSpace {}, _) -> do + -- In this case we are dealing with an array that simply cannot be + -- shared, and so we do not (and should not) use an atomic. Ideally, + -- such cases are optimised away before code generation. + forM_ (zip x_params arrs) $ \(xp, arr) -> copyDWIMFix xp [] (Var arr) is' + compileBody' mempty $ lambdaBody lam + forM_ (zip arrs $ bodyResult $ lambdaBody lam) $ \(arr, r) -> + copyDWIMFix arr is' (resSubExp r) [] + (_, AtomicPrim f) -> f space arrs is' + (_, AtomicCAS f) -> f space arrs is' + (_, AtomicLocking f) -> do + c_locks <- M.lookup c . kernelLocks <$> askEnv + case c_locks of + Just (Locks locks num_locks) -> do + let locking = + Locking locks 0 1 0 $ + pure . (`rem` fromIntegral num_locks) . flattenIndex dims + f locking space arrs is' + Nothing -> + error $ "Missing locks for " ++ prettyString acc + -- | Generate a constant device array of 32-bit integer zeroes with -- the given number of elements. Initialised with a replicate. genZeroes :: String -> Int -> CallKernelGen VName @@ -893,17 +901,9 @@ -- While-loop: Try to insert your value let (toBits, fromBits) = case t of - FloatType Float16 -> - ( \v -> Imp.FunExp "to_bits16" [v] int16, - \v -> Imp.FunExp "from_bits16" [v] t - ) - FloatType Float32 -> - ( \v -> Imp.FunExp "to_bits32" [v] int32, - \v -> Imp.FunExp "from_bits32" [v] t - ) - FloatType Float64 -> - ( \v -> Imp.FunExp "to_bits64" [v] int64, - \v -> Imp.FunExp "from_bits64" [v] t + FloatType ft -> + ( Imp.ConvOpExp (FPToBits ft), + Imp.ConvOpExp (BitsToFP ft) ) _ -> (id, id) @@ -1239,6 +1239,11 @@ body <- makeAllMemoryGlobal $ subImpM_ (KernelEnv atomics 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 + -- to somewhere in /prelude), so try to synthesize it from the body instead. + -- It may be that we should do this earlier in the compiler. + let p = Imp.foldProvenances (const mempty) body + when (p /= mempty) $ emit $ Imp.Meta $ Imp.MetaProvenance p emit . Imp.Op . Imp.CallKernel $ Imp.Kernel { Imp.kernelBody = body, 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 @@ -578,6 +578,7 @@ compileBlockOp pat _ = compilerBugS $ "compileBlockOp: cannot compile rhs of binding " ++ prettyString pat +-- | The operations for block-level kernels. blockOperations :: Operations GPUMem KernelEnv Imp.KernelOp blockOperations = (defaultOperations compileBlockOp) @@ -598,6 +599,7 @@ _ -> pure False arrayInSharedMemory Constant {} = pure False +-- | Create a kernel with GPU operations at the block level. sKernelBlock :: String -> VName -> @@ -606,6 +608,8 @@ CallKernelGen () sKernelBlock = sKernel blockOperations $ sExt64 . kernelBlockId +-- | Generate code for writing this result of a block-level kernel. The +-- 'PatElem' and 'KernelResult' must be matched as in the original segop. compileBlockResult :: SegSpace -> PatElem LetDecMem -> 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 @@ -194,7 +194,6 @@ codeMayFail f (For _ _ x) = codeMayFail f x codeMayFail f (While _ x) = codeMayFail f x codeMayFail f (If _ x y) = codeMayFail f x || codeMayFail f y -codeMayFail f (Comment _ x) = codeMayFail f x codeMayFail _ _ = False hostOpMayFail :: ImpGPU.HostOp -> Bool @@ -382,7 +381,6 @@ then (SafetyNone, []) else -- No possible failures in this kernel, so if we make -- it past an initial check, then we are good to go. - ( SafetyCheap, [C.citems|if (*global_failure >= 0) { return; }|] ) @@ -663,7 +661,8 @@ pure [C.cty|$tyquals:(volatile++quals) $ty:t|] atomicSpace (Space sid) = sid - atomicSpace _ = "global" + atomicSpace ScalarSpace {} = error "atomicSpace: cannot do atomics on ScalarSpace" + atomicSpace DefaultSpace = "global" doAtomic s t old arr ind val op ty = do ind' <- GC.compileExp $ untyped $ unCount ind @@ -896,7 +895,7 @@ typesInCode (If (TPrimExp e) c1 c2) = typesInExp e <> typesInCode c1 <> typesInCode c2 typesInCode (Assert e _ _) = typesInExp e -typesInCode (Comment _ c) = typesInCode c +typesInCode (Meta _) = mempty typesInCode (DebugPrint _ v) = maybe mempty typesInExp v typesInCode (TracePrint msg) = foldMap typesInExp msg typesInCode Op {} = mempty diff --git a/src/Futhark/CodeGen/ImpGen/Multicore.hs b/src/Futhark/CodeGen/ImpGen/Multicore.hs --- a/src/Futhark/CodeGen/ImpGen/Multicore.hs +++ b/src/Futhark/CodeGen/ImpGen/Multicore.hs @@ -155,9 +155,12 @@ s <- segOpString op let seq_task = Imp.ParallelTask seq_code free_params <- filter (`notElem` retvals) <$> freeParams (par_task, seq_task) - emit . Imp.Op $ - Imp.SegOp s free_params seq_task par_task retvals $ - scheduling_info (decideScheduling' op seq_code) + let code = + Imp.Op $ + Imp.SegOp s free_params seq_task par_task retvals $ + scheduling_info (decideScheduling' op seq_code) + emit $ Imp.Meta $ Imp.MetaProvenance $ taskProvenance code + emit code compileSegOp :: Pat LetDecMem -> diff --git a/src/Futhark/CodeGen/ImpGen/Multicore/Base.hs b/src/Futhark/CodeGen/ImpGen/Multicore/Base.hs --- a/src/Futhark/CodeGen/ImpGen/Multicore/Base.hs +++ b/src/Futhark/CodeGen/ImpGen/Multicore/Base.hs @@ -26,11 +26,11 @@ inISPC, toParam, sLoopNestVectorized, + taskProvenance, ) where import Control.Monad -import Data.Bifunctor import Data.Map qualified as M import Data.Maybe import Futhark.CodeGen.ImpCode.Multicore qualified as Imp @@ -151,7 +151,6 @@ isLoadBalanced (a Imp.:>>: b) = isLoadBalanced a && isLoadBalanced b isLoadBalanced (Imp.For _ _ a) = isLoadBalanced a isLoadBalanced (Imp.If _ a b) = isLoadBalanced a && isLoadBalanced b -isLoadBalanced (Imp.Comment _ a) = isLoadBalanced a isLoadBalanced Imp.While {} = False isLoadBalanced (Imp.Op (Imp.ParLoop _ code _)) = isLoadBalanced code isLoadBalanced (Imp.Op (Imp.ForEachActive _ a)) = isLoadBalanced a @@ -189,8 +188,6 @@ (mempty, Imp.While cond body) f (Imp.For i bound body) = (mempty, Imp.For i bound body) - f (Imp.Comment s code) = - second (Imp.Comment s) (f code) f Imp.Free {} = mempty f (Imp.If cond tcode fcode) = @@ -491,17 +488,9 @@ bytes <- toIntegral $ primBitSize t let (toBits, fromBits) = case t of - FloatType Float16 -> - ( \v -> Imp.FunExp "to_bits16" [v] int16, - \v -> Imp.FunExp "from_bits16" [v] t - ) - FloatType Float32 -> - ( \v -> Imp.FunExp "to_bits32" [v] int32, - \v -> Imp.FunExp "from_bits32" [v] t - ) - FloatType Float64 -> - ( \v -> Imp.FunExp "to_bits64" [v] int64, - \v -> Imp.FunExp "from_bits64" [v] t + FloatType ft -> + ( Imp.ConvOpExp (FPToBits ft), + Imp.ConvOpExp (BitsToFP ft) ) _ -> (id, id) @@ -544,3 +533,17 @@ toIntegral 32 = pure int32 toIntegral 64 = pure int64 toIntegral b = error $ "number of bytes is not supported for CAS - " ++ prettyString b + +-- | Find the provenance of a task given its body. This is done by folding the +-- provenance of the code in the body. +taskProvenance :: Imp.MCCode -> Provenance +taskProvenance = Imp.foldProvenances onOp + where + onOp (Imp.ParLoop _ code _) = taskProvenance code + onOp (Imp.SegOp _ _ task1 task2 _ _) = + onTask task1 <> maybe mempty onTask task2 + onOp (Imp.ISPCKernel code _) = taskProvenance code + onOp (Imp.ForEach _ _ _ code) = taskProvenance code + onOp (Imp.ForEachActive _ code) = taskProvenance code + onOp _ = mempty + onTask (Imp.ParallelTask code) = taskProvenance code diff --git a/src/Futhark/CodeGen/ImpGen/Multicore/SegScan.hs b/src/Futhark/CodeGen/ImpGen/Multicore/SegScan.hs --- a/src/Futhark/CodeGen/ImpGen/Multicore/SegScan.hs +++ b/src/Futhark/CodeGen/ImpGen/Multicore/SegScan.hs @@ -1,3 +1,5 @@ +-- | Multicore code generation for SegScan. Uses a fairly naive multipass +-- algorithm, with no particular locality optimisations. module Futhark.CodeGen.ImpGen.Multicore.SegScan ( compileSegScan, ) @@ -12,7 +14,7 @@ import Futhark.Util.IntegralExp (quot, rem) import Prelude hiding (quot, rem) --- Compile a SegScan construct +-- | Compile a SegScan construct. compileSegScan :: Pat LetDecMem -> SegSpace -> diff --git a/src/Futhark/Compiler/Program.hs b/src/Futhark/Compiler/Program.hs --- a/src/Futhark/Compiler/Program.hs +++ b/src/Futhark/Compiler/Program.hs @@ -46,9 +46,9 @@ import Futhark.Util (interactWithFileSafely, nubOrd, startupTime) import Futhark.Util.Pretty (Doc, align, pretty) import Language.Futhark qualified as E +import Language.Futhark.Core (isBuiltin) import Language.Futhark.Parser (SyntaxError (..), parseFuthark) import Language.Futhark.Prelude -import Language.Futhark.Prop (isBuiltin) import Language.Futhark.Semantic import Language.Futhark.TypeChecker qualified as E import Language.Futhark.Warnings 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 @@ -380,10 +380,10 @@ StmAux (ExpDec rep) -> Exp (Aliases rep) -> Stm (Aliases rep) -mkAliasedStm pat (StmAux cs attrs dec) e = +mkAliasedStm pat aux e = Let (mkAliasedPat pat e) - (StmAux cs attrs (AliasDec $ consumedInExp e, dec)) + (fmap (AliasDec (consumedInExp e),) aux) e instance diff --git a/src/Futhark/IR/Mem/Simplify.hs b/src/Futhark/IR/Mem/Simplify.hs --- a/src/Futhark/IR/Mem/Simplify.hs +++ b/src/Futhark/IR/Mem/Simplify.hs @@ -105,7 +105,7 @@ -- the certificates on it. This can help hoist things that would -- otherwise be stuck inside loops or branches. decertifySafeAlloc :: (SimplifyMemory rep inner) => TopDownRuleOp (Wise rep) -decertifySafeAlloc _ pat (StmAux cs attrs _) op +decertifySafeAlloc _ pat (StmAux cs attrs _ _) op | cs /= mempty, [Mem _] <- patTypes pat, safeOp op = 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 @@ -27,6 +27,7 @@ import Data.Functor import Data.List (singleton) import Data.List.NonEmpty (NonEmpty (..)) +import Data.Loc qualified as L import Data.Maybe import Data.Set qualified as S import Data.Text qualified as T @@ -238,12 +239,31 @@ pErrorMsg :: Parser (ErrorMsg SubExp) pErrorMsg = ErrorMsg <$> braces (pErrorMsgPart `sepBy` pComma) -pSrcLoc :: Parser SrcLoc -pSrcLoc = pStringLiteral $> mempty -- FIXME +lInt :: Parser Int +lInt = lexeme L.decimal -pErrorLoc :: Parser (SrcLoc, [SrcLoc]) -pErrorLoc = (,mempty) <$> pSrcLoc +pPos :: Parser L.Pos +pPos = + L.Pos + <$> manyTill L.charLiteral (char ':') + <*> lInt + <*> (char ':' *> lInt) + <*> pure (-1) -- Cannot recover offset. +pLocStr :: Parser Loc +pLocStr = do + start <- pPos + void $ char '-' + end <- do + x <- lInt + choice + [ do + y <- char ':' *> lInt + pure $ L.Pos (L.posFile start) x y (-1), + pure $ L.Pos (L.posFile start) (L.posLine start) x (-1) + ] + pure $ L.Loc start end + pIota :: Parser BasicOp pIota = choice $ map p allIntTypes @@ -274,15 +294,7 @@ $> uncurry (Opaque . OpaqueTrace) <*> parens ((,) <$> pStringLiteral <* pComma <*> pSubExp), keyword "copy" $> Replicate mempty . Var <*> parens pVName, - keyword "assert" - *> parens - ( Assert - <$> pSubExp - <* pComma - <*> pErrorMsg - <* pComma - <*> pErrorLoc - ), + keyword "assert" *> parens (Assert <$> pSubExp <* pComma <*> pErrorMsg), keyword "replicate" *> parens (Replicate <$> pShape <* pComma <*> pSubExp), keyword "reshape" @@ -341,6 +353,8 @@ pConvOp "btoi" (const BToI) (keyword "bool") pIntType, pConvOp "ftob" (const . FToB) pFloatType (keyword "bool"), pConvOp "btof" (const BToF) (keyword "bool") pFloatType, + pConvOp "fptobits" (const . FPToBits) pFloatType pIntType, + pConvOp "bitstofp" (const BitsToFP) pIntType pFloatType, -- pIndex, pFlatIndex, @@ -485,7 +499,7 @@ <*> parens (pArg `sepBy` pComma) <* pColon <*> pRetTypes pr - <*> pure (safety, mempty, mempty) + <*> pure safety pArg = choice @@ -587,11 +601,21 @@ pSubExpRes :: Parser SubExpRes pSubExpRes = SubExpRes <$> pCerts <*> pSubExp +pProvenance :: Parser Provenance +pProvenance = + choice + [ lexeme $ between (char '"') (char '"') $ do + l <- pLocStr `sepBy1` "->" + pure $ Provenance (init l) (last l), + pure mempty + ] + pStm :: PR rep -> Parser (Stm rep) -pStm pr = - keyword "let" $> Let <*> pPat pr <* pEqual <*> pStmAux <*> pExp pr +pStm pr = do + loc <- pProvenance + keyword "let" $> Let <*> pPat pr <* pEqual <*> pStmAux loc <*> pExp pr where - pStmAux = flip StmAux <$> pAttrs <*> pCerts <*> pure (pExpDec pr) + pStmAux loc = flip StmAux <$> pAttrs <*> pCerts <*> pure loc <*> pure (pExpDec pr) pStms :: PR rep -> Parser (Stms rep) pStms pr = stmsFromList <$> many (pStm pr) 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 @@ -148,9 +148,15 @@ instance Pretty Attrs where pretty = hsep . attrAnnots +prettyLoc :: Loc -> Doc a +prettyLoc = pretty . locText + +instance Pretty Provenance where + pretty (Provenance locs loc) = mconcat $ punctuate "->" $ map prettyLoc $ locs ++ [loc] + instance (Pretty dec) => Pretty (StmAux dec) where - pretty (StmAux cs attrs dec) = - braces $ mconcat $ punctuate semi [pretty cs, pretty attrs, pretty dec] + pretty (StmAux cs attrs p dec) = + braces $ mconcat $ punctuate semi [pretty cs, pretty attrs, pretty p, pretty dec] instance (Pretty t) => Pretty (Pat t) where pretty (Pat xs) = braces $ commastack $ map pretty xs @@ -164,13 +170,18 @@ instance (PrettyRep rep) => Pretty (Stm rep) where pretty stm@(Let pat aux e) = - align . hang 2 $ + (locstr <>) . align . hang 2 $ "let" <+> align (pretty pat) <+> case stmannot of [] -> equals pretty e _ -> equals (stack stmannot pretty e) where + locstr = + if stmAuxLoc aux == mempty + then mempty + else dquotes (pretty (stmAuxLoc aux)) <> line + stmannot = concat [ maybeToList (ppExpDec (stmAuxDec aux) e), @@ -243,8 +254,8 @@ "concat" <> "@" <> pretty i <> apply (pretty w : pretty x : map pretty xs) pretty (Manifest v perm) = "manifest" <> apply [pretty v, apply (map pretty perm)] - pretty (Assert e msg (loc, _)) = - "assert" <> apply [pretty e, pretty msg, pretty $ show $ locStr loc] + pretty (Assert e msg) = + "assert" <> apply [pretty e, pretty msg] pretty (UpdateAcc safety acc is v) = update_acc_str <> apply @@ -312,12 +323,12 @@ MatchFallback -> " " MatchEquiv -> " " pretty (BasicOp op) = pretty op - pretty (Apply fname args ret (safety, _, _)) = + pretty (Apply fname args ret safety) = applykw <+> pretty (nameToString fname) <> apply (map (align . prettyArg) args) colon - <+> braces (commasep $ map prettyRet ret) + <+> braces (align $ commasep $ map prettyRet ret) where prettyArg (arg, Consume) = "*" <> pretty arg prettyArg (arg, _) = pretty arg 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 @@ -28,6 +28,7 @@ defAux, stmCerts, certify, + attribute, expExtTypesFromPat, attrsForAssert, lamIsBinOp, @@ -167,7 +168,7 @@ -- | A 'StmAux' with empty 'Certs'. defAux :: dec -> StmAux dec -defAux = StmAux mempty mempty +defAux = StmAux mempty mempty mempty -- | The certificates associated with a statement. stmCerts :: Stm rep -> Certs @@ -175,8 +176,13 @@ -- | Add certificates to a statement. certify :: Certs -> Stm rep -> Stm rep -certify cs1 (Let pat (StmAux cs2 attrs dec) e) = - Let pat (StmAux (cs2 <> cs1) attrs dec) e +certify cs1 (Let pat aux e) = + Let pat (aux {stmAuxCerts = stmAuxCerts aux <> cs1}) e + +-- | Add attributes to a statement. +attribute :: Attrs -> Stm rep -> Stm rep +attribute attrs (Let pat aux e) = + Let pat (aux {stmAuxAttrs = stmAuxAttrs aux <> attrs}) e -- | A handy shorthand for properties that we usually want for things -- we stuff into ASTs. diff --git a/src/Futhark/IR/Prop/Names.hs b/src/Futhark/IR/Prop/Names.hs --- a/src/Futhark/IR/Prop/Names.hs +++ b/src/Futhark/IR/Prop/Names.hs @@ -307,7 +307,7 @@ ) => FreeIn (Stm rep) where - freeIn' (Let pat (StmAux cs attrs dec) e) = + freeIn' (Let pat (StmAux cs attrs _ dec) e) = freeIn' cs <> freeIn' attrs <> precomputed dec (freeIn' dec <> freeIn' e <> freeIn' pat) @@ -399,7 +399,7 @@ freeIn' (Attrs _) = mempty instance (FreeIn dec) => FreeIn (StmAux dec) where - freeIn' (StmAux cs attrs dec) = freeIn' cs <> freeIn' attrs <> freeIn' dec + freeIn' (StmAux cs attrs _ dec) = freeIn' cs <> freeIn' attrs <> freeIn' dec instance (FreeIn a) => FreeIn (MatchDec a) where freeIn' (MatchDec r _) = freeIn' r diff --git a/src/Futhark/IR/Prop/Types.hs b/src/Futhark/IR/Prop/Types.hs --- a/src/Futhark/IR/Prop/Types.hs +++ b/src/Futhark/IR/Prop/Types.hs @@ -12,6 +12,7 @@ staticShapes1, primType, isAcc, + isMem, arrayOf, arrayOfRow, arrayOfShape, @@ -297,6 +298,11 @@ isAcc :: TypeBase shape u -> Bool isAcc Acc {} = True isAcc _ = False + +-- | Is this a memory block? +isMem :: TypeBase shape u -> Bool +isMem Mem {} = True +isMem _ = False -- | Returns the bottommost type of an array. For @[][]i32@, this -- would be @i32@. If the given type is not an array, it is returned. diff --git a/src/Futhark/IR/Rephrase.hs b/src/Futhark/IR/Rephrase.hs --- a/src/Futhark/IR/Rephrase.hs +++ b/src/Futhark/IR/Rephrase.hs @@ -56,10 +56,10 @@ -- | Rephrase a statement. rephraseStm :: (Monad m) => Rephraser m from to -> Stm from -> m (Stm to) -rephraseStm rephraser (Let pat (StmAux cs attrs dec) e) = +rephraseStm rephraser (Let pat aux e) = Let <$> rephrasePat (rephraseLetBoundDec rephraser) pat - <*> (StmAux cs attrs <$> rephraseExpDec rephraser dec) + <*> traverse (rephraseExpDec rephraser) aux <*> rephraseExp rephraser e -- | Rephrase a pattern. diff --git a/src/Futhark/IR/Syntax.hs b/src/Futhark/IR/Syntax.hs --- a/src/Futhark/IR/Syntax.hs +++ b/src/Futhark/IR/Syntax.hs @@ -204,16 +204,27 @@ data StmAux dec = StmAux { stmAuxCerts :: !Certs, stmAuxAttrs :: Attrs, + stmAuxLoc :: Provenance, stmAuxDec :: dec } deriving (Ord, Show, Eq) +instance Functor StmAux where + fmap = fmapDefault + +instance Foldable StmAux where + foldMap = foldMapDefault + +instance Traversable StmAux where + traverse f (StmAux cs attrs loc dec) = + StmAux cs attrs loc <$> f dec + instance (Monoid dec) => Monoid (StmAux dec) where - mempty = StmAux mempty mempty mempty + mempty = StmAux mempty mempty mempty mempty instance (Semigroup dec) => Semigroup (StmAux dec) where - StmAux cs1 attrs1 dec1 <> StmAux cs2 attrs2 dec2 = - StmAux (cs1 <> cs2) (attrs1 <> attrs2) (dec1 <> dec2) + StmAux cs1 attrs1 loc1 dec1 <> StmAux cs2 attrs2 loc2 dec2 = + StmAux (cs1 <> cs2) (attrs1 <> attrs2) (loc1 <> loc2) (dec1 <> dec2) -- | A local variable binding. data Stm rep = Let @@ -376,9 +387,10 @@ CmpOp CmpOp SubExp SubExp | -- | Conversion "casting". ConvOp ConvOp SubExp - | -- | Turn a boolean into a certificate, halting the program with the - -- given error message if the boolean is false. - Assert SubExp (ErrorMsg SubExp) (SrcLoc, [SrcLoc]) + | -- | Turn a boolean into a certificate, halting the program with the given + -- error message if the boolean is false. The error location comes from the + -- provenance of the statement. + Assert SubExp (ErrorMsg SubExp) | -- | The certificates for bounds-checking are part of the 'Stm'. Index VName (Slice SubExp) | -- | An in-place update of the given array at the given position. @@ -472,7 +484,7 @@ data Exp rep = -- | A simple (non-recursive) operation. BasicOp BasicOp - | Apply Name [(SubExp, Diet)] [(RetType rep, RetAls)] (Safety, SrcLoc, [SrcLoc]) + | Apply Name [(SubExp, Diet)] [(RetType rep, RetAls)] Safety | -- | A match statement picks a branch by comparing the given -- subexpressions (called the /scrutinee/) with the pattern in -- each of the cases. If none of the cases match, the /default @@ -608,3 +620,25 @@ progFuns :: [FunDef rep] } deriving (Eq, Ord, Show) + +-- Note [Tracking Source Locations] +-- +-- It is useful for such things as profiling to be able to relate the generated +-- code to the original source code. The Futhark compiler is not great at this, +-- but we have begun to try a bit. +-- +-- Each 'Stm' is associated with a 'Provenance', which keeps information about +-- the (single) source expression that gave rise to the statement. This is by +-- itself not challenging (although a single source expression can give rise to +-- multiple core expressions). The real challenge is how to propagate this +-- information when the compiler starts rewriting the program, without every +-- rewrite having to be laboriously aware of provenances. In practice, we stick +-- it in the StmAux and hope that consistent use of such constructs as 'auxing' +-- will mostly do the right thing. +-- +-- Another downside of our representation is that it is not flow-sensitive: an +-- expression can be reached in multiple ways and generally the innermost one is +-- picked. This is particularly problematic for the prelude functions (e.g. +-- f32.exp), as it is not exceptionally useful when the provenance simply points +-- at a file in /prelude. We could address this by just special casing /prelude, +-- but that won't help when users write their own libraries. diff --git a/src/Futhark/IR/Syntax/Core.hs b/src/Futhark/IR/Syntax/Core.hs --- a/src/Futhark/IR/Syntax/Core.hs +++ b/src/Futhark/IR/Syntax/Core.hs @@ -73,6 +73,10 @@ FlatDimIndex (..), flatSliceDims, flatSliceStrides, + + -- * Provenance + Provenance (..), + stackProvenance, ) where @@ -82,12 +86,14 @@ import Data.Bifoldable import Data.Bifunctor import Data.Bitraversable +import Data.Loc (locEnd, locStart) import Data.Map.Strict qualified as M import Data.Maybe import Data.Set qualified as S import Data.String import Data.Text qualified as T import Data.Traversable (fmapDefault, foldMapDefault) +import Futhark.Util (splitFromEnd) import Language.Futhark.Core import Language.Futhark.Primitive import Prelude hiding (id, (.)) @@ -642,3 +648,37 @@ instance Semigroup OpaqueTypes where OpaqueTypes x <> OpaqueTypes y = OpaqueTypes $ x <> filter ((`notElem` map fst x) . fst) y + +-- | Information about what in the original program a given IR statement +-- corresponds to. See Note [Tracking Source Locations]. +data Provenance = Provenance [Loc] Loc + deriving (Eq, Ord, Show) + +contains :: Loc -> Loc -> Bool +contains l1 l2 = locStart l1 <= locStart l2 && locEnd l1 >= locEnd l2 + +clean :: [Loc] -> [Loc] +clean (l : ls) | l == mempty = clean ls +clean (l1 : l2 : ls) + -- Remove locations that completely enclose a successive location. This is to + -- remove locations that correspond to lambdas that are immediately applied - + -- they are pretty boring and just add clutter. + | l1 `contains` l2 = clean $ l2 : ls + | otherwise = l1 : clean (l2 : ls) +clean ls = ls + +stackProvenance :: Provenance -> Provenance -> Provenance +stackProvenance (Provenance xs x) (Provenance ys y) = + case splitFromEnd 1 $ clean $ xs <> [x] <> ys <> [y] of + (zs', [z']) -> Provenance zs' z' + _ -> mempty -- Zero-information case. + +instance Monoid Provenance where + mempty = Provenance mempty mempty + +instance Semigroup Provenance where + Provenance xs x <> Provenance ys y + | y == mempty = Provenance xs x + | x == mempty = Provenance ys y + | xs == ys = Provenance xs (x <> y) + | otherwise = Provenance ys y 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 @@ -113,10 +113,10 @@ <*> (MatchDec <$> mapM (mapOnBranchType tv) ts <*> pure s) where mapOnCase (Case vs body) = Case vs <$> mapOnBody tv mempty body -mapExpM tv (Apply fname args ret loc) = do +mapExpM tv (Apply fname args ret safety) = do args' <- forM args $ \(arg, d) -> (,) <$> mapOnSubExp tv arg <*> pure d - Apply fname args' <$> mapM (bitraverse (mapOnRetType tv) pure) ret <*> pure loc + Apply fname args' <$> mapM (bitraverse (mapOnRetType tv) pure) ret <*> pure safety mapExpM tv (BasicOp (Index arr slice)) = BasicOp <$> ( Index @@ -164,8 +164,8 @@ pure $ BasicOp $ Concat i (x' :| ys') size' mapExpM tv (BasicOp (Manifest v perm)) = BasicOp <$> (Manifest <$> mapOnVName tv v <*> pure perm) -mapExpM tv (BasicOp (Assert e msg loc)) = - BasicOp <$> (Assert <$> mapOnSubExp tv e <*> traverse (mapOnSubExp tv) msg <*> pure loc) +mapExpM tv (BasicOp (Assert e msg)) = + BasicOp <$> (Assert <$> mapOnSubExp tv e <*> traverse (mapOnSubExp tv) msg) mapExpM tv (BasicOp (Opaque op e)) = BasicOp <$> (Opaque op <$> mapOnSubExp tv e) mapExpM tv (BasicOp (UpdateAcc safety v is ses)) = @@ -327,7 +327,7 @@ walkOnVName tv x >> mapM_ (walkOnVName tv) ys >> walkOnSubExp tv size walkExpM tv (BasicOp (Manifest v _)) = walkOnVName tv v -walkExpM tv (BasicOp (Assert e msg _)) = +walkExpM tv (BasicOp (Assert e msg)) = walkOnSubExp tv e >> traverse_ (walkOnSubExp tv) msg walkExpM tv (BasicOp (Opaque _ e)) = walkOnSubExp tv e 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 @@ -940,7 +940,7 @@ require [Prim int64] ressize checkBasicOp (Manifest arr perm) = checkBasicOp $ Rearrange arr perm -- Basically same thing! -checkBasicOp (Assert e (ErrorMsg parts) _) = do +checkBasicOp (Assert e (ErrorMsg parts)) = do require [Prim Bool] e mapM_ checkPart parts where @@ -1257,7 +1257,9 @@ Stm (Aliases rep) -> TypeM rep a -> TypeM rep a -checkStm stm@(Let pat (StmAux (Certs cs) _ (_, dec)) e) m = do +checkStm stm@(Let pat aux e) m = do + let Certs cs = stmAuxCerts aux + (_, dec) = stmAuxDec aux context "When checking certificates" $ mapM_ (requireI [Prim Unit]) cs context "When checking expression annotation" $ checkExpDec dec context ("When matching\n" <> message " " pat <> "\nwith\n" <> message " " e) $ diff --git a/src/Futhark/Internalise/AccurateSizes.hs b/src/Futhark/Internalise/AccurateSizes.hs --- a/src/Futhark/Internalise/AccurateSizes.hs +++ b/src/Futhark/Internalise/AccurateSizes.hs @@ -51,61 +51,56 @@ ensureResultShape :: ErrorMsg SubExp -> - SrcLoc -> [Type] -> Result -> InternaliseM Result -ensureResultShape msg loc = - ensureResultExtShape msg loc . staticShapes +ensureResultShape msg = + ensureResultExtShape msg . staticShapes ensureResultExtShape :: ErrorMsg SubExp -> - SrcLoc -> [ExtType] -> Result -> InternaliseM Result -ensureResultExtShape msg loc rettype res = do - res' <- ensureResultExtShapeNoCtx msg loc rettype res +ensureResultExtShape msg rettype res = do + res' <- ensureResultExtShapeNoCtx msg rettype res ts <- mapM subExpResType res' let ctx = extractShapeContext rettype $ map arrayDims ts pure $ subExpsRes ctx ++ res' ensureResultExtShapeNoCtx :: ErrorMsg SubExp -> - SrcLoc -> [ExtType] -> Result -> InternaliseM Result -ensureResultExtShapeNoCtx msg loc rettype es = do +ensureResultExtShapeNoCtx msg rettype es = do es_ts <- mapM subExpResType es let ext_mapping = shapeExtMapping rettype es_ts rettype' = foldr (uncurry fixExt) rettype $ M.toList ext_mapping assertProperShape t (SubExpRes cs se) = let name = "result_proper_shape" - in SubExpRes cs <$> ensureExtShape msg loc t name se + in SubExpRes cs <$> ensureExtShape msg t name se zipWithM assertProperShape rettype' es ensureExtShape :: ErrorMsg SubExp -> - SrcLoc -> ExtType -> String -> SubExp -> InternaliseM SubExp -ensureExtShape msg loc t name orig +ensureExtShape msg t name orig | Array {} <- t, Var v <- orig = - Var <$> ensureShapeVar msg loc t name v + Var <$> ensureShapeVar msg t name v | otherwise = pure orig ensureShape :: ErrorMsg SubExp -> - SrcLoc -> Type -> String -> SubExp -> InternaliseM SubExp -ensureShape msg loc = ensureExtShape msg loc . staticShapes1 +ensureShape msg = ensureExtShape msg . staticShapes1 -- | Reshape the arguments to a function so that they fit the expected -- shape declarations. Not used to change rank of arguments. Assumes @@ -113,28 +108,26 @@ ensureArgShapes :: (Typed (TypeBase Shape u)) => ErrorMsg SubExp -> - SrcLoc -> [VName] -> [TypeBase Shape u] -> [SubExp] -> InternaliseM [SubExp] -ensureArgShapes msg loc shapes paramts args = +ensureArgShapes msg shapes paramts args = zipWithM ensureArgShape (expectedTypes shapes paramts args) args where ensureArgShape _ (Constant v) = pure $ Constant v ensureArgShape t (Var v) | arrayRank t < 1 = pure $ Var v | otherwise = - ensureShape msg loc t (baseString v) $ Var v + ensureShape msg t (baseString v) $ Var v ensureShapeVar :: ErrorMsg SubExp -> - SrcLoc -> ExtType -> String -> VName -> InternaliseM VName -ensureShapeVar msg loc t name v +ensureShapeVar msg t name v | Array {} <- t = do newdims <- arrayDims . removeExistentials t <$> lookupType v olddims <- arrayDims <$> lookupType v @@ -143,7 +136,7 @@ else do matches <- zipWithM checkDim newdims olddims all_match <- letSubExp "match" =<< eAll matches - cs <- assert "empty_or_match_cert" all_match msg loc + cs <- assert "empty_or_match_cert" all_match msg certifying cs $ letExp name $ shapeCoerce newdims v | otherwise = pure v where diff --git a/src/Futhark/Internalise/Defunctionalise.hs b/src/Futhark/Internalise/Defunctionalise.hs --- a/src/Futhark/Internalise/Defunctionalise.hs +++ b/src/Futhark/Internalise/Defunctionalise.hs @@ -738,7 +738,7 @@ (pats, body, tp) <- etaExpand (RetType [] $ toRes Nonunique $ typeOf e) e let env = foldMap envFromPat pats body' <- localEnv env $ defuncExp' body - pure $ Lambda pats body' Nothing (Info tp) mempty + pure $ Lambda pats body' Nothing (Info tp) (srclocOf e) | otherwise = defuncExp' e etaExpand :: ResRetType -> Exp -> DefM ([Pat ParamType], Exp, ResRetType) @@ -910,11 +910,11 @@ liftedName _ _ = "defunc" defuncApplyArg :: - String -> + (String, SrcLoc) -> (Exp, StaticVal) -> ((Maybe VName, Exp), [ParamType]) -> DefM (Exp, StaticVal) -defuncApplyArg fname_s (f', LambdaSV pat lam_e_t lam_e closure_env) ((argext, arg), _) = do +defuncApplyArg (fname_s, floc) (f', LambdaSV pat lam_e_t lam_e closure_env) ((argext, arg), _) = do (arg', arg_sv) <- defuncExp arg let env' = alwaysMatchPatSV pat arg_sv dims = mempty @@ -961,7 +961,7 @@ let f_t = toStruct $ typeOf f' arg_t = toStruct $ typeOf arg' fname_t = foldFunType [toParam Observe f_t, toParam (diet (patternType pat)) arg_t] lifted_rettype - fname' = Var (qualName fname) (Info fname_t) (srclocOf arg) + fname' = Var (qualName fname) (Info fname_t) floc callret <- unRetType lifted_rettype pure @@ -979,7 +979,7 @@ apply_e = mkApply f' [(argext, arg')] callret pure (apply_e, sv) -- -defuncApplyArg fname_s (_, sv) ((_, arg), _) = +defuncApplyArg (fname_s, _) (_, sv) ((_, arg), _) = error $ "defuncApplyArg: cannot apply StaticVal\n" <> show sv @@ -1009,7 +1009,7 @@ let fname = liftedName 0 f (argtypes, _) = unfoldFunType $ typeOf f fmap (first $ updateReturn appres) $ - foldM (defuncApplyArg fname) (f', f_sv) $ + foldM (defuncApplyArg (fname, loc)) (f', f_sv) $ NE.zip args $ NE.tails argtypes where 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 @@ -46,7 +46,7 @@ shiftRetAls d (RetAls pals rals) = RetAls pals $ map (+ d) rals internaliseValBind :: VisibleTypes -> E.ValBind -> InternaliseM () -internaliseValBind types fb@(E.ValBind entry fname _ (Info rettype) tparams params body _ attrs loc) = do +internaliseValBind types fb@(E.ValBind entry fname _ (Info rettype) tparams params body _ attrs _) = do bindingFParams tparams params $ \shapeparams params' -> do let shapenames = map I.paramName shapeparams all_params = map pure shapeparams ++ concat params' @@ -70,7 +70,7 @@ bindExtSizes (E.AppRes (E.toStruct $ E.retType rettype) (E.retDims rettype)) body_res body_res' <- - ensureResultExtShape msg loc (map I.fromDecl rettype') $ subExpsRes body_res + ensureResultExtShape msg (map I.fromDecl rettype') $ subExpsRes body_res let num_ctx = length (shapeContext rettype') pure ( body_res', @@ -110,7 +110,7 @@ generateEntryPoint :: VisibleTypes -> E.EntryPoint -> E.ValBind -> InternaliseM () generateEntryPoint types (E.EntryPoint e_params e_rettype) vb = do - let (E.ValBind _ ofname _ (Info rettype) tparams params _ _ attrs loc) = vb + let (E.ValBind _ ofname _ (Info rettype) tparams params _ _ attrs _) = vb bindingFParams tparams params $ \shapeparams params' -> do let all_params = map pure shapeparams ++ concat params' (entry_rettype, retals) = @@ -133,7 +133,7 @@ Just ses -> pure ses Nothing -> - funcall "entry_result" (E.qualName ofname) args loc + funcall "entry_result" (E.qualName ofname) args ctx <- extractShapeContext (zeroExts $ concat entry_rettype) <$> mapM (fmap I.arrayDims . subExpType) vals @@ -182,17 +182,17 @@ letValExp' name ses = map I.Var <$> letValExp name ses internaliseAppExp :: String -> E.AppRes -> E.AppExp -> InternaliseM [I.SubExp] -internaliseAppExp desc _ (E.Index e idxs loc) = do +internaliseAppExp desc _ (E.Index e idxs _) = do vs <- internaliseExpToVars "indexed" e dims <- case vs of [] -> pure [] -- Will this happen? v : _ -> I.arrayDims <$> lookupType v - (idxs', cs) <- internaliseSlice loc dims idxs + (idxs', cs) <- internaliseSlice dims idxs let index v = do v_t <- lookupType v pure $ I.BasicOp $ I.Index v $ fullSlice v_t idxs' certifying cs $ mapM (letSubExp desc <=< index) vs -internaliseAppExp desc _ (E.Range start maybe_second end loc) = do +internaliseAppExp desc _ (E.Range start maybe_second end _) = do start' <- internaliseExp1 "range_start" start end' <- internaliseExp1 "range_end" $ case end of DownToExclusive e -> e @@ -325,7 +325,7 @@ I.BasicOp $ I.BinOp I.LogOr step_invalid bounds_invalid valid <- letSubExp "valid" $ I.BasicOp $ I.UnOp (I.Neg I.Bool) invalid - cs <- assert "range_valid_c" valid errmsg loc + cs <- assert "range_valid_c" valid errmsg step_i64 <- asIntS Int64 step pos_step <- @@ -358,7 +358,6 @@ -- Argument evaluation is outermost-in so that any existential sizes -- created by function applications can be brought into scope. let fname = nameFromString $ prettyString $ baseName $ qualLeaf qfname - loc = srclocOf e arg_desc = nameToString fname ++ "_arg" -- Some functions are magical (overloaded) and we handle that here. @@ -383,26 +382,26 @@ -- arguments (except equality, but those cannot be -- existential), so we can safely ignore the existential -- dimensions. - | Just internalise <- isOverloadedFunction qfname desc loc -> do + | Just internalise <- isOverloadedFunction qfname desc -> do let prepareArg (arg, _) = (E.toStruct (E.typeOf arg),) <$> internaliseExp "arg" arg internalise =<< mapM prepareArg args - | Just internalise <- isIntrinsicFunction qfname (map fst args) loc -> + | Just internalise <- isIntrinsicFunction qfname (map fst args) -> internalise desc | baseTag (qualLeaf qfname) <= maxIntrinsicTag, Just (rettype, _) <- M.lookup fname I.builtInFunctions -> do let tag ses = [(se, I.Observe) | se <- ses] args' <- reverse <$> mapM (internaliseArg arg_desc) (reverse args) let args'' = concatMap tag args' - letValExp' desc $ I.Apply fname args'' [(I.Prim rettype, mempty)] (Safe, loc, []) + letValExp' desc $ I.Apply fname args'' [(I.Prim rettype, mempty)] Safe | otherwise -> do args' <- concat . reverse <$> mapM (internaliseArg arg_desc) (reverse args) - funcall desc qfname args' loc + funcall desc qfname args' internaliseAppExp desc _ (E.LetPat sizes pat e body _) = internalisePat desc sizes pat e $ internaliseExp desc body internaliseAppExp _ _ (E.LetFun ofname _ _ _) = error $ "Unexpected LetFun " ++ prettyString ofname -internaliseAppExp desc _ (E.Loop sparams mergepat loopinit form loopbody loc) = do +internaliseAppExp desc _ (E.Loop sparams mergepat loopinit form loopbody _) = do ses <- internaliseExp "loop_init" $ loopInitExp loopinit ((loopbody', (form', shapepat, mergepat', mergeinit')), initstms) <- collectStms $ handleForm ses form @@ -422,7 +421,6 @@ args' <- ensureArgShapes "initial loop values have right shape" - loc (map I.paramName shapepat) (map paramType $ shapepat ++ mergepat') args @@ -439,7 +437,6 @@ fmap subExpsRes . ensureArgShapes "shape of loop result does not match shapes in loop parameter" - loc (map (I.paramName . fst) merge) merge_ts . map resSubExp @@ -603,7 +600,7 @@ internaliseExp desc (E.Hole (Info t) loc) = do let msg = docText $ "Reached hole of type: " <> align (pretty t) ts = foldMap toList $ internaliseType (E.toStruct t) - c <- assert "hole_c" (constant False) (errorMsg [ErrorString msg]) loc + c <- assert "hole_c" (constant False) $ errorMsg [ErrorString msg] case mapM hasStaticShape ts of Nothing -> error $ "Hole at " <> locStr loc <> " has existential type:\n" <> show ts @@ -612,8 +609,8 @@ certifying c $ mapM (fmap I.Var . letExp desc <=< eBlank . I.fromDecl) ts' internaliseExp desc (E.QualParens _ e _) = internaliseExp desc e -internaliseExp desc (E.StringLit vs _) = - fmap pure . letSubExp desc $ +internaliseExp desc (E.StringLit vs loc) = + locating loc . fmap pure . letSubExp desc $ I.BasicOp $ I.ArrayLit (map constant vs) $ I.Prim int8 @@ -623,7 +620,7 @@ Just substs -> pure substs Nothing -> pure [I.Var name] internaliseExp desc (E.AppExp e (Info appres)) = do - ses <- internaliseAppExp desc appres e + ses <- locating e $ internaliseAppExp desc appres e bindExtSizes appres ses pure ses internaliseExp _ (E.TupLit [] _) = @@ -642,9 +639,10 @@ (L noLoc (baseName name)) (E.Var (E.qualName name) t loc) loc -internaliseExp desc (E.ArrayVal vs t _) = - fmap pure . letSubExp desc . I.BasicOp $ - I.ArrayVal (map internalisePrimValue vs) (internalisePrimType t) +internaliseExp desc (E.ArrayVal vs t loc) = + locating loc $ + fmap pure . letSubExp desc . I.BasicOp $ + I.ArrayVal (map internalisePrimValue vs) (internalisePrimType t) internaliseExp desc (E.ArrayLit es (Info arr_t) loc) -- If this is a multidimensional array literal of primitives, we -- treat it specially by flattening it out followed by a reshape. @@ -688,7 +686,6 @@ mapM ( ensureShape "shape of element differs from shape of first element" - loc rt "elem_reshaped" ) @@ -709,7 +706,7 @@ Just ([], [e]) internaliseExp desc (E.Ascript e _ _) = internaliseExp desc e -internaliseExp desc (E.Coerce e _ (Info et) loc) = do +internaliseExp desc (E.Coerce e _ (Info et) _) = do ses <- internaliseExp desc e ts <- internaliseCoerceType (E.toStruct et) <$> mapM subExpType ses dt' <- typeExpForError $ toStruct et @@ -718,18 +715,18 @@ let parts = ["Value of (desugared) shape ["] ++ intersperse "][" (map (ErrorVal int64) dims) - ++ ["] cannot match shape of type `"] + ++ ["] cannot match shape of type \""] ++ dt' - ++ ["`."] - ensureExtShape (errorMsg parts) loc (I.fromDecl t') desc e' -internaliseExp desc (E.Negate e _) = do + ++ ["\"."] + ensureExtShape (errorMsg parts) (I.fromDecl t') desc e' +internaliseExp desc (E.Negate e loc) = locating loc $ do e' <- internaliseExp1 "negate_arg" e et <- subExpType e' case et of I.Prim pt -> letTupExp' desc $ I.BasicOp $ I.UnOp (I.Neg pt) e' _ -> error "Futhark.Internalise.internaliseExp: non-primitive type in Negate" -internaliseExp desc (E.Not e _) = do +internaliseExp desc (E.Not e loc) = locating loc $ do e' <- internaliseExp1 "not_arg" e et <- subExpType e' case et of @@ -739,7 +736,7 @@ letTupExp' desc $ I.BasicOp $ I.UnOp (I.Neg I.Bool) e' _ -> error "Futhark.Internalise.internaliseExp: non-int/bool type in Not" -internaliseExp desc (E.Update src slice ve loc) = do +internaliseExp desc (E.Update src slice ve loc) = locating loc $ do ves <- internaliseExp "lw_val" ve srcs <- internaliseExpToVars "src" src (src_dims, ve_dims) <- case (srcs, ves) of @@ -748,7 +745,7 @@ <$> (I.arrayDims <$> lookupType src_v) <*> (I.arrayDims <$> subExpType ve_v) _ -> pure ([], []) -- Will this happen? - (idxs', cs) <- internaliseSlice loc src_dims slice + (idxs', cs) <- internaliseSlice src_dims slice let src_dims' = sliceDims (Slice idxs') rank = length src_dims' errormsg = @@ -763,10 +760,10 @@ let full_slice = fullSlice sname_t idxs' rowtype = sname_t `setArrayDims` sliceDims full_slice ve'' <- - ensureShape errormsg loc rowtype "lw_val_correct_shape" ve' + ensureShape errormsg rowtype "lw_val_correct_shape" ve' letInPlace desc sname full_slice $ BasicOp $ SubExp ve'' certifying cs $ map I.Var <$> zipWithM comb srcs ves -internaliseExp desc (E.RecordUpdate src fields ve _ _) = do +internaliseExp desc (E.RecordUpdate src fields ve _ loc) = locating loc $ do src' <- internaliseExp desc src ve' <- internaliseExp desc ve replace (E.typeOf src) fields ve' src' @@ -822,9 +819,9 @@ env {envDoBoundsChecks = False} | otherwise = env {envAttrs = envAttrs env <> oneAttr attr'} -internaliseExp desc (E.Assert e1 e2 (Info check) loc) = do +internaliseExp desc (E.Assert e1 e2 (Info check) loc) = locating loc $ do e1' <- internaliseExp1 "assert_cond" e1 - c <- assert "assert_c" e1' (errorMsg [ErrorString $ "Assertion is false: " <> check]) loc + c <- assert "assert_c" e1' $ errorMsg [ErrorString $ "Assertion is false: " <> check] -- Make sure there are some bindings to certify. certifying c $ mapM rebind =<< internaliseExp desc e2 where @@ -832,7 +829,7 @@ v' <- newVName "assert_res" letBindNames [v'] $ I.BasicOp $ I.SubExp v pure $ I.Var v' -internaliseExp _ (E.Constr c es (Info (E.Scalar (E.Sum fs))) _) = do +internaliseExp _ (E.Constr c es (Info (E.Scalar (E.Sum fs))) loc) = locating loc $ do (ts, constr_map) <- internaliseSumType $ M.map (map E.toStruct) fs es' <- concat <$> mapM (internaliseExp "payload") es @@ -1023,11 +1020,10 @@ m internaliseSlice :: - SrcLoc -> [SubExp] -> [E.DimIndex] -> InternaliseM ([I.DimIndex SubExp], Certs) -internaliseSlice loc dims idxs = do +internaliseSlice dims idxs = do (idxs', oks, parts) <- unzip3 <$> zipWithM internaliseDimIndex dims idxs ok <- letSubExp "index_ok" =<< eAll oks let msg = @@ -1037,7 +1033,7 @@ ++ ["] out of bounds for array of shape ["] ++ intersperse "][" (map (ErrorVal int64) $ take (length idxs) dims) ++ ["]."] - c <- assert "index_certs" ok msg loc + c <- assert "index_certs" ok msg pure (idxs', c) internaliseDimIndex :: @@ -1186,16 +1182,15 @@ String -> String -> (SubExp -> I.Lambda SOACS -> [SubExp] -> [VName] -> InternaliseM (SOAC SOACS)) -> - (E.Exp, E.Exp, E.Exp, SrcLoc) -> + (E.Exp, E.Exp, E.Exp) -> InternaliseM [SubExp] -internaliseScanOrReduce desc what f (lam, ne, arr, loc) = do +internaliseScanOrReduce desc what f (lam, ne, arr) = do arrs <- internaliseExpToVars (what ++ "_arr") arr nes <- internaliseExp (what ++ "_ne") ne nes' <- forM (zip nes arrs) $ \(ne', arr') -> do rowtype <- I.stripArray 1 <$> lookupType arr' ensureShape "Row shape of input array does not match shape of neutral element" - loc rowtype (what ++ "_ne_right_shape") ne' @@ -1214,9 +1209,8 @@ E.Exp -> E.Exp -> E.Exp -> - SrcLoc -> InternaliseM [SubExp] -internaliseHist dim desc rf hist op ne buckets img loc = do +internaliseHist dim desc rf hist op ne buckets img = do rf' <- internaliseExp1 "hist_rf" rf ne' <- internaliseExp "hist_ne" ne hist' <- internaliseExpToVars "hist_hist" hist @@ -1228,7 +1222,6 @@ rowtype <- I.stripArray 1 <$> lookupType h ensureShape "Row shape of destination array does not match shape of neutral element" - loc rowtype "hist_ne_right_shape" n @@ -1247,7 +1240,6 @@ mkLambda params $ ensureResultShape "Row shape of value array does not match row shape of hist target" - (srclocOf img) rettype =<< bodyBind body @@ -1333,35 +1325,32 @@ mapM (letSubExp s . I.BasicOp <=< op) vs certifyingNonzero :: - SrcLoc -> IntType -> SubExp -> InternaliseM a -> InternaliseM a -certifyingNonzero loc t x m = do +certifyingNonzero t x m = do zero <- letSubExp "zero" $ I.BasicOp $ CmpOp (CmpEq (IntType t)) x (intConst t 0) nonzero <- letSubExp "nonzero" $ I.BasicOp $ UnOp (I.Neg I.Bool) zero - c <- assert "nonzero_cert" nonzero "division by zero" loc + c <- assert "nonzero_cert" nonzero "division by zero" certifying c m certifyingNonnegative :: - SrcLoc -> IntType -> SubExp -> InternaliseM a -> InternaliseM a -certifyingNonnegative loc t x m = do +certifyingNonnegative t x m = do nonnegative <- letSubExp "nonnegative" . I.BasicOp $ CmpOp (CmpSle t) (intConst t 0) x - c <- assert "nonzero_cert" nonnegative "negative exponent" loc + c <- assert "nonzero_cert" nonnegative "negative exponent" certifying c m internaliseBinOp :: - SrcLoc -> String -> E.BinOp -> I.SubExp -> @@ -1369,123 +1358,123 @@ E.PrimType -> E.PrimType -> InternaliseM [I.SubExp] -internaliseBinOp _ desc E.LogAnd x y E.Bool _ = +internaliseBinOp desc E.LogAnd x y E.Bool _ = simpleBinOp desc I.LogAnd x y -internaliseBinOp _ desc E.LogOr x y E.Bool _ = +internaliseBinOp desc E.LogOr x y E.Bool _ = simpleBinOp desc I.LogOr x y -internaliseBinOp _ desc E.Plus x y (E.Signed t) _ = +internaliseBinOp desc E.Plus x y (E.Signed t) _ = simpleBinOp desc (I.Add t I.OverflowWrap) x y -internaliseBinOp _ desc E.Plus x y (E.Unsigned t) _ = +internaliseBinOp desc E.Plus x y (E.Unsigned t) _ = simpleBinOp desc (I.Add t I.OverflowWrap) x y -internaliseBinOp _ desc E.Plus x y (E.FloatType t) _ = +internaliseBinOp desc E.Plus x y (E.FloatType t) _ = simpleBinOp desc (I.FAdd t) x y -internaliseBinOp _ desc E.Minus x y (E.Signed t) _ = +internaliseBinOp desc E.Minus x y (E.Signed t) _ = simpleBinOp desc (I.Sub t I.OverflowWrap) x y -internaliseBinOp _ desc E.Minus x y (E.Unsigned t) _ = +internaliseBinOp desc E.Minus x y (E.Unsigned t) _ = simpleBinOp desc (I.Sub t I.OverflowWrap) x y -internaliseBinOp _ desc E.Minus x y (E.FloatType t) _ = +internaliseBinOp desc E.Minus x y (E.FloatType t) _ = simpleBinOp desc (I.FSub t) x y -internaliseBinOp _ desc E.Times x y (E.Signed t) _ = +internaliseBinOp desc E.Times x y (E.Signed t) _ = simpleBinOp desc (I.Mul t I.OverflowWrap) x y -internaliseBinOp _ desc E.Times x y (E.Unsigned t) _ = +internaliseBinOp desc E.Times x y (E.Unsigned t) _ = simpleBinOp desc (I.Mul t I.OverflowWrap) x y -internaliseBinOp _ desc E.Times x y (E.FloatType t) _ = +internaliseBinOp desc E.Times x y (E.FloatType t) _ = simpleBinOp desc (I.FMul t) x y -internaliseBinOp loc desc E.Divide x y (E.Signed t) _ = - certifyingNonzero loc t y $ +internaliseBinOp desc E.Divide x y (E.Signed t) _ = + certifyingNonzero t y $ simpleBinOp desc (I.SDiv t I.Unsafe) x y -internaliseBinOp loc desc E.Divide x y (E.Unsigned t) _ = - certifyingNonzero loc t y $ +internaliseBinOp desc E.Divide x y (E.Unsigned t) _ = + certifyingNonzero t y $ simpleBinOp desc (I.UDiv t I.Unsafe) x y -internaliseBinOp _ desc E.Divide x y (E.FloatType t) _ = +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) _ = +internaliseBinOp desc E.Pow x y (E.FloatType t) _ = simpleBinOp desc (I.FPow t) x y -internaliseBinOp loc desc E.Pow x y (E.Signed t) _ = - certifyingNonnegative loc t y $ +internaliseBinOp desc E.Pow x y (E.Signed t) _ = + certifyingNonnegative t y $ simpleBinOp desc (I.Pow t) x y -internaliseBinOp _ desc E.Pow x y (E.Unsigned t) _ = +internaliseBinOp desc E.Pow x y (E.Unsigned t) _ = simpleBinOp desc (I.Pow t) x y -internaliseBinOp loc desc E.Mod x y (E.Signed t) _ = - certifyingNonzero loc t y $ +internaliseBinOp desc E.Mod x y (E.Signed t) _ = + certifyingNonzero t y $ simpleBinOp desc (I.SMod t I.Unsafe) x y -internaliseBinOp loc desc E.Mod x y (E.Unsigned t) _ = - certifyingNonzero loc t y $ +internaliseBinOp desc E.Mod x y (E.Unsigned t) _ = + certifyingNonzero t y $ simpleBinOp desc (I.UMod t I.Unsafe) x y -internaliseBinOp _ desc E.Mod x y (E.FloatType t) _ = +internaliseBinOp desc E.Mod x y (E.FloatType t) _ = simpleBinOp desc (I.FMod t) x y -internaliseBinOp loc desc E.Quot x y (E.Signed t) _ = - certifyingNonzero loc t y $ +internaliseBinOp desc E.Quot x y (E.Signed t) _ = + certifyingNonzero t y $ simpleBinOp desc (I.SQuot t I.Unsafe) x y -internaliseBinOp loc desc E.Quot x y (E.Unsigned t) _ = - certifyingNonzero loc t y $ +internaliseBinOp desc E.Quot x y (E.Unsigned t) _ = + certifyingNonzero t y $ simpleBinOp desc (I.UDiv t I.Unsafe) x y -internaliseBinOp loc desc E.Rem x y (E.Signed t) _ = - certifyingNonzero loc t y $ +internaliseBinOp desc E.Rem x y (E.Signed t) _ = + certifyingNonzero t y $ simpleBinOp desc (I.SRem t I.Unsafe) x y -internaliseBinOp loc desc E.Rem x y (E.Unsigned t) _ = - certifyingNonzero loc t y $ +internaliseBinOp desc E.Rem x y (E.Unsigned t) _ = + certifyingNonzero t y $ simpleBinOp desc (I.UMod t I.Unsafe) x y -internaliseBinOp _ desc E.ShiftR x y (E.Signed t) _ = +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) _ = +internaliseBinOp desc E.ShiftR x y (E.Unsigned t) _ = simpleBinOp desc (I.LShr t) x y -internaliseBinOp _ desc E.ShiftL x y (E.Signed t) _ = +internaliseBinOp desc E.ShiftL x y (E.Signed t) _ = simpleBinOp desc (I.Shl t) x y -internaliseBinOp _ desc E.ShiftL x y (E.Unsigned t) _ = +internaliseBinOp desc E.ShiftL x y (E.Unsigned t) _ = simpleBinOp desc (I.Shl t) x y -internaliseBinOp _ desc E.Band x y (E.Signed t) _ = +internaliseBinOp desc E.Band x y (E.Signed t) _ = simpleBinOp desc (I.And t) x y -internaliseBinOp _ desc E.Band x y (E.Unsigned t) _ = +internaliseBinOp desc E.Band x y (E.Unsigned t) _ = simpleBinOp desc (I.And t) x y -internaliseBinOp _ desc E.Xor x y (E.Signed t) _ = +internaliseBinOp desc E.Xor x y (E.Signed t) _ = simpleBinOp desc (I.Xor t) x y -internaliseBinOp _ desc E.Xor x y (E.Unsigned t) _ = +internaliseBinOp desc E.Xor x y (E.Unsigned t) _ = simpleBinOp desc (I.Xor t) x y -internaliseBinOp _ desc E.Bor x y (E.Signed t) _ = +internaliseBinOp desc E.Bor x y (E.Signed t) _ = simpleBinOp desc (I.Or t) x y -internaliseBinOp _ desc E.Bor x y (E.Unsigned t) _ = +internaliseBinOp desc E.Bor x y (E.Unsigned t) _ = simpleBinOp desc (I.Or t) x y -internaliseBinOp _ desc E.Equal x y t _ = +internaliseBinOp desc E.Equal x y t _ = simpleCmpOp desc (I.CmpEq $ internalisePrimType t) x y -internaliseBinOp _ desc E.NotEqual x y t _ = do +internaliseBinOp desc E.NotEqual x y t _ = do eq <- letSubExp (desc ++ "true") $ I.BasicOp $ I.CmpOp (I.CmpEq $ internalisePrimType t) x y fmap pure $ letSubExp desc $ I.BasicOp $ I.UnOp (I.Neg I.Bool) eq -internaliseBinOp _ desc E.Less x y (E.Signed t) _ = +internaliseBinOp desc E.Less x y (E.Signed t) _ = simpleCmpOp desc (I.CmpSlt t) x y -internaliseBinOp _ desc E.Less x y (E.Unsigned t) _ = +internaliseBinOp desc E.Less x y (E.Unsigned t) _ = simpleCmpOp desc (I.CmpUlt t) x y -internaliseBinOp _ desc E.Leq x y (E.Signed t) _ = +internaliseBinOp desc E.Leq x y (E.Signed t) _ = simpleCmpOp desc (I.CmpSle t) x y -internaliseBinOp _ desc E.Leq x y (E.Unsigned t) _ = +internaliseBinOp desc E.Leq x y (E.Unsigned t) _ = simpleCmpOp desc (I.CmpUle t) x y -internaliseBinOp _ desc E.Greater x y (E.Signed t) _ = +internaliseBinOp desc E.Greater x y (E.Signed t) _ = simpleCmpOp desc (I.CmpSlt t) y x -- Note the swapped x and y -internaliseBinOp _ desc E.Greater x y (E.Unsigned t) _ = +internaliseBinOp desc E.Greater x y (E.Unsigned t) _ = simpleCmpOp desc (I.CmpUlt t) y x -- Note the swapped x and y -internaliseBinOp _ desc E.Geq x y (E.Signed t) _ = +internaliseBinOp desc E.Geq x y (E.Signed t) _ = simpleCmpOp desc (I.CmpSle t) y x -- Note the swapped x and y -internaliseBinOp _ desc E.Geq x y (E.Unsigned t) _ = +internaliseBinOp desc E.Geq x y (E.Unsigned t) _ = simpleCmpOp desc (I.CmpUle t) y x -- Note the swapped x and y -internaliseBinOp _ desc E.Less x y (E.FloatType t) _ = +internaliseBinOp desc E.Less x y (E.FloatType t) _ = simpleCmpOp desc (I.FCmpLt t) x y -internaliseBinOp _ desc E.Leq x y (E.FloatType t) _ = +internaliseBinOp desc E.Leq x y (E.FloatType t) _ = simpleCmpOp desc (I.FCmpLe t) x y -internaliseBinOp _ desc E.Greater x y (E.FloatType t) _ = +internaliseBinOp desc E.Greater x y (E.FloatType t) _ = simpleCmpOp desc (I.FCmpLt t) y x -- Note the swapped x and y -internaliseBinOp _ desc E.Geq x y (E.FloatType t) _ = +internaliseBinOp desc E.Geq x y (E.FloatType t) _ = simpleCmpOp desc (I.FCmpLe t) y x -- Note the swapped x and y -- Relational operators for booleans. -internaliseBinOp _ desc E.Less x y E.Bool _ = +internaliseBinOp desc E.Less x y E.Bool _ = simpleCmpOp desc I.CmpLlt x y -internaliseBinOp _ desc E.Leq x y E.Bool _ = +internaliseBinOp desc E.Leq x y E.Bool _ = simpleCmpOp desc I.CmpLle x y -internaliseBinOp _ desc E.Greater x y E.Bool _ = +internaliseBinOp desc E.Greater x y E.Bool _ = simpleCmpOp desc I.CmpLlt y x -- Note the swapped x and y -internaliseBinOp _ desc E.Geq x y E.Bool _ = +internaliseBinOp desc E.Geq x y E.Bool _ = simpleCmpOp desc I.CmpLle y x -- Note the swapped x and y -internaliseBinOp _ _ op _ _ t1 t2 = +internaliseBinOp _ op _ _ t1 t2 = error $ "Invalid binary operator " ++ prettyString op @@ -1553,7 +1542,6 @@ mkLambda params $ ensureResultShape (ErrorMsg [ErrorString "unexpected lambda result size"]) - (srclocOf lam) rettype =<< bodyBind body @@ -1561,9 +1549,8 @@ isOverloadedFunction :: E.QualName VName -> String -> - SrcLoc -> Maybe ([(E.StructType, [SubExp])] -> InternaliseM [SubExp]) -isOverloadedFunction qname desc loc = do +isOverloadedFunction qname desc = do guard $ baseTag (qualLeaf qname) <= maxIntrinsicTag handle $ baseString $ qualLeaf qname where @@ -1625,7 +1612,7 @@ Just $ \[(x_t, [x']), (y_t, [y'])] -> case (x_t, y_t) of (E.Scalar (E.Prim t1), E.Scalar (E.Prim t2)) -> - internaliseBinOp loc desc bop x' y' t1 t2 + internaliseBinOp desc bop x' y' t1 t2 _ -> error "Futhark.Internalise.internaliseExp: non-primitive type in BinOp." handle _ = Nothing @@ -1635,9 +1622,8 @@ isIntrinsicFunction :: E.QualName VName -> [E.Exp] -> - SrcLoc -> Maybe (String -> InternaliseM [SubExp]) -isIntrinsicFunction qname args loc = do +isIntrinsicFunction qname args = do guard $ baseTag (qualLeaf qname) <= maxIntrinsicTag let handlers = [ handleSign, @@ -1695,28 +1681,28 @@ fromInt32 (IntLit k' (Info (E.Scalar (E.Prim (E.Signed Int32)))) _) = Just $ fromInteger k' fromInt32 _ = Nothing handleSOACs [lam, ne, arr] "reduce" = Just $ \desc -> - internaliseScanOrReduce desc "reduce" reduce (lam, ne, arr, loc) + internaliseScanOrReduce desc "reduce" reduce (lam, ne, arr) where reduce w red_lam nes arrs = I.Screma w arrs <$> I.reduceSOAC [Reduce Noncommutative red_lam nes] handleSOACs [lam, ne, arr] "reduce_comm" = Just $ \desc -> - internaliseScanOrReduce desc "reduce" reduce (lam, ne, arr, loc) + internaliseScanOrReduce desc "reduce" reduce (lam, ne, arr) where reduce w red_lam nes arrs = I.Screma w arrs <$> I.reduceSOAC [Reduce Commutative red_lam nes] handleSOACs [lam, ne, arr] "scan" = Just $ \desc -> - internaliseScanOrReduce desc "scan" reduce (lam, ne, arr, loc) + internaliseScanOrReduce desc "scan" reduce (lam, ne, arr) where reduce w scan_lam nes arrs = I.Screma w arrs <$> I.scanSOAC [Scan scan_lam nes] handleSOACs [rf, dest, op, ne, buckets, img] "hist_1d" = Just $ \desc -> - internaliseHist 1 desc rf dest op ne buckets img loc + internaliseHist 1 desc rf dest op ne buckets img handleSOACs [rf, dest, op, ne, buckets, img] "hist_2d" = Just $ \desc -> - internaliseHist 2 desc rf dest op ne buckets img loc + internaliseHist 2 desc rf dest op ne buckets img handleSOACs [rf, dest, op, ne, buckets, img] "hist_3d" = Just $ \desc -> - internaliseHist 3 desc rf dest op ne buckets img loc + internaliseHist 3 desc rf dest op ne buckets img handleSOACs _ _ = Nothing handleAccs [dest, f, bs] "scatter_stream" = Just $ \desc -> @@ -1761,20 +1747,16 @@ .&&. pe64 m' .>=. 0 dim_ok_cert <- - assert - "dim_ok_cert" - dim_ok - ( ErrorMsg - [ "Cannot unflatten array of shape [", - ErrorVal int64 old_dim, - "] to array of shape [", - ErrorVal int64 n', - "][", - ErrorVal int64 m', - "]" - ] - ) - loc + assert "dim_ok_cert" dim_ok $ + ErrorMsg + [ "Cannot unflatten array of shape [", + ErrorVal int64 old_dim, + "] to array of shape [", + ErrorVal int64 n', + "][", + ErrorVal int64 m', + "]" + ] certifying dim_ok_cert $ forM arrs $ \arr' -> do arr_t <- lookupType arr' @@ -1831,17 +1813,17 @@ mapM (letSubExp desc . BasicOp . Replicate mempty . I.Var) =<< internaliseExpToVars desc x handleRest [arr, offset, n1, s1, n2, s2] "flat_index_2d" = Just $ \desc -> do - flatIndexHelper desc loc arr offset [(n1, s1), (n2, s2)] + flatIndexHelper desc arr offset [(n1, s1), (n2, s2)] handleRest [arr1, offset, s1, s2, arr2] "flat_update_2d" = Just $ \desc -> do - flatUpdateHelper desc loc arr1 offset [s1, s2] arr2 + flatUpdateHelper desc arr1 offset [s1, s2] arr2 handleRest [arr, offset, n1, s1, n2, s2, n3, s3] "flat_index_3d" = Just $ \desc -> do - flatIndexHelper desc loc arr offset [(n1, s1), (n2, s2), (n3, s3)] + flatIndexHelper desc arr offset [(n1, s1), (n2, s2), (n3, s3)] handleRest [arr1, offset, s1, s2, s3, arr2] "flat_update_3d" = Just $ \desc -> do - flatUpdateHelper desc loc arr1 offset [s1, s2, s3] arr2 + flatUpdateHelper desc arr1 offset [s1, s2, s3] arr2 handleRest [arr, offset, n1, s1, n2, s2, n3, s3, n4, s4] "flat_index_4d" = Just $ \desc -> do - flatIndexHelper desc loc arr offset [(n1, s1), (n2, s2), (n3, s3), (n4, s4)] + flatIndexHelper desc arr offset [(n1, s1), (n2, s2), (n3, s3), (n4, s4)] handleRest [arr1, offset, s1, s2, s3, s4, arr2] "flat_update_4d" = Just $ \desc -> do - flatUpdateHelper desc loc arr1 offset [s1, s2, s3, s4] arr2 + flatUpdateHelper desc arr1 offset [s1, s2, s3, s4] arr2 handleRest _ _ = Nothing toSigned int_to e desc = do @@ -1901,7 +1883,6 @@ "write_cert" cmp "length of index and value array does not match" - loc certifying c $ letExp (baseString sv ++ "_write_sv") $ shapeCoerce (I.shapeDims (reshapeOuter (I.Shape [si_w]) 1 sv_shape)) sv @@ -1924,7 +1905,6 @@ letSubExp "write_res" $ I.BasicOp $ I.SubExp $ I.Var name ensureResultShape "scatter value has wrong size" - loc bodyTypes (subExpsRes results) @@ -1940,8 +1920,8 @@ spec = zip3 sa_ws (repeat 1) sas letTupExp' desc $ I.Op $ I.Scatter si_w sivs spec lam -flatIndexHelper :: String -> SrcLoc -> E.Exp -> E.Exp -> [(E.Exp, E.Exp)] -> InternaliseM [SubExp] -flatIndexHelper desc loc arr offset slices = do +flatIndexHelper :: String -> E.Exp -> E.Exp -> [(E.Exp, E.Exp)] -> InternaliseM [SubExp] +flatIndexHelper desc arr offset slices = do arrs <- internaliseExpToVars "arr" arr offset' <- internaliseExp1 "offset" offset old_dim <- I.arraysSize 0 <$> mapM lookupType arrs @@ -1980,14 +1960,16 @@ offset_inbounds_down [offset_inbounds_up, min_in_bounds, max_in_bounds] - c <- assert "bounds_cert" all_bounds (ErrorMsg [ErrorString $ "Flat slice out of bounds: " <> prettyText old_dim <> " and " <> prettyText slices']) loc + c <- + assert "bounds_cert" all_bounds $ + ErrorMsg [ErrorString $ "Flat slice out of bounds: " <> prettyText old_dim <> " and " <> prettyText slices'] let slice = I.FlatSlice offset' $ map (uncurry FlatDimIndex) slices' certifying c $ forM arrs $ \arr' -> letSubExp desc $ I.BasicOp $ I.FlatIndex arr' slice -flatUpdateHelper :: String -> SrcLoc -> E.Exp -> E.Exp -> [E.Exp] -> E.Exp -> InternaliseM [SubExp] -flatUpdateHelper desc loc arr1 offset slices arr2 = do +flatUpdateHelper :: String -> E.Exp -> E.Exp -> [E.Exp] -> E.Exp -> InternaliseM [SubExp] +flatUpdateHelper desc arr1 offset slices arr2 = do arrs1 <- internaliseExpToVars "arr" arr1 offset' <- internaliseExp1 "offset" offset old_dim <- I.arraysSize 0 <$> mapM lookupType arrs1 @@ -2028,7 +2010,9 @@ offset_inbounds_down [offset_inbounds_up, min_in_bounds, max_in_bounds] - c <- assert "bounds_cert" all_bounds (ErrorMsg [ErrorString $ "Flat slice out of bounds: " <> prettyText old_dim <> " and " <> prettyText slices']) loc + c <- + assert "bounds_cert" all_bounds $ + ErrorMsg [ErrorString $ "Flat slice out of bounds: " <> prettyText old_dim <> " and " <> prettyText slices'] let slice = I.FlatSlice offset' $ map (uncurry FlatDimIndex) slices' certifying c $ forM (zip arrs1 arrs2) $ \(arr1', arr2') -> @@ -2038,9 +2022,8 @@ String -> QualName VName -> [SubExp] -> - SrcLoc -> InternaliseM [SubExp] -funcall desc (QualName _ fname) args loc = do +funcall desc (QualName _ fname) args = do (shapes, value_paramts, fun_params, rettype_fun) <- lookupFunction fname argts <- mapM subExpType args @@ -2051,7 +2034,6 @@ args' <- ensureArgShapes "function arguments of wrong shape" - loc (map I.paramName fun_params) (map I.paramType fun_params) (shapeargs ++ args) @@ -2074,7 +2056,7 @@ safety <- askSafety attrs <- asks envAttrs attributing attrs . letValExp' desc $ - I.Apply (internaliseFunName fname) (zip args' diets) ts (safety, loc, mempty) + I.Apply (internaliseFunName fname) (zip args' diets) ts safety -- Bind existential names defined by an expression, based on the -- concrete values that expression evaluated to. This most @@ -2220,9 +2202,11 @@ (resultBodyM [next_one]) sizeExpForError :: E.Size -> InternaliseM [ErrorMsgPart SubExp] -sizeExpForError e = do - e' <- internaliseExp1 "size" e - pure ["[", ErrorVal int64 e', "]"] +sizeExpForError e + | e == anySize = pure ["[]"] + | otherwise = do + e' <- internaliseExp1 "size" e + pure ["[", ErrorVal int64 e', "]"] typeExpForError :: E.TypeBase Size u -> InternaliseM [ErrorMsgPart SubExp] typeExpForError (E.Scalar (E.Prim t)) = pure [ErrorString $ prettyText t] diff --git a/src/Futhark/Internalise/FullNormalise.hs b/src/Futhark/Internalise/FullNormalise.hs --- a/src/Futhark/Internalise/FullNormalise.hs +++ b/src/Futhark/Internalise/FullNormalise.hs @@ -218,7 +218,7 @@ let y = Var (qualName yn) (Info $ toStruct yty) mempty ret' = applySubst (pSubst x y) ret body = - mkApply (Var op ty mempty) [(xext, x), (Nothing, y)] $ + mkApply (Var op ty loc) [(xext, x), (Nothing, y)] $ AppRes (toStruct ret') exts nameExp final $ Lambda [Id yn (Info yty) mempty] body Nothing (Info (RetType dims ret')) loc where @@ -231,7 +231,7 @@ y <- getOrdering False e let x = Var (qualName xn) (Info $ toStruct xty) mempty ret' = applySubst (pSubst x y) ret - body = mkApply (Var op ty mempty) [(Nothing, x), (yext, y)] $ AppRes (toStruct ret') [] + body = mkApply (Var op ty loc) [(Nothing, x), (yext, y)] $ AppRes (toStruct ret') [] nameExp final $ Lambda [Id xn (Info xty) mempty] body Nothing (Info (RetType dims ret')) loc where pSubst x y vn diff --git a/src/Futhark/Internalise/Lambdas.hs b/src/Futhark/Internalise/Lambdas.hs --- a/src/Futhark/Internalise/Lambdas.hs +++ b/src/Futhark/Internalise/Lambdas.hs @@ -33,7 +33,6 @@ mkLambda params $ ensureResultShape (ErrorMsg [ErrorString "shape of result does not match shape of initial value"]) - (srclocOf lam) rettype' =<< bodyBind body diff --git a/src/Futhark/Internalise/Monad.hs b/src/Futhark/Internalise/Monad.hs --- a/src/Futhark/Internalise/Monad.hs +++ b/src/Futhark/Internalise/Monad.hs @@ -16,6 +16,7 @@ bindFunction, bindConstant, assert, + locating, -- * Convenient reexports module Futhark.Tools, @@ -49,7 +50,8 @@ { envSubsts :: VarSubsts, envDoBoundsChecks :: Bool, envSafe :: Bool, - envAttrs :: Attrs + envAttrs :: Attrs, + envLoc :: Loc } data InternaliseState = InternaliseState @@ -115,7 +117,8 @@ { envSubsts = mempty, envDoBoundsChecks = True, envSafe = safe, - envAttrs = mempty + envAttrs = mempty, + envLoc = mempty } newState src = InternaliseState @@ -185,18 +188,16 @@ { stateConstSubsts = M.insert cname substs $ stateConstSubsts s } --- | Construct an 'Assert' statement, but taking attributes into --- account. Always use this function, and never construct 'Assert' --- directly in the internaliser! +-- | Construct an 'Assert' statement, but taking attributes into account. Always +-- use this function, and never construct 'Assert' directly in the internaliser! assert :: String -> SubExp -> ErrorMsg SubExp -> - SrcLoc -> InternaliseM Certs -assert desc se msg loc = assertingOne $ do +assert desc se msg = assertingOne $ do attrs <- asks $ attrsForAssert . envAttrs - attributing attrs $ letExp desc $ BasicOp $ Assert se msg (loc, mempty) + attributing attrs $ letExp desc $ BasicOp $ Assert se msg -- | Execute the given action if 'envDoBoundsChecks' is true, otherwise -- just return an empty list. @@ -215,3 +216,13 @@ InternaliseM VName -> InternaliseM Certs assertingOne m = asserting $ Certs . pure <$> m + +-- | Attach the provided location to all statements produced during execution of +-- this action. +locating :: (Located a) => a -> InternaliseM b -> InternaliseM b +locating a + | loc == mempty || isBuiltinLoc loc = id + | otherwise = censorStms $ fmap onStm + where + loc = locOf a + onStm (Let pat aux e) = Let pat (aux {stmAuxLoc = Provenance mempty loc}) e 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 @@ -20,7 +20,7 @@ import Futhark.LSP.State (State (..), getStaleContent, getStaleMapping) import Futhark.Util.Loc (Loc (Loc, NoLoc), Pos (Pos)) import Futhark.Util.Pretty (prettyText) -import Language.Futhark.Prop (isBuiltinLoc) +import Language.Futhark.Core (isBuiltinLoc) import Language.Futhark.Query ( AtPos (AtName), BoundTo (..), diff --git a/src/Futhark/Optimise/ArrayLayout/Layout.hs b/src/Futhark/Optimise/ArrayLayout/Layout.hs --- a/src/Futhark/Optimise/ArrayLayout/Layout.hs +++ b/src/Futhark/Optimise/ArrayLayout/Layout.hs @@ -59,10 +59,10 @@ isInscrutable op@(BinOpExp {}) counter = if counter then -- Calculate stride and offset for loop-counters and thread-IDs - case reduceStrideAndOffset op of - -- Maximum allowable stride, might need tuning. - Just (s, _) -> s > 8 - Nothing -> isInscrutableExp op + case reduceStrideAndOffset op of + -- Maximum allowable stride, might need tuning. + Just (s, _) -> s > 8 + Nothing -> isInscrutableExp op else isInscrutableExp op isInscrutable op _ = isInscrutableExp op diff --git a/src/Futhark/Optimise/ArrayLayout/Transform.hs b/src/Futhark/Optimise/ArrayLayout/Transform.hs --- a/src/Futhark/Optimise/ArrayLayout/Transform.hs +++ b/src/Futhark/Optimise/ArrayLayout/Transform.hs @@ -17,7 +17,7 @@ import Futhark.IR.MC import Futhark.Optimise.ArrayLayout.Layout (Layout, LayoutTable, Permutation) -class (Layout rep, PrimExpAnalysis rep) => Transform rep where +class (Layout rep, ExpDec rep ~ (), PrimExpAnalysis rep) => Transform rep where onOp :: (Monad m) => SOACMapper rep rep m -> @@ -60,7 +60,7 @@ transformSegOpGPU perm_table expmap stm@(Let pat aux _) op = -- Optimization: Only traverse the body of the SegOp if it is -- represented in the layout table - case M.lookup patternName (M.mapKeys vnameFromSegOp perm_table) of + case M.lookup pat_name (M.mapKeys vnameFromSegOp perm_table) of Nothing -> do addStm stm pure (perm_table, M.fromList [(name, stm) | name <- patNames pat] <> expmap) @@ -69,14 +69,14 @@ identitySegOpMapper { mapOnSegOpBody = case segLevel op of SegBlock {} -> transformSegGroupKernelBody perm_table expmap - _ -> transformSegThreadKernelBody perm_table patternName + _ -> transformSegThreadKernelBody perm_table (stmAuxLoc aux) pat_name } op' <- mapSegOpM mapper op let stm' = Let pat aux $ Op $ SegOp op' addStm stm' pure (perm_table, M.fromList [(name, stm') | name <- patNames pat] <> expmap) where - patternName = patElemName . head $ patElems pat + pat_name = patElemName . head $ patElems pat transformSegOpMC :: LayoutTable -> ExpMap MC -> Stm MC -> Maybe (SegOp () MC) -> SegOp () MC -> TransformM MC (LayoutTable, ExpMap MC) transformSegOpMC perm_table expmap (Let pat aux _) maybe_par_segop seqSegOp @@ -84,7 +84,7 @@ | Just par_segop <- maybe_par_segop = -- Optimization: Only traverse the body of the SegOp if it is -- represented in the layout table - case M.lookup patternName (M.mapKeys vnameFromSegOp perm_table) of + case M.lookup pat_name (M.mapKeys vnameFromSegOp perm_table) of Nothing -> add $ Just par_segop Just _ -> add . Just =<< mapSegOpM mapper par_segop where @@ -94,8 +94,12 @@ let stm' = Let pat aux $ Op $ ParOp maybe_par_segop' seqSegOp' addStm stm' pure (perm_table, M.fromList [(name, stm') | name <- patNames pat] <> expmap) - mapper = identitySegOpMapper {mapOnSegOpBody = transformKernelBody perm_table expmap patternName} - patternName = patElemName . head $ patElems pat + mapper = + identitySegOpMapper + { mapOnSegOpBody = + transformKernelBody perm_table expmap (stmAuxLoc aux) pat_name + } + pat_name = patElemName . head $ patElems pat transformRestOp :: (Transform rep, BuilderOps rep) => LayoutTable -> ExpMap rep -> Stm rep -> TransformM rep (LayoutTable, ExpMap rep) transformRestOp perm_table expmap (Let pat aux e) = do @@ -127,14 +131,15 @@ transformSegThreadKernelBody :: (Transform rep, BuilderOps rep) => LayoutTable -> + Provenance -> VName -> KernelBody rep -> TransformM rep (KernelBody rep) -transformSegThreadKernelBody perm_table seg_name kbody = do +transformSegThreadKernelBody perm_table p seg_name kbody = do evalStateT ( traverseKernelBodyArrayIndexes seg_name - (ensureTransformedAccess perm_table) + (ensureTransformedAccess perm_table p) kbody ) mempty @@ -143,15 +148,16 @@ (Transform rep, BuilderOps rep) => LayoutTable -> ExpMap rep -> + Provenance -> VName -> KernelBody rep -> TransformM rep (KernelBody rep) -transformKernelBody perm_table expmap seg_name (KernelBody b stms res) = do +transformKernelBody perm_table expmap p seg_name (KernelBody b stms res) = do stms' <- transformStms perm_table expmap stms evalStateT ( traverseKernelBodyArrayIndexes seg_name - (ensureTransformedAccess perm_table) + (ensureTransformedAccess perm_table p) (KernelBody b stms' res) ) mempty @@ -176,14 +182,14 @@ stms' <- stmsFromList <$> mapM onStm (stmsToList stms) pure $ Body bdec stms' bres - onStm (Let pat dec (BasicOp (Index arr is))) = - Let pat dec . oldOrNew <$> coalesce seg_name patternName arr is + onStm (Let pat aux (BasicOp (Index arr is))) = + Let pat aux . oldOrNew <$> coalesce seg_name pat_name arr is where oldOrNew Nothing = BasicOp $ Index arr is oldOrNew (Just (arr', is')) = BasicOp $ Index arr' is' - patternName = patElemName . head $ patElems pat + pat_name = patElemName . head $ patElems pat onStm (Let pat dec e) = Let pat dec <$> mapExpM mapper e @@ -212,8 +218,9 @@ ensureTransformedAccess :: (MonadBuilder m) => LayoutTable -> + Provenance -> ArrayIndexTransform (StateT Replacements m) -ensureTransformedAccess perm_table seg_name idx_name arr slice = do +ensureTransformedAccess perm_table p seg_name idx_name arr slice = do -- Check if the array has the optimal layout in memory. -- If it does not, replace it with a manifest to allocate -- it with the optimal layout @@ -227,6 +234,8 @@ Just arr' -> pure $ Just (arr', slice) Nothing -> replace perm =<< lift (manifest perm arr) where + aux = (defAux ()) {stmAuxLoc = p} + replace perm arr' = do -- Store the fact that we have seen this array + permutation -- so we don't make duplicate manifests @@ -235,7 +244,7 @@ pure $ Just (arr', slice) manifest perm array = - letExp (baseString array ++ "_coalesced") $ + auxing aux . letExp (baseString array ++ "_coalesced") $ BasicOp (Manifest array perm) lookupPermutation :: LayoutTable -> VName -> IndexExprName -> VName -> Maybe Permutation diff --git a/src/Futhark/Optimise/ArrayShortCircuiting.hs b/src/Futhark/Optimise/ArrayShortCircuiting.hs --- a/src/Futhark/Optimise/ArrayShortCircuiting.hs +++ b/src/Futhark/Optimise/ArrayShortCircuiting.hs @@ -118,14 +118,14 @@ (Mem rep inner, LetDec rep ~ LetDecMem) => Stm rep -> UpdateM (inner rep) (Stm rep) -replaceInStm (Let (Pat elems) (StmAux c a d) e) = do +replaceInStm (Let (Pat elems) (StmAux c a loc d) e) = do elems' <- mapM replaceInPatElem elems e' <- replaceInExp elems' e entries <- asks (M.elems . envCoalesceTab) let c' = case filter (\entry -> (map patElemName elems `L.intersect` M.keys (vartab entry)) /= []) entries of [] -> c entries' -> c <> foldMap certs entries' - pure $ Let (Pat elems') (StmAux c' a d) e' + pure $ Let (Pat elems') (StmAux c' a loc d) e' where replaceInPatElem :: PatElem LetDecMem -> UpdateM inner (PatElem LetDecMem) replaceInPatElem p@(PatElem vname (MemArray _ _ u _)) = 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 @@ -252,9 +252,9 @@ Nothing -> acc _ -> acc --- | Short-circuit handler for 'GPUMem' 'Op'. +-- | Short-circuit handler for t'GPUMem' t'Op'. -- --- When the 'Op' is a 'SegOp', we handle it accordingly, otherwise we do +-- When the t'Op' is a t'SegOp', we handle it accordingly, otherwise we do -- nothing. shortCircuitGPUMem :: LUTabFun -> @@ -1250,14 +1250,12 @@ info' = info {vartab = M.insert b mem_info vtab} in if safe_4 then -- array creation point, successful coalescing verified! - let (a_acc', s_acc') = markSuccessCoal (a_acc, s_acc) mb info' in ((a_acc', inhb), s_acc') else -- this is an invertible alias case of the kind -- @ let b = alias a @ -- @ let x[i] = b @ -- do not promote, but update the index function - ((M.insert mb info' a_acc, inhb), s_acc) _ -> (failed, s_acc) -- fail! @@ -1674,7 +1672,6 @@ } in M.insert m_r etry' activeCoals_tab else -- make them both optimistically depend on each other - let opts_x_new = M.insert r m_r (optdeps etry) -- Here we should translate the @ind_b@ field of @mem_info@ -- across the existential introduced by the if-then-else diff --git a/src/Futhark/Optimise/ArrayShortCircuiting/TopdownAnalysis.hs b/src/Futhark/Optimise/ArrayShortCircuiting/TopdownAnalysis.hs --- a/src/Futhark/Optimise/ArrayShortCircuiting/TopdownAnalysis.hs +++ b/src/Futhark/Optimise/ArrayShortCircuiting/TopdownAnalysis.hs @@ -180,7 +180,7 @@ nonNegatives = nonNegatives env <> innerNonNegatives (patNames pat) inner, knownLessThan = knownLessThan env <> innerKnownLessThan inner } -updateTopdownEnv env stm@(Let (Pat _) _ (BasicOp (Assert se _ _))) = +updateTopdownEnv env stm@(Let (Pat _) _ (BasicOp (Assert se _))) = env { scope = scope env <> scopeOf stm, td_asserts = se : td_asserts env diff --git a/src/Futhark/Optimise/BlkRegTiling.hs b/src/Futhark/Optimise/BlkRegTiling.hs --- a/src/Futhark/Optimise/BlkRegTiling.hs +++ b/src/Futhark/Optimise/BlkRegTiling.hs @@ -136,7 +136,6 @@ -- if i and j are out of range than css[i,j] -- is garbage anyways and should not be written. -- so fits_ij should be always true!!! - (le64 iii + le64 i + pe64 ry * le64 ltid_y .<. pe64 height_A) .&&. (le64 jjj + le64 j + pe64 rx * le64 ltid_x .<. pe64 width_B) ) diff --git a/src/Futhark/Optimise/CSE.hs b/src/Futhark/Optimise/CSE.hs --- a/src/Futhark/Optimise/CSE.hs +++ b/src/Futhark/Optimise/CSE.hs @@ -196,41 +196,34 @@ | patElemName pe `nameIn` consumed = Consume | otherwise = Observe --- A small amount of normalisation of expressions that otherwise would --- be different for pointless reasons. -normExp :: Exp lore -> Exp lore -normExp (Apply fname args ret (safety, _, _)) = - Apply fname args ret (safety, mempty, mempty) -normExp e = e - cseInStm :: (ASTRep rep) => Names -> Stm rep -> ([Stm rep] -> CSEM rep a) -> CSEM rep a -cseInStm consumed (Let pat (StmAux cs attrs edec) e) m = do +cseInStm consumed (Let pat aux e) m = do CSEState (esubsts, nsubsts) cse_arrays <- ask - let e' = normExp $ substituteNames nsubsts e + let e' = substituteNames nsubsts e pat' = substituteNames nsubsts pat if not (alreadyAliases e) && any (bad cse_arrays) (patElems pat) - then m [Let pat' (StmAux cs attrs edec) e'] - else case M.lookup (edec, e') esubsts of + then m [Let pat' aux e'] + else case M.lookup (stmAuxDec aux, e') esubsts of Just (subcs, subpat) -> do - let subsumes = all (`elem` unCerts subcs) (unCerts cs) + let subsumes = all (`elem` unCerts subcs) (unCerts (stmAuxCerts aux)) -- We can only do a plain name substitution if it doesn't -- violate any certificate dependencies. local (if subsumes then addNameSubst pat' subpat else id) $ do let lets = - [ Let (Pat [patElem']) (StmAux cs attrs edec) $ + [ Let (Pat [patElem']) aux $ BasicOp (SubExp $ Var $ patElemName patElem) | (name, patElem) <- zip (patNames pat') $ patElems subpat, let patElem' = patElem {patElemName = name} ] m lets _ -> - local (addExpSubst pat' edec cs e') $ - m [Let pat' (StmAux cs attrs edec) e'] + local (addExpSubst pat' (stmAuxDec aux) (stmAuxCerts aux) e') $ + m [Let pat' aux e'] where alreadyAliases (BasicOp Index {}) = True alreadyAliases (BasicOp Reshape {}) = True diff --git a/src/Futhark/Optimise/Fusion.hs b/src/Futhark/Optimise/Fusion.hs --- a/src/Futhark/Optimise/Fusion.hs +++ b/src/Futhark/Optimise/Fusion.hs @@ -350,7 +350,6 @@ pat1_acc_nms <- namesFromList $ take n $ map patElemName $ patElems pat1, -- not $ namesIntersect (freeIn soac) pat1_acc_nms all ((`notNameIn` pat1_acc_nms) . getName) edges = do - let empty_aux = StmAux mempty mempty mempty wlam <- fst <$> doFusionInLambda wlam0 bdy' <- runBodyBuilder $ inScopeOf wlam $ do @@ -360,7 +359,7 @@ let other_pr1 = drop n $ zip (patElems pat1) wlam_res forM_ other_pr1 $ \(pat_elm, bdy_res) -> do let (nm, se, tp) = (patElemName pat_elm, resSubExp bdy_res, patElemType pat_elm) - aux = empty_aux {stmAuxCerts = resCerts bdy_res} + aux = (defAux ()) {stmAuxCerts = resCerts bdy_res} addStm $ Let (Pat [PatElem nm tp]) aux $ BasicOp $ SubExp se -- add the soac stmt soac' <- H.toExp soac @@ -552,16 +551,26 @@ lam' <- fst <$> doFusionInLambda lam pure (incoming, node, StmNode (Let pat aux (WithAcc inputs lam')), outgoing) SoacNode ots pat soac aux -> do - let lam = H.lambda soac - lam' <- inScopeOf lam $ case soac of - H.Stream {} -> - dontFuseScans $ fst <$> doFusionInLambda lam + soac' <- case soac of + H.Stream w inputs accs lam -> + H.Stream w inputs accs <$> dontFuseScans (onLambda lam) + H.Screma w inputs (ScremaForm lam scans reds) -> + H.Screma w inputs + <$> ( ScremaForm + <$> doFuseScans (onLambda lam) + <*> mapM onScan scans + <*> mapM onRed reds + ) _ -> - doFuseScans $ fst <$> doFusionInLambda lam - let nodeT' = SoacNode ots pat (H.setLambda lam' soac) aux + H.setLambda <$> doFuseScans (onLambda (H.lambda soac)) <*> pure soac + let nodeT' = SoacNode ots pat soac' aux pure (incoming, node, nodeT', outgoing) _ -> pure c where + onLambda lam = inScopeOf lam . fmap fst $ doFusionInLambda lam + onScan (Scan lam nes) = Scan <$> onLambda lam <*> pure nes + onRed (Reduce comm lam nes) = Reduce comm <$> onLambda lam <*> pure nes + doFusionWithDelayed :: Body SOACS -> [(NodeT, [EdgeT])] -> FusionM (Body SOACS) doFusionWithDelayed (Body () stms res) extraNodes = inScopeOf stms $ do stm_node <- mapM (finalizeNode . fst) extraNodes diff --git a/src/Futhark/Optimise/Fusion/TryFusion.hs b/src/Futhark/Optimise/Fusion/TryFusion.hs --- a/src/Futhark/Optimise/Fusion/TryFusion.hs +++ b/src/Futhark/Optimise/Fusion/TryFusion.hs @@ -408,6 +408,10 @@ fail "Cannot fuse a scatter with anything else than a scatter or a map" (_, SOAC.Scatter {}, _) -> fail "Cannot fuse a scatter with anything else than a scatter or a map" + (_, SOAC.Hist {}, _) -> + fail "Cannot fuse a Hist with anything else than a Hist or a Map" + (SOAC.Hist {}, _, _) -> + fail "Cannot fuse a Hist with anything else than a Hist or a Map" ---------------------------- -- Stream-Stream Fusions: -- ---------------------------- 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 @@ -220,10 +220,11 @@ Pat Type -> StmAux dec -> [(SubExp, Diet)] -> - (Safety, SrcLoc, [SrcLoc]) -> + Safety -> + Provenance -> FunDef SOACS -> m (Stms SOACS) -inlineFunction pat aux args (safety, loc, locs) fun = do +inlineFunction pat aux args safety p fun = do Body _ stms res <- renameBody $ mkBody (param_stms <> body_stms) (bodyResult (funDefBody fun)) pure $ stms <> stmsFromList (zipWith bindSubExpRes (patIdents pat) res) @@ -234,9 +235,7 @@ <$> zipWith bindSubExp (map paramIdent $ funDefParams fun) (map fst args) body_stms = - addLocations (stmAuxAttrs aux) safety (filter notmempty (loc : locs)) $ - bodyStms $ - funDefBody fun + addLocations (stmAuxAttrs aux) safety p $ bodyStms $ funDefBody fun -- Note that the sizes of arrays may not be correct at this -- point - it is crucial that we run copy propagation before @@ -247,8 +246,6 @@ bindSubExpRes ident (SubExpRes cs se) = certify cs $ bindSubExp ident se - notmempty = (/= mempty) . locOf - inlineInStms :: (MonadFreshNames m) => M.Map Name (FunDef SOACS) -> @@ -264,11 +261,11 @@ m (Body SOACS) inlineInBody fdmap = onBody where - inline (Let pat aux (Apply fname args _ what) : rest) + inline (Let pat aux (Apply fname args _ safety) : rest) | Just fd <- M.lookup fname fdmap, not $ "noinline" `inAttrs` funDefAttrs fd, not $ "noinline" `inAttrs` stmAuxAttrs aux = - (<>) <$> inlineFunction pat aux args what fd <*> inline rest + (<>) <$> inlineFunction pat aux args safety (stmAuxLoc aux) fd <*> inline rest inline (stm@(Let _ _ BasicOp {}) : rest) = (oneStm stm <>) <$> inline rest inline (stm : rest) = @@ -292,39 +289,43 @@ onLambda (Lambda params ret body) = Lambda params ret <$> onBody body --- Propagate source locations and attributes to the inlined --- statements. Attributes are propagated only when applicable (this --- probably means that every supported attribute needs to be handled --- specially here). -addLocations :: Attrs -> Safety -> [SrcLoc] -> Stms SOACS -> Stms SOACS -addLocations attrs caller_safety more_locs = fmap onStm +traceLocs :: Provenance -> StmAux () -> StmAux () +traceLocs p aux = + aux {stmAuxLoc = stackProvenance p $ stmAuxLoc aux} + +-- Propagate source locations and attributes to the inlined statements. +-- Attributes are propagated only when applicable (this probably means that +-- every supported attribute needs to be handled specially here). +addLocations :: Attrs -> Safety -> Provenance -> Stms SOACS -> Stms SOACS +addLocations attrs caller_safety p = fmap onStm where - onStm (Let pat aux (Apply fname args t (safety, loc, locs))) = + onStm (Let pat aux (BasicOp (Assert cond desc))) = Let pat aux' $ - Apply fname args t (min caller_safety safety, loc, locs ++ more_locs) - where - aux' = aux {stmAuxAttrs = attrs <> stmAuxAttrs aux} - onStm (Let pat aux (BasicOp (Assert cond desc (loc, locs)))) = - Let pat (withAttrs (attrsForAssert attrs) aux) $ case caller_safety of - Safe -> BasicOp $ Assert cond desc (loc, locs ++ more_locs) + Safe -> BasicOp $ Assert cond desc Unsafe -> BasicOp $ SubExp $ Constant UnitValue + where + aux' = traceLocs p (withAttrs (attrsForAssert attrs) aux) + onStm (Let pat aux (Apply fname args t safety)) = + Let pat aux' $ Apply fname args t $ min caller_safety safety + where + aux' = traceLocs p $ aux {stmAuxAttrs = attrs <> stmAuxAttrs aux} onStm (Let pat aux (Op soac)) = - Let pat (withAttrs attrs' aux) $ - Op $ - runIdentity $ - mapSOACM - identitySOACMapper - { mapOnSOACLambda = pure . onLambda - } - soac + Let pat aux' . Op $ + runIdentity $ + mapSOACM + identitySOACMapper + { mapOnSOACLambda = pure . onLambda + } + soac where + aux' = traceLocs p $ withAttrs attrs' aux attrs' = attrs `withoutAttrs` for_assert for_assert = attrsForAssert attrs onLambda lam = lam {lambdaBody = onBody for_assert $ lambdaBody lam} onStm (Let pat aux e) = - Let pat aux $ onExp e + Let pat (traceLocs p aux) $ onExp e onExp = mapExp @@ -336,9 +337,7 @@ onBody attrs' body = body - { bodyStms = - addLocations attrs' caller_safety more_locs $ - bodyStms body + { bodyStms = addLocations attrs' caller_safety p $ bodyStms body } -- | Remove functions not ultimately called from an entry point or a diff --git a/src/Futhark/Optimise/MergeGPUBodies.hs b/src/Futhark/Optimise/MergeGPUBodies.hs --- a/src/Futhark/Optimise/MergeGPUBodies.hs +++ b/src/Futhark/Optimise/MergeGPUBodies.hs @@ -111,10 +111,10 @@ -- This creates sequences of GPUBody statements that can be merged into single -- kernels. reorderStm :: AliasTable -> Stm (Aliases GPU) -> ReorderM AliasTable -reorderStm aliases (Let pat (StmAux cs attrs _) e) = do +reorderStm aliases (Let pat (StmAux cs attrs loc _) e) = do (e', deps) <- lift (transformExp aliases e) let pat' = removePatAliases pat - let stm' = Let pat' (StmAux cs attrs ()) e' + let stm' = Let pat' (StmAux cs attrs loc ()) e' let pes' = patElems pat' -- Array aliases can be seen as a directed graph where vertices are arrays @@ -489,19 +489,19 @@ | otherwise = SQ.singleton <$> foldrM merge empty stms where - empty = Let mempty (StmAux mempty mempty ()) noop + empty = Let mempty (defAux ()) noop noop = Op (GPUBody [] (Body () SQ.empty [])) merge :: Stm GPU -> Stm GPU -> ReorderM (Stm GPU) merge stm0 stm1 - | Let pat0 (StmAux cs0 attrs0 _) (Op (GPUBody types0 body)) <- stm0, - Let pat1 (StmAux cs1 attrs1 _) (Op (GPUBody types1 body1)) <- stm1 = + | Let pat0 (StmAux cs0 attrs0 _ _) (Op (GPUBody types0 body)) <- stm0, + Let pat1 (StmAux cs1 attrs1 _ _) (Op (GPUBody types1 body1)) <- stm1 = do Body _ stms0 res0 <- execRewrite (rewriteBody body) let Body _ stms1 res1 = body1 pat' = pat0 <> pat1 - aux' = StmAux (cs0 <> cs1) (attrs0 <> attrs1) () + aux' = StmAux (cs0 <> cs1) (attrs0 <> attrs1) mempty () types' = types0 ++ types1 body' = Body () (stms0 <> stms1) (res0 <> res1) in pure (Let pat' aux' (Op (GPUBody types' body'))) @@ -530,11 +530,11 @@ rewriteStms = mapM rewriteStm rewriteStm :: Stm GPU -> RewriteM (Stm GPU) -rewriteStm (Let (Pat pes) (StmAux cs attrs _) e) = do +rewriteStm (Let (Pat pes) (StmAux cs attrs loc _) e) = do pat' <- Pat <$> mapM rewritePatElem pes cs' <- rewriteCerts cs e' <- rewriteExp e - pure $ Let pat' (StmAux cs' attrs ()) e' + pure $ Let pat' (StmAux cs' attrs loc ()) e' rewritePatElem :: PatElem Type -> RewriteM (PatElem Type) rewritePatElem (PatElem n t) = @@ -616,10 +616,9 @@ let t = row_t `arrayOfRow` intConst Int64 1 let pat = Pat [PatElem name t] - let aux = StmAux mempty mempty () let e = BasicOp (ArrayLit [se] row_t) - modify (|> Let pat aux e) + modify (|> Let pat (defAux ()) e) pure name -- | @referConst c@ adds @let x = c@ to the rewrite prologue and returns the @@ -630,10 +629,9 @@ let t = Prim (primValueType c) let pat = Pat [PatElem name t] - let aux = StmAux mempty mempty () let e = BasicOp (SubExp $ Constant c) - modify (|> Let pat aux e) + modify (|> Let pat (defAux ()) e) pure name -- | Produce a fresh name, using the given string as a template. diff --git a/src/Futhark/Optimise/ReduceDeviceSyncs.hs b/src/Futhark/Optimise/ReduceDeviceSyncs.hs --- a/src/Futhark/Optimise/ReduceDeviceSyncs.hs +++ b/src/Futhark/Optimise/ReduceDeviceSyncs.hs @@ -136,11 +136,10 @@ let e' = BasicOp $ Replicate (Shape dims) (Var v') let repl = Let pat' (stmAux stm) e' - let aux = StmAux mempty mempty () let slice = map sliceDim (arrayDims arr_t) let slice' = slice ++ [DimFix $ intConst Int64 0] let idx = BasicOp $ Index n' (Slice slice') - let index = Let (stmPat stm) aux idx + let index = Let (stmPat stm) (defAux ()) idx pure (out |> repl |> index) BasicOp {} -> @@ -479,7 +478,7 @@ -- | A shorthand for binding a single variable to an expression. bind :: PatElem Type -> Exp GPU -> Stm GPU -bind pe = Let (Pat [pe]) (StmAux mempty mempty ()) +bind pe = Let (Pat [pe]) (defAux ()) -- | Returns the array alias of @se@ if it is a variable that has been migrated -- to device. Otherwise returns @Nothing@. @@ -606,7 +605,7 @@ let pes = patElems (stmPat stm) pat <- Pat <$> mapM arrayizePatElem pes - let aux = StmAux mempty mempty () + let aux = defAux () let types = map patElemType pes let res = map (SubExpRes mempty . Var . patElemName) pes let body = Body () (prologue |> stm) res @@ -711,9 +710,9 @@ bnd :: Stms GPU -> (PatElem Type, SubExpRes) -> Stms GPU bnd out (pe, SubExpRes cs se) | Just t' <- peelArray 1 (typeOf pe) = - out |> Let (Pat [pe]) (StmAux cs mempty ()) (BasicOp $ ArrayLit [se] t') + out |> Let (Pat [pe]) (StmAux cs mempty mempty ()) (BasicOp $ ArrayLit [se] t') | otherwise = - out |> Let (Pat [pe]) (StmAux cs mempty ()) (BasicOp $ SubExp se) + out |> Let (Pat [pe]) (StmAux cs mempty mempty ()) (BasicOp $ SubExp se) -- | Rewrite all bindings introduced by a single statement (to ensure they are -- unique) and fix any dependencies that are broken as a result of migration or @@ -745,9 +744,9 @@ -- | Fix any 'StmAux' certificate references that are broken as a result of -- migration or rewriting. rewriteStmAux :: StmAux () -> RewriteM (StmAux ()) -rewriteStmAux (StmAux certs attrs _) = do - certs' <- renameCerts certs - pure (StmAux certs' attrs ()) +rewriteStmAux aux = do + certs' <- renameCerts $ stmAuxCerts aux + pure $ aux {stmAuxCerts = certs'} -- | Rewrite the bindings introduced by an expression (to ensure they are -- unique) and fix any dependencies that are broken as a result of migration or 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 @@ -296,10 +296,10 @@ auxing aux . letBind pat $ Match [cond'] [Case [Just (BoolValue True)] taken_body] untaken_body $ MatchDec if_ts MatchFallback -protectIf _ _ taken (Let pat aux (BasicOp (Assert cond msg loc))) = do +protectIf _ _ taken (Let pat aux (BasicOp (Assert cond msg))) = do not_taken <- letSubExp "loop_not_taken" $ BasicOp $ UnOp (Neg Bool) taken cond' <- letSubExp "protect_assert_disj" $ BasicOp $ BinOp LogOr not_taken cond - auxing aux $ letBind pat $ BasicOp $ Assert cond' msg loc + auxing aux $ letBind pat $ BasicOp $ Assert cond' msg protectIf protect _ taken (Let pat aux (Op op)) | Just m <- protect taken pat op = auxing aux m @@ -423,11 +423,11 @@ (SimplifiableRep rep) => Stm (Wise rep) -> SimpleM rep (Stm (Wise rep)) -nonrecSimplifyStm (Let pat (StmAux cs attrs (_, dec)) e) = do +nonrecSimplifyStm (Let pat (StmAux cs attrs loc (_, dec)) e) = do cs' <- simplify cs e' <- simplifyExpBase e (pat', pat_cs) <- collectCerts $ traverse simplify $ removePatWisdom pat - let aux' = StmAux (cs' <> pat_cs) attrs dec + let aux' = StmAux (cs' <> pat_cs) attrs loc dec pure $ mkWiseStm pat' aux' e' -- Bottom-up simplify a statement. Recurses into sub-Bodies and Ops. @@ -439,9 +439,9 @@ Stm (Wise rep) -> UT.UsageTable -> SimpleM rep (Stms (Wise rep), Stm (Wise rep)) -recSimplifyStm (Let pat (StmAux cs attrs (_, dec)) e) usage = do +recSimplifyStm (Let pat (StmAux cs attrs loc (_, dec)) e) usage = do ((e', e_hoisted), e_cs) <- collectCerts $ simplifyExp (usage <> UT.usageInPat pat) pat e - let aux' = StmAux (cs <> e_cs) attrs dec + let aux' = StmAux (cs <> e_cs) attrs loc dec pure (e_hoisted, mkWiseStm (removePatWisdom pat) aux' e') hoistStms :: diff --git a/src/Futhark/Optimise/Simplify/Rep.hs b/src/Futhark/Optimise/Simplify/Rep.hs --- a/src/Futhark/Optimise/Simplify/Rep.hs +++ b/src/Futhark/Optimise/Simplify/Rep.hs @@ -252,9 +252,9 @@ StmAux (ExpDec rep) -> Exp (Wise rep) -> Stm (Wise rep) -mkWiseStm pat (StmAux cs attrs dec) e = +mkWiseStm pat aux e = let pat' = addWisdomToPat pat e - in Let pat' (StmAux cs attrs $ mkWiseExpDec pat' dec e) e + in Let pat' (flip (mkWiseExpDec pat') e <$> aux) e -- | Produce simplifier information for an expression. mkWiseExpDec :: 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 @@ -95,17 +95,12 @@ removeUnnecessaryCopy _ _ _ _ = Skip constantFoldPrimFun :: (BuilderOps rep) => TopDownRuleGeneric rep -constantFoldPrimFun _ (Let pat (StmAux cs attrs _) (Apply fname args _ _)) +constantFoldPrimFun _ (Let pat aux (Apply fname args _ _)) | Just args' <- mapM (isConst . fst) args, Just (_, _, fun) <- M.lookup (nameToText fname) primFuns, Just result <- fun args' = - Simplify $ - certifying cs $ - attributing attrs $ - letBind pat $ - BasicOp $ - SubExp $ - Constant result + Simplify . auxing aux . letBind pat $ + BasicOp (SubExp $ Constant result) where isConst (Constant v) = Just v isConst _ = Nothing @@ -124,11 +119,11 @@ emptyArrayToScratch _ _ = Skip simplifyIndex :: (BuilderOps rep) => BottomUpRuleBasicOp rep -simplifyIndex (vtable, used) pat@(Pat [pe]) (StmAux cs attrs _) (Index idd inds) +simplifyIndex (vtable, used) pat@(Pat [pe]) aux (Index idd inds) | Just m <- simplifyIndexing vtable seType idd inds consumed consuming = - Simplify $ certifying cs $ do + Simplify $ certifying (stmAuxCerts aux) $ do res <- m - attributing attrs $ case res of + attributing (stmAuxAttrs aux) $ case res of SubExpResult cs' se -> certifying cs' $ letBindNames (patNames pat) $ BasicOp $ SubExp se IndexResult extra_cs idd' inds' -> 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 @@ -102,14 +102,12 @@ -- Still need a copy because Concat produces a fresh array. Simplify $ auxing aux $ letBind pat $ BasicOp $ Replicate mempty $ Var x -- concat xs (concat ys zs) == concat xs ys zs -simplifyConcat (vtable, _) pat (StmAux cs attrs _) (Concat i (x :| xs) new_d) +simplifyConcat (vtable, _) pat aux (Concat i (x :| xs) new_d) | x' /= x || concat xs' /= xs = - Simplify $ - certifying (cs <> x_cs <> mconcat xs_cs) $ - attributing attrs $ - letBind pat $ - BasicOp $ - Concat i (x' :| zs ++ concat xs') new_d + Simplify . auxing aux . certifying (x_cs <> mconcat xs_cs) $ + letBind pat $ + BasicOp $ + Concat i (x' :| zs ++ concat xs') new_d where (x' : zs, x_cs) = isConcat x (xs', xs_cs) = unzip $ map isConcat xs @@ -198,16 +196,16 @@ reshapeAll (arrayShape v_t) (arrayShape dest_t) letBind pat $ BasicOp $ Replicate mempty v_reshaped _ -> letBind pat $ BasicOp $ ArrayLit [se] $ rowType dest_t -ruleBasicOp vtable pat (StmAux cs1 attrs _) (Update safety1 dest1 is1 (Var v1)) +ruleBasicOp vtable pat aux (Update safety1 dest1 is1 (Var v1)) | Just (Update safety2 dest2 is2 se2, cs2) <- ST.lookupBasicOp v1 vtable, Just (Replicate (Shape []) (Var v3), cs3) <- ST.lookupBasicOp dest2 vtable, Just (Index v4 is4, cs4) <- ST.lookupBasicOp v3 vtable, is4 == is1, v4 == dest1 = - Simplify $ - certifying (cs1 <> cs2 <> cs3 <> cs4) $ do + Simplify . auxing aux $ + certifying (cs2 <> cs3 <> cs4) $ do is5 <- subExpSlice $ sliceSlice (primExpSlice is1) (primExpSlice is2) - attributing attrs $ letBind pat $ BasicOp $ Update (max safety1 safety2) dest1 is5 se2 + letBind pat $ BasicOp $ Update (max safety1 safety2) dest1 is5 se2 ruleBasicOp vtable pat _ (CmpOp (CmpEq t) se1 se2) | Just m <- simplifyWith se1 se2 = Simplify m | Just m <- simplifyWith se2 se1 = Simplify m 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 @@ -40,9 +40,9 @@ new_default : _ <- reverse always_matches = Simplify $ letBind pat $ Match cond cases' (caseBody new_default) ifdec -- Remove caseless match. -ruleMatch _ pat (StmAux cs _ _) (_, [], defbody, _) = Simplify $ do +ruleMatch _ pat aux (_, [], defbody, _) = Simplify $ do defbody_res <- bodyBind defbody - certifying cs $ forM_ (zip (patElems pat) defbody_res) $ \(pe, res) -> + certifying (stmAuxCerts aux) $ forM_ (zip (patElems pat) defbody_res) $ \(pe, res) -> certifying (resCerts res) . letBind (Pat [pe]) $ BasicOp (SubExp $ resSubExp res) -- IMPROVE: the following two rules can be generalised to work in more 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 @@ -263,7 +263,7 @@ -- If expression is true then just replace assertion. simplifyAssert :: SimpleRule rep -simplifyAssert _ _ (Assert (Constant (BoolValue True)) _ _) = +simplifyAssert _ _ (Assert (Constant (BoolValue True)) _) = constRes UnitValue simplifyAssert _ _ _ = Nothing diff --git a/src/Futhark/Pass/ExplicitAllocations.hs b/src/Futhark/Pass/ExplicitAllocations.hs --- a/src/Futhark/Pass/ExplicitAllocations.hs +++ b/src/Futhark/Pass/ExplicitAllocations.hs @@ -615,8 +615,11 @@ allocInFunBody (map (const $ Just space) rettype) fbody let num_extra_params = length params' - length params num_extra_rets = length mem_rets + -- The mem_pals is an over-approximation, like in the case for Apply. + mem_pals = map fst $ filter (isMem . paramType . snd) $ zip [0 ..] params' + mem_als = RetAls mem_pals mempty rettype' = - map (,RetAls mempty mempty) mem_rets + map (,mem_als) mem_rets ++ zip (memoryInDeclExtType space (length mem_rets) (map fst rettype)) (map (shiftRetAls num_extra_params num_extra_rets . snd) rettype) @@ -915,16 +918,20 @@ allocInExp (Apply fname args rettype loc) = do args' <- funcallArgs args space <- askDefaultSpace - -- We assume that every array is going to be in its own memory. - let num_extra_args = length args' - length args + args_ts <- mapM (subExpType . fst) args' + -- We assume that every array is going to be in its own memory. Further, we + -- assume that every result memory block can alias any argument memory block. + -- This is an overapproximation that can be loosened in the future. + let mem_als = RetAls (map fst $ filter (isMem . snd) $ zip [0 ..] args_ts) mempty + mems = replicate num_arrays (MemMem space, mem_als) + num_extra_args = length args' - length args rettype' = - mems space + mems ++ zip (memoryInDeclExtType space num_arrays (map fst rettype)) (map (shiftRetAls num_extra_args num_arrays . snd) rettype) pure $ Apply fname args' rettype' loc where - mems space = replicate num_arrays (MemMem space, RetAls mempty mempty) num_arrays = length $ filter ((> 0) . arrayRank . declExtTypeOf . fst) rettype allocInExp (Match ses cases defbody (MatchDec rets ifsort)) = do (defbody', def_reqs) <- allocInMatchBody rets defbody diff --git a/src/Futhark/Pass/ExtractKernels.hs b/src/Futhark/Pass/ExtractKernels.hs --- a/src/Futhark/Pass/ExtractKernels.hs +++ b/src/Futhark/Pass/ExtractKernels.hs @@ -392,7 +392,7 @@ transformStm path (Let pat aux (Op (Screma w arrs form))) | Just lam <- isMapSOAC form = onMap path $ MapLoop pat aux w lam arrs -transformStm path (Let pat aux@(StmAux cs _ _) (Op (Screma w arrs form))) +transformStm path (Let pat aux (Op (Screma w arrs form))) | Just scans <- isScanSOAC form, Scan scan_lam nes <- singleScan scans, Just do_iswim <- iswim pat w scan_lam $ zip nes arrs = do @@ -425,6 +425,8 @@ =<< (mkBody <$> paralleliseInner path' <*> pure (varsRes (patNames pat))) versionScanRed path pat aux w map_lam paralleliseOuter outerParallelBody innerParallelBody + where + cs = stmAuxCerts aux transformStm path (Let res_pat aux (Op (Screma w arrs form))) | Just [Reduce comm red_fun nes] <- isReduceSOAC form, let comm' @@ -434,7 +436,7 @@ types <- asksScope scopeForSOACs stms <- fst <$> runBuilderT (simplifyStms =<< collectStms_ (auxing aux do_irwim)) types transformStms path $ stmsToList stms -transformStm path (Let pat aux@(StmAux cs _ _) (Op (Screma w arrs form))) +transformStm path (Let pat aux (Op (Screma w arrs form))) | Just (reds, map_lam) <- isRedomapSOAC form = do let paralleliseOuter = runBuilder_ $ do red_ops <- forM reds $ \(Reduce comm red_lam nes) -> do @@ -465,11 +467,13 @@ =<< (mkBody <$> paralleliseInner path' <*> pure (varsRes (patNames pat))) versionScanRed path pat aux w map_lam paralleliseOuter outerParallelBody innerParallelBody -transformStm path (Let pat (StmAux cs _ _) (Op (Screma w arrs form))) = do + where + cs = stmAuxCerts aux +transformStm path (Let pat aux (Op (Screma w arrs form))) = do -- This screma is too complicated for us to immediately do -- anything, so split it up and try again. scope <- asksScope scopeForSOACs - transformStms path . map (certify cs) . stmsToList . snd + transformStms path . map (certify (stmAuxCerts aux)) . stmsToList . snd =<< runBuilderT (dissectScrema pat w form arrs) scope transformStm path (Let pat _ (Op (Stream w arrs nes fold_fun))) = do -- Remove the stream and leave the body parallel. It will be @@ -526,7 +530,7 @@ addStms stms letBind (Pat [res_pe]) $ Op $ SegOp kernel -- -transformStm _ (Let pat (StmAux cs _ _) (Op (Scatter w ivs as lam))) = runBuilder_ $ do +transformStm _ (Let pat aux (Op (Scatter w ivs as lam))) = runBuilder_ $ do let lam' = soacsLambdaToGPU lam write_i <- newVName "write_i" let krets = do @@ -547,10 +551,10 @@ inputs (patTypes pat) body - certifying cs $ do + certifying (stmAuxCerts aux) $ do addStms stms letBind pat $ Op $ SegOp kernel -transformStm _ (Let orig_pat (StmAux cs _ _) (Op (Hist w imgs ops bucket_fun))) = do +transformStm _ (Let orig_pat aux (Op (Hist w imgs ops bucket_fun))) = do let bfun' = soacsLambdaToGPU bucket_fun -- It is important not to launch unnecessarily many threads for @@ -558,7 +562,7 @@ -- subhistograms as well. runBuilder_ $ do lvl <- segThreadCapped [w] "seghist" $ NoRecommendation SegNoVirt - addStms =<< histKernel onLambda lvl orig_pat [] [] cs w ops bfun' imgs + addStms =<< histKernel onLambda lvl orig_pat [] [] (stmAuxCerts aux) w ops bfun' imgs where onLambda = pure . soacsLambdaToGPU transformStm _ stm = diff --git a/src/Futhark/Pass/ExtractKernels/DistributeNests.hs b/src/Futhark/Pass/ExtractKernels/DistributeNests.hs --- a/src/Futhark/Pass/ExtractKernels/DistributeNests.hs +++ b/src/Futhark/Pass/ExtractKernels/DistributeNests.hs @@ -334,13 +334,13 @@ distributeMapBodyStms orig_acc = distribute <=< onStms orig_acc . stmsToList where onStms acc [] = pure acc - onStms acc (Let pat (StmAux cs _ _) (Op (Stream w arrs accs lam)) : stms) = do + onStms acc (Let pat aux (Op (Stream w arrs accs lam)) : stms) = do types <- asksScope scopeForSOACs stream_stms <- snd <$> runBuilderT (sequentialStreamWholeArray pat w accs lam arrs) types stream_stms' <- runReaderT (copyPropagateInStms simpleSOACS types stream_stms) types - onStms acc $ stmsToList (fmap (certify cs) stream_stms') ++ stms + onStms acc $ stmsToList (fmap (certify (stmAuxCerts aux)) stream_stms') ++ stms onStms acc (stm : stms) = -- It is important that stm is in scope if 'maybeDistributeStm' -- wants to distribute, even if this causes the slightly silly @@ -463,7 +463,7 @@ distributeMapBodyStms acc stms -- Parallelise segmented scatters. -maybeDistributeStm stm@(Let pat (StmAux cs _ _) (Op (Scatter w ivs as lam))) acc = +maybeDistributeStm stm@(Let pat aux (Op (Scatter w ivs as lam))) acc = distributeSingleStm acc stm >>= \case Just (kernels, res, nest, acc') | Just (perm, pat_unused) <- permutationAndMissing pat res -> @@ -471,12 +471,12 @@ nest' <- expandKernelNest pat_unused nest lam' <- soacsLambda lam addPostStms kernels - postStm =<< segmentedScatterKernel nest' perm pat cs w lam' ivs as + postStm =<< segmentedScatterKernel nest' perm pat (stmAuxCerts aux) w lam' ivs as pure acc' _ -> addStmToAcc stm acc -- Parallelise segmented Hist. -maybeDistributeStm stm@(Let pat (StmAux cs _ _) (Op (Hist w as ops lam))) acc = +maybeDistributeStm stm@(Let pat aux (Op (Hist w as ops lam))) acc = distributeSingleStm acc stm >>= \case Just (kernels, res, nest, acc') | Just (perm, pat_unused) <- permutationAndMissing pat res -> @@ -484,7 +484,7 @@ lam' <- soacsLambda lam nest' <- expandKernelNest pat_unused nest addPostStms kernels - postStm =<< segmentedHistKernel nest' perm cs w ops lam' as + postStm =<< segmentedHistKernel nest' perm (stmAuxCerts aux) w ops lam' as pure acc' _ -> addStmToAcc stm acc @@ -507,7 +507,7 @@ -- -- If the scan cannot be distributed by itself, it will be -- sequentialised in the default case for this function. -maybeDistributeStm stm@(Let pat (StmAux cs _ _) (Op (Screma w arrs form))) acc +maybeDistributeStm stm@(Let pat aux (Op (Screma w arrs form))) acc | Just (scans, map_lam) <- isScanomapSOAC form, Scan lam nes <- singleScan scans = distributeSingleStm acc stm >>= \case @@ -519,7 +519,7 @@ nest' <- expandKernelNest pat_unused nest map_lam' <- soacsLambda map_lam localScope (typeEnvFromDistAcc acc') $ - segmentedScanomapKernel nest' perm cs w lam map_lam' nes arrs + segmentedScanomapKernel nest' perm (stmAuxCerts aux) w lam map_lam' nes arrs >>= kernelOrNot mempty stm acc kernels acc' _ -> addStmToAcc stm acc @@ -536,7 +536,7 @@ -- -- If the reduction cannot be distributed by itself, it will be -- sequentialised in the default case for this function. -maybeDistributeStm stm@(Let pat (StmAux cs _ _) (Op (Screma w arrs form))) acc +maybeDistributeStm stm@(Let pat aux (Op (Screma w arrs form))) acc | Just (reds, map_lam) <- isRedomapSOAC form, Reduce comm lam nes <- singleReduce reds = distributeSingleStm acc stm >>= \case @@ -554,15 +554,15 @@ | commutativeLambda lam = Commutative | otherwise = comm - regularSegmentedRedomapKernel nest' perm cs w comm' lam' map_lam' nes arrs + regularSegmentedRedomapKernel nest' perm (stmAuxCerts aux) w comm' lam' map_lam' nes arrs >>= kernelOrNot mempty stm acc kernels acc' _ -> addStmToAcc stm acc -maybeDistributeStm (Let pat (StmAux cs _ _) (Op (Screma w arrs form))) acc = do +maybeDistributeStm (Let pat aux (Op (Screma w arrs form))) acc = do -- This Screma is too complicated for us to immediately do -- anything, so split it up and try again. scope <- asksScope scopeForSOACs - distributeMapBodyStms acc . fmap (certify cs) . snd + distributeMapBodyStms acc . fmap (certify (stmAuxCerts aux)) . snd =<< runBuilderT (dissectScrema pat w form arrs) scope maybeDistributeStm stm@(Let _ aux (BasicOp (Replicate shape (Var stm_arr)))) acc = do distributeSingleUnaryStm acc stm stm_arr $ \nest outerpat arr -> @@ -771,7 +771,7 @@ -- KernelNest we produce here is technically not sensible, but it's -- good enough for flatKernel to work. let nesting = - MapNesting scatter_pat (StmAux cs mempty ()) scatter_w $ zip (lambdaParams lam) ivs + MapNesting scatter_pat (StmAux cs mempty mempty ()) scatter_w $ zip (lambdaParams lam) ivs nest' = pushInnerKernelNesting (scatter_pat, bodyResult $ lambdaBody lam) nesting nest (ispace, kernel_inps) <- flatKernel nest' diff --git a/src/Futhark/Pkg/Types.hs b/src/Futhark/Pkg/Types.hs --- a/src/Futhark/Pkg/Types.hs +++ b/src/Futhark/Pkg/Types.hs @@ -282,7 +282,7 @@ pPkgPath = T.pack - <$> some (alphaNumChar <|> oneOf ("@-/.:_" :: String)) + <$> some (alphaNumChar <|> oneOf ("@-/.:_~" :: String)) "package path" pRequired = diff --git a/src/Futhark/Profile.hs b/src/Futhark/Profile.hs --- a/src/Futhark/Profile.hs +++ b/src/Futhark/Profile.hs @@ -19,21 +19,26 @@ -- | A thing that has occurred during execution. data ProfilingEvent = ProfilingEvent - { -- | Short, single line. + { -- | Short, single line, not instance-specific. eventName :: T.Text, -- | In microseconds. eventDuration :: Double, - -- | Long, may be multiple lines. - eventDescription :: T.Text + -- | The provenance of the event - that is, from where in the original + -- program it originates. + eventProvenance :: T.Text, + -- | Arbitrary additional information, probably in the form of a dictionary, + -- but that depends on the backend. + eventDetails :: JSON.Value } deriving (Eq, Ord, Show) instance JSON.ToJSON ProfilingEvent where - toJSON (ProfilingEvent name duration description) = + toJSON (ProfilingEvent name duration provenance details) = JSON.object [ ("name", JSON.toJSON name), ("duration", JSON.toJSON duration), - ("description", JSON.toJSON description) + ("provenance", JSON.toJSON provenance), + ("details", details) ] instance JSON.FromJSON ProfilingEvent where @@ -41,7 +46,8 @@ ProfilingEvent <$> o JSON..: "name" <*> o JSON..: "duration" - <*> o JSON..: "description" + <*> o JSON..: "provenance" + <*> o JSON..: "details" -- | A profiling report contains all profiling information for a -- single benchmark (meaning a single invocation on an entry point on @@ -53,11 +59,14 @@ } deriving (Eq, Ord, Show) +mapToJSON :: (JSON.ToJSON v) => M.Map T.Text v -> JSON.Value +mapToJSON = JSON.object . map (bimap JSON.fromText JSON.toJSON) . M.toList + instance JSON.ToJSON ProfilingReport where toJSON (ProfilingReport events memory) = JSON.object [ ("events", JSON.toJSON events), - ("memory", JSON.object $ map (bimap JSON.fromText JSON.toJSON) $ M.toList memory) + ("memory", mapToJSON memory) ] instance JSON.FromJSON ProfilingReport where diff --git a/src/Futhark/Script.hs b/src/Futhark/Script.hs --- a/src/Futhark/Script.hs +++ b/src/Futhark/Script.hs @@ -162,13 +162,7 @@ parseExp :: Parsec Void T.Text () -> Parsec Void T.Text Exp parseExp sep = choice - [ lexeme sep "let" - $> Let - <*> pPat - <* lexeme sep "=" - <*> parseExp sep - <* lexeme sep "in" - <*> parseExp sep, + [ pLet, try $ Call <$> parseFunc <*> many pAtom, pAtom ] @@ -179,6 +173,17 @@ pComma = lexeme sep "," mkTuple [v] = v mkTuple vs = Tuple vs + + pLet = + lexeme sep "let" + $> Let + <*> pPat + <* lexeme sep "=" + <*> parseExp sep + <*> choice + [ lexeme sep "in" *> parseExp sep, + pLet + ] pAtom = choice diff --git a/src/Futhark/Transform/Rename.hs b/src/Futhark/Transform/Rename.hs --- a/src/Futhark/Transform/Rename.hs +++ b/src/Futhark/Transform/Rename.hs @@ -245,8 +245,8 @@ rename = pure instance (Rename dec) => Rename (StmAux dec) where - rename (StmAux cs attrs dec) = - StmAux <$> rename cs <*> rename attrs <*> rename dec + rename (StmAux cs attrs loc dec) = + StmAux <$> rename cs <*> rename attrs <*> pure loc <*> rename dec instance Rename SubExpRes where rename (SubExpRes cs se) = SubExpRes <$> rename cs <*> rename se diff --git a/src/Futhark/Transform/Substitute.hs b/src/Futhark/Transform/Substitute.hs --- a/src/Futhark/Transform/Substitute.hs +++ b/src/Futhark/Transform/Substitute.hs @@ -80,10 +80,11 @@ substituteNames _ attrs = attrs instance (Substitute dec) => Substitute (StmAux dec) where - substituteNames substs (StmAux cs attrs dec) = + substituteNames substs (StmAux cs attrs loc dec) = StmAux (substituteNames substs cs) (substituteNames substs attrs) + loc (substituteNames substs dec) instance (Substitute dec) => Substitute (Param dec) where diff --git a/src/Language/Futhark/Core.hs b/src/Language/Futhark/Core.hs --- a/src/Language/Futhark/Core.hs +++ b/src/Language/Futhark/Core.hs @@ -18,6 +18,8 @@ locText, locTextRel, prettyStacktrace, + isBuiltin, + isBuiltinLoc, -- * Name handling Name, @@ -54,6 +56,7 @@ import Futhark.Util.Loc import Futhark.Util.Pretty import Numeric.Half +import System.FilePath (takeDirectory) import Prelude hiding (id, (.)) -- | The uniqueness attribute of a type. This essentially indicates @@ -160,6 +163,18 @@ -- | 'locStrRel', but for text. locTextRel :: (Located a, Located b) => a -> b -> T.Text locTextRel a b = T.pack $ locStrRel a b + +-- | Is this include part of the built-in prelude? +isBuiltin :: FilePath -> Bool +isBuiltin = (== "/prelude") . takeDirectory + +-- | Is the position of this thing builtin as per 'isBuiltin'? Things +-- without location are considered not built-in. +isBuiltinLoc :: (Located a) => a -> Bool +isBuiltinLoc x = + case locOf x of + NoLoc -> False + Loc pos _ -> isBuiltin $ posFile pos -- | Given a list of strings representing entries in the stack trace -- and the index of the frame to highlight, produce a final 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 @@ -1017,15 +1017,13 @@ Just _ -> pure v Nothing -> bad loc env . docText $ - "Value `" - <> prettyValue v - <> "` of shape `" - <> pretty (valueShape v) - <> "` cannot match shape of type `" - <> pretty te - <> "` (`" - <> pretty t' - <> "`)" + "Value" + <+> dquotes (prettyValue v) + <+> "of shape" + <+> dquotes (pretty (valueShape v)) + <+> "cannot match shape of type" + <+> dquotes (pretty te) + <+> parens (dquotes (pretty t')) eval _ (IntLit v (Info t) _) = case t of Scalar (Prim (Signed it)) -> @@ -1640,6 +1638,7 @@ case x of (ValuePrim (UnsignedValue x')) -> pure $ ValuePrim $ SignedValue x' + ValueAD {} -> pure x -- FIXME: these do not carry signs. _ -> error $ "Cannot sign: " <> show x | "unsign_" `T.isPrefixOf` s = Just $ @@ -1647,6 +1646,7 @@ case x of (ValuePrim (SignedValue x')) -> pure $ ValuePrim $ UnsignedValue x' + ValueAD {} -> pure x -- FIXME: these do not carry signs. _ -> error $ "Cannot unsign: " <> show x def "map" = Just $ TermPoly Nothing $ \t -> do @@ -2101,11 +2101,19 @@ expectJust "jvp: differentiation failed" $ mapM ( \on -> case on of - -- If it is a JVP variable of the correct depth, return its primal and derivative + -- If it is a JVP variable of the correct depth, return + -- its primal and derivative (ValueAD d (AD.JVP (AD.JVPValue pv dv))) | d == depth -> Just (putAD pv, putAD dv) -- Otherwise, its partial derivatives are all 0 - _ -> (on,) . ValuePrim . putV . P.blankPrimValue . P.primValueType . AD.primitive <$> getAD on + _ -> + (on,) + . ValuePrim + . putV + . P.blankPrimValue + . P.primValueType + . AD.primitive + <$> getAD on ) o' @@ -2117,15 +2125,11 @@ pure $ toTuple [ov, od] where modifyValue f v = snd $ valueAccum (\a b -> (a + 1, f a b)) 0 v - modifyValueM f v = - snd - <$> valueAccumLM - ( \a b -> do - b' <- f a b - pure (a + 1, b') - ) - 0 - v + modifyValueM f v = snd <$> valueAccumLM step 0 v + where + step a b = do + b' <- f a b + pure (a + 1, b') expectJust _ (Just v) = v expectJust s Nothing = error s diff --git a/src/Language/Futhark/Interpreter/AD.hs b/src/Language/Futhark/Interpreter/AD.hs --- a/src/Language/Futhark/Interpreter/AD.hs +++ b/src/Language/Futhark/Interpreter/AD.hs @@ -377,7 +377,6 @@ if r > 0 then pure (ss', rs') else -- Otherwise, derive the tape - if r == 0 then do let s'' = fromJust (M.lookup (-uid' - 1) ss') 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 @@ -566,6 +566,10 @@ UIToFP IntType FloatType | -- | Convert a signed integer to a floating-point value. SIToFP IntType FloatType + | -- | Convert floating point number to its bitwise representation. + FPToBits FloatType + | -- | Convert bitwise representation to a floating point number. + BitsToFP FloatType | -- | Convert an integer to a boolean value. Zero -- becomes false; anything else is true. IToB IntType @@ -653,6 +657,8 @@ FPToSI <$> allFloatTypes <*> allIntTypes, UIToFP <$> allIntTypes <*> allFloatTypes, SIToFP <$> allIntTypes <*> allFloatTypes, + FPToBits <$> allFloatTypes, + BitsToFP <$> allFloatTypes, IToB <$> allIntTypes, BToI <$> allIntTypes, FToB <$> allFloatTypes, @@ -930,12 +936,30 @@ doConvOp (FPToSI _ to) (FloatValue v) = Just $ IntValue $ doFPToSI v to doConvOp (UIToFP _ to) (IntValue v) = Just $ FloatValue $ doUIToFP v to doConvOp (SIToFP _ to) (IntValue v) = Just $ FloatValue $ doSIToFP v to +doConvOp FPToBits {} (FloatValue (Float16Value x)) = + Just $ IntValue $ Int16Value $ fromIntegral $ halfToWord x +doConvOp FPToBits {} (FloatValue (Float32Value x)) = + Just $ IntValue $ Int32Value $ fromIntegral $ floatToWord x +doConvOp FPToBits {} (FloatValue (Float64Value x)) = + Just $ IntValue $ Int64Value $ fromIntegral $ doubleToWord x +doConvOp BitsToFP {} (IntValue (Int16Value x)) = + Just $ FloatValue $ Float16Value $ wordToHalf $ fromIntegral x +doConvOp BitsToFP {} (IntValue (Int32Value x)) = + Just $ FloatValue $ Float32Value $ wordToFloat $ fromIntegral x +doConvOp BitsToFP {} (IntValue (Int64Value x)) = + Just $ FloatValue $ Float64Value $ wordToDouble $ fromIntegral x doConvOp (IToB _) (IntValue v) = Just $ BoolValue $ intToInt64 v /= 0 doConvOp (BToI to) (BoolValue v) = Just $ IntValue $ intValue to $ if v then 1 else 0 :: Int doConvOp (FToB _) (FloatValue v) = Just $ BoolValue $ floatToDouble v /= 0 doConvOp (BToF to) (BoolValue v) = Just $ FloatValue $ floatValue to $ if v then 1 else 0 :: Double doConvOp _ _ = Nothing +-- | The integer type with the same size as the given floating point type. +matchingInt :: FloatType -> IntType +matchingInt Float16 = Int16 +matchingInt Float32 = Int32 +matchingInt Float64 = Int64 + -- | Turn the conversion the other way around. Note that most -- conversions are lossy, so there is no guarantee the value will -- round-trip. @@ -947,6 +971,8 @@ flipConvOp (FPToSI from to) = SIToFP to from flipConvOp (UIToFP from to) = FPToSI to from flipConvOp (SIToFP from to) = FPToSI to from +flipConvOp (FPToBits from) = BitsToFP from +flipConvOp (BitsToFP to) = FPToBits to flipConvOp (IToB from) = BToI from flipConvOp (BToI to) = IToB to flipConvOp (FToB from) = BToF from @@ -1161,6 +1187,8 @@ convOpType (FPToSI from to) = (FloatType from, IntType to) convOpType (UIToFP from to) = (IntType from, FloatType to) convOpType (SIToFP from to) = (IntType from, FloatType to) +convOpType (FPToBits from) = (FloatType from, IntType $ matchingInt from) +convOpType (BitsToFP to) = (IntType $ matchingInt to, FloatType to) convOpType (IToB from) = (IntType from, Bool) convOpType (BToI to) = (Bool, IntType to) convOpType (FToB from) = (FloatType from, Bool) @@ -1534,60 +1562,6 @@ _ -> Nothing ) ), - ( "to_bits16", - ( [FloatType Float16], - IntType Int16, - \case - [FloatValue (Float16Value x)] -> - Just $ IntValue $ Int16Value $ fromIntegral $ halfToWord x - _ -> Nothing - ) - ), - ( "to_bits32", - ( [FloatType Float32], - IntType Int32, - \case - [FloatValue (Float32Value x)] -> - Just $ IntValue $ Int32Value $ fromIntegral $ floatToWord x - _ -> Nothing - ) - ), - ( "to_bits64", - ( [FloatType Float64], - IntType Int64, - \case - [FloatValue (Float64Value x)] -> - Just $ IntValue $ Int64Value $ fromIntegral $ doubleToWord x - _ -> Nothing - ) - ), - ( "from_bits16", - ( [IntType Int16], - FloatType Float16, - \case - [IntValue (Int16Value x)] -> - Just $ FloatValue $ Float16Value $ wordToHalf $ fromIntegral x - _ -> Nothing - ) - ), - ( "from_bits32", - ( [IntType Int32], - FloatType Float32, - \case - [IntValue (Int32Value x)] -> - Just $ FloatValue $ Float32Value $ wordToFloat $ fromIntegral x - _ -> Nothing - ) - ), - ( "from_bits64", - ( [IntType Int64], - FloatType Float64, - \case - [IntValue (Int64Value x)] -> - Just $ FloatValue $ Float64Value $ wordToDouble $ fromIntegral x - _ -> Nothing - ) - ), f16_3 "lerp16" (\v0 v1 t -> v0 + (v1 - v0) * max 0 (min 1 t)), f32_3 "lerp32" (\v0 v1 t -> v0 + (v1 - v0) * max 0 (min 1 t)), f64_3 "lerp64" (\v0 v1 t -> v0 + (v1 - v0) * max 0 (min 1 t)), @@ -1950,6 +1924,8 @@ convOpFun FPToSI {} = "fptosi" convOpFun UIToFP {} = "uitofp" convOpFun SIToFP {} = "sitofp" +convOpFun FPToBits {} = "fptobits" +convOpFun BitsToFP {} = "bitstofp" convOpFun IToB {} = "itob" convOpFun BToI {} = "btoi" convOpFun FToB {} = "ftob" 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 @@ -7,8 +7,6 @@ Intrinsic (..), intrinsics, intrinsicVar, - isBuiltin, - isBuiltinLoc, maxIntrinsicTag, namesToPrimTypes, qualName, @@ -135,7 +133,6 @@ import Data.Foldable import Data.List (genericLength, isPrefixOf, sortOn) import Data.List.NonEmpty qualified as NE -import Data.Loc (Loc (..), posFile) import Data.Map.Strict qualified as M import Data.Maybe import Data.Ord @@ -147,7 +144,6 @@ import Language.Futhark.Syntax import Language.Futhark.Traversals import Language.Futhark.Tuple -import System.FilePath (takeDirectory) -- | The name of the default program entry point (@main@). defaultEntryPoint :: Name @@ -1197,18 +1193,6 @@ Prim $ Signed Int64 tupInt64 x = tupleRecord $ replicate x $ Scalar $ Prim $ Signed Int64 - --- | Is this include part of the built-in prelude? -isBuiltin :: FilePath -> Bool -isBuiltin = (== "/prelude") . takeDirectory - --- | Is the position of this thing builtin as per 'isBuiltin'? Things --- without location are considered not built-in. -isBuiltinLoc :: (Located a) => a -> Bool -isBuiltinLoc x = - case locOf x of - NoLoc -> False - Loc pos _ -> isBuiltin $ posFile pos -- | The largest tag used by an intrinsic - this can be used to -- determine whether a 'VName' refers to an intrinsic or a user-defined name. 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 @@ -1377,6 +1377,7 @@ mkApplyUT f x = AppExp (Apply f (NE.singleton (NoInfo, x)) (srcspan f x)) NoInfo +-- | Retrieve the expression for the initial values of loop parameters. loopInitExp :: LoopInitBase Info VName -> ExpBase Info VName loopInitExp (LoopInitExplicit e) = e loopInitExp (LoopInitImplicit (Info e)) = e diff --git a/src/Language/Futhark/TypeChecker/Consumption.hs b/src/Language/Futhark/TypeChecker/Consumption.hs --- a/src/Language/Futhark/TypeChecker/Consumption.hs +++ b/src/Language/Futhark/TypeChecker/Consumption.hs @@ -674,16 +674,25 @@ LoopInitExplicit e -> contain $ first LoopInitExplicit <$> checkArg [] param_t e consumed arg_cons - free_bound <- boundFreeInExp body - let bad = any (`M.member` arg_cons) . boundAliases . aliases . snd - forM_ (filter bad $ M.toList free_bound) $ \(v, _) -> do - v' <- describeVar v - addError loop_loc mempty $ - "Loop body uses" - <+> v' - <> " (or an alias)," - "but this is consumed by the initial loop argument." + let checkFree what e = do + free_bound <- boundFreeInExp e + + let bad = any (`M.member` arg_cons) . boundAliases . aliases . snd + forM_ (filter bad $ M.toList free_bound) $ \(v, _) -> do + v' <- describeVar v + addError loop_loc mempty $ + what + <+> "uses" + <+> v' + <> " (or an alias)," + "but this is consumed by the initial loop argument." + + checkFree "Loop body" body + + case form of + While cond -> checkFree "Loop condition" cond + _ -> pure () v <- VName "internal_loop_result" <$> incCounter modify $ \s -> s {stateNames = M.insert v (NameLoopRes (srclocOf loop_loc)) $ stateNames s} diff --git a/unittests/Futhark/AD/DerivativesTests.hs b/unittests/Futhark/AD/DerivativesTests.hs deleted file mode 100644 --- a/unittests/Futhark/AD/DerivativesTests.hs +++ /dev/null @@ -1,52 +0,0 @@ -module Futhark.AD.DerivativesTests (tests) where - -import Data.Map qualified as M -import Data.Text qualified as T -import Futhark.AD.Derivatives -import Futhark.Analysis.PrimExp -import Futhark.IR.Syntax.Core (nameFromText) -import Futhark.Util.Pretty (prettyString) -import Test.Tasty -import Test.Tasty.HUnit - -tests :: TestTree -tests = - testGroup - "Futhark.AD.DerivativesTests" - [ testGroup "Primitive functions" $ - map primFunTest $ - filter (not . (`elem` missing_primfuns) . fst) $ - M.toList primFuns, - testGroup "BinOps" $ map binOpTest allBinOps, - testGroup "UnOps" $ map unOpTest allUnOps - ] - where - blank = ValueExp . blankPrimValue - - primFunTest (f, (ts, ret, _)) = - testCase (T.unpack f) $ - case pdBuiltin (nameFromText f) (map blank ts) of - Nothing -> assertFailure "pdBuiltin gives Nothing" - Just v -> map primExpType v @?= replicate (length ts) ret - - -- We know we have no derivatives for these... and they are not - -- coming any time soon. - missing_primfuns = - [ "gamma16", - "gamma32", - "gamma64", - "lgamma16", - "lgamma32", - "lgamma64" - ] - - binOpTest bop = - testCase (prettyString bop) $ - let t = binOpType bop - (dx, dy) = pdBinOp bop (blank t) (blank t) - in (primExpType dx, primExpType dy) @?= (t, t) - - unOpTest bop = - testCase (prettyString bop) $ - let t = unOpType bop - in primExpType (pdUnOp bop $ blank t) @?= t diff --git a/unittests/Futhark/Analysis/AlgSimplifyTests.hs b/unittests/Futhark/Analysis/AlgSimplifyTests.hs deleted file mode 100644 --- a/unittests/Futhark/Analysis/AlgSimplifyTests.hs +++ /dev/null @@ -1,90 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# OPTIONS_GHC -fno-warn-unused-imports #-} -{-# OPTIONS_GHC -fno-warn-unused-matches #-} -{-# OPTIONS_GHC -fno-warn-unused-top-binds #-} - -module Futhark.Analysis.AlgSimplifyTests - ( tests, - ) -where - -import Control.Monad -import Data.Function ((&)) -import Data.List (subsequences) -import Data.Map qualified as M -import Data.Maybe (fromMaybe, mapMaybe) -import Futhark.Analysis.AlgSimplify hiding (add, sub) -import Futhark.Analysis.PrimExp -import Futhark.IR.Syntax.Core -import Test.Tasty -import Test.Tasty.HUnit -import Test.Tasty.QuickCheck - -tests :: TestTree -tests = - testGroup - "AlgSimplifyTests" - [ testProperty "simplify is idempotent" $ \(TestableExp e) -> simplify e == simplify (simplify e), - testProperty "simplify doesn't change exp evalutation result" $ - \(TestableExp e) -> - evalPrimExp (\_ -> Nothing) e - == evalPrimExp (\_ -> Nothing) (simplify e) - ] - -eval :: TestableExp -> Int64 -eval (TestableExp e) = evalExp e - -evalExp :: PrimExp VName -> Int64 -evalExp (ValueExp (IntValue (Int64Value i))) = i -evalExp (BinOpExp (Add Int64 OverflowUndef) e1 e2) = evalExp e1 + evalExp e2 -evalExp (BinOpExp (Sub Int64 OverflowUndef) e1 e2) = evalExp e1 - evalExp e2 -evalExp (BinOpExp (Mul Int64 OverflowUndef) e1 e2) = evalExp e1 * evalExp e2 -evalExp _ = undefined - -add :: PrimExp VName -> PrimExp VName -> PrimExp VName -add = BinOpExp (Add Int64 OverflowUndef) - -sub :: PrimExp VName -> PrimExp VName -> PrimExp VName -sub = BinOpExp (Sub Int64 OverflowUndef) - -mul :: PrimExp VName -> PrimExp VName -> PrimExp VName -mul = BinOpExp (Mul Int64 OverflowUndef) - -neg :: PrimExp VName -> PrimExp VName -neg = BinOpExp (Sub Int64 OverflowUndef) (val 0) - -l :: Int -> PrimExp VName -l i = LeafExp (VName (nameFromString $ show i) i) (IntType Int64) - -val :: Int64 -> PrimExp VName -val = ValueExp . IntValue . Int64Value - -generateExp :: Gen (PrimExp VName) -generateExp = do - n <- getSize - if n <= 1 - then val <$> arbitrary - else - oneof - [ scale (`div` 2) $ generateBinOp add, - scale (`div` 2) $ generateBinOp sub, - scale (`div` 2) $ generateBinOp mul, - scale (`div` 2) generateNeg, - val <$> arbitrary - ] - -generateBinOp :: (PrimExp VName -> PrimExp VName -> PrimExp VName) -> Gen (PrimExp VName) -generateBinOp op = do - t1 <- generateExp - op t1 <$> generateExp - -generateNeg :: Gen (PrimExp VName) -generateNeg = - do neg <$> generateExp - -newtype TestableExp = TestableExp (PrimExp VName) - deriving (Show) - -instance Arbitrary TestableExp where - arbitrary = TestableExp <$> generateExp diff --git a/unittests/Futhark/Analysis/PrimExp/TableTests.hs b/unittests/Futhark/Analysis/PrimExp/TableTests.hs deleted file mode 100644 --- a/unittests/Futhark/Analysis/PrimExp/TableTests.hs +++ /dev/null @@ -1,257 +0,0 @@ -module Futhark.Analysis.PrimExp.TableTests (tests) where - -import Control.Monad.State.Strict -import Data.Map.Strict qualified as M -import Futhark.Analysis.PrimExp -import Futhark.Analysis.PrimExp.Table -import Futhark.IR.GPU -import Futhark.IR.GPUTests () -import Futhark.IR.MC -import Futhark.IR.MCTests () -import Test.Tasty -import Test.Tasty.HUnit - -tests :: TestTree -tests = testGroup "AnalyzePrim" [stmToPrimExpsTests] - -stmToPrimExpsTests :: TestTree -stmToPrimExpsTests = - testGroup - "stmToPrimExps" - [stmToPrimExpsTestsGPU, stmToPrimExpsTestsMC] - -stmToPrimExpsTestsGPU :: TestTree -stmToPrimExpsTestsGPU = - testGroup - "GPU" - $ do - let scope = - M.fromList - [ ("n_5142", FParamName "i64"), - ("m_5143", FParamName "i64"), - ("xss_5144", FParamName "[n_5142][m_5143]i64"), - ("segmap_group_size_5201", LetName "i64"), - ("segmap_usable_groups_5202", LetName "i64"), - ("defunc_0_map_res_5203", LetName "[n_5142]i64"), - ("defunc_0_f_res_5207", LetName "i64"), - ("i_5208", IndexName Int64), - ("acc_5209", FParamName "i64"), - ("b_5210", LetName "i64"), - ("defunc_0_f_res_5211", LetName "i64") - ] - [ testCase "BinOp" $ do - let stm = "let {defunc_0_f_res_5211 : i64} = add64(acc_5209, b_5210)" - let res = execState (stmToPrimExps scope stm) mempty - let expected = - M.fromList - [ ( "defunc_0_f_res_5211", - Just - ( BinOpExp - (Add Int64 OverflowWrap) - (LeafExp "acc_5209" (IntType Int64)) - (LeafExp "b_5210" (IntType Int64)) - ) - ) - ] - res @?= expected, - testCase "Index" $ do - let stm = "let {b_5210 : i64} = xss_5144[gtid_5204, i_5208]" - let res = execState (stmToPrimExps scope stm) mempty - let expected = M.fromList [("b_5210", Nothing)] - res @?= expected, - testCase "Loop" $ do - let stm = "let {defunc_0_f_res_5207 : i64} = loop {acc_5209 : i64} = {0i64} for i_5208:i64 < m_5143 do { {defunc_0_f_res_5211} }" - let res = execState (stmToPrimExps scope stm) mempty - let expected = - M.fromList - [ ("defunc_0_f_res_5207", Nothing), - ("i_5208", Just (LeafExp "i_5208" (IntType Int64))), - ("acc_5209", Just (LeafExp "acc_5209" (IntType Int64))) - ] - res @?= expected, - testCase "Loop body" $ do - let stm = "let {defunc_0_f_res_5207 : i64} = loop {acc_5209 : i64} = {0i64} for i_5208:i64 < m_5143 do { let {b_5210 : i64} = xss_5144[gtid_5204, i_5208] let {defunc_0_f_res_5211 : i64} = add64(acc_5209, b_5210) in {defunc_0_f_res_5211} }" - let res = execState (stmToPrimExps scope stm) mempty - let expected = - M.fromList - [ ("defunc_0_f_res_5207", Nothing), - ("i_5208", Just (LeafExp "i_5208" (IntType Int64))), - ("acc_5209", Just (LeafExp "acc_5209" (IntType Int64))), - ("b_5210", Nothing), - ( "defunc_0_f_res_5211", - Just - ( BinOpExp - (Add Int64 OverflowWrap) - (LeafExp "acc_5209" (IntType Int64)) - (LeafExp "b_5210" (IntType Int64)) - ) - ) - ] - res @?= expected, - testCase "SegMap" $ - do - let stm = - "let {defunc_0_map_res_5125 : [n_5142]i64} =\ - \ segmap(thread; ; grid=segmap_usable_groups_5124; blocksize=segmap_group_size_5123)\ - \ (gtid_5126 < n_5142) (~phys_tid_5127) : {i64} {\ - \ return {returns lifted_lambda_res_5129} \ - \}" - let res = execState (stmToPrimExps scope stm) mempty - let expected = - M.fromList - [ ("defunc_0_map_res_5125", Nothing), - ("gtid_5126", Just (LeafExp "gtid_5126" (IntType Int64))) - ] - res @?= expected, - testCase "SegMap body" $ - do - let stm :: Stm GPU - stm = - "let {defunc_0_map_res_5125 : [n_5142]i64} =\ - \ segmap(thread; ; grid=segmap_usable_groups_5124; blocksize=segmap_group_size_5123)\ - \ (gtid_5126 < n_5142) (~phys_tid_5127) : {i64} {\ - \ let {eta_p_5128 : i64} =\ - \ xs_5093[gtid_5126]\ - \ let {lifted_lambda_res_5129 : i64} =\ - \ add64(2i64, eta_p_5128)\ - \ return {returns lifted_lambda_res_5129}\ - \ }" - let res = execState (stmToPrimExps scope stm) mempty - let expected = - M.fromList - [ ("defunc_0_map_res_5125", Nothing), - ("gtid_5126", Just (LeafExp "gtid_5126" (IntType Int64))), - ("eta_p_5128", Nothing), - ( "lifted_lambda_res_5129", - Just - ( BinOpExp - (Add Int64 OverflowWrap) - (ValueExp (IntValue (Int64Value 2))) - (LeafExp "eta_p_5128" (IntType Int64)) - ) - ) - ] - res @?= expected - ] - -stmToPrimExpsTestsMC :: TestTree -stmToPrimExpsTestsMC = - testGroup - "MC" - $ do - let scope = - M.fromList - [ ("n_5142", FParamName "i64"), - ("m_5143", FParamName "i64"), - ("xss_5144", FParamName "[n_5142][5143]i64"), - ("segmap_group_size_5201", LetName "i64"), - ("segmap_usable_groups_5202", LetName "i64"), - ("defunc_0_map_res_5203", LetName "[n_5142]i64"), - ("defunc_0_f_res_5207", LetName "i64"), - ("i_5208", IndexName Int64), - ("acc_5209", FParamName "i64"), - ("b_5210", LetName "i64"), - ("defunc_0_f_res_5211", LetName "i64") - ] - [ testCase "BinOp" $ do - let stm = "let {defunc_0_f_res_5211 : i64} = add64(acc_5209, b_5210)" - let res = execState (stmToPrimExps scope stm) mempty - let expected = - M.fromList - [ ( "defunc_0_f_res_5211", - Just - ( BinOpExp - (Add Int64 OverflowWrap) - (LeafExp "acc_5209" (IntType Int64)) - (LeafExp "b_5210" (IntType Int64)) - ) - ) - ] - res @?= expected, - testCase "Index" $ do - let stm = "let {b_5210 : i64} = xss_5144[gtid_5204, i_5208]" - let res = execState (stmToPrimExps scope stm) mempty - let expected = M.fromList [("b_5210", Nothing)] - res @?= expected, - testCase "Loop" $ do - let stm = "let {defunc_0_f_res_5207 : i64} = loop {acc_5209 : i64} = {0i64} for i_5208:i64 < m_5143 do { {defunc_0_f_res_5211} }" - let res = execState (stmToPrimExps scope stm) mempty - let expected = - M.fromList - [ ("defunc_0_f_res_5207", Nothing), - ("i_5208", Just (LeafExp "i_5208" (IntType Int64))), - ("acc_5209", Just (LeafExp "acc_5209" (IntType Int64))) - ] - res @?= expected, - testCase "Loop body" $ do - let stm = - "\ - \let {defunc_0_f_res_5207 : i64} =\ - \ loop {acc_5209 : i64} = {0i64}\ - \ for i_5208:i64 < m_5143 do {\ - \ let {b_5210 : i64} =\ - \ xss_5144[gtid_5204, i_5208]\ - \ let {defunc_0_f_res_5211 : i64} =\ - \ add64(acc_5209, b_5210)\ - \ in {defunc_0_f_res_5211}\ - \ }" - let res = execState (stmToPrimExps scope stm) mempty - let expected = - M.fromList - [ ("defunc_0_f_res_5207", Nothing), - ("i_5208", Just (LeafExp "i_5208" (IntType Int64))), - ("acc_5209", Just (LeafExp "acc_5209" (IntType Int64))), - ("b_5210", Nothing), - ( "defunc_0_f_res_5211", - Just - ( BinOpExp - (Add Int64 OverflowWrap) - (LeafExp "acc_5209" (IntType Int64)) - (LeafExp "b_5210" (IntType Int64)) - ) - ) - ] - res @?= expected, - testCase "SegMap" $ do - let stm = - "let {defunc_0_map_res_5125 : [n_5142]i64} =\ - \ segmap()\ - \ (gtid_5126 < n_5142) (~flat_tid_5112) : {i64} {\ - \ return {returns lifted_lambda_res_5129}\ - \ }" - let res = execState (stmToPrimExps scope stm) mempty - let expected = - M.fromList - [ ("defunc_0_map_res_5125", Nothing), - ("gtid_5126", Just (LeafExp "gtid_5126" (IntType Int64))) - ] - res @?= expected, - testCase "SegMap body" $ do - let stm :: Stm MC - stm = - "let {defunc_0_map_res_5125 : [n_5142]i64} =\ - \ segmap()\ - \ (gtid_5126 < n_5142) (~flat_tid_5112) : {i64} {\ - \ let {eta_p_5128 : i64} =\ - \ xs_5093[gtid_5126]\ - \ let {lifted_lambda_res_5129 : i64} =\ - \ add64(2i64, eta_p_5128)\ - \ return {returns lifted_lambda_res_5129}\ - \ }" - let res = execState (stmToPrimExps scope stm) mempty - let expected = - M.fromList - [ ("defunc_0_map_res_5125", Nothing), - ("gtid_5126", Just (LeafExp "gtid_5126" (IntType Int64))), - ("eta_p_5128", Nothing), - ( "lifted_lambda_res_5129", - Just - ( BinOpExp - (Add Int64 OverflowWrap) - (ValueExp (IntValue (Int64Value 2))) - (LeafExp "eta_p_5128" (IntType Int64)) - ) - ) - ] - res @?= expected - ] diff --git a/unittests/Futhark/BenchTests.hs b/unittests/Futhark/BenchTests.hs deleted file mode 100644 --- a/unittests/Futhark/BenchTests.hs +++ /dev/null @@ -1,48 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Futhark.BenchTests (tests) where - -import Data.Map qualified as M -import Data.Text qualified as T -import Futhark.Bench -import Futhark.ProfileTests () -import Test.Tasty -import Test.Tasty.QuickCheck - -instance Arbitrary RunResult where - arbitrary = RunResult . getPositive <$> arbitrary - -printable :: Gen String -printable = getASCIIString <$> arbitrary - -instance Arbitrary DataResult where - arbitrary = - DataResult - <$> (T.pack <$> printable) - <*> oneof - [ Left <$> arbText, - Right - <$> ( Result - <$> arbitrary - <*> arbMap - <*> oneof [pure Nothing, Just <$> arbText] - <*> arbitrary - ) - ] - where - arbText = T.pack <$> printable - arbMap = M.fromList <$> listOf ((,) <$> arbText <*> arbitrary) - --- XXX: we restrict this generator to single datasets to we don't have --- to worry about duplicates. -instance Arbitrary BenchResult where - arbitrary = BenchResult <$> printable <*> (pure <$> arbitrary) - -encodeDecodeJSON :: TestTree -encodeDecodeJSON = testProperty "encoding and decoding are inverse" prop - where - prop :: BenchResult -> Bool - prop brs = decodeBenchResults (encodeBenchResults [brs]) == Right [brs] - -tests :: TestTree -tests = testGroup "Futhark.BenchTests" [encodeDecodeJSON] diff --git a/unittests/Futhark/IR/GPUTests.hs b/unittests/Futhark/IR/GPUTests.hs deleted file mode 100644 --- a/unittests/Futhark/IR/GPUTests.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Futhark.IR.GPUTests () where - -import Data.String -import Futhark.IR.GPU -import Futhark.IR.Parse -import Futhark.IR.SyntaxTests (parseString) - --- There isn't anything to test in this module, but we define some --- convenience instances. - -instance IsString (Stm GPU) where - fromString = parseString "Stm GPU" parseStmGPU - -instance IsString (Body GPU) where - fromString = parseString "Body GPU" parseBodyGPU - -instance IsString (Prog GPU) where - fromString = parseString "Prog GPU" parseGPU diff --git a/unittests/Futhark/IR/MCTests.hs b/unittests/Futhark/IR/MCTests.hs deleted file mode 100644 --- a/unittests/Futhark/IR/MCTests.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Futhark.IR.MCTests () where - -import Data.String -import Futhark.IR.MC -import Futhark.IR.Parse -import Futhark.IR.SyntaxTests (parseString) - --- There isn't anything to test in this module, but we define some --- convenience instances. - -instance IsString (Stm MC) where - fromString = parseString "Stm MC" parseStmMC - -instance IsString (Body MC) where - fromString = parseString "Body MC" parseBodyMC - -instance IsString (Prog MC) where - fromString = parseString "Prog MC" parseMC diff --git a/unittests/Futhark/IR/Mem/IntervalTests.hs b/unittests/Futhark/IR/Mem/IntervalTests.hs deleted file mode 100644 --- a/unittests/Futhark/IR/Mem/IntervalTests.hs +++ /dev/null @@ -1,68 +0,0 @@ -module Futhark.IR.Mem.IntervalTests - ( tests, - ) -where - -import Futhark.Analysis.AlgSimplify -import Futhark.Analysis.PrimExp.Convert -import Futhark.IR.Mem.Interval -import Futhark.IR.Syntax -import Futhark.IR.Syntax.Core () -import Test.Tasty -import Test.Tasty.HUnit - --- Actual tests. -tests :: TestTree -tests = - testGroup - "IntervalTests" - testDistributeOffset - -name :: String -> Int -> VName -name s = VName (nameFromString s) - -testDistributeOffset :: [TestTree] -testDistributeOffset = - [ testCase "Stride is (nb-b)" $ do - let n = TPrimExp $ LeafExp (name "n" 1) $ IntType Int64 - b = TPrimExp $ LeafExp (name "b" 2) $ IntType Int64 - res <- - distributeOffset - [Prod False [untyped (n * b - b :: TPrimExp Int64 VName)]] - [ Interval 0 1 (n * b - b), - Interval 0 b b, - Interval 0 b 1 - ] - res == [Interval 1 1 (n * b - b), Interval 0 b b, Interval 0 b 1] @? "Failed", - testCase "Stride is 1024r" $ do - let r = TPrimExp $ LeafExp (name "r" 1) $ IntType Int64 - res <- - distributeOffset - [Prod False [untyped (1024 :: TPrimExp Int64 VName), untyped r]] - [ Interval 0 1 (1024 * r), - Interval 0 32 32, - Interval 0 32 1 - ] - res == [Interval 1 1 (1024 * r), Interval 0 32 32, Interval 0 32 1] @? "Failed. Got " <> show res, - testCase "Stride is 32, offsets are multples of 32" $ do - let n = TPrimExp $ LeafExp (name "n" 0) $ IntType Int64 - let g1 = TPrimExp $ LeafExp (name "g" 1) $ IntType Int64 - let g2 = TPrimExp $ LeafExp (name "g" 2) $ IntType Int64 - res <- - distributeOffset - [ Prod False [untyped (1024 :: TPrimExp Int64 VName)], - Prod False [untyped (1024 :: TPrimExp Int64 VName), untyped g1], - Prod False [untyped (32 :: TPrimExp Int64 VName), untyped g2] - ] - [ Interval 0 1 (1024 * n), - Interval 0 1 32, - Interval 0 32 1 - ] - res - == [ Interval 0 1 (1024 * n), - Interval (32 + 32 * g1 + g2) 1 32, - Interval 0 32 1 - ] - @? "Failed. Got " - <> show res - ] diff --git a/unittests/Futhark/IR/Mem/IxFun/Alg.hs b/unittests/Futhark/IR/Mem/IxFun/Alg.hs deleted file mode 100644 --- a/unittests/Futhark/IR/Mem/IxFun/Alg.hs +++ /dev/null @@ -1,176 +0,0 @@ --- | A simple index operation representation. Every operation corresponds to a --- constructor. -module Futhark.IR.Mem.IxFun.Alg - ( IxFun (..), - iota, - offsetIndex, - permute, - reshape, - coerce, - slice, - flatSlice, - expand, - shape, - index, - disjoint, - ) -where - -import Data.List qualified as L -import Data.Set qualified as S -import Futhark.IR.Pretty () -import Futhark.IR.Prop -import Futhark.IR.Syntax - ( DimIndex (..), - FlatDimIndex (..), - FlatSlice (..), - Slice (..), - flatSliceDims, - sliceDims, - unitSlice, - ) -import Futhark.Util.IntegralExp -import Futhark.Util.Pretty -import Prelude hiding (div, mod, span) - -type Shape num = [num] - -type Indices num = [num] - -type Permutation = [Int] - -data IxFun num - = Direct (Shape num) - | Permute (IxFun num) Permutation - | Index (IxFun num) (Slice num) - | FlatIndex (IxFun num) (FlatSlice num) - | Reshape (IxFun num) (Shape num) - | Coerce (IxFun num) (Shape num) - | OffsetIndex (IxFun num) num - | Expand num num (IxFun num) - deriving (Eq, Show) - -instance (Pretty num) => Pretty (IxFun num) where - pretty (Direct dims) = - "Direct" <> parens (commasep $ map pretty dims) - pretty (Permute fun perm) = pretty fun <> pretty perm - pretty (Index fun is) = pretty fun <> pretty is - pretty (FlatIndex fun is) = pretty fun <> pretty is - pretty (Reshape fun oldshape) = - pretty fun - <> "->reshape" - <> parens (pretty oldshape) - pretty (Coerce fun oldshape) = - pretty fun - <> "->coerce" - <> parens (pretty oldshape) - pretty (OffsetIndex fun i) = - pretty fun <> "->offset_index" <> parens (pretty i) - pretty (Expand o p fun) = - "expand(" <> pretty o <> "," <+> pretty p <> "," <+> pretty fun <> ")" - -iota :: Shape num -> IxFun num -iota = Direct - -offsetIndex :: IxFun num -> num -> IxFun num -offsetIndex = OffsetIndex - -permute :: IxFun num -> Permutation -> IxFun num -permute = Permute - -slice :: IxFun num -> Slice num -> IxFun num -slice = Index - -flatSlice :: IxFun num -> FlatSlice num -> IxFun num -flatSlice = FlatIndex - -expand :: num -> num -> IxFun num -> IxFun num -expand = Expand - -reshape :: IxFun num -> Shape num -> IxFun num -reshape = Reshape - -coerce :: IxFun num -> Shape num -> IxFun num -coerce = Reshape - -shape :: - (IntegralExp num) => - IxFun num -> - Shape num -shape (Direct dims) = - dims -shape (Permute ixfun perm) = - rearrangeShape perm $ shape ixfun -shape (Index _ how) = - sliceDims how -shape (FlatIndex ixfun how) = - flatSliceDims how <> tail (shape ixfun) -shape (Reshape _ dims) = - dims -shape (Coerce _ dims) = - dims -shape (OffsetIndex ixfun _) = - shape ixfun -shape (Expand _ _ ixfun) = - shape ixfun - -index :: - (Eq num, IntegralExp num) => - IxFun num -> - Indices num -> - num -index (Direct dims) is = - sum $ zipWith (*) is slicesizes - where - slicesizes = drop 1 $ sliceSizes dims -index (Permute fun perm) is_new = - index fun is_old - where - is_old = rearrangeShape (rearrangeInverse perm) is_new -index (Index fun (Slice js)) is = - index fun (adjust js is) - where - adjust (DimFix j : js') is' = j : adjust js' is' - adjust (DimSlice j _ s : js') (i : is') = j + i * s : adjust js' is' - adjust _ _ = [] -index (FlatIndex fun (FlatSlice offset js)) is = - index fun $ sum (offset : zipWith f is js) : drop (length js) is - where - f i (FlatDimIndex _ s) = i * s -index (Reshape fun newshape) is = - let new_indices = reshapeIndex (shape fun) newshape is - in index fun new_indices -index (Coerce fun _) is = - index fun is -index (OffsetIndex fun i) is = - case shape fun of - d : ds -> - index (Index fun (Slice (DimSlice i (d - i) 1 : map (unitSlice 0) ds))) is - [] -> error "index: OffsetIndex: underlying index function has rank zero" -index (Expand o p ixfun) is = - o + p * index ixfun is - -allPoints :: (IntegralExp num, Enum num) => [num] -> [[num]] -allPoints dims = - let total = product dims - strides = drop 1 $ L.reverse $ scanl (*) 1 $ L.reverse dims - in map (unflatInd strides) [0 .. total - 1] - where - unflatInd strides x = - fst $ - foldl - ( \(res, acc) span -> - (res ++ [acc `div` span], acc `mod` span) - ) - ([], x) - strides - -disjoint :: (IntegralExp num, Ord num, Enum num) => IxFun num -> IxFun num -> Bool -disjoint ixf1 ixf2 = - let shp1 = shape ixf1 - points1 = S.fromList $ allPoints shp1 - allIdxs1 = S.map (index ixf1) points1 - shp2 = shape ixf2 - points2 = S.fromList $ allPoints shp2 - allIdxs2 = S.map (index ixf2) points2 - in S.disjoint allIdxs1 allIdxs2 diff --git a/unittests/Futhark/IR/Mem/IxFunTests.hs b/unittests/Futhark/IR/Mem/IxFunTests.hs deleted file mode 100644 --- a/unittests/Futhark/IR/Mem/IxFunTests.hs +++ /dev/null @@ -1,571 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Futhark.IR.Mem.IxFunTests - ( tests, - ) -where - -import Data.Bifunctor -import Data.Function ((&)) -import Data.List qualified as L -import Data.Map qualified as M -import Data.Text qualified as T -import Futhark.Analysis.PrimExp.Convert -import Futhark.IR.Mem.IxFun.Alg qualified as IxFunAlg -import Futhark.IR.Mem.IxFunWrapper -import Futhark.IR.Mem.IxFunWrapper qualified as IxFunWrap -import Futhark.IR.Mem.LMAD qualified as IxFunLMAD -import Futhark.IR.Prop -import Futhark.IR.Syntax -import Futhark.IR.Syntax.Core () -import Futhark.Util.IntegralExp qualified as IE -import Futhark.Util.Pretty -import Test.Tasty -import Test.Tasty.HUnit -import Prelude hiding (span) -import Prelude qualified as P - -instance IE.IntegralExp Int where - quot = P.quot - rem = P.rem - div = P.div - mod = P.mod - pow = (P.^) - sgn = Just . P.signum - -allPoints :: [Int] -> [[Int]] -allPoints dims = - let total = product dims - strides = drop 1 $ L.reverse $ scanl (*) 1 $ L.reverse dims - in map (unflatInd strides) [0 .. total - 1] - where - unflatInd :: [Int] -> Int -> [Int] - unflatInd strides x = - fst $ - foldl - ( \(res, acc) span -> - (res ++ [acc `P.div` span], acc `P.mod` span) - ) - ([], x) - strides - -compareIxFuns :: Maybe (IxFunLMAD.LMAD Int) -> IxFunAlg.IxFun Int -> Assertion -compareIxFuns (Just ixfunLMAD) ixfunAlg = - let lmadShape = IxFunLMAD.shape ixfunLMAD - algShape = IxFunAlg.shape ixfunAlg - points = allPoints lmadShape - resLMAD = map (IxFunLMAD.index ixfunLMAD) points - resAlg = map (IxFunAlg.index ixfunAlg) points - errorMessage = - T.unpack . docText $ - "lmad ixfun: " - <> pretty ixfunLMAD - "alg ixfun: " - <> pretty ixfunAlg - "lmad shape: " - <> pretty lmadShape - "alg shape: " - <> pretty algShape - "lmad points length: " - <> pretty (length resLMAD) - "alg points length: " - <> pretty (length resAlg) - "lmad points: " - <> pretty resLMAD - "alg points: " - <> pretty resAlg - in (lmadShape == algShape && resLMAD == resAlg) @? errorMessage -compareIxFuns Nothing ixfunAlg = - assertFailure $ - unlines - [ "lmad ixfun: Nothing", - "alg ixfun: " <> prettyString ixfunAlg - ] - -compareOps :: IxFunWrap.IxFun Int -> Assertion -compareOps (ixfunLMAD, ixfunAlg) = compareIxFuns ixfunLMAD ixfunAlg - -compareOpsFailure :: IxFunWrap.IxFun Int -> Assertion -compareOpsFailure (Nothing, _) = pure () -compareOpsFailure (Just ixfunLMAD, ixfunAlg) = - assertFailure . T.unpack . docText $ - "Not supposed to be representable as LMAD." - "lmad ixfun: " - <> pretty ixfunLMAD - "alg ixfun: " - <> pretty ixfunAlg - --- XXX: Clean this up. -n :: Int -n = 19 - -slice3 :: Slice Int -slice3 = - Slice - [ DimSlice 2 (n `P.div` 3) 3, - DimFix (n `P.div` 2), - DimSlice 1 (n `P.div` 2) 2 - ] - --- Actual tests. -tests :: TestTree -tests = - testGroup "IxFunTests" $ - concat - [ test_iota, - test_slice_iota, - test_slice_reshape_iota1, - test_permute_slice_iota, - test_reshape_iota, - test_reshape_permute_iota, - test_slice_reshape_iota2, - test_reshape_slice_iota3, - test_flatten_strided, - test_complex1, - test_complex2, - test_expand1, - test_expand2, - test_expand3, - test_expand4, - test_flatSlice_iota, - test_slice_flatSlice_iota, - test_flatSlice_flatSlice_iota, - test_flatSlice_slice_iota, - test_flatSlice_transpose_slice_iota - -- TODO: Without z3, these tests fail. Ideally, our internal simplifier - -- should be able to handle them: - -- - -- test_disjoint3 - ] - -singleton :: TestTree -> [TestTree] -singleton = (: []) - -test_iota :: [TestTree] -test_iota = - singleton . testCase "iota" . compareOps $ - iota [n] - -test_slice_iota :: [TestTree] -test_slice_iota = - singleton . testCase "slice . iota" . compareOps $ - slice (iota [n, n, n]) slice3 - -test_slice_reshape_iota1 :: [TestTree] -test_slice_reshape_iota1 = - singleton . testCase "slice . reshape . iota 1" . compareOps $ - slice (reshape (iota [n, n, n]) [n `P.div` 2, n `P.div` 3, 1]) slice3 - -test_permute_slice_iota :: [TestTree] -test_permute_slice_iota = - singleton . testCase "permute . slice . iota" . compareOps $ - permute (slice (iota [n, n, n]) slice3) [1, 0] - -test_reshape_iota :: [TestTree] -test_reshape_iota = - -- This tests a pattern that occurs with ScalarSpace. - singleton . testCase "reshape . zeroslice . iota" . compareOps $ - let s = Slice [DimSlice 0 n 0, DimSlice 0 n 1] - in reshape (slice (iota [n, n]) s) [1, n, 1, n] - -test_reshape_permute_iota :: [TestTree] -test_reshape_permute_iota = - -- negative reshape test - singleton . testCase "reshape . permute . iota" . compareOpsFailure $ - let newdims = [n * n, n] - in reshape (permute (iota [n, n, n]) [1, 2, 0]) newdims - -test_slice_reshape_iota2 :: [TestTree] -test_slice_reshape_iota2 = - singleton . testCase "slice . reshape . iota 2" . compareOps $ - let newdims = [n * n, n] - slc = - Slice - [ DimFix (n `P.div` 2), - DimSlice 0 n 1 - ] - in slice (reshape (iota [n, n, n, n]) newdims) slc - -test_reshape_slice_iota3 :: [TestTree] -test_reshape_slice_iota3 = - -- negative reshape test - singleton . testCase "reshape . slice . iota 3" . compareOpsFailure $ - let newdims = [n * n, n] - slc = - Slice - [ DimFix (n `P.div` 2), - DimSlice 0 n 1, - DimSlice 0 (n `P.div` 2) 1, - DimSlice 0 n 1 - ] - in reshape (slice (iota [n, n, n, n]) slc) newdims - --- Tests flattening something that is strided - this can occur after --- memory expansion. -test_flatten_strided :: [TestTree] -test_flatten_strided = - singleton . testCase "reshape . fix . iota 3d" . compareOps $ - let slc = Slice [DimSlice 0 n 1, DimSlice 0 2 1, DimFix 1] - in reshape (slice (iota [n, 2, n * n]) slc) [2 * 10] - -test_complex1 :: [TestTree] -test_complex1 = - singleton . testCase "permute . slice . permute . slice . iota 1" . compareOps $ - let slice33 = - Slice - [ DimSlice (n - 1) (n `P.div` 3) (-1), - DimSlice (n - 1) n (-1), - DimSlice (n - 1) n (-1), - DimSlice 0 n 1 - ] - ixfun = permute (slice (iota [n, n, n, n, n]) slice33) [3, 1, 2, 0] - m = n `P.div` 3 - slice1 = - Slice - [ DimSlice 0 n 1, - DimSlice (n - 1) n (-1), - DimSlice (n - 1) n (-1), - DimSlice 1 (m - 2) (-1) - ] - ixfun' = slice ixfun slice1 - in ixfun' - -test_complex2 :: [TestTree] -test_complex2 = - singleton . testCase "permute . slice . permute . slice . iota 2" . compareOps $ - let slc2 = - Slice - [ DimFix (n `P.div` 2), - DimSlice (n - 1) (n `P.div` 3) (-1), - DimSlice (n - 1) n (-1), - DimSlice (n - 1) n (-1), - DimSlice 0 n 1 - ] - ixfun = permute (slice (iota [n, n, n, n, n]) slc2) [3, 1, 2, 0] - m = n `P.div` 3 - slice1 = - Slice - [ DimSlice 0 n 1, - DimSlice (n - 1) n (-1), - DimSlice (n - 1) n (-1), - DimSlice 1 (m - 2) (-1) - ] - ixfun' = slice ixfun slice1 - in ixfun' - --- Imitates a case from memory expansion. -test_expand1 :: [TestTree] -test_expand1 = - [ testCase "expand . iota1d" . compareOps $ - expand t nt (iota [n]) - ] - where - t = 3 - nt = 7 - --- Imitates another case from memory expansion. -test_expand2 :: [TestTree] -test_expand2 = - [ testCase "expand . iota2d" . compareOps $ - expand t nt (iota [n, n]) - ] - where - t = 3 - nt = 7 - -test_expand3 :: [TestTree] -test_expand3 = - [ testCase "expand . permute . iota2d" . compareOps $ - expand t nt (permute (iota [n, n `div` 2]) [1, 0]) - ] - where - t = 3 - nt = 7 - -test_expand4 :: [TestTree] -test_expand4 = - [ testCase "expand . slice . iota1d" . compareOps $ - expand t nt (slice (iota [n]) (Slice [DimSlice (n `div` 2) (n `div` 2) 1])) - ] - where - t = 3 - nt = 7 - -test_flatSlice_iota :: [TestTree] -test_flatSlice_iota = - singleton . testCase "flatSlice . iota" . compareOps $ - flatSlice (iota [n * n * n * n]) $ - FlatSlice 2 [FlatDimIndex (n * 2) 4, FlatDimIndex n 3, FlatDimIndex 1 2] - -test_slice_flatSlice_iota :: [TestTree] -test_slice_flatSlice_iota = - singleton . testCase "slice . flatSlice . iota " . compareOps $ - slice (flatSlice (iota [2 + n * n * n]) flat_slice) $ - Slice [DimFix 2, DimSlice 0 n 1, DimFix 0] - where - flat_slice = FlatSlice 2 [FlatDimIndex (n * n) 1, FlatDimIndex n 1, FlatDimIndex 1 1] - -test_flatSlice_flatSlice_iota :: [TestTree] -test_flatSlice_flatSlice_iota = - singleton . testCase "flatSlice . flatSlice . iota " . compareOps $ - flatSlice (flatSlice (iota [10 * 10]) flat_slice_1) flat_slice_2 - where - flat_slice_1 = FlatSlice 17 [FlatDimIndex 3 27, FlatDimIndex 3 10, FlatDimIndex 3 1] - flat_slice_2 = FlatSlice 2 [FlatDimIndex 2 (-2)] - -test_flatSlice_slice_iota :: [TestTree] -test_flatSlice_slice_iota = - singleton . testCase "flatSlice . slice . iota " . compareOps $ - flatSlice (slice (iota [210, 100]) $ Slice [DimSlice 10 100 2, DimFix 10]) flat_slice_1 - where - flat_slice_1 = FlatSlice 17 [FlatDimIndex 3 27, FlatDimIndex 3 10, FlatDimIndex 3 1] - -test_flatSlice_transpose_slice_iota :: [TestTree] -test_flatSlice_transpose_slice_iota = - singleton . testCase "flatSlice . transpose . slice . iota " . compareOps $ - flatSlice (permute (slice (iota [20, 20]) $ Slice [DimSlice 1 5 2, DimSlice 0 5 2]) [1, 0]) flat_slice_1 - where - flat_slice_1 = FlatSlice 1 [FlatDimIndex 2 2] - --- test_disjoint2 :: [TestTree] --- test_disjoint2 = --- let add_nw64 = (+) - --- mul_nw64 = (*) - --- sub64 = (-) - --- vname s i = VName (nameFromString s) i --- in [ let gtid_8472 = TPrimExp $ LeafExp (vname "gtid" 8472) $ IntType Int64 - --- gtid_8473 = TPrimExp $ LeafExp (vname "gtid" 8473) $ IntType Int64 - --- gtid_8474 = TPrimExp $ LeafExp (vname "gtid" 8474) $ IntType Int64 - --- num_blocks_8284 = TPrimExp $ LeafExp (vname "num_blocks" 8284) $ IntType Int64 - --- nonnegs = freeIn [gtid_8472, gtid_8473, gtid_8474, num_blocks_8284] - --- j_m_i_8287 :: TPrimExp Int64 VName --- j_m_i_8287 = num_blocks_8284 - 1 - --- lessthans :: [(VName, PrimExp VName)] --- lessthans = --- [ (head $ namesToList $ freeIn gtid_8472, untyped j_m_i_8287), --- (head $ namesToList $ freeIn gtid_8473, untyped j_m_i_8287), --- (head $ namesToList $ freeIn gtid_8474, untyped (16 :: TPrimExp Int64 VName)) --- ] - --- lm1 :: IxFunLMAD.LMAD (TPrimExp Int64 VName) --- lm1 = --- IxFunLMAD.LMAD --- 256 --- [ IxFunLMAD.LMADDim 256 0 (sub64 (num_blocks_8284) 1) 0 , --- IxFunLMAD.LMADDim 1 0 16 1 , --- IxFunLMAD.LMADDim 16 0 16 2 --- ] --- lm2 :: IxFunLMAD.LMAD (TPrimExp Int64 VName) --- lm2 = --- IxFunLMAD.LMAD --- (add_nw64 (add_nw64 (add_nw64 (add_nw64 (mul_nw64 (256) (num_blocks_8284)) (256)) (mul_nw64 (gtid_8472) (mul_nw64 (256) (num_blocks_8284)))) (mul_nw64 (gtid_8473) (256))) (mul_nw64 (gtid_8474) (16))) --- [IxFunLMAD.LMADDim 1 0 16 0 ] --- in testCase (pretty lm1 <> " and " <> pretty lm2) $ IxFunLMAD.disjoint2 lessthans nonnegs lm1 lm2 @? "Failed" --- ] - --- test_lessThanish :: [TestTree] --- test_lessThanish = --- [testCase "0 < 1" $ IxFunLMAD.lessThanish mempty mempty 0 1 @? "Failed"] - --- test_lessThanOrEqualish :: [TestTree] --- test_lessThanOrEqualish = --- [testCase "1 <= 1" $ IxFunLMAD.lessThanOrEqualish mempty mempty 1 1 @? "Failed"] - -_test_disjoint3 :: [TestTree] -_test_disjoint3 = - let foo s = VName (nameFromString s) - add_nw64 = (+) - add64 = (+) - mul_nw64 = (*) - mul64 = (*) - sub64 = (-) - sdiv64 = IE.div - sub_nw64 = (-) - disjointTester asserts lessthans lm1 lm2 = - let nonnegs = map (`LeafExp` IntType Int64) $ namesToList $ freeIn lm1 <> freeIn lm2 - - scmap = - M.fromList $ - map (\x -> (x, Prim $ IntType Int64)) $ - namesToList $ - freeIn lm1 <> freeIn lm2 <> freeIn lessthans <> freeIn asserts - in IxFunLMAD.disjoint3 scmap asserts lessthans nonnegs lm1 lm2 - in [ testCase "lm1 and lm2" $ - let lessthans = - [ ( i_12214, - sdiv64 (sub64 n_blab 1) block_size_12121 - ), - (gtid_12553, add64 1 i_12214) - ] - & map (\(v, p) -> (head $ namesToList $ freeIn v, untyped p)) - - asserts = - [ untyped ((2 * block_size_12121 :: TPrimExp Int64 VName) .<. n_blab :: TPrimExp Bool VName), - untyped ((3 :: TPrimExp Int64 VName) .<. n_blab :: TPrimExp Bool VName) - ] - - block_size_12121 = TPrimExp $ LeafExp (foo "block_size" 12121) $ IntType Int64 - i_12214 = TPrimExp $ LeafExp (foo "i" 12214) $ IntType Int64 - n_blab = TPrimExp $ LeafExp (foo "n" 1337) $ IntType Int64 - gtid_12553 = TPrimExp $ LeafExp (foo "gtid" 12553) $ IntType Int64 - - lm1 = - IxFunLMAD.LMAD - (add_nw64 (mul64 block_size_12121 i_12214) (mul_nw64 (add_nw64 gtid_12553 1) (sub64 (mul64 block_size_12121 n_blab) block_size_12121))) - [ IxFunLMAD.LMADDim (add_nw64 (mul_nw64 block_size_12121 n_blab) (mul_nw64 (-1) block_size_12121)) (sub_nw64 (sub_nw64 (add64 1 i_12214) gtid_12553) 1), - IxFunLMAD.LMADDim 1 (block_size_12121 + 1) - ] - - lm2 = - IxFunLMAD.LMAD - (block_size_12121 * i_12214) - [ IxFunLMAD.LMADDim (add_nw64 (mul_nw64 block_size_12121 n_blab) (mul_nw64 (-1) block_size_12121)) gtid_12553, - IxFunLMAD.LMADDim 1 (1 + block_size_12121) - ] - - lm_w = - IxFunLMAD.LMAD - (add_nw64 (add64 (add64 1 n_blab) (mul64 block_size_12121 i_12214)) (mul_nw64 gtid_12553 (sub64 (mul64 block_size_12121 n_blab) block_size_12121))) - [ IxFunLMAD.LMADDim n_blab block_size_12121, - IxFunLMAD.LMADDim 1 block_size_12121 - ] - - lm_blocks = - IxFunLMAD.LMAD - (block_size_12121 * i_12214 + n_blab + 1) - [ IxFunLMAD.LMADDim (add_nw64 (mul_nw64 block_size_12121 n_blab) (mul_nw64 (-1) block_size_12121)) (i_12214 + 1), - IxFunLMAD.LMADDim n_blab block_size_12121, - IxFunLMAD.LMADDim 1 block_size_12121 - ] - - lm_lower_per = - IxFunLMAD.LMAD - (block_size_12121 * i_12214) - [ IxFunLMAD.LMADDim (add_nw64 (mul_nw64 block_size_12121 n_blab) (mul_nw64 (-1) block_size_12121)) (i_12214 + 1), - IxFunLMAD.LMADDim 1 (block_size_12121 + 1) - ] - - res1 = disjointTester asserts lessthans lm1 lm_w - res2 = disjointTester asserts lessthans lm2 lm_w - res3 = disjointTester asserts lessthans lm_lower_per lm_blocks - in res1 && res2 && res3 @? "Failed", - testCase "nw second half" $ do - let lessthans = - [ ( i_12214, - sdiv64 (sub64 n_blab 1) block_size_12121 - ), - (gtid_12553, add64 1 i_12214) - ] - & map (\(v, p) -> (head $ namesToList $ freeIn v, untyped p)) - - asserts = - [ untyped ((2 * block_size_12121 :: TPrimExp Int64 VName) .<. n_blab :: TPrimExp Bool VName), - untyped ((3 :: TPrimExp Int64 VName) .<. n_blab :: TPrimExp Bool VName) - ] - - block_size_12121 = TPrimExp $ LeafExp (foo "block_size" 12121) $ IntType Int64 - i_12214 = TPrimExp $ LeafExp (foo "i" 12214) $ IntType Int64 - n_blab = TPrimExp $ LeafExp (foo "n" 1337) $ IntType Int64 - gtid_12553 = TPrimExp $ LeafExp (foo "gtid" 12553) $ IntType Int64 - - lm1 = - IxFunLMAD.LMAD - (add_nw64 (add64 n_blab (sub64 (sub64 (mul64 n_blab (add64 1 (mul64 block_size_12121 (add64 1 i_12214)))) block_size_12121) 1)) (mul_nw64 (add_nw64 gtid_12553 1) (sub64 (mul64 block_size_12121 n_blab) block_size_12121))) - [ IxFunLMAD.LMADDim (add_nw64 (mul_nw64 block_size_12121 n_blab) (mul_nw64 (-1) block_size_12121)) (sub_nw64 (sub_nw64 (sub64 (sub64 (sdiv64 (sub64 n_blab 1) block_size_12121) i_12214) 1) gtid_12553) 1), - IxFunLMAD.LMADDim n_blab block_size_12121 - ] - - lm2 = - IxFunLMAD.LMAD - (add_nw64 (sub64 (sub64 (mul64 n_blab (add64 1 (mul64 block_size_12121 (add64 1 i_12214)))) block_size_12121) 1) (mul_nw64 (add_nw64 gtid_12553 1) (sub64 (mul64 block_size_12121 n_blab) block_size_12121))) - [ IxFunLMAD.LMADDim (add_nw64 (mul_nw64 block_size_12121 n_blab) (mul_nw64 (-1) block_size_12121)) (sub_nw64 (sub_nw64 (sub64 (sub64 (sdiv64 (sub64 n_blab 1) block_size_12121) i_12214) 1) gtid_12553) 1), - IxFunLMAD.LMADDim 1 (1 + block_size_12121) - ] - - lm3 = - IxFunLMAD.LMAD - (add64 n_blab (sub64 (sub64 (mul64 n_blab (add64 1 (mul64 block_size_12121 (add64 1 i_12214)))) block_size_12121) 1)) - [ IxFunLMAD.LMADDim (add_nw64 (mul_nw64 block_size_12121 n_blab) (mul_nw64 (-1) block_size_12121)) gtid_12553, - IxFunLMAD.LMADDim n_blab block_size_12121 - ] - - lm4 = - IxFunLMAD.LMAD - (sub64 (sub64 (mul64 n_blab (add64 1 (mul64 block_size_12121 (add64 1 i_12214)))) block_size_12121) 1) - [ IxFunLMAD.LMADDim - (add_nw64 (mul_nw64 block_size_12121 n_blab) (mul_nw64 (-1) block_size_12121)) - gtid_12553, - IxFunLMAD.LMADDim - 1 - (1 + block_size_12121) - ] - - lm_w = - IxFunLMAD.LMAD - (add_nw64 (sub64 (mul64 n_blab (add64 2 (mul64 block_size_12121 (add64 1 i_12214)))) block_size_12121) (mul_nw64 gtid_12553 (sub64 (mul64 block_size_12121 n_blab) block_size_12121))) - [ IxFunLMAD.LMADDim n_blab block_size_12121, - IxFunLMAD.LMADDim 1 block_size_12121 - ] - - res1 = disjointTester asserts lessthans lm1 lm_w - res2 = disjointTester asserts lessthans lm2 lm_w - res3 = disjointTester asserts lessthans lm3 lm_w - res4 = disjointTester asserts lessthans lm4 lm_w - in res1 && res2 && res3 && res4 @? "Failed " <> show [res1, res2, res3, res4], - testCase "lud long" $ - let lessthans = - [ bimap - (head . namesToList . freeIn) - untyped - (step, num_blocks - 1 :: TPrimExp Int64 VName) - ] - - step = TPrimExp $ LeafExp (foo "step" 1337) $ IntType Int64 - - num_blocks = TPrimExp $ LeafExp (foo "n" 1338) $ IntType Int64 - - lm1 = - IxFunLMAD.LMAD - (1024 * num_blocks * (1 + step) + 1024 * step) - [ IxFunLMAD.LMADDim (1024 * num_blocks) (num_blocks - step - 1), - IxFunLMAD.LMADDim 32 32, - IxFunLMAD.LMADDim 1 32 - ] - - lm_w1 = - IxFunLMAD.LMAD - (1024 * num_blocks * step + 1024 * step) - [ IxFunLMAD.LMADDim 32 32, - IxFunLMAD.LMADDim 1 32 - ] - - lm_w2 = - IxFunLMAD.LMAD - ((1 + step) * 1024 * num_blocks + (1 + step) * 1024) - [ IxFunLMAD.LMADDim (1024 * num_blocks) (num_blocks - step - 1), - IxFunLMAD.LMADDim 1024 (num_blocks - step - 1), - IxFunLMAD.LMADDim 1024 1, - IxFunLMAD.LMADDim 32 1, - IxFunLMAD.LMADDim 128 8, - IxFunLMAD.LMADDim 4 8, - IxFunLMAD.LMADDim 32 4, - IxFunLMAD.LMADDim 1 4 - ] - - asserts = - [ untyped ((1 :: TPrimExp Int64 VName) .<. num_blocks :: TPrimExp Bool VName) - ] - - res1 = disjointTester asserts lessthans lm1 lm_w1 - res2 = disjointTester asserts lessthans lm1 lm_w2 - in res1 && res2 @? "Failed" - ] diff --git a/unittests/Futhark/IR/Mem/IxFunWrapper.hs b/unittests/Futhark/IR/Mem/IxFunWrapper.hs deleted file mode 100644 --- a/unittests/Futhark/IR/Mem/IxFunWrapper.hs +++ /dev/null @@ -1,72 +0,0 @@ --- | Perform index function operations in both algebraic and LMAD --- representations. -module Futhark.IR.Mem.IxFunWrapper - ( IxFun, - iota, - permute, - reshape, - coerce, - slice, - flatSlice, - expand, - ) -where - -import Control.Monad (join) -import Futhark.IR.Mem.IxFun.Alg qualified as IA -import Futhark.IR.Mem.LMAD qualified as I -import Futhark.IR.Syntax (FlatSlice, Slice) -import Futhark.Util.IntegralExp - -type Shape num = [num] - -type Permutation = [Int] - -type IxFun num = (Maybe (I.LMAD num), IA.IxFun num) - -iota :: - (IntegralExp num) => - Shape num -> - IxFun num -iota x = (Just $ I.iota 0 x, IA.iota x) - -permute :: - IxFun num -> - Permutation -> - IxFun num -permute (l, a) x = (I.permute <$> l <*> pure x, IA.permute a x) - -reshape :: - (Eq num, IntegralExp num) => - IxFun num -> - Shape num -> - IxFun num -reshape (l, a) x = (join (I.reshape <$> l <*> pure x), IA.reshape a x) - -coerce :: - IxFun num -> - Shape num -> - IxFun num -coerce (l, a) x = (I.coerce <$> l <*> pure x, IA.coerce a x) - -slice :: - (Eq num, IntegralExp num) => - IxFun num -> - Slice num -> - IxFun num -slice (l, a) x = (I.slice <$> l <*> pure x, IA.slice a x) - -flatSlice :: - (IntegralExp num) => - IxFun num -> - FlatSlice num -> - IxFun num -flatSlice (l, a) x = (I.flatSlice <$> l <*> pure x, IA.flatSlice a x) - -expand :: - (IntegralExp num) => - num -> - num -> - IxFun num -> - IxFun num -expand o p (lf, af) = (Just . I.expand o p =<< lf, IA.expand o p af) diff --git a/unittests/Futhark/IR/Prop/RearrangeTests.hs b/unittests/Futhark/IR/Prop/RearrangeTests.hs deleted file mode 100644 --- a/unittests/Futhark/IR/Prop/RearrangeTests.hs +++ /dev/null @@ -1,54 +0,0 @@ -module Futhark.IR.Prop.RearrangeTests (tests) where - -import Control.Applicative -import Futhark.IR.Prop.Rearrange -import Test.Tasty -import Test.Tasty.HUnit -import Test.Tasty.QuickCheck -import Prelude - -tests :: TestTree -tests = - testGroup "RearrangeTests" $ - isMapTransposeTests - ++ [isMapTransposeProp] - -isMapTransposeTests :: [TestTree] -isMapTransposeTests = - [ testCase (unwords ["isMapTranspose", show perm, "==", show dres]) $ - isMapTranspose perm @?= dres - | (perm, dres) <- - [ ([0, 1, 4, 5, 2, 3], Just (2, 2, 2)), - ([1, 0, 4, 5, 2, 3], Nothing), - ([1, 0], Just (0, 1, 1)), - ([0, 2, 1], Just (1, 1, 1)), - ([0, 1, 2], Nothing), - ([1, 0, 2], Nothing) - ] - ] - -newtype Permutation = Permutation [Int] - deriving (Eq, Ord, Show) - -instance Arbitrary Permutation where - arbitrary = do - Positive n <- arbitrary - Permutation <$> shuffle [0 .. n - 1] - -isMapTransposeProp :: TestTree -isMapTransposeProp = testProperty "isMapTranspose corresponds to a map of transpose" prop - where - prop :: Permutation -> Bool - prop (Permutation perm) = - case isMapTranspose perm of - Nothing -> True - Just (r1, r2, r3) -> - and - [ r1 >= 0, - r2 > 0, - r3 > 0, - r1 + r2 + r3 == length perm, - let (mapped, notmapped) = splitAt r1 perm - (pretrans, posttrans) = splitAt r2 notmapped - in mapped ++ posttrans ++ pretrans == [0 .. length perm - 1] - ] diff --git a/unittests/Futhark/IR/Prop/ReshapeTests.hs b/unittests/Futhark/IR/Prop/ReshapeTests.hs deleted file mode 100644 --- a/unittests/Futhark/IR/Prop/ReshapeTests.hs +++ /dev/null @@ -1,236 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Futhark.IR.Prop.ReshapeTests - ( tests, - ) -where - -import Data.List qualified as L -import Futhark.IR.Prop.Constants -import Futhark.IR.Prop.Reshape -import Futhark.IR.Syntax -import Futhark.IR.SyntaxTests () -import Test.Tasty -import Test.Tasty.HUnit - -intShape :: [Int] -> Shape -intShape = Shape . map (intConst Int32 . toInteger) - -reshapeOuterTests :: [TestTree] -reshapeOuterTests = - [ testCase (unwords ["reshapeOuter", show sc, show n, show shape, "==", show sc_res]) $ - reshapeOuter (intShape sc) n (intShape shape) @?= intShape sc_res - | (sc, n, shape, sc_res) <- - [ ([1], 1, [4, 3], [1, 3]), - ([1], 2, [4, 3], [1]), - ([2, 2], 1, [4, 3], [2, 2, 3]), - ([2, 2], 2, [4, 3], [2, 2]) - ] - ] - -reshapeInnerTests :: [TestTree] -reshapeInnerTests = - [ testCase (unwords ["reshapeInner", show sc, show n, show shape, "==", show sc_res]) $ - reshapeInner (intShape sc) n (intShape shape) @?= intShape sc_res - | (sc, n, shape, sc_res) <- - [ ([1], 1, [4, 3], [4, 1]), - ([1], 0, [4, 3], [1]), - ([2, 2], 1, [4, 3], [4, 2, 2]), - ([2, 2], 0, [4, 3], [2, 2]) - ] - ] - -dimFlatten :: Int -> Int -> d -> DimSplice d -dimFlatten i k w = DimSplice i k (Shape [w]) - -dimUnflatten :: Int -> [d] -> DimSplice d -dimUnflatten i ws = DimSplice i 1 (Shape ws) - -dimCoerce :: Int -> d -> DimSplice d -dimCoerce i w = DimSplice i 1 (Shape [w]) - -dimSplice :: Int -> Int -> [d] -> DimSplice d -dimSplice i n s = DimSplice i n $ Shape s - -flipReshapeRearrangeTests :: [TestTree] -flipReshapeRearrangeTests = - [ testCase - ( unwords - [ "flipReshapeRearrange", - show v0_shape, - show v1_shape, - show perm - ] - ) - $ flipReshapeRearrange v0_shape v1_shape perm @?= res - | (v0_shape :: [String], v1_shape, perm, res) <- - [ ( ["A", "B", "C"], - ["A", "BC"], - [1, 0], - Just [1, 2, 0] - ), - ( ["A", "B", "C", "D"], - ["A", "BCD"], - [1, 0], - Just [1, 2, 3, 0] - ), - ( ["A"], - ["B", "C"], - [1, 0], - Nothing - ), - ( ["A", "B", "C"], - ["AB", "C"], - [1, 0], - Just [2, 0, 1] - ), - ( ["A", "B", "C", "D"], - ["ABC", "D"], - [1, 0], - Just [3, 0, 1, 2] - ) - ] - ] - -flipRearrangeReshapeTests :: [TestTree] -flipRearrangeReshapeTests = - [ testCase - ( unwords - [ "flipRearrangeReshape", - show perm, - prettyStringOneLine newshape - ] - ) - $ flipRearrangeReshape perm newshape @?= res - | (perm, newshape :: NewShape String, res) <- - [ ( [1, 0], - NewShape - [dimUnflatten 1 ["B", "C"]] - (Shape ["A", "B", "C"]), - Just - ( NewShape - [dimUnflatten 0 ["B", "C"]] - (Shape ["B", "C", "A"]), - [2, 0, 1] - ) - ), - ( [1, 0], - NewShape - [dimFlatten 0 2 "AB"] - (Shape ["AB"]), - Nothing - ) - ] - ] - -simplifyTests :: TestTree -simplifyTests = - testGroup - "simplifyNewShape" - [ testCase "Inverse flatten and unflatten - simple case" $ - lhs - ["A", "B"] - [dimFlatten 0 2 "AB", dimUnflatten 0 ["A", "B"]] - @?= Just [], - testCase "Non-inverse flatten and unflatten - simple case" $ - lhs - ["A", "B"] - [dimFlatten 0 2 "AB", dimUnflatten 0 ["C", "D"]] - @?= Just [dimSplice 0 2 ["C", "D"]], - testCase "Inverse flatten and unflatten - separated by coercion" $ - lhs - ["A", "B"] - [ dimFlatten 0 2 "AB", - dimCoerce 0 "CD", - dimUnflatten 0 ["C", "D"] - ] - @?= Just [dimSplice 0 2 ["C", "D"]], - testCase "Two unflattens - simple case" $ - lhs - ["ABC"] - [dimUnflatten 0 ["A", "BC"], dimUnflatten 1 ["B", "C"]] - @?= Just [dimUnflatten 0 ["A", "B", "C"]], - testCase "Two unflattens with unchanged prefix" $ - lhs - ["A", "B", "C", "D", "E"] - [ DimSplice 3 2 $ Shape ["DE"], - DimSplice 2 2 $ Shape ["CDE"] - ] - @?= Just [dimFlatten 2 3 "CDE"], - testCase "Identity coerce" $ - lhs - ["A", "B", "C"] - [dimCoerce 1 "B", dimCoerce 2 "C"] - @?= Just [], - testCase "Identity coerce (multiple dimensions)" $ - lhs - ["A", "B", "C"] - [DimSplice 1 2 (Shape ["B", "C"])] - @?= Just [], - testCase "Identity coerce (with non-identity stuff afterwards)" $ - lhs - ["B", "CD"] - [dimCoerce 0 "B", dimUnflatten 1 ["C", "D"]] - @?= Just [dimUnflatten 1 ["C", "D"]], - testCase "Get rid of a coerce before an unflatten" $ - lhs - ["CD"] - [dimCoerce 0 "AB", dimUnflatten 0 ["A", "B"]] - @?= Just [dimUnflatten 0 ["A", "B"]], - testCase "Get rid of a coerce after a flatten" $ - lhs - ["A", "B", "C"] - [dimFlatten 0 2 "ABC", dimCoerce 0 "K"] - @?= Just [dimFlatten 0 2 "K"], - testCase "Flatten and unflatten (invariant suffix)" $ - lhs - ["A", "B", "C"] - [dimFlatten 0 3 "ABC", dimUnflatten 0 ["D", "E", "C"]] - @?= Just [dimSplice 0 2 ["D", "E"]], - testCase "Flatten and unflatten (invariant prefix)" $ - lhs - ["A", "B", "C"] - [dimFlatten 0 3 "ABC", dimUnflatten 0 ["A", "D", "E"]] - @?= Just [dimSplice 1 2 ["D", "E"]], - testCase "Invariant part of splice" $ - lhs - ["A", "B", "C", "D"] - [DimSplice 1 3 $ Shape ["BC", "D"]] - @?= Just [DimSplice 1 2 $ Shape ["BC"]], - testCase "Necessary coercion" $ - lhs - ["A", "B"] - [dimCoerce 0 "C", dimCoerce 1 "D"] - @?= Nothing, - testCase "Another necessary coercion" $ - lhs - ["A", "B", "C"] - [dimCoerce 0 "A'", dimCoerce 1 "A'", dimCoerce 2 "A'"] - @?= Nothing, - testCase "Long with redundancies" $ - lhs - ["A", "B", "C", "D"] - [ DimSplice 1 3 $ Shape ["BC", "D"], - dimCoerce 1 "BC", - dimCoerce 2 "D", - dimFlatten 1 2 "BCD", - dimFlatten 0 2 "ABCD" - ] - @?= Just [dimFlatten 0 4 "ABCD"] - ] - where - lhs orig_shape ss = - let res_shape :: ShapeBase String = - L.foldl' applySplice (Shape orig_shape) ss - in dimSplices - <$> simplifyNewShape (Shape orig_shape) (NewShape ss res_shape) - -tests :: TestTree -tests = - testGroup "ReshapeTests" . mconcat $ - [ reshapeOuterTests, - reshapeInnerTests, - flipReshapeRearrangeTests, - flipRearrangeReshapeTests, - [simplifyTests] - ] diff --git a/unittests/Futhark/IR/PropTests.hs b/unittests/Futhark/IR/PropTests.hs deleted file mode 100644 --- a/unittests/Futhark/IR/PropTests.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Futhark.IR.PropTests - ( tests, - ) -where - -import Futhark.IR.Prop.RearrangeTests qualified -import Futhark.IR.Prop.ReshapeTests qualified -import Test.Tasty - -tests :: TestTree -tests = - testGroup - "PropTests" - [ Futhark.IR.Prop.ReshapeTests.tests, - Futhark.IR.Prop.RearrangeTests.tests - ] diff --git a/unittests/Futhark/IR/Syntax/CoreTests.hs b/unittests/Futhark/IR/Syntax/CoreTests.hs deleted file mode 100644 --- a/unittests/Futhark/IR/Syntax/CoreTests.hs +++ /dev/null @@ -1,70 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Futhark.IR.Syntax.CoreTests (tests) where - -import Control.Applicative -import Futhark.IR.Pretty (prettyString) -import Futhark.IR.Syntax.Core -import Language.Futhark.CoreTests () -import Language.Futhark.PrimitiveTests () -import Test.QuickCheck -import Test.Tasty -import Test.Tasty.HUnit -import Prelude - -tests :: TestTree -tests = testGroup "Internal CoreTests" subShapeTests - -subShapeTests :: [TestTree] -subShapeTests = - [ shape [free 1, free 2] `isSubShapeOf` shape [free 1, free 2], - shape [free 1, free 3] `isNotSubShapeOf` shape [free 1, free 2], - shape [free 1] `isNotSubShapeOf` shape [free 1, free 2], - shape [free 1, free 2] `isSubShapeOf` shape [free 1, Ext 3], - shape [Ext 1, Ext 2] `isNotSubShapeOf` shape [Ext 1, Ext 1], - shape [Ext 1, Ext 1] `isSubShapeOf` shape [Ext 1, Ext 2] - ] - where - shape :: [ExtSize] -> ExtShape - shape = Shape - - free :: Int -> ExtSize - free = Free . Constant . IntValue . Int32Value . fromIntegral - - isSubShapeOf shape1 shape2 = - subShapeTest shape1 shape2 True - isNotSubShapeOf shape1 shape2 = - subShapeTest shape1 shape2 False - - subShapeTest :: ExtShape -> ExtShape -> Bool -> TestTree - subShapeTest shape1 shape2 expected = - testCase - ( "subshapeOf " - ++ prettyString shape1 - ++ " " - ++ prettyString shape2 - ++ " == " - ++ show expected - ) - $ shape1 `subShapeOf` shape2 @?= expected - -instance Arbitrary NoUniqueness where - arbitrary = pure NoUniqueness - -instance (Arbitrary shape, Arbitrary u) => Arbitrary (TypeBase shape u) where - arbitrary = - oneof - [ Prim <$> arbitrary, - Array <$> arbitrary <*> arbitrary <*> arbitrary - ] - -instance Arbitrary Ident where - arbitrary = Ident <$> arbitrary <*> arbitrary - -instance Arbitrary Rank where - arbitrary = Rank <$> elements [1 .. 9] - -instance Arbitrary Shape where - arbitrary = Shape . map intconst <$> listOf1 (elements [1 .. 9]) - where - intconst = Constant . IntValue . Int32Value diff --git a/unittests/Futhark/IR/SyntaxTests.hs b/unittests/Futhark/IR/SyntaxTests.hs deleted file mode 100644 --- a/unittests/Futhark/IR/SyntaxTests.hs +++ /dev/null @@ -1,33 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Futhark.IR.SyntaxTests (parseString) where - -import Data.String -import Data.Text qualified as T -import Futhark.IR.Parse -import Futhark.IR.Syntax - --- There isn't anything to test in this module, but we define some --- convenience instances. - -parseString :: String -> (FilePath -> T.Text -> Either T.Text a) -> String -> a -parseString desc p = - either (error . T.unpack) id . p ("IsString " <> desc) . T.pack - -instance IsString Type where - fromString = parseString "Type" parseType - -instance IsString DeclExtType where - fromString = parseString "DeclExtType" parseDeclExtType - -instance IsString DeclType where - fromString = parseString "DeclType" parseDeclType - -instance IsString VName where - fromString = parseString "VName" parseVName - -instance IsString SubExp where - fromString = parseString "SubExp" parseSubExp - -instance IsString SubExpRes where - fromString = parseString "SubExpRes" parseSubExpRes diff --git a/unittests/Futhark/Internalise/TypesValuesTests.hs b/unittests/Futhark/Internalise/TypesValuesTests.hs deleted file mode 100644 --- a/unittests/Futhark/Internalise/TypesValuesTests.hs +++ /dev/null @@ -1,170 +0,0 @@ -module Futhark.Internalise.TypesValuesTests (tests) where - -import Control.Monad.Free (Free (..)) -import Data.Map qualified as M -import Data.String (fromString) -import Futhark.IR.Syntax hiding (Free) -import Futhark.IR.SyntaxTests () -import Futhark.Internalise.TypesValues -import Language.Futhark.SyntaxTests () -import Test.Tasty -import Test.Tasty.HUnit - -internaliseTypeTests :: TestTree -internaliseTypeTests = - testGroup - "internaliseType" - [ mkTest - "[0]()" - [Free [Pure "[0i64]unit"]], - mkTest - "{a: [t_7447][n_7448](f32, f32), b: i64, c: i64}" - [Free [Pure "[t_7447][n_7448]f32", Pure "[t_7447][n_7448]f32"], Pure "i64", Pure "i64"], - mkTest - "([0]i32, {a: f32, b: f32, c: f32, d: [0]((f32, f32), (f32, f32))})" - [ Free [Pure "[0i64]i32"], - Pure "f32", - Pure "f32", - Pure "f32", - Free [Pure "[0i64]f32", Pure "[0i64]f32", Pure "[0i64]f32", Pure "[0i64]f32"] - ], - mkTest - "[0]([1]i32, f32)" - [Free [Free [Pure "[0i64][1i64]i32"], Pure "[0i64]f32"]] - ] - where - mkTest x y = - testCase (prettyString x) $ internaliseType x @?= y - -sumTypeTests :: TestTree -sumTypeTests = - testGroup - "internaliseConstructors" - [ testCase "Dedup of primitives" $ - internaliseConstructors - ( M.fromList - [ ("foo", [Pure "i64"]), - ("bar", [Pure "i64"]) - ] - ) - @?= ( [Pure "i64"], - [ ("bar", [0]), - ("foo", [0]) - ] - ), - testCase "Dedup of array" $ - internaliseConstructors - ( M.fromList - [ ("foo", [Pure "[?0]i64"]), - ("bar", [Pure "[?0]i64"]) - ] - ) - @?= ( [Pure "[?0]i64", Pure "[?0]i64"], - [ ("bar", [0]), - ("foo", [1]) - ] - ), - testCase - "Dedup of array of tuple" - $ internaliseConstructors - ( M.fromList - [ ("foo", [Free [Pure "[?0]i64", Pure "[?0]i64"]]), - ("bar", [Pure "[?0]i64"]) - ] - ) - @?= ( [Pure "[?0]i64", Free [Pure "[?0]i64", Pure "[?0]i64"]], - [ ("bar", [0]), - ("foo", [1, 2]) - ] - ) - ] - --- Be aware that some of these tests simply reinforce current --- behaviour - it may be that we want to restrict aliasing even --- further in the future; these tests would have to be updated in such --- cases. -inferAliasesTests :: TestTree -inferAliasesTests = - testGroup - "inferAliases" - [ mkTest - [Free [Pure "[0i64]i32"]] - [Free [Pure "[?0]i32"]] - [[("[?0]i32", RetAls [0] [0])]], - mkTest - [Free [Pure "[0i64]i32", Pure "[0i64]i32"]] - [Free [Pure "[0i64]i32", Pure "[0i64]i32"]] - [ [ ("[0i64]i32", RetAls [0] [0]), - ("[0i64]i32", RetAls [1] [1]) - ] - ], - -- Basically zip. - mkTest - [Free [Pure "[n_0]i32"], Free [Pure "[n_0]i32"]] - [Free [Pure "[n_0]i32", Pure "[n_0]i32"]] - [ [ ("[n_0]i32", RetAls [] [0]), - ("[n_0]i32", RetAls [] [1]) - ] - ], - mkTest - [Free [Pure "[0i64]i32"], Free [Pure "[0i64]i32", Pure "[0i64]i32"]] - [Free [Pure "[?0]i32", Pure "[?0]i32"]] - [ [ ("[?0]i32", RetAls [1] [0]), - ("[?0]i32", RetAls [2] [1]) - ] - ], - mkTest - [Free [Pure "[0i64][1i64]i32", Pure "[0i64][1i64]i32"]] - [Free [Pure "[?0]i32", Pure "[?0]i32"]] - [ [ ("[?0]i32", RetAls [0] [0]), - ("[?0]i32", RetAls [1] [1]) - ] - ], - -- Basically unzip. - mkTest - [Free [Pure "[n_0][n_1]i32", Pure "[n_0][n_1]i32"]] - [Free [Pure "[?0]i32"], Free [Pure "[?0]i32"]] - [ [("[?0]i32", RetAls [] [0, 1])], - [("[?0]i32", RetAls [] [0, 1])] - ], - mkTest - [ Free [Pure "*[n_0][n_1]i32"], - Free [Pure "[n_2]i64"], - Free [Pure "[n_3]i64"] - ] - [Free [Pure "*[n_0][n_1]i32"]] - [[("*[n_0][n_1]i32", RetAls [] [])]], - mkTest - [Free [Pure "[n_0]i32", Free [Pure "[n_0][n_1]i32"]]] - [Free [Pure "[n_0]i32"]] - [[("[n_0]i32", RetAls [1] [0])]], - mkTest - [] - [ Free [Pure "[n_0]i32", Free [Pure "[n_0][n_1]i32"]], - Free [Pure "[n_0]i32"] - ] - [ [("[n_0]i32", RetAls [] [0]), ("[n_0][n_1]i32", RetAls [] [1])], - [("[n_0]i32", RetAls [] [1, 2])] - ], - mkTest - [Free [Pure "[n_0]i32"]] - [Free [Pure "[m_1][m_1]i32"]] - [ [("[m_1][m_1]i32", RetAls [0] [0])] - ] - ] - where - mkTest all_param_ts all_res_ts expected = - testCase (show all_param_ts <> " " <> show all_res_ts) $ - inferAliases - (map (fmap fromString) all_param_ts) - (map (fmap fromString) all_res_ts) - @?= expected - -tests :: TestTree -tests = - testGroup - "Futhark.Internalise.TypesValuesTests" - [ internaliseTypeTests, - sumTypeTests, - inferAliasesTests - ] diff --git a/unittests/Futhark/Optimise/ArrayLayout/AnalyseTests.hs b/unittests/Futhark/Optimise/ArrayLayout/AnalyseTests.hs deleted file mode 100644 --- a/unittests/Futhark/Optimise/ArrayLayout/AnalyseTests.hs +++ /dev/null @@ -1,241 +0,0 @@ -module Futhark.Optimise.ArrayLayout.AnalyseTests (tests) where - -import Data.Map.Strict qualified as M -import Futhark.Analysis.AccessPattern -import Futhark.IR.GPU -import Futhark.IR.GPUTests () -import Futhark.IR.SyntaxTests () -import Test.Tasty -import Test.Tasty.HUnit - -tests :: TestTree -tests = testGroup "Analyse" [analyseStmTests] - -analyseStmTests :: TestTree -analyseStmTests = - testGroup - "analyseStm" - [analyseIndexTests, analyseDimAccessesTests] - -analyseIndexTests :: TestTree -analyseIndexTests = - testGroup - "analyseIndex" - $ do - let arr_name = "xss_5144" - -- ============================= TestCase0 ============================= - -- Most simple case where we want to manifest an array, hence, we record - -- the Index in the IndexTable. - let testCase0 = testCase "2D manifest" $ do - let ctx = - mempty - { parents = - [ SegOpName (SegmentedMap "defunc_0_map_res_5204"), - LoopBodyName "defunc_0_f_res_5208" - ], - assignments = - M.fromList - [ ("gtid_5205", VariableInfo mempty 0 mempty ThreadID), - ("i_5209", VariableInfo mempty 1 mempty LoopVar) - ] - } - let patternNames = ["b_5211"] - let dimFixes = - [ DimFix (Var "gtid_5205"), - DimFix (Var "i_5209") - ] - let indexTable = - M.fromList - [ ( SegmentedMap "defunc_0_map_res_5204", - M.fromList - [ ( (arr_name, [], [0 .. 1]), - M.fromList - [ ( "b_5211", - [ DimAccess (M.fromList [("gtid_5205", Dependency 0 ThreadID)]) (Just "gtid_5205"), - DimAccess (M.fromList [("i_5209", Dependency 1 LoopVar)]) (Just "i_5209") - ] - ) - ] - ) - ] - ) - ] - let (_, indexTable') = analyseIndex ctx patternNames arr_name dimFixes - indexTable' @?= indexTable - - -- ============================= TestCase2 ============================= - -- We don't want to manifest an array with only one dimension, so we don't - -- record anything in the IndexTable. - let testCase1 = testCase "1D manifest" $ do - let ctx = - mempty - { parents = - [ SegOpName (SegmentedMap "defunc_0_map_res_5204"), - LoopBodyName "defunc_0_f_res_5208" - ] - } - let patternNames = ["b_5211"] - let dimFixes = [DimFix "i_5209"] - - let (_, indexTable') = analyseIndex ctx patternNames arr_name dimFixes - indexTable' @?= mempty - - -- ============================= TestCase1 ============================= - -- We don't want to record anything to the IndexTable when the array is - -- not accessed inside a SegMap - -- TODO: Create a similar one for MC with loops - let testCase2 = testCase "Not inside SegMap" $ do - let ctx = mempty - let patternNames = ["b_5211"] - let dimFixes = - [ DimFix "gtid_5205", - DimFix "i_5209" - ] - let (_, indexTable') = analyseIndex ctx patternNames arr_name dimFixes - indexTable' @?= mempty - - -- ============================= TestCase3 ============================= - -- If an array is allocated inside a loop or SegMap, we want to record that - -- information in the ArrayName of the IndexTable. - let testCase3 = testCase "Allocated inside SegMap" $ do - let parents' = - [ SegOpName (SegmentedMap "defunc_0_map_res_5204"), - LoopBodyName "defunc_0_f_res_5208" - ] - let ctx = - mempty - { parents = parents', - assignments = - M.fromList - [ ("gtid_5205", VariableInfo mempty 0 mempty ThreadID), - ("i_5209", VariableInfo mempty 1 mempty LoopVar), - (arr_name, VariableInfo mempty 0 parents' Variable) - ] - } - let patternNames = ["b_5211"] - let dimFixes = - [ DimFix "gtid_5205", - DimFix "i_5209" - ] - let indexTable = - M.fromList - [ ( SegmentedMap "defunc_0_map_res_5204", - M.fromList - [ ( (arr_name, parents', [0 .. 1]), - M.fromList - [ ( "b_5211", - [ DimAccess (M.fromList [("gtid_5205", Dependency 0 ThreadID)]) (Just "gtid_5205"), - DimAccess (M.fromList [("i_5209", Dependency 1 LoopVar)]) (Just "i_5209") - ] - ) - ] - ) - ] - ) - ] - let (_, indexTable') = analyseIndex ctx patternNames arr_name dimFixes - indexTable' @?= indexTable - - -- ============================= TestCase4 ============================= - -- If the vars in the index are temporaries, we want to reduce them to - -- to the thread IDs and or loop counters they are functions of. - let testCase4 = testCase "Reduce dependencies" $ do - let ctx = - mempty - { parents = - [ SegOpName (SegmentedMap "defunc_0_map_res_5204"), - LoopBodyName "defunc_0_f_res_5208" - ], - assignments = - M.fromList - [ ("gtid_5205", VariableInfo mempty 0 mempty ThreadID), - ("i_5209", VariableInfo mempty 1 mempty LoopVar), - ("tmp0_5210", VariableInfo (namesFromList ["gtid_5205"]) 2 mempty Variable), - ("tmp1_5211", VariableInfo (namesFromList ["i_5209"]) 3 mempty Variable), - ("k_5212", VariableInfo mempty 1 mempty ConstType) - ] - } - let patternNames = ["b_5211"] - let dimFixes = - [ DimFix "tmp0_5210", - DimFix "tmp1_5211", - DimFix "k_5212" - ] - let indexTable = - M.fromList - [ ( SegmentedMap "defunc_0_map_res_5204", - M.fromList - [ ( (arr_name, [], [0 .. 2]), - M.fromList - [ ( "b_5211", - [ DimAccess (M.fromList [("gtid_5205", Dependency 0 ThreadID)]) (Just "tmp0_5210"), - DimAccess (M.fromList [("i_5209", Dependency 1 LoopVar)]) (Just "tmp1_5211"), - DimAccess mempty (Just "k_5212") - ] - ) - ] - ) - ] - ) - ] - let (_, indexTable') = analyseIndex ctx patternNames arr_name dimFixes - indexTable' @?= indexTable - - [testCase0, testCase1, testCase2, testCase3, testCase4] - -analyseDimAccessesTests :: TestTree -analyseDimAccessesTests = testGroup - "analyseDimAccesses" - $ do - let testCase0 = testCase "Fold" $ do - let indexTable = - M.fromList - [ ( SegmentedMap "defunc_0_map_res_5204", - M.fromList - [ ( ("xss_5144", [], [0, 1]), - M.fromList - [ ( "b_5211", - [ DimAccess (M.fromList [("gtid_5205", Dependency 0 ThreadID)]) (Just "gtid_5205"), - DimAccess (M.fromList [("i_5209", Dependency 1 LoopVar)]) (Just "i_5209") - ] - ) - ] - ) - ] - ) - ] - let indexTable' = (analyseDimAccesses @GPU) prog0 - indexTable' @?= indexTable - - [testCase0] - where - prog0 :: Prog GPU - prog0 = - "\ - \entry(\"main\",\ - \ {xss: [][]i64},\ - \ {[]i64})\ - \ entry_main (n_5142 : i64,\ - \ m_5143 : i64,\ - \ xss_5144 : [n_5142][m_5143]i64)\ - \ : {[n_5142]i64#([2], [0])} = {\ - \ let {segmap_group_size_5202 : i64} =\ - \ get_size(segmap_group_size_5190, thread_block_size)\ - \ let {segmap_usable_groups_5203 : i64} =\ - \ sdiv_up64(n_5142, segmap_group_size_5202)\ - \ let {defunc_0_map_res_5204 : [n_5142]i64} =\ - \ segmap(thread; ; grid=segmap_usable_groups_5203; blocksize=segmap_group_size_5202)\ - \ (gtid_5205 < n_5142) (~phys_tid_5206) : {i64} {\ - \ let {defunc_0_f_res_5208 : i64} =\ - \ loop {acc_5210 : i64} = {0i64}\ - \ for i_5209:i64 < m_5143 do {\ - \ let {b_5211 : i64} =\ - \ xss_5144[gtid_5205, i_5209]\ - \ let {defunc_0_f_res_5212 : i64} =\ - \ add64(acc_5210, b_5211)\ - \ in {defunc_0_f_res_5212}\ - \ }\ - \ return {returns defunc_0_f_res_5208}\ - \ }\ - \ in {defunc_0_map_res_5204}\ - \}" diff --git a/unittests/Futhark/Optimise/ArrayLayout/LayoutTests.hs b/unittests/Futhark/Optimise/ArrayLayout/LayoutTests.hs deleted file mode 100644 --- a/unittests/Futhark/Optimise/ArrayLayout/LayoutTests.hs +++ /dev/null @@ -1,163 +0,0 @@ -module Futhark.Optimise.ArrayLayout.LayoutTests (tests) where - -import Data.Map.Strict qualified as M -import Futhark.Analysis.AccessPattern -import Futhark.Analysis.PrimExp -import Futhark.FreshNames -import Futhark.IR.GPU (GPU) -import Futhark.IR.GPUTests () -import Futhark.Optimise.ArrayLayout.Layout -import Language.Futhark.Core -import Test.Tasty -import Test.Tasty.HUnit - -tests :: TestTree -tests = - testGroup - "Layout" - [commonPermutationEliminatorsTests] - -commonPermutationEliminatorsTests :: TestTree -commonPermutationEliminatorsTests = - testGroup - "commonPermutationEliminators" - [permutationTests, nestTests, dimAccessTests, constIndexElimTests] - -permutationTests :: TestTree -permutationTests = - testGroup "Permutations" $ - do - -- This isn't the way to test this, in reality we should provide realistic - -- access patterns that might result in the given permutations. - -- Luckily we only use the original access for one check atm. - [ testCase (unwords [show perm, "->", show res]) $ - commonPermutationEliminators perm [] @?= res - | (perm, res) <- - [ ([0], True), - ([1, 0], False), - ([0, 1], True), - ([0, 0], True), - ([1, 1], True), - ([1, 2, 0], False), - ([2, 0, 1], False), - ([0, 1, 2], True), - ([1, 0, 2], True), - ([2, 1, 0], True), - ([2, 2, 0], True), - ([2, 1, 1], True), - ([1, 0, 1], True), - ([0, 0, 0], True), - ([0, 1, 2, 3, 4], True), - ([1, 0, 2, 3, 4], True), - ([2, 3, 0, 1, 4], True), - ([3, 4, 2, 0, 1], True), - ([2, 3, 4, 0, 1], False), - ([1, 2, 3, 4, 0], False), - ([3, 4, 0, 1, 2], False) - ] - ] - -nestTests :: TestTree -nestTests = testGroup "Nests" $ - do - let names = generateNames 2 - [ testCase (unwords [args, "->", show res]) $ - commonPermutationEliminators [1, 0] nest @?= res - | (args, nest, res) <- - [ ("[]", [], False), - ("[CondBodyName]", [CondBodyName] <*> names, False), - ("[SegOpName]", [SegOpName . SegmentedMap] <*> names, True), - ("[LoopBodyName]", [LoopBodyName] <*> names, False), - ("[SegOpName, CondBodyName]", [SegOpName . SegmentedMap, CondBodyName] <*> names, True), - ("[CondBodyName, LoopBodyName]", [CondBodyName, LoopBodyName] <*> names, False) - ] - ] - -dimAccessTests :: TestTree -dimAccessTests = testGroup "DimAccesses" [] -- TODO: Write tests for the part of commonPermutationEliminators that checks the complexity of the DimAccesses. - -constIndexElimTests :: TestTree -constIndexElimTests = - testGroup - "constIndexElimTests" - [ testCase "gpu eliminates indexes with constant in any dim" $ do - let primExpTable = - M.fromList - [ ("gtid_4", Just (LeafExp "n_4" (IntType Int64))), - ("i_5", Just (LeafExp "n_4" (IntType Int64))) - ] - layoutTableFromIndexTable primExpTable accessTableGPU @?= mempty, - testCase "gpu ignores when not last" $ do - let primExpTable = - M.fromList - [ ("gtid_4", Just (LeafExp "gtid_4" (IntType Int64))), - ("gtid_5", Just (LeafExp "gtid_5" (IntType Int64))), - ("i_6", Just (LeafExp "i_6" (IntType Int64))) - ] - layoutTableFromIndexTable primExpTable accessTableGPUrev - @?= M.fromList - [ ( SegmentedMap "mapres_1", - M.fromList - [ ( ("a_2", [], [0, 1, 2, 3]), - M.fromList [("A_3", [2, 3, 0, 1])] - ) - ] - ) - ] - ] - where - accessTableGPU :: IndexTable GPU - accessTableGPU = - singleAccess - [ singleParAccess 0 "gtid_4", - DimAccess mempty Nothing, - singleSeqAccess 1 "i_5" - ] - - accessTableGPUrev :: IndexTable GPU - accessTableGPUrev = - singleAccess - [ singleParAccess 1 "gtid_4", - singleParAccess 2 "gtid_5", - singleSeqAccess 0 "i_5", - singleSeqAccess 2 "gtid_4" - ] - -singleAccess :: [DimAccess rep] -> IndexTable rep -singleAccess dims = - M.fromList - [ ( sgOp, - M.fromList - [ ( ("A_2", [], [0, 1, 2, 3]), - M.fromList - [ ( "a_3", - dims - ) - ] - ) - ] - ) - ] - where - sgOp = SegmentedMap {vnameFromSegOp = "mapres_1"} - -singleParAccess :: Int -> VName -> DimAccess rep -singleParAccess level name = - DimAccess - (M.singleton name $ Dependency level ThreadID) - (Just name) - -singleSeqAccess :: Int -> VName -> DimAccess rep -singleSeqAccess level name = - DimAccess - (M.singleton name $ Dependency level LoopVar) - (Just name) - -generateNames :: Int -> [VName] -generateNames count = do - let (name, source) = newName blankNameSource "i_0" - fst $ foldl f ([name], source) [1 .. count - 1] - where - f (names, source) _ = do - let (name, source') = newName source (last names) - (names ++ [name], source') diff --git a/unittests/Futhark/Optimise/ArrayLayoutTests.hs b/unittests/Futhark/Optimise/ArrayLayoutTests.hs deleted file mode 100644 --- a/unittests/Futhark/Optimise/ArrayLayoutTests.hs +++ /dev/null @@ -1,15 +0,0 @@ -module Futhark.Optimise.ArrayLayoutTests (tests) where - -import Futhark.Analysis.PrimExp.TableTests qualified -import Futhark.Optimise.ArrayLayout.AnalyseTests qualified -import Futhark.Optimise.ArrayLayout.LayoutTests qualified -import Test.Tasty - -tests :: TestTree -tests = - testGroup - "OptimizeArrayLayoutTests" - [ Futhark.Optimise.ArrayLayout.AnalyseTests.tests, - Futhark.Optimise.ArrayLayout.LayoutTests.tests, - Futhark.Analysis.PrimExp.TableTests.tests - ] diff --git a/unittests/Futhark/Optimise/MemoryBlockMerging/GreedyColoringTests.hs b/unittests/Futhark/Optimise/MemoryBlockMerging/GreedyColoringTests.hs deleted file mode 100644 --- a/unittests/Futhark/Optimise/MemoryBlockMerging/GreedyColoringTests.hs +++ /dev/null @@ -1,80 +0,0 @@ -module Futhark.Optimise.MemoryBlockMerging.GreedyColoringTests - ( tests, - ) -where - -import Control.Arrow ((***)) -import Data.Function ((&)) -import Data.Map qualified as M -import Data.Set qualified as S -import Futhark.Optimise.MemoryBlockMerging.GreedyColoring qualified as GreedyColoring -import Test.Tasty -import Test.Tasty.HUnit - -tests :: TestTree -tests = - testGroup - "GreedyColoringTests" - [psumTest, allIntersect, emptyGraph, noIntersections, differentSpaces] - -psumTest :: TestTree -psumTest = - testCase "psumTest" - $ assertEqual - "Color simple 1-2-3 using two colors" - ( [(0, "shared"), (1, "shared")] :: [(Int, String)], - [(1 :: Int, 0), (2, 1), (3, 0)] - ) - $ (M.toList *** M.toList) - $ GreedyColoring.colorGraph - (M.fromList [(1, "shared"), (2, "shared"), (3, "shared")]) - $ S.fromList [(1, 2), (2, 3)] - -allIntersect :: TestTree -allIntersect = - testCase "allIntersect" - $ assertEqual - "Color a graph where all values intersect" - ( [(0, "shared"), (1, "shared"), (2, "shared")] :: [(Int, String)], - [(1 :: Int, 2), (2, 1), (3, 0)] - ) - $ (M.toList *** M.toList) - $ GreedyColoring.colorGraph - (M.fromList [(1, "shared"), (2, "shared"), (3, "shared")]) - $ S.fromList [(1, 2), (2, 3), (1, 3)] - -emptyGraph :: TestTree -emptyGraph = - testCase "emptyGraph" - $ assertEqual - "Color an empty graph" - ([] :: [(Int, Char)], [] :: [(Int, Int)]) - $ (M.toList *** M.toList) - $ GreedyColoring.colorGraph M.empty - $ S.fromList [] - -noIntersections :: TestTree -noIntersections = - GreedyColoring.colorGraph - (M.fromList [(1, "shared"), (2, "shared"), (3, "shared")]) - (S.fromList []) - & M.toList *** M.toList - & assertEqual - "Color nodes with no intersections" - ( [(0, "shared")] :: [(Int, String)], - [(1, 0), (2, 0), (3, 0)] :: [(Int, Int)] - ) - & testCase "noIntersections" - -differentSpaces :: TestTree -differentSpaces = - GreedyColoring.colorGraph - (M.fromList [(1, "a"), (2, "b"), (3, "c")]) - (S.fromList []) - & M.toList *** M.toList - & assertEqual - "Color nodes with no intersections but in different spaces" - ( [(0, "c"), (1, "b"), (2, "a")] :: [(Int, String)], - [(1, 2), (2, 1), (3, 0)] :: [(Int, Int)] - ) - & testCase "differentSpaces" diff --git a/unittests/Futhark/Pkg/SolveTests.hs b/unittests/Futhark/Pkg/SolveTests.hs deleted file mode 100644 --- a/unittests/Futhark/Pkg/SolveTests.hs +++ /dev/null @@ -1,142 +0,0 @@ -module Futhark.Pkg.SolveTests (tests) where - -import Data.Map qualified as M -import Data.Monoid -import Data.Text qualified as T -import Futhark.Pkg.Solve -import Futhark.Pkg.Types -import Test.Tasty -import Test.Tasty.HUnit -import Prelude - -semverE :: T.Text -> SemVer -semverE s = case parseVersion s of - Left err -> - error $ - T.unpack s - <> " is not a valid version number: " - <> errorBundlePretty err - Right x -> x - --- | A world of packages and interdependencies for testing the solver --- without touching the outside world. -testEnv :: PkgRevDepInfo -testEnv = - M.fromList $ - concatMap - frob - [ ( "athas", - [ ( "foo", - [ ("0.1.0", []), - ("0.2.0", [("athas/bar", "1.0.0")]), - ("0.3.0", []) - ] - ), - ("foo@v2", [("2.0.0", [("athas/quux", "0.1.0")])]), - ("bar", [("1.0.0", [])]), - ("baz", [("0.1.0", [("athas/foo", "0.3.0")])]), - ( "quux", - [ ( "0.1.0", - [ ("athas/foo", "0.2.0"), - ("athas/baz", "0.1.0") - ] - ) - ] - ), - ( "quux_perm", - [ ( "0.1.0", - [ ("athas/baz", "0.1.0"), - ("athas/foo", "0.2.0") - ] - ) - ] - ), - ("x_bar", [("1.0.0", [("athas/bar", "1.0.0")])]), - ("x_foo", [("1.0.0", [("athas/foo", "0.3.0")])]), - ( "tricky", - [ ( "1.0.0", - [ ("athas/foo", "0.2.0"), - ("athas/x_foo", "1.0.0") - ] - ) - ] - ) - ] - ), - -- Some mutually recursive packages. - ( "nasty", - [ ("foo", [("1.0.0", [("nasty/bar", "1.0.0")])]), - ("bar", [("1.0.0", [("nasty/foo", "1.0.0")])]) - ] - ) - ] - where - frob (user, repos) = do - (repo, repo_revs) <- repos - (rev, deps) <- repo_revs - let rev' = semverE rev - onDep (dp, dv) = (dp, (semverE dv, Nothing)) - deps' = PkgRevDeps $ M.fromList $ map onDep deps - pure ((user <> "/" <> repo, rev'), deps') - -newtype SolverRes = SolverRes BuildList - deriving (Eq) - -instance Show SolverRes where - show (SolverRes bl) = T.unpack $ prettyBuildList bl - -solverTest :: PkgPath -> T.Text -> Either T.Text [(PkgPath, T.Text)] -> TestTree -solverTest p v expected = - testCase (T.unpack $ p <> "-" <> prettySemVer v') $ - fmap SolverRes (solveDepsPure testEnv target) - @?= expected' - where - target = PkgRevDeps $ M.singleton p (v', Nothing) - v' = semverE v - expected' = SolverRes . BuildList . M.fromList . map onRes <$> expected - onRes (dp, dv) = (dp, semverE dv) - -tests :: TestTree -tests = - testGroup - "SolveTests" - [ solverTest "athas/foo" "0.1.0" $ - Right [("athas/foo", "0.1.0")], - solverTest "athas/foo" "0.2.0" $ - Right - [ ("athas/foo", "0.2.0"), - ("athas/bar", "1.0.0") - ], - solverTest "athas/quux" "0.1.0" $ - Right - [ ("athas/quux", "0.1.0"), - ("athas/foo", "0.3.0"), - ("athas/baz", "0.1.0") - ], - solverTest "athas/quux_perm" "0.1.0" $ - Right - [ ("athas/quux_perm", "0.1.0"), - ("athas/foo", "0.3.0"), - ("athas/baz", "0.1.0") - ], - solverTest "athas/foo@v2" "2.0.0" $ - Right - [ ("athas/foo@v2", "2.0.0"), - ("athas/quux", "0.1.0"), - ("athas/foo", "0.3.0"), - ("athas/baz", "0.1.0") - ], - solverTest "athas/foo@v3" "3.0.0" $ - Left "Unknown package/version: athas/foo@v3-3.0.0", - solverTest "nasty/foo" "1.0.0" $ - Right - [ ("nasty/foo", "1.0.0"), - ("nasty/bar", "1.0.0") - ], - solverTest "athas/tricky" "1.0.0" $ - Right - [ ("athas/tricky", "1.0.0"), - ("athas/foo", "0.3.0"), - ("athas/x_foo", "1.0.0") - ] - ] diff --git a/unittests/Futhark/ProfileTests.hs b/unittests/Futhark/ProfileTests.hs deleted file mode 100644 --- a/unittests/Futhark/ProfileTests.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Futhark.ProfileTests () where - -import Data.Map qualified as M -import Data.Text qualified as T -import Futhark.Profile -import Test.Tasty.QuickCheck - -printable :: Gen String -printable = getPrintableString <$> arbitrary - -arbText :: Gen T.Text -arbText = T.pack <$> printable - -instance Arbitrary ProfilingEvent where - arbitrary = ProfilingEvent <$> arbText <*> arbitrary <*> arbText - -instance Arbitrary ProfilingReport where - arbitrary = - ProfilingReport - <$> arbitrary - <*> (M.fromList <$> listOf ((,) <$> arbText <*> arbitrary)) diff --git a/unittests/Language/Futhark/CoreTests.hs b/unittests/Language/Futhark/CoreTests.hs deleted file mode 100644 --- a/unittests/Language/Futhark/CoreTests.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Language.Futhark.CoreTests () where - -import Language.Futhark.Core -import Language.Futhark.PrimitiveTests () -import Test.QuickCheck - -instance Arbitrary Name where - arbitrary = nameFromString <$> listOf1 (elements ['a' .. 'z']) - -instance Arbitrary VName where - arbitrary = VName <$> arbitrary <*> arbitrary diff --git a/unittests/Language/Futhark/PrimitiveTests.hs b/unittests/Language/Futhark/PrimitiveTests.hs deleted file mode 100644 --- a/unittests/Language/Futhark/PrimitiveTests.hs +++ /dev/null @@ -1,76 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Language.Futhark.PrimitiveTests - ( tests, - arbitraryPrimValOfType, - ) -where - -import Control.Applicative -import Futhark.Util (convFloat) -import Language.Futhark.Primitive -import Test.QuickCheck -import Test.Tasty -import Test.Tasty.HUnit -import Prelude - -tests :: TestTree -tests = testGroup "PrimitiveTests" [propPrimValuesHaveRightType] - -propPrimValuesHaveRightType :: TestTree -propPrimValuesHaveRightType = - testGroup - "propPrimValuesHaveRightTypes" - [ testCase (show t ++ " has blank of right type") $ - primValueType (blankPrimValue t) @?= t - | t <- [minBound .. maxBound] - ] - -instance Arbitrary IntType where - arbitrary = elements [minBound .. maxBound] - -instance Arbitrary FloatType where - arbitrary = elements [minBound .. maxBound] - -instance Arbitrary PrimType where - arbitrary = elements [minBound .. maxBound] - -instance Arbitrary IntValue where - arbitrary = - oneof - [ Int8Value <$> arbitrary, - Int16Value <$> arbitrary, - Int32Value <$> arbitrary, - Int64Value <$> arbitrary - ] - -instance Arbitrary Half where - arbitrary = (convFloat :: Float -> Half) <$> arbitrary - -instance Arbitrary FloatValue where - arbitrary = - oneof - [ Float16Value <$> arbitrary, - Float32Value <$> arbitrary, - Float64Value <$> arbitrary - ] - -instance Arbitrary PrimValue where - arbitrary = - oneof - [ IntValue <$> arbitrary, - FloatValue <$> arbitrary, - BoolValue <$> arbitrary, - pure UnitValue - ] - -arbitraryPrimValOfType :: PrimType -> Gen PrimValue -arbitraryPrimValOfType (IntType Int8) = IntValue . Int8Value <$> arbitrary -arbitraryPrimValOfType (IntType Int16) = IntValue . Int16Value <$> arbitrary -arbitraryPrimValOfType (IntType Int32) = IntValue . Int32Value <$> arbitrary -arbitraryPrimValOfType (IntType Int64) = IntValue . Int64Value <$> arbitrary -arbitraryPrimValOfType (FloatType Float16) = FloatValue . Float16Value <$> arbitrary -arbitraryPrimValOfType (FloatType Float32) = FloatValue . Float32Value <$> arbitrary -arbitraryPrimValOfType (FloatType Float64) = FloatValue . Float32Value <$> arbitrary -arbitraryPrimValOfType Bool = BoolValue <$> arbitrary -arbitraryPrimValOfType Unit = pure UnitValue diff --git a/unittests/Language/Futhark/SemanticTests.hs b/unittests/Language/Futhark/SemanticTests.hs deleted file mode 100644 --- a/unittests/Language/Futhark/SemanticTests.hs +++ /dev/null @@ -1,24 +0,0 @@ -module Language.Futhark.SemanticTests (tests) where - -import Language.Futhark (ImportName (..)) -import Language.Futhark.Semantic -import Test.Tasty -import Test.Tasty.HUnit - -tests :: TestTree -tests = - testGroup - "Semantic objects" - [ testCase "a" $ - mkInitialImport "a" @?= ImportName "a", - testCase "./a" $ - mkInitialImport "./a" @?= ImportName "a", - testCase "a/b -> ../c" $ - mkImportFrom (mkInitialImport "a/b") "../c" @?= ImportName "c", - testCase "a/b -> ../../c" $ - mkImportFrom (mkInitialImport "a/b") "../../c" @?= ImportName "../c", - testCase "../a -> b" $ - mkImportFrom (mkInitialImport "../a") "b" @?= ImportName "../b", - testCase "../a -> ../b" $ - mkImportFrom (mkInitialImport "../a") "../b" @?= ImportName "../../b" - ] diff --git a/unittests/Language/Futhark/SyntaxTests.hs b/unittests/Language/Futhark/SyntaxTests.hs deleted file mode 100644 --- a/unittests/Language/Futhark/SyntaxTests.hs +++ /dev/null @@ -1,208 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Language.Futhark.SyntaxTests (tests) where - -import Control.Applicative hiding (many, some) -import Data.Bifunctor -import Data.Char (isAlpha) -import Data.Functor -import Data.Map qualified as M -import Data.String -import Data.Text qualified as T -import Data.Void -import Language.Futhark -import Language.Futhark.Parser -import Language.Futhark.Primitive.Parse (constituent, keyword, lexeme) -import Language.Futhark.PrimitiveTests () -import Test.QuickCheck -import Test.Tasty -import Text.Megaparsec -import Text.Megaparsec.Char.Lexer qualified as L -import Prelude - -tests :: TestTree -tests = testGroup "Source SyntaxTests" [] - -instance Arbitrary BinOp where - arbitrary = elements [minBound .. maxBound] - -instance Arbitrary Uniqueness where - arbitrary = elements [Unique, Nonunique] - -instance Arbitrary PrimType where - arbitrary = - oneof - [ Signed <$> arbitrary, - Unsigned <$> arbitrary, - FloatType <$> arbitrary, - pure Bool - ] - -instance Arbitrary PrimValue where - arbitrary = - oneof - [ SignedValue <$> arbitrary, - UnsignedValue <$> arbitrary, - FloatValue <$> arbitrary, - BoolValue <$> arbitrary - ] - --- The following dirty instances make it slightly nicer to write unit tests. - -instance IsString VName where - fromString s = - let (s', '_' : tag) = span (/= '_') s - in VName (fromString s') (read tag) - -instance (IsString v) => IsString (QualName v) where - fromString = QualName [] . fromString - -instance IsString UncheckedTypeExp where - fromString = - either (error . T.unpack . syntaxErrorMsg) id - . parseType "IsString UncheckedTypeExp" - . fromString - -type Parser = Parsec Void T.Text - -braces, brackets, parens :: Parser a -> Parser a -braces = between (lexeme "{") (lexeme "}") -brackets = between (lexeme "[") (lexeme "]") -parens = between (lexeme "(") (lexeme ")") - -pName :: Parser Name -pName = - lexeme . fmap nameFromString $ - (:) <$> satisfy isAlpha <*> many (satisfy constituent) - -pVName :: Parser VName -pVName = lexeme $ do - (s, tag) <- - satisfy constituent - `manyTill_` try pTag - "variable name" - pure $ VName (nameFromString s) tag - where - pTag = - "_" *> L.decimal <* notFollowedBy (satisfy constituent) - -pQualName :: Parser (QualName VName) -pQualName = QualName [] <$> pVName - -pPrimType :: Parser PrimType -pPrimType = - choice $ - map - f - [ Bool, - Signed Int8, - Signed Int16, - Signed Int32, - Signed Int64, - Unsigned Int8, - Unsigned Int16, - Unsigned Int32, - Unsigned Int64, - FloatType Float32, - FloatType Float64 - ] - where - f t = keyword (prettyText t) $> t - -pUniqueness :: Parser Uniqueness -pUniqueness = choice [lexeme "*" $> Unique, pure Nonunique] - -pSize :: Parser Size -pSize = - brackets $ - choice - [ flip sizeFromInteger mempty <$> lexeme L.decimal, - flip sizeFromName mempty <$> pQualName - ] - -pScalarNonFun :: Parser (ScalarTypeBase Size Uniqueness) -pScalarNonFun = - choice - [ Prim <$> pPrimType, - pTypeVar, - tupleRecord <$> parens (pType `sepBy` lexeme ","), - Record . M.fromList <$> braces (pField `sepBy1` lexeme ",") - ] - where - pField = (,) <$> pName <* lexeme ":" <*> pType - pTypeVar = TypeVar <$> pUniqueness <*> pQualName <*> many pTypeArg - pTypeArg = - choice - [ TypeArgDim <$> pSize, - TypeArgType . second (const NoUniqueness) <$> pTypeArgType - ] - pTypeArgType = - choice - [ Scalar . Prim <$> pPrimType, - parens pType - ] - -pArrayType :: Parser ResType -pArrayType = - Array - <$> pUniqueness - <*> (Shape <$> some pSize) - <*> (second (const NoUniqueness) <$> pScalarNonFun) - -pNonFunType :: Parser ResType -pNonFunType = - choice - [ try pArrayType, - try $ parens pType, - Scalar <$> pScalarNonFun - ] - -pScalarType :: Parser (ScalarTypeBase Size Uniqueness) -pScalarType = choice [try pFun, pScalarNonFun] - where - pFun = - pParam <* lexeme "->" <*> pRetType - pParam = - choice - [ try pNamedParam, - do - t <- pNonFunType - pure $ Arrow Nonunique Unnamed (diet $ resToParam t) (toStruct t) - ] - pNamedParam = parens $ do - v <- pVName <* lexeme ":" - t <- pType - pure $ Arrow Nonunique (Named v) (diet $ resToParam t) (toStruct t) - -pRetType :: Parser ResRetType -pRetType = - choice - [ lexeme "?" *> (RetType <$> some (brackets pVName) <* lexeme "." <*> pType), - RetType [] <$> pType - ] - -pType :: Parser ResType -pType = - choice [try $ Scalar <$> pScalarType, pArrayType, parens pType] - -fromStringParse :: Parser a -> String -> String -> a -fromStringParse p what s = - either onError id $ parse (p <* eof) "" (T.pack s) - where - onError e = - error $ "not a " <> what <> ": " <> s <> "\n" <> errorBundlePretty e - -instance IsString (ScalarTypeBase Size NoUniqueness) where - fromString = - fromStringParse (second (const NoUniqueness) <$> pScalarType) "ScalarType" - -instance IsString StructType where - fromString = - fromStringParse (second (const NoUniqueness) <$> pType) "StructType" - -instance IsString StructRetType where - fromString = - fromStringParse (second (pure NoUniqueness) <$> pRetType) "StructRetType" - -instance IsString ResRetType where - fromString = fromStringParse pRetType "ResRetType" diff --git a/unittests/Language/Futhark/TypeChecker/TypesTests.hs b/unittests/Language/Futhark/TypeChecker/TypesTests.hs deleted file mode 100644 --- a/unittests/Language/Futhark/TypeChecker/TypesTests.hs +++ /dev/null @@ -1,185 +0,0 @@ -module Language.Futhark.TypeChecker.TypesTests (tests) where - -import Data.Bifunctor -import Data.List (isInfixOf) -import Data.Map qualified as M -import Data.Text qualified as T -import Futhark.FreshNames -import Futhark.Util.Pretty (docText, prettyTextOneLine) -import Language.Futhark -import Language.Futhark.Semantic -import Language.Futhark.SyntaxTests () -import Language.Futhark.TypeChecker (initialEnv) -import Language.Futhark.TypeChecker.Monad -import Language.Futhark.TypeChecker.Names (resolveTypeExp) -import Language.Futhark.TypeChecker.Terms -import Language.Futhark.TypeChecker.Types -import Test.Tasty -import Test.Tasty.HUnit - -evalTest :: TypeExp (ExpBase NoInfo Name) Name -> Either String ([VName], ResRetType) -> TestTree -evalTest te expected = - testCase (prettyString te) $ - case (fmap (extract . fst) (run (checkTypeExp checkSizeExp =<< resolveTypeExp te)), expected) of - (Left got_e, Left expected_e) -> - let got_e_s = T.unpack $ docText $ prettyTypeError got_e - in (expected_e `isInfixOf` got_e_s) @? got_e_s - (Left got_e, Right _) -> - let got_e_s = T.unpack $ docText $ prettyTypeError got_e - in assertFailure $ "Failed: " <> got_e_s - (Right actual_t, Right expected_t) -> - actual_t @?= expected_t - (Right actual_t, Left _) -> - assertFailure $ "Expected error, got: " <> show actual_t - where - extract (_, svars, t, _) = (svars, t) - run = snd . runTypeM env mempty (mkInitialImport "") (newNameSource 100) - -- We hack up an environment with some predefined type - -- abbreviations for testing. This is all pretty sensitive to the - -- specific unique names, so we have to be careful! - env = - initialEnv - { envTypeTable = - M.fromList - [ ( "square_1000", - TypeAbbr - Unlifted - [TypeParamDim "n_1001" mempty] - "[n_1001][n_1001]i32" - ), - ( "fun_1100", - TypeAbbr - Lifted - [ TypeParamType Lifted "a_1101" mempty, - TypeParamType Lifted "b_1102" mempty - ] - "a_1101 -> b_1102" - ), - ( "pair_1200", - TypeAbbr - SizeLifted - [] - "?[n_1201][m_1202].([n_1201]i64, [m_1202]i64)" - ) - ] - <> envTypeTable initialEnv, - envNameMap = - M.fromList - [ ((Type, "square"), "square_1000"), - ((Type, "fun"), "fun_1100"), - ((Type, "pair"), "pair_1200") - ] - <> envNameMap initialEnv - } - -evalTests :: TestTree -evalTests = - testGroup - "Type expression elaboration" - [ testGroup "Positive tests" (map mkPos pos), - testGroup "Negative tests" (map mkNeg neg) - ] - where - mkPos (x, y) = evalTest x (Right y) - mkNeg (x, y) = evalTest x (Left y) - pos = - [ ( "[]i32", - ([], "?[d_100].[d_100]i32") - ), - ( "[][]i32", - ([], "?[d_100][d_101].[d_100][d_101]i32") - ), - ( "bool -> []i32", - ([], "bool -> ?[d_100].[d_100]i32") - ), - ( "bool -> []f32 -> []i32", - (["d_100"], "bool -> [d_100]f32 -> ?[d_101].[d_101]i32") - ), - ( "([]i32,[]i32)", - ([], "?[d_100][d_101].([d_100]i32, [d_101]i32)") - ), - ( "{a:[]i32,b:[]i32}", - ([], "?[d_100][d_101].{a:[d_100]i32, b:[d_101]i32}") - ), - ( "?[n].[n][n]bool", - ([], "?[n_100].[n_100][n_100]bool") - ), - ( "([]i32 -> []i32) -> bool -> []i32", - (["d_100"], "([d_100]i32 -> ?[d_101].[d_101]i32) -> bool -> ?[d_102].[d_102]i32") - ), - ( "((k: i64) -> [k]i32 -> [k]i32) -> []i32 -> bool", - (["d_101"], "((k_100: i64) -> [k_100]i32 -> [k_100]i32) -> [d_101]i32 -> bool") - ), - ( "square [10]", - ([], "[10][10]i32") - ), - ( "square []", - ([], "?[d_100].[d_100][d_100]i32") - ), - ( "bool -> square []", - ([], "bool -> ?[d_100].[d_100][d_100]i32") - ), - ( "(k: i64) -> square [k]", - ([], "(k_100: i64) -> [k_100][k_100]i32") - ), - ( "fun i32 bool", - ([], "i32 -> bool") - ), - ( "fun ([]i32) bool", - ([], "?[d_100].[d_100]i32 -> bool") - ), - ( "fun bool ([]i32)", - ([], "?[d_100].bool -> [d_100]i32") - ), - ( "bool -> fun ([]i32) bool", - ([], "bool -> ?[d_100].[d_100]i32 -> bool") - ), - ( "bool -> fun bool ([]i32)", - ([], "bool -> ?[d_100].bool -> [d_100]i32") - ), - ( "pair", - ([], "?[n_100][m_101].([n_100]i64, [m_101]i64)") - ), - ( "(pair,pair)", - ([], "?[n_100][m_101][n_102][m_103].(([n_100]i64, [m_101]i64), ([n_102]i64, [m_103]i64))") - ) - ] - neg = - [ ("?[n].bool", "Existential size \"n\""), - ("?[n].bool -> [n]bool", "Existential size \"n\""), - ("?[n].[n]bool -> [n]bool", "Existential size \"n\""), - ("?[n].[n]bool -> bool", "Existential size \"n\"") - ] - -substTest :: M.Map VName (Subst StructRetType) -> StructRetType -> StructRetType -> TestTree -substTest m t expected = - testCase (pretty_m <> ": " <> T.unpack (prettyTextOneLine t)) $ - applySubst (`M.lookup` m) t @?= expected - where - pretty_m = T.unpack $ prettyText $ map (first toName) $ M.toList m - --- Some of these tests may be a bit fragile, in that they depend on --- internal renumbering, which can be arbitrary. -substTests :: TestTree -substTests = - testGroup - "Type substitution" - [ substTest m0 "t_0" "i64", - substTest m0 "[1]t_0" "[1]i64", - substTest m0 "?[n_10].[n_10]t_0" "?[n_10].[n_10]i64", - -- - substTest m1 "t_0" "?[n_1].[n_1]bool", - substTest m1 "f32 -> t_0" "f32 -> ?[n_1].[n_1]bool", - substTest m1 "f32 -> f64 -> t_0" "f32 -> f64 -> ?[n_1].[n_1]bool", - substTest m1 "f32 -> t_0 -> bool" "?[n_1].f32 -> [n_1]bool -> bool", - substTest m1 "f32 -> t_0 -> t_0" "?[n_1].f32 -> [n_1]bool -> ?[n_2].[n_2]bool" - ] - where - m0 = - M.fromList [("t_0", Subst [] "i64")] - - m1 = - M.fromList [("t_0", Subst [] "?[n_1].[n_1]bool")] - -tests :: TestTree -tests = testGroup "Basic type operations" [evalTests, substTests] diff --git a/unittests/Language/Futhark/TypeCheckerTests.hs b/unittests/Language/Futhark/TypeCheckerTests.hs deleted file mode 100644 --- a/unittests/Language/Futhark/TypeCheckerTests.hs +++ /dev/null @@ -1,11 +0,0 @@ -module Language.Futhark.TypeCheckerTests (tests) where - -import Language.Futhark.TypeChecker.TypesTests qualified -import Test.Tasty - -tests :: TestTree -tests = - testGroup - "Source type checker tests" - [ Language.Futhark.TypeChecker.TypesTests.tests - ] diff --git a/unittests/futhark_tests.hs b/unittests/futhark_tests.hs deleted file mode 100644 --- a/unittests/futhark_tests.hs +++ /dev/null @@ -1,42 +0,0 @@ -module Main (main) where - -import Futhark.AD.DerivativesTests qualified -import Futhark.Analysis.AlgSimplifyTests qualified -import Futhark.BenchTests qualified -import Futhark.IR.Mem.IntervalTests qualified -import Futhark.IR.Mem.IxFunTests qualified -import Futhark.IR.PropTests qualified -import Futhark.IR.Syntax.CoreTests qualified -import Futhark.Internalise.TypesValuesTests qualified -import Futhark.Optimise.ArrayLayoutTests qualified -import Futhark.Optimise.MemoryBlockMerging.GreedyColoringTests qualified -import Futhark.Pkg.SolveTests qualified -import Language.Futhark.PrimitiveTests qualified -import Language.Futhark.SemanticTests qualified -import Language.Futhark.SyntaxTests qualified -import Language.Futhark.TypeCheckerTests qualified -import Test.Tasty - -allTests :: TestTree -allTests = - testGroup - "" - [ Language.Futhark.SyntaxTests.tests, - Futhark.AD.DerivativesTests.tests, - Futhark.BenchTests.tests, - Futhark.IR.PropTests.tests, - Futhark.IR.Syntax.CoreTests.tests, - Futhark.Pkg.SolveTests.tests, - Futhark.Internalise.TypesValuesTests.tests, - Futhark.IR.Mem.IntervalTests.tests, - Futhark.IR.Mem.IxFunTests.tests, - Language.Futhark.PrimitiveTests.tests, - Futhark.Optimise.MemoryBlockMerging.GreedyColoringTests.tests, - Futhark.Analysis.AlgSimplifyTests.tests, - Language.Futhark.TypeCheckerTests.tests, - Language.Futhark.SemanticTests.tests, - Futhark.Optimise.ArrayLayoutTests.tests - ] - -main :: IO () -main = defaultMain allTests