diff --git a/docs/c-api.rst b/docs/c-api.rst --- a/docs/c-api.rst +++ b/docs/c-api.rst @@ -60,6 +60,7 @@ :c:func:`futhark_context_new`. A configuration object must not be freed before any context objects for which it is used. The same configuration may *not* be used for multiple concurrent contexts. +Configuration objects are cheap to create and destroy. .. c:struct:: futhark_context_config @@ -274,8 +275,9 @@ .. c:function:: int futhark_values_i32_1d(struct futhark_context *ctx, struct futhark_i32_1d *arr, int32_t *data) Asynchronously copy data from the value into ``data``, which must - be of sufficient size. Multi-dimensional arrays are written in - row-major form. + point to free memory, allocated by the caller, with sufficient + space to store the full array. Multi-dimensional arrays are + written in row-major form. .. c:function:: const int64_t *futhark_shape_i32_1d(struct futhark_context *ctx, struct futhark_i32_1d *arr) @@ -439,8 +441,8 @@ GPU --- -The following API functions are available when using the ``opencl`` or -``cuda`` backends. +The following API functions are available when using the ``opencl``, +``cuda``, or ``hip`` backends. .. c:function:: void futhark_context_config_set_device(struct futhark_context_config *cfg, const char *s) @@ -469,15 +471,15 @@ Set the default tile size used when executing kernels that have been block tiled. -.. c:function:: void futhark_context_config_dump_program_to(struct futhark_context_config *cfg, const char *path) +.. c:function:: const char* futhark_context_config_get_program(struct futhark_context_config *cfg) - During :c:func:`futhark_context_new`, dump the OpenCL or CUDA - program source to the given file. + Retrieve the embedded GPU program. The context configuration keeps + ownership, so don't free the string. -.. c:function:: void futhark_context_config_load_program_from(struct futhark_context_config *cfg, const char *path) +.. c:function:: void futhark_context_config_set_program(struct futhark_context_config *cfg, const char *program) - During :c:func:`futhark_context_new`, read OpenCL or CUDA program - source from the given file instead of using the embedded program. + Instead of using the embedded GPU program, use the provided string, + which is copied by this function. OpenCL ------ @@ -520,10 +522,9 @@ Add a build option to the OpenCL kernel compiler. See the OpenCL specification for `clBuildProgram` for available options. -.. c:function:: void futhark_context_config_dump_binary_to(struct futhark_context_config *cfg, const char *path) +.. c:function:: cl_program futhark_context_get_program(struct futhark_context_config *cfg) - During :c:func:`futhark_context_new`, dump the compiled OpenCL - binary to the given file. + Retrieve the compiled OpenCL program. .. c:function:: void futhark_context_config_load_binary_from(struct futhark_context_config *cfg, const char *path) @@ -547,7 +548,7 @@ Add a build option to the NVRTC compiler. See the CUDA documentation for ``nvrtcCompileProgram`` for available options. -.. c:function:: void futhark_context_config_dump_ptx_to(struct futhark_context_config *cfg, const char *path) +.. c:function:: void futhark_context_dump_ptx_to(struct futhark_context_config *cfg, const char *path) During :c:func:`futhark_context_new`, dump the generated PTX code to the given file. diff --git a/docs/index.rst b/docs/index.rst --- a/docs/index.rst +++ b/docs/index.rst @@ -45,16 +45,16 @@ :caption: Manual Pages :maxdepth: 1 - man/futhark.rst man/futhark-autotune.rst man/futhark-bench.rst man/futhark-c.rst man/futhark-cuda.rst man/futhark-dataset.rst man/futhark-doc.rst + man/futhark-hip.rst + man/futhark-ispc.rst man/futhark-literate.rst man/futhark-multicore.rst - man/futhark-ispc.rst man/futhark-opencl.rst man/futhark-pkg.rst man/futhark-pyopencl.rst @@ -62,5 +62,6 @@ man/futhark-repl.rst man/futhark-run.rst man/futhark-test.rst - man/futhark-wasm.rst man/futhark-wasm-multicore.rst + man/futhark-wasm.rst + man/futhark.rst diff --git a/docs/man/futhark-hip.rst b/docs/man/futhark-hip.rst new file mode 100644 --- /dev/null +++ b/docs/man/futhark-hip.rst @@ -0,0 +1,128 @@ +.. role:: ref(emphasis) + +.. _futhark-hip(1): + +============== +futhark-hip +============== + +SYNOPSIS +======== + +futhark hip [options...] + +DESCRIPTION +=========== + + +``futhark hip`` translates a Futhark program to C code invoking HIP +kernels, and either compiles that C code with a C compiler to an +executable binary program, or produces a ``.h`` and ``.c`` file that +can be linked with other code. The standard Futhark optimisation +pipeline is used. + +``futhark hip`` uses ``-lhiprtc -lamdhip64`` to link. If using +``--library``, you will need to do the same when linking the final +binary. Although the HIP backend can be made to work on NVIDIA GPUs, +you are probably better off using the very similar +:ref:`futhark-cuda(1)`. + +OPTIONS +======= + +Accepts the same options as :ref:`futhark-c(1)`. + +ENVIRONMENT VARIABLES +===================== + +``CC`` + + The C compiler used to compile the program. Defaults to ``cc`` if + unset. + +``CFLAGS`` + + Space-separated list of options passed to the C compiler. Defaults + to ``-O -std=c99`` if unset. + +EXECUTABLE OPTIONS +================== + +Generated executables accept the same options as those generated by +:ref:`futhark-c(1)`. For commonality, the options use OpenCL +nomenclature ("group" instead of "thread block"). + +The following additional options are accepted. + +-h, --help + + Print help text to standard output and exit. + +--default-group-size=INT + + The default size of thread blocks that are launched. Capped to the + hardware limit if necessary. + +--default-num-groups=INT + + The default number of thread blocks that are launched. + +--default-threshold=INT + + The default parallelism threshold used for comparisons when + selecting between code versions generated by incremental flattening. + Intuitively, the amount of parallelism needed to saturate the GPU. + +--default-tile-size=INT + + The default tile size used when performing two-dimensional tiling + (the workgroup size will be the square of the tile size). + +--dump-hip=FILE + + Don't run the program, but instead dump the embedded HIP kernels to + the indicated file. Useful if you want to see what is actually + being executed. + +--load-hip=FILE + + Instead of using the embedded HIP kernels, load them from the + indicated file. + +-n, --no-print-result + + Do not print the program result. + +--build-option=OPT + + Add an additional build option to the string passed to the kernel + compiler (HIPRTC). Refer to the HIP documentation for which options + are supported. Be careful - some options can easily result in + invalid results. + +--param=ASSIGNMENT + + Set a tuning parameter to the given + value. ``ASSIGNMENT`` must be of the form ``NAME=INT`` Use + ``--print-params`` to see which names are available. + +--print-params + + Print all tuning parameters that can be set with ``--param`` or + ``--tuning``. + +--tuning=FILE + + Read size=value assignments from the given file. + +ENVIRONMENT +=========== + +If run without ``--library``, ``futhark hip`` will invoke a C +compiler to compile the generated C program into a binary. This only +works if the C compiler can find the necessary HIP libraries. + +SEE ALSO +======== + +:ref:`futhark(1)` diff --git a/docs/usage.rst b/docs/usage.rst --- a/docs/usage.rst +++ b/docs/usage.rst @@ -158,7 +158,7 @@ ~~~~~~~~~~~ The following options are supported by executables generated with the -GPU backends (``opencl``, ``pyopencl``, and ``cuda``). +GPU backends (``opencl``, ``pyopencl``, ``hip``, and ``cuda``). ``-d/--device DEVICE`` 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.2 +version: 0.25.3 synopsis: An optimising compiler for a functional, array-oriented language. description: Futhark is a small programming language designed to be compiled to @@ -41,12 +41,16 @@ rts/c/context_prototypes.h rts/c/backends/c.h rts/c/backends/cuda.h + rts/c/backends/hip.h rts/c/backends/multicore.h rts/c/backends/opencl.h rts/c/lock.h + rts/c/copy.h rts/c/timing.h rts/c/errors.h rts/c/free_list.h + rts/c/gpu.h + rts/c/gpu_prototypes.h rts/c/tuning.h rts/c/values.h rts/c/half.h @@ -58,10 +62,14 @@ rts/c/uniform.h rts/c/util.h rts/c/server.h + rts/cuda/prelude.cu rts/futhark-doc/style.css rts/javascript/server.js rts/javascript/values.js rts/javascript/wrapperclasses.js + rts/opencl/copy.cl + rts/opencl/prelude.cl + rts/opencl/transpose.cl rts/python/tuning.py rts/python/panic.py rts/python/memory.py @@ -191,6 +199,7 @@ Futhark.CLI.Dev Futhark.CLI.Doc Futhark.CLI.Eval + Futhark.CLI.HIP Futhark.CLI.Literate Futhark.CLI.LSP Futhark.CLI.Main @@ -208,9 +217,8 @@ Futhark.CLI.Test Futhark.CLI.WASM Futhark.CodeGen.Backends.CCUDA - Futhark.CodeGen.Backends.CCUDA.Boilerplate Futhark.CodeGen.Backends.COpenCL - Futhark.CodeGen.Backends.COpenCL.Boilerplate + Futhark.CodeGen.Backends.HIP Futhark.CodeGen.Backends.GenericC Futhark.CodeGen.Backends.GenericC.CLI Futhark.CodeGen.Backends.GenericC.Code @@ -225,6 +233,7 @@ Futhark.CodeGen.Backends.GenericPython.AST Futhark.CodeGen.Backends.GenericPython.Options Futhark.CodeGen.Backends.GenericWASM + Futhark.CodeGen.Backends.GPU Futhark.CodeGen.Backends.MulticoreC Futhark.CodeGen.Backends.MulticoreC.Boilerplate Futhark.CodeGen.Backends.MulticoreISPC @@ -237,6 +246,8 @@ Futhark.CodeGen.Backends.SequentialWASM Futhark.CodeGen.Backends.SimpleRep Futhark.CodeGen.RTS.C + Futhark.CodeGen.RTS.CUDA + Futhark.CodeGen.RTS.OpenCL Futhark.CodeGen.RTS.Python Futhark.CodeGen.RTS.JavaScript Futhark.CodeGen.ImpCode @@ -248,7 +259,6 @@ Futhark.CodeGen.ImpGen.CUDA Futhark.CodeGen.ImpGen.GPU Futhark.CodeGen.ImpGen.GPU.Base - Futhark.CodeGen.ImpGen.GPU.Copy Futhark.CodeGen.ImpGen.GPU.Group Futhark.CodeGen.ImpGen.GPU.SegHist Futhark.CodeGen.ImpGen.GPU.SegMap @@ -257,7 +267,7 @@ Futhark.CodeGen.ImpGen.GPU.SegScan.SinglePass Futhark.CodeGen.ImpGen.GPU.SegScan.TwoPass Futhark.CodeGen.ImpGen.GPU.ToOpenCL - Futhark.CodeGen.ImpGen.GPU.Transpose + Futhark.CodeGen.ImpGen.HIP Futhark.CodeGen.ImpGen.Multicore Futhark.CodeGen.ImpGen.Multicore.Base Futhark.CodeGen.ImpGen.Multicore.SegHist @@ -266,7 +276,6 @@ Futhark.CodeGen.ImpGen.Multicore.SegScan Futhark.CodeGen.ImpGen.OpenCL Futhark.CodeGen.ImpGen.Sequential - Futhark.CodeGen.ImpGen.Transpose Futhark.CodeGen.OpenCL.Heuristics Futhark.Compiler Futhark.Compiler.CLI @@ -449,7 +458,7 @@ Language.Futhark.TypeChecker.Modules Language.Futhark.TypeChecker.Monad Language.Futhark.TypeChecker.Terms - Language.Futhark.TypeChecker.Terms.DoLoop + Language.Futhark.TypeChecker.Terms.Loop Language.Futhark.TypeChecker.Terms.Monad Language.Futhark.TypeChecker.Terms.Pat Language.Futhark.TypeChecker.Types @@ -472,7 +481,7 @@ , base16-bytestring , binary >=0.8.3 , blaze-html >=0.9.0.1 - , bytestring >=0.10.8 + , bytestring >=0.11.2 , bytestring-to-vector >=0.3.0.1 , bmp >=1.2.6.3 , co-log-core diff --git a/prelude/array.fut b/prelude/array.fut --- a/prelude/array.fut +++ b/prelude/array.fut @@ -197,7 +197,7 @@ -- | Create a value for each point in a two-dimensional index space. -- --- **Work:** *O(n ✕ W(f))* +-- **Work:** *O(n ✕ m ✕ W(f))* -- -- **Span:** *O(S(f))* def tabulate_2d 'a (n: i64) (m: i64) (f: i64 -> i64 -> a): *[n][m]a = @@ -205,7 +205,7 @@ -- | Create a value for each point in a three-dimensional index space. -- --- **Work:** *O(n ✕ W(f))* +-- **Work:** *O(n ✕ m ✕ o ✕ W(f))* -- -- **Span:** *O(S(f))* def tabulate_3d 'a (n: i64) (m: i64) (o: i64) (f: i64 -> i64 -> i64 -> a): *[n][m][o]a = diff --git a/rts/c/atomics.h b/rts/c/atomics.h --- a/rts/c/atomics.h +++ b/rts/c/atomics.h @@ -1,82 +1,82 @@ // Start of atomics.h -inline int32_t atomic_xchg_i32_global(volatile __global int32_t *p, int32_t x); -inline int32_t atomic_xchg_i32_local(volatile __local int32_t *p, int32_t x); -inline int32_t atomic_cmpxchg_i32_global(volatile __global int32_t *p, - int32_t cmp, int32_t val); -inline int32_t atomic_cmpxchg_i32_local(volatile __local int32_t *p, - int32_t cmp, int32_t val); -inline int32_t atomic_add_i32_global(volatile __global int32_t *p, int32_t x); -inline int32_t atomic_add_i32_local(volatile __local int32_t *p, int32_t x); -inline float atomic_fadd_f32_global(volatile __global float *p, float x); -inline float atomic_fadd_f32_local(volatile __local float *p, float x); -inline int32_t atomic_smax_i32_global(volatile __global int32_t *p, int32_t x); -inline int32_t atomic_smax_i32_local(volatile __local int32_t *p, int32_t x); -inline int32_t atomic_smin_i32_global(volatile __global int32_t *p, int32_t x); -inline int32_t atomic_smin_i32_local(volatile __local int32_t *p, int32_t x); -inline uint32_t atomic_umax_i32_global(volatile __global uint32_t *p, uint32_t x); -inline uint32_t atomic_umax_i32_local(volatile __local uint32_t *p, uint32_t x); -inline uint32_t atomic_umin_i32_global(volatile __global uint32_t *p, uint32_t x); -inline uint32_t atomic_umin_i32_local(volatile __local uint32_t *p, uint32_t x); -inline int32_t atomic_and_i32_global(volatile __global int32_t *p, int32_t x); -inline int32_t atomic_and_i32_local(volatile __local int32_t *p, int32_t x); -inline int32_t atomic_or_i32_global(volatile __global int32_t *p, int32_t x); -inline int32_t atomic_or_i32_local(volatile __local int32_t *p, int32_t x); -inline int32_t atomic_xor_i32_global(volatile __global int32_t *p, int32_t x); -inline int32_t atomic_xor_i32_local(volatile __local int32_t *p, int32_t x); +SCALAR_FUN_ATTR int32_t atomic_xchg_i32_global(volatile __global int32_t *p, int32_t x); +SCALAR_FUN_ATTR int32_t atomic_xchg_i32_local(volatile __local int32_t *p, int32_t x); +SCALAR_FUN_ATTR int32_t atomic_cmpxchg_i32_global(volatile __global int32_t *p, + int32_t cmp, int32_t val); +SCALAR_FUN_ATTR int32_t atomic_cmpxchg_i32_local(volatile __local int32_t *p, + int32_t cmp, int32_t val); +SCALAR_FUN_ATTR int32_t atomic_add_i32_global(volatile __global int32_t *p, int32_t x); +SCALAR_FUN_ATTR int32_t atomic_add_i32_local(volatile __local int32_t *p, int32_t x); +SCALAR_FUN_ATTR float atomic_fadd_f32_global(volatile __global float *p, float x); +SCALAR_FUN_ATTR float atomic_fadd_f32_local(volatile __local float *p, float x); +SCALAR_FUN_ATTR int32_t atomic_smax_i32_global(volatile __global int32_t *p, int32_t x); +SCALAR_FUN_ATTR int32_t atomic_smax_i32_local(volatile __local int32_t *p, int32_t x); +SCALAR_FUN_ATTR int32_t atomic_smin_i32_global(volatile __global int32_t *p, int32_t x); +SCALAR_FUN_ATTR int32_t atomic_smin_i32_local(volatile __local int32_t *p, int32_t x); +SCALAR_FUN_ATTR uint32_t atomic_umax_i32_global(volatile __global uint32_t *p, uint32_t x); +SCALAR_FUN_ATTR uint32_t atomic_umax_i32_local(volatile __local uint32_t *p, uint32_t x); +SCALAR_FUN_ATTR uint32_t atomic_umin_i32_global(volatile __global uint32_t *p, uint32_t x); +SCALAR_FUN_ATTR uint32_t atomic_umin_i32_local(volatile __local uint32_t *p, uint32_t x); +SCALAR_FUN_ATTR int32_t atomic_and_i32_global(volatile __global int32_t *p, int32_t x); +SCALAR_FUN_ATTR int32_t atomic_and_i32_local(volatile __local int32_t *p, int32_t x); +SCALAR_FUN_ATTR int32_t atomic_or_i32_global(volatile __global int32_t *p, int32_t x); +SCALAR_FUN_ATTR int32_t atomic_or_i32_local(volatile __local int32_t *p, int32_t x); +SCALAR_FUN_ATTR int32_t atomic_xor_i32_global(volatile __global int32_t *p, int32_t x); +SCALAR_FUN_ATTR int32_t atomic_xor_i32_local(volatile __local int32_t *p, int32_t x); -inline int32_t atomic_xchg_i32_global(volatile __global int32_t *p, int32_t x) { -#ifdef FUTHARK_CUDA +SCALAR_FUN_ATTR int32_t atomic_xchg_i32_global(volatile __global int32_t *p, int32_t x) { +#if defined(FUTHARK_CUDA) || defined(FUTHARK_HIP) return atomicExch((int32_t*)p, x); #else return atomic_xor(p, x); #endif } -inline int32_t atomic_xchg_i32_local(volatile __local int32_t *p, int32_t x) { -#ifdef FUTHARK_CUDA +SCALAR_FUN_ATTR int32_t atomic_xchg_i32_local(volatile __local int32_t *p, int32_t x) { +#if defined(FUTHARK_CUDA) || defined(FUTHARK_HIP) return atomicExch((int32_t*)p, x); #else return atomic_xor(p, x); #endif } -inline int32_t atomic_cmpxchg_i32_global(volatile __global int32_t *p, - int32_t cmp, int32_t val) { -#ifdef FUTHARK_CUDA +SCALAR_FUN_ATTR int32_t atomic_cmpxchg_i32_global(volatile __global int32_t *p, + int32_t cmp, int32_t val) { +#if defined(FUTHARK_CUDA) || defined(FUTHARK_HIP) return atomicCAS((int32_t*)p, cmp, val); #else return atomic_cmpxchg(p, cmp, val); #endif } -inline int32_t atomic_cmpxchg_i32_local(volatile __local int32_t *p, - int32_t cmp, int32_t val) { -#ifdef FUTHARK_CUDA +SCALAR_FUN_ATTR int32_t atomic_cmpxchg_i32_local(volatile __local int32_t *p, + int32_t cmp, int32_t val) { +#if defined(FUTHARK_CUDA) || defined(FUTHARK_HIP) return atomicCAS((int32_t*)p, cmp, val); #else return atomic_cmpxchg(p, cmp, val); #endif } -inline int32_t atomic_add_i32_global(volatile __global int32_t *p, int32_t x) { -#ifdef FUTHARK_CUDA +SCALAR_FUN_ATTR int32_t atomic_add_i32_global(volatile __global int32_t *p, int32_t x) { +#if defined(FUTHARK_CUDA) || defined(FUTHARK_HIP) return atomicAdd((int32_t*)p, x); #else return atomic_add(p, x); #endif } -inline int32_t atomic_add_i32_local(volatile __local int32_t *p, int32_t x) { -#ifdef FUTHARK_CUDA +SCALAR_FUN_ATTR int32_t atomic_add_i32_local(volatile __local int32_t *p, int32_t x) { +#if defined(FUTHARK_CUDA) || defined(FUTHARK_HIP) return atomicAdd((int32_t*)p, x); #else return atomic_add(p, x); #endif } -inline float atomic_fadd_f32_global(volatile __global float *p, float x) { -#ifdef FUTHARK_CUDA +SCALAR_FUN_ATTR float atomic_fadd_f32_global(volatile __global float *p, float x) { +#if defined(FUTHARK_CUDA) || defined(FUTHARK_HIP) return atomicAdd((float*)p, x); #else union { int32_t i; float f; } old; @@ -91,8 +91,8 @@ #endif } -inline float atomic_fadd_f32_local(volatile __local float *p, float x) { -#ifdef FUTHARK_CUDA +SCALAR_FUN_ATTR float atomic_fadd_f32_local(volatile __local float *p, float x) { +#if defined(FUTHARK_CUDA) || defined(FUTHARK_HIP) return atomicAdd((float*)p, x); #else union { int32_t i; float f; } old; @@ -107,112 +107,112 @@ #endif } -inline int32_t atomic_smax_i32_global(volatile __global int32_t *p, int32_t x) { -#ifdef FUTHARK_CUDA +SCALAR_FUN_ATTR int32_t atomic_smax_i32_global(volatile __global int32_t *p, int32_t x) { +#if defined(FUTHARK_CUDA) || defined(FUTHARK_HIP) return atomicMax((int32_t*)p, x); #else return atomic_max(p, x); #endif } -inline int32_t atomic_smax_i32_local(volatile __local int32_t *p, int32_t x) { -#ifdef FUTHARK_CUDA +SCALAR_FUN_ATTR int32_t atomic_smax_i32_local(volatile __local int32_t *p, int32_t x) { +#if defined(FUTHARK_CUDA) || defined(FUTHARK_HIP) return atomicMax((int32_t*)p, x); #else return atomic_max(p, x); #endif } -inline int32_t atomic_smin_i32_global(volatile __global int32_t *p, int32_t x) { -#ifdef FUTHARK_CUDA +SCALAR_FUN_ATTR int32_t atomic_smin_i32_global(volatile __global int32_t *p, int32_t x) { +#if defined(FUTHARK_CUDA) || defined(FUTHARK_HIP) return atomicMin((int32_t*)p, x); #else return atomic_min(p, x); #endif } -inline int32_t atomic_smin_i32_local(volatile __local int32_t *p, int32_t x) { -#ifdef FUTHARK_CUDA +SCALAR_FUN_ATTR int32_t atomic_smin_i32_local(volatile __local int32_t *p, int32_t x) { +#if defined(FUTHARK_CUDA) || defined(FUTHARK_HIP) return atomicMin((int32_t*)p, x); #else return atomic_min(p, x); #endif } -inline uint32_t atomic_umax_i32_global(volatile __global uint32_t *p, uint32_t x) { -#ifdef FUTHARK_CUDA +SCALAR_FUN_ATTR uint32_t atomic_umax_i32_global(volatile __global uint32_t *p, uint32_t x) { +#if defined(FUTHARK_CUDA) || defined(FUTHARK_HIP) return atomicMax((uint32_t*)p, x); #else return atomic_max(p, x); #endif } -inline uint32_t atomic_umax_i32_local(volatile __local uint32_t *p, uint32_t x) { -#ifdef FUTHARK_CUDA +SCALAR_FUN_ATTR uint32_t atomic_umax_i32_local(volatile __local uint32_t *p, uint32_t x) { +#if defined(FUTHARK_CUDA) || defined(FUTHARK_HIP) return atomicMax((uint32_t*)p, x); #else return atomic_max(p, x); #endif } -inline uint32_t atomic_umin_i32_global(volatile __global uint32_t *p, uint32_t x) { -#ifdef FUTHARK_CUDA +SCALAR_FUN_ATTR uint32_t atomic_umin_i32_global(volatile __global uint32_t *p, uint32_t x) { +#if defined(FUTHARK_CUDA) || defined(FUTHARK_HIP) return atomicMin((uint32_t*)p, x); #else return atomic_min(p, x); #endif } -inline uint32_t atomic_umin_i32_local(volatile __local uint32_t *p, uint32_t x) { -#ifdef FUTHARK_CUDA +SCALAR_FUN_ATTR uint32_t atomic_umin_i32_local(volatile __local uint32_t *p, uint32_t x) { +#if defined(FUTHARK_CUDA) || defined(FUTHARK_HIP) return atomicMin((uint32_t*)p, x); #else return atomic_min(p, x); #endif } -inline int32_t atomic_and_i32_global(volatile __global int32_t *p, int32_t x) { -#ifdef FUTHARK_CUDA +SCALAR_FUN_ATTR int32_t atomic_and_i32_global(volatile __global int32_t *p, int32_t x) { +#if defined(FUTHARK_CUDA) || defined(FUTHARK_HIP) return atomicAnd((int32_t*)p, x); #else return atomic_and(p, x); #endif } -inline int32_t atomic_and_i32_local(volatile __local int32_t *p, int32_t x) { -#ifdef FUTHARK_CUDA +SCALAR_FUN_ATTR int32_t atomic_and_i32_local(volatile __local int32_t *p, int32_t x) { +#if defined(FUTHARK_CUDA) || defined(FUTHARK_HIP) return atomicAnd((int32_t*)p, x); #else return atomic_and(p, x); #endif } -inline int32_t atomic_or_i32_global(volatile __global int32_t *p, int32_t x) { -#ifdef FUTHARK_CUDA +SCALAR_FUN_ATTR int32_t atomic_or_i32_global(volatile __global int32_t *p, int32_t x) { +#if defined(FUTHARK_CUDA) || defined(FUTHARK_HIP) return atomicOr((int32_t*)p, x); #else return atomic_or(p, x); #endif } -inline int32_t atomic_or_i32_local(volatile __local int32_t *p, int32_t x) { -#ifdef FUTHARK_CUDA +SCALAR_FUN_ATTR int32_t atomic_or_i32_local(volatile __local int32_t *p, int32_t x) { +#if defined(FUTHARK_CUDA) || defined(FUTHARK_HIP) return atomicOr((int32_t*)p, x); #else return atomic_or(p, x); #endif } -inline int32_t atomic_xor_i32_global(volatile __global int32_t *p, int32_t x) { -#ifdef FUTHARK_CUDA +SCALAR_FUN_ATTR int32_t atomic_xor_i32_global(volatile __global int32_t *p, int32_t x) { +#if defined(FUTHARK_CUDA) || defined(FUTHARK_HIP) return atomicXor((int32_t*)p, x); #else return atomic_xor(p, x); #endif } -inline int32_t atomic_xor_i32_local(volatile __local int32_t *p, int32_t x) { -#ifdef FUTHARK_CUDA +SCALAR_FUN_ATTR int32_t atomic_xor_i32_local(volatile __local int32_t *p, int32_t x) { +#if defined(FUTHARK_CUDA) || defined(FUTHARK_HIP) return atomicXor((int32_t*)p, x); #else return atomic_xor(p, x); @@ -221,80 +221,80 @@ // Start of 64 bit atomics -#if defined(FUTHARK_CUDA) || defined(cl_khr_int64_base_atomics) && defined(cl_khr_int64_extended_atomics) +#if defined(FUTHARK_CUDA) || defined(FUTHARK_HIP) || defined(cl_khr_int64_base_atomics) && defined(cl_khr_int64_extended_atomics) -inline int64_t atomic_xchg_i64_global(volatile __global int64_t *p, int64_t x); -inline int64_t atomic_xchg_i64_local(volatile __local int64_t *p, int64_t x); -inline int64_t atomic_cmpxchg_i64_global(volatile __global int64_t *p, - int64_t cmp, int64_t val); -inline int64_t atomic_cmpxchg_i64_local(volatile __local int64_t *p, - int64_t cmp, int64_t val); -inline int64_t atomic_add_i64_global(volatile __global int64_t *p, int64_t x); -inline int64_t atomic_add_i64_local(volatile __local int64_t *p, int64_t x); -inline int64_t atomic_smax_i64_global(volatile __global int64_t *p, int64_t x); -inline int64_t atomic_smax_i64_local(volatile __local int64_t *p, int64_t x); -inline int64_t atomic_smin_i64_global(volatile __global int64_t *p, int64_t x); -inline int64_t atomic_smin_i64_local(volatile __local int64_t *p, int64_t x); -inline uint64_t atomic_umax_i64_global(volatile __global uint64_t *p, uint64_t x); -inline uint64_t atomic_umax_i64_local(volatile __local uint64_t *p, uint64_t x); -inline uint64_t atomic_umin_i64_global(volatile __global uint64_t *p, uint64_t x); -uint64_t atomic_umin_i64_local(volatile __local uint64_t *p, uint64_t x); -inline int64_t atomic_and_i64_global(volatile __global int64_t *p, int64_t x); -inline int64_t atomic_and_i64_local(volatile __local int64_t *p, int64_t x); -inline int64_t atomic_or_i64_global(volatile __global int64_t *p, int64_t x); -inline int64_t atomic_or_i64_local(volatile __local int64_t *p, int64_t x); -inline int64_t atomic_xor_i64_global(volatile __global int64_t *p, int64_t x); -inline int64_t atomic_xor_i64_local(volatile __local int64_t *p, int64_t x); +SCALAR_FUN_ATTR int64_t atomic_xchg_i64_global(volatile __global int64_t *p, int64_t x); +SCALAR_FUN_ATTR int64_t atomic_xchg_i64_local(volatile __local int64_t *p, int64_t x); +SCALAR_FUN_ATTR int64_t atomic_cmpxchg_i64_global(volatile __global int64_t *p, + int64_t cmp, int64_t val); +SCALAR_FUN_ATTR int64_t atomic_cmpxchg_i64_local(volatile __local int64_t *p, + int64_t cmp, int64_t val); +SCALAR_FUN_ATTR int64_t atomic_add_i64_global(volatile __global int64_t *p, int64_t x); +SCALAR_FUN_ATTR int64_t atomic_add_i64_local(volatile __local int64_t *p, int64_t x); +SCALAR_FUN_ATTR int64_t atomic_smax_i64_global(volatile __global int64_t *p, int64_t x); +SCALAR_FUN_ATTR int64_t atomic_smax_i64_local(volatile __local int64_t *p, int64_t x); +SCALAR_FUN_ATTR int64_t atomic_smin_i64_global(volatile __global int64_t *p, int64_t x); +SCALAR_FUN_ATTR int64_t atomic_smin_i64_local(volatile __local int64_t *p, int64_t x); +SCALAR_FUN_ATTR uint64_t atomic_umax_i64_global(volatile __global uint64_t *p, uint64_t x); +SCALAR_FUN_ATTR uint64_t atomic_umax_i64_local(volatile __local uint64_t *p, uint64_t x); +SCALAR_FUN_ATTR uint64_t atomic_umin_i64_global(volatile __global uint64_t *p, uint64_t x); +SCALAR_FUN_ATTR uint64_t atomic_umin_i64_local(volatile __local uint64_t *p, uint64_t x); +SCALAR_FUN_ATTR int64_t atomic_and_i64_global(volatile __global int64_t *p, int64_t x); +SCALAR_FUN_ATTR int64_t atomic_and_i64_local(volatile __local int64_t *p, int64_t x); +SCALAR_FUN_ATTR int64_t atomic_or_i64_global(volatile __global int64_t *p, int64_t x); +SCALAR_FUN_ATTR int64_t atomic_or_i64_local(volatile __local int64_t *p, int64_t x); +SCALAR_FUN_ATTR int64_t atomic_xor_i64_global(volatile __global int64_t *p, int64_t x); +SCALAR_FUN_ATTR int64_t atomic_xor_i64_local(volatile __local int64_t *p, int64_t x); #ifdef FUTHARK_F64_ENABLED -inline double atomic_fadd_f64_global(volatile __global double *p, double x); -inline double atomic_fadd_f64_local(volatile __local double *p, double x); +SCALAR_FUN_ATTR double atomic_fadd_f64_global(volatile __global double *p, double x); +SCALAR_FUN_ATTR double atomic_fadd_f64_local(volatile __local double *p, double x); #endif -inline int64_t atomic_xchg_i64_global(volatile __global int64_t *p, int64_t x) { -#ifdef FUTHARK_CUDA +SCALAR_FUN_ATTR int64_t atomic_xchg_i64_global(volatile __global int64_t *p, int64_t x) { +#if defined(FUTHARK_CUDA) || defined(FUTHARK_HIP) return atomicExch((uint64_t*)p, x); #else return atom_xor(p, x); #endif } -inline int64_t atomic_xchg_i64_local(volatile __local int64_t *p, int64_t x) { -#ifdef FUTHARK_CUDA +SCALAR_FUN_ATTR int64_t atomic_xchg_i64_local(volatile __local int64_t *p, int64_t x) { +#if defined(FUTHARK_CUDA) || defined(FUTHARK_HIP) return atomicExch((uint64_t*)p, x); #else return atom_xor(p, x); #endif } -inline int64_t atomic_cmpxchg_i64_global(volatile __global int64_t *p, - int64_t cmp, int64_t val) { -#ifdef FUTHARK_CUDA +SCALAR_FUN_ATTR int64_t atomic_cmpxchg_i64_global(volatile __global int64_t *p, + int64_t cmp, int64_t val) { +#if defined(FUTHARK_CUDA) || defined(FUTHARK_HIP) return atomicCAS((uint64_t*)p, cmp, val); #else return atom_cmpxchg(p, cmp, val); #endif } -inline int64_t atomic_cmpxchg_i64_local(volatile __local int64_t *p, - int64_t cmp, int64_t val) { -#ifdef FUTHARK_CUDA +SCALAR_FUN_ATTR int64_t atomic_cmpxchg_i64_local(volatile __local int64_t *p, + int64_t cmp, int64_t val) { +#if defined(FUTHARK_CUDA) || defined(FUTHARK_HIP) return atomicCAS((uint64_t*)p, cmp, val); #else return atom_cmpxchg(p, cmp, val); #endif } -inline int64_t atomic_add_i64_global(volatile __global int64_t *p, int64_t x) { -#ifdef FUTHARK_CUDA +SCALAR_FUN_ATTR int64_t atomic_add_i64_global(volatile __global int64_t *p, int64_t x) { +#if defined(FUTHARK_CUDA) || defined(FUTHARK_HIP) return atomicAdd((uint64_t*)p, x); #else return atom_add(p, x); #endif } -inline int64_t atomic_add_i64_local(volatile __local int64_t *p, int64_t x) { -#ifdef FUTHARK_CUDA +SCALAR_FUN_ATTR int64_t atomic_add_i64_local(volatile __local int64_t *p, int64_t x) { +#if defined(FUTHARK_CUDA) || defined(FUTHARK_HIP) return atomicAdd((uint64_t*)p, x); #else return atom_add(p, x); @@ -303,8 +303,8 @@ #ifdef FUTHARK_F64_ENABLED -inline double atomic_fadd_f64_global(volatile __global double *p, double x) { -#if defined(FUTHARK_CUDA) && __CUDA_ARCH__ >= 600 +SCALAR_FUN_ATTR double atomic_fadd_f64_global(volatile __global double *p, double x) { +#if defined(FUTHARK_CUDA) && __CUDA_ARCH__ >= 600 || defined(FUTHARK_HIP) return atomicAdd((double*)p, x); #else union { int64_t i; double f; } old; @@ -319,8 +319,8 @@ #endif } -inline double atomic_fadd_f64_local(volatile __local double *p, double x) { -#if defined(FUTHARK_CUDA) && __CUDA_ARCH__ >= 600 +SCALAR_FUN_ATTR double atomic_fadd_f64_local(volatile __local double *p, double x) { +#if defined(FUTHARK_CUDA) && __CUDA_ARCH__ >= 600 || defined(FUTHARK_HIP) return atomicAdd((double*)p, x); #else union { int64_t i; double f; } old; @@ -337,118 +337,154 @@ #endif -inline int64_t atomic_smax_i64_global(volatile __global int64_t *p, int64_t x) { -#ifdef FUTHARK_CUDA +SCALAR_FUN_ATTR int64_t atomic_smax_i64_global(volatile __global int64_t *p, int64_t x) { +#if defined(FUTHARK_CUDA) return atomicMax((int64_t*)p, x); +#elif defined(FUTHARK_HIP) + // Currentely missing in HIP; probably a temporary oversight. + int64_t old = *p, assumed; + do { + assumed = old; + old = smax64(old, x); + old = atomic_cmpxchg_i64_global((volatile __global int64_t*)p, assumed, old); + } while (assumed != old); + return old; #else return atom_max(p, x); #endif } -inline int64_t atomic_smax_i64_local(volatile __local int64_t *p, int64_t x) { -#ifdef FUTHARK_CUDA +SCALAR_FUN_ATTR int64_t atomic_smax_i64_local(volatile __local int64_t *p, int64_t x) { +#if defined(FUTHARK_CUDA) return atomicMax((int64_t*)p, x); +#elif defined(FUTHARK_HIP) + // Currentely missing in HIP; probably a temporary oversight. + int64_t old = *p, assumed; + do { + assumed = old; + old = smax64(old, x); + old = atomic_cmpxchg_i64_local((volatile __local int64_t*)p, assumed, old); + } while (assumed != old); + return old; #else return atom_max(p, x); #endif } -inline int64_t atomic_smin_i64_global(volatile __global int64_t *p, int64_t x) { -#ifdef FUTHARK_CUDA +SCALAR_FUN_ATTR int64_t atomic_smin_i64_global(volatile __global int64_t *p, int64_t x) { +#if defined(FUTHARK_CUDA) return atomicMin((int64_t*)p, x); +#elif defined(FUTHARK_HIP) + // Currentely missing in HIP; probably a temporary oversight. + int64_t old = *p, assumed; + do { + assumed = old; + old = smin64(old, x); + old = atomic_cmpxchg_i64_global((volatile __global int64_t*)p, assumed, old); + } while (assumed != old); + return old; #else return atom_min(p, x); #endif } -inline int64_t atomic_smin_i64_local(volatile __local int64_t *p, int64_t x) { -#ifdef FUTHARK_CUDA +SCALAR_FUN_ATTR int64_t atomic_smin_i64_local(volatile __local int64_t *p, int64_t x) { +#if defined(FUTHARK_CUDA) return atomicMin((int64_t*)p, x); +#elif defined(FUTHARK_HIP) + // Currentely missing in HIP; probably a temporary oversight. + int64_t old = *p, assumed; + do { + assumed = old; + old = smin64(old, x); + old = atomic_cmpxchg_i64_local((volatile __local int64_t*)p, assumed, old); + } while (assumed != old); + return old; #else return atom_min(p, x); #endif } -inline uint64_t atomic_umax_i64_global(volatile __global uint64_t *p, uint64_t x) { -#ifdef FUTHARK_CUDA +SCALAR_FUN_ATTR uint64_t atomic_umax_i64_global(volatile __global uint64_t *p, uint64_t x) { +#if defined(FUTHARK_CUDA) || defined(FUTHARK_HIP) return atomicMax((uint64_t*)p, x); #else return atom_max(p, x); #endif } -inline uint64_t atomic_umax_i64_local(volatile __local uint64_t *p, uint64_t x) { -#ifdef FUTHARK_CUDA +SCALAR_FUN_ATTR uint64_t atomic_umax_i64_local(volatile __local uint64_t *p, uint64_t x) { +#if defined(FUTHARK_CUDA) || defined(FUTHARK_HIP) return atomicMax((uint64_t*)p, x); #else return atom_max(p, x); #endif } -inline uint64_t atomic_umin_i64_global(volatile __global uint64_t *p, uint64_t x) { -#ifdef FUTHARK_CUDA +SCALAR_FUN_ATTR uint64_t atomic_umin_i64_global(volatile __global uint64_t *p, uint64_t x) { +#if defined(FUTHARK_CUDA) || defined(FUTHARK_HIP) return atomicMin((uint64_t*)p, x); #else return atom_min(p, x); #endif } -inline uint64_t atomic_umin_i64_local(volatile __local uint64_t *p, uint64_t x) { -#ifdef FUTHARK_CUDA +SCALAR_FUN_ATTR uint64_t atomic_umin_i64_local(volatile __local uint64_t *p, uint64_t x) { +#if defined(FUTHARK_CUDA) || defined(FUTHARK_HIP) return atomicMin((uint64_t*)p, x); #else return atom_min(p, x); #endif } -inline int64_t atomic_and_i64_global(volatile __global int64_t *p, int64_t x) { -#ifdef FUTHARK_CUDA - return atomicAnd((int64_t*)p, x); +SCALAR_FUN_ATTR int64_t atomic_and_i64_global(volatile __global int64_t *p, int64_t x) { +#if defined(FUTHARK_CUDA) || defined(FUTHARK_HIP) + return atomicAnd((uint64_t*)p, x); #else return atom_and(p, x); #endif } -inline int64_t atomic_and_i64_local(volatile __local int64_t *p, int64_t x) { -#ifdef FUTHARK_CUDA - return atomicAnd((int64_t*)p, x); +SCALAR_FUN_ATTR int64_t atomic_and_i64_local(volatile __local int64_t *p, int64_t x) { +#if defined(FUTHARK_CUDA) || defined(FUTHARK_HIP) + return atomicAnd((uint64_t*)p, x); #else return atom_and(p, x); #endif } -inline int64_t atomic_or_i64_global(volatile __global int64_t *p, int64_t x) { -#ifdef FUTHARK_CUDA - return atomicOr((int64_t*)p, x); +SCALAR_FUN_ATTR int64_t atomic_or_i64_global(volatile __global int64_t *p, int64_t x) { +#if defined(FUTHARK_CUDA) || defined(FUTHARK_HIP) + return atomicOr((uint64_t*)p, x); #else return atom_or(p, x); #endif } -inline int64_t atomic_or_i64_local(volatile __local int64_t *p, int64_t x) { -#ifdef FUTHARK_CUDA - return atomicOr((int64_t*)p, x); +SCALAR_FUN_ATTR int64_t atomic_or_i64_local(volatile __local int64_t *p, int64_t x) { +#if defined(FUTHARK_CUDA) || defined(FUTHARK_HIP) + return atomicOr((uint64_t*)p, x); #else return atom_or(p, x); #endif } -inline int64_t atomic_xor_i64_global(volatile __global int64_t *p, int64_t x) { -#ifdef FUTHARK_CUDA - return atomicXor((int64_t*)p, x); +SCALAR_FUN_ATTR int64_t atomic_xor_i64_global(volatile __global int64_t *p, int64_t x) { +#if defined(FUTHARK_CUDA) || defined(FUTHARK_HIP) + return atomicXor((uint64_t*)p, x); #else return atom_xor(p, x); #endif } -inline int64_t atomic_xor_i64_local(volatile __local int64_t *p, int64_t x) { -#ifdef FUTHARK_CUDA - return atomicXor((int64_t*)p, x); +SCALAR_FUN_ATTR int64_t atomic_xor_i64_local(volatile __local int64_t *p, int64_t x) { +#if defined(FUTHARK_CUDA) || defined(FUTHARK_HIP) + return atomicXor((uint64_t*)p, x); #else return atom_xor(p, x); #endif } -#endif // defined(FUTHARK_CUDA) || defined(cl_khr_int64_base_atomics) && defined(cl_khr_int64_extended_atomics) +#endif // defined(FUTHARK_CUDA) || defined(FUTHARK_HIP) || defined(cl_khr_int64_base_atomics) && defined(cl_khr_int64_extended_atomics) // End of atomics.h 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 @@ -87,15 +87,13 @@ const char** tuning_param_classes; // Uniform fields above. + char* program; int num_nvrtc_opts; const char **nvrtc_opts; const char *preferred_device; int preferred_device_num; - const char *dump_program_to; - const char *load_program_from; - const char *dump_ptx_to; const char *load_ptx_from; @@ -115,10 +113,10 @@ cfg->nvrtc_opts = (const char**) malloc(sizeof(const char*)); cfg->nvrtc_opts[0] = NULL; + cfg->program = strconcat(gpu_program); + cfg->preferred_device_num = 0; cfg->preferred_device = ""; - cfg->dump_program_to = NULL; - cfg->load_program_from = NULL; cfg->dump_ptx_to = NULL; cfg->load_ptx_from = NULL; @@ -161,12 +159,12 @@ cfg->preferred_device_num = x; } -void futhark_context_config_dump_program_to(struct futhark_context_config *cfg, const char *path) { - cfg->dump_program_to = path; +const char* futhark_context_config_get_program(struct futhark_context_config *cfg) { + return cfg->program; } -void futhark_context_config_load_program_from(struct futhark_context_config *cfg, const char *path) { - cfg->load_program_from = path; +void futhark_context_config_set_program(struct futhark_context_config *cfg, const char *s) { + cfg->program = strdup(s); } void futhark_context_config_dump_ptx_to(struct futhark_context_config *cfg, const char *path) { @@ -235,8 +233,7 @@ // A record of something that happened. struct profiling_record { cudaEvent_t *events; // Points to two events. - int *runs; - int64_t *runtime; + const char *name; }; struct futhark_context { @@ -272,13 +269,13 @@ CUmodule module; CUstream stream; - struct free_list cu_free_list; + struct free_list gpu_free_list; - size_t max_block_size; + size_t max_group_size; size_t max_grid_size; size_t max_tile_size; size_t max_threshold; - size_t max_shared_memory; + size_t max_local_memory; size_t max_bespoke; size_t lockstep_width; @@ -286,6 +283,8 @@ struct profiling_record *profiling_records; int profiling_records_capacity; int profiling_records_used; + + struct builtin_kernels* kernels; }; #define CU_DEV_ATTR(x) (CU_DEVICE_ATTRIBUTE_##x) @@ -331,13 +330,13 @@ name[sizeof(name) - 1] = 0; if (cfg->logging) { - fprintf(stderr, "Device #%d: name=\"%s\", compute capability=%d.%d\n", + fprintf(ctx->log, "Device #%d: name=\"%s\", compute capability=%d.%d\n", i, name, cc_major, cc_minor); } if (device_query(dev, COMPUTE_MODE) == CU_COMPUTEMODE_PROHIBITED) { if (cfg->logging) { - fprintf(stderr, "Device #%d is compute-prohibited, ignoring\n", i); + fprintf(ctx->log, "Device #%d is compute-prohibited, ignoring\n", i); } continue; } @@ -360,31 +359,13 @@ if (chosen == -1) { return 1; } if (cfg->logging) { - fprintf(stderr, "Using device #%d\n", chosen); + fprintf(ctx->log, "Using device #%d\n", chosen); } CUDA_SUCCEED_FATAL(cuDeviceGet(&ctx->dev, chosen)); return 0; } -static char *concat_fragments(const char *src_fragments[]) { - size_t src_len = 0; - const char **p; - - for (p = src_fragments; *p; p++) { - src_len += strlen(*p); - } - - char *src = (char*) malloc(src_len + 1); - size_t n = 0; - for (p = src_fragments; *p; p++) { - strcpy(src + n, *p); - n += strlen(*p); - } - - return src; -} - static const char *cuda_nvrtc_get_arch(CUdevice dev) { static struct { int major; @@ -467,13 +448,13 @@ } opts[i++] = msgprintf("-D%s=%d", "max_group_size", - (int)ctx->max_block_size); + (int)ctx->max_group_size); for (int j = 0; j < cfg->num_tuning_params; j++) { opts[i++] = msgprintf("-D%s=%zu", cfg->tuning_param_vars[j], cfg->tuning_params[j]); } opts[i++] = msgprintf("-DLOCKSTEP_WIDTH=%zu", ctx->lockstep_width); - opts[i++] = msgprintf("-DMAX_THREADS_PER_BLOCK=%zu", ctx->max_block_size); + opts[i++] = msgprintf("-DMAX_THREADS_PER_BLOCK=%zu", ctx->max_group_size); // Time for the best lines of the code in the entire compiler. if (getenv("CUDA_HOME") != NULL) { @@ -492,6 +473,10 @@ opts[i++] = strdup(extra_opts[j]); } + opts[i++] = msgprintf("-DTR_BLOCK_DIM=%d", TR_BLOCK_DIM); + opts[i++] = msgprintf("-DTR_TILE_DIM=%d", TR_TILE_DIM); + opts[i++] = msgprintf("-DTR_ELEMS_PER_THREAD=%d", TR_ELEMS_PER_THREAD); + *n_opts = i; *opts_out = opts; } @@ -557,13 +542,13 @@ static void cuda_size_setup(struct futhark_context *ctx) { struct futhark_context_config *cfg = ctx->cfg; - if (cfg->default_block_size > ctx->max_block_size) { + if (cfg->default_block_size > ctx->max_group_size) { if (cfg->default_block_size_changed) { fprintf(stderr, "Note: Device limits default block size to %zu (down from %zu).\n", - ctx->max_block_size, cfg->default_block_size); + ctx->max_group_size, cfg->default_block_size); } - cfg->default_block_size = ctx->max_block_size; + cfg->default_block_size = ctx->max_group_size; } if (cfg->default_grid_size > ctx->max_grid_size) { if (cfg->default_grid_size_changed) { @@ -596,7 +581,7 @@ int64_t max_value = 0, default_value = 0; if (strstr(size_class, "group_size") == size_class) { - max_value = ctx->max_block_size; + max_value = ctx->max_group_size; default_value = cfg->default_block_size; } else if (strstr(size_class, "num_groups") == size_class) { max_value = ctx->max_grid_size; @@ -631,31 +616,16 @@ } static char* cuda_module_setup(struct futhark_context *ctx, - const char *src_fragments[], + const char *src, const char *extra_opts[], const char* cache_fname) { - char *ptx = NULL, *src = NULL; + char *ptx = NULL; struct futhark_context_config *cfg = ctx->cfg; - if (cfg->load_program_from == NULL) { - src = concat_fragments(src_fragments); - } else { - src = slurp_file(cfg->load_program_from, NULL); - } - if (cfg->load_ptx_from) { - if (cfg->load_program_from != NULL) { - fprintf(stderr, - "WARNING: Using PTX from %s instead of C code from %s\n", - cfg->load_ptx_from, cfg->load_program_from); - } ptx = slurp_file(cfg->load_ptx_from, NULL); } - if (cfg->dump_program_to != NULL) { - dump_file(cfg->dump_program_to, src, strlen(src)); - } - char **opts; size_t n_opts; cuda_nvrtc_mk_build_options(ctx, extra_opts, &opts, &n_opts); @@ -695,7 +665,6 @@ if (ptx == NULL) { char* problem = cuda_nvrtc_build(src, (const char**)opts, n_opts, &ptx); if (problem != NULL) { - free(src); return problem; } } @@ -722,18 +691,15 @@ free((char *)opts[i]); } free(opts); - free(ptx); - if (src != NULL) { - free(src); - } return NULL; } // Count up the runtime all the profiling_records that occured during execution. // Also clears the buffer of profiling_records. -static CUresult cuda_tally_profiling_records(struct futhark_context *ctx) { +static CUresult tally_profiling_records(struct futhark_context *ctx, + struct cost_centres* ccs) { CUresult err; for (int i = 0; i < ctx->profiling_records_used; i++) { struct profiling_record record = ctx->profiling_records[i]; @@ -743,9 +709,15 @@ return err; } - // CUDA provides milisecond resolution, but we want microseconds. - *record.runs += 1; - *record.runtime += ms*1000; + if (ccs) { + // CUDA provides milisecond resolution, but we want microseconds. + struct cost_centre c = { + .name = record.name, + .runs = 1, + .runtime = ms*1000 + }; + cost_centres_add(ccs, c); + } if ((err = cuEventDestroy(record.events[0])) != CUDA_SUCCESS) { return err; @@ -763,7 +735,7 @@ } // Returns pointer to two events. -static cudaEvent_t* cuda_get_events(struct futhark_context *ctx, int *runs, int64_t *runtime) { +static cudaEvent_t* cuda_get_events(struct futhark_context *ctx, const char* name) { if (ctx->profiling_records_used == ctx->profiling_records_capacity) { ctx->profiling_records_capacity *= 2; ctx->profiling_records = @@ -775,79 +747,11 @@ cudaEventCreate(&events[0]); cudaEventCreate(&events[1]); ctx->profiling_records[ctx->profiling_records_used].events = events; - ctx->profiling_records[ctx->profiling_records_used].runs = runs; - ctx->profiling_records[ctx->profiling_records_used].runtime = runtime; + ctx->profiling_records[ctx->profiling_records_used].name = name; ctx->profiling_records_used++; return events; } -static CUresult cuda_alloc(struct futhark_context *ctx, FILE *log, - size_t min_size, const char *tag, - CUdeviceptr *mem_out, size_t *size_out) { - if (min_size < sizeof(int)) { - min_size = sizeof(int); - } - - if (free_list_find(&ctx->cu_free_list, min_size, tag, size_out, (fl_mem*)mem_out) == 0) { - if (*size_out >= min_size) { - if (ctx->cfg->debugging) { - fprintf(log, "No need to allocate: Found a block in the free list.\n"); - } - return CUDA_SUCCESS; - } else { - if (ctx->cfg->debugging) { - fprintf(log, "Found a free block, but it was too small.\n"); - } - - CUresult res = cuMemFree(*mem_out); - if (res != CUDA_SUCCESS) { - return res; - } - } - } - - *size_out = min_size; - - if (ctx->cfg->debugging) { - fprintf(log, "Actually allocating the desired block.\n"); - } - - CUresult res = cuMemAlloc(mem_out, min_size); - while (res == CUDA_ERROR_OUT_OF_MEMORY) { - CUdeviceptr mem; - if (free_list_first(&ctx->cu_free_list, (fl_mem*)&mem) == 0) { - res = cuMemFree(mem); - if (res != CUDA_SUCCESS) { - return res; - } - } else { - break; - } - res = cuMemAlloc(mem_out, min_size); - } - - return res; -} - -static CUresult cuda_free(struct futhark_context *ctx, - CUdeviceptr mem, size_t size, const char *tag) { - free_list_insert(&ctx->cu_free_list, size, (fl_mem)mem, tag); - return CUDA_SUCCESS; -} - -static CUresult cuda_free_all(struct futhark_context *ctx) { - CUdeviceptr mem; - free_list_pack(&ctx->cu_free_list); - while (free_list_first(&ctx->cu_free_list, (fl_mem*)&mem) == 0) { - CUresult res = cuMemFree(mem); - if (res != CUDA_SUCCESS) { - return res; - } - } - - return CUDA_SUCCESS; -} - int futhark_context_sync(struct futhark_context* ctx) { CUDA_SUCCEED_OR_RETURN(cuCtxPushCurrent(ctx->cu_ctx)); CUDA_SUCCEED_OR_RETURN(cuCtxSynchronize()); @@ -880,10 +784,14 @@ return FUTHARK_PROGRAM_ERROR; } } + CUDA_SUCCEED_OR_RETURN(cuCtxPopCurrent(&ctx->cu_ctx)); return 0; } +struct builtin_kernels* init_builtin_kernels(struct futhark_context* ctx); +void free_builtin_kernels(struct futhark_context* ctx, struct builtin_kernels* kernels); + int backend_context_setup(struct futhark_context* ctx) { ctx->profiling_records_capacity = 200; ctx->profiling_records_used = 0; @@ -902,18 +810,18 @@ } CUDA_SUCCEED_FATAL(cuCtxCreate(&ctx->cu_ctx, 0, ctx->dev)); - free_list_init(&ctx->cu_free_list); + free_list_init(&ctx->gpu_free_list); - ctx->max_shared_memory = device_query(ctx->dev, MAX_SHARED_MEMORY_PER_BLOCK); - ctx->max_block_size = device_query(ctx->dev, MAX_THREADS_PER_BLOCK); + ctx->max_local_memory = device_query(ctx->dev, MAX_SHARED_MEMORY_PER_BLOCK); + ctx->max_group_size = device_query(ctx->dev, MAX_THREADS_PER_BLOCK); ctx->max_grid_size = device_query(ctx->dev, MAX_GRID_DIM_X); - ctx->max_tile_size = sqrt(ctx->max_block_size); + ctx->max_tile_size = sqrt(ctx->max_group_size); ctx->max_threshold = 0; ctx->max_bespoke = 0; ctx->lockstep_width = device_query(ctx->dev, WARP_SIZE); CUDA_SUCCEED_FATAL(cuStreamCreate(&ctx->stream, CU_STREAM_DEFAULT)); cuda_size_setup(ctx); - ctx->error = cuda_module_setup(ctx, cuda_program, + ctx->error = cuda_module_setup(ctx, ctx->cfg->program, ctx->cfg->nvrtc_opts, ctx->cfg->cache_fname); if (ctx->error != NULL) { @@ -925,18 +833,207 @@ CUDA_SUCCEED_FATAL(cuMemcpyHtoD(ctx->global_failure, &no_error, sizeof(no_error))); // The +1 is to avoid zero-byte allocations. CUDA_SUCCEED_FATAL(cuMemAlloc(&ctx->global_failure_args, sizeof(int64_t)*(max_failure_args+1))); + + if ((ctx->kernels = init_builtin_kernels(ctx)) == NULL) { + return 1; + } + return 0; } void backend_context_teardown(struct futhark_context* ctx) { + free_builtin_kernels(ctx, ctx->kernels); cuMemFree(ctx->global_failure); cuMemFree(ctx->global_failure_args); - CUDA_SUCCEED_FATAL(cuda_free_all(ctx)); - (void)cuda_tally_profiling_records(ctx); + CUDA_SUCCEED_FATAL(gpu_free_all(ctx)); + (void)tally_profiling_records(ctx, NULL); free(ctx->profiling_records); CUDA_SUCCEED_FATAL(cuStreamDestroy(ctx->stream)); CUDA_SUCCEED_FATAL(cuModuleUnload(ctx->module)); CUDA_SUCCEED_FATAL(cuCtxDestroy(ctx->cu_ctx)); +} + +// GPU ABSTRACTION LAYER + +// Types. + +typedef CUfunction gpu_kernel; +typedef CUdeviceptr gpu_mem; + +static void gpu_create_kernel(struct futhark_context *ctx, + gpu_kernel* kernel, + const char* name) { + if (ctx->debugging) { + fprintf(ctx->log, "Creating kernel %s.\n", name); + } + CUDA_SUCCEED_FATAL(cuModuleGetFunction(kernel, ctx->module, name)); +} + +static void gpu_free_kernel(struct futhark_context *ctx, + gpu_kernel kernel) { + (void)ctx; + (void)kernel; +} + +static int gpu_scalar_to_device(struct futhark_context* ctx, + gpu_mem dst, size_t offset, size_t size, + void *src) { + CUevent *pevents = NULL; + if (ctx->profiling && !ctx->profiling_paused) { + pevents = cuda_get_events(ctx, "copy_scalar_to_dev"); + CUDA_SUCCEED_FATAL(cuEventRecord(pevents[0], ctx->stream)); + } + CUDA_SUCCEED_OR_RETURN(cuMemcpyHtoD(dst + offset, src, size)); + if (pevents != NULL) { + CUDA_SUCCEED_FATAL(cuEventRecord(pevents[1], ctx->stream)); + } + return FUTHARK_SUCCESS; +} + +static int gpu_scalar_from_device(struct futhark_context* ctx, + void *dst, + gpu_mem src, size_t offset, size_t size) { + CUevent *pevents = NULL; + if (ctx->profiling && !ctx->profiling_paused) { + pevents = cuda_get_events(ctx, "copy_scalar_from_dev"); + CUDA_SUCCEED_FATAL(cuEventRecord(pevents[0], ctx->stream)); + } + CUDA_SUCCEED_OR_RETURN(cuMemcpyDtoH(dst, src + offset, size)); + if (pevents != NULL) { + CUDA_SUCCEED_FATAL(cuEventRecord(pevents[1], ctx->stream)); + } + return FUTHARK_SUCCESS; +} + +static int gpu_memcpy(struct futhark_context* ctx, + gpu_mem dst, int64_t dst_offset, + gpu_mem src, int64_t src_offset, + int64_t nbytes) { + CUevent *pevents = NULL; + if (ctx->profiling && !ctx->profiling_paused) { + pevents = cuda_get_events(ctx, "copy_dev_to_dev"); + CUDA_SUCCEED_FATAL(cuEventRecord(pevents[0], ctx->stream)); + } + CUDA_SUCCEED_OR_RETURN(cuMemcpy(dst+dst_offset, src+src_offset, nbytes)); + if (pevents != NULL) { + CUDA_SUCCEED_FATAL(cuEventRecord(pevents[1], ctx->stream)); + } + return FUTHARK_SUCCESS; +} + +static int memcpy_host2gpu(struct futhark_context* ctx, bool sync, + gpu_mem dst, int64_t dst_offset, + const unsigned char* src, int64_t src_offset, + int64_t nbytes) { + if (nbytes > 0) { + CUevent* pevents = NULL; + if (ctx->profiling && !ctx->profiling_paused) { + pevents = cuda_get_events(ctx, "copy_host_to_dev"); + CUDA_SUCCEED_FATAL(cuEventRecord(pevents[0], ctx->stream)); + } + if (sync) { + CUDA_SUCCEED_OR_RETURN + (cuMemcpyHtoD(dst + dst_offset, src + src_offset, nbytes)); + } else { + CUDA_SUCCEED_OR_RETURN + (cuMemcpyHtoDAsync(dst + dst_offset, src + src_offset, nbytes, ctx->stream)); + } + if (pevents != NULL) { + CUDA_SUCCEED_FATAL(cuEventRecord(pevents[1], ctx->stream)); + } + } + return FUTHARK_SUCCESS; +} + +static int memcpy_gpu2host(struct futhark_context* ctx, bool sync, + unsigned char* dst, int64_t dst_offset, + gpu_mem src, int64_t src_offset, + int64_t nbytes) { + if (nbytes > 0) { + CUevent* pevents = NULL; + if (ctx->profiling && !ctx->profiling_paused) { + pevents = cuda_get_events(ctx, "copy_dev_to_host"); + CUDA_SUCCEED_FATAL(cuEventRecord(pevents[0], ctx->stream)); + } + if (sync) { + CUDA_SUCCEED_OR_RETURN + (cuMemcpyDtoH(dst + dst_offset, src + src_offset, nbytes)); + } else { + CUDA_SUCCEED_OR_RETURN + (cuMemcpyDtoHAsync(dst + dst_offset, src + src_offset, nbytes, ctx->stream)); + } + if (sync && + ctx->failure_is_an_option && + futhark_context_sync(ctx) != 0) { + return 1; + } + } + return FUTHARK_SUCCESS; +} + +static int gpu_launch_kernel(struct futhark_context* ctx, + gpu_kernel kernel, const char *name, + const int32_t grid[3], + const int32_t block[3], + unsigned int local_mem_bytes, + int num_args, + void* args[num_args], + size_t args_sizes[num_args]) { + (void) args_sizes; + int64_t time_start = 0, time_end = 0; + if (ctx->logging) { + fprintf(ctx->log, + "Launching kernel %s with\n" + " grid=(%d,%d,%d)\n" + " block=(%d,%d,%d)\n" + " local memory=%d\n", + name, + grid[0], grid[1], grid[2], + block[0], block[1], block[2], + local_mem_bytes); + time_start = get_wall_time(); + } + + CUevent *pevents = NULL; + if (ctx->profiling && !ctx->profiling_paused) { + pevents = cuda_get_events(ctx, name); + CUDA_SUCCEED_FATAL(cuEventRecord(pevents[0], ctx->stream)); + } + + CUDA_SUCCEED_OR_RETURN + (cuLaunchKernel(kernel, + grid[0], grid[1], grid[2], + block[0], block[1], block[2], + local_mem_bytes, ctx->stream, + args, NULL)); + + if (pevents != NULL) { + CUDA_SUCCEED_FATAL(cuEventRecord(pevents[1], ctx->stream)); + } + + if (ctx->debugging) { + CUDA_SUCCEED_FATAL(cuCtxSynchronize()); + time_end = get_wall_time(); + long int time_diff = time_end - time_start; + fprintf(ctx->log, " runtime: %ldus\n\n", time_diff); + } + + return FUTHARK_SUCCESS; +} + +static int gpu_alloc_actual(struct futhark_context *ctx, size_t size, gpu_mem *mem_out) { + CUresult res = cuMemAlloc(mem_out, size); + if (res == CUDA_ERROR_OUT_OF_MEMORY) { + return FUTHARK_OUT_OF_MEMORY; + } + CUDA_SUCCEED_OR_RETURN(res); + return FUTHARK_SUCCESS; +} + +static int gpu_free_actual(struct futhark_context *ctx, gpu_mem mem) { + (void)ctx; + CUDA_SUCCEED_OR_RETURN(cuMemFree(mem)); + return FUTHARK_SUCCESS; } // End of backends/cuda.h. diff --git a/rts/c/backends/hip.h b/rts/c/backends/hip.h new file mode 100644 --- /dev/null +++ b/rts/c/backends/hip.h @@ -0,0 +1,911 @@ +// Start of backends/hip.h. + +// Forward declarations. +// Invoked by setup_opencl() after the platform and device has been +// found, but before the program is loaded. Its intended use is to +// tune constants based on the selected platform and device. +static void set_tuning_params(struct futhark_context* ctx); +static char* get_failure_msg(int failure_idx, int64_t args[]); + +#define HIP_SUCCEED_FATAL(x) hip_api_succeed_fatal(x, #x, __FILE__, __LINE__) +#define HIP_SUCCEED_NONFATAL(x) hip_api_succeed_nonfatal(x, #x, __FILE__, __LINE__) +#define HIPRTC_SUCCEED_FATAL(x) hiprtc_api_succeed_fatal(x, #x, __FILE__, __LINE__) +#define HIPRTC_SUCCEED_NONFATAL(x) hiprtc_api_succeed_nonfatal(x, #x, __FILE__, __LINE__) +// Take care not to override an existing error. +#define HIP_SUCCEED_OR_RETURN(e) { \ + char *serror = HIP_SUCCEED_NONFATAL(e); \ + if (serror) { \ + if (!ctx->error) { \ + ctx->error = serror; \ + return bad; \ + } else { \ + free(serror); \ + } \ + } \ + } + +// HIP_SUCCEED_OR_RETURN returns the value of the variable 'bad' in +// scope. By default, it will be this one. Create a local variable +// of some other type if needed. This is a bit of a hack, but it +// saves effort in the code generator. +static const int bad = 1; + +static inline void hip_api_succeed_fatal(hipError_t res, const char *call, + const char *file, int line) { + if (res != hipSuccess) { + const char *err_str = hipGetErrorString(res); + if (err_str == NULL) { err_str = "Unknown"; } + futhark_panic(-1, "%s:%d: HIP call\n %s\nfailed with error code %d (%s)\n", + file, line, call, res, err_str); + } +} + +static char* hip_api_succeed_nonfatal(hipError_t res, const char *call, + const char *file, int line) { + if (res != hipSuccess) { + const char *err_str = hipGetErrorString(res); + if (err_str == NULL) { err_str = "Unknown"; } + return msgprintf("%s:%d: HIP call\n %s\nfailed with error code %d (%s)\n", + file, line, call, res, err_str); + } else { + return NULL; + } +} + +static inline void hiprtc_api_succeed_fatal(hiprtcResult res, const char *call, + const char *file, int line) { + if (res != HIPRTC_SUCCESS) { + const char *err_str = hiprtcGetErrorString(res); + futhark_panic(-1, "%s:%d: HIPRTC call\n %s\nfailed with error code %d (%s)\n", + file, line, call, res, err_str); + } +} + +static char* hiprtc_api_succeed_nonfatal(hiprtcResult res, const char *call, + const char *file, int line) { + if (res != HIPRTC_SUCCESS) { + const char *err_str = hiprtcGetErrorString(res); + return msgprintf("%s:%d: HIPRTC call\n %s\nfailed with error code %d (%s)\n", + file, line, call, res, err_str); + } else { + return NULL; + } +} + +struct futhark_context_config { + int in_use; + int debugging; + int profiling; + int logging; + const char *cache_fname; + int num_tuning_params; + int64_t *tuning_params; + const char** tuning_param_names; + const char** tuning_param_vars; + const char** tuning_param_classes; + // Uniform fields above. + + char* program; + int num_build_opts; + const char **build_opts; + + const char *preferred_device; + int preferred_device_num; + + size_t default_block_size; + size_t default_grid_size; + size_t default_tile_size; + size_t default_reg_tile_size; + size_t default_threshold; + + int default_block_size_changed; + int default_grid_size_changed; + int default_tile_size_changed; +}; + +static void backend_context_config_setup(struct futhark_context_config *cfg) { + cfg->num_build_opts = 0; + cfg->build_opts = (const char**) malloc(sizeof(const char*)); + cfg->build_opts[0] = NULL; + cfg->preferred_device_num = 0; + cfg->preferred_device = ""; + cfg->program = strconcat(gpu_program); + + cfg->default_block_size = 256; + cfg->default_grid_size = 0; // Set properly later. + cfg->default_tile_size = 32; + cfg->default_reg_tile_size = 2; + cfg->default_threshold = 32*1024; + + cfg->default_block_size_changed = 0; + cfg->default_grid_size_changed = 0; + cfg->default_tile_size_changed = 0; +} + +static void backend_context_config_teardown(struct futhark_context_config* cfg) { + free(cfg->build_opts); + free(cfg->program); +} + +void futhark_context_config_add_build_option(struct futhark_context_config *cfg, const char *opt) { + cfg->build_opts[cfg->num_build_opts] = opt; + cfg->num_build_opts++; + cfg->build_opts = (const char **) realloc(cfg->build_opts, (cfg->num_build_opts + 1) * sizeof(const char *)); + cfg->build_opts[cfg->num_build_opts] = NULL; +} + +void futhark_context_config_set_device(struct futhark_context_config *cfg, const char *s) { + int x = 0; + if (*s == '#') { + s++; + while (isdigit(*s)) { + x = x * 10 + (*s++)-'0'; + } + // Skip trailing spaces. + while (isspace(*s)) { + s++; + } + } + cfg->preferred_device = s; + cfg->preferred_device_num = x; +} + + +const char* futhark_context_config_get_program(struct futhark_context_config *cfg) { + return cfg->program; +} + +void futhark_context_config_set_program(struct futhark_context_config *cfg, const char *s) { + cfg->program = strdup(s); +} + +void futhark_context_config_set_default_group_size(struct futhark_context_config *cfg, int size) { + cfg->default_block_size = size; + cfg->default_block_size_changed = 1; +} + +void futhark_context_config_set_default_num_groups(struct futhark_context_config *cfg, int num) { + cfg->default_grid_size = num; + cfg->default_grid_size_changed = 1; +} + +void futhark_context_config_set_default_tile_size(struct futhark_context_config *cfg, int size) { + cfg->default_tile_size = size; + cfg->default_tile_size_changed = 1; +} + +void futhark_context_config_set_default_reg_tile_size(struct futhark_context_config *cfg, int size) { + cfg->default_reg_tile_size = size; +} + +void futhark_context_config_set_default_threshold(struct futhark_context_config *cfg, int size) { + cfg->default_threshold = size; +} + +int futhark_context_config_set_tuning_param(struct futhark_context_config *cfg, + const char *param_name, + size_t new_value) { + for (int i = 0; i < cfg->num_tuning_params; i++) { + if (strcmp(param_name, cfg->tuning_param_names[i]) == 0) { + cfg->tuning_params[i] = new_value; + return 0; + } + } + if (strcmp(param_name, "default_group_size") == 0) { + cfg->default_block_size = new_value; + return 0; + } + if (strcmp(param_name, "default_num_groups") == 0) { + cfg->default_grid_size = new_value; + return 0; + } + if (strcmp(param_name, "default_threshold") == 0) { + cfg->default_threshold = new_value; + return 0; + } + if (strcmp(param_name, "default_tile_size") == 0) { + cfg->default_tile_size = new_value; + return 0; + } + if (strcmp(param_name, "default_reg_tile_size") == 0) { + cfg->default_reg_tile_size = new_value; + return 0; + } + return 1; +} + +// A record of something that happened. +struct profiling_record { + hipEvent_t *events; // Points to two events. + const char *name; +}; + +struct futhark_context { + struct futhark_context_config* cfg; + int detail_memory; + int debugging; + int profiling; + int profiling_paused; + int logging; + lock_t lock; + char *error; + lock_t error_lock; + FILE *log; + struct constants *constants; + struct free_list free_list; + int64_t peak_mem_usage_default; + int64_t cur_mem_usage_default; + // Uniform fields above. + + void* global_failure; + void* global_failure_args; + struct tuning_params tuning_params; + // True if a potentially failing kernel has been enqueued. + int32_t failure_is_an_option; + int total_runs; + long int total_runtime; + int64_t peak_mem_usage_device; + int64_t cur_mem_usage_device; + struct program* program; + + hipDevice_t dev; + int dev_id; + hipModule_t module; + hipStream_t stream; + + struct free_list gpu_free_list; + + size_t max_group_size; + size_t max_grid_size; + size_t max_tile_size; + size_t max_threshold; + size_t max_local_memory; + size_t max_bespoke; + + size_t lockstep_width; + + struct profiling_record *profiling_records; + int profiling_records_capacity; + int profiling_records_used; + + struct builtin_kernels* kernels; +}; + +static int device_query(int dev_id, hipDeviceAttribute_t attr) { + int val; + HIP_SUCCEED_FATAL(hipDeviceGetAttribute(&val, attr, dev_id)); + return val; +} + +static int function_query(hipFunction_t f, hipFunction_attribute attr) { + int val; + HIP_SUCCEED_FATAL(hipFuncGetAttribute(&val, attr, f)); + return val; +} + +static int hip_device_setup(struct futhark_context *ctx) { + struct futhark_context_config *cfg = ctx->cfg; + int count, chosen = -1; + hipDevice_t dev; + + HIP_SUCCEED_FATAL(hipGetDeviceCount(&count)); + if (count == 0) { return 1; } + + int num_device_matches = 0; + + for (int i = 0; i < count; i++) { + hipDeviceProp_t prop; + hipGetDeviceProperties(&prop, i); + + if (cfg->logging) { + fprintf(ctx->log, "Device #%d: name=\"%s\"\n", i, prop.name); + } + + if (strstr(prop.name, cfg->preferred_device) != NULL && + num_device_matches++ == cfg->preferred_device_num) { + chosen = i; + break; + } + } + + if (chosen == -1) { return 1; } + + if (cfg->logging) { + fprintf(ctx->log, "Using device #%d\n", chosen); + } + + ctx->dev_id = chosen; + HIP_SUCCEED_FATAL(hipDeviceGet(&ctx->dev, ctx->dev_id)); + return 0; +} + +static void hip_load_code_from_cache(struct futhark_context_config *cfg, + const char *src, + const char *opts[], size_t n_opts, + struct cache_hash *h, const char *cache_fname, + char **code, size_t *code_size) { + if (cfg->logging) { + fprintf(stderr, "Restoring cache from from %s...\n", cache_fname); + } + cache_hash_init(h); + for (size_t i = 0; i < n_opts; i++) { + cache_hash(h, opts[i], strlen(opts[i])); + } + cache_hash(h, src, strlen(src)); + errno = 0; + if (cache_restore(cache_fname, h, (unsigned char**)code, code_size) != 0) { + if (cfg->logging) { + fprintf(stderr, "Failed to restore cache (errno: %s)\n", strerror(errno)); + } + } +} + +static void hip_size_setup(struct futhark_context *ctx) { + struct futhark_context_config *cfg = ctx->cfg; + if (cfg->default_block_size > ctx->max_group_size) { + if (cfg->default_block_size_changed) { + fprintf(stderr, + "Note: Device limits default block size to %zu (down from %zu).\n", + ctx->max_group_size, cfg->default_block_size); + } + cfg->default_block_size = ctx->max_group_size; + } + if (cfg->default_grid_size > ctx->max_grid_size) { + if (cfg->default_grid_size_changed) { + fprintf(stderr, + "Note: Device limits default grid size to %zu (down from %zu).\n", + ctx->max_grid_size, cfg->default_grid_size); + } + cfg->default_grid_size = ctx->max_grid_size; + } + if (cfg->default_tile_size > ctx->max_tile_size) { + if (cfg->default_tile_size_changed) { + fprintf(stderr, + "Note: Device limits default tile size to %zu (down from %zu).\n", + ctx->max_tile_size, cfg->default_tile_size); + } + cfg->default_tile_size = ctx->max_tile_size; + } + + if (!cfg->default_grid_size_changed) { + cfg->default_grid_size = + (device_query(ctx->dev, hipDeviceAttributePhysicalMultiProcessorCount) * + device_query(ctx->dev, hipDeviceAttributeMaxThreadsPerMultiProcessor)) + / cfg->default_block_size; + } + + for (int i = 0; i < cfg->num_tuning_params; i++) { + const char *size_class = cfg->tuning_param_classes[i]; + int64_t *size_value = &cfg->tuning_params[i]; + const char* size_name = cfg->tuning_param_names[i]; + int64_t max_value = 0, default_value = 0; + + if (strstr(size_class, "group_size") == size_class) { + max_value = ctx->max_group_size; + default_value = cfg->default_block_size; + } else if (strstr(size_class, "num_groups") == size_class) { + max_value = ctx->max_grid_size; + default_value = cfg->default_grid_size; + // XXX: as a quick and dirty hack, use twice as many threads for + // histograms by default. We really should just be smarter + // about sizes somehow. + if (strstr(size_name, ".seghist_") != NULL) { + default_value *= 2; + } + } else if (strstr(size_class, "tile_size") == size_class) { + max_value = ctx->max_tile_size; + default_value = cfg->default_tile_size; + } else if (strstr(size_class, "reg_tile_size") == size_class) { + max_value = 0; // No limit. + default_value = cfg->default_reg_tile_size; + } else if (strstr(size_class, "threshold") == size_class) { + // Threshold can be as large as it takes. + default_value = cfg->default_threshold; + } else { + // Bespoke sizes have no limit or default. + } + + if (*size_value == 0) { + *size_value = default_value; + } else if (max_value > 0 && *size_value > max_value) { + fprintf(stderr, "Note: Device limits %s to %zu (down from %zu)\n", + size_name, max_value, *size_value); + *size_value = max_value; + } + } +} + +static char* hiprtc_build(const char *src, const char *opts[], size_t n_opts, + char **code, size_t *code_size) { + hiprtcProgram prog; + char *problem = NULL; + + problem = HIPRTC_SUCCEED_NONFATAL(hiprtcCreateProgram(&prog, src, "futhark-hip", 0, NULL, NULL)); + + if (problem) { + return problem; + } + + hiprtcResult res = hiprtcCompileProgram(prog, n_opts, opts); + if (res != HIPRTC_SUCCESS) { + size_t log_size; + if (hiprtcGetProgramLogSize(prog, &log_size) == HIPRTC_SUCCESS) { + char *log = (char*) malloc(log_size+1); + log[log_size] = 0; // HIPRTC does not zero-terminate. + if (hiprtcGetProgramLog(prog, log) == HIPRTC_SUCCESS) { + problem = msgprintf("HIPRTC compilation failed.\n\n%s\n", log); + } else { + problem = msgprintf("Could not retrieve compilation log\n"); + } + free(log); + } + return problem; + } + + HIPRTC_SUCCEED_FATAL(hiprtcGetCodeSize(prog, code_size)); + *code = (char*) malloc(*code_size); + HIPRTC_SUCCEED_FATAL(hiprtcGetCode(prog, *code)); + HIPRTC_SUCCEED_FATAL(hiprtcDestroyProgram(&prog)); + return NULL; +} + +static void hiprtc_mk_build_options(struct futhark_context *ctx, const char *extra_opts[], + char*** opts_out, size_t *n_opts) { + int arch_set = 0, num_extra_opts; + struct futhark_context_config *cfg = ctx->cfg; + + for (num_extra_opts = 0; extra_opts[num_extra_opts] != NULL; num_extra_opts++) { + if (strstr(extra_opts[num_extra_opts], "--gpu-architecture") + == extra_opts[num_extra_opts]) { + arch_set = 1; + } + } + + size_t i = 0, n_opts_alloc = 20 + num_extra_opts + cfg->num_tuning_params; + char **opts = (char**) malloc(n_opts_alloc * sizeof(char *)); + if (!arch_set) { + hipDeviceProp_t props; + HIP_SUCCEED_FATAL(hipGetDeviceProperties(&props, ctx->dev_id)); + opts[i++] = msgprintf("--gpu-architecture=%s", props.gcnArchName); + } + if (cfg->debugging) { + opts[i++] = strdup("-G"); + opts[i++] = strdup("-lineinfo"); + } + opts[i++] = msgprintf("-D%s=%d", + "max_group_size", + (int)ctx->max_group_size); + for (int j = 0; j < cfg->num_tuning_params; j++) { + opts[i++] = msgprintf("-D%s=%zu", cfg->tuning_param_vars[j], + cfg->tuning_params[j]); + } + opts[i++] = msgprintf("-DLOCKSTEP_WIDTH=%zu", ctx->lockstep_width); + opts[i++] = msgprintf("-DMAX_THREADS_PER_BLOCK=%zu", ctx->max_group_size); + + for (int j = 0; extra_opts[j] != NULL; j++) { + opts[i++] = strdup(extra_opts[j]); + } + + opts[i++] = msgprintf("-DTR_BLOCK_DIM=%d", TR_BLOCK_DIM); + opts[i++] = msgprintf("-DTR_TILE_DIM=%d", TR_TILE_DIM); + opts[i++] = msgprintf("-DTR_ELEMS_PER_THREAD=%d", TR_ELEMS_PER_THREAD); + + *n_opts = i; + *opts_out = opts; +} + +static char* hip_module_setup(struct futhark_context *ctx, + const char *src, + const char *extra_opts[], + const char* cache_fname) { + char *code = NULL; + size_t code_size = 0; + struct futhark_context_config *cfg = ctx->cfg; + + char **opts; + size_t n_opts; + hiprtc_mk_build_options(ctx, extra_opts, &opts, &n_opts); + + if (cfg->logging) { + fprintf(stderr, "HIPRTC build options:\n"); + for (size_t j = 0; j < n_opts; j++) { + fprintf(stderr, "\t%s\n", opts[j]); + } + fprintf(stderr, "\n"); + } + + struct cache_hash h; + int loaded_code_from_cache = 0; + if (cache_fname != NULL) { + hip_load_code_from_cache(cfg, src, (const char**)opts, n_opts, &h, cache_fname, &code, &code_size); + + if (code != NULL) { + if (cfg->logging) { + fprintf(stderr, "Restored compiled code from cache; now loading module...\n"); + } + if (hipModuleLoadData(&ctx->module, code) == hipSuccess) { + if (cfg->logging) { + fprintf(stderr, "Success!\n"); + } + loaded_code_from_cache = 1; + } else { + if (cfg->logging) { + fprintf(stderr, "Failed!\n"); + } + free(code); + code = NULL; + } + } + } + + if (code == NULL) { + char* problem = hiprtc_build(src, (const char**)opts, n_opts, &code, &code_size); + if (problem != NULL) { + return problem; + } + } + + if (!loaded_code_from_cache) { + HIP_SUCCEED_FATAL(hipModuleLoadData(&ctx->module, code)); + } + + if (cache_fname != NULL && !loaded_code_from_cache) { + if (cfg->logging) { + fprintf(stderr, "Caching compiled code in %s...\n", cache_fname); + } + errno = 0; + if (cache_store(cache_fname, &h, (const unsigned char*)code, code_size) != 0) { + fprintf(stderr, "Failed to cache compiled code: %s\n", strerror(errno)); + } + } + + for (size_t i = 0; i < n_opts; i++) { + free((char *)opts[i]); + } + free(opts); + free(code); + + return NULL; +} + +static int tally_profiling_records(struct futhark_context *ctx, + struct cost_centres* ccs) { + hipError_t err; + for (int i = 0; i < ctx->profiling_records_used; i++) { + struct profiling_record record = ctx->profiling_records[i]; + + float ms; + if ((err = hipEventElapsedTime(&ms, record.events[0], record.events[1])) != hipSuccess) { + return err; + } + + if (ccs) { + struct cost_centre c = { + .name = record.name, + .runs = 1, + .runtime = ms*1000 + }; + cost_centres_add(ccs, c); + } + + if ((err = hipEventDestroy(record.events[0])) != hipSuccess) { + return 1; + } + if ((err = hipEventDestroy(record.events[1])) != hipSuccess) { + return 1; + } + + free(record.events); + } + + ctx->profiling_records_used = 0; + + return 0; +} + +static hipEvent_t* hip_get_events(struct futhark_context *ctx, const char* name) { + if (ctx->profiling_records_used == ctx->profiling_records_capacity) { + ctx->profiling_records_capacity *= 2; + ctx->profiling_records = + realloc(ctx->profiling_records, + ctx->profiling_records_capacity * + sizeof(struct profiling_record)); + } + hipEvent_t *events = calloc(2, sizeof(hipEvent_t)); + hipEventCreate(&events[0]); + hipEventCreate(&events[1]); + ctx->profiling_records[ctx->profiling_records_used].events = events; + ctx->profiling_records[ctx->profiling_records_used].name = name; + ctx->profiling_records_used++; + return events; +} + +int futhark_context_sync(struct futhark_context* ctx) { + HIP_SUCCEED_OR_RETURN(hipStreamSynchronize(ctx->stream)); + if (ctx->failure_is_an_option) { + // Check for any delayed error. + int32_t failure_idx; + HIP_SUCCEED_OR_RETURN(hipMemcpyDtoH(&failure_idx, + ctx->global_failure, + sizeof(int32_t))); + ctx->failure_is_an_option = 0; + + if (failure_idx >= 0) { + // We have to clear global_failure so that the next entry point + // is not considered a failure from the start. + int32_t no_failure = -1; + HIP_SUCCEED_OR_RETURN(hipMemcpyHtoD(ctx->global_failure, + &no_failure, + sizeof(int32_t))); + + int64_t args[max_failure_args+1]; + HIP_SUCCEED_OR_RETURN(hipMemcpyDtoH(&args, + ctx->global_failure_args, + sizeof(args))); + + ctx->error = get_failure_msg(failure_idx, args); + + return FUTHARK_PROGRAM_ERROR; + } + } + return 0; +} + +struct builtin_kernels* init_builtin_kernels(struct futhark_context* ctx); +void free_builtin_kernels(struct futhark_context* ctx, struct builtin_kernels* kernels); + +int backend_context_setup(struct futhark_context* ctx) { + ctx->profiling_records_capacity = 200; + ctx->profiling_records_used = 0; + ctx->profiling_records = + malloc(ctx->profiling_records_capacity * + sizeof(struct profiling_record)); + ctx->failure_is_an_option = 0; + ctx->total_runs = 0; + ctx->total_runtime = 0; + ctx->peak_mem_usage_device = 0; + ctx->cur_mem_usage_device = 0; + + HIP_SUCCEED_FATAL(hipInit(0)); + if (hip_device_setup(ctx) != 0) { + futhark_panic(-1, "No suitable HIP device found.\n"); + } + + free_list_init(&ctx->gpu_free_list); + + ctx->max_local_memory = device_query(ctx->dev, hipDeviceAttributeMaxSharedMemoryPerBlock); + ctx->max_group_size = device_query(ctx->dev, hipDeviceAttributeMaxThreadsPerBlock); + ctx->max_grid_size = device_query(ctx->dev, hipDeviceAttributeMaxGridDimX); + ctx->max_tile_size = sqrt(ctx->max_group_size); + ctx->max_threshold = 0; + ctx->max_bespoke = 0; + // FIXME: in principle we should query hipDeviceAttributeWarpSize + // from the device, which will provide 64 on AMD GPUs. + // Unfortunately, we currently do nasty implicit intra-warp + // synchronisation in codegen, which does not work when this is 64. + // Once our codegen properly synchronises intra-warp operations, we + // can use the actual hardware lockstep width instead. + ctx->lockstep_width = 32; + HIP_SUCCEED_FATAL(hipStreamCreate(&ctx->stream)); + hip_size_setup(ctx); + ctx->error = hip_module_setup(ctx, ctx->cfg->program, + ctx->cfg->build_opts, ctx->cfg->cache_fname); + + if (ctx->error != NULL) { + futhark_panic(1, "During HIP initialisation:\n%s\n", ctx->error); + } + + int32_t no_error = -1; + HIP_SUCCEED_FATAL(hipMalloc(&ctx->global_failure, sizeof(no_error))); + HIP_SUCCEED_FATAL(hipMemcpyHtoD(ctx->global_failure, &no_error, sizeof(no_error))); + // The +1 is to avoid zero-byte allocations. + HIP_SUCCEED_FATAL(hipMalloc(&ctx->global_failure_args, sizeof(int64_t)*(max_failure_args+1))); + + if ((ctx->kernels = init_builtin_kernels(ctx)) == NULL) { + return 1; + } + + return 0; +} + +void backend_context_teardown(struct futhark_context* ctx) { + free_builtin_kernels(ctx, ctx->kernels); + hipFree(ctx->global_failure); + hipFree(ctx->global_failure_args); + HIP_SUCCEED_FATAL(gpu_free_all(ctx)); + (void)tally_profiling_records(ctx, NULL); + free(ctx->profiling_records); + HIP_SUCCEED_FATAL(hipStreamDestroy(ctx->stream)); + HIP_SUCCEED_FATAL(hipModuleUnload(ctx->module)); +} + +// GPU ABSTRACTION LAYER + +typedef hipFunction_t gpu_kernel; +typedef hipDeviceptr_t gpu_mem; + +static void gpu_create_kernel(struct futhark_context *ctx, + gpu_kernel* kernel, + const char* name) { + if (ctx->debugging) { + fprintf(ctx->log, "Creating kernel %s.\n", name); + } + HIP_SUCCEED_FATAL(hipModuleGetFunction(kernel, ctx->module, name)); +} + +static void gpu_free_kernel(struct futhark_context *ctx, + gpu_kernel kernel) { + (void)ctx; + (void)kernel; +} + +static int gpu_scalar_to_device(struct futhark_context* ctx, + gpu_mem dst, size_t offset, size_t size, + void *src) { + hipEvent_t *pevents = NULL; + if (ctx->profiling && !ctx->profiling_paused) { + pevents = hip_get_events(ctx, "copy_scalar_to_dev"); + HIP_SUCCEED_FATAL(hipEventRecord(pevents[0], ctx->stream)); + } + HIP_SUCCEED_OR_RETURN(hipMemcpyHtoD((unsigned char*)dst + offset, src, size)); + if (pevents != NULL) { + HIP_SUCCEED_FATAL(hipEventRecord(pevents[1], ctx->stream)); + } + return FUTHARK_SUCCESS; +} + +static int gpu_scalar_from_device(struct futhark_context* ctx, + void *dst, + gpu_mem src, size_t offset, size_t size) { + hipEvent_t *pevents = NULL; + if (ctx->profiling && !ctx->profiling_paused) { + pevents = hip_get_events(ctx, "copy_scalar_from_dev"); + HIP_SUCCEED_FATAL(hipEventRecord(pevents[0], ctx->stream)); + } + HIP_SUCCEED_OR_RETURN(hipMemcpyDtoH(dst, (unsigned char*)src + offset, size)); + if (pevents != NULL) { + HIP_SUCCEED_FATAL(hipEventRecord(pevents[1], ctx->stream)); + } + return FUTHARK_SUCCESS; +} + +static int gpu_memcpy(struct futhark_context* ctx, + gpu_mem dst, int64_t dst_offset, + gpu_mem src, int64_t src_offset, + int64_t nbytes) { + hipEvent_t *pevents = NULL; + if (ctx->profiling && !ctx->profiling_paused) { + pevents = hip_get_events(ctx, "copy_dev_to_dev"); + HIP_SUCCEED_FATAL(hipEventRecord(pevents[0], ctx->stream)); + } + HIP_SUCCEED_OR_RETURN(hipMemcpyWithStream((unsigned char*)dst+dst_offset, (unsigned char*)src+src_offset, + nbytes, hipMemcpyDeviceToDevice ,ctx->stream)); + if (pevents != NULL) { + HIP_SUCCEED_FATAL(hipEventRecord(pevents[1], ctx->stream)); + } + return FUTHARK_SUCCESS; +} + +static int memcpy_host2gpu(struct futhark_context* ctx, bool sync, + gpu_mem dst, int64_t dst_offset, + const unsigned char* src, int64_t src_offset, + int64_t nbytes) { + if (nbytes > 0) { + hipEvent_t* pevents = NULL; + if (ctx->profiling && !ctx->profiling_paused) { + pevents = hip_get_events(ctx, "copy_host_to_dev"); + HIP_SUCCEED_FATAL(hipEventRecord(pevents[0], ctx->stream)); + } + if (sync) { + HIP_SUCCEED_OR_RETURN + (hipMemcpyHtoD((unsigned char*)dst + dst_offset, + (unsigned char*)src + src_offset, nbytes)); + } else { + HIP_SUCCEED_OR_RETURN + (hipMemcpyHtoDAsync((unsigned char*)dst + dst_offset, + (unsigned char*)src + src_offset, + nbytes, ctx->stream)); + } + if (pevents != NULL) { + HIP_SUCCEED_FATAL(hipEventRecord(pevents[1], ctx->stream)); + } + } + return FUTHARK_SUCCESS; +} + +static int memcpy_gpu2host(struct futhark_context* ctx, bool sync, + unsigned char* dst, int64_t dst_offset, + gpu_mem src, int64_t src_offset, + int64_t nbytes) { + if (nbytes > 0) { + hipEvent_t* pevents = NULL; + if (ctx->profiling && !ctx->profiling_paused) { + pevents = hip_get_events(ctx, "copy_dev_to_host"); + HIP_SUCCEED_FATAL(hipEventRecord(pevents[0], ctx->stream)); + } + if (sync) { + HIP_SUCCEED_OR_RETURN + (hipMemcpyDtoH(dst + dst_offset, + (unsigned char*)src + src_offset, + nbytes)); + } else { + HIP_SUCCEED_OR_RETURN + (hipMemcpyDtoHAsync(dst + dst_offset, + (unsigned char*)src + src_offset, + nbytes, ctx->stream)); + } + if (sync && + ctx->failure_is_an_option && + futhark_context_sync(ctx) != 0) { + return 1; + } + } + return FUTHARK_SUCCESS; +} + +static int gpu_launch_kernel(struct futhark_context* ctx, + gpu_kernel kernel, const char *name, + const int32_t grid[3], + const int32_t block[3], + unsigned int local_mem_bytes, + int num_args, + void* args[num_args], + size_t args_sizes[num_args]) { + (void) args_sizes; + int64_t time_start = 0, time_end = 0; + if (ctx->logging) { + fprintf(ctx->log, + "Launching kernel %s with\n" + " grid=(%d,%d,%d)\n" + " block=(%d,%d,%d)\n" + " local memory=%d\n", + name, + grid[0], grid[1], grid[2], + block[0], block[1], block[2], + local_mem_bytes); + time_start = get_wall_time(); + } + + hipEvent_t *pevents = NULL; + if (ctx->profiling && !ctx->profiling_paused) { + pevents = hip_get_events(ctx, name); + HIP_SUCCEED_FATAL(hipEventRecord(pevents[0], ctx->stream)); + } + + HIP_SUCCEED_OR_RETURN + (hipModuleLaunchKernel(kernel, + grid[0], grid[1], grid[2], + block[0], block[1], block[2], + local_mem_bytes, ctx->stream, + args, NULL)); + + if (pevents != NULL) { + HIP_SUCCEED_FATAL(hipEventRecord(pevents[1], ctx->stream)); + } + + if (ctx->debugging) { + HIP_SUCCEED_FATAL(hipStreamSynchronize(ctx->stream)); + time_end = get_wall_time(); + long int time_diff = time_end - time_start; + fprintf(ctx->log, " runtime: %ldus\n\n", time_diff); + } + + return FUTHARK_SUCCESS; +} + +static int gpu_alloc_actual(struct futhark_context *ctx, size_t size, gpu_mem *mem_out) { + hipError_t res = hipMalloc(mem_out, size); + if (res == hipErrorOutOfMemory) { + return FUTHARK_OUT_OF_MEMORY; + } + HIP_SUCCEED_OR_RETURN(res); + return FUTHARK_SUCCESS; +} + +static int gpu_free_actual(struct futhark_context *ctx, gpu_mem mem) { + (void)ctx; + HIP_SUCCEED_OR_RETURN(hipFree(mem)); + return FUTHARK_SUCCESS; +} + +// End of backends/hip.h. 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 @@ -1,5 +1,18 @@ // Start of backends/opencl.h +// Note [32-bit transpositions] +// +// Transposition kernels are much slower when they have to use 64-bit +// arithmetic. I observed about 0.67x slowdown on an A100 GPU when +// transposing four-byte elements (much less when transposing 8-byte +// elements). Unfortunately, 64-bit arithmetic is a requirement for +// large arrays (see #1953 for what happens otherwise). We generate +// both 32- and 64-bit index arithmetic versions of transpositions, +// and dynamically pick between them at runtime. This is an +// unfortunate code bloat, and it would be preferable if we could +// simply optimise the 64-bit version to make this distinction +// unnecessary. Fortunately these kernels are quite small. + // Forward declarations. struct opencl_device_option; // Invoked by setup_opencl() after the platform and device has been @@ -117,13 +130,12 @@ const char** tuning_param_classes; // Uniform fields above. + char* program; int preferred_device_num; const char *preferred_platform; const char *preferred_device; int ignore_blacklist; - const char* dump_program_to; - const char* load_program_from; const char* dump_binary_to; const char* load_binary_from; @@ -150,10 +162,9 @@ cfg->preferred_platform = ""; cfg->preferred_device = ""; cfg->ignore_blacklist = 0; - cfg->dump_program_to = NULL; - cfg->load_program_from = NULL; cfg->dump_binary_to = NULL; cfg->load_binary_from = NULL; + cfg->program = strconcat(gpu_program); // The following are dummy sizes that mean the concrete defaults // will be set during initialisation via hardware-inspection-based @@ -172,6 +183,7 @@ static void backend_context_config_teardown(struct futhark_context_config* cfg) { free(cfg->build_opts); + free(cfg->program); } void futhark_context_config_add_build_option(struct futhark_context_config* cfg, const char *opt) { @@ -392,12 +404,12 @@ free(devices); } -void futhark_context_config_dump_program_to(struct futhark_context_config *cfg, const char *path) { - cfg->dump_program_to = path; +const char* futhark_context_config_get_program(struct futhark_context_config *cfg) { + return cfg->program; } -void futhark_context_config_load_program_from(struct futhark_context_config *cfg, const char *path) { - cfg->load_program_from = path; +void futhark_context_config_set_program(struct futhark_context_config *cfg, const char *s) { + cfg->program = strdup(s); } void futhark_context_config_dump_binary_to(struct futhark_context_config *cfg, const char *path) { @@ -465,8 +477,7 @@ // A record of something that happened. struct profiling_record { cl_event *event; - int *runs; - int64_t *runtime; + const char* name; }; struct futhark_context { @@ -503,7 +514,7 @@ cl_command_queue queue; cl_program clprogram; - struct free_list cl_free_list; + struct free_list gpu_free_list; size_t max_group_size; size_t max_num_groups; @@ -517,9 +528,10 @@ int profiling_records_capacity; int profiling_records_used; + struct builtin_kernels* kernels; }; -static cl_build_status build_opencl_program(cl_program program, cl_device_id device, const char* options) { +static cl_build_status build_gpu_program(cl_program program, cl_device_id device, const char* options) { cl_int clBuildProgram_error = clBuildProgram(program, 1, &device, options, NULL, NULL); // Avoid termination due to CL_BUILD_PROGRAM_FAILURE @@ -591,6 +603,10 @@ "%s ", extra_build_opts[i]); } + w += snprintf(compile_opts+w, compile_opts_size-w, + "-DTR_BLOCK_DIM=%d -DTR_TILE_DIM=%d -DTR_ELEMS_PER_THREAD=%d ", + TR_BLOCK_DIM, TR_TILE_DIM, TR_ELEMS_PER_THREAD); + // Oclgrind claims to support cl_khr_fp16, but this is not actually // the case. if (strcmp(device_option.platform_name, "Oclgrind") == 0) { @@ -600,49 +616,49 @@ return compile_opts; } + // Count up the runtime all the profiling_records that occured during execution. // Also clears the buffer of profiling_records. -static cl_int opencl_tally_profiling_records(struct futhark_context *ctx) { +static void tally_profiling_records(struct futhark_context *ctx, + struct cost_centres* ccs) { cl_int err; for (int i = 0; i < ctx->profiling_records_used; i++) { struct profiling_record record = ctx->profiling_records[i]; cl_ulong start_t, end_t; - if ((err = clGetEventProfilingInfo(*record.event, - CL_PROFILING_COMMAND_START, - sizeof(start_t), - &start_t, - NULL)) != CL_SUCCESS) { - return err; - } - - if ((err = clGetEventProfilingInfo(*record.event, - CL_PROFILING_COMMAND_END, - sizeof(end_t), - &end_t, - NULL)) != CL_SUCCESS) { - return err; - } + OPENCL_SUCCEED_FATAL(clGetEventProfilingInfo(*record.event, + CL_PROFILING_COMMAND_START, + sizeof(start_t), + &start_t, + NULL)); - // OpenCL provides nanosecond resolution, but we want - // microseconds. - *record.runs += 1; - *record.runtime += (end_t - start_t)/1000; + OPENCL_SUCCEED_FATAL(clGetEventProfilingInfo(*record.event, + CL_PROFILING_COMMAND_END, + sizeof(end_t), + &end_t, + NULL)); - if ((err = clReleaseEvent(*record.event)) != CL_SUCCESS) { - return err; + if (ccs) { + // Note that OpenCL provides nanosecond resolution, but we want + // microseconds. + struct cost_centre c = { + .name = record.name, + .runs = 1, + .runtime = (end_t - start_t)/1000 + }; + cost_centres_add(ccs, c); } + + OPENCL_SUCCEED_FATAL(clReleaseEvent(*record.event)); free(record.event); } ctx->profiling_records_used = 0; - - return CL_SUCCESS; } // If profiling, produce an event associated with a profiling record. -static cl_event* opencl_get_event(struct futhark_context *ctx, int *runs, int64_t *runtime) { +static cl_event* opencl_get_event(struct futhark_context *ctx, const char *name) { if (ctx->profiling_records_used == ctx->profiling_records_capacity) { ctx->profiling_records_capacity *= 2; ctx->profiling_records = @@ -652,130 +668,11 @@ } cl_event *event = malloc(sizeof(cl_event)); ctx->profiling_records[ctx->profiling_records_used].event = event; - ctx->profiling_records[ctx->profiling_records_used].runs = runs; - ctx->profiling_records[ctx->profiling_records_used].runtime = runtime; + ctx->profiling_records[ctx->profiling_records_used].name = name; ctx->profiling_records_used++; return event; } -// Allocate memory from driver. The problem is that OpenCL may perform -// lazy allocation, so we cannot know whether an allocation succeeded -// until the first time we try to use it. Hence we immediately -// perform a write to see if the allocation succeeded. This is slow, -// but the assumption is that this operation will be rare (most things -// will go through the free list). -static int opencl_alloc_actual(struct futhark_context *ctx, size_t size, cl_mem *mem_out) { - int error; - *mem_out = clCreateBuffer(ctx->ctx, CL_MEM_READ_WRITE, size, NULL, &error); - - if (error != CL_SUCCESS) { - return error; - } - - int x = 2; - error = clEnqueueWriteBuffer(ctx->queue, *mem_out, - CL_TRUE, - 0, sizeof(x), &x, - 0, NULL, NULL); - - // No need to wait for completion here. clWaitForEvents() cannot - // return mem object allocation failures. This implies that the - // buffer is faulted onto the device on enqueue. (Observation by - // Andreas Kloeckner.) - - return error; -} - -static int opencl_alloc(struct futhark_context *ctx, FILE *log, - size_t min_size, const char *tag, - cl_mem *mem_out, size_t *size_out) { - (void)tag; - if (min_size < sizeof(int)) { - min_size = sizeof(int); - } - - cl_mem* memptr; - if (free_list_find(&ctx->cl_free_list, min_size, tag, size_out, (fl_mem*)&memptr) == 0) { - // Successfully found a free block. Is it big enough? - if (*size_out >= min_size) { - if (ctx->cfg->debugging) { - fprintf(log, "No need to allocate: Found a block in the free list.\n"); - } - *mem_out = *memptr; - free(memptr); - return CL_SUCCESS; - } else { - if (ctx->cfg->debugging) { - fprintf(log, "Found a free block, but it was too small.\n"); - } - int error = clReleaseMemObject(*memptr); - free(*memptr); - if (error != CL_SUCCESS) { - return error; - } - } - } - - *size_out = min_size; - - // We have to allocate a new block from the driver. If the - // allocation does not succeed, then we might be in an out-of-memory - // situation. We now start freeing things from the free list until - // we think we have freed enough that the allocation will succeed. - // Since we don't know how far the allocation is from fitting, we - // have to check after every deallocation. This might be pretty - // expensive. Let's hope that this case is hit rarely. - - if (ctx->cfg->debugging) { - fprintf(log, "Actually allocating the desired block.\n"); - } - - int error = opencl_alloc_actual(ctx, min_size, mem_out); - - while (error == CL_MEM_OBJECT_ALLOCATION_FAILURE) { - if (ctx->cfg->debugging) { - fprintf(log, "Out of OpenCL memory: releasing entry from the free list...\n"); - } - cl_mem* memptr; - if (free_list_first(&ctx->cl_free_list, (fl_mem*)&memptr) == 0) { - cl_mem mem = *memptr; - free(memptr); - error = clReleaseMemObject(mem); - if (error != CL_SUCCESS) { - return error; - } - } else { - break; - } - error = opencl_alloc_actual(ctx, min_size, mem_out); - } - - return error; -} - -static int opencl_free(struct futhark_context *ctx, - cl_mem mem, size_t size, const char *tag) { - cl_mem* memptr = malloc(sizeof(cl_mem)); - *memptr = mem; - free_list_insert(&ctx->cl_free_list, size, (fl_mem)memptr, tag); - return CL_SUCCESS; -} - -static int opencl_free_all(struct futhark_context *ctx) { - free_list_pack(&ctx->cl_free_list); - cl_mem* memptr; - while (free_list_first(&ctx->cl_free_list, (fl_mem*)&memptr) == 0) { - cl_mem mem = *memptr; - free(memptr); - int error = clReleaseMemObject(mem); - if (error != CL_SUCCESS) { - return error; - } - } - - return CL_SUCCESS; -} - int futhark_context_sync(struct futhark_context* ctx) { // Check for any delayed error. cl_int failure_idx = -1; @@ -822,12 +719,11 @@ // array must be NULL-terminated. static void setup_opencl_with_command_queue(struct futhark_context *ctx, cl_command_queue queue, - const char *srcs[], const char *extra_build_opts[], const char* cache_fname) { int error; - free_list_init(&ctx->cl_free_list); + free_list_init(&ctx->gpu_free_list); ctx->queue = queue; OPENCL_SUCCEED_FATAL(clGetCommandQueueInfo(ctx->queue, CL_QUEUE_CONTEXT, sizeof(cl_context), &ctx->ctx, NULL)); @@ -971,7 +867,7 @@ fprintf(stderr, "OpenCL compiler options: %s\n", compile_opts); } - char *fut_opencl_src = NULL; + const char* opencl_src = ctx->cfg->program; cl_program prog; error = CL_SUCCESS; @@ -981,40 +877,12 @@ if (ctx->cfg->load_binary_from == NULL) { size_t src_size = 0; - // Maybe we have to read OpenCL source from somewhere else (used for debugging). - if (ctx->cfg->load_program_from != NULL) { - fut_opencl_src = slurp_file(ctx->cfg->load_program_from, NULL); - assert(fut_opencl_src != NULL); - } else { - // Construct the OpenCL source concatenating all the fragments. - for (const char **src = srcs; src && *src; src++) { - src_size += strlen(*src); - } - - fut_opencl_src = (char*) malloc(src_size + 1); - - size_t n, i; - for (i = 0, n = 0; srcs && srcs[i]; i++) { - strncpy(fut_opencl_src+n, srcs[i], src_size-n); - n += strlen(srcs[i]); - } - fut_opencl_src[src_size] = 0; - } - - if (ctx->cfg->dump_program_to != NULL) { - if (ctx->cfg->logging) { - fprintf(stderr, "Dumping OpenCL source to %s...\n", ctx->cfg->dump_program_to); - } - - dump_file(ctx->cfg->dump_program_to, fut_opencl_src, strlen(fut_opencl_src)); - } - if (cache_fname != NULL) { if (ctx->cfg->logging) { fprintf(stderr, "Restoring cache from from %s...\n", cache_fname); } cache_hash_init(&h); - cache_hash(&h, fut_opencl_src, strlen(fut_opencl_src)); + cache_hash(&h, opencl_src, strlen(opencl_src)); cache_hash(&h, compile_opts, strlen(compile_opts)); unsigned char *buf; @@ -1051,7 +919,7 @@ fprintf(stderr, "Creating OpenCL program...\n"); } - const char* src_ptr[] = {fut_opencl_src}; + const char* src_ptr[] = {opencl_src}; prog = clCreateProgramWithSource(ctx->ctx, 1, src_ptr, &src_size, &error); OPENCL_SUCCEED_FATAL(error); } @@ -1077,10 +945,9 @@ if (ctx->cfg->logging) { fprintf(stderr, "Building OpenCL program...\n"); } - OPENCL_SUCCEED_FATAL(build_opencl_program(prog, device_option.device, compile_opts)); + OPENCL_SUCCEED_FATAL(build_gpu_program(prog, device_option.device, compile_opts)); free(compile_opts); - free(fut_opencl_src); size_t binary_size = 0; unsigned char *binary = NULL; @@ -1144,7 +1011,6 @@ } static void setup_opencl(struct futhark_context *ctx, - const char *srcs[], const char *extra_build_opts[], const char* cache_fname) { struct opencl_device_option device_option = get_preferred_device(ctx->cfg); @@ -1173,9 +1039,12 @@ &clCreateCommandQueue_error); OPENCL_SUCCEED_FATAL(clCreateCommandQueue_error); - setup_opencl_with_command_queue(ctx, queue, srcs, extra_build_opts, cache_fname); + setup_opencl_with_command_queue(ctx, queue, extra_build_opts, cache_fname); } +struct builtin_kernels* init_builtin_kernels(struct futhark_context* ctx); +void free_builtin_kernels(struct futhark_context* ctx, struct builtin_kernels* kernels); + int backend_context_setup(struct futhark_context* ctx) { ctx->lockstep_width = 0; // Real value set later. ctx->profiling_records_capacity = 200; @@ -1190,9 +1059,9 @@ ctx->cur_mem_usage_device = 0; if (ctx->cfg->queue_set) { - setup_opencl_with_command_queue(ctx, ctx->cfg->queue, opencl_program, ctx->cfg->build_opts, ctx->cfg->cache_fname); + setup_opencl_with_command_queue(ctx, ctx->cfg->queue, ctx->cfg->build_opts, ctx->cfg->cache_fname); } else { - setup_opencl(ctx, opencl_program, ctx->cfg->build_opts, ctx->cfg->cache_fname); + setup_opencl(ctx, ctx->cfg->build_opts, ctx->cfg->cache_fname); } cl_int error; @@ -1209,15 +1078,23 @@ CL_MEM_READ_WRITE, sizeof(int64_t)*(max_failure_args+1), NULL, &error); OPENCL_SUCCEED_OR_RETURN(error); - return 0; + + if ((ctx->kernels = init_builtin_kernels(ctx)) == NULL) { + return 1; + } + + return FUTHARK_SUCCESS; } +static int gpu_free_all(struct futhark_context *ctx); + void backend_context_teardown(struct futhark_context* ctx) { + free_builtin_kernels(ctx, ctx->kernels); OPENCL_SUCCEED_FATAL(clReleaseMemObject(ctx->global_failure)); OPENCL_SUCCEED_FATAL(clReleaseMemObject(ctx->global_failure_args)); - (void)opencl_tally_profiling_records(ctx); + (void)tally_profiling_records(ctx, NULL); free(ctx->profiling_records); - (void)opencl_free_all(ctx); + (void)gpu_free_all(ctx); (void)clReleaseProgram(ctx->clprogram); (void)clReleaseCommandQueue(ctx->queue); (void)clReleaseContext(ctx->ctx); @@ -1225,6 +1102,231 @@ cl_command_queue futhark_context_get_command_queue(struct futhark_context* ctx) { return ctx->queue; +} + +// GPU ABSTRACTION LAYER + +// Types. + +typedef cl_kernel gpu_kernel; +typedef cl_mem gpu_mem; + +static void gpu_create_kernel(struct futhark_context *ctx, + gpu_kernel* kernel, + const char* name) { + if (ctx->debugging) { + fprintf(ctx->log, "Creating kernel %s.\n", name); + } + cl_int error; + *kernel = clCreateKernel(ctx->clprogram, name, &error); + OPENCL_SUCCEED_FATAL(error); +} + +static void gpu_free_kernel(struct futhark_context *ctx, + gpu_kernel kernel) { + (void)ctx; + clReleaseKernel(kernel); +} + +static int gpu_scalar_to_device(struct futhark_context* ctx, + gpu_mem dst, size_t offset, size_t size, + void *src) { + cl_event* event = NULL; + if (ctx->profiling && !ctx->profiling_paused) { + event = opencl_get_event(ctx, "copy_scalar_to_dev"); + } + OPENCL_SUCCEED_OR_RETURN + (clEnqueueWriteBuffer + (ctx->queue, dst, CL_TRUE, + offset, size, src, 0, NULL, event)); + return 0; +} + +static int gpu_scalar_from_device(struct futhark_context* ctx, + void *dst, + gpu_mem src, size_t offset, size_t size) { + cl_event* event = NULL; + if (ctx->profiling && !ctx->profiling_paused) { + event = opencl_get_event(ctx, "copy_scalar_from_dev"); + } + OPENCL_SUCCEED_OR_RETURN + (clEnqueueReadBuffer + (ctx->queue, src, ctx->failure_is_an_option ? CL_FALSE : CL_TRUE, + offset, size, dst, 0, NULL, event)); + return 0; +} + +static int gpu_memcpy(struct futhark_context* ctx, + gpu_mem dst, int64_t dst_offset, + gpu_mem src, int64_t src_offset, + int64_t nbytes) { + if (nbytes > 0) { + cl_event* event = NULL; + if (ctx->profiling && !ctx->profiling_paused) { + event = opencl_get_event(ctx, "copy_dev_to_dev"); + } + // OpenCL swaps the usual order of operands for memcpy()-like + // functions. The order below is not a typo. + OPENCL_SUCCEED_OR_RETURN + (clEnqueueCopyBuffer + (ctx->queue, src, dst, src_offset, dst_offset, nbytes, + 0, NULL, event)); + if (ctx->debugging) { + OPENCL_SUCCEED_FATAL(clFinish(ctx->queue)); + } + } + return FUTHARK_SUCCESS; +} + +static int memcpy_host2gpu(struct futhark_context* ctx, bool sync, + gpu_mem dst, int64_t dst_offset, + const unsigned char* src, int64_t src_offset, + int64_t nbytes) { + if (nbytes > 0) { + cl_event* event = NULL; + if (ctx->profiling && !ctx->profiling_paused) { + event = opencl_get_event(ctx, "copy_host_to_dev"); + } + OPENCL_SUCCEED_OR_RETURN + (clEnqueueWriteBuffer(ctx->queue, + dst, + sync ? CL_TRUE : CL_FALSE, + (size_t)dst_offset, (size_t)nbytes, + src + src_offset, + 0, NULL, event)); + if (ctx->debugging) { + OPENCL_SUCCEED_FATAL(clFinish(ctx->queue)); + } + } + return FUTHARK_SUCCESS; +} + +static int memcpy_gpu2host(struct futhark_context* ctx, bool sync, + unsigned char* dst, int64_t dst_offset, + gpu_mem src, int64_t src_offset, + int64_t nbytes) { + if (nbytes > 0) { + cl_event* event = NULL; + if (ctx->profiling && !ctx->profiling_paused) { + event = opencl_get_event(ctx, "copy_dev_to_host"); + } + OPENCL_SUCCEED_OR_RETURN + (clEnqueueReadBuffer(ctx->queue, src, + ctx->failure_is_an_option ? CL_FALSE + : sync ? CL_TRUE : CL_FALSE, + src_offset, nbytes, + dst + dst_offset, + 0, NULL, event)); + if (sync && + ctx->failure_is_an_option && + futhark_context_sync(ctx) != 0) { + return 1; + } + } + return FUTHARK_SUCCESS; +} + +static int gpu_launch_kernel(struct futhark_context* ctx, + gpu_kernel kernel, const char *name, + const int32_t grid[3], + const int32_t block[3], + unsigned int local_mem_bytes, + int num_args, + void* args[num_args], + size_t args_sizes[num_args]) { + int64_t time_start = 0, time_end = 0; + if (ctx->logging) { + fprintf(ctx->log, + "Launching kernel %s with\n" + " grid=(%d,%d,%d)\n" + " block=(%d,%d,%d)\n" + " local memory=%d\n", + name, + grid[0], grid[1], grid[2], + block[0], block[1], block[2], + local_mem_bytes); + time_start = get_wall_time(); + } + + // Some implementations do not work with 0-byte local memory. + if (local_mem_bytes == 0) { + local_mem_bytes = 4; + } + + OPENCL_SUCCEED_OR_RETURN + (clSetKernelArg(kernel, 0, local_mem_bytes, NULL)); + for (int i = 0; i < num_args; i++) { + OPENCL_SUCCEED_OR_RETURN + (clSetKernelArg(kernel, i+1, args_sizes[i], args[i])); + } + + const size_t global_work_size[3] = + {(size_t)grid[0]*block[0], + (size_t)grid[1]*block[1], + (size_t)grid[2]*block[2]}; + const size_t local_work_size[3] = + {block[0], + block[1], + block[2]}; + + cl_event* event = NULL; + if (ctx->profiling && !ctx->profiling_paused) { + event = opencl_get_event(ctx, name); + } + + OPENCL_SUCCEED_OR_RETURN + (clEnqueueNDRangeKernel(ctx->queue, + kernel, + 3, NULL, global_work_size, local_work_size, + 0, NULL, event)); + + if (ctx->debugging) { + OPENCL_SUCCEED_FATAL(clFinish(ctx->queue)); + time_end = get_wall_time(); + long int time_diff = time_end - time_start; + fprintf(ctx->log, " runtime: %ldus\n", time_diff); + } + if (ctx->logging) { + printf("\n"); + } + + return FUTHARK_SUCCESS; +} + +// Allocate memory from driver. The problem is that OpenCL may perform +// lazy allocation, so we cannot know whether an allocation succeeded +// until the first time we try to use it. Hence we immediately +// perform a write to see if the allocation succeeded. This is slow, +// but the assumption is that this operation will be rare (most things +// will go through the free list). +static int gpu_alloc_actual(struct futhark_context *ctx, size_t size, gpu_mem *mem_out) { + int error; + *mem_out = clCreateBuffer(ctx->ctx, CL_MEM_READ_WRITE, size, NULL, &error); + + OPENCL_SUCCEED_OR_RETURN(error); + + int x = 2; + error = clEnqueueWriteBuffer(ctx->queue, *mem_out, + CL_TRUE, + 0, sizeof(x), &x, + 0, NULL, NULL); + + // No need to wait for completion here. clWaitForEvents() cannot + // return mem object allocation failures. This implies that the + // buffer is faulted onto the device on enqueue. (Observation by + // Andreas Kloeckner.) + + if (error == CL_MEM_OBJECT_ALLOCATION_FAILURE) { + return FUTHARK_OUT_OF_MEMORY; + } + OPENCL_SUCCEED_OR_RETURN(error); + return FUTHARK_SUCCESS; +} + +static int gpu_free_actual(struct futhark_context *ctx, gpu_mem mem) { + (void)ctx; + OPENCL_SUCCEED_OR_RETURN(clReleaseMemObject(mem)); + return FUTHARK_SUCCESS; } // End of backends/opencl.h 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,6 +20,27 @@ // 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. +static void log_copy(struct futhark_context* ctx, + const char *kind, int r, + int64_t dst_offset, int64_t dst_strides[r], + int64_t src_offset, int64_t src_strides[r], + int64_t shape[r]); + +static void log_transpose(struct futhark_context* ctx, + int64_t k, int64_t m, int64_t n); + +static bool lmad_map_tr(int64_t *num_arrays_out, int64_t *n_out, int64_t *m_out, + int r, + const int64_t dst_strides[r], + const int64_t src_strides[r], + const int64_t shape[r]); + +static bool lmad_contiguous(int r, int64_t strides[r], int64_t shape[r]); + +static bool lmad_memcpyable(int r, + int64_t dst_strides[r], int64_t src_strides[r], int64_t shape[r]); + // Functions that must be defined by the backend. static void backend_context_config_setup(struct futhark_context_config* cfg); static void backend_context_config_teardown(struct futhark_context_config* cfg); diff --git a/rts/c/copy.h b/rts/c/copy.h new file mode 100644 --- /dev/null +++ b/rts/c/copy.h @@ -0,0 +1,262 @@ +// Start of copy.h + +// Cache-oblivious map-transpose function. +#define GEN_MAP_TRANSPOSE(NAME, ELEM_TYPE) \ + static void map_transpose_##NAME \ + (ELEM_TYPE* dst, ELEM_TYPE* src, \ + int64_t k, int64_t m, int64_t n, \ + int64_t cb, int64_t ce, int64_t rb, int64_t re) \ + { \ + int32_t r = re - rb; \ + int32_t c = ce - cb; \ + if (k == 1) { \ + if (r <= 64 && c <= 64) { \ + for (int64_t j = 0; j < c; j++) { \ + for (int64_t i = 0; i < r; i++) { \ + dst[(j + cb) * n + (i + rb)] = src[(i + rb) * m + (j + cb)]; \ + } \ + } \ + } else if (c <= r) { \ + map_transpose_##NAME(dst, src, k, m, n, cb, ce, rb, rb + r/2); \ + map_transpose_##NAME(dst, src, k, m, n, cb, ce, rb + r/2, re); \ + } else { \ + map_transpose_##NAME(dst, src, k, m, n, cb, cb + c/2, rb, re); \ + map_transpose_##NAME(dst, src, k, m, n, cb + c/2, ce, rb, re); \ + } \ + } else { \ + for (int64_t i = 0; i < k; i++) { \ + map_transpose_##NAME(dst + i * m * n, src + i * m * n, 1, m, n, cb, ce, rb, re); \ + }\ +} \ +} + +// Straightforward LMAD copy function. +#define GEN_LMAD_COPY_ELEMENTS(NAME, ELEM_TYPE) \ + static void lmad_copy_elements_##NAME(int r, \ + ELEM_TYPE* dst, int64_t dst_strides[r], \ + ELEM_TYPE *src, int64_t src_strides[r], \ + int64_t shape[r]) { \ + if (r == 1) { \ + for (int i = 0; i < shape[0]; i++) { \ + dst[i*dst_strides[0]] = src[i*src_strides[0]]; \ + } \ + } else if (r > 1) { \ + for (int i = 0; i < shape[0]; i++) { \ + lmad_copy_elements_##NAME(r-1, \ + dst+i*dst_strides[0], dst_strides+1, \ + src+i*src_strides[0], src_strides+1, \ + shape+1); \ + } \ + } \ + } \ + +// Check whether this LMAD can be seen as a transposed 2D array. This +// is done by checking every possible splitting point. +static bool lmad_is_tr(int64_t *n_out, int64_t *m_out, + int r, + const int64_t strides[r], + const int64_t shape[r]) { + for (int i = 1; i < r; i++) { + int n = 1, m = 1; + bool ok = true; + int64_t expected = 1; + // Check strides before 'i'. + for (int j = i-1; j >= 0; j--) { + ok = ok && strides[j] == expected; + expected *= shape[j]; + n *= shape[j]; + } + // Check strides after 'i'. + for (int j = r-1; j >= i; j--) { + ok = ok && strides[j] == expected; + expected *= shape[j]; + m *= shape[j]; + } + if (ok) { + *n_out = n; + *m_out = m; + return true; + } + } + return false; +} + +// This function determines whether the a 'dst' LMAD is row-major and +// 'src' LMAD is column-major. Both LMADs are for arrays of the same +// shape. Both LMADs are allowed to have additional dimensions "on +// top". Essentially, this function determines whether a copy from +// 'src' to 'dst' is a "map(transpose)" that we know how to implement +// efficiently. The LMADs can have arbitrary rank, and the main +// challenge here is checking whether the src LMAD actually +// corresponds to a 2D column-major layout by morally collapsing +// dimensions. There is a lot of looping here, but the actual trip +// count is going to be very low in practice. +// +// Returns true if this is indeed a map(transpose), and writes the +// number of arrays, and moral array size to appropriate output +// parameters. +static bool lmad_map_tr(int64_t *num_arrays_out, int64_t *n_out, int64_t *m_out, + int r, + const int64_t dst_strides[r], + const int64_t src_strides[r], + const int64_t shape[r]) { + int64_t rowmajor_strides[r]; + rowmajor_strides[r-1] = 1; + + for (int i = r-2; i >= 0; i--) { + rowmajor_strides[i] = rowmajor_strides[i+1] * shape[i+1]; + } + + // map_r will be the number of mapped dimensions on top. + int map_r = 0; + int64_t num_arrays = 1; + for (int i = 0; i < r; i++) { + if (dst_strides[i] != rowmajor_strides[i] || + src_strides[i] != rowmajor_strides[i]) { + break; + } else { + num_arrays *= shape[i]; + map_r++; + } + } + + *num_arrays_out = num_arrays; + + if (memcmp(&rowmajor_strides[map_r], + &dst_strides[map_r], + sizeof(int64_t)*(r-map_r)) == 0) { + return lmad_is_tr(n_out, m_out, r-map_r, src_strides+map_r, shape+map_r); + } else if (memcmp(&rowmajor_strides[map_r], + &src_strides[map_r], + sizeof(int64_t)*(r-map_r)) == 0) { + return lmad_is_tr(m_out, n_out, r-map_r, dst_strides+map_r, shape+map_r); + } + return false; +} + +// Check if the strides correspond to row-major strides of *any* +// permutation of the shape. This is done by recursive search with +// backtracking. This is worst-case exponential, but hopefully the +// arrays we encounter do not have that many dimensions. +static bool lmad_contiguous_search(int checked, int64_t expected, + int r, + int64_t strides[r], int64_t shape[r], bool used[r]) { + for (int i = 0; i < r; i++) { + for (int j = 0; j < r; j++) { + if (!used[j] && strides[j] == expected && strides[j] >= 0) { + used[j] = true; + if (checked+1 == r || + lmad_contiguous_search(checked+1, expected * shape[j], r, strides, shape, used)) { + return true; + } + used[j] = false; + } + } + } + return false; +} + +// Does this LMAD correspond to an array with positive strides and no +// holes? +static bool lmad_contiguous(int r, int64_t strides[r], int64_t shape[r]) { + bool used[r]; + for (int i = 0; i < r; i++) { + used[i] = false; + } + return lmad_contiguous_search(0, 1, r, strides, shape, used); +} + +// Does this copy correspond to something that could be done with a +// memcpy()-like operation? I.e. do the LMADs actually represent the +// same in-memory layout and are they contiguous? +static bool lmad_memcpyable(int r, + int64_t dst_strides[r], int64_t src_strides[r], int64_t shape[r]) { + if (!lmad_contiguous(r, dst_strides, shape)) { + return false; + } + for (int i = 0; i < r; i++) { + if (dst_strides[i] != src_strides[i] && shape[i] != 1) { + return false; + } + } + return true; +} + + +static void log_copy(struct futhark_context* ctx, + const char *kind, 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); + fprintf(ctx->log, "Shape: "); + for (int i = 0; i < r; i++) { fprintf(ctx->log, "[%ld]", (long int)shape[i]); } + fprintf(ctx->log, "\n"); + fprintf(ctx->log, "Dst offset: %ld\n", dst_offset); + fprintf(ctx->log, "Dst strides:"); + for (int i = 0; i < r; i++) { fprintf(ctx->log, " %ld", (long int)dst_strides[i]); } + fprintf(ctx->log, "\n"); + fprintf(ctx->log, "Src offset: %ld\n", src_offset); + fprintf(ctx->log, "Src strides:"); + for (int i = 0; i < r; i++) { fprintf(ctx->log, " %ld", (long int)src_strides[i]); } + fprintf(ctx->log, "\n"); + } +} + +static void log_transpose(struct futhark_context* ctx, + int64_t k, int64_t n, int64_t m) { + if (ctx->logging) { + fprintf(ctx->log, "## Transpose\n"); + fprintf(ctx->log, "Arrays : %ld\n", (long int)k); + fprintf(ctx->log, "X elements : %ld\n", (long int)m); + fprintf(ctx->log, "Y elements : %ld\n", (long int)n); + fprintf(ctx->log, "\n"); + } +} + +#define GEN_LMAD_COPY(NAME, ELEM_TYPE) \ + static void lmad_copy_##NAME \ + (struct futhark_context *ctx, int r, \ + 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, \ + src_offset, src_strides, shape); \ + int64_t size = 1; \ + for (int i = 0; i < r; i++) { size *= shape[i]; } \ + if (size == 0) { return; } \ + int64_t k, n, m; \ + if (lmad_map_tr(&k, &n, &m, \ + r, dst_strides, src_strides, shape)) { \ + log_transpose(ctx, k, n, m); \ + map_transpose_##NAME \ + (dst+dst_offset, src+src_offset, k, n, m, 0, n, 0, m); \ + } else if (lmad_memcpyable(r, dst_strides, src_strides, shape)) { \ + if (ctx->logging) {fprintf(ctx->log, "## Flat copy\n\n");} \ + memcpy(dst+dst_offset, src+src_offset, size*sizeof(*dst)); \ + } else { \ + if (ctx->logging) {fprintf(ctx->log, "## General copy\n\n");} \ + lmad_copy_elements_##NAME \ + (r, \ + dst+dst_offset, dst_strides, \ + src+src_offset, src_strides, shape); \ + } \ + } + +GEN_MAP_TRANSPOSE(1b, uint8_t) +GEN_MAP_TRANSPOSE(2b, uint16_t) +GEN_MAP_TRANSPOSE(4b, uint32_t) +GEN_MAP_TRANSPOSE(8b, uint64_t) + +GEN_LMAD_COPY_ELEMENTS(1b, uint8_t) +GEN_LMAD_COPY_ELEMENTS(2b, uint16_t) +GEN_LMAD_COPY_ELEMENTS(4b, uint32_t) +GEN_LMAD_COPY_ELEMENTS(8b, uint64_t) + +GEN_LMAD_COPY(1b, uint8_t) +GEN_LMAD_COPY(2b, uint16_t) +GEN_LMAD_COPY(4b, uint32_t) +GEN_LMAD_COPY(8b, uint64_t) + +// End of copy.h diff --git a/rts/c/gpu.h b/rts/c/gpu.h new file mode 100644 --- /dev/null +++ b/rts/c/gpu.h @@ -0,0 +1,591 @@ +// Start of gpu.h + +// Generic functions that use our tiny GPU abstraction layer. The +// entire context must be defined before this header is included. In +// particular we expect the following functions to be available: + +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, + const int32_t grid[3], + const int32_t block[3], + unsigned int local_mem_bytes, + int num_args, + void* args[num_args], + size_t args_sizes[num_args]); +int gpu_memcpy(struct futhark_context* ctx, + 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, + void *dst, + gpu_mem src, size_t offset, size_t size); +int gpu_scalar_to_device(struct futhark_context* ctx, + gpu_mem dst, size_t offset, size_t size, + void *src); +void gpu_create_kernel(struct futhark_context *ctx, + gpu_kernel* kernel, + const char* name); + +// Max number of groups we allow along the second or third dimension +// for transpositions. +#define MAX_TR_GROUPS 65535 + +struct builtin_kernels { + // We have a lot of ways to transpose arrays. + gpu_kernel map_transpose_1b; + gpu_kernel map_transpose_1b_low_height; + gpu_kernel map_transpose_1b_low_width; + gpu_kernel map_transpose_1b_small; + gpu_kernel map_transpose_1b_large; + gpu_kernel map_transpose_2b; + gpu_kernel map_transpose_2b_low_height; + gpu_kernel map_transpose_2b_low_width; + gpu_kernel map_transpose_2b_small; + gpu_kernel map_transpose_2b_large; + gpu_kernel map_transpose_4b; + gpu_kernel map_transpose_4b_low_height; + gpu_kernel map_transpose_4b_low_width; + gpu_kernel map_transpose_4b_small; + gpu_kernel map_transpose_4b_large; + gpu_kernel map_transpose_8b; + gpu_kernel map_transpose_8b_low_height; + gpu_kernel map_transpose_8b_low_width; + gpu_kernel map_transpose_8b_small; + gpu_kernel map_transpose_8b_large; + + // And a few ways of copying. + gpu_kernel lmad_copy_1b; + gpu_kernel lmad_copy_2b; + gpu_kernel lmad_copy_4b; + gpu_kernel lmad_copy_8b; +}; + +struct builtin_kernels* init_builtin_kernels(struct futhark_context* ctx) { + struct builtin_kernels *kernels = malloc(sizeof(struct builtin_kernels)); + gpu_create_kernel(ctx, &kernels->map_transpose_1b, "map_transpose_1b"); + gpu_create_kernel(ctx, &kernels->map_transpose_1b_large, "map_transpose_1b_large"); + gpu_create_kernel(ctx, &kernels->map_transpose_1b_low_height, "map_transpose_1b_low_height"); + gpu_create_kernel(ctx, &kernels->map_transpose_1b_low_width, "map_transpose_1b_low_width"); + gpu_create_kernel(ctx, &kernels->map_transpose_1b_small, "map_transpose_1b_small"); + + gpu_create_kernel(ctx, &kernels->map_transpose_2b, "map_transpose_2b"); + gpu_create_kernel(ctx, &kernels->map_transpose_2b_large, "map_transpose_2b_large"); + gpu_create_kernel(ctx, &kernels->map_transpose_2b_low_height, "map_transpose_2b_low_height"); + gpu_create_kernel(ctx, &kernels->map_transpose_2b_low_width, "map_transpose_2b_low_width"); + gpu_create_kernel(ctx, &kernels->map_transpose_2b_small, "map_transpose_2b_small"); + + gpu_create_kernel(ctx, &kernels->map_transpose_4b, "map_transpose_4b"); + gpu_create_kernel(ctx, &kernels->map_transpose_4b_large, "map_transpose_4b_large"); + gpu_create_kernel(ctx, &kernels->map_transpose_4b_low_height, "map_transpose_4b_low_height"); + gpu_create_kernel(ctx, &kernels->map_transpose_4b_low_width, "map_transpose_4b_low_width"); + gpu_create_kernel(ctx, &kernels->map_transpose_4b_small, "map_transpose_4b_small"); + + gpu_create_kernel(ctx, &kernels->map_transpose_8b, "map_transpose_8b"); + gpu_create_kernel(ctx, &kernels->map_transpose_8b_large, "map_transpose_8b_large"); + gpu_create_kernel(ctx, &kernels->map_transpose_8b_low_height, "map_transpose_8b_low_height"); + gpu_create_kernel(ctx, &kernels->map_transpose_8b_low_width, "map_transpose_8b_low_width"); + gpu_create_kernel(ctx, &kernels->map_transpose_8b_small, "map_transpose_8b_small"); + + gpu_create_kernel(ctx, &kernels->lmad_copy_1b, "lmad_copy_1b"); + gpu_create_kernel(ctx, &kernels->lmad_copy_2b, "lmad_copy_2b"); + gpu_create_kernel(ctx, &kernels->lmad_copy_4b, "lmad_copy_4b"); + gpu_create_kernel(ctx, &kernels->lmad_copy_8b, "lmad_copy_8b"); + + return kernels; +} + +void free_builtin_kernels(struct futhark_context* ctx, struct builtin_kernels* kernels) { + gpu_free_kernel(ctx, kernels->map_transpose_1b); + gpu_free_kernel(ctx, kernels->map_transpose_1b_large); + gpu_free_kernel(ctx, kernels->map_transpose_1b_low_height); + gpu_free_kernel(ctx, kernels->map_transpose_1b_low_width); + gpu_free_kernel(ctx, kernels->map_transpose_1b_small); + + gpu_free_kernel(ctx, kernels->map_transpose_2b); + gpu_free_kernel(ctx, kernels->map_transpose_2b_large); + gpu_free_kernel(ctx, kernels->map_transpose_2b_low_height); + gpu_free_kernel(ctx, kernels->map_transpose_2b_low_width); + gpu_free_kernel(ctx, kernels->map_transpose_2b_small); + + gpu_free_kernel(ctx, kernels->map_transpose_4b); + gpu_free_kernel(ctx, kernels->map_transpose_4b_large); + gpu_free_kernel(ctx, kernels->map_transpose_4b_low_height); + gpu_free_kernel(ctx, kernels->map_transpose_4b_low_width); + gpu_free_kernel(ctx, kernels->map_transpose_4b_small); + + gpu_free_kernel(ctx, kernels->map_transpose_8b); + gpu_free_kernel(ctx, kernels->map_transpose_8b_large); + gpu_free_kernel(ctx, kernels->map_transpose_8b_low_height); + gpu_free_kernel(ctx, kernels->map_transpose_8b_low_width); + gpu_free_kernel(ctx, kernels->map_transpose_8b_small); + + gpu_free_kernel(ctx, kernels->lmad_copy_1b); + gpu_free_kernel(ctx, kernels->lmad_copy_2b); + gpu_free_kernel(ctx, kernels->lmad_copy_4b); + gpu_free_kernel(ctx, kernels->lmad_copy_8b); + + free(kernels); +} + +static int gpu_alloc(struct futhark_context *ctx, FILE *log, + size_t min_size, const char *tag, + gpu_mem *mem_out, size_t *size_out) { + if (min_size < sizeof(int)) { + min_size = sizeof(int); + } + + gpu_mem* memptr; + if (free_list_find(&ctx->gpu_free_list, min_size, tag, size_out, (fl_mem*)&memptr) == 0) { + // Successfully found a free block. Is it big enough? + if (*size_out >= min_size) { + if (ctx->cfg->debugging) { + fprintf(log, "No need to allocate: Found a block in the free list.\n"); + } + *mem_out = *memptr; + free(memptr); + return FUTHARK_SUCCESS; + } else { + if (ctx->cfg->debugging) { + fprintf(log, "Found a free block, but it was too small.\n"); + } + int error = gpu_free_actual(ctx, *memptr); + free(memptr); + if (error != FUTHARK_SUCCESS) { + return error; + } + } + } + + *size_out = min_size; + + // We have to allocate a new block from the driver. If the + // allocation does not succeed, then we might be in an out-of-memory + // situation. We now start freeing things from the free list until + // we think we have freed enough that the allocation will succeed. + // Since we don't know how far the allocation is from fitting, we + // have to check after every deallocation. This might be pretty + // expensive. Let's hope that this case is hit rarely. + + if (ctx->cfg->debugging) { + fprintf(log, "Actually allocating the desired block.\n"); + } + + int error = gpu_alloc_actual(ctx, min_size, mem_out); + + while (error == FUTHARK_OUT_OF_MEMORY) { + if (ctx->cfg->debugging) { + fprintf(log, "Out of GPU memory: releasing entry from the free list...\n"); + } + gpu_mem* memptr; + if (free_list_first(&ctx->gpu_free_list, (fl_mem*)&memptr) == 0) { + gpu_mem mem = *memptr; + free(memptr); + error = gpu_free_actual(ctx, mem); + if (error != FUTHARK_SUCCESS) { + return error; + } + } else { + break; + } + error = gpu_alloc_actual(ctx, min_size, mem_out); + } + + return error; +} + +static int gpu_free(struct futhark_context *ctx, + gpu_mem mem, size_t size, const char *tag) { + gpu_mem* memptr = malloc(sizeof(gpu_mem)); + *memptr = mem; + free_list_insert(&ctx->gpu_free_list, size, (fl_mem)memptr, tag); + return FUTHARK_SUCCESS; +} + +static int gpu_free_all(struct futhark_context *ctx) { + free_list_pack(&ctx->gpu_free_list); + gpu_mem* memptr; + while (free_list_first(&ctx->gpu_free_list, (fl_mem*)&memptr) == 0) { + gpu_mem mem = *memptr; + free(memptr); + int error = gpu_free_actual(ctx, mem); + if (error != FUTHARK_SUCCESS) { + return error; + } + } + + return FUTHARK_SUCCESS; +} + +static int gpu_map_transpose(struct futhark_context* ctx, + gpu_kernel kernel_default, + gpu_kernel kernel_low_height, + gpu_kernel kernel_low_width, + gpu_kernel kernel_small, + gpu_kernel kernel_large, + const char *name, size_t elem_size, + gpu_mem dst, int64_t dst_offset, + gpu_mem src, int64_t src_offset, + int64_t k, int64_t n, int64_t m) { + int64_t mulx = TR_BLOCK_DIM / n; + int64_t muly = TR_BLOCK_DIM / m; + int32_t mulx32 = mulx; + int32_t muly32 = muly; + int32_t k32 = k; + int32_t n32 = n; + int32_t m32 = m; + + gpu_kernel kernel = kernel_default; + int32_t grid[3]; + int32_t block[3]; + + void* args[11]; + size_t args_sizes[11] = { + sizeof(gpu_mem), sizeof(int64_t), + sizeof(gpu_mem), sizeof(int64_t), + sizeof(int32_t), + sizeof(int32_t), + sizeof(int32_t), + sizeof(int32_t), + sizeof(int32_t) + }; + + args[0] = &dst; + args[1] = &dst_offset; + args[2] = &src; + args[3] = &src_offset; + args[7] = &mulx; + args[8] = &muly; + + if (dst_offset + k * n * m <= 2147483647L && + src_offset + k * n * m <= 2147483647L) { + if (m <= TR_BLOCK_DIM/2 && n <= TR_BLOCK_DIM/2) { + if (ctx->logging) { fprintf(ctx->log, "Using small kernel\n"); } + kernel = kernel_small; + grid[0] = ((k * n * m) + (TR_BLOCK_DIM*TR_BLOCK_DIM) - 1) / (TR_BLOCK_DIM*TR_BLOCK_DIM); + grid[1] = 1; + grid[2] = 1; + block[0] = TR_BLOCK_DIM*TR_BLOCK_DIM; + block[1] = 1; + block[2] = 1; + } else if (m <= TR_BLOCK_DIM/2 && TR_BLOCK_DIM < n) { + if (ctx->logging) { fprintf(ctx->log, "Using low-width kernel\n"); } + kernel = kernel_low_width; + int64_t x_elems = m; + int64_t y_elems = (n + muly - 1) / muly; + grid[0] = (x_elems + TR_BLOCK_DIM - 1) / TR_BLOCK_DIM; + grid[1] = (y_elems + TR_BLOCK_DIM - 1) / TR_BLOCK_DIM; + grid[2] = k; + block[0] = TR_BLOCK_DIM; + block[1] = TR_BLOCK_DIM; + block[2] = 1; + } else if (n <= TR_BLOCK_DIM/2 && TR_BLOCK_DIM < m) { + if (ctx->logging) { fprintf(ctx->log, "Using low-height kernel\n"); } + kernel = kernel_low_height; + int64_t x_elems = (m + mulx - 1) / mulx; + int64_t y_elems = n; + grid[0] = (x_elems + TR_BLOCK_DIM - 1) / TR_BLOCK_DIM; + grid[1] = (y_elems + TR_BLOCK_DIM - 1) / TR_BLOCK_DIM; + grid[2] = k; + block[0] = TR_BLOCK_DIM; + block[1] = TR_BLOCK_DIM; + block[2] = 1; + } else { + if (ctx->logging) { fprintf(ctx->log, "Using default kernel\n"); } + kernel = kernel_default; + grid[0] = (m+TR_TILE_DIM-1)/TR_TILE_DIM; + grid[1] = (n+TR_TILE_DIM-1)/TR_TILE_DIM; + grid[2] = k; + block[0] = TR_TILE_DIM; + block[1] = TR_TILE_DIM/TR_ELEMS_PER_THREAD; + block[2] = 1; + } + args[4] = &k32; + args[5] = &m32; + args[6] = &n32; + args[7] = &mulx32; + args[8] = &muly32; + } else { + if (ctx->logging) { fprintf(ctx->log, "Using large kernel\n"); } + kernel = kernel_large; + grid[0] = (m+TR_TILE_DIM-1)/TR_TILE_DIM; + grid[1] = (n+TR_TILE_DIM-1)/TR_TILE_DIM; + grid[2] = k; + block[0] = TR_TILE_DIM; + block[1] = TR_TILE_DIM/TR_ELEMS_PER_THREAD; + block[2] = 1; + args[4] = &k; + args[5] = &m; + args[6] = &n; + args[7] = &mulx; + args[8] = &muly; + args_sizes[4] = sizeof(int64_t); + args_sizes[5] = sizeof(int64_t); + args_sizes[6] = sizeof(int64_t); + args_sizes[7] = sizeof(int64_t); + args_sizes[8] = sizeof(int64_t); + } + + // Cap the number of groups we launch and figure out how many + // repeats we need alongside each dimension. + int32_t repeat_1 = grid[1] / MAX_TR_GROUPS; + int32_t repeat_2 = grid[2] / MAX_TR_GROUPS; + grid[1] = repeat_1 > 0 ? MAX_TR_GROUPS : grid[1]; + grid[2] = repeat_2 > 0 ? MAX_TR_GROUPS : grid[2]; + args[9] = &repeat_1; + args[10] = &repeat_2; + args_sizes[9] = sizeof(repeat_1); + args_sizes[10] = sizeof(repeat_2); + + if (ctx->logging) { + fprintf(ctx->log, "\n"); + } + + return gpu_launch_kernel(ctx, kernel, name, 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, \ + gpu_mem dst, int64_t dst_offset, \ + gpu_mem src, int64_t src_offset, \ + int64_t k, int64_t m, int64_t n) \ + { \ + return \ + gpu_map_transpose \ + (ctx, \ + ctx->kernels->map_transpose_##NAME, \ + ctx->kernels->map_transpose_##NAME##_low_height, \ + ctx->kernels->map_transpose_##NAME##_low_width, \ + ctx->kernels->map_transpose_##NAME##_small, \ + ctx->kernels->map_transpose_##NAME##_large, \ + "map_transpose_" #NAME, sizeof(ELEM_TYPE), \ + dst, dst_offset, src, src_offset, \ + k, n, m); \ + } + +static int gpu_lmad_copy(struct futhark_context* ctx, + 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], + int64_t shape[r]) { + if (r > 8) { + set_error(ctx, strdup("Futhark runtime limitation:\nCannot copy array of greater than rank 8.\n")); + return 1; + } + + int64_t n = 1; + for (int i = 0; i < r; i++) { n *= shape[i]; } + + void* args[6+(8*3)]; + size_t args_sizes[6+(8*3)]; + + args[0] = &dst; + args_sizes[0] = sizeof(gpu_mem); + args[1] = &dst_offset; + args_sizes[1] = sizeof(dst_offset); + args[2] = &src; + args_sizes[2] = sizeof(gpu_mem); + args[3] = &src_offset; + args_sizes[3] = sizeof(src_offset); + args[4] = &n; + args_sizes[4] = sizeof(n); + args[5] = &r; + args_sizes[5] = sizeof(r); + + int64_t zero = 0; + + for (int i = 0; i < 8; i++) { + args_sizes[6+i*3] = sizeof(int64_t); + args_sizes[6+i*3+1] = sizeof(int64_t); + args_sizes[6+i*3+2] = sizeof(int64_t); + if (i < r) { + args[6+i*3] = &shape[i]; + args[6+i*3+1] = &dst_strides[i]; + args[6+i*3+2] = &src_strides[i]; + } else { + args[6+i*3] = &zero; + args[6+i*3+1] = &zero; + args[6+i*3+2] = &zero; + } + } + const size_t w = 256; // XXX: hardcoded workgroup size. + + return gpu_launch_kernel(ctx, kernel, "copy_lmad_dev_to_dev", + (const int32_t[3]) {(n+w-1)/w,1,1}, + (const int32_t[3]) {w,1,1}, + 0, 6+(8*3), args, args_sizes); +} + +#define GEN_LMAD_COPY_ELEMENTS_GPU2GPU(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 gpu_lmad_copy(ctx, ctx->kernels->lmad_copy_##NAME, r, \ + dst, dst_offset, dst_strides, \ + src, src_offset, src_strides, \ + shape); \ + } \ + +#define GEN_LMAD_COPY_GPU2GPU(NAME, ELEM_TYPE) \ + static int lmad_copy_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]) { \ + log_copy(ctx, "GPU to GPU", 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)) { \ + log_transpose(ctx, k, n, m); \ + return map_transpose_gpu2gpu_##NAME \ + (ctx, 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, \ + 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, \ + dst, dst_offset, dst_strides, \ + src, src_offset, src_strides, \ + shape); \ + } \ + } + +static int +lmad_copy_elements_host2gpu(struct futhark_context *ctx, 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)dst; (void)dst_offset; (void)dst_strides; + (void)src; (void)src_offset; (void)src_strides; + (void)shape; + set_error(ctx, strdup("Futhark runtime limitation:\nCannot copy unstructured array from host to GPU.\n")); + return 1; +} + +static int +lmad_copy_elements_gpu2host (struct futhark_context *ctx, 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)dst; (void)dst_offset; (void)dst_strides; + (void)src; (void)src_offset; (void)src_strides; + (void)shape; + set_error(ctx, strdup("Futhark runtime limitation:\nCannot copy unstructured array from GPU to host.\n")); + 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, + 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, + src_offset, src_strides, shape); + int64_t size = elem_size; + for (int i = 0; i < r; i++) { size *= shape[i]; } + if (size == 0) { return FUTHARK_SUCCESS; } + 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, + dst, dst_offset*elem_size, + src, src_offset*elem_size, + size); + } else { + if (ctx->logging) {fprintf(ctx->log, "## General copy\n\n");} + int error; + error = lmad_copy_elements_host2gpu + (ctx, elem_size, r, + dst, dst_offset, dst_strides, + src, src_offset, src_strides, + shape); + if (error == 0 && sync) { + error = futhark_context_sync(ctx); + } + return error; + } +} + +static int lmad_copy_gpu2host(struct futhark_context* ctx, 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, + src_offset, src_strides, shape); + int64_t size = elem_size; + for (int i = 0; i < r; i++) { size *= shape[i]; } + if (size == 0) { return FUTHARK_SUCCESS; } + 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, + dst, dst_offset*elem_size, + src, src_offset*elem_size, + size); + } else { + if (ctx->logging) {fprintf(ctx->log, "## General copy\n\n");} + int error; + error = lmad_copy_elements_gpu2host + (ctx, elem_size, r, + dst, dst_offset, dst_strides, + src, src_offset, src_strides, + shape); + if (error == 0 && sync) { + error = futhark_context_sync(ctx); + } + return error; + } +} + +GEN_MAP_TRANSPOSE_GPU2GPU(1b, uint8_t) +GEN_MAP_TRANSPOSE_GPU2GPU(2b, uint16_t) +GEN_MAP_TRANSPOSE_GPU2GPU(4b, uint32_t) +GEN_MAP_TRANSPOSE_GPU2GPU(8b, uint64_t) + +GEN_LMAD_COPY_ELEMENTS_GPU2GPU(1b, uint8_t) +GEN_LMAD_COPY_ELEMENTS_GPU2GPU(2b, uint16_t) +GEN_LMAD_COPY_ELEMENTS_GPU2GPU(4b, uint32_t) +GEN_LMAD_COPY_ELEMENTS_GPU2GPU(8b, uint64_t) + +GEN_LMAD_COPY_GPU2GPU(1b, uint8_t) +GEN_LMAD_COPY_GPU2GPU(2b, uint16_t) +GEN_LMAD_COPY_GPU2GPU(4b, uint32_t) +GEN_LMAD_COPY_GPU2GPU(8b, uint64_t) + +// End of gpu.h diff --git a/rts/c/gpu_prototypes.h b/rts/c/gpu_prototypes.h new file mode 100644 --- /dev/null +++ b/rts/c/gpu_prototypes.h @@ -0,0 +1,12 @@ +// Start of gpu_prototypes.h + +// Constants used for transpositions. In principle these should be configurable. +#define TR_BLOCK_DIM 16 +#define TR_TILE_DIM (TR_BLOCK_DIM*2) +#define TR_ELEMS_PER_THREAD 8 + +struct builtin_kernels* init_builtin_kernels(struct futhark_context* ctx); +void free_builtin_kernels(struct futhark_context* ctx, struct builtin_kernels* kernels); +static int gpu_free_all(struct futhark_context *ctx); + +// End of gpu_prototypes.h diff --git a/rts/c/half.h b/rts/c/half.h --- a/rts/c/half.h +++ b/rts/c/half.h @@ -217,7 +217,7 @@ 0, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 0, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024, 1024 }; -static uint16_t float2halfbits(float value) { +SCALAR_FUN_ATTR uint16_t float2halfbits(float value) { union { float x; uint32_t y; } u; u.x = value; uint32_t bits = u.y; @@ -227,7 +227,7 @@ return hbits; } -static float halfbits2float(uint16_t value) { +SCALAR_FUN_ATTR float halfbits2float(uint16_t value) { uint32_t bits = mantissa_table[offset_table[value>>10]+(value&0x3FF)] + exponent_table[value>>10]; union { uint32_t x; float y; } u; @@ -235,7 +235,7 @@ return u.y; } -static uint16_t halfbitsnextafter(uint16_t from, uint16_t to) { +SCALAR_FUN_ATTR uint16_t halfbitsnextafter(uint16_t from, uint16_t to) { int fabs = from & 0x7FFF, tabs = to & 0x7FFF; if(fabs > 0x7C00 || tabs > 0x7C00) { return ((from&0x7FFF)>0x7C00) ? (from|0x200) : (to|0x200); diff --git a/rts/c/ispc_util.h b/rts/c/ispc_util.h --- a/rts/c/ispc_util.h +++ b/rts/c/ispc_util.h @@ -399,58 +399,4 @@ return err; } -// AOS <-> SOA memcpy functions -#define memmove_sized(dim) \ -static inline void memmove_##dim(varying uint8 * uniform dst, uniform uint8 * varying src, uniform int64_t n) { \ - uniform uint##dim * varying srcp = (uniform uint##dim * varying) src; \ - varying uint##dim * uniform dstp = (varying uint##dim * uniform) dst; \ - for (uniform int64_t i = 0; i < n / (dim / 8); i++) { \ - dstp[i] = srcp[i]; \ - } \ -} \ -static inline void memmove_##dim(uniform uint8 * varying dst, varying uint8 * uniform src, uniform int64_t n) { \ - varying uint##dim * uniform srcp = (varying uint##dim * uniform) src; \ - uniform uint##dim * varying dstp = (uniform uint##dim * varying) dst; \ - for (uniform int64_t i = 0; i < n / (dim / 8); i++) { \ - dstp[i] = srcp[i]; \ - } \ -} \ -static inline void memmove_##dim(varying uint8 * uniform dst, varying uint8 * uniform src, uniform int64_t n) { \ - varying uint##dim * uniform srcp = (varying uint##dim * uniform) src; \ - varying uint##dim * uniform dstp = (varying uint##dim * uniform) dst; \ - for (uniform int64_t i = 0; i < n / (dim / 8); i++) { \ - dstp[i] = srcp[i]; \ - } \ -} \ -static inline void memmove_##dim(varying uint8 * varying dst, uniform uint8 * varying src, uniform int64_t n) { \ - foreach_unique (ptr in dst) { \ - memmove_##dim(ptr, src, n); \ - } \ -} \ -static inline void memmove_##dim(uniform uint8 * varying dst, varying uint8 * varying src, uniform int64_t n) { \ - foreach_unique (ptr in src) { \ - memmove_##dim(dst, ptr, n); \ - } \ -} \ -static inline void memmove_##dim(varying uint8 * varying dst, varying uint8 * uniform src, uniform int64_t n) { \ - foreach_unique (ptr in dst) { \ - memmove_##dim(ptr, src, n); \ - } \ -} \ -static inline void memmove_##dim(varying uint8 * varying dst, varying uint8 * varying src, uniform int64_t n) { \ - if (reduce_equal((varying int64_t)dst)) { \ - foreach_unique (ptr in src) { \ - memmove_##dim(dst, ptr, n); \ - } \ - } else { \ - foreach_unique (ptr in dst) { \ - memmove_##dim(ptr, src, n); \ - } \ - } \ -} -memmove_sized(8) -memmove_sized(16) -memmove_sized(32) -memmove_sized(64) - // End of ispc_util.h. diff --git a/rts/c/scalar.h b/rts/c/scalar.h --- a/rts/c/scalar.h +++ b/rts/c/scalar.h @@ -17,2980 +17,2980 @@ // Double-precision definitions are only included if the preprocessor // macro FUTHARK_F64_ENABLED is set. -static inline uint8_t add8(uint8_t x, uint8_t y) { - return x + y; -} - -static inline uint16_t add16(uint16_t x, uint16_t y) { - return x + y; -} - -static inline uint32_t add32(uint32_t x, uint32_t y) { - return x + y; -} - -static inline uint64_t add64(uint64_t x, uint64_t y) { - return x + y; -} - -static inline uint8_t sub8(uint8_t x, uint8_t y) { - return x - y; -} - -static inline uint16_t sub16(uint16_t x, uint16_t y) { - return x - y; -} - -static inline uint32_t sub32(uint32_t x, uint32_t y) { - return x - y; -} - -static inline uint64_t sub64(uint64_t x, uint64_t y) { - return x - y; -} - -static inline uint8_t mul8(uint8_t x, uint8_t y) { - return x * y; -} - -static inline uint16_t mul16(uint16_t x, uint16_t y) { - return x * y; -} - -static inline uint32_t mul32(uint32_t x, uint32_t y) { - return x * y; -} - -static inline uint64_t mul64(uint64_t x, uint64_t y) { - return x * y; -} - -#if ISPC - -static inline uint8_t udiv8(uint8_t x, uint8_t y) { - // This strange pattern is used to prevent the ISPC compiler from - // causing SIGFPEs and bogus results on divisions where inactive lanes - // have 0-valued divisors. It ensures that any inactive lane instead - // has a divisor of 1. https://github.com/ispc/ispc/issues/2292 - uint8_t ys = 1; - foreach_active(i){ - ys = y; - } - - return x / ys; -} - -static inline uint16_t udiv16(uint16_t x, uint16_t y) { - uint16_t ys = 1; - foreach_active(i){ - ys = y; - } - - return x / ys; -} - -static inline uint32_t udiv32(uint32_t x, uint32_t y) { - uint32_t ys = 1; - foreach_active(i){ - ys = y; - } - - - return x / ys; -} - -static inline uint64_t udiv64(uint64_t x, uint64_t y) { - uint64_t ys = 1; - foreach_active(i){ - ys = y; - } - - - return x / ys; -} - -static inline uint8_t udiv_up8(uint8_t x, uint8_t y) { - uint8_t ys = 1; - foreach_active(i){ - ys = y; - } - - - return (x + y - 1) / ys; -} - -static inline uint16_t udiv_up16(uint16_t x, uint16_t y) { - uint16_t ys = 1; - foreach_active(i){ - ys = y; - } - - return (x + y - 1) / ys; -} - -static inline uint32_t udiv_up32(uint32_t x, uint32_t y) { - uint32_t ys = 1; - foreach_active(i){ - ys = y; - } - - return (x + y - 1) / ys; -} - -static inline uint64_t udiv_up64(uint64_t x, uint64_t y) { - uint64_t ys = 1; - foreach_active(i){ - ys = y; - } - - return (x + y - 1) / ys; -} - -static inline uint8_t umod8(uint8_t x, uint8_t y) { - uint8_t ys = 1; - foreach_active(i){ - ys = y; - } - - return x % ys; -} - -static inline uint16_t umod16(uint16_t x, uint16_t y) { - uint16_t ys = 1; - foreach_active(i){ - ys = y; - } - - - return x % ys; -} - -static inline uint32_t umod32(uint32_t x, uint32_t y) { - uint32_t ys = 1; - foreach_active(i){ - ys = y; - } - - return x % ys; -} - -static inline uint64_t umod64(uint64_t x, uint64_t y) { - uint64_t ys = 1; - foreach_active(i){ - ys = y; - } - - return x % ys; -} - -static inline uint8_t udiv_safe8(uint8_t x, uint8_t y) { - uint8_t ys = 1; - foreach_active(i){ - ys = y; - } - - return y == 0 ? 0 : x / ys; -} - -static inline uint16_t udiv_safe16(uint16_t x, uint16_t y) { - uint16_t ys = 1; - foreach_active(i){ - ys = y; - } - - return y == 0 ? 0 : x / ys; -} - -static inline uint32_t udiv_safe32(uint32_t x, uint32_t y) { - uint32_t ys = 1; - foreach_active(i){ - ys = y; - } - - return y == 0 ? 0 : x / ys; -} - -static inline uint64_t udiv_safe64(uint64_t x, uint64_t y) { - uint64_t ys = 1; - foreach_active(i){ - ys = y; - } - - return y == 0 ? 0 : x / ys; -} - -static inline uint8_t udiv_up_safe8(uint8_t x, uint8_t y) { - uint8_t ys = 1; - foreach_active(i){ - ys = y; - } - - return y == 0 ? 0 : (x + y - 1) / ys; -} - -static inline uint16_t udiv_up_safe16(uint16_t x, uint16_t y) { - uint16_t ys = 1; - foreach_active(i){ - ys = y; - } - - return y == 0 ? 0 : (x + y - 1) / ys; -} - -static inline uint32_t udiv_up_safe32(uint32_t x, uint32_t y) { - uint32_t ys = 1; - foreach_active(i){ - ys = y; - } - - return y == 0 ? 0 : (x + y - 1) / ys; -} - -static inline uint64_t udiv_up_safe64(uint64_t x, uint64_t y) { - uint64_t ys = 1; - foreach_active(i){ - ys = y; - } - - return y == 0 ? 0 : (x + y - 1) / ys; -} - -static inline uint8_t umod_safe8(uint8_t x, uint8_t y) { - uint8_t ys = 1; - foreach_active(i){ - ys = y; - } - - return y == 0 ? 0 : x % ys; -} - -static inline uint16_t umod_safe16(uint16_t x, uint16_t y) { - uint16_t ys = 1; - foreach_active(i){ - ys = y; - } - - return y == 0 ? 0 : x % ys; -} - -static inline uint32_t umod_safe32(uint32_t x, uint32_t y) { - uint32_t ys = 1; - foreach_active(i){ - ys = y; - } - - return y == 0 ? 0 : x % ys; -} - -static inline uint64_t umod_safe64(uint64_t x, uint64_t y) { - uint64_t ys = 1; - foreach_active(i){ - ys = y; - } - - return y == 0 ? 0 : x % ys; -} - -static inline int8_t sdiv8(int8_t x, int8_t y) { - int8_t ys = 1; - foreach_active(i){ - ys = y; - } - - int8_t q = x / ys; - int8_t r = x % ys; - - return q - ((r != 0 && r < 0 != y < 0) ? 1 : 0); -} - -static inline int16_t sdiv16(int16_t x, int16_t y) { - int16_t ys = 1; - foreach_active(i){ - ys = y; - } - - int16_t q = x / ys; - int16_t r = x % ys; - - return q - ((r != 0 && r < 0 != y < 0) ? 1 : 0); -} - -static inline int32_t sdiv32(int32_t x, int32_t y) { - int32_t ys = 1; - foreach_active(i){ - ys = y; - } - int32_t q = x / ys; - int32_t r = x % ys; - - return q - ((r != 0 && r < 0 != y < 0) ? 1 : 0); -} - -static inline int64_t sdiv64(int64_t x, int64_t y) { - int64_t ys = 1; - foreach_active(i){ - ys = y; - } - - int64_t q = x / ys; - int64_t r = x % ys; - - return q - ((r != 0 && r < 0 != y < 0) ? 1 : 0); -} - -static inline int8_t sdiv_up8(int8_t x, int8_t y) { - return sdiv8(x + y - 1, y); -} - -static inline int16_t sdiv_up16(int16_t x, int16_t y) { - return sdiv16(x + y - 1, y); -} - -static inline int32_t sdiv_up32(int32_t x, int32_t y) { - return sdiv32(x + y - 1, y); -} - -static inline int64_t sdiv_up64(int64_t x, int64_t y) { - return sdiv64(x + y - 1, y); -} - -static inline int8_t smod8(int8_t x, int8_t y) { - int8_t ys = 1; - foreach_active(i){ - ys = y; - } - - int8_t r = x % ys; - - return r + (r == 0 || (x > 0 && y > 0) || (x < 0 && y < 0) ? 0 : y); -} - -static inline int16_t smod16(int16_t x, int16_t y) { - int16_t ys = 1; - foreach_active(i){ - ys = y; - } - - int16_t r = x % ys; - - return r + (r == 0 || (x > 0 && y > 0) || (x < 0 && y < 0) ? 0 : y); -} - -static inline int32_t smod32(int32_t x, int32_t y) { - int32_t ys = 1; - foreach_active(i){ - ys = y; - } - - int32_t r = x % ys; - - return r + (r == 0 || (x > 0 && y > 0) || (x < 0 && y < 0) ? 0 : y); -} - -static inline int64_t smod64(int64_t x, int64_t y) { - int64_t ys = 1; - foreach_active(i){ - ys = y; - } - - int64_t r = x % ys; - - return r + (r == 0 || (x > 0 && y > 0) || (x < 0 && y < 0) ? 0 : y); -} - -static inline int8_t sdiv_safe8(int8_t x, int8_t y) { - return y == 0 ? 0 : sdiv8(x, y); -} - -static inline int16_t sdiv_safe16(int16_t x, int16_t y) { - return y == 0 ? 0 : sdiv16(x, y); -} - -static inline int32_t sdiv_safe32(int32_t x, int32_t y) { - return y == 0 ? 0 : sdiv32(x, y); -} - -static inline int64_t sdiv_safe64(int64_t x, int64_t y) { - return y == 0 ? 0 : sdiv64(x, y); -} - -static inline int8_t sdiv_up_safe8(int8_t x, int8_t y) { - return sdiv_safe8(x + y - 1, y); -} - -static inline int16_t sdiv_up_safe16(int16_t x, int16_t y) { - return sdiv_safe16(x + y - 1, y); -} - -static inline int32_t sdiv_up_safe32(int32_t x, int32_t y) { - return sdiv_safe32(x + y - 1, y); -} - -static inline int64_t sdiv_up_safe64(int64_t x, int64_t y) { - return sdiv_safe64(x + y - 1, y); -} - -static inline int8_t smod_safe8(int8_t x, int8_t y) { - return y == 0 ? 0 : smod8(x, y); -} - -static inline int16_t smod_safe16(int16_t x, int16_t y) { - return y == 0 ? 0 : smod16(x, y); -} - -static inline int32_t smod_safe32(int32_t x, int32_t y) { - return y == 0 ? 0 : smod32(x, y); -} - -static inline int64_t smod_safe64(int64_t x, int64_t y) { - return y == 0 ? 0 : smod64(x, y); -} - -static inline int8_t squot8(int8_t x, int8_t y) { - int8_t ys = 1; - foreach_active(i){ - ys = y; - } - - return x / ys; -} - -static inline int16_t squot16(int16_t x, int16_t y) { - int16_t ys = 1; - foreach_active(i){ - ys = y; - } - - return x / ys; -} - -static inline int32_t squot32(int32_t x, int32_t y) { - int32_t ys = 1; - foreach_active(i){ - ys = y; - } - - return x / ys; -} - -static inline int64_t squot64(int64_t x, int64_t y) { - int64_t ys = 1; - foreach_active(i){ - ys = y; - } - - return x / ys; -} - -static inline int8_t srem8(int8_t x, int8_t y) { - int8_t ys = 1; - foreach_active(i){ - ys = y; - } - - return x % ys; -} - -static inline int16_t srem16(int16_t x, int16_t y) { - int16_t ys = 1; - foreach_active(i){ - ys = y; - } - - return x % ys; -} - -static inline int32_t srem32(int32_t x, int32_t y) { - int32_t ys = 1; - foreach_active(i){ - ys = y; - } - - return x % ys; -} - -static inline int64_t srem64(int64_t x, int64_t y) { - int8_t ys = 1; - foreach_active(i){ - ys = y; - } - - return x % ys; -} - -static inline int8_t squot_safe8(int8_t x, int8_t y) { - int8_t ys = 1; - foreach_active(i){ - ys = y; - } - - return y == 0 ? 0 : x / ys; -} - -static inline int16_t squot_safe16(int16_t x, int16_t y) { - int16_t ys = 1; - foreach_active(i){ - ys = y; - } - - return y == 0 ? 0 : x / ys; -} - -static inline int32_t squot_safe32(int32_t x, int32_t y) { - int32_t ys = 1; - foreach_active(i){ - ys = y; - } - - return y == 0 ? 0 : x / ys; -} - -static inline int64_t squot_safe64(int64_t x, int64_t y) { - int64_t ys = 1; - foreach_active(i){ - ys = y; - } - - return y == 0 ? 0 : x / ys; -} - -static inline int8_t srem_safe8(int8_t x, int8_t y) { - int8_t ys = 1; - foreach_active(i){ - ys = y; - } - - return y == 0 ? 0 : x % ys; -} - -static inline int16_t srem_safe16(int16_t x, int16_t y) { - int16_t ys = 1; - foreach_active(i){ - ys = y; - } - - return y == 0 ? 0 : x % ys; -} - -static inline int32_t srem_safe32(int32_t x, int32_t y) { - int32_t ys = 1; - foreach_active(i){ - ys = y; - } - - return y == 0 ? 0 : x % ys; -} - -static inline int64_t srem_safe64(int64_t x, int64_t y) { - int64_t ys = 1; - foreach_active(i){ - ys = y; - } - - return y == 0 ? 0 : x % ys; -} - -#else - -static inline uint8_t udiv8(uint8_t x, uint8_t y) { - return x / y; -} - -static inline uint16_t udiv16(uint16_t x, uint16_t y) { - return x / y; -} - -static inline uint32_t udiv32(uint32_t x, uint32_t y) { - return x / y; -} - -static inline uint64_t udiv64(uint64_t x, uint64_t y) { - return x / y; -} - -static inline uint8_t udiv_up8(uint8_t x, uint8_t y) { - return (x + y - 1) / y; -} - -static inline uint16_t udiv_up16(uint16_t x, uint16_t y) { - return (x + y - 1) / y; -} - -static inline uint32_t udiv_up32(uint32_t x, uint32_t y) { - return (x + y - 1) / y; -} - -static inline uint64_t udiv_up64(uint64_t x, uint64_t y) { - return (x + y - 1) / y; -} - -static inline uint8_t umod8(uint8_t x, uint8_t y) { - return x % y; -} - -static inline uint16_t umod16(uint16_t x, uint16_t y) { - return x % y; -} - -static inline uint32_t umod32(uint32_t x, uint32_t y) { - return x % y; -} - -static inline uint64_t umod64(uint64_t x, uint64_t y) { - return x % y; -} - -static inline uint8_t udiv_safe8(uint8_t x, uint8_t y) { - return y == 0 ? 0 : x / y; -} - -static inline uint16_t udiv_safe16(uint16_t x, uint16_t y) { - return y == 0 ? 0 : x / y; -} - -static inline uint32_t udiv_safe32(uint32_t x, uint32_t y) { - return y == 0 ? 0 : x / y; -} - -static inline uint64_t udiv_safe64(uint64_t x, uint64_t y) { - return y == 0 ? 0 : x / y; -} - -static inline uint8_t udiv_up_safe8(uint8_t x, uint8_t y) { - return y == 0 ? 0 : (x + y - 1) / y; -} - -static inline uint16_t udiv_up_safe16(uint16_t x, uint16_t y) { - return y == 0 ? 0 : (x + y - 1) / y; -} - -static inline uint32_t udiv_up_safe32(uint32_t x, uint32_t y) { - return y == 0 ? 0 : (x + y - 1) / y; -} - -static inline uint64_t udiv_up_safe64(uint64_t x, uint64_t y) { - return y == 0 ? 0 : (x + y - 1) / y; -} - -static inline uint8_t umod_safe8(uint8_t x, uint8_t y) { - return y == 0 ? 0 : x % y; -} - -static inline uint16_t umod_safe16(uint16_t x, uint16_t y) { - return y == 0 ? 0 : x % y; -} - -static inline uint32_t umod_safe32(uint32_t x, uint32_t y) { - return y == 0 ? 0 : x % y; -} - -static inline uint64_t umod_safe64(uint64_t x, uint64_t y) { - return y == 0 ? 0 : x % y; -} - -static inline int8_t sdiv8(int8_t x, int8_t y) { - int8_t q = x / y; - int8_t r = x % y; - - return q - ((r != 0 && r < 0 != y < 0) ? 1 : 0); -} - -static inline int16_t sdiv16(int16_t x, int16_t y) { - int16_t q = x / y; - int16_t r = x % y; - - return q - ((r != 0 && r < 0 != y < 0) ? 1 : 0); -} - -static inline int32_t sdiv32(int32_t x, int32_t y) { - int32_t q = x / y; - int32_t r = x % y; - - return q - ((r != 0 && r < 0 != y < 0) ? 1 : 0); -} - -static inline int64_t sdiv64(int64_t x, int64_t y) { - int64_t q = x / y; - int64_t r = x % y; - - return q - ((r != 0 && r < 0 != y < 0) ? 1 : 0); -} - -static inline int8_t sdiv_up8(int8_t x, int8_t y) { - return sdiv8(x + y - 1, y); -} - -static inline int16_t sdiv_up16(int16_t x, int16_t y) { - return sdiv16(x + y - 1, y); -} - -static inline int32_t sdiv_up32(int32_t x, int32_t y) { - return sdiv32(x + y - 1, y); -} - -static inline int64_t sdiv_up64(int64_t x, int64_t y) { - return sdiv64(x + y - 1, y); -} - -static inline int8_t smod8(int8_t x, int8_t y) { - int8_t r = x % y; - - return r + (r == 0 || (x > 0 && y > 0) || (x < 0 && y < 0) ? 0 : y); -} - -static inline int16_t smod16(int16_t x, int16_t y) { - int16_t r = x % y; - - return r + (r == 0 || (x > 0 && y > 0) || (x < 0 && y < 0) ? 0 : y); -} - -static inline int32_t smod32(int32_t x, int32_t y) { - int32_t r = x % y; - - return r + (r == 0 || (x > 0 && y > 0) || (x < 0 && y < 0) ? 0 : y); -} - -static inline int64_t smod64(int64_t x, int64_t y) { - int64_t r = x % y; - - return r + (r == 0 || (x > 0 && y > 0) || (x < 0 && y < 0) ? 0 : y); -} - -static inline int8_t sdiv_safe8(int8_t x, int8_t y) { - return y == 0 ? 0 : sdiv8(x, y); -} - -static inline int16_t sdiv_safe16(int16_t x, int16_t y) { - return y == 0 ? 0 : sdiv16(x, y); -} - -static inline int32_t sdiv_safe32(int32_t x, int32_t y) { - return y == 0 ? 0 : sdiv32(x, y); -} - -static inline int64_t sdiv_safe64(int64_t x, int64_t y) { - return y == 0 ? 0 : sdiv64(x, y); -} - -static inline int8_t sdiv_up_safe8(int8_t x, int8_t y) { - return sdiv_safe8(x + y - 1, y); -} - -static inline int16_t sdiv_up_safe16(int16_t x, int16_t y) { - return sdiv_safe16(x + y - 1, y); -} - -static inline int32_t sdiv_up_safe32(int32_t x, int32_t y) { - return sdiv_safe32(x + y - 1, y); -} - -static inline int64_t sdiv_up_safe64(int64_t x, int64_t y) { - return sdiv_safe64(x + y - 1, y); -} - -static inline int8_t smod_safe8(int8_t x, int8_t y) { - return y == 0 ? 0 : smod8(x, y); -} - -static inline int16_t smod_safe16(int16_t x, int16_t y) { - return y == 0 ? 0 : smod16(x, y); -} - -static inline int32_t smod_safe32(int32_t x, int32_t y) { - return y == 0 ? 0 : smod32(x, y); -} - -static inline int64_t smod_safe64(int64_t x, int64_t y) { - return y == 0 ? 0 : smod64(x, y); -} - -static inline int8_t squot8(int8_t x, int8_t y) { - return x / y; -} - -static inline int16_t squot16(int16_t x, int16_t y) { - return x / y; -} - -static inline int32_t squot32(int32_t x, int32_t y) { - return x / y; -} - -static inline int64_t squot64(int64_t x, int64_t y) { - return x / y; -} - -static inline int8_t srem8(int8_t x, int8_t y) { - return x % y; -} - -static inline int16_t srem16(int16_t x, int16_t y) { - return x % y; -} - -static inline int32_t srem32(int32_t x, int32_t y) { - return x % y; -} - -static inline int64_t srem64(int64_t x, int64_t y) { - return x % y; -} - -static inline int8_t squot_safe8(int8_t x, int8_t y) { - return y == 0 ? 0 : x / y; -} - -static inline int16_t squot_safe16(int16_t x, int16_t y) { - return y == 0 ? 0 : x / y; -} - -static inline int32_t squot_safe32(int32_t x, int32_t y) { - return y == 0 ? 0 : x / y; -} - -static inline int64_t squot_safe64(int64_t x, int64_t y) { - return y == 0 ? 0 : x / y; -} - -static inline int8_t srem_safe8(int8_t x, int8_t y) { - return y == 0 ? 0 : x % y; -} - -static inline int16_t srem_safe16(int16_t x, int16_t y) { - return y == 0 ? 0 : x % y; -} - -static inline int32_t srem_safe32(int32_t x, int32_t y) { - return y == 0 ? 0 : x % y; -} - -static inline int64_t srem_safe64(int64_t x, int64_t y) { - return y == 0 ? 0 : x % y; -} - -#endif - -static inline int8_t smin8(int8_t x, int8_t y) { - return x < y ? x : y; -} - -static inline int16_t smin16(int16_t x, int16_t y) { - return x < y ? x : y; -} - -static inline int32_t smin32(int32_t x, int32_t y) { - return x < y ? x : y; -} - -static inline int64_t smin64(int64_t x, int64_t y) { - return x < y ? x : y; -} - -static inline uint8_t umin8(uint8_t x, uint8_t y) { - return x < y ? x : y; -} - -static inline uint16_t umin16(uint16_t x, uint16_t y) { - return x < y ? x : y; -} - -static inline uint32_t umin32(uint32_t x, uint32_t y) { - return x < y ? x : y; -} - -static inline uint64_t umin64(uint64_t x, uint64_t y) { - return x < y ? x : y; -} - -static inline int8_t smax8(int8_t x, int8_t y) { - return x < y ? y : x; -} - -static inline int16_t smax16(int16_t x, int16_t y) { - return x < y ? y : x; -} - -static inline int32_t smax32(int32_t x, int32_t y) { - return x < y ? y : x; -} - -static inline int64_t smax64(int64_t x, int64_t y) { - return x < y ? y : x; -} - -static inline uint8_t umax8(uint8_t x, uint8_t y) { - return x < y ? y : x; -} - -static inline uint16_t umax16(uint16_t x, uint16_t y) { - return x < y ? y : x; -} - -static inline uint32_t umax32(uint32_t x, uint32_t y) { - return x < y ? y : x; -} - -static inline uint64_t umax64(uint64_t x, uint64_t y) { - return x < y ? y : x; -} - -static inline uint8_t shl8(uint8_t x, uint8_t y) { - return (uint8_t)(x << y); -} - -static inline uint16_t shl16(uint16_t x, uint16_t y) { - return (uint16_t)(x << y); -} - -static inline uint32_t shl32(uint32_t x, uint32_t y) { - return x << y; -} - -static inline uint64_t shl64(uint64_t x, uint64_t y) { - return x << y; -} - -static inline uint8_t lshr8(uint8_t x, uint8_t y) { - return x >> y; -} - -static inline uint16_t lshr16(uint16_t x, uint16_t y) { - return x >> y; -} - -static inline uint32_t lshr32(uint32_t x, uint32_t y) { - return x >> y; -} - -static inline uint64_t lshr64(uint64_t x, uint64_t y) { - return x >> y; -} - -static inline int8_t ashr8(int8_t x, int8_t y) { - return x >> y; -} - -static inline int16_t ashr16(int16_t x, int16_t y) { - return x >> y; -} - -static inline int32_t ashr32(int32_t x, int32_t y) { - return x >> y; -} - -static inline int64_t ashr64(int64_t x, int64_t y) { - return x >> y; -} - -static inline uint8_t and8(uint8_t x, uint8_t y) { - return x & y; -} - -static inline uint16_t and16(uint16_t x, uint16_t y) { - return x & y; -} - -static inline uint32_t and32(uint32_t x, uint32_t y) { - return x & y; -} - -static inline uint64_t and64(uint64_t x, uint64_t y) { - return x & y; -} - -static inline uint8_t or8(uint8_t x, uint8_t y) { - return x | y; -} - -static inline uint16_t or16(uint16_t x, uint16_t y) { - return x | y; -} - -static inline uint32_t or32(uint32_t x, uint32_t y) { - return x | y; -} - -static inline uint64_t or64(uint64_t x, uint64_t y) { - return x | y; -} - -static inline uint8_t xor8(uint8_t x, uint8_t y) { - return x ^ y; -} - -static inline uint16_t xor16(uint16_t x, uint16_t y) { - return x ^ y; -} - -static inline uint32_t xor32(uint32_t x, uint32_t y) { - return x ^ y; -} - -static inline uint64_t xor64(uint64_t x, uint64_t y) { - return x ^ y; -} - -static inline bool ult8(uint8_t x, uint8_t y) { - return x < y; -} - -static inline bool ult16(uint16_t x, uint16_t y) { - return x < y; -} - -static inline bool ult32(uint32_t x, uint32_t y) { - return x < y; -} - -static inline bool ult64(uint64_t x, uint64_t y) { - return x < y; -} - -static inline bool ule8(uint8_t x, uint8_t y) { - return x <= y; -} - -static inline bool ule16(uint16_t x, uint16_t y) { - return x <= y; -} - -static inline bool ule32(uint32_t x, uint32_t y) { - return x <= y; -} - -static inline bool ule64(uint64_t x, uint64_t y) { - return x <= y; -} - -static inline bool slt8(int8_t x, int8_t y) { - return x < y; -} - -static inline bool slt16(int16_t x, int16_t y) { - return x < y; -} - -static inline bool slt32(int32_t x, int32_t y) { - return x < y; -} - -static inline bool slt64(int64_t x, int64_t y) { - return x < y; -} - -static inline bool sle8(int8_t x, int8_t y) { - return x <= y; -} - -static inline bool sle16(int16_t x, int16_t y) { - return x <= y; -} - -static inline bool sle32(int32_t x, int32_t y) { - return x <= y; -} - -static inline bool sle64(int64_t x, int64_t y) { - return x <= y; -} - -static inline uint8_t pow8(uint8_t x, uint8_t y) { - uint8_t res = 1, rem = y; - - while (rem != 0) { - if (rem & 1) - res *= x; - rem >>= 1; - x *= x; - } - return res; -} - -static inline uint16_t pow16(uint16_t x, uint16_t y) { - uint16_t res = 1, rem = y; - - while (rem != 0) { - if (rem & 1) - res *= x; - rem >>= 1; - x *= x; - } - return res; -} - -static inline uint32_t pow32(uint32_t x, uint32_t y) { - uint32_t res = 1, rem = y; - - while (rem != 0) { - if (rem & 1) - res *= x; - rem >>= 1; - x *= x; - } - return res; -} - -static inline uint64_t pow64(uint64_t x, uint64_t y) { - uint64_t res = 1, rem = y; - - while (rem != 0) { - if (rem & 1) - res *= x; - rem >>= 1; - x *= x; - } - return res; -} - -static inline bool itob_i8_bool(int8_t x) { - return x != 0; -} - -static inline bool itob_i16_bool(int16_t x) { - return x != 0; -} - -static inline bool itob_i32_bool(int32_t x) { - return x != 0; -} - -static inline bool itob_i64_bool(int64_t x) { - return x != 0; -} - -static inline int8_t btoi_bool_i8(bool x) { - return x; -} - -static inline int16_t btoi_bool_i16(bool x) { - return x; -} - -static inline int32_t btoi_bool_i32(bool x) { - return x; -} - -static inline int64_t btoi_bool_i64(bool x) { - return x; -} - -#define sext_i8_i8(x) ((int8_t) (int8_t) (x)) -#define sext_i8_i16(x) ((int16_t) (int8_t) (x)) -#define sext_i8_i32(x) ((int32_t) (int8_t) (x)) -#define sext_i8_i64(x) ((int64_t) (int8_t) (x)) -#define sext_i16_i8(x) ((int8_t) (int16_t) (x)) -#define sext_i16_i16(x) ((int16_t) (int16_t) (x)) -#define sext_i16_i32(x) ((int32_t) (int16_t) (x)) -#define sext_i16_i64(x) ((int64_t) (int16_t) (x)) -#define sext_i32_i8(x) ((int8_t) (int32_t) (x)) -#define sext_i32_i16(x) ((int16_t) (int32_t) (x)) -#define sext_i32_i32(x) ((int32_t) (int32_t) (x)) -#define sext_i32_i64(x) ((int64_t) (int32_t) (x)) -#define sext_i64_i8(x) ((int8_t) (int64_t) (x)) -#define sext_i64_i16(x) ((int16_t) (int64_t) (x)) -#define sext_i64_i32(x) ((int32_t) (int64_t) (x)) -#define sext_i64_i64(x) ((int64_t) (int64_t) (x)) -#define zext_i8_i8(x) ((int8_t) (uint8_t) (x)) -#define zext_i8_i16(x) ((int16_t) (uint8_t) (x)) -#define zext_i8_i32(x) ((int32_t) (uint8_t) (x)) -#define zext_i8_i64(x) ((int64_t) (uint8_t) (x)) -#define zext_i16_i8(x) ((int8_t) (uint16_t) (x)) -#define zext_i16_i16(x) ((int16_t) (uint16_t) (x)) -#define zext_i16_i32(x) ((int32_t) (uint16_t) (x)) -#define zext_i16_i64(x) ((int64_t) (uint16_t) (x)) -#define zext_i32_i8(x) ((int8_t) (uint32_t) (x)) -#define zext_i32_i16(x) ((int16_t) (uint32_t) (x)) -#define zext_i32_i32(x) ((int32_t) (uint32_t) (x)) -#define zext_i32_i64(x) ((int64_t) (uint32_t) (x)) -#define zext_i64_i8(x) ((int8_t) (uint64_t) (x)) -#define zext_i64_i16(x) ((int16_t) (uint64_t) (x)) -#define zext_i64_i32(x) ((int32_t) (uint64_t) (x)) -#define zext_i64_i64(x) ((int64_t) (uint64_t) (x)) - -static int8_t abs8(int8_t x) { - return (int8_t)abs(x); -} - -static int16_t abs16(int16_t x) { - return (int16_t)abs(x); -} - -static int32_t abs32(int32_t x) { - return abs(x); -} - -static int64_t abs64(int64_t x) { -#if defined(__OPENCL_VERSION__) || defined(ISPC) - return abs(x); -#else - return llabs(x); -#endif -} - -#if defined(__OPENCL_VERSION__) -static int32_t futrts_popc8(int8_t x) { - return popcount(x); -} - -static int32_t futrts_popc16(int16_t x) { - return popcount(x); -} - -static int32_t futrts_popc32(int32_t x) { - return popcount(x); -} - -static int32_t futrts_popc64(int64_t x) { - return popcount(x); -} -#elif defined(__CUDA_ARCH__) - -static int32_t futrts_popc8(int8_t x) { - return __popc(zext_i8_i32(x)); -} - -static int32_t futrts_popc16(int16_t x) { - return __popc(zext_i16_i32(x)); -} - -static int32_t futrts_popc32(int32_t x) { - return __popc(x); -} - -static int32_t futrts_popc64(int64_t x) { - return __popcll(x); -} - -#else // Not OpenCL or CUDA, but plain C. - -static int32_t futrts_popc8(uint8_t x) { - int c = 0; - for (; x; ++c) { x &= x - 1; } - return c; -} - -static int32_t futrts_popc16(uint16_t x) { - int c = 0; - for (; x; ++c) { x &= x - 1; } - return c; -} - -static int32_t futrts_popc32(uint32_t x) { - int c = 0; - for (; x; ++c) { x &= x - 1; } - return c; -} - -static int32_t futrts_popc64(uint64_t x) { - int c = 0; - for (; x; ++c) { x &= x - 1; } - return c; -} -#endif - -#if defined(__OPENCL_VERSION__) -static uint8_t futrts_umul_hi8 ( uint8_t a, uint8_t b) { return mul_hi(a, b); } -static uint16_t futrts_umul_hi16(uint16_t a, uint16_t b) { return mul_hi(a, b); } -static uint32_t futrts_umul_hi32(uint32_t a, uint32_t b) { return mul_hi(a, b); } -static uint64_t futrts_umul_hi64(uint64_t a, uint64_t b) { return mul_hi(a, b); } -static uint8_t futrts_smul_hi8 ( int8_t a, int8_t b) { return mul_hi(a, b); } -static uint16_t futrts_smul_hi16(int16_t a, int16_t b) { return mul_hi(a, b); } -static uint32_t futrts_smul_hi32(int32_t a, int32_t b) { return mul_hi(a, b); } -static uint64_t futrts_smul_hi64(int64_t a, int64_t b) { return mul_hi(a, b); } -#elif defined(__CUDA_ARCH__) -static uint8_t futrts_umul_hi8(uint8_t a, uint8_t b) { return ((uint16_t)a) * ((uint16_t)b) >> 8; } -static uint16_t futrts_umul_hi16(uint16_t a, uint16_t b) { return ((uint32_t)a) * ((uint32_t)b) >> 16; } -static uint32_t futrts_umul_hi32(uint32_t a, uint32_t b) { return __umulhi(a, b); } -static uint64_t futrts_umul_hi64(uint64_t a, uint64_t b) { return __umul64hi(a, b); } -static uint8_t futrts_smul_hi8 ( int8_t a, int8_t b) { return ((int16_t)a) * ((int16_t)b) >> 8; } -static uint16_t futrts_smul_hi16(int16_t a, int16_t b) { return ((int32_t)a) * ((int32_t)b) >> 16; } -static uint32_t futrts_smul_hi32(int32_t a, int32_t b) { return __mulhi(a, b); } -static uint64_t futrts_smul_hi64(int64_t a, int64_t b) { return __mul64hi(a, b); } -#elif ISPC -static uint8_t futrts_umul_hi8(uint8_t a, uint8_t b) { return ((uint16_t)a) * ((uint16_t)b) >> 8; } -static uint16_t futrts_umul_hi16(uint16_t a, uint16_t b) { return ((uint32_t)a) * ((uint32_t)b) >> 16; } -static uint32_t futrts_umul_hi32(uint32_t a, uint32_t b) { return ((uint64_t)a) * ((uint64_t)b) >> 32; } -static uint64_t futrts_umul_hi64(uint64_t a, uint64_t b) { - uint64_t ah = a >> 32; - uint64_t al = a & 0xffffffff; - uint64_t bh = b >> 32; - uint64_t bl = b & 0xffffffff; - - uint64_t p1 = al * bl; - uint64_t p2 = al * bh; - uint64_t p3 = ah * bl; - uint64_t p4 = ah * bh; - - uint64_t p1h = p1 >> 32; - uint64_t p2h = p2 >> 32; - uint64_t p3h = p3 >> 32; - uint64_t p2l = p2 & 0xffffffff; - uint64_t p3l = p3 & 0xffffffff; - - uint64_t l = p1h + p2l + p3l; - uint64_t m = (p2 >> 32) + (p3 >> 32); - uint64_t h = (l >> 32) + m + p4; - - return h; -} -static int8_t futrts_smul_hi8 ( int8_t a, int8_t b) { return ((uint16_t)a) * ((uint16_t)b) >> 8; } -static int16_t futrts_smul_hi16(int16_t a, int16_t b) { return ((uint32_t)a) * ((uint32_t)b) >> 16; } -static int32_t futrts_smul_hi32(int32_t a, int32_t b) { return ((uint64_t)a) * ((uint64_t)b) >> 32; } -static int64_t futrts_smul_hi64(int64_t a, int64_t b) { - uint64_t ah = a >> 32; - uint64_t al = a & 0xffffffff; - uint64_t bh = b >> 32; - uint64_t bl = b & 0xffffffff; - - uint64_t p1 = al * bl; - int64_t p2 = al * bh; - int64_t p3 = ah * bl; - uint64_t p4 = ah * bh; - - uint64_t p1h = p1 >> 32; - uint64_t p2h = p2 >> 32; - uint64_t p3h = p3 >> 32; - uint64_t p2l = p2 & 0xffffffff; - uint64_t p3l = p3 & 0xffffffff; - - uint64_t l = p1h + p2l + p3l; - uint64_t m = (p2 >> 32) + (p3 >> 32); - uint64_t h = (l >> 32) + m + p4; - - return h; -} - -#else // Not OpenCL, ISPC, or CUDA, but plain C. -static uint8_t futrts_umul_hi8(uint8_t a, uint8_t b) { return ((uint16_t)a) * ((uint16_t)b) >> 8; } -static uint16_t futrts_umul_hi16(uint16_t a, uint16_t b) { return ((uint32_t)a) * ((uint32_t)b) >> 16; } -static uint32_t futrts_umul_hi32(uint32_t a, uint32_t b) { return ((uint64_t)a) * ((uint64_t)b) >> 32; } -static uint64_t futrts_umul_hi64(uint64_t a, uint64_t b) { return ((__uint128_t)a) * ((__uint128_t)b) >> 64; } -static int8_t futrts_smul_hi8(int8_t a, int8_t b) { return ((int16_t)a) * ((int16_t)b) >> 8; } -static int16_t futrts_smul_hi16(int16_t a, int16_t b) { return ((int32_t)a) * ((int32_t)b) >> 16; } -static int32_t futrts_smul_hi32(int32_t a, int32_t b) { return ((int64_t)a) * ((int64_t)b) >> 32; } -static int64_t futrts_smul_hi64(int64_t a, int64_t b) { return ((__int128_t)a) * ((__int128_t)b) >> 64; } -#endif - -#if defined(__OPENCL_VERSION__) -static uint8_t futrts_umad_hi8 ( uint8_t a, uint8_t b, uint8_t c) { return mad_hi(a, b, c); } -static uint16_t futrts_umad_hi16(uint16_t a, uint16_t b, uint16_t c) { return mad_hi(a, b, c); } -static uint32_t futrts_umad_hi32(uint32_t a, uint32_t b, uint32_t c) { return mad_hi(a, b, c); } -static uint64_t futrts_umad_hi64(uint64_t a, uint64_t b, uint64_t c) { return mad_hi(a, b, c); } -static uint8_t futrts_smad_hi8( int8_t a, int8_t b, int8_t c) { return mad_hi(a, b, c); } -static uint16_t futrts_smad_hi16(int16_t a, int16_t b, int16_t c) { return mad_hi(a, b, c); } -static uint32_t futrts_smad_hi32(int32_t a, int32_t b, int32_t c) { return mad_hi(a, b, c); } -static uint64_t futrts_smad_hi64(int64_t a, int64_t b, int64_t c) { return mad_hi(a, b, c); } -#else // Not OpenCL - -static uint8_t futrts_umad_hi8( uint8_t a, uint8_t b, uint8_t c) { return futrts_umul_hi8(a, b) + c; } -static uint16_t futrts_umad_hi16(uint16_t a, uint16_t b, uint16_t c) { return futrts_umul_hi16(a, b) + c; } -static uint32_t futrts_umad_hi32(uint32_t a, uint32_t b, uint32_t c) { return futrts_umul_hi32(a, b) + c; } -static uint64_t futrts_umad_hi64(uint64_t a, uint64_t b, uint64_t c) { return futrts_umul_hi64(a, b) + c; } -static uint8_t futrts_smad_hi8 ( int8_t a, int8_t b, int8_t c) { return futrts_smul_hi8(a, b) + c; } -static uint16_t futrts_smad_hi16(int16_t a, int16_t b, int16_t c) { return futrts_smul_hi16(a, b) + c; } -static uint32_t futrts_smad_hi32(int32_t a, int32_t b, int32_t c) { return futrts_smul_hi32(a, b) + c; } -static uint64_t futrts_smad_hi64(int64_t a, int64_t b, int64_t c) { return futrts_smul_hi64(a, b) + c; } -#endif - -#if defined(__OPENCL_VERSION__) -static int32_t futrts_clzz8(int8_t x) { - return clz(x); -} - -static int32_t futrts_clzz16(int16_t x) { - return clz(x); -} - -static int32_t futrts_clzz32(int32_t x) { - return clz(x); -} - -static int32_t futrts_clzz64(int64_t x) { - return clz(x); -} - -#elif defined(__CUDA_ARCH__) - -static int32_t futrts_clzz8(int8_t x) { - return __clz(zext_i8_i32(x)) - 24; -} - -static int32_t futrts_clzz16(int16_t x) { - return __clz(zext_i16_i32(x)) - 16; -} - -static int32_t futrts_clzz32(int32_t x) { - return __clz(x); -} - -static int32_t futrts_clzz64(int64_t x) { - return __clzll(x); -} - -#elif ISPC - -static int32_t futrts_clzz8(int8_t x) { - return count_leading_zeros((int32_t)(uint8_t)x)-24; -} - -static int32_t futrts_clzz16(int16_t x) { - return count_leading_zeros((int32_t)(uint16_t)x)-16; -} - -static int32_t futrts_clzz32(int32_t x) { - return count_leading_zeros(x); -} - -static int32_t futrts_clzz64(int64_t x) { - return count_leading_zeros(x); -} - -#else // Not OpenCL, ISPC or CUDA, but plain C. - -static int32_t futrts_clzz8(int8_t x) { - return x == 0 ? 8 : __builtin_clz((uint32_t)zext_i8_i32(x)) - 24; -} - -static int32_t futrts_clzz16(int16_t x) { - return x == 0 ? 16 : __builtin_clz((uint32_t)zext_i16_i32(x)) - 16; -} - -static int32_t futrts_clzz32(int32_t x) { - return x == 0 ? 32 : __builtin_clz((uint32_t)x); -} - -static int32_t futrts_clzz64(int64_t x) { - return x == 0 ? 64 : __builtin_clzll((uint64_t)x); -} -#endif - -#if defined(__OPENCL_VERSION__) -static int32_t futrts_ctzz8(int8_t x) { - int i = 0; - for (; i < 8 && (x & 1) == 0; i++, x >>= 1) - ; - return i; -} - -static int32_t futrts_ctzz16(int16_t x) { - int i = 0; - for (; i < 16 && (x & 1) == 0; i++, x >>= 1) - ; - return i; -} - -static int32_t futrts_ctzz32(int32_t x) { - int i = 0; - for (; i < 32 && (x & 1) == 0; i++, x >>= 1) - ; - return i; -} - -static int32_t futrts_ctzz64(int64_t x) { - int i = 0; - for (; i < 64 && (x & 1) == 0; i++, x >>= 1) - ; - return i; -} - -#elif defined(__CUDA_ARCH__) - -static int32_t futrts_ctzz8(int8_t x) { - int y = __ffs(x); - return y == 0 ? 8 : y - 1; -} - -static int32_t futrts_ctzz16(int16_t x) { - int y = __ffs(x); - return y == 0 ? 16 : y - 1; -} - -static int32_t futrts_ctzz32(int32_t x) { - int y = __ffs(x); - return y == 0 ? 32 : y - 1; -} - -static int32_t futrts_ctzz64(int64_t x) { - int y = __ffsll(x); - return y == 0 ? 64 : y - 1; -} - -#elif ISPC - -static int32_t futrts_ctzz8(int8_t x) { - return x == 0 ? 8 : count_trailing_zeros((int32_t)x); -} - -static int32_t futrts_ctzz16(int16_t x) { - return x == 0 ? 16 : count_trailing_zeros((int32_t)x); -} - -static int32_t futrts_ctzz32(int32_t x) { - return count_trailing_zeros(x); -} - -static int32_t futrts_ctzz64(int64_t x) { - return count_trailing_zeros(x); -} - -#else // Not OpenCL or CUDA, but plain C. - -static int32_t futrts_ctzz8(int8_t x) { - return x == 0 ? 8 : __builtin_ctz((uint32_t)x); -} - -static int32_t futrts_ctzz16(int16_t x) { - return x == 0 ? 16 : __builtin_ctz((uint32_t)x); -} - -static int32_t futrts_ctzz32(int32_t x) { - return x == 0 ? 32 : __builtin_ctz((uint32_t)x); -} - -static int32_t futrts_ctzz64(int64_t x) { - return x == 0 ? 64 : __builtin_ctzll((uint64_t)x); -} -#endif - -static inline float fdiv32(float x, float y) { - return x / y; -} - -static inline float fadd32(float x, float y) { - return x + y; -} - -static inline float fsub32(float x, float y) { - return x - y; -} - -static inline float fmul32(float x, float y) { - return x * y; -} - -static inline bool cmplt32(float x, float y) { - return x < y; -} - -static inline bool cmple32(float x, float y) { - return x <= y; -} - -static inline float sitofp_i8_f32(int8_t x) { - return (float) x; -} - -static inline float sitofp_i16_f32(int16_t x) { - return (float) x; -} - -static inline float sitofp_i32_f32(int32_t x) { - return (float) x; -} - -static inline float sitofp_i64_f32(int64_t x) { - return (float) x; -} - -static inline float uitofp_i8_f32(uint8_t x) { - return (float) x; -} - -static inline float uitofp_i16_f32(uint16_t x) { - return (float) x; -} - -static inline float uitofp_i32_f32(uint32_t x) { - return (float) x; -} - -static inline float uitofp_i64_f32(uint64_t x) { - return (float) x; -} - -#ifdef __OPENCL_VERSION__ -static inline float fabs32(float x) { - return fabs(x); -} - -static inline float fmax32(float x, float y) { - return fmax(x, y); -} - -static inline float fmin32(float x, float y) { - return fmin(x, y); -} - -static inline float fpow32(float x, float y) { - return pow(x, y); -} - -#elif ISPC - -static inline float fabs32(float x) { - return abs(x); -} - -static inline float fmax32(float x, float y) { - return isnan(x) ? y : isnan(y) ? x : max(x, y); -} - -static inline float fmin32(float x, float y) { - return isnan(x) ? y : isnan(y) ? x : min(x, y); -} - -static inline float fpow32(float a, float b) { - float ret; - foreach_active (i) { - uniform float r = __stdlib_powf(extract(a, i), extract(b, i)); - ret = insert(ret, i, r); - } - return ret; -} - -#else // Not OpenCL, but CUDA or plain C. - -static inline float fabs32(float x) { - return fabsf(x); -} - -static inline float fmax32(float x, float y) { - return fmaxf(x, y); -} - -static inline float fmin32(float x, float y) { - return fminf(x, y); -} - -static inline float fpow32(float x, float y) { - return powf(x, y); -} -#endif - -static inline bool futrts_isnan32(float x) { - return isnan(x); -} - -#if ISPC - -static inline bool futrts_isinf32(float x) { - return !isnan(x) && isnan(x - x); -} - -static inline bool futrts_isfinite32(float x) { - return !isnan(x) && !futrts_isinf32(x); -} - -#else - -static inline bool futrts_isinf32(float x) { - return isinf(x); -} - -#endif - -static inline int8_t fptosi_f32_i8(float x) { - if (futrts_isnan32(x) || futrts_isinf32(x)) { - return 0; - } else { - return (int8_t) x; - } -} - -static inline int16_t fptosi_f32_i16(float x) { - if (futrts_isnan32(x) || futrts_isinf32(x)) { - return 0; - } else { - return (int16_t) x; - } -} - -static inline int32_t fptosi_f32_i32(float x) { - if (futrts_isnan32(x) || futrts_isinf32(x)) { - return 0; - } else { - return (int32_t) x; - } -} - -static inline int64_t fptosi_f32_i64(float x) { - if (futrts_isnan32(x) || futrts_isinf32(x)) { - return 0; - } else { - return (int64_t) x; - }; -} - -static inline uint8_t fptoui_f32_i8(float x) { - if (futrts_isnan32(x) || futrts_isinf32(x)) { - return 0; - } else { - return (uint8_t) (int8_t) x; - } -} - -static inline uint16_t fptoui_f32_i16(float x) { - if (futrts_isnan32(x) || futrts_isinf32(x)) { - return 0; - } else { - return (uint16_t) (int16_t) x; - } -} - -static inline uint32_t fptoui_f32_i32(float x) { - if (futrts_isnan32(x) || futrts_isinf32(x)) { - return 0; - } else { - return (uint32_t) (int32_t) x; - } -} - -static inline uint64_t fptoui_f32_i64(float x) { - if (futrts_isnan32(x) || futrts_isinf32(x)) { - return 0; - } else { - return (uint64_t) (int64_t) x; - } -} - -static inline bool ftob_f32_bool(float x) { - return x != 0; -} - -static inline float btof_bool_f32(bool x) { - return x ? 1 : 0; -} - -#ifdef __OPENCL_VERSION__ -static inline float futrts_log32(float x) { - return log(x); -} - -static inline float futrts_log2_32(float x) { - return log2(x); -} - -static inline float futrts_log10_32(float x) { - return log10(x); -} - -static inline float futrts_log1p_32(float x) { - return log1p(x); -} - -static inline float futrts_sqrt32(float x) { - return sqrt(x); -} - -static inline float futrts_cbrt32(float x) { - return cbrt(x); -} - -static inline float futrts_exp32(float x) { - return exp(x); -} - -static inline float futrts_cos32(float x) { - return cos(x); -} - -static inline float futrts_sin32(float x) { - return sin(x); -} - -static inline float futrts_tan32(float x) { - return tan(x); -} - -static inline float futrts_acos32(float x) { - return acos(x); -} - -static inline float futrts_asin32(float x) { - return asin(x); -} - -static inline float futrts_atan32(float x) { - return atan(x); -} - -static inline float futrts_cosh32(float x) { - return cosh(x); -} - -static inline float futrts_sinh32(float x) { - return sinh(x); -} - -static inline float futrts_tanh32(float x) { - return tanh(x); -} - -static inline float futrts_acosh32(float x) { - return acosh(x); -} - -static inline float futrts_asinh32(float x) { - return asinh(x); -} - -static inline float futrts_atanh32(float x) { - return atanh(x); -} - -static inline float futrts_atan2_32(float x, float y) { - return atan2(x, y); -} - -static inline float futrts_hypot32(float x, float y) { - return hypot(x, y); -} - -static inline float futrts_gamma32(float x) { - return tgamma(x); -} - -static inline float futrts_lgamma32(float x) { - return lgamma(x); -} - -static inline float futrts_erf32(float x) { - return erf(x); -} - -static inline float futrts_erfc32(float x) { - return erfc(x); -} - -static inline float fmod32(float x, float y) { - return fmod(x, y); -} - -static inline float futrts_round32(float x) { - return rint(x); -} - -static inline float futrts_floor32(float x) { - return floor(x); -} - -static inline float futrts_ceil32(float x) { - return ceil(x); -} - -static inline float futrts_nextafter32(float x, float y) { - return nextafter(x, y); -} - -static inline float futrts_lerp32(float v0, float v1, float t) { - return mix(v0, v1, t); -} - -static inline float futrts_mad32(float a, float b, float c) { - return mad(a, b, c); -} - -static inline float futrts_fma32(float a, float b, float c) { - return fma(a, b, c); -} - -#elif ISPC - -static inline float futrts_log32(float x) { - return futrts_isfinite32(x) || (futrts_isinf32(x) && x < 0)? log(x) : x; -} - -static inline float futrts_log2_32(float x) { - return futrts_log32(x) / log(2.0f); -} - -static inline float futrts_log10_32(float x) { - return futrts_log32(x) / log(10.0f); -} - -static inline float futrts_log1p_32(float x) { - if(x == -1.0f || (futrts_isinf32(x) && x > 0.0f)) return x / 0.0f; - float y = 1.0f + x; - float z = y - 1.0f; - return log(y) - (z-x)/y; -} - -static inline float futrts_sqrt32(float x) { - return sqrt(x); -} - -extern "C" unmasked uniform float cbrtf(uniform float); -static inline float futrts_cbrt32(float x) { - float res; - foreach_active (i) { - uniform float r = cbrtf(extract(x, i)); - res = insert(res, i, r); - } - return res; -} - -static inline float futrts_exp32(float x) { - return exp(x); -} - -static inline float futrts_cos32(float x) { - return cos(x); -} - -static inline float futrts_sin32(float x) { - return sin(x); -} - -static inline float futrts_tan32(float x) { - return tan(x); -} - -static inline float futrts_acos32(float x) { - return acos(x); -} - -static inline float futrts_asin32(float x) { - return asin(x); -} - -static inline float futrts_atan32(float x) { - return atan(x); -} - -static inline float futrts_cosh32(float x) { - return (exp(x)+exp(-x)) / 2.0f; -} - -static inline float futrts_sinh32(float x) { - return (exp(x)-exp(-x)) / 2.0f; -} - -static inline float futrts_tanh32(float x) { - return futrts_sinh32(x)/futrts_cosh32(x); -} - -static inline float futrts_acosh32(float x) { - float f = x+sqrt(x*x-1); - if(futrts_isfinite32(f)) return log(f); - return f; -} - -static inline float futrts_asinh32(float x) { - float f = x+sqrt(x*x+1); - if(futrts_isfinite32(f)) return log(f); - return f; - -} - -static inline float futrts_atanh32(float x) { - float f = (1+x)/(1-x); - if(futrts_isfinite32(f)) return log(f)/2.0f; - return f; - -} - -static inline float futrts_atan2_32(float x, float y) { - return (x == 0.0f && y == 0.0f) ? 0.0f : atan2(x, y); -} - -static inline float futrts_hypot32(float x, float y) { - if (futrts_isfinite32(x) && futrts_isfinite32(y)) { - x = abs(x); - y = abs(y); - float a; - float b; - if (x >= y){ - a = x; - b = y; - } else { - a = y; - b = x; - } - if(b == 0){ - return a; - } - - int e; - float an; - float bn; - an = frexp (a, &e); - bn = ldexp (b, - e); - float cn; - cn = sqrt (an * an + bn * bn); - return ldexp (cn, e); - } else { - if (futrts_isinf32(x) || futrts_isinf32(y)) return INFINITY; - else return x + y; - } - -} - -extern "C" unmasked uniform float tgammaf(uniform float x); -static inline float futrts_gamma32(float x) { - float res; - foreach_active (i) { - uniform float r = tgammaf(extract(x, i)); - res = insert(res, i, r); - } - return res; -} - -extern "C" unmasked uniform float lgammaf(uniform float x); -static inline float futrts_lgamma32(float x) { - float res; - foreach_active (i) { - uniform float r = lgammaf(extract(x, i)); - res = insert(res, i, r); - } - return res; -} - -extern "C" unmasked uniform float erff(uniform float x); -static inline float futrts_erf32(float x) { - float res; - foreach_active (i) { - uniform float r = erff(extract(x, i)); - res = insert(res, i, r); - } - return res; -} - -extern "C" unmasked uniform float erfcf(uniform float x); -static inline float futrts_erfc32(float x) { - float res; - foreach_active (i) { - uniform float r = erfcf(extract(x, i)); - res = insert(res, i, r); - } - return res; -} - -static inline float fmod32(float x, float y) { - return x - y * trunc(x/y); -} - -static inline float futrts_round32(float x) { - return round(x); -} - -static inline float futrts_floor32(float x) { - return floor(x); -} - -static inline float futrts_ceil32(float x) { - return ceil(x); -} - -extern "C" unmasked uniform float nextafterf(uniform float x, uniform float y); -static inline float futrts_nextafter32(float x, float y) { - float res; - foreach_active (i) { - uniform float r = nextafterf(extract(x, i), extract(y, i)); - res = insert(res, i, r); - } - return res; -} - -static inline float futrts_lerp32(float v0, float v1, float t) { - return v0 + (v1 - v0) * t; -} - -static inline float futrts_mad32(float a, float b, float c) { - return a * b + c; -} - -static inline float futrts_fma32(float a, float b, float c) { - return a * b + c; -} - -#else // Not OpenCL or ISPC, but CUDA or plain C. - -static inline float futrts_log32(float x) { - return logf(x); -} - -static inline float futrts_log2_32(float x) { - return log2f(x); -} - -static inline float futrts_log10_32(float x) { - return log10f(x); -} - -static inline float futrts_log1p_32(float x) { - return log1pf(x); -} - -static inline float futrts_sqrt32(float x) { - return sqrtf(x); -} - -static inline float futrts_cbrt32(float x) { - return cbrtf(x); -} - -static inline float futrts_exp32(float x) { - return expf(x); -} - -static inline float futrts_cos32(float x) { - return cosf(x); -} - -static inline float futrts_sin32(float x) { - return sinf(x); -} - -static inline float futrts_tan32(float x) { - return tanf(x); -} - -static inline float futrts_acos32(float x) { - return acosf(x); -} - -static inline float futrts_asin32(float x) { - return asinf(x); -} - -static inline float futrts_atan32(float x) { - return atanf(x); -} - -static inline float futrts_cosh32(float x) { - return coshf(x); -} - -static inline float futrts_sinh32(float x) { - return sinhf(x); -} - -static inline float futrts_tanh32(float x) { - return tanhf(x); -} - -static inline float futrts_acosh32(float x) { - return acoshf(x); -} - -static inline float futrts_asinh32(float x) { - return asinhf(x); -} - -static inline float futrts_atanh32(float x) { - return atanhf(x); -} - -static inline float futrts_atan2_32(float x, float y) { - return atan2f(x, y); -} - -static inline float futrts_hypot32(float x, float y) { - return hypotf(x, y); -} - -static inline float futrts_gamma32(float x) { - return tgammaf(x); -} - -static inline float futrts_lgamma32(float x) { - return lgammaf(x); -} - -static inline float futrts_erf32(float x) { - return erff(x); -} - -static inline float futrts_erfc32(float x) { - return erfcf(x); -} - -static inline float fmod32(float x, float y) { - return fmodf(x, y); -} - -static inline float futrts_round32(float x) { - return rintf(x); -} - -static inline float futrts_floor32(float x) { - return floorf(x); -} - -static inline float futrts_ceil32(float x) { - return ceilf(x); -} - -static inline float futrts_nextafter32(float x, float y) { - return nextafterf(x, y); -} - -static inline float futrts_lerp32(float v0, float v1, float t) { - return v0 + (v1 - v0) * t; -} - -static inline float futrts_mad32(float a, float b, float c) { - return a * b + c; -} - -static inline float futrts_fma32(float a, float b, float c) { - return fmaf(a, b, c); -} -#endif - -#if ISPC -static inline int32_t futrts_to_bits32(float x) { - return intbits(x); -} - -static inline float futrts_from_bits32(int32_t x) { - return floatbits(x); -} -#else -static inline int32_t futrts_to_bits32(float x) { - union { - float f; - int32_t t; - } p; - - p.f = x; - return p.t; -} - -static inline float futrts_from_bits32(int32_t x) { - union { - int32_t f; - float t; - } p; - - p.f = x; - return p.t; -} -#endif - -static inline float fsignum32(float x) { - return futrts_isnan32(x) ? x : (x > 0 ? 1 : 0) - (x < 0 ? 1 : 0); -} - -#ifdef FUTHARK_F64_ENABLED - -#if ISPC -static inline bool futrts_isinf64(float x) { - return !isnan(x) && isnan(x - x); -} - -static inline bool futrts_isfinite64(float x) { - return !isnan(x) && !futrts_isinf64(x); -} - -static inline double fdiv64(double x, double y) { - return x / y; -} - -static inline double fadd64(double x, double y) { - return x + y; -} - -static inline double fsub64(double x, double y) { - return x - y; -} - -static inline double fmul64(double x, double y) { - return x * y; -} - -static inline bool cmplt64(double x, double y) { - return x < y; -} - -static inline bool cmple64(double x, double y) { - return x <= y; -} - -static inline double sitofp_i8_f64(int8_t x) { - return (double) x; -} - -static inline double sitofp_i16_f64(int16_t x) { - return (double) x; -} - -static inline double sitofp_i32_f64(int32_t x) { - return (double) x; -} - -static inline double sitofp_i64_f64(int64_t x) { - return (double) x; -} - -static inline double uitofp_i8_f64(uint8_t x) { - return (double) x; -} - -static inline double uitofp_i16_f64(uint16_t x) { - return (double) x; -} - -static inline double uitofp_i32_f64(uint32_t x) { - return (double) x; -} - -static inline double uitofp_i64_f64(uint64_t x) { - return (double) x; -} - -static inline double fabs64(double x) { - return abs(x); -} - -static inline double fmax64(double x, double y) { - return isnan(x) ? y : isnan(y) ? x : max(x, y); -} - -static inline double fmin64(double x, double y) { - return isnan(x) ? y : isnan(y) ? x : min(x, y); -} - -static inline double fpow64(double a, double b) { - float ret; - foreach_active (i) { - uniform float r = __stdlib_powf(extract(a, i), extract(b, i)); - ret = insert(ret, i, r); - } - return ret; -} - -static inline double futrts_log64(double x) { - return futrts_isfinite64(x) || (futrts_isinf64(x) && x < 0)? log(x) : x; -} - -static inline double futrts_log2_64(double x) { - return futrts_log64(x)/log(2.0d); -} - -static inline double futrts_log10_64(double x) { - return futrts_log64(x)/log(10.0d); -} - -static inline double futrts_log1p_64(double x) { - if(x == -1.0d || (futrts_isinf64(x) && x > 0.0d)) return x / 0.0d; - double y = 1.0d + x; - double z = y - 1.0d; - return log(y) - (z-x)/y; -} - -static inline double futrts_sqrt64(double x) { - return sqrt(x); -} - -extern "C" unmasked uniform double cbrt(uniform double); -static inline double futrts_cbrt64(double x) { - double res; - foreach_active (i) { - uniform double r = cbrtf(extract(x, i)); - res = insert(res, i, r); - } - return res; -} - -static inline double futrts_exp64(double x) { - return exp(x); -} - -static inline double futrts_cos64(double x) { - return cos(x); -} - -static inline double futrts_sin64(double x) { - return sin(x); -} - -static inline double futrts_tan64(double x) { - return tan(x); -} - -static inline double futrts_acos64(double x) { - return acos(x); -} - -static inline double futrts_asin64(double x) { - return asin(x); -} - -static inline double futrts_atan64(double x) { - return atan(x); -} - -static inline double futrts_cosh64(double x) { - return (exp(x)+exp(-x)) / 2.0d; -} - -static inline double futrts_sinh64(double x) { - return (exp(x)-exp(-x)) / 2.0d; -} - -static inline double futrts_tanh64(double x) { - return futrts_sinh64(x)/futrts_cosh64(x); -} - -static inline double futrts_acosh64(double x) { - double f = x+sqrt(x*x-1.0d); - if(futrts_isfinite64(f)) return log(f); - return f; -} - -static inline double futrts_asinh64(double x) { - double f = x+sqrt(x*x+1.0d); - if(futrts_isfinite64(f)) return log(f); - return f; -} - -static inline double futrts_atanh64(double x) { - double f = (1.0d+x)/(1.0d-x); - if(futrts_isfinite64(f)) return log(f)/2.0d; - return f; - -} - -static inline double futrts_atan2_64(double x, double y) { - return atan2(x, y); -} - -extern "C" unmasked uniform double hypot(uniform double x, uniform double y); -static inline double futrts_hypot64(double x, double y) { - double res; - foreach_active (i) { - uniform double r = hypot(extract(x, i), extract(y, i)); - res = insert(res, i, r); - } - return res; -} - -extern "C" unmasked uniform double tgamma(uniform double x); -static inline double futrts_gamma64(double x) { - double res; - foreach_active (i) { - uniform double r = tgamma(extract(x, i)); - res = insert(res, i, r); - } - return res; -} - -extern "C" unmasked uniform double lgamma(uniform double x); -static inline double futrts_lgamma64(double x) { - double res; - foreach_active (i) { - uniform double r = lgamma(extract(x, i)); - res = insert(res, i, r); - } - return res; -} - -extern "C" unmasked uniform double erf(uniform double x); -static inline double futrts_erf64(double x) { - double res; - foreach_active (i) { - uniform double r = erf(extract(x, i)); - res = insert(res, i, r); - } - return res; -} - -extern "C" unmasked uniform double erfc(uniform double x); -static inline double futrts_erfc64(double x) { - double res; - foreach_active (i) { - uniform double r = erfc(extract(x, i)); - res = insert(res, i, r); - } - return res; -} - -static inline double futrts_fma64(double a, double b, double c) { - return a * b + c; -} - -static inline double futrts_round64(double x) { - return round(x); -} - -static inline double futrts_ceil64(double x) { - return ceil(x); -} - -extern "C" unmasked uniform double nextafter(uniform float x, uniform double y); -static inline float futrts_nextafter64(double x, double y) { - double res; - foreach_active (i) { - uniform double r = nextafter(extract(x, i), extract(y, i)); - res = insert(res, i, r); - } - return res; -} - -static inline double futrts_floor64(double x) { - return floor(x); -} - -static inline bool futrts_isnan64(double x) { - return isnan(x); -} - -static inline int8_t fptosi_f64_i8(double x) { - if (futrts_isnan64(x) || futrts_isinf64(x)) { - return 0; - } else { - return (int8_t) x; - } -} - -static inline int16_t fptosi_f64_i16(double x) { - if (futrts_isnan64(x) || futrts_isinf64(x)) { - return 0; - } else { - return (int16_t) x; - } -} - -static inline int32_t fptosi_f64_i32(double x) { - if (futrts_isnan64(x) || futrts_isinf64(x)) { - return 0; - } else { - return (int32_t) x; - } -} - -static inline int64_t fptosi_f64_i64(double x) { - if (futrts_isnan64(x) || futrts_isinf64(x)) { - return 0; - } else { - return (int64_t) x; - } -} - -static inline uint8_t fptoui_f64_i8(double x) { - if (futrts_isnan64(x) || futrts_isinf64(x)) { - return 0; - } else { - return (uint8_t) (int8_t) x; - } -} - -static inline uint16_t fptoui_f64_i16(double x) { - if (futrts_isnan64(x) || futrts_isinf64(x)) { - return 0; - } else { - return (uint16_t) (int16_t) x; - } -} - -static inline uint32_t fptoui_f64_i32(double x) { - if (futrts_isnan64(x) || futrts_isinf64(x)) { - return 0; - } else { - return (uint32_t) (int32_t) x; - } -} - -static inline uint64_t fptoui_f64_i64(double x) { - if (futrts_isnan64(x) || futrts_isinf64(x)) { - return 0; - } else { - return (uint64_t) (int64_t) x; - } -} - -static inline bool ftob_f64_bool(double x) { - return x != 0.0; -} - -static inline double btof_bool_f64(bool x) { - return x ? 1.0 : 0.0; -} - -static inline int64_t futrts_to_bits64(double x) { - int64_t res; - foreach_active (i) { - uniform double tmp = extract(x, i); - uniform int64_t r = *((uniform int64_t* uniform)&tmp); - res = insert(res, i, r); - } - return res; -} - -static inline double futrts_from_bits64(int64_t x) { - double res; - foreach_active (i) { - uniform int64_t tmp = extract(x, i); - uniform double r = *((uniform double* uniform)&tmp); - res = insert(res, i, r); - } - return res; -} - -static inline double fmod64(double x, double y) { - return x - y * trunc(x/y); -} - -static inline double fsignum64(double x) { - return futrts_isnan64(x) ? x : (x > 0 ? 1.0d : 0.0d) - (x < 0 ? 1.0d : 0.0d); -} - -static inline double futrts_lerp64(double v0, double v1, double t) { - return v0 + (v1 - v0) * t; -} - -static inline double futrts_mad64(double a, double b, double c) { - return a * b + c; -} - -static inline float fpconv_f32_f32(float x) { - return (float) x; -} - -static inline double fpconv_f32_f64(float x) { - return (double) x; -} - -static inline float fpconv_f64_f32(double x) { - return (float) x; -} - -static inline double fpconv_f64_f64(double x) { - return (double) x; -} - -#else - -static inline double fdiv64(double x, double y) { - return x / y; -} - -static inline double fadd64(double x, double y) { - return x + y; -} - -static inline double fsub64(double x, double y) { - return x - y; -} - -static inline double fmul64(double x, double y) { - return x * y; -} - -static inline bool cmplt64(double x, double y) { - return x < y; -} - -static inline bool cmple64(double x, double y) { - return x <= y; -} - -static inline double sitofp_i8_f64(int8_t x) { - return (double) x; -} - -static inline double sitofp_i16_f64(int16_t x) { - return (double) x; -} - -static inline double sitofp_i32_f64(int32_t x) { - return (double) x; -} - -static inline double sitofp_i64_f64(int64_t x) { - return (double) x; -} - -static inline double uitofp_i8_f64(uint8_t x) { - return (double) x; -} - -static inline double uitofp_i16_f64(uint16_t x) { - return (double) x; -} - -static inline double uitofp_i32_f64(uint32_t x) { - return (double) x; -} - -static inline double uitofp_i64_f64(uint64_t x) { - return (double) x; -} - -static inline double fabs64(double x) { - return fabs(x); -} - -static inline double fmax64(double x, double y) { - return fmax(x, y); -} - -static inline double fmin64(double x, double y) { - return fmin(x, y); -} - -static inline double fpow64(double x, double y) { - return pow(x, y); -} - -static inline double futrts_log64(double x) { - return log(x); -} - -static inline double futrts_log2_64(double x) { - return log2(x); -} - -static inline double futrts_log10_64(double x) { - return log10(x); -} - -static inline double futrts_log1p_64(double x) { - return log1p(x); -} - -static inline double futrts_sqrt64(double x) { - return sqrt(x); -} - -static inline double futrts_cbrt64(double x) { - return cbrt(x); -} - -static inline double futrts_exp64(double x) { - return exp(x); -} - -static inline double futrts_cos64(double x) { - return cos(x); -} - -static inline double futrts_sin64(double x) { - return sin(x); -} - -static inline double futrts_tan64(double x) { - return tan(x); -} - -static inline double futrts_acos64(double x) { - return acos(x); -} - -static inline double futrts_asin64(double x) { - return asin(x); -} - -static inline double futrts_atan64(double x) { - return atan(x); -} - -static inline double futrts_cosh64(double x) { - return cosh(x); -} - -static inline double futrts_sinh64(double x) { - return sinh(x); -} - -static inline double futrts_tanh64(double x) { - return tanh(x); -} - -static inline double futrts_acosh64(double x) { - return acosh(x); -} - -static inline double futrts_asinh64(double x) { - return asinh(x); -} - -static inline double futrts_atanh64(double x) { - return atanh(x); -} - -static inline double futrts_atan2_64(double x, double y) { - return atan2(x, y); -} - -static inline double futrts_hypot64(double x, double y) { - return hypot(x, y); -} - -static inline double futrts_gamma64(double x) { - return tgamma(x); -} - -static inline double futrts_lgamma64(double x) { - return lgamma(x); -} - -static inline double futrts_erf64(double x) { - return erf(x); -} - -static inline double futrts_erfc64(double x) { - return erfc(x); -} - -static inline double futrts_fma64(double a, double b, double c) { - return fma(a, b, c); -} - -static inline double futrts_round64(double x) { - return rint(x); -} - -static inline double futrts_ceil64(double x) { - return ceil(x); -} - -static inline float futrts_nextafter64(float x, float y) { - return nextafter(x, y); -} - -static inline double futrts_floor64(double x) { - return floor(x); -} - -static inline bool futrts_isnan64(double x) { - return isnan(x); -} - -static inline bool futrts_isinf64(double x) { - return isinf(x); -} - -static inline int8_t fptosi_f64_i8(double x) { - if (futrts_isnan64(x) || futrts_isinf64(x)) { - return 0; - } else { - return (int8_t) x; - } -} - -static inline int16_t fptosi_f64_i16(double x) { - if (futrts_isnan64(x) || futrts_isinf64(x)) { - return 0; - } else { - return (int16_t) x; - } -} - -static inline int32_t fptosi_f64_i32(double x) { - if (futrts_isnan64(x) || futrts_isinf64(x)) { - return 0; - } else { - return (int32_t) x; - } -} - -static inline int64_t fptosi_f64_i64(double x) { - if (futrts_isnan64(x) || futrts_isinf64(x)) { - return 0; - } else { - return (int64_t) x; - } -} - -static inline uint8_t fptoui_f64_i8(double x) { - if (futrts_isnan64(x) || futrts_isinf64(x)) { - return 0; - } else { - return (uint8_t) (int8_t) x; - } -} - -static inline uint16_t fptoui_f64_i16(double x) { - if (futrts_isnan64(x) || futrts_isinf64(x)) { - return 0; - } else { - return (uint16_t) (int16_t) x; - } -} - -static inline uint32_t fptoui_f64_i32(double x) { - if (futrts_isnan64(x) || futrts_isinf64(x)) { - return 0; - } else { - return (uint32_t) (int32_t) x; - } -} - -static inline uint64_t fptoui_f64_i64(double x) { - if (futrts_isnan64(x) || futrts_isinf64(x)) { - return 0; - } else { - return (uint64_t) (int64_t) x; - } -} - -static inline bool ftob_f64_bool(double x) { - return x != 0; -} - -static inline double btof_bool_f64(bool x) { - return x ? 1 : 0; -} - -static inline int64_t futrts_to_bits64(double x) { - union { - double f; - int64_t t; - } p; - - p.f = x; - return p.t; -} - -static inline double futrts_from_bits64(int64_t x) { - union { - int64_t f; - double t; - } p; - - p.f = x; - return p.t; -} - -static inline double fmod64(double x, double y) { - return fmod(x, y); -} - -static inline double fsignum64(double x) { - return futrts_isnan64(x) ? x : (x > 0) - (x < 0); -} - -static inline double futrts_lerp64(double v0, double v1, double t) { -#ifdef __OPENCL_VERSION__ - return mix(v0, v1, t); -#else - return v0 + (v1 - v0) * t; -#endif -} - -static inline double futrts_mad64(double a, double b, double c) { -#ifdef __OPENCL_VERSION__ - return mad(a, b, c); -#else - return a * b + c; -#endif -} - -static inline float fpconv_f32_f32(float x) { - return (float) x; -} - -static inline double fpconv_f32_f64(float x) { - return (double) x; -} - -static inline float fpconv_f64_f32(double x) { - return (float) x; -} - -static inline double fpconv_f64_f64(double 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; +} + +SCALAR_FUN_ATTR uint32_t add32(uint32_t x, uint32_t y) { + return x + y; +} + +SCALAR_FUN_ATTR uint64_t add64(uint64_t x, uint64_t y) { + return x + y; +} + +SCALAR_FUN_ATTR uint8_t sub8(uint8_t x, uint8_t y) { + return x - y; +} + +SCALAR_FUN_ATTR uint16_t sub16(uint16_t x, uint16_t y) { + return x - y; +} + +SCALAR_FUN_ATTR uint32_t sub32(uint32_t x, uint32_t y) { + return x - y; +} + +SCALAR_FUN_ATTR uint64_t sub64(uint64_t x, uint64_t y) { + return x - y; +} + +SCALAR_FUN_ATTR uint8_t mul8(uint8_t x, uint8_t y) { + return x * y; +} + +SCALAR_FUN_ATTR uint16_t mul16(uint16_t x, uint16_t y) { + return x * y; +} + +SCALAR_FUN_ATTR uint32_t mul32(uint32_t x, uint32_t y) { + return x * y; +} + +SCALAR_FUN_ATTR uint64_t mul64(uint64_t x, uint64_t y) { + return x * y; +} + +#if ISPC + +SCALAR_FUN_ATTR uint8_t udiv8(uint8_t x, uint8_t y) { + // This strange pattern is used to prevent the ISPC compiler from + // causing SIGFPEs and bogus results on divisions where inactive lanes + // have 0-valued divisors. It ensures that any inactive lane instead + // has a divisor of 1. https://github.com/ispc/ispc/issues/2292 + uint8_t ys = 1; + foreach_active(i){ + ys = y; + } + + return x / ys; +} + +SCALAR_FUN_ATTR uint16_t udiv16(uint16_t x, uint16_t y) { + uint16_t ys = 1; + foreach_active(i){ + ys = y; + } + + return x / ys; +} + +SCALAR_FUN_ATTR uint32_t udiv32(uint32_t x, uint32_t y) { + uint32_t ys = 1; + foreach_active(i){ + ys = y; + } + + + return x / ys; +} + +SCALAR_FUN_ATTR uint64_t udiv64(uint64_t x, uint64_t y) { + uint64_t ys = 1; + foreach_active(i){ + ys = y; + } + + + return x / ys; +} + +SCALAR_FUN_ATTR uint8_t udiv_up8(uint8_t x, uint8_t y) { + uint8_t ys = 1; + foreach_active(i){ + ys = y; + } + + + return (x + y - 1) / ys; +} + +SCALAR_FUN_ATTR uint16_t udiv_up16(uint16_t x, uint16_t y) { + uint16_t ys = 1; + foreach_active(i){ + ys = y; + } + + return (x + y - 1) / ys; +} + +SCALAR_FUN_ATTR uint32_t udiv_up32(uint32_t x, uint32_t y) { + uint32_t ys = 1; + foreach_active(i){ + ys = y; + } + + return (x + y - 1) / ys; +} + +SCALAR_FUN_ATTR uint64_t udiv_up64(uint64_t x, uint64_t y) { + uint64_t ys = 1; + foreach_active(i){ + ys = y; + } + + return (x + y - 1) / ys; +} + +SCALAR_FUN_ATTR uint8_t umod8(uint8_t x, uint8_t y) { + uint8_t ys = 1; + foreach_active(i){ + ys = y; + } + + return x % ys; +} + +SCALAR_FUN_ATTR uint16_t umod16(uint16_t x, uint16_t y) { + uint16_t ys = 1; + foreach_active(i){ + ys = y; + } + + + return x % ys; +} + +SCALAR_FUN_ATTR uint32_t umod32(uint32_t x, uint32_t y) { + uint32_t ys = 1; + foreach_active(i){ + ys = y; + } + + return x % ys; +} + +SCALAR_FUN_ATTR uint64_t umod64(uint64_t x, uint64_t y) { + uint64_t ys = 1; + foreach_active(i){ + ys = y; + } + + return x % ys; +} + +SCALAR_FUN_ATTR uint8_t udiv_safe8(uint8_t x, uint8_t y) { + uint8_t ys = 1; + foreach_active(i){ + ys = y; + } + + return y == 0 ? 0 : x / ys; +} + +SCALAR_FUN_ATTR uint16_t udiv_safe16(uint16_t x, uint16_t y) { + uint16_t ys = 1; + foreach_active(i){ + ys = y; + } + + return y == 0 ? 0 : x / ys; +} + +SCALAR_FUN_ATTR uint32_t udiv_safe32(uint32_t x, uint32_t y) { + uint32_t ys = 1; + foreach_active(i){ + ys = y; + } + + return y == 0 ? 0 : x / ys; +} + +SCALAR_FUN_ATTR uint64_t udiv_safe64(uint64_t x, uint64_t y) { + uint64_t ys = 1; + foreach_active(i){ + ys = y; + } + + return y == 0 ? 0 : x / ys; +} + +SCALAR_FUN_ATTR uint8_t udiv_up_safe8(uint8_t x, uint8_t y) { + uint8_t ys = 1; + foreach_active(i){ + ys = y; + } + + return y == 0 ? 0 : (x + y - 1) / ys; +} + +SCALAR_FUN_ATTR uint16_t udiv_up_safe16(uint16_t x, uint16_t y) { + uint16_t ys = 1; + foreach_active(i){ + ys = y; + } + + return y == 0 ? 0 : (x + y - 1) / ys; +} + +SCALAR_FUN_ATTR uint32_t udiv_up_safe32(uint32_t x, uint32_t y) { + uint32_t ys = 1; + foreach_active(i){ + ys = y; + } + + return y == 0 ? 0 : (x + y - 1) / ys; +} + +SCALAR_FUN_ATTR uint64_t udiv_up_safe64(uint64_t x, uint64_t y) { + uint64_t ys = 1; + foreach_active(i){ + ys = y; + } + + return y == 0 ? 0 : (x + y - 1) / ys; +} + +SCALAR_FUN_ATTR uint8_t umod_safe8(uint8_t x, uint8_t y) { + uint8_t ys = 1; + foreach_active(i){ + ys = y; + } + + return y == 0 ? 0 : x % ys; +} + +SCALAR_FUN_ATTR uint16_t umod_safe16(uint16_t x, uint16_t y) { + uint16_t ys = 1; + foreach_active(i){ + ys = y; + } + + return y == 0 ? 0 : x % ys; +} + +SCALAR_FUN_ATTR uint32_t umod_safe32(uint32_t x, uint32_t y) { + uint32_t ys = 1; + foreach_active(i){ + ys = y; + } + + return y == 0 ? 0 : x % ys; +} + +SCALAR_FUN_ATTR uint64_t umod_safe64(uint64_t x, uint64_t y) { + uint64_t ys = 1; + foreach_active(i){ + ys = y; + } + + return y == 0 ? 0 : x % ys; +} + +SCALAR_FUN_ATTR int8_t sdiv8(int8_t x, int8_t y) { + int8_t ys = 1; + foreach_active(i){ + ys = y; + } + + int8_t q = x / ys; + int8_t r = x % ys; + + return q - ((r != 0 && r < 0 != y < 0) ? 1 : 0); +} + +SCALAR_FUN_ATTR int16_t sdiv16(int16_t x, int16_t y) { + int16_t ys = 1; + foreach_active(i){ + ys = y; + } + + int16_t q = x / ys; + int16_t r = x % ys; + + return q - ((r != 0 && r < 0 != y < 0) ? 1 : 0); +} + +SCALAR_FUN_ATTR int32_t sdiv32(int32_t x, int32_t y) { + int32_t ys = 1; + foreach_active(i){ + ys = y; + } + int32_t q = x / ys; + int32_t r = x % ys; + + return q - ((r != 0 && r < 0 != y < 0) ? 1 : 0); +} + +SCALAR_FUN_ATTR int64_t sdiv64(int64_t x, int64_t y) { + int64_t ys = 1; + foreach_active(i){ + ys = y; + } + + int64_t q = x / ys; + int64_t r = x % ys; + + return q - ((r != 0 && r < 0 != y < 0) ? 1 : 0); +} + +SCALAR_FUN_ATTR int8_t sdiv_up8(int8_t x, int8_t y) { + return sdiv8(x + y - 1, y); +} + +SCALAR_FUN_ATTR int16_t sdiv_up16(int16_t x, int16_t y) { + return sdiv16(x + y - 1, y); +} + +SCALAR_FUN_ATTR int32_t sdiv_up32(int32_t x, int32_t y) { + return sdiv32(x + y - 1, y); +} + +SCALAR_FUN_ATTR int64_t sdiv_up64(int64_t x, int64_t y) { + return sdiv64(x + y - 1, y); +} + +SCALAR_FUN_ATTR int8_t smod8(int8_t x, int8_t y) { + int8_t ys = 1; + foreach_active(i){ + ys = y; + } + + int8_t r = x % ys; + + return r + (r == 0 || (x > 0 && y > 0) || (x < 0 && y < 0) ? 0 : y); +} + +SCALAR_FUN_ATTR int16_t smod16(int16_t x, int16_t y) { + int16_t ys = 1; + foreach_active(i){ + ys = y; + } + + int16_t r = x % ys; + + return r + (r == 0 || (x > 0 && y > 0) || (x < 0 && y < 0) ? 0 : y); +} + +SCALAR_FUN_ATTR int32_t smod32(int32_t x, int32_t y) { + int32_t ys = 1; + foreach_active(i){ + ys = y; + } + + int32_t r = x % ys; + + return r + (r == 0 || (x > 0 && y > 0) || (x < 0 && y < 0) ? 0 : y); +} + +SCALAR_FUN_ATTR int64_t smod64(int64_t x, int64_t y) { + int64_t ys = 1; + foreach_active(i){ + ys = y; + } + + int64_t r = x % ys; + + return r + (r == 0 || (x > 0 && y > 0) || (x < 0 && y < 0) ? 0 : y); +} + +SCALAR_FUN_ATTR int8_t sdiv_safe8(int8_t x, int8_t y) { + return y == 0 ? 0 : sdiv8(x, y); +} + +SCALAR_FUN_ATTR int16_t sdiv_safe16(int16_t x, int16_t y) { + return y == 0 ? 0 : sdiv16(x, y); +} + +SCALAR_FUN_ATTR int32_t sdiv_safe32(int32_t x, int32_t y) { + return y == 0 ? 0 : sdiv32(x, y); +} + +SCALAR_FUN_ATTR int64_t sdiv_safe64(int64_t x, int64_t y) { + return y == 0 ? 0 : sdiv64(x, y); +} + +SCALAR_FUN_ATTR int8_t sdiv_up_safe8(int8_t x, int8_t y) { + return sdiv_safe8(x + y - 1, y); +} + +SCALAR_FUN_ATTR int16_t sdiv_up_safe16(int16_t x, int16_t y) { + return sdiv_safe16(x + y - 1, y); +} + +SCALAR_FUN_ATTR int32_t sdiv_up_safe32(int32_t x, int32_t y) { + return sdiv_safe32(x + y - 1, y); +} + +SCALAR_FUN_ATTR int64_t sdiv_up_safe64(int64_t x, int64_t y) { + return sdiv_safe64(x + y - 1, y); +} + +SCALAR_FUN_ATTR int8_t smod_safe8(int8_t x, int8_t y) { + return y == 0 ? 0 : smod8(x, y); +} + +SCALAR_FUN_ATTR int16_t smod_safe16(int16_t x, int16_t y) { + return y == 0 ? 0 : smod16(x, y); +} + +SCALAR_FUN_ATTR int32_t smod_safe32(int32_t x, int32_t y) { + return y == 0 ? 0 : smod32(x, y); +} + +SCALAR_FUN_ATTR int64_t smod_safe64(int64_t x, int64_t y) { + return y == 0 ? 0 : smod64(x, y); +} + +SCALAR_FUN_ATTR int8_t squot8(int8_t x, int8_t y) { + int8_t ys = 1; + foreach_active(i){ + ys = y; + } + + return x / ys; +} + +SCALAR_FUN_ATTR int16_t squot16(int16_t x, int16_t y) { + int16_t ys = 1; + foreach_active(i){ + ys = y; + } + + return x / ys; +} + +SCALAR_FUN_ATTR int32_t squot32(int32_t x, int32_t y) { + int32_t ys = 1; + foreach_active(i){ + ys = y; + } + + return x / ys; +} + +SCALAR_FUN_ATTR int64_t squot64(int64_t x, int64_t y) { + int64_t ys = 1; + foreach_active(i){ + ys = y; + } + + return x / ys; +} + +SCALAR_FUN_ATTR int8_t srem8(int8_t x, int8_t y) { + int8_t ys = 1; + foreach_active(i){ + ys = y; + } + + return x % ys; +} + +SCALAR_FUN_ATTR int16_t srem16(int16_t x, int16_t y) { + int16_t ys = 1; + foreach_active(i){ + ys = y; + } + + return x % ys; +} + +SCALAR_FUN_ATTR int32_t srem32(int32_t x, int32_t y) { + int32_t ys = 1; + foreach_active(i){ + ys = y; + } + + return x % ys; +} + +SCALAR_FUN_ATTR int64_t srem64(int64_t x, int64_t y) { + int8_t ys = 1; + foreach_active(i){ + ys = y; + } + + return x % ys; +} + +SCALAR_FUN_ATTR int8_t squot_safe8(int8_t x, int8_t y) { + int8_t ys = 1; + foreach_active(i){ + ys = y; + } + + return y == 0 ? 0 : x / ys; +} + +SCALAR_FUN_ATTR int16_t squot_safe16(int16_t x, int16_t y) { + int16_t ys = 1; + foreach_active(i){ + ys = y; + } + + return y == 0 ? 0 : x / ys; +} + +SCALAR_FUN_ATTR int32_t squot_safe32(int32_t x, int32_t y) { + int32_t ys = 1; + foreach_active(i){ + ys = y; + } + + return y == 0 ? 0 : x / ys; +} + +SCALAR_FUN_ATTR int64_t squot_safe64(int64_t x, int64_t y) { + int64_t ys = 1; + foreach_active(i){ + ys = y; + } + + return y == 0 ? 0 : x / ys; +} + +SCALAR_FUN_ATTR int8_t srem_safe8(int8_t x, int8_t y) { + int8_t ys = 1; + foreach_active(i){ + ys = y; + } + + return y == 0 ? 0 : x % ys; +} + +SCALAR_FUN_ATTR int16_t srem_safe16(int16_t x, int16_t y) { + int16_t ys = 1; + foreach_active(i){ + ys = y; + } + + return y == 0 ? 0 : x % ys; +} + +SCALAR_FUN_ATTR int32_t srem_safe32(int32_t x, int32_t y) { + int32_t ys = 1; + foreach_active(i){ + ys = y; + } + + return y == 0 ? 0 : x % ys; +} + +SCALAR_FUN_ATTR int64_t srem_safe64(int64_t x, int64_t y) { + int64_t ys = 1; + foreach_active(i){ + ys = y; + } + + return y == 0 ? 0 : x % ys; +} + +#else + +SCALAR_FUN_ATTR uint8_t udiv8(uint8_t x, uint8_t y) { + return x / y; +} + +SCALAR_FUN_ATTR uint16_t udiv16(uint16_t x, uint16_t y) { + return x / y; +} + +SCALAR_FUN_ATTR uint32_t udiv32(uint32_t x, uint32_t y) { + return x / y; +} + +SCALAR_FUN_ATTR uint64_t udiv64(uint64_t x, uint64_t y) { + return x / y; +} + +SCALAR_FUN_ATTR uint8_t udiv_up8(uint8_t x, uint8_t y) { + return (x + y - 1) / y; +} + +SCALAR_FUN_ATTR uint16_t udiv_up16(uint16_t x, uint16_t y) { + return (x + y - 1) / y; +} + +SCALAR_FUN_ATTR uint32_t udiv_up32(uint32_t x, uint32_t y) { + return (x + y - 1) / y; +} + +SCALAR_FUN_ATTR uint64_t udiv_up64(uint64_t x, uint64_t y) { + return (x + y - 1) / y; +} + +SCALAR_FUN_ATTR uint8_t umod8(uint8_t x, uint8_t y) { + return x % y; +} + +SCALAR_FUN_ATTR uint16_t umod16(uint16_t x, uint16_t y) { + return x % y; +} + +SCALAR_FUN_ATTR uint32_t umod32(uint32_t x, uint32_t y) { + return x % y; +} + +SCALAR_FUN_ATTR uint64_t umod64(uint64_t x, uint64_t y) { + return x % y; +} + +SCALAR_FUN_ATTR uint8_t udiv_safe8(uint8_t x, uint8_t y) { + return y == 0 ? 0 : x / y; +} + +SCALAR_FUN_ATTR uint16_t udiv_safe16(uint16_t x, uint16_t y) { + return y == 0 ? 0 : x / y; +} + +SCALAR_FUN_ATTR uint32_t udiv_safe32(uint32_t x, uint32_t y) { + return y == 0 ? 0 : x / y; +} + +SCALAR_FUN_ATTR uint64_t udiv_safe64(uint64_t x, uint64_t y) { + return y == 0 ? 0 : x / y; +} + +SCALAR_FUN_ATTR uint8_t udiv_up_safe8(uint8_t x, uint8_t y) { + return y == 0 ? 0 : (x + y - 1) / y; +} + +SCALAR_FUN_ATTR uint16_t udiv_up_safe16(uint16_t x, uint16_t y) { + return y == 0 ? 0 : (x + y - 1) / y; +} + +SCALAR_FUN_ATTR uint32_t udiv_up_safe32(uint32_t x, uint32_t y) { + return y == 0 ? 0 : (x + y - 1) / y; +} + +SCALAR_FUN_ATTR uint64_t udiv_up_safe64(uint64_t x, uint64_t y) { + return y == 0 ? 0 : (x + y - 1) / y; +} + +SCALAR_FUN_ATTR uint8_t umod_safe8(uint8_t x, uint8_t y) { + return y == 0 ? 0 : x % y; +} + +SCALAR_FUN_ATTR uint16_t umod_safe16(uint16_t x, uint16_t y) { + return y == 0 ? 0 : x % y; +} + +SCALAR_FUN_ATTR uint32_t umod_safe32(uint32_t x, uint32_t y) { + return y == 0 ? 0 : x % y; +} + +SCALAR_FUN_ATTR uint64_t umod_safe64(uint64_t x, uint64_t y) { + return y == 0 ? 0 : x % y; +} + +SCALAR_FUN_ATTR int8_t sdiv8(int8_t x, int8_t y) { + int8_t q = x / y; + int8_t r = x % y; + + return q - ((r != 0 && r < 0 != y < 0) ? 1 : 0); +} + +SCALAR_FUN_ATTR int16_t sdiv16(int16_t x, int16_t y) { + int16_t q = x / y; + int16_t r = x % y; + + return q - ((r != 0 && r < 0 != y < 0) ? 1 : 0); +} + +SCALAR_FUN_ATTR int32_t sdiv32(int32_t x, int32_t y) { + int32_t q = x / y; + int32_t r = x % y; + + return q - ((r != 0 && r < 0 != y < 0) ? 1 : 0); +} + +SCALAR_FUN_ATTR int64_t sdiv64(int64_t x, int64_t y) { + int64_t q = x / y; + int64_t r = x % y; + + return q - ((r != 0 && r < 0 != y < 0) ? 1 : 0); +} + +SCALAR_FUN_ATTR int8_t sdiv_up8(int8_t x, int8_t y) { + return sdiv8(x + y - 1, y); +} + +SCALAR_FUN_ATTR int16_t sdiv_up16(int16_t x, int16_t y) { + return sdiv16(x + y - 1, y); +} + +SCALAR_FUN_ATTR int32_t sdiv_up32(int32_t x, int32_t y) { + return sdiv32(x + y - 1, y); +} + +SCALAR_FUN_ATTR int64_t sdiv_up64(int64_t x, int64_t y) { + return sdiv64(x + y - 1, y); +} + +SCALAR_FUN_ATTR int8_t smod8(int8_t x, int8_t y) { + int8_t r = x % y; + + return r + (r == 0 || (x > 0 && y > 0) || (x < 0 && y < 0) ? 0 : y); +} + +SCALAR_FUN_ATTR int16_t smod16(int16_t x, int16_t y) { + int16_t r = x % y; + + return r + (r == 0 || (x > 0 && y > 0) || (x < 0 && y < 0) ? 0 : y); +} + +SCALAR_FUN_ATTR int32_t smod32(int32_t x, int32_t y) { + int32_t r = x % y; + + return r + (r == 0 || (x > 0 && y > 0) || (x < 0 && y < 0) ? 0 : y); +} + +SCALAR_FUN_ATTR int64_t smod64(int64_t x, int64_t y) { + int64_t r = x % y; + + return r + (r == 0 || (x > 0 && y > 0) || (x < 0 && y < 0) ? 0 : y); +} + +SCALAR_FUN_ATTR int8_t sdiv_safe8(int8_t x, int8_t y) { + return y == 0 ? 0 : sdiv8(x, y); +} + +SCALAR_FUN_ATTR int16_t sdiv_safe16(int16_t x, int16_t y) { + return y == 0 ? 0 : sdiv16(x, y); +} + +SCALAR_FUN_ATTR int32_t sdiv_safe32(int32_t x, int32_t y) { + return y == 0 ? 0 : sdiv32(x, y); +} + +SCALAR_FUN_ATTR int64_t sdiv_safe64(int64_t x, int64_t y) { + return y == 0 ? 0 : sdiv64(x, y); +} + +SCALAR_FUN_ATTR int8_t sdiv_up_safe8(int8_t x, int8_t y) { + return sdiv_safe8(x + y - 1, y); +} + +SCALAR_FUN_ATTR int16_t sdiv_up_safe16(int16_t x, int16_t y) { + return sdiv_safe16(x + y - 1, y); +} + +SCALAR_FUN_ATTR int32_t sdiv_up_safe32(int32_t x, int32_t y) { + return sdiv_safe32(x + y - 1, y); +} + +SCALAR_FUN_ATTR int64_t sdiv_up_safe64(int64_t x, int64_t y) { + return sdiv_safe64(x + y - 1, y); +} + +SCALAR_FUN_ATTR int8_t smod_safe8(int8_t x, int8_t y) { + return y == 0 ? 0 : smod8(x, y); +} + +SCALAR_FUN_ATTR int16_t smod_safe16(int16_t x, int16_t y) { + return y == 0 ? 0 : smod16(x, y); +} + +SCALAR_FUN_ATTR int32_t smod_safe32(int32_t x, int32_t y) { + return y == 0 ? 0 : smod32(x, y); +} + +SCALAR_FUN_ATTR int64_t smod_safe64(int64_t x, int64_t y) { + return y == 0 ? 0 : smod64(x, y); +} + +SCALAR_FUN_ATTR int8_t squot8(int8_t x, int8_t y) { + return x / y; +} + +SCALAR_FUN_ATTR int16_t squot16(int16_t x, int16_t y) { + return x / y; +} + +SCALAR_FUN_ATTR int32_t squot32(int32_t x, int32_t y) { + return x / y; +} + +SCALAR_FUN_ATTR int64_t squot64(int64_t x, int64_t y) { + return x / y; +} + +SCALAR_FUN_ATTR int8_t srem8(int8_t x, int8_t y) { + return x % y; +} + +SCALAR_FUN_ATTR int16_t srem16(int16_t x, int16_t y) { + return x % y; +} + +SCALAR_FUN_ATTR int32_t srem32(int32_t x, int32_t y) { + return x % y; +} + +SCALAR_FUN_ATTR int64_t srem64(int64_t x, int64_t y) { + return x % y; +} + +SCALAR_FUN_ATTR int8_t squot_safe8(int8_t x, int8_t y) { + return y == 0 ? 0 : x / y; +} + +SCALAR_FUN_ATTR int16_t squot_safe16(int16_t x, int16_t y) { + return y == 0 ? 0 : x / y; +} + +SCALAR_FUN_ATTR int32_t squot_safe32(int32_t x, int32_t y) { + return y == 0 ? 0 : x / y; +} + +SCALAR_FUN_ATTR int64_t squot_safe64(int64_t x, int64_t y) { + return y == 0 ? 0 : x / y; +} + +SCALAR_FUN_ATTR int8_t srem_safe8(int8_t x, int8_t y) { + return y == 0 ? 0 : x % y; +} + +SCALAR_FUN_ATTR int16_t srem_safe16(int16_t x, int16_t y) { + return y == 0 ? 0 : x % y; +} + +SCALAR_FUN_ATTR int32_t srem_safe32(int32_t x, int32_t y) { + return y == 0 ? 0 : x % y; +} + +SCALAR_FUN_ATTR int64_t srem_safe64(int64_t x, int64_t y) { + return y == 0 ? 0 : x % y; +} + +#endif + +SCALAR_FUN_ATTR int8_t smin8(int8_t x, int8_t y) { + return x < y ? x : y; +} + +SCALAR_FUN_ATTR int16_t smin16(int16_t x, int16_t y) { + return x < y ? x : y; +} + +SCALAR_FUN_ATTR int32_t smin32(int32_t x, int32_t y) { + return x < y ? x : y; +} + +SCALAR_FUN_ATTR int64_t smin64(int64_t x, int64_t y) { + return x < y ? x : y; +} + +SCALAR_FUN_ATTR uint8_t umin8(uint8_t x, uint8_t y) { + return x < y ? x : y; +} + +SCALAR_FUN_ATTR uint16_t umin16(uint16_t x, uint16_t y) { + return x < y ? x : y; +} + +SCALAR_FUN_ATTR uint32_t umin32(uint32_t x, uint32_t y) { + return x < y ? x : y; +} + +SCALAR_FUN_ATTR uint64_t umin64(uint64_t x, uint64_t y) { + return x < y ? x : y; +} + +SCALAR_FUN_ATTR int8_t smax8(int8_t x, int8_t y) { + return x < y ? y : x; +} + +SCALAR_FUN_ATTR int16_t smax16(int16_t x, int16_t y) { + return x < y ? y : x; +} + +SCALAR_FUN_ATTR int32_t smax32(int32_t x, int32_t y) { + return x < y ? y : x; +} + +SCALAR_FUN_ATTR int64_t smax64(int64_t x, int64_t y) { + return x < y ? y : x; +} + +SCALAR_FUN_ATTR uint8_t umax8(uint8_t x, uint8_t y) { + return x < y ? y : x; +} + +SCALAR_FUN_ATTR uint16_t umax16(uint16_t x, uint16_t y) { + return x < y ? y : x; +} + +SCALAR_FUN_ATTR uint32_t umax32(uint32_t x, uint32_t y) { + return x < y ? y : x; +} + +SCALAR_FUN_ATTR uint64_t umax64(uint64_t x, uint64_t y) { + return x < y ? y : x; +} + +SCALAR_FUN_ATTR uint8_t shl8(uint8_t x, uint8_t y) { + return (uint8_t)(x << y); +} + +SCALAR_FUN_ATTR uint16_t shl16(uint16_t x, uint16_t y) { + return (uint16_t)(x << y); +} + +SCALAR_FUN_ATTR uint32_t shl32(uint32_t x, uint32_t y) { + return x << y; +} + +SCALAR_FUN_ATTR uint64_t shl64(uint64_t x, uint64_t y) { + return x << y; +} + +SCALAR_FUN_ATTR uint8_t lshr8(uint8_t x, uint8_t y) { + return x >> y; +} + +SCALAR_FUN_ATTR uint16_t lshr16(uint16_t x, uint16_t y) { + return x >> y; +} + +SCALAR_FUN_ATTR uint32_t lshr32(uint32_t x, uint32_t y) { + return x >> y; +} + +SCALAR_FUN_ATTR uint64_t lshr64(uint64_t x, uint64_t y) { + return x >> y; +} + +SCALAR_FUN_ATTR int8_t ashr8(int8_t x, int8_t y) { + return x >> y; +} + +SCALAR_FUN_ATTR int16_t ashr16(int16_t x, int16_t y) { + return x >> y; +} + +SCALAR_FUN_ATTR int32_t ashr32(int32_t x, int32_t y) { + return x >> y; +} + +SCALAR_FUN_ATTR int64_t ashr64(int64_t x, int64_t y) { + return x >> y; +} + +SCALAR_FUN_ATTR uint8_t and8(uint8_t x, uint8_t y) { + return x & y; +} + +SCALAR_FUN_ATTR uint16_t and16(uint16_t x, uint16_t y) { + return x & y; +} + +SCALAR_FUN_ATTR uint32_t and32(uint32_t x, uint32_t y) { + return x & y; +} + +SCALAR_FUN_ATTR uint64_t and64(uint64_t x, uint64_t y) { + return x & y; +} + +SCALAR_FUN_ATTR uint8_t or8(uint8_t x, uint8_t y) { + return x | y; +} + +SCALAR_FUN_ATTR uint16_t or16(uint16_t x, uint16_t y) { + return x | y; +} + +SCALAR_FUN_ATTR uint32_t or32(uint32_t x, uint32_t y) { + return x | y; +} + +SCALAR_FUN_ATTR uint64_t or64(uint64_t x, uint64_t y) { + return x | y; +} + +SCALAR_FUN_ATTR uint8_t xor8(uint8_t x, uint8_t y) { + return x ^ y; +} + +SCALAR_FUN_ATTR uint16_t xor16(uint16_t x, uint16_t y) { + return x ^ y; +} + +SCALAR_FUN_ATTR uint32_t xor32(uint32_t x, uint32_t y) { + return x ^ y; +} + +SCALAR_FUN_ATTR uint64_t xor64(uint64_t x, uint64_t y) { + return x ^ y; +} + +SCALAR_FUN_ATTR bool ult8(uint8_t x, uint8_t y) { + return x < y; +} + +SCALAR_FUN_ATTR bool ult16(uint16_t x, uint16_t y) { + return x < y; +} + +SCALAR_FUN_ATTR bool ult32(uint32_t x, uint32_t y) { + return x < y; +} + +SCALAR_FUN_ATTR bool ult64(uint64_t x, uint64_t y) { + return x < y; +} + +SCALAR_FUN_ATTR bool ule8(uint8_t x, uint8_t y) { + return x <= y; +} + +SCALAR_FUN_ATTR bool ule16(uint16_t x, uint16_t y) { + return x <= y; +} + +SCALAR_FUN_ATTR bool ule32(uint32_t x, uint32_t y) { + return x <= y; +} + +SCALAR_FUN_ATTR bool ule64(uint64_t x, uint64_t y) { + return x <= y; +} + +SCALAR_FUN_ATTR bool slt8(int8_t x, int8_t y) { + return x < y; +} + +SCALAR_FUN_ATTR bool slt16(int16_t x, int16_t y) { + return x < y; +} + +SCALAR_FUN_ATTR bool slt32(int32_t x, int32_t y) { + return x < y; +} + +SCALAR_FUN_ATTR bool slt64(int64_t x, int64_t y) { + return x < y; +} + +SCALAR_FUN_ATTR bool sle8(int8_t x, int8_t y) { + return x <= y; +} + +SCALAR_FUN_ATTR bool sle16(int16_t x, int16_t y) { + return x <= y; +} + +SCALAR_FUN_ATTR bool sle32(int32_t x, int32_t y) { + return x <= y; +} + +SCALAR_FUN_ATTR bool sle64(int64_t x, int64_t y) { + return x <= y; +} + +SCALAR_FUN_ATTR uint8_t pow8(uint8_t x, uint8_t y) { + uint8_t res = 1, rem = y; + + while (rem != 0) { + if (rem & 1) + res *= x; + rem >>= 1; + x *= x; + } + return res; +} + +SCALAR_FUN_ATTR uint16_t pow16(uint16_t x, uint16_t y) { + uint16_t res = 1, rem = y; + + while (rem != 0) { + if (rem & 1) + res *= x; + rem >>= 1; + x *= x; + } + return res; +} + +SCALAR_FUN_ATTR uint32_t pow32(uint32_t x, uint32_t y) { + uint32_t res = 1, rem = y; + + while (rem != 0) { + if (rem & 1) + res *= x; + rem >>= 1; + x *= x; + } + return res; +} + +SCALAR_FUN_ATTR uint64_t pow64(uint64_t x, uint64_t y) { + uint64_t res = 1, rem = y; + + while (rem != 0) { + if (rem & 1) + res *= x; + rem >>= 1; + x *= x; + } + return res; +} + +SCALAR_FUN_ATTR bool itob_i8_bool(int8_t x) { + return x != 0; +} + +SCALAR_FUN_ATTR bool itob_i16_bool(int16_t x) { + return x != 0; +} + +SCALAR_FUN_ATTR bool itob_i32_bool(int32_t x) { + return x != 0; +} + +SCALAR_FUN_ATTR bool itob_i64_bool(int64_t x) { + return x != 0; +} + +SCALAR_FUN_ATTR int8_t btoi_bool_i8(bool x) { + return x; +} + +SCALAR_FUN_ATTR int16_t btoi_bool_i16(bool x) { + return x; +} + +SCALAR_FUN_ATTR int32_t btoi_bool_i32(bool x) { + return x; +} + +SCALAR_FUN_ATTR int64_t btoi_bool_i64(bool x) { + return x; +} + +#define sext_i8_i8(x) ((int8_t) (int8_t) (x)) +#define sext_i8_i16(x) ((int16_t) (int8_t) (x)) +#define sext_i8_i32(x) ((int32_t) (int8_t) (x)) +#define sext_i8_i64(x) ((int64_t) (int8_t) (x)) +#define sext_i16_i8(x) ((int8_t) (int16_t) (x)) +#define sext_i16_i16(x) ((int16_t) (int16_t) (x)) +#define sext_i16_i32(x) ((int32_t) (int16_t) (x)) +#define sext_i16_i64(x) ((int64_t) (int16_t) (x)) +#define sext_i32_i8(x) ((int8_t) (int32_t) (x)) +#define sext_i32_i16(x) ((int16_t) (int32_t) (x)) +#define sext_i32_i32(x) ((int32_t) (int32_t) (x)) +#define sext_i32_i64(x) ((int64_t) (int32_t) (x)) +#define sext_i64_i8(x) ((int8_t) (int64_t) (x)) +#define sext_i64_i16(x) ((int16_t) (int64_t) (x)) +#define sext_i64_i32(x) ((int32_t) (int64_t) (x)) +#define sext_i64_i64(x) ((int64_t) (int64_t) (x)) +#define zext_i8_i8(x) ((int8_t) (uint8_t) (x)) +#define zext_i8_i16(x) ((int16_t) (uint8_t) (x)) +#define zext_i8_i32(x) ((int32_t) (uint8_t) (x)) +#define zext_i8_i64(x) ((int64_t) (uint8_t) (x)) +#define zext_i16_i8(x) ((int8_t) (uint16_t) (x)) +#define zext_i16_i16(x) ((int16_t) (uint16_t) (x)) +#define zext_i16_i32(x) ((int32_t) (uint16_t) (x)) +#define zext_i16_i64(x) ((int64_t) (uint16_t) (x)) +#define zext_i32_i8(x) ((int8_t) (uint32_t) (x)) +#define zext_i32_i16(x) ((int16_t) (uint32_t) (x)) +#define zext_i32_i32(x) ((int32_t) (uint32_t) (x)) +#define zext_i32_i64(x) ((int64_t) (uint32_t) (x)) +#define zext_i64_i8(x) ((int8_t) (uint64_t) (x)) +#define zext_i64_i16(x) ((int16_t) (uint64_t) (x)) +#define zext_i64_i32(x) ((int32_t) (uint64_t) (x)) +#define zext_i64_i64(x) ((int64_t) (uint64_t) (x)) + +SCALAR_FUN_ATTR int8_t abs8(int8_t x) { + return (int8_t)abs(x); +} + +SCALAR_FUN_ATTR int16_t abs16(int16_t x) { + return (int16_t)abs(x); +} + +SCALAR_FUN_ATTR int32_t abs32(int32_t x) { + return abs(x); +} + +SCALAR_FUN_ATTR int64_t abs64(int64_t x) { +#if defined(__OPENCL_VERSION__) || defined(ISPC) + return abs(x); +#else + return llabs(x); +#endif +} + +#if defined(__OPENCL_VERSION__) +SCALAR_FUN_ATTR int32_t futrts_popc8(int8_t x) { + return popcount(x); +} + +SCALAR_FUN_ATTR int32_t futrts_popc16(int16_t x) { + return popcount(x); +} + +SCALAR_FUN_ATTR int32_t futrts_popc32(int32_t x) { + return popcount(x); +} + +SCALAR_FUN_ATTR int32_t futrts_popc64(int64_t x) { + return popcount(x); +} +#elif defined(__CUDA_ARCH__) + +SCALAR_FUN_ATTR int32_t futrts_popc8(int8_t x) { + return __popc(zext_i8_i32(x)); +} + +SCALAR_FUN_ATTR int32_t futrts_popc16(int16_t x) { + return __popc(zext_i16_i32(x)); +} + +SCALAR_FUN_ATTR int32_t futrts_popc32(int32_t x) { + return __popc(x); +} + +SCALAR_FUN_ATTR int32_t futrts_popc64(int64_t x) { + return __popcll(x); +} + +#else // Not OpenCL or CUDA, but plain C. + +SCALAR_FUN_ATTR int32_t futrts_popc8(uint8_t x) { + int c = 0; + for (; x; ++c) { x &= x - 1; } + return c; +} + +SCALAR_FUN_ATTR int32_t futrts_popc16(uint16_t x) { + int c = 0; + for (; x; ++c) { x &= x - 1; } + return c; +} + +SCALAR_FUN_ATTR int32_t futrts_popc32(uint32_t x) { + int c = 0; + for (; x; ++c) { x &= x - 1; } + return c; +} + +SCALAR_FUN_ATTR int32_t futrts_popc64(uint64_t x) { + int c = 0; + for (; x; ++c) { x &= x - 1; } + return c; +} +#endif + +#if defined(__OPENCL_VERSION__) +SCALAR_FUN_ATTR uint8_t futrts_umul_hi8 ( uint8_t a, uint8_t b) { return mul_hi(a, b); } +SCALAR_FUN_ATTR uint16_t futrts_umul_hi16(uint16_t a, uint16_t b) { return mul_hi(a, b); } +SCALAR_FUN_ATTR uint32_t futrts_umul_hi32(uint32_t a, uint32_t b) { return mul_hi(a, b); } +SCALAR_FUN_ATTR uint64_t futrts_umul_hi64(uint64_t a, uint64_t b) { return mul_hi(a, b); } +SCALAR_FUN_ATTR uint8_t futrts_smul_hi8 ( int8_t a, int8_t b) { return mul_hi(a, b); } +SCALAR_FUN_ATTR uint16_t futrts_smul_hi16(int16_t a, int16_t b) { return mul_hi(a, b); } +SCALAR_FUN_ATTR uint32_t futrts_smul_hi32(int32_t a, int32_t b) { return mul_hi(a, b); } +SCALAR_FUN_ATTR uint64_t futrts_smul_hi64(int64_t a, int64_t b) { return mul_hi(a, b); } +#elif defined(__CUDA_ARCH__) +SCALAR_FUN_ATTR uint8_t futrts_umul_hi8(uint8_t a, uint8_t b) { return ((uint16_t)a) * ((uint16_t)b) >> 8; } +SCALAR_FUN_ATTR uint16_t futrts_umul_hi16(uint16_t a, uint16_t b) { return ((uint32_t)a) * ((uint32_t)b) >> 16; } +SCALAR_FUN_ATTR uint32_t futrts_umul_hi32(uint32_t a, uint32_t b) { return __umulhi(a, b); } +SCALAR_FUN_ATTR uint64_t futrts_umul_hi64(uint64_t a, uint64_t b) { return __umul64hi(a, b); } +SCALAR_FUN_ATTR uint8_t futrts_smul_hi8 ( int8_t a, int8_t b) { return ((int16_t)a) * ((int16_t)b) >> 8; } +SCALAR_FUN_ATTR uint16_t futrts_smul_hi16(int16_t a, int16_t b) { return ((int32_t)a) * ((int32_t)b) >> 16; } +SCALAR_FUN_ATTR uint32_t futrts_smul_hi32(int32_t a, int32_t b) { return __mulhi(a, b); } +SCALAR_FUN_ATTR uint64_t futrts_smul_hi64(int64_t a, int64_t b) { return __mul64hi(a, b); } +#elif ISPC +SCALAR_FUN_ATTR uint8_t futrts_umul_hi8(uint8_t a, uint8_t b) { return ((uint16_t)a) * ((uint16_t)b) >> 8; } +SCALAR_FUN_ATTR uint16_t futrts_umul_hi16(uint16_t a, uint16_t b) { return ((uint32_t)a) * ((uint32_t)b) >> 16; } +SCALAR_FUN_ATTR uint32_t futrts_umul_hi32(uint32_t a, uint32_t b) { return ((uint64_t)a) * ((uint64_t)b) >> 32; } +SCALAR_FUN_ATTR uint64_t futrts_umul_hi64(uint64_t a, uint64_t b) { + uint64_t ah = a >> 32; + uint64_t al = a & 0xffffffff; + uint64_t bh = b >> 32; + uint64_t bl = b & 0xffffffff; + + uint64_t p1 = al * bl; + uint64_t p2 = al * bh; + uint64_t p3 = ah * bl; + uint64_t p4 = ah * bh; + + uint64_t p1h = p1 >> 32; + uint64_t p2h = p2 >> 32; + uint64_t p3h = p3 >> 32; + uint64_t p2l = p2 & 0xffffffff; + uint64_t p3l = p3 & 0xffffffff; + + uint64_t l = p1h + p2l + p3l; + uint64_t m = (p2 >> 32) + (p3 >> 32); + uint64_t h = (l >> 32) + m + p4; + + return h; +} +SCALAR_FUN_ATTR int8_t futrts_smul_hi8 ( int8_t a, int8_t b) { return ((uint16_t)a) * ((uint16_t)b) >> 8; } +SCALAR_FUN_ATTR int16_t futrts_smul_hi16(int16_t a, int16_t b) { return ((uint32_t)a) * ((uint32_t)b) >> 16; } +SCALAR_FUN_ATTR int32_t futrts_smul_hi32(int32_t a, int32_t b) { return ((uint64_t)a) * ((uint64_t)b) >> 32; } +SCALAR_FUN_ATTR int64_t futrts_smul_hi64(int64_t a, int64_t b) { + uint64_t ah = a >> 32; + uint64_t al = a & 0xffffffff; + uint64_t bh = b >> 32; + uint64_t bl = b & 0xffffffff; + + uint64_t p1 = al * bl; + int64_t p2 = al * bh; + int64_t p3 = ah * bl; + uint64_t p4 = ah * bh; + + uint64_t p1h = p1 >> 32; + uint64_t p2h = p2 >> 32; + uint64_t p3h = p3 >> 32; + uint64_t p2l = p2 & 0xffffffff; + uint64_t p3l = p3 & 0xffffffff; + + uint64_t l = p1h + p2l + p3l; + uint64_t m = (p2 >> 32) + (p3 >> 32); + uint64_t h = (l >> 32) + m + p4; + + return h; +} + +#else // Not OpenCL, ISPC, or CUDA, but plain C. +SCALAR_FUN_ATTR uint8_t futrts_umul_hi8(uint8_t a, uint8_t b) { return ((uint16_t)a) * ((uint16_t)b) >> 8; } +SCALAR_FUN_ATTR uint16_t futrts_umul_hi16(uint16_t a, uint16_t b) { return ((uint32_t)a) * ((uint32_t)b) >> 16; } +SCALAR_FUN_ATTR uint32_t futrts_umul_hi32(uint32_t a, uint32_t b) { return ((uint64_t)a) * ((uint64_t)b) >> 32; } +SCALAR_FUN_ATTR uint64_t futrts_umul_hi64(uint64_t a, uint64_t b) { return ((__uint128_t)a) * ((__uint128_t)b) >> 64; } +SCALAR_FUN_ATTR int8_t futrts_smul_hi8(int8_t a, int8_t b) { return ((int16_t)a) * ((int16_t)b) >> 8; } +SCALAR_FUN_ATTR int16_t futrts_smul_hi16(int16_t a, int16_t b) { return ((int32_t)a) * ((int32_t)b) >> 16; } +SCALAR_FUN_ATTR int32_t futrts_smul_hi32(int32_t a, int32_t b) { return ((int64_t)a) * ((int64_t)b) >> 32; } +SCALAR_FUN_ATTR int64_t futrts_smul_hi64(int64_t a, int64_t b) { return ((__int128_t)a) * ((__int128_t)b) >> 64; } +#endif + +#if defined(__OPENCL_VERSION__) +SCALAR_FUN_ATTR uint8_t futrts_umad_hi8 ( uint8_t a, uint8_t b, uint8_t c) { return mad_hi(a, b, c); } +SCALAR_FUN_ATTR uint16_t futrts_umad_hi16(uint16_t a, uint16_t b, uint16_t c) { return mad_hi(a, b, c); } +SCALAR_FUN_ATTR uint32_t futrts_umad_hi32(uint32_t a, uint32_t b, uint32_t c) { return mad_hi(a, b, c); } +SCALAR_FUN_ATTR uint64_t futrts_umad_hi64(uint64_t a, uint64_t b, uint64_t c) { return mad_hi(a, b, c); } +SCALAR_FUN_ATTR uint8_t futrts_smad_hi8( int8_t a, int8_t b, int8_t c) { return mad_hi(a, b, c); } +SCALAR_FUN_ATTR uint16_t futrts_smad_hi16(int16_t a, int16_t b, int16_t c) { return mad_hi(a, b, c); } +SCALAR_FUN_ATTR uint32_t futrts_smad_hi32(int32_t a, int32_t b, int32_t c) { return mad_hi(a, b, c); } +SCALAR_FUN_ATTR uint64_t futrts_smad_hi64(int64_t a, int64_t b, int64_t c) { return mad_hi(a, b, c); } +#else // Not OpenCL + +SCALAR_FUN_ATTR uint8_t futrts_umad_hi8( uint8_t a, uint8_t b, uint8_t c) { return futrts_umul_hi8(a, b) + c; } +SCALAR_FUN_ATTR uint16_t futrts_umad_hi16(uint16_t a, uint16_t b, uint16_t c) { return futrts_umul_hi16(a, b) + c; } +SCALAR_FUN_ATTR uint32_t futrts_umad_hi32(uint32_t a, uint32_t b, uint32_t c) { return futrts_umul_hi32(a, b) + c; } +SCALAR_FUN_ATTR uint64_t futrts_umad_hi64(uint64_t a, uint64_t b, uint64_t c) { return futrts_umul_hi64(a, b) + c; } +SCALAR_FUN_ATTR uint8_t futrts_smad_hi8 ( int8_t a, int8_t b, int8_t c) { return futrts_smul_hi8(a, b) + c; } +SCALAR_FUN_ATTR uint16_t futrts_smad_hi16(int16_t a, int16_t b, int16_t c) { return futrts_smul_hi16(a, b) + c; } +SCALAR_FUN_ATTR uint32_t futrts_smad_hi32(int32_t a, int32_t b, int32_t c) { return futrts_smul_hi32(a, b) + c; } +SCALAR_FUN_ATTR uint64_t futrts_smad_hi64(int64_t a, int64_t b, int64_t c) { return futrts_smul_hi64(a, b) + c; } +#endif + +#if defined(__OPENCL_VERSION__) +SCALAR_FUN_ATTR int32_t futrts_clzz8(int8_t x) { + return clz(x); +} + +SCALAR_FUN_ATTR int32_t futrts_clzz16(int16_t x) { + return clz(x); +} + +SCALAR_FUN_ATTR int32_t futrts_clzz32(int32_t x) { + return clz(x); +} + +SCALAR_FUN_ATTR int32_t futrts_clzz64(int64_t x) { + return clz(x); +} + +#elif defined(__CUDA_ARCH__) + +SCALAR_FUN_ATTR int32_t futrts_clzz8(int8_t x) { + return __clz(zext_i8_i32(x)) - 24; +} + +SCALAR_FUN_ATTR int32_t futrts_clzz16(int16_t x) { + return __clz(zext_i16_i32(x)) - 16; +} + +SCALAR_FUN_ATTR int32_t futrts_clzz32(int32_t x) { + return __clz(x); +} + +SCALAR_FUN_ATTR int32_t futrts_clzz64(int64_t x) { + return __clzll(x); +} + +#elif ISPC + +SCALAR_FUN_ATTR int32_t futrts_clzz8(int8_t x) { + return count_leading_zeros((int32_t)(uint8_t)x)-24; +} + +SCALAR_FUN_ATTR int32_t futrts_clzz16(int16_t x) { + return count_leading_zeros((int32_t)(uint16_t)x)-16; +} + +SCALAR_FUN_ATTR int32_t futrts_clzz32(int32_t x) { + return count_leading_zeros(x); +} + +SCALAR_FUN_ATTR int32_t futrts_clzz64(int64_t x) { + return count_leading_zeros(x); +} + +#else // Not OpenCL, ISPC or CUDA, but plain C. + +SCALAR_FUN_ATTR int32_t futrts_clzz8(int8_t x) { + return x == 0 ? 8 : __builtin_clz((uint32_t)zext_i8_i32(x)) - 24; +} + +SCALAR_FUN_ATTR int32_t futrts_clzz16(int16_t x) { + return x == 0 ? 16 : __builtin_clz((uint32_t)zext_i16_i32(x)) - 16; +} + +SCALAR_FUN_ATTR int32_t futrts_clzz32(int32_t x) { + return x == 0 ? 32 : __builtin_clz((uint32_t)x); +} + +SCALAR_FUN_ATTR int32_t futrts_clzz64(int64_t x) { + return x == 0 ? 64 : __builtin_clzll((uint64_t)x); +} +#endif + +#if defined(__OPENCL_VERSION__) +SCALAR_FUN_ATTR int32_t futrts_ctzz8(int8_t x) { + int i = 0; + for (; i < 8 && (x & 1) == 0; i++, x >>= 1) + ; + return i; +} + +SCALAR_FUN_ATTR int32_t futrts_ctzz16(int16_t x) { + int i = 0; + for (; i < 16 && (x & 1) == 0; i++, x >>= 1) + ; + return i; +} + +SCALAR_FUN_ATTR int32_t futrts_ctzz32(int32_t x) { + int i = 0; + for (; i < 32 && (x & 1) == 0; i++, x >>= 1) + ; + return i; +} + +SCALAR_FUN_ATTR int32_t futrts_ctzz64(int64_t x) { + int i = 0; + for (; i < 64 && (x & 1) == 0; i++, x >>= 1) + ; + return i; +} + +#elif defined(__CUDA_ARCH__) + +SCALAR_FUN_ATTR int32_t futrts_ctzz8(int8_t x) { + int y = __ffs(x); + return y == 0 ? 8 : y - 1; +} + +SCALAR_FUN_ATTR int32_t futrts_ctzz16(int16_t x) { + int y = __ffs(x); + return y == 0 ? 16 : y - 1; +} + +SCALAR_FUN_ATTR int32_t futrts_ctzz32(int32_t x) { + int y = __ffs(x); + return y == 0 ? 32 : y - 1; +} + +SCALAR_FUN_ATTR int32_t futrts_ctzz64(int64_t x) { + int y = __ffsll(x); + return y == 0 ? 64 : y - 1; +} + +#elif ISPC + +SCALAR_FUN_ATTR int32_t futrts_ctzz8(int8_t x) { + return x == 0 ? 8 : count_trailing_zeros((int32_t)x); +} + +SCALAR_FUN_ATTR int32_t futrts_ctzz16(int16_t x) { + return x == 0 ? 16 : count_trailing_zeros((int32_t)x); +} + +SCALAR_FUN_ATTR int32_t futrts_ctzz32(int32_t x) { + return count_trailing_zeros(x); +} + +SCALAR_FUN_ATTR int32_t futrts_ctzz64(int64_t x) { + return count_trailing_zeros(x); +} + +#else // Not OpenCL or CUDA, but plain C. + +SCALAR_FUN_ATTR int32_t futrts_ctzz8(int8_t x) { + return x == 0 ? 8 : __builtin_ctz((uint32_t)x); +} + +SCALAR_FUN_ATTR int32_t futrts_ctzz16(int16_t x) { + return x == 0 ? 16 : __builtin_ctz((uint32_t)x); +} + +SCALAR_FUN_ATTR int32_t futrts_ctzz32(int32_t x) { + return x == 0 ? 32 : __builtin_ctz((uint32_t)x); +} + +SCALAR_FUN_ATTR int32_t futrts_ctzz64(int64_t x) { + return x == 0 ? 64 : __builtin_ctzll((uint64_t)x); +} +#endif + +SCALAR_FUN_ATTR float fdiv32(float x, float y) { + return x / y; +} + +SCALAR_FUN_ATTR float fadd32(float x, float y) { + return x + y; +} + +SCALAR_FUN_ATTR float fsub32(float x, float y) { + return x - y; +} + +SCALAR_FUN_ATTR float fmul32(float x, float y) { + return x * y; +} + +SCALAR_FUN_ATTR bool cmplt32(float x, float y) { + return x < y; +} + +SCALAR_FUN_ATTR bool cmple32(float x, float y) { + return x <= y; +} + +SCALAR_FUN_ATTR float sitofp_i8_f32(int8_t x) { + return (float) x; +} + +SCALAR_FUN_ATTR float sitofp_i16_f32(int16_t x) { + return (float) x; +} + +SCALAR_FUN_ATTR float sitofp_i32_f32(int32_t x) { + return (float) x; +} + +SCALAR_FUN_ATTR float sitofp_i64_f32(int64_t x) { + return (float) x; +} + +SCALAR_FUN_ATTR float uitofp_i8_f32(uint8_t x) { + return (float) x; +} + +SCALAR_FUN_ATTR float uitofp_i16_f32(uint16_t x) { + return (float) x; +} + +SCALAR_FUN_ATTR float uitofp_i32_f32(uint32_t x) { + return (float) x; +} + +SCALAR_FUN_ATTR float uitofp_i64_f32(uint64_t x) { + return (float) x; +} + +#ifdef __OPENCL_VERSION__ +SCALAR_FUN_ATTR float fabs32(float x) { + return fabs(x); +} + +SCALAR_FUN_ATTR float fmax32(float x, float y) { + return fmax(x, y); +} + +SCALAR_FUN_ATTR float fmin32(float x, float y) { + return fmin(x, y); +} + +SCALAR_FUN_ATTR float fpow32(float x, float y) { + return pow(x, y); +} + +#elif ISPC + +SCALAR_FUN_ATTR float fabs32(float x) { + return abs(x); +} + +SCALAR_FUN_ATTR float fmax32(float x, float y) { + return isnan(x) ? y : isnan(y) ? x : max(x, y); +} + +SCALAR_FUN_ATTR float fmin32(float x, float y) { + return isnan(x) ? y : isnan(y) ? x : min(x, y); +} + +SCALAR_FUN_ATTR float fpow32(float a, float b) { + float ret; + foreach_active (i) { + uniform float r = __stdlib_powf(extract(a, i), extract(b, i)); + ret = insert(ret, i, r); + } + return ret; +} + +#else // Not OpenCL, but CUDA or plain C. + +SCALAR_FUN_ATTR float fabs32(float x) { + return fabsf(x); +} + +SCALAR_FUN_ATTR float fmax32(float x, float y) { + return fmaxf(x, y); +} + +SCALAR_FUN_ATTR float fmin32(float x, float y) { + return fminf(x, y); +} + +SCALAR_FUN_ATTR float fpow32(float x, float y) { + return powf(x, y); +} +#endif + +SCALAR_FUN_ATTR bool futrts_isnan32(float x) { + return isnan(x); +} + +#if ISPC + +SCALAR_FUN_ATTR bool futrts_isinf32(float x) { + return !isnan(x) && isnan(x - x); +} + +SCALAR_FUN_ATTR bool futrts_isfinite32(float x) { + return !isnan(x) && !futrts_isinf32(x); +} + +#else + +SCALAR_FUN_ATTR bool futrts_isinf32(float x) { + return isinf(x); +} + +#endif + +SCALAR_FUN_ATTR int8_t fptosi_f32_i8(float x) { + if (futrts_isnan32(x) || futrts_isinf32(x)) { + return 0; + } else { + return (int8_t) x; + } +} + +SCALAR_FUN_ATTR int16_t fptosi_f32_i16(float x) { + if (futrts_isnan32(x) || futrts_isinf32(x)) { + return 0; + } else { + return (int16_t) x; + } +} + +SCALAR_FUN_ATTR int32_t fptosi_f32_i32(float x) { + if (futrts_isnan32(x) || futrts_isinf32(x)) { + return 0; + } else { + return (int32_t) x; + } +} + +SCALAR_FUN_ATTR int64_t fptosi_f32_i64(float x) { + if (futrts_isnan32(x) || futrts_isinf32(x)) { + return 0; + } else { + return (int64_t) x; + }; +} + +SCALAR_FUN_ATTR uint8_t fptoui_f32_i8(float x) { + if (futrts_isnan32(x) || futrts_isinf32(x)) { + return 0; + } else { + return (uint8_t) (int8_t) x; + } +} + +SCALAR_FUN_ATTR uint16_t fptoui_f32_i16(float x) { + if (futrts_isnan32(x) || futrts_isinf32(x)) { + return 0; + } else { + return (uint16_t) (int16_t) x; + } +} + +SCALAR_FUN_ATTR uint32_t fptoui_f32_i32(float x) { + if (futrts_isnan32(x) || futrts_isinf32(x)) { + return 0; + } else { + return (uint32_t) (int32_t) x; + } +} + +SCALAR_FUN_ATTR uint64_t fptoui_f32_i64(float x) { + if (futrts_isnan32(x) || futrts_isinf32(x)) { + return 0; + } else { + return (uint64_t) (int64_t) x; + } +} + +SCALAR_FUN_ATTR bool ftob_f32_bool(float x) { + return x != 0; +} + +SCALAR_FUN_ATTR float btof_bool_f32(bool x) { + return x ? 1 : 0; +} + +#ifdef __OPENCL_VERSION__ +SCALAR_FUN_ATTR float futrts_log32(float x) { + return log(x); +} + +SCALAR_FUN_ATTR float futrts_log2_32(float x) { + return log2(x); +} + +SCALAR_FUN_ATTR float futrts_log10_32(float x) { + return log10(x); +} + +SCALAR_FUN_ATTR float futrts_log1p_32(float x) { + return log1p(x); +} + +SCALAR_FUN_ATTR float futrts_sqrt32(float x) { + return sqrt(x); +} + +SCALAR_FUN_ATTR float futrts_cbrt32(float x) { + return cbrt(x); +} + +SCALAR_FUN_ATTR float futrts_exp32(float x) { + return exp(x); +} + +SCALAR_FUN_ATTR float futrts_cos32(float x) { + return cos(x); +} + +SCALAR_FUN_ATTR float futrts_sin32(float x) { + return sin(x); +} + +SCALAR_FUN_ATTR float futrts_tan32(float x) { + return tan(x); +} + +SCALAR_FUN_ATTR float futrts_acos32(float x) { + return acos(x); +} + +SCALAR_FUN_ATTR float futrts_asin32(float x) { + return asin(x); +} + +SCALAR_FUN_ATTR float futrts_atan32(float x) { + return atan(x); +} + +SCALAR_FUN_ATTR float futrts_cosh32(float x) { + return cosh(x); +} + +SCALAR_FUN_ATTR float futrts_sinh32(float x) { + return sinh(x); +} + +SCALAR_FUN_ATTR float futrts_tanh32(float x) { + return tanh(x); +} + +SCALAR_FUN_ATTR float futrts_acosh32(float x) { + return acosh(x); +} + +SCALAR_FUN_ATTR float futrts_asinh32(float x) { + return asinh(x); +} + +SCALAR_FUN_ATTR float futrts_atanh32(float x) { + return atanh(x); +} + +SCALAR_FUN_ATTR float futrts_atan2_32(float x, float y) { + return atan2(x, y); +} + +SCALAR_FUN_ATTR float futrts_hypot32(float x, float y) { + return hypot(x, y); +} + +SCALAR_FUN_ATTR float futrts_gamma32(float x) { + return tgamma(x); +} + +SCALAR_FUN_ATTR float futrts_lgamma32(float x) { + return lgamma(x); +} + +SCALAR_FUN_ATTR float futrts_erf32(float x) { + return erf(x); +} + +SCALAR_FUN_ATTR float futrts_erfc32(float x) { + return erfc(x); +} + +SCALAR_FUN_ATTR float fmod32(float x, float y) { + return fmod(x, y); +} + +SCALAR_FUN_ATTR float futrts_round32(float x) { + return rint(x); +} + +SCALAR_FUN_ATTR float futrts_floor32(float x) { + return floor(x); +} + +SCALAR_FUN_ATTR float futrts_ceil32(float x) { + return ceil(x); +} + +SCALAR_FUN_ATTR float futrts_nextafter32(float x, float y) { + return nextafter(x, y); +} + +SCALAR_FUN_ATTR float futrts_lerp32(float v0, float v1, float t) { + return mix(v0, v1, t); +} + +SCALAR_FUN_ATTR float futrts_mad32(float a, float b, float c) { + return mad(a, b, c); +} + +SCALAR_FUN_ATTR float futrts_fma32(float a, float b, float c) { + return fma(a, b, c); +} + +#elif ISPC + +SCALAR_FUN_ATTR float futrts_log32(float x) { + return futrts_isfinite32(x) || (futrts_isinf32(x) && x < 0)? log(x) : x; +} + +SCALAR_FUN_ATTR float futrts_log2_32(float x) { + return futrts_log32(x) / log(2.0f); +} + +SCALAR_FUN_ATTR float futrts_log10_32(float x) { + return futrts_log32(x) / log(10.0f); +} + +SCALAR_FUN_ATTR float futrts_log1p_32(float x) { + if(x == -1.0f || (futrts_isinf32(x) && x > 0.0f)) return x / 0.0f; + float y = 1.0f + x; + float z = y - 1.0f; + return log(y) - (z-x)/y; +} + +SCALAR_FUN_ATTR float futrts_sqrt32(float x) { + return sqrt(x); +} + +extern "C" unmasked uniform float cbrtf(uniform float); +SCALAR_FUN_ATTR float futrts_cbrt32(float x) { + float res; + foreach_active (i) { + uniform float r = cbrtf(extract(x, i)); + res = insert(res, i, r); + } + return res; +} + +SCALAR_FUN_ATTR float futrts_exp32(float x) { + return exp(x); +} + +SCALAR_FUN_ATTR float futrts_cos32(float x) { + return cos(x); +} + +SCALAR_FUN_ATTR float futrts_sin32(float x) { + return sin(x); +} + +SCALAR_FUN_ATTR float futrts_tan32(float x) { + return tan(x); +} + +SCALAR_FUN_ATTR float futrts_acos32(float x) { + return acos(x); +} + +SCALAR_FUN_ATTR float futrts_asin32(float x) { + return asin(x); +} + +SCALAR_FUN_ATTR float futrts_atan32(float x) { + return atan(x); +} + +SCALAR_FUN_ATTR float futrts_cosh32(float x) { + return (exp(x)+exp(-x)) / 2.0f; +} + +SCALAR_FUN_ATTR float futrts_sinh32(float x) { + return (exp(x)-exp(-x)) / 2.0f; +} + +SCALAR_FUN_ATTR float futrts_tanh32(float x) { + return futrts_sinh32(x)/futrts_cosh32(x); +} + +SCALAR_FUN_ATTR float futrts_acosh32(float x) { + float f = x+sqrt(x*x-1); + if(futrts_isfinite32(f)) return log(f); + return f; +} + +SCALAR_FUN_ATTR float futrts_asinh32(float x) { + float f = x+sqrt(x*x+1); + if(futrts_isfinite32(f)) return log(f); + return f; + +} + +SCALAR_FUN_ATTR float futrts_atanh32(float x) { + float f = (1+x)/(1-x); + if(futrts_isfinite32(f)) return log(f)/2.0f; + return f; + +} + +SCALAR_FUN_ATTR float futrts_atan2_32(float x, float y) { + return (x == 0.0f && y == 0.0f) ? 0.0f : atan2(x, y); +} + +SCALAR_FUN_ATTR float futrts_hypot32(float x, float y) { + if (futrts_isfinite32(x) && futrts_isfinite32(y)) { + x = abs(x); + y = abs(y); + float a; + float b; + if (x >= y){ + a = x; + b = y; + } else { + a = y; + b = x; + } + if(b == 0){ + return a; + } + + int e; + float an; + float bn; + an = frexp (a, &e); + bn = ldexp (b, - e); + float cn; + cn = sqrt (an * an + bn * bn); + return ldexp (cn, e); + } else { + if (futrts_isinf32(x) || futrts_isinf32(y)) return INFINITY; + else return x + y; + } + +} + +extern "C" unmasked uniform float tgammaf(uniform float x); +SCALAR_FUN_ATTR float futrts_gamma32(float x) { + float res; + foreach_active (i) { + uniform float r = tgammaf(extract(x, i)); + res = insert(res, i, r); + } + return res; +} + +extern "C" unmasked uniform float lgammaf(uniform float x); +SCALAR_FUN_ATTR float futrts_lgamma32(float x) { + float res; + foreach_active (i) { + uniform float r = lgammaf(extract(x, i)); + res = insert(res, i, r); + } + return res; +} + +extern "C" unmasked uniform float erff(uniform float x); +SCALAR_FUN_ATTR float futrts_erf32(float x) { + float res; + foreach_active (i) { + uniform float r = erff(extract(x, i)); + res = insert(res, i, r); + } + return res; +} + +extern "C" unmasked uniform float erfcf(uniform float x); +SCALAR_FUN_ATTR float futrts_erfc32(float x) { + float res; + foreach_active (i) { + uniform float r = erfcf(extract(x, i)); + res = insert(res, i, r); + } + return res; +} + +SCALAR_FUN_ATTR float fmod32(float x, float y) { + return x - y * trunc(x/y); +} + +SCALAR_FUN_ATTR float futrts_round32(float x) { + return round(x); +} + +SCALAR_FUN_ATTR float futrts_floor32(float x) { + return floor(x); +} + +SCALAR_FUN_ATTR float futrts_ceil32(float x) { + return ceil(x); +} + +extern "C" unmasked uniform float nextafterf(uniform float x, uniform float y); +SCALAR_FUN_ATTR float futrts_nextafter32(float x, float y) { + float res; + foreach_active (i) { + uniform float r = nextafterf(extract(x, i), extract(y, i)); + res = insert(res, i, r); + } + return res; +} + +SCALAR_FUN_ATTR float futrts_lerp32(float v0, float v1, float t) { + return v0 + (v1 - v0) * t; +} + +SCALAR_FUN_ATTR float futrts_mad32(float a, float b, float c) { + return a * b + c; +} + +SCALAR_FUN_ATTR float futrts_fma32(float a, float b, float c) { + return a * b + c; +} + +#else // Not OpenCL or ISPC, but CUDA or plain C. + +SCALAR_FUN_ATTR float futrts_log32(float x) { + return logf(x); +} + +SCALAR_FUN_ATTR float futrts_log2_32(float x) { + return log2f(x); +} + +SCALAR_FUN_ATTR float futrts_log10_32(float x) { + return log10f(x); +} + +SCALAR_FUN_ATTR float futrts_log1p_32(float x) { + return log1pf(x); +} + +SCALAR_FUN_ATTR float futrts_sqrt32(float x) { + return sqrtf(x); +} + +SCALAR_FUN_ATTR float futrts_cbrt32(float x) { + return cbrtf(x); +} + +SCALAR_FUN_ATTR float futrts_exp32(float x) { + return expf(x); +} + +SCALAR_FUN_ATTR float futrts_cos32(float x) { + return cosf(x); +} + +SCALAR_FUN_ATTR float futrts_sin32(float x) { + return sinf(x); +} + +SCALAR_FUN_ATTR float futrts_tan32(float x) { + return tanf(x); +} + +SCALAR_FUN_ATTR float futrts_acos32(float x) { + return acosf(x); +} + +SCALAR_FUN_ATTR float futrts_asin32(float x) { + return asinf(x); +} + +SCALAR_FUN_ATTR float futrts_atan32(float x) { + return atanf(x); +} + +SCALAR_FUN_ATTR float futrts_cosh32(float x) { + return coshf(x); +} + +SCALAR_FUN_ATTR float futrts_sinh32(float x) { + return sinhf(x); +} + +SCALAR_FUN_ATTR float futrts_tanh32(float x) { + return tanhf(x); +} + +SCALAR_FUN_ATTR float futrts_acosh32(float x) { + return acoshf(x); +} + +SCALAR_FUN_ATTR float futrts_asinh32(float x) { + return asinhf(x); +} + +SCALAR_FUN_ATTR float futrts_atanh32(float x) { + return atanhf(x); +} + +SCALAR_FUN_ATTR float futrts_atan2_32(float x, float y) { + return atan2f(x, y); +} + +SCALAR_FUN_ATTR float futrts_hypot32(float x, float y) { + return hypotf(x, y); +} + +SCALAR_FUN_ATTR float futrts_gamma32(float x) { + return tgammaf(x); +} + +SCALAR_FUN_ATTR float futrts_lgamma32(float x) { + return lgammaf(x); +} + +SCALAR_FUN_ATTR float futrts_erf32(float x) { + return erff(x); +} + +SCALAR_FUN_ATTR float futrts_erfc32(float x) { + return erfcf(x); +} + +SCALAR_FUN_ATTR float fmod32(float x, float y) { + return fmodf(x, y); +} + +SCALAR_FUN_ATTR float futrts_round32(float x) { + return rintf(x); +} + +SCALAR_FUN_ATTR float futrts_floor32(float x) { + return floorf(x); +} + +SCALAR_FUN_ATTR float futrts_ceil32(float x) { + return ceilf(x); +} + +SCALAR_FUN_ATTR float futrts_nextafter32(float x, float y) { + return nextafterf(x, y); +} + +SCALAR_FUN_ATTR float futrts_lerp32(float v0, float v1, float t) { + return v0 + (v1 - v0) * t; +} + +SCALAR_FUN_ATTR float futrts_mad32(float a, float b, float c) { + return a * b + c; +} + +SCALAR_FUN_ATTR float futrts_fma32(float a, float b, float c) { + return fmaf(a, b, c); +} +#endif + +#if 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); +} +#else +SCALAR_FUN_ATTR int32_t futrts_to_bits32(float x) { + union { + float f; + int32_t t; + } p; + + p.f = x; + return p.t; +} + +SCALAR_FUN_ATTR float futrts_from_bits32(int32_t x) { + union { + int32_t f; + float t; + } p; + + p.f = x; + return p.t; +} +#endif + +SCALAR_FUN_ATTR float fsignum32(float x) { + return futrts_isnan32(x) ? x : (x > 0 ? 1 : 0) - (x < 0 ? 1 : 0); +} + +#ifdef FUTHARK_F64_ENABLED + +#if ISPC +SCALAR_FUN_ATTR bool futrts_isinf64(float x) { + return !isnan(x) && isnan(x - x); +} + +SCALAR_FUN_ATTR bool futrts_isfinite64(float x) { + return !isnan(x) && !futrts_isinf64(x); +} + +SCALAR_FUN_ATTR double fdiv64(double x, double y) { + return x / y; +} + +SCALAR_FUN_ATTR double fadd64(double x, double y) { + return x + y; +} + +SCALAR_FUN_ATTR double fsub64(double x, double y) { + return x - y; +} + +SCALAR_FUN_ATTR double fmul64(double x, double y) { + return x * y; +} + +SCALAR_FUN_ATTR bool cmplt64(double x, double y) { + return x < y; +} + +SCALAR_FUN_ATTR bool cmple64(double x, double y) { + return x <= y; +} + +SCALAR_FUN_ATTR double sitofp_i8_f64(int8_t x) { + return (double) x; +} + +SCALAR_FUN_ATTR double sitofp_i16_f64(int16_t x) { + return (double) x; +} + +SCALAR_FUN_ATTR double sitofp_i32_f64(int32_t x) { + return (double) x; +} + +SCALAR_FUN_ATTR double sitofp_i64_f64(int64_t x) { + return (double) x; +} + +SCALAR_FUN_ATTR double uitofp_i8_f64(uint8_t x) { + return (double) x; +} + +SCALAR_FUN_ATTR double uitofp_i16_f64(uint16_t x) { + return (double) x; +} + +SCALAR_FUN_ATTR double uitofp_i32_f64(uint32_t x) { + return (double) x; +} + +SCALAR_FUN_ATTR double uitofp_i64_f64(uint64_t x) { + return (double) x; +} + +SCALAR_FUN_ATTR double fabs64(double x) { + return abs(x); +} + +SCALAR_FUN_ATTR double fmax64(double x, double y) { + return isnan(x) ? y : isnan(y) ? x : max(x, y); +} + +SCALAR_FUN_ATTR double fmin64(double x, double y) { + return isnan(x) ? y : isnan(y) ? x : min(x, y); +} + +SCALAR_FUN_ATTR double fpow64(double a, double b) { + float ret; + foreach_active (i) { + uniform float r = __stdlib_powf(extract(a, i), extract(b, i)); + ret = insert(ret, i, r); + } + return ret; +} + +SCALAR_FUN_ATTR double futrts_log64(double x) { + return futrts_isfinite64(x) || (futrts_isinf64(x) && x < 0)? log(x) : x; +} + +SCALAR_FUN_ATTR double futrts_log2_64(double x) { + return futrts_log64(x)/log(2.0d); +} + +SCALAR_FUN_ATTR double futrts_log10_64(double x) { + return futrts_log64(x)/log(10.0d); +} + +SCALAR_FUN_ATTR double futrts_log1p_64(double x) { + if(x == -1.0d || (futrts_isinf64(x) && x > 0.0d)) return x / 0.0d; + double y = 1.0d + x; + double z = y - 1.0d; + return log(y) - (z-x)/y; +} + +SCALAR_FUN_ATTR double futrts_sqrt64(double x) { + return sqrt(x); +} + +extern "C" unmasked uniform double cbrt(uniform double); +SCALAR_FUN_ATTR double futrts_cbrt64(double x) { + double res; + foreach_active (i) { + uniform double r = cbrtf(extract(x, i)); + res = insert(res, i, r); + } + return res; +} + +SCALAR_FUN_ATTR double futrts_exp64(double x) { + return exp(x); +} + +SCALAR_FUN_ATTR double futrts_cos64(double x) { + return cos(x); +} + +SCALAR_FUN_ATTR double futrts_sin64(double x) { + return sin(x); +} + +SCALAR_FUN_ATTR double futrts_tan64(double x) { + return tan(x); +} + +SCALAR_FUN_ATTR double futrts_acos64(double x) { + return acos(x); +} + +SCALAR_FUN_ATTR double futrts_asin64(double x) { + return asin(x); +} + +SCALAR_FUN_ATTR double futrts_atan64(double x) { + return atan(x); +} + +SCALAR_FUN_ATTR double futrts_cosh64(double x) { + return (exp(x)+exp(-x)) / 2.0d; +} + +SCALAR_FUN_ATTR double futrts_sinh64(double x) { + return (exp(x)-exp(-x)) / 2.0d; +} + +SCALAR_FUN_ATTR double futrts_tanh64(double x) { + return futrts_sinh64(x)/futrts_cosh64(x); +} + +SCALAR_FUN_ATTR double futrts_acosh64(double x) { + double f = x+sqrt(x*x-1.0d); + if(futrts_isfinite64(f)) return log(f); + return f; +} + +SCALAR_FUN_ATTR double futrts_asinh64(double x) { + double f = x+sqrt(x*x+1.0d); + if(futrts_isfinite64(f)) return log(f); + return f; +} + +SCALAR_FUN_ATTR double futrts_atanh64(double x) { + double f = (1.0d+x)/(1.0d-x); + if(futrts_isfinite64(f)) return log(f)/2.0d; + return f; + +} + +SCALAR_FUN_ATTR double futrts_atan2_64(double x, double y) { + return atan2(x, y); +} + +extern "C" unmasked uniform double hypot(uniform double x, uniform double y); +SCALAR_FUN_ATTR double futrts_hypot64(double x, double y) { + double res; + foreach_active (i) { + uniform double r = hypot(extract(x, i), extract(y, i)); + res = insert(res, i, r); + } + return res; +} + +extern "C" unmasked uniform double tgamma(uniform double x); +SCALAR_FUN_ATTR double futrts_gamma64(double x) { + double res; + foreach_active (i) { + uniform double r = tgamma(extract(x, i)); + res = insert(res, i, r); + } + return res; +} + +extern "C" unmasked uniform double lgamma(uniform double x); +SCALAR_FUN_ATTR double futrts_lgamma64(double x) { + double res; + foreach_active (i) { + uniform double r = lgamma(extract(x, i)); + res = insert(res, i, r); + } + return res; +} + +extern "C" unmasked uniform double erf(uniform double x); +SCALAR_FUN_ATTR double futrts_erf64(double x) { + double res; + foreach_active (i) { + uniform double r = erf(extract(x, i)); + res = insert(res, i, r); + } + return res; +} + +extern "C" unmasked uniform double erfc(uniform double x); +SCALAR_FUN_ATTR double futrts_erfc64(double x) { + double res; + foreach_active (i) { + uniform double r = erfc(extract(x, i)); + res = insert(res, i, r); + } + return res; +} + +SCALAR_FUN_ATTR double futrts_fma64(double a, double b, double c) { + return a * b + c; +} + +SCALAR_FUN_ATTR double futrts_round64(double x) { + return round(x); +} + +SCALAR_FUN_ATTR double futrts_ceil64(double x) { + return ceil(x); +} + +extern "C" unmasked uniform double nextafter(uniform float x, uniform double y); +SCALAR_FUN_ATTR float futrts_nextafter64(double x, double y) { + double res; + foreach_active (i) { + uniform double r = nextafter(extract(x, i), extract(y, i)); + res = insert(res, i, r); + } + return res; +} + +SCALAR_FUN_ATTR double futrts_floor64(double x) { + return floor(x); +} + +SCALAR_FUN_ATTR bool futrts_isnan64(double x) { + return isnan(x); +} + +SCALAR_FUN_ATTR int8_t fptosi_f64_i8(double x) { + if (futrts_isnan64(x) || futrts_isinf64(x)) { + return 0; + } else { + return (int8_t) x; + } +} + +SCALAR_FUN_ATTR int16_t fptosi_f64_i16(double x) { + if (futrts_isnan64(x) || futrts_isinf64(x)) { + return 0; + } else { + return (int16_t) x; + } +} + +SCALAR_FUN_ATTR int32_t fptosi_f64_i32(double x) { + if (futrts_isnan64(x) || futrts_isinf64(x)) { + return 0; + } else { + return (int32_t) x; + } +} + +SCALAR_FUN_ATTR int64_t fptosi_f64_i64(double x) { + if (futrts_isnan64(x) || futrts_isinf64(x)) { + return 0; + } else { + return (int64_t) x; + } +} + +SCALAR_FUN_ATTR uint8_t fptoui_f64_i8(double x) { + if (futrts_isnan64(x) || futrts_isinf64(x)) { + return 0; + } else { + return (uint8_t) (int8_t) x; + } +} + +SCALAR_FUN_ATTR uint16_t fptoui_f64_i16(double x) { + if (futrts_isnan64(x) || futrts_isinf64(x)) { + return 0; + } else { + return (uint16_t) (int16_t) x; + } +} + +SCALAR_FUN_ATTR uint32_t fptoui_f64_i32(double x) { + if (futrts_isnan64(x) || futrts_isinf64(x)) { + return 0; + } else { + return (uint32_t) (int32_t) x; + } +} + +SCALAR_FUN_ATTR uint64_t fptoui_f64_i64(double x) { + if (futrts_isnan64(x) || futrts_isinf64(x)) { + return 0; + } else { + return (uint64_t) (int64_t) x; + } +} + +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) { + int64_t res; + foreach_active (i) { + uniform double tmp = extract(x, i); + uniform int64_t r = *((uniform int64_t* uniform)&tmp); + res = insert(res, i, r); + } + return res; +} + +SCALAR_FUN_ATTR double futrts_from_bits64(int64_t x) { + double res; + foreach_active (i) { + uniform int64_t tmp = extract(x, i); + uniform double r = *((uniform double* uniform)&tmp); + res = insert(res, i, r); + } + return res; +} + +SCALAR_FUN_ATTR double fmod64(double x, double y) { + return x - y * trunc(x/y); +} + +SCALAR_FUN_ATTR double fsignum64(double x) { + return futrts_isnan64(x) ? x : (x > 0 ? 1.0d : 0.0d) - (x < 0 ? 1.0d : 0.0d); +} + +SCALAR_FUN_ATTR double futrts_lerp64(double v0, double v1, double t) { + return v0 + (v1 - v0) * t; +} + +SCALAR_FUN_ATTR double futrts_mad64(double a, double b, double c) { + return a * b + c; +} + +SCALAR_FUN_ATTR float fpconv_f32_f32(float x) { + return (float) x; +} + +SCALAR_FUN_ATTR double fpconv_f32_f64(float x) { + return (double) x; +} + +SCALAR_FUN_ATTR float fpconv_f64_f32(double x) { + return (float) x; +} + +SCALAR_FUN_ATTR double fpconv_f64_f64(double x) { + return (double) x; +} + +#else + +SCALAR_FUN_ATTR double fdiv64(double x, double y) { + return x / y; +} + +SCALAR_FUN_ATTR double fadd64(double x, double y) { + return x + y; +} + +SCALAR_FUN_ATTR double fsub64(double x, double y) { + return x - y; +} + +SCALAR_FUN_ATTR double fmul64(double x, double y) { + return x * y; +} + +SCALAR_FUN_ATTR bool cmplt64(double x, double y) { + return x < y; +} + +SCALAR_FUN_ATTR bool cmple64(double x, double y) { + return x <= y; +} + +SCALAR_FUN_ATTR double sitofp_i8_f64(int8_t x) { + return (double) x; +} + +SCALAR_FUN_ATTR double sitofp_i16_f64(int16_t x) { + return (double) x; +} + +SCALAR_FUN_ATTR double sitofp_i32_f64(int32_t x) { + return (double) x; +} + +SCALAR_FUN_ATTR double sitofp_i64_f64(int64_t x) { + return (double) x; +} + +SCALAR_FUN_ATTR double uitofp_i8_f64(uint8_t x) { + return (double) x; +} + +SCALAR_FUN_ATTR double uitofp_i16_f64(uint16_t x) { + return (double) x; +} + +SCALAR_FUN_ATTR double uitofp_i32_f64(uint32_t x) { + return (double) x; +} + +SCALAR_FUN_ATTR double uitofp_i64_f64(uint64_t x) { + return (double) x; +} + +SCALAR_FUN_ATTR double fabs64(double x) { + return fabs(x); +} + +SCALAR_FUN_ATTR double fmax64(double x, double y) { + return fmax(x, y); +} + +SCALAR_FUN_ATTR double fmin64(double x, double y) { + return fmin(x, y); +} + +SCALAR_FUN_ATTR double fpow64(double x, double y) { + return pow(x, y); +} + +SCALAR_FUN_ATTR double futrts_log64(double x) { + return log(x); +} + +SCALAR_FUN_ATTR double futrts_log2_64(double x) { + return log2(x); +} + +SCALAR_FUN_ATTR double futrts_log10_64(double x) { + return log10(x); +} + +SCALAR_FUN_ATTR double futrts_log1p_64(double x) { + return log1p(x); +} + +SCALAR_FUN_ATTR double futrts_sqrt64(double x) { + return sqrt(x); +} + +SCALAR_FUN_ATTR double futrts_cbrt64(double x) { + return cbrt(x); +} + +SCALAR_FUN_ATTR double futrts_exp64(double x) { + return exp(x); +} + +SCALAR_FUN_ATTR double futrts_cos64(double x) { + return cos(x); +} + +SCALAR_FUN_ATTR double futrts_sin64(double x) { + return sin(x); +} + +SCALAR_FUN_ATTR double futrts_tan64(double x) { + return tan(x); +} + +SCALAR_FUN_ATTR double futrts_acos64(double x) { + return acos(x); +} + +SCALAR_FUN_ATTR double futrts_asin64(double x) { + return asin(x); +} + +SCALAR_FUN_ATTR double futrts_atan64(double x) { + return atan(x); +} + +SCALAR_FUN_ATTR double futrts_cosh64(double x) { + return cosh(x); +} + +SCALAR_FUN_ATTR double futrts_sinh64(double x) { + return sinh(x); +} + +SCALAR_FUN_ATTR double futrts_tanh64(double x) { + return tanh(x); +} + +SCALAR_FUN_ATTR double futrts_acosh64(double x) { + return acosh(x); +} + +SCALAR_FUN_ATTR double futrts_asinh64(double x) { + return asinh(x); +} + +SCALAR_FUN_ATTR double futrts_atanh64(double x) { + return atanh(x); +} + +SCALAR_FUN_ATTR double futrts_atan2_64(double x, double y) { + return atan2(x, y); +} + +SCALAR_FUN_ATTR double futrts_hypot64(double x, double y) { + return hypot(x, y); +} + +SCALAR_FUN_ATTR double futrts_gamma64(double x) { + return tgamma(x); +} + +SCALAR_FUN_ATTR double futrts_lgamma64(double x) { + return lgamma(x); +} + +SCALAR_FUN_ATTR double futrts_erf64(double x) { + return erf(x); +} + +SCALAR_FUN_ATTR double futrts_erfc64(double x) { + return erfc(x); +} + +SCALAR_FUN_ATTR double futrts_fma64(double a, double b, double c) { + return fma(a, b, c); +} + +SCALAR_FUN_ATTR double futrts_round64(double x) { + return rint(x); +} + +SCALAR_FUN_ATTR double futrts_ceil64(double x) { + return ceil(x); +} + +SCALAR_FUN_ATTR float futrts_nextafter64(float x, float y) { + return nextafter(x, y); +} + +SCALAR_FUN_ATTR double futrts_floor64(double x) { + return floor(x); +} + +SCALAR_FUN_ATTR bool futrts_isnan64(double x) { + return isnan(x); +} + +SCALAR_FUN_ATTR bool futrts_isinf64(double x) { + return isinf(x); +} + +SCALAR_FUN_ATTR int8_t fptosi_f64_i8(double x) { + if (futrts_isnan64(x) || futrts_isinf64(x)) { + return 0; + } else { + return (int8_t) x; + } +} + +SCALAR_FUN_ATTR int16_t fptosi_f64_i16(double x) { + if (futrts_isnan64(x) || futrts_isinf64(x)) { + return 0; + } else { + return (int16_t) x; + } +} + +SCALAR_FUN_ATTR int32_t fptosi_f64_i32(double x) { + if (futrts_isnan64(x) || futrts_isinf64(x)) { + return 0; + } else { + return (int32_t) x; + } +} + +SCALAR_FUN_ATTR int64_t fptosi_f64_i64(double x) { + if (futrts_isnan64(x) || futrts_isinf64(x)) { + return 0; + } else { + return (int64_t) x; + } +} + +SCALAR_FUN_ATTR uint8_t fptoui_f64_i8(double x) { + if (futrts_isnan64(x) || futrts_isinf64(x)) { + return 0; + } else { + return (uint8_t) (int8_t) x; + } +} + +SCALAR_FUN_ATTR uint16_t fptoui_f64_i16(double x) { + if (futrts_isnan64(x) || futrts_isinf64(x)) { + return 0; + } else { + return (uint16_t) (int16_t) x; + } +} + +SCALAR_FUN_ATTR uint32_t fptoui_f64_i32(double x) { + if (futrts_isnan64(x) || futrts_isinf64(x)) { + return 0; + } else { + return (uint32_t) (int32_t) x; + } +} + +SCALAR_FUN_ATTR uint64_t fptoui_f64_i64(double x) { + if (futrts_isnan64(x) || futrts_isinf64(x)) { + return 0; + } else { + return (uint64_t) (int64_t) x; + } +} + +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) { + union { + double f; + int64_t t; + } p; + + p.f = x; + return p.t; +} + +SCALAR_FUN_ATTR double futrts_from_bits64(int64_t x) { + union { + int64_t f; + double t; + } p; + + p.f = x; + return p.t; +} + +SCALAR_FUN_ATTR double fmod64(double x, double y) { + return fmod(x, y); +} + +SCALAR_FUN_ATTR double fsignum64(double x) { + return futrts_isnan64(x) ? x : (x > 0) - (x < 0); +} + +SCALAR_FUN_ATTR double futrts_lerp64(double v0, double v1, double t) { +#ifdef __OPENCL_VERSION__ + return mix(v0, v1, t); +#else + return v0 + (v1 - v0) * t; +#endif +} + +SCALAR_FUN_ATTR double futrts_mad64(double a, double b, double c) { +#ifdef __OPENCL_VERSION__ + return mad(a, b, c); +#else + return a * b + c; +#endif +} + +SCALAR_FUN_ATTR float fpconv_f32_f32(float x) { + return (float) x; +} + +SCALAR_FUN_ATTR double fpconv_f32_f64(float x) { + return (double) x; +} + +SCALAR_FUN_ATTR float fpconv_f64_f32(double x) { + return (float) x; +} + +SCALAR_FUN_ATTR double fpconv_f64_f64(double x) { return (double) x; } 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 @@ -39,396 +39,396 @@ // Some of these functions convert to single precision because half // precision versions are not available. -static inline f16 fadd16(f16 x, f16 y) { +SCALAR_FUN_ATTR f16 fadd16(f16 x, f16 y) { return x + y; } -static inline f16 fsub16(f16 x, f16 y) { +SCALAR_FUN_ATTR f16 fsub16(f16 x, f16 y) { return x - y; } -static inline f16 fmul16(f16 x, f16 y) { +SCALAR_FUN_ATTR f16 fmul16(f16 x, f16 y) { return x * y; } -static inline bool cmplt16(f16 x, f16 y) { +SCALAR_FUN_ATTR bool cmplt16(f16 x, f16 y) { return x < y; } -static inline bool cmple16(f16 x, f16 y) { +SCALAR_FUN_ATTR bool cmple16(f16 x, f16 y) { return x <= y; } -static inline f16 sitofp_i8_f16(int8_t x) { +SCALAR_FUN_ATTR f16 sitofp_i8_f16(int8_t x) { return (f16) x; } -static inline f16 sitofp_i16_f16(int16_t x) { +SCALAR_FUN_ATTR f16 sitofp_i16_f16(int16_t x) { return (f16) x; } -static inline f16 sitofp_i32_f16(int32_t x) { +SCALAR_FUN_ATTR f16 sitofp_i32_f16(int32_t x) { return (f16) x; } -static inline f16 sitofp_i64_f16(int64_t x) { +SCALAR_FUN_ATTR f16 sitofp_i64_f16(int64_t x) { return (f16) x; } -static inline f16 uitofp_i8_f16(uint8_t x) { +SCALAR_FUN_ATTR f16 uitofp_i8_f16(uint8_t x) { return (f16) x; } -static inline f16 uitofp_i16_f16(uint16_t x) { +SCALAR_FUN_ATTR f16 uitofp_i16_f16(uint16_t x) { return (f16) x; } -static inline f16 uitofp_i32_f16(uint32_t x) { +SCALAR_FUN_ATTR f16 uitofp_i32_f16(uint32_t x) { return (f16) x; } -static inline f16 uitofp_i64_f16(uint64_t x) { +SCALAR_FUN_ATTR f16 uitofp_i64_f16(uint64_t x) { return (f16) x; } -static inline int8_t fptosi_f16_i8(f16 x) { +SCALAR_FUN_ATTR int8_t fptosi_f16_i8(f16 x) { return (int8_t) (float) x; } -static inline int16_t fptosi_f16_i16(f16 x) { +SCALAR_FUN_ATTR int16_t fptosi_f16_i16(f16 x) { return (int16_t) x; } -static inline int32_t fptosi_f16_i32(f16 x) { +SCALAR_FUN_ATTR int32_t fptosi_f16_i32(f16 x) { return (int32_t) x; } -static inline int64_t fptosi_f16_i64(f16 x) { +SCALAR_FUN_ATTR int64_t fptosi_f16_i64(f16 x) { return (int64_t) x; } -static inline uint8_t fptoui_f16_i8(f16 x) { +SCALAR_FUN_ATTR uint8_t fptoui_f16_i8(f16 x) { return (uint8_t) (float) x; } -static inline uint16_t fptoui_f16_i16(f16 x) { +SCALAR_FUN_ATTR uint16_t fptoui_f16_i16(f16 x) { return (uint16_t) x; } -static inline uint32_t fptoui_f16_i32(f16 x) { +SCALAR_FUN_ATTR uint32_t fptoui_f16_i32(f16 x) { return (uint32_t) x; } -static inline uint64_t fptoui_f16_i64(f16 x) { +SCALAR_FUN_ATTR uint64_t fptoui_f16_i64(f16 x) { return (uint64_t) x; } -static inline bool ftob_f16_bool(f16 x) { +SCALAR_FUN_ATTR bool ftob_f16_bool(f16 x) { return x != (f16)0; } -static inline f16 btof_bool_f16(bool x) { +SCALAR_FUN_ATTR f16 btof_bool_f16(bool x) { return x ? 1 : 0; } #ifndef EMULATE_F16 -static inline bool futrts_isnan16(f16 x) { +SCALAR_FUN_ATTR bool futrts_isnan16(f16 x) { return isnan((float)x); } #ifdef __OPENCL_VERSION__ -static inline f16 fabs16(f16 x) { +SCALAR_FUN_ATTR f16 fabs16(f16 x) { return fabs(x); } -static inline f16 fmax16(f16 x, f16 y) { +SCALAR_FUN_ATTR f16 fmax16(f16 x, f16 y) { return fmax(x, y); } -static inline f16 fmin16(f16 x, f16 y) { +SCALAR_FUN_ATTR f16 fmin16(f16 x, f16 y) { return fmin(x, y); } -static inline f16 fpow16(f16 x, f16 y) { +SCALAR_FUN_ATTR f16 fpow16(f16 x, f16 y) { return pow(x, y); } #elif ISPC -static inline f16 fabs16(f16 x) { +SCALAR_FUN_ATTR f16 fabs16(f16 x) { return abs(x); } -static inline f16 fmax16(f16 x, f16 y) { +SCALAR_FUN_ATTR f16 fmax16(f16 x, f16 y) { return futrts_isnan16(x) ? y : futrts_isnan16(y) ? x : max(x, y); } -static inline f16 fmin16(f16 x, f16 y) { +SCALAR_FUN_ATTR f16 fmin16(f16 x, f16 y) { return futrts_isnan16(x) ? y : futrts_isnan16(y) ? x : min(x, y); } -static inline f16 fpow16(f16 x, f16 y) { +SCALAR_FUN_ATTR f16 fpow16(f16 x, f16 y) { return pow(x, y); } #else // Assuming CUDA. -static inline f16 fabs16(f16 x) { +SCALAR_FUN_ATTR f16 fabs16(f16 x) { return fabsf(x); } -static inline f16 fmax16(f16 x, f16 y) { +SCALAR_FUN_ATTR f16 fmax16(f16 x, f16 y) { return fmaxf(x, y); } -static inline f16 fmin16(f16 x, f16 y) { +SCALAR_FUN_ATTR f16 fmin16(f16 x, f16 y) { return fminf(x, y); } -static inline f16 fpow16(f16 x, f16 y) { +SCALAR_FUN_ATTR f16 fpow16(f16 x, f16 y) { return powf(x, y); } #endif #if ISPC -static inline bool futrts_isinf16(float x) { +SCALAR_FUN_ATTR bool futrts_isinf16(float x) { return !futrts_isnan16(x) && futrts_isnan16(x - x); } -static inline bool futrts_isfinite16(float x) { +SCALAR_FUN_ATTR bool futrts_isfinite16(float x) { return !futrts_isnan16(x) && !futrts_isinf16(x); } #else -static inline bool futrts_isinf16(f16 x) { +SCALAR_FUN_ATTR bool futrts_isinf16(f16 x) { return isinf((float)x); } #endif #ifdef __OPENCL_VERSION__ -static inline f16 futrts_log16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_log16(f16 x) { return log(x); } -static inline f16 futrts_log2_16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_log2_16(f16 x) { return log2(x); } -static inline f16 futrts_log10_16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_log10_16(f16 x) { return log10(x); } -static inline f16 futrts_log1p_16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_log1p_16(f16 x) { return log1p(x); } -static inline f16 futrts_sqrt16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_sqrt16(f16 x) { return sqrt(x); } -static inline f16 futrts_cbrt16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_cbrt16(f16 x) { return cbrt(x); } -static inline f16 futrts_exp16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_exp16(f16 x) { return exp(x); } -static inline f16 futrts_cos16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_cos16(f16 x) { return cos(x); } -static inline f16 futrts_sin16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_sin16(f16 x) { return sin(x); } -static inline f16 futrts_tan16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_tan16(f16 x) { return tan(x); } -static inline f16 futrts_acos16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_acos16(f16 x) { return acos(x); } -static inline f16 futrts_asin16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_asin16(f16 x) { return asin(x); } -static inline f16 futrts_atan16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_atan16(f16 x) { return atan(x); } -static inline f16 futrts_cosh16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_cosh16(f16 x) { return cosh(x); } -static inline f16 futrts_sinh16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_sinh16(f16 x) { return sinh(x); } -static inline f16 futrts_tanh16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_tanh16(f16 x) { return tanh(x); } -static inline f16 futrts_acosh16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_acosh16(f16 x) { return acosh(x); } -static inline f16 futrts_asinh16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_asinh16(f16 x) { return asinh(x); } -static inline f16 futrts_atanh16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_atanh16(f16 x) { return atanh(x); } -static inline f16 futrts_atan2_16(f16 x, f16 y) { +SCALAR_FUN_ATTR f16 futrts_atan2_16(f16 x, f16 y) { return atan2(x, y); } -static inline f16 futrts_hypot16(f16 x, f16 y) { +SCALAR_FUN_ATTR f16 futrts_hypot16(f16 x, f16 y) { return hypot(x, y); } -static inline f16 futrts_gamma16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_gamma16(f16 x) { return tgamma(x); } -static inline f16 futrts_lgamma16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_lgamma16(f16 x) { return lgamma(x); } -static inline f16 futrts_erf16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_erf16(f16 x) { return erf(x); } -static inline f16 futrts_erfc16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_erfc16(f16 x) { return erfc(x); } -static inline f16 fmod16(f16 x, f16 y) { +SCALAR_FUN_ATTR f16 fmod16(f16 x, f16 y) { return fmod(x, y); } -static inline f16 futrts_round16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_round16(f16 x) { return rint(x); } -static inline f16 futrts_floor16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_floor16(f16 x) { return floor(x); } -static inline f16 futrts_ceil16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_ceil16(f16 x) { return ceil(x); } -static inline f16 futrts_nextafter16(f16 x, f16 y) { +SCALAR_FUN_ATTR f16 futrts_nextafter16(f16 x, f16 y) { return nextafter(x, y); } -static inline f16 futrts_lerp16(f16 v0, f16 v1, f16 t) { +SCALAR_FUN_ATTR f16 futrts_lerp16(f16 v0, f16 v1, f16 t) { return mix(v0, v1, t); } -static inline f16 futrts_mad16(f16 a, f16 b, f16 c) { +SCALAR_FUN_ATTR f16 futrts_mad16(f16 a, f16 b, f16 c) { return mad(a, b, c); } -static inline f16 futrts_fma16(f16 a, f16 b, f16 c) { +SCALAR_FUN_ATTR f16 futrts_fma16(f16 a, f16 b, f16 c) { return fma(a, b, c); } #elif ISPC -static inline f16 futrts_log16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_log16(f16 x) { return futrts_isfinite16(x) || (futrts_isinf16(x) && x < 0) ? log(x) : x; } -static inline f16 futrts_log2_16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_log2_16(f16 x) { return futrts_log16(x) / log(2.0f16); } -static inline f16 futrts_log10_16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_log10_16(f16 x) { return futrts_log16(x) / log(10.0f16); } -static inline f16 futrts_log1p_16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_log1p_16(f16 x) { if(x == -1.0f16 || (futrts_isinf16(x) && x > 0.0f16)) return x / 0.0f16; f16 y = 1.0f16 + x; f16 z = y - 1.0f16; return log(y) - (z-x)/y; } -static inline f16 futrts_sqrt16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_sqrt16(f16 x) { return (float16)sqrt((float)x); } -static inline f16 futrts_exp16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_exp16(f16 x) { return exp(x); } -static inline f16 futrts_cos16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_cos16(f16 x) { return (float16)cos((float)x); } -static inline f16 futrts_sin16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_sin16(f16 x) { return (float16)sin((float)x); } -static inline f16 futrts_tan16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_tan16(f16 x) { return (float16)tan((float)x); } -static inline f16 futrts_acos16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_acos16(f16 x) { return (float16)acos((float)x); } -static inline f16 futrts_asin16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_asin16(f16 x) { return (float16)asin((float)x); } -static inline f16 futrts_atan16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_atan16(f16 x) { return (float16)atan((float)x); } -static inline f16 futrts_cosh16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_cosh16(f16 x) { return (exp(x)+exp(-x)) / 2.0f16; } -static inline f16 futrts_sinh16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_sinh16(f16 x) { return (exp(x)-exp(-x)) / 2.0f16; } -static inline f16 futrts_tanh16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_tanh16(f16 x) { return futrts_sinh16(x)/futrts_cosh16(x); } -static inline f16 futrts_acosh16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_acosh16(f16 x) { float16 f = x+(float16)sqrt((float)(x*x-1)); if(futrts_isfinite16(f)) return log(f); return f; } -static inline f16 futrts_asinh16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_asinh16(f16 x) { float16 f = x+(float16)sqrt((float)(x*x+1)); if(futrts_isfinite16(f)) return log(f); return f; } -static inline f16 futrts_atanh16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_atanh16(f16 x) { float16 f = (1+x)/(1-x); if(futrts_isfinite16(f)) return log(f)/2.0f16; return f; } -static inline f16 futrts_atan2_16(f16 x, f16 y) { +SCALAR_FUN_ATTR f16 futrts_atan2_16(f16 x, f16 y) { return (float16)atan2((float)x, (float)y); } -static inline f16 futrts_hypot16(f16 x, f16 y) { +SCALAR_FUN_ATTR f16 futrts_hypot16(f16 x, f16 y) { return (float16)futrts_hypot32((float)x, (float)y); } extern "C" unmasked uniform float tgammaf(uniform float x); -static inline f16 futrts_gamma16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_gamma16(f16 x) { f16 res; foreach_active (i) { uniform f16 r = (f16)tgammaf(extract((float)x, i)); @@ -438,7 +438,7 @@ } extern "C" unmasked uniform float lgammaf(uniform float x); -static inline f16 futrts_lgamma16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_lgamma16(f16 x) { f16 res; foreach_active (i) { uniform f16 r = (f16)lgammaf(extract((float)x, i)); @@ -447,184 +447,184 @@ return res; } -static inline f16 futrts_cbrt16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_cbrt16(f16 x) { f16 res = (f16)futrts_cbrt32((float)x); return res; } -static inline f16 futrts_erf16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_erf16(f16 x) { f16 res = (f16)futrts_erf32((float)x); return res; } -static inline f16 futrts_erfc16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_erfc16(f16 x) { f16 res = (f16)futrts_erfc32((float)x); return res; } -static inline f16 fmod16(f16 x, f16 y) { +SCALAR_FUN_ATTR f16 fmod16(f16 x, f16 y) { return x - y * (float16)trunc((float) (x/y)); } -static inline f16 futrts_round16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_round16(f16 x) { return (float16)round((float)x); } -static inline f16 futrts_floor16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_floor16(f16 x) { return (float16)floor((float)x); } -static inline f16 futrts_ceil16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_ceil16(f16 x) { return (float16)ceil((float)x); } -static inline f16 futrts_nextafter16(f16 x, f16 y) { +SCALAR_FUN_ATTR f16 futrts_nextafter16(f16 x, f16 y) { return (float16)futrts_nextafter32((float)x, (float) y); } -static inline f16 futrts_lerp16(f16 v0, f16 v1, f16 t) { +SCALAR_FUN_ATTR f16 futrts_lerp16(f16 v0, f16 v1, f16 t) { return v0 + (v1 - v0) * t; } -static inline f16 futrts_mad16(f16 a, f16 b, f16 c) { +SCALAR_FUN_ATTR f16 futrts_mad16(f16 a, f16 b, f16 c) { return a * b + c; } -static inline f16 futrts_fma16(f16 a, f16 b, f16 c) { +SCALAR_FUN_ATTR f16 futrts_fma16(f16 a, f16 b, f16 c) { return a * b + c; } #else // Assume CUDA. -static inline f16 futrts_log16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_log16(f16 x) { return hlog(x); } -static inline f16 futrts_log2_16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_log2_16(f16 x) { return hlog2(x); } -static inline f16 futrts_log10_16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_log10_16(f16 x) { return hlog10(x); } -static inline f16 futrts_log1p_16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_log1p_16(f16 x) { return (f16)log1pf((float)x); } -static inline f16 futrts_sqrt16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_sqrt16(f16 x) { return hsqrt(x); } -static inline f16 futrts_cbrt16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_cbrt16(f16 x) { return cbrtf(x); } -static inline f16 futrts_exp16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_exp16(f16 x) { return hexp(x); } -static inline f16 futrts_cos16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_cos16(f16 x) { return hcos(x); } -static inline f16 futrts_sin16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_sin16(f16 x) { return hsin(x); } -static inline f16 futrts_tan16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_tan16(f16 x) { return tanf(x); } -static inline f16 futrts_acos16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_acos16(f16 x) { return acosf(x); } -static inline f16 futrts_asin16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_asin16(f16 x) { return asinf(x); } -static inline f16 futrts_atan16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_atan16(f16 x) { return atanf(x); } -static inline f16 futrts_cosh16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_cosh16(f16 x) { return coshf(x); } -static inline f16 futrts_sinh16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_sinh16(f16 x) { return sinhf(x); } -static inline f16 futrts_tanh16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_tanh16(f16 x) { return tanhf(x); } -static inline f16 futrts_acosh16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_acosh16(f16 x) { return acoshf(x); } -static inline f16 futrts_asinh16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_asinh16(f16 x) { return asinhf(x); } -static inline f16 futrts_atanh16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_atanh16(f16 x) { return atanhf(x); } -static inline f16 futrts_atan2_16(f16 x, f16 y) { +SCALAR_FUN_ATTR f16 futrts_atan2_16(f16 x, f16 y) { return atan2f(x, y); } -static inline f16 futrts_hypot16(f16 x, f16 y) { +SCALAR_FUN_ATTR f16 futrts_hypot16(f16 x, f16 y) { return hypotf(x, y); } -static inline f16 futrts_gamma16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_gamma16(f16 x) { return tgammaf(x); } -static inline f16 futrts_lgamma16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_lgamma16(f16 x) { return lgammaf(x); } -static inline f16 futrts_erf16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_erf16(f16 x) { return erff(x); } -static inline f16 futrts_erfc16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_erfc16(f16 x) { return erfcf(x); } -static inline f16 fmod16(f16 x, f16 y) { +SCALAR_FUN_ATTR f16 fmod16(f16 x, f16 y) { return fmodf(x, y); } -static inline f16 futrts_round16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_round16(f16 x) { return rintf(x); } -static inline f16 futrts_floor16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_floor16(f16 x) { return hfloor(x); } -static inline f16 futrts_ceil16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_ceil16(f16 x) { return hceil(x); } -static inline f16 futrts_nextafter16(f16 x, f16 y) { +SCALAR_FUN_ATTR f16 futrts_nextafter16(f16 x, f16 y) { return __ushort_as_half(halfbitsnextafter(__half_as_ushort(x), __half_as_ushort(y))); } -static inline f16 futrts_lerp16(f16 v0, f16 v1, f16 t) { +SCALAR_FUN_ATTR f16 futrts_lerp16(f16 v0, f16 v1, f16 t) { return v0 + (v1 - v0) * t; } -static inline f16 futrts_mad16(f16 a, f16 b, f16 c) { +SCALAR_FUN_ATTR f16 futrts_mad16(f16 a, f16 b, f16 c) { return a * b + c; } -static inline f16 futrts_fma16(f16 a, f16 b, f16 c) { +SCALAR_FUN_ATTR f16 futrts_fma16(f16 a, f16 b, f16 c) { return fmaf(a, b, c); } @@ -633,25 +633,25 @@ // The CUDA __half type cannot be put in unions for some reason, so we // use bespoke conversion functions instead. #ifdef __CUDA_ARCH__ -static inline int16_t futrts_to_bits16(f16 x) { +SCALAR_FUN_ATTR int16_t futrts_to_bits16(f16 x) { return __half_as_ushort(x); } -static inline f16 futrts_from_bits16(int16_t x) { +SCALAR_FUN_ATTR f16 futrts_from_bits16(int16_t x) { return __ushort_as_half(x); } #elif ISPC -static inline int16_t futrts_to_bits16(f16 x) { +SCALAR_FUN_ATTR int16_t futrts_to_bits16(f16 x) { varying int16_t y = *((varying int16_t * uniform)&x); return y; } -static inline f16 futrts_from_bits16(int16_t x) { +SCALAR_FUN_ATTR f16 futrts_from_bits16(int16_t x) { varying f16 y = *((varying f16 * uniform)&x); return y; } #else -static inline int16_t futrts_to_bits16(f16 x) { +SCALAR_FUN_ATTR int16_t futrts_to_bits16(f16 x) { union { f16 f; int16_t t; @@ -661,7 +661,7 @@ return p.t; } -static inline f16 futrts_from_bits16(int16_t x) { +SCALAR_FUN_ATTR f16 futrts_from_bits16(int16_t x) { union { int16_t f; f16 t; @@ -674,159 +674,159 @@ #else // No native f16 - emulate. -static inline f16 fabs16(f16 x) { +SCALAR_FUN_ATTR f16 fabs16(f16 x) { return fabs32(x); } -static inline f16 fmax16(f16 x, f16 y) { +SCALAR_FUN_ATTR f16 fmax16(f16 x, f16 y) { return fmax32(x, y); } -static inline f16 fmin16(f16 x, f16 y) { +SCALAR_FUN_ATTR f16 fmin16(f16 x, f16 y) { return fmin32(x, y); } -static inline f16 fpow16(f16 x, f16 y) { +SCALAR_FUN_ATTR f16 fpow16(f16 x, f16 y) { return fpow32(x, y); } -static inline bool futrts_isnan16(f16 x) { +SCALAR_FUN_ATTR bool futrts_isnan16(f16 x) { return futrts_isnan32(x); } -static inline bool futrts_isinf16(f16 x) { +SCALAR_FUN_ATTR bool futrts_isinf16(f16 x) { return futrts_isinf32(x); } -static inline f16 futrts_log16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_log16(f16 x) { return futrts_log32(x); } -static inline f16 futrts_log2_16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_log2_16(f16 x) { return futrts_log2_32(x); } -static inline f16 futrts_log10_16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_log10_16(f16 x) { return futrts_log10_32(x); } -static inline f16 futrts_log1p_16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_log1p_16(f16 x) { return futrts_log1p_32(x); } -static inline f16 futrts_sqrt16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_sqrt16(f16 x) { return futrts_sqrt32(x); } -static inline f16 futrts_cbrt16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_cbrt16(f16 x) { return futrts_cbrt32(x); } -static inline f16 futrts_exp16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_exp16(f16 x) { return futrts_exp32(x); } -static inline f16 futrts_cos16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_cos16(f16 x) { return futrts_cos32(x); } -static inline f16 futrts_sin16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_sin16(f16 x) { return futrts_sin32(x); } -static inline f16 futrts_tan16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_tan16(f16 x) { return futrts_tan32(x); } -static inline f16 futrts_acos16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_acos16(f16 x) { return futrts_acos32(x); } -static inline f16 futrts_asin16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_asin16(f16 x) { return futrts_asin32(x); } -static inline f16 futrts_atan16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_atan16(f16 x) { return futrts_atan32(x); } -static inline f16 futrts_cosh16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_cosh16(f16 x) { return futrts_cosh32(x); } -static inline f16 futrts_sinh16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_sinh16(f16 x) { return futrts_sinh32(x); } -static inline f16 futrts_tanh16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_tanh16(f16 x) { return futrts_tanh32(x); } -static inline f16 futrts_acosh16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_acosh16(f16 x) { return futrts_acosh32(x); } -static inline f16 futrts_asinh16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_asinh16(f16 x) { return futrts_asinh32(x); } -static inline f16 futrts_atanh16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_atanh16(f16 x) { return futrts_atanh32(x); } -static inline f16 futrts_atan2_16(f16 x, f16 y) { +SCALAR_FUN_ATTR f16 futrts_atan2_16(f16 x, f16 y) { return futrts_atan2_32(x, y); } -static inline f16 futrts_hypot16(f16 x, f16 y) { +SCALAR_FUN_ATTR f16 futrts_hypot16(f16 x, f16 y) { return futrts_hypot32(x, y); } -static inline f16 futrts_gamma16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_gamma16(f16 x) { return futrts_gamma32(x); } -static inline f16 futrts_lgamma16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_lgamma16(f16 x) { return futrts_lgamma32(x); } -static inline f16 futrts_erf16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_erf16(f16 x) { return futrts_erf32(x); } -static inline f16 futrts_erfc16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_erfc16(f16 x) { return futrts_erfc32(x); } -static inline f16 fmod16(f16 x, f16 y) { +SCALAR_FUN_ATTR f16 fmod16(f16 x, f16 y) { return fmod32(x, y); } -static inline f16 futrts_round16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_round16(f16 x) { return futrts_round32(x); } -static inline f16 futrts_floor16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_floor16(f16 x) { return futrts_floor32(x); } -static inline f16 futrts_ceil16(f16 x) { +SCALAR_FUN_ATTR f16 futrts_ceil16(f16 x) { return futrts_ceil32(x); } -static inline f16 futrts_nextafter16(f16 x, f16 y) { +SCALAR_FUN_ATTR f16 futrts_nextafter16(f16 x, f16 y) { return halfbits2float(halfbitsnextafter(float2halfbits(x), float2halfbits(y))); } -static inline f16 futrts_lerp16(f16 v0, f16 v1, f16 t) { +SCALAR_FUN_ATTR f16 futrts_lerp16(f16 v0, f16 v1, f16 t) { return futrts_lerp32(v0, v1, t); } -static inline f16 futrts_mad16(f16 a, f16 b, f16 c) { +SCALAR_FUN_ATTR f16 futrts_mad16(f16 a, f16 b, f16 c) { return futrts_mad32(a, b, c); } -static inline f16 futrts_fma16(f16 a, f16 b, f16 c) { +SCALAR_FUN_ATTR f16 futrts_fma16(f16 a, f16 b, f16 c) { return futrts_fma32(a, b, c); } @@ -836,28 +836,28 @@ // float. Similarly for vstore_half. #ifdef __OPENCL_VERSION__ -static inline int16_t futrts_to_bits16(f16 x) { +SCALAR_FUN_ATTR int16_t futrts_to_bits16(f16 x) { int16_t y; // Violating strict aliasing here. vstore_half((float)x, 0, (half*)&y); return y; } -static inline f16 futrts_from_bits16(int16_t x) { +SCALAR_FUN_ATTR f16 futrts_from_bits16(int16_t x) { return (f16)vload_half(0, (half*)&x); } #else -static inline int16_t futrts_to_bits16(f16 x) { +SCALAR_FUN_ATTR int16_t futrts_to_bits16(f16 x) { return (int16_t)float2halfbits(x); } -static inline f16 futrts_from_bits16(int16_t x) { +SCALAR_FUN_ATTR f16 futrts_from_bits16(int16_t x) { return halfbits2float((uint16_t)x); } -static inline f16 fsignum16(f16 x) { +SCALAR_FUN_ATTR f16 fsignum16(f16 x) { return futrts_isnan16(x) ? x : (x > 0 ? 1 : 0) - (x < 0 ? 1 : 0); } @@ -865,30 +865,30 @@ #endif -static inline float fpconv_f16_f16(f16 x) { +SCALAR_FUN_ATTR float fpconv_f16_f16(f16 x) { return x; } -static inline float fpconv_f16_f32(f16 x) { +SCALAR_FUN_ATTR float fpconv_f16_f32(f16 x) { return x; } -static inline f16 fpconv_f32_f16(float x) { +SCALAR_FUN_ATTR f16 fpconv_f32_f16(float x) { return (f16) x; } #ifdef FUTHARK_F64_ENABLED -static inline double fpconv_f16_f64(f16 x) { +SCALAR_FUN_ATTR double fpconv_f16_f64(f16 x) { return (double) x; } #if ISPC -static inline f16 fpconv_f64_f16(double x) { +SCALAR_FUN_ATTR f16 fpconv_f64_f16(double x) { return (f16) ((float)x); } #else -static inline f16 fpconv_f64_f16(double x) { +SCALAR_FUN_ATTR f16 fpconv_f64_f16(double x) { return (f16) x; } #endif diff --git a/rts/c/util.h b/rts/c/util.h --- a/rts/c/util.h +++ b/rts/c/util.h @@ -136,7 +136,78 @@ b->used += needed; } +struct cost_centre { + const char *name; + int64_t runs; + int64_t runtime; +}; +// Dynamic dictionary for tallying cost centres when aggregating +// profiling information. Not performance-critical. +struct cost_centres { + size_t capacity; + size_t used; + struct cost_centre* centres; +}; + +static struct cost_centres *cost_centres_new() { + struct cost_centres *ccs = malloc(sizeof(struct cost_centres)); + ccs->capacity = 100; + ccs->used = 0; + ccs->centres = calloc(ccs->capacity, sizeof(struct cost_centre)); + return ccs; +} + +static void cost_centres_free(struct cost_centres* ccs) { + free(ccs->centres); + free(ccs); +} + +static void cost_centres_init(struct cost_centres* ccs, const char *name) { + if (ccs->used == ccs->capacity) { + ccs->capacity *= 2; + ccs->centres = realloc(ccs->centres, ccs->capacity*sizeof(struct cost_centre)); + } + ccs->centres[ccs->used].name = name; + ccs->centres[ccs->used].runs = 0; + ccs->centres[ccs->used].runtime = 0; + ccs->used++; +} + +static void cost_centres_add(struct cost_centres* ccs, struct cost_centre c) { + size_t i = 0; + for (i = 0; i < ccs->used; i++) { + if (strcmp(c.name, ccs->centres[i].name) == 0) { + ccs->centres[i].runs += c.runs; + ccs->centres[i].runtime += c.runtime; + return; + } + } + if (i == ccs->capacity) { + ccs->capacity *= 2; + ccs->centres = realloc(ccs->centres, ccs->capacity*sizeof(struct cost_centre)); + } + ccs->centres[i] = c; + ccs->used++; +} + +static void cost_centre_report(struct cost_centres* ccs, struct str_builder *b) { + int64_t total_runs = 0; + int64_t total_runtime = 0; + for (size_t i = 0; i < ccs->used; i++) { + struct cost_centre c = ccs->centres[i]; + str_builder(b, + "%-40s ran %5d times; avg %8ldus; total: %8ldus\n", + c.name, + c.runs, c.runs == 0 ? 0 : c.runtime/c.runs, c.runtime); + total_runs += c.runs; + total_runtime += c.runtime; + } + str_builder(b, + "%d operations with cumulative runtime: %6ldus\n", + total_runs, total_runtime); +} + static char *strclone(const char *str) { size_t size = strlen(str) + 1; char *copy = (char*) malloc(size); @@ -146,6 +217,25 @@ memcpy(copy, str, size); return copy; +} + +// Assumes NULL-terminated. +static char *strconcat(const char *src_fragments[]) { + size_t src_len = 0; + const char **p; + + for (p = src_fragments; *p; p++) { + src_len += strlen(*p); + } + + char *src = (char*) malloc(src_len + 1); + size_t n = 0; + for (p = src_fragments; *p; p++) { + strcpy(src + n, *p); + n += strlen(*p); + } + + return src; } // End of util.h. diff --git a/rts/cuda/prelude.cu b/rts/cuda/prelude.cu new file mode 100644 --- /dev/null +++ b/rts/cuda/prelude.cu @@ -0,0 +1,102 @@ +// start of prelude.cu + +#define SCALAR_FUN_ATTR __device__ static inline +#define FUTHARK_FUN_ATTR __device__ static +#define FUTHARK_F64_ENABLED + +typedef char int8_t; +typedef short int16_t; +typedef int int32_t; +typedef long long int64_t; +typedef unsigned char uint8_t; +typedef unsigned short uint16_t; +typedef unsigned int uint32_t; +typedef unsigned long long uint64_t; + +#define __global +#define __local +#define __private +#define __constant +#define __write_only +#define __read_only + +static inline __device__ int get_group_id(int d) { + switch (d) { + case 0: return blockIdx.x; + case 1: return blockIdx.y; + case 2: return blockIdx.z; + default: return 0; + } +} + +static inline __device__ int get_num_groups(int d) { + switch(d) { + case 0: return gridDim.x; + case 1: return gridDim.y; + case 2: return gridDim.z; + default: return 0; + } +} + +static inline __device__ int get_global_id(int d) { + switch (d) { + case 0: return threadIdx.x + blockIdx.x * blockDim.x; + case 1: return threadIdx.y + blockIdx.y * blockDim.y; + case 2: return threadIdx.z + blockIdx.z * blockDim.z; + default: return 0; + } +} + +static inline __device__ int get_local_id(int d) { + switch (d) { + case 0: return threadIdx.x; + case 1: return threadIdx.y; + case 2: return threadIdx.z; + default: return 0; + } +} + +static inline __device__ int get_local_size(int d) { + switch (d) { + case 0: return blockDim.x; + case 1: return blockDim.y; + case 2: return blockDim.z; + default: return 0; + } +} + +static inline __device__ int get_global_size(int d) { + switch (d) { + case 0: return gridDim.x * blockDim.x; + case 1: return gridDim.y * blockDim.y; + case 2: return gridDim.z * blockDim.z; + default: return 0; + } +} + + +#define CLK_LOCAL_MEM_FENCE 1 +#define CLK_GLOBAL_MEM_FENCE 2 +static inline __device__ void barrier(int x) { + __syncthreads(); +} +static inline __device__ void mem_fence_local() { + __threadfence_block(); +} +static inline __device__ void mem_fence_global() { + __threadfence(); +} + +static inline __device__ void barrier_local() { + __syncthreads(); +} + +#define NAN (0.0/0.0) +#define INFINITY (1.0/0.0) +extern volatile __shared__ unsigned char local_mem[]; + +#define LOCAL_MEM_PARAM +#define FUTHARK_KERNEL extern "C" __global__ __launch_bounds__(MAX_THREADS_PER_BLOCK) +#define FUTHARK_KERNEL_SIZED(a,b,c) extern "C" __global__ __launch_bounds__(a*b*c) + +// End of prelude.cu diff --git a/rts/opencl/copy.cl b/rts/opencl/copy.cl new file mode 100644 --- /dev/null +++ b/rts/opencl/copy.cl @@ -0,0 +1,83 @@ +// Start of copy.cl + +#define GEN_COPY_KERNEL(NAME, ELEM_TYPE) \ +FUTHARK_KERNEL void lmad_copy_##NAME(LOCAL_MEM_PARAM \ + __global ELEM_TYPE *dst_mem, \ + int64_t dst_offset, \ + __global ELEM_TYPE *src_mem, \ + int64_t src_offset, \ + int64_t n, \ + int r, \ + int64_t shape0, int64_t dst_stride0, int64_t src_stride0, \ + int64_t shape1, int64_t dst_stride1, int64_t src_stride1, \ + int64_t shape2, int64_t dst_stride2, int64_t src_stride2, \ + int64_t shape3, int64_t dst_stride3, int64_t src_stride3, \ + int64_t shape4, int64_t dst_stride4, int64_t src_stride4, \ + int64_t shape5, int64_t dst_stride5, int64_t src_stride5, \ + int64_t shape6, int64_t dst_stride6, int64_t src_stride6, \ + int64_t shape7, int64_t dst_stride7, int64_t src_stride7) { \ + int64_t gtid = get_global_id(0); \ + int64_t remainder = gtid; \ + \ + if (gtid >= n) { \ + return; \ + } \ + \ + if (r > 0) { \ + int64_t i = remainder % shape0; \ + dst_offset += i * dst_stride0; \ + src_offset += i * src_stride0; \ + remainder /= shape0; \ + } \ + if (r > 1) { \ + int64_t i = remainder % shape1; \ + dst_offset += i * dst_stride1; \ + src_offset += i * src_stride1; \ + remainder /= shape1; \ + } \ + if (r > 2) { \ + int64_t i = remainder % shape2; \ + dst_offset += i * dst_stride2; \ + src_offset += i * src_stride2; \ + remainder /= shape2; \ + } \ + if (r > 3) { \ + int64_t i = remainder % shape3; \ + dst_offset += i * dst_stride3; \ + src_offset += i * src_stride3; \ + remainder /= shape3; \ + } \ + if (r > 4) { \ + int64_t i = remainder % shape4; \ + dst_offset += i * dst_stride4; \ + src_offset += i * src_stride4; \ + remainder /= shape4; \ + } \ + if (r > 5) { \ + int64_t i = remainder % shape5; \ + dst_offset += i * dst_stride5; \ + src_offset += i * src_stride5; \ + remainder /= shape5; \ + } \ + if (r > 6) { \ + int64_t i = remainder % shape6; \ + dst_offset += i * dst_stride6; \ + src_offset += i * src_stride6; \ + remainder /= shape6; \ + } \ + if (r > 7) { \ + int64_t i = remainder % shape7; \ + dst_offset += i * dst_stride7; \ + src_offset += i * src_stride7; \ + remainder /= shape7; \ + } \ + \ + dst_mem[dst_offset] = src_mem[src_offset]; \ +} + +GEN_COPY_KERNEL(1b, uint8_t) +GEN_COPY_KERNEL(2b, uint16_t) +GEN_COPY_KERNEL(4b, uint32_t) +GEN_COPY_KERNEL(8b, uint64_t) + +// End of copy.cl diff --git a/rts/opencl/prelude.cl b/rts/opencl/prelude.cl new file mode 100644 --- /dev/null +++ b/rts/opencl/prelude.cl @@ -0,0 +1,54 @@ +// Start of prelude.cl + +#define SCALAR_FUN_ATTR static inline +#define FUTHARK_FUN_ATTR static + +typedef char int8_t; +typedef short int16_t; +typedef int int32_t; +typedef long int64_t; + +typedef uchar uint8_t; +typedef ushort uint16_t; +typedef uint uint32_t; +typedef ulong uint64_t; + + +// Clang-based OpenCL implementations need this for 'static' to work. +#ifdef cl_clang_storage_class_specifiers +#pragma OPENCL EXTENSION cl_clang_storage_class_specifiers : enable +#endif +#pragma OPENCL EXTENSION cl_khr_byte_addressable_store : enable + +#ifdef FUTHARK_F64_ENABLED +#pragma OPENCL EXTENSION cl_khr_fp64 : enable +#endif + +#pragma OPENCL EXTENSION cl_khr_int64_base_atomics : enable +#pragma OPENCL EXTENSION cl_khr_int64_extended_atomics : enable + +// NVIDIAs OpenCL does not create device-wide memory fences (see #734), so we +// use inline assembly if we detect we are on an NVIDIA GPU. +#ifdef cl_nv_pragma_unroll +static inline void mem_fence_global() { + asm("membar.gl;"); +} +#else +static inline void mem_fence_global() { + mem_fence(CLK_LOCAL_MEM_FENCE | CLK_GLOBAL_MEM_FENCE); +} +#endif +static inline void mem_fence_local() { + mem_fence(CLK_LOCAL_MEM_FENCE); +} + +static inline void barrier_local() { + barrier(CLK_LOCAL_MEM_FENCE); +} + +// Important for this to be int64_t so it has proper alignment for any type. +#define LOCAL_MEM_PARAM __local uint64_t* local_mem, +#define FUTHARK_KERNEL __kernel +#define FUTHARK_KERNEL_SIZED(a,b,c) __attribute__((reqd_work_group_size(a, b, c))) __kernel + +// End of prelude.cl diff --git a/rts/opencl/transpose.cl b/rts/opencl/transpose.cl new file mode 100644 --- /dev/null +++ b/rts/opencl/transpose.cl @@ -0,0 +1,273 @@ +// Start of transpose.cl + +#define GEN_TRANSPOSE_KERNELS(NAME, ELEM_TYPE) \ +FUTHARK_KERNEL_SIZED(TR_BLOCK_DIM*2, TR_TILE_DIM/TR_ELEMS_PER_THREAD, 1)\ +void map_transpose_##NAME(LOCAL_MEM_PARAM \ + __global ELEM_TYPE *dst_mem, \ + int64_t dst_offset, \ + __global ELEM_TYPE *src_mem, \ + int64_t src_offset, \ + int32_t num_arrays, \ + int32_t x_elems, \ + int32_t y_elems, \ + int32_t mulx, \ + int32_t muly, \ + int32_t repeat_1, \ + int32_t repeat_2) { \ + (void)mulx; (void)muly; \ + __local ELEM_TYPE* block = (__local ELEM_TYPE*)local_mem; \ + int group_id_0 = get_group_id(0); \ + int global_id_0 = get_global_id(0); \ + int group_id_1 = get_group_id(1); \ + int global_id_1 = get_global_id(1); \ + for (int i1 = 0; i1 <= repeat_1; i1++) { \ + int group_id_2 = get_group_id(2); \ + int global_id_2 = get_global_id(2); \ + for (int i2 = 0; i2 <= repeat_2; i2++) { \ + int32_t our_array_offset = group_id_2 * x_elems * y_elems; \ + int32_t odata_offset = dst_offset + our_array_offset; \ + int32_t idata_offset = src_offset + our_array_offset; \ + int32_t x_index = global_id_0; \ + int32_t y_index = group_id_1 * TR_TILE_DIM + get_local_id(1); \ + if (x_index < x_elems) { \ + for (int32_t j = 0; j < TR_ELEMS_PER_THREAD; j++) { \ + int32_t index_i = (y_index + j * (TR_TILE_DIM/TR_ELEMS_PER_THREAD)) * x_elems + x_index; \ + if (y_index + j * (TR_TILE_DIM/TR_ELEMS_PER_THREAD) < y_elems) { \ + block[(get_local_id(1) + j * (TR_TILE_DIM/TR_ELEMS_PER_THREAD)) * (TR_TILE_DIM+1) + \ + get_local_id(0)] = \ + src_mem[idata_offset + index_i]; \ + } \ + } \ + } \ + barrier_local(); \ + x_index = group_id_1 * TR_TILE_DIM + get_local_id(0); \ + y_index = group_id_0 * TR_TILE_DIM + get_local_id(1); \ + if (x_index < y_elems) { \ + for (int32_t j = 0; j < TR_ELEMS_PER_THREAD; j++) { \ + int32_t index_out = (y_index + j * (TR_TILE_DIM/TR_ELEMS_PER_THREAD)) * y_elems + x_index; \ + if (y_index + j * (TR_TILE_DIM/TR_ELEMS_PER_THREAD) < x_elems) { \ + dst_mem[(odata_offset + index_out)] = \ + block[get_local_id(0) * (TR_TILE_DIM+1) + \ + get_local_id(1) + j * (TR_TILE_DIM/TR_ELEMS_PER_THREAD)]; \ + } \ + } \ + } \ + group_id_2 += get_num_groups(2); \ + global_id_2 += get_global_size(2); \ + } \ + group_id_1 += get_num_groups(1); \ + global_id_1 += get_global_size(1); \ + } \ +} \ + \ +FUTHARK_KERNEL_SIZED(TR_BLOCK_DIM, TR_BLOCK_DIM, 1) \ +void map_transpose_##NAME##_low_height(LOCAL_MEM_PARAM \ + __global ELEM_TYPE *dst_mem, \ + int64_t dst_offset, \ + __global ELEM_TYPE *src_mem, \ + int64_t src_offset, \ + int32_t num_arrays, \ + int32_t x_elems, \ + int32_t y_elems, \ + int32_t mulx, \ + int32_t muly, \ + int32_t repeat_1, \ + int32_t repeat_2) { \ + __local ELEM_TYPE* block = (__local ELEM_TYPE*)local_mem; \ + int group_id_0 = get_group_id(0); \ + int global_id_0 = get_global_id(0); \ + int group_id_1 = get_group_id(1); \ + int global_id_1 = get_global_id(1); \ + for (int i1 = 0; i1 <= repeat_1; i1++) { \ + int group_id_2 = get_group_id(2); \ + int global_id_2 = get_global_id(2); \ + for (int i2 = 0; i2 <= repeat_2; i2++) { \ + int32_t our_array_offset = group_id_2 * x_elems * y_elems; \ + int32_t odata_offset = dst_offset + our_array_offset; \ + int32_t idata_offset = src_offset + our_array_offset; \ + int32_t x_index = \ + group_id_0 * TR_BLOCK_DIM * mulx + \ + get_local_id(0) + \ + get_local_id(1)%mulx * TR_BLOCK_DIM; \ + int32_t y_index = group_id_1 * TR_BLOCK_DIM + get_local_id(1)/mulx; \ + int32_t index_in = y_index * x_elems + x_index; \ + if (x_index < x_elems && y_index < y_elems) { \ + block[get_local_id(1) * (TR_BLOCK_DIM+1) + get_local_id(0)] = \ + src_mem[idata_offset + index_in]; \ + } \ + barrier_local(); \ + x_index = group_id_1 * TR_BLOCK_DIM + get_local_id(0)/mulx; \ + y_index = \ + group_id_0 * TR_BLOCK_DIM * mulx + \ + get_local_id(1) + \ + (get_local_id(0)%mulx) * TR_BLOCK_DIM; \ + int32_t index_out = y_index * y_elems + x_index; \ + if (x_index < y_elems && y_index < x_elems) { \ + dst_mem[odata_offset + index_out] = \ + block[get_local_id(0) * (TR_BLOCK_DIM+1) + get_local_id(1)]; \ + } \ + group_id_2 += get_num_groups(2); \ + global_id_2 += get_global_size(2); \ + } \ + group_id_1 += get_num_groups(1); \ + global_id_1 += get_global_size(1); \ + } \ +} \ + \ +FUTHARK_KERNEL_SIZED(TR_BLOCK_DIM, TR_BLOCK_DIM, 1) \ +void map_transpose_##NAME##_low_width(LOCAL_MEM_PARAM \ + __global ELEM_TYPE *dst_mem, \ + int64_t dst_offset, \ + __global ELEM_TYPE *src_mem, \ + int64_t src_offset, \ + int32_t num_arrays, \ + int32_t x_elems, \ + int32_t y_elems, \ + int32_t mulx, \ + int32_t muly, \ + int32_t repeat_1, \ + int32_t repeat_2) { \ + __local ELEM_TYPE* block = (__local ELEM_TYPE*)local_mem; \ + int group_id_0 = get_group_id(0); \ + int global_id_0 = get_global_id(0); \ + int group_id_1 = get_group_id(1); \ + int global_id_1 = get_global_id(1); \ + for (int i1 = 0; i1 <= repeat_1; i1++) { \ + int group_id_2 = get_group_id(2); \ + int global_id_2 = get_global_id(2); \ + for (int i2 = 0; i2 <= repeat_2; i2++) { \ + int32_t our_array_offset = group_id_2 * x_elems * y_elems; \ + int32_t odata_offset = dst_offset + our_array_offset; \ + int32_t idata_offset = src_offset + our_array_offset; \ + int32_t x_index = group_id_0 * TR_BLOCK_DIM + get_local_id(0)/muly; \ + int32_t y_index = \ + group_id_1 * TR_BLOCK_DIM * muly + \ + get_local_id(1) + (get_local_id(0)%muly) * TR_BLOCK_DIM; \ + int32_t index_in = y_index * x_elems + x_index; \ + if (x_index < x_elems && y_index < y_elems) { \ + block[get_local_id(1) * (TR_BLOCK_DIM+1) + get_local_id(0)] = \ + src_mem[idata_offset + index_in]; \ + } \ + barrier_local(); \ + x_index = group_id_1 * TR_BLOCK_DIM * muly + \ + get_local_id(0) + (get_local_id(1)%muly) * TR_BLOCK_DIM; \ + y_index = group_id_0 * TR_BLOCK_DIM + get_local_id(1)/muly; \ + int32_t index_out = y_index * y_elems + x_index; \ + if (x_index < y_elems && y_index < x_elems) { \ + dst_mem[odata_offset + index_out] = \ + block[get_local_id(0) * (TR_BLOCK_DIM+1) + get_local_id(1)]; \ + } \ + group_id_2 += get_num_groups(2); \ + global_id_2 += get_num_groups(2) * get_local_size(2); \ + } \ + group_id_1 += get_num_groups(1); \ + global_id_1 += get_num_groups(1) * get_local_size(1); \ + } \ +} \ + \ +FUTHARK_KERNEL_SIZED(TR_BLOCK_DIM*TR_BLOCK_DIM, 1, 1) \ +void map_transpose_##NAME##_small(LOCAL_MEM_PARAM \ + __global ELEM_TYPE *dst_mem, \ + int64_t dst_offset, \ + __global ELEM_TYPE *src_mem, \ + int64_t src_offset, \ + int32_t num_arrays, \ + int32_t x_elems, \ + int32_t y_elems, \ + int32_t mulx, \ + int32_t muly, \ + int32_t repeat_1, \ + int32_t repeat_2) { \ + (void)mulx; (void)muly; \ + __local ELEM_TYPE* block = (__local ELEM_TYPE*)local_mem; \ + int group_id_0 = get_group_id(0); \ + int global_id_0 = get_global_id(0); \ + int group_id_1 = get_group_id(1); \ + int global_id_1 = get_global_id(1); \ + for (int i1 = 0; i1 <= repeat_1; i1++) { \ + int group_id_2 = get_group_id(2); \ + int global_id_2 = get_global_id(2); \ + for (int i2 = 0; i2 <= repeat_2; i2++) { \ + int32_t our_array_offset = global_id_0/(y_elems * x_elems) * y_elems * x_elems; \ + int32_t x_index = (global_id_0 % (y_elems * x_elems))/y_elems; \ + int32_t y_index = global_id_0%y_elems; \ + int32_t odata_offset = dst_offset + our_array_offset; \ + int32_t idata_offset = src_offset + our_array_offset; \ + int32_t index_in = y_index * x_elems + x_index; \ + int32_t index_out = x_index * y_elems + y_index; \ + if (global_id_0 < x_elems * y_elems * num_arrays) { \ + dst_mem[odata_offset + index_out] = src_mem[idata_offset + index_in]; \ + } \ + group_id_2 += get_num_groups(2); \ + global_id_2 += get_global_size(2); \ + } \ + group_id_1 += get_num_groups(1); \ + global_id_1 += get_global_size(1); \ + } \ +} \ + \ +FUTHARK_KERNEL_SIZED(TR_BLOCK_DIM*2, TR_TILE_DIM/TR_ELEMS_PER_THREAD, 1)\ +void map_transpose_##NAME##_large(LOCAL_MEM_PARAM \ + __global ELEM_TYPE *dst_mem, \ + int64_t dst_offset, \ + __global ELEM_TYPE *src_mem, \ + int64_t src_offset, \ + int64_t num_arrays, \ + int64_t x_elems, \ + int64_t y_elems, \ + int64_t mulx, \ + int64_t muly, \ + int32_t repeat_1, \ + int32_t repeat_2) { \ + (void)mulx; (void)muly; \ + __local ELEM_TYPE* block = (__local ELEM_TYPE*)local_mem; \ + int group_id_0 = get_group_id(0); \ + int global_id_0 = get_global_id(0); \ + int group_id_1 = get_group_id(1); \ + int global_id_1 = get_global_id(1); \ + for (int i1 = 0; i1 <= repeat_1; i1++) { \ + int group_id_2 = get_group_id(2); \ + int global_id_2 = get_global_id(2); \ + for (int i2 = 0; i2 <= repeat_2; i2++) { \ + int64_t our_array_offset = group_id_2 * x_elems * y_elems; \ + int64_t odata_offset = dst_offset + our_array_offset; \ + int64_t idata_offset = src_offset + our_array_offset; \ + int64_t x_index = global_id_0; \ + int64_t y_index = group_id_1 * TR_TILE_DIM + get_local_id(1); \ + if (x_index < x_elems) { \ + for (int64_t j = 0; j < TR_ELEMS_PER_THREAD; j++) { \ + int64_t index_i = (y_index + j * (TR_TILE_DIM/TR_ELEMS_PER_THREAD)) * x_elems + x_index; \ + if (y_index + j * (TR_TILE_DIM/TR_ELEMS_PER_THREAD) < y_elems) { \ + block[(get_local_id(1) + j * (TR_TILE_DIM/TR_ELEMS_PER_THREAD)) * (TR_TILE_DIM+1) + \ + get_local_id(0)] = \ + src_mem[idata_offset + index_i]; \ + } \ + } \ + } \ + barrier_local(); \ + x_index = group_id_1 * TR_TILE_DIM + get_local_id(0); \ + y_index = group_id_0 * TR_TILE_DIM + get_local_id(1); \ + if (x_index < y_elems) { \ + for (int64_t j = 0; j < TR_ELEMS_PER_THREAD; j++) { \ + int64_t index_out = (y_index + j * (TR_TILE_DIM/TR_ELEMS_PER_THREAD)) * y_elems + x_index; \ + if (y_index + j * (TR_TILE_DIM/TR_ELEMS_PER_THREAD) < x_elems) { \ + dst_mem[(odata_offset + index_out)] = \ + block[get_local_id(0) * (TR_TILE_DIM+1) + \ + get_local_id(1) + j * (TR_TILE_DIM/TR_ELEMS_PER_THREAD)]; \ + } \ + } \ + } \ + group_id_2 += get_num_groups(2); \ + global_id_2 += get_global_size(2); \ + } \ + group_id_1 += get_num_groups(1); \ + global_id_1 += get_global_size(1); \ + } \ +} \ + +GEN_TRANSPOSE_KERNELS(1b, uint8_t) +GEN_TRANSPOSE_KERNELS(2b, uint16_t) +GEN_TRANSPOSE_KERNELS(4b, uint32_t) +GEN_TRANSPOSE_KERNELS(8b, uint64_t) + +// End of transpose.cl diff --git a/rts/python/memory.py b/rts/python/memory.py --- a/rts/python/memory.py +++ b/rts/python/memory.py @@ -55,4 +55,136 @@ return "".format(self.desc) +# LMAD stuff + + +def lmad_contiguous_search(checked, expected, strides, shape, used): + for i in range(len(strides)): + for j in range(len(strides)): + if not used[j] and strides[j] == expected and strides[j] >= 0: + used[j] = True + if checked + 1 == len(strides) or lmad_contiguous_search( + checked + 1, expected * shape[j], strides, shape, used + ): + return True + used[j] = False + return False + + +def lmad_contiguous(strides, shape): + used = len(strides) * [False] + return lmad_contiguous_search(0, 1, strides, shape, used) + + +def lmad_memcpyable(dst_strides, src_strides, shape): + if not lmad_contiguous(dst_strides, shape): + return False + for i in range(len(dst_strides)): + if dst_strides[i] != src_strides[i] and shape[i] != 1: + return False + return True + + +def lmad_is_tr(strides, shape): + r = len(shape) + for i in range(1, r): + n = 1 + m = 1 + ok = True + expected = 1 + # Check strides before 'i'. + for j in range(i - 1, -1, -1): + ok = ok and strides[j] == expected + expected *= shape[j] + n *= shape[j] + # Check strides after 'i'. + for j in range(r - 1, i - 1, -1): + ok = ok and strides[j] == expected + expected *= shape[j] + m *= shape[j] + if ok: + return (n, m) + return None + + +def lmad_map_tr(dst_strides, src_strides, shape): + r = len(dst_strides) + rowmajor_strides = [0] * r + rowmajor_strides[r - 1] = 1 + + for i in range(r - 2, -1, -1): + rowmajor_strides[i] = rowmajor_strides[i + 1] * shape[i + 1] + + # map_r will be the number of mapped dimensions on top. + map_r = 0 + k = 1 + for i in range(r): + if ( + dst_strides[i] != rowmajor_strides[i] + or src_strides[i] != rowmajor_strides[i] + ): + break + else: + k *= shape[i] + map_r += 1 + + if rowmajor_strides[map_r:] == dst_strides[map_r:]: + r = lmad_is_tr(src_strides[map_r:], shape[map_r:]) + if r is not None: + (n, m) = r + return (k, n, m) + elif rowmajor_strides[map_r:] == src_strides[map_r:]: + r = lmad_is_tr(dst_strides[map_r:], shape[map_r:]) + if r is not None: + (n, m) = r + return (k, m, n) # Sic! + return None + + +def lmad_copy_elements( + pt, dst, dst_offset, dst_strides, src, src_offset, src_strides, shape +): + if len(shape) == 1: + for i in range(shape[0]): + writeScalarArray( + dst, + dst_offset + i * dst_strides[0], + pt(indexArray(src, src_offset + i * src_strides[0], pt)), + ) + else: + for i in range(shape[0]): + lmad_copy_elements( + pt, + dst, + dst_offset + i * dst_strides[0], + dst_strides[1:], + src, + src_offset + i * src_strides[0], + src_strides[1:], + shape[1:], + ) + + +def lmad_copy( + pt, dst, dst_offset, dst_strides, src, src_offset, src_strides, shape +): + if lmad_memcpyable(dst_strides, src_strides, shape): + ct.memmove( + addressOffset(dst, dst_offset * ct.sizeof(pt), ct.c_byte), + addressOffset(src, src_offset * ct.sizeof(pt), ct.c_byte), + np.prod(shape) * ct.sizeof(pt), + ) + else: + lmad_copy_elements( + pt, + dst, + dst_offset, + dst_strides, + src, + src_offset, + src_strides, + shape, + ) + + # End of memory.py. diff --git a/rts/python/opencl.py b/rts/python/opencl.py --- a/rts/python/opencl.py +++ b/rts/python/opencl.py @@ -10,7 +10,11 @@ % cl.version.VERSION_TEXT ) +TR_BLOCK_DIM = 16 +TR_TILE_DIM = TR_BLOCK_DIM * 2 +TR_ELEMS_PER_THREAD = 8 + def parse_preferred_device(s): pref_num = 0 if len(s) > 1 and s[0] == "#": @@ -284,9 +288,55 @@ if self.platform.name == "Oclgrind": build_options += ["-DEMULATE_F16"] - return cl.Program(self.ctx, program_src).build(build_options) + build_options += [ + f"-DTR_BLOCK_DIM={TR_BLOCK_DIM}", + f"-DTR_TILE_DIM={TR_TILE_DIM}", + f"-DTR_ELEMS_PER_THREAD={TR_ELEMS_PER_THREAD}", + ] + program = cl.Program(self.ctx, program_src).build(build_options) + self.transpose_kernels = { + 1: { + "default": program.map_transpose_1b, + "low_height": program.map_transpose_1b_low_height, + "low_width": program.map_transpose_1b_low_width, + "small": program.map_transpose_1b_small, + "large": program.map_transpose_1b_large, + }, + 2: { + "default": program.map_transpose_2b, + "low_height": program.map_transpose_2b_low_height, + "low_width": program.map_transpose_2b_low_width, + "small": program.map_transpose_2b_small, + "large": program.map_transpose_2b_large, + }, + 4: { + "default": program.map_transpose_4b, + "low_height": program.map_transpose_4b_low_height, + "low_width": program.map_transpose_4b_low_width, + "small": program.map_transpose_4b_small, + "large": program.map_transpose_4b_large, + }, + 8: { + "default": program.map_transpose_8b, + "low_height": program.map_transpose_8b_low_height, + "low_width": program.map_transpose_8b_low_width, + "small": program.map_transpose_8b_small, + "large": program.map_transpose_8b_large, + }, + } + + self.copy_kernels = { + 1: program.lmad_copy_1b, + 2: program.lmad_copy_2b, + 4: program.lmad_copy_4b, + 8: program.lmad_copy_8b, + } + + return program + + def opencl_alloc(self, min_size, tag): min_size = 1 if min_size == 0 else min_size assert min_size > 0 @@ -323,3 +373,125 @@ ) raise Exception(self.failure_msgs[failure[0]].format(*failure_args)) + + +def map_transpose_gpu2gpu( + self, elem_size, dst, dst_offset, src, src_offset, k, n, m +): + kernels = self.transpose_kernels[elem_size] + kernel = kernels["default"] + mulx = TR_BLOCK_DIM / n + muly = TR_BLOCK_DIM / m + + group_dims = (TR_TILE_DIM, TR_TILE_DIM // TR_ELEMS_PER_THREAD, 1) + dims = ( + (m + TR_TILE_DIM - 1) // TR_TILE_DIM * group_dims[0], + (n + TR_TILE_DIM - 1) // TR_TILE_DIM * group_dims[1], + k, + ) + + k32 = np.int32(k) + n32 = np.int32(n) + m32 = np.int32(m) + mulx32 = np.int32(mulx) + muly32 = np.int32(muly) + + kernel.set_args( + cl.LocalMemory(TR_TILE_DIM * (TR_TILE_DIM + 1) * elem_size), + dst, + dst_offset, + src, + src_offset, + k32, + m32, + n32, + mulx32, + muly32, + np.int32(0), + np.int32(0), + ) + cl.enqueue_nd_range_kernel(self.queue, kernel, dims, group_dims) + + +def copy_elements_gpu2gpu( + self, + elem_size, + dst, + dst_offset, + dst_strides, + src, + src_offset, + src_strides, + shape, +): + r = len(shape) + if r > 8: + raise Exception( + "Futhark runtime limitation:\nCannot copy array of greater than rank 8.\n" + ) + + n = np.product(shape) + zero = np.int64(0) + layout_args = [None] * (8 * 3) + for i in range(8): + if i < r: + layout_args[i * 3 + 0] = shape[i] + layout_args[i * 3 + 1] = dst_strides[i] + layout_args[i * 3 + 2] = src_strides[i] + else: + layout_args[i * 3 + 0] = zero + layout_args[i * 3 + 1] = zero + layout_args[i * 3 + 2] = zero + + kernel = self.copy_kernels[elem_size] + kernel.set_args( + cl.LocalMemory(1), + dst, + dst_offset, + src, + src_offset, + n, + np.int32(r), + *layout_args, + ) + w = 256 + dims = ((n + w - 1) // w * w,) + group_dims = (w,) + cl.enqueue_nd_range_kernel(self.queue, kernel, dims, group_dims) + + +def lmad_copy_gpu2gpu( + self, pt, dst, dst_offset, dst_strides, src, src_offset, src_strides, shape +): + elem_size = ct.sizeof(pt) + nbytes = np.product(shape) * elem_size + if nbytes == 0: + return None + if lmad_memcpyable(dst_strides, src_strides, shape): + cl.enqueue_copy( + self.queue, + dst, + src, + dst_offset=dst_offset * elem_size, + src_offset=src_offset * elem_size, + byte_count=nbytes, + ) + else: + tr = lmad_map_tr(dst_strides, src_strides, shape) + if tr is not None: + (k, n, m) = tr + map_transpose_gpu2gpu( + self, elem_size, dst, dst_offset, src, src_offset, k, m, n + ) + else: + copy_elements_gpu2gpu( + self, + elem_size, + dst, + dst_offset, + dst_strides, + src, + src_offset, + src_strides, + shape, + ) diff --git a/src/Futhark/AD/Fwd.hs b/src/Futhark/AD/Fwd.hs --- a/src/Futhark/AD/Fwd.hs +++ b/src/Futhark/AD/Fwd.hs @@ -72,7 +72,7 @@ getNameSource = gets stateNameSource putNameSource src = modify (\env -> env {stateNameSource = src}) -runADM :: MonadFreshNames m => ADM a -> m a +runADM :: (MonadFreshNames m) => ADM a -> m a runADM (ADM m) = modifyNameSource $ \vn -> second stateNameSource $ @@ -91,7 +91,7 @@ newTan :: a -> ADM a bundleNew :: a -> ADM [a] -bundleNewList :: TanBuilder a => [a] -> ADM [a] +bundleNewList :: (TanBuilder a) => [a] -> ADM [a] bundleNewList = fmap mconcat . mapM bundleNew instance TanBuilder (PatElem (TypeBase s u)) where @@ -111,10 +111,10 @@ then pure [pe'] else pure [pe, pe'] -newTanPat :: TanBuilder (PatElem t) => Pat t -> ADM (Pat t) +newTanPat :: (TanBuilder (PatElem t)) => Pat t -> ADM (Pat t) newTanPat (Pat pes) = Pat <$> mapM newTan pes -bundleNewPat :: TanBuilder (PatElem t) => Pat t -> ADM (Pat t) +bundleNewPat :: (TanBuilder (PatElem t)) => Pat t -> ADM (Pat t) bundleNewPat (Pat pes) = Pat <$> bundleNewList pes instance TanBuilder (Param (TypeBase s u)) where @@ -129,7 +129,7 @@ then pure [param'] else pure [param, param'] -instance Tangent a => TanBuilder (Param (TypeBase s u), a) where +instance (Tangent a) => TanBuilder (Param (TypeBase s u), a) where newTan (p, x) = (,) <$> newTan p <*> tangent x bundleNew (p, x) = do b <- bundleNew p @@ -150,7 +150,7 @@ t' <- tangent t pure [t, t'] -bundleTangents :: Tangent a => [a] -> ADM [a] +bundleTangents :: (Tangent a) => [a] -> ADM [a] bundleTangents = (mconcat <$>) . mapM bundleTan instance Tangent VName where @@ -402,21 +402,21 @@ pat' <- bundleNewPat pat ret' <- bundleTangents ret addStm $ Let pat' aux $ Match ses cases' defbody' $ MatchDec ret' ifsort -fwdStm (Let pat aux (DoLoop val_pats loop@(WhileLoop v) body)) = do +fwdStm (Let pat aux (Loop val_pats loop@(WhileLoop v) body)) = do val_pats' <- bundleNewList val_pats pat' <- bundleNewPat pat body' <- localScope (scopeOfFParams (map fst val_pats) <> scopeOf loop) . slocal' $ fwdBody body - addStm $ Let pat' aux $ DoLoop val_pats' (WhileLoop v) body' -fwdStm (Let pat aux (DoLoop val_pats loop@(ForLoop i it bound loop_vars) body)) = do + addStm $ Let pat' aux $ Loop val_pats' (WhileLoop v) body' +fwdStm (Let pat aux (Loop val_pats loop@(ForLoop i it bound loop_vars) body)) = do pat' <- bundleNewPat pat val_pats' <- bundleNewList val_pats loop_vars' <- bundleNewList loop_vars body' <- localScope (scopeOfFParams (map fst val_pats) <> scopeOf loop) . slocal' $ fwdBody body - addStm $ Let pat' aux $ DoLoop val_pats' (ForLoop i it bound loop_vars') body' + addStm $ Let pat' aux $ Loop val_pats' (ForLoop i it bound loop_vars') body' fwdStm (Let pat aux (WithAcc inputs lam)) = do inputs' <- forM inputs $ \(shape, arrs, op) -> do arrs_tan <- mapM tangent arrs @@ -451,7 +451,7 @@ mapM_ fwdStm stms (res <>) <$> mapM tangent res -fwdJVP :: MonadFreshNames m => Scope SOACS -> Lambda SOACS -> m (Lambda SOACS) +fwdJVP :: (MonadFreshNames m) => Scope SOACS -> Lambda SOACS -> m (Lambda SOACS) fwdJVP scope l@(Lambda params body ret) = runADM . localScope scope . inScopeOf l $ do params_tan <- mapM newTan params 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 @@ -278,7 +278,7 @@ zipWithM_ insAdj branches_free branches_free_adj diffStm (Let pat aux (Op soac)) m = vjpSOAC vjpOps pat aux soac m -diffStm (Let pat aux loop@DoLoop {}) m = +diffStm (Let pat aux loop@Loop {}) m = diffLoop diffStms pat aux loop m -- See Note [Adjoints of accumulators] diffStm stm@(Let pat _aux (WithAcc inputs lam)) m = do @@ -343,7 +343,7 @@ ts' <- mapM lookupType get_adjs_for pure $ Lambda params body' ts' -revVJP :: MonadFreshNames m => Scope SOACS -> Lambda SOACS -> m (Lambda SOACS) +revVJP :: (MonadFreshNames m) => Scope SOACS -> Lambda SOACS -> m (Lambda SOACS) revVJP scope (Lambda params body ts) = runADM . localScope (scope <> scopeOfLParams params) $ do params_adj <- forM (zip (map resSubExp (bodyResult body)) ts) $ \(se, t) -> diff --git a/src/Futhark/AD/Rev/Hist.hs b/src/Futhark/AD/Rev/Hist.hs --- a/src/Futhark/AD/Rev/Hist.hs +++ b/src/Futhark/AD/Rev/Hist.hs @@ -644,7 +644,7 @@ radixSortStep (map paramName params) types bit n w letTupExp "sorted" $ - DoLoop + Loop (zip params $ map Var xs) (ForLoop i Int64 iters []) loopbody @@ -664,7 +664,7 @@ l <- letTupExp' "log2res" $ - DoLoop + Loop (zip params [cond_init, m, Constant $ blankPrimValue int64]) (WhileLoop $ paramName cond) body diff --git a/src/Futhark/AD/Rev/Loop.hs b/src/Futhark/AD/Rev/Loop.hs --- a/src/Futhark/AD/Rev/Loop.hs +++ b/src/Futhark/AD/Rev/Loop.hs @@ -21,7 +21,7 @@ -- | A convenience function to bring the components of a for-loop into -- scope and throw an error if the passed 'Exp' is not a for-loop. bindForLoop :: - PrettyRep rep => + (PrettyRep rep) => Exp rep -> ( [(Param (FParamInfo rep), SubExp)] -> LoopForm rep -> @@ -33,7 +33,7 @@ a ) -> a -bindForLoop (DoLoop val_pats form@(ForLoop i it bound loop_vars) body) f = +bindForLoop (Loop val_pats form@(ForLoop i it bound loop_vars) body) f = f val_pats form i it bound loop_vars body bindForLoop e _ = error $ "bindForLoop: not a for-loop:\n" <> prettyString e @@ -57,12 +57,12 @@ -- | Is the loop a while-loop? isWhileLoop :: Exp rep -> Bool -isWhileLoop (DoLoop _ WhileLoop {} _) = True +isWhileLoop (Loop _ WhileLoop {} _) = True isWhileLoop _ = False -- | Transforms a 'ForLoop' into a 'ForLoop' with an empty list of -- loop variables. -removeLoopVars :: MonadBuilder m => Exp (Rep m) -> m (Exp (Rep m)) +removeLoopVars :: (MonadBuilder m) => Exp (Rep m) -> m (Exp (Rep m)) removeLoopVars loop = bindForLoop loop $ \val_pats form i _it _bound loop_vars body -> do let indexify (x_param, xs) = do @@ -73,11 +73,11 @@ pure (paramName x_param, x') (substs_list, subst_stms) <- collectStms $ mapM indexify loop_vars let Body aux' stms' res' = substituteNames (M.fromList substs_list) body - pure $ DoLoop val_pats form $ Body aux' (subst_stms <> stms') res' + pure $ Loop val_pats form $ Body aux' (subst_stms <> stms') res' -- | Augments a while-loop to also compute the number of iterations. computeWhileIters :: Exp SOACS -> ADM SubExp -computeWhileIters (DoLoop val_pats (WhileLoop b) body) = do +computeWhileIters (Loop val_pats (WhileLoop b) body) = do bound_v <- newVName "bound" let t = Prim $ IntType Int64 bound_param = Param mempty bound_v t @@ -89,17 +89,17 @@ in letSubExp "bound+1" $ BasicOp $ BinOp (Add Int64 OverflowUndef) (Var bound_v) one addStms $ bodyStms body pure (pure (subExpRes bound_plus_one) <> bodyResult body) - res <- letTupExp' "loop" $ DoLoop ((bound_param, bound_init) : val_pats) (WhileLoop b) body' + res <- letTupExp' "loop" $ Loop ((bound_param, bound_init) : val_pats) (WhileLoop b) body' pure $ head res computeWhileIters e = error $ "convertWhileIters: not a while-loop:\n" <> prettyString e -- | Converts a 'WhileLoop' into a 'ForLoop'. Requires that the --- surrounding 'DoLoop' is annotated with a @#[bound(n)]@ attribute, +-- surrounding 'Loop' is annotated with a @#[bound(n)]@ attribute, -- where @n@ is an upper bound on the number of iterations of the -- while-loop. The resulting for-loop will execute for @n@ iterations on -- all inputs, so the tighter the bound the better. convertWhileLoop :: SubExp -> Exp SOACS -> ADM (Exp SOACS) -convertWhileLoop bound_se (DoLoop val_pats (WhileLoop cond) body) = +convertWhileLoop bound_se (Loop val_pats (WhileLoop cond) body) = localScope (scopeOfFParams $ map fst val_pats) $ do i <- newVName "i" body' <- @@ -109,7 +109,7 @@ (pure body) (resultBodyM $ map (Var . paramName . fst) val_pats) ] - pure $ DoLoop val_pats (ForLoop i Int64 bound_se mempty) body' + pure $ Loop val_pats (ForLoop i Int64 bound_se mempty) body' convertWhileLoop _ e = error $ "convertWhileLoopBound: not a while-loop:\n" <> prettyString e -- | @nestifyLoop n bound loop@ transforms a loop into a depth-@n@ loop nest @@ -149,12 +149,12 @@ =<< nestifyLoop' offset' (n - 1) - (DoLoop val_pats'' (ForLoop i' it' bound_se loop_vars') inner_body) + (Loop val_pats'' (ForLoop i' it' bound_se loop_vars') inner_body) pure $ varsRes inner_loop pure $ - DoLoop val_pats (ForLoop i it bound_se loop_vars) outer_body + Loop val_pats (ForLoop i it bound_se loop_vars) outer_body | n == 1 = - pure $ DoLoop val_pats (ForLoop i it bound_se loop_vars) body + pure $ Loop val_pats (ForLoop i it bound_se loop_vars) body | otherwise = pure loop -- | @stripmine n pat loop@ stripmines a loop into a depth-@n@ loop nest. @@ -185,7 +185,7 @@ let loop_params_rem = map fst val_pats' loop_inits_rem = map (Var . patElemName) $ patElems pat' val_pats_rem = zip loop_params_rem loop_inits_rem - remain_loop = DoLoop val_pats_rem (ForLoop i' it' remain_iters loop_vars') remain_body + remain_loop = Loop val_pats_rem (ForLoop i' it' remain_iters loop_vars') remain_body collectStms_ $ do letBind pat' mined_loop letBind pat remain_loop @@ -194,7 +194,7 @@ -- expression is a for-loop with a @#[stripmine(n)]@ attribute, where -- @n@ is the nesting depth. stripmineStm :: Stm SOACS -> ADM (Stms SOACS) -stripmineStm stm@(Let pat aux loop@(DoLoop _ ForLoop {} _)) = +stripmineStm stm@(Let pat aux loop@(Loop _ ForLoop {} _)) = case nums of (n : _) -> stripmine n pat loop _ -> pure $ oneStm stm @@ -256,7 +256,7 @@ let pat' = pat <> Pat saved_pats val_pats' = val_pats <> zip saved_params empty_saved_array - addStm $ Let pat' aux $ DoLoop val_pats' form body' + addStm $ Let pat' aux $ Loop val_pats' form body' -- | Construct a loop value-pattern for the adjoint of the -- given variable. @@ -420,7 +420,7 @@ adjs' <- letTupExp "loop_adj" $ substituteNames (restore_true_deps <> var_array_substs) $ - DoLoop val_pat_adjs_list form' body_adj + Loop val_pat_adjs_list form' body_adj let (loop_res_adjs, loop_free_var_val_adjs) = splitAt (length $ loopRes loop_adjs) adjs' (loop_free_adjs, loop_var_val_adjs) = diff --git a/src/Futhark/AD/Rev/Map.hs b/src/Futhark/AD/Rev/Map.hs --- a/src/Futhark/AD/Rev/Map.hs +++ b/src/Futhark/AD/Rev/Map.hs @@ -50,7 +50,7 @@ (xs, ys, zs) = partitionAdjVars fvs buildRenamedBody :: - MonadBuilder m => + (MonadBuilder m) => m (Result, a) -> m (Body (Rep m), a) buildRenamedBody m = do diff --git a/src/Futhark/AD/Rev/Monad.hs b/src/Futhark/AD/Rev/Monad.hs --- a/src/Futhark/AD/Rev/Monad.hs +++ b/src/Futhark/AD/Rev/Monad.hs @@ -125,7 +125,7 @@ substituteNames m (AdjVal (Var v)) = AdjVal $ Var $ substituteNames m v substituteNames _ adj = adj -zeroArray :: MonadBuilder m => Shape -> Type -> m VName +zeroArray :: (MonadBuilder m) => Shape -> Type -> m VName zeroArray shape t | shapeRank shape == 0 = letExp "zero" $ zeroExp t @@ -217,7 +217,7 @@ getNameSource = gets stateNameSource putNameSource src = modify (\env -> env {stateNameSource = src}) -runADM :: MonadFreshNames m => ADM a -> m a +runADM :: (MonadFreshNames m) => ADM a -> m a runADM (ADM m) = modifyNameSource $ \vn -> second stateNameSource $ diff --git a/src/Futhark/AD/Rev/Reduce.hs b/src/Futhark/AD/Rev/Reduce.hs --- a/src/Futhark/AD/Rev/Reduce.hs +++ b/src/Futhark/AD/Rev/Reduce.hs @@ -16,7 +16,7 @@ import Futhark.Tools import Futhark.Transform.Rename -eReverse :: MonadBuilder m => VName -> m VName +eReverse :: (MonadBuilder m) => VName -> m VName eReverse arr = do arr_t <- lookupType arr let w = arraySize 0 arr_t diff --git a/src/Futhark/Actions.hs b/src/Futhark/Actions.hs --- a/src/Futhark/Actions.hs +++ b/src/Futhark/Actions.hs @@ -16,6 +16,7 @@ compileCtoWASMAction, compileOpenCLAction, compileCUDAAction, + compileHIPAction, compileMulticoreAction, compileMulticoreToISPCAction, compileMulticoreToWASMAction, @@ -40,6 +41,7 @@ import Futhark.Analysis.Metrics import Futhark.CodeGen.Backends.CCUDA qualified as CCUDA import Futhark.CodeGen.Backends.COpenCL qualified as COpenCL +import Futhark.CodeGen.Backends.HIP qualified as HIP import Futhark.CodeGen.Backends.MulticoreC qualified as MulticoreC import Futhark.CodeGen.Backends.MulticoreISPC qualified as MulticoreISPC import Futhark.CodeGen.Backends.MulticoreWASM qualified as MulticoreWASM @@ -65,7 +67,7 @@ import System.Info qualified -- | Print the result to stdout. -printAction :: ASTRep rep => Action rep +printAction :: (ASTRep rep) => Action rep printAction = Action { actionName = "Prettyprint", @@ -74,7 +76,7 @@ } -- | Print the result to stdout, alias annotations. -printAliasesAction :: AliasableRep rep => Action rep +printAliasesAction :: (AliasableRep rep) => Action rep printAliasesAction = Action { actionName = "Prettyprint", @@ -141,7 +143,7 @@ } -- | Print metrics about AST node counts to stdout. -metricsAction :: OpMetrics (Op rep) => Action rep +metricsAction :: (OpMetrics (Op rep)) => Action rep metricsAction = Action { actionName = "Compute metrics", @@ -365,6 +367,37 @@ runCC cpath outpath ["-O", "-std=c99"] ("-lm" : extra_options) ToServer -> do liftIO $ T.writeFile cpath $ cPrependHeader $ CCUDA.asServer cprog + runCC cpath outpath ["-O", "-std=c99"] ("-lm" : extra_options) + +-- | The @futhark hip@ action. +compileHIPAction :: FutharkConfig -> CompilerMode -> FilePath -> Action GPUMem +compileHIPAction fcfg mode outpath = + Action + { actionName = "Compile to HIP", + actionDescription = "Compile to HIP", + actionProcedure = helper + } + where + helper prog = do + cprog <- handleWarnings fcfg $ HIP.compileProg versionString prog + let cpath = outpath `addExtension` "c" + hpath = outpath `addExtension` "h" + jsonpath = outpath `addExtension` "json" + extra_options = + [ "-lamdhip64", + "-lhiprtc" + ] + case mode of + ToLibrary -> do + let (header, impl, manifest) = HIP.asLibrary cprog + liftIO $ T.writeFile hpath $ cPrependHeader header + liftIO $ T.writeFile cpath $ cPrependHeader impl + liftIO $ T.writeFile jsonpath manifest + ToExecutable -> do + liftIO $ T.writeFile cpath $ cPrependHeader $ HIP.asExecutable cprog + runCC cpath outpath ["-O", "-std=c99"] ("-lm" : extra_options) + ToServer -> do + liftIO $ T.writeFile cpath $ cPrependHeader $ HIP.asServer cprog runCC cpath outpath ["-O", "-std=c99"] ("-lm" : extra_options) -- | The @futhark multicore@ action. 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 @@ -28,7 +28,7 @@ -- | Perform alias analysis on a Futhark program. aliasAnalysis :: - AliasableRep rep => + (AliasableRep rep) => Prog rep -> Prog (Aliases rep) aliasAnalysis prog = @@ -39,7 +39,7 @@ -- | Perform alias analysis on function. analyseFun :: - AliasableRep rep => + (AliasableRep rep) => FunDef rep -> FunDef (Aliases rep) analyseFun (FunDef entry attrs fname restype params body) = @@ -49,7 +49,7 @@ -- | Perform alias analysis on Body. analyseBody :: - AliasableRep rep => + (AliasableRep rep) => AliasTable -> Body rep -> Body (Aliases rep) @@ -59,7 +59,7 @@ -- | Perform alias analysis on statements. analyseStms :: - AliasableRep rep => + (AliasableRep rep) => AliasTable -> Stms rep -> (Stms (Aliases rep), AliasesAndConsumed) @@ -78,7 +78,7 @@ -- | Perform alias analysis on statement. analyseStm :: - AliasableRep rep => + (AliasableRep rep) => AliasTable -> Stm rep -> Stm (Aliases rep) @@ -90,7 +90,7 @@ -- | Perform alias analysis on expression. analyseExp :: - AliasableRep rep => + (AliasableRep rep) => AliasTable -> Exp rep -> Exp (Aliases rep) @@ -130,7 +130,7 @@ -- | Perform alias analysis on lambda. analyseLambda :: - AliasableRep rep => + (AliasableRep rep) => AliasTable -> Lambda rep -> Lambda (Aliases rep) diff --git a/src/Futhark/Analysis/CallGraph.hs b/src/Futhark/Analysis/CallGraph.hs --- a/src/Futhark/Analysis/CallGraph.hs +++ b/src/Futhark/Analysis/CallGraph.hs @@ -88,8 +88,8 @@ <> fcAllCalled cg ftable = buildFunctionTable prog -count :: Ord k => [k] -> M.Map k Int -count ks = M.fromListWith (+) $ zip ks $ repeat 1 +count :: (Ord k) => [k] -> M.Map k Int +count ks = M.fromListWith (+) $ map (,1) ks -- | Produce a mapping of the number of occurences in the call graph -- of each function. Only counts functions that are called at least diff --git a/src/Futhark/Analysis/DataDependencies.hs b/src/Futhark/Analysis/DataDependencies.hs --- a/src/Futhark/Analysis/DataDependencies.hs +++ b/src/Futhark/Analysis/DataDependencies.hs @@ -17,11 +17,11 @@ type Dependencies = M.Map VName Names -- | Compute the data dependencies for an entire body. -dataDependencies :: ASTRep rep => Body rep -> Dependencies +dataDependencies :: (ASTRep rep) => Body rep -> Dependencies dataDependencies = dataDependencies' M.empty dataDependencies' :: - ASTRep rep => + (ASTRep rep) => Dependencies -> Body rep -> Dependencies diff --git a/src/Futhark/Analysis/HORep/MapNest.hs b/src/Futhark/Analysis/HORep/MapNest.hs --- a/src/Futhark/Analysis/HORep/MapNest.hs +++ b/src/Futhark/Analysis/HORep/MapNest.hs @@ -164,7 +164,7 @@ pure $ SOAC.Screma w (Futhark.mapSOAC outerlam) inps fixInputs :: - MonadFreshNames m => + (MonadFreshNames m) => SubExp -> [(VName, SOAC.Input)] -> [(VName, SOAC.Input)] -> diff --git a/src/Futhark/Analysis/HORep/SOAC.hs b/src/Futhark/Analysis/HORep/SOAC.hs --- a/src/Futhark/Analysis/HORep/SOAC.hs +++ b/src/Futhark/Analysis/HORep/SOAC.hs @@ -266,7 +266,7 @@ (substituteNames substs t) -- | Create a plain array variable input with no transformations. -varInput :: HasScope t f => VName -> f Input +varInput :: (HasScope t f) => VName -> f Input varInput v = withType <$> lookupType v where withType = Input (ArrayTransforms Seq.empty) v @@ -301,7 +301,7 @@ addInitialTransforms :: ArrayTransforms -> Input -> Input addInitialTransforms ts (Input ots a t) = Input (ts <> ots) a t -applyTransform :: MonadBuilder m => ArrayTransform -> VName -> m VName +applyTransform :: (MonadBuilder m) => ArrayTransform -> VName -> m VName applyTransform tr ia = do (cs, e) <- transformToExp tr ia certifying cs $ letExp s e @@ -313,7 +313,7 @@ ReshapeOuter {} -> "reshape_outer" ReshapeInner {} -> "reshape_inner" -applyTransforms :: MonadBuilder m => ArrayTransforms -> VName -> m VName +applyTransforms :: (MonadBuilder m) => ArrayTransforms -> VName -> m VName applyTransforms (ArrayTransforms ts) a = foldlM (flip applyTransform) a ts -- | Convert SOAC inputs to the corresponding expressions. @@ -416,7 +416,7 @@ f e (Replicate cs ne) = "replicate" <> pretty cs <> PP.apply [pretty ne, e] -instance PrettyRep rep => PP.Pretty (SOAC rep) where +instance (PrettyRep rep) => PP.Pretty (SOAC rep) where pretty (Screma w form arrs) = Futhark.ppScrema w arrs form pretty (Hist len ops bucket_fun imgs) = Futhark.ppHist len imgs ops bucket_fun pretty (Stream w lam nes arrs) = Futhark.ppStream w arrs nes lam @@ -499,7 +499,7 @@ toExp soac = Op <$> toSOAC soac -- | Convert a SOAC to a Futhark-level SOAC. -toSOAC :: MonadBuilder m => SOAC (Rep m) -> m (Futhark.SOAC (Rep m)) +toSOAC :: (MonadBuilder m) => SOAC (Rep m) -> m (Futhark.SOAC (Rep m)) toSOAC (Stream w lam nes inps) = Futhark.Stream w <$> inputsToSubExps inps <*> pure nes <*> pure lam toSOAC (Scatter w lam ivs dests) = diff --git a/src/Futhark/Analysis/Interference.hs b/src/Futhark/Analysis/Interference.hs --- a/src/Futhark/Analysis/Interference.hs +++ b/src/Futhark/Analysis/Interference.hs @@ -34,13 +34,13 @@ type Graph a = Set (a, a) -- | Insert an edge between two values into the graph. -makeEdge :: Ord a => a -> a -> Graph a +makeEdge :: (Ord a) => a -> a -> Graph a makeEdge v1 v2 | v1 == v2 = mempty | otherwise = S.singleton (min v1 v2, max v1 v2) analyseStm :: - LocalScope GPUMem m => + (LocalScope GPUMem m) => LUTabFun -> InUse -> Stm GPUMem -> @@ -86,7 +86,7 @@ (namesToList $ inuse_outside <> inuse <> lus <> last_use_mems) ) --- We conservatively treat all memory arguments to a DoLoop to +-- We conservatively treat all memory arguments to a Loop to -- interfere with each other, as well as anything used inside the -- loop. This could potentially be improved by looking at the -- interference computed by the loop body wrt. the loop arguments, but @@ -104,7 +104,7 @@ isMemArg _ = Nothing analyseExp :: - LocalScope GPUMem m => + (LocalScope GPUMem m) => LUTabFun -> InUse -> Exp GPUMem -> @@ -115,7 +115,7 @@ fmap mconcat $ mapM (analyseBody lumap inuse_outside) $ defbody : map caseBody cases - DoLoop merge _ body -> + Loop merge _ body -> analyseLoopParams merge <$> analyseBody lumap inuse_outside body Op (Inner (SegOp segop)) -> do analyseSegOp lumap inuse_outside segop @@ -123,7 +123,7 @@ pure mempty analyseKernelBody :: - LocalScope GPUMem m => + (LocalScope GPUMem m) => LUTabFun -> InUse -> KernelBody GPUMem -> @@ -131,7 +131,7 @@ analyseKernelBody lumap inuse body = analyseStms lumap inuse $ kernelBodyStms body analyseBody :: - LocalScope GPUMem m => + (LocalScope GPUMem m) => LUTabFun -> InUse -> Body GPUMem -> @@ -139,7 +139,7 @@ analyseBody lumap inuse body = analyseStms lumap inuse $ bodyStms body analyseStms :: - LocalScope GPUMem m => + (LocalScope GPUMem m) => LUTabFun -> InUse -> Stms GPUMem -> @@ -152,7 +152,7 @@ pure (inuse', lus' <> lus, graph' <> graph) analyseSegOp :: - LocalScope GPUMem m => + (LocalScope GPUMem m) => LUTabFun -> InUse -> SegOp lvl GPUMem -> @@ -169,7 +169,7 @@ pure (inuse'', lus' <> lus'', graph <> graph') segWithBinOps :: - LocalScope GPUMem m => + (LocalScope GPUMem m) => LUTabFun -> InUse -> [SegBinOp GPUMem] -> @@ -185,7 +185,7 @@ pure (inuse'', lus' <> lus'', graph <> graph') analyseSegBinOp :: - LocalScope GPUMem m => + (LocalScope GPUMem m) => LUTabFun -> InUse -> SegBinOp GPUMem -> @@ -194,7 +194,7 @@ analyseLambda lumap inuse lambda analyseHistOp :: - LocalScope GPUMem m => + (LocalScope GPUMem m) => LUTabFun -> InUse -> HistOp GPUMem -> @@ -203,7 +203,7 @@ analyseLambda lumap inuse (histOp histop) analyseLambda :: - LocalScope GPUMem m => + (LocalScope GPUMem m) => LUTabFun -> InUse -> Lambda GPUMem -> @@ -238,7 +238,7 @@ -- triple of the names currently in use, names that hit their last use somewhere -- within, and the resulting graph. analyseGPU :: - LocalScope GPUMem m => + (LocalScope GPUMem m) => LUTabFun -> Stms GPUMem -> m (Graph VName) @@ -264,16 +264,16 @@ -- | Return a mapping from memory blocks to their element sizes in the given -- statements. -memSizes :: LocalScope GPUMem m => Stms GPUMem -> m (Map VName Int) +memSizes :: (LocalScope GPUMem m) => Stms GPUMem -> m (Map VName Int) memSizes stms = inScopeOf stms $ fmap mconcat <$> mapM memSizesStm $ stmsToList stms where - memSizesStm :: LocalScope GPUMem m => Stm GPUMem -> m (Map VName Int) + memSizesStm :: (LocalScope GPUMem m) => Stm GPUMem -> m (Map VName Int) memSizesStm (Let pat _ e) = do arraySizes <- fmap mconcat <$> mapM memElemSize $ patNames pat arraySizes' <- memSizesExp e pure $ arraySizes <> arraySizes' - memSizesExp :: LocalScope GPUMem m => Exp GPUMem -> m (Map VName Int) + memSizesExp :: (LocalScope GPUMem m) => Exp GPUMem -> m (Map VName Int) memSizesExp (Op (Inner (SegOp segop))) = let body = segBody segop in inScopeOf (kernelBodyStms body) @@ -283,12 +283,12 @@ $ kernelBodyStms body memSizesExp (Match _ cases defbody _) = do mconcat <$> mapM (memSizes . bodyStms) (defbody : map caseBody cases) - memSizesExp (DoLoop _ _ body) = + memSizesExp (Loop _ _ body) = memSizes $ bodyStms body memSizesExp _ = pure mempty -- | Return a mapping from memory blocks to the space they are allocated in. -memSpaces :: LocalScope GPUMem m => Stms GPUMem -> m (Map VName Space) +memSpaces :: (LocalScope GPUMem m) => Stms GPUMem -> m (Map VName Space) memSpaces stms = pure $ foldMap getSpacesStm stms where @@ -300,12 +300,12 @@ foldMap getSpacesStm $ kernelBodyStms $ segBody segop getSpacesStm (Let _ _ (Match _ cases defbody _)) = foldMap (foldMap getSpacesStm . bodyStms) $ defbody : map caseBody cases - getSpacesStm (Let _ _ (DoLoop _ _ body)) = + getSpacesStm (Let _ _ (Loop _ _ body)) = foldMap getSpacesStm (bodyStms body) getSpacesStm _ = mempty analyseGPU' :: - LocalScope GPUMem m => + (LocalScope GPUMem m) => LUTabFun -> Stms GPUMem -> m (InUse, LastUsed, Graph VName) @@ -313,7 +313,7 @@ mconcat . toList <$> mapM helper stms where helper :: - LocalScope GPUMem m => + (LocalScope GPUMem m) => Stm GPUMem -> m (InUse, LastUsed, Graph VName) helper stm@Let {stmExp = Op (Inner (SegOp segop))} = @@ -322,14 +322,14 @@ inScopeOf stm $ mconcat <$> mapM (analyseGPU' lumap . bodyStms) (defbody : map caseBody cases) - helper stm@Let {stmExp = DoLoop merge _ body} = + helper stm@Let {stmExp = Loop merge _ body} = fmap (analyseLoopParams merge) . inScopeOf stm $ analyseGPU' lumap $ bodyStms body helper stm = inScopeOf stm $ pure mempty -nameInfoToMemInfo :: Mem rep inner => NameInfo rep -> MemBound NoUniqueness +nameInfoToMemInfo :: (Mem rep inner) => NameInfo rep -> MemBound NoUniqueness nameInfoToMemInfo info = case info of FParamName summary -> noUniquenessReturns summary @@ -337,7 +337,7 @@ LetName summary -> letDecMem summary IndexName it -> MemPrim $ IntType it -memInfo :: LocalScope GPUMem m => VName -> m (Maybe VName) +memInfo :: (LocalScope GPUMem m) => VName -> m (Maybe VName) memInfo vname = do summary <- asksScope (fmap nameInfoToMemInfo . M.lookup vname) case summary of @@ -349,7 +349,7 @@ -- | Returns a mapping from memory block to element size. The input is the -- `VName` of a variable (supposedly an array), and the result is a mapping from -- the memory block of that array to element size of the array. -memElemSize :: LocalScope GPUMem m => VName -> m (Map VName Int) +memElemSize :: (LocalScope GPUMem m) => VName -> m (Map VName Int) memElemSize vname = do summary <- asksScope (fmap nameInfoToMemInfo . M.lookup vname) case summary of 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 @@ -62,10 +62,10 @@ MonadState AliasTab ) -instance RepTypes (Aliases rep) => HasScope (Aliases rep) (LastUseM rep) where +instance (RepTypes (Aliases rep)) => HasScope (Aliases rep) (LastUseM rep) where askScope = asks scope -instance RepTypes (Aliases rep) => LocalScope (Aliases rep) (LastUseM rep) where +instance (RepTypes (Aliases rep)) => LocalScope (Aliases rep) (LastUseM rep) where localScope sc (LastUseM m) = LastUseM $ do local (\rd -> rd {scope = scope rd <> sc}) m @@ -84,7 +84,7 @@ gets $ fromMaybe mempty . M.lookup vname lastUseProg :: - Constraints rep => + (Constraints rep) => Prog (Aliases rep) -> LastUseM rep LUTabProg lastUseProg prog = @@ -100,7 +100,7 @@ pure (consts_lu, M.fromList $ zip (map funDefName funs) lus) lastUseFun :: - Constraints rep => + (Constraints rep) => Names -> FunDef (Aliases rep) -> LastUseM rep LUTabFun @@ -126,7 +126,7 @@ -- difference between the free-variables in that stmt and the set of variables -- known to be used after that statement. lastUseBody :: - Constraints rep => + (Constraints rep) => -- | The body of statements Body (Aliases rep) -> -- | The current last-use table, tupled with the known set of already used names @@ -156,7 +156,7 @@ -- difference between the free-variables in that stmt and the set of variables -- known to be used after that statement. lastUseKernelBody :: - Constraints rep => + (Constraints rep) => -- | The body of statements KernelBody (Aliases rep) -> -- | The current last-use table, tupled with the known set of already used names @@ -177,7 +177,7 @@ pure (lutab', used_nms <> used_in_body) lastUseStms :: - Constraints rep => + (Constraints rep) => Stms (Aliases rep) -> (LUTabFun, Names) -> [VName] -> @@ -199,7 +199,7 @@ pure (lutab'', nms'') lastUseStm :: - Constraints rep => + (Constraints rep) => Stm (Aliases rep) -> (LUTabFun, Names) -> LastUseM rep (LUTabFun, Names) @@ -229,7 +229,7 @@ -- | Last-Use Analysis for an expression. lastUseExp :: - Constraints rep => + (Constraints rep) => -- | The expression to analyse Exp (Aliases rep) -> -- | The set of used names "after" this expression @@ -253,7 +253,7 @@ let used_nms' = used_cases <> body_used_nms (_, last_used_arrs) <- lastUsedInNames used_nms $ free_in_body <> free_in_cases pure (lutab_cases <> lutab', last_used_arrs, used_nms') -lastUseExp (DoLoop var_ses lf body) used_nms0 = inScopeOf lf $ do +lastUseExp (Loop var_ses lf body) used_nms0 = inScopeOf lf $ do free_in_body <- aliasTransitiveClosure $ freeIn body -- compute the aliasing transitive closure of initializers that are not last-uses var_inis <- catMaybes <$> mapM (initHelper (free_in_body <> used_nms0)) var_ses @@ -304,7 +304,7 @@ lastUseMemOp onInner (Inner op) used_nms = onInner op used_nms lastUseSegOp :: - Constraints rep => + (Constraints rep) => SegOp lvl (Aliases rep) -> Names -> LastUseM rep (LUTabFun, Names, Names) @@ -356,7 +356,7 @@ ) lastUseSegBinOp :: - Constraints rep => + (Constraints rep) => [SegBinOp (Aliases rep)] -> Names -> LastUseM rep (LUTabFun, Names, Names) @@ -370,7 +370,7 @@ pure (body_lutab, lu_vars, used_nms'') lastUseHistOp :: - Constraints rep => + (Constraints rep) => [HistOp (Aliases rep)] -> Names -> LastUseM rep (LUTabFun, Names, Names) @@ -430,7 +430,7 @@ -- | For each 'PatElem' in the 'Pat', add its aliases to the 'AliasTab' in -- 'LastUseM'. Additionally, 'Names' are added as aliases of all the 'PatElemT'. updateAliasing :: - AliasesOf dec => + (AliasesOf dec) => -- | Extra names that all 'PatElem' should alias. Names -> -- | Pattern to process @@ -439,7 +439,7 @@ updateAliasing extra_aliases = mapM_ update . patElems where - update :: AliasesOf dec => PatElem dec -> LastUseM rep () + update :: (AliasesOf dec) => PatElem dec -> LastUseM rep () update (PatElem name dec) = do let aliases = aliasesOf dec aliases' <- aliasTransitiveClosure $ extra_aliases <> aliases diff --git a/src/Futhark/Analysis/MemAlias.hs b/src/Futhark/Analysis/MemAlias.hs --- a/src/Futhark/Analysis/MemAlias.hs +++ b/src/Futhark/Analysis/MemAlias.hs @@ -95,7 +95,7 @@ & mapMaybe (filterFun m') & foldr (uncurry addAlias) m' & pure -analyzeStm m (Let pat _ (DoLoop params _ body)) = do +analyzeStm m (Let pat _ (Loop params _ body)) = do let m_init = map snd params & zip (patNames pat) diff --git a/src/Futhark/Analysis/Metrics.hs b/src/Futhark/Analysis/Metrics.hs --- a/src/Futhark/Analysis/Metrics.hs +++ b/src/Futhark/Analysis/Metrics.hs @@ -29,7 +29,7 @@ class OpMetrics op where opMetrics :: op -> MetricsM () -instance OpMetrics a => OpMetrics (Maybe a) where +instance (OpMetrics a) => OpMetrics (Maybe a) where opMetrics Nothing = pure () opMetrics (Just x) = opMetrics x @@ -78,7 +78,7 @@ addWhat' (ctx, k) = (what : ctx, k) -- | Compute the metrics for a program. -progMetrics :: OpMetrics (Op rep) => Prog rep -> AstMetrics +progMetrics :: (OpMetrics (Op rep)) => Prog rep -> AstMetrics progMetrics prog = actualMetrics $ execWriter $ @@ -86,24 +86,24 @@ mapM_ funDefMetrics $ progFuns prog mapM_ stmMetrics $ progConsts prog -funDefMetrics :: OpMetrics (Op rep) => FunDef rep -> MetricsM () +funDefMetrics :: (OpMetrics (Op rep)) => FunDef rep -> MetricsM () funDefMetrics = bodyMetrics . funDefBody -- | Compute metrics for this body. -bodyMetrics :: OpMetrics (Op rep) => Body rep -> MetricsM () +bodyMetrics :: (OpMetrics (Op rep)) => Body rep -> MetricsM () bodyMetrics = mapM_ stmMetrics . bodyStms -- | Compute metrics for this statement. -stmMetrics :: OpMetrics (Op rep) => Stm rep -> MetricsM () +stmMetrics :: (OpMetrics (Op rep)) => Stm rep -> MetricsM () stmMetrics = expMetrics . stmExp -expMetrics :: OpMetrics (Op rep) => Exp rep -> MetricsM () +expMetrics :: (OpMetrics (Op rep)) => Exp rep -> MetricsM () expMetrics (BasicOp op) = seen "BasicOp" >> basicOpMetrics op -expMetrics (DoLoop _ ForLoop {} body) = - inside "DoLoop" $ seen "ForLoop" >> bodyMetrics body -expMetrics (DoLoop _ WhileLoop {} body) = - inside "DoLoop" $ seen "WhileLoop" >> bodyMetrics body +expMetrics (Loop _ ForLoop {} body) = + inside "Loop" $ seen "ForLoop" >> bodyMetrics body +expMetrics (Loop _ WhileLoop {} body) = + inside "Loop" $ seen "WhileLoop" >> bodyMetrics body expMetrics (Match _ [Case [Just (BoolValue True)] tb] fb _) = inside "If" $ do inside "True" $ bodyMetrics tb @@ -143,5 +143,5 @@ basicOpMetrics UpdateAcc {} = seen "UpdateAcc" -- | Compute metrics for this lambda. -lambdaMetrics :: OpMetrics (Op rep) => Lambda rep -> MetricsM () +lambdaMetrics :: (OpMetrics (Op rep)) => Lambda rep -> MetricsM () lambdaMetrics = bodyMetrics . lambdaBody diff --git a/src/Futhark/Analysis/PrimExp.hs b/src/Futhark/Analysis/PrimExp.hs --- a/src/Futhark/Analysis/PrimExp.hs +++ b/src/Futhark/Analysis/PrimExp.hs @@ -118,7 +118,7 @@ traverse f (FunExp h args t) = FunExp h <$> traverse (traverse f) args <*> pure t -instance FreeIn v => FreeIn (PrimExp v) where +instance (FreeIn v) => FreeIn (PrimExp v) where freeIn' = foldMap freeIn' -- | A 'PrimExp' tagged with a phantom type used to provide type-safe @@ -136,7 +136,7 @@ instance Traversable (TPrimExp t) where traverse f (TPrimExp e) = TPrimExp <$> traverse f e -instance FreeIn v => FreeIn (TPrimExp t v) where +instance (FreeIn v) => FreeIn (TPrimExp t v) where freeIn' = freeIn' . untyped -- | This expression is of type t'Int8'. @@ -246,7 +246,7 @@ ValueExp $ IntValue $ intValue it (0 :: Integer) constFoldPrimExp e = e -constFoldCmpExp :: Eq v => PrimExp v -> PrimExp v +constFoldCmpExp :: (Eq v) => PrimExp v -> PrimExp v constFoldCmpExp (CmpOpExp (CmpEq _) x y) | x == y = untyped true @@ -267,7 +267,7 @@ -- | The class of integer types that can be used for constructing -- 'TPrimExp's. -class NumExp t => IntExp t where +class (NumExp t) => IntExp t where -- | The type of an expression, known to be an integer type. expIntType :: TPrimExp t v -> IntType @@ -301,7 +301,7 @@ -- | The class of floating-point types that can be used for -- constructing 'TPrimExp's. -class NumExp t => FloatExp t where +class (NumExp t) => FloatExp t where -- | Construct a typed expression from a rational. fromRational' :: Rational -> TPrimExp t v @@ -378,7 +378,7 @@ fromRational = fromRational' -instance Pretty v => Floating (TPrimExp Half v) where +instance (Pretty v) => Floating (TPrimExp Half v) where x ** y = isF16 $ BinOpExp (FPow Float16) (untyped x) (untyped y) pi = isF16 $ ValueExp $ FloatValue $ Float16Value pi exp x = isF16 $ FunExp "exp16" [untyped x] $ FloatType Float16 @@ -396,7 +396,7 @@ acosh x = isF16 $ FunExp "acosh16" [untyped x] $ FloatType Float16 atanh x = isF16 $ FunExp "atanh16" [untyped x] $ FloatType Float16 -instance Pretty v => Floating (TPrimExp Float v) where +instance (Pretty v) => Floating (TPrimExp Float v) where x ** y = isF32 $ BinOpExp (FPow Float32) (untyped x) (untyped y) pi = isF32 $ ValueExp $ FloatValue $ Float32Value pi exp x = isF32 $ FunExp "exp32" [untyped x] $ FloatType Float32 @@ -414,7 +414,7 @@ acosh x = isF32 $ FunExp "acosh32" [untyped x] $ FloatType Float32 atanh x = isF32 $ FunExp "atanh32" [untyped x] $ FloatType Float32 -instance Pretty v => Floating (TPrimExp Double v) where +instance (Pretty v) => Floating (TPrimExp Double v) where x ** y = isF64 $ BinOpExp (FPow Float64) (untyped x) (untyped y) pi = isF64 $ ValueExp $ FloatValue $ Float64Value pi exp x = isF64 $ FunExp "exp64" [untyped x] $ FloatType Float64 @@ -476,16 +476,16 @@ sgn _ = Nothing -- | Lifted logical conjunction. -(.&&.) :: Eq v => TPrimExp Bool v -> TPrimExp Bool v -> TPrimExp Bool v +(.&&.) :: (Eq v) => TPrimExp Bool v -> TPrimExp Bool v -> TPrimExp Bool v TPrimExp x .&&. TPrimExp y = TPrimExp $ constFoldPrimExp $ BinOpExp LogAnd x y -- | Lifted logical conjunction. -(.||.) :: Eq v => TPrimExp Bool v -> TPrimExp Bool v -> TPrimExp Bool v +(.||.) :: (Eq v) => TPrimExp Bool v -> TPrimExp Bool v -> TPrimExp Bool v TPrimExp x .||. TPrimExp y = TPrimExp $ constFoldPrimExp $ BinOpExp LogOr x y -- | Lifted relational operators; assuming signed numbers in case of -- integers. -(.<.), (.>.), (.<=.), (.>=.), (.==.) :: Eq v => TPrimExp t v -> TPrimExp t v -> TPrimExp Bool v +(.<.), (.>.), (.<=.), (.>=.), (.==.) :: (Eq v) => TPrimExp t v -> TPrimExp t v -> TPrimExp Bool v TPrimExp x .<. TPrimExp y = TPrimExp $ constFoldCmpExp $ CmpOpExp cmp x y where @@ -508,8 +508,8 @@ x .>=. y = y .<=. x -- | Lifted bitwise operators. The right-shift is logical, *not* arithmetic. -(.&.), (.|.), (.^.), (.>>.), (.<<.) :: Eq v => TPrimExp t v -> TPrimExp t v -> TPrimExp t v -bitPrimExp :: Eq v => (IntType -> BinOp) -> TPrimExp t v -> TPrimExp t v -> TPrimExp t v +(.&.), (.|.), (.^.), (.>>.), (.<<.) :: (Eq v) => TPrimExp t v -> TPrimExp t v -> TPrimExp t v +bitPrimExp :: (Eq v) => (IntType -> BinOp) -> TPrimExp t v -> TPrimExp t v -> TPrimExp t v bitPrimExp op (TPrimExp x) (TPrimExp y) = TPrimExp $ constFoldPrimExp $ @@ -552,7 +552,7 @@ | FloatType t <- primExpType x = Just $ BinOpExp (f t) x y | otherwise = Nothing -numBad :: Pretty a => String -> a -> b +numBad :: (Pretty a) => String -> a -> b numBad s x = error $ "Invalid argument to PrimExp method " ++ s ++ ": " ++ prettyString x @@ -661,19 +661,19 @@ sMin64 x y = TPrimExp $ BinOpExp (SMin Int64) (untyped x) (untyped y) -- | Sign-extend to 32 bit integer. -sExt32 :: IntExp t => TPrimExp t v -> TPrimExp Int32 v +sExt32 :: (IntExp t) => TPrimExp t v -> TPrimExp Int32 v sExt32 = isInt32 . sExt Int32 . untyped -- | Sign-extend to 64 bit integer. -sExt64 :: IntExp t => TPrimExp t v -> TPrimExp Int64 v +sExt64 :: (IntExp t) => TPrimExp t v -> TPrimExp Int64 v sExt64 = isInt64 . sExt Int64 . untyped -- | Zero-extend to 32 bit integer. -zExt32 :: IntExp t => TPrimExp t v -> TPrimExp Int32 v +zExt32 :: (IntExp t) => TPrimExp t v -> TPrimExp Int32 v zExt32 = isInt32 . zExt Int32 . untyped -- | Zero-extend to 64 bit integer. -zExt64 :: IntExp t => TPrimExp t v -> TPrimExp Int64 v +zExt64 :: (IntExp t) => TPrimExp t v -> TPrimExp Int64 v zExt64 = isInt64 . zExt Int64 . untyped -- | 16-bit float minimum. @@ -711,7 +711,7 @@ -- Prettyprinting instances -instance Pretty v => Pretty (PrimExp v) where +instance (Pretty v) => Pretty (PrimExp v) where pretty (LeafExp v _) = pretty v pretty (ValueExp v) = pretty v pretty (BinOpExp op x y) = pretty op <+> parens (pretty x) <+> parens (pretty y) @@ -720,12 +720,12 @@ pretty (UnOpExp op x) = pretty op <+> parens (pretty x) pretty (FunExp h args _) = pretty h <+> parens (commasep $ map pretty args) -instance Pretty v => Pretty (TPrimExp t v) where +instance (Pretty v) => Pretty (TPrimExp t v) where pretty = pretty . untyped -- | Produce a mapping from the leaves of the 'PrimExp' to their -- designated types. -leafExpTypes :: Ord a => PrimExp a -> S.Set (a, PrimType) +leafExpTypes :: (Ord a) => PrimExp a -> S.Set (a, PrimType) leafExpTypes (LeafExp x ptp) = S.singleton (x, ptp) leafExpTypes (ValueExp _) = S.empty leafExpTypes (UnOpExp _ e) = leafExpTypes e 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 @@ -33,7 +33,7 @@ import Futhark.Construct import Futhark.IR -instance ToExp v => ToExp (PrimExp v) where +instance (ToExp v) => ToExp (PrimExp v) where toExp (BinOpExp op x y) = BasicOp <$> (BinOp op <$> toSubExp "binop_x" x <*> toSubExp "binop_y" y) toExp (CmpOpExp op x y) = @@ -54,7 +54,7 @@ toExp (LeafExp v _) = toExp v -instance ToExp v => ToExp (TPrimExp t v) where +instance (ToExp v) => ToExp (TPrimExp t v) where toExp = toExp . untyped -- | Convert an expression to a 'PrimExp'. The provided function is @@ -83,7 +83,7 @@ primExpFromExp _ _ = fail "Not a PrimExp" -- | Like 'primExpFromExp', but for a t'SubExp'. -primExpFromSubExpM :: Applicative m => (VName -> m (PrimExp v)) -> SubExp -> m (PrimExp v) +primExpFromSubExpM :: (Applicative m) => (VName -> m (PrimExp v)) -> SubExp -> m (PrimExp v) primExpFromSubExpM f (Var v) = f v primExpFromSubExpM _ (Constant v) = pure $ ValueExp v @@ -126,7 +126,7 @@ -- | Applying a monadic transformation to the leaves in a 'PrimExp'. replaceInPrimExpM :: - Monad m => + (Monad m) => (a -> PrimType -> m (PrimExp b)) -> PrimExp a -> m (PrimExp b) @@ -157,7 +157,7 @@ -- | Substituting names in a PrimExp with other PrimExps substituteInPrimExp :: - Ord v => + (Ord v) => M.Map v (PrimExp v) -> PrimExp v -> PrimExp v @@ -169,5 +169,5 @@ primExpSlice = fmap pe64 -- | Convert a 'PrimExp' slice to a t'SubExp' slice. -subExpSlice :: MonadBuilder m => Slice (TPrimExp Int64 VName) -> m (Slice SubExp) +subExpSlice :: (MonadBuilder m) => Slice (TPrimExp Int64 VName) -> m (Slice SubExp) subExpSlice = traverse $ toSubExp "slice" diff --git a/src/Futhark/Analysis/PrimExp/Simplify.hs b/src/Futhark/Analysis/PrimExp/Simplify.hs --- a/src/Futhark/Analysis/PrimExp/Simplify.hs +++ b/src/Futhark/Analysis/PrimExp/Simplify.hs @@ -9,7 +9,7 @@ -- refers to a name that is a 'Constant', the node turns into a -- 'ValueExp'. simplifyPrimExp :: - SimplifiableRep rep => + (SimplifiableRep rep) => PrimExp VName -> SimpleM rep (PrimExp VName) simplifyPrimExp = simplifyAnyPrimExp onLeaf @@ -22,7 +22,7 @@ -- | Like 'simplifyPrimExp', but where leaves may be 'Ext's. simplifyExtPrimExp :: - SimplifiableRep rep => + (SimplifiableRep rep) => PrimExp (Ext VName) -> SimpleM rep (PrimExp (Ext VName)) simplifyExtPrimExp = simplifyAnyPrimExp onLeaf @@ -35,7 +35,7 @@ onLeaf (Ext i) pt = pure $ LeafExp (Ext i) pt simplifyAnyPrimExp :: - SimplifiableRep rep => + (SimplifiableRep rep) => (a -> PrimType -> SimpleM rep (PrimExp a)) -> PrimExp a -> SimpleM rep (PrimExp a) diff --git a/src/Futhark/Analysis/SymbolTable.hs b/src/Futhark/Analysis/SymbolTable.hs --- a/src/Futhark/Analysis/SymbolTable.hs +++ b/src/Futhark/Analysis/SymbolTable.hs @@ -93,7 +93,7 @@ empty :: SymbolTable rep empty = SymbolTable 0 M.empty mempty False -fromScope :: ASTRep rep => Scope rep -> SymbolTable rep +fromScope :: (ASTRep rep) => Scope rep -> SymbolTable rep fromScope = M.foldlWithKey' insertFreeVar' empty where insertFreeVar' m k dec = insertFreeVar k dec m @@ -182,7 +182,7 @@ freeVarIndex :: VName -> IndexArray } -instance ASTRep rep => Typed (Entry rep) where +instance (ASTRep rep) => Typed (Entry rep) where typeOf = typeOf . entryInfo entryInfo :: Entry rep -> NameInfo rep @@ -239,10 +239,10 @@ Just (BasicOp e, cs) -> Just (e, cs) _ -> Nothing -lookupType :: ASTRep rep => VName -> SymbolTable rep -> Maybe Type +lookupType :: (ASTRep rep) => VName -> SymbolTable rep -> Maybe Type lookupType name vtable = typeOf <$> lookup name vtable -lookupSubExpType :: ASTRep rep => SubExp -> SymbolTable rep -> Maybe Type +lookupSubExpType :: (ASTRep rep) => SubExp -> SymbolTable rep -> Maybe Type lookupSubExpType (Var v) = lookupType v lookupSubExpType (Constant v) = const $ Just $ Prim $ primValueType v @@ -288,7 +288,7 @@ subExpAvailable Constant {} = const True index :: - ASTRep rep => + (ASTRep rep) => VName -> [SubExp] -> SymbolTable rep -> @@ -405,11 +405,11 @@ pat_elem <- patElems pat pure $ defBndEntry vtable pat_elem (Aliases.aliasesOf pat_elem) stm -adjustSeveral :: Ord k => (v -> v) -> [k] -> M.Map k v -> M.Map k v +adjustSeveral :: (Ord k) => (v -> v) -> [k] -> M.Map k v -> M.Map k v adjustSeveral f = flip $ foldl' $ flip $ M.adjust f insertEntry :: - ASTRep rep => + (ASTRep rep) => VName -> EntryType rep -> SymbolTable rep -> @@ -433,7 +433,7 @@ } insertEntries :: - ASTRep rep => + (ASTRep rep) => [(VName, EntryType rep)] -> SymbolTable rep -> SymbolTable rep @@ -495,7 +495,7 @@ mconcat . map (`lookupAliases` vtable) . namesToList $ names insertFParam :: - ASTRep rep => + (ASTRep rep) => AST.FParam rep -> SymbolTable rep -> SymbolTable rep @@ -511,13 +511,13 @@ } insertFParams :: - ASTRep rep => + (ASTRep rep) => [AST.FParam rep] -> SymbolTable rep -> SymbolTable rep insertFParams fparams symtable = foldl' (flip insertFParam) symtable fparams -insertLParam :: ASTRep rep => LParam rep -> SymbolTable rep -> SymbolTable rep +insertLParam :: (ASTRep rep) => LParam rep -> SymbolTable rep -> SymbolTable rep insertLParam param = insertEntry name bind where bind = @@ -537,7 +537,7 @@ -- used to help some loop optimisations detect invariant loop -- parameters. insertLoopMerge :: - ASTRep rep => + (ASTRep rep) => [(AST.FParam rep, SubExp, SubExpRes)] -> SymbolTable rep -> SymbolTable rep @@ -552,7 +552,7 @@ fparamMerge = Just (initial, res) } -insertLoopVar :: ASTRep rep => VName -> IntType -> SubExp -> SymbolTable rep -> SymbolTable rep +insertLoopVar :: (ASTRep rep) => VName -> IntType -> SubExp -> SymbolTable rep -> SymbolTable rep insertLoopVar name it bound = insertEntry name bind where bind = @@ -562,7 +562,7 @@ loopVarBound = bound } -insertFreeVar :: ASTRep rep => VName -> NameInfo rep -> SymbolTable rep -> SymbolTable rep +insertFreeVar :: (ASTRep rep) => VName -> NameInfo rep -> SymbolTable rep -> SymbolTable rep insertFreeVar name dec = insertEntry name entry where entry = diff --git a/src/Futhark/Analysis/UsageTable.hs b/src/Futhark/Analysis/UsageTable.hs --- a/src/Futhark/Analysis/UsageTable.hs +++ b/src/Futhark/Analysis/UsageTable.hs @@ -148,12 +148,12 @@ withoutU :: Usages -> Usages -> Usages withoutU (Usages x) (Usages y) = Usages $ x .&. complement y -usageInBody :: Aliased rep => Body rep -> UsageTable +usageInBody :: (Aliased rep) => Body rep -> UsageTable usageInBody = foldMap consumedUsage . namesToList . consumedInBody -- | Produce a usage table reflecting the use of the free variables in -- a single statement. -usageInStm :: Aliased rep => Stm rep -> UsageTable +usageInStm :: (Aliased rep) => Stm rep -> UsageTable usageInStm (Let pat rep e) = mconcat [ usageInPat pat `without` patNames pat, @@ -165,17 +165,17 @@ -- | Usage table reflecting use in pattern. In particular, free -- variables in the decorations are considered used as sizes, even if -- they are also bound in this pattern. -usageInPat :: FreeIn t => Pat t -> UsageTable +usageInPat :: (FreeIn t) => Pat t -> UsageTable usageInPat = sizeUsages . foldMap freeIn . patElems -usageInExp :: Aliased rep => Exp rep -> UsageTable +usageInExp :: (Aliased rep) => Exp rep -> UsageTable usageInExp (Apply _ args _ _) = mconcat [ mconcat $ map consumedUsage $ namesToList $ subExpAliases arg | (arg, d) <- args, d == Consume ] -usageInExp e@DoLoop {} = +usageInExp e@Loop {} = foldMap consumedUsage $ namesToList $ consumedInExp e usageInExp (Match _ cases defbody _) = foldMap (usageInBody . caseBody) cases <> usageInBody defbody diff --git a/src/Futhark/Bench.hs b/src/Futhark/Bench.hs --- a/src/Futhark/Bench.hs +++ b/src/Futhark/Bench.hs @@ -359,7 +359,7 @@ -- | Compile and produce reference datasets. prepareBenchmarkProgram :: - MonadIO m => + (MonadIO m) => Maybe Int -> CompileOptions -> FilePath -> diff --git a/src/Futhark/Builder.hs b/src/Futhark/Builder.hs --- a/src/Futhark/Builder.hs +++ b/src/Futhark/Builder.hs @@ -38,7 +38,7 @@ -- | A 'BuilderT' (and by extension, a 'Builder') is only an instance of -- 'MonadBuilder' for representations that implement this type class, -- which contains methods for constructing statements. -class ASTRep rep => BuilderOps rep where +class (ASTRep rep) => BuilderOps rep where mkExpDecB :: (MonadBuilder m, Rep m ~ rep) => Pat (LetDec rep) -> @@ -91,7 +91,7 @@ -- | The most commonly used binder monad. type Builder rep = BuilderT rep (State VNameSource) -instance MonadFreshNames m => MonadFreshNames (BuilderT rep m) where +instance (MonadFreshNames m) => MonadFreshNames (BuilderT rep m) where getNameSource = lift getNameSource putNameSource = lift . putNameSource @@ -141,7 +141,7 @@ -- | Run a binder action given an initial scope, returning a value and -- the statements added ('addStm') during the action. runBuilderT :: - MonadFreshNames m => + (MonadFreshNames m) => BuilderT rep m a -> Scope rep -> m (a, Stms rep) @@ -151,7 +151,7 @@ -- | Like 'runBuilderT', but return only the statements. runBuilderT_ :: - MonadFreshNames m => + (MonadFreshNames m) => BuilderT rep m () -> Scope rep -> m (Stms rep) @@ -228,7 +228,7 @@ -- UndecidableInstances, but save on typing elsewhere. mapInner :: - Monad m => + (Monad m) => ( m (a, (Stms rep, Scope rep)) -> m (b, (Stms rep, Scope rep)) ) -> @@ -240,15 +240,15 @@ put s' pure x -instance MonadReader r m => MonadReader r (BuilderT rep m) where +instance (MonadReader r m) => MonadReader r (BuilderT rep m) where ask = BuilderT $ lift ask local f = mapInner $ local f -instance MonadState s m => MonadState s (BuilderT rep m) where +instance (MonadState s m) => MonadState s (BuilderT rep m) where get = BuilderT $ lift get put = BuilderT . lift . put -instance MonadWriter w m => MonadWriter w (BuilderT rep m) where +instance (MonadWriter w m) => MonadWriter w (BuilderT rep m) where tell = BuilderT . lift . tell pass = mapInner $ \m -> pass $ do ((x, f), s) <- m @@ -257,7 +257,7 @@ ((x, s), y) <- listen m pure ((x, y), s) -instance MonadError e m => MonadError e (BuilderT rep m) where +instance (MonadError e m) => MonadError e (BuilderT rep m) where throwError = lift . throwError catchError (BuilderT m) f = BuilderT $ catchError m $ unBuilder . f 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 @@ -93,7 +93,7 @@ -- | Apply a function to the statements added by this action. censorStms :: - MonadBuilder m => + (MonadBuilder m) => (Stms (Rep m) -> Stms (Rep m)) -> m a -> m a @@ -103,7 +103,7 @@ pure x -- | Add the given attributes to any statements added by this action. -attributing :: MonadBuilder m => Attrs -> m a -> m a +attributing :: (MonadBuilder m) => Attrs -> m a -> m a attributing attrs = censorStms $ fmap onStm where onStm (Let pat aux e) = @@ -111,7 +111,7 @@ -- | Add the certificates and attributes to any statements added by -- this action. -auxing :: MonadBuilder m => StmAux anyrep -> m a -> m a +auxing :: (MonadBuilder m) => StmAux anyrep -> m a -> m a auxing (StmAux cs attrs _) = censorStms $ fmap onStm where onStm (Let pat aux e) = @@ -125,7 +125,7 @@ -- | Add a statement with the given pattern and expression. letBind :: - MonadBuilder m => + (MonadBuilder m) => Pat (LetDec (Rep m)) -> Exp (Rep m) -> m () @@ -134,7 +134,7 @@ -- | Construct a 'Stm' from identifiers for the context- and value -- part of the pattern, as well as the expression. -mkLet :: Buildable rep => [Ident] -> Exp rep -> Stm rep +mkLet :: (Buildable rep) => [Ident] -> Exp rep -> Stm rep mkLet ids e = let pat = mkExpPat ids e dec = mkExpDec pat e @@ -142,7 +142,7 @@ -- | Like mkLet, but also take attributes and certificates from the -- given 'StmAux'. -mkLet' :: Buildable rep => [Ident] -> StmAux a -> Exp rep -> Stm rep +mkLet' :: (Buildable rep) => [Ident] -> StmAux a -> Exp rep -> Stm rep mkLet' ids (StmAux cs attrs _) e = let pat = mkExpPat ids e dec = mkExpDec pat e @@ -150,23 +150,23 @@ -- | Add a statement with the given pattern element names and -- expression. -letBindNames :: MonadBuilder m => [VName] -> Exp (Rep m) -> m () +letBindNames :: (MonadBuilder m) => [VName] -> Exp (Rep m) -> m () letBindNames names e = addStm =<< mkLetNamesM names e -- | As 'collectStms', but throw away the ordinary result. -collectStms_ :: MonadBuilder m => m a -> m (Stms (Rep m)) +collectStms_ :: (MonadBuilder m) => m a -> m (Stms (Rep m)) collectStms_ = fmap snd . collectStms -- | Add the statements of the body, then return the body result. -bodyBind :: MonadBuilder m => Body (Rep m) -> m Result +bodyBind :: (MonadBuilder m) => Body (Rep m) -> m Result bodyBind (Body _ stms res) = do addStms stms pure res -- | Add several bindings at the outermost level of a t'Body'. -insertStms :: Buildable rep => Stms rep -> Body rep -> Body rep +insertStms :: (Buildable rep) => Stms rep -> Body rep -> Body rep insertStms stms1 (Body _ stms2 res) = mkBody (stms1 <> stms2) res -- | Add a single binding at the outermost level of a t'Body'. -insertStm :: Buildable rep => Stm rep -> Body rep -> Body rep +insertStm :: (Buildable rep) => Stm rep -> Body rep -> Body rep insertStm = insertStms . oneStm diff --git a/src/Futhark/CLI/Dataset.hs b/src/Futhark/CLI/Dataset.hs --- a/src/Futhark/CLI/Dataset.hs +++ b/src/Futhark/CLI/Dataset.hs @@ -141,7 +141,7 @@ ] setRangeOption :: - Read a => + (Read a) => String -> (Range a -> RandomConfiguration -> RandomConfiguration) -> FunOptDescr DataOptions diff --git a/src/Futhark/CLI/Dev.hs b/src/Futhark/CLI/Dev.hs --- a/src/Futhark/CLI/Dev.hs +++ b/src/Futhark/CLI/Dev.hs @@ -241,7 +241,7 @@ "Pass " ++ name ++ " expects MCMem representation, but got " ++ representation rep typedPassOption :: - Checkable torep => + (Checkable torep) => (String -> UntypedPassState -> FutharkM (Prog fromrep)) -> (Prog torep -> UntypedPassState) -> Pass fromrep torep -> diff --git a/src/Futhark/CLI/Eval.hs b/src/Futhark/CLI/Eval.hs --- a/src/Futhark/CLI/Eval.hs +++ b/src/Futhark/CLI/Eval.hs @@ -128,7 +128,7 @@ badOnLeft _ (Right x) = pure x badOnLeft p (Left err) = throwError $ p err -runInterpreterNoBreak :: MonadIO m => F I.ExtOp a -> m (Either I.InterpreterError a) +runInterpreterNoBreak :: (MonadIO m) => F I.ExtOp a -> m (Either I.InterpreterError a) runInterpreterNoBreak m = runF m (pure . Right) intOp where intOp (I.ExtOpError err) = pure $ Left err diff --git a/src/Futhark/CLI/HIP.hs b/src/Futhark/CLI/HIP.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/CLI/HIP.hs @@ -0,0 +1,17 @@ +-- | @futhark hip@ +module Futhark.CLI.HIP (main) where + +import Futhark.Actions (compileHIPAction) +import Futhark.Compiler.CLI +import Futhark.Passes (gpumemPipeline) + +-- | Run @futhark hip@. +main :: String -> [String] -> IO () +main = compilerMain + () + [] + "Compile HIP" + "Generate HIP/C code from optimised Futhark program." + gpumemPipeline + $ \fcfg () mode outpath prog -> + actionProcedure (compileHIPAction fcfg mode outpath) prog diff --git a/src/Futhark/CLI/Main.hs b/src/Futhark/CLI/Main.hs --- a/src/Futhark/CLI/Main.hs +++ b/src/Futhark/CLI/Main.hs @@ -17,6 +17,7 @@ import Futhark.CLI.Dev qualified as Dev import Futhark.CLI.Doc qualified as Doc import Futhark.CLI.Eval qualified as Eval +import Futhark.CLI.HIP qualified as HIP import Futhark.CLI.LSP qualified as LSP import Futhark.CLI.Literate qualified as Literate import Futhark.CLI.Misc qualified as Misc @@ -55,6 +56,7 @@ ("c", (C.main, "Compile to sequential C.")), ("opencl", (OpenCL.main, "Compile to C calling OpenCL.")), ("cuda", (CCUDA.main, "Compile to C calling CUDA.")), + ("hip", (HIP.main, "Compile to C calling HIP.")), ("multicore", (Multicore.main, "Compile to multicore C.")), ("python", (Python.main, "Compile to sequential Python.")), ("pyopencl", (PyOpenCL.main, "Compile to Python calling PyOpenCL.")), diff --git a/src/Futhark/CLI/REPL.hs b/src/Futhark/CLI/REPL.hs --- a/src/Futhark/CLI/REPL.hs +++ b/src/Futhark/CLI/REPL.hs @@ -358,7 +358,7 @@ c -runInterpreterNoBreak :: MonadIO m => F I.ExtOp a -> m (Either I.InterpreterError a) +runInterpreterNoBreak :: (MonadIO m) => F I.ExtOp a -> m (Either I.InterpreterError a) runInterpreterNoBreak m = runF m (pure . Right) intOp where intOp (I.ExtOpError err) = pure $ Left err diff --git a/src/Futhark/CLI/Run.hs b/src/Futhark/CLI/Run.hs --- a/src/Futhark/CLI/Run.hs +++ b/src/Futhark/CLI/Run.hs @@ -138,7 +138,7 @@ badOnLeft _ (Right x) = pure x badOnLeft p (Left err) = throwError $ p err -runInterpreter' :: MonadIO m => F I.ExtOp a -> m (Either I.InterpreterError a) +runInterpreter' :: (MonadIO m) => F I.ExtOp a -> m (Either I.InterpreterError a) runInterpreter' m = runF m (pure . Right) intOp where intOp (I.ExtOpError err) = pure $ Left err diff --git a/src/Futhark/CLI/Test.hs b/src/Futhark/CLI/Test.hs --- a/src/Futhark/CLI/Test.hs +++ b/src/Futhark/CLI/Test.hs @@ -42,7 +42,7 @@ eitherToErrors :: Either e a -> Errors e a eitherToErrors = either failure Pure -throwError :: MonadError [e] m => e -> m a +throwError :: (MonadError [e] m) => e -> m a throwError e = E.throwError [e] runTestM :: TestM () -> IO TestResult @@ -57,7 +57,7 @@ [] -> [] (e : es') -> (s <> ":\n" <> e) : es' -context1 :: Monad m => T.Text -> ExceptT T.Text m a -> ExceptT T.Text m a +context1 :: (Monad m) => T.Text -> ExceptT T.Text m a -> ExceptT T.Text m a context1 s = withExceptT $ \e -> s <> ":\n" <> e accErrors :: [TestM a] -> TestM [a] @@ -358,7 +358,7 @@ compareResult entry index program expected res -checkError :: MonadError T.Text m => ExpectedError -> T.Text -> m () +checkError :: (MonadError T.Text m) => ExpectedError -> T.Text -> m () checkError (ThisError regex_s regex) err | not (match regex $ T.unpack err) = E.throwError $ diff --git a/src/Futhark/CodeGen/Backends/CCUDA.hs b/src/Futhark/CodeGen/Backends/CCUDA.hs --- a/src/Futhark/CodeGen/Backends/CCUDA.hs +++ b/src/Futhark/CodeGen/Backends/CCUDA.hs @@ -10,17 +10,14 @@ ) where -import Control.Monad -import Data.List (unzip4) -import Data.Maybe (catMaybes) +import Data.Map qualified as M import Data.Text qualified as T -import Futhark.CodeGen.Backends.CCUDA.Boilerplate -import Futhark.CodeGen.Backends.COpenCL.Boilerplate (commonOptions, sizeLoggingCode) +import Futhark.CodeGen.Backends.GPU import Futhark.CodeGen.Backends.GenericC qualified as GC import Futhark.CodeGen.Backends.GenericC.Options -import Futhark.CodeGen.Backends.SimpleRep (primStorageType, toStorage) import Futhark.CodeGen.ImpCode.OpenCL import Futhark.CodeGen.ImpGen.CUDA qualified as ImpGen +import Futhark.CodeGen.RTS.C (backendsCudaH) import Futhark.IR.GPUMem hiding ( CmpSizeLe, GetSize, @@ -28,81 +25,60 @@ ) import Futhark.MonadFreshNames import Language.C.Quote.OpenCL qualified as C -import Language.C.Syntax qualified as C import NeatInterpolation (untrimming) --- | Compile the program to C with calls to CUDA. -compileProg :: MonadFreshNames m => T.Text -> Prog GPUMem -> m (ImpGen.Warnings, GC.CParts) -compileProg version prog = do - (ws, Program cuda_code cuda_prelude kernels _ params failures prog') <- - ImpGen.compileProg prog - let cost_centres = - [ copyDevToDev, - copyDevToHost, - copyHostToDev, - copyScalarToDev, - copyScalarFromDev - ] - extra = - generateBoilerplate - cuda_code - cuda_prelude - cost_centres - kernels - failures - (ws,) - <$> GC.compileProg - "cuda" - version - params - operations - extra - cuda_includes - (Space "device", [Space "device", DefaultSpace]) - cliOptions - prog' - where - operations :: GC.Operations OpenCL () - operations = - GC.defaultOperations - { GC.opsWriteScalar = writeCUDAScalar, - GC.opsReadScalar = readCUDAScalar, - GC.opsAllocate = allocateCUDABuffer, - GC.opsDeallocate = deallocateCUDABuffer, - GC.opsCopy = copyCUDAMemory, - GC.opsMemoryType = cudaMemoryType, - GC.opsCompiler = callKernel, - GC.opsFatMemory = True, - GC.opsCritical = - ( [C.citems|CUDA_SUCCEED_FATAL(cuCtxPushCurrent(ctx->cu_ctx));|], - [C.citems|CUDA_SUCCEED_FATAL(cuCtxPopCurrent(&ctx->cu_ctx));|] - ) - } - cuda_includes = - [untrimming| - #include - #include - #include - |] +mkBoilerplate :: + T.Text -> + M.Map Name KernelSafety -> + [PrimType] -> + [FailureMsg] -> + GC.CompilerM OpenCL () () +mkBoilerplate cuda_program kernels types failures = do + generateGPUBoilerplate + cuda_program + backendsCudaH + (M.keys kernels) + types + failures + GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_add_nvrtc_option(struct futhark_context_config *cfg, const char* opt);|] + GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_set_device(struct futhark_context_config *cfg, const char* s);|] + GC.headerDecl GC.InitDecl [C.cedecl|const char* futhark_context_config_get_program(struct futhark_context_config *cfg);|] + GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_set_program(struct futhark_context_config *cfg, const char* s);|] + GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_dump_ptx_to(struct futhark_context_config *cfg, const char* s);|] + GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_load_ptx_from(struct futhark_context_config *cfg, const char* s);|] + GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_set_default_group_size(struct futhark_context_config *cfg, int size);|] + GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_set_default_num_groups(struct futhark_context_config *cfg, int size);|] + GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_set_default_tile_size(struct futhark_context_config *cfg, int size);|] + GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_set_default_reg_tile_size(struct futhark_context_config *cfg, int size);|] + GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_set_default_threshold(struct futhark_context_config *cfg, int size);|] + cliOptions :: [Option] cliOptions = - commonOptions + gpuOptions ++ [ Option { optionLongName = "dump-cuda", optionShortName = Nothing, optionArgument = RequiredArgument "FILE", optionDescription = "Dump the embedded CUDA kernels to the indicated file.", optionAction = - [C.cstm|{futhark_context_config_dump_program_to(cfg, optarg); - entry_point = NULL;}|] + [C.cstm|{const char* prog = futhark_context_config_get_program(cfg); + if (dump_file(optarg, prog, strlen(prog)) != 0) { + fprintf(stderr, "%s: %s\n", optarg, strerror(errno)); + exit(1); + } + exit(1);}|] }, Option { optionLongName = "load-cuda", optionShortName = Nothing, optionArgument = RequiredArgument "FILE", optionDescription = "Instead of using the embedded CUDA kernels, load them from the indicated file.", - optionAction = [C.cstm|futhark_context_config_load_program_from(cfg, optarg);|] + optionAction = + [C.cstm|{ size_t n; const char *s = slurp_file(optarg, &n); + if (s == NULL) { fprintf(stderr, "%s: %s\n", optarg, strerror(errno)); exit(1); } + futhark_context_config_set_program(cfg, s); + }|] }, Option { optionLongName = "dump-ptx", @@ -136,278 +112,41 @@ } ] --- We detect the special case of writing a constant and turn it into a --- non-blocking write. This may be slightly faster, as it prevents --- unnecessary synchronisation of the context, and writing a constant --- is fairly common. This is only possible because we can give the --- constant infinite lifetime (with 'static'), which is not the case --- for ordinary variables. -writeCUDAScalar :: GC.WriteScalar OpenCL () -writeCUDAScalar mem idx t "device" _ val@C.Const {} = do - val' <- newVName "write_static" - let (bef, aft) = profilingEnclosure copyScalarToDev - GC.item - [C.citem|{static $ty:t $id:val' = $exp:val; - $items:bef - CUDA_SUCCEED_OR_RETURN( - cuMemcpyHtoDAsync($exp:mem + $exp:idx * sizeof($ty:t), - &$id:val', - sizeof($ty:t), - ctx->stream)); - $items:aft - }|] -writeCUDAScalar mem idx t "device" _ val = do - val' <- newVName "write_tmp" - let (bef, aft) = profilingEnclosure copyScalarToDev - GC.item - [C.citem|{$ty:t $id:val' = $exp:val; - $items:bef - CUDA_SUCCEED_OR_RETURN( - cuMemcpyHtoD($exp:mem + $exp:idx * sizeof($ty:t), - &$id:val', - sizeof($ty:t))); - $items:aft - }|] -writeCUDAScalar _ _ _ space _ _ = - error $ "Cannot write to '" ++ space ++ "' memory space." - -readCUDAScalar :: GC.ReadScalar OpenCL () -readCUDAScalar mem idx t "device" _ = do - val <- newVName "read_res" - let (bef, aft) = profilingEnclosure copyScalarFromDev - mapM_ - GC.item - [C.citems| - $ty:t $id:val; - { - $items:bef - CUDA_SUCCEED_OR_RETURN( - cuMemcpyDtoH(&$id:val, - $exp:mem + $exp:idx * sizeof($ty:t), - sizeof($ty:t))); - $items:aft - } - |] - GC.stm - [C.cstm|if (ctx->failure_is_an_option && futhark_context_sync(ctx) != 0) - { return 1; }|] - pure [C.cexp|$id:val|] -readCUDAScalar _ _ _ space _ = - error $ "Cannot write to '" ++ space ++ "' memory space." - -allocateCUDABuffer :: GC.Allocate OpenCL () -allocateCUDABuffer mem size tag "device" = - GC.stm - [C.cstm|ctx->error = - CUDA_SUCCEED_NONFATAL(cuda_alloc(ctx, ctx->log, - (size_t)$exp:size, $exp:tag, - &$exp:mem, (size_t*)&$exp:size));|] -allocateCUDABuffer _ _ _ space = - error $ "Cannot allocate in '" ++ space ++ "' memory space." - -deallocateCUDABuffer :: GC.Deallocate OpenCL () -deallocateCUDABuffer mem size tag "device" = - GC.stm [C.cstm|CUDA_SUCCEED_OR_RETURN(cuda_free(ctx, $exp:mem, $exp:size, $exp:tag));|] -deallocateCUDABuffer _ _ _ space = - error $ "Cannot deallocate in '" ++ space ++ "' memory space." - -copyCUDAMemory :: GC.Copy OpenCL () -copyCUDAMemory b dstmem dstidx dstSpace srcmem srcidx srcSpace nbytes = do - let (copy, prof) = memcpyFun b dstSpace srcSpace - (bef, aft) = profilingEnclosure prof - GC.item - [C.citem|{$items:bef CUDA_SUCCEED_OR_RETURN($exp:copy); $items:aft}|] - where - dst = [C.cexp|$exp:dstmem + $exp:dstidx|] - src = [C.cexp|$exp:srcmem + $exp:srcidx|] - memcpyFun GC.CopyBarrier DefaultSpace (Space "device") = - ([C.cexp|cuMemcpyDtoH($exp:dst, $exp:src, $exp:nbytes)|], copyDevToHost) - memcpyFun GC.CopyBarrier (Space "device") DefaultSpace = - ([C.cexp|cuMemcpyHtoD($exp:dst, $exp:src, $exp:nbytes)|], copyHostToDev) - memcpyFun _ (Space "device") (Space "device") = - ([C.cexp|cuMemcpy($exp:dst, $exp:src, $exp:nbytes)|], copyDevToDev) - memcpyFun GC.CopyNoBarrier DefaultSpace (Space "device") = - ([C.cexp|cuMemcpyDtoHAsync($exp:dst, $exp:src, $exp:nbytes, ctx->stream)|], copyDevToHost) - memcpyFun GC.CopyNoBarrier (Space "device") DefaultSpace = - ([C.cexp|cuMemcpyHtoDAsync($exp:dst, $exp:src, $exp:nbytes, ctx->stream)|], copyHostToDev) - memcpyFun _ _ _ = - error $ - "Cannot copy to '" - ++ show dstSpace - ++ "' from '" - ++ show srcSpace - ++ "'." - cudaMemoryType :: GC.MemoryType OpenCL () cudaMemoryType "device" = pure [C.cty|typename CUdeviceptr|] -cudaMemoryType space = - error $ "CUDA backend does not support '" ++ space ++ "' memory space." - -kernelConstToExp :: KernelConst -> C.Exp -kernelConstToExp (SizeConst key) = - [C.cexp|*ctx->tuning_params.$id:key|] -kernelConstToExp (SizeMaxConst size_class) = - [C.cexp|ctx->$id:field|] - where - field = "max_" <> cudaSizeClass size_class - cudaSizeClass SizeThreshold {} = "threshold" - cudaSizeClass SizeGroup = "block_size" - cudaSizeClass SizeNumGroups = "grid_size" - cudaSizeClass SizeTile = "tile_size" - cudaSizeClass SizeRegTile = "reg_tile_size" - cudaSizeClass SizeLocalMemory = "shared_memory" - cudaSizeClass (SizeBespoke x _) = prettyString x - -compileGroupDim :: GroupDim -> GC.CompilerM op s C.Exp -compileGroupDim (Left e) = GC.compileExp e -compileGroupDim (Right kc) = pure $ kernelConstToExp kc - -callKernel :: GC.OpCompiler OpenCL () -callKernel (GetSize v key) = do - let e = kernelConstToExp $ SizeConst key - GC.stm [C.cstm|$id:v = $exp:e;|] -callKernel (CmpSizeLe v key x) = do - let e = kernelConstToExp $ SizeConst key - x' <- GC.compileExp x - GC.stm [C.cstm|$id:v = $exp:e <= $exp:x';|] - sizeLoggingCode v key x' -callKernel (GetSizeMax v size_class) = do - let e = kernelConstToExp $ SizeMaxConst size_class - GC.stm [C.cstm|$id:v = $exp:e;|] -callKernel (LaunchKernel safety kernel_name args num_blocks block_size) = do - (arg_params, arg_params_inits, call_args, shared_vars) <- - unzip4 <$> zipWithM mkArgs [(0 :: Int) ..] args - let (shared_sizes, shared_offsets) = unzip $ catMaybes shared_vars - shared_offsets_sc = mkOffsets shared_sizes - shared_args = zip shared_offsets shared_offsets_sc - shared_bytes = last shared_offsets_sc - forM_ shared_args $ \(arg, offset) -> - GC.decl [C.cdecl|unsigned int $id:arg = $exp:offset;|] - - (grid_x, grid_y, grid_z) <- mkDims <$> mapM GC.compileExp num_blocks - (block_x, block_y, block_z) <- mkDims <$> mapM compileGroupDim block_size - - let need_perm = length num_blocks == 3 - kernel_fname <- genKernelFunction kernel_name safety need_perm arg_params arg_params_inits - - GC.stm - [C.cstm|{ - err = $id:kernel_fname(ctx, - $exp:grid_x,$exp:grid_y,$exp:grid_z, - $exp:block_x, $exp:block_y, $exp:block_z, - $exp:shared_bytes, - $args:call_args); - if (err != FUTHARK_SUCCESS) { goto cleanup; } - }|] +cudaMemoryType space = error $ "GPU backend does not support '" ++ space ++ "' memory space." - when (safety >= SafetyFull) $ - GC.stm [C.cstm|ctx->failure_is_an_option = 1;|] +-- | Compile the program to C with calls to CUDA. +compileProg :: (MonadFreshNames m) => T.Text -> Prog GPUMem -> m (ImpGen.Warnings, GC.CParts) +compileProg version prog = do + ( ws, + Program cuda_code cuda_prelude kernels types params failures prog' + ) <- + ImpGen.compileProg prog + (ws,) + <$> GC.compileProg + "cuda" + version + params + operations + (mkBoilerplate (cuda_prelude <> cuda_code) kernels types failures) + cuda_includes + (Space "device", [Space "device", DefaultSpace]) + cliOptions + prog' where - mkDims [] = ([C.cexp|0|], [C.cexp|0|], [C.cexp|0|]) - mkDims [x] = (x, [C.cexp|1|], [C.cexp|1|]) - mkDims [x, y] = (x, y, [C.cexp|1|]) - mkDims (x : y : z : _) = (x, y, z) - addExp x y = [C.cexp|$exp:x + $exp:y|] - alignExp e = [C.cexp|$exp:e + ((8 - ($exp:e % 8)) % 8)|] - mkOffsets = scanl (\a b -> a `addExp` alignExp b) [C.cexp|0|] - mkArgs i (ValueKArg e t) = do - e' <- GC.compileExp e - pure - ( [C.cparam|$ty:(primStorageType t) $id:("arg" <> show i)|], - [C.cinit|&$id:("arg" <> show i)|], - toStorage t e', - Nothing - ) - mkArgs i (MemKArg v) = do - v' <- GC.rawMem v - pure - ( [C.cparam|typename CUdeviceptr $id:("arg" <> show i)|], - [C.cinit|&$id:("arg" <> show i)|], - v', - Nothing - ) - mkArgs i (SharedMemoryKArg (Count c)) = do - num_bytes <- GC.compileExp c - size <- newVName "shared_size" - offset <- newVName "shared_offset" - GC.decl [C.cdecl|unsigned int $id:size = $exp:num_bytes;|] - pure - ( [C.cparam|unsigned int $id:("arg" <> show i)|], - [C.cinit|&$id:("arg" <> show i)|], - [C.cexp|$id:offset|], - Just (size, offset) - ) - -genKernelFunction :: - KernelName -> - KernelSafety -> - Bool -> - [C.Param] -> - [C.Initializer] -> - GC.CompilerM op s Name -genKernelFunction kernel_name safety need_perm arg_params arg_params_inits = do - let kernel_fname = "gpu_kernel_" <> kernel_name - (bef, aft) = profilingEnclosure kernel_name - perm_args - | need_perm = [[C.cinit|&perm[0]|], [C.cinit|&perm[1]|], [C.cinit|&perm[2]|]] - | otherwise = [] - failure_args = - take - (numFailureParams safety) - [ [C.cinit|&ctx->global_failure|], - [C.cinit|&ctx->failure_is_an_option|], - [C.cinit|&ctx->global_failure_args|] - ] - - GC.libDecl - [C.cedecl|static int $id:kernel_fname( - struct futhark_context* ctx, unsigned int grid_x, unsigned int grid_y, unsigned int grid_z, - unsigned int block_x, unsigned int block_y, unsigned int block_z, - unsigned int shared_bytes, $params:arg_params) { - if (grid_x * grid_y * grid_z * block_x * block_y * block_z != 0) { - int perm[3] = { 0, 1, 2 }; - - if (grid_y >= (1<<16)) { - perm[1] = perm[0]; - perm[0] = 1; - } - - if (grid_z >= (1<<16)) { - perm[2] = perm[0]; - perm[0] = 2; - } - - size_t grid[3]; - grid[perm[0]] = grid_x; - grid[perm[1]] = grid_y; - grid[perm[2]] = grid_z; - - void *all_args[] = { $inits:(perm_args ++ failure_args ++ arg_params_inits) }; - typename int64_t time_start = 0, time_end = 0; - if (ctx->debugging) { - fprintf(ctx->log, "Launching %s with grid size [%d, %d, %d] and block size [%d, %d, %d]; shared memory: %d bytes.\n", - $string:(prettyString kernel_name), - grid_x, grid_y, grid_z, - block_x, block_y, block_z, - shared_bytes); - time_start = get_wall_time(); - } - $items:bef - CUDA_SUCCEED_OR_RETURN( - cuLaunchKernel(ctx->program->$id:kernel_name, - grid[0], grid[1], grid[2], - block_x, block_y, block_z, - shared_bytes, ctx->stream, - all_args, NULL)); - $items:aft - if (ctx->debugging) { - CUDA_SUCCEED_FATAL(cuCtxSynchronize()); - time_end = get_wall_time(); - fprintf(ctx->log, "Kernel %s runtime: %ldus\n", - $string:(prettyString kernel_name), time_end - time_start); - } - } - return FUTHARK_SUCCESS; - }|] - - pure kernel_fname + operations :: GC.Operations OpenCL () + operations = + gpuOperations + { GC.opsMemoryType = cudaMemoryType, + GC.opsCritical = + ( [C.citems|CUDA_SUCCEED_FATAL(cuCtxPushCurrent(ctx->cu_ctx));|], + [C.citems|CUDA_SUCCEED_FATAL(cuCtxPopCurrent(&ctx->cu_ctx));|] + ) + } + cuda_includes = + [untrimming| + #include + #include + #include + |] diff --git a/src/Futhark/CodeGen/Backends/CCUDA/Boilerplate.hs b/src/Futhark/CodeGen/Backends/CCUDA/Boilerplate.hs deleted file mode 100644 --- a/src/Futhark/CodeGen/Backends/CCUDA/Boilerplate.hs +++ /dev/null @@ -1,132 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} - --- | Various boilerplate definitions for the CUDA backend. -module Futhark.CodeGen.Backends.CCUDA.Boilerplate - ( generateBoilerplate, - profilingEnclosure, - module Futhark.CodeGen.Backends.COpenCL.Boilerplate, - ) -where - -import Control.Monad -import Data.Map qualified as M -import Data.Text qualified as T -import Futhark.CodeGen.Backends.COpenCL.Boilerplate - ( copyDevToDev, - copyDevToHost, - copyHostToDev, - copyScalarFromDev, - copyScalarToDev, - costCentreReport, - failureMsgFunction, - kernelRuns, - kernelRuntime, - ) -import Futhark.CodeGen.Backends.GenericC qualified as GC -import Futhark.CodeGen.Backends.GenericC.Pretty -import Futhark.CodeGen.ImpCode.OpenCL -import Futhark.CodeGen.RTS.C (backendsCudaH) -import Futhark.Util (chunk) -import Language.C.Quote.OpenCL qualified as C -import Language.C.Syntax qualified as C - -errorMsgNumArgs :: ErrorMsg a -> Int -errorMsgNumArgs = length . errorMsgArgTypes - --- | Block items to put before and after a thing to be profiled. -profilingEnclosure :: Name -> ([C.BlockItem], [C.BlockItem]) -profilingEnclosure name = - ( [C.citems| - typename CUevent *pevents = NULL; - if (ctx->profiling && !ctx->profiling_paused) { - pevents = cuda_get_events(ctx, - &ctx->program->$id:(kernelRuns name), - &ctx->program->$id:(kernelRuntime name)); - CUDA_SUCCEED_FATAL(cuEventRecord(pevents[0], ctx->stream)); - } - |], - [C.citems| - if (pevents != NULL) { - CUDA_SUCCEED_FATAL(cuEventRecord(pevents[1], ctx->stream)); - } - |] - ) - -generateCUDADecls :: - [Name] -> - M.Map KernelName KernelSafety -> - GC.CompilerM op s () -generateCUDADecls cost_centres kernels = do - let forCostCentre name = do - GC.contextField - (C.toIdent (kernelRuntime name) mempty) - [C.cty|typename int64_t|] - (Just [C.cexp|0|]) - GC.contextField - (C.toIdent (kernelRuns name) mempty) - [C.cty|int|] - (Just [C.cexp|0|]) - - forM_ (M.keys kernels) $ \name -> do - GC.contextFieldDyn - (C.toIdent name mempty) - [C.cty|typename CUfunction|] - [C.cstm| - CUDA_SUCCEED_FATAL(cuModuleGetFunction( - &ctx->program->$id:name, - ctx->module, - $string:(T.unpack (idText (C.toIdent name mempty)))));|] - [C.cstm|{}|] - forCostCentre name - - mapM_ forCostCentre cost_centres - --- | Called after most code has been generated to generate the bulk of --- the boilerplate. -generateBoilerplate :: - T.Text -> - T.Text -> - [Name] -> - M.Map KernelName KernelSafety -> - [FailureMsg] -> - GC.CompilerM OpenCL () () -generateBoilerplate cuda_program cuda_prelude cost_centres kernels failures = do - let cuda_program_fragments = - -- Some C compilers limit the size of literal strings, so - -- chunk the entire program into small bits here, and - -- concatenate it again at runtime. - [[C.cinit|$string:s|] | s <- chunk 2000 $ T.unpack $ cuda_prelude <> cuda_program] - program_fragments = cuda_program_fragments ++ [[C.cinit|NULL|]] - let max_failure_args = foldl max 0 $ map (errorMsgNumArgs . failureError) failures - mapM_ - GC.earlyDecl - [C.cunit|static const int max_failure_args = $int:max_failure_args; - static const char *cuda_program[] = {$inits:program_fragments, NULL}; - $esc:(T.unpack backendsCudaH) - |] - GC.earlyDecl $ failureMsgFunction failures - - generateCUDADecls cost_centres kernels - - GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_add_nvrtc_option(struct futhark_context_config *cfg, const char* opt);|] - GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_set_device(struct futhark_context_config *cfg, const char* s);|] - GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_dump_program_to(struct futhark_context_config *cfg, const char* s);|] - GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_load_program_from(struct futhark_context_config *cfg, const char* s);|] - GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_dump_ptx_to(struct futhark_context_config *cfg, const char* s);|] - GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_load_ptx_from(struct futhark_context_config *cfg, const char* s);|] - GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_set_default_group_size(struct futhark_context_config *cfg, int size);|] - GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_set_default_num_groups(struct futhark_context_config *cfg, int size);|] - GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_set_default_tile_size(struct futhark_context_config *cfg, int size);|] - GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_set_default_reg_tile_size(struct futhark_context_config *cfg, int size);|] - GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_set_default_threshold(struct futhark_context_config *cfg, int size);|] - - GC.generateProgramStruct - - GC.onClear - [C.citem|if (ctx->error == NULL) { - CUDA_SUCCEED_NONFATAL(cuda_free_all(ctx)); - }|] - - GC.profileReport [C.citem|CUDA_SUCCEED_FATAL(cuda_tally_profiling_records(ctx));|] - mapM_ GC.profileReport $ costCentreReport $ cost_centres ++ M.keys kernels -{-# NOINLINE generateBoilerplate #-} diff --git a/src/Futhark/CodeGen/Backends/COpenCL.hs b/src/Futhark/CodeGen/Backends/COpenCL.hs --- a/src/Futhark/CodeGen/Backends/COpenCL.hs +++ b/src/Futhark/CodeGen/Backends/COpenCL.hs @@ -10,14 +10,16 @@ ) where -import Control.Monad hiding (mapM) +import Control.Monad.State +import Data.Map qualified as M import Data.Text qualified as T -import Futhark.CodeGen.Backends.COpenCL.Boilerplate +import Futhark.CodeGen.Backends.GPU import Futhark.CodeGen.Backends.GenericC qualified as GC import Futhark.CodeGen.Backends.GenericC.Options -import Futhark.CodeGen.Backends.SimpleRep (primStorageType, toStorage) import Futhark.CodeGen.ImpCode.OpenCL import Futhark.CodeGen.ImpGen.OpenCL qualified as ImpGen +import Futhark.CodeGen.OpenCL.Heuristics +import Futhark.CodeGen.RTS.C (backendsOpenclH) import Futhark.IR.GPUMem hiding ( CmpSizeLe, GetSize, @@ -28,73 +30,90 @@ import Language.C.Syntax qualified as C import NeatInterpolation (untrimming) --- | Compile the program to C with calls to OpenCL. -compileProg :: MonadFreshNames m => T.Text -> Prog GPUMem -> m (ImpGen.Warnings, GC.CParts) -compileProg version prog = do - ( ws, - Program - opencl_code - opencl_prelude - kernels - types - params - failures - prog' - ) <- - ImpGen.compileProg prog - let cost_centres = - [ copyDevToDev, - copyDevToHost, - copyHostToDev, - copyScalarToDev, - copyScalarFromDev - ] - (ws,) - <$> GC.compileProg - "opencl" - version - params - operations - ( generateBoilerplate - opencl_code - opencl_prelude - cost_centres - kernels - types - failures - ) - include_opencl_h - (Space "device", [Space "device", DefaultSpace]) - cliOptions - prog' +sizeHeuristicsCode :: SizeHeuristic -> C.Stm +sizeHeuristicsCode (SizeHeuristic platform_name device_type which (TPrimExp what)) = + [C.cstm| + if ($exp:which' == 0 && + strstr(option->platform_name, $string:platform_name) != NULL && + (option->device_type & $exp:(clDeviceType device_type)) == $exp:(clDeviceType device_type)) { + $items:get_size + }|] where - operations :: GC.Operations OpenCL () - operations = - GC.defaultOperations - { GC.opsCompiler = callKernel, - GC.opsWriteScalar = writeOpenCLScalar, - GC.opsReadScalar = readOpenCLScalar, - GC.opsAllocate = allocateOpenCLBuffer, - GC.opsDeallocate = deallocateOpenCLBuffer, - GC.opsCopy = copyOpenCLMemory, - GC.opsMemoryType = openclMemoryType, - GC.opsFatMemory = True - } - include_opencl_h = - [untrimming| - #define CL_TARGET_OPENCL_VERSION 120 - #define CL_USE_DEPRECATED_OPENCL_1_2_APIS - #ifdef __APPLE__ - #define CL_SILENCE_DEPRECATION - #include - #else - #include - #endif - |] + clDeviceType DeviceGPU = [C.cexp|CL_DEVICE_TYPE_GPU|] + clDeviceType DeviceCPU = [C.cexp|CL_DEVICE_TYPE_CPU|] + which' = case which of + LockstepWidth -> [C.cexp|ctx->lockstep_width|] + NumGroups -> [C.cexp|ctx->cfg->default_num_groups|] + GroupSize -> [C.cexp|ctx->cfg->default_group_size|] + TileSize -> [C.cexp|ctx->cfg->default_tile_size|] + RegTileSize -> [C.cexp|ctx->cfg->default_reg_tile_size|] + Threshold -> [C.cexp|ctx->cfg->default_threshold|] + + get_size = + let (e, m) = runState (GC.compilePrimExp onLeaf what) mempty + in concat (M.elems m) ++ [[C.citem|$exp:which' = $exp:e;|]] + + onLeaf (DeviceInfo s) = do + let s' = "CL_DEVICE_" ++ s + v = s ++ "_val" + m <- get + case M.lookup s m of + Nothing -> + -- XXX: Cheating with the type here; works for the infos we + -- currently use because we zero-initialise and assume a + -- little-endian platform, but should be made more + -- size-aware in the future. + modify $ + M.insert + s' + [C.citems|size_t $id:v = 0; + clGetDeviceInfo(ctx->device, $id:s', + sizeof($id:v), &$id:v, + NULL);|] + Just _ -> pure () + + pure [C.cexp|$id:v|] + +mkBoilerplate :: + T.Text -> + M.Map Name KernelSafety -> + [PrimType] -> + [FailureMsg] -> + GC.CompilerM OpenCL () () +mkBoilerplate opencl_program kernels types failures = do + generateGPUBoilerplate + opencl_program + backendsOpenclH + (M.keys kernels) + types + failures + + GC.earlyDecl + [C.cedecl|void post_opencl_setup(struct futhark_context *ctx, struct opencl_device_option *option) { + $stms:(map sizeHeuristicsCode sizeHeuristicsTable) + }|] + + GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_add_build_option(struct futhark_context_config *cfg, const char* opt);|] + GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_set_device(struct futhark_context_config *cfg, const char* s);|] + GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_set_platform(struct futhark_context_config *cfg, const char* s);|] + GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_select_device_interactively(struct futhark_context_config *cfg);|] + GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_list_devices(struct futhark_context_config *cfg);|] + GC.headerDecl GC.InitDecl [C.cedecl|const char* futhark_context_config_get_program(struct futhark_context_config *cfg);|] + GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_set_program(struct futhark_context_config *cfg, const char* s);|] + GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_dump_binary_to(struct futhark_context_config *cfg, const char* s);|] + GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_load_binary_from(struct futhark_context_config *cfg, const char* s);|] + GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_set_default_group_size(struct futhark_context_config *cfg, int size);|] + GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_set_default_num_groups(struct futhark_context_config *cfg, int size);|] + GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_set_default_tile_size(struct futhark_context_config *cfg, int size);|] + GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_set_default_reg_tile_size(struct futhark_context_config *cfg, int size);|] + GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_set_default_threshold(struct futhark_context_config *cfg, int size);|] + GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_set_command_queue(struct futhark_context_config *cfg, typename cl_command_queue);|] + GC.headerDecl GC.MiscDecl [C.cedecl|typename cl_command_queue futhark_context_get_command_queue(struct futhark_context* ctx);|] + cliOptions :: [Option] cliOptions = - commonOptions + gpuOptions ++ [ Option { optionLongName = "platform", optionShortName = Just 'p', @@ -108,15 +127,23 @@ optionArgument = RequiredArgument "FILE", optionDescription = "Dump the embedded OpenCL program to the indicated file.", optionAction = - [C.cstm|{futhark_context_config_dump_program_to(cfg, optarg); - entry_point = NULL;}|] + [C.cstm|{const char* prog = futhark_context_config_get_program(cfg); + if (dump_file(optarg, prog, strlen(prog)) != 0) { + fprintf(stderr, "%s: %s\n", optarg, strerror(errno)); + exit(1); + } + exit(0);}|] }, Option { optionLongName = "load-opencl", optionShortName = Nothing, optionArgument = RequiredArgument "FILE", optionDescription = "Instead of using the embedded OpenCL program, load it from the indicated file.", - optionAction = [C.cstm|futhark_context_config_load_program_from(cfg, optarg);|] + optionAction = + [C.cstm|{ size_t n; const char *s = slurp_file(optarg, &n); + if (s == NULL) { fprintf(stderr, "%s: %s\n", optarg, strerror(errno)); exit(1); } + futhark_context_config_set_program(cfg, s); + }|] }, Option { optionLongName = "dump-opencl-binary", @@ -159,267 +186,42 @@ } ] --- We detect the special case of writing a constant and turn it into a --- non-blocking write. This may be slightly faster, as it prevents --- unnecessary synchronisation of the OpenCL command queue, and --- writing a constant is fairly common. This is only possible because --- we can give the constant infinite lifetime (with 'static'), which --- is not the case for ordinary variables. -writeOpenCLScalar :: GC.WriteScalar OpenCL () -writeOpenCLScalar mem i t "device" _ val = do - val' <- newVName "write_tmp" - let (decl, blocking) = - case val of - C.Const {} -> ([C.citem|static $ty:t $id:val' = $exp:val;|], [C.cexp|CL_FALSE|]) - _ -> ([C.citem|$ty:t $id:val' = $exp:val;|], [C.cexp|CL_TRUE|]) - GC.stm - [C.cstm|{$item:decl - OPENCL_SUCCEED_OR_RETURN( - clEnqueueWriteBuffer(ctx->queue, $exp:mem, $exp:blocking, - $exp:i * sizeof($ty:t), sizeof($ty:t), - &$id:val', - 0, NULL, $exp:(profilingEvent copyScalarToDev))); - }|] -writeOpenCLScalar _ _ _ space _ _ = - error $ "Cannot write to '" ++ space ++ "' memory space." - --- It is often faster to do a blocking clEnqueueReadBuffer() than to --- do an async clEnqueueReadBuffer() followed by a clFinish(), even --- with an in-order command queue. This is safe if and only if there --- are no possible outstanding failures. -readOpenCLScalar :: GC.ReadScalar OpenCL () -readOpenCLScalar mem i t "device" _ = do - val <- newVName "read_res" - GC.decl [C.cdecl|$ty:t $id:val;|] - GC.stm - [C.cstm|OPENCL_SUCCEED_OR_RETURN( - clEnqueueReadBuffer(ctx->queue, $exp:mem, - ctx->failure_is_an_option ? CL_FALSE : CL_TRUE, - $exp:i * sizeof($ty:t), sizeof($ty:t), - &$id:val, - 0, NULL, $exp:(profilingEvent copyScalarFromDev))); - |] - GC.stm - [C.cstm|if (ctx->failure_is_an_option && futhark_context_sync(ctx) != 0) - { return 1; }|] - pure [C.cexp|$id:val|] -readOpenCLScalar _ _ _ space _ = - error $ "Cannot read from '" ++ space ++ "' memory space." - -allocateOpenCLBuffer :: GC.Allocate OpenCL () -allocateOpenCLBuffer mem size tag "device" = - GC.stm - [C.cstm|ctx->error = - OPENCL_SUCCEED_NONFATAL(opencl_alloc(ctx, ctx->log, - (size_t)$exp:size, $exp:tag, - &$exp:mem, (size_t*)&$exp:size));|] -allocateOpenCLBuffer _ _ _ space = - error $ "Cannot allocate in '" ++ space ++ "' memory space." - -deallocateOpenCLBuffer :: GC.Deallocate OpenCL () -deallocateOpenCLBuffer mem size tag "device" = - GC.stm [C.cstm|OPENCL_SUCCEED_OR_RETURN(opencl_free(ctx, $exp:mem, $exp:size, $exp:tag));|] -deallocateOpenCLBuffer _ _ _ space = - error $ "Cannot deallocate in '" ++ space ++ "' space" - -syncArg :: GC.CopyBarrier -> C.Exp -syncArg GC.CopyBarrier = [C.cexp|CL_TRUE|] -syncArg GC.CopyNoBarrier = [C.cexp|CL_FALSE|] - -copyOpenCLMemory :: GC.Copy OpenCL () --- The read/write/copy-buffer functions fail if the given offset is --- out of bounds, even if asked to read zero bytes. We protect with a --- branch to avoid this. -copyOpenCLMemory b destmem destidx DefaultSpace srcmem srcidx (Space "device") nbytes = - GC.stm - [C.cstm| - if ($exp:nbytes > 0) { - typename cl_bool sync_call = $exp:(syncArg b); - OPENCL_SUCCEED_OR_RETURN( - clEnqueueReadBuffer(ctx->queue, $exp:srcmem, - ctx->failure_is_an_option ? CL_FALSE : sync_call, - (size_t)$exp:srcidx, (size_t)$exp:nbytes, - $exp:destmem + $exp:destidx, - 0, NULL, $exp:(profilingEvent copyHostToDev))); - if (sync_call && - ctx->failure_is_an_option && - futhark_context_sync(ctx) != 0) { return 1; } - } - |] -copyOpenCLMemory b destmem destidx (Space "device") srcmem srcidx DefaultSpace nbytes = - GC.stm - [C.cstm| - if ($exp:nbytes > 0) { - OPENCL_SUCCEED_OR_RETURN( - clEnqueueWriteBuffer(ctx->queue, $exp:destmem, $exp:(syncArg b), - (size_t)$exp:destidx, (size_t)$exp:nbytes, - $exp:srcmem + $exp:srcidx, - 0, NULL, $exp:(profilingEvent copyDevToHost))); - } - |] -copyOpenCLMemory _ destmem destidx (Space "device") srcmem srcidx (Space "device") nbytes = - -- Be aware that OpenCL swaps the usual order of operands for - -- memcpy()-like functions. The order below is not a typo. - GC.stm - [C.cstm|{ - if ($exp:nbytes > 0) { - OPENCL_SUCCEED_OR_RETURN( - clEnqueueCopyBuffer(ctx->queue, - $exp:srcmem, $exp:destmem, - (size_t)$exp:srcidx, (size_t)$exp:destidx, - (size_t)$exp:nbytes, - 0, NULL, $exp:(profilingEvent copyDevToDev))); - if (ctx->debugging) { - OPENCL_SUCCEED_FATAL(clFinish(ctx->queue)); - } - } - }|] -copyOpenCLMemory _ destmem destidx DefaultSpace srcmem srcidx DefaultSpace nbytes = - GC.copyMemoryDefaultSpace destmem destidx srcmem srcidx nbytes -copyOpenCLMemory _ _ _ destspace _ _ srcspace _ = - error $ "Cannot copy to " ++ show destspace ++ " from " ++ show srcspace - openclMemoryType :: GC.MemoryType OpenCL () openclMemoryType "device" = pure [C.cty|typename cl_mem|] -openclMemoryType space = - error $ "OpenCL backend does not support '" ++ space ++ "' memory space." - -kernelConstToExp :: KernelConst -> C.Exp -kernelConstToExp (SizeConst key) = - [C.cexp|*ctx->tuning_params.$id:key|] -kernelConstToExp (SizeMaxConst size_class) = - [C.cexp|ctx->$id:field|] - where - field = "max_" <> prettyString size_class - -compileGroupDim :: GroupDim -> GC.CompilerM op s C.Exp -compileGroupDim (Left e) = GC.compileExp e -compileGroupDim (Right kc) = pure $ kernelConstToExp kc - -callKernel :: GC.OpCompiler OpenCL () -callKernel (GetSize v key) = do - let e = kernelConstToExp $ SizeConst key - GC.stm [C.cstm|$id:v = $exp:e;|] -callKernel (CmpSizeLe v key x) = do - let e = kernelConstToExp $ SizeConst key - x' <- GC.compileExp x - GC.stm [C.cstm|$id:v = $exp:e <= $exp:x';|] - sizeLoggingCode v key x' -callKernel (GetSizeMax v size_class) = do - let e = kernelConstToExp $ SizeMaxConst size_class - GC.stm [C.cstm|$id:v = $exp:e;|] -callKernel (LaunchKernel safety name args num_workgroups workgroup_size) = do - -- The other failure args are set automatically when the kernel is - -- first created. - when (safety == SafetyFull) $ - GC.stm - [C.cstm| - OPENCL_SUCCEED_OR_RETURN(clSetKernelArg(ctx->program->$id:name, 1, - sizeof(ctx->failure_is_an_option), - &ctx->failure_is_an_option)); - |] - - (arg_params, arg_set, call_args) <- - unzip3 <$> zipWithM onArg [(0 :: Int) ..] args - - num_workgroups' <- mapM GC.compileExp num_workgroups - workgroup_size' <- mapM compileGroupDim workgroup_size - local_bytes <- foldM localBytes [C.cexp|0|] args - - kernel_fname <- genKernelFunction name safety arg_params arg_set - - let grid_x : grid_y : grid_z : _ = num_workgroups' ++ repeat [C.cexp|1|] - group_x : group_y : group_z : _ = workgroup_size' ++ repeat [C.cexp|1|] - - GC.stm - [C.cstm|{ - err = $id:kernel_fname(ctx, - $exp:grid_x,$exp:grid_y,$exp:grid_z, - $exp:group_x, $exp:group_y, $exp:group_z, - $exp:local_bytes, - $args:call_args); - if (err != FUTHARK_SUCCESS) { goto cleanup; } - }|] - - when (safety >= SafetyFull) $ - GC.stm [C.cstm|ctx->failure_is_an_option = 1;|] - where - localBytes cur (SharedMemoryKArg num_bytes) = do - num_bytes' <- GC.compileExp $ unCount num_bytes - pure [C.cexp|$exp:cur + $exp:num_bytes'|] - localBytes cur _ = pure cur - - onArg i (ValueKArg e t) = do - let arg = "arg" <> show i - e' <- GC.compileExp e - pure - ( [C.cparam|$ty:(primStorageType t) $id:arg|], - ([C.cexp|sizeof($id:arg)|], [C.cexp|&$id:arg|]), - toStorage t e' - ) - onArg i (MemKArg v) = do - let arg = "arg" <> show i - v' <- GC.rawMem v - pure - ( [C.cparam|typename cl_mem $id:arg|], - ([C.cexp|sizeof($id:arg)|], [C.cexp|&$id:arg|]), - v' - ) - onArg i (SharedMemoryKArg (Count c)) = do - let arg = "arg" <> show i - num_bytes <- GC.compileExp c - pure - ( [C.cparam|unsigned int $id:arg|], - ([C.cexp|$id:arg|], [C.cexp|NULL|]), - num_bytes - ) - -genKernelFunction :: - KernelName -> - KernelSafety -> - [C.Param] -> - [(C.Exp, C.Exp)] -> - GC.CompilerM op s Name -genKernelFunction kernel_name safety arg_params arg_set = do - let kernel_fname = "gpu_kernel_" <> kernel_name - GC.libDecl - [C.cedecl|static int $id:kernel_fname( - struct futhark_context* ctx, - unsigned int grid_x, unsigned int grid_y, unsigned int grid_z, - unsigned int block_x, unsigned int block_y, unsigned int block_z, - unsigned int local_bytes, $params:arg_params) { - (void)local_bytes; - if (grid_x * grid_y * grid_z * block_x * block_y * block_z != 0) { - const size_t global_work_size[3] = {grid_x*block_x, grid_y*block_y, grid_z*block_z}; - const size_t local_work_size[3] = {block_x, block_y, block_z}; - typename int64_t time_start = 0, time_end = 0; - $stms:set_args - if (ctx->debugging) { - fprintf(ctx->log, "Launching %s with grid size [%d, %d, %d] and group size [%d, %d, %d]; local memory: %d bytes.\n", - $string:(prettyString kernel_name), - grid_x, grid_y, grid_z, - block_x, block_y, block_z, - local_bytes); - time_start = get_wall_time(); - } - typename cl_event *pevent = $exp:(profilingEvent kernel_name); - OPENCL_SUCCEED_OR_RETURN( - clEnqueueNDRangeKernel(ctx->queue, ctx->program->$id:kernel_name, 3, NULL, - global_work_size, local_work_size, - 0, NULL, pevent)); - if (ctx->debugging) { - OPENCL_SUCCEED_FATAL(clFinish(ctx->queue)); - time_end = get_wall_time(); - long int time_diff = time_end - time_start; - fprintf(ctx->log, "kernel %s runtime: %ldus\n", - $string:(prettyString kernel_name), time_diff); - } - } - return FUTHARK_SUCCESS; - }|] +openclMemoryType space = error $ "GPU backend does not support '" ++ space ++ "' memory space." - pure kernel_fname +-- | Compile the program to C with calls to OpenCL. +compileProg :: (MonadFreshNames m) => T.Text -> Prog GPUMem -> m (ImpGen.Warnings, GC.CParts) +compileProg version prog = do + ( ws, + Program opencl_code opencl_prelude kernels types params failures prog' + ) <- + ImpGen.compileProg prog + (ws,) + <$> GC.compileProg + "opencl" + version + params + operations + (mkBoilerplate (opencl_prelude <> opencl_code) kernels types failures) + opencl_includes + (Space "device", [Space "device", DefaultSpace]) + cliOptions + prog' where - set_args = zipWith setKernelArg [numFailureParams safety ..] arg_set - setKernelArg i (size, e) = - [C.cstm|OPENCL_SUCCEED_OR_RETURN(clSetKernelArg(ctx->program->$id:kernel_name, $int:i, $exp:size, $exp:e));|] + operations :: GC.Operations OpenCL () + operations = + gpuOperations + { GC.opsMemoryType = openclMemoryType + } + opencl_includes = + [untrimming| + #define CL_TARGET_OPENCL_VERSION 120 + #define CL_USE_DEPRECATED_OPENCL_1_2_APIS + #ifdef __APPLE__ + #define CL_SILENCE_DEPRECATION + #include + #else + #include + #endif + |] diff --git a/src/Futhark/CodeGen/Backends/COpenCL/Boilerplate.hs b/src/Futhark/CodeGen/Backends/COpenCL/Boilerplate.hs deleted file mode 100644 --- a/src/Futhark/CodeGen/Backends/COpenCL/Boilerplate.hs +++ /dev/null @@ -1,320 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} - -module Futhark.CodeGen.Backends.COpenCL.Boilerplate - ( generateBoilerplate, - profilingEvent, - copyDevToDev, - copyDevToHost, - copyHostToDev, - copyScalarToDev, - copyScalarFromDev, - commonOptions, - failureMsgFunction, - costCentreReport, - kernelRuntime, - kernelRuns, - sizeLoggingCode, - ) -where - -import Control.Monad -import Control.Monad.State -import Data.Map qualified as M -import Data.Text qualified as T -import Futhark.CodeGen.Backends.GenericC qualified as GC -import Futhark.CodeGen.Backends.GenericC.Options -import Futhark.CodeGen.Backends.GenericC.Pretty -import Futhark.CodeGen.ImpCode.OpenCL -import Futhark.CodeGen.OpenCL.Heuristics -import Futhark.CodeGen.RTS.C (backendsOpenclH) -import Futhark.Util (chunk) -import Futhark.Util.Pretty (prettyTextOneLine) -import Language.C.Quote.OpenCL qualified as C -import Language.C.Syntax qualified as C - -errorMsgNumArgs :: ErrorMsg a -> Int -errorMsgNumArgs = length . errorMsgArgTypes - -failureMsgFunction :: [FailureMsg] -> C.Definition -failureMsgFunction failures = - let printfEscape = - let escapeChar '%' = "%%" - escapeChar c = [c] - in concatMap escapeChar - onPart (ErrorString s) = printfEscape $ T.unpack s - -- FIXME: bogus for non-ints. - onPart ErrorVal {} = "%lld" - onFailure i (FailureMsg emsg@(ErrorMsg parts) backtrace) = - let msg = concatMap onPart parts ++ "\n" ++ printfEscape backtrace - msgargs = [[C.cexp|args[$int:j]|] | j <- [0 .. errorMsgNumArgs emsg - 1]] - in [C.cstm|case $int:i: {return msgprintf($string:msg, $args:msgargs); break;}|] - failure_cases = - zipWith onFailure [(0 :: Int) ..] failures - in [C.cedecl|static char* get_failure_msg(int failure_idx, typename int64_t args[]) { - switch (failure_idx) { $stms:failure_cases } - return strdup("Unknown error. This is a compiler bug."); - }|] - -copyDevToDev, copyDevToHost, copyHostToDev, copyScalarToDev, copyScalarFromDev :: Name -copyDevToDev = "copy_dev_to_dev" -copyDevToHost = "copy_dev_to_host" -copyHostToDev = "copy_host_to_dev" -copyScalarToDev = "copy_scalar_to_dev" -copyScalarFromDev = "copy_scalar_from_dev" - -profilingEvent :: Name -> C.Exp -profilingEvent name = - [C.cexp|(ctx->profiling_paused || !ctx->profiling) ? NULL - : opencl_get_event(ctx, - &ctx->program->$id:(kernelRuns name), - &ctx->program->$id:(kernelRuntime name))|] - -releaseKernel :: (KernelName, KernelSafety) -> C.Stm -releaseKernel (name, _) = [C.cstm|OPENCL_SUCCEED_FATAL(clReleaseKernel(ctx->program->$id:name));|] - -loadKernel :: (KernelName, KernelSafety) -> C.Stm -loadKernel (name, safety) = - [C.cstm|{ - ctx->program->$id:name = clCreateKernel(ctx->clprogram, $string:(T.unpack (idText (C.toIdent name mempty))), &error); - OPENCL_SUCCEED_FATAL(error); - $items:set_args - if (ctx->debugging) { - fprintf(ctx->log, "Created kernel %s.\n", $string:(prettyString name)); - } - }|] - where - set_global_failure = - [C.citem|OPENCL_SUCCEED_FATAL( - clSetKernelArg(ctx->program->$id:name, 0, sizeof(typename cl_mem), - &ctx->global_failure));|] - set_global_failure_args = - [C.citem|OPENCL_SUCCEED_FATAL( - clSetKernelArg(ctx->program->$id:name, 2, sizeof(typename cl_mem), - &ctx->global_failure_args));|] - set_args = case safety of - SafetyNone -> [] - SafetyCheap -> [set_global_failure] - SafetyFull -> [set_global_failure, set_global_failure_args] - -generateOpenCLDecls :: - [Name] -> - M.Map KernelName KernelSafety -> - GC.CompilerM op s () -generateOpenCLDecls cost_centres kernels = do - forM_ (M.toList kernels) $ \(name, safety) -> - GC.contextFieldDyn - (C.toIdent name mempty) - [C.cty|typename cl_kernel|] - (loadKernel (name, safety)) - (releaseKernel (name, safety)) - forM_ (cost_centres <> M.keys kernels) $ \name -> do - GC.contextField - (C.toIdent (kernelRuntime name) mempty) - [C.cty|typename int64_t|] - (Just [C.cexp|0|]) - GC.contextField - (C.toIdent (kernelRuns name) mempty) - [C.cty|int|] - (Just [C.cexp|0|]) - GC.earlyDecl - [C.cedecl| -void post_opencl_setup(struct futhark_context *ctx, struct opencl_device_option *option) { - $stms:(map sizeHeuristicsCode sizeHeuristicsTable) -}|] - --- | Called after most code has been generated to generate the bulk of --- the boilerplate. -generateBoilerplate :: - T.Text -> - T.Text -> - [Name] -> - M.Map KernelName KernelSafety -> - [PrimType] -> - [FailureMsg] -> - GC.CompilerM OpenCL () () -generateBoilerplate opencl_program opencl_prelude cost_centres kernels types failures = do - let opencl_program_fragments = - -- Some C compilers limit the size of literal strings, so - -- chunk the entire program into small bits here, and - -- concatenate it again at runtime. - [[C.cinit|$string:s|] | s <- chunk 2000 $ T.unpack $ opencl_prelude <> opencl_program] - program_fragments = opencl_program_fragments ++ [[C.cinit|NULL|]] - f64_required - | FloatType Float64 `elem` types = [C.cexp|1|] - | otherwise = [C.cexp|0|] - max_failure_args = foldl max 0 $ map (errorMsgNumArgs . failureError) failures - mapM_ - GC.earlyDecl - [C.cunit|static const int max_failure_args = $int:max_failure_args; - static const int f64_required = $exp:f64_required; - static const char *opencl_program[] = {$inits:program_fragments}; - $esc:(T.unpack backendsOpenclH) - |] - GC.earlyDecl $ failureMsgFunction failures - - generateOpenCLDecls cost_centres kernels - - GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_add_build_option(struct futhark_context_config *cfg, const char* opt);|] - GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_set_device(struct futhark_context_config *cfg, const char* s);|] - GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_set_platform(struct futhark_context_config *cfg, const char* s);|] - GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_select_device_interactively(struct futhark_context_config *cfg);|] - GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_list_devices(struct futhark_context_config *cfg);|] - GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_dump_program_to(struct futhark_context_config *cfg, const char* s);|] - GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_load_program_from(struct futhark_context_config *cfg, const char* s);|] - GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_dump_binary_to(struct futhark_context_config *cfg, const char* s);|] - GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_load_binary_from(struct futhark_context_config *cfg, const char* s);|] - GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_set_default_group_size(struct futhark_context_config *cfg, int size);|] - GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_set_default_num_groups(struct futhark_context_config *cfg, int size);|] - GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_set_default_tile_size(struct futhark_context_config *cfg, int size);|] - GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_set_default_reg_tile_size(struct futhark_context_config *cfg, int size);|] - GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_set_default_threshold(struct futhark_context_config *cfg, int size);|] - GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_set_command_queue(struct futhark_context_config *cfg, typename cl_command_queue);|] - GC.headerDecl GC.MiscDecl [C.cedecl|typename cl_command_queue futhark_context_get_command_queue(struct futhark_context* ctx);|] - - GC.generateProgramStruct - - GC.onClear - [C.citem|if (ctx->error == NULL) { ctx->error = OPENCL_SUCCEED_NONFATAL(opencl_free_all(ctx)); }|] - - GC.profileReport [C.citem|OPENCL_SUCCEED_FATAL(opencl_tally_profiling_records(ctx));|] - mapM_ GC.profileReport $ costCentreReport $ cost_centres ++ M.keys kernels - -kernelRuntime :: KernelName -> Name -kernelRuntime = (<> "_total_runtime") - -kernelRuns :: KernelName -> Name -kernelRuns = (<> "_runs") - -costCentreReport :: [Name] -> [C.BlockItem] -costCentreReport names = report_kernels ++ [report_total] - where - longest_name = foldl max 0 $ map (length . prettyString) names - report_kernels = concatMap reportKernel names - format_string name = - let padding = replicate (longest_name - length name) ' ' - in unwords - [ name ++ padding, - "ran %5d times; avg: %8ldus; total: %8ldus\n" - ] - reportKernel name = - let runs = kernelRuns name - total_runtime = kernelRuntime name - in [ [C.citem| - str_builder(&builder, - $string:(format_string (prettyString name)), - ctx->program->$id:runs, - (long int) ctx->program->$id:total_runtime / (ctx->program->$id:runs != 0 ? ctx->program->$id:runs : 1), - (long int) ctx->program->$id:total_runtime); - |], - [C.citem|ctx->total_runtime += ctx->program->$id:total_runtime;|], - [C.citem|ctx->total_runs += ctx->program->$id:runs;|] - ] - - report_total = - [C.citem|str_builder(&builder, "%d operations with cumulative runtime: %6ldus\n", - ctx->total_runs, ctx->total_runtime);|] - -sizeHeuristicsCode :: SizeHeuristic -> C.Stm -sizeHeuristicsCode (SizeHeuristic platform_name device_type which (TPrimExp what)) = - [C.cstm| - if ($exp:which' == 0 && - strstr(option->platform_name, $string:platform_name) != NULL && - (option->device_type & $exp:(clDeviceType device_type)) == $exp:(clDeviceType device_type)) { - $items:get_size - }|] - where - clDeviceType DeviceGPU = [C.cexp|CL_DEVICE_TYPE_GPU|] - clDeviceType DeviceCPU = [C.cexp|CL_DEVICE_TYPE_CPU|] - - which' = case which of - LockstepWidth -> [C.cexp|ctx->lockstep_width|] - NumGroups -> [C.cexp|ctx->cfg->default_num_groups|] - GroupSize -> [C.cexp|ctx->cfg->default_group_size|] - TileSize -> [C.cexp|ctx->cfg->default_tile_size|] - RegTileSize -> [C.cexp|ctx->cfg->default_reg_tile_size|] - Threshold -> [C.cexp|ctx->cfg->default_threshold|] - - get_size = - let (e, m) = runState (GC.compilePrimExp onLeaf what) mempty - in concat (M.elems m) ++ [[C.citem|$exp:which' = $exp:e;|]] - - onLeaf (DeviceInfo s) = do - let s' = "CL_DEVICE_" ++ s - v = s ++ "_val" - m <- get - case M.lookup s m of - Nothing -> - -- XXX: Cheating with the type here; works for the infos we - -- currently use because we zero-initialise and assume a - -- little-endian platform, but should be made more - -- size-aware in the future. - modify $ - M.insert - s' - [C.citems|size_t $id:v = 0; - clGetDeviceInfo(ctx->device, $id:s', - sizeof($id:v), &$id:v, - NULL);|] - Just _ -> pure () - - pure [C.cexp|$id:v|] - --- Output size information if logging is enabled. --- --- The autotuner depends on the format of this output, so use caution if --- changing it. -sizeLoggingCode :: VName -> Name -> C.Exp -> GC.CompilerM op () () -sizeLoggingCode v key x' = do - GC.stm - [C.cstm|if (ctx->logging) { - fprintf(ctx->log, "Compared %s <= %ld: %s.\n", $string:(T.unpack (prettyTextOneLine key)), (long)$exp:x', $id:v ? "true" : "false"); - }|] - --- Options that are common to multiple GPU-like backends. -commonOptions :: [Option] -commonOptions = - [ Option - { optionLongName = "device", - optionShortName = Just 'd', - optionArgument = RequiredArgument "NAME", - optionDescription = "Use the first OpenCL device whose name contains the given string.", - optionAction = [C.cstm|futhark_context_config_set_device(cfg, optarg);|] - }, - Option - { optionLongName = "default-group-size", - optionShortName = Nothing, - optionArgument = RequiredArgument "INT", - optionDescription = "The default size of OpenCL workgroups that are launched.", - optionAction = [C.cstm|futhark_context_config_set_default_group_size(cfg, atoi(optarg));|] - }, - Option - { optionLongName = "default-num-groups", - optionShortName = Nothing, - optionArgument = RequiredArgument "INT", - optionDescription = "The default number of OpenCL workgroups that are launched.", - optionAction = [C.cstm|futhark_context_config_set_default_num_groups(cfg, atoi(optarg));|] - }, - Option - { optionLongName = "default-tile-size", - optionShortName = Nothing, - optionArgument = RequiredArgument "INT", - optionDescription = "The default tile size used when performing two-dimensional tiling.", - optionAction = [C.cstm|futhark_context_config_set_default_tile_size(cfg, atoi(optarg));|] - }, - Option - { optionLongName = "default-reg-tile-size", - optionShortName = Nothing, - optionArgument = RequiredArgument "INT", - optionDescription = "The default register tile size used when performing two-dimensional tiling.", - optionAction = [C.cstm|futhark_context_config_set_default_reg_tile_size(cfg, atoi(optarg));|] - }, - Option - { optionLongName = "default-threshold", - optionShortName = Nothing, - optionArgument = RequiredArgument "INT", - optionDescription = "The default parallelism threshold.", - optionAction = [C.cstm|futhark_context_config_set_default_threshold(cfg, atoi(optarg));|] - } - ] - -{-# NOINLINE generateBoilerplate #-} diff --git a/src/Futhark/CodeGen/Backends/GPU.hs b/src/Futhark/CodeGen/Backends/GPU.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/CodeGen/Backends/GPU.hs @@ -0,0 +1,440 @@ +{-# LANGUAGE QuasiQuotes #-} + +-- | C code generation for GPU, in general. +-- +-- This module generates codes that targets the tiny GPU API +-- abstraction layer we define in the runtime system. +module Futhark.CodeGen.Backends.GPU + ( gpuOperations, + gpuOptions, + generateGPUBoilerplate, + ) +where + +import Control.Monad +import Data.Bifunctor (bimap) +import Data.Map qualified as M +import Data.Text qualified as T +import Futhark.CodeGen.Backends.GenericC qualified as GC +import Futhark.CodeGen.Backends.GenericC.Options +import Futhark.CodeGen.Backends.GenericC.Pretty (idText) +import Futhark.CodeGen.Backends.SimpleRep (primStorageType, toStorage) +import Futhark.CodeGen.ImpCode.OpenCL +import Futhark.CodeGen.RTS.C (gpuH, gpuPrototypesH) +import Futhark.MonadFreshNames +import Futhark.Util (chunk) +import Futhark.Util.Pretty (prettyTextOneLine) +import Language.C.Quote.OpenCL qualified as C +import Language.C.Syntax qualified as C + +genKernelFunction :: + KernelName -> + KernelSafety -> + [C.Param] -> + [(C.Exp, C.Exp)] -> + GC.CompilerM op s Name +genKernelFunction kernel_name safety arg_params arg_set = do + let kernel_fname = "gpu_kernel_" <> kernel_name + GC.libDecl + [C.cedecl|static int $id:kernel_fname + (struct futhark_context* ctx, + unsigned int grid_x, unsigned int grid_y, unsigned int grid_z, + unsigned int block_x, unsigned int block_y, unsigned int block_z, + unsigned int shared_bytes, $params:arg_params) { + if (grid_x * grid_y * grid_z * block_x * block_y * block_z != 0) { + 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), + (const typename int32_t[]){grid_x, grid_y, grid_z}, + (const typename int32_t[]){block_x, block_y, block_z}, + shared_bytes, + $int:num_args, args, args_sizes); + } + return FUTHARK_SUCCESS; + }|] + + pure kernel_fname + where + num_args = numFailureParams safety + length arg_set + expToInit e = [C.cinit|$exp:e|] + (args_sizes, args_inits) = bimap (map expToInit) (map expToInit) $ unzip arg_set + (failure_inits, failure_sizes) = + unzip . take (numFailureParams safety) $ + [ ([C.cinit|&ctx->global_failure|], [C.cinit|sizeof(ctx->global_failure)|]), + ([C.cinit|&ctx->failure_is_an_option|], [C.cinit|sizeof(ctx->failure_is_an_option)|]), + ([C.cinit|&ctx->global_failure_args|], [C.cinit|sizeof(ctx->global_failure_args)|]) + ] + +kernelConstToExp :: KernelConst -> C.Exp +kernelConstToExp (SizeConst key) = + [C.cexp|*ctx->tuning_params.$id:key|] +kernelConstToExp (SizeMaxConst size_class) = + [C.cexp|ctx->$id:field|] + where + field = "max_" <> prettyString size_class + +compileGroupDim :: GroupDim -> GC.CompilerM op s C.Exp +compileGroupDim (Left e) = GC.compileExp e +compileGroupDim (Right kc) = pure $ kernelConstToExp kc + +genLaunchKernel :: + KernelSafety -> + KernelName -> + Count Bytes (TExp Int64) -> + [KernelArg] -> + [Exp] -> + [GroupDim] -> + GC.CompilerM op s () +genLaunchKernel safety kernel_name local_memory args num_groups group_size = do + (arg_params, arg_params_inits, call_args) <- + unzip3 <$> zipWithM mkArgs [(0 :: Int) ..] args + + (grid_x, grid_y, grid_z) <- mkDims <$> mapM GC.compileExp num_groups + (group_x, group_y, group_z) <- mkDims <$> mapM compileGroupDim group_size + + kernel_fname <- genKernelFunction kernel_name safety arg_params arg_params_inits + + local_memory' <- GC.compileExp $ untyped $ unCount local_memory + + GC.stm + [C.cstm|{ + err = $id:kernel_fname(ctx, + $exp:grid_x, $exp:grid_y, $exp:grid_z, + $exp:group_x, $exp:group_y, $exp:group_z, + $exp:local_memory', + $args:call_args); + if (err != FUTHARK_SUCCESS) { goto cleanup; } + }|] + + when (safety >= SafetyFull) $ + GC.stm [C.cstm|ctx->failure_is_an_option = 1;|] + where + mkDims [] = ([C.cexp|0|], [C.cexp|0|], [C.cexp|0|]) + mkDims [x] = (x, [C.cexp|1|], [C.cexp|1|]) + mkDims [x, y] = (x, y, [C.cexp|1|]) + mkDims (x : y : z : _) = (x, y, z) + + mkArgs i (ValueKArg e t) = do + let arg = "arg" <> show i + e' <- GC.compileExp e + pure + ( [C.cparam|$ty:(primStorageType t) $id:arg|], + ([C.cexp|sizeof($id:arg)|], [C.cexp|&$id:arg|]), + toStorage t e' + ) + mkArgs i (MemKArg v) = do + let arg = "arg" <> show i + v' <- GC.rawMem v + pure + ( [C.cparam|typename gpu_mem $id:arg|], + ([C.cexp|sizeof($id:arg)|], [C.cexp|&$id:arg|]), + v' + ) + +callKernel :: GC.OpCompiler OpenCL () +callKernel (GetSize v key) = do + let e = kernelConstToExp $ SizeConst key + GC.stm [C.cstm|$id:v = $exp:e;|] +callKernel (CmpSizeLe v key x) = do + let e = kernelConstToExp $ SizeConst key + x' <- GC.compileExp x + GC.stm [C.cstm|$id:v = $exp:e <= $exp:x';|] + -- Output size information if logging is enabled. The autotuner + -- depends on the format of this output, so use caution if changing + -- it. + GC.stm + [C.cstm|if (ctx->logging) { + fprintf(ctx->log, "Compared %s <= %ld: %s.\n", $string:(T.unpack (prettyTextOneLine key)), (long)$exp:x', $id:v ? "true" : "false"); + }|] +callKernel (GetSizeMax v size_class) = do + let e = kernelConstToExp $ SizeMaxConst size_class + GC.stm [C.cstm|$id:v = $exp:e;|] +callKernel (LaunchKernel safety kernel_name local_memory args num_groups group_size) = + genLaunchKernel safety kernel_name local_memory args num_groups group_size + +copygpu2gpu :: GC.DoLMADCopy op s +copygpu2gpu _ t shape dst (dstoffset, dststride) src (srcoffset, srcstride) = do + let fname = "lmad_copy_gpu2gpu_" <> show (primByteSize t :: Int) <> "b" + r = length shape + 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] + GC.stm + [C.cstm| + if ((err = + $id:fname(ctx, $int:r, + $exp:dst, $exp:(unCount dstoffset), + (typename int64_t[]){ $inits:dststride_inits }, + $exp:src, $exp:(unCount srcoffset), + (typename int64_t[]){ $inits:srcstride_inits }, + (typename int64_t[]){ $inits:shape_inits })) != 0) { + goto cleanup; + } + |] + +copyhost2gpu :: GC.DoLMADCopy op s +copyhost2gpu sync t shape dst (dstoffset, dststride) src (srcoffset, srcstride) = do + let r = length shape + 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] + GC.stm + [C.cstm| + if ((err = + lmad_copy_host2gpu + (ctx, $int:(primByteSize t::Int), $exp:sync', $int:r, + $exp:dst, $exp:(unCount dstoffset), + (typename int64_t[]){ $inits:dststride_inits }, + $exp:src, $exp:(unCount srcoffset), + (typename int64_t[]){ $inits:srcstride_inits }, + (typename int64_t[]){ $inits:shape_inits })) != 0) { + goto cleanup; + } + |] + where + sync' = case sync of + GC.CopyBarrier -> [C.cexp|true|] + GC.CopyNoBarrier -> [C.cexp|false|] + +copygpu2host :: GC.DoLMADCopy op s +copygpu2host sync t shape dst (dstoffset, dststride) src (srcoffset, srcstride) = do + let r = length shape + 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] + GC.stm + [C.cstm| + if ((err = + lmad_copy_gpu2host + (ctx, $int:(primByteSize t::Int), $exp:sync', $int:r, + $exp:dst, $exp:(unCount dstoffset), + (typename int64_t[]){ $inits:dststride_inits }, + $exp:src, $exp:(unCount srcoffset), + (typename int64_t[]){ $inits:srcstride_inits }, + (typename int64_t[]){ $inits:shape_inits })) != 0) { + goto cleanup; + } + |] + where + sync' = case sync of + GC.CopyBarrier -> [C.cexp|true|] + GC.CopyNoBarrier -> [C.cexp|false|] + +gpuCopies :: M.Map (Space, Space) (GC.DoLMADCopy op s) +gpuCopies = + M.fromList + [ ((Space "device", Space "device"), copygpu2gpu), + ((Space "device", DefaultSpace), copyhost2gpu), + ((DefaultSpace, Space "device"), copygpu2host) + ] + +createKernels :: [KernelName] -> GC.CompilerM op s () +createKernels kernels = forM_ kernels $ \name -> + GC.contextFieldDyn + (C.toIdent name mempty) + [C.cty|typename gpu_kernel|] + [C.cstm|gpu_create_kernel(ctx, &ctx->program->$id:name, $string:(T.unpack (idText (C.toIdent name mempty))));|] + [C.cstm|gpu_free_kernel(ctx, ctx->program->$id:name);|] + +allocateGPU :: GC.Allocate op () +allocateGPU mem size tag "device" = + GC.stm + [C.cstm|(void)gpu_alloc(ctx, ctx->log, + (size_t)$exp:size, $exp:tag, + &$exp:mem, (size_t*)&$exp:size);|] +allocateGPU _ _ _ space = + error $ "Cannot allocate in '" ++ space ++ "' memory space." + +deallocateGPU :: GC.Deallocate op () +deallocateGPU mem size tag "device" = + GC.stm [C.cstm|(void)gpu_free(ctx, $exp:mem, $exp:size, $exp:tag);|] +deallocateGPU _ _ _ space = + error $ "Cannot deallocate in '" ++ space ++ "' space" + +-- It is often faster to do a blocking clEnqueueReadBuffer() than to +-- do an async clEnqueueReadBuffer() followed by a clFinish(), even +-- with an in-order command queue. This is safe if and only if there +-- are no possible outstanding failures. +readScalarGPU :: GC.ReadScalar op () +readScalarGPU mem i t "device" _ = do + val <- newVName "read_res" + GC.decl [C.cdecl|$ty:t $id:val;|] + 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; }|] + GC.stm + [C.cstm|if (ctx->failure_is_an_option && futhark_context_sync(ctx) != 0) + { err = 1; goto cleanup; }|] + pure [C.cexp|$id:val|] +readScalarGPU _ _ _ space _ = + error $ "Cannot read from '" ++ space ++ "' memory space." + +-- TODO: Optimised special case when the scalar is a constant, in +-- which case we can do the write asynchronously. +writeScalarGPU :: GC.WriteScalar op () +writeScalarGPU mem i t "device" _ val = do + val' <- newVName "write_tmp" + GC.item [C.citem|$ty:t $id:val' = $exp:val;|] + 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; }|] +writeScalarGPU _ _ _ space _ _ = + error $ "Cannot write to '" ++ space ++ "' memory space." + +syncArg :: GC.CopyBarrier -> C.Exp +syncArg GC.CopyBarrier = [C.cexp|true|] +syncArg GC.CopyNoBarrier = [C.cexp|false|] + +copyGPU :: GC.Copy OpenCL () +copyGPU _ dstmem dstidx (Space "device") srcmem srcidx (Space "device") nbytes = + 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 = + 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 = + GC.stm + [C.cstm|err = memcpy_host2gpu(ctx, $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 + +gpuOperations :: GC.Operations OpenCL () +gpuOperations = + GC.defaultOperations + { GC.opsCompiler = callKernel, + GC.opsWriteScalar = writeScalarGPU, + GC.opsReadScalar = readScalarGPU, + GC.opsAllocate = allocateGPU, + GC.opsDeallocate = deallocateGPU, + GC.opsCopy = copyGPU, + GC.opsCopies = gpuCopies <> GC.opsCopies GC.defaultOperations, + GC.opsFatMemory = True + } + +-- | Options that are common to multiple GPU-like backends. +gpuOptions :: [Option] +gpuOptions = + [ Option + { optionLongName = "device", + optionShortName = Just 'd', + optionArgument = RequiredArgument "NAME", + optionDescription = "Use the first device whose name contains the given string.", + optionAction = [C.cstm|futhark_context_config_set_device(cfg, optarg);|] + }, + Option + { optionLongName = "default-group-size", + optionShortName = Nothing, + optionArgument = RequiredArgument "INT", + optionDescription = "The default size of workgroups that are launched.", + optionAction = [C.cstm|futhark_context_config_set_default_group_size(cfg, atoi(optarg));|] + }, + Option + { optionLongName = "default-num-groups", + optionShortName = Nothing, + optionArgument = RequiredArgument "INT", + optionDescription = "The default number of workgroups that are launched.", + optionAction = [C.cstm|futhark_context_config_set_default_num_groups(cfg, atoi(optarg));|] + }, + Option + { optionLongName = "default-tile-size", + optionShortName = Nothing, + optionArgument = RequiredArgument "INT", + optionDescription = "The default tile size used when performing two-dimensional tiling.", + optionAction = [C.cstm|futhark_context_config_set_default_tile_size(cfg, atoi(optarg));|] + }, + Option + { optionLongName = "default-reg-tile-size", + optionShortName = Nothing, + optionArgument = RequiredArgument "INT", + optionDescription = "The default register tile size used when performing two-dimensional tiling.", + optionAction = [C.cstm|futhark_context_config_set_default_reg_tile_size(cfg, atoi(optarg));|] + }, + Option + { optionLongName = "default-threshold", + optionShortName = Nothing, + optionArgument = RequiredArgument "INT", + optionDescription = "The default parallelism threshold.", + optionAction = [C.cstm|futhark_context_config_set_default_threshold(cfg, atoi(optarg));|] + } + ] + +errorMsgNumArgs :: ErrorMsg a -> Int +errorMsgNumArgs = length . errorMsgArgTypes + +failureMsgFunction :: [FailureMsg] -> C.Definition +failureMsgFunction failures = + let printfEscape = + let escapeChar '%' = "%%" + escapeChar c = [c] + in concatMap escapeChar + onPart (ErrorString s) = printfEscape $ T.unpack s + -- FIXME: bogus for non-ints. + onPart ErrorVal {} = "%lld" + onFailure i (FailureMsg emsg@(ErrorMsg parts) backtrace) = + let msg = concatMap onPart parts ++ "\n" ++ printfEscape backtrace + msgargs = [[C.cexp|args[$int:j]|] | j <- [0 .. errorMsgNumArgs emsg - 1]] + in [C.cstm|case $int:i: {return msgprintf($string:msg, $args:msgargs); break;}|] + failure_cases = + zipWith onFailure [(0 :: Int) ..] failures + in [C.cedecl|static char* get_failure_msg(int failure_idx, typename int64_t args[]) { + (void)args; + switch (failure_idx) { $stms:failure_cases } + return strdup("Unknown error. This is a compiler bug."); + }|] + +genProfileReport :: [Name] -> GC.CompilerM op s () +genProfileReport cost_centres = + GC.profileReport + [C.citem|{struct cost_centres* ccs = cost_centres_new(); + $stms:(map initCostCentre (def_cost_centres<>cost_centres)) + tally_profiling_records(ctx, ccs); + cost_centre_report(ccs, &builder); + cost_centres_free(ccs); + }|] + where + def_cost_centres = + [ "copy_dev_to_dev", + "copy_dev_to_host", + "copy_host_to_dev", + "copy_scalar_to_dev", + "copy_scalar_from_dev" + ] + initCostCentre v = + [C.cstm|cost_centres_init(ccs, $string:(nameToString v));|] + +-- | Called after most code has been generated to generate the bulk of +-- the boilerplate. +generateGPUBoilerplate :: + T.Text -> + T.Text -> + [Name] -> + [PrimType] -> + [FailureMsg] -> + GC.CompilerM OpenCL () () +generateGPUBoilerplate gpu_program backendH kernels types failures = do + createKernels kernels + let gpu_program_fragments = + -- Some C compilers limit the size of literal strings, so + -- chunk the entire program into small bits here, and + -- concatenate it again at runtime. + [[C.cinit|$string:s|] | s <- chunk 2000 $ T.unpack gpu_program] + program_fragments = gpu_program_fragments ++ [[C.cinit|NULL|]] + f64_required + | FloatType Float64 `elem` types = [C.cexp|1|] + | otherwise = [C.cexp|0|] + max_failure_args = foldl max 0 $ map (errorMsgNumArgs . failureError) failures + mapM_ + GC.earlyDecl + [C.cunit|static const int max_failure_args = $int:max_failure_args; + static const int f64_required = $exp:f64_required; + static const char *gpu_program[] = {$inits:program_fragments}; + $esc:(T.unpack gpuPrototypesH) + $esc:(T.unpack backendH) + $esc:(T.unpack gpuH) + |] + GC.earlyDecl $ failureMsgFunction failures + + GC.generateProgramStruct + + GC.onClear [C.citem|if (ctx->error == NULL) { gpu_free_all(ctx); }|] + + genProfileReport kernels diff --git a/src/Futhark/CodeGen/Backends/GenericC.hs b/src/Futhark/CodeGen/Backends/GenericC.hs --- a/src/Futhark/CodeGen/Backends/GenericC.hs +++ b/src/Futhark/CodeGen/Backends/GenericC.hs @@ -37,7 +37,7 @@ import Futhark.CodeGen.Backends.GenericC.Server (serverDefs) import Futhark.CodeGen.Backends.GenericC.Types import Futhark.CodeGen.ImpCode -import Futhark.CodeGen.RTS.C (cacheH, contextH, contextPrototypesH, errorsH, freeListH, halfH, lockH, timingH, utilH) +import Futhark.CodeGen.RTS.C (cacheH, contextH, contextPrototypesH, copyH, errorsH, freeListH, halfH, lockH, timingH, utilH) import Futhark.IR.GPU.Sizes import Futhark.Manifest qualified as Manifest import Futhark.MonadFreshNames @@ -61,6 +61,29 @@ err = FUTHARK_PROGRAM_ERROR; goto cleanup;|] +lmadcopyCPU :: DoLMADCopy op s +lmadcopyCPU _ t shape dst (dstoffset, dststride) src (srcoffset, srcstride) = do + let fname :: String + (fname, ty) = + case primByteSize t :: Int of + 1 -> ("lmad_copy_1b", [C.cty|typename uint8_t|]) + 2 -> ("lmad_copy_2b", [C.cty|typename uint16_t|]) + 4 -> ("lmad_copy_4b", [C.cty|typename uint32_t|]) + 8 -> ("lmad_copy_8b", [C.cty|typename uint64_t|]) + k -> error $ "lmadcopyCPU: " <> error (show k) + r = length shape + 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] + stm + [C.cstm| + $id:fname(ctx, $int:r, + ($ty:ty*) $exp:dst, $exp:(unCount dstoffset), + (typename int64_t[]){ $inits:dststride_inits }, + ($ty:ty*) $exp:src, $exp:(unCount srcoffset), + (typename int64_t[]){ $inits:srcstride_inits }, + (typename int64_t[]){ $inits:shape_inits });|] + -- | A set of operations that fail for every operation involving -- non-default memory spaces. Uses plain pointers and @malloc@ for -- memory management. @@ -72,6 +95,7 @@ opsAllocate = defAllocate, opsDeallocate = defDeallocate, opsCopy = defCopy, + opsCopies = M.singleton (DefaultSpace, DefaultSpace) lmadcopyCPU, opsMemoryType = defMemoryType, opsCompiler = defCompiler, opsFatMemory = True, @@ -174,20 +198,11 @@ return ret; } - long long new_usage = ctx->$id:usagename + size; if (ctx->detail_memory) { - fprintf(ctx->log, "Allocating %lld bytes for %s in %s (then allocated: %lld bytes)", + fprintf(ctx->log, "Allocating %lld bytes for %s in %s (currently allocated: %lld bytes).\n", (long long) size, desc, $string:spacedesc, - new_usage); - } - if (new_usage > ctx->$id:peakname) { - ctx->$id:peakname = new_usage; - if (ctx->detail_memory) { - fprintf(ctx->log, " (new peak).\n"); - } - } else if (ctx->detail_memory) { - fprintf(ctx->log, ".\n"); + ctx->$id:usagename); } $items:alloc @@ -197,7 +212,20 @@ *(block->references) = 1; block->size = size; block->desc = desc; + long long new_usage = ctx->$id:usagename + size; + if (ctx->detail_memory) { + fprintf(ctx->log, "Received block of %lld bytes; now allocated: %lld bytes", + (long long)block->size, new_usage); + } ctx->$id:usagename = new_usage; + if (new_usage > ctx->$id:peakname) { + ctx->$id:peakname = new_usage; + if (ctx->detail_memory) { + fprintf(ctx->log, " (new peak).\n"); + } + } else if (ctx->detail_memory) { + fprintf(ctx->log, ".\n"); + } return FUTHARK_SUCCESS; } else { // We are naively assuming that any memory allocation error is due to OOM. @@ -298,11 +326,14 @@ #ifdef __clang__ #pragma clang diagnostic ignored "-Wunused-function" #pragma clang diagnostic ignored "-Wunused-variable" +#pragma clang diagnostic ignored "-Wunused-const-variable" #pragma clang diagnostic ignored "-Wparentheses" #pragma clang diagnostic ignored "-Wunused-label" +#pragma clang diagnostic ignored "-Wunused-but-set-variable" #elif __GNUC__ #pragma GCC diagnostic ignored "-Wunused-function" #pragma GCC diagnostic ignored "-Wunused-variable" +#pragma GCC diagnostic ignored "-Wunused-const-variable" #pragma GCC diagnostic ignored "-Wparentheses" #pragma GCC diagnostic ignored "-Wunused-label" #pragma GCC diagnostic ignored "-Wunused-but-set-variable" @@ -332,7 +363,7 @@ map fst $ filter ((fname `S.member`) . snd . snd) $ M.toList m compileProg' :: - MonadFreshNames m => + (MonadFreshNames m) => T.Text -> T.Text -> ParamMap -> @@ -404,6 +435,7 @@ #undef NDEBUG #include #include +#define SCALAR_FUN_ATTR static inline $utilH $cacheH $halfH @@ -439,6 +471,10 @@ $contextH +$copyH + +#define FUTHARK_FUN_ATTR static + $prototypes $lib_decls @@ -514,7 +550,7 @@ -- | Compile imperative program to a C program. Always uses the -- function named "main" as entry point, so make sure it is defined. compileProg :: - MonadFreshNames m => + (MonadFreshNames m) => T.Text -> T.Text -> ParamMap -> 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 @@ -8,6 +8,8 @@ compileCode, compileDest, compileArg, + compileLMADCopy, + compileLMADCopyWith, errorMsgString, linearCode, ) @@ -15,6 +17,7 @@ import Control.Monad import Control.Monad.Reader (asks) +import Data.Map qualified as M import Data.Maybe import Data.Text qualified as T import Futhark.CodeGen.Backends.GenericC.Monad @@ -55,7 +58,7 @@ compileExp = compilePrimExp $ \v -> pure [C.cexp|$id:v|] -- | Tell me how to compile a @v@, and I'll Compile any @PrimExp v@ for you. -compilePrimExp :: Monad m => (v -> m C.Exp) -> PrimExp v -> m C.Exp +compilePrimExp :: (Monad m) => (v -> m C.Exp) -> PrimExp v -> m C.Exp compilePrimExp _ (ValueExp val) = pure $ C.toExp val mempty compilePrimExp f (LeafExp v _) = @@ -133,6 +136,50 @@ assignmentOperator Mul {} = Just $ \d e -> [C.cexp|$id:d *= $exp:e|] assignmentOperator _ = Nothing +generateRead :: + C.Exp -> + C.Exp -> + PrimType -> + Space -> + Volatility -> + CompilerM op s C.Exp +generateRead _ _ Unit _ _ = + pure [C.cexp|$exp:(UnitValue)|] +generateRead src iexp _ ScalarSpace {} _ = + pure [C.cexp|$exp:src[$exp:iexp]|] +generateRead src iexp restype DefaultSpace vol = + pure . fromStorage restype $ + derefPointer + src + iexp + [C.cty|$tyquals:(volQuals vol) $ty:(primStorageType restype)*|] +generateRead src iexp restype (Space space) vol = do + reader <- asks (opsReadScalar . envOperations) + fromStorage restype <$> reader src iexp (primStorageType restype) space vol + +generateWrite :: + C.Exp -> + C.Exp -> + PrimType -> + Space -> + Volatility -> + C.Exp -> + CompilerM op s () +generateWrite _ _ Unit _ _ _ = pure () +generateWrite dest idx _ ScalarSpace {} _ elemexp = do + stm [C.cstm|$exp:dest[$exp:idx] = $exp:elemexp;|] +generateWrite dest idx elemtype DefaultSpace vol elemexp = do + let deref = + derefPointer + dest + idx + [C.cty|$tyquals:(volQuals vol) $ty:(primStorageType elemtype)*|] + elemexp' = toStorage elemtype elemexp + stm [C.cstm|$exp:deref = $exp:elemexp';|] +generateWrite dest idx elemtype (Space space) vol elemexp = do + writer <- asks (opsWriteScalar . envOperations) + writer dest idx (primStorageType elemtype) space vol (toStorage elemtype elemexp) + compileRead :: VName -> Count u (TPrimExp t VName) -> @@ -140,25 +187,10 @@ Space -> Volatility -> CompilerM op s C.Exp -compileRead _ _ Unit _ _ = - pure [C.cexp|$exp:(UnitValue)|] -compileRead src (Count iexp) restype DefaultSpace vol = do +compileRead src (Count iexp) restype space vol = do src' <- rawMem src - fmap (fromStorage restype) $ - derefPointer src' - <$> compileExp (untyped iexp) - <*> pure [C.cty|$tyquals:(volQuals vol) $ty:(primStorageType restype)*|] -compileRead src (Count iexp) restype (Space space) vol = - fmap (fromStorage restype) . join $ - asks (opsReadScalar . envOperations) - <*> rawMem src - <*> compileExp (untyped iexp) - <*> pure (primStorageType restype) - <*> pure space - <*> pure vol -compileRead src (Count iexp) _ ScalarSpace {} _ = do - iexp' <- compileExp $ untyped iexp - pure [C.cexp|$id:src[$exp:iexp']|] + iexp' <- compileExp (untyped iexp) + generateRead src' iexp' restype space vol memNeedsWrapping :: VName -> CompilerM op s Bool memNeedsWrapping v = do @@ -304,47 +336,26 @@ [C.cstm|if ($exp:cond') { $items:tbranch' } else $stm:x|] _ -> [C.cstm|if ($exp:cond') { $items:tbranch' } else { $items:fbranch' }|] -compileCode (Copy _ dest (Count destoffset) DefaultSpace src (Count srcoffset) DefaultSpace (Count size)) = - join $ - copyMemoryDefaultSpace - <$> rawMem dest - <*> compileExp (untyped destoffset) - <*> rawMem src - <*> compileExp (untyped srcoffset) - <*> compileExp (untyped size) -compileCode (Copy _ dest (Count destoffset) destspace src (Count srcoffset) srcspace (Count size)) = do - copy <- asks $ opsCopy . envOperations - join $ - copy CopyBarrier - <$> rawMem dest - <*> compileExp (untyped destoffset) - <*> pure destspace - <*> rawMem src - <*> compileExp (untyped srcoffset) - <*> pure srcspace - <*> compileExp (untyped size) +compileCode (LMADCopy t shape (dst, dstspace) (dstoffset, dststrides) (src, srcspace) (srcoffset, srcstrides)) = do + cp <- asks $ M.lookup (dstspace, srcspace) . opsCopies . envOperations + case cp of + Nothing -> + compileLMADCopy t shape (dst, dstspace) (dstoffset, dststrides) (src, srcspace) (srcoffset, srcstrides) + Just cp' -> do + shape' <- traverse (traverse (compileExp . untyped)) shape + dst' <- rawMem dst + src' <- rawMem src + dstoffset' <- traverse (compileExp . untyped) dstoffset + dststrides' <- traverse (traverse (compileExp . untyped)) dststrides + srcoffset' <- traverse (compileExp . untyped) srcoffset + srcstrides' <- traverse (traverse (compileExp . untyped)) srcstrides + cp' CopyBarrier t shape' dst' (dstoffset', dststrides') src' (srcoffset', srcstrides') compileCode (Write _ _ Unit _ _ _) = pure () -compileCode (Write dest (Count idx) elemtype DefaultSpace vol elemexp) = do - dest' <- rawMem dest - deref <- - derefPointer dest' - <$> compileExp (untyped idx) - <*> pure [C.cty|$tyquals:(volQuals vol) $ty:(primStorageType elemtype)*|] - elemexp' <- toStorage elemtype <$> compileExp elemexp - stm [C.cstm|$exp:deref = $exp:elemexp';|] -compileCode (Write dest (Count idx) _ ScalarSpace {} _ elemexp) = do +compileCode (Write dst (Count idx) elemtype space vol elemexp) = do + dst' <- rawMem dst idx' <- compileExp (untyped idx) elemexp' <- compileExp elemexp - stm [C.cstm|$id:dest[$exp:idx'] = $exp:elemexp';|] -compileCode (Write dest (Count idx) elemtype (Space space) vol elemexp) = - join $ - asks (opsWriteScalar . envOperations) - <*> rawMem dest - <*> compileExp (untyped idx) - <*> pure (primStorageType elemtype) - <*> pure space - <*> pure vol - <*> (toStorage elemtype <$> compileExp elemexp) + generateWrite dst' idx' elemtype space vol elemexp' compileCode (Read x src i restype space vol) = do e <- compileRead src i restype space vol stm [C.cstm|$id:x = $exp:e;|] @@ -394,3 +405,61 @@ <*> pure fname <*> mapM compileArg args stms $ mconcat unpack_dest + +-- | Compile an 'LMADCopy' using sequential nested loops, but +-- parameterised over how to do the reads and writes. +compileLMADCopyWith :: + [Count Elements (TExp Int64)] -> + (C.Exp -> C.Exp -> CompilerM op s ()) -> + ( Count Elements (TExp Int64), + [Count Elements (TExp Int64)] + ) -> + (C.Exp -> CompilerM op s C.Exp) -> + ( Count Elements (TExp Int64), + [Count Elements (TExp Int64)] + ) -> + CompilerM op s () +compileLMADCopyWith shape doWrite dst_lmad doRead src_lmad = do + let (dstoffset, dststrides) = dst_lmad + (srcoffset, srcstrides) = src_lmad + shape' <- mapM (compileExp . untyped . unCount) shape + body <- collect $ do + dst_i <- + compileExp . untyped . unCount $ + dstoffset + sum (zipWith (*) is' dststrides) + src_i <- + compileExp . untyped . unCount $ + srcoffset + sum (zipWith (*) is' srcstrides) + doWrite dst_i =<< doRead src_i + items $ loops (zip is shape') body + where + r = length shape + is = map (VName "i") [0 .. r - 1] + is' :: [Count Elements (TExp Int64)] + is' = map (elements . le64) is + loops [] body = body + loops ((i, n) : ins) body = + [C.citems|for (typename int64_t $id:i = 0; $id:i < $exp:n; $id:i++) + { $items:(loops ins body) }|] + +-- | Compile an 'LMADCopy' using sequential nested loops and +-- 'Read'/'Write' of individual scalars. This always works, but can +-- be pretty slow if those reads and writes are costly. +compileLMADCopy :: + PrimType -> + [Count Elements (TExp Int64)] -> + (VName, Space) -> + ( Count Elements (TExp Int64), + [Count Elements (TExp Int64)] + ) -> + (VName, Space) -> + ( Count Elements (TExp Int64), + [Count Elements (TExp Int64)] + ) -> + CompilerM op s () +compileLMADCopy t shape (dst, dstspace) dst_lmad (src, srcspace) src_lmad = do + src' <- rawMem src + dst' <- rawMem dst + let doWrite dst_i = generateWrite dst' dst_i t dstspace Nonvolatile + doRead src_i = generateRead src' src_i t srcspace Nonvolatile + compileLMADCopyWith shape doWrite dst_lmad doRead src_lmad diff --git a/src/Futhark/CodeGen/Backends/GenericC/Fun.hs b/src/Futhark/CodeGen/Backends/GenericC/Fun.hs --- a/src/Futhark/CodeGen/Backends/GenericC/Fun.hs +++ b/src/Futhark/CodeGen/Backends/GenericC/Fun.hs @@ -63,10 +63,12 @@ body' <- collect $ compileFunBody out_ptrs outputs body decl_mem <- declAllocatedMem free_mem <- freeAllocatedMem + let futhark_function = + C.DeclSpec [] [C.EscTypeQual "FUTHARK_FUN_ATTR" mempty] (C.Tint Nothing mempty) mempty pure - ( [C.cedecl|static int $id:(funName fname)($params:extra, $params:outparams, $params:inparams);|], - [C.cfun|static int $id:(funName fname)($params:extra, $params:outparams, $params:inparams) { + ( [C.cedecl|$spec:futhark_function $id:(funName fname)($params:extra, $params:outparams, $params:inparams);|], + [C.cfun|$spec:futhark_function $id:(funName fname)($params:extra, $params:outparams, $params:inparams) { $stms:ignores int err = 0; $items:decl_cached @@ -96,10 +98,12 @@ cachingMemory (lexicalMemoryUsage func) $ \decl_cached free_cached -> do body' <- collect $ compileFunBody out_ptrs outputs body + let futhark_function = + C.DeclSpec [] [C.EscTypeQual "FUTHARK_FUN_ATTR" mempty] (C.Tvoid mempty) mempty pure - ( [C.cedecl|static void $id:(funName fname)($params:outparams, $params:inparams);|], - [C.cfun|static void $id:(funName fname)($params:outparams, $params:inparams) { + ( [C.cedecl|$spec:futhark_function $id:(funName fname)($params:outparams, $params:inparams);|], + [C.cfun|$spec:futhark_function $id:(funName fname)($params:outparams, $params:inparams) { $items:decl_cached $items:get_constants $items:body' 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 @@ -18,6 +18,7 @@ Deallocate, CopyBarrier (..), Copy, + DoLMADCopy, -- * Monadic compiler interface CompilerM, @@ -203,6 +204,22 @@ C.Exp -> CompilerM op s () +-- | Perform an 'LMADCopy'. It is expected that these functions are +-- each specialised on which spaces they operate on, so that is not part of their arguments. +type DoLMADCopy op s = + CopyBarrier -> + PrimType -> + [Count Elements C.Exp] -> + C.Exp -> + ( Count Elements C.Exp, + [Count Elements C.Exp] + ) -> + C.Exp -> + ( Count Elements C.Exp, + [Count Elements C.Exp] + ) -> + CompilerM op s () + -- | Call a function. type CallCompiler op s = [VName] -> Name -> [C.Exp] -> CompilerM op s () @@ -216,6 +233,8 @@ opsCompiler :: OpCompiler op s, opsError :: ErrorCompiler op s, opsCall :: CallCompiler op s, + -- | @(dst,src)@-space mapping to copy functions. + opsCopies :: M.Map (Space, Space) (DoLMADCopy op s), -- | If true, use reference counting. Otherwise, bare -- pointers. opsFatMemory :: Bool, @@ -351,7 +370,7 @@ fatMemory ScalarSpace {} = pure False fatMemory _ = asks $ opsFatMemory . envOperations -cacheMem :: C.ToExp a => a -> CompilerM op s (Maybe VName) +cacheMem :: (C.ToExp a) => a -> CompilerM op s (Maybe VName) cacheMem a = asks $ M.lookup (C.toExp a noLoc) . envCachedMem -- | Construct a publicly visible definition using the specified name @@ -468,7 +487,7 @@ where fat = asks ((&&) . opsFatMemory . envOperations) <*> (isNothing <$> cacheMem v) -rawMem' :: C.ToExp a => Bool -> a -> C.Exp +rawMem' :: (C.ToExp a) => Bool -> a -> C.Exp rawMem' True e = [C.cexp|$exp:e.mem|] rawMem' False e = [C.cexp|$exp:e|] @@ -518,7 +537,7 @@ ty <- memToCType name space decl [C.cdecl|$ty:ty $id:name;|] -resetMem :: C.ToExp a => a -> Space -> CompilerM op s () +resetMem :: (C.ToExp a) => a -> Space -> CompilerM op s () resetMem mem space = do refcount <- fatMemory space cached <- isJust <$> cacheMem mem @@ -552,7 +571,7 @@ }|] _ -> stm [C.cstm|$exp:dest = $exp:src;|] -unRefMem :: C.ToExp a => a -> Space -> CompilerM op s () +unRefMem :: (C.ToExp a) => a -> Space -> CompilerM op s () unRefMem mem space = do refcount <- fatMemory space cached <- isJust <$> cacheMem mem diff --git a/src/Futhark/CodeGen/Backends/GenericC/Types.hs b/src/Futhark/CodeGen/Backends/GenericC/Types.hs --- a/src/Futhark/CodeGen/Backends/GenericC/Types.hs +++ b/src/Futhark/CodeGen/Backends/GenericC/Types.hs @@ -83,7 +83,7 @@ [C.cexp|arr->mem.mem|] [C.cexp|0|] space - [C.cexp|data|] + [C.cexp|(const unsigned char*)data|] [C.cexp|0|] DefaultSpace [C.cexp|((size_t)$exp:arr_size) * $int:(primByteSize pt::Int)|] @@ -106,7 +106,7 @@ collect $ copy CopyNoBarrier - [C.cexp|data|] + [C.cexp|(unsigned char*)data|] [C.cexp|0|] DefaultSpace [C.cexp|arr->mem.mem|] @@ -126,7 +126,7 @@ proto [C.cedecl|$ty:array_type* $id:new_array($ty:ctx_ty *ctx, const $ty:pt' *data, $params:shape_params);|] proto - [C.cedecl|$ty:array_type* $id:new_raw_array($ty:ctx_ty *ctx, const $ty:memty data, typename int64_t offset, $params:shape_params);|] + [C.cedecl|$ty:array_type* $id:new_raw_array($ty:ctx_ty *ctx, $ty:memty data, typename int64_t offset, $params:shape_params);|] proto [C.cedecl|int $id:free_array($ty:ctx_ty *ctx, $ty:array_type *arr);|] proto @@ -140,17 +140,22 @@ libDecl [C.cunit| $ty:array_type* $id:new_array($ty:ctx_ty *ctx, const $ty:pt' *data, $params:shape_params) { + int err = 0; $ty:array_type* bad = NULL; $ty:array_type *arr = ($ty:array_type*) malloc(sizeof($ty:array_type)); if (arr == NULL) { return bad; } $items:(criticalSection ops new_body) + if (err != 0) { + free(arr); + return bad; + } return arr; } - $ty:array_type* $id:new_raw_array($ty:ctx_ty *ctx, const $ty:memty data, typename int64_t offset, - $params:shape_params) { + $ty:array_type* $id:new_raw_array($ty:ctx_ty *ctx, $ty:memty data, typename int64_t offset, $params:shape_params) { + int err = 0; $ty:array_type* bad = NULL; $ty:array_type *arr = ($ty:array_type*) malloc(sizeof($ty:array_type)); if (arr == NULL) { @@ -167,8 +172,9 @@ } int $id:values_array($ty:ctx_ty *ctx, $ty:array_type *arr, $ty:pt' *data) { + int err = 0; $items:(criticalSection ops values_body) - return 0; + return err; } $ty:memty $id:values_raw_array($ty:ctx_ty *ctx, $ty:array_type *arr) { 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 @@ -20,6 +20,7 @@ fromStorage, toStorage, Operations (..), + DoLMADCopy, defaultOperations, unpackDim, CompilerM (..), @@ -42,13 +43,14 @@ where import Control.Monad -import Control.Monad.RWS +import Control.Monad.RWS hiding (reader, writer) import Data.Char (isAlpha, isAlphaNum) import Data.Map qualified as M import Data.Maybe import Data.Text qualified as T import Futhark.CodeGen.Backends.GenericPython.AST import Futhark.CodeGen.Backends.GenericPython.Options +import Futhark.CodeGen.ImpCode (Count (..), Elements, TExp, elements, le64, untyped) import Futhark.CodeGen.ImpCode qualified as Imp import Futhark.CodeGen.RTS.Python import Futhark.Compiler.Config (CompilerMode (..)) @@ -102,6 +104,22 @@ PrimType -> CompilerM op s () +-- | Perform an 'Imp.LMADCopy'. It is expected that these functions +-- are each specialised on which spaces they operate on, so that is +-- not part of their arguments. +type DoLMADCopy op s = + PrimType -> + [Count Elements PyExp] -> + PyExp -> + ( Count Elements PyExp, + [Count Elements PyExp] + ) -> + PyExp -> + ( Count Elements PyExp, + [Count Elements PyExp] + ) -> + CompilerM op s () + -- | Construct the Python array being returned from an entry point. type EntryOutput op s = VName -> @@ -126,6 +144,8 @@ opsReadScalar :: ReadScalar op s, opsAllocate :: Allocate op s, opsCopy :: Copy op s, + -- | @(dst,src)@-space mapping to copy functions. + opsCopies :: M.Map (Space, Space) (DoLMADCopy op s), opsCompiler :: OpCompiler op s, opsEntryOutput :: EntryOutput op s, opsEntryInput :: EntryInput op s @@ -141,6 +161,7 @@ opsReadScalar = defReadScalar, opsAllocate = defAllocate, opsCopy = defCopy, + opsCopies = M.singleton (DefaultSpace, DefaultSpace) lmadcopyCPU, opsCompiler = defCompiler, opsEntryOutput = defEntryOutput, opsEntryInput = defEntryInput @@ -178,9 +199,6 @@ envAllocate :: CompilerEnv op s -> Allocate op s envAllocate = opsAllocate . envOperations -envCopy :: CompilerEnv op s -> Copy op s -envCopy = opsCopy . envOperations - envEntryOutput :: CompilerEnv op s -> EntryOutput op s envEntryOutput = opsEntryOutput . envOperations @@ -366,7 +384,7 @@ Def "__init__" params $ body <> at_init compileProg :: - MonadFreshNames m => + (MonadFreshNames m) => CompilerMode -> String -> Constructor -> @@ -1000,7 +1018,7 @@ FSignum {} -> "np.sign" compileBinOpLike :: - Monad m => + (Monad m) => (v -> m PyExp) -> Imp.PrimExp v -> Imp.PrimExp v -> @@ -1123,7 +1141,7 @@ v' = compileName v -- | Tell me how to compile a @v@, and I'll Compile any @PrimExp v@ for you. -compilePrimExp :: Monad m => (v -> m PyExp) -> Imp.PrimExp v -> m PyExp +compilePrimExp :: (Monad m) => (v -> m PyExp) -> Imp.PrimExp v -> m PyExp compilePrimExp _ (Imp.ValueExp v) = pure $ compilePrimValue v compilePrimExp f (Imp.LeafExp v _) = f v compilePrimExp f (Imp.BinOpExp op x y) = do @@ -1174,6 +1192,96 @@ (formatstrs, formatargs) <- mapAndUnzipM onPart parts pure (mconcat formatstrs, formatargs) +generateRead :: + PyExp -> + PyExp -> + PrimType -> + Space -> + CompilerM op s PyExp +generateRead _ _ Unit _ = + pure (compilePrimValue UnitValue) +generateRead _ _ _ ScalarSpace {} = + error "GenericPython.generateRead: ScalarSpace" +generateRead src iexp pt DefaultSpace = do + let pt' = compilePrimType pt + pure $ fromStorage pt $ simpleCall "indexArray" [src, iexp, Var pt'] +generateRead src iexp pt (Space space) = do + reader <- asks envReadScalar + reader src iexp pt space + +generateWrite :: + PyExp -> + PyExp -> + PrimType -> + Space -> + PyExp -> + CompilerM op s () +generateWrite _ _ Unit _ _ = pure () +generateWrite _ _ _ ScalarSpace {} _ = do + error "GenericPython.generateWrite: ScalarSpace" +generateWrite dst iexp pt (Imp.Space space) elemexp = do + writer <- asks envWriteScalar + writer dst iexp pt space elemexp +generateWrite dst iexp pt DefaultSpace elemexp = + stm $ Exp $ simpleCall "writeScalarArray" [dst, iexp, toStorage pt elemexp] + +-- | Compile an 'LMADCopy' using sequential nested loops, but +-- parameterised over how to do the reads and writes. +compileLMADCopyWith :: + [Count Elements (TExp Int64)] -> + (PyExp -> PyExp -> CompilerM op s ()) -> + ( Count Elements (TExp Int64), + [Count Elements (TExp Int64)] + ) -> + (PyExp -> CompilerM op s PyExp) -> + ( Count Elements (TExp Int64), + [Count Elements (TExp Int64)] + ) -> + CompilerM op s () +compileLMADCopyWith shape doWrite dst_lmad doRead src_lmad = do + let (dstoffset, dststrides) = dst_lmad + (srcoffset, srcstrides) = src_lmad + shape' <- mapM (compileExp . untyped . unCount) shape + body <- collect $ do + dst_i <- + compileExp . untyped . unCount $ + dstoffset + sum (zipWith (*) is' dststrides) + src_i <- + compileExp . untyped . unCount $ + srcoffset + sum (zipWith (*) is' srcstrides) + doWrite dst_i =<< doRead src_i + mapM_ stm $ loops (zip is shape') body + where + r = length shape + is = map (VName "i") [0 .. r - 1] + is' :: [Count Elements (TExp Int64)] + is' = map (elements . le64) is + loops [] body = body + loops ((i, n) : ins) body = + [For (compileName i) (simpleCall "range" [n]) $ loops ins body] + +-- | Compile an 'LMADCopy' using sequential nested loops and +-- 'Imp.Read'/'Imp.Write' of individual scalars. This always works, +-- but can be pretty slow if those reads and writes are costly. +compileLMADCopy :: + PrimType -> + [Count Elements (TExp Int64)] -> + (VName, Space) -> + ( Count Elements (TExp Int64), + [Count Elements (TExp Int64)] + ) -> + (VName, Space) -> + ( Count Elements (TExp Int64), + [Count Elements (TExp Int64)] + ) -> + CompilerM op s () +compileLMADCopy t shape (dst, dstspace) dst_lmad (src, srcspace) src_lmad = do + src' <- compileVar src + dst' <- compileVar dst + let doWrite dst_i = generateWrite dst' dst_i t dstspace + doRead src_i = generateRead src' src_i t srcspace + compileLMADCopyWith shape doWrite dst_lmad doRead src_lmad + compileCode :: Imp.Code op -> CompilerM op s () compileCode Imp.DebugPrint {} = pure () @@ -1278,57 +1386,41 @@ stm =<< Assign <$> compileVar name <*> pure allocate' compileCode (Imp.Free name _) = stm =<< Assign <$> compileVar name <*> pure None -compileCode (Imp.Copy _ dest (Imp.Count destoffset) DefaultSpace src (Imp.Count srcoffset) DefaultSpace (Imp.Count size)) = do - destoffset' <- compileExp $ Imp.untyped destoffset - srcoffset' <- compileExp $ Imp.untyped srcoffset - dest' <- compileVar dest - src' <- compileVar src - size' <- compileExp $ Imp.untyped size - let offset_call1 = simpleCall "addressOffset" [dest', destoffset', Var "ct.c_byte"] - let offset_call2 = simpleCall "addressOffset" [src', srcoffset', Var "ct.c_byte"] - stm $ Exp $ simpleCall "ct.memmove" [offset_call1, offset_call2, size'] -compileCode (Imp.Copy pt dest (Imp.Count destoffset) destspace src (Imp.Count srcoffset) srcspace (Imp.Count size)) = do - copy <- asks envCopy - join $ - copy - <$> compileVar dest - <*> compileExp (Imp.untyped destoffset) - <*> pure destspace - <*> compileVar src - <*> compileExp (Imp.untyped srcoffset) - <*> pure srcspace - <*> compileExp (Imp.untyped size) - <*> pure pt -compileCode (Imp.Write _ _ Unit _ _ _) = pure () -compileCode (Imp.Write dest (Imp.Count idx) elemtype (Imp.Space space) _ elemexp) = - join $ - asks envWriteScalar - <*> compileVar dest - <*> compileExp (Imp.untyped idx) - <*> pure elemtype - <*> pure space - <*> compileExp elemexp -compileCode (Imp.Write dest (Imp.Count idx) elemtype _ _ elemexp) = do +compileCode (Imp.LMADCopy t shape (dst, dstspace) (dstoffset, dststrides) (src, srcspace) (srcoffset, srcstrides)) = do + cp <- asks $ M.lookup (dstspace, srcspace) . opsCopies . envOperations + case cp of + Nothing -> + compileLMADCopy t shape (dst, dstspace) (dstoffset, dststrides) (src, srcspace) (srcoffset, srcstrides) + Just cp' -> do + shape' <- traverse (traverse (compileExp . untyped)) shape + dst' <- compileVar dst + src' <- compileVar src + dstoffset' <- traverse (compileExp . untyped) dstoffset + dststrides' <- traverse (traverse (compileExp . untyped)) dststrides + srcoffset' <- traverse (compileExp . untyped) srcoffset + srcstrides' <- traverse (traverse (compileExp . untyped)) srcstrides + cp' t shape' dst' (dstoffset', dststrides') src' (srcoffset', srcstrides') +compileCode (Imp.Write dst (Imp.Count idx) pt space _ elemexp) = do + dst' <- compileVar dst idx' <- compileExp $ Imp.untyped idx - elemexp' <- toStorage elemtype <$> compileExp elemexp - dest' <- compileVar dest - stm $ Exp $ simpleCall "writeScalarArray" [dest', idx', elemexp'] -compileCode (Imp.Read x _ _ Unit _ _) = - stm =<< Assign <$> compileVar x <*> pure (compilePrimValue UnitValue) -compileCode (Imp.Read x src (Imp.Count iexp) restype (Imp.Space space) _) = do - x' <- compileVar x - e <- - join $ - asks envReadScalar - <*> compileVar src - <*> compileExp (Imp.untyped iexp) - <*> pure restype - <*> pure space - stm $ Assign x' e -compileCode (Imp.Read x src (Imp.Count iexp) bt _ _) = do + elemexp' <- compileExp elemexp + generateWrite dst' idx' pt space elemexp' +compileCode (Imp.Read x src (Imp.Count iexp) pt space _) = do x' <- compileVar x - iexp' <- compileExp $ Imp.untyped iexp - let bt' = compilePrimType bt + iexp' <- compileExp $ untyped iexp src' <- compileVar src - stm $ Assign x' $ fromStorage bt $ simpleCall "indexArray" [src', iexp', Var bt'] + stm . Assign x' =<< generateRead src' iexp' pt space compileCode Imp.Skip = pure () + +lmadcopyCPU :: DoLMADCopy op s +lmadcopyCPU t shape dst (dstoffset, dststride) src (srcoffset, srcstride) = + stm . Exp . simpleCall "lmad_copy" $ + [ Var (compilePrimType t), + dst, + unCount dstoffset, + List (map unCount dststride), + src, + unCount srcoffset, + List (map unCount srcstride), + List (map unCount shape) + ] diff --git a/src/Futhark/CodeGen/Backends/GenericPython/AST.hs b/src/Futhark/CodeGen/Backends/GenericPython/AST.hs --- a/src/Futhark/CodeGen/Backends/GenericPython/AST.hs +++ b/src/Futhark/CodeGen/Backends/GenericPython/AST.hs @@ -132,21 +132,25 @@ instance Pretty PyStmt where pretty (If cond [] []) = "if" - <+> pretty cond <> ":" + <+> pretty cond + <> ":" indent 2 "pass" pretty (If cond [] fbranch) = "if" - <+> pretty cond <> ":" + <+> pretty cond + <> ":" indent 2 "pass" "else:" indent 2 (stack $ map pretty fbranch) pretty (If cond tbranch []) = "if" - <+> pretty cond <> ":" + <+> pretty cond + <> ":" indent 2 (stack $ map pretty tbranch) pretty (If cond tbranch fbranch) = "if" - <+> pretty cond <> ":" + <+> pretty cond + <> ":" indent 2 (stack $ map pretty tbranch) "else:" indent 2 (stack $ map pretty fbranch) @@ -156,17 +160,20 @@ stack (map pretty pyexcepts) pretty (While cond body) = "while" - <+> pretty cond <> ":" + <+> pretty cond + <> ":" indent 2 (stack $ map pretty body) pretty (For i what body) = "for" <+> pretty i <+> "in" - <+> pretty what <> ":" + <+> pretty what + <> ":" indent 2 (stack $ map pretty body) pretty (With what body) = "with" - <+> pretty what <> ":" + <+> pretty what + <> ":" indent 2 (stack $ map pretty body) pretty (Assign e1 e2) = pretty e1 <+> "=" <+> pretty e2 pretty (AssignOp op e1 e2) = pretty e1 <+> pretty (op ++ "=") <+> pretty e2 @@ -187,13 +194,16 @@ instance Pretty PyFunDef where pretty (Def fname params body) = "def" - <+> pretty fname <> parens (commasep $ map pretty params) <> ":" + <+> pretty fname + <> parens (commasep $ map pretty params) + <> ":" indent 2 (stack (map pretty body)) instance Pretty PyClassDef where pretty (Class cname body) = "class" - <+> pretty cname <> ":" + <+> pretty cname + <> ":" indent 2 (stack (map pretty body)) instance Pretty PyExcept where diff --git a/src/Futhark/CodeGen/Backends/HIP.hs b/src/Futhark/CodeGen/Backends/HIP.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/CodeGen/Backends/HIP.hs @@ -0,0 +1,130 @@ +{-# LANGUAGE QuasiQuotes #-} + +-- | Code generation for HIP. +module Futhark.CodeGen.Backends.HIP + ( compileProg, + GC.CParts (..), + GC.asLibrary, + GC.asExecutable, + GC.asServer, + ) +where + +import Data.Map qualified as M +import Data.Text qualified as T +import Futhark.CodeGen.Backends.GPU +import Futhark.CodeGen.Backends.GenericC qualified as GC +import Futhark.CodeGen.Backends.GenericC.Options +import Futhark.CodeGen.ImpCode.OpenCL +import Futhark.CodeGen.ImpGen.HIP qualified as ImpGen +import Futhark.CodeGen.RTS.C (backendsHipH) +import Futhark.IR.GPUMem hiding + ( CmpSizeLe, + GetSize, + GetSizeMax, + ) +import Futhark.MonadFreshNames +import Language.C.Quote.OpenCL qualified as C +import NeatInterpolation (untrimming) + +mkBoilerplate :: + T.Text -> + M.Map Name KernelSafety -> + [PrimType] -> + [FailureMsg] -> + GC.CompilerM OpenCL () () +mkBoilerplate hip_program kernels types failures = do + generateGPUBoilerplate + hip_program + backendsHipH + (M.keys kernels) + types + failures + + GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_add_build_option(struct futhark_context_config *cfg, const char* opt);|] + GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_set_device(struct futhark_context_config *cfg, const char* s);|] + GC.headerDecl GC.InitDecl [C.cedecl|const char* futhark_context_config_get_program(struct futhark_context_config *cfg);|] + GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_set_program(struct futhark_context_config *cfg, const char* s);|] + GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_set_default_group_size(struct futhark_context_config *cfg, int size);|] + GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_set_default_num_groups(struct futhark_context_config *cfg, int size);|] + GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_set_default_tile_size(struct futhark_context_config *cfg, int size);|] + GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_set_default_reg_tile_size(struct futhark_context_config *cfg, int size);|] + GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_set_default_threshold(struct futhark_context_config *cfg, int size);|] + +cliOptions :: [Option] +cliOptions = + gpuOptions + ++ [ Option + { optionLongName = "dump-hip", + optionShortName = Nothing, + optionArgument = RequiredArgument "FILE", + optionDescription = "Dump the embedded HIP kernels to the indicated file.", + optionAction = + [C.cstm|{const char* prog = futhark_context_config_get_program(cfg); + if (dump_file(optarg, prog, strlen(prog)) != 0) { + fprintf(stderr, "%s: %s\n", optarg, strerror(errno)); + exit(1); + } + exit(0);}|] + }, + Option + { optionLongName = "load-hip", + optionShortName = Nothing, + optionArgument = RequiredArgument "FILE", + optionDescription = "Instead of using the embedded HIP kernels, load them from the indicated file.", + optionAction = + [C.cstm|{ size_t n; const char *s = slurp_file(optarg, &n); + if (s == NULL) { fprintf(stderr, "%s: %s\n", optarg, strerror(errno)); exit(1); } + futhark_context_config_set_program(cfg, s); + }|] + }, + Option + { optionLongName = "build-option", + optionShortName = Nothing, + optionArgument = RequiredArgument "OPT", + optionDescription = "Add an additional build option to the string passed to NVRTC.", + optionAction = [C.cstm|futhark_context_config_add_build_option(cfg, optarg);|] + }, + Option + { optionLongName = "profile", + optionShortName = Just 'P', + optionArgument = NoArgument, + optionDescription = "Gather profiling data while executing and print out a summary at the end.", + optionAction = [C.cstm|futhark_context_config_set_profiling(cfg, 1);|] + } + ] + +hipMemoryType :: GC.MemoryType OpenCL () +hipMemoryType "device" = pure [C.cty|typename hipDeviceptr_t|] +hipMemoryType space = error $ "GPU backend does not support '" ++ space ++ "' memory space." + +-- | Compile the program to C with calls to HIP. +compileProg :: (MonadFreshNames m) => T.Text -> Prog GPUMem -> m (ImpGen.Warnings, GC.CParts) +compileProg version prog = do + ( ws, + Program hip_code hip_prelude kernels types params failures prog' + ) <- + ImpGen.compileProg prog + (ws,) + <$> GC.compileProg + "hip" + version + params + operations + (mkBoilerplate (hip_prelude <> hip_code) kernels types failures) + hip_includes + (Space "device", [Space "device", DefaultSpace]) + cliOptions + prog' + where + operations :: GC.Operations OpenCL () + operations = + gpuOperations + { GC.opsMemoryType = hipMemoryType + } + hip_includes = + [untrimming| + #define __HIP_PLATFORM_AMD__ + #include + #include + |] 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 @@ -45,7 +45,7 @@ -- | Compile the program to ImpCode with multicore operations. compileProg :: - MonadFreshNames m => T.Text -> Prog MCMem -> m (ImpGen.Warnings, GC.CParts) + (MonadFreshNames m) => T.Text -> Prog MCMem -> m (ImpGen.Warnings, GC.CParts) compileProg version = traverse ( GC.compileProg @@ -122,7 +122,7 @@ [C.csdecl|$ty:defaultMemBlockType $id:(closureRetvalStructField name);|] compileSetStructValues :: - C.ToIdent a => + (C.ToIdent a) => a -> [VName] -> [(C.Type, ValueType)] -> @@ -137,7 +137,7 @@ [C.cstm|$id:struct.$id:(closureFreeStructField name)=$id:name;|] compileSetRetvalStructValues :: - C.ToIdent a => + (C.ToIdent a) => a -> [VName] -> [(C.Type, ValueType)] -> @@ -154,7 +154,7 @@ field name (_, RawMem) = [C.cstms|$id:struct.$id:(closureRetvalStructField name)=$id:name;|] -compileGetRetvalStructVals :: C.ToIdent a => a -> [VName] -> [(C.Type, ValueType)] -> [C.InitGroup] +compileGetRetvalStructVals :: (C.ToIdent a) => a -> [VName] -> [(C.Type, ValueType)] -> [C.InitGroup] compileGetRetvalStructVals struct = zipWith field where field name (ty, Prim pt) = @@ -167,7 +167,7 @@ .size = 0, .references = NULL};|] compileGetStructVals :: - C.ToIdent a => + (C.ToIdent a) => a -> [VName] -> [(C.Type, ValueType)] -> @@ -183,7 +183,7 @@ .mem = $id:struct->$id:(closureFreeStructField name), .size = 0, .references = NULL};|] -compileWriteBackResVals :: C.ToIdent a => a -> [VName] -> [(C.Type, ValueType)] -> [C.Stm] +compileWriteBackResVals :: (C.ToIdent a) => a -> [VName] -> [(C.Type, ValueType)] -> [C.Stm] compileWriteBackResVals struct = zipWith field where field name (_, Prim pt) = @@ -341,7 +341,7 @@ pure s' generateParLoopFn :: - C.ToIdent a => + (C.ToIdent a) => M.Map VName Space -> String -> MCCode -> 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 @@ -61,7 +61,7 @@ -- | Compile the program to C and ISPC code using multicore operations. compileProg :: - MonadFreshNames m => T.Text -> Prog MCMem -> m (ImpGen.Warnings, (GC.CParts, T.Text)) + (MonadFreshNames m) => T.Text -> Prog MCMem -> m (ImpGen.Warnings, (GC.CParts, T.Text)) compileProg version prog = do -- Dynamic scheduling seems completely broken currently, so we disable it. (ws, defs) <- ImpGen.compileProg prog @@ -101,6 +101,7 @@ typedef unsigned int16 uint16_t; typedef unsigned int8 uint8_t; #define volatile +#define SCALAR_FUN_ATTR static inline $errorsH @@ -122,7 +123,9 @@ operations :: GC.Operations Multicore ISPCState operations = MC.operations - { GC.opsCompiler = compileOp + { GC.opsCompiler = compileOp, + -- FIXME: the default codegen for LMAD copies does not work for ISPC. + GC.opsCopies = mempty } ispcDecl :: C.Definition -> ISPCCompilerM () @@ -147,26 +150,6 @@ GC.earlyDecl =<< f s' pure s' --- | Copy memory where one of the operands is using an AoS layout. -copyMemoryAOS :: - PrimType -> - C.Exp -> - C.Exp -> - C.Exp -> - C.Exp -> - C.Exp -> - GC.CompilerM op s () -copyMemoryAOS pt destmem destidx srcmem srcidx nbytes = - GC.stm - [C.cstm|if ($exp:nbytes > 0) { - $id:overload($exp:destmem + $exp:destidx, - $exp:srcmem + $exp:srcidx, - extract($exp:nbytes, 0)); - }|] - where - size = show (8 * primByteSize pt :: Integer) - overload = "memmove_" <> size - -- | ISPC has no string literals, so this makes one in C and exposes it via an -- external function, returning the name. makeStringLiteral :: String -> ISPCCompilerM Name @@ -189,7 +172,7 @@ }|] -- | Unref memory in ISPC -unRefMem :: C.ToExp a => a -> Space -> ISPCCompilerM () +unRefMem :: (C.ToExp a) => a -> Space -> ISPCCompilerM () unRefMem mem space = do cached <- isJust <$> GC.cacheMem mem let mem_s = T.unpack $ expText $ C.toExp mem noLoc @@ -552,16 +535,20 @@ dest' <- GC.rawMem dest idxexp <- compileExp $ constFoldPrimExp $ untyped idx deref <- - GC.derefPointer dest' [C.cexp|($tyquals:([varying]) typename int64_t)$exp:idxexp|] + GC.derefPointer + dest' + [C.cexp|($tyquals:([varying]) typename int64_t)$exp:idxexp|] <$> getMemType dest elemtype elemexp' <- toStorage elemtype <$> compileExp elemexp GC.stm [C.cstm|$exp:deref = $exp:elemexp';|] | otherwise = do dest' <- GC.rawMem dest + idxexp <- compileExp $ untyped idx deref <- - GC.derefPointer dest' - <$> compileExp (untyped idx) - <*> getMemType dest elemtype + GC.derefPointer + dest' + [C.cexp|($tyquals:([varying]) typename int64_t)$exp:idxexp|] + <$> getMemType dest elemtype elemexp' <- toStorage elemtype <$> compileExp elemexp GC.stm [C.cstm|$exp:deref = $exp:elemexp';|] where @@ -576,19 +563,19 @@ <$> compileExp (untyped iexp) <*> getMemType src restype GC.stm [C.cstm|$id:x = $exp:e;|] -compileCode code@(Copy pt dest (Count destoffset) DefaultSpace src (Count srcoffset) DefaultSpace (Count size)) = do - dm <- isJust <$> GC.cacheMem dest - sm <- isJust <$> GC.cacheMem src - if dm || sm - then - join $ - copyMemoryAOS pt - <$> GC.rawMem dest - <*> compileExp (untyped destoffset) - <*> GC.rawMem src - <*> compileExp (untyped srcoffset) - <*> compileExp (untyped size) - else GC.compileCode code +compileCode (LMADCopy t shape (dst, DefaultSpace) dst_lmad (src, DefaultSpace) src_lmad) = do + dst' <- GC.rawMem dst + src' <- GC.rawMem src + let doWrite dst_i ve = do + deref <- + GC.derefPointer + dst' + [C.cexp|($tyquals:([varying]) typename int64_t)$exp:dst_i|] + <$> getMemType dst t + GC.stm [C.cstm|$exp:deref = $exp:(toStorage t ve);|] + doRead src_i = + fromStorage t . GC.derefPointer src' src_i <$> getMemType src t + GC.compileLMADCopyWith shape doWrite dst_lmad doRead src_lmad compileCode (Free name space) = do cached <- isJust <$> GC.cacheMem name unless cached $ unRefMem name space diff --git a/src/Futhark/CodeGen/Backends/MulticoreWASM.hs b/src/Futhark/CodeGen/Backends/MulticoreWASM.hs --- a/src/Futhark/CodeGen/Backends/MulticoreWASM.hs +++ b/src/Futhark/CodeGen/Backends/MulticoreWASM.hs @@ -37,7 +37,7 @@ -- -- * Options that should be passed to @emcc@. compileProg :: - MonadFreshNames m => + (MonadFreshNames m) => T.Text -> Prog MCMem -> m (ImpGen.Warnings, (GC.CParts, T.Text, [String])) diff --git a/src/Futhark/CodeGen/Backends/PyOpenCL.hs b/src/Futhark/CodeGen/Backends/PyOpenCL.hs --- a/src/Futhark/CodeGen/Backends/PyOpenCL.hs +++ b/src/Futhark/CodeGen/Backends/PyOpenCL.hs @@ -7,10 +7,12 @@ import Control.Monad import Data.Map qualified as M import Data.Text qualified as T -import Futhark.CodeGen.Backends.GenericPython qualified as Py +import Futhark.CodeGen.Backends.GenericPython hiding (compileProg) +import Futhark.CodeGen.Backends.GenericPython qualified as GP import Futhark.CodeGen.Backends.GenericPython.AST import Futhark.CodeGen.Backends.GenericPython.Options import Futhark.CodeGen.Backends.PyOpenCL.Boilerplate +import Futhark.CodeGen.ImpCode (Count (..)) import Futhark.CodeGen.ImpCode.OpenCL qualified as Imp import Futhark.CodeGen.ImpGen.OpenCL qualified as ImpGen import Futhark.CodeGen.RTS.Python (openclPy) @@ -21,8 +23,8 @@ -- | Compile the program to Python with calls to OpenCL. compileProg :: - MonadFreshNames m => - Py.CompilerMode -> + (MonadFreshNames m) => + CompilerMode -> String -> Prog GPUMem -> m (ImpGen.Warnings, T.Text) @@ -73,7 +75,7 @@ ] let constructor = - Py.Constructor + Constructor [ "self", "build_options=build_options", "command_queue=None", @@ -169,7 +171,7 @@ ] (ws,) - <$> Py.compileProg + <$> GP.compileProg mode class_name constructor @@ -177,26 +179,29 @@ defines operations () - [Exp $ Py.simpleCall "sync" [Var "self"]] + [Exp $ simpleCall "sync" [Var "self"]] options prog' where - operations :: Py.Operations Imp.OpenCL () + operations :: Operations Imp.OpenCL () operations = - Py.Operations - { Py.opsCompiler = callKernel, - Py.opsWriteScalar = writeOpenCLScalar, - Py.opsReadScalar = readOpenCLScalar, - Py.opsAllocate = allocateOpenCLBuffer, - Py.opsCopy = copyOpenCLMemory, - Py.opsEntryOutput = packArrayOutput, - Py.opsEntryInput = unpackArrayInput + Operations + { opsCompiler = callKernel, + opsWriteScalar = writeOpenCLScalar, + opsReadScalar = readOpenCLScalar, + opsAllocate = allocateOpenCLBuffer, + opsCopy = copyOpenCLMemory, + opsCopies = + M.insert (Imp.Space "device", Imp.Space "device") copygpu2gpu $ + opsCopies defaultOperations, + opsEntryOutput = packArrayOutput, + opsEntryInput = unpackArrayInput } -- We have many casts to 'long', because PyOpenCL may get confused at -- the 32-bit numbers that ImpCode uses for offsets and the like. asLong :: PyExp -> PyExp -asLong x = Py.simpleCall "np.int64" [x] +asLong x = simpleCall "np.int64" [x] kernelConstToExp :: Imp.KernelConst -> PyExp kernelConstToExp (Imp.SizeConst key) = @@ -204,37 +209,37 @@ kernelConstToExp (Imp.SizeMaxConst size_class) = Var $ "self.max_" <> prettyString size_class -compileGroupDim :: Imp.GroupDim -> Py.CompilerM op s PyExp -compileGroupDim (Left e) = asLong <$> Py.compileExp e +compileGroupDim :: Imp.GroupDim -> CompilerM op s PyExp +compileGroupDim (Left e) = asLong <$> compileExp e compileGroupDim (Right kc) = pure $ kernelConstToExp kc -callKernel :: Py.OpCompiler Imp.OpenCL () +callKernel :: OpCompiler Imp.OpenCL () callKernel (Imp.GetSize v key) = do - v' <- Py.compileVar v - Py.stm $ Assign v' $ kernelConstToExp $ Imp.SizeConst key + v' <- compileVar v + stm $ Assign v' $ kernelConstToExp $ Imp.SizeConst key callKernel (Imp.CmpSizeLe v key x) = do - v' <- Py.compileVar v - x' <- Py.compileExp x - Py.stm $ + v' <- compileVar v + x' <- compileExp x + stm $ Assign v' $ BinOp "<=" (kernelConstToExp (Imp.SizeConst key)) x' callKernel (Imp.GetSizeMax v size_class) = do - v' <- Py.compileVar v - Py.stm $ Assign v' $ kernelConstToExp $ Imp.SizeMaxConst size_class -callKernel (Imp.LaunchKernel safety name args num_workgroups workgroup_size) = do - num_workgroups' <- mapM (fmap asLong . Py.compileExp) num_workgroups + v' <- compileVar v + stm $ Assign v' $ kernelConstToExp $ Imp.SizeMaxConst size_class +callKernel (Imp.LaunchKernel safety name local_memory args num_workgroups workgroup_size) = do + num_workgroups' <- mapM (fmap asLong . compileExp) num_workgroups workgroup_size' <- mapM compileGroupDim workgroup_size let kernel_size = zipWith mult_exp num_workgroups' workgroup_size' total_elements = foldl mult_exp (Integer 1) kernel_size cond = BinOp "!=" total_elements (Integer 0) - - body <- Py.collect $ launchKernel name safety kernel_size workgroup_size' args - Py.stm $ If cond body [] + local_memory' <- compileExp $ Imp.untyped $ Imp.unCount local_memory + body <- collect $ launchKernel name safety kernel_size workgroup_size' local_memory' args + stm $ If cond body [] when (safety >= Imp.SafetyFull) $ - Py.stm $ + stm $ Assign (Var "self.failure_is_an_option") $ - Py.compilePrimValue (Imp.IntValue (Imp.Int32Value 1)) + compilePrimValue (Imp.IntValue (Imp.Int32Value 1)) where mult_exp = BinOp "*" @@ -243,9 +248,10 @@ Imp.KernelSafety -> [PyExp] -> [PyExp] -> + PyExp -> [Imp.KernelArg] -> - Py.CompilerM op s () -launchKernel kernel_name safety kernel_dims workgroup_dims args = do + CompilerM op s () +launchKernel kernel_name safety kernel_dims workgroup_dims local_memory args = do let kernel_dims' = Tuple kernel_dims workgroup_dims' = Tuple workgroup_dims kernel_name' = "self." <> zEncodeText (nameToText kernel_name) <> "_var" @@ -257,45 +263,41 @@ Var "self.failure_is_an_option", Var "self.global_failure_args" ] - Py.stm $ - Exp $ - Py.simpleCall (T.unpack $ kernel_name' <> ".set_args") $ - failure_args ++ args' - Py.stm $ - Exp $ - Py.simpleCall - "cl.enqueue_nd_range_kernel" - [Var "self.queue", Var (T.unpack kernel_name'), kernel_dims', workgroup_dims'] + stm . Exp $ + simpleCall (T.unpack $ kernel_name' <> ".set_args") $ + [simpleCall "cl.LocalMemory" [simpleCall "max" [local_memory, Integer 1]]] + ++ failure_args + ++ args' + stm . Exp $ + simpleCall + "cl.enqueue_nd_range_kernel" + [Var "self.queue", Var (T.unpack kernel_name'), kernel_dims', workgroup_dims'] finishIfSynchronous where - processKernelArg :: Imp.KernelArg -> Py.CompilerM op s PyExp - processKernelArg (Imp.ValueKArg e bt) = - Py.toStorage bt <$> Py.compileExp e - processKernelArg (Imp.MemKArg v) = Py.compileVar v - processKernelArg (Imp.SharedMemoryKArg (Imp.Count num_bytes)) = do - num_bytes' <- Py.compileExp num_bytes - pure $ Py.simpleCall "cl.LocalMemory" [asLong num_bytes'] + processKernelArg :: Imp.KernelArg -> CompilerM op s PyExp + processKernelArg (Imp.ValueKArg e bt) = toStorage bt <$> compileExp e + processKernelArg (Imp.MemKArg v) = compileVar v -writeOpenCLScalar :: Py.WriteScalar Imp.OpenCL () +writeOpenCLScalar :: WriteScalar Imp.OpenCL () writeOpenCLScalar mem i bt "device" val = do let nparr = Call (Var "np.array") - [Arg val, ArgKeyword "dtype" $ Var $ Py.compilePrimType bt] - Py.stm $ + [Arg val, ArgKeyword "dtype" $ Var $ compilePrimType bt] + stm $ Exp $ Call (Var "cl.enqueue_copy") [ Arg $ Var "self.queue", Arg mem, Arg nparr, - ArgKeyword "device_offset" $ BinOp "*" (asLong i) (Integer $ Imp.primByteSize bt), + ArgKeyword "dst_offset" $ BinOp "*" (asLong i) (Integer $ Imp.primByteSize bt), ArgKeyword "is_blocking" $ Var "synchronous" ] writeOpenCLScalar _ _ _ space _ = error $ "Cannot write to '" ++ space ++ "' memory space." -readOpenCLScalar :: Py.ReadScalar Imp.OpenCL () +readOpenCLScalar :: ReadScalar Imp.OpenCL () readOpenCLScalar mem i bt "device" = do val <- newVName "read_res" let val' = Var $ prettyString val @@ -303,38 +305,38 @@ Call (Var "np.empty") [ Arg $ Integer 1, - ArgKeyword "dtype" (Var $ Py.compilePrimType bt) + ArgKeyword "dtype" (Var $ compilePrimType bt) ] - Py.stm $ Assign val' nparr - Py.stm $ + stm $ Assign val' nparr + stm $ Exp $ Call (Var "cl.enqueue_copy") [ Arg $ Var "self.queue", Arg val', Arg mem, - ArgKeyword "device_offset" $ BinOp "*" (asLong i) (Integer $ Imp.primByteSize bt), + ArgKeyword "src_offset" $ BinOp "*" (asLong i) (Integer $ Imp.primByteSize bt), ArgKeyword "is_blocking" $ Var "synchronous" ] - Py.stm $ Exp $ Py.simpleCall "sync" [Var "self"] + stm $ Exp $ simpleCall "sync" [Var "self"] pure $ Index val' $ IdxExp $ Integer 0 readOpenCLScalar _ _ _ space = error $ "Cannot read from '" ++ space ++ "' memory space." -allocateOpenCLBuffer :: Py.Allocate Imp.OpenCL () +allocateOpenCLBuffer :: Allocate Imp.OpenCL () allocateOpenCLBuffer mem size "device" = - Py.stm $ + stm $ Assign mem $ - Py.simpleCall "opencl_alloc" [Var "self", size, String $ prettyText mem] + simpleCall "opencl_alloc" [Var "self", size, String $ prettyText mem] allocateOpenCLBuffer _ _ space = error $ "Cannot allocate in '" ++ space ++ "' space" -copyOpenCLMemory :: Py.Copy Imp.OpenCL () +copyOpenCLMemory :: Copy Imp.OpenCL () copyOpenCLMemory destmem destidx Imp.DefaultSpace srcmem srcidx (Imp.Space "device") nbytes bt = do let divide = BinOp "//" nbytes (Integer $ Imp.primByteSize bt) end = BinOp "+" destidx divide dest = Index destmem (IdxRange destidx end) - Py.stm $ + stm $ ifNotZeroSize nbytes $ Exp $ Call @@ -347,8 +349,8 @@ ] copyOpenCLMemory destmem destidx (Imp.Space "device") srcmem srcidx Imp.DefaultSpace nbytes _ = do let end = BinOp "+" srcidx nbytes - src = Index (Py.simpleCall "createArray" [srcmem, List [nbytes], Var "np.byte"]) (IdxRange srcidx end) - Py.stm $ + src = Index (simpleCall "createArray" [srcmem, List [nbytes], Var "np.byte"]) (IdxRange srcidx end) + stm $ ifNotZeroSize nbytes $ Exp $ Call @@ -360,7 +362,7 @@ ArgKeyword "is_blocking" $ Var "synchronous" ] copyOpenCLMemory destmem destidx (Imp.Space "device") srcmem srcidx (Imp.Space "device") nbytes _ = do - Py.stm $ + stm $ ifNotZeroSize nbytes $ Exp $ Call @@ -368,48 +370,48 @@ [ Arg $ Var "self.queue", Arg destmem, Arg srcmem, - ArgKeyword "dest_offset" $ asLong destidx, + ArgKeyword "dst_offset" $ asLong destidx, ArgKeyword "src_offset" $ asLong srcidx, ArgKeyword "byte_count" $ asLong nbytes ] finishIfSynchronous copyOpenCLMemory destmem destidx Imp.DefaultSpace srcmem srcidx Imp.DefaultSpace nbytes _ = - Py.copyMemoryDefaultSpace destmem destidx srcmem srcidx nbytes + copyMemoryDefaultSpace destmem destidx srcmem srcidx nbytes copyOpenCLMemory _ _ destspace _ _ srcspace _ _ = error $ "Cannot copy to " ++ show destspace ++ " from " ++ show srcspace -packArrayOutput :: Py.EntryOutput Imp.OpenCL () +packArrayOutput :: EntryOutput Imp.OpenCL () packArrayOutput mem "device" bt ept dims = do - mem' <- Py.compileVar mem - dims' <- mapM Py.compileDim dims + mem' <- compileVar mem + dims' <- mapM compileDim dims pure $ Call (Var "cl.array.Array") [ Arg $ Var "self.queue", Arg $ Tuple $ dims' <> [Integer 0 | bt == Imp.Unit], - Arg $ Var $ Py.compilePrimToExtNp bt ept, + Arg $ Var $ compilePrimToExtNp bt ept, ArgKeyword "data" mem' ] packArrayOutput _ sid _ _ _ = error $ "Cannot return array from " ++ sid ++ " space." -unpackArrayInput :: Py.EntryInput Imp.OpenCL () +unpackArrayInput :: EntryInput Imp.OpenCL () unpackArrayInput mem "device" t s dims e = do let type_is_ok = BinOp "and" - (BinOp "in" (Py.simpleCall "type" [e]) (List [Var "np.ndarray", Var "cl.array.Array"])) - (BinOp "==" (Field e "dtype") (Var (Py.compilePrimToExtNp t s))) - Py.stm $ Assert type_is_ok $ String "Parameter has unexpected type" + (BinOp "in" (simpleCall "type" [e]) (List [Var "np.ndarray", Var "cl.array.Array"])) + (BinOp "==" (Field e "dtype") (Var (compilePrimToExtNp t s))) + stm $ Assert type_is_ok $ String "Parameter has unexpected type" - zipWithM_ (Py.unpackDim e) dims [0 ..] + zipWithM_ (unpackDim e) dims [0 ..] - let memsize' = Py.simpleCall "np.int64" [Field e "nbytes"] + let memsize' = simpleCall "np.int64" [Field e "nbytes"] pyOpenCLArrayCase = [Assign mem $ Field e "data"] - numpyArrayCase <- Py.collect $ do + numpyArrayCase <- collect $ do allocateOpenCLBuffer mem memsize' "device" - Py.stm $ + stm $ ifNotZeroSize memsize' $ Exp $ Call @@ -420,9 +422,9 @@ ArgKeyword "is_blocking" $ Var "synchronous" ] - Py.stm $ + stm $ If - (BinOp "==" (Py.simpleCall "type" [e]) (Var "cl.array.Array")) + (BinOp "==" (simpleCall "type" [e]) (Var "cl.array.Array")) pyOpenCLArrayCase numpyArrayCase unpackArrayInput _ sid _ _ _ _ = @@ -432,6 +434,20 @@ ifNotZeroSize e s = If (BinOp "!=" e (Integer 0)) [s] [] -finishIfSynchronous :: Py.CompilerM op s () +finishIfSynchronous :: CompilerM op s () finishIfSynchronous = - Py.stm $ If (Var "synchronous") [Exp $ Py.simpleCall "sync" [Var "self"]] [] + stm $ If (Var "synchronous") [Exp $ simpleCall "sync" [Var "self"]] [] + +copygpu2gpu :: DoLMADCopy op s +copygpu2gpu t shape dst (dstoffset, dststride) src (srcoffset, srcstride) = do + stm . Exp . simpleCall "lmad_copy_gpu2gpu" $ + [ Var "self", + Var (compilePrimType t), + dst, + unCount dstoffset, + List (map unCount dststride), + src, + unCount srcoffset, + List (map unCount srcstride), + List (map unCount shape) + ] diff --git a/src/Futhark/CodeGen/Backends/SequentialC.hs b/src/Futhark/CodeGen/Backends/SequentialC.hs --- a/src/Futhark/CodeGen/Backends/SequentialC.hs +++ b/src/Futhark/CodeGen/Backends/SequentialC.hs @@ -20,7 +20,7 @@ import Futhark.MonadFreshNames -- | Compile the program to sequential C. -compileProg :: MonadFreshNames m => T.Text -> Prog SeqMem -> m (ImpGen.Warnings, GC.CParts) +compileProg :: (MonadFreshNames m) => T.Text -> Prog SeqMem -> m (ImpGen.Warnings, GC.CParts) compileProg version = traverse ( GC.compileProg diff --git a/src/Futhark/CodeGen/Backends/SequentialPython.hs b/src/Futhark/CodeGen/Backends/SequentialPython.hs --- a/src/Futhark/CodeGen/Backends/SequentialPython.hs +++ b/src/Futhark/CodeGen/Backends/SequentialPython.hs @@ -15,7 +15,7 @@ -- | Compile the program to Python. compileProg :: - MonadFreshNames m => + (MonadFreshNames m) => GenericPython.CompilerMode -> String -> Prog SeqMem -> diff --git a/src/Futhark/CodeGen/Backends/SequentialWASM.hs b/src/Futhark/CodeGen/Backends/SequentialWASM.hs --- a/src/Futhark/CodeGen/Backends/SequentialWASM.hs +++ b/src/Futhark/CodeGen/Backends/SequentialWASM.hs @@ -35,7 +35,7 @@ -- file by itself). -- -- * Options that should be passed to @emcc@. -compileProg :: MonadFreshNames m => T.Text -> Prog SeqMem -> m (ImpGen.Warnings, (GC.CParts, T.Text, [String])) +compileProg :: (MonadFreshNames m) => T.Text -> Prog SeqMem -> m (ImpGen.Warnings, (GC.CParts, T.Text, [String])) compileProg version prog = do (ws, prog') <- ImpGen.compileProg prog 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 @@ -28,9 +28,9 @@ -- ImpCode does not have arrays. 'DeclareArray' is for declaring -- constant array literals, not arrays in general. Instead, ImpCode -- deals only with memory. Array operations present in core IR --- programs are turned into 'Write', v'Read', and 'Copy' operations --- that use flat indexes and offsets based on the index function of --- the original array. +-- programs are turned into 'Write', v'Read', and 'LMADCopy' +-- operations that use flat indexes and offsets based on the index +-- function of the original array. -- -- == Scoping -- @@ -73,6 +73,7 @@ ArrayContents (..), declaredIn, lexicalMemoryUsage, + declsFirst, calledFuncs, callGraph, ParamMap, @@ -98,7 +99,7 @@ where import Data.Bifunctor (second) -import Data.List (intersperse) +import Data.List (intersperse, partition) import Data.Map qualified as M import Data.Ord (comparing) import Data.Set qualified as S @@ -279,18 +280,18 @@ -- all memory blocks will be freed with this statement. -- Backends are free to ignore it entirely. Free VName Space - | -- | Element type being copied, destination, offset in - -- destination, destination space, source, offset in source, - -- offset space, number of bytes. - Copy + | -- | @LMADcopy pt dest dest_lmad src src_lmad shape@ + LMADCopy PrimType - VName - (Count Bytes (TExp Int64)) - Space - VName - (Count Bytes (TExp Int64)) - Space - (Count Bytes (TExp Int64)) + [Count Elements (TExp Int64)] + (VName, Space) + ( Count Elements (TExp Int64), + [Count Elements (TExp Int64)] + ) + (VName, Space) + ( Count Elements (TExp Int64), + [Count Elements (TExp Int64)] + ) | -- | @Write mem i t space vol v@ writes the value @v@ to -- @mem@ offset by @i@ elements of type @t@. The -- 'Space' argument is the memory space of @mem@ @@ -384,6 +385,21 @@ onArg (MemArg x) = oneName x set x = go set x +-- | Reorder the code such that all declarations appear first. This +-- is always possible, because 'DeclareScalar' and 'DeclareMem' do +-- not depend on any local bindings. +declsFirst :: Code a -> Code a +declsFirst = mconcat . uncurry (<>) . partition isDecl . listify + where + listify (c1 :>>: c2) = listify c1 <> listify c2 + listify (If cond c1 c2) = [If cond (declsFirst c1) (declsFirst c2)] + listify (For i e c) = [For i e (declsFirst c)] + listify (While cond c) = [While cond (declsFirst c)] + listify c = [c] + isDecl (DeclareScalar {}) = True + isDecl (DeclareMem {}) = True + isDecl _ = False + -- | The set of functions that are called by this code. Accepts a -- function for determing function calls in 'Op's. calledFuncs :: (a -> S.Set Name) -> Code a -> S.Set Name @@ -449,17 +465,17 @@ -- Prettyprinting definitions. -instance Pretty op => Pretty (Definitions op) where +instance (Pretty op) => Pretty (Definitions op) where pretty (Definitions types consts funs) = pretty types pretty consts pretty funs -instance Pretty op => Pretty (Functions op) where +instance (Pretty op) => Pretty (Functions op) where pretty (Functions funs) = stack $ intersperse mempty $ map ppFun funs where ppFun (name, fun) = "Function " <> pretty name <> colon indent 2 (pretty fun) -instance Pretty op => Pretty (Constants op) where +instance (Pretty op) => Pretty (Constants op) where pretty (Constants decls code) = "Constants:" indent 2 (stack $ map pretty decls) @@ -479,7 +495,7 @@ ppArg ((p, u), t) = pretty p <+> ":" <+> ppRes (u, t) ppRes (u, t) = pretty u <> pretty t -instance Pretty op => Pretty (FunctionT op) where +instance (Pretty op) => Pretty (FunctionT op) where pretty (Function entry outs ins body) = "Inputs:" indent 2 (stack $ map pretty ins) @@ -520,7 +536,7 @@ pretty (ArrayValues vs) = braces (commasep $ map pretty vs) pretty (ArrayZeros n) = braces "0" <+> "*" <+> pretty n -instance Pretty op => Pretty (Code op) where +instance (Pretty op) => Pretty (Code op) where pretty (Op op) = pretty op pretty Skip = "skip" pretty (c1 :>>: c2) = pretty c1 pretty c2 @@ -581,17 +597,19 @@ pretty dest <+> "<-" <+> pretty from <+> "@" <> pretty space pretty (Assert e msg _) = "assert" <> parens (commasep [pretty msg, pretty e]) - pretty (Copy t dest destoffset destspace src srcoffset srcspace size) = - "copy" + pretty (LMADCopy t shape (dst, dstspace) (dstoffset, dststrides) (src, srcspace) (srcoffset, srcstrides)) = + ("lmadcopy_" <> pretty (length shape) <> "d_" <> pretty t) <> (parens . align) - ( pretty t <> comma - ppMemLoc dest destoffset <> pretty destspace <> comma - ppMemLoc src srcoffset <> pretty srcspace <> comma - pretty size + ( foldMap (brackets . pretty) shape + <> "," + p dst dstspace dstoffset dststrides + <> "," + p src srcspace srcoffset srcstrides ) where - ppMemLoc base offset = - pretty base <+> "+" <+> pretty offset + p mem space offset strides = + pretty mem <> pretty space <> "+" <> pretty offset + <+> foldMap (brackets . pretty) strides pretty (If cond tbranch fbranch) = "if" <+> pretty cond @@ -673,8 +691,8 @@ pure $ Allocate name size s traverse _ (Free name space) = pure $ Free name space - traverse _ (Copy dest pt destoffset destspace src srcoffset srcspace size) = - pure $ Copy dest pt destoffset destspace src srcoffset srcspace size + traverse _ (LMADCopy t shape (dst, dstspace) (dstoffset, dststrides) (src, srcspace) (srcoffset, srcstrides)) = + pure $ LMADCopy t shape (dst, dstspace) (dstoffset, dststrides) (src, srcspace) (srcoffset, srcstrides) traverse _ (Write name i bt val space vol) = pure $ Write name i bt val space vol traverse _ (Read x name i bt space vol) = @@ -711,7 +729,7 @@ freeIn' (EntryPoint _ res args) = freeIn' (map snd res) <> freeIn' (map snd args) -instance FreeIn a => FreeIn (Functions a) where +instance (FreeIn a) => FreeIn (Functions a) where freeIn' (Functions fs) = foldMap (onFun . snd) fs where onFun f = @@ -728,7 +746,7 @@ freeIn' (TransparentValue vd) = freeIn' vd freeIn' (OpaqueValue _ vds) = foldMap freeIn' vds -instance FreeIn a => FreeIn (Code a) where +instance (FreeIn a) => FreeIn (Code a) where freeIn' (x :>>: y) = fvBind (declaredIn x) $ freeIn' x <> freeIn' y freeIn' Skip = @@ -747,8 +765,8 @@ freeIn' name <> freeIn' size <> freeIn' space freeIn' (Free name _) = freeIn' name - freeIn' (Copy _ dest x _ src y _ n) = - freeIn' dest <> freeIn' x <> freeIn' src <> freeIn' y <> freeIn' n + freeIn' (LMADCopy _ shape (dst, _) (dstoffset, dststrides) (src, _) (srcoffset, srcstrides)) = + freeIn' shape <> freeIn' dst <> freeIn' dstoffset <> freeIn' dststrides <> freeIn' src <> freeIn' srcoffset <> freeIn' srcstrides freeIn' (SetMem x y _) = freeIn' x <> freeIn' y freeIn' (Write v i _ _ _ e) = diff --git a/src/Futhark/CodeGen/ImpCode/OpenCL.hs b/src/Futhark/CodeGen/ImpCode/OpenCL.hs --- a/src/Futhark/CodeGen/ImpCode/OpenCL.hs +++ b/src/Futhark/CodeGen/ImpCode/OpenCL.hs @@ -64,8 +64,6 @@ ValueKArg Exp PrimType | -- | Pass this pointer as argument. MemKArg VName - | -- | Create this much local memory per workgroup. - SharedMemoryKArg (Count Bytes Exp) deriving (Show) -- | Whether a kernel can potentially fail (because it contains bounds @@ -95,7 +93,7 @@ -- | Host-level OpenCL operation. data OpenCL - = LaunchKernel KernelSafety KernelName [KernelArg] [Exp] [GroupDim] + = LaunchKernel KernelSafety KernelName (Count Bytes (TExp Int64)) [KernelArg] [Exp] [GroupDim] | GetSize VName Name | CmpSizeLe VName Name Exp | GetSizeMax VName SizeClass @@ -105,6 +103,7 @@ data KernelTarget = TargetOpenCL | TargetCUDA + | TargetHIP deriving (Eq) instance Pretty OpenCL where 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 @@ -70,10 +70,9 @@ copy, copyDWIM, copyDWIMFix, - copyElementWise, + lmadCopy, typeSize, inBounds, - isMapTransposeCopy, caseMatch, -- * Constructing code. @@ -108,7 +107,6 @@ sWrite, sUpdate, sLoopNest, - sCopy, sLoopSpace, (<--), (<~~), @@ -137,12 +135,9 @@ ( Bytes, Count, Elements, - bytes, elements, - withElemType, ) import Futhark.CodeGen.ImpCode qualified as Imp -import Futhark.CodeGen.ImpGen.Transpose import Futhark.Construct hiding (ToExp (..)) import Futhark.IR.Mem import Futhark.IR.Mem.IxFun qualified as IxFun @@ -192,7 +187,7 @@ { opsExpCompiler = defCompileExp, opsOpCompiler = opc, opsStmsCompiler = defCompileStms, - opsCopyCompiler = defaultCopy, + opsCopyCompiler = lmadCopy, opsAllocCompilers = mempty } @@ -200,17 +195,17 @@ data MemLoc = MemLoc { memLocName :: VName, memLocShape :: [Imp.DimSize], - memLocIxFun :: IxFun.IxFun (Imp.TExp Int64) + memLocLMAD :: LMAD.LMAD (Imp.TExp Int64) } deriving (Eq, Show) sliceMemLoc :: MemLoc -> Slice (Imp.TExp Int64) -> MemLoc -sliceMemLoc (MemLoc mem shape ixfun) slice = - MemLoc mem shape $ IxFun.slice ixfun slice +sliceMemLoc (MemLoc mem shape lmad) slice = + MemLoc mem shape $ LMAD.slice lmad slice -flatSliceMemLoc :: MemLoc -> FlatSlice (Imp.TExp Int64) -> Maybe MemLoc -flatSliceMemLoc (MemLoc mem shape ixfun) slice = - MemLoc mem shape <$> IxFun.flatSlice ixfun slice +flatSliceMemLoc :: MemLoc -> FlatSlice (Imp.TExp Int64) -> MemLoc +flatSliceMemLoc (MemLoc mem shape lmad) slice = + MemLoc mem shape $ LMAD.flatSlice lmad slice data ArrayEntry = ArrayEntry { entryArrayLoc :: MemLoc, @@ -411,7 +406,7 @@ warnings ws = modify $ \s -> s {stateWarnings = ws <> stateWarnings s} -- | Emit a warning about something the user should be aware of. -warn :: Located loc => loc -> [loc] -> T.Text -> ImpM rep r op () +warn :: (Located loc) => loc -> [loc] -> T.Text -> ImpM rep r op () warn loc locs problem = warnings $ singleWarning' (srclocOf loc) (map srclocOf locs) (pretty problem) @@ -427,7 +422,7 @@ let Imp.Functions fs = stateFunctions s in isJust $ lookup fname fs -constsVTable :: Mem rep inner => Stms rep -> VTable rep +constsVTable :: (Mem rep inner) => Stms rep -> VTable rep constsVTable = foldMap stmVtable where stmVtable (Let pat _ e) = @@ -511,7 +506,7 @@ OpaqueRecord fs -> sum $ map (entryPointSize types . snd) fs compileInParam :: - Mem rep inner => + (Mem rep inner) => FParam rep -> ImpM rep r op (Either Imp.Param ArrayDecl) compileInParam fparam = case paramDec fparam of @@ -519,8 +514,8 @@ pure $ Left $ Imp.ScalarParam name bt MemMem space -> pure $ Left $ Imp.MemParam name space - MemArray bt shape _ (ArrayIn mem ixfun) -> - pure $ Right $ ArrayDecl name bt $ MemLoc mem (shapeDims shape) ixfun + MemArray bt shape _ (ArrayIn mem lmad) -> + pure $ Right $ ArrayDecl name bt $ MemLoc mem (shapeDims shape) $ IxFun.ixfunLMAD lmad MemAcc {} -> error "Functions may not have accumulator parameters." where @@ -529,7 +524,7 @@ data ArrayDecl = ArrayDecl VName PrimType MemLoc compileInParams :: - Mem rep inner => + (Mem rep inner) => OpaqueTypes -> [FParam rep] -> Maybe [EntryParam] -> @@ -601,7 +596,7 @@ error "Functions may not return accumulators." compileExternalValues :: - Mem rep inner => + (Mem rep inner) => OpaqueTypes -> [RetType rep] -> [EntryResult] -> @@ -621,9 +616,9 @@ mkValueDesc _ signedness (MemArray t shape _ ret) = do (mem, space) <- case ret of - ReturnsNewBlock space j _ixfun -> + ReturnsNewBlock space j _lmad -> pure (nthOut j, space) - ReturnsInBlock mem _ixfun -> do + ReturnsInBlock mem _lmad -> do space <- entryMemSpace <$> lookupMemory mem pure (mem, space) pure $ Imp.ArrayValue mem space t signedness $ map f $ shapeDims shape @@ -651,7 +646,7 @@ mkExts (length ctx_rts) orig_epts val_rts compileOutParams :: - Mem rep inner => + (Mem rep inner) => OpaqueTypes -> [RetType rep] -> Maybe [EntryResult] -> @@ -665,7 +660,7 @@ pure (evs, catMaybes maybe_params, dests) compileFunDef :: - Mem rep inner => + (Mem rep inner) => OpaqueTypes -> FunDef rep -> ImpM rep r op () @@ -708,7 +703,7 @@ forM_ (zip params ses) $ \(param, SubExpRes _ se) -> copyDWIM (paramName param) [] se [] -compileLoopBody :: Typed dec => [Param dec] -> Body rep -> ImpM rep r op () +compileLoopBody :: (Typed dec) => [Param dec] -> Body rep -> ImpM rep r op () compileLoopBody mergeparams (Body _ stms ses) = do -- We cannot write the results to the merge parameters immediately, -- as some of the results may actually *be* merge parameters, and @@ -811,7 +806,7 @@ (Var v, Mem {}) -> pure $ Just $ Imp.MemArg v _ -> pure Nothing defCompileExp pat (BasicOp op) = defCompileBasicOp pat op -defCompileExp pat (DoLoop merge form body) = do +defCompileExp pat (Loop merge form body) = do attrs <- askAttrs when ("unroll" `inAttrs` attrs) $ warn (noLoc :: SrcLoc) [] "#[unroll] on loop with unknown number of iterations." -- FIXME: no location. @@ -874,7 +869,7 @@ emit . Imp.TracePrint $ ErrorMsg ["\n"] defCompileBasicOp :: - Mem rep inner => + (Mem rep inner) => Pat (LetDec rep) -> BasicOp -> ImpM rep r op () @@ -932,11 +927,8 @@ defCompileBasicOp (Pat [pe]) (FlatUpdate _ slice v) = do pe_loc <- entryArrayLoc <$> lookupArray (patElemName pe) v_loc <- entryArrayLoc <$> lookupArray v - case flatSliceMemLoc pe_loc slice' of - Just pe_loc' -> copy (elemType (patElemType pe)) pe_loc' v_loc - Nothing -> error "defCompileBasicOp FlatUpdate" - where - slice' = fmap pe64 slice + let pe_loc' = flatSliceMemLoc pe_loc $ fmap pe64 slice + copy (elemType (patElemType pe)) pe_loc' v_loc defCompileBasicOp (Pat [pe]) (Replicate shape se) | Acc {} <- patElemType pe = pure () | shape == mempty = @@ -979,7 +971,7 @@ emit $ Imp.DeclareArray static_array t $ Imp.ArrayValues vs let static_src = MemLoc static_array [intConst Int64 $ fromIntegral $ length es] $ - IxFun.iota [fromIntegral $ length es] + LMAD.iota 0 [fromIntegral $ length es] addVar static_array $ MemVar Nothing $ MemEntry DefaultSpace copy t dest_mem static_src | otherwise = @@ -1047,7 +1039,7 @@ -- | Like 'dFParams', but does not create new declarations. -- Note: a hack to be used only for functions. -addFParams :: Mem rep inner => [FParam rep] -> ImpM rep r op () +addFParams :: (Mem rep inner) => [FParam rep] -> ImpM rep r op () addFParams = mapM_ addFParam where addFParam fparam = @@ -1061,7 +1053,7 @@ addLoopVar i it = addVar i $ ScalarVar Nothing $ ScalarEntry $ IntType it dVars :: - Mem rep inner => + (Mem rep inner) => Maybe (Exp rep) -> [PatElem (LetDec rep)] -> ImpM rep r op () @@ -1069,10 +1061,10 @@ where dVar = dScope e . scopeOfPatElem -dFParams :: Mem rep inner => [FParam rep] -> ImpM rep r op () +dFParams :: (Mem rep inner) => [FParam rep] -> ImpM rep r op () dFParams = dScope Nothing . scopeOfFParams -dLParams :: Mem rep inner => [LParam rep] -> ImpM rep r op () +dLParams :: (Mem rep inner) => [LParam rep] -> ImpM rep r op () dLParams = dScope Nothing . scopeOfLParams dPrimVol :: String -> PrimType -> Imp.TExp t -> ImpM rep r op (TV t) @@ -1126,8 +1118,8 @@ MemVar e $ MemEntry space memBoundToVarEntry e (MemAcc acc ispace ts _) = AccVar e (acc, ispace, ts) -memBoundToVarEntry e (MemArray bt shape _ (ArrayIn mem ixfun)) = - let location = MemLoc mem (shapeDims shape) ixfun +memBoundToVarEntry e (MemArray bt shape _ (ArrayIn mem lmad)) = + let location = MemLoc mem (shapeDims shape) $ IxFun.ixfunLMAD lmad in ArrayVar e ArrayEntry @@ -1136,7 +1128,7 @@ } infoDec :: - Mem rep inner => + (Mem rep inner) => NameInfo rep -> MemInfo SubExp NoUniqueness MemBind infoDec (LetName dec) = letDecMem dec @@ -1145,7 +1137,7 @@ infoDec (IndexName it) = MemPrim $ IntType it dInfo :: - Mem rep inner => + (Mem rep inner) => Maybe (Exp rep) -> VName -> NameInfo rep -> @@ -1164,18 +1156,17 @@ addVar name entry dScope :: - Mem rep inner => + (Mem rep inner) => Maybe (Exp rep) -> Scope rep -> ImpM rep r op () dScope e = mapM_ (uncurry $ dInfo e) . M.toList -dArray :: VName -> PrimType -> ShapeBase SubExp -> VName -> IxFun -> ImpM rep r op () -dArray name pt shape mem ixfun = +dArray :: VName -> PrimType -> ShapeBase SubExp -> VName -> LMAD -> ImpM rep r op () +dArray name pt shape mem lmad = addVar name $ ArrayVar Nothing $ ArrayEntry location pt where - location = - MemLoc mem (shapeDims shape) ixfun + location = MemLoc mem (shapeDims shape) lmad everythingVolatile :: ImpM rep r op a -> ImpM rep r op a everythingVolatile = local $ \env -> env {envVolatility = Imp.Volatile} @@ -1391,12 +1382,12 @@ MemLoc -> [Imp.TExp Int64] -> ImpM rep r op (VName, Imp.Space, Count Elements (Imp.TExp Int64)) -fullyIndexArray' (MemLoc mem _ ixfun) indices = do +fullyIndexArray' (MemLoc mem _ lmad) indices = do space <- entryMemSpace <$> lookupMemory mem pure ( mem, space, - elements $ IxFun.index ixfun indices + elements $ LMAD.index lmad indices ) -- More complicated read/write operations that use index functions. @@ -1404,150 +1395,43 @@ copy :: CopyCompiler rep r op copy bt - dst@(MemLoc dst_name _ dst_ixfn@(IxFun.IxFun dst_lmad _)) - src@(MemLoc src_name _ src_ixfn@(IxFun.IxFun src_lmad _)) = do + dst@(MemLoc dst_name _ dst_ixfn@dst_lmad) + src@(MemLoc src_name _ src_ixfn@src_lmad) = do -- If we can statically determine that the two index-functions -- are equivalent, don't do anything - unless (dst_name == src_name && dst_ixfn `IxFun.equivalent` src_ixfn) + unless (dst_name == src_name && dst_ixfn `LMAD.equivalent` src_ixfn) $ -- It's also possible that we can dynamically determine that the two -- index-functions are equivalent. sUnless ( fromBool (dst_name == src_name) - .&&. IxFun.dynamicEqualsLMAD dst_lmad src_lmad + .&&. LMAD.dynamicEqualsLMAD dst_lmad src_lmad ) $ do -- If none of the above is true, actually do the copy cc <- asks envCopyCompiler cc bt dst src --- | Is this copy really a mapping with transpose? Produce an --- expression that is true if so, as well as other expressions that --- contain information about the transpose in that case (don't trust --- these if the boolean is false). -isMapTransposeCopy :: - PrimType -> - MemLoc -> - MemLoc -> - Maybe - ( Imp.TExp Bool, - ( Imp.TExp Int64, - Imp.TExp Int64, - Imp.TExp Int64, - Imp.TExp Int64, - Imp.TExp Int64 - ) - ) -isMapTransposeCopy pt (MemLoc _ _ destIxFun) (MemLoc _ _ srcIxFun) - | perm <- LMAD.permutation dest_lmad, - LMAD.permutation src_lmad == [0 .. rank - 1], - Just (r1, r2, _) <- isMapTranspose perm = - isOk (IxFun.shape destIxFun) swap r1 r2 - | perm <- LMAD.permutation src_lmad, - LMAD.permutation dest_lmad == [0 .. rank - 1], - Just (r1, r2, _) <- isMapTranspose perm = - isOk (IxFun.shape srcIxFun) id r1 r2 - | otherwise = - Nothing - where - rank = IxFun.rank destIxFun - swap (x, y) = (y, x) - dest_lmad = IxFun.ixfunLMAD destIxFun - src_lmad = IxFun.ixfunLMAD srcIxFun - dest_offset = LMAD.offset dest_lmad - src_offset = LMAD.offset src_lmad - - isOk shape f r1 r2 = - let (num_arrays, size_x, size_y) = getSizes shape f r1 r2 - in Just - ( LMAD.contiguous dest_lmad - .&&. LMAD.contiguous src_lmad, - ( dest_offset * primByteSize pt, - src_offset * primByteSize pt, - num_arrays, - size_x, - size_y - ) - ) - - getSizes shape f r1 r2 = - let (mapped, notmapped) = splitAt r1 shape - (pretrans, posttrans) = f $ splitAt r2 notmapped - in (product mapped, product pretrans, product posttrans) - -mapTransposeName :: PrimType -> String -mapTransposeName bt = "map_transpose_" ++ prettyString bt - -mapTransposeForType :: PrimType -> ImpM rep r op Name -mapTransposeForType bt = do - let fname = nameFromString $ "builtin#" <> mapTransposeName bt - - exists <- hasFunction fname - unless exists $ emitFunction fname $ mapTransposeFunction fname bt - - pure fname - --- | Use 'sCopy' if possible, otherwise 'copyElementWise'. -defaultCopy :: CopyCompiler rep r op -defaultCopy pt dest src - | Just (is_transpose, (destoffset, srcoffset, num_arrays, size_x, size_y)) <- - isMapTransposeCopy pt dest src = do - fname <- mapTransposeForType pt - sIf - is_transpose - ( emit . Imp.Call [] fname $ - transposeArgs - pt - destmem - (bytes destoffset) - srcmem - (bytes srcoffset) - num_arrays - size_x - size_y - ) - nontranspose - | otherwise = nontranspose - where - num_elems = Imp.elements $ product $ IxFun.shape $ memLocIxFun src - - MemLoc destmem _ dest_ixfun = dest - MemLoc srcmem _ src_ixfun = src - - isScalarSpace ScalarSpace {} = True - isScalarSpace _ = False - - nontranspose = do - srcspace <- entryMemSpace <$> lookupMemory srcmem - destspace <- entryMemSpace <$> lookupMemory destmem - if isScalarSpace srcspace || isScalarSpace destspace - then copyElementWise pt dest src - else do - let dest_lmad = LMAD.noPermutation $ IxFun.ixfunLMAD dest_ixfun - src_lmad = LMAD.noPermutation $ IxFun.ixfunLMAD src_ixfun - destoffset = elements (LMAD.offset dest_lmad) `withElemType` pt - srcoffset = elements (LMAD.offset src_lmad) `withElemType` pt - sIf - (LMAD.memcpyable dest_lmad src_lmad) - (sCopy destmem destoffset destspace srcmem srcoffset srcspace num_elems pt) - (copyElementWise pt dest src) - -copyElementWise :: CopyCompiler rep r op -copyElementWise bt dest src = do - let bounds = IxFun.shape $ memLocIxFun src - is <- replicateM (length bounds) (newVName "i") - let ivars = map Imp.le64 is - (destmem, destspace, destidx) <- fullyIndexArray' dest ivars - (srcmem, srcspace, srcidx) <- fullyIndexArray' src ivars - vol <- asks envVolatility - tmp <- newVName "tmp" +lmadCopy :: CopyCompiler rep r op +lmadCopy t dstloc srcloc = do + let dstmem = memLocName dstloc + srcmem = memLocName srcloc + dstlmad = memLocLMAD dstloc + srclmad = memLocLMAD srcloc + srcspace <- entryMemSpace <$> lookupMemory srcmem + dstspace <- entryMemSpace <$> lookupMemory dstmem emit $ - foldl (.) id (zipWith Imp.For is $ map untyped bounds) $ - mconcat - [ Imp.DeclareScalar tmp vol bt, - Imp.Read tmp srcmem srcidx bt srcspace vol, - Imp.Write destmem destidx bt destspace vol $ Imp.var tmp bt - ] + Imp.LMADCopy + t + (elements <$> LMAD.shape dstlmad) + (dstmem, dstspace) + ( LMAD.offset $ elements <$> dstlmad, + map LMAD.ldStride $ LMAD.dims $ elements <$> dstlmad + ) + (srcmem, srcspace) + ( LMAD.offset $ elements <$> srclmad, + map LMAD.ldStride $ LMAD.dims $ elements <$> srclmad + ) -- | Copy from here to there; both destination and source may be -- indexeded. @@ -1737,7 +1621,7 @@ -- @space@, writing the result to @pat@, which must contain a single -- memory-typed element. compileAlloc :: - Mem rep inner => Pat (LetDec rep) -> SubExp -> Space -> ImpM rep r op () + (Mem rep inner) => Pat (LetDec rep) -> SubExp -> Space -> ImpM rep r op () compileAlloc (Pat [mem]) e space = do let e' = Imp.bytes $ pe64 e allocator <- asks $ M.lookup space . envAllocCompilers @@ -1837,7 +1721,7 @@ sAlloc_ name' size space pure name' -sArray :: String -> PrimType -> ShapeBase SubExp -> VName -> IxFun -> ImpM rep r op VName +sArray :: String -> PrimType -> ShapeBase SubExp -> VName -> LMAD -> ImpM rep r op VName sArray name bt shape mem ixfun = do name' <- newVName name dArray name' bt shape mem ixfun @@ -1847,7 +1731,7 @@ sArrayInMem :: String -> PrimType -> ShapeBase SubExp -> VName -> ImpM rep r op VName sArrayInMem name pt shape mem = sArray name pt shape mem $ - IxFun.iota $ + LMAD.iota 0 $ map (isInt64 . primExpFromSubExp int64) $ shapeDims shape @@ -1856,9 +1740,9 @@ sAllocArrayPerm name pt shape space perm = do let permuted_dims = rearrangeShape perm $ shapeDims shape mem <- sAlloc (name ++ "_mem") (typeSize (Array pt shape NoUniqueness)) space - let iota_ixfun = IxFun.iota $ map (isInt64 . primExpFromSubExp int64) permuted_dims + let iota_ixfun = LMAD.iota 0 $ map (isInt64 . primExpFromSubExp int64) permuted_dims sArray name pt shape mem $ - IxFun.permute iota_ixfun $ + LMAD.permute iota_ixfun $ rearrangeInverse perm -- | Uses linear/iota index function. @@ -1876,7 +1760,7 @@ mem <- newVNameForFun $ name ++ "_mem" emit $ Imp.DeclareArray mem pt vs addVar mem $ MemVar Nothing $ MemEntry DefaultSpace - sArray name pt shape mem $ IxFun.iota [fromIntegral num_elems] + sArray name pt shape mem $ LMAD.iota 0 [fromIntegral num_elems] sWrite :: VName -> [Imp.TExp Int64] -> Imp.Exp -> ImpM rep r op () sWrite arr is v = do @@ -1904,33 +1788,6 @@ ([Imp.TExp Int64] -> ImpM rep r op ()) -> ImpM rep r op () sLoopNest = sLoopSpace . map pe64 . shapeDims - -sCopy :: - VName -> - Count Bytes (Imp.TExp Int64) -> - Space -> - VName -> - Count Bytes (Imp.TExp Int64) -> - Space -> - Count Elements (Imp.TExp Int64) -> - PrimType -> - ImpM rep r op () -sCopy destmem destoffset destspace srcmem srcoffset srcspace num_elems pt = - if destmem == srcmem - then sUnless (Imp.unCount destoffset .==. Imp.unCount srcoffset) the_copy - else the_copy - where - the_copy = - emit - $ Imp.Copy - pt - destmem - destoffset - destspace - srcmem - srcoffset - srcspace - $ num_elems `withElemType` pt -- | Untyped assignment. (<~~) :: VName -> Imp.Exp -> ImpM rep r op () diff --git a/src/Futhark/CodeGen/ImpGen/CUDA.hs b/src/Futhark/CodeGen/ImpGen/CUDA.hs --- a/src/Futhark/CodeGen/ImpGen/CUDA.hs +++ b/src/Futhark/CodeGen/ImpGen/CUDA.hs @@ -13,5 +13,5 @@ import Futhark.MonadFreshNames -- | Compile the program to ImpCode with CUDA kernels. -compileProg :: MonadFreshNames m => Prog GPUMem -> m (Warnings, Program) +compileProg :: (MonadFreshNames m) => Prog GPUMem -> m (Warnings, Program) compileProg prog = second kernelsToCUDA <$> compileProgCUDA prog diff --git a/src/Futhark/CodeGen/ImpGen/GPU.hs b/src/Futhark/CodeGen/ImpGen/GPU.hs --- a/src/Futhark/CodeGen/ImpGen/GPU.hs +++ b/src/Futhark/CodeGen/ImpGen/GPU.hs @@ -7,13 +7,12 @@ module Futhark.CodeGen.ImpGen.GPU ( compileProgOpenCL, compileProgCUDA, + compileProgHIP, Warnings, ) where import Control.Monad -import Control.Monad.State -import Data.Foldable (toList) import Data.List (foldl') import Data.Map qualified as M import Data.Maybe @@ -21,25 +20,21 @@ import Futhark.CodeGen.ImpGen hiding (compileProg) import Futhark.CodeGen.ImpGen qualified import Futhark.CodeGen.ImpGen.GPU.Base -import Futhark.CodeGen.ImpGen.GPU.Copy import Futhark.CodeGen.ImpGen.GPU.SegHist import Futhark.CodeGen.ImpGen.GPU.SegMap import Futhark.CodeGen.ImpGen.GPU.SegRed import Futhark.CodeGen.ImpGen.GPU.SegScan -import Futhark.CodeGen.ImpGen.GPU.Transpose import Futhark.Error import Futhark.IR.GPUMem -import Futhark.IR.Mem.IxFun qualified as IxFun -import Futhark.IR.Mem.LMAD qualified as LMAD import Futhark.MonadFreshNames -import Futhark.Util.IntegralExp (IntegralExp, divUp, quot, rem) +import Futhark.Util.IntegralExp (divUp, rem) import Prelude hiding (quot, rem) callKernelOperations :: Operations GPUMem HostEnv Imp.HostOp callKernelOperations = Operations { opsExpCompiler = expCompiler, - opsCopyCompiler = callKernelCopy, + opsCopyCompiler = lmadCopy, opsOpCompiler = opCompiler, opsStmsCompiler = defCompileStms, opsAllocCompilers = mempty @@ -76,7 +71,7 @@ ] compileProg :: - MonadFreshNames m => + (MonadFreshNames m) => HostEnv -> Prog GPUMem -> m (Warnings, Imp.Program) @@ -88,10 +83,12 @@ -- | Compile a 'GPUMem' program to low-level parallel code, with -- either CUDA or OpenCL characteristics. compileProgOpenCL, - compileProgCUDA :: - MonadFreshNames m => Prog GPUMem -> m (Warnings, Imp.Program) + compileProgCUDA, + compileProgHIP :: + (MonadFreshNames m) => Prog GPUMem -> m (Warnings, Imp.Program) compileProgOpenCL = compileProg $ HostEnv openclAtomics OpenCL mempty compileProgCUDA = compileProg $ HostEnv cudaAtomics CUDA mempty +compileProgHIP = compileProg $ HostEnv cudaAtomics HIP mempty opCompiler :: Pat LetDecMem -> @@ -262,327 +259,3 @@ Just ok -> Imp.If (matches .&&. ok) tcode fcode expCompiler dest e = defCompileExp dest e - -gpuCopyForType :: Rank -> PrimType -> CallKernelGen Name -gpuCopyForType r bt = do - let fname = nameFromString $ "builtin#" <> gpuCopyName r bt - - exists <- hasFunction fname - unless exists $ emitFunction fname $ gpuCopyFunction r bt - - pure fname - -gpuCopyName :: Rank -> PrimType -> String -gpuCopyName (Rank r) bt = "gpu_copy_" <> show r <> "d_" <> prettyString bt - -gpuCopyFunction :: Rank -> PrimType -> Imp.Function Imp.HostOp -gpuCopyFunction (Rank r) pt = do - let tdesc = mconcat (replicate r "[]") <> prettyString pt - Imp.Function Nothing [] params $ - Imp.DebugPrint ("\n# Copy " <> tdesc) Nothing - <> copy_code - <> Imp.DebugPrint "" Nothing - where - space = Space "device" - memparam v = Imp.MemParam v space - intparam v = Imp.ScalarParam v $ IntType Int64 - - mkIxFun desc = do - let new x = newVName $ desc <> "_" <> x - newDim i = LMAD.LMADDim <$> new "stride" <*> new "shape" <*> pure i - LMAD.LMAD <$> new "offset" <*> mapM newDim [0 .. r - 1] - - (params, copy_code) = do - flip evalState blankNameSource $ do - dest_mem <- newVName "destmem" - dest_lmad <- mkIxFun "dest" - - src_mem <- newVName "srcmem" - src_lmad <- mkIxFun "src" - - group_size <- newVName "group_size" - num_groups <- newVName "num_groups" - - let kernel = - copyKernel - pt - (le64 num_groups, Left $ untyped $ le64 group_size) - (dest_mem, le64 <$> dest_lmad) - (src_mem, le64 <$> src_lmad) - - dest_offset = - Imp.elements (le64 (LMAD.offset dest_lmad)) `Imp.withElemType` pt - - src_offset = - Imp.elements (le64 (LMAD.offset src_lmad)) `Imp.withElemType` pt - - num_bytes = - Imp.elements (product (le64 <$> LMAD.shape src_lmad)) `Imp.withElemType` pt - - do_copy = - Imp.Copy - pt - dest_mem - dest_offset - (Space "device") - src_mem - src_offset - (Space "device") - num_bytes - - pure - ( [memparam dest_mem] - ++ map intparam (toList dest_lmad) - ++ [memparam src_mem] - ++ map intparam (toList src_lmad), - Imp.DeclareScalar group_size Imp.Nonvolatile int64 - <> Imp.DeclareScalar num_groups Imp.Nonvolatile int64 - <> Imp.Op (Imp.GetSize group_size "copy_group_size" Imp.SizeGroup) - <> Imp.Op (Imp.GetSize num_groups "copy_num_groups" Imp.SizeNumGroups) - <> Imp.If - (LMAD.memcpyable (le64 <$> dest_lmad) (le64 <$> src_lmad)) - ( Imp.DebugPrint "## Simple copy" Nothing - <> do_copy - ) - ( Imp.DebugPrint "## Kernel copy" Nothing - <> Imp.Op (Imp.CallKernel kernel) - ) - ) - -mapTransposeForType :: PrimType -> CallKernelGen Name -mapTransposeForType bt = do - let fname = nameFromString $ "builtin#" <> mapTransposeName bt - - exists <- hasFunction fname - unless exists $ emitFunction fname $ mapTransposeFunction bt - - pure fname - -mapTransposeName :: PrimType -> String -mapTransposeName bt = "gpu_map_transpose_" ++ prettyString bt - -mapTransposeFunction :: PrimType -> Imp.Function Imp.HostOp -mapTransposeFunction bt = - Imp.Function Nothing [] params $ - Imp.DebugPrint ("\n# Transpose " <> prettyString bt) Nothing - <> Imp.DebugPrint "Number of arrays " (Just $ untyped $ Imp.le64 num_arrays) - <> Imp.DebugPrint "X elements " (Just $ untyped $ Imp.le64 x) - <> Imp.DebugPrint "Y elements " (Just $ untyped $ Imp.le64 y) - <> Imp.DebugPrint "Source offset" (Just $ untyped $ Imp.le64 srcoffset) - <> Imp.DebugPrint "Destination offset" (Just $ untyped $ Imp.le64 destoffset) - <> transpose_code - <> Imp.DebugPrint "" Nothing - where - params = - [ memparam destmem, - intparam destoffset, - memparam srcmem, - intparam srcoffset, - intparam num_arrays, - intparam x, - intparam y - ] - - space = Space "device" - memparam v = Imp.MemParam v space - intparam v = Imp.ScalarParam v $ IntType Int64 - - [ destmem, - destoffset, - srcmem, - srcoffset, - num_arrays, - x, - y, - mulx, - muly, - block, - use_32b - ] = - zipWith - (VName . nameFromString) - [ "destmem", - "destoffset", - "srcmem", - "srcoffset", - "num_arrays", - "x_elems", - "y_elems", - -- The following is only used for low width/height - -- transpose kernels - "mulx", - "muly", - "block", - "use_32b" - ] - [0 ..] - - block_dim_int = 16 - - block_dim :: IntegralExp a => a - block_dim = 16 - - -- When an input array has either width==1 or height==1, performing a - -- transpose will be the same as performing a copy. - can_use_copy = - let onearr = Imp.le64 num_arrays .==. 1 - height_is_one = Imp.le64 y .==. 1 - width_is_one = Imp.le64 x .==. 1 - in onearr .&&. (width_is_one .||. height_is_one) - - transpose_code = - Imp.If input_is_empty mempty $ - mconcat - [ Imp.DeclareScalar muly Imp.Nonvolatile (IntType Int64), - Imp.SetScalar muly $ untyped $ block_dim `quot` Imp.le64 x, - Imp.DeclareScalar mulx Imp.Nonvolatile (IntType Int64), - Imp.SetScalar mulx $ untyped $ block_dim `quot` Imp.le64 y, - Imp.DeclareScalar use_32b Imp.Nonvolatile Bool, - Imp.SetScalar use_32b $ - untyped $ - (le64 destoffset + le64 num_arrays * le64 x * le64 y) .<=. 2 ^ (31 :: Int) - 1 - .&&. (le64 srcoffset + le64 num_arrays * le64 x * le64 y) .<=. 2 ^ (31 :: Int) - 1, - Imp.If can_use_copy copy_code $ - Imp.If should_use_lowwidth (callTransposeKernel TransposeLowWidth) $ - Imp.If should_use_lowheight (callTransposeKernel TransposeLowHeight) $ - Imp.If should_use_small (callTransposeKernel TransposeSmall) $ - callTransposeKernel TransposeNormal - ] - - input_is_empty = - Imp.le64 num_arrays .==. 0 .||. Imp.le64 x .==. 0 .||. Imp.le64 y .==. 0 - - should_use_small = - Imp.le64 x .<=. (block_dim `quot` 2) - .&&. Imp.le64 y .<=. (block_dim `quot` 2) - - should_use_lowwidth = - Imp.le64 x .<=. (block_dim `quot` 2) - .&&. block_dim .<. Imp.le64 y - - should_use_lowheight = - Imp.le64 y .<=. (block_dim `quot` 2) - .&&. block_dim .<. Imp.le64 x - - copy_code = - let num_bytes = sExt64 $ Imp.le64 x * Imp.le64 y * primByteSize bt - in Imp.Copy - bt - destmem - (Imp.Count $ Imp.le64 destoffset) - space - srcmem - (Imp.Count $ Imp.le64 srcoffset) - space - (Imp.Count num_bytes) - - callTransposeKernel which = - Imp.If - (isBool (LeafExp use_32b Bool)) - ( Imp.DebugPrint "Using 32-bit indexing" Nothing - <> callTransposeKernel32 which - ) - ( Imp.DebugPrint "Using 64-bit indexing" Nothing - <> callTransposeKernel64 which - ) - - callTransposeKernel64 = - Imp.Op - . Imp.CallKernel - . mapTransposeKernel - (int64, le64) - (mapTransposeName bt) - block_dim_int - ( destmem, - le64 destoffset, - srcmem, - le64 srcoffset, - le64 x, - le64 y, - le64 mulx, - le64 muly, - le64 num_arrays, - block - ) - bt - - callTransposeKernel32 = - Imp.Op - . Imp.CallKernel - . mapTransposeKernel - (int32, le32) - (mapTransposeName bt) - block_dim_int - ( destmem, - sExt32 (le64 destoffset), - srcmem, - sExt32 (le64 srcoffset), - sExt32 (le64 x), - sExt32 (le64 y), - sExt32 (le64 mulx), - sExt32 (le64 muly), - sExt32 (le64 num_arrays), - block - ) - bt - --- Note [32-bit transpositions] --- --- Transposition kernels are much slower when they have to use 64-bit --- arithmetic. I observed about 0.67x slowdown on an A100 GPU when --- transposing four-byte elements (much less when transposing 8-byte --- elements). Unfortunately, 64-bit arithmetic is a requirement for --- large arrays (see #1953 for what happens otherwise). We generate --- both 32- and 64-bit index arithmetic versions of transpositions, --- and dynamically pick between them at runtime. This is an --- unfortunate code bloat, and it would be preferable if we could --- simply optimise the 64-bit version to make this distinction --- unnecessary. Fortunately these kernels are quite small. - -callKernelCopy :: CopyCompiler GPUMem HostEnv Imp.HostOp -callKernelCopy pt destloc@(MemLoc destmem _ dest_ixfun) srcloc@(MemLoc srcmem _ src_ixfun) - | Just (is_transpose, (destoffset, srcoffset, num_arrays, size_x, size_y)) <- - isMapTransposeCopy pt destloc srcloc = do - fname <- mapTransposeForType pt - sIf - is_transpose - ( emit . Imp.Call [] fname $ - [ Imp.MemArg destmem, - Imp.ExpArg $ untyped destoffset, - Imp.MemArg srcmem, - Imp.ExpArg $ untyped srcoffset, - Imp.ExpArg $ untyped num_arrays, - Imp.ExpArg $ untyped size_x, - Imp.ExpArg $ untyped size_y - ] - ) - nontranspose - | otherwise = nontranspose - where - nontranspose = do - fname <- gpuCopyForType (Rank (IxFun.rank dest_ixfun)) pt - dest_space <- entryMemSpace <$> lookupMemory destmem - src_space <- entryMemSpace <$> lookupMemory srcmem - let dest_lmad = LMAD.noPermutation $ IxFun.ixfunLMAD dest_ixfun - src_lmad = LMAD.noPermutation $ IxFun.ixfunLMAD src_ixfun - num_elems = Imp.elements $ product $ LMAD.shape dest_lmad - if dest_space == Space "device" && src_space == Space "device" - then - emit . Imp.Call [] fname $ - [Imp.MemArg destmem] - ++ map (Imp.ExpArg . untyped) (toList dest_lmad) - ++ [Imp.MemArg srcmem] - ++ map (Imp.ExpArg . untyped) (toList src_lmad) - else -- FIXME: this assumes a linear representation! - -- Currently we never generate code where this is not the - -- case, but we might in the future. - - sCopy - destmem - (Imp.elements (LMAD.offset dest_lmad) `Imp.withElemType` pt) - dest_space - srcmem - (Imp.elements (LMAD.offset src_lmad) `Imp.withElemType` pt) - src_space - num_elems - pt 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 @@ -33,7 +33,6 @@ -- * Host-level bulk operations sReplicate, sIota, - sCopy, -- * Atomics AtomicBinOp, @@ -52,7 +51,7 @@ import Futhark.CodeGen.ImpGen import Futhark.Error import Futhark.IR.GPUMem -import Futhark.IR.Mem.IxFun qualified as IxFun +import Futhark.IR.Mem.LMAD qualified as LMAD import Futhark.MonadFreshNames import Futhark.Transform.Rename import Futhark.Util (dropLast, nubOrd, splitFromEnd) @@ -63,7 +62,7 @@ -- of the kernels code is the same, there are some cases where we -- generate special code based on the ultimate low-level API we are -- targeting. -data Target = CUDA | OpenCL +data Target = CUDA | OpenCL | HIP -- | Information about the locks available for accumulators. data Locks = Locks @@ -188,7 +187,7 @@ -- The body must contain thread-level code. For multidimensional -- loops, use 'groupCoverSpace'. kernelLoop :: - IntExp t => + (IntExp t) => Imp.TExp t -> Imp.TExp t -> Imp.TExp t -> @@ -208,7 +207,7 @@ -- passed-in function is invoked with the (symbolic) iteration. For -- multidimensional loops, use 'groupCoverSpace'. groupLoop :: - IntExp t => + (IntExp t) => Imp.TExp t -> (Imp.TExp t -> InKernelGen ()) -> InKernelGen () @@ -224,7 +223,7 @@ -- all threads in the group participate. The passed-in function is -- invoked with a (symbolic) point in the index space. groupCoverSpace :: - IntExp t => + (IntExp t) => [Imp.TExp t] -> ([Imp.TExp t] -> InKernelGen ()) -> InKernelGen () @@ -410,6 +409,12 @@ | otherwise = sOp $ Imp.Barrier fence + errorsync + | array_scan = + sOp $ Imp.ErrorSync Imp.FenceGlobal + | otherwise = + sOp $ Imp.ErrorSync Imp.FenceLocal + group_offset = sExt64 (kernelGroupId constants) * kernelGroupSize constants writeBlockResult p arr @@ -453,7 +458,7 @@ "scan the first block, after which offset 'i' contains carry-in for block 'i+1'" $ doInBlockScan first_block_seg_flag (is_first_block .&&. ltid_in_bounds) renamed_lam - barrier + errorsync when array_scan $ do sComment "move correct values for first block back a block" $ @@ -528,38 +533,44 @@ constants <- kernelConstants <$> askEnv let local_tid = kernelLocalThreadId constants - global_tid = kernelGlobalThreadId constants barrier | all primType $ lambdaReturnType lam = sOp $ Imp.Barrier Imp.FenceLocal | otherwise = sOp $ Imp.Barrier Imp.FenceGlobal - readReduceArgument param arr - | Prim _ <- paramType param = do - let i = local_tid + tvExp offset - copyDWIMFix (paramName param) [] (Var arr) [sExt64 i] - | otherwise = do - let i = global_tid + tvExp offset - copyDWIMFix (paramName param) [] (Var arr) [sExt64 i] + errorsync + | all primType $ lambdaReturnType lam = sOp $ Imp.ErrorSync Imp.FenceLocal + | otherwise = sOp $ Imp.ErrorSync Imp.FenceGlobal + readReduceArgument param arr = do + let i = local_tid + tvExp offset + copyDWIMFix (paramName param) [] (Var arr) [sExt64 i] + writeReduceOpResult param arr | Prim _ <- paramType param = copyDWIMFix arr [sExt64 local_tid] (Var $ paramName param) [] | otherwise = pure () - let (reduce_acc_params, reduce_arr_params) = splitAt (length arrs) $ lambdaParams lam + writeArrayOpResult param arr + | Prim _ <- paramType param = + pure () + | otherwise = + copyDWIMFix arr [0] (Var $ paramName param) [] + let (reduce_acc_params, reduce_arr_params) = + splitAt (length arrs) $ lambdaParams lam + skip_waves <- dPrimV "skip_waves" (1 :: Imp.TExp Int32) dLParams $ lambdaParams lam offset <-- (0 :: Imp.TExp Int32) comment "participating threads read initial accumulator" $ - sWhen (local_tid .<. w) $ + localOps threadOperations . sWhen (local_tid .<. w) $ zipWithM_ readReduceArgument reduce_acc_params arrs - let do_reduce = do + let do_reduce = localOps threadOperations $ do comment "read array element" $ zipWithM_ readReduceArgument reduce_arr_params arrs comment "apply reduction operation" $ @@ -600,14 +611,18 @@ sWhile doing_cross_wave_reductions $ do barrier offset <-- tvExp skip_waves * wave_size - sWhen - apply_in_cross_wave_iteration - do_reduce + sWhen apply_in_cross_wave_iteration do_reduce skip_waves <-- tvExp skip_waves * 2 in_wave_reductions cross_wave_reductions + errorsync + sComment "Copy array-typed operands to result array" $ do + sWhen (local_tid .==. 0) $ + localOps threadOperations $ + zipWithM_ writeArrayOpResult reduce_acc_params arrs + compileThreadOp :: OpCompiler GPUMem KernelEnv Imp.KernelOp compileThreadOp pat (Alloc size space) = kernelAlloc pat size space @@ -847,7 +862,7 @@ sWhen (isBool won) (run_loop <-- false) computeKernelUses :: - FreeIn a => + (FreeIn a) => a -> [VName] -> CallKernelGen [Imp.KernelUse] @@ -1195,7 +1210,7 @@ threadOperations :: Operations GPUMem KernelEnv Imp.KernelOp threadOperations = (defaultOperations compileThreadOp) - { opsCopyCompiler = copyElementWise, + { opsCopyCompiler = lmadCopy, opsExpCompiler = compileThreadExp, opsStmsCompiler = \_ -> defCompileStms mempty, opsAllocCompilers = @@ -1246,7 +1261,7 @@ shape = Shape [Var num_elems] function fname [] params $ do arr <- - sArray "arr" bt shape mem $ IxFun.iota $ map pe64 $ shapeDims shape + sArray "arr" bt shape mem $ LMAD.iota 0 $ map pe64 $ shapeDims shape sReplicateKernel arr $ Var val pure fname @@ -1257,7 +1272,7 @@ v_t <- subExpType v case v_t of Prim v_t' - | IxFun.isDirect arr_ixfun -> pure $ + | LMAD.isDirect arr_ixfun -> pure $ Just $ do fname <- replicateForType v_t' emit $ @@ -1342,9 +1357,7 @@ function fname [] params $ do arr <- sArray "arr" (IntType bt) shape mem $ - IxFun.iota $ - map pe64 $ - shapeDims shape + LMAD.iota 0 (map pe64 (shapeDims shape)) sIotaKernel arr (sExt64 n') x' s' bt pure fname @@ -1359,7 +1372,7 @@ CallKernelGen () sIota arr n x s et = do ArrayEntry (MemLoc arr_mem _ arr_ixfun) _ <- lookupArray arr - if IxFun.isDirect arr_ixfun + if LMAD.isDirect arr_ixfun then do fname <- iotaForType et emit $ diff --git a/src/Futhark/CodeGen/ImpGen/GPU/Copy.hs b/src/Futhark/CodeGen/ImpGen/GPU/Copy.hs deleted file mode 100644 --- a/src/Futhark/CodeGen/ImpGen/GPU/Copy.hs +++ /dev/null @@ -1,81 +0,0 @@ --- | General implementation of GPU copying, using LMAD representation. --- That means the dynamic performance of this kernel depends crucially --- on the LMAD. In most cases we should use a more specialised kernel. --- Written in ImpCode so we can compile it to both CUDA and OpenCL. -module Futhark.CodeGen.ImpGen.GPU.Copy (copyKernel) where - -import Control.Monad -import Control.Monad.State -import Data.Foldable (toList) -import Futhark.CodeGen.ImpCode.GPU -import Futhark.IR.Mem.LMAD qualified as LMAD -import Futhark.IR.Prop.Reshape -import Futhark.MonadFreshNames -import Futhark.Util (nubOrd) -import Futhark.Util.IntegralExp (divUp) -import Prelude hiding (quot, rem) - -copyKernel :: - PrimType -> - (TExp Int64, GroupDim) -> - (VName, LMAD.LMAD (TExp Int64)) -> - (VName, LMAD.LMAD (TExp Int64)) -> - Kernel -copyKernel pt (num_groups, group_dim) (dest_mem, dest_lmad) (src_mem, src_lmad) = - Kernel - { kernelBody = body, - kernelUses = - let frees = - nubOrd - ( foldMap toList dest_lmad - <> foldMap toList src_lmad - <> toList num_groups - ) - in map (`ScalarUse` IntType Int64) frees - ++ map MemoryUse [dest_mem, src_mem], - kernelNumGroups = [untyped num_groups], - kernelGroupSize = [group_dim], - kernelName = nameFromString ("copy_" <> show rank <> "d_" <> prettyString pt), - kernelFailureTolerant = True, - kernelCheckLocalMemory = False - } - where - shape = LMAD.shape dest_lmad - rank = length shape - - body = flip evalState (newNameSource 1000) $ do - group_id <- newVName "group_id" - local_id <- newVName "local_id" - local_size <- newVName "local_size" - global_id <- newVName "global_id" - group_iter <- newVName "group_iter" - let global_id_e = - ((le64 group_id + le64 group_iter * num_groups) * le64 local_size) - + le64 local_id - - is <- replicateM rank $ newVName "i" - let is_e = map untyped (unflattenIndex shape (le64 global_id)) - in_bounds = foldl1 (.&&.) (zipWith (.<.) (map le64 is) shape) - - element <- newVName "element" - - let dec v = DeclareScalar v Nonvolatile $ IntType Int64 - src_o = Count (LMAD.index src_lmad (map le64 is)) - dest_o = Count (LMAD.index dest_lmad (map le64 is)) - copy_elem = - DeclareScalar element Nonvolatile pt - <> Read element src_mem src_o pt (Space "device") Nonvolatile - <> Write dest_mem dest_o pt (Space "device") Nonvolatile (LeafExp element pt) - pure $ - foldMap dec [group_id, local_id, local_size, global_id] - <> Op (GetLocalId local_id 0) - <> Op (GetLocalSize local_size 0) - <> Op (GetGroupId group_id 0) - <> For - group_iter - (untyped (product shape `divUp` (le64 local_size * num_groups))) - ( SetScalar global_id (untyped global_id_e) - <> foldMap dec is - <> mconcat (zipWith SetScalar is is_e) - <> If in_bounds copy_elem mempty - ) diff --git a/src/Futhark/CodeGen/ImpGen/GPU/Group.hs b/src/Futhark/CodeGen/ImpGen/GPU/Group.hs --- a/src/Futhark/CodeGen/ImpGen/GPU/Group.hs +++ b/src/Futhark/CodeGen/ImpGen/GPU/Group.hs @@ -26,7 +26,7 @@ import Futhark.Construct (fullSliceNum) import Futhark.Error import Futhark.IR.GPUMem -import Futhark.IR.Mem.IxFun qualified as IxFun +import Futhark.IR.Mem.LMAD qualified as LMAD import Futhark.MonadFreshNames import Futhark.Transform.Rename import Futhark.Util (chunks, mapAccumLM, takeLast) @@ -42,9 +42,7 @@ let flat_shape = Shape $ Var (tvVar flat) : drop k (memLocShape arr_loc) sArray (baseString arr ++ "_flat") pt flat_shape (memLocName arr_loc) $ fromMaybe (error "flattenArray") $ - IxFun.reshape (memLocIxFun arr_loc) $ - map pe64 $ - shapeDims flat_shape + LMAD.reshape (memLocLMAD arr_loc) (map pe64 $ shapeDims flat_shape) sliceArray :: Imp.TExp Int64 -> TV Int64 -> VName -> ImpM rep r op VName sliceArray start size arr = do @@ -59,7 +57,7 @@ (elemType arr_t) (arrayShape arr_t `setOuterDim` Var (tvVar size)) mem - $ IxFun.slice ixfun slice + $ LMAD.slice ixfun slice -- | @applyLambda lam dests args@ emits code that: -- @@ -73,7 +71,7 @@ -- provided @dest@s, again interpreted as the destination for a -- 'copyDWIM'. applyLambda :: - Mem rep inner => + (Mem rep inner) => Lambda rep -> [(VName, [DimIndex (Imp.TExp Int64)])] -> [(SubExp, [DimIndex (Imp.TExp Int64)])] -> @@ -92,7 +90,7 @@ -- anyway, but you have to be more careful - use this if you are in -- doubt.) applyRenamedLambda :: - Mem rep inner => + (Mem rep inner) => Lambda rep -> [(VName, [DimIndex (Imp.TExp Int64)])] -> [(SubExp, [DimIndex (Imp.TExp Int64)])] -> @@ -138,9 +136,9 @@ carry_idx <- dPrimVE "carry_idx" $ sExt64 chunk_start - 1 applyRenamedLambda lam - (zip arrs $ repeat [DimFix $ sExt64 chunk_start]) - ( zip (map Var arrs) (repeat [DimFix carry_idx]) - ++ zip (map Var arrs) (repeat [DimFix $ sExt64 chunk_start]) + (map (,[DimFix $ sExt64 chunk_start]) arrs) + ( map ((,[DimFix carry_idx]) . Var) arrs + ++ map ((,[DimFix $ sExt64 chunk_start]) . Var) arrs ) arrs_chunks <- mapM (sliceArray (sExt64 chunk_start) chunk_size) arrs @@ -154,8 +152,8 @@ dest_space <- entryMemSpace <$> lookupMemory (memLocName destloc) src_space <- entryMemSpace <$> lookupMemory (memLocName srcloc) - let src_ixfun = memLocIxFun srcloc - dims = IxFun.shape src_ixfun + let src_lmad = memLocLMAD srcloc + dims = LMAD.shape src_lmad rank = length dims case (dest_space, src_space) of @@ -169,13 +167,13 @@ Slice $ replicate (rank - length srcds) (DimFix 0) ++ takeLast (length srcds) (map fullDim dims) - copyElementWise + lmadCopy pt (sliceMemLoc destloc destslice') (sliceMemLoc srcloc srcslice') _ -> do groupCoverSpace (map sExt32 dims) $ \is -> - copyElementWise + lmadCopy pt (sliceMemLoc destloc (Slice $ map (DimFix . sExt64) is)) (sliceMemLoc srcloc (Slice $ map (DimFix . sExt64) is)) @@ -229,7 +227,7 @@ locks_mem <- sAlloc "locks_mem" (typeSize locks_t) $ Space "local" dArray locks int32 (arrayShape locks_t) locks_mem $ - IxFun.iota . map pe64 . arrayDims $ + LMAD.iota 0 . map pe64 . arrayDims $ locks_t sComment "All locks start out unlocked" $ @@ -326,8 +324,17 @@ slice' = fmap pe64 slice dims = map pe64 $ arrayDims $ patElemType pe write = copyDWIM (patElemName pe) (unSlice slice') se [] -compileGroupExp dest e = +compileGroupExp dest e = do + -- It is a messy to jump into control flow for error handling. + -- Avoid that by always doing an error sync here. Potential + -- improvement: only do this if any errors are pending (this could + -- also be handled in later codegen). + when (doSync e) $ sOp $ Imp.ErrorSync Imp.FenceLocal defCompileExp dest e + where + doSync Loop {} = True + doSync Match {} = True + doSync _ = False compileGroupOp :: OpCompiler GPUMem KernelEnv Imp.KernelOp compileGroupOp pat (Alloc size space) = @@ -421,9 +428,9 @@ forM_ (zip ops tmps_for_ops) $ \(op, tmps) -> applyRenamedLambda (segBinOpLambda op) - (zip tmps $ repeat [DimFix $ sExt64 chunk_start]) - ( zip (map (Var . patElemName) red_pes) (repeat []) - ++ zip (map Var tmps) (repeat [DimFix $ sExt64 chunk_start]) + (map (,[DimFix $ sExt64 chunk_start]) tmps) + ( map ((,[]) . Var . patElemName) red_pes + ++ map ((,[DimFix $ sExt64 chunk_start]) . Var) tmps ) sOp $ Imp.ErrorSync Imp.FenceLocal @@ -434,8 +441,11 @@ sOp $ Imp.ErrorSync Imp.FenceLocal - forM_ (zip red_pes $ concat tmps_for_ops) $ \(pe, arr) -> - copyDWIMFix (patElemName pe) [] (Var arr) [sExt64 chunk_start] + sComment "Save result of reduction." $ + forM_ (zip red_pes $ concat tmps_for_ops) $ \(pe, arr) -> + copyDWIMFix (patElemName pe) [] (Var arr) [sExt64 chunk_start] + + -- virtCase dims' tmps_for_ops = do dims_flat <- dPrimV "dims_flat" $ product dims' let segment_size = last dims' @@ -452,29 +462,31 @@ sOp $ Imp.ErrorSync Imp.FenceLocal - forM_ (zip red_pes $ concat tmps_for_ops) $ \(pe, arr) -> - copyDWIM - (patElemName pe) - [] - (Var arr) - (map (unitSlice 0) (init dims') ++ [DimFix $ last dims' - 1]) + sComment "Save result of reduction." $ + forM_ (zip red_pes $ concat tmps_for_ops) $ \(pe, arr) -> + copyDWIM + (patElemName pe) + [] + (Var arr) + (map (unitSlice 0) (init dims') ++ [DimFix $ last dims' - 1]) sOp $ Imp.Barrier Imp.FenceLocal + -- Nonsegmented case (or rather, a single segment) - this we can + -- handle directly with a group-level reduction. nonvirtCase [dim'] tmps_for_ops = do - -- Nonsegmented case (or rather, a single segment) - this we can - -- handle directly with a group-level reduction. forM_ (zip ops tmps_for_ops) $ \(op, tmps) -> groupReduce (sExt32 dim') (segBinOpLambda op) tmps sOp $ Imp.ErrorSync Imp.FenceLocal - forM_ (zip red_pes $ concat tmps_for_ops) $ \(pe, arr) -> - copyDWIMFix (patElemName pe) [] (Var arr) [0] - -- - nonvirtCase dims' tmps_for_ops = do - -- Segmented intra-group reductions are turned into (regular) - -- segmented scans. It is possible that this can be done - -- better, but at least this approach is simple. + sComment "Save result of reduction." $ + forM_ (zip red_pes $ concat tmps_for_ops) $ \(pe, arr) -> + copyDWIMFix (patElemName pe) [] (Var arr) [0] + sOp $ Imp.ErrorSync Imp.FenceLocal + -- Segmented intra-group reductions are turned into (regular) + -- segmented scans. It is possible that this can be done + -- better, but at least this approach is simple. + nonvirtCase dims' tmps_for_ops = do -- groupScan operates on flattened arrays. This does not -- involve copying anything; merely playing with the index -- function. @@ -494,12 +506,13 @@ sOp $ Imp.ErrorSync Imp.FenceLocal - forM_ (zip red_pes $ concat tmps_for_ops) $ \(pe, arr) -> - copyDWIM - (patElemName pe) - [] - (Var arr) - (map (unitSlice 0) (init dims') ++ [DimFix $ last dims' - 1]) + sComment "Save result of reduction." $ + forM_ (zip red_pes $ concat tmps_for_ops) $ \(pe, arr) -> + copyDWIM + (patElemName pe) + [] + (Var arr) + (map (unitSlice 0) (init dims') ++ [DimFix $ last dims' - 1]) sOp $ Imp.Barrier Imp.FenceLocal compileGroupOp pat (Inner (SegOp (SegHist lvl space ops _ kbody))) = do @@ -531,7 +544,7 @@ \(bin, op_vs, do_op, HistOp dest_shape _ _ _ shape lam) -> do let bin' = pe64 bin dest_shape' = map pe64 $ shapeDims dest_shape - bin_in_bounds = inBounds (Slice (map DimFix [bin'])) dest_shape' + bin_in_bounds = inBounds (Slice [DimFix bin']) dest_shape' bin_is = map Imp.le64 (init ltids) ++ [bin'] vs_params = takeLast (length op_vs) $ lambdaParams lam @@ -693,7 +706,7 @@ S.singleton $ arrayDims $ patElemType pe onStm (Let _ _ (Match _ cases defbody _)) = foldMap (onStms . bodyStms . caseBody) cases <> onStms (bodyStms defbody) - onStm (Let _ _ (DoLoop _ _ body)) = + onStm (Let _ _ (Loop _ _ body)) = onStms (bodyStms body) onStm _ = mempty diff --git a/src/Futhark/CodeGen/ImpGen/GPU/SegHist.hs b/src/Futhark/CodeGen/ImpGen/GPU/SegHist.hs --- a/src/Futhark/CodeGen/ImpGen/GPU/SegHist.hs +++ b/src/Futhark/CodeGen/ImpGen/GPU/SegHist.hs @@ -47,7 +47,7 @@ import Futhark.CodeGen.ImpGen.GPU.SegRed (compileSegRed') import Futhark.Construct (fullSliceNum) import Futhark.IR.GPUMem -import Futhark.IR.Mem.IxFun qualified as IxFun +import Futhark.IR.Mem.LMAD qualified as LMAD import Futhark.MonadFreshNames import Futhark.Pass.ExplicitAllocations () import Futhark.Util (chunks, mapAccumLM, maxinum, splitFromEnd, takeLast) @@ -114,7 +114,7 @@ (elemType dest_t) subhistos_shape subhistos_mem - $ IxFun.iota + $ LMAD.iota 0 $ map pe64 $ shapeDims subhistos_shape diff --git a/src/Futhark/CodeGen/ImpGen/GPU/SegRed.hs b/src/Futhark/CodeGen/ImpGen/GPU/SegRed.hs --- a/src/Futhark/CodeGen/ImpGen/GPU/SegRed.hs +++ b/src/Futhark/CodeGen/ImpGen/GPU/SegRed.hs @@ -56,7 +56,7 @@ import Futhark.CodeGen.ImpGen.GPU.Base import Futhark.Error import Futhark.IR.GPUMem -import Futhark.IR.Mem.IxFun qualified as IxFun +import Futhark.IR.Mem.LMAD qualified as LMAD import Futhark.Transform.Rename import Futhark.Util (chunks) import Futhark.Util.IntegralExp (divUp, quot, rem) @@ -94,7 +94,7 @@ let map_arrs = drop (segBinOpResults reds) $ patElems pat zipWithM_ (compileThreadResult space) map_arrs map_res - red_cont $ zip (map kernelResultSubExp red_res) $ repeat [] + red_cont $ map ((,[]) . kernelResultSubExp) red_res emit $ Imp.DebugPrint "" Nothing -- | Like 'compileSegRed', but where the body is a monadic action. @@ -142,9 +142,7 @@ MemArray pt shape _ (ArrayIn mem _) -> do let shape' = Shape [num_threads] <> shape sArray "red_arr" pt shape' mem $ - IxFun.iota $ - map pe64 $ - shapeDims shape' + LMAD.iota 0 (map pe64 $ shapeDims shape') _ -> do let pt = elemType $ paramType p shape = Shape [group_size] @@ -311,7 +309,7 @@ in_bounds = body $ \red_res -> sComment "save results to be reduced" $ do - let red_dests = zip (concat reds_arrs) $ repeat [ltid] + let red_dests = map (,[ltid]) (concat reds_arrs) forM_ (zip red_dests red_res) $ \((d, d_is), (res, res_is)) -> copyDWIMFix d d_is res res_is @@ -721,7 +719,7 @@ copyDWIMFix acc (acc_is ++ vec_is) ne [] sUnless (local_tid .==. 0) reset_to_neutral _ -> pure () - + sOp $ Imp.ErrorSync Imp.FenceLocal pure (slugs_op_renamed, doTheReduction) reductionStageOne :: @@ -872,7 +870,7 @@ when (primType $ paramType p) $ copyDWIMFix arr [sExt64 local_tid] (Var $ paramName p) [] - sOp $ Imp.Barrier Imp.FenceLocal + sOp $ Imp.ErrorSync Imp.FenceLocal sComment "reduce the per-group results" $ do groupReduce (sExt32 group_size) red_op_renamed red_arrs diff --git a/src/Futhark/CodeGen/ImpGen/GPU/SegScan.hs b/src/Futhark/CodeGen/ImpGen/GPU/SegScan.hs --- a/src/Futhark/CodeGen/ImpGen/GPU/SegScan.hs +++ b/src/Futhark/CodeGen/ImpGen/GPU/SegScan.hs @@ -3,6 +3,8 @@ -- the scan and the chosen abckend. module Futhark.CodeGen.ImpGen.GPU.SegScan (compileSegScan) where +import Control.Monad +import Data.Maybe import Futhark.CodeGen.ImpCode.GPU qualified as Imp import Futhark.CodeGen.ImpGen hiding (compileProg) import Futhark.CodeGen.ImpGen.GPU.Base @@ -35,9 +37,21 @@ (concatMap (bodyResult . lambdaBody) lams) } -canBeSinglePass :: [SegBinOp GPUMem] -> Maybe (SegBinOp GPUMem) -canBeSinglePass ops - | all ok ops = +bodyHas :: (Exp GPUMem -> Bool) -> Body GPUMem -> Bool +bodyHas f = any (f' . stmExp) . bodyStms + where + f' e + | f e = True + | otherwise = isNothing $ walkExpM walker e + walker = + identityWalker + { walkOnBody = const $ guard . not . bodyHas f + } + +canBeSinglePass :: [SegBinOp GPUMem] -> KernelBody GPUMem -> Maybe (SegBinOp GPUMem) +canBeSinglePass ops kbody + | all ok ops, + not $ bodyHas freshArray (Body () (kernelBodyStms kbody) []) = Just $ combineScans ops | otherwise = Nothing @@ -45,6 +59,19 @@ ok op = segBinOpShape op == mempty && all primType (lambdaReturnType (segBinOpLambda op)) + && not (bodyHas isAssert (lambdaBody (segBinOpLambda op))) + isAssert (BasicOp Assert {}) = True + isAssert _ = False + -- XXX: Currently single pass scans cannot handle construction of + -- arrays in the kernel body (#2013), because of insufficient + -- memory expansion. This can in principle be fixed. + freshArray (BasicOp Manifest {}) = True + freshArray (BasicOp Iota {}) = True + freshArray (BasicOp Replicate {}) = True + freshArray (BasicOp Scratch {}) = True + freshArray (BasicOp Concat {}) = True + freshArray (BasicOp ArrayLit {}) = True + freshArray _ = False -- | Compile 'SegScan' instance to host-level code with calls to -- various kernels. @@ -60,7 +87,10 @@ target <- hostTarget <$> askEnv case target of CUDA - | Just scan' <- canBeSinglePass scans -> + | Just scan' <- canBeSinglePass scans kbody -> + SinglePass.compileSegScan pat lvl space scan' kbody + HIP + | Just scan' <- canBeSinglePass scans kbody -> SinglePass.compileSegScan pat lvl space scan' kbody _ -> TwoPass.compileSegScan pat lvl space scans kbody emit $ Imp.DebugPrint "" Nothing diff --git a/src/Futhark/CodeGen/ImpGen/GPU/SegScan/SinglePass.hs b/src/Futhark/CodeGen/ImpGen/GPU/SegScan/SinglePass.hs --- a/src/Futhark/CodeGen/ImpGen/GPU/SegScan/SinglePass.hs +++ b/src/Futhark/CodeGen/ImpGen/GPU/SegScan/SinglePass.hs @@ -12,9 +12,9 @@ import Futhark.CodeGen.ImpGen import Futhark.CodeGen.ImpGen.GPU.Base import Futhark.IR.GPUMem -import Futhark.IR.Mem.IxFun qualified as IxFun +import Futhark.IR.Mem.LMAD qualified as LMAD import Futhark.Transform.Rename -import Futhark.Util (takeLast) +import Futhark.Util (mapAccumLM, takeLast) import Futhark.Util.IntegralExp (IntegralExp (mod, rem), divUp, quot) import Prelude hiding (mod, quot, rem) @@ -24,7 +24,7 @@ yParams scan = drop (length (segBinOpNeutral scan)) (lambdaParams (segBinOpLambda scan)) -alignTo :: IntegralExp a => a -> a -> a +alignTo :: (IntegralExp a) => a -> a -> a alignTo x a = (x `divUp` a) * a createLocalArrays :: @@ -41,7 +41,7 @@ maxTransposedArraySize = foldl1 sMax64 $ map (\ty -> workSize * primByteSize ty) types - warpSize :: Num a => a + warpSize :: (Num a) => a warpSize = 32 maxWarpExchangeSize = foldl (\acc tySize -> alignTo acc tySize + tySize * fromInteger warpSize) 0 $ @@ -49,18 +49,23 @@ maxLookbackSize = maxWarpExchangeSize + warpSize size = Imp.bytes $ maxLookbackSize `sMax64` prefixArraysSize `sMax64` maxTransposedArraySize - varTE :: TV Int64 -> TPrimExp Int64 VName - varTE = le64 . tvVar - - byteOffsets <- - mapM (fmap varTE . dPrimV "byte_offsets") $ - scanl (\off tySize -> alignTo off tySize + pe64 groupSize * tySize) 0 $ - map primByteSize types + (_, byteOffsets) <- + mapAccumLM + ( \off tySize -> do + off' <- dPrimVE "byte_offsets" $ alignTo off tySize + pe64 groupSize * tySize + pure (off', off) + ) + 0 + $ map primByteSize types - warpByteOffsets <- - mapM (fmap varTE . dPrimV "warp_byte_offset") $ - scanl (\off tySize -> alignTo off tySize + warpSize * tySize) warpSize $ - map primByteSize types + (_, warpByteOffsets) <- + mapAccumLM + ( \off tySize -> do + off' <- dPrimVE "warp_byte_offset" $ alignTo off tySize + warpSize * tySize + pure (off', off) + ) + warpSize + $ map primByteSize types sComment "Allocate reused shared memeory" $ pure () @@ -85,7 +90,7 @@ ty (Shape [groupSize]) localMem - $ IxFun.iotaOffset off' [pe64 groupSize] + $ LMAD.iota off' [pe64 groupSize] warpscan <- sArrayInMem "warpscan" int8 (Shape [constant (warpSize :: Int64)]) localMem warpExchanges <- @@ -96,7 +101,7 @@ ty (Shape [constant (warpSize :: Int64)]) localMem - $ IxFun.iotaOffset off' [warpSize] + $ LMAD.iota off' [warpSize] pure (sharedId, transposedArrays, prefixArrays, warpscan, warpExchanges) @@ -226,7 +231,7 @@ primByteSize' = max 4 . primByteSize sumT' = foldl (\bytes typ -> bytes + primByteSize' typ) 0 tys `div` 4 maxT = maximum (map primByteSize tys) - m :: Num a => a + m :: (Num a) => a m = fromIntegral $ max 1 $ min mem_constraint reg_constraint -- TODO: Make these constants dynamic by querying device k_reg = 64 @@ -250,13 +255,13 @@ not_segmented_e = if segmented then false else true segment_size = last dims' - statusX, statusA, statusP :: Num a => a + statusX, statusA, statusP :: (Num a) => a statusX = 0 statusA = 1 statusP = 2 - emit $ Imp.DebugPrint "Sequential elements per thread (m):" $ Just $ untyped (m :: Imp.TExp Int32) - emit $ Imp.DebugPrint "Memory constraint " $ Just $ untyped (fromIntegral mem_constraint :: Imp.TExp Int32) + emit $ Imp.DebugPrint "Sequential elements per thread (m) " $ Just $ untyped (m :: Imp.TExp Int32) + emit $ Imp.DebugPrint "Memory constraint" $ Just $ untyped (fromIntegral mem_constraint :: Imp.TExp Int32) emit $ Imp.DebugPrint "Register constraint" $ Just $ untyped (fromIntegral reg_constraint :: Imp.TExp Int32) emit $ Imp.DebugPrint "sumT'" $ Just $ untyped (fromIntegral sumT' :: Imp.TExp Int32) @@ -359,7 +364,7 @@ sFor "i" m $ \i -> do sharedIdx <- dPrimV "sharedIdx" $ kernelLocalThreadId constants * m + i copyDWIMFix priv [sExt64 i] (Var trans) [sExt64 $ tvExp sharedIdx] - sOp localBarrier + sOp $ Imp.ErrorSync Imp.FenceLocal sComment "Per thread scan" $ do -- We don't need to touch the first element, so only m-1 @@ -410,7 +415,7 @@ scanOp' prefixArrays - sOp localBarrier + sOp $ Imp.ErrorSync Imp.FenceLocal let firstThread acc prefixes = copyDWIMFix (tvVar acc) [] (Var prefixes) [sExt64 (kernelGroupSize constants) - 1] @@ -547,6 +552,7 @@ \(prefix, ty, res) -> prefix <-- TPrimExp (toExp' ty res) sOp localFence ) + -- end sWhile -- end sIf sWhen (kernelLocalThreadId constants .==. 0) $ do @@ -640,3 +646,4 @@ sComment "If this is the last block, reset the dynamicId" $ sWhen (tvExp dynamicId .==. num_groups' - 1) $ copyDWIMFix globalId [0] (constant (0 :: Int32)) [] +{-# NOINLINE compileSegScan #-} diff --git a/src/Futhark/CodeGen/ImpGen/GPU/SegScan/TwoPass.hs b/src/Futhark/CodeGen/ImpGen/GPU/SegScan/TwoPass.hs --- a/src/Futhark/CodeGen/ImpGen/GPU/SegScan/TwoPass.hs +++ b/src/Futhark/CodeGen/ImpGen/GPU/SegScan/TwoPass.hs @@ -12,7 +12,7 @@ import Futhark.CodeGen.ImpGen import Futhark.CodeGen.ImpGen.GPU.Base import Futhark.IR.GPUMem -import Futhark.IR.Mem.IxFun qualified as IxFun +import Futhark.IR.Mem.LMAD qualified as LMAD import Futhark.Transform.Rename import Futhark.Util (takeLast) import Futhark.Util.IntegralExp (divUp, quot, rem) @@ -42,9 +42,7 @@ let shape' = Shape [num_threads] <> shape arr <- lift . sArray "scan_arr" pt shape' mem $ - IxFun.iota $ - map pe64 $ - shapeDims shape' + LMAD.iota 0 (map pe64 $ shapeDims shape') pure (arr, []) _ -> do let pt = elemType $ paramType p 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 @@ -5,6 +5,7 @@ module Futhark.CodeGen.ImpGen.GPU.ToOpenCL ( kernelsToOpenCL, kernelsToCUDA, + kernelsToHIP, ) where @@ -26,13 +27,21 @@ import Futhark.CodeGen.ImpCode.OpenCL hiding (Program) import Futhark.CodeGen.ImpCode.OpenCL qualified as ImpOpenCL import Futhark.CodeGen.RTS.C (atomicsH, halfH) +import Futhark.CodeGen.RTS.CUDA (preludeCU) +import Futhark.CodeGen.RTS.OpenCL (copyCL, preludeCL, transposeCL) import Futhark.Error (compilerLimitationS) import Futhark.MonadFreshNames -import Futhark.Util (zEncodeText) +import Futhark.Util (mapAccumLM, zEncodeText) +import Futhark.Util.IntegralExp (rem) import Language.C.Quote.OpenCL qualified as C import Language.C.Syntax qualified as C import NeatInterpolation (untrimming) +import Prelude hiding (rem) +-- | Generate HIP host and device code. +kernelsToHIP :: ImpGPU.Program -> ImpOpenCL.Program +kernelsToHIP = translateGPU TargetHIP + -- | Generate CUDA host and device code. kernelsToCUDA :: ImpGPU.Program -> ImpOpenCL.Program kernelsToCUDA = translateGPU TargetCUDA @@ -87,6 +96,7 @@ where genPrelude TargetOpenCL = genOpenClPrelude genPrelude TargetCUDA = const genCUDAPrelude + genPrelude TargetHIP = const genHIPPrelude -- | Due to simplifications after kernel extraction, some threshold -- parameters may contain KernelPaths that reference threshold @@ -139,7 +149,7 @@ pointerQuals s = error $ "'" ++ s ++ "' is not an OpenCL kernel address space." -- In-kernel name and per-workgroup size in bytes. -type LocalMemoryUse = (VName, Count Bytes Exp) +type LocalMemoryUse = (VName, Count Bytes (TExp Int64)) data KernelState = KernelState { kernelLocalMemory :: [LocalMemoryUse], @@ -259,12 +269,12 @@ [C.cparam|__global typename int64_t *global_failure_args|] ] (f, cstate) = - genGPUCode env FunMode (functionBody device_func) failures $ + genGPUCode env FunMode (declsFirst $ functionBody device_func) failures $ GC.compileFun mempty params (fname, device_func) in (f, GC.compUserState cstate) else let (f, cstate) = - genGPUCode env FunMode (functionBody device_func) failures $ + genGPUCode env FunMode (declsFirst $ functionBody device_func) failures $ GC.compileVoidFun mempty (fname, device_func) in (f, GC.compUserState cstate) @@ -338,46 +348,20 @@ let (kernel_body, cstate) = genGPUCode env KernelMode (kernelBody kernel) failures . GC.collect $ do - body <- GC.collect $ GC.compileCode $ kernelBody kernel + body <- GC.collect $ GC.compileCode $ declsFirst $ kernelBody kernel -- No need to free, as we cannot allocate memory in kernels. mapM_ GC.item =<< GC.declAllocatedMem mapM_ GC.item body kstate = GC.compUserState cstate - (local_memory_args, local_memory_params, local_memory_init) = - unzip3 . flip evalState (blankNameSource :: VNameSource) $ - mapM (prepareLocalMemory target) $ - kernelLocalMemory kstate - - -- CUDA has very strict restrictions on the number of blocks - -- permitted along the 'y' and 'z' dimensions of the grid - -- (1<<16). To work around this, we are going to dynamically - -- permute the block dimensions to move the largest one to the - -- 'x' dimension, which has a higher limit (1<<31). This means - -- we need to extend the kernel with extra parameters that - -- contain information about this permutation, but we only do - -- this for multidimensional kernels (at the time of this - -- writing, only transposes). The corresponding arguments are - -- added automatically in CCUDA.hs. - (perm_params, block_dim_init) = - case (target, num_groups) of - (TargetCUDA, [_, _, _]) -> - ( [ [C.cparam|const int block_dim0|], - [C.cparam|const int block_dim1|], - [C.cparam|const int block_dim2|] - ], - mempty - ) - _ -> - ( mempty, - [ [C.citem|const int block_dim0 = 0;|], - [C.citem|const int block_dim1 = 1;|], - [C.citem|const int block_dim2 = 2;|] - ] - ) - (const_defs, const_undefs) = unzip $ mapMaybe constDef $ kernelUses kernel + let (local_memory_bytes, (local_memory_params, local_memory_args, local_memory_init)) = + second unzip3 $ + evalState + (mapAccumLM prepareLocalMemory 0 (kernelLocalMemory kstate)) + blankNameSource + let (use_params, unpack_params) = unzip $ mapMaybe useAsParam $ kernelUses kernel @@ -430,29 +414,38 @@ [C.cparam|__global typename int64_t *global_failure_args|] ] + (local_memory_param, prepare_local_memory) = + case target of + TargetOpenCL -> + ( [[C.cparam|__local typename uint64_t* local_mem_aligned|]], + [C.citems|__local unsigned char* local_mem = local_mem_aligned;|] + ) + TargetCUDA -> (mempty, mempty) + TargetHIP -> (mempty, mempty) + params = - perm_params + local_memory_param ++ take (numFailureParams safety) failure_params - ++ catMaybes local_memory_params + ++ local_memory_params ++ use_params attribute = - case (target, mapM isConst $ kernelGroupSize kernel) of - (TargetOpenCL, Just [x, y, z]) -> - "__attribute__((reqd_work_group_size" <> prettyText (x, y, z) <> "))\n" - (TargetOpenCL, Just [x, y]) -> - "__attribute__((reqd_work_group_size" <> prettyText (x, y, 1 :: Int) <> "))\n" - (TargetOpenCL, Just [x]) -> - "__attribute__((reqd_work_group_size" <> prettyText (x, 1 :: Int, 1 :: Int) <> "))\n" - _ -> "" + case mapM isConst $ kernelGroupSize kernel of + Just [x, y, z] -> + "FUTHARK_KERNEL_SIZED" <> prettyText (x, y, z) <> "\n" + Just [x, y] -> + "FUTHARK_KERNEL_SIZED" <> prettyText (x, y, 1 :: Int) <> "\n" + Just [x] -> + "FUTHARK_KERNEL_SIZED" <> prettyText (x, 1 :: Int, 1 :: Int) <> "\n" + _ -> "FUTHARK_KERNEL\n" kernel_fun = attribute <> funcText - [C.cfun|__kernel void $id:name ($params:params) { + [C.cfun|void $id:name ($params:params) { $items:(mconcat unpack_params) $items:const_defs - $items:block_dim_init + $items:prepare_local_memory $items:local_memory_init $items:error_init $items:kernel_body @@ -468,29 +461,25 @@ clFailures = kernelFailures kstate } - -- The argument corresponding to the global_failure parameters is - -- added automatically later. - let args = catMaybes local_memory_args ++ kernelArgs kernel + -- The error handling stuff is automatically added later. + let args = local_memory_args ++ kernelArgs kernel - pure $ LaunchKernel safety name args num_groups group_size + pure $ LaunchKernel safety name local_memory_bytes args num_groups group_size where name = kernelName kernel num_groups = kernelNumGroups kernel group_size = kernelGroupSize kernel + padTo8 e = e + ((8 - (e `rem` 8)) `rem` 8) - prepareLocalMemory TargetOpenCL (mem, size) = do - mem_aligned <- newVName $ baseString mem ++ "_aligned" - pure - ( Just $ SharedMemoryKArg size, - Just [C.cparam|__local volatile typename int64_t* $id:mem_aligned|], - [C.citem|__local volatile unsigned char* restrict $id:mem = (__local volatile unsigned char*) $id:mem_aligned;|] - ) - prepareLocalMemory TargetCUDA (mem, size) = do + prepareLocalMemory (Count offset) (mem, Count size) = do param <- newVName $ baseString mem ++ "_offset" + let offset' = offset + padTo8 size pure - ( Just $ SharedMemoryKArg size, - Just [C.cparam|uint $id:param|], - [C.citem|volatile $ty:defaultMemBlockType $id:mem = &shared_mem[$id:param];|] + ( bytes offset', + ( [C.cparam|typename int64_t $id:param|], + ValueKArg (untyped offset) $ IntType Int64, + [C.citem|volatile __local $ty:defaultMemBlockType $id:mem = &local_mem[$id:param];|] + ) ) useAsParam :: KernelUse -> Maybe (C.Param, [C.BlockItem]) @@ -529,156 +518,37 @@ undef = "#undef " <> idText (C.toIdent v mempty) constDef _ = Nothing -genOpenClPrelude :: S.Set PrimType -> T.Text -genOpenClPrelude ts = - [untrimming| -// Clang-based OpenCL implementations need this for 'static' to work. -#ifdef cl_clang_storage_class_specifiers -#pragma OPENCL EXTENSION cl_clang_storage_class_specifiers : enable -#endif -#pragma OPENCL EXTENSION cl_khr_byte_addressable_store : enable -$enable_f64 -// Some OpenCL programs dislike empty progams, or programs with no kernels. -// Declare a dummy kernel to ensure they remain our friends. -__kernel void dummy_kernel(__global unsigned char *dummy, int n) -{ - const int thread_gid = get_global_id(0); - if (thread_gid >= n) return; -} - -#pragma OPENCL EXTENSION cl_khr_int64_base_atomics : enable -#pragma OPENCL EXTENSION cl_khr_int64_extended_atomics : enable - -typedef char int8_t; -typedef short int16_t; -typedef int int32_t; -typedef long int64_t; - -typedef uchar uint8_t; -typedef ushort uint16_t; -typedef uint uint32_t; -typedef ulong uint64_t; - -// NVIDIAs OpenCL does not create device-wide memory fences (see #734), so we -// use inline assembly if we detect we are on an NVIDIA GPU. -#ifdef cl_nv_pragma_unroll -static inline void mem_fence_global() { - asm("membar.gl;"); -} -#else -static inline void mem_fence_global() { - mem_fence(CLK_LOCAL_MEM_FENCE | CLK_GLOBAL_MEM_FENCE); -} -#endif -static inline void mem_fence_local() { - mem_fence(CLK_LOCAL_MEM_FENCE); -} -|] - <> halfH +commonPrelude :: T.Text +commonPrelude = + halfH <> cScalarDefs <> atomicsH + <> transposeCL + <> copyCL + +genOpenClPrelude :: S.Set PrimType -> T.Text +genOpenClPrelude ts = + "#define FUTHARK_OPENCL\n" + <> enable_f64 + <> preludeCL + <> commonPrelude where enable_f64 | FloatType Float64 `S.member` ts = - [untrimming| - #pragma OPENCL EXTENSION cl_khr_fp64 : enable - #define FUTHARK_F64_ENABLED - |] + [untrimming|#define FUTHARK_F64_ENABLED|] | otherwise = mempty genCUDAPrelude :: T.Text genCUDAPrelude = - [untrimming| -#define FUTHARK_CUDA -#define FUTHARK_F64_ENABLED - -typedef char int8_t; -typedef short int16_t; -typedef int int32_t; -typedef long long int64_t; -typedef unsigned char uint8_t; -typedef unsigned short uint16_t; -typedef unsigned int uint32_t; -typedef unsigned long long uint64_t; -typedef uint8_t uchar; -typedef uint16_t ushort; -typedef uint32_t uint; -typedef uint64_t ulong; -#define __kernel extern "C" __global__ __launch_bounds__(MAX_THREADS_PER_BLOCK) -#define __global -#define __local -#define __private -#define __constant -#define __write_only -#define __read_only - -static inline int get_group_id_fn(int block_dim0, int block_dim1, int block_dim2, int d) { - switch (d) { - case 0: d = block_dim0; break; - case 1: d = block_dim1; break; - case 2: d = block_dim2; break; - } - switch (d) { - case 0: return blockIdx.x; - case 1: return blockIdx.y; - case 2: return blockIdx.z; - default: return 0; - } -} -#define get_group_id(d) get_group_id_fn(block_dim0, block_dim1, block_dim2, d) - -static inline int get_num_groups_fn(int block_dim0, int block_dim1, int block_dim2, int d) { - switch (d) { - case 0: d = block_dim0; break; - case 1: d = block_dim1; break; - case 2: d = block_dim2; break; - } - switch(d) { - case 0: return gridDim.x; - case 1: return gridDim.y; - case 2: return gridDim.z; - default: return 0; - } -} -#define get_num_groups(d) get_num_groups_fn(block_dim0, block_dim1, block_dim2, d) - -static inline int get_local_id(int d) { - switch (d) { - case 0: return threadIdx.x; - case 1: return threadIdx.y; - case 2: return threadIdx.z; - default: return 0; - } -} - -static inline int get_local_size(int d) { - switch (d) { - case 0: return blockDim.x; - case 1: return blockDim.y; - case 2: return blockDim.z; - default: return 0; - } -} - -#define CLK_LOCAL_MEM_FENCE 1 -#define CLK_GLOBAL_MEM_FENCE 2 -static inline void barrier(int x) { - __syncthreads(); -} -static inline void mem_fence_local() { - __threadfence_block(); -} -static inline void mem_fence_global() { - __threadfence(); -} + "#define FUTHARK_CUDA\n" + <> preludeCU + <> commonPrelude -#define NAN (0.0/0.0) -#define INFINITY (1.0/0.0) -extern volatile __shared__ unsigned char shared_mem[]; -|] - <> halfH - <> cScalarDefs - <> atomicsH +genHIPPrelude :: T.Text +genHIPPrelude = + "#define FUTHARK_HIP\n" + <> preludeCU + <> commonPrelude compilePrimExp :: PrimExp KernelConst -> C.Exp compilePrimExp e = runIdentity $ GC.compilePrimExp compileKernelConst e @@ -733,6 +603,7 @@ GC.opsAllocate = cannotAllocate, GC.opsDeallocate = cannotDeallocate, GC.opsCopy = copyInKernel, + GC.opsCopies = mempty, GC.opsFatMemory = False, GC.opsError = errorInKernel, GC.opsCall = callInKernel, @@ -763,7 +634,7 @@ kernelOps (LocalAlloc name size) = do name' <- newVName $ prettyString name ++ "_backing" GC.modifyUserState $ \s -> - s {kernelLocalMemory = (name', fmap untyped size) : kernelLocalMemory s} + s {kernelLocalMemory = (name', size) : kernelLocalMemory s} GC.stm [C.cstm|$id:name = (__local unsigned char*) $id:name';|] kernelOps (ErrorSync f) = do label <- nextErrorLabel @@ -941,8 +812,12 @@ typesInCode (DeclareArray _ t _) = S.singleton t typesInCode (Allocate _ (Count (TPrimExp e)) _) = typesInExp e typesInCode Free {} = mempty -typesInCode (Copy _ _ (Count (TPrimExp e1)) _ _ (Count (TPrimExp e2)) _ (Count (TPrimExp e3))) = - typesInExp e1 <> typesInExp e2 <> typesInExp e3 +typesInCode (LMADCopy _ shape _ (Count (TPrimExp dstoffset), dststrides) _ (Count (TPrimExp srcoffset), srcstrides)) = + foldMap (typesInExp . untyped . unCount) shape + <> typesInExp dstoffset + <> foldMap (typesInExp . untyped . unCount) dststrides + <> typesInExp srcoffset + <> foldMap (typesInExp . untyped . unCount) srcstrides typesInCode (Write _ (Count (TPrimExp e1)) t _ _ e2) = typesInExp e1 <> S.singleton t <> typesInExp e2 typesInCode (Read _ _ (Count (TPrimExp e1)) t _ _) = diff --git a/src/Futhark/CodeGen/ImpGen/GPU/Transpose.hs b/src/Futhark/CodeGen/ImpGen/GPU/Transpose.hs deleted file mode 100644 --- a/src/Futhark/CodeGen/ImpGen/GPU/Transpose.hs +++ /dev/null @@ -1,425 +0,0 @@ --- | Carefully optimised implementations of GPU transpositions. --- Written in ImpCode so we can compile it to both CUDA and OpenCL. -module Futhark.CodeGen.ImpGen.GPU.Transpose - ( TransposeType (..), - TransposeArgs, - mapTransposeKernel, - ) -where - --- See also Note [32-bit transpositions]. - -import Futhark.CodeGen.ImpCode.GPU -import Futhark.Util.IntegralExp (divUp, quot, rem) -import Prelude hiding (quot, rem) - --- | Which form of transposition to generate code for. -data TransposeType - = TransposeNormal - | TransposeLowWidth - | TransposeLowHeight - | -- | For small arrays that do not - -- benefit from coalescing. - TransposeSmall - deriving (Eq, Ord, Show) - --- | The types of the arguments accepted by a transposition function. -type TransposeArgs int = - ( VName, - TExp int, - VName, - TExp int, - TExp int, - TExp int, - TExp int, - TExp int, - TExp int, - VName - ) - -elemsPerThread :: Num a => a -elemsPerThread = 8 - -mapTranspose :: forall int. IntExp int => (PrimType, VName -> TExp int) -> TExp int -> TransposeArgs int -> PrimType -> TransposeType -> KernelCode -mapTranspose (int, le) block_dim args t kind = - case kind of - TransposeSmall -> - mconcat - [ get_ids, - dec our_array_offset $ le get_global_id_0 `quot` (height * width) * (height * width), - dec x_index $ (le get_global_id_0 `rem` (height * width)) `quot` height, - dec y_index $ le get_global_id_0 `rem` height, - DeclareScalar val Nonvolatile t, - dec odata_offset $ - (basic_odata_offset `quot` primByteSize t) + le our_array_offset, - dec idata_offset $ - (basic_idata_offset `quot` primByteSize t) + le our_array_offset, - dec index_in $ le y_index * width + le x_index, - dec index_out $ le x_index * height + le y_index, - when - (le get_global_id_0 .<. width * height * num_arrays) - ( mconcat - [ Read val idata (elements $ toOffset $ le idata_offset + le index_in) t (Space "global") Nonvolatile, - Write odata (elements $ toOffset $ le odata_offset + le index_out) t (Space "global") Nonvolatile (var val t) - ] - ) - ] - TransposeLowWidth -> - mkTranspose $ - lowDimBody - (le get_group_id_0 * block_dim + (le get_local_id_0 `quot` muly)) - ( le get_group_id_1 * block_dim * muly - + le get_local_id_1 - + (le get_local_id_0 `rem` muly) * block_dim - ) - ( le get_group_id_1 * block_dim * muly - + le get_local_id_0 - + (le get_local_id_1 `rem` muly) * block_dim - ) - (le get_group_id_0 * block_dim + (le get_local_id_1 `quot` muly)) - TransposeLowHeight -> - mkTranspose $ - lowDimBody - ( le get_group_id_0 * block_dim * mulx - + le get_local_id_0 - + (le get_local_id_1 `rem` mulx) * block_dim - ) - (le get_group_id_1 * block_dim + (le get_local_id_1 `quot` mulx)) - (le get_group_id_1 * block_dim + (le get_local_id_0 `quot` mulx)) - ( le get_group_id_0 * block_dim * mulx - + le get_local_id_1 - + (le get_local_id_0 `rem` mulx) * block_dim - ) - TransposeNormal -> - mkTranspose $ - mconcat - [ dec x_index $ le get_global_id_0, - dec y_index $ le get_group_id_1 * tile_dim + le get_local_id_1, - DeclareScalar val Nonvolatile t, - when (le x_index .<. width) $ - For j (untyped (elemsPerThread :: TExp int)) $ - let i = le j * (tile_dim `quot` elemsPerThread) - in mconcat - [ dec index_in $ (le y_index + i) * width + le x_index, - when (le y_index + i .<. height) $ - mconcat - [ Read - val - idata - (elements $ toOffset $ le idata_offset + le index_in) - t - (Space "global") - Nonvolatile, - Write - block - ( elements $ - toOffset $ - (le get_local_id_1 + i) * (tile_dim + 1) - + le get_local_id_0 - ) - t - (Space "local") - Nonvolatile - (var val t) - ] - ], - Op $ Barrier FenceLocal, - SetScalar x_index $ untyped $ le get_group_id_1 * tile_dim + le get_local_id_0, - SetScalar y_index $ untyped $ le get_group_id_0 * tile_dim + le get_local_id_1, - when (le x_index .<. height) $ - For j (untyped (elemsPerThread :: TExp int)) $ - let i = le j * (tile_dim `quot` elemsPerThread) - in mconcat - [ dec index_out $ (le y_index + i) * height + le x_index, - when (le y_index + i .<. width) $ - mconcat - [ Read - val - block - ( elements . toOffset $ - le get_local_id_0 * (tile_dim + 1) + le get_local_id_1 + i - ) - t - (Space "local") - Nonvolatile, - Write - odata - (elements $ toOffset $ le odata_offset + le index_out) - t - (Space "global") - Nonvolatile - (var val t) - ] - ] - ] - where - toOffset :: TExp int -> TExp Int64 - toOffset = sExt64 - - dec v (TPrimExp e) = - DeclareScalar v Nonvolatile (primExpType e) <> SetScalar v e - tile_dim = 2 * block_dim - - when a b = If a b mempty - - ( odata, - basic_odata_offset, - idata, - basic_idata_offset, - width, - height, - mulx, - muly, - num_arrays, - block - ) = args - - -- Be extremely careful when editing this list to ensure that - -- the names match up. Also, be careful that the tags on - -- these names do not conflict with the tags of the - -- surrounding code. We accomplish the latter by using very - -- low tags (normal variables start at least in the low - -- hundreds). - [ our_array_offset, - x_index, - y_index, - odata_offset, - idata_offset, - index_in, - index_out, - get_global_id_0, - get_local_id_0, - get_local_id_1, - get_local_size_0, - get_group_id_0, - get_group_id_1, - get_group_id_2, - j, - val - ] = - zipWith (flip VName) [30 ..] $ - map - nameFromString - [ "our_array_offset", - "x_index", - "y_index", - "odata_offset", - "idata_offset", - "index_in", - "index_out", - "get_global_id_0", - "get_local_id_0", - "get_local_id_1", - "get_local_size_0", - "get_group_id_0", - "get_group_id_1", - "get_group_id_2", - "j", - "val" - ] - - get_ids = - mconcat - [ DeclareScalar get_local_id_0 Nonvolatile int, - Op $ GetLocalId get_local_id_0 0, - DeclareScalar get_local_id_1 Nonvolatile int, - Op $ GetLocalId get_local_id_1 1, - DeclareScalar get_group_id_0 Nonvolatile int, - Op $ GetGroupId get_group_id_0 0, - DeclareScalar get_group_id_1 Nonvolatile int, - Op $ GetGroupId get_group_id_1 1, - DeclareScalar get_group_id_2 Nonvolatile int, - Op $ GetGroupId get_group_id_2 2, - DeclareScalar get_local_size_0 Nonvolatile int, - Op $ GetLocalSize get_local_size_0 0, - DeclareScalar get_global_id_0 Nonvolatile int, - SetScalar get_global_id_0 $ untyped $ le get_group_id_0 * le get_local_size_0 + le get_local_id_0 - ] - - mkTranspose body = - mconcat - [ get_ids, - dec our_array_offset $ le get_group_id_2 * width * height, - dec odata_offset $ - (basic_odata_offset `quot` primByteSize t) + le our_array_offset, - dec idata_offset $ - (basic_idata_offset `quot` primByteSize t) + le our_array_offset, - body - ] - - lowDimBody x_in_index y_in_index x_out_index y_out_index = - mconcat - [ dec x_index x_in_index, - dec y_index y_in_index, - DeclareScalar val Nonvolatile t, - dec index_in $ le y_index * width + le x_index, - when (le x_index .<. width .&&. le y_index .<. height) $ - mconcat - [ Read - val - idata - (elements $ sExt64 $ le idata_offset + le index_in) - t - (Space "global") - Nonvolatile, - Write - block - (elements $ sExt64 $ le get_local_id_1 * (block_dim + 1) + le get_local_id_0) - t - (Space "local") - Nonvolatile - (var val t) - ], - Op $ Barrier FenceLocal, - SetScalar x_index $ untyped x_out_index, - SetScalar y_index $ untyped y_out_index, - dec index_out $ le y_index * height + le x_index, - when (le x_index .<. height .&&. le y_index .<. width) $ - mconcat - [ Read - val - block - (elements $ toOffset $ le get_local_id_0 * (block_dim + 1) + le get_local_id_1) - t - (Space "local") - Nonvolatile, - Write - odata - (elements $ toOffset (le odata_offset + le index_out)) - t - (Space "global") - Nonvolatile - (var val t) - ] - ] - -lowDimKernelAndGroupSize :: - IntExp int => - TExp int -> - TExp int -> - TExp int -> - TExp int -> - ([TExp int], [TExp int]) -lowDimKernelAndGroupSize block_dim num_arrays x_elems y_elems = - ( [ x_elems `divUp` block_dim, - y_elems `divUp` block_dim, - num_arrays - ], - [block_dim, block_dim, 1] - ) - --- | Generate a transpose kernel. There is special support to handle --- input arrays with low width, low height, or both. --- --- Normally when transposing a @[2][n]@ array we would use a @FUT_BLOCK_DIM x --- FUT_BLOCK_DIM@ group to process a @[2][FUT_BLOCK_DIM]@ slice of the input --- array. This would mean that many of the threads in a group would be inactive. --- We try to remedy this by using a special kernel that will process a larger --- part of the input, by using more complex indexing. In our example, we could --- use all threads in a group if we are processing @(2/FUT_BLOCK_DIM)@ as large --- a slice of each rows per group. The variable @mulx@ contains this factor for --- the kernel to handle input arrays with low height. --- --- See issue #308 on GitHub for more details. --- --- These kernels are optimized to ensure all global reads and writes --- are coalesced, and to avoid bank conflicts in shared memory. Each --- thread group transposes a 2D tile of block_dim*2 by block_dim*2 --- elements. The size of a thread group is block_dim/2 by --- block_dim*2, meaning that each thread will process 4 elements in a --- 2D tile. The shared memory array containing the 2D tile consists --- of block_dim*2 by block_dim*2+1 elements. Padding each row with --- an additional element prevents bank conflicts from occuring when --- the tile is accessed column-wise. -mapTransposeKernel :: - forall int. - IntExp int => - (PrimType, VName -> TExp int) -> - String -> - Integer -> - TransposeArgs int -> - PrimType -> - TransposeType -> - Kernel -mapTransposeKernel (int, le) desc block_dim_int args t kind = - Kernel - { kernelBody = - DeclareMem block (Space "local") - <> Op (LocalAlloc block block_size) - <> mapTranspose (int, le) block_dim args t kind, - kernelUses = uses, - kernelNumGroups = map untyped num_groups, - kernelGroupSize = map (Left . untyped) group_size, - kernelName = nameFromString (name <> "_" <> prettyString int), - kernelFailureTolerant = True, - kernelCheckLocalMemory = False - } - where - pad2DBytes k = k * (k + 1) * primByteSize t - block_size :: Count Bytes (TExp Int64) - block_size = - bytes $ - case kind of - TransposeSmall -> 1 - -- Not used, but AMD's OpenCL does not like zero-size local - -- memory. - TransposeNormal -> fromInteger $ pad2DBytes $ 2 * block_dim_int - TransposeLowWidth -> fromInteger $ pad2DBytes block_dim_int - TransposeLowHeight -> fromInteger $ pad2DBytes block_dim_int - block_dim = fromInteger block_dim_int :: TExp int - - ( odata, - basic_odata_offset, - idata, - basic_idata_offset, - width, - height, - mulx, - muly, - num_arrays, - block - ) = args - - (num_groups, group_size) = - case kind of - TransposeSmall -> - ( [(num_arrays * width * height) `divUp` (block_dim * block_dim)], - [block_dim * block_dim] - ) - TransposeLowWidth -> - lowDimKernelAndGroupSize block_dim num_arrays width $ height `divUp` muly - TransposeLowHeight -> - lowDimKernelAndGroupSize block_dim num_arrays (width `divUp` mulx) height - TransposeNormal -> - let actual_dim = block_dim * 2 - in ( [ width `divUp` actual_dim, - height `divUp` actual_dim, - num_arrays - ], - [actual_dim, actual_dim `quot` elemsPerThread, 1] - ) - - uses = - map - (`ScalarUse` IntType Int64) - ( namesToList $ - mconcat $ - map - freeIn - [ basic_odata_offset, - basic_idata_offset, - num_arrays, - width, - height, - mulx, - muly - ] - ) - ++ map MemoryUse [odata, idata] - - name = - case kind of - TransposeSmall -> desc ++ "_small" - TransposeLowHeight -> desc ++ "_low_height" - TransposeLowWidth -> desc ++ "_low_width" - TransposeNormal -> desc diff --git a/src/Futhark/CodeGen/ImpGen/HIP.hs b/src/Futhark/CodeGen/ImpGen/HIP.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/CodeGen/ImpGen/HIP.hs @@ -0,0 +1,17 @@ +-- | Code generation for ImpCode with HIP kernels. +module Futhark.CodeGen.ImpGen.HIP + ( compileProg, + Warnings, + ) +where + +import Data.Bifunctor (second) +import Futhark.CodeGen.ImpCode.OpenCL +import Futhark.CodeGen.ImpGen.GPU +import Futhark.CodeGen.ImpGen.GPU.ToOpenCL +import Futhark.IR.GPUMem +import Futhark.MonadFreshNames + +-- | Compile the program to ImpCode with HIP kernels. +compileProg :: (MonadFreshNames m) => Prog GPUMem -> m (Warnings, Program) +compileProg prog = second kernelsToHIP <$> compileProgHIP prog 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 @@ -189,7 +189,7 @@ -- | Compile the program. compileProg :: - MonadFreshNames m => + (MonadFreshNames m) => Prog MCMem -> m (Warnings, Imp.Definitions Imp.Multicore) compileProg = 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 @@ -142,7 +142,7 @@ compileThreadResult _ _ RegTileReturns {} = compilerBugS "compileThreadResult: RegTileReturns unhandled." -freeParams :: FreeIn a => a -> MulticoreGen [Imp.Param] +freeParams :: (FreeIn a) => a -> MulticoreGen [Imp.Param] freeParams code = do let free = namesToList $ freeIn code ts <- mapM lookupType free diff --git a/src/Futhark/CodeGen/ImpGen/Multicore/SegRed.hs b/src/Futhark/CodeGen/ImpGen/Multicore/SegRed.hs --- a/src/Futhark/CodeGen/ImpGen/Multicore/SegRed.hs +++ b/src/Futhark/CodeGen/ImpGen/Multicore/SegRed.hs @@ -32,7 +32,7 @@ let map_arrs = drop (segBinOpResults reds) $ patElems pat zipWithM_ (compileThreadResult space) map_arrs map_res - red_cont $ segBinOpChunks reds $ zip (map kernelResultSubExp red_res) $ repeat [] + red_cont $ segBinOpChunks reds $ map ((,[]) . kernelResultSubExp) red_res -- | Like 'compileSegRed', but where the body is a monadic action. compileSegRed' :: diff --git a/src/Futhark/CodeGen/ImpGen/OpenCL.hs b/src/Futhark/CodeGen/ImpGen/OpenCL.hs --- a/src/Futhark/CodeGen/ImpGen/OpenCL.hs +++ b/src/Futhark/CodeGen/ImpGen/OpenCL.hs @@ -13,5 +13,5 @@ import Futhark.MonadFreshNames -- | Compile the program to ImpCode with OpenCL kernels. -compileProg :: MonadFreshNames m => Prog GPUMem -> m (Warnings, OpenCL.Program) +compileProg :: (MonadFreshNames m) => Prog GPUMem -> m (Warnings, OpenCL.Program) compileProg prog = second kernelsToOpenCL <$> compileProgOpenCL prog diff --git a/src/Futhark/CodeGen/ImpGen/Sequential.hs b/src/Futhark/CodeGen/ImpGen/Sequential.hs --- a/src/Futhark/CodeGen/ImpGen/Sequential.hs +++ b/src/Futhark/CodeGen/ImpGen/Sequential.hs @@ -13,7 +13,7 @@ import Futhark.MonadFreshNames -- | Compile a 'SeqMem' program to sequential imperative code. -compileProg :: MonadFreshNames m => Prog SeqMem -> m (ImpGen.Warnings, Imp.Program) +compileProg :: (MonadFreshNames m) => Prog SeqMem -> m (ImpGen.Warnings, Imp.Program) compileProg = ImpGen.compileProg () ops Imp.DefaultSpace where ops = ImpGen.defaultOperations opCompiler diff --git a/src/Futhark/CodeGen/ImpGen/Transpose.hs b/src/Futhark/CodeGen/ImpGen/Transpose.hs deleted file mode 100644 --- a/src/Futhark/CodeGen/ImpGen/Transpose.hs +++ /dev/null @@ -1,219 +0,0 @@ --- | A cache-oblivious sequential transposition for CPU execution. --- Generates a recursive function. -module Futhark.CodeGen.ImpGen.Transpose - ( mapTransposeFunction, - transposeArgs, - ) -where - -import Futhark.CodeGen.ImpCode -import Futhark.IR.Prop.Types -import Futhark.Util.IntegralExp -import Prelude hiding (quot) - --- | Take well-typed arguments to the transpose function and produce --- the actual argument list. -transposeArgs :: - PrimType -> - VName -> - Count Bytes (TExp Int64) -> - VName -> - Count Bytes (TExp Int64) -> - TExp Int64 -> - TExp Int64 -> - TExp Int64 -> - [Arg] -transposeArgs pt destmem destoffset srcmem srcoffset num_arrays m n = - [ MemArg destmem, - ExpArg $ untyped $ unCount destoffset `quot` primByteSize pt, - MemArg srcmem, - ExpArg $ untyped $ unCount srcoffset `quot` primByteSize pt, - ExpArg $ untyped num_arrays, - ExpArg $ untyped m, - ExpArg $ untyped n, - ExpArg $ untyped (0 :: TExp Int64), - ExpArg $ untyped m, - ExpArg $ untyped (0 :: TExp Int64), - ExpArg $ untyped n - ] - --- | We need to know the name of the function we are generating, as --- this function is recursive. -mapTransposeFunction :: Name -> PrimType -> Function op -mapTransposeFunction fname pt = - Function - Nothing - [] - params - ( mconcat - [ dec r $ le64 re - le64 rb, - dec c $ le64 ce - le64 cb, - If (le64 num_arrays .==. 1) doTranspose doMapTranspose - ] - ) - where - params = - [ memparam destmem, - intparam destoffset, - memparam srcmem, - intparam srcoffset, - intparam num_arrays, - intparam m, - intparam n, - intparam cb, - intparam ce, - intparam rb, - intparam re - ] - - memparam v = MemParam v DefaultSpace - intparam v = ScalarParam v int64 - - [ destmem, - destoffset, - srcmem, - srcoffset, - num_arrays, - n, - m, - rb, - re, - cb, - ce, - r, - c, - i, - j, - val - ] = - zipWith - (VName . nameFromString) - [ "destmem", - "destoffset", - "srcmem", - "srcoffset", - "num_arrays", - "n", - "m", - "rb", - "re", - "cb", - "ce", - "r", - "c", - "i", - "j", -- local - "val" - ] - [0 ..] - - dec v e = DeclareScalar v Nonvolatile int32 <> SetScalar v (untyped e) - - naiveTranspose = - For j (untyped $ le64 c) $ - For i (untyped $ le64 r) $ - let i' = le64 i + le64 rb - j' = le64 j + le64 cb - in mconcat - [ DeclareScalar val Nonvolatile pt, - Read - val - srcmem - (elements $ le64 srcoffset + i' * le64 m + j') - pt - DefaultSpace - Nonvolatile, - Write - destmem - (elements $ le64 destoffset + j' * le64 n + i') - pt - DefaultSpace - Nonvolatile - (var val pt) - ] - - recArgs (cb', ce', rb', re') = - [ MemArg destmem, - ExpArg $ untyped $ le64 destoffset, - MemArg srcmem, - ExpArg $ untyped $ le64 srcoffset, - ExpArg $ untyped $ le64 num_arrays, - ExpArg $ untyped $ le64 m, - ExpArg $ untyped $ le64 n, - ExpArg $ untyped cb', - ExpArg $ untyped ce', - ExpArg $ untyped rb', - ExpArg $ untyped re' - ] - - cutoff = 64 -- arbitrary - doTranspose = - mconcat - [ If - (le64 r .<=. cutoff .&&. le64 c .<=. cutoff) - naiveTranspose - $ If - (le64 r .>=. le64 c) - ( Call - [] - fname - ( recArgs - ( le64 cb, - le64 ce, - le64 rb, - le64 rb + (le64 r `quot` 2) - ) - ) - <> Call - [] - fname - ( recArgs - ( le64 cb, - le64 ce, - le64 rb + le64 r `quot` 2, - le64 re - ) - ) - ) - ( Call - [] - fname - ( recArgs - ( le64 cb, - le64 cb + (le64 c `quot` 2), - le64 rb, - le64 re - ) - ) - <> Call - [] - fname - ( recArgs - ( le64 cb + le64 c `quot` 2, - le64 ce, - le64 rb, - le64 re - ) - ) - ) - ] - - doMapTranspose = - -- In the map-transpose case, we assume that cb==rb==0, ce==m, - -- re==n. - For i (untyped $ le64 num_arrays) $ - Call - [] - fname - [ MemArg destmem, - ExpArg $ untyped $ le64 destoffset + le64 i * le64 m * le64 n, - MemArg srcmem, - ExpArg $ untyped $ le64 srcoffset + le64 i * le64 m * le64 n, - ExpArg $ untyped (1 :: TExp Int64), - ExpArg $ untyped $ le64 m, - ExpArg $ untyped $ le64 n, - ExpArg $ untyped $ le64 cb, - ExpArg $ untyped $ le64 ce, - ExpArg $ untyped $ le64 rb, - ExpArg $ untyped $ le64 re - ] diff --git a/src/Futhark/CodeGen/RTS/C.hs b/src/Futhark/CodeGen/RTS/C.hs --- a/src/Futhark/CodeGen/RTS/C.hs +++ b/src/Futhark/CodeGen/RTS/C.hs @@ -5,7 +5,10 @@ ( atomicsH, contextH, contextPrototypesH, + copyH, freeListH, + gpuH, + gpuPrototypesH, halfH, lockH, scalarF16H, @@ -22,6 +25,7 @@ ispcUtilH, backendsOpenclH, backendsCudaH, + backendsHipH, backendsCH, backendsMulticoreH, ) @@ -48,6 +52,16 @@ freeListH = $(embedStringFile "rts/c/free_list.h") {-# NOINLINE freeListH #-} +-- | @rts/c/gpu.h@ +gpuH :: T.Text +gpuH = $(embedStringFile "rts/c/gpu.h") +{-# NOINLINE gpuH #-} + +-- | @rts/c/gpu_prototypes.h@ +gpuPrototypesH :: T.Text +gpuPrototypesH = $(embedStringFile "rts/c/gpu_prototypes.h") +{-# NOINLINE gpuPrototypesH #-} + -- | @rts/c/half.h@ halfH :: T.Text halfH = $(embedStringFile "rts/c/half.h") @@ -133,6 +147,11 @@ backendsCudaH = $(embedStringFile "rts/c/backends/cuda.h") {-# NOINLINE backendsCudaH #-} +-- | @rts/c/backends/hip.h@ +backendsHipH :: T.Text +backendsHipH = $(embedStringFile "rts/c/backends/hip.h") +{-# NOINLINE backendsHipH #-} + -- | @rts/c/backends/c.h@ backendsCH :: T.Text backendsCH = $(embedStringFile "rts/c/backends/c.h") @@ -142,3 +161,8 @@ backendsMulticoreH :: T.Text backendsMulticoreH = $(embedStringFile "rts/c/backends/multicore.h") {-# NOINLINE backendsMulticoreH #-} + +-- | @rts/c/copy.h@ +copyH :: T.Text +copyH = $(embedStringFile "rts/c/copy.h") +{-# NOINLINE copyH #-} diff --git a/src/Futhark/CodeGen/RTS/CUDA.hs b/src/Futhark/CodeGen/RTS/CUDA.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/CodeGen/RTS/CUDA.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | Code snippets used by the CUDA backend. +module Futhark.CodeGen.RTS.CUDA (preludeCU) where + +import Data.FileEmbed +import Data.Text qualified as T + +-- | @rts/cuda/prelude.cu@ +preludeCU :: T.Text +preludeCU = $(embedStringFile "rts/cuda/prelude.cu") +{-# NOINLINE preludeCU #-} diff --git a/src/Futhark/CodeGen/RTS/OpenCL.hs b/src/Futhark/CodeGen/RTS/OpenCL.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/CodeGen/RTS/OpenCL.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | Code snippets used by the OpenCL and CUDA backends. +module Futhark.CodeGen.RTS.OpenCL + ( transposeCL, + preludeCL, + copyCL, + ) +where + +import Data.FileEmbed +import Data.Text qualified as T + +-- | @rts/opencl/transpose.cl@ +transposeCL :: T.Text +transposeCL = $(embedStringFile "rts/opencl/transpose.cl") +{-# NOINLINE transposeCL #-} + +-- | @rts/opencl/prelude.cl@ +preludeCL :: T.Text +preludeCL = $(embedStringFile "rts/opencl/prelude.cl") +{-# NOINLINE preludeCL #-} + +-- | @rts/opencl/copy.cl@ +copyCL :: T.Text +copyCL = $(embedStringFile "rts/opencl/copy.cl") +{-# NOINLINE copyCL #-} diff --git a/src/Futhark/Compiler.hs b/src/Futhark/Compiler.hs --- a/src/Futhark/Compiler.hs +++ b/src/Futhark/Compiler.hs @@ -151,7 +151,7 @@ -- | Throw an exception formatted with 'pprProgErrors' if there's -- an error. throwOnProgError :: - MonadError CompilerError m => + (MonadError CompilerError m) => Either (NE.NonEmpty ProgError) a -> m a throwOnProgError = @@ -187,7 +187,7 @@ fmap (map (first includeToString)) . throwOnProgError <=< liftIO . readUntypedLibrary . pure -orDie :: MonadIO m => FutharkM a -> m a +orDie :: (MonadIO m) => FutharkM a -> m a orDie m = liftIO $ do res <- runFutharkM m NotVerbose case res of @@ -197,11 +197,11 @@ Right res' -> pure res' -- | Not verbose, and terminates process on error. -readProgramOrDie :: MonadIO m => FilePath -> m (Warnings, Imports, VNameSource) +readProgramOrDie :: (MonadIO m) => FilePath -> m (Warnings, Imports, VNameSource) readProgramOrDie file = orDie $ readProgramFile mempty file -- | Not verbose, and terminates process on error. -readUntypedProgramOrDie :: MonadIO m => FilePath -> m [(String, E.UncheckedProg)] +readUntypedProgramOrDie :: (MonadIO m) => FilePath -> m [(String, E.UncheckedProg)] readUntypedProgramOrDie file = orDie $ readUntypedProgram file -- | Run an operation that produces warnings, and handle them 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 @@ -96,7 +96,7 @@ type ReaderState = MVar (M.Map ImportName (Maybe (MVar UncheckedImport))) newState :: [ImportName] -> IO ReaderState -newState known = newMVar $ M.fromList $ zip known $ repeat Nothing +newState known = newMVar $ M.fromList $ map (,Nothing) known orderedImports :: [((ImportName, Loc), MVar UncheckedImport)] -> @@ -364,7 +364,7 @@ lpFilePaths = map lfPath . lpFiles unchangedImports :: - MonadIO m => + (MonadIO m) => VNameSource -> VFS -> [LoadedFile CheckedFile] -> @@ -398,7 +398,7 @@ -- | Find out how many of the old imports can be used. Here we are -- forced to be overly conservative, because our type checker -- enforces a linear ordering. -usableLoadedProg :: MonadIO m => LoadedProg -> VFS -> [FilePath] -> m LoadedProg +usableLoadedProg :: (MonadIO m) => LoadedProg -> VFS -> [FilePath] -> m LoadedProg usableLoadedProg (LoadedProg roots imports src) vfs new_roots | sort roots == sort new_roots = do (imports', src') <- unchangedImports src vfs imports diff --git a/src/Futhark/Construct.hs b/src/Futhark/Construct.hs --- a/src/Futhark/Construct.hs +++ b/src/Futhark/Construct.hs @@ -134,7 +134,7 @@ -- value. For expressions that produce multiple values, see -- 'letTupExp'. letSubExp :: - MonadBuilder m => + (MonadBuilder m) => String -> Exp (Rep m) -> m SubExp @@ -143,7 +143,7 @@ -- | Like 'letSubExp', but returns a name rather than a t'SubExp'. letExp :: - MonadBuilder m => + (MonadBuilder m) => String -> Exp (Rep m) -> m VName @@ -161,7 +161,7 @@ -- is 'Update'd with the result of the expression. The name of the -- updated array is returned. letInPlace :: - MonadBuilder m => + (MonadBuilder m) => String -> VName -> Slice SubExp -> @@ -198,14 +198,14 @@ -- lead to any code generation. This is supposed to be used alongside -- the other monadic expression functions, such as 'eIf'. eSubExp :: - MonadBuilder m => + (MonadBuilder m) => SubExp -> m (Exp (Rep m)) eSubExp = pure . BasicOp . SubExp -- | Treat a parameter as a monadic expression. eParam :: - MonadBuilder m => + (MonadBuilder m) => Param t -> m (Exp (Rep m)) eParam = eSubExp . Var . paramName @@ -292,7 +292,7 @@ -- | Construct a v'BinOp' expression with the given operator. eBinOp :: - MonadBuilder m => + (MonadBuilder m) => BinOp -> m (Exp (Rep m)) -> m (Exp (Rep m)) -> @@ -304,7 +304,7 @@ -- | Construct a v'UnOp' expression with the given operator. eUnOp :: - MonadBuilder m => + (MonadBuilder m) => UnOp -> m (Exp (Rep m)) -> m (Exp (Rep m)) @@ -312,7 +312,7 @@ -- | Construct a v'CmpOp' expression with the given comparison. eCmpOp :: - MonadBuilder m => + (MonadBuilder m) => CmpOp -> m (Exp (Rep m)) -> m (Exp (Rep m)) -> @@ -324,7 +324,7 @@ -- | Construct a v'ConvOp' expression with the given conversion. eConvOp :: - MonadBuilder m => + (MonadBuilder m) => ConvOp -> m (Exp (Rep m)) -> m (Exp (Rep m)) @@ -335,7 +335,7 @@ -- | Construct a 'SSignum' expression. Fails if the provided -- expression is not of integer type. eSignum :: - MonadBuilder m => + (MonadBuilder m) => m (Exp (Rep m)) -> m (Exp (Rep m)) eSignum em = do @@ -350,7 +350,7 @@ -- | Copy a value. eCopy :: - MonadBuilder m => + (MonadBuilder m) => m (Exp (Rep m)) -> m (Exp (Rep m)) eCopy e = BasicOp . Replicate mempty <$> (letSubExp "copy_arg" =<< e) @@ -375,7 +375,7 @@ -- bind the body of the lambda. The expressions must produce only a -- single value each. eLambda :: - MonadBuilder m => + (MonadBuilder m) => Lambda (Rep m) -> [m (Exp (Rep m))] -> m [SubExpRes] @@ -386,7 +386,7 @@ bindParam param arg = letBindNames [paramName param] =<< arg -- | @eInBoundsForDim w i@ produces @0 <= i < w@. -eDimInBounds :: MonadBuilder m => m (Exp (Rep m)) -> m (Exp (Rep m)) -> m (Exp (Rep m)) +eDimInBounds :: (MonadBuilder m) => m (Exp (Rep m)) -> m (Exp (Rep m)) -> m (Exp (Rep m)) eDimInBounds w i = eBinOp LogAnd @@ -395,7 +395,7 @@ -- | Are these indexes out-of-bounds for the array? eOutOfBounds :: - MonadBuilder m => + (MonadBuilder m) => VName -> [m (Exp (Rep m))] -> m (Exp (Rep m)) @@ -418,14 +418,14 @@ foldBinOp LogOr (constant False) =<< zipWithM checkDim ws is' -- | The array element at this index. -eIndex :: MonadBuilder m => VName -> m (Exp (Rep m)) -> m (Exp (Rep m)) +eIndex :: (MonadBuilder m) => VName -> m (Exp (Rep m)) -> m (Exp (Rep m)) eIndex arr i = do i' <- letSubExp "i" =<< i arr_t <- lookupType arr pure $ BasicOp $ Index arr $ fullSlice arr_t [DimFix i'] -- | The last element of the given array. -eLast :: MonadBuilder m => VName -> m (Exp (Rep m)) +eLast :: (MonadBuilder m) => VName -> m (Exp (Rep m)) eLast arr = do n <- arraySize 0 <$> lookupType arr nm1 <- @@ -434,22 +434,22 @@ eIndex arr (eSubExp nm1) -- | Construct an unspecified value of the given type. -eBlank :: MonadBuilder m => Type -> m (Exp (Rep m)) +eBlank :: (MonadBuilder m) => Type -> m (Exp (Rep m)) eBlank (Prim t) = pure $ BasicOp $ SubExp $ Constant $ blankPrimValue t eBlank (Array t shape _) = pure $ BasicOp $ Scratch t $ shapeDims shape eBlank Acc {} = error "eBlank: cannot create blank accumulator" eBlank Mem {} = error "eBlank: cannot create blank memory" -- | Sign-extend to the given integer type. -asIntS :: MonadBuilder m => IntType -> SubExp -> m SubExp +asIntS :: (MonadBuilder m) => IntType -> SubExp -> m SubExp asIntS = asInt SExt -- | Zero-extend to the given integer type. -asIntZ :: MonadBuilder m => IntType -> SubExp -> m SubExp +asIntZ :: (MonadBuilder m) => IntType -> SubExp -> m SubExp asIntZ = asInt ZExt asInt :: - MonadBuilder m => + (MonadBuilder m) => (IntType -> IntType -> ConvOp) -> IntType -> SubExp -> @@ -468,7 +468,7 @@ -- | Apply a binary operator to several subexpressions. A left-fold. foldBinOp :: - MonadBuilder m => + (MonadBuilder m) => BinOp -> SubExp -> [SubExp] -> @@ -479,13 +479,13 @@ eBinOp bop (pure $ BasicOp $ SubExp e) (foldBinOp bop ne es) -- | True if all operands are true. -eAll :: MonadBuilder m => [SubExp] -> m (Exp (Rep m)) +eAll :: (MonadBuilder m) => [SubExp] -> m (Exp (Rep m)) eAll [] = pure $ BasicOp $ SubExp $ constant True eAll [x] = eSubExp x eAll (x : xs) = foldBinOp LogAnd x xs -- | True if any operand is true. -eAny :: MonadBuilder m => [SubExp] -> m (Exp (Rep m)) +eAny :: (MonadBuilder m) => [SubExp] -> m (Exp (Rep m)) eAny [] = pure $ BasicOp $ SubExp $ constant False eAny [x] = eSubExp x eAny (x : xs) = foldBinOp LogOr x xs @@ -535,7 +535,7 @@ -- | Easily construct a t'Lambda' within a 'MonadBuilder'. See also -- 'runLambdaBuilder'. mkLambda :: - MonadBuilder m => + (MonadBuilder m) => [LParam (Rep m)] -> m Result -> m (Lambda (Rep m)) @@ -566,7 +566,7 @@ fullSlice t $ map sliceDim (take n $ arrayDims t) ++ slice -- | Like 'fullSlice', but the dimensions are simply numeric. -fullSliceNum :: Num d => [d] -> [DimIndex d] -> Slice d +fullSliceNum :: (Num d) => [d] -> [DimIndex d] -> Slice d fullSliceNum dims slice = Slice $ slice ++ map (\d -> DimSlice 0 d 1) (drop (length slice) dims) @@ -581,12 +581,12 @@ allOfIt _ _ = False -- | Conveniently construct a body that contains no bindings. -resultBody :: Buildable rep => [SubExp] -> Body rep +resultBody :: (Buildable rep) => [SubExp] -> Body rep resultBody = mkBody mempty . subExpsRes -- | Conveniently construct a body that contains no bindings - but -- this time, monadically! -resultBodyM :: MonadBuilder m => [SubExp] -> m (Body (Rep m)) +resultBodyM :: (MonadBuilder m) => [SubExp] -> m (Body (Rep m)) resultBodyM = mkBodyM mempty . subExpsRes -- | Evaluate the action, producing a body, then wrap it in all the @@ -603,7 +603,7 @@ -- value, then return the body constructed from the 'Result' and any -- statements added during the action, along the auxiliary value. buildBody :: - MonadBuilder m => + (MonadBuilder m) => m (Result, a) -> m (Body (Rep m), a) buildBody m = do @@ -613,7 +613,7 @@ -- | As 'buildBody', but there is no auxiliary value. buildBody_ :: - MonadBuilder m => + (MonadBuilder m) => m Result -> m (Body (Rep m)) buildBody_ m = fst <$> buildBody ((,()) <$> m) @@ -621,7 +621,7 @@ -- | Change that result where evaluation of the body would stop. Also -- change type annotations at branches. mapResult :: - Buildable rep => + (Buildable rep) => (Result -> Body rep) -> Body rep -> Body rep @@ -634,7 +634,7 @@ -- You should call this function within some monad that allows you to -- collect the actions performed (say, 'State'). instantiateShapes :: - Monad m => + (Monad m) => (Int -> m SubExp) -> [TypeBase ExtShape u] -> m [TypeBase Shape u] @@ -700,7 +700,7 @@ -- | Instances of this class can be converted to Futhark expressions -- within a 'MonadBuilder'. class ToExp a where - toExp :: MonadBuilder m => a -> m (Exp (Rep m)) + toExp :: (MonadBuilder m) => a -> m (Exp (Rep m)) instance ToExp SubExp where toExp = pure . BasicOp . SubExp diff --git a/src/Futhark/Error.hs b/src/Futhark/Error.hs --- a/src/Futhark/Error.hs +++ b/src/Futhark/Error.hs @@ -43,15 +43,15 @@ prettyCompilerError (InternalError s _ _) = pretty s -- | Raise an 'ExternalError' based on a prettyprinting result. -externalError :: MonadError CompilerError m => Doc AnsiStyle -> m a +externalError :: (MonadError CompilerError m) => Doc AnsiStyle -> m a externalError = throwError . ExternalError -- | Raise an 'ExternalError' based on a string. -externalErrorS :: MonadError CompilerError m => String -> m a +externalErrorS :: (MonadError CompilerError m) => String -> m a externalErrorS = externalError . pretty -- | Raise an v'InternalError' based on a prettyprinting result. -internalErrorS :: MonadError CompilerError m => String -> Doc AnsiStyle -> m a +internalErrorS :: (MonadError CompilerError m) => String -> Doc AnsiStyle -> m a internalErrorS s d = throwError $ InternalError (T.pack s) (p d) CompilerBug where 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 @@ -157,7 +157,7 @@ where merge_dec = case e of - DoLoop merge _ body -> + Loop merge _ body -> let mergeParamAliases fparam als | primType (paramType fparam) = Nothing @@ -179,7 +179,7 @@ maybeComment [] = Nothing maybeComment cs = Just $ PP.stack cs -resultAliasComment :: PP.Pretty a => a -> Names -> Maybe (PP.Doc ann) +resultAliasComment :: (PP.Pretty a) => a -> Names -> Maybe (PP.Doc ann) resultAliasComment name als = case namesToList als of [] -> Nothing @@ -191,7 +191,7 @@ <> " aliases " <> PP.commasep (map PP.pretty als') -removeAliases :: RephraseOp (OpC rep) => Rephraser Identity (Aliases rep) rep +removeAliases :: (RephraseOp (OpC rep)) => Rephraser Identity (Aliases rep) rep removeAliases = Rephraser { rephraseExpDec = pure . snd, @@ -215,42 +215,42 @@ -- | Remove alias information from a program. removeProgAliases :: - RephraseOp (OpC rep) => + (RephraseOp (OpC rep)) => Prog (Aliases rep) -> Prog rep removeProgAliases = runIdentity . rephraseProg removeAliases -- | Remove alias information from a function. removeFunDefAliases :: - RephraseOp (OpC rep) => + (RephraseOp (OpC rep)) => FunDef (Aliases rep) -> FunDef rep removeFunDefAliases = runIdentity . rephraseFunDef removeAliases -- | Remove alias information from an expression. removeExpAliases :: - RephraseOp (OpC rep) => + (RephraseOp (OpC rep)) => Exp (Aliases rep) -> Exp rep removeExpAliases = runIdentity . rephraseExp removeAliases -- | Remove alias information from statements. removeStmAliases :: - RephraseOp (OpC rep) => + (RephraseOp (OpC rep)) => Stm (Aliases rep) -> Stm rep removeStmAliases = runIdentity . rephraseStm removeAliases -- | Remove alias information from body. removeBodyAliases :: - RephraseOp (OpC rep) => + (RephraseOp (OpC rep)) => Body (Aliases rep) -> Body rep removeBodyAliases = runIdentity . rephraseBody removeAliases -- | Remove alias information from lambda. removeLambdaAliases :: - RephraseOp (OpC rep) => + (RephraseOp (OpC rep)) => Lambda (Aliases rep) -> Lambda rep removeLambdaAliases = runIdentity . rephraseLambda removeAliases @@ -296,7 +296,7 @@ -- in scope outside of it. Note that this does *not* include aliases -- of results that are not bound in the statements! mkBodyAliasing :: - Aliased rep => + (Aliased rep) => Stms rep -> Result -> BodyAliasing @@ -313,7 +313,7 @@ -- | The aliases of the result and everything consumed in the given -- statements. mkStmsAliases :: - Aliased rep => + (Aliased rep) => Stms rep -> Result -> ([Names], Names) @@ -338,7 +338,7 @@ ) -- | The variables consumed in these statements. -consumedInStms :: Aliased rep => Stms rep -> Names +consumedInStms :: (Aliased rep) => Stms rep -> Names consumedInStms = snd . flip mkStmsAliases [] -- | A helper function for computing the aliases of a sequence of @@ -348,7 +348,7 @@ -- state. The main thing this function provides is proper handling of -- transitivity and "reverse" aliases. trackAliases :: - Aliased rep => + (Aliased rep) => AliasesAndConsumed -> Stm rep -> AliasesAndConsumed @@ -420,7 +420,7 @@ class CanBeAliased op where -- | Add aliases to this op. addOpAliases :: - AliasableRep rep => AliasTable -> op rep -> op (Aliases rep) + (AliasableRep rep) => AliasTable -> op rep -> op (Aliases rep) instance CanBeAliased NoOp where addOpAliases _ NoOp = NoOp diff --git a/src/Futhark/IR/GPU/Op.hs b/src/Futhark/IR/GPU/Op.hs --- a/src/Futhark/IR/GPU/Op.hs +++ b/src/Futhark/IR/GPU/Op.hs @@ -230,7 +230,7 @@ opMetrics CmpSizeLe {} = seen "CmpSizeLe" opMetrics CalcNumGroups {} = seen "CalcNumGroups" -typeCheckSizeOp :: TC.Checkable rep => SizeOp -> TC.TypeM rep () +typeCheckSizeOp :: (TC.Checkable rep) => SizeOp -> TC.TypeM rep () typeCheckSizeOp GetSize {} = pure () typeCheckSizeOp GetSizeMax {} = pure () typeCheckSizeOp (CmpSizeLe _ _ x) = TC.require [Prim int64] x @@ -251,7 +251,7 @@ -- | A helper for defining 'TraverseOpStms'. traverseHostOpStms :: - Monad m => + (Monad m) => OpStmsTraverser m (op rep) rep -> OpStmsTraverser m (HostOp op rep) rep traverseHostOpStms _ f (SegOp segop) = SegOp <$> traverseSegOpStms f segop @@ -291,7 +291,7 @@ -- transfer scalars to device. SQ.null (bodyStms body) && all ((== 0) . arrayRank) types -instance TypedOp (op rep) => TypedOp (HostOp op rep) where +instance (TypedOp (op rep)) => TypedOp (HostOp op rep) where opType (SegOp op) = opType op opType (OtherOp op) = opType op opType (SizeOp op) = opType op @@ -315,13 +315,13 @@ freeIn' (SizeOp op) = freeIn' op freeIn' (GPUBody ts body) = freeIn' ts <> freeIn' body -instance CanBeAliased op => CanBeAliased (HostOp op) where +instance (CanBeAliased op) => CanBeAliased (HostOp op) where addOpAliases aliases (SegOp op) = SegOp $ addOpAliases aliases op addOpAliases aliases (GPUBody ts body) = GPUBody ts $ Alias.analyseBody aliases body addOpAliases aliases (OtherOp op) = OtherOp $ addOpAliases aliases op addOpAliases _ (SizeOp op) = SizeOp op -instance CanBeWise op => CanBeWise (HostOp op) where +instance (CanBeWise op) => CanBeWise (HostOp op) where addOpWisdom (SegOp op) = SegOp $ addOpWisdom op addOpWisdom (OtherOp op) = OtherOp $ addOpWisdom op addOpWisdom (SizeOp op) = SizeOp op @@ -345,19 +345,19 @@ opMetrics (SizeOp op) = opMetrics op opMetrics (GPUBody _ body) = inside "GPUBody" $ bodyMetrics body -instance RephraseOp op => RephraseOp (HostOp op) where +instance (RephraseOp op) => RephraseOp (HostOp op) where rephraseInOp r (SegOp op) = SegOp <$> rephraseInOp r op rephraseInOp r (OtherOp op) = OtherOp <$> rephraseInOp r op rephraseInOp _ (SizeOp op) = pure $ SizeOp op rephraseInOp r (GPUBody ts body) = GPUBody ts <$> rephraseBody r body -checkGrid :: TC.Checkable rep => KernelGrid -> TC.TypeM rep () +checkGrid :: (TC.Checkable rep) => KernelGrid -> TC.TypeM rep () checkGrid grid = do TC.require [Prim int64] $ unCount $ gridNumGroups grid TC.require [Prim int64] $ unCount $ gridGroupSize grid checkSegLevel :: - TC.Checkable rep => + (TC.Checkable rep) => Maybe SegLevel -> SegLevel -> TC.TypeM rep () @@ -381,7 +381,7 @@ mapM_ checkGrid grid typeCheckHostOp :: - TC.Checkable rep => + (TC.Checkable rep) => (SegLevel -> Op (Aliases rep) -> TC.TypeM rep ()) -> Maybe SegLevel -> (op (Aliases rep) -> TC.TypeM rep ()) -> diff --git a/src/Futhark/IR/GPU/Simplify.hs b/src/Futhark/IR/GPU/Simplify.hs --- a/src/Futhark/IR/GPU/Simplify.hs +++ b/src/Futhark/IR/GPU/Simplify.hs @@ -71,7 +71,7 @@ keepOnGPU _ _ = keepExpOnGPU . stmExp keepExpOnGPU (BasicOp Index {}) = True keepExpOnGPU (BasicOp (ArrayLit _ t)) | primType t = True - keepExpOnGPU DoLoop {} = True + keepExpOnGPU Loop {} = True keepExpOnGPU _ = False instance TraverseOpStms (Wise GPU) where @@ -130,7 +130,7 @@ -- Update with a slice of that array. This matters when the arrays -- are far away (on the GPU, say), because it avoids a copy of the -- scalar to and from the host. -removeScalarCopy :: BuilderOps rep => TopDownRuleBasicOp rep +removeScalarCopy :: (BuilderOps rep) => TopDownRuleBasicOp rep removeScalarCopy vtable pat aux (Update safety arr_x (Slice slice_x) (Var v)) | Just _ <- sliceIndices (Slice slice_x), Just (Index arr_y (Slice slice_y), cs_y) <- ST.lookupBasicOp v vtable, diff --git a/src/Futhark/IR/GPUMem.hs b/src/Futhark/IR/GPUMem.hs --- a/src/Futhark/IR/GPUMem.hs +++ b/src/Futhark/IR/GPUMem.hs @@ -90,11 +90,11 @@ traverseOpStms = traverseMemOpStms (traverseHostOpStms (const pure)) simplifyProg :: Prog GPUMem -> PassM (Prog GPUMem) -simplifyProg = simplifyProgGeneric simpleGPUMem +simplifyProg = simplifyProgGeneric memRuleBook simpleGPUMem simplifyStms :: (HasScope GPUMem m, MonadFreshNames m) => Stms GPUMem -> m (Stms GPUMem) -simplifyStms = simplifyStmsGeneric simpleGPUMem +simplifyStms = simplifyStmsGeneric memRuleBook simpleGPUMem simpleGPUMem :: Engine.SimpleOps GPUMem simpleGPUMem = diff --git a/src/Futhark/IR/MC/Op.hs b/src/Futhark/IR/MC/Op.hs --- a/src/Futhark/IR/MC/Op.hs +++ b/src/Futhark/IR/MC/Op.hs @@ -50,7 +50,7 @@ deriving (Eq, Ord, Show) traverseMCOpStms :: - Monad m => + (Monad m) => OpStmsTraverser m (op rep) rep -> OpStmsTraverser m (MCOp op rep) rep traverseMCOpStms _ f (ParOp par_op op) = @@ -78,7 +78,7 @@ cheapOp (ParOp _ op) = cheapOp op cheapOp (OtherOp op) = cheapOp op -instance TypedOp (op rep) => TypedOp (MCOp op rep) where +instance (TypedOp (op rep)) => TypedOp (MCOp op rep) where opType (ParOp _ op) = opType op opType (OtherOp op) = opType op @@ -89,13 +89,13 @@ consumedInOp (ParOp _ op) = consumedInOp op consumedInOp (OtherOp op) = consumedInOp op -instance CanBeAliased op => CanBeAliased (MCOp op) where +instance (CanBeAliased op) => CanBeAliased (MCOp op) where addOpAliases aliases (ParOp par_op op) = ParOp (addOpAliases aliases <$> par_op) (addOpAliases aliases op) addOpAliases aliases (OtherOp op) = OtherOp $ addOpAliases aliases op -instance CanBeWise op => CanBeWise (MCOp op) where +instance (CanBeWise op) => CanBeWise (MCOp op) where addOpWisdom (ParOp par_op op) = ParOp (addOpWisdom <$> par_op) (addOpWisdom op) addOpWisdom (OtherOp op) = @@ -118,13 +118,13 @@ opMetrics (ParOp par_op op) = opMetrics par_op >> opMetrics op opMetrics (OtherOp op) = opMetrics op -instance RephraseOp op => RephraseOp (MCOp op) where +instance (RephraseOp op) => RephraseOp (MCOp op) where rephraseInOp r (ParOp par_op op) = ParOp <$> traverse (rephraseInOp r) par_op <*> rephraseInOp r op rephraseInOp r (OtherOp op) = OtherOp <$> rephraseInOp r op typeCheckMCOp :: - TC.Checkable rep => + (TC.Checkable rep) => (op (Aliases rep) -> TC.TypeM rep ()) -> MCOp op (Aliases rep) -> TC.TypeM rep () diff --git a/src/Futhark/IR/MCMem.hs b/src/Futhark/IR/MCMem.hs --- a/src/Futhark/IR/MCMem.hs +++ b/src/Futhark/IR/MCMem.hs @@ -82,7 +82,7 @@ traverseOpStms = traverseMemOpStms (traverseMCOpStms (const pure)) simplifyProg :: Prog MCMem -> PassM (Prog MCMem) -simplifyProg = simplifyProgGeneric simpleMCMem +simplifyProg = simplifyProgGeneric memRuleBook simpleMCMem simpleMCMem :: Engine.SimpleOps MCMem simpleMCMem = diff --git a/src/Futhark/IR/Mem.hs b/src/Futhark/IR/Mem.hs --- a/src/Futhark/IR/Mem.hs +++ b/src/Futhark/IR/Mem.hs @@ -64,6 +64,7 @@ MemReturn (..), IxFun, ExtIxFun, + LMAD, isStaticIxFun, ExpReturns, BodyReturns, @@ -156,7 +157,7 @@ instance HasLetDecMem LetDecMem where letDecMem = id -instance HasLetDecMem b => HasLetDecMem (a, b) where +instance (HasLetDecMem b) => HasLetDecMem (a, b) where letDecMem = letDecMem . snd type Mem rep inner = @@ -186,70 +187,73 @@ -- | A helper for defining 'TraverseOpStms'. traverseMemOpStms :: - Monad m => + (Monad m) => OpStmsTraverser m (inner rep) rep -> OpStmsTraverser m (MemOp inner rep) rep traverseMemOpStms _ _ op@Alloc {} = pure op traverseMemOpStms onInner f (Inner inner) = Inner <$> onInner f inner -instance RephraseOp inner => RephraseOp (MemOp inner) where +instance (RephraseOp inner) => RephraseOp (MemOp inner) where rephraseInOp _ (Alloc e space) = pure (Alloc e space) rephraseInOp r (Inner x) = Inner <$> rephraseInOp r x -instance FreeIn (inner rep) => FreeIn (MemOp inner rep) where +instance (FreeIn (inner rep)) => FreeIn (MemOp inner rep) where freeIn' (Alloc size _) = freeIn' size freeIn' (Inner k) = freeIn' k -instance TypedOp (inner rep) => TypedOp (MemOp inner rep) where +instance (TypedOp (inner rep)) => TypedOp (MemOp inner rep) where opType (Alloc _ space) = pure [Mem space] opType (Inner k) = opType k -instance AliasedOp (inner rep) => AliasedOp (MemOp inner rep) where +instance (AliasedOp (inner rep)) => AliasedOp (MemOp inner rep) where opAliases Alloc {} = [mempty] opAliases (Inner k) = opAliases k consumedInOp Alloc {} = mempty consumedInOp (Inner k) = consumedInOp k -instance CanBeAliased inner => CanBeAliased (MemOp inner) where +instance (CanBeAliased inner) => CanBeAliased (MemOp inner) where addOpAliases _ (Alloc se space) = Alloc se space addOpAliases aliases (Inner k) = Inner $ addOpAliases aliases k -instance Rename (inner rep) => Rename (MemOp inner rep) where +instance (Rename (inner rep)) => Rename (MemOp inner rep) where rename (Alloc size space) = Alloc <$> rename size <*> pure space rename (Inner k) = Inner <$> rename k -instance Substitute (inner rep) => Substitute (MemOp inner rep) where +instance (Substitute (inner rep)) => Substitute (MemOp inner rep) where substituteNames subst (Alloc size space) = Alloc (substituteNames subst size) space substituteNames subst (Inner k) = Inner $ substituteNames subst k -instance PP.Pretty (inner rep) => PP.Pretty (MemOp inner rep) where +instance (PP.Pretty (inner rep)) => PP.Pretty (MemOp inner rep) where pretty (Alloc e DefaultSpace) = "alloc" <> PP.apply [PP.pretty e] pretty (Alloc e s) = "alloc" <> PP.apply [PP.pretty e, PP.pretty s] pretty (Inner k) = PP.pretty k -instance OpMetrics (inner rep) => OpMetrics (MemOp inner rep) where +instance (OpMetrics (inner rep)) => OpMetrics (MemOp inner rep) where opMetrics Alloc {} = seen "Alloc" opMetrics (Inner k) = opMetrics k -instance IsOp (inner rep) => IsOp (MemOp inner rep) where +instance (IsOp (inner rep)) => IsOp (MemOp inner rep) where safeOp (Alloc (Constant (IntValue (Int64Value k))) _) = k >= 0 safeOp Alloc {} = False safeOp (Inner k) = safeOp k cheapOp (Inner k) = cheapOp k cheapOp Alloc {} = True -instance CanBeWise inner => CanBeWise (MemOp inner) where +instance (CanBeWise inner) => CanBeWise (MemOp inner) where addOpWisdom (Alloc size space) = Alloc size space addOpWisdom (Inner k) = Inner $ addOpWisdom k -instance ST.IndexOp (inner rep) => ST.IndexOp (MemOp inner rep) where +instance (ST.IndexOp (inner rep)) => ST.IndexOp (MemOp inner rep) where indexOp vtable k (Inner op) is = ST.indexOp vtable k op is indexOp _ _ _ _ = Nothing -- | The index function representation used for memory annotations. type IxFun = IxFun.IxFun (TPrimExp Int64 VName) +-- | The LMAD representation used for memory annotations. +type LMAD = IxFun.LMAD (TPrimExp Int64 VName) + -- | An index function that may contain existential variables. type ExtIxFun = IxFun.IxFun (TPrimExp Int64 (Ext VName)) @@ -273,22 +277,22 @@ type MemBound u = MemInfo SubExp u MemBind -instance FixExt ret => DeclExtTyped (MemInfo ExtSize Uniqueness ret) where +instance (FixExt ret) => DeclExtTyped (MemInfo ExtSize Uniqueness ret) where declExtTypeOf (MemPrim pt) = Prim pt declExtTypeOf (MemMem space) = Mem space declExtTypeOf (MemArray pt shape u _) = Array pt shape u declExtTypeOf (MemAcc acc ispace ts u) = Acc acc ispace ts u -instance FixExt ret => ExtTyped (MemInfo ExtSize Uniqueness ret) where +instance (FixExt ret) => ExtTyped (MemInfo ExtSize Uniqueness ret) where extTypeOf = fromDecl . declExtTypeOf -instance FixExt ret => ExtTyped (MemInfo ExtSize NoUniqueness ret) where +instance (FixExt ret) => ExtTyped (MemInfo ExtSize NoUniqueness ret) where extTypeOf (MemPrim pt) = Prim pt extTypeOf (MemMem space) = Mem space extTypeOf (MemArray pt shape u _) = Array pt shape u extTypeOf (MemAcc acc ispace ts u) = Acc acc ispace ts u -instance FixExt ret => FixExt (MemInfo ExtSize u ret) where +instance (FixExt ret) => FixExt (MemInfo ExtSize u ret) where fixExt _ _ (MemPrim pt) = MemPrim pt fixExt _ _ (MemMem space) = MemMem space fixExt i se (MemArray pt shape u ret) = @@ -338,13 +342,13 @@ rename = substituteRename simplifyIxFun :: - Engine.SimplifiableRep rep => + (Engine.SimplifiableRep rep) => IxFun -> Engine.SimpleM rep IxFun simplifyIxFun = traverse $ fmap isInt64 . simplifyPrimExp . untyped simplifyExtIxFun :: - Engine.SimplifiableRep rep => + (Engine.SimplifiableRep rep) => ExtIxFun -> Engine.SimpleM rep ExtIxFun simplifyExtIxFun = traverse $ fmap isInt64 . simplifyExtPrimExp . untyped @@ -668,7 +672,7 @@ ) matchReturnType :: - PP.Pretty u => + (PP.Pretty u) => [MemInfo ExtSize u MemReturn] -> [SubExp] -> [MemInfo SubExp NoUniqueness MemBind] -> @@ -817,7 +821,7 @@ matches _ _ _ _ = False varMemInfo :: - Mem rep inner => + (Mem rep inner) => VName -> TC.TypeM rep (MemInfo SubExp NoUniqueness MemBind) varMemInfo name = do @@ -829,7 +833,7 @@ LParamName summary -> pure summary IndexName it -> pure $ MemPrim $ IntType it -nameInfoToMemInfo :: Mem rep inner => NameInfo rep -> MemBound NoUniqueness +nameInfoToMemInfo :: (Mem rep inner) => NameInfo rep -> MemBound NoUniqueness nameInfoToMemInfo info = case info of FParamName summary -> noUniquenessReturns summary @@ -883,7 +887,7 @@ <> prettyText summary checkMemInfo :: - TC.Checkable rep => + (TC.Checkable rep) => VName -> MemInfo SubExp u MemBind -> TC.TypeM rep () @@ -1053,13 +1057,13 @@ Just . pure . varInfoToExpReturns <$> sliceInfo v slice expReturns (BasicOp (Update _ v _ _)) = Just . pure <$> varReturns v -expReturns (BasicOp (FlatIndex v slice)) = do - fmap (pure . varInfoToExpReturns) <$> flatSliceInfo v slice +expReturns (BasicOp (FlatIndex v slice)) = + Just . pure . varInfoToExpReturns <$> flatSliceInfo v slice expReturns (BasicOp (FlatUpdate v _ _)) = Just . pure <$> varReturns v expReturns (BasicOp op) = Just . extReturns . staticShapes <$> basicOpType op -expReturns e@(DoLoop merge _ _) = do +expReturns e@(Loop merge _ _) = do t <- expExtType e Just <$> zipWithM typeWithDec t (map fst merge) where @@ -1122,20 +1126,20 @@ (Monad m, HasScope rep m, Mem rep inner) => VName -> FlatSlice SubExp -> - m (Maybe (MemInfo SubExp NoUniqueness MemBind)) + m (MemInfo SubExp NoUniqueness MemBind) flatSliceInfo v slice@(FlatSlice offset idxs) = do (et, _, mem, ixfun) <- arrayVarReturns v map (fmap pe64) idxs & FlatSlice (pe64 offset) & IxFun.flatSlice ixfun - & fmap (MemArray et (Shape (flatSliceDims slice)) NoUniqueness . ArrayIn mem) + & MemArray et (Shape (flatSliceDims slice)) NoUniqueness . ArrayIn mem & pure -class IsOp op => OpReturns op where +class (IsOp op) => OpReturns op where opReturns :: (Mem rep inner, Monad m, HasScope rep m) => op -> m [ExpReturns] opReturns op = extReturns <$> opType op -instance OpReturns (inner rep) => OpReturns (MemOp inner rep) where +instance (OpReturns (inner rep)) => OpReturns (MemOp inner rep) where opReturns (Alloc _ space) = pure [MemMem space] opReturns (Inner op) = opReturns op @@ -1143,7 +1147,7 @@ opReturns NoOp = pure [] applyFunReturns :: - Typed dec => + (Typed dec) => [FunReturns] -> [Param dec] -> [(SubExp, Type)] -> diff --git a/src/Futhark/IR/Mem/Interval.hs b/src/Futhark/IR/Mem/Interval.hs --- a/src/Futhark/IR/Mem/Interval.hs +++ b/src/Futhark/IR/Mem/Interval.hs @@ -30,7 +30,7 @@ instance FreeIn Interval where freeIn' (Interval lb ne st) = freeIn' lb <> freeIn' ne <> freeIn' st -distributeOffset :: MonadFail m => AlgSimplify.SofP -> [Interval] -> m [Interval] +distributeOffset :: (MonadFail m) => AlgSimplify.SofP -> [Interval] -> m [Interval] distributeOffset [] interval = pure interval distributeOffset offset [] = fail $ "Cannot distribute offset " <> show offset <> " across empty interval" distributeOffset offset [Interval lb ne 1] = pure [Interval (lb + TPrimExp (AlgSimplify.sumToExp offset)) ne 1] diff --git a/src/Futhark/IR/Mem/IxFun.hs b/src/Futhark/IR/Mem/IxFun.hs --- a/src/Futhark/IR/Mem/IxFun.hs +++ b/src/Futhark/IR/Mem/IxFun.hs @@ -10,45 +10,41 @@ index, mkExistential, iota, - iotaOffset, permute, reshape, coerce, slice, flatSlice, - rebase, + expand, shape, - permutation, rank, isDirect, substituteInIxFun, substituteInLMAD, existentialize, closeEnough, - equivalent, - permuteInv, disjoint, disjoint2, disjoint3, - dynamicEqualsLMAD, ) where import Control.Category import Control.Monad import Control.Monad.State -import Data.List (sort, zip4) import Data.Map.Strict qualified as M import Data.Traversable import Futhark.Analysis.PrimExp import Futhark.Analysis.PrimExp.Convert import Futhark.IR.Mem.LMAD hiding - ( flatSlice, + ( equivalent, + flatSlice, index, iota, + isDirect, mkExistential, - permutation, permute, + rank, reshape, shape, slice, @@ -83,20 +79,20 @@ } deriving (Show, Eq) -instance Pretty num => Pretty (IxFun num) where +instance (Pretty num) => Pretty (IxFun num) where pretty (IxFun lmad oshp) = braces . semistack $ [ "base:" <+> brackets (commasep $ map pretty oshp), "LMAD:" <+> pretty lmad ] -instance Substitute num => Substitute (IxFun num) where +instance (Substitute num) => Substitute (IxFun num) where substituteNames substs = fmap $ substituteNames substs -instance Substitute num => Rename (IxFun num) where +instance (Substitute num) => Rename (IxFun num) where rename = substituteRename -instance FreeIn num => FreeIn (IxFun num) where +instance (FreeIn num) => FreeIn (IxFun num) where freeIn' = foldMap freeIn' instance Functor IxFun where @@ -113,7 +109,7 @@ -- | Substitute a name with a PrimExp in an index function. substituteInIxFun :: - Ord a => + (Ord a) => M.Map a (TPrimExp t a) -> IxFun (TPrimExp t a) -> IxFun (TPrimExp t a) @@ -131,24 +127,13 @@ in length oshp == length dims && offset == 0 && all - (\(LMADDim s n p, m, d, se) -> s == se && n == d && p == m) - (zip4 dims [0 .. length dims - 1] oshp strides_expected) - --- | Does the index function have an ascending permutation? -hasContiguousPerm :: IxFun num -> Bool -hasContiguousPerm (IxFun lmad _) = - let perm = LMAD.permutation lmad - in perm == sort perm + (\(LMADDim s n, d, se) -> s == se && n == d) + (zip3 dims oshp strides_expected) -- | The index space of the index function. This is the same as the -- shape of arrays that the index function supports. shape :: (Eq num, IntegralExp num) => IxFun num -> Shape num -shape (IxFun lmad _) = - permuteFwd (LMAD.permutation lmad) $ LMAD.shapeBase lmad - --- | The permutation of the first LMAD of the index function. -permutation :: IxFun num -> Permutation -permutation = map LMAD.ldPerm . LMAD.dims . ixfunLMAD +shape = LMAD.shape . ixfunLMAD -- | Compute the flat memory index for a complete set @inds@ of array indices -- and a certain element size @elem_size@. @@ -160,25 +145,24 @@ index = LMAD.index . ixfunLMAD -- | iota with offset. -iotaOffset :: IntegralExp num => num -> Shape num -> IxFun num +iotaOffset :: (IntegralExp num) => num -> Shape num -> IxFun num iotaOffset o ns = IxFun (LMAD.iota o ns) ns -- | iota. -iota :: IntegralExp num => Shape num -> IxFun num +iota :: (IntegralExp num) => Shape num -> IxFun num iota = iotaOffset 0 -- | Create a single-LMAD index function that is -- existential in everything, with the provided permutation. -mkExistential :: Int -> [Int] -> Int -> IxFun (Ext a) -mkExistential basis_rank perm start = - IxFun (LMAD.mkExistential perm start) basis +mkExistential :: Int -> Int -> Int -> IxFun (Ext a) +mkExistential basis_rank lmad_rank start = + IxFun (LMAD.mkExistential lmad_rank start) basis where - basis = take basis_rank $ map Ext [start + 1 + dims_rank * 2 ..] - dims_rank = length perm + basis = take basis_rank $ map Ext [start + 1 + lmad_rank * 2 ..] -- | Permute dimensions. permute :: - IntegralExp num => + (IntegralExp num) => IxFun num -> Permutation -> IxFun num @@ -202,10 +186,8 @@ (Eq num, IntegralExp num) => IxFun num -> FlatSlice num -> - Maybe (IxFun num) -flatSlice (IxFun lmad oshp) s = do - lmad' <- LMAD.flatSlice lmad s - Just $ IxFun lmad' oshp + IxFun num +flatSlice (IxFun lmad oshp) s = IxFun (LMAD.flatSlice lmad s) oshp -- | Reshape an index function. -- @@ -243,89 +225,21 @@ onDim ld d = ld {ldShape = d} -- | The number of dimensions in the domain of the input function. -rank :: IntegralExp num => IxFun num -> Int +rank :: (IntegralExp num) => IxFun num -> Int rank (IxFun (LMAD _ sss) _) = length sss --- | Essentially @rebase new_base ixfun = ixfun o new_base@ --- Core soundness condition: @base ixfun == shape new_base@ --- Handles the case where a rebase operation can stay within m + n - 1 LMADs, --- where m is the number of LMADs in the index function, and n is the number of --- LMADs in the new base. If both index function have only on LMAD, this means --- that we stay within the single-LMAD domain. --- --- We can often stay in that domain if the original ixfun is essentially a --- slice, e.g. `x[i, (k1,m,s1), (k2,n,s2)] = orig`. --- --- However, I strongly suspect that for in-place update what we need is actually --- the INVERSE of the rebase function, i.e., given an index function new-base --- and another one orig, compute the index function ixfun0 such that: --- --- new-base == rebase ixfun0 ixfun, or equivalently: --- new-base == ixfun o ixfun0 --- --- because then I can go bottom up and compose with ixfun0 all the index --- functions corresponding to the memory block associated with ixfun. -rebase :: - (Eq num, IntegralExp num) => - IxFun num -> - IxFun num -> - Maybe (IxFun num) -rebase new_base@(IxFun lmad_base _) ixfun@(IxFun lmad shp) = do - let dims = LMAD.dims lmad - perm = LMAD.permutation lmad - perm_base = LMAD.permutation lmad_base - - guard $ - -- Core rebase condition. - base ixfun == shape new_base - -- XXX: We should be able to handle some basic cases where both index - -- functions have non-trivial permutations. - && (hasContiguousPerm ixfun || hasContiguousPerm new_base) - -- We need the permutations to be of the same size if we want to compose - -- them. They don't have to be of the same size if the ixfun has a trivial - -- permutation. Supporting this latter case allows us to rebase when ixfun - -- has been created by slicing with fixed dimensions. - && (length perm == length perm_base || hasContiguousPerm ixfun) - -- To not have to worry about ixfun having non-1 strides, we also check that - -- it is a row-major array (modulo permutation, which is handled - -- separately). Accept a non-full outermost dimension. XXX: Maybe this can - -- be less conservative? - && and - ( zipWith3 - (\sn ld inner -> inner || sn == ldShape ld) - shp - dims - (True : replicate (length dims - 1) False) - ) - - -- Compose permutations, reverse strides and adjust offset if necessary. - let perm_base' = - if hasContiguousPerm ixfun - then perm_base - else map (perm !!) perm_base - lmad_base' = LMAD.setPermutation perm_base' lmad_base - dims_base = LMAD.dims lmad_base' - n_fewer_dims = length dims_base - length dims - (dims_base', offs_contrib) = - unzip $ - zipWith - ( \(LMADDim s1 n1 p1) (LMADDim {}) -> - let (s', off') = (s1, 0) - in (LMADDim s' n1 (p1 - n_fewer_dims), off') - ) - -- If @dims@ is morally a slice, it might have fewer dimensions than - -- @dims_base@. Drop extraneous outer dimensions. - (drop n_fewer_dims dims_base) - dims - off_base = LMAD.offset lmad_base' + sum offs_contrib - lmad_base'' = - LMAD.setShape - (LMAD.shape lmad) - ( LMAD - (off_base + ldStride (last dims_base) * LMAD.offset lmad) - dims_base' - ) - pure $ IxFun lmad_base'' shp +-- | Conceptually expand index function to be a particular slice of +-- another by adjusting the offset and strides. Used for memory +-- expansion. +expand :: + (Eq num, IntegralExp num) => num -> num -> IxFun num -> Maybe (IxFun num) +expand o p (IxFun lmad base) = + let onDim ld = ld {LMAD.ldStride = LMAD.ldStride ld * p} + lmad' = + LMAD + (o + p * LMAD.offset lmad) + (map onDim (LMAD.dims lmad)) + in Just $ IxFun lmad' base -- | Turn all the leaves of the index function into 'Ext's. We -- require that there's only one LMAD, that the index function is @@ -357,18 +271,3 @@ where closeEnoughLMADs lmad1 lmad2 = length (LMAD.dims lmad1) == length (LMAD.dims lmad2) - && map ldPerm (LMAD.dims lmad1) == map ldPerm (LMAD.dims lmad2) - --- | Returns true if two 'IxFun's are equivalent. --- --- Equivalence in this case is defined as having the same number of LMADs, with --- each pair of LMADs matching in permutation, offsets, and strides. -equivalent :: Eq num => IxFun num -> IxFun num -> Bool -equivalent ixf1 ixf2 = - equivalentLMADs (ixfunLMAD ixf1) (ixfunLMAD ixf2) - where - equivalentLMADs lmad1 lmad2 = - length (LMAD.dims lmad1) == length (LMAD.dims lmad2) - && map ldPerm (LMAD.dims lmad1) == map ldPerm (LMAD.dims lmad2) - && LMAD.offset lmad1 == LMAD.offset lmad2 - && map ldStride (LMAD.dims lmad1) == map ldStride (LMAD.dims lmad2) diff --git a/src/Futhark/IR/Mem/LMAD.hs b/src/Futhark/IR/Mem/LMAD.hs --- a/src/Futhark/IR/Mem/LMAD.hs +++ b/src/Futhark/IR/Mem/LMAD.hs @@ -15,32 +15,25 @@ reshape, permute, shape, - permutation, - shapeBase, - setPermutation, - setShape, + rank, substituteInLMAD, - permuteInv, - permuteFwd, disjoint, disjoint2, disjoint3, dynamicEqualsLMAD, - contiguous, - memcpyable, - noPermutation, iota, mkExistential, + equivalent, + isDirect, ) where import Control.Category import Control.Monad -import Data.Foldable (toList) import Data.Function (on, (&)) -import Data.List (elemIndex, partition, sort, sortBy) +import Data.List (elemIndex, partition, sortBy) import Data.Map.Strict qualified as M -import Data.Maybe (fromJust, isJust, isNothing) +import Data.Maybe (fromJust, isNothing) import Data.Traversable import Futhark.Analysis.AlgSimplify qualified as AlgSimplify import Futhark.Analysis.PrimExp @@ -54,7 +47,6 @@ FlatSlice (..), Slice (..), Type, - dimFix, unitSlice, ) import Futhark.IR.Syntax.Core (VName (..)) @@ -77,8 +69,7 @@ -- | A single dimension in an 'LMAD'. data LMADDim num = LMADDim { ldStride :: num, - ldShape :: num, - ldPerm :: Int + ldShape :: num } deriving (Show, Eq, Ord) @@ -118,28 +109,27 @@ } deriving (Show, Eq, Ord) -instance Pretty num => Pretty (LMAD num) where +instance (Pretty num) => Pretty (LMAD num) where pretty (LMAD offset dims) = braces . semistack $ [ "offset:" <+> group (pretty offset), "strides:" <+> p ldStride, - "shape:" <+> p ldShape, - "permutation:" <+> p ldPerm + "shape:" <+> p ldShape ] where p f = group $ brackets $ align $ commasep $ map (pretty . f) dims -instance Substitute num => Substitute (LMAD num) where +instance (Substitute num) => Substitute (LMAD num) where substituteNames substs = fmap $ substituteNames substs -instance Substitute num => Rename (LMAD num) where +instance (Substitute num) => Rename (LMAD num) where rename = substituteRename -instance FreeIn num => FreeIn (LMAD num) where +instance (FreeIn num) => FreeIn (LMAD num) where freeIn' = foldMap freeIn' -instance FreeIn num => FreeIn (LMADDim num) where - freeIn' (LMADDim s n _) = freeIn' s <> freeIn' n +instance (FreeIn num) => FreeIn (LMADDim num) where + freeIn' (LMADDim s n) = freeIn' s <> freeIn' n instance Functor LMAD where fmap = fmapDefault @@ -151,7 +141,7 @@ traverse f (LMAD offset dims) = LMAD <$> f offset <*> traverse f' dims where - f' (LMADDim s n p) = LMADDim <$> f s <*> f n <*> pure p + f' (LMADDim s n) = LMADDim <$> f s <*> f n flatOneDim :: (Eq num, IntegralExp num) => @@ -163,18 +153,10 @@ | otherwise = i * s index :: (IntegralExp num, Eq num) => LMAD num -> Indices num -> num -index lmad@(LMAD off dims) inds = +index (LMAD off dims) inds = off + sum prods where - prods = - zipWith - flatOneDim - (map ldStride dims) - (permuteInv (permutation lmad) inds) - -setLMADPermutation :: Permutation -> LMAD num -> LMAD num -setLMADPermutation perm lmad = - lmad {dims = zipWith (\dim p -> dim {ldPerm = p}) (dims lmad) perm} + prods = zipWith flatOneDim (map ldStride dims) inds -- | Handle the case where a slice can stay within a single LMAD. slice :: @@ -183,69 +165,41 @@ Slice num -> LMAD num slice lmad@(LMAD _ ldims) (Slice is) = - let perm = permutation lmad - is' = permuteInv perm is - lmad' = foldl sliceOne (LMAD (offset lmad) []) $ zip is' ldims - -- need to remove the fixed dims from the permutation - perm' = - updatePerm perm $ - map fst $ - filter (isJust . dimFix . snd) $ - zip [0 .. length is' - 1] is' - in setLMADPermutation perm' lmad' + foldl sliceOne (LMAD (offset lmad) []) $ zip is ldims where - updatePerm ps inds = concatMap decrease ps - where - decrease p = - let f n i - | i == p = -1 - | i > p = n - | n /= -1 = n + 1 - | otherwise = n - d = foldl f 0 inds - in [p - d | d /= -1] - sliceOne :: (Eq num, IntegralExp num) => LMAD num -> (DimIndex num, LMADDim num) -> LMAD num - sliceOne (LMAD off dims) (DimFix i, LMADDim s _x _) = + sliceOne (LMAD off dims) (DimFix i, LMADDim s _x) = LMAD (off + flatOneDim s i) dims - sliceOne (LMAD off dims) (DimSlice _ ne _, LMADDim 0 _ p) = - LMAD off (dims ++ [LMADDim 0 ne p]) - sliceOne (LMAD off dims) (dmind, dim@(LMADDim _ n _)) + sliceOne (LMAD off dims) (DimSlice _ ne _, LMADDim 0 _) = + LMAD off (dims ++ [LMADDim 0 ne]) + sliceOne (LMAD off dims) (dmind, dim@(LMADDim _ n)) | dmind == unitSlice 0 n = LMAD off (dims ++ [dim]) - sliceOne (LMAD off dims) (dmind, LMADDim s n p) + sliceOne (LMAD off dims) (dmind, LMADDim s n) | dmind == DimSlice (n - 1) n (-1) = let off' = off + flatOneDim s (n - 1) - in LMAD off' (dims ++ [LMADDim (s * (-1)) n p]) - sliceOne (LMAD off dims) (DimSlice b ne 0, LMADDim s _ p) = - LMAD (off + flatOneDim s b) (dims ++ [LMADDim 0 ne p]) - sliceOne (LMAD off dims) (DimSlice bs ns ss, LMADDim s _ p) = - LMAD (off + s * bs) (dims ++ [LMADDim (ss * s) ns p]) - -hasContiguousPerm :: LMAD num -> Bool -hasContiguousPerm lmad = perm == sort perm - where - perm = permutation lmad + in LMAD off' (dims ++ [LMADDim (s * (-1)) n]) + sliceOne (LMAD off dims) (DimSlice b ne 0, LMADDim s _) = + LMAD (off + flatOneDim s b) (dims ++ [LMADDim 0 ne]) + sliceOne (LMAD off dims) (DimSlice bs ns ss, LMADDim s _) = + LMAD (off + s * bs) (dims ++ [LMADDim (ss * s) ns]) -- | Flat-slice an LMAD. flatSlice :: (IntegralExp num) => LMAD num -> FlatSlice num -> - Maybe (LMAD num) -flatSlice lmad@(LMAD offset (dim : dims)) (FlatSlice new_offset is) - | hasContiguousPerm lmad = - Just $ - LMAD - (offset + new_offset * ldStride dim) - (map (helper $ ldStride dim) is <> dims) - & setLMADPermutation [0 ..] + LMAD num +flatSlice (LMAD offset (dim : dims)) (FlatSlice new_offset is) = + LMAD + (offset + new_offset * ldStride dim) + (map (helper $ ldStride dim) is <> dims) where - helper s0 (FlatDimIndex n s) = LMADDim (s0 * s) n 0 -flatSlice _ _ = Nothing + helper s0 (FlatDimIndex n s) = LMADDim (s0 * s) n +flatSlice (LMAD offset []) _ = LMAD offset [] -- | Handle the case where a reshape operation can stay inside a -- single LMAD. See "Futhark.IR.Mem.IxFun.reshape" for @@ -254,115 +208,56 @@ (Eq num, IntegralExp num) => LMAD num -> Shape num -> Maybe (LMAD num) -- -- First a special case for when we are merely injecting unit --- dimensions into a non-permuted LMAD. -reshape lmad@(LMAD off dims) newshape - | sort (permutation lmad) == permutation lmad, - Just dims' <- addingVacuous 0 newshape dims = +-- dimensions into an LMAD. +reshape (LMAD off dims) newshape + | Just dims' <- addingVacuous newshape dims = Just $ LMAD off dims' where - addingVacuous i (dnew : dnews) (dold : dolds) + addingVacuous (dnew : dnews) (dold : dolds) | dnew == ldShape dold = - (dold {ldPerm = i} :) <$> addingVacuous (i + 1) dnews dolds - addingVacuous i (1 : dnews) dolds = - (LMADDim 0 1 i :) <$> addingVacuous (i + 1) dnews dolds - addingVacuous _ [] [] = Just [] - addingVacuous _ _ _ = Nothing + (dold :) <$> addingVacuous dnews dolds + addingVacuous (1 : dnews) dolds = + (LMADDim 0 1 :) <$> addingVacuous dnews dolds + addingVacuous [] [] = Just [] + addingVacuous _ _ = Nothing -- Then the general case. reshape lmad@(LMAD off dims) newshape = do - let perm = permutation lmad - dims_perm = permuteFwd perm dims - mid_dims = take (length dims) dims_perm + let mid_dims = take (length dims) dims guard $ -- checking conditions (2) - all (\(LMADDim s _ _) -> s /= 0) mid_dims - && - -- checking condition (1) - consecutive 0 (map ldPerm mid_dims) - && - -- checking condition (3) - hasContiguousPerm lmad + all (\(LMADDim s _) -> s /= 0) mid_dims && all (\(ld, se) -> ldStride ld == se) (zip dims (reverse $ scanl (*) 1 (reverse (tail (shape lmad))))) - -- make new permutation - let rsh_len = length newshape - diff = length newshape - length dims - iota_shape = [0 .. length newshape - 1] - perm' = - map - ( \i -> - let ind = i - diff - in if (i >= 0) && (i < rsh_len) - then i -- already checked mid_dims not affected - else ldPerm (dims !! ind) + diff - ) - iota_shape - -- split the dimensions - (support_inds, repeat_inds) = - foldl - (\(sup, rpt) (shpdim, ip) -> ((ip, shpdim) : sup, rpt)) - ([], []) - $ reverse - $ zip newshape perm' - - (sup_inds, support) = unzip $ sortBy (compare `on` fst) support_inds - (rpt_inds, repeats) = unzip repeat_inds - LMAD off' dims_sup = iota off support - repeats' = map (\n -> LMADDim 0 n 0) repeats - dims' = - map snd $ - sortBy (compare `on` fst) $ - zip sup_inds dims_sup ++ zip rpt_inds repeats' - lmad' = LMAD off' dims' - Just $ setLMADPermutation perm' lmad' - where - consecutive _ [] = True - consecutive i [p] = i == p - consecutive i ps = and $ zipWith (==) ps [i, i + 1 ..] - -permutation :: LMAD num -> Permutation -permutation = map ldPerm . dims - -setPermutation :: Permutation -> LMAD num -> LMAD num -setPermutation perm lmad = - lmad {dims = zipWith (\dim p -> dim {ldPerm = p}) (dims lmad) perm} - -setShape :: Shape num -> LMAD num -> LMAD num -setShape shp lmad = lmad {dims = zipWith (\dim s -> dim {ldShape = s}) (dims lmad) shp} + let LMAD off' dims_sup = iota off newshape + Just $ LMAD off' dims_sup -- | Substitute a name with a PrimExp in an LMAD. substituteInLMAD :: - Ord a => + (Ord a) => M.Map a (TPrimExp t a) -> LMAD (TPrimExp t a) -> LMAD (TPrimExp t a) substituteInLMAD tab (LMAD offset dims) = - LMAD (sub offset) $ - map (\(LMADDim s n p) -> LMADDim (sub s) (sub n) p) dims + LMAD (sub offset) $ map (\(LMADDim s n) -> LMADDim (sub s) (sub n)) dims where tab' = fmap untyped tab sub = TPrimExp . substituteInPrimExp tab' . untyped -- | Shape of an LMAD. shape :: LMAD num -> Shape num -shape lmad = permuteInv (permutation lmad) $ shapeBase lmad - --- | Shape of an LMAD, ignoring permutations. -shapeBase :: LMAD num -> Shape num -shapeBase = map ldShape . dims - -permuteFwd :: Permutation -> [a] -> [a] -permuteFwd ps elems = map (elems !!) ps +shape = map ldShape . dims -permuteInv :: Permutation -> [a] -> [a] -permuteInv ps elems = map snd $ sortBy (compare `on` fst) $ zip ps elems +-- | Rank of an LMAD. +rank :: LMAD num -> Int +rank = length . shape -- | Generalised iota with user-specified offset. iota :: - IntegralExp num => + (IntegralExp num) => -- | Offset num -> -- | Shape @@ -371,25 +266,18 @@ iota off ns = let rk = length ns ss = reverse $ take rk $ scanl (*) 1 $ reverse ns - ps = map fromIntegral [0 .. rk - 1] - in LMAD off $ zipWith3 LMADDim ss ns ps + in LMAD off $ zipWith LMADDim ss ns --- | Create an LMAD that is existential in everything, with the --- provided permutation. -mkExistential :: [Int] -> Int -> LMAD (Ext a) -mkExistential perm start = - lmad +-- | Create an LMAD that is existential in everything. +mkExistential :: Int -> Int -> LMAD (Ext a) +mkExistential r start = LMAD (Ext start) $ map onDim [0 .. r - 1] where - lmad = LMAD (Ext start) $ zipWith onDim perm [0 ..] - onDim p i = - LMADDim (Ext (start + 1 + i * 2)) (Ext (start + 2 + i * 2)) p + onDim i = LMADDim (Ext (start + 1 + i * 2)) (Ext (start + 2 + i * 2)) -- | Permute dimensions. permute :: LMAD num -> Permutation -> LMAD num -permute lmad perm_new = - let perm_cur = permutation lmad - perm = map (perm_cur !!) perm_new - in setPermutation perm lmad +permute lmad perm = + lmad {dims = rearrangeShape perm $ dims lmad} -- | Computes the maximum span of an 'LMAD'. The result is the lowest and -- highest flat values representable by that 'LMAD'. @@ -412,7 +300,7 @@ -- conservativeFlatten :: (IntegralExp e, Ord e, Pretty e) => LMAD e -> LMAD e conservativeFlatten :: LMAD (TPrimExp Int64 VName) -> Maybe (LMAD (TPrimExp Int64 VName)) conservativeFlatten (LMAD offset []) = - pure $ LMAD offset [LMADDim 1 1 0] + pure $ LMAD offset [LMADDim 1 1] conservativeFlatten l@(LMAD _ [_]) = pure l conservativeFlatten l@(LMAD offset dims) = do @@ -421,7 +309,7 @@ gcd (ldStride $ head dims) $ map ldStride dims - pure $ LMAD offset [LMADDim strd (shp + 1) 0] + pure $ LMAD offset [LMADDim strd (shp + 1)] where shp = flatSpan l @@ -603,28 +491,26 @@ lmadToIntervals :: LMAD (TPrimExp Int64 VName) -> (AlgSimplify.SofP, [Interval]) lmadToIntervals (LMAD offset []) = (AlgSimplify.simplify0 $ untyped offset, [Interval 0 1 1]) -lmadToIntervals lmad@(LMAD offset dims0) = - (offset', map helper $ permuteInv (permutation lmad) dims0) +lmadToIntervals (LMAD offset dims0) = + (offset', map helper dims0) where offset' = AlgSimplify.simplify0 $ untyped offset helper :: LMADDim (TPrimExp Int64 VName) -> Interval - helper (LMADDim strd shp _) = do + helper (LMADDim strd shp) = do Interval 0 (AlgSimplify.simplify' shp) (AlgSimplify.simplify' strd) -- | Dynamically determine if two 'LMADDim' are equal. -- -- True if the dynamic values of their constituents are equal. -dynamicEqualsLMADDim :: Eq num => LMADDim (TPrimExp t num) -> LMADDim (TPrimExp t num) -> TPrimExp Bool num +dynamicEqualsLMADDim :: (Eq num) => LMADDim (TPrimExp t num) -> LMADDim (TPrimExp t num) -> TPrimExp Bool num dynamicEqualsLMADDim dim1 dim2 = - ldStride dim1 .==. ldStride dim2 - .&&. ldShape dim1 .==. ldShape dim2 - .&&. fromBool (ldPerm dim1 == ldPerm dim2) + ldStride dim1 .==. ldStride dim2 .&&. ldShape dim1 .==. ldShape dim2 -- | Dynamically determine if two 'LMAD' are equal. -- -- True if offset and constituent 'LMADDim' are equal. -dynamicEqualsLMAD :: Eq num => LMAD (TPrimExp t num) -> LMAD (TPrimExp t num) -> TPrimExp Bool num +dynamicEqualsLMAD :: (Eq num) => LMAD (TPrimExp t num) -> LMAD (TPrimExp t num) -> TPrimExp Bool num dynamicEqualsLMAD lmad1 lmad2 = offset lmad1 .==. offset lmad2 .&&. foldr @@ -632,40 +518,18 @@ true (zip (dims lmad1) (dims lmad2)) --- | True if these LMADs represent the same function (ignoring --- offset). -compatible :: - Eq num => - LMAD (TPrimExp Int64 num) -> - LMAD (TPrimExp Int64 num) -> - TPrimExp Bool num -compatible x y = - foldl1 (.&&.) $ zipWith dynamicEqualsLMADDim (dims x) (dims y) - --- | True if this LMAD corresponds to an array without "holes". This --- implies it can be copied with a memcpy()-like operation. -contiguous :: - (Pretty num, Eq num) => - LMAD (TPrimExp Int64 num) -> - TPrimExp Bool num -contiguous lmad = - foldl1 (.&&.) $ zipWith (.==.) (toList lmad) lmad' - where - lmad' = toList (iota (offset lmad) $ map ldShape $ dims lmad) - --- | True if these LMADs have the same contiguous representation, such --- that one can be copied to the other with a @memcpy()@-like --- operation. -memcpyable :: - (Pretty num, Eq num) => - LMAD (TPrimExp Int64 num) -> - LMAD (TPrimExp Int64 num) -> - TPrimExp Bool num -memcpyable dest_lmad src_lmad = - contiguous dest_lmad .&&. compatible dest_lmad src_lmad +-- | Returns true if two 'LMAD's are equivalent. +-- +-- Equivalence in this case is matching in offsets and strides. +equivalent :: (Eq num) => LMAD num -> LMAD num -> Bool +equivalent lmad1 lmad2 = + length (dims lmad1) == length (dims lmad2) + && offset lmad1 == offset lmad2 + && map ldStride (dims lmad1) == map ldStride (dims lmad2) --- | Remove the permutation of an LMAD by actually applying it to the --- dimensions. -noPermutation :: LMAD t -> LMAD t -noPermutation lmad = - lmad {dims = rearrangeShape (permutation lmad) $ dims lmad} +-- | Is this is a row-major array? +isDirect :: (Eq num, IntegralExp num) => LMAD num -> Bool +isDirect (LMAD offset dims) = + let strides_expected = reverse $ scanl (*) 1 $ reverse $ tail $ map ldShape dims + in offset == 0 + && and (zipWith (==) (map ldStride dims) strides_expected) 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 @@ -5,6 +5,7 @@ simplifyStmsGeneric, simpleGeneric, SimplifyMemory, + memRuleBook, ) where @@ -50,13 +51,14 @@ simplifyProgGeneric :: (SimplifyMemory rep inner) => + RuleBook (Wise rep) -> Simplify.SimpleOps rep -> Prog rep -> PassM (Prog rep) -simplifyProgGeneric ops = +simplifyProgGeneric rules ops = Simplify.simplifyProg ops - callKernelRules + rules blockers {Engine.blockHoistBranch = blockAllocs} where blockAllocs vtable _ (Let _ _ (Op Alloc {})) = @@ -75,24 +77,25 @@ MonadFreshNames m, SimplifyMemory rep inner ) => + RuleBook (Wise rep) -> Simplify.SimpleOps rep -> Stms rep -> m (Stms rep) -simplifyStmsGeneric ops stms = do +simplifyStmsGeneric rules ops stms = do scope <- askScope Simplify.simplifyStms ops - callKernelRules + rules blockers scope stms -isResultAlloc :: OpC rep ~ MemOp op => Engine.BlockPred rep +isResultAlloc :: (OpC rep ~ MemOp op) => Engine.BlockPred rep isResultAlloc _ usage (Let (Pat [pe]) _ (Op Alloc {})) = UT.isInResult (patElemName pe) usage isResultAlloc _ _ _ = False -isAlloc :: OpC rep ~ MemOp op => Engine.BlockPred rep +isAlloc :: (OpC rep ~ MemOp op) => Engine.BlockPred rep isAlloc _ _ (Let _ _ (Op Alloc {})) = True isAlloc _ _ _ = False @@ -106,8 +109,10 @@ Engine.isAllocation = isAlloc mempty mempty } -callKernelRules :: SimplifyMemory rep inner => RuleBook (Wise rep) -callKernelRules = +-- | Standard collection of simplification rules for representations +-- with memory. +memRuleBook :: (SimplifyMemory rep inner) => RuleBook (Wise rep) +memRuleBook = standardRules <> ruleBook [ RuleMatch unExistentialiseMemory, @@ -119,7 +124,7 @@ -- the array is not existential, and the index function of the array -- does not refer to any names in the pattern, then we can create a -- block of the proper size and always return there. -unExistentialiseMemory :: SimplifyMemory rep inner => TopDownRuleMatch (Wise rep) +unExistentialiseMemory :: (SimplifyMemory rep inner) => TopDownRuleMatch (Wise rep) unExistentialiseMemory vtable pat _ (cond, cases, defbody, ifdec) | ST.simplifyMemory vtable, fixable <- foldl hasConcretisableMemory mempty $ patElems pat, @@ -185,7 +190,7 @@ -- If an allocation is statically known to be safe, then we can remove -- 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 :: (SimplifyMemory rep inner) => TopDownRuleOp (Wise rep) decertifySafeAlloc _ pat (StmAux cs attrs _) op | cs /= mempty, [Mem _] <- patTypes pat, 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 @@ -104,7 +104,7 @@ ] pTypeBase :: - ArrayShape shape => + (ArrayShape shape) => Parser shape -> Parser u -> Parser (TypeBase shape u) @@ -479,7 +479,7 @@ pLoop :: PR rep -> Parser (Exp rep) pLoop pr = keyword "loop" - $> DoLoop + $> Loop <*> pLoopParams <*> pLoopForm <* keyword "do" @@ -978,9 +978,8 @@ pLMAD = braces $ do offset <- pLab "offset" pNum <* pSemi strides <- pLab "strides" $ brackets (pNum `sepBy` pComma) <* pSemi - shape <- pLab "shape" $ brackets (pNum `sepBy` pComma) <* pSemi - perm <- pLab "permutation" $ brackets (pInt `sepBy` pComma) - pure $ IxFun.LMAD offset $ zipWith3 IxFun.LMADDim strides shape perm + shape <- pLab "shape" $ brackets (pNum `sepBy` pComma) + pure $ IxFun.LMAD offset $ zipWith IxFun.LMADDim strides shape pPrimExpLeaf :: Parser VName pPrimExpLeaf = pVName 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 @@ -49,7 +49,7 @@ instance Pretty Rank where pretty (Rank r) = mconcat $ replicate r "[]" -instance Pretty a => Pretty (Ext a) where +instance (Pretty a) => Pretty (Ext a) where pretty (Free e) = pretty e pretty (Ext x) = "?" <> pretty (show x) @@ -61,7 +61,7 @@ pretty (Space s) = "@" <> pretty s pretty (ScalarSpace d t) = "@" <> mconcat (map (brackets . pretty) d) <> pretty t -instance Pretty u => Pretty (TypeBase Shape u) where +instance (Pretty u) => Pretty (TypeBase Shape u) where pretty (Prim t) = pretty t pretty (Acc acc ispace ts u) = pretty u @@ -75,7 +75,7 @@ pretty u <> mconcat (map (brackets . pretty) ds) <> pretty et pretty (Mem s) = "mem" <> pretty s -instance Pretty u => Pretty (TypeBase ExtShape u) where +instance (Pretty u) => Pretty (TypeBase ExtShape u) where pretty (Prim t) = pretty t pretty (Acc acc ispace ts u) = pretty u @@ -89,7 +89,7 @@ pretty u <> mconcat (map (brackets . pretty) ds) <> pretty et pretty (Mem s) = "mem" <> pretty s -instance Pretty u => Pretty (TypeBase Rank u) where +instance (Pretty u) => Pretty (TypeBase Rank u) where pretty (Prim t) = pretty t pretty (Acc acc ispace ts u) = pretty u @@ -114,13 +114,13 @@ pretty (Certs []) = mempty pretty (Certs cs) = "#" <> braces (commasep (map pretty cs)) -instance PrettyRep rep => Pretty (Stms rep) where +instance (PrettyRep rep) => Pretty (Stms rep) where pretty = stack . map pretty . stmsToList instance Pretty SubExpRes where pretty (SubExpRes cs se) = hsep $ certAnnots cs ++ [pretty se] -instance PrettyRep rep => Pretty (Body rep) where +instance (PrettyRep rep) => Pretty (Body rep) where pretty (Body _ stms res) | null stms = braces (commasep $ map pretty res) | otherwise = @@ -152,17 +152,17 @@ instance Pretty Attrs where pretty = hsep . attrAnnots -instance Pretty t => Pretty (Pat t) where +instance (Pretty t) => Pretty (Pat t) where pretty (Pat xs) = braces $ commastack $ map pretty xs -instance Pretty t => Pretty (PatElem t) where +instance (Pretty t) => Pretty (PatElem t) where pretty (PatElem name t) = pretty name <+> colon <+> align (pretty t) -instance Pretty t => Pretty (Param t) where +instance (Pretty t) => Pretty (Param t) where pretty (Param attrs name t) = annot (attrAnnots attrs) $ pretty name <+> colon <+> align (pretty t) -instance PrettyRep rep => Pretty (Stm rep) where +instance (PrettyRep rep) => Pretty (Stm rep) where pretty stm@(Let pat aux e) = align . hang 2 $ "let" @@ -178,13 +178,13 @@ stmCertAnnots stm ] -instance Pretty a => Pretty (Slice a) where +instance (Pretty a) => Pretty (Slice a) where pretty (Slice xs) = brackets (commasep (map pretty xs)) -instance Pretty d => Pretty (FlatDimIndex d) where +instance (Pretty d) => Pretty (FlatDimIndex d) where pretty (FlatDimIndex n s) = pretty n <+> ":" <+> pretty s -instance Pretty a => Pretty (FlatSlice a) where +instance (Pretty a) => Pretty (FlatSlice a) where pretty (FlatSlice offset xs) = brackets (pretty offset <> ";" <+> commasep (map pretty xs)) instance Pretty BasicOp where @@ -241,22 +241,22 @@ ppTuple' $ map pretty v ] -instance Pretty a => Pretty (ErrorMsg a) where +instance (Pretty a) => Pretty (ErrorMsg a) where pretty (ErrorMsg parts) = braces $ align $ commasep $ map p parts where p (ErrorString s) = pretty $ show s p (ErrorVal t x) = pretty x <+> colon <+> pretty t -maybeNest :: PrettyRep rep => Body rep -> Doc a +maybeNest :: (PrettyRep rep) => Body rep -> Doc a maybeNest b | null $ bodyStms b = pretty b | otherwise = nestedBlock "{" "}" $ pretty b -instance PrettyRep rep => Pretty (Case (Body rep)) where +instance (PrettyRep rep) => Pretty (Case (Body rep)) where pretty (Case vs b) = "case" <+> ppTuple' (map (maybe "_" pretty) vs) <+> "->" <+> maybeNest b -prettyRet :: Pretty t => (t, RetAls) -> Doc a +prettyRet :: (Pretty t) => (t, RetAls) -> Doc a prettyRet (t, RetAls pals rals) | pals == mempty, rals == mempty = @@ -266,7 +266,7 @@ where pl = brackets . commasep . map pretty -instance PrettyRep rep => Pretty (Exp rep) where +instance (PrettyRep rep) => Pretty (Exp rep) where pretty (Match [c] [Case [Just (BoolValue True)] t] f (MatchDec ret ifsort)) = "if" <> info' @@ -299,7 +299,7 @@ pretty (Apply fname args ret (safety, _, _)) = applykw <+> pretty (nameToString fname) - <> apply (map (align . prettyArg) args) + <> apply (map (align . prettyArg) args) colon <+> braces (commasep $ map prettyRet ret) where @@ -309,7 +309,7 @@ Unsafe -> "apply " Safe -> "apply" pretty (Op op) = pretty op - pretty (DoLoop merge form loopbody) = + pretty (Loop merge form loopbody) = "loop" <+> braces (commastack $ map pretty params) <+> equals @@ -325,7 +325,9 @@ ForLoop i it bound loop_vars -> "for" <+> align - ( pretty i <> ":" <> pretty it + ( pretty i + <> ":" + <> pretty it <+> "<" <+> align (pretty bound) stack (map prettyLoopVar loop_vars) @@ -352,7 +354,7 @@ comma parens (pretty op' <> comma ppTuple' (map pretty nes)) ) -instance PrettyRep rep => Pretty (Lambda rep) where +instance (PrettyRep rep) => Pretty (Lambda rep) where pretty (Lambda [] (Body _ stms []) []) | stms == mempty = "nilFn" pretty (Lambda params body rettype) = "\\" @@ -378,7 +380,7 @@ instance Pretty EntryResult where pretty (EntryResult u t) = pretty u <> pretty t -instance PrettyRep rep => Pretty (FunDef rep) where +instance (PrettyRep rep) => Pretty (FunDef rep) where pretty (FunDef entry attrs name rettype fparams body) = annot (attrAnnots attrs) $ fun @@ -393,8 +395,12 @@ Just (p_name, p_entry, ret_entry) -> "entry" <> (parens . align) - ( "\"" <> pretty p_name <> "\"" <> comma - ppTupleLines' (map pretty p_entry) <> comma + ( "\"" + <> pretty p_name + <> "\"" + <> comma + ppTupleLines' (map pretty p_entry) + <> comma ppTupleLines' (map pretty ret_entry) ) @@ -411,10 +417,10 @@ where p (name, t) = "type" <+> dquotes (pretty name) <+> equals <+> pretty t -instance PrettyRep rep => Pretty (Prog rep) where +instance (PrettyRep rep) => Pretty (Prog rep) where pretty (Prog types consts funs) = stack $ punctuate line $ pretty types : pretty consts : map pretty funs -instance Pretty d => Pretty (DimIndex d) where +instance (Pretty d) => Pretty (DimIndex d) where pretty (DimFix i) = pretty i pretty (DimSlice i n s) = pretty i <+> ":+" <+> pretty n <+> "*" <+> pretty s 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 @@ -76,7 +76,7 @@ -- any required certificates have been checked) in any context. For -- example, array indexing is not safe, as the index may be out of -- bounds. On the other hand, adding two numbers cannot fail. -safeExp :: IsOp (Op rep) => Exp rep -> Bool +safeExp :: (IsOp (Op rep)) => Exp rep -> Bool safeExp (BasicOp op) = safeBasicOp op where safeBasicOp (BinOp (SDiv _ Safe) _ _) = True @@ -119,7 +119,7 @@ safeBasicOp Iota {} = True safeBasicOp Replicate {} = True safeBasicOp _ = False -safeExp (DoLoop _ _ body) = safeBody body +safeExp (Loop _ _ body) = safeBody body safeExp (Apply fname _ _ _) = isBuiltInFunction fname safeExp (Match _ cases def_case _) = @@ -128,7 +128,7 @@ safeExp WithAcc {} = True -- Although unlikely to matter. safeExp (Op op) = safeOp op -safeBody :: IsOp (Op rep) => Body rep -> Bool +safeBody :: (IsOp (Op rep)) => Body rep -> Bool safeBody = all (safeExp . stmExp) . bodyStms -- | Return the variable names used in 'Var' subexpressions. May contain @@ -223,7 +223,7 @@ m [BranchType rep] -- | Construct the type of an expression that would match the pattern. -expExtTypesFromPat :: Typed dec => Pat dec -> [ExtType] +expExtTypesFromPat :: (Typed dec) => Pat dec -> [ExtType] expExtTypesFromPat pat = existentialiseExtTypes (patNames pat) $ staticShapes $ @@ -239,7 +239,7 @@ attrForAssert = (== AttrComp "warn" ["safety_checks"]) -- | Horizontally fission a lambda that models a binary operator. -lamIsBinOp :: ASTRep rep => Lambda rep -> Maybe [(BinOp, PrimType, VName, VName)] +lamIsBinOp :: (ASTRep rep) => Lambda rep -> Maybe [(BinOp, PrimType, VName, VName)] lamIsBinOp lam = mapM splitStm $ bodyResult $ lambdaBody lam where n = length $ lambdaReturnType lam diff --git a/src/Futhark/IR/Prop/Aliases.hs b/src/Futhark/IR/Prop/Aliases.hs --- a/src/Futhark/IR/Prop/Aliases.hs +++ b/src/Futhark/IR/Prop/Aliases.hs @@ -122,7 +122,7 @@ onBody body = (bodyAliases body, consumedInBody body) bound = foldMap boundInBody $ defbody : map caseBody cases expAliases _ (BasicOp op) = basicOpAliases op -expAliases pes (DoLoop merge _ loopbody) = +expAliases pes (Loop merge _ loopbody) = mutualAliases (bound <> param_names) pes $ do (p, als) <- transitive . zip params $ zipWith (<>) arg_aliases (bodyAliases loopbody) @@ -154,7 +154,7 @@ expAliases _ (Op op) = opAliases op -- | The variables consumed in this statement. -consumedInStm :: Aliased rep => Stm rep -> Names +consumedInStm :: (Aliased rep) => Stm rep -> Names consumedInStm = consumedInExp . stmExp -- | The variables consumed in this expression. @@ -166,7 +166,7 @@ consumeArg _ = mempty consumedInExp (Match _ cases defbody _) = foldMap (consumedInBody . caseBody) cases <> consumedInBody defbody -consumedInExp (DoLoop merge form body) = +consumedInExp (Loop merge form body) = mconcat ( map (subExpAliases . snd) $ filter (unique . paramDeclType . fst) merge @@ -193,11 +193,11 @@ consumedInExp (Op op) = consumedInOp op -- | The variables consumed by this lambda. -consumedByLambda :: Aliased rep => Lambda rep -> Names +consumedByLambda :: (Aliased rep) => Lambda rep -> Names consumedByLambda = consumedInBody . lambdaBody -- | The aliases of each pattern element. -patAliases :: AliasesOf dec => Pat dec -> [Names] +patAliases :: (AliasesOf dec) => Pat dec -> [Names] patAliases = map aliasesOf . patElems -- | Something that contains alias information. @@ -208,11 +208,11 @@ instance AliasesOf Names where aliasesOf = id -instance AliasesOf dec => AliasesOf (PatElem dec) where +instance (AliasesOf dec) => AliasesOf (PatElem dec) where aliasesOf = aliasesOf . patElemDec -- | Also includes the name itself. -lookupAliases :: AliasesOf (LetDec rep) => VName -> Scope rep -> Names +lookupAliases :: (AliasesOf (LetDec rep)) => VName -> Scope rep -> Names lookupAliases root scope = -- We must be careful to handle circular aliasing properly (this -- can happen due to Match and Loop). @@ -229,7 +229,7 @@ -- | The class of operations that can produce aliasing and consumption -- information. -class IsOp op => AliasedOp op where +class (IsOp op) => AliasedOp op where opAliases :: op -> [Names] consumedInOp :: op -> Names diff --git a/src/Futhark/IR/Prop/Constants.hs b/src/Futhark/IR/Prop/Constants.hs --- a/src/Futhark/IR/Prop/Constants.hs +++ b/src/Futhark/IR/Prop/Constants.hs @@ -61,7 +61,7 @@ value = FloatValue -- | Create a 'Constant' 'SubExp' containing the given value. -constant :: IsValue v => v -> SubExp +constant :: (IsValue v) => v -> SubExp constant = Constant . value -- | Utility definition for reasons of type ambiguity. 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 @@ -192,7 +192,7 @@ freeIn' = fvNames . freeIn -- | The free variables of some syntactic construct. -freeIn :: FreeIn a => a -> Names +freeIn :: (FreeIn a) => a -> Names freeIn = unFV . freeIn' instance FreeIn FV where @@ -216,10 +216,10 @@ instance (FreeIn a, FreeIn b) => FreeIn (Either a b) where freeIn' = either freeIn' freeIn' -instance FreeIn a => FreeIn [a] where +instance (FreeIn a) => FreeIn [a] where freeIn' = foldMap freeIn' -instance FreeIn a => FreeIn (S.Set a) where +instance (FreeIn a) => FreeIn (S.Set a) where freeIn' = foldMap freeIn' instance FreeIn (NoOp rep) where @@ -284,7 +284,7 @@ ) => FreeIn (Exp rep) where - freeIn' (DoLoop merge form loopbody) = + freeIn' (Loop merge form loopbody) = let (params, args) = unzip merge bound_here = namesFromList $ M.keys $ scopeOf form <> scopeOfFParams params @@ -311,10 +311,10 @@ <> freeIn' attrs <> precomputed dec (freeIn' dec <> freeIn' e <> freeIn' pat) -instance FreeIn (Stm rep) => FreeIn (Stms rep) where +instance (FreeIn (Stm rep)) => FreeIn (Stms rep) where freeIn' = foldMap freeIn' -instance FreeIn body => FreeIn (Case body) where +instance (FreeIn body) => FreeIn (Case body) where freeIn' = freeIn' . caseBody instance FreeIn Names where @@ -323,7 +323,7 @@ instance FreeIn Bool where freeIn' _ = mempty -instance FreeIn a => FreeIn (Maybe a) where +instance (FreeIn a) => FreeIn (Maybe a) where freeIn' = maybe mempty freeIn' instance FreeIn VName where @@ -341,48 +341,48 @@ freeIn' DefaultSpace = mempty freeIn' (Space _) = mempty -instance FreeIn d => FreeIn (ShapeBase d) where +instance (FreeIn d) => FreeIn (ShapeBase d) where freeIn' = freeIn' . shapeDims -instance FreeIn d => FreeIn (Ext d) where +instance (FreeIn d) => FreeIn (Ext d) where freeIn' (Free x) = freeIn' x freeIn' (Ext _) = mempty instance FreeIn PrimType where freeIn' _ = mempty -instance FreeIn shape => FreeIn (TypeBase shape u) where +instance (FreeIn shape) => FreeIn (TypeBase shape u) where freeIn' (Array t shape _) = freeIn' t <> freeIn' shape freeIn' (Mem s) = freeIn' s freeIn' Prim {} = mempty freeIn' (Acc acc ispace ts _) = freeIn' (acc, ispace, ts) -instance FreeIn dec => FreeIn (Param dec) where +instance (FreeIn dec) => FreeIn (Param dec) where freeIn' (Param attrs _ dec) = freeIn' attrs <> freeIn' dec -instance FreeIn dec => FreeIn (PatElem dec) where +instance (FreeIn dec) => FreeIn (PatElem dec) where freeIn' (PatElem _ dec) = freeIn' dec -instance FreeIn (LParamInfo rep) => FreeIn (LoopForm rep) where +instance (FreeIn (LParamInfo rep)) => FreeIn (LoopForm rep) where freeIn' (ForLoop _ _ bound loop_vars) = freeIn' bound <> freeIn' loop_vars freeIn' (WhileLoop cond) = freeIn' cond -instance FreeIn d => FreeIn (DimIndex d) where +instance (FreeIn d) => FreeIn (DimIndex d) where freeIn' = Data.Foldable.foldMap freeIn' -instance FreeIn d => FreeIn (Slice d) where +instance (FreeIn d) => FreeIn (Slice d) where freeIn' = Data.Foldable.foldMap freeIn' -instance FreeIn d => FreeIn (FlatDimIndex d) where +instance (FreeIn d) => FreeIn (FlatDimIndex d) where freeIn' = Data.Foldable.foldMap freeIn' -instance FreeIn d => FreeIn (FlatSlice d) where +instance (FreeIn d) => FreeIn (FlatSlice d) where freeIn' = Data.Foldable.foldMap freeIn' instance FreeIn SubExpRes where freeIn' (SubExpRes cs se) = freeIn' cs <> freeIn' se -instance FreeIn dec => FreeIn (Pat dec) where +instance (FreeIn dec) => FreeIn (Pat dec) where freeIn' (Pat xs) = fvBind bound_here $ freeIn' xs where @@ -394,16 +394,16 @@ instance FreeIn Attrs where freeIn' (Attrs _) = mempty -instance FreeIn dec => FreeIn (StmAux dec) where +instance (FreeIn dec) => FreeIn (StmAux dec) where freeIn' (StmAux cs attrs dec) = freeIn' cs <> freeIn' attrs <> freeIn' dec -instance FreeIn a => FreeIn (MatchDec a) where +instance (FreeIn a) => FreeIn (MatchDec a) where freeIn' (MatchDec r _) = freeIn' r -- | Either return precomputed free names stored in the attribute, or -- the freshly computed names. Relies on lazy evaluation to avoid the -- work. -class FreeIn dec => FreeDec dec where +class (FreeIn dec) => FreeDec dec where precomputed :: dec -> FV -> FV precomputed _ = id @@ -412,11 +412,11 @@ instance (FreeDec a, FreeIn b) => FreeDec (a, b) where precomputed (a, _) = precomputed a -instance FreeDec a => FreeDec [a] where +instance (FreeDec a) => FreeDec [a] where precomputed [] = id precomputed (a : _) = precomputed a -instance FreeDec a => FreeDec (Maybe a) where +instance (FreeDec a) => FreeDec (Maybe a) where precomputed Nothing = id precomputed (Just a) = precomputed a diff --git a/src/Futhark/IR/Prop/Patterns.hs b/src/Futhark/IR/Prop/Patterns.hs --- a/src/Futhark/IR/Prop/Patterns.hs +++ b/src/Futhark/IR/Prop/Patterns.hs @@ -26,23 +26,23 @@ import Futhark.IR.Syntax -- | The 'Type' of a parameter. -paramType :: Typed dec => Param dec -> Type +paramType :: (Typed dec) => Param dec -> Type paramType = typeOf -- | The 'DeclType' of a parameter. -paramDeclType :: DeclTyped dec => Param dec -> DeclType +paramDeclType :: (DeclTyped dec) => Param dec -> DeclType paramDeclType = declTypeOf -- | An 'Ident' corresponding to a parameter. -paramIdent :: Typed dec => Param dec -> Ident +paramIdent :: (Typed dec) => Param dec -> Ident paramIdent param = Ident (paramName param) (typeOf param) -- | An 'Ident' corresponding to a pattern element. -patElemIdent :: Typed dec => PatElem dec -> Ident +patElemIdent :: (Typed dec) => PatElem dec -> Ident patElemIdent pelem = Ident (patElemName pelem) (typeOf pelem) -- | The type of a name bound by a t'PatElem'. -patElemType :: Typed dec => PatElem dec -> Type +patElemType :: (Typed dec) => PatElem dec -> Type patElemType = typeOf -- | Set the rep of a t'PatElem'. @@ -50,7 +50,7 @@ setPatElemDec pe x = fmap (const x) pe -- | Return a list of the 'Ident's bound by the t'Pat'. -patIdents :: Typed dec => Pat dec -> [Ident] +patIdents :: (Typed dec) => Pat dec -> [Ident] patIdents = map patElemIdent . patElems -- | Return a list of the 'Name's bound by the t'Pat'. @@ -58,7 +58,7 @@ patNames = map patElemName . patElems -- | Return a list of the typess bound by the pattern. -patTypes :: Typed dec => Pat dec -> [Type] +patTypes :: (Typed dec) => Pat dec -> [Type] patTypes = map identType . patIdents -- | Return the number of names bound by the pattern. diff --git a/src/Futhark/IR/Prop/Rearrange.hs b/src/Futhark/IR/Prop/Rearrange.hs --- a/src/Futhark/IR/Prop/Rearrange.hs +++ b/src/Futhark/IR/Prop/Rearrange.hs @@ -47,14 +47,14 @@ -- if so, return the permutation. This will also find identity -- permutations (i.e. the lists are the same) The implementation is -- naive and slow. -isPermutationOf :: Eq a => [a] -> [a] -> Maybe [Int] +isPermutationOf :: (Eq a) => [a] -> [a] -> Maybe [Int] isPermutationOf l1 l2 = case mapAccumLM (pick 0) (map Just l2) l1 of Just (l2', perm) | all (== Nothing) l2' -> Just perm _ -> Nothing where - pick :: Eq a => Int -> [Maybe a] -> a -> Maybe ([Maybe a], Int) + pick :: (Eq a) => Int -> [Maybe a] -> a -> Maybe ([Maybe a], Int) pick _ [] _ = Nothing pick i (x : xs) y | Just y == x = Just (Nothing : xs, i) diff --git a/src/Futhark/IR/Prop/Reshape.hs b/src/Futhark/IR/Prop/Reshape.hs --- a/src/Futhark/IR/Prop/Reshape.hs +++ b/src/Futhark/IR/Prop/Reshape.hs @@ -47,7 +47,7 @@ -- have the same length as @from_dims@, and @is'@ will have the same -- length as @to_dims@. reshapeIndex :: - IntegralExp num => + (IntegralExp num) => [num] -> [num] -> [num] -> @@ -59,14 +59,14 @@ -- with dimension @dims@ given the flat index @i@. The resulting list -- will have the same size as @dims@. unflattenIndex :: - IntegralExp num => + (IntegralExp num) => [num] -> num -> [num] unflattenIndex = unflattenIndexFromSlices . drop 1 . sliceSizes unflattenIndexFromSlices :: - IntegralExp num => + (IntegralExp num) => [num] -> num -> [num] @@ -78,7 +78,7 @@ -- array with dimensions @dims@. The length of @dims@ and @is@ must -- be the same. flattenIndex :: - IntegralExp num => + (IntegralExp num) => [num] -> [num] -> num @@ -92,7 +92,7 @@ -- slice. The first element of this list will be the product of -- @dims@, and the last element will be 1. sliceSizes :: - IntegralExp num => + (IntegralExp num) => [num] -> [num] sliceSizes [] = [1] diff --git a/src/Futhark/IR/Prop/Scope.hs b/src/Futhark/IR/Prop/Scope.hs --- a/src/Futhark/IR/Prop/Scope.hs +++ b/src/Futhark/IR/Prop/Scope.hs @@ -51,9 +51,9 @@ | LParamName (LParamInfo rep) | IndexName IntType -deriving instance RepTypes rep => Show (NameInfo rep) +deriving instance (RepTypes rep) => Show (NameInfo rep) -instance RepTypes rep => Typed (NameInfo rep) where +instance (RepTypes rep) => Typed (NameInfo rep) where typeOf (LetName dec) = typeOf dec typeOf (FParamName dec) = typeOf dec typeOf (LParamName dec) = typeOf dec @@ -156,7 +156,7 @@ inScopeOf :: (Scoped rep a, LocalScope rep m) => a -> m b -> m b inScopeOf = localScope . scopeOf -instance Scoped rep a => Scoped rep [a] where +instance (Scoped rep a) => Scoped rep [a] where scopeOf = mconcat . map scopeOf instance Scoped rep (Stms rep) where @@ -177,17 +177,17 @@ M.insert i (IndexName it) $ scopeOfLParams (map fst xs) -- | The scope of a pattern. -scopeOfPat :: LetDec rep ~ dec => Pat dec -> Scope rep +scopeOfPat :: (LetDec rep ~ dec) => Pat dec -> Scope rep scopeOfPat = mconcat . map scopeOfPatElem . patElems -- | The scope of a pattern element. -scopeOfPatElem :: LetDec rep ~ dec => PatElem dec -> Scope rep +scopeOfPatElem :: (LetDec rep ~ dec) => PatElem dec -> Scope rep scopeOfPatElem (PatElem name dec) = M.singleton name $ LetName dec -- | The scope of some lambda parameters. scopeOfLParams :: - LParamInfo rep ~ dec => + (LParamInfo rep ~ dec) => [Param dec] -> Scope rep scopeOfLParams = M.fromList . map f @@ -196,7 +196,7 @@ -- | The scope of some function or loop parameters. scopeOfFParams :: - FParamInfo rep ~ dec => + (FParamInfo rep ~ dec) => [Param dec] -> Scope rep scopeOfFParams = M.fromList . map f @@ -217,13 +217,13 @@ -- | If two scopes are really the same, then you can convert one to -- the other. castScope :: - SameScope fromrep torep => + (SameScope fromrep torep) => Scope fromrep -> Scope torep castScope = M.map castNameInfo castNameInfo :: - SameScope fromrep torep => + (SameScope fromrep torep) => NameInfo fromrep -> NameInfo torep castNameInfo (LetName dec) = LetName dec diff --git a/src/Futhark/IR/Prop/TypeOf.hs b/src/Futhark/IR/Prop/TypeOf.hs --- a/src/Futhark/IR/Prop/TypeOf.hs +++ b/src/Futhark/IR/Prop/TypeOf.hs @@ -39,13 +39,13 @@ import Futhark.IR.Syntax -- | The type of a subexpression. -subExpType :: HasScope t m => SubExp -> m Type +subExpType :: (HasScope t m) => SubExp -> m Type subExpType (Constant val) = pure $ Prim $ primValueType val subExpType (Var name) = lookupType name -- | Type type of a 'SubExpRes' - not that this might refer to names -- bound in the body containing the result. -subExpResType :: HasScope t m => SubExpRes -> m Type +subExpResType :: (HasScope t m) => SubExpRes -> m Type subExpResType = subExpType . resSubExp -- | @mapType f arrts@ wraps each element in the return type of @f@ in @@ -58,7 +58,7 @@ ] -- | The type of a primitive operation. -basicOpType :: HasScope rep m => BasicOp -> m [Type] +basicOpType :: (HasScope rep m) => BasicOp -> m [Type] basicOpType (SubExp se) = pure <$> subExpType se basicOpType (Opaque _ se) = @@ -127,7 +127,7 @@ m [ExtType] expExtType (Apply _ _ rt _) = pure $ map (fromDecl . declExtTypeOf . fst) rt expExtType (Match _ _ _ rt) = pure $ map extTypeOf $ matchReturns rt -expExtType (DoLoop merge _ _) = +expExtType (Loop merge _ _) = pure $ loopExtType $ map fst merge expExtType (BasicOp op) = staticShapes <$> basicOpType op expExtType (WithAcc inputs lam) = @@ -141,7 +141,7 @@ expExtType (Op op) = opType op -- | Given the parameters of a loop, produce the return type. -loopExtType :: Typed dec => [Param dec] -> [ExtType] +loopExtType :: (Typed dec) => [Param dec] -> [ExtType] loopExtType params = existentialiseExtTypes inaccessible $ staticShapes $ map typeOf params where @@ -150,7 +150,7 @@ -- | Any operation must define an instance of this class, which -- describes the type of the operation (at the value level). class TypedOp op where - opType :: HasScope t m => op -> m [ExtType] + opType :: (HasScope t m) => op -> m [ExtType] instance TypedOp (NoOp rep) where opType NoOp = pure [] 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 @@ -77,7 +77,7 @@ import Futhark.IR.Syntax.Core -- | Remove shape information from a type. -rankShaped :: ArrayShape shape => TypeBase shape u -> TypeBase Rank u +rankShaped :: (ArrayShape shape) => TypeBase shape u -> TypeBase Rank u rankShaped (Array et sz u) = Array et (Rank $ shapeRank sz) u rankShaped (Prim pt) = Prim pt rankShaped (Acc acc ispace ts u) = Acc acc ispace ts u @@ -86,18 +86,18 @@ -- | Return the dimensionality of a type. For non-arrays, this is -- zero. For a one-dimensional array it is one, for a two-dimensional -- it is two, and so forth. -arrayRank :: ArrayShape shape => TypeBase shape u -> Int +arrayRank :: (ArrayShape shape) => TypeBase shape u -> Int arrayRank = shapeRank . arrayShape -- | Return the shape of a type - for non-arrays, this is the -- 'mempty'. -arrayShape :: ArrayShape shape => TypeBase shape u -> shape +arrayShape :: (ArrayShape shape) => TypeBase shape u -> shape arrayShape (Array _ ds _) = ds arrayShape _ = mempty -- | Modify the shape of an array - for non-arrays, this does nothing. modifyArrayShape :: - ArrayShape newshape => + (ArrayShape newshape) => (oldshape -> newshape) -> TypeBase oldshape u -> TypeBase newshape u @@ -113,7 +113,7 @@ -- | Set the shape of an array. If the given type is not an -- array, return the type unchanged. setArrayShape :: - ArrayShape newshape => + (ArrayShape newshape) => TypeBase oldshape u -> newshape -> TypeBase newshape u @@ -169,7 +169,7 @@ -- be returned, although if it is an array, with the uniqueness -- changed to @u@. arrayOf :: - ArrayShape shape => + (ArrayShape shape) => TypeBase shape u_unused -> shape -> u -> @@ -188,7 +188,7 @@ -- size is the given dimension. This is just a convenient wrapper -- around 'arrayOf'. arrayOfRow :: - ArrayShape (ShapeBase d) => + (ArrayShape (ShapeBase d)) => TypeBase (ShapeBase d) NoUniqueness -> d -> TypeBase (ShapeBase d) NoUniqueness @@ -208,7 +208,7 @@ -- | Replace the size of the outermost dimension of an array. If the -- given type is not an array, it is returned unchanged. setOuterSize :: - ArrayShape (ShapeBase d) => + (ArrayShape (ShapeBase d)) => TypeBase (ShapeBase d) u -> d -> TypeBase (ShapeBase d) u @@ -217,7 +217,7 @@ -- | Replace the size of the given dimension of an array. If the -- given type is not an array, it is returned unchanged. setDimSize :: - ArrayShape (ShapeBase d) => + (ArrayShape (ShapeBase d)) => Int -> TypeBase (ShapeBase d) u -> d -> @@ -322,7 +322,7 @@ -- | Transform any t'SubExp's in the type. mapOnExtType :: - Monad m => + (Monad m) => (SubExp -> m SubExp) -> TypeBase ExtShape u -> m (TypeBase ExtShape u) @@ -345,7 +345,7 @@ -- | Transform any t'SubExp's in the type. mapOnType :: - Monad m => + (Monad m) => (SubExp -> m SubExp) -> TypeBase Shape u -> m (TypeBase Shape u) @@ -385,9 +385,9 @@ u2 <= u1 && t1 - == t2 + == t2 && shape1 - `subShapeOf` shape2 + `subShapeOf` shape2 subtypeOf t1 t2 = t1 == t2 -- | @xs \`subtypesOf\` ys@ is true if @xs@ is the same size as @ys@, @@ -515,7 +515,7 @@ match (Ext i) dim = M.singleton i dim dimMapping :: - Monoid res => + (Monoid res) => (t1 -> [dim1]) -> (t2 -> [dim2]) -> (dim1 -> dim2 -> res) -> @@ -563,13 +563,13 @@ instance Typed Ident where typeOf = identType -instance Typed dec => Typed (Param dec) where +instance (Typed dec) => Typed (Param dec) where typeOf = typeOf . paramDec -instance Typed dec => Typed (PatElem dec) where +instance (Typed dec) => Typed (PatElem dec) where typeOf = typeOf . patElemDec -instance Typed b => Typed (a, b) where +instance (Typed b) => Typed (a, b) where typeOf = typeOf . snd -- | Typeclass for things that contain 'DeclType's. @@ -579,11 +579,11 @@ instance DeclTyped DeclType where declTypeOf = id -instance DeclTyped dec => DeclTyped (Param dec) where +instance (DeclTyped dec) => DeclTyped (Param dec) where declTypeOf = declTypeOf . paramDec -- | Typeclass for things that contain 'ExtType's. -class FixExt t => ExtTyped t where +class (FixExt t) => ExtTyped t where extTypeOf :: t -> ExtType instance ExtTyped ExtType where @@ -593,23 +593,23 @@ extTypeOf = fromDecl . declExtTypeOf -- | Typeclass for things that contain 'DeclExtType's. -class FixExt t => DeclExtTyped t where +class (FixExt t) => DeclExtTyped t where declExtTypeOf :: t -> DeclExtType instance DeclExtTyped DeclExtType where declExtTypeOf = id -- | Typeclass for things whose type can be changed. -class Typed a => SetType a where +class (Typed a) => SetType a where setType :: a -> Type -> a instance SetType Type where setType _ t = t -instance SetType b => SetType (a, b) where +instance (SetType b) => SetType (a, b) where setType (a, b) t = (a, setType b t) -instance SetType dec => SetType (PatElem dec) where +instance (SetType dec) => SetType (PatElem dec) where setType (PatElem name dec) t = PatElem name $ setType dec t @@ -623,10 +623,10 @@ instance (FixExt shape, ArrayShape shape) => FixExt (TypeBase shape u) where fixExt i se = modifyArrayShape $ fixExt i se -instance FixExt d => FixExt (ShapeBase d) where +instance (FixExt d) => FixExt (ShapeBase d) where fixExt i se = fmap $ fixExt i se -instance FixExt a => FixExt [a] where +instance (FixExt a) => FixExt [a] where fixExt i se = fmap $ fixExt i se instance FixExt ExtSize where 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 @@ -36,14 +36,14 @@ } -- | Rephrase an entire program. -rephraseProg :: Monad m => Rephraser m from to -> Prog from -> m (Prog to) +rephraseProg :: (Monad m) => Rephraser m from to -> Prog from -> m (Prog to) rephraseProg rephraser prog = do consts <- mapM (rephraseStm rephraser) (progConsts prog) funs <- mapM (rephraseFunDef rephraser) (progFuns prog) pure $ prog {progConsts = consts, progFuns = funs} -- | Rephrase a function definition. -rephraseFunDef :: Monad m => Rephraser m from to -> FunDef from -> m (FunDef to) +rephraseFunDef :: (Monad m) => Rephraser m from to -> FunDef from -> m (FunDef to) rephraseFunDef rephraser fundec = do body' <- rephraseBody rephraser $ funDefBody fundec params' <- mapM (rephraseParam $ rephraseFParamDec rephraser) $ funDefParams fundec @@ -51,11 +51,11 @@ pure fundec {funDefBody = body', funDefParams = params', funDefRetType = rettype'} -- | Rephrase an expression. -rephraseExp :: Monad m => Rephraser m from to -> Exp from -> m (Exp to) +rephraseExp :: (Monad m) => Rephraser m from to -> Exp from -> m (Exp to) rephraseExp = mapExpM . mapper -- | Rephrase a statement. -rephraseStm :: Monad m => Rephraser m from to -> Stm from -> m (Stm to) +rephraseStm :: (Monad m) => Rephraser m from to -> Stm from -> m (Stm to) rephraseStm rephraser (Let pat (StmAux cs attrs dec) e) = Let <$> rephrasePat (rephraseLetBoundDec rephraser) pat @@ -64,24 +64,24 @@ -- | Rephrase a pattern. rephrasePat :: - Monad m => + (Monad m) => (from -> m to) -> Pat from -> m (Pat to) rephrasePat = traverse -- | Rephrase a pattern element. -rephrasePatElem :: Monad m => (from -> m to) -> PatElem from -> m (PatElem to) +rephrasePatElem :: (Monad m) => (from -> m to) -> PatElem from -> m (PatElem to) rephrasePatElem rephraser (PatElem ident from) = PatElem ident <$> rephraser from -- | Rephrase a parameter. -rephraseParam :: Monad m => (from -> m to) -> Param from -> m (Param to) +rephraseParam :: (Monad m) => (from -> m to) -> Param from -> m (Param to) rephraseParam rephraser (Param attrs name from) = Param attrs name <$> rephraser from -- | Rephrase a body. -rephraseBody :: Monad m => Rephraser m from to -> Body from -> m (Body to) +rephraseBody :: (Monad m) => Rephraser m from to -> Body from -> m (Body to) rephraseBody rephraser (Body rep stms res) = Body <$> rephraseBodyDec rephraser rep @@ -89,13 +89,13 @@ <*> pure res -- | Rephrase a lambda. -rephraseLambda :: Monad m => Rephraser m from to -> Lambda from -> m (Lambda to) +rephraseLambda :: (Monad m) => Rephraser m from to -> Lambda from -> m (Lambda to) rephraseLambda rephraser lam = do body' <- rephraseBody rephraser $ lambdaBody lam params' <- mapM (rephraseParam $ rephraseLParamDec rephraser) $ lambdaParams lam pure lam {lambdaBody = body', lambdaParams = params'} -mapper :: Monad m => Rephraser m from to -> Mapper from to m +mapper :: (Monad m) => Rephraser m from to -> Mapper from to m mapper rephraser = identityMapper { mapOnBody = const $ rephraseBody rephraser, @@ -109,7 +109,7 @@ -- | Rephrasing any fragments inside an Op from one representation to -- another. class RephraseOp op where - rephraseInOp :: Monad m => Rephraser m from to -> op from -> m (op to) + rephraseInOp :: (Monad m) => Rephraser m from to -> op from -> m (op to) instance RephraseOp NoOp where rephraseInOp _ NoOp = pure NoOp diff --git a/src/Futhark/IR/RetType.hs b/src/Futhark/IR/RetType.hs --- a/src/Futhark/IR/RetType.hs +++ b/src/Futhark/IR/RetType.hs @@ -36,7 +36,7 @@ -- and the arguments for a concrete call, return the instantiated -- return type for the concrete call, if valid. applyRetType :: - Typed dec => + (Typed dec) => [rt] -> [Param dec] -> [(SubExp, Type)] -> @@ -44,7 +44,7 @@ -- | Given shape parameter names and types, produce the types of -- arguments accepted. -expectedTypes :: Typed t => [VName] -> [t] -> [SubExp] -> [Type] +expectedTypes :: (Typed t) => [VName] -> [t] -> [SubExp] -> [Type] expectedTypes shapes value_ts args = map (correctDims . typeOf) value_ts where parammap :: M.Map VName SubExp diff --git a/src/Futhark/IR/SOACS.hs b/src/Futhark/IR/SOACS.hs --- a/src/Futhark/IR/SOACS.hs +++ b/src/Futhark/IR/SOACS.hs @@ -65,7 +65,7 @@ lamUsesAD lam expUsesAD (Match _ cases def_case _) = any (bodyUsesAD . caseBody) cases || bodyUsesAD def_case - expUsesAD (DoLoop _ _ body) = bodyUsesAD body + expUsesAD (Loop _ _ body) = bodyUsesAD body expUsesAD (WithAcc _ lam) = lamUsesAD lam expUsesAD BasicOp {} = False expUsesAD Apply {} = False diff --git a/src/Futhark/IR/SOACS/SOAC.hs b/src/Futhark/IR/SOACS/SOAC.hs --- a/src/Futhark/IR/SOACS/SOAC.hs +++ b/src/Futhark/IR/SOACS/SOAC.hs @@ -149,7 +149,7 @@ (Lambda rep) deriving (Eq, Ord, Show) -singleBinOp :: Buildable rep => [Lambda rep] -> Lambda rep +singleBinOp :: (Buildable rep) => [Lambda rep] -> Lambda rep singleBinOp lams = Lambda { lambdaParams = concatMap xParams lams ++ concatMap yParams lams, @@ -175,7 +175,7 @@ scanResults = sum . map (length . scanNeutral) -- | Combine multiple scan operators to a single operator. -singleScan :: Buildable rep => [Scan rep] -> Scan rep +singleScan :: (Buildable rep) => [Scan rep] -> Scan rep singleScan scans = let scan_nes = concatMap scanNeutral scans scan_lam = singleBinOp $ map scanLambda scans @@ -194,7 +194,7 @@ redResults = sum . map (length . redNeutral) -- | Combine multiple reduction operators to a single operator. -singleReduce :: Buildable rep => [Reduce rep] -> Reduce rep +singleReduce :: (Buildable rep) => [Reduce rep] -> Reduce rep singleReduce reds = let red_nes = concatMap redNeutral reds red_lam = singleBinOp $ map redLambda reds @@ -234,7 +234,7 @@ == map (Var . paramName) (lambdaParams lam) -- | A lambda with no parameters that returns no values. -nilFn :: Buildable rep => Lambda rep +nilFn :: (Buildable rep) => Lambda rep nilFn = Lambda mempty (mkBody mempty mempty) mempty -- | Construct a Screma with possibly multiple scans, and @@ -372,7 +372,7 @@ } -- | A mapper that simply returns the SOAC verbatim. -identitySOACMapper :: forall rep m. Monad m => SOACMapper rep rep m +identitySOACMapper :: forall rep m. (Monad m) => SOACMapper rep rep m identitySOACMapper = SOACMapper { mapOnSOACSubExp = pure, @@ -384,7 +384,7 @@ -- SOAC. The mapping does not descend recursively into subexpressions -- and is done left-to-right. mapSOACM :: - Monad m => + (Monad m) => SOACMapper frep trep m -> SOAC frep -> m (SOAC trep) @@ -455,26 +455,26 @@ ) -- | A helper for defining 'TraverseOpStms'. -traverseSOACStms :: Monad m => OpStmsTraverser m (SOAC rep) rep +traverseSOACStms :: (Monad m) => OpStmsTraverser m (SOAC rep) rep traverseSOACStms f = mapSOACM mapper where mapper = identitySOACMapper {mapOnSOACLambda = traverseLambdaStms f} -instance ASTRep rep => FreeIn (Scan rep) where +instance (ASTRep rep) => FreeIn (Scan rep) where freeIn' (Scan lam ne) = freeIn' lam <> freeIn' ne -instance ASTRep rep => FreeIn (Reduce rep) where +instance (ASTRep rep) => FreeIn (Reduce rep) where freeIn' (Reduce _ lam ne) = freeIn' lam <> freeIn' ne -instance ASTRep rep => FreeIn (ScremaForm rep) where +instance (ASTRep rep) => FreeIn (ScremaForm rep) where freeIn' (ScremaForm scans reds lam) = freeIn' scans <> freeIn' reds <> freeIn' lam -instance ASTRep rep => FreeIn (HistOp rep) where +instance (ASTRep rep) => FreeIn (HistOp rep) where freeIn' (HistOp w rf dests nes lam) = freeIn' w <> freeIn' rf <> freeIn' dests <> freeIn' nes <> freeIn' lam -instance ASTRep rep => FreeIn (SOAC rep) where +instance (ASTRep rep) => FreeIn (SOAC rep) where freeIn' = flip execState mempty . mapSOACM free where walk f x = modify (<> f x) >> pure x @@ -485,7 +485,7 @@ mapOnSOACVName = walk freeIn' } -instance ASTRep rep => Substitute (SOAC rep) where +instance (ASTRep rep) => Substitute (SOAC rep) where substituteNames subst = runIdentity . mapSOACM substitute where @@ -496,13 +496,13 @@ mapOnSOACVName = pure . substituteNames subst } -instance ASTRep rep => Rename (SOAC rep) where +instance (ASTRep rep) => Rename (SOAC rep) where rename = mapSOACM renamer where renamer = SOACMapper rename rename rename -- | The type of a SOAC. -soacType :: Typed (LParamInfo rep) => SOAC rep -> [Type] +soacType :: (Typed (LParamInfo rep)) => SOAC rep -> [Type] soacType (JVP lam _ _) = lambdaReturnType lam ++ lambdaReturnType lam @@ -516,21 +516,20 @@ substs = M.fromList $ zip nms (outersize : accs) Lambda params _ rtp = lam soacType (Scatter _w _ivs lam dests) = - zipWith arrayOfShape val_ts ws + zipWith arrayOfShape (map (snd . head) rets) shapes where - indexes = sum $ zipWith (*) ns $ map length ws - val_ts = drop indexes $ lambdaReturnType lam - (ws, ns, _) = unzip3 dests + (shapes, _, rets) = + unzip3 $ groupScatterResults dests $ lambdaReturnType lam soacType (Hist _ _ ops _bucket_fun) = do op <- ops map (`arrayOfShape` histShape op) (lambdaReturnType $ histOp op) soacType (Screma w _arrs form) = scremaType w form -instance ASTRep rep => TypedOp (SOAC rep) where +instance (ASTRep rep) => TypedOp (SOAC rep) where opType = pure . staticShapes . soacType -instance Aliased rep => AliasedOp (SOAC rep) where +instance (Aliased rep) => AliasedOp (SOAC rep) where opAliases = map (const mempty) . soacType consumedInOp JVP {} = mempty @@ -586,7 +585,7 @@ onRed red = red {redLambda = Alias.analyseLambda aliases $ redLambda red} onScan scan = scan {scanLambda = Alias.analyseLambda aliases $ scanLambda scan} -instance ASTRep rep => IsOp (SOAC rep) where +instance (ASTRep rep) => IsOp (SOAC rep) where safeOp _ = False cheapOp _ = False @@ -606,7 +605,7 @@ instance CanBeWise SOAC where addOpWisdom = runIdentity . mapSOACM (SOACMapper pure (pure . informLambda) pure) -instance RepTypes rep => ST.IndexOp (SOAC rep) where +instance (RepTypes rep) => ST.IndexOp (SOAC rep) where indexOp vtable k soac [i] = do (lam, se, arr_params, arrs) <- lambdaAndSubExp soac let arr_indexes = M.fromList $ catMaybes $ zipWith arrIndex arr_params arrs @@ -645,7 +644,7 @@ indexOp _ _ _ _ = Nothing -- | Type-check a SOAC. -typeCheckSOAC :: TC.Checkable rep => SOAC (Aliases rep) -> TC.TypeM rep () +typeCheckSOAC :: (TC.Checkable rep) => SOAC (Aliases rep) -> TC.TypeM rep () typeCheckSOAC (VJP lam args vec) = do args' <- mapM TC.checkArg args TC.checkLambda lam $ map TC.noArgAliases args' @@ -850,7 +849,7 @@ onScan (Scan op nes) = Scan <$> rephraseLambda r op <*> pure nes onRed (Reduce comm op nes) = Reduce comm <$> rephraseLambda r op <*> pure nes -instance OpMetrics (Op rep) => OpMetrics (SOAC rep) where +instance (OpMetrics (Op rep)) => OpMetrics (SOAC rep) where opMetrics (VJP lam _ _) = inside "VJP" $ lambdaMetrics lam opMetrics (JVP lam _ _) = @@ -867,21 +866,25 @@ mapM_ (lambdaMetrics . redLambda) reds lambdaMetrics map_lam -instance PrettyRep rep => PP.Pretty (SOAC rep) where +instance (PrettyRep rep) => PP.Pretty (SOAC rep) where pretty (VJP lam args vec) = "vjp" <> parens ( PP.align $ - pretty lam <> comma - PP.braces (commasep $ map pretty args) <> comma + pretty lam + <> comma + PP.braces (commasep $ map pretty args) + <> comma PP.braces (commasep $ map pretty vec) ) pretty (JVP lam args vec) = "jvp" <> parens ( PP.align $ - pretty lam <> comma - PP.braces (commasep $ map pretty args) <> comma + pretty lam + <> comma + PP.braces (commasep $ map pretty args) + <> comma PP.braces (commasep $ map pretty vec) ) pretty (Stream size arrs acc lam) = @@ -895,24 +898,32 @@ null reds = "map" <> (parens . align) - ( pretty w <> comma - ppTuple' (map pretty arrs) <> comma + ( pretty w + <> comma + ppTuple' (map pretty arrs) + <> comma pretty map_lam ) | null scans = "redomap" <> (parens . align) - ( pretty w <> comma - ppTuple' (map pretty arrs) <> comma - PP.braces (mconcat $ intersperse (comma <> PP.line) $ map pretty reds) <> comma + ( pretty w + <> comma + ppTuple' (map pretty arrs) + <> comma + PP.braces (mconcat $ intersperse (comma <> PP.line) $ map pretty reds) + <> comma pretty map_lam ) | null reds = "scanomap" <> (parens . align) - ( pretty w <> comma - ppTuple' (map pretty arrs) <> comma - PP.braces (mconcat $ intersperse (comma <> PP.line) $ map pretty scans) <> comma + ( pretty w + <> comma + ppTuple' (map pretty arrs) + <> comma + PP.braces (mconcat $ intersperse (comma <> PP.line) $ map pretty scans) + <> comma pretty map_lam ) pretty (Screma w arrs form) = ppScrema w arrs form @@ -923,10 +934,14 @@ ppScrema w arrs (ScremaForm scans reds map_lam) = "screma" <> (parens . align) - ( pretty w <> comma - ppTuple' (map pretty arrs) <> comma - PP.braces (mconcat $ intersperse (comma <> PP.line) $ map pretty scans) <> comma - PP.braces (mconcat $ intersperse (comma <> PP.line) $ map pretty reds) <> comma + ( pretty w + <> comma + ppTuple' (map pretty arrs) + <> comma + PP.braces (mconcat $ intersperse (comma <> PP.line) $ map pretty scans) + <> comma + PP.braces (mconcat $ intersperse (comma <> PP.line) $ map pretty reds) + <> comma pretty map_lam ) @@ -936,9 +951,12 @@ ppStream size arrs acc lam = "streamSeq" <> (parens . align) - ( pretty size <> comma - ppTuple' (map pretty arrs) <> comma - ppTuple' (map pretty acc) <> comma + ( pretty size + <> comma + ppTuple' (map pretty arrs) + <> comma + ppTuple' (map pretty acc) + <> comma pretty lam ) @@ -948,13 +966,16 @@ ppScatter w arrs lam dests = "scatter" <> (parens . align) - ( pretty w <> comma - ppTuple' (map pretty arrs) <> comma - pretty lam <> comma + ( pretty w + <> comma + ppTuple' (map pretty arrs) + <> comma + pretty lam + <> comma commasep (map pretty dests) ) -instance PrettyRep rep => Pretty (Scan rep) where +instance (PrettyRep rep) => Pretty (Scan rep) where pretty (Scan scan_lam scan_nes) = pretty scan_lam <> comma PP.braces (commasep $ map pretty scan_nes) @@ -962,9 +983,11 @@ ppComm Noncommutative = mempty ppComm Commutative = "commutative " -instance PrettyRep rep => Pretty (Reduce rep) where +instance (PrettyRep rep) => Pretty (Reduce rep) where pretty (Reduce comm red_lam red_nes) = - ppComm comm <> pretty red_lam <> comma + ppComm comm + <> pretty red_lam + <> comma PP.braces (commasep $ map pretty red_nes) -- | Prettyprint the given histogram operation. @@ -978,15 +1001,22 @@ ppHist w arrs ops bucket_fun = "hist" <> parens - ( pretty w <> comma - ppTuple' (map pretty arrs) <> comma - PP.braces (mconcat $ intersperse (comma <> PP.line) $ map ppOp ops) <> comma + ( pretty w + <> comma + ppTuple' (map pretty arrs) + <> comma + PP.braces (mconcat $ intersperse (comma <> PP.line) $ map ppOp ops) + <> comma pretty bucket_fun ) where ppOp (HistOp dest_w rf dests nes op) = - pretty dest_w <> comma - <+> pretty rf <> comma - <+> PP.braces (commasep $ map pretty dests) <> comma - ppTuple' (map pretty nes) <> comma + pretty dest_w + <> comma + <+> pretty rf + <> comma + <+> PP.braces (commasep $ map pretty dests) + <> comma + ppTuple' (map pretty nes) + <> comma pretty op diff --git a/src/Futhark/IR/SOACS/Simplify.hs b/src/Futhark/IR/SOACS/Simplify.hs --- a/src/Futhark/IR/SOACS/Simplify.hs +++ b/src/Futhark/IR/SOACS/Simplify.hs @@ -56,7 +56,7 @@ Simplify.simplifyProg simpleSOACS soacRules Engine.noExtraHoistBlockers simplifyFun :: - MonadFreshNames m => + (MonadFreshNames m) => ST.SymbolTable (Wise SOACS) -> FunDef SOACS -> m (FunDef SOACS) @@ -75,12 +75,12 @@ Simplify.simplifyStms simpleSOACS soacRules Engine.noExtraHoistBlockers scope stms simplifyConsts :: - MonadFreshNames m => Stms SOACS -> m (Stms SOACS) + (MonadFreshNames m) => Stms SOACS -> m (Stms SOACS) simplifyConsts = Simplify.simplifyStms simpleSOACS soacRules Engine.noExtraHoistBlockers mempty simplifySOAC :: - Simplify.SimplifiableRep rep => + (Simplify.SimplifiableRep rep) => Simplify.SimplifyOp rep (SOAC (Wise rep)) simplifySOAC (VJP lam arr vec) = do (lam', hoisted) <- Engine.simplifyLambda mempty lam @@ -356,7 +356,7 @@ removeReplicateWrite _ _ _ _ = Skip removeReplicateInput :: - Aliased rep => + (Aliased rep) => ST.SymbolTable rep -> Lambda rep -> [VName] -> @@ -537,7 +537,7 @@ (zip redlam_params $ map resSubExp $ redlam_res <> redlam_res) redlam_deps, let alive_mask = map ((`nameIn` necessary) . paramName) redlam_params, - not $ all (== True) (take (length nes) alive_mask) = Simplify $ do + not $ and (take (length nes) alive_mask) = Simplify $ do let fixDeadToNeutral lives ne = if lives then Nothing else Just ne dead_fix = zipWith fixDeadToNeutral alive_mask nes (used_red_pes, _, used_nes) = diff --git a/src/Futhark/IR/SegOp.hs b/src/Futhark/IR/SegOp.hs --- a/src/Futhark/IR/SegOp.hs +++ b/src/Futhark/IR/SegOp.hs @@ -163,11 +163,11 @@ kernelBodyResult :: [KernelResult] } -deriving instance RepTypes rep => Ord (KernelBody rep) +deriving instance (RepTypes rep) => Ord (KernelBody rep) -deriving instance RepTypes rep => Show (KernelBody rep) +deriving instance (RepTypes rep) => Show (KernelBody rep) -deriving instance RepTypes rep => Eq (KernelBody rep) +deriving instance (RepTypes rep) => Eq (KernelBody rep) -- | Metadata about whether there is a subtle point to this -- 'KernelResult'. This is used to protect things like tiling, which @@ -236,13 +236,13 @@ freeIn' (RegTileReturns cs dims_n_tiles v) = freeIn' cs <> freeIn' dims_n_tiles <> freeIn' v -instance ASTRep rep => FreeIn (KernelBody rep) where +instance (ASTRep rep) => FreeIn (KernelBody rep) where freeIn' (KernelBody dec stms res) = fvBind bound_in_stms $ freeIn' dec <> freeIn' stms <> freeIn' res where bound_in_stms = foldMap boundByStm stms -instance ASTRep rep => Substitute (KernelBody rep) where +instance (ASTRep rep) => Substitute (KernelBody rep) where substituteNames subst (KernelBody dec stms res) = KernelBody (substituteNames subst dec) @@ -269,7 +269,7 @@ (substituteNames subst dims_n_tiles) (substituteNames subst v) -instance ASTRep rep => Rename (KernelBody rep) where +instance (ASTRep rep) => Rename (KernelBody rep) where rename (KernelBody dec stms res) = do dec' <- rename dec renamingStms stms $ \stms' -> @@ -280,7 +280,7 @@ -- | Perform alias analysis on a 'KernelBody'. aliasAnalyseKernelBody :: - Alias.AliasableRep rep => + (Alias.AliasableRep rep) => AliasTable -> KernelBody rep -> KernelBody (Aliases rep) @@ -290,7 +290,7 @@ -- | The variables consumed in the kernel body. consumedInKernelBody :: - Aliased rep => + (Aliased rep) => KernelBody rep -> Names consumedInKernelBody (KernelBody dec stms res) = @@ -300,7 +300,7 @@ consumedByReturn _ = mempty checkKernelBody :: - TC.Checkable rep => + (TC.Checkable rep) => [Type] -> KernelBody (Aliases rep) -> TC.TypeM rep () @@ -374,10 +374,10 @@ (dims, blk_tiles, reg_tiles) = unzip3 dims_n_tiles expected = t `arrayOfShape` Shape (blk_tiles <> reg_tiles) -kernelBodyMetrics :: OpMetrics (Op rep) => KernelBody rep -> MetricsM () +kernelBodyMetrics :: (OpMetrics (Op rep)) => KernelBody rep -> MetricsM () kernelBodyMetrics = mapM_ stmMetrics . kernelBodyStms -instance PrettyRep rep => Pretty (KernelBody rep) where +instance (PrettyRep rep) => Pretty (KernelBody rep) where pretty (KernelBody _ stms res) = PP.stack (map pretty (stmsToList stms)) "return" @@ -434,9 +434,9 @@ -- this 'SegSpace'. scopeOfSegSpace :: SegSpace -> Scope rep scopeOfSegSpace (SegSpace phys space) = - M.fromList $ zip (phys : map fst space) $ repeat $ IndexName Int64 + M.fromList $ map (,IndexName Int64) (phys : map fst space) -checkSegSpace :: TC.Checkable rep => SegSpace -> TC.TypeM rep () +checkSegSpace :: (TC.Checkable rep) => SegSpace -> TC.TypeM rep () checkSegSpace (SegSpace _ dims) = mapM_ (TC.require [Prim int64] . snd) dims @@ -546,7 +546,7 @@ -- | Type check a 'SegOp', given a checker for its level. typeCheckSegOp :: - TC.Checkable rep => + (TC.Checkable rep) => (lvl -> TC.TypeM rep ()) -> SegOp lvl (Aliases rep) -> TC.TypeM rep () @@ -621,7 +621,7 @@ segment_dims = init $ segSpaceDims space checkScanRed :: - TC.Checkable rep => + (TC.Checkable rep) => SegSpace -> [(Lambda (Aliases rep), [SubExp], Shape)] -> [Type] -> @@ -669,7 +669,7 @@ } -- | A mapper that simply returns the 'SegOp' verbatim. -identitySegOpMapper :: Monad m => SegOpMapper lvl rep rep m +identitySegOpMapper :: (Monad m) => SegOpMapper lvl rep rep m identitySegOpMapper = SegOpMapper { mapOnSegOpSubExp = pure, @@ -680,14 +680,14 @@ } mapOnSegSpace :: - Monad f => SegOpMapper lvl frep trep f -> SegSpace -> f SegSpace + (Monad f) => SegOpMapper lvl frep trep f -> SegSpace -> f SegSpace mapOnSegSpace tv (SegSpace phys dims) = SegSpace <$> mapOnSegOpVName tv phys <*> traverse (bitraverse (mapOnSegOpVName tv) (mapOnSegOpSubExp tv)) dims mapSegBinOp :: - Monad m => + (Monad m) => SegOpMapper lvl frep trep m -> SegBinOp frep -> m (SegBinOp trep) @@ -699,7 +699,7 @@ -- | Apply a 'SegOpMapper' to the given 'SegOp'. mapSegOpM :: - Monad m => + (Monad m) => SegOpMapper lvl frep trep m -> SegOp lvl frep -> m (SegOp lvl trep) @@ -741,7 +741,7 @@ <*> mapOnSegOpLambda tv op mapOnSegOpType :: - Monad m => + (Monad m) => SegOpMapper lvl frep trep m -> Type -> m Type @@ -757,7 +757,7 @@ mapOnSegOpType _tv (Mem s) = pure $ Mem s rephraseBinOp :: - Monad f => + (Monad f) => Rephraser f from rep -> SegBinOp from -> f (SegBinOp rep) @@ -765,7 +765,7 @@ SegBinOp comm <$> rephraseLambda r lam <*> pure nes <*> pure shape rephraseKernelBody :: - Monad f => + (Monad f) => Rephraser f from rep -> KernelBody from -> f (KernelBody rep) @@ -795,7 +795,7 @@ HistOp w rf arrs nes shape <$> rephraseLambda r op -- | A helper for defining 'TraverseOpStms'. -traverseSegOpStms :: Monad m => OpStmsTraverser m (SegOp lvl rep) rep +traverseSegOpStms :: (Monad m) => OpStmsTraverser m (SegOp lvl rep) rep traverseSegOpStms f segop = mapSegOpM mapper segop where seg_scope = scopeOfSegSpace (segSpace segop) @@ -845,7 +845,7 @@ mapOnSegOpLevel = walk freeIn' } -instance OpMetrics (Op rep) => OpMetrics (SegOp lvl rep) where +instance (OpMetrics (Op rep)) => OpMetrics (SegOp lvl rep) where opMetrics (SegMap _ _ _ body) = inside "SegMap" $ kernelBodyMetrics body opMetrics (SegRed _ _ reds _ body) = @@ -870,11 +870,14 @@ ) <+> parens ("~" <> pretty phys) -instance PrettyRep rep => Pretty (SegBinOp rep) where +instance (PrettyRep rep) => Pretty (SegBinOp rep) where pretty (SegBinOp comm lam nes shape) = - PP.braces (PP.commasep $ map pretty nes) <> PP.comma - pretty shape <> PP.comma - comm' <> pretty lam + PP.braces (PP.commasep $ map pretty nes) + <> PP.comma + pretty shape + <> PP.comma + comm' + <> pretty lam where comm' = case comm of Commutative -> "commutative " @@ -882,27 +885,31 @@ instance (PrettyRep rep, PP.Pretty lvl) => PP.Pretty (SegOp lvl rep) where pretty (SegMap lvl space ts body) = - "segmap" <> pretty lvl + "segmap" + <> pretty lvl PP.align (pretty space) <+> PP.colon <+> ppTuple' (map pretty ts) <+> PP.nestedBlock "{" "}" (pretty body) pretty (SegRed lvl space reds ts body) = - "segred" <> pretty lvl + "segred" + <> pretty lvl PP.align (pretty space) PP.parens (mconcat $ intersperse (PP.comma <> PP.line) $ map pretty reds) PP.colon <+> ppTuple' (map pretty ts) <+> PP.nestedBlock "{" "}" (pretty body) pretty (SegScan lvl space scans ts body) = - "segscan" <> pretty lvl + "segscan" + <> pretty lvl PP.align (pretty space) PP.parens (mconcat $ intersperse (PP.comma <> PP.line) $ map pretty scans) PP.colon <+> ppTuple' (map pretty ts) <+> PP.nestedBlock "{" "}" (pretty body) pretty (SegHist lvl space ops ts body) = - "seghist" <> pretty lvl + "seghist" + <> pretty lvl PP.align (pretty space) PP.parens (mconcat $ intersperse (PP.comma <> PP.line) $ map ppOp ops) PP.colon @@ -910,11 +917,16 @@ <+> PP.nestedBlock "{" "}" (pretty body) where ppOp (HistOp w rf dests nes shape op) = - pretty w <> PP.comma - <+> pretty rf <> PP.comma - PP.braces (PP.commasep $ map pretty dests) <> PP.comma - PP.braces (PP.commasep $ map pretty nes) <> PP.comma - pretty shape <> PP.comma + pretty w + <> PP.comma + <+> pretty rf + <> PP.comma + PP.braces (PP.commasep $ map pretty dests) + <> PP.comma + PP.braces (PP.commasep $ map pretty nes) + <> PP.comma + pretty shape + <> PP.comma pretty op instance CanBeAliased (SegOp lvl) where @@ -928,7 +940,7 @@ pure pure -informKernelBody :: Informing rep => KernelBody rep -> KernelBody (Wise rep) +informKernelBody :: (Informing rep) => KernelBody rep -> KernelBody (Wise rep) informKernelBody (KernelBody dec stms res) = mkWiseKernelBody dec (informStms stms) res @@ -943,7 +955,7 @@ pure pure -instance ASTRep rep => ST.IndexOp (SegOp lvl rep) where +instance (ASTRep rep) => ST.IndexOp (SegOp lvl rep) where indexOp vtable k (SegMap _ space _ kbody) is = do Returns ResultMaySimplify _ se <- maybeNth k $ kernelBodyResult kbody guard $ length gtids <= length is @@ -1018,7 +1030,7 @@ <*> Engine.simplify what mkWiseKernelBody :: - Informing rep => + (Informing rep) => BodyDec rep -> Stms (Wise rep) -> [KernelResult] -> @@ -1030,7 +1042,7 @@ res_vs = map kernelResultSubExp res mkKernelBodyM :: - MonadBuilder m => + (MonadBuilder m) => Stms (Rep m) -> [KernelResult] -> m (KernelBody (Rep m)) @@ -1080,20 +1092,20 @@ [] simplifyLambda :: - Engine.SimplifiableRep rep => + (Engine.SimplifiableRep rep) => Names -> Lambda (Wise rep) -> Engine.SimpleM rep (Lambda (Wise rep), Stms (Wise rep)) simplifyLambda bound = Engine.blockMigrated . Engine.simplifyLambda bound -segSpaceSymbolTable :: ASTRep rep => SegSpace -> ST.SymbolTable rep +segSpaceSymbolTable :: (ASTRep rep) => SegSpace -> ST.SymbolTable rep segSpaceSymbolTable (SegSpace flat gtids_and_dims) = foldl' f (ST.fromScope $ M.singleton flat $ IndexName Int64) gtids_and_dims where f vtable (gtid, dim) = ST.insertLoopVar gtid Int64 dim vtable simplifySegBinOp :: - Engine.SimplifiableRep rep => + (Engine.SimplifiableRep rep) => VName -> SegBinOp (Wise rep) -> Engine.SimpleM rep (SegBinOp (Wise rep), Stms (Wise rep)) @@ -1358,13 +1370,13 @@ space = segSpace segop sliceWithGtidsFixed stm - | Let _ _ (BasicOp (Index arr slice)) <- stm, + | Let _ aux (BasicOp (Index arr slice)) <- stm, space_slice <- map (DimFix . Var . fst) $ unSegSpace space, space_slice `isPrefixOf` unSlice slice, remaining_slice <- Slice $ drop (length space_slice) (unSlice slice), all (isJust . flip ST.lookup vtable) $ namesToList $ - freeIn arr <> freeIn remaining_slice = + freeIn arr <> freeIn remaining_slice <> freeIn (stmAuxCerts aux) = Just (remaining_slice, arr) | otherwise = Nothing @@ -1376,20 +1388,15 @@ let outer_slice = map ( \d -> - DimSlice - (constant (0 :: Int64)) - d - (constant (1 :: Int64)) + DimSlice (constant (0 :: Int64)) d (constant (1 :: Int64)) ) $ segSpaceDims space index kpe' = letBindNames [patElemName kpe'] . BasicOp . Index arr $ Slice $ outer_slice <> remaining_slice - if patElemName kpe - `UT.isConsumed` used - || arr - `nameIn` consumed_in_segop + if (patElemName kpe `UT.isConsumed` used) + || (arr `nameIn` consumed_in_segop) then do precopy <- newVName $ baseString (patElemName kpe) <> "_precopy" index kpe {patElemName = precopy} diff --git a/src/Futhark/IR/SeqMem.hs b/src/Futhark/IR/SeqMem.hs --- a/src/Futhark/IR/SeqMem.hs +++ b/src/Futhark/IR/SeqMem.hs @@ -65,7 +65,7 @@ traverseOpStms _ = pure simplifyProg :: Prog SeqMem -> PassM (Prog SeqMem) -simplifyProg = simplifyProgGeneric simpleSeqMem +simplifyProg = simplifyProgGeneric memRuleBook simpleSeqMem simpleSeqMem :: Engine.SimpleOps SeqMem simpleSeqMem = 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 @@ -205,7 +205,7 @@ } deriving (Ord, Show, Eq) -instance Semigroup dec => Semigroup (StmAux dec) where +instance (Semigroup dec) => Semigroup (StmAux dec) where StmAux cs1 attrs1 dec1 <> StmAux cs2 attrs2 dec2 = StmAux (cs1 <> cs2) (attrs1 <> attrs2) (dec1 <> dec2) @@ -219,11 +219,11 @@ stmExp :: Exp rep } -deriving instance RepTypes rep => Ord (Stm rep) +deriving instance (RepTypes rep) => Ord (Stm rep) -deriving instance RepTypes rep => Show (Stm rep) +deriving instance (RepTypes rep) => Show (Stm rep) -deriving instance RepTypes rep => Eq (Stm rep) +deriving instance (RepTypes rep) => Eq (Stm rep) -- | A sequence of statements. type Stms rep = Seq.Seq (Stm rep) @@ -291,11 +291,11 @@ bodyResult :: Result } -deriving instance RepTypes rep => Ord (Body rep) +deriving instance (RepTypes rep) => Ord (Body rep) -deriving instance RepTypes rep => Show (Body rep) +deriving instance (RepTypes rep) => Show (Body rep) -deriving instance RepTypes rep => Eq (Body rep) +deriving instance (RepTypes rep) => Eq (Body rep) -- | Apart from being Opaque, what else is going on here? data OpaqueOp @@ -435,7 +435,7 @@ -- body/ is picked. Match [SubExp] [Case (Body rep)] (Body rep) (MatchDec (BranchType rep)) | -- | @loop {a} = {v} (for i < n|while b) do b@. - DoLoop [(FParam rep, SubExp)] (LoopForm rep) (Body rep) + Loop [(FParam rep, SubExp)] (LoopForm rep) (Body rep) | -- | Create accumulators backed by the given arrays (which are -- consumed) and pass them to the lambda, which must return the -- updated accumulators and possibly some extra values. The @@ -446,11 +446,11 @@ WithAcc [WithAccInput rep] (Lambda rep) | Op (Op rep) -deriving instance RepTypes rep => Eq (Exp rep) +deriving instance (RepTypes rep) => Eq (Exp rep) -deriving instance RepTypes rep => Show (Exp rep) +deriving instance (RepTypes rep) => Show (Exp rep) -deriving instance RepTypes rep => Ord (Exp rep) +deriving instance (RepTypes rep) => Ord (Exp rep) -- | For-loop or while-loop? data LoopForm rep @@ -464,11 +464,11 @@ [(LParam rep, VName)] | WhileLoop VName -deriving instance RepTypes rep => Eq (LoopForm rep) +deriving instance (RepTypes rep) => Eq (LoopForm rep) -deriving instance RepTypes rep => Show (LoopForm rep) +deriving instance (RepTypes rep) => Show (LoopForm rep) -deriving instance RepTypes rep => Ord (LoopForm rep) +deriving instance (RepTypes rep) => Ord (LoopForm rep) -- | Data associated with a branch. data MatchDec rt = MatchDec @@ -503,11 +503,11 @@ lambdaReturnType :: [Type] } -deriving instance RepTypes rep => Eq (Lambda rep) +deriving instance (RepTypes rep) => Eq (Lambda rep) -deriving instance RepTypes rep => Show (Lambda rep) +deriving instance (RepTypes rep) => Show (Lambda rep) -deriving instance RepTypes rep => Ord (Lambda rep) +deriving instance (RepTypes rep) => Ord (Lambda rep) -- | A function and loop parameter. type FParam rep = Param (FParamInfo rep) @@ -527,11 +527,11 @@ funDefBody :: Body rep } -deriving instance RepTypes rep => Eq (FunDef rep) +deriving instance (RepTypes rep) => Eq (FunDef rep) -deriving instance RepTypes rep => Show (FunDef rep) +deriving instance (RepTypes rep) => Show (FunDef rep) -deriving instance RepTypes rep => Ord (FunDef rep) +deriving instance (RepTypes rep) => Ord (FunDef rep) -- | An entry point parameter, comprising its name and original type. data EntryParam = EntryParam 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 @@ -390,12 +390,12 @@ dimSlice DimFix {} = Nothing -- | A slice with a stride of one. -unitSlice :: Num d => d -> d -> DimIndex d +unitSlice :: (Num d) => d -> d -> DimIndex d unitSlice offset n = DimSlice offset n 1 -- | Fix the 'DimSlice's of a slice. The number of indexes must equal -- the length of 'sliceDims' for the slice. -fixSlice :: Num d => Slice d -> [d] -> [d] +fixSlice :: (Num d) => Slice d -> [d] -> [d] fixSlice = fixSlice' . unSlice where fixSlice' (DimFix j : mis') is' = @@ -406,7 +406,7 @@ -- | Further slice the 'DimSlice's of a slice. The number of slices -- must equal the length of 'sliceDims' for the slice. -sliceSlice :: Num d => Slice d -> Slice d -> Slice d +sliceSlice :: (Num d) => Slice d -> Slice d -> Slice d sliceSlice (Slice jslice) (Slice islice) = Slice $ sliceSlice' jslice islice where sliceSlice' (DimFix j : js') is' = 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 @@ -66,7 +66,7 @@ } -- | A mapper that simply returns the tree verbatim. -identityMapper :: forall rep m. Monad m => Mapper rep rep m +identityMapper :: forall rep m. (Monad m) => Mapper rep rep m identityMapper = Mapper { mapOnSubExp = pure, @@ -83,7 +83,7 @@ -- expression. Importantly, the mapping does not descend recursively -- into subexpressions. The mapping is done left-to-right. mapExpM :: - Monad m => + (Monad m) => Mapper frep trep m -> Exp frep -> m (Exp trep) @@ -181,11 +181,11 @@ <$> mapOnShape tv shape <*> mapM (mapOnVName tv) vs <*> traverse (bitraverse (mapOnLambda tv) (mapM (mapOnSubExp tv))) op -mapExpM tv (DoLoop merge form loopbody) = do +mapExpM tv (Loop merge form loopbody) = do params' <- mapM (mapOnFParam tv) params form' <- mapOnLoopForm tv form let scope = scopeOf form' <> scopeOfFParams params' - DoLoop + Loop <$> (zip params' <$> mapM (mapOnSubExp tv) args) <*> pure form' <*> mapOnBody tv scope loopbody @@ -194,11 +194,11 @@ mapExpM tv (Op op) = Op <$> mapOnOp tv op -mapOnShape :: Monad m => Mapper frep trep m -> Shape -> m Shape +mapOnShape :: (Monad m) => Mapper frep trep m -> Shape -> m Shape mapOnShape tv (Shape ds) = Shape <$> mapM (mapOnSubExp tv) ds mapOnLoopForm :: - Monad m => + (Monad m) => Mapper frep trep m -> LoopForm frep -> m (LoopForm trep) @@ -214,7 +214,7 @@ WhileLoop <$> mapOnVName tv cond mapOnLambda :: - Monad m => + (Monad m) => Mapper frep trep m -> Lambda frep -> m (Lambda trep) @@ -243,7 +243,7 @@ } -- | A no-op traversal. -identityWalker :: forall rep m. Monad m => Walker rep m +identityWalker :: forall rep m. (Monad m) => Walker rep m identityWalker = Walker { walkOnSubExp = const $ pure (), @@ -256,10 +256,10 @@ walkOnOp = const $ pure () } -walkOnShape :: Monad m => Walker rep m -> Shape -> m () +walkOnShape :: (Monad m) => Walker rep m -> Shape -> m () walkOnShape tv (Shape ds) = mapM_ (walkOnSubExp tv) ds -walkOnType :: Monad m => Walker rep m -> Type -> m () +walkOnType :: (Monad m) => Walker rep m -> Type -> m () walkOnType _ Prim {} = pure () walkOnType tv (Acc acc ispace ts _) = do walkOnVName tv acc @@ -268,7 +268,7 @@ walkOnType _ Mem {} = pure () walkOnType tv (Array _ shape _) = walkOnShape tv shape -walkOnLoopForm :: Monad m => Walker rep m -> LoopForm rep -> m () +walkOnLoopForm :: (Monad m) => Walker rep m -> LoopForm rep -> m () walkOnLoopForm tv (ForLoop i _ bound loop_vars) = walkOnVName tv i >> walkOnSubExp tv bound @@ -279,14 +279,14 @@ walkOnLoopForm tv (WhileLoop cond) = walkOnVName tv cond -walkOnLambda :: Monad m => Walker rep m -> Lambda rep -> m () +walkOnLambda :: (Monad m) => Walker rep m -> Lambda rep -> m () walkOnLambda tv (Lambda params body ret) = do mapM_ (walkOnLParam tv) params walkOnBody tv (scopeOfLParams params) body mapM_ (walkOnType tv) ret -- | As 'mapExpM', but do not construct a result AST. -walkExpM :: Monad m => Walker rep m -> Exp rep -> m () +walkExpM :: (Monad m) => Walker rep m -> Exp rep -> m () walkExpM tv (BasicOp (SubExp se)) = walkOnSubExp tv se walkExpM tv (BasicOp (ArrayLit els rowt)) = @@ -347,7 +347,7 @@ mapM_ (walkOnVName tv) vs traverse_ (bitraverse (walkOnLambda tv) (mapM (walkOnSubExp tv))) op walkOnLambda tv lam -walkExpM tv (DoLoop merge form loopbody) = do +walkExpM tv (Loop merge form loopbody) = do mapM_ (walkOnFParam tv) params walkOnLoopForm tv form mapM_ (walkOnSubExp tv) args @@ -366,9 +366,9 @@ -- This is used for some simplification rules. class TraverseOpStms rep where -- | Transform every sub-'Stms' of this op. - traverseOpStms :: Monad m => OpStmsTraverser m (Op rep) rep + traverseOpStms :: (Monad m) => OpStmsTraverser m (Op rep) rep -- | A helper for defining 'traverseOpStms'. -traverseLambdaStms :: Monad m => OpStmsTraverser m (Lambda rep) rep +traverseLambdaStms :: (Monad m) => OpStmsTraverser m (Lambda rep) rep traverseLambdaStms f (Lambda ps (Body dec stms res) ret) = Lambda ps <$> (Body dec <$> f (scopeOfLParams ps) stms <*> pure res) <*> pure ret 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 @@ -79,7 +79,7 @@ | NotAnArray VName Type | PermutationError [Int] Int (Maybe VName) -instance Checkable rep => Show (ErrorCase rep) where +instance (Checkable rep) => Show (ErrorCase rep) where show (TypeError msg) = "Type error:\n" ++ T.unpack msg show (UnexpectedType e _ []) = @@ -102,7 +102,7 @@ ++ "\nBut body has type\n " ++ T.unpack (prettyTuple bodytype) show (DupDefinitionError name) = - "Duplicate definition of function " ++ nameToString name ++ "" + "Duplicate definition of function " ++ nameToString name show (DupParamError funname paramname) = "Parameter " ++ prettyString paramname @@ -181,7 +181,7 @@ -- | A type error. data TypeError rep = Error [T.Text] (ErrorCase rep) -instance Checkable rep => Show (TypeError rep) where +instance (Checkable rep) => Show (TypeError rep) where show (Error [] err) = show err show (Error msgs err) = @@ -297,7 +297,7 @@ ) instance - Checkable rep => + (Checkable rep) => HasScope (Aliases rep) (TypeM rep) where lookupType = fmap typeOf . lookupVar @@ -331,7 +331,7 @@ TypeM rep a context s = local $ \env -> env {envContext = s : envContext env} -message :: Pretty a => T.Text -> a -> T.Text +message :: (Pretty a) => T.Text -> a -> T.Text message s x = docText $ pretty s <+> align (pretty x) -- | Mark a name as bound. If the name has been bound previously in @@ -349,7 +349,7 @@ -- | Proclaim that we have made read-only use of the given variable. -- No-op unless the variable is array-typed. observe :: - Checkable rep => + (Checkable rep) => VName -> TypeM rep () observe name = do @@ -358,7 +358,7 @@ occur [observation $ oneName name <> aliases dec] -- | Proclaim that we have written to the given variables. -consume :: Checkable rep => Names -> TypeM rep () +consume :: (Checkable rep) => Names -> TypeM rep () consume als = do scope <- askScope let isArray = maybe False (not . primType . typeOf) . (`M.lookup` scope) @@ -433,7 +433,7 @@ _ -> mempty binding :: - Checkable rep => + (Checkable rep) => Scope (Aliases rep) -> TypeM rep a -> TypeM rep a @@ -468,7 +468,7 @@ Nothing -> bad $ UnknownVariableError name Just dec -> pure dec -lookupAliases :: Checkable rep => VName -> TypeM rep Names +lookupAliases :: (Checkable rep) => VName -> TypeM rep Names lookupAliases name = do info <- lookupVar name pure $ @@ -480,12 +480,12 @@ aliases (LetName (als, _)) = unAliases als aliases _ = mempty -subExpAliasesM :: Checkable rep => SubExp -> TypeM rep Names +subExpAliasesM :: (Checkable rep) => SubExp -> TypeM rep Names subExpAliasesM Constant {} = pure mempty subExpAliasesM (Var v) = lookupAliases v lookupFun :: - Checkable rep => + (Checkable rep) => Name -> [SubExp] -> TypeM rep ([(RetType rep, RetAls)], [DeclType]) @@ -514,7 +514,7 @@ -- | @require ts se@ causes a '(TypeError vn)' if the type of @se@ is -- not a subtype of one of the types in @ts@. -require :: Checkable rep => [Type] -> SubExp -> TypeM rep () +require :: (Checkable rep) => [Type] -> SubExp -> TypeM rep () require ts se = do t <- checkSubExp se unless (t `elem` ts) $ @@ -522,11 +522,11 @@ UnexpectedType (BasicOp $ SubExp se) t ts -- | Variant of 'require' working on variable names. -requireI :: Checkable rep => [Type] -> VName -> TypeM rep () +requireI :: (Checkable rep) => [Type] -> VName -> TypeM rep () requireI ts ident = require ts $ Var ident checkArrIdent :: - Checkable rep => + (Checkable rep) => VName -> TypeM rep (Shape, PrimType) checkArrIdent v = do @@ -536,7 +536,7 @@ _ -> bad $ NotAnArray v t checkAccIdent :: - Checkable rep => + (Checkable rep) => VName -> TypeM rep (Shape, [Type]) checkAccIdent v = do @@ -571,7 +571,7 @@ -- yielding either a type error or a program with complete type -- information. checkProg :: - Checkable rep => + (Checkable rep) => Prog (Aliases rep) -> Either (TypeError rep) () checkProg (Prog opaques consts funs) = do @@ -604,7 +604,7 @@ pure $ M.insert name (ret, params) ftable initialFtable :: - Checkable rep => + (Checkable rep) => TypeM rep (M.Map Name (FunBinding rep)) initialFtable = fmap M.fromList $ mapM addBuiltin $ M.toList builtInFunctions where @@ -614,7 +614,7 @@ name = VName (nameFromString "x") 0 checkFun :: - Checkable rep => + (Checkable rep) => FunDef (Aliases rep) -> TypeM rep () checkFun (FunDef _ _ fname rettype params body) = @@ -647,7 +647,7 @@ ) checkFunParams :: - Checkable rep => + (Checkable rep) => [FParam rep] -> TypeM rep () checkFunParams = mapM_ $ \param -> @@ -655,7 +655,7 @@ checkFParamDec (paramName param) (paramDec param) checkLambdaParams :: - Checkable rep => + (Checkable rep) => [LParam rep] -> TypeM rep () checkLambdaParams = mapM_ $ \param -> @@ -672,7 +672,7 @@ pure $ pname : seen checkFun' :: - Checkable rep => + (Checkable rep) => ( Name, [(DeclExtType, RetAls)], [(VName, NameInfo (Aliases rep))] @@ -728,23 +728,23 @@ isProblem i als rals (j, jals, j_rals) = i /= j && j `notElem` rals && i `notElem` j_rals && namesIntersect als jals -checkSubExp :: Checkable rep => SubExp -> TypeM rep Type +checkSubExp :: (Checkable rep) => SubExp -> TypeM rep Type checkSubExp (Constant val) = pure $ Prim $ primValueType val checkSubExp (Var ident) = context ("In subexp " <> prettyText ident) $ do observe ident lookupType ident -checkCerts :: Checkable rep => Certs -> TypeM rep () +checkCerts :: (Checkable rep) => Certs -> TypeM rep () checkCerts (Certs cs) = mapM_ (requireI [Prim Unit]) cs -checkSubExpRes :: Checkable rep => SubExpRes -> TypeM rep Type +checkSubExpRes :: (Checkable rep) => SubExpRes -> TypeM rep Type checkSubExpRes (SubExpRes cs se) = do checkCerts cs checkSubExp se checkStms :: - Checkable rep => + (Checkable rep) => Stms (Aliases rep) -> TypeM rep a -> TypeM rep a @@ -759,13 +759,13 @@ m checkResult :: - Checkable rep => + (Checkable rep) => Result -> TypeM rep () checkResult = mapM_ checkSubExpRes checkFunBody :: - Checkable rep => + (Checkable rep) => [(RetType rep, RetAls)] -> Body (Aliases rep) -> TypeM rep [Names] @@ -778,7 +778,7 @@ mapM (subExpAliasesM . resSubExp) res checkLambdaBody :: - Checkable rep => + (Checkable rep) => [Type] -> Body (Aliases rep) -> TypeM rep () @@ -787,7 +787,7 @@ checkStms stms $ checkLambdaResult ret res checkLambdaResult :: - Checkable rep => + (Checkable rep) => [Type] -> Result -> TypeM rep () @@ -813,7 +813,7 @@ <> prettyText t checkBody :: - Checkable rep => + (Checkable rep) => Body (Aliases rep) -> TypeM rep [Names] checkBody (Body (_, rep) stms res) = do @@ -824,7 +824,7 @@ where bound_here = namesFromList $ M.keys $ scopeOf stms -checkBasicOp :: Checkable rep => BasicOp -> TypeM rep () +checkBasicOp :: (Checkable rep) => BasicOp -> TypeM rep () checkBasicOp (SubExp es) = void $ checkSubExp es checkBasicOp (Opaque _ es) = @@ -953,7 +953,7 @@ consume =<< lookupAliases acc matchLoopResultExt :: - Checkable rep => + (Checkable rep) => [Param DeclType] -> Result -> TypeM rep () @@ -984,7 +984,7 @@ RetAls [0 .. n - 1] [0 .. m - 1] checkExp :: - Checkable rep => + (Checkable rep) => Exp (Aliases rep) -> TypeM rep () checkExp (BasicOp op) = checkBasicOp op @@ -1017,7 +1017,7 @@ "But annotation is:" indent 2 (pretty $ map fst rettype_annot) consumeArgs paramtypes argflows -checkExp (DoLoop merge form loopbody) = do +checkExp (Loop merge form loopbody) = do let (mergepat, mergeexps) = unzip merge mergeargs <- mapM checkArg mergeexps @@ -1102,9 +1102,8 @@ <> prettyText (paramType condparam) <> "." Nothing -> - bad $ - TypeError $ - "Conditional '" <> prettyText cond <> "' of while-loop is not a merge variable." + -- Implies infinite loop, but that's OK. + pure () let mergepat = map fst merge funparams = mergepat paramts = map paramDeclType funparams @@ -1167,7 +1166,7 @@ checker op checkSOACArrayArgs :: - Checkable rep => + (Checkable rep) => SubExp -> [VName] -> TypeM rep [Arg] @@ -1192,7 +1191,7 @@ "SOAC argument " <> prettyText v <> " is not an array" checkType :: - Checkable rep => + (Checkable rep) => TypeBase Shape u -> TypeM rep () checkType (Mem (ScalarSpace d _)) = mapM_ (require [Prim int64]) d @@ -1203,7 +1202,7 @@ checkType t = mapM_ checkSubExp $ arrayDims t checkExtType :: - Checkable rep => + (Checkable rep) => TypeBase ExtShape u -> TypeM rep () checkExtType = mapM_ checkExtDim . shapeDims . arrayShape @@ -1212,7 +1211,7 @@ checkExtDim (Ext _) = pure () checkCmpOp :: - Checkable rep => + (Checkable rep) => CmpOp -> SubExp -> SubExp -> @@ -1230,7 +1229,7 @@ checkCmpOp CmpLle x y = checkBinOpArgs Bool x y checkBinOpArgs :: - Checkable rep => + (Checkable rep) => PrimType -> SubExp -> SubExp -> @@ -1240,7 +1239,7 @@ require [Prim t] e2 checkPatElem :: - Checkable rep => + (Checkable rep) => PatElem (LetDec rep) -> TypeM rep () checkPatElem (PatElem name dec) = @@ -1248,13 +1247,13 @@ checkLetBoundDec name dec checkFlatDimIndex :: - Checkable rep => + (Checkable rep) => FlatDimIndex SubExp -> TypeM rep () checkFlatDimIndex (FlatDimIndex n s) = mapM_ (require [Prim int64]) [n, s] checkFlatSlice :: - Checkable rep => + (Checkable rep) => FlatSlice SubExp -> TypeM rep () checkFlatSlice (FlatSlice offset idxs) = do @@ -1262,14 +1261,14 @@ mapM_ checkFlatDimIndex idxs checkDimIndex :: - Checkable rep => + (Checkable rep) => DimIndex SubExp -> TypeM rep () checkDimIndex (DimFix i) = require [Prim int64] i checkDimIndex (DimSlice i n s) = mapM_ (require [Prim int64]) [i, n, s] checkStm :: - Checkable rep => + (Checkable rep) => Stm (Aliases rep) -> TypeM rep a -> TypeM rep a @@ -1283,7 +1282,7 @@ m matchExtPat :: - Checkable rep => + (Checkable rep) => Pat (LetDec (Aliases rep)) -> [ExtType] -> TypeM rep () @@ -1293,7 +1292,7 @@ InvalidPatError pat ts Nothing matchExtReturnType :: - Checkable rep => + (Checkable rep) => [ExtType] -> Result -> TypeM rep () @@ -1302,7 +1301,7 @@ matchExtReturns rettype res ts matchExtBranchType :: - Checkable rep => + (Checkable rep) => [ExtType] -> Body (Aliases rep) -> TypeM rep () @@ -1335,7 +1334,7 @@ unless (rettype' == ts) problem validApply :: - ArrayShape shape => + (ArrayShape shape) => [TypeBase shape Uniqueness] -> [TypeBase shape NoUniqueness] -> Bool @@ -1361,7 +1360,7 @@ noArgAliases (t, _) = (t, mempty) checkArg :: - Checkable rep => + (Checkable rep) => SubExp -> TypeM rep Arg checkArg arg = do @@ -1396,7 +1395,7 @@ -- The boolean indicates whether we only allow consumption of -- parameters. checkAnyLambda :: - Checkable rep => Bool -> Lambda (Aliases rep) -> [Arg] -> TypeM rep () + (Checkable rep) => Bool -> Lambda (Aliases rep) -> [Arg] -> TypeM rep () checkAnyLambda soac (Lambda params body rettype) args = do let fname = nameFromString "" if length params == length args @@ -1428,10 +1427,10 @@ <> prettyText (length args) <> " arguments." -checkLambda :: Checkable rep => Lambda (Aliases rep) -> [Arg] -> TypeM rep () +checkLambda :: (Checkable rep) => Lambda (Aliases rep) -> [Arg] -> TypeM rep () checkLambda = checkAnyLambda True -checkPrimExp :: Checkable rep => PrimExp VName -> TypeM rep () +checkPrimExp :: (Checkable rep) => PrimExp VName -> TypeM rep () checkPrimExp ValueExp {} = pure () checkPrimExp (LeafExp v pt) = requireI [Prim pt] v checkPrimExp (BinOpExp op x y) = do @@ -1461,7 +1460,7 @@ <> prettyText h_ret zipWithM_ requirePrimExp h_ts args -requirePrimExp :: Checkable rep => PrimType -> PrimExp VName -> TypeM rep () +requirePrimExp :: (Checkable rep) => PrimType -> PrimExp VName -> TypeM rep () requirePrimExp t e = context ("in PrimExp " <> prettyText e) $ do checkPrimExp e unless (primExpType e == t) . bad . TypeError $ @@ -1484,38 +1483,38 @@ -- | Used at top level; can be locally changed with 'checkOpWith'. checkOp :: Op (Aliases rep) -> TypeM rep () - default checkExpDec :: ExpDec rep ~ () => ExpDec rep -> TypeM rep () + default checkExpDec :: (ExpDec rep ~ ()) => ExpDec rep -> TypeM rep () checkExpDec = pure - default checkBodyDec :: BodyDec rep ~ () => BodyDec rep -> TypeM rep () + default checkBodyDec :: (BodyDec rep ~ ()) => BodyDec rep -> TypeM rep () checkBodyDec = pure - default checkFParamDec :: FParamInfo rep ~ DeclType => VName -> FParamInfo rep -> TypeM rep () + default checkFParamDec :: (FParamInfo rep ~ DeclType) => VName -> FParamInfo rep -> TypeM rep () checkFParamDec _ = checkType - default checkLParamDec :: LParamInfo rep ~ Type => VName -> LParamInfo rep -> TypeM rep () + default checkLParamDec :: (LParamInfo rep ~ Type) => VName -> LParamInfo rep -> TypeM rep () checkLParamDec _ = checkType - default checkLetBoundDec :: LetDec rep ~ Type => VName -> LetDec rep -> TypeM rep () + default checkLetBoundDec :: (LetDec rep ~ Type) => VName -> LetDec rep -> TypeM rep () checkLetBoundDec _ = checkType - default checkRetType :: RetType rep ~ DeclExtType => [RetType rep] -> TypeM rep () + default checkRetType :: (RetType rep ~ DeclExtType) => [RetType rep] -> TypeM rep () checkRetType = mapM_ $ checkExtType . declExtTypeOf default matchPat :: Pat (LetDec (Aliases rep)) -> Exp (Aliases rep) -> TypeM rep () matchPat pat = matchExtPat pat <=< expExtType - default primFParam :: FParamInfo rep ~ DeclType => VName -> PrimType -> TypeM rep (FParam (Aliases rep)) + default primFParam :: (FParamInfo rep ~ DeclType) => VName -> PrimType -> TypeM rep (FParam (Aliases rep)) primFParam name t = pure $ Param mempty name (Prim t) - default matchReturnType :: RetType rep ~ DeclExtType => [RetType rep] -> Result -> TypeM rep () + default matchReturnType :: (RetType rep ~ DeclExtType) => [RetType rep] -> Result -> TypeM rep () matchReturnType = matchExtReturnType . map fromDecl - default matchBranchType :: BranchType rep ~ ExtType => [BranchType rep] -> Body (Aliases rep) -> TypeM rep () + default matchBranchType :: (BranchType rep ~ ExtType) => [BranchType rep] -> Body (Aliases rep) -> TypeM rep () matchBranchType = matchExtBranchType default matchLoopResult :: - FParamInfo rep ~ DeclType => + (FParamInfo rep ~ DeclType) => [FParam (Aliases rep)] -> Result -> TypeM rep () diff --git a/src/Futhark/Internalise/Bindings.hs b/src/Futhark/Internalise/Bindings.hs --- a/src/Futhark/Internalise/Bindings.hs +++ b/src/Futhark/Internalise/Bindings.hs @@ -117,7 +117,7 @@ type Params t = [I.Param t] processFlatPat :: - Show t => + (Show t) => [(E.Ident ParamType, [E.AttrInfo VName])] -> [t] -> InternaliseM ([Params t], VarSubsts) @@ -150,7 +150,7 @@ n -> replicateM n $ newVName $ baseString name bindingFlatPat :: - Show t => + (Show t) => [(E.Ident E.ParamType, [E.AttrInfo VName])] -> [t] -> ([Params t] -> InternaliseM a) -> @@ -161,7 +161,7 @@ m ps -- | Flatten a pattern. Returns a list of identifiers. -flattenPat :: MonadFreshNames m => E.Pat (TypeBase Size u) -> m [(E.Ident (TypeBase Size u), [E.AttrInfo VName])] +flattenPat :: (MonadFreshNames m) => E.Pat (TypeBase Size u) -> m [(E.Ident (TypeBase Size u), [E.AttrInfo VName])] flattenPat = flattenPat' where flattenPat' (E.PatParens p _) = 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 @@ -117,7 +117,7 @@ mapOnParamType = pure . replaceTypeSizes substs, mapOnResRetType = pure, mapOnExp = pure . onExp substs, - mapOnName = pure . onName substs + mapOnName = pure . fmap (onName substs) } onName substs v = @@ -282,7 +282,7 @@ deriving (Eq, Ord, Show) dimMapping :: - Monoid a => + (Monoid a) => TypeBase Size a -> TypeBase Size a -> M.Map VName SizeSubst @@ -299,7 +299,7 @@ f _ d _ = pure d dimMapping' :: - Monoid a => + (Monoid a) => TypeBase Size a -> TypeBase Size a -> M.Map VName VName @@ -372,7 +372,7 @@ -- When we instantiate a polymorphic StaticVal, we rename all the -- sizes to avoid name conflicts later on. This is a bit of a hack... instStaticVal :: - MonadFreshNames m => + (MonadFreshNames m) => S.Set VName -> [VName] -> StructType -> @@ -582,7 +582,7 @@ defuncExp OpSectionRight {} = error "defuncExp: unexpected operator section." defuncExp ProjectSection {} = error "defuncExp: unexpected projection section." defuncExp IndexSection {} = error "defuncExp: unexpected projection section." -defuncExp (AppExp (DoLoop sparams pat e1 form e3 loc) res) = do +defuncExp (AppExp (Loop sparams pat e1 form e3 loc) res) = do (e1', sv1) <- defuncExp e1 let env1 = alwaysMatchPatSV pat sv1 (form', env2) <- case form of @@ -596,7 +596,7 @@ e2' <- localEnv env1 $ defuncExp' e2 pure (While e2', mempty) (e3', sv) <- localEnv (env1 <> env2) $ defuncExp e3 - pure (AppExp (DoLoop sparams pat e1' form' e3' loc) res, sv) + pure (AppExp (Loop sparams pat e1' form' e3' loc) res, sv) where envFromIdent (Ident vn (Info tp) _) = M.singleton vn $ Binding Nothing $ Dynamic $ toParam Observe tp @@ -668,14 +668,14 @@ pure (Constr name es' (Info sum_t') loc, sv) where defuncType :: - Monoid als => + (Monoid als) => TypeBase Size als -> TypeBase Size als defuncType (Array u shape t) = Array u shape (defuncScalar t) defuncType (Scalar t) = Scalar $ defuncScalar t defuncScalar :: - Monoid als => + (Monoid als) => ScalarTypeBase Size als -> ScalarTypeBase Size als defuncScalar (Record fs) = Record $ M.map defuncType fs @@ -826,7 +826,7 @@ RecordSV $ M.toList $ M.intersectionWith imposeType (M.fromList fs1) fs2 imposeType sv _ = sv -instAnySizes :: MonadFreshNames m => [Pat ParamType] -> m [Pat ParamType] +instAnySizes :: (MonadFreshNames m) => [Pat ParamType] -> m [Pat ParamType] instAnySizes = traverse $ traverse $ bitraverse onDim pure where onDim d @@ -1298,7 +1298,7 @@ -- | Transform a list of top-level value bindings. May produce new -- lifted function definitions, which are placed in front of the -- resulting list of declarations. -transformProg :: MonadFreshNames m => [ValBind] -> m [ValBind] +transformProg :: (MonadFreshNames m) => [ValBind] -> m [ValBind] transformProg decs = modifyNameSource $ \namesrc -> let ((), namesrc', decs') = runDefM namesrc $ defuncVals decs in (decs', namesrc') diff --git a/src/Futhark/Internalise/Defunctorise.hs b/src/Futhark/Internalise/Defunctorise.hs --- a/src/Futhark/Internalise/Defunctorise.hs +++ b/src/Futhark/Internalise/Defunctorise.hs @@ -239,7 +239,7 @@ transformName v = lookupSubst v . scopeSubsts <$> askScope -- | A general-purpose substitution of names. -transformNames :: ASTMappable x => x -> TransformM x +transformNames :: (ASTMappable x) => x -> TransformM x transformNames x = do scope <- askScope pure $ runIdentity $ astMap (substituter scope) x @@ -247,8 +247,7 @@ substituter scope = ASTMapper { mapOnExp = onExp scope, - mapOnName = \v -> - pure $ qualLeaf $ fst $ lookupSubstInScope (qualName v) scope, + mapOnName = \v -> pure $ fst $ lookupSubstInScope v {qualQuals = []} scope, mapOnStructType = astMap (substituter scope), mapOnParamType = astMap (substituter scope), mapOnResRetType = astMap (substituter scope) @@ -291,17 +290,15 @@ tdecl' <- traverse transformTypeExp tdecl t' <- transformResType t e' <- transformExp e - tparams' <- traverse transformNames tparams params' <- traverse transformNames params - emit $ ValDec $ ValBind entry' name' tdecl' (Info (RetType dims t')) tparams' params' e' doc attrs loc + emit $ ValDec $ ValBind entry' name' tdecl' (Info (RetType dims t')) tparams params' e' doc attrs loc transformTypeBind :: TypeBind -> TransformM () transformTypeBind (TypeBind name l tparams te (Info (RetType dims t)) doc loc) = do name' <- transformName name emit . TypeDec - =<< ( TypeBind name' l - <$> traverse transformNames tparams - <*> transformTypeExp te + =<< ( TypeBind name' l tparams + <$> transformTypeExp te <*> (Info . RetType dims <$> transformStructType t) <*> pure doc <*> pure loc @@ -373,7 +370,7 @@ maybeHideEntryPoint d = d -- | Perform defunctorisation. -transformProg :: MonadFreshNames m => Imports -> m [Dec] +transformProg :: (MonadFreshNames m) => Imports -> m [Dec] transformProg prog = modifyNameSource $ \namesrc -> let ((), namesrc', prog') = runTransformM namesrc $ transformImports prog in (DL.toList prog', namesrc') 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 @@ -30,7 +30,7 @@ -- | Convert a program in source Futhark to a program in the Futhark -- core language. -transformProg :: MonadFreshNames m => Bool -> VisibleTypes -> [E.ValBind] -> m (I.Prog SOACS) +transformProg :: (MonadFreshNames m) => Bool -> VisibleTypes -> [E.ValBind] -> m (I.Prog SOACS) transformProg always_safe types vbinds = do (opaques, consts, funs) <- runInternaliseM always_safe (internaliseValBinds types vbinds) @@ -340,7 +340,7 @@ -- application. One caveat is that we need to replace any -- existential sizes, too (with zeroes, because they don't -- matter). - let subst = zip ext $ repeat $ E.ExpSubst $ E.sizeFromInteger 0 mempty + let subst = map (,E.ExpSubst (E.sizeFromInteger 0 mempty)) ext et' = E.applySubst (`lookup` subst) et internaliseExp desc (E.Hole (Info et') loc) (FunctionName qfname, args) -> do @@ -391,7 +391,7 @@ internalisePat desc sizes pat e $ internaliseExp desc body internaliseAppExp _ _ (E.LetFun ofname _ _ _) = error $ "Unexpected LetFun " ++ prettyString ofname -internaliseAppExp desc _ (E.DoLoop sparams mergepat mergeexp form loopbody loc) = do +internaliseAppExp desc _ (E.Loop sparams mergepat mergeexp form loopbody loc) = do ses <- internaliseExp "loop_init" mergeexp ((loopbody', (form', shapepat, mergepat', mergeinit')), initstms) <- collectStms $ handleForm ses form @@ -438,7 +438,7 @@ map I.Var . dropCond <$> attributing attrs - (letValExp desc (I.DoLoop merge form' loopbody'')) + (letValExp desc (I.Loop merge form' loopbody'')) where sparams' = map (`TypeParamDim` mempty) sparams @@ -474,7 +474,7 @@ num_iterations_t <- I.subExpType num_iterations' it <- case num_iterations_t of I.Prim (IntType it) -> pure it - _ -> error "internaliseExp DoLoop: invalid type" + _ -> error "internaliseExp Loop: invalid type" ts <- mapM subExpType mergeinit bindingLoopParams sparams' mergepat ts $ 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 @@ -82,7 +82,7 @@ addBind b@FunBind {} = OrderingM $ modify $ first $ first (b :) -runOrdering :: MonadFreshNames m => OrderingM a -> m (a, [Binding]) +runOrdering :: (MonadFreshNames m) => OrderingM a -> m (a, [Binding]) runOrdering (OrderingM m) = modifyNameSource $ mod_tup . flip runReader "tmp" . runStateT m . (([], []),) where @@ -283,14 +283,14 @@ et' <- transformBody et ef' <- transformBody ef nameExp final $ AppExp (If cond' et' ef' loc) resT -getOrdering final (AppExp (DoLoop sizes pat einit form body loc) resT) = do +getOrdering final (AppExp (Loop sizes pat einit form body loc) resT) = do einit' <- getOrdering False einit form' <- case form of For ident e -> For ident <$> getOrdering True e ForIn fpat e -> ForIn fpat <$> getOrdering True e While e -> While <$> transformBody e body' <- transformBody body - nameExp final $ AppExp (DoLoop sizes pat einit' form' body' loc) resT + nameExp final $ AppExp (Loop sizes pat einit' form' body' loc) resT getOrdering final (AppExp (BinOp (op, oloc) opT (el, Info elp) (er, Info erp) loc) (Info resT)) = do expr' <- case (isOr, isAnd) of (True, _) -> do @@ -335,7 +335,7 @@ -- branches of an if/match... -- Note that this is not producing an OrderingM, produce -- a complete separtion of states. -transformBody :: MonadFreshNames m => Exp -> m Exp +transformBody :: (MonadFreshNames m) => Exp -> m Exp transformBody e = do (e', pre_eval) <- runOrdering (getOrdering True e) pure $ foldl f e' pre_eval @@ -357,11 +357,11 @@ f body (FunBind vn infos) = AppExp (LetFun vn infos body mempty) appRes -transformDec :: MonadFreshNames m => Dec -> m Dec +transformDec :: (MonadFreshNames m) => Dec -> m Dec transformDec (ValDec valbind) = do body' <- transformBody $ valBindBody valbind pure $ ValDec (valbind {valBindBody = body'}) transformDec d = pure d -transformProg :: MonadFreshNames m => [Dec] -> m [Dec] +transformProg :: (MonadFreshNames m) => [Dec] -> m [Dec] transformProg = mapM transformDec diff --git a/src/Futhark/Internalise/LiftLambdas.hs b/src/Futhark/Internalise/LiftLambdas.hs --- a/src/Futhark/Internalise/LiftLambdas.hs +++ b/src/Futhark/Internalise/LiftLambdas.hs @@ -158,11 +158,20 @@ e' <- transformExp e body' <- bindingLetPat (map sizeName sizes) pat $ transformExp body pure $ AppExp (LetPat sizes pat e' body' loc) appres -transformExp (AppExp (DoLoop sizes pat args form body loc) appres) = do +transformExp (AppExp (Match e cases loc) appres) = do + e' <- transformExp e + cases' <- mapM transformCase cases + pure $ AppExp (Match e' cases' loc) appres + where + transformCase (CasePat case_pat case_e case_loc) = + CasePat case_pat + <$> bindingLetPat [] case_pat (transformExp case_e) + <*> pure case_loc +transformExp (AppExp (Loop sizes pat args form body loc) appres) = do args' <- transformExp args form' <- astMap transformSubExps form body' <- bindingParams sizes [pat] $ bindingForm form' $ transformExp body - pure $ AppExp (DoLoop sizes pat args' form' body' loc) appres + pure $ AppExp (Loop sizes pat args' form' body' loc) appres transformExp e@(Var v _ _) = -- Note that function-typed variables can only occur in expressions, -- not in other places where VNames/QualNames can occur. @@ -179,7 +188,7 @@ {-# NOINLINE transformProg #-} -- | Perform the transformation. -transformProg :: MonadFreshNames m => [ValBind] -> m [ValBind] +transformProg :: (MonadFreshNames m) => [ValBind] -> m [ValBind] transformProg vbinds = modifyNameSource $ \namesrc -> runLiftM namesrc $ mapM_ transformValBind vbinds 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 @@ -97,7 +97,7 @@ collectStms (InternaliseM m) = InternaliseM $ collectStms m runInternaliseM :: - MonadFreshNames m => + (MonadFreshNames m) => Bool -> InternaliseM () -> m (OpaqueTypes, Stms SOACS, [FunDef SOACS]) diff --git a/src/Futhark/Internalise/Monomorphise.hs b/src/Futhark/Internalise/Monomorphise.hs --- a/src/Futhark/Internalise/Monomorphise.hs +++ b/src/Futhark/Internalise/Monomorphise.hs @@ -460,7 +460,7 @@ let dims' = dims <> map snd rl pure $ RetType dims' ty' -sizesForPat :: MonadFreshNames m => Pat ParamType -> m ([VName], Pat ParamType) +sizesForPat :: (MonadFreshNames m) => Pat ParamType -> m ([VName], Pat ParamType) sizesForPat pat = do (params', sizes) <- runStateT (traverse (bitraverse onDim pure) pat) [] pure (sizes, params') @@ -528,7 +528,7 @@ <*> transformAppRes res where onArg (Info (d, ext), e) = (d,ext,) <$> transformExp e -transformAppExp (DoLoop sparams pat e1 form body loc) res = do +transformAppExp (Loop sparams pat e1 form body loc) res = do e1' <- transformExp e1 let dimArgs = S.fromList sparams @@ -555,7 +555,7 @@ -- sizes for them. (pat_sizes, pat'') <- sizesForPat pat' res' <- transformAppRes res - pure $ AppExp (DoLoop (sparams' ++ pat_sizes) pat'' e1' form' body' loc) (Info res') + pure $ AppExp (Loop (sparams' ++ pat_sizes) pat'' e1' form' body' loc) (Info res') transformAppExp (BinOp (fname, _) (Info t) (e1, d1) (e2, d2) loc) res = do (AppRes ret ext) <- transformAppRes res fname' <- transformFName loc fname (toStruct t) @@ -866,7 +866,7 @@ type DimInst = M.Map VName Size dimMapping :: - Monoid a => + (Monoid a) => TypeBase Size a -> TypeBase Size a -> ExpReplacements -> @@ -899,7 +899,7 @@ inferSizeArgs :: [TypeParam] -> StructType -> ExpReplacements -> StructType -> MonoM [Exp] inferSizeArgs tparams bind_t bind_r t = do - r <- get + r <- gets (<>) <*> asks envParametrized let dinst = dimMapping bind_t t bind_r r mapM (tparamArg dinst) tparams where @@ -1142,7 +1142,7 @@ } typeSubstsM :: - MonadFreshNames m => + (MonadFreshNames m) => SrcLoc -> TypeBase () NoUniqueness -> MonoType -> @@ -1309,7 +1309,7 @@ -- | Monomorphise a list of top-level declarations. A module-free input program -- is expected, so only value declarations and type declaration are accepted. -transformProg :: MonadFreshNames m => [Dec] -> m [ValBind] +transformProg :: (MonadFreshNames m) => [Dec] -> m [ValBind] transformProg decs = fmap (toList . fmap snd . snd) $ modifyNameSource $ \namesrc -> diff --git a/src/Futhark/Internalise/ReplaceRecords.hs b/src/Futhark/Internalise/ReplaceRecords.hs --- a/src/Futhark/Internalise/ReplaceRecords.hs +++ b/src/Futhark/Internalise/ReplaceRecords.hs @@ -141,7 +141,7 @@ -- | Monomorphise a list of top-level declarations. A module-free input program -- is expected, so only value declarations and type declaration are accepted. -transformProg :: MonadFreshNames m => [ValBind] -> m [ValBind] +transformProg :: (MonadFreshNames m) => [ValBind] -> m [ValBind] transformProg vbs = modifyNameSource $ \namesrc -> runRecordM namesrc $ mapM onValBind vbs diff --git a/src/Futhark/Internalise/TypesValues.hs b/src/Futhark/Internalise/TypesValues.hs --- a/src/Futhark/Internalise/TypesValues.hs +++ b/src/Futhark/Internalise/TypesValues.hs @@ -97,7 +97,7 @@ <$> internaliseParamTypes [et] -- Tag every sublist with its offset in corresponding flattened list. -withOffsets :: Foldable a => [a b] -> [(a b, Int)] +withOffsets :: (Foldable a) => [a b] -> [(a b, Int)] withOffsets xs = zip xs (scanl (+) 0 $ map length xs) numberFrom :: Int -> Tree a -> Tree (a, Int) diff --git a/src/Futhark/MonadFreshNames.hs b/src/Futhark/MonadFreshNames.hs --- a/src/Futhark/MonadFreshNames.hs +++ b/src/Futhark/MonadFreshNames.hs @@ -40,15 +40,15 @@ -- getNameSource = get -- putNameSource = put -- @ -class Monad m => MonadFreshNames m where +class (Monad m) => MonadFreshNames m where getNameSource :: m VNameSource putNameSource :: VNameSource -> m () -instance Monad im => MonadFreshNames (Control.Monad.State.Lazy.StateT VNameSource im) where +instance (Monad im) => MonadFreshNames (Control.Monad.State.Lazy.StateT VNameSource im) where getNameSource = Control.Monad.State.Lazy.get putNameSource = Control.Monad.State.Lazy.put -instance Monad im => MonadFreshNames (Control.Monad.State.Strict.StateT VNameSource im) where +instance (Monad im) => MonadFreshNames (Control.Monad.State.Strict.StateT VNameSource im) where getNameSource = Control.Monad.State.Strict.get putNameSource = Control.Monad.State.Strict.put @@ -69,7 +69,7 @@ -- | Run a computation needing a fresh name source and returning a new -- one, using 'getNameSource' and 'putNameSource' before and after the -- computation. -modifyNameSource :: MonadFreshNames m => (VNameSource -> (a, VNameSource)) -> m a +modifyNameSource :: (MonadFreshNames m) => (VNameSource -> (a, VNameSource)) -> m a modifyNameSource m = do src <- getNameSource let (x, src') = m src @@ -77,24 +77,24 @@ pure x -- | Produce a fresh name, using the given name as a template. -newName :: MonadFreshNames m => VName -> m VName +newName :: (MonadFreshNames m) => VName -> m VName newName = modifyNameSource . flip FreshNames.newName -- | As @newName@, but takes a 'String' for the name template. -newNameFromString :: MonadFreshNames m => String -> m VName +newNameFromString :: (MonadFreshNames m) => String -> m VName newNameFromString s = newName $ VName (nameFromString s) 0 -- | Produce a fresh 'VName', using the given base name as a template. -newID :: MonadFreshNames m => Name -> m VName +newID :: (MonadFreshNames m) => Name -> m VName newID s = newName $ VName s 0 -- | Produce a fresh 'VName', using the given base name as a template. -newVName :: MonadFreshNames m => String -> m VName +newVName :: (MonadFreshNames m) => String -> m VName newVName = newID . nameFromString -- | Produce a fresh 'Ident', using the given name as a template. newIdent :: - MonadFreshNames m => + (MonadFreshNames m) => String -> Type -> m Ident @@ -105,7 +105,7 @@ -- | Produce a fresh 'Ident', using the given 'Ident' as a template, -- but possibly modifying the name. newIdent' :: - MonadFreshNames m => + (MonadFreshNames m) => (String -> String) -> Ident -> m Ident @@ -116,7 +116,7 @@ -- | Produce a fresh 'Param', using the given name as a template. newParam :: - MonadFreshNames m => + (MonadFreshNames m) => String -> dec -> m (Param dec) @@ -127,7 +127,7 @@ -- Utility instance defintions for MTL classes. This requires -- UndecidableInstances, but saves on typing elsewhere. -instance MonadFreshNames m => MonadFreshNames (ReaderT s m) where +instance (MonadFreshNames m) => MonadFreshNames (ReaderT s m) where getNameSource = lift getNameSource putNameSource = lift . putNameSource @@ -146,14 +146,14 @@ putNameSource = lift . putNameSource instance - MonadFreshNames m => + (MonadFreshNames m) => MonadFreshNames (Control.Monad.Trans.Maybe.MaybeT m) where getNameSource = lift getNameSource putNameSource = lift . putNameSource instance - MonadFreshNames m => + (MonadFreshNames m) => MonadFreshNames (ExceptT e m) where getNameSource = lift getNameSource 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 @@ -144,12 +144,12 @@ case_rets <- zipWithM (generalizeIxfun pat_elems) pat_elems $ matchReturns dec let dec' = dec {matchReturns = case_rets} pure $ Match cond_ses cases' defbody' dec' -replaceInExp _ (DoLoop loop_inits loop_form (Body dec stms res)) = do +replaceInExp _ (Loop loop_inits loop_form (Body dec stms res)) = do loop_inits' <- mapM (replaceInFParam . fst) loop_inits stms' <- updateStms stms coalstab <- asks envCoalesceTab let res' = map (replaceResMem coalstab) res - pure $ DoLoop (zip loop_inits' $ map snd loop_inits) loop_form $ Body dec stms' res' + pure $ Loop (zip loop_inits' $ map snd loop_inits) loop_form $ Body dec stms' res' replaceInExp _ (Op op) = case op of Inner i -> do 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 @@ -121,7 +121,7 @@ -- | Given a 'Prog' in 'GPUMem' representation, compute the coalescing table -- by folding over each function. -mkCoalsTabGPU :: MonadFreshNames m => Prog (Aliases GPUMem) -> m (M.Map Name CoalsTab) +mkCoalsTabGPU :: (MonadFreshNames m) => Prog (Aliases GPUMem) -> m (M.Map Name CoalsTab) mkCoalsTabGPU prog = mkCoalsTabProg (lastUseGPUMem prog) @@ -184,7 +184,7 @@ -- | Short-circuit handler for SegOp. shortCircuitSegOp :: - Coalesceable rep inner => + (Coalesceable rep inner) => (lvl -> Bool) -> LUTabFun -> Pat (VarAliases, LetDecMem) -> @@ -347,7 +347,7 @@ -- 4. Mark active coalescings as finished, since a 'SegOp' is an array creation -- point. shortCircuitSegOpHelper :: - Coalesceable rep inner => + (Coalesceable rep inner) => -- | The number of returns for which we should drop the last seg space Int -> -- | Whether we should look at a segop with this lvl. @@ -485,21 +485,17 @@ Just (Coalesced knd mbd@(MemBlock _ _ _ ixfn) _) -> pure $ case freeVarSubstitutions (scope td_env) (scalarTable td_env) ixfn of Just fv_subst -> - if IxFun.permutation ixfn - == IxFun.permutation (ixfun $ fromJust $ getScopeMemInfo (patElemName p) $ scope td_env) - then - let entry = - coal_entry - { vartab = - M.insert - (patElemName p) - (Coalesced knd mbd fv_subst) - (vartab coal_entry) - } - (ac, suc) = - markSuccessCoal (activeCoals bu_env_f, successCoals bu_env_f) m_b entry - in bu_env_f {activeCoals = ac, successCoals = suc} - else fail_res + let entry = + coal_entry + { vartab = + M.insert + (patElemName p) + (Coalesced knd mbd fv_subst) + (vartab coal_entry) + } + (ac, suc) = + markSuccessCoal (activeCoals bu_env_f, successCoals bu_env_f) m_b entry + in bu_env_f {activeCoals = ac, successCoals = suc} Nothing -> fail_res else pure fail_res @@ -600,7 +596,7 @@ Slice $ slc ++ map (\d -> DimSlice 0 d 1) (drop (length slc) shp) fixPointCoalesce :: - Coalesceable rep inner => + (Coalesceable rep inner) => LUTabFun -> [Param FParamMem] -> Body (Aliases rep) -> @@ -616,7 +612,9 @@ handleFunctionParams (a, i, s) (_, u, MemBlock _ _ m ixf) = case (u, M.lookup m a) of (Unique, Just entry) - | dstind entry == ixf -> + | dstind entry == ixf, + Set dst_uses <- dstrefs (memrefs entry), + dst_uses == mempty -> let (a', s') = markSuccessCoal (a, s) m entry in (a', i, s') _ -> @@ -663,7 +661,7 @@ -- | Perform short-circuiting on 'Stms'. mkCoalsTabStms :: - Coalesceable rep inner => + (Coalesceable rep inner) => LUTabFun -> Stms (Aliases rep) -> TopdownEnv rep -> @@ -706,7 +704,7 @@ -- then the checks should be extended to the actual -- array-creation points. mkCoalsTabStm :: - Coalesceable rep inner => + (Coalesceable rep inner) => LUTabFun -> Stm (Aliases rep) -> TopdownEnv rep -> @@ -841,7 +839,7 @@ -- hence remove the coalescing of the result. (markFailedCoal (act, inhb) (patMem mbr), succc) -mkCoalsTabStm lutab (Let pat _ (DoLoop arginis lform body)) td_env bu_env = do +mkCoalsTabStm lutab (Let pat _ (Loop arginis lform body)) td_env bu_env = do let pat_val_elms = patElems pat -- i) Filter @activeCoals@ by the 2nd, 3rd AND 5th safety conditions. In @@ -1004,6 +1002,9 @@ | b <- patElemName patel, (_, MemArray _ _ _ (ArrayIn m_b _)) <- patElemDec patel, a <- paramName arg, + -- Not safe to short-circuit if the index function of this + -- parameter is variant to the loop. + not $ any ((`nameIn` freeIn (paramDec arg)) . paramName . fst) arginis, Var a0 <- ini, Var r <- bdyres, Just coal_etry <- M.lookup m_b actv0, @@ -1179,9 +1180,9 @@ mkCoalsTabStm lutab stm@(Let pat aux (Op op)) td_env bu_env = do -- Process body on_op <- asks onOp - activeCoals' <- mkCoalsHelper3PatternMatch stm lutab td_env bu_env - let bu_env' = bu_env {activeCoals = activeCoals'} - on_op lutab pat (stmAuxCerts aux) op td_env bu_env' + bu_env' <- on_op lutab pat (stmAuxCerts aux) op td_env bu_env + activeCoals' <- mkCoalsHelper3PatternMatch stm lutab td_env bu_env' + pure $ bu_env' {activeCoals = activeCoals'} mkCoalsTabStm lutab stm@(Let pat _ e) td_env bu_env = do -- i) Filter @activeCoals@ by the 3rd safety condition: -- this is now relaxed by use of LMAD eqs: @@ -1267,7 +1268,7 @@ -- any variables used in the index function of the target array are available at -- the definition site of b. filterSafetyCond2and5 :: - HasMemBlock (Aliases rep) => + (HasMemBlock (Aliases rep)) => CoalsTab -> InhibitTab -> ScalarTab -> @@ -1323,7 +1324,7 @@ -- | Pattern matches a potentially coalesced statement and -- records a new association in @activeCoals@ mkCoalsHelper3PatternMatch :: - Coalesceable rep inner => + (Coalesceable rep inner) => Stm (Aliases rep) -> LUTabFun -> TopdownEnv rep -> @@ -1435,7 +1436,7 @@ -- | For 'SegOp', we currently only handle 'SegMap', and only under the following -- circumstances: -- --- 1. The 'SegMap' has only one return/pattern value. +-- 1. The 'SegMap' has only one return/pattern value, which is a 'Returns'. -- -- 2. The 'KernelBody' contains an 'Index' statement that is indexing an array using -- only the values from the 'SegSpace'. @@ -1456,19 +1457,19 @@ -- The result of the 'SegMap' is treated as the destination, while the candidate -- array from inside the body is treated as the source. genSSPointInfoSegOp :: - Coalesceable rep inner => GenSSPoint rep (SegOp lvl (Aliases rep)) + (Coalesceable rep inner) => GenSSPoint rep (SegOp lvl (Aliases rep)) genSSPointInfoSegOp lutab td_env scopetab (Pat [PatElem dst (_, MemArray dst_pt _ _ (ArrayIn dst_mem dst_ixf))]) certs - (SegMap _ space _ kernel_body) - | (src, MemBlock _ shp src_mem src_ixf) : _ <- + (SegMap _ space _ kernel_body@KernelBody {kernelBodyResult = [Returns {}]}) + | (src, MemBlock src_pt shp src_mem src_ixf) : _ <- mapMaybe getPotentialMapShortCircuit $ stmsToList $ kernelBodyStms kernel_body = - Just [(MapCoal, id, dst, dst_mem, dst_ixf, src, src_mem, src_ixf, dst_pt, shp, certs)] + Just [(MapCoal, id, dst, dst_mem, dst_ixf, src, src_mem, src_ixf, src_pt, shp, certs)] where iterators = map fst $ unSegSpace space frees = freeIn kernel_body @@ -1517,7 +1518,7 @@ f _ _ _ _ _ _ = Nothing genCoalStmtInfo :: - Coalesceable rep inner => + (Coalesceable rep inner) => LUTabFun -> TopdownEnv rep -> ScopeTab rep -> @@ -1557,10 +1558,7 @@ where updateIndFunSlice :: IxFun -> FlatSlice SubExp -> IxFun updateIndFunSlice ind_fun (FlatSlice offset dims) = - fromMaybe (error "updateIndFunSlice") $ - IxFun.flatSlice ind_fun $ - FlatSlice (pe64 offset) $ - map (fmap pe64) dims + IxFun.flatSlice ind_fun $ FlatSlice (pe64 offset) $ map (fmap pe64) dims -- CASE b) @let x = concat(a, b^{lu})@ genCoalStmtInfo lutab _ scopetab (Let pat aux (BasicOp (Concat concat_dim (b0 :| bs) _))) @@ -1694,14 +1692,14 @@ mki64subst _ = Nothing computeScalarTable :: - Coalesceable rep inner => + (Coalesceable rep inner) => ScopeTab rep -> Stm (Aliases rep) -> ScalarTableM rep (M.Map VName (PrimExp VName)) computeScalarTable scope_table (Let (Pat [pe]) _ e) | Just primexp <- primExpFromExp (vnameToPrimExp scope_table mempty) e = pure $ M.singleton (patElemName pe) primexp -computeScalarTable scope_table (Let _ _ (DoLoop loop_inits loop_form body)) = +computeScalarTable scope_table (Let _ _ (Loop loop_inits loop_form body)) = concatMapM ( computeScalarTable $ scope_table @@ -1734,7 +1732,7 @@ computeScalarTableMemOp onInner scope_table (Inner op) = onInner scope_table op computeScalarTableSegOp :: - Coalesceable rep inner => + (Coalesceable rep inner) => ComputeScalarTable rep (GPU.SegOp lvl (Aliases rep)) computeScalarTableSegOp scope_table segop = do concatMapM diff --git a/src/Futhark/Optimise/ArrayShortCircuiting/MemRefAggreg.hs b/src/Futhark/Optimise/ArrayShortCircuiting/MemRefAggreg.hs --- a/src/Futhark/Optimise/ArrayShortCircuiting/MemRefAggreg.hs +++ b/src/Futhark/Optimise/ArrayShortCircuiting/MemRefAggreg.hs @@ -40,7 +40,7 @@ -- table) until all vars appearing in the index function are defined in the -- current scope?" freeVarSubstitutions :: - FreeIn a => + (FreeIn a) => ScopeTab rep -> ScalarTab -> a -> @@ -135,7 +135,8 @@ Var x -> Just (ws, ws ++ mapMaybe (getDirAliasedIxfn td_env coal_tab) [x]) getUseSumFromStm td_env coal_tab (Let (Pat [x]) _ (BasicOp (FlatUpdate _ (FlatSlice offset slc) v))) | Just (m_b, m_x, x_ixfn) <- getDirAliasedIxfn td_env coal_tab (patElemName x) = do - x_ixfn_slc <- IxFun.flatSlice x_ixfn $ FlatSlice (pe64 offset) $ map (fmap pe64) slc + let x_ixfn_slc = + IxFun.flatSlice x_ixfn $ FlatSlice (pe64 offset) $ map (fmap pe64) slc let r1 = (m_b, m_x, x_ixfn_slc) case getDirAliasedIxfn td_env coal_tab v of Nothing -> Just ([r1], [r1]) @@ -298,7 +299,7 @@ -- \bigcup_{j=0}^{j + (MonadFreshNames m) => ScopeTab rep -> ScopeTab rep -> ScalarTab -> @@ -335,7 +336,7 @@ -- \bigcup_{j=i+1}^{j + (MonadFreshNames m) => ScalarTab -> Maybe (VName, (TPrimExp Int64 VName, TPrimExp Int64 VName)) -> AccessSummary -> @@ -372,7 +373,7 @@ -- total aggregation of the inner dimensions. For outer dimensions, the equation -- is the same, the point accesses in $Access_j$ are replaced with the total -- aggregation of the inner dimensions. -aggSummaryMapPartial :: MonadFreshNames m => ScalarTab -> [(VName, SubExp)] -> LmadRef -> m AccessSummary +aggSummaryMapPartial :: (MonadFreshNames m) => ScalarTab -> [(VName, SubExp)] -> LmadRef -> m AccessSummary aggSummaryMapPartial _ [] = const $ pure mempty aggSummaryMapPartial scalars dims = helper mempty (reverse dims) . Set . S.singleton -- Reverse dims so we work from the inside out @@ -396,7 +397,7 @@ -- \[ -- \bigcup_{j=0}^{j ScalarTab -> (VName, SubExp) -> AccessSummary -> m AccessSummary +aggSummaryMapPartialOne :: (MonadFreshNames m) => ScalarTab -> (VName, SubExp) -> AccessSummary -> m AccessSummary aggSummaryMapPartialOne _ _ Undeterminable = pure Undeterminable aggSummaryMapPartialOne _ (_, Constant n) (Set _) | oneIsh n = pure mempty aggSummaryMapPartialOne scalars (gtid, size) (Set lmads0) = @@ -412,7 +413,7 @@ helper (x, y) = concatMapM (aggSummaryOne gtid x y) lmads -- | Computes to total access summary over a multi-dimensional map. -aggSummaryMapTotal :: MonadFreshNames m => ScalarTab -> [(VName, SubExp)] -> AccessSummary -> m AccessSummary +aggSummaryMapTotal :: (MonadFreshNames m) => ScalarTab -> [(VName, SubExp)] -> AccessSummary -> m AccessSummary aggSummaryMapTotal _ [] _ = pure mempty aggSummaryMapTotal _ _ (Set lmads) | lmads == mempty = pure mempty @@ -446,7 +447,7 @@ -- -- The function returns 'Underterminable' if the iterator is free in the output -- LMAD or the dimensions of the input LMAD . -aggSummaryOne :: MonadFreshNames m => VName -> TPrimExp Int64 VName -> TPrimExp Int64 VName -> LmadRef -> m AccessSummary +aggSummaryOne :: (MonadFreshNames m) => VName -> TPrimExp Int64 VName -> TPrimExp Int64 VName -> LmadRef -> m AccessSummary aggSummaryOne iterator_var lower_bound spn lmad@(IxFun.LMAD offset0 dims0) | iterator_var `nameIn` freeIn dims0 = pure Undeterminable | iterator_var `notNameIn` freeIn offset0 = pure $ Set $ S.singleton lmad @@ -457,13 +458,11 @@ new_stride = TPrimExp $ constFoldPrimExp $ simplify $ untyped $ offsetp1 - offset new_offset = replaceIteratorWith lower_bound offset0 new_lmad = - IxFun.LMAD new_offset $ - IxFun.LMADDim new_stride spn 0 : map incPerm dims0 + IxFun.LMAD new_offset $ IxFun.LMADDim new_stride spn : dims0 if new_var `nameIn` freeIn new_lmad then pure Undeterminable else pure $ Set $ S.singleton new_lmad where - incPerm dim = dim {IxFun.ldPerm = IxFun.ldPerm dim + 1} replaceIteratorWith se = TPrimExp . substituteInPrimExp (M.singleton iterator_var $ untyped se) . untyped -- | Takes a 'VName' and converts it into a 'TPrimExp' with type 'Int64'. 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 @@ -83,7 +83,7 @@ getDirAliasFromExp (BasicOp (FlatIndex x (FlatSlice offset idxs))) = Just ( x, - (`IxFun.flatSlice` FlatSlice (pe64 offset) (map (fmap pe64) idxs)) + Just . (`IxFun.flatSlice` FlatSlice (pe64 offset) (map (fmap pe64) idxs)) ) getDirAliasFromExp (BasicOp (FlatUpdate x _ _)) = Just (x, Just) getDirAliasFromExp _ = Nothing @@ -110,8 +110,7 @@ getInvAliasFromExp (BasicOp (Opaque _ (Var _))) = Just id getInvAliasFromExp (BasicOp Update {}) = Just id getInvAliasFromExp (BasicOp (Rearrange perm _)) = - let perm' = IxFun.permuteInv perm [0 .. length perm - 1] - in Just (`IxFun.permute` perm') + Just (`IxFun.permute` rearrangeInverse perm) getInvAliasFromExp _ = Nothing class TopDownHelper inner where @@ -142,7 +141,7 @@ scopeHelper (SegOp op) = scopeHelper op scopeHelper _ = mempty -instance TopDownHelper (inner (Aliases MCMem)) => TopDownHelper (MC.MCOp inner (Aliases MCMem)) where +instance (TopDownHelper (inner (Aliases MCMem))) => TopDownHelper (MC.MCOp inner (Aliases MCMem)) where innerNonNegatives vs (ParOp par_op op) = maybe mempty (innerNonNegatives vs) par_op <> innerNonNegatives vs op @@ -198,7 +197,7 @@ nonNegatives = nonNegatives env <> nonNegativesInPat (stmPat stm) } -nonNegativesInPat :: Typed rep => Pat rep -> Names +nonNegativesInPat :: (Typed rep) => Pat rep -> Names nonNegativesInPat (Pat elems) = foldMap (namesFromList . mapMaybe subExpVar . arrayDims . typeOf) elems @@ -226,7 +225,7 @@ -- | Get direct aliased index function. Returns a triple of current memory -- block to be coalesced, the destination memory block and the index function of -- the access in the space of the destination block. -getDirAliasedIxfn :: HasMemBlock (Aliases rep) => TopdownEnv rep -> CoalsTab -> VName -> Maybe (VName, VName, IxFun) +getDirAliasedIxfn :: (HasMemBlock (Aliases rep)) => TopdownEnv rep -> CoalsTab -> VName -> Maybe (VName, VName, IxFun) getDirAliasedIxfn td_env coals_tab x = case getScopeMemInfo x (scope td_env) of Just (MemBlock _ _ m_x orig_ixfun) -> @@ -242,7 +241,7 @@ -- | Like 'getDirAliasedIxfn', but this version returns 'Nothing' if the value -- is not currently subject to coalescing. -getDirAliasedIxfn' :: HasMemBlock (Aliases rep) => TopdownEnv rep -> CoalsTab -> VName -> Maybe (VName, VName, IxFun) +getDirAliasedIxfn' :: (HasMemBlock (Aliases rep)) => TopdownEnv rep -> CoalsTab -> VName -> Maybe (VName, VName, IxFun) getDirAliasedIxfn' td_env coals_tab x = case getScopeMemInfo x (scope td_env) of Just (MemBlock _ _ m_x _) -> @@ -284,7 +283,7 @@ -- @vartab@, of course if their aliasing operations are invertible. -- We assume inverting aliases has been performed by the top-down pass. addInvAliasesVarTab :: - HasMemBlock (Aliases rep) => + (HasMemBlock (Aliases rep)) => TopdownEnv rep -> M.Map VName Coalesced -> VName -> 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 @@ -47,7 +47,7 @@ se8 :: SubExp se8 = intConst Int64 8 -scratch :: MonadBuilder m => String -> PrimType -> [SubExp] -> m VName +scratch :: (MonadBuilder m) => String -> PrimType -> [SubExp] -> m VName scratch se_name t shape = letExp se_name $ BasicOp $ Scratch t shape -- | Main helper function for Register-and-Block Tiling @@ -149,10 +149,8 @@ error "kkLoopBody.isInnerCoal: not an error, but I would like to know why!" innerHasStride1 lmad = let lmad_dims = LMAD.dims lmad - q = length lmad_dims - last_perm = IxFun.ldPerm $ last lmad_dims stride = IxFun.ldStride $ last lmad_dims - in (last_perm == q - 1) && (stride == pe64 (intConst Int64 1)) + in stride == pe64 (intConst Int64 1) -- mkRedomapOneTileBody acc_merge asss bsss fits_ij = do -- the actual redomap. @@ -713,7 +711,7 @@ matchesBlkRegTile _ _ = Nothing -- ceiled division expression -ceilDiv :: MonadBuilder m => SubExp -> SubExp -> m (Exp (Rep m)) +ceilDiv :: (MonadBuilder m) => SubExp -> SubExp -> m (Exp (Rep m)) ceilDiv x y = pure $ BasicOp $ BinOp (SDivUp Int64 Unsafe) x y mkTileMemSizes :: 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 @@ -188,7 +188,7 @@ nestedCSE stm' = do let ds = case stmExp stm' of - DoLoop merge _ _ -> map (diet . declTypeOf . fst) merge + Loop merge _ _ -> map (diet . declTypeOf . fst) merge _ -> map patElemDiet $ patElems $ stmPat stm' e <- mapExpM (cse ds) $ stmExp stm' pure stm' {stmExp = e} @@ -211,7 +211,7 @@ normExp e = e cseInStm :: - ASTRep rep => + (ASTRep rep) => Names -> Stm rep -> ([Stm rep] -> CSEM rep a) -> @@ -271,7 +271,7 @@ CSEState (esubsts, mkSubsts pat subpat `M.union` nsubsts) cse_arrays addExpSubst :: - ASTRep rep => + (ASTRep rep) => Pat (LetDec rep) -> ExpDec rep -> Certs -> @@ -336,7 +336,7 @@ Body _ stms' _ <- cseInBody (map (const Observe) res) $ Body bodydec stms [] pure $ GPU.KernelBody bodydec stms' res -instance CSEInOp (op rep) => CSEInOp (Memory.MemOp op rep) where +instance (CSEInOp (op rep)) => CSEInOp (Memory.MemOp op rep) where cseInOp o@Memory.Alloc {} = pure o cseInOp (Memory.Inner k) = Memory.Inner <$> subCSE (cseInOp k) diff --git a/src/Futhark/Optimise/DoubleBuffer.hs b/src/Futhark/Optimise/DoubleBuffer.hs --- a/src/Futhark/Optimise/DoubleBuffer.hs +++ b/src/Futhark/Optimise/DoubleBuffer.hs @@ -98,7 +98,7 @@ doubleBufferMC = doubleBuffer optimiseMCOp -- | The double buffering pass definition. -doubleBuffer :: Mem rep inner => OptimiseOp rep -> Pass rep rep +doubleBuffer :: (Mem rep inner) => OptimiseOp rep -> Pass rep rep doubleBuffer onOp = Pass { passName = "Double buffer", @@ -140,32 +140,32 @@ } deriving (Functor, Applicative, Monad, MonadReader (Env rep), MonadFreshNames) -instance ASTRep rep => HasScope rep (DoubleBufferM rep) where +instance (ASTRep rep) => HasScope rep (DoubleBufferM rep) where askScope = asks envScope -instance ASTRep rep => LocalScope rep (DoubleBufferM rep) where +instance (ASTRep rep) => LocalScope rep (DoubleBufferM rep) where localScope scope = local $ \env -> env {envScope = envScope env <> scope} -optimiseBody :: ASTRep rep => Body rep -> DoubleBufferM rep (Body rep) +optimiseBody :: (ASTRep rep) => Body rep -> DoubleBufferM rep (Body rep) optimiseBody body = do stms' <- optimiseStms $ stmsToList $ bodyStms body pure $ body {bodyStms = stms'} -optimiseStms :: ASTRep rep => [Stm rep] -> DoubleBufferM rep (Stms rep) +optimiseStms :: (ASTRep rep) => [Stm rep] -> DoubleBufferM rep (Stms rep) optimiseStms [] = pure mempty optimiseStms (e : es) = do e_es <- optimiseStm e es' <- localScope (castScope $ scopeOf e_es) $ optimiseStms es pure $ e_es <> es' -optimiseStm :: forall rep. ASTRep rep => Stm rep -> DoubleBufferM rep (Stms rep) -optimiseStm (Let pat aux (DoLoop merge form body)) = do +optimiseStm :: forall rep. (ASTRep rep) => Stm rep -> DoubleBufferM rep (Stms rep) +optimiseStm (Let pat aux (Loop merge form body)) = do body' <- localScope (scopeOf form <> scopeOfFParams (map fst merge)) $ optimiseBody body opt_loop <- asks envOptimiseLoop (stms, pat', merge', body'') <- opt_loop pat merge body' - pure $ stms <> oneStm (Let pat' aux $ DoLoop merge' form body'') + pure $ stms <> oneStm (Let pat' aux $ Loop merge' form body'') optimiseStm (Let pat aux e) = do onOp <- asks envOptimiseOp oneStm . Let pat aux <$> mapExpM (optimise onOp) e @@ -204,7 +204,7 @@ optimiseMCOp op = pure op optimiseKernelBody :: - ASTRep rep => + (ASTRep rep) => KernelBody rep -> DoubleBufferM rep (KernelBody rep) optimiseKernelBody kbody = do @@ -212,7 +212,7 @@ pure $ kbody {kernelBodyStms = stms'} optimiseLambda :: - ASTRep rep => + (ASTRep rep) => Lambda rep -> DoubleBufferM rep (Lambda rep) optimiseLambda lam = do @@ -227,7 +227,7 @@ LetDec rep ~ LetDecMem ) -extractAllocOf :: Constraints rep inner => Names -> VName -> Stms rep -> Maybe (Stm rep, Stms rep) +extractAllocOf :: (Constraints rep inner) => Names -> VName -> Stms rep -> Maybe (Stm rep, Stms rep) extractAllocOf bound needle stms = do (stm, stms') <- stmsHead stms case stm of @@ -242,7 +242,7 @@ invariant Constant {} = True invariant (Var v) = v `notNameIn` bound -optimiseLoop :: Constraints rep inner => OptimiseLoop rep +optimiseLoop :: (Constraints rep inner) => OptimiseLoop rep optimiseLoop pat merge body = do (outer_stms_1, pat', merge', body') <- optimiseLoopBySwitching pat merge body @@ -254,7 +254,7 @@ isArrayIn x (Param _ _ (MemArray _ _ _ (ArrayIn y _))) = x == y isArrayIn _ _ = False -optimiseLoopBySwitching :: Constraints rep inner => OptimiseLoop rep +optimiseLoopBySwitching :: (Constraints rep inner) => OptimiseLoop rep optimiseLoopBySwitching (Pat pes) merge (Body _ body_stms body_res) = do ((pat', merge', body'), outer_stms) <- runBuilder $ do ((buffered, body_stms'), (pes', merge', body_res')) <- @@ -321,7 +321,7 @@ mkUnique (MemArray bt shape _ ret) = MemArray bt shape Unique ret mkUnique x = x -optimiseLoopByCopying :: Constraints rep inner => OptimiseLoop rep +optimiseLoopByCopying :: (Constraints rep inner) => OptimiseLoop rep optimiseLoopByCopying pat merge body = do -- We start out by figuring out which of the merge variables should -- be double-buffered. @@ -347,7 +347,7 @@ deriving (Show) doubleBufferMergeParams :: - MonadFreshNames m => + (MonadFreshNames m) => [(Param FParamMem, SubExpRes)] -> Names -> m [DoubleBuffer] @@ -359,7 +359,7 @@ v `nameIn` bound_in_loop || v - `elem` map (paramName . fst) ctx_and_res + `elem` map (paramName . fst) ctx_and_res loopInvariantSize (Constant v) = Just (Constant v, True) @@ -410,7 +410,7 @@ _ -> pure NoBuffer allocStms :: - Constraints rep inner => + (Constraints rep inner) => [(FParam rep, SubExp)] -> [DoubleBuffer] -> DoubleBufferM rep ([(FParam rep, SubExp)], [Stm rep]) @@ -447,7 +447,7 @@ pure (f, se) doubleBufferResult :: - Constraints rep inner => + (Constraints rep inner) => [FParam rep] -> [DoubleBuffer] -> Body rep -> diff --git a/src/Futhark/Optimise/EntryPointMem.hs b/src/Futhark/Optimise/EntryPointMem.hs --- a/src/Futhark/Optimise/EntryPointMem.hs +++ b/src/Futhark/Optimise/EntryPointMem.hs @@ -28,15 +28,15 @@ mkTable :: Stms rep -> Table rep mkTable = foldMap f where - f stm = M.fromList $ zip (patNames (stmPat stm)) $ repeat stm + f stm = M.fromList $ map (,stm) (patNames (stmPat stm)) -varInfo :: Mem rep inner => VName -> Table rep -> Maybe (LetDecMem, Exp rep) +varInfo :: (Mem rep inner) => VName -> Table rep -> Maybe (LetDecMem, Exp rep) varInfo v table = do Let pat _ e <- M.lookup v table PatElem _ info <- find ((== v) . patElemName) (patElems pat) Just (letDecMem info, e) -optimiseFun :: Mem rep inner => Table rep -> FunDef rep -> FunDef rep +optimiseFun :: (Mem rep inner) => Table rep -> FunDef rep -> FunDef rep optimiseFun consts_table fd = fd {funDefBody = onBody $ funDefBody fd} where @@ -53,7 +53,7 @@ let substs = mconcat $ map (mkSubst . resSubExp) res in Body dec stms $ substituteNames substs res -entryPointMem :: Mem rep inner => Pass rep rep +entryPointMem :: (Mem rep inner) => Pass rep rep entryPointMem = Pass { passName = "Entry point memory optimisation", 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 @@ -56,7 +56,7 @@ putNameSource source = modify (\env -> env {vNameSource = source}) -runFusionM :: MonadFreshNames m => Scope SOACS -> FusionEnv -> FusionM a -> m a +runFusionM :: (MonadFreshNames m) => Scope SOACS -> FusionEnv -> FusionM a -> m a runFusionM scope fenv (FusionM a) = modifyNameSource $ \src -> let x = runReaderT a scope (y, z) = runState x (fenv {vNameSource = src}) @@ -401,10 +401,10 @@ runInnerFusionOnContext :: DepContext -> FusionM DepContext runInnerFusionOnContext c@(incoming, node, nodeT, outgoing) = case nodeT of - DoNode (Let pat aux (DoLoop params form body)) to_fuse -> + DoNode (Let pat aux (Loop params form body)) to_fuse -> doFuseScans . localScope (scopeOfFParams (map fst params) <> scopeOf form) $ do b <- doFusionWithDelayed body to_fuse - pure (incoming, node, DoNode (Let pat aux (DoLoop params form b)) [], outgoing) + pure (incoming, node, DoNode (Let pat aux (Loop params form b)) [], outgoing) MatchNode (Let pat aux (Match cond cases defbody dec)) to_fuse -> doFuseScans $ do cases' <- mapM (traverse $ renameBody <=< (`doFusionWithDelayed` to_fuse)) cases defbody' <- doFusionWithDelayed defbody to_fuse diff --git a/src/Futhark/Optimise/Fusion/Composing.hs b/src/Futhark/Optimise/Fusion/Composing.hs --- a/src/Futhark/Optimise/Fusion/Composing.hs +++ b/src/Futhark/Optimise/Fusion/Composing.hs @@ -43,7 +43,7 @@ -- The result is the fused function, and a list of the array inputs -- expected by the SOAC containing the fused function. fuseMaps :: - Buildable rep => + (Buildable rep) => -- | The producer var names that still need to be returned Names -> -- | Function of SOAC to be fused. @@ -91,7 +91,7 @@ -- (unfus_accpat, unfus_arrpat) = splitAt (length unfus_accs) unfus_pat fuseInputs :: - Buildable rep => + (Buildable rep) => Names -> Lambda rep -> [SOAC.Input] -> @@ -168,7 +168,7 @@ _ -> (m, ra) removeDuplicateInputs :: - Buildable rep => + (Buildable rep) => M.Map Ident SOAC.Input -> (M.Map Ident SOAC.Input, Body rep -> Body rep) removeDuplicateInputs = fst . M.foldlWithKey' comb ((M.empty, id), M.empty) @@ -187,7 +187,7 @@ mkLet [to] (BasicOp $ SubExp $ Var from) `insertStm` b fuseRedomap :: - Buildable rep => + (Buildable rep) => Names -> [VName] -> Lambda rep -> diff --git a/src/Futhark/Optimise/Fusion/GraphRep.hs b/src/Futhark/Optimise/Fusion/GraphRep.hs --- a/src/Futhark/Optimise/Fusion/GraphRep.hs +++ b/src/Futhark/Optimise/Fusion/GraphRep.hs @@ -162,7 +162,7 @@ -- it. type ProducerMapping = M.Map VName G.Node -makeMapping :: Monad m => DepGraphAug m +makeMapping :: (Monad m) => DepGraphAug m makeMapping dg@(DepGraph {dgGraph = g}) = pure dg {dgProducerMapping = M.fromList $ concatMap gen_dep_list (G.labNodes g)} where @@ -170,11 +170,11 @@ gen_dep_list (i, node) = [(name, i) | name <- getOutputs node] -- | Apply several graph augmentations in sequence. -applyAugs :: Monad m => [DepGraphAug m] -> DepGraphAug m +applyAugs :: (Monad m) => [DepGraphAug m] -> DepGraphAug m applyAugs augs g = foldlM (flip ($)) g augs -- | Creates deps for the given nodes on the graph using the 'EdgeGenerator'. -genEdges :: Monad m => [DepNode] -> EdgeGenerator -> DepGraphAug m +genEdges :: (Monad m) => [DepNode] -> EdgeGenerator -> DepGraphAug m genEdges l_stms edge_fun dg = depGraphInsertEdges (concatMap (genEdge (dgProducerMapping dg)) l_stms) dg where @@ -185,11 +185,11 @@ Just to <- [M.lookup dep name_map] pure $ G.toLEdge (from, to) edgeT -depGraphInsertEdges :: Monad m => [DepEdge] -> DepGraphAug m +depGraphInsertEdges :: (Monad m) => [DepEdge] -> DepGraphAug m depGraphInsertEdges edgs dg = pure $ dg {dgGraph = G.insEdges edgs $ dgGraph dg} -- | Monadically modify every node of the graph. -mapAcross :: Monad m => (DepContext -> m DepContext) -> DepGraphAug m +mapAcross :: (Monad m) => (DepContext -> m DepContext) -> DepGraphAug m mapAcross f dg = do g' <- foldlM (flip helper) (dgGraph dg) (G.nodes (dgGraph dg)) pure $ dg {dgGraph = g'} @@ -221,10 +221,10 @@ reachable dg source target = target `elem` Q.reachable source (dgGraph dg) -- Utility func for augs -augWithFun :: Monad m => EdgeGenerator -> DepGraphAug m +augWithFun :: (Monad m) => EdgeGenerator -> DepGraphAug m augWithFun f dg = genEdges (G.labNodes (dgGraph dg)) f dg -addDeps :: Monad m => DepGraphAug m +addDeps :: (Monad m) => DepGraphAug m addDeps = augWithFun toDep where toDep stmt = @@ -237,7 +237,7 @@ mkInfDep vname = (vname, InfDep vname) in map mkDep fusible <> map mkInfDep infusible -addConsAndAliases :: Monad m => DepGraphAug m +addConsAndAliases :: (Monad m) => DepGraphAug m addConsAndAliases = augWithFun edges where edges (StmNode s) = consEdges s' <> aliasEdges s' @@ -257,7 +257,7 @@ -- extra dependencies mask the fact that consuming nodes "depend" on all other -- nodes coming before it (now also adds fake edges to aliases - hope this -- fixes asymptotic complexity guarantees) -addExtraCons :: Monad m => DepGraphAug m +addExtraCons :: (Monad m) => DepGraphAug m addExtraCons dg = depGraphInsertEdges (concatMap makeEdge (G.labEdges g)) dg where @@ -273,7 +273,7 @@ pure $ G.toLEdge (from, to2) (Fake cname) makeEdge _ = [] -mapAcrossNodeTs :: Monad m => (NodeT -> m NodeT) -> DepGraphAug m +mapAcrossNodeTs :: (Monad m) => (NodeT -> m NodeT) -> DepGraphAug m mapAcrossNodeTs f = mapAcross f' where f' (ins, n, nodeT, outs) = do @@ -287,7 +287,7 @@ case maybeSoac of Right hsoac -> pure $ SoacNode mempty pat hsoac aux Left H.NotSOAC -> pure n - DoLoop {} -> + Loop {} -> pure $ DoNode s [] Match {} -> pure $ MatchNode s [] @@ -317,7 +317,7 @@ getStmRes (ResNode name) = [(name, Res name)] getStmRes _ = [] -addResEdges :: Monad m => DepGraphAug m +addResEdges :: (Monad m) => DepGraphAug m addResEdges = augWithFun getStmRes -- | Make a dependency graph corresponding to a 'Body'. @@ -340,7 +340,7 @@ scope = scopeOfFParams (funDefParams f) <> scopeOf (bodyStms (funDefBody f)) -- | Merges two contexts. -mergedContext :: Ord b => a -> G.Context a b -> G.Context a b -> G.Context a b +mergedContext :: (Ord b) => a -> G.Context a b -> G.Context a b -> G.Context a b mergedContext mergedlabel (inp1, n1, _, out1) (inp2, n2, _, out2) = let new_inp = filter (\n -> snd n /= n1 && snd n /= n2) (nubOrd (inp1 <> inp2)) new_out = filter (\n -> snd n /= n1 && snd n /= n2) (nubOrd (out1 <> out2)) @@ -349,7 +349,7 @@ -- | Remove the given node, and insert the 'DepContext' into the -- graph, replacing any existing information about the node contained -- in the 'DepContext'. -contractEdge :: Monad m => G.Node -> DepContext -> DepGraphAug m +contractEdge :: (Monad m) => G.Node -> DepContext -> DepGraphAug m contractEdge n2 ctx dg = do let n1 = G.node' ctx -- n1 remains pure $ dg {dgGraph = ctx G.& G.delNodes [n1, n2] (dgGraph dg)} @@ -367,7 +367,7 @@ type Classifications = S.Set (VName, Classification) -freeClassifications :: FreeIn a => a -> Classifications +freeClassifications :: (FreeIn a) => a -> Classifications freeClassifications = S.fromList . (`zip` repeat Other) . namesToList . freeIn @@ -383,7 +383,7 @@ foldMap (bodyInputs . caseBody) cases <> bodyInputs defbody <> freeClassifications (cond, attr) -expInputs (DoLoop params form b1) = +expInputs (Loop params form b1) = freeClassifications (params, form) <> bodyInputs b1 expInputs (Op soac) = case soac of Futhark.Screma w is form -> inputs is <> freeClassifications (w, form) 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 @@ -51,7 +51,7 @@ ) tryFusion :: - MonadFreshNames m => + (MonadFreshNames m) => TryFusion a -> Scope SOACS -> m (Maybe a) diff --git a/src/Futhark/Optimise/GenRedOpt.hs b/src/Futhark/Optimise/GenRedOpt.hs --- a/src/Futhark/Optimise/GenRedOpt.hs +++ b/src/Futhark/Optimise/GenRedOpt.hs @@ -403,7 +403,7 @@ costRedundantStmt :: Stm GPU -> Cost costRedundantStmt (Let _ _ (Op _)) = Big -costRedundantStmt (Let _ _ DoLoop {}) = Big +costRedundantStmt (Let _ _ Loop {}) = Big costRedundantStmt (Let _ _ Apply {}) = Big costRedundantStmt (Let _ _ WithAcc {}) = Big costRedundantStmt (Let _ _ (Match _ cases defbody _)) = diff --git a/src/Futhark/Optimise/HistAccs.hs b/src/Futhark/Optimise/HistAccs.hs --- a/src/Futhark/Optimise/HistAccs.hs +++ b/src/Futhark/Optimise/HistAccs.hs @@ -56,7 +56,7 @@ ) mkHistBody _ _ = Nothing -withAccLamToHistLam :: MonadFreshNames m => Shape -> Lambda GPU -> m (Lambda GPU) +withAccLamToHistLam :: (MonadFreshNames m) => Shape -> Lambda GPU -> m (Lambda GPU) withAccLamToHistLam shape lam = renameLambda $ lam {lambdaParams = drop (shapeRank shape) (lambdaParams lam)} @@ -89,7 +89,7 @@ KernelBody () stms [Returns ResultMaySimplify mempty (Var acc')] flatKernelBody :: - MonadBuilder m => + (MonadBuilder m) => SegSpace -> KernelBody (Rep m) -> m (SegSpace, KernelBody (Rep m)) diff --git a/src/Futhark/Optimise/InPlaceLowering.hs b/src/Futhark/Optimise/InPlaceLowering.hs --- a/src/Futhark/Optimise/InPlaceLowering.hs +++ b/src/Futhark/Optimise/InPlaceLowering.hs @@ -93,7 +93,7 @@ -- | Apply the in-place lowering optimisation to the given program. inPlaceLowering :: - Constraints rep => + (Constraints rep) => OnOp rep -> LowerUpdate rep (ForwardingM rep) -> Pass rep rep @@ -122,7 +122,7 @@ type Constraints rep = (Buildable rep, AliasableRep rep) optimiseBody :: - Constraints rep => + (Constraints rep) => Body (Aliases rep) -> ForwardingM rep (Body (Aliases rep)) optimiseBody (Body als stms res) = do @@ -133,7 +133,7 @@ seen (Var v) = seenVar v optimiseStms :: - Constraints rep => + (Constraints rep) => [Stm (Aliases rep)] -> ForwardingM rep () -> ForwardingM rep [Stm (Aliases rep)] @@ -180,14 +180,14 @@ checkIfForwardableUpdate stm' = mapM_ seenVar $ namesToList $ freeIn $ stmExp stm' -optimiseInStm :: Constraints rep => Stm (Aliases rep) -> ForwardingM rep (Stm (Aliases rep)) +optimiseInStm :: (Constraints rep) => Stm (Aliases rep) -> ForwardingM rep (Stm (Aliases rep)) optimiseInStm (Let pat dec e) = Let pat dec <$> optimiseExp e -optimiseExp :: Constraints rep => Exp (Aliases rep) -> ForwardingM rep (Exp (Aliases rep)) -optimiseExp (DoLoop merge form body) = +optimiseExp :: (Constraints rep) => Exp (Aliases rep) -> ForwardingM rep (Exp (Aliases rep)) +optimiseExp (Loop merge form body) = bindingScope (scopeOf form) . bindingFParams (map fst merge) $ - DoLoop merge form <$> optimiseBody body + Loop merge form <$> optimiseBody body optimiseExp (Op op) = do f <- asks topOnOp Op <$> f op @@ -199,7 +199,7 @@ } onSegOp :: - Constraints rep => + (Constraints rep) => SegOp lvl (Aliases rep) -> ForwardingM rep (SegOp lvl (Aliases rep)) onSegOp op = @@ -270,7 +270,7 @@ getNameSource = get putNameSource = put -instance Constraints rep => HasScope (Aliases rep) (ForwardingM rep) where +instance (Constraints rep) => HasScope (Aliases rep) (ForwardingM rep) where askScope = M.map entryType <$> asks topDownTable runForwardingM :: @@ -393,7 +393,7 @@ pure (x, bup) maybeForward :: - Constraints rep => + (Constraints rep) => VName -> VName -> LetDec (Aliases rep) -> diff --git a/src/Futhark/Optimise/InPlaceLowering/LowerIntoStm.hs b/src/Futhark/Optimise/InPlaceLowering/LowerIntoStm.hs --- a/src/Futhark/Optimise/InPlaceLowering/LowerIntoStm.hs +++ b/src/Futhark/Optimise/InPlaceLowering/LowerIntoStm.hs @@ -50,7 +50,7 @@ AliasableRep rep ) => LowerUpdate rep m -lowerUpdate scope (Let pat aux (DoLoop merge form body)) updates = do +lowerUpdate scope (Let pat aux (Loop merge form body)) updates = do canDo <- lowerUpdateIntoLoop scope updates pat merge form body Just $ do (prestms, poststms, pat', merge', body') <- canDo @@ -58,7 +58,7 @@ prestms ++ [ certify (stmAuxCerts aux) $ mkLet pat' $ - DoLoop merge' form body' + Loop merge' form body' ] ++ poststms lowerUpdate @@ -77,7 +77,7 @@ lowerUpdate _ _ _ = Nothing -lowerUpdateGPU :: MonadFreshNames m => LowerUpdate GPU m +lowerUpdateGPU :: (MonadFreshNames m) => LowerUpdate GPU m lowerUpdateGPU scope (Let pat aux (Op (SegOp (SegMap lvl space ts kbody)))) @@ -103,7 +103,7 @@ lowerUpdateGPU scope stm updates = lowerUpdate scope stm updates lowerUpdatesIntoSegMap :: - MonadFreshNames m => + (MonadFreshNames m) => Scope (Aliases GPU) -> Pat (LetDec (Aliases GPU)) -> [DesiredUpdate (LetDec (Aliases GPU))] -> @@ -339,7 +339,7 @@ } deriving (Show) -indexSubstitutions :: Typed dec => [LoopResultSummary dec] -> IndexSubstitutions +indexSubstitutions :: (Typed dec) => [LoopResultSummary dec] -> IndexSubstitutions indexSubstitutions = mapMaybe getSubstitution where getSubstitution res = do diff --git a/src/Futhark/Optimise/InPlaceLowering/SubstituteIndices.hs b/src/Futhark/Optimise/InPlaceLowering/SubstituteIndices.hs --- a/src/Futhark/Optimise/InPlaceLowering/SubstituteIndices.hs +++ b/src/Futhark/Optimise/InPlaceLowering/SubstituteIndices.hs @@ -25,7 +25,7 @@ -- should be replaced with. type IndexSubstitutions = [(VName, IndexSubstitution)] -typeEnvFromSubstitutions :: LParamInfo rep ~ Type => IndexSubstitutions -> Scope rep +typeEnvFromSubstitutions :: (LParamInfo rep ~ Type) => IndexSubstitutions -> Scope rep typeEnvFromSubstitutions = M.fromList . map (fromSubstitution . snd) where fromSubstitution (_, name, t, _) = @@ -130,7 +130,7 @@ in foldM consumingSubst substs . namesToList . consumedInExp substituteIndicesInSubExp :: - MonadBuilder m => + (MonadBuilder m) => IndexSubstitutions -> SubExp -> m SubExp @@ -140,7 +140,7 @@ pure se substituteIndicesInVar :: - MonadBuilder m => + (MonadBuilder m) => IndexSubstitutions -> VName -> m VName 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 @@ -32,7 +32,7 @@ ) import Futhark.Transform.Rename -parMapM :: MonadFreshNames m => (a -> State VNameSource b) -> [a] -> m [b] +parMapM :: (MonadFreshNames m) => (a -> State VNameSource b) -> [a] -> m [b] -- The special-casing of [] is quite important here! If 'as' is -- empty, then we might otherwise create an empty name source below, -- which can wreak all kinds of havoc. @@ -50,7 +50,7 @@ -- simplification rates used have been determined heuristically and -- are probably not optimal for any given program. inlineFunctions :: - MonadFreshNames m => + (MonadFreshNames m) => Int -> CallGraph -> S.Set Name -> @@ -119,14 +119,14 @@ -- Conservative inlining of functions that are called just once, or -- have #[inline] on them. -consInlineFunctions :: MonadFreshNames m => Prog SOACS -> m (Prog SOACS) +consInlineFunctions :: (MonadFreshNames m) => Prog SOACS -> m (Prog SOACS) consInlineFunctions prog = inlineFunctions 4 cg (calledOnce cg <> inlineBecauseTiny prog) prog where cg = buildCallGraph prog -- Inline everything that is not #[noinline]. -aggInlineFunctions :: MonadFreshNames m => Prog SOACS -> m (Prog SOACS) +aggInlineFunctions :: (MonadFreshNames m) => Prog SOACS -> m (Prog SOACS) aggInlineFunctions prog = inlineFunctions 3 cg (S.fromList $ map funDefName $ progFuns prog) prog where @@ -138,7 +138,7 @@ -- importantly, the functions in @fdmap@ do not call any other -- functions. inlineInFunDef :: - MonadFreshNames m => + (MonadFreshNames m) => M.Map Name (FunDef SOACS) -> FunDef SOACS -> m (FunDef SOACS) @@ -146,7 +146,7 @@ FunDef entry attrs name rtp args <$> inlineInBody fdmap body inlineFunction :: - MonadFreshNames m => + (MonadFreshNames m) => Pat Type -> StmAux dec -> [(SubExp, Diet)] -> @@ -180,7 +180,7 @@ notmempty = (/= mempty) . locOf inlineInStms :: - MonadFreshNames m => + (MonadFreshNames m) => M.Map Name (FunDef SOACS) -> Stms SOACS -> m (Stms SOACS) @@ -188,7 +188,7 @@ bodyStms <$> inlineInBody fdmap (mkBody stms []) inlineInBody :: - MonadFreshNames m => + (MonadFreshNames m) => M.Map Name (FunDef SOACS) -> Body SOACS -> m (Body SOACS) diff --git a/src/Futhark/Optimise/MemoryBlockMerging.hs b/src/Futhark/Optimise/MemoryBlockMerging.hs --- a/src/Futhark/Optimise/MemoryBlockMerging.hs +++ b/src/Futhark/Optimise/MemoryBlockMerging.hs @@ -30,7 +30,7 @@ getAllocsStm (Let _ _ (Op (Alloc _ _))) = error "impossible" getAllocsStm (Let _ _ (Match _ cases defbody _)) = foldMap (foldMap getAllocsStm . bodyStms) $ defbody : map caseBody cases -getAllocsStm (Let _ _ (DoLoop _ _ body)) = +getAllocsStm (Let _ _ (Loop _ _ body)) = foldMap getAllocsStm (bodyStms body) getAllocsStm _ = mempty @@ -55,10 +55,10 @@ stm {stmExp = Match cond (map (fmap onBody) cases) (onBody defbody) dec} where onBody (Body () stms res) = Body () (setAllocsStm m <$> stms) res -setAllocsStm m stm@(Let _ _ (DoLoop merge form body)) = +setAllocsStm m stm@(Let _ _ (Loop merge form body)) = stm { stmExp = - DoLoop merge form (body {bodyStms = setAllocsStm m <$> bodyStms body}) + Loop merge form (body {bodyStms = setAllocsStm m <$> bodyStms body}) } setAllocsStm _ stm = stm @@ -79,7 +79,7 @@ SegHist lvl sp segbinops tps $ body {kernelBodyStms = setAllocsStm m <$> kernelBodyStms body} -maxSubExp :: MonadBuilder m => Set SubExp -> m SubExp +maxSubExp :: (MonadBuilder m) => Set SubExp -> m SubExp maxSubExp = helper . S.toList where helper (s1 : s2 : sexps) = do @@ -98,7 +98,7 @@ isScalarSpace _ = False onKernelBodyStms :: - MonadBuilder m => + (MonadBuilder m) => SegOp lvl GPUMem -> (Stms GPUMem -> m (Stms GPUMem)) -> m (SegOp lvl GPUMem) @@ -160,7 +160,7 @@ -- | Helper function that modifies kernels found inside some statements. onKernels :: - LocalScope GPUMem m => + (LocalScope GPUMem m) => (SegOp SegLevel GPUMem -> m (SegOp SegLevel GPUMem)) -> Stms GPUMem -> m (Stms GPUMem) @@ -176,9 +176,9 @@ where onBody (Body () stms res) = Body () <$> f `onKernels` stms <*> pure res - helper stm@Let {stmExp = DoLoop merge form body} = do + helper stm@Let {stmExp = Loop merge form body} = do body_stms <- f `onKernels` bodyStms body - pure $ stm {stmExp = DoLoop merge form (body {bodyStms = body_stms})} + pure $ stm {stmExp = Loop merge form (body {bodyStms = body_stms})} helper stm = pure stm -- | Perform the reuse-allocations optimization. diff --git a/src/Futhark/Optimise/MemoryBlockMerging/GreedyColoring.hs b/src/Futhark/Optimise/MemoryBlockMerging/GreedyColoring.hs --- a/src/Futhark/Optimise/MemoryBlockMerging/GreedyColoring.hs +++ b/src/Futhark/Optimise/MemoryBlockMerging/GreedyColoring.hs @@ -14,7 +14,7 @@ type Neighbors a = M.Map a (S.Set a) -- | Computes the neighbor map of a graph. -neighbors :: Ord a => Interference.Graph a -> Neighbors a +neighbors :: (Ord a) => Interference.Graph a -> Neighbors a neighbors = S.foldr ( \(x, y) acc -> @@ -24,7 +24,7 @@ ) M.empty -firstAvailable :: Eq space => M.Map Int space -> S.Set Int -> Int -> space -> (M.Map Int space, Int) +firstAvailable :: (Eq space) => M.Map Int space -> S.Set Int -> Int -> space -> (M.Map Int space, Int) firstAvailable spaces xs i sp = case (i `S.member` xs, spaces M.!? i) of (False, Just sp') | sp' == sp -> (spaces, i) 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 @@ -64,7 +64,7 @@ -------------------------------------------------------------------------------- -- | All free variables of a construct as 'Dependencies'. -depsOf :: FreeIn a => a -> Dependencies +depsOf :: (FreeIn a) => a -> Dependencies depsOf = namesToSet . freeIn -- | Convert 'Names' to an integer set of name tags. @@ -181,7 +181,7 @@ (defbody', defbody_deps) <- transformBody aliases defbody let deps = depsOf ses <> mconcat cases_deps <> defbody_deps <> depsOf dec pure (Match ses cases' defbody' dec, deps) - DoLoop merge lform body -> do + Loop merge lform body -> do -- What merge and lform aliases outside the loop is irrelevant as those -- cannot be consumed within the loop. (body', body_deps) <- transformBody aliases body @@ -192,10 +192,10 @@ let bound = IS.fromList $ map baseTag (M.keys scope) let deps' = deps \\ bound - let dummy = DoLoop merge lform (Body (bodyDec body) SQ.empty []) - let DoLoop merge' lform' _ = removeExpAliases dummy + let dummy = Loop merge lform (Body (bodyDec body) SQ.empty []) + let Loop merge' lform' _ = removeExpAliases dummy - pure (DoLoop merge' lform' body', deps') + pure (Loop merge' lform' body', deps') WithAcc inputs lambda -> do accs <- mapM (transformWithAccInput aliases) inputs let (inputs', input_deps) = unzip accs 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 @@ -195,7 +195,7 @@ -- Read migrated scalars that are used on host. foldM addRead (out |> stm') (zip pes pes') - DoLoop ps lf b -> do + Loop ps lf b -> do -- Enable the migration of for-in loop variables. (params, lform, body) <- rewriteForIn (ps, lf, b) @@ -249,7 +249,7 @@ let body3 = body2 {bodyStms = bstms, bodyResult = reverse res} -- Rewrite statement. - let e' = DoLoop params' lform body3 + let e' = Loop params' lform body3 let stm' = Let (Pat pes') (stmAux stm) e' -- Read migrated scalars that are used on host. @@ -393,7 +393,7 @@ MonadReader MigrationTable ) -runReduceM :: MonadFreshNames m => MigrationTable -> ReduceM a -> m a +runReduceM :: (MonadFreshNames m) => MigrationTable -> ReduceM a -> m a runReduceM mt (ReduceM m) = modifyNameSource $ \src -> second stateNameSource (runReader (runStateT m (initialState src)) mt) diff --git a/src/Futhark/Optimise/ReduceDeviceSyncs/MigrationTable.hs b/src/Futhark/Optimise/ReduceDeviceSyncs/MigrationTable.hs --- a/src/Futhark/Optimise/ReduceDeviceSyncs/MigrationTable.hs +++ b/src/Futhark/Optimise/ReduceDeviceSyncs/MigrationTable.hs @@ -64,7 +64,7 @@ import Data.IntSet qualified as IS import Data.List qualified as L import Data.Map.Strict qualified as M -import Data.Maybe (fromJust, fromMaybe, isJust, isNothing) +import Data.Maybe (fromMaybe, isJust, isNothing) import Data.Sequence qualified as SQ import Data.Set (Set, (\\)) import Data.Set qualified as S @@ -127,9 +127,9 @@ statusOf n mt /= StayOnHost shouldMoveStm (Let _ _ (Match cond _ _ _)) mt = all ((== MoveToDevice) . (`statusOf` mt)) $ subExpVars cond -shouldMoveStm (Let _ _ (DoLoop _ (ForLoop _ _ (Var n) _) _)) mt = +shouldMoveStm (Let _ _ (Loop _ (ForLoop _ _ (Var n) _) _)) mt = statusOf n mt == MoveToDevice -shouldMoveStm (Let _ _ (DoLoop _ (WhileLoop n) _)) mt = +shouldMoveStm (Let _ _ (Loop _ (WhileLoop n) _)) mt = statusOf n mt == MoveToDevice -- BasicOp and Apply statements might not bind any variables (shouldn't happen). -- If statements might use a constant branch condition. @@ -216,7 +216,7 @@ checkExp (Apply fn _ _ _) = Just (S.singleton fn) checkExp (Match _ cases defbody _) = mconcat <$> mapM checkBody (defbody : map caseBody cases) - checkExp (DoLoop params lform body) = do + checkExp (Loop params lform body) = do checkLParams params checkLoopForm lform checkBody body @@ -296,7 +296,7 @@ -- TYPE HELPERS -- -------------------------------------------------------------------------------- -isScalar :: Typed t => t -> Bool +isScalar :: (Typed t) => t -> Bool isScalar = isScalarType . typeOf isScalarType :: TypeBase shape u -> Bool @@ -304,10 +304,10 @@ isScalarType (Prim _) = True isScalarType _ = False -isArray :: Typed t => t -> Bool +isArray :: (Typed t) => t -> Bool isArray = isArrayType . typeOf -isArrayType :: ArrayShape shape => TypeBase shape u -> Bool +isArrayType :: (ArrayShape shape) => TypeBase shape u -> Bool isArrayType = (0 <) . arrayRank -------------------------------------------------------------------------------- @@ -507,7 +507,7 @@ graphApply fn bs e Match ses cases defbody _ -> graphMatch bs ses cases defbody - DoLoop params lform body -> + Loop params lform body -> graphLoop bs params lform body WithAcc inputs f -> graphWithAcc bs inputs f @@ -700,7 +700,7 @@ unless may_migrate $ case lform of ForLoop _ _ (Var n) _ -> connectToSink (nameToId n) WhileLoop n - | (_, p, _, res) <- loopValueFor n -> do + | Just (_, p, _, res) <- loopValueFor n -> do connectToSink p case res of Var v -> connectToSink (nameToId v) @@ -741,8 +741,9 @@ ForLoop _ _ n _ -> onlyGraphedScalarSubExp n >>= addEdges (ToNodes bindings Nothing) WhileLoop n - | (_, _, arg, _) <- loopValueFor n -> + | Just (_, _, arg, _) <- loopValueFor n -> onlyGraphedScalarSubExp arg >>= addEdges (ToNodes bindings Nothing) + _ -> pure () where subgraphId :: Id subgraphId = fst b @@ -759,9 +760,8 @@ bindings :: IdSet bindings = IS.fromList $ map (\((i, _), _, _, _) -> i) loopValues - loopValueFor :: VName -> LoopValue loopValueFor n = - fromJust $ find (\(_, p, _, _) -> p == nameToId n) loopValues + find (\(_, p, _, _) -> p == nameToId n) loopValues graphTheLoop :: Grapher () graphTheLoop = do @@ -1012,7 +1012,7 @@ mapM_ collectSubExp ses mapM_ (collectBody . caseBody) cases collectBody defbody - collect (DoLoop params lform body) = do + collect (Loop params lform body) = do mapM_ (collectSubExp . snd) params collectLForm lform collectBody body @@ -1504,7 +1504,7 @@ -- | Reduces the variables to just the 'Id's of those that are scalars and which -- have a vertex representation in the graph, excluding those that have been -- connected to sinks. -onlyGraphedScalars :: Foldable t => t VName -> Grapher IdSet +onlyGraphedScalars :: (Foldable t) => t VName -> Grapher IdSet onlyGraphedScalars vs = do let is = foldl' (\s n -> IS.insert (nameToId n) s) IS.empty vs IS.intersection is <$> getGraphedScalars diff --git a/src/Futhark/Optimise/ReduceDeviceSyncs/MigrationTable/Graph.hs b/src/Futhark/Optimise/ReduceDeviceSyncs/MigrationTable/Graph.hs --- a/src/Futhark/Optimise/ReduceDeviceSyncs/MigrationTable/Graph.hs +++ b/src/Futhark/Optimise/ReduceDeviceSyncs/MigrationTable/Graph.hs @@ -185,7 +185,7 @@ FoundSink deriving (Eq) -instance Semigroup a => Semigroup (Result a) where +instance (Semigroup a) => Semigroup (Result a) where FoundSink <> _ = FoundSink _ <> FoundSink = FoundSink Produced x <> Produced y = Produced (x <> y) @@ -344,7 +344,7 @@ -- -- The reduction of a cyclic reference resolves to 'mempty'. reduce :: - Monoid a => + (Monoid a) => Graph m -> (a -> EdgeType -> Vertex m -> a) -> Visited (Result a) -> diff --git a/src/Futhark/Optimise/Simplify.hs b/src/Futhark/Optimise/Simplify.hs --- a/src/Futhark/Optimise/Simplify.hs +++ b/src/Futhark/Optimise/Simplify.hs @@ -31,7 +31,7 @@ -- output, meaningful simplification may not have taken place - the -- order of bindings may simply have been rearranged. simplifyProg :: - Engine.SimplifiableRep rep => + (Engine.SimplifiableRep rep) => Engine.SimpleOps rep -> RuleBook (Engine.Wise rep) -> Engine.HoistBlockers rep -> 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 @@ -136,10 +136,6 @@ -- actually be used. protectHoistedOpS :: Protect (Builder (Wise rep)), opUsageS :: Op (Wise rep) -> UT.UsageTable, - simplifyPatFromExpS :: - Pat (LetDec rep) -> - Exp (Wise rep) -> - SimpleM rep (Pat (LetDec rep)), simplifyOpS :: SimplifyOp rep (Op (Wise rep)) } @@ -148,12 +144,11 @@ SimplifyOp rep (Op (Wise rep)) -> SimpleOps rep bindableSimpleOps = - SimpleOps mkExpDecS' mkBodyS' protectHoistedOpS' (const mempty) simplifyPatFromExp + SimpleOps mkExpDecS' mkBodyS' protectHoistedOpS' (const mempty) where mkExpDecS' _ pat e = pure $ mkExpDec pat e mkBodyS' _ stms res = pure $ mkBody stms res protectHoistedOpS' _ _ _ = Nothing - simplifyPatFromExp pat _ = traverse simplify pat newtype SimpleM rep a = SimpleM @@ -174,7 +169,7 @@ putNameSource src = modify $ \(_, b, c) -> (src, b, c) getNameSource = gets $ \(a, _, _) -> a -instance SimplifiableRep rep => HasScope (Wise rep) (SimpleM rep) where +instance (SimplifiableRep rep) => HasScope (Wise rep) (SimpleM rep) where askScope = ST.toScope <$> askVtable lookupType name = do vtable <- askVtable @@ -187,7 +182,7 @@ ++ " in symbol table." instance - SimplifiableRep rep => + (SimplifiableRep rep) => LocalScope (Wise rep) (SimpleM rep) where localScope types = localVtable (<> ST.fromScope types) @@ -236,16 +231,16 @@ enterLoop :: SimpleM rep a -> SimpleM rep a enterLoop = localVtable ST.deepen -bindFParams :: SimplifiableRep rep => [FParam (Wise rep)] -> SimpleM rep a -> SimpleM rep a +bindFParams :: (SimplifiableRep rep) => [FParam (Wise rep)] -> SimpleM rep a -> SimpleM rep a bindFParams params = localVtable $ ST.insertFParams params -bindLParams :: SimplifiableRep rep => [LParam (Wise rep)] -> SimpleM rep a -> SimpleM rep a +bindLParams :: (SimplifiableRep rep) => [LParam (Wise rep)] -> SimpleM rep a -> SimpleM rep a bindLParams params = localVtable $ \vtable -> foldr ST.insertLParam vtable params bindArrayLParams :: - SimplifiableRep rep => + (SimplifiableRep rep) => [LParam (Wise rep)] -> SimpleM rep a -> SimpleM rep a @@ -253,13 +248,13 @@ localVtable $ \vtable -> foldl' (flip ST.insertLParam) vtable params bindMerge :: - SimplifiableRep rep => + (SimplifiableRep rep) => [(FParam (Wise rep), SubExp, SubExpRes)] -> SimpleM rep a -> SimpleM rep a bindMerge = localVtable . ST.insertLoopMerge -bindLoopVar :: SimplifiableRep rep => VName -> IntType -> SubExp -> SimpleM rep a -> SimpleM rep a +bindLoopVar :: (SimplifiableRep rep) => VName -> IntType -> SubExp -> SimpleM rep a -> SimpleM rep a bindLoopVar var it bound = localVtable $ ST.insertLoopVar var it bound @@ -283,7 +278,7 @@ makeSafe _ = Nothing -emptyOfType :: MonadBuilder m => [VName] -> Type -> m (Exp (Rep m)) +emptyOfType :: (MonadBuilder m) => [VName] -> Type -> m (Exp (Rep m)) emptyOfType _ Mem {} = error "emptyOfType: Cannot hoist non-existential memory." emptyOfType _ Acc {} = @@ -298,7 +293,7 @@ zeroIfContext se = se protectIf :: - MonadBuilder m => + (MonadBuilder m) => Protect m -> (Exp (Rep m) -> Bool) -> SubExp -> @@ -339,7 +334,7 @@ -- loops, but they must be protected by adding a branch on top of -- them. protectLoopHoisted :: - SimplifiableRep rep => + (SimplifiableRep rep) => [(FParam (Wise rep), SubExp)] -> LoopForm (Wise rep) -> SimpleM rep (a, b, Stms (Wise rep)) -> @@ -370,7 +365,7 @@ -- Produces a true subexpression if the pattern (as in a 'Case') -- matches the subexpression. matching :: - BuilderOps rep => + (BuilderOps rep) => [(SubExp, Maybe PrimValue)] -> Builder rep SubExp matching = letSubExp "match" <=< eAll <=< sequence . mapMaybe cmp @@ -383,7 +378,7 @@ cmp (_, Nothing) = Nothing matchingExactlyThis :: - BuilderOps rep => + (BuilderOps rep) => [SubExp] -> [[Maybe PrimValue]] -> [Maybe PrimValue] -> @@ -401,7 +396,7 @@ -- them. (This means such hoisting is not worth it unless they are in -- turn hoisted out of a loop somewhere.) protectCaseHoisted :: - SimplifiableRep rep => + (SimplifiableRep rep) => -- | Scrutinee. [SubExp] -> -- | Pattern of previosu cases. @@ -426,21 +421,20 @@ -- | Statements that are not worth hoisting out of loops, because they -- are unsafe, and added safety (by 'protectLoopHoisted') may inhibit -- further optimisation. -notWorthHoisting :: ASTRep rep => BlockPred rep +notWorthHoisting :: (ASTRep rep) => BlockPred rep notWorthHoisting _ _ (Let pat _ e) = not (safeExp e) && any ((> 0) . arrayRank) (patTypes pat) -- Top-down simplify a statement (including copy propagation into the -- pattern and such). Does not recurse into any sub-Bodies or Ops. nonrecSimplifyStm :: - SimplifiableRep rep => + (SimplifiableRep rep) => Stm (Wise rep) -> SimpleM rep (Stm (Wise rep)) nonrecSimplifyStm (Let pat (StmAux cs attrs (_, dec)) e) = do cs' <- simplify cs e' <- simplifyExpBase e - simplifyPat <- asks $ simplifyPatFromExpS . fst - (pat', pat_cs) <- collectCerts $ simplifyPat (removePatWisdom pat) e' + (pat', pat_cs) <- collectCerts $ traverse simplify $ removePatWisdom pat let aux' = StmAux (cs' <> pat_cs) attrs dec pure $ mkWiseStm pat' aux' e' @@ -449,7 +443,7 @@ -- assumed 'nonrecSimplifyStm' has already touched it (and worst case, -- it'll get it on the next round of the overall fixpoint iteration.) recSimplifyStm :: - SimplifiableRep rep => + (SimplifiableRep rep) => Stm (Wise rep) -> UT.UsageTable -> SimpleM rep (Stms (Wise rep), Stm (Wise rep)) @@ -459,7 +453,7 @@ pure (e_hoisted, mkWiseStm (removePatWisdom pat) aux' e') hoistStms :: - SimplifiableRep rep => + (SimplifiableRep rep) => RuleBook (Wise rep) -> BlockPred (Wise rep) -> Stms (Wise rep) -> @@ -542,7 +536,7 @@ process usageInStm stms_h'' stms_t' usage x blockUnhoistedDeps :: - ASTRep rep => + (ASTRep rep) => [Either (Stm rep) (Stm rep)] -> [Either (Stm rep) (Stm rep)] blockUnhoistedDeps = snd . mapAccumL block mempty @@ -559,7 +553,7 @@ provides = patNames . stmPat expandUsage :: - Aliased rep => + (Aliased rep) => (Stm rep -> UT.UsageTable) -> ST.SymbolTable rep -> UT.UsageTable -> @@ -608,7 +602,7 @@ isOp _ _ _ = False constructBody :: - SimplifiableRep rep => + (SimplifiableRep rep) => Stms (Wise rep) -> Result -> SimpleM rep (Body (Wise rep)) @@ -618,7 +612,7 @@ pure res blockIf :: - SimplifiableRep rep => + (SimplifiableRep rep) => BlockPred (Wise rep) -> Stms (Wise rep) -> SimpleM rep (a, UT.UsageTable) -> @@ -627,24 +621,24 @@ rules <- asksEngineEnv envRules hoistStms rules block stms m -hasFree :: ASTRep rep => Names -> BlockPred rep +hasFree :: (ASTRep rep) => Names -> BlockPred rep hasFree ks _ _ need = ks `namesIntersect` freeIn need -isNotSafe :: ASTRep rep => BlockPred rep +isNotSafe :: (ASTRep rep) => BlockPred rep isNotSafe _ _ = not . safeExp . stmExp -isConsuming :: Aliased rep => BlockPred rep +isConsuming :: (Aliased rep) => BlockPred rep isConsuming _ _ = isUpdate . stmExp where isUpdate e = consumedInExp e /= mempty -isNotCheap :: ASTRep rep => BlockPred rep +isNotCheap :: (ASTRep rep) => BlockPred rep isNotCheap _ _ = not . cheapStm -cheapStm :: ASTRep rep => Stm rep -> Bool +cheapStm :: (ASTRep rep) => Stm rep -> Bool cheapStm = cheapExp . stmExp -cheapExp :: ASTRep rep => Exp rep -> Bool +cheapExp :: (ASTRep rep) => Exp rep -> Bool cheapExp (BasicOp BinOp {}) = True cheapExp (BasicOp SubExp {}) = True cheapExp (BasicOp UnOp {}) = True @@ -654,7 +648,7 @@ cheapExp (BasicOp Replicate {}) = False cheapExp (BasicOp Concat {}) = False cheapExp (BasicOp Manifest {}) = False -cheapExp DoLoop {} = False +cheapExp Loop {} = False cheapExp (Match _ cases defbranch _) = all (all cheapStm . bodyStms . caseBody) cases && all cheapStm (bodyStms defbranch) @@ -662,12 +656,12 @@ cheapExp _ = True -- Used to be False, but -- let's try it out. -loopInvariantStm :: ASTRep rep => ST.SymbolTable rep -> Stm rep -> Bool +loopInvariantStm :: (ASTRep rep) => ST.SymbolTable rep -> Stm rep -> Bool loopInvariantStm vtable = all (`nameIn` ST.availableAtClosestLoop vtable) . namesToList . freeIn matchBlocker :: - SimplifiableRep rep => + (SimplifiableRep rep) => [SubExp] -> MatchDec rt -> SimpleM rep (BlockPred (Wise rep)) @@ -728,7 +722,7 @@ -- | Simplify a single body. simplifyBody :: - SimplifiableRep rep => + (SimplifiableRep rep) => BlockPred (Wise rep) -> UT.UsageTable -> [UT.Usages] -> @@ -744,7 +738,7 @@ -- | Simplify a single body. simplifyBodyNoHoisting :: - SimplifiableRep rep => + (SimplifiableRep rep) => UT.UsageTable -> [UT.Usages] -> Body (Wise rep) -> @@ -758,7 +752,7 @@ -- | Simplify a single 'Result'. simplifyResult :: - SimplifiableRep rep => [UT.Usages] -> Result -> SimpleM rep (Result, UT.UsageTable) + (SimplifiableRep rep) => [UT.Usages] -> Result -> SimpleM rep (Result, UT.UsageTable) simplifyResult usages res = do res' <- mapM simplify res vtable <- askVtable @@ -776,14 +770,14 @@ <> more_usages ) -isDoLoopResult :: Result -> UT.UsageTable -isDoLoopResult = mconcat . map checkForVar +isLoopResult :: Result -> UT.UsageTable +isLoopResult = mconcat . map checkForVar where checkForVar (SubExpRes _ (Var ident)) = UT.inResultUsage ident checkForVar _ = mempty simplifyStms :: - SimplifiableRep rep => + (SimplifiableRep rep) => Stms (Wise rep) -> SimpleM rep (Stms (Wise rep)) simplifyStms stms = do @@ -793,7 +787,7 @@ UT.usages (namesFromList (M.keys (scopeOf stms))) simplifyStmsWithUsage :: - SimplifiableRep rep => + (SimplifiableRep rep) => UT.UsageTable -> Stms (Wise rep) -> SimpleM rep (Stms (Wise rep)) @@ -807,7 +801,7 @@ f op simplifyExp :: - SimplifiableRep rep => + (SimplifiableRep rep) => UT.UsageTable -> Pat (LetDec (Wise rep)) -> Exp (Wise rep) -> @@ -833,7 +827,7 @@ protectCaseHoisted ses' prior vs $ simplifyBody block usage pes_usages body pure (hoisted, Case vs body') -simplifyExp _ _ (DoLoop merge form loopbody) = do +simplifyExp _ _ (Loop merge form loopbody) = do let (params, args) = unzip merge params' <- mapM (traverse simplify) params args' <- mapM simplify args @@ -876,9 +870,9 @@ (\p -> if unique (paramDeclType p) then UT.consumedU else mempty) params' (res, uses) <- simplifyResult params_usages $ bodyResult loopbody - pure (res, uses <> isDoLoopResult res) + pure (res, uses <> isLoopResult res) loopbody' <- constructBody loopstms loopres - pure (DoLoop merge' form' loopbody', hoisted) + pure (Loop merge' form' loopbody', hoisted) where fparamnames = namesFromList (map (paramName . fst) merge) @@ -909,7 +903,7 @@ -- | Block hoisting of 'Index' statements introduced by migration. blockMigrated :: - SimplifiableRep rep => + (SimplifiableRep rep) => SimpleM rep (Lambda (Wise rep), Stms (Wise rep)) -> SimpleM rep (Lambda (Wise rep), Stms (Wise rep)) blockMigrated = local withMigrationBlocker @@ -925,7 +919,7 @@ in (ops, env') -- | Statement is a scalar read from a single element array of rank one. -isDeviceMigrated :: SimplifiableRep rep => BlockPred (Wise rep) +isDeviceMigrated :: (SimplifiableRep rep) => BlockPred (Wise rep) isDeviceMigrated vtable _ stm | BasicOp (Index arr slice) <- stmExp stm, [DimFix idx] <- unSlice slice, @@ -939,7 +933,7 @@ -- The simple nonrecursive case that we can perform without bottom-up -- information. -simplifyExpBase :: SimplifiableRep rep => Exp (Wise rep) -> SimpleM rep (Exp (Wise rep)) +simplifyExpBase :: (SimplifiableRep rep) => Exp (Wise rep) -> SimpleM rep (Exp (Wise rep)) -- Special case for simplification of commutative BinOps where we -- arrange the operands in sorted order. This can make expressions -- more identical, which helps CSE. @@ -975,7 +969,7 @@ ) class Simplifiable e where - simplify :: SimplifiableRep rep => e -> SimpleM rep e + simplify :: (SimplifiableRep rep) => e -> SimpleM rep e instance (Simplifiable a, Simplifiable b) => Simplifiable (a, b) where simplify (x, y) = (,) <$> simplify x <*> simplify y @@ -990,11 +984,11 @@ instance Simplifiable Int where simplify = pure -instance Simplifiable a => Simplifiable (Maybe a) where +instance (Simplifiable a) => Simplifiable (Maybe a) where simplify Nothing = pure Nothing simplify (Just x) = Just <$> simplify x -instance Simplifiable a => Simplifiable [a] where +instance (Simplifiable a) => Simplifiable [a] where simplify = mapM simplify instance Simplifiable SubExp where @@ -1032,7 +1026,7 @@ pure v' _ -> pure v -instance Simplifiable d => Simplifiable (ShapeBase d) where +instance (Simplifiable d) => Simplifiable (ShapeBase d) where simplify = fmap Shape . simplify . shapeDims instance Simplifiable ExtSize where @@ -1046,7 +1040,7 @@ instance Simplifiable PrimType where simplify = pure -instance Simplifiable shape => Simplifiable (TypeBase shape u) where +instance (Simplifiable shape) => Simplifiable (TypeBase shape u) where simplify (Array et shape u) = Array <$> simplify et <*> simplify shape <*> pure u simplify (Acc acc ispace ts u) = @@ -1056,15 +1050,15 @@ simplify (Prim bt) = pure $ Prim bt -instance Simplifiable d => Simplifiable (DimIndex d) where +instance (Simplifiable d) => Simplifiable (DimIndex d) where simplify (DimFix i) = DimFix <$> simplify i simplify (DimSlice i n s) = DimSlice <$> simplify i <*> simplify n <*> simplify s -instance Simplifiable d => Simplifiable (Slice d) where +instance (Simplifiable d) => Simplifiable (Slice d) where simplify = traverse simplify simplifyLambda :: - SimplifiableRep rep => + (SimplifiableRep rep) => Names -> Lambda (Wise rep) -> SimpleM rep (Lambda (Wise rep), Stms (Wise rep)) @@ -1073,14 +1067,14 @@ simplifyLambdaMaybeHoist (par_blocker `orIf` hasFree extra_bound) mempty lam simplifyLambdaNoHoisting :: - SimplifiableRep rep => + (SimplifiableRep rep) => Lambda (Wise rep) -> SimpleM rep (Lambda (Wise rep)) simplifyLambdaNoHoisting lam = fst <$> simplifyLambdaMaybeHoist (isFalse False) mempty lam simplifyLambdaMaybeHoist :: - SimplifiableRep rep => + (SimplifiableRep rep) => BlockPred (Wise rep) -> UT.UsageTable -> Lambda (Wise rep) -> @@ -1088,7 +1082,7 @@ simplifyLambdaMaybeHoist = simplifyLambdaWith id simplifyLambdaWith :: - SimplifiableRep rep => + (SimplifiableRep rep) => (ST.SymbolTable (Wise rep) -> ST.SymbolTable (Wise rep)) -> BlockPred (Wise rep) -> UT.UsageTable -> @@ -1118,7 +1112,7 @@ _ -> pure [idd] simplifyFun :: - SimplifiableRep rep => + (SimplifiableRep rep) => FunDef (Wise rep) -> SimpleM rep (FunDef (Wise rep)) simplifyFun (FunDef entry attrs fname rettype params body) = do 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 @@ -157,11 +157,11 @@ instance AliasesOf (VarWisdom, dec) where aliasesOf = unAliases . varWisdomAliases . fst -instance Informing rep => Aliased (Wise rep) where +instance (Informing rep) => Aliased (Wise rep) where bodyAliases = map unAliases . bodyWisdomAliases . fst . bodyDec consumedInBody = unAliases . bodyWisdomConsumed . fst . bodyDec -removeWisdom :: RephraseOp (OpC rep) => Rephraser Identity (Wise rep) rep +removeWisdom :: (RephraseOp (OpC rep)) => Rephraser Identity (Wise rep) rep removeWisdom = Rephraser { rephraseExpDec = pure . snd, @@ -194,23 +194,23 @@ alias (IndexName it) = IndexName it -- | Remove simplifier information from function. -removeFunDefWisdom :: RephraseOp (OpC rep) => FunDef (Wise rep) -> FunDef rep +removeFunDefWisdom :: (RephraseOp (OpC rep)) => FunDef (Wise rep) -> FunDef rep removeFunDefWisdom = runIdentity . rephraseFunDef removeWisdom -- | Remove simplifier information from statement. -removeStmWisdom :: RephraseOp (OpC rep) => Stm (Wise rep) -> Stm rep +removeStmWisdom :: (RephraseOp (OpC rep)) => Stm (Wise rep) -> Stm rep removeStmWisdom = runIdentity . rephraseStm removeWisdom -- | Remove simplifier information from lambda. -removeLambdaWisdom :: RephraseOp (OpC rep) => Lambda (Wise rep) -> Lambda rep +removeLambdaWisdom :: (RephraseOp (OpC rep)) => Lambda (Wise rep) -> Lambda rep removeLambdaWisdom = runIdentity . rephraseLambda removeWisdom -- | Remove simplifier information from body. -removeBodyWisdom :: RephraseOp (OpC rep) => Body (Wise rep) -> Body rep +removeBodyWisdom :: (RephraseOp (OpC rep)) => Body (Wise rep) -> Body rep removeBodyWisdom = runIdentity . rephraseBody removeWisdom -- | Remove simplifier information from expression. -removeExpWisdom :: RephraseOp (OpC rep) => Exp (Wise rep) -> Exp rep +removeExpWisdom :: (RephraseOp (OpC rep)) => Exp (Wise rep) -> Exp rep removeExpWisdom = runIdentity . rephraseExp removeWisdom -- | Remove simplifier information from pattern. @@ -219,7 +219,7 @@ -- | Add simplifier information to pattern. addWisdomToPat :: - Informing rep => + (Informing rep) => Pat (LetDec rep) -> Exp (Wise rep) -> Pat (LetDec (Wise rep)) @@ -230,7 +230,7 @@ -- | Produce a body with simplifier information. mkWiseBody :: - Informing rep => + (Informing rep) => BodyDec rep -> Stms (Wise rep) -> Result -> @@ -247,7 +247,7 @@ -- | Produce a statement with simplifier information. mkWiseStm :: - Informing rep => + (Informing rep) => Pat (LetDec rep) -> StmAux (ExpDec rep) -> Exp (Wise rep) -> @@ -258,7 +258,7 @@ -- | Produce simplifier information for an expression. mkWiseExpDec :: - Informing rep => + (Informing rep) => Pat (LetDec (Wise rep)) -> ExpDec rep -> Exp (Wise rep) -> @@ -299,36 +299,36 @@ -- | A type class for indicating that this operation can be lifted into the simplifier representation. class CanBeWise op where - addOpWisdom :: Informing rep => op rep -> op (Wise rep) + addOpWisdom :: (Informing rep) => op rep -> op (Wise rep) instance CanBeWise NoOp where addOpWisdom NoOp = NoOp -- | Construct a 'Wise' statement. -informStm :: Informing rep => Stm rep -> Stm (Wise rep) +informStm :: (Informing rep) => Stm rep -> Stm (Wise rep) informStm (Let pat aux e) = mkWiseStm pat aux $ informExp e -- | Construct 'Wise' statements. -informStms :: Informing rep => Stms rep -> Stms (Wise rep) +informStms :: (Informing rep) => Stms rep -> Stms (Wise rep) informStms = fmap informStm -- | Construct a 'Wise' body. -informBody :: Informing rep => Body rep -> Body (Wise rep) +informBody :: (Informing rep) => Body rep -> Body (Wise rep) informBody (Body dec stms res) = mkWiseBody dec (informStms stms) res -- | Construct a 'Wise' lambda. -informLambda :: Informing rep => Lambda rep -> Lambda (Wise rep) +informLambda :: (Informing rep) => Lambda rep -> Lambda (Wise rep) informLambda (Lambda ps body ret) = Lambda ps (informBody body) ret -- | Construct a 'Wise' expression. -informExp :: Informing rep => Exp rep -> Exp (Wise rep) +informExp :: (Informing rep) => Exp rep -> Exp (Wise rep) informExp (Match cond cases defbody (MatchDec ts ifsort)) = Match cond (map (fmap informBody) cases) (informBody defbody) (MatchDec ts ifsort) -informExp (DoLoop merge form loopbody) = +informExp (Loop merge form loopbody) = let form' = case form of ForLoop i it bound params -> ForLoop i it bound params WhileLoop cond -> WhileLoop cond - in DoLoop merge form' $ informBody loopbody + in Loop merge form' $ informBody loopbody informExp e = runIdentity $ mapExpM mapper e where mapper = @@ -344,6 +344,6 @@ } -- | Construct a 'Wise' function definition. -informFunDef :: Informing rep => FunDef rep -> FunDef (Wise rep) +informFunDef :: (Informing rep) => FunDef rep -> FunDef (Wise rep) informFunDef (FunDef entry attrs fname rettype params body) = FunDef entry attrs fname rettype params $ informBody body diff --git a/src/Futhark/Optimise/Simplify/Rule.hs b/src/Futhark/Optimise/Simplify/Rule.hs --- a/src/Futhark/Optimise/Simplify/Rule.hs +++ b/src/Futhark/Optimise/Simplify/Rule.hs @@ -23,7 +23,7 @@ RuleGeneric, RuleBasicOp, RuleMatch, - RuleDoLoop, + RuleLoop, -- * Top-down rules TopDown, @@ -31,7 +31,7 @@ TopDownRuleGeneric, TopDownRuleBasicOp, TopDownRuleMatch, - TopDownRuleDoLoop, + TopDownRuleLoop, TopDownRuleOp, -- * Bottom-up rules @@ -40,7 +40,7 @@ BottomUpRuleGeneric, BottomUpRuleBasicOp, BottomUpRuleMatch, - BottomUpRuleDoLoop, + BottomUpRuleLoop, BottomUpRuleOp, -- * Assembling rules @@ -125,7 +125,7 @@ ) -> Rule rep -type RuleDoLoop rep a = +type RuleLoop rep a = a -> Pat (LetDec rep) -> StmAux (ExpDec rep) -> @@ -148,7 +148,7 @@ = RuleGeneric (RuleGeneric rep a) | RuleBasicOp (RuleBasicOp rep a) | RuleMatch (RuleMatch rep a) - | RuleDoLoop (RuleDoLoop rep a) + | RuleLoop (RuleLoop rep a) | RuleOp (RuleOp rep a) -- | A collection of rules grouped by which forms of statements they @@ -157,7 +157,7 @@ { rulesAny :: [SimplificationRule rep a], rulesBasicOp :: [SimplificationRule rep a], rulesMatch :: [SimplificationRule rep a], - rulesDoLoop :: [SimplificationRule rep a], + rulesLoop :: [SimplificationRule rep a], rulesOp :: [SimplificationRule rep a] } @@ -178,7 +178,7 @@ type TopDownRuleMatch rep = RuleMatch rep (TopDown rep) -type TopDownRuleDoLoop rep = RuleDoLoop rep (TopDown rep) +type TopDownRuleLoop rep = RuleLoop rep (TopDown rep) type TopDownRuleOp rep = RuleOp rep (TopDown rep) @@ -194,7 +194,7 @@ type BottomUpRuleMatch rep = RuleMatch rep (BottomUp rep) -type BottomUpRuleDoLoop rep = RuleDoLoop rep (BottomUp rep) +type BottomUpRuleLoop rep = RuleLoop rep (BottomUp rep) type BottomUpRuleOp rep = RuleOp rep (BottomUp rep) @@ -232,7 +232,7 @@ { rulesAny = rs, rulesBasicOp = filter forBasicOp rs, rulesMatch = filter forMatch rs, - rulesDoLoop = filter forDoLoop rs, + rulesLoop = filter forLoop rs, rulesOp = filter forOp rs } @@ -244,9 +244,9 @@ forMatch RuleGeneric {} = True forMatch _ = False - forDoLoop RuleDoLoop {} = True - forDoLoop RuleGeneric {} = True - forDoLoop _ = False + forLoop RuleLoop {} = True + forLoop RuleGeneric {} = True + forLoop _ = False forOp RuleOp {} = True forOp RuleGeneric {} = True @@ -280,7 +280,7 @@ rulesForStm :: Stm rep -> Rules rep a -> [SimplificationRule rep a] rulesForStm stm = case stmExp stm of BasicOp {} -> rulesBasicOp - DoLoop {} -> rulesDoLoop + Loop {} -> rulesLoop Op {} -> rulesOp Match {} -> rulesMatch _ -> rulesAny @@ -288,7 +288,7 @@ applyRule :: SimplificationRule rep a -> a -> Stm rep -> Rule rep applyRule (RuleGeneric f) a stm = f a stm applyRule (RuleBasicOp f) a (Let pat aux (BasicOp e)) = f a pat aux e -applyRule (RuleDoLoop f) a (Let pat aux (DoLoop merge form body)) = +applyRule (RuleLoop f) a (Let pat aux (Loop merge form body)) = f a pat aux (merge, form, body) applyRule (RuleMatch f) a (Let pat aux (Match cond cases defbody ifsort)) = f a pat aux (cond, cases, defbody, ifsort) 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 @@ -35,7 +35,7 @@ import Futhark.Optimise.Simplify.Rules.Match import Futhark.Util -topDownRules :: BuilderOps rep => [TopDownRule rep] +topDownRules :: (BuilderOps rep) => [TopDownRule rep] topDownRules = [ RuleGeneric constantFoldPrimFun, RuleGeneric withAccTopDown, @@ -62,7 +62,7 @@ -- statement and it can be consumed. -- -- This simplistic rule is only valid before we introduce memory. -removeUnnecessaryCopy :: BuilderOps rep => BottomUpRuleBasicOp rep +removeUnnecessaryCopy :: (BuilderOps rep) => BottomUpRuleBasicOp rep removeUnnecessaryCopy (vtable, used) (Pat [d]) aux (Replicate (Shape []) (Var v)) | not (v `UT.isConsumed` used), -- This two first clauses below are too conservative, but the @@ -95,7 +95,7 @@ pure True removeUnnecessaryCopy _ _ _ _ = Skip -constantFoldPrimFun :: BuilderOps rep => TopDownRuleGeneric rep +constantFoldPrimFun :: (BuilderOps rep) => TopDownRuleGeneric rep constantFoldPrimFun _ (Let pat (StmAux cs attrs _) (Apply fname args _ _)) | Just args' <- mapM (isConst . fst) args, Just (_, _, fun) <- M.lookup (nameToString fname) primFuns, @@ -114,7 +114,7 @@ -- | If an expression produces an array with a constant zero anywhere -- in its shape, just turn that into a Scratch. -emptyArrayToScratch :: BuilderOps rep => TopDownRuleGeneric rep +emptyArrayToScratch :: (BuilderOps rep) => TopDownRuleGeneric rep emptyArrayToScratch _ (Let pat@(Pat [pe]) aux e) | Just (pt, shape) <- isEmptyArray $ patElemType pe, not $ isScratch e = @@ -124,7 +124,7 @@ isScratch _ = False emptyArrayToScratch _ _ = Skip -simplifyIndex :: BuilderOps rep => BottomUpRuleBasicOp rep +simplifyIndex :: (BuilderOps rep) => BottomUpRuleBasicOp rep simplifyIndex (vtable, used) pat@(Pat [pe]) (StmAux cs attrs _) (Index idd inds) | Just m <- simplifyIndexing vtable seType idd inds consumed = Simplify $ certifying cs $ do @@ -140,7 +140,7 @@ seType (Constant v) = Just $ Prim $ primValueType v simplifyIndex _ _ _ _ = Skip -withAccTopDown :: BuilderOps rep => TopDownRuleGeneric rep +withAccTopDown :: (BuilderOps rep) => TopDownRuleGeneric rep -- A WithAcc with no accumulators is sent to Valhalla. withAccTopDown _ (Let pat aux (WithAcc [] lam)) = Simplify . auxing aux $ do lam_res <- bodyBind $ lambdaBody lam @@ -219,7 +219,7 @@ onExp = mapExpM mapper where mapper = - (identityMapper :: forall m. Monad m => Mapper rep rep m) + (identityMapper :: forall m. (Monad m) => Mapper rep rep m) { mapOnOp = traverseOpStms (\_ stms -> onStms stms), mapOnBody = \_ body -> onBody body } 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 @@ -44,7 +44,7 @@ (ArgVar v, mempty) fromConcatArg :: - MonadBuilder m => + (MonadBuilder m) => Type -> (ConcatArg, Certs) -> m VName @@ -75,7 +75,7 @@ fuseConcatArg xs y = y : xs -simplifyConcat :: BuilderOps rep => BottomUpRuleBasicOp rep +simplifyConcat :: (BuilderOps rep) => BottomUpRuleBasicOp rep -- concat@1(transpose(x),transpose(y)) == transpose(concat@0(x,y)) simplifyConcat (vtable, _) pat _ (Concat i (x :| xs) new_d) | Just r <- arrayRank <$> ST.lookupType x vtable, @@ -144,7 +144,7 @@ forSingleArray ys = ys simplifyConcat _ _ _ _ = Skip -ruleBasicOp :: BuilderOps rep => TopDownRuleBasicOp rep +ruleBasicOp :: (BuilderOps rep) => TopDownRuleBasicOp rep ruleBasicOp vtable pat aux op | Just (op', cs) <- applySimpleRules defOf seType op = Simplify $ certifying (cs <> stmAuxCerts aux) $ letBind pat $ BasicOp op' @@ -330,6 +330,11 @@ | isCt0 y, maybe False ST.entryIsSize $ ST.lookup x vtable = Simplify $ auxing aux $ letBind pat $ BasicOp $ SubExp $ constant False +-- Simplify away 0<=y when 'y' has been used as array size. +ruleBasicOp vtable pat aux (CmpOp CmpSle {} x (Var y)) + | isCt0 x, + maybe False ST.entryIsSize $ ST.lookup y vtable = + Simplify $ auxing aux $ letBind pat $ BasicOp $ SubExp $ constant True -- Remove certificates for variables whose definition already contain -- that certificate. ruleBasicOp vtable pat aux (SubExp (Var v)) @@ -351,24 +356,26 @@ Just (_, _, Just (_, ne)) <- ST.entryAccInput =<< ST.lookup token vtable, vs == ne = Simplify . auxing aux $ letBind pat $ BasicOp $ SubExp $ Var acc --- Manifest of a a copy can be simplified to manifesting the original --- array, if it is still available. +-- Manifest of a a copy (or another Manifest) can be simplified to +-- manifesting the original array, if it is still available. ruleBasicOp vtable pat aux (Manifest perm v1) | Just (Replicate (Shape []) (Var v2), cs) <- ST.lookupBasicOp v1 vtable, ST.available v2 vtable = - Simplify . auxing aux . certifying cs $ - letBind pat $ - BasicOp $ - Manifest perm v2 + Simplify . auxing aux . certifying cs . letBind pat . BasicOp $ + Manifest perm v2 + | Just (Manifest _ v2, cs) <- ST.lookupBasicOp v1 vtable, + ST.available v2 vtable = + Simplify . auxing aux . certifying cs . letBind pat . BasicOp $ + Manifest perm v2 ruleBasicOp _ _ _ _ = Skip -topDownRules :: BuilderOps rep => [TopDownRule rep] +topDownRules :: (BuilderOps rep) => [TopDownRule rep] topDownRules = [ RuleBasicOp ruleBasicOp ] -bottomUpRules :: BuilderOps rep => [BottomUpRule rep] +bottomUpRules :: (BuilderOps rep) => [BottomUpRule rep] bottomUpRules = [ RuleBasicOp simplifyConcat ] diff --git a/src/Futhark/Optimise/Simplify/Rules/ClosedForm.hs b/src/Futhark/Optimise/Simplify/Rules/ClosedForm.hs --- a/src/Futhark/Optimise/Simplify/Rules/ClosedForm.hs +++ b/src/Futhark/Optimise/Simplify/Rules/ClosedForm.hs @@ -118,7 +118,7 @@ knownBnds = M.fromList $ zip mergenames mergeexp checkResults :: - BuilderOps rep => + (BuilderOps rep) => [VName] -> SubExp -> Names -> diff --git a/src/Futhark/Optimise/Simplify/Rules/Index.hs b/src/Futhark/Optimise/Simplify/Rules/Index.hs --- a/src/Futhark/Optimise/Simplify/Rules/Index.hs +++ b/src/Futhark/Optimise/Simplify/Rules/Index.hs @@ -33,7 +33,7 @@ -- | Try to simplify an index operation. simplifyIndexing :: - MonadBuilder m => + (MonadBuilder m) => ST.SymbolTable (Rep m) -> TypeLookup -> VName -> diff --git a/src/Futhark/Optimise/Simplify/Rules/Loop.hs b/src/Futhark/Optimise/Simplify/Rules/Loop.hs --- a/src/Futhark/Optimise/Simplify/Rules/Loop.hs +++ b/src/Futhark/Optimise/Simplify/Rules/Loop.hs @@ -24,7 +24,7 @@ -- I do not claim that the current implementation of this rule is -- perfect, but it should suffice for many cases, and should never -- generate wrong code. -removeRedundantMergeVariables :: BuilderOps rep => BottomUpRuleDoLoop rep +removeRedundantMergeVariables :: (BuilderOps rep) => BottomUpRuleLoop rep removeRedundantMergeVariables (_, used) pat aux (merge, form, body) | not $ all (usedAfterLoop . fst) merge = let necessaryForReturned = @@ -63,7 +63,7 @@ body'' <- insertStmsM $ do mapM_ (uncurry letBindNames) $ dummyStms discard_val pure body' - auxing aux $ letBind pat' $ DoLoop merge' form body'' + auxing aux $ letBind pat' $ Loop merge' form body'' where pat_used = map (`UT.isUsedDirectly` used) $ patNames pat used_vals = map fst $ filter snd $ zip (map (paramName . fst) merge) pat_used @@ -85,7 +85,7 @@ -- We may change the type of the loop if we hoist out a shape -- annotation, in which case we also need to tweak the bound pattern. -hoistLoopInvariantMergeVariables :: BuilderOps rep => TopDownRuleDoLoop rep +hoistLoopInvariantMergeVariables :: (BuilderOps rep) => TopDownRuleLoop rep hoistLoopInvariantMergeVariables vtable pat aux (merge, form, loopbody) = do -- Figure out which of the elements of loopresult are -- loop-invariant, and hoist them out. @@ -101,7 +101,7 @@ explpat'' = map fst explpat' forM_ invariant $ \(v1, (v2, cs)) -> certifying cs $ letBindNames [identName v1] $ BasicOp $ SubExp v2 - letBind (Pat explpat'') $ DoLoop merge' form loopbody' + letBind (Pat explpat'') $ Loop merge' form loopbody' where res = bodyResult loopbody @@ -118,8 +118,6 @@ (pat_name, (mergeParam, mergeInit), resExp) (invariant, explpat', merge', resExps) | isInvariant, - -- Also do not remove the condition in a while-loop. - paramName mergeParam `notNameIn` freeIn form, -- Certificates must be available. all (`ST.elem` vtable) $ unCerts $ resCerts resExp = let (stm, explpat'') = @@ -174,12 +172,12 @@ (name `notNameIn` namesOfMergeParams) || (name `nameIn` namesOfInvariant) -simplifyClosedFormLoop :: BuilderOps rep => TopDownRuleDoLoop rep +simplifyClosedFormLoop :: (BuilderOps rep) => TopDownRuleLoop rep simplifyClosedFormLoop _ pat _ (val, ForLoop i it bound [], body) = Simplify $ loopClosedForm pat val (oneName i) it bound body simplifyClosedFormLoop _ _ _ _ = Skip -simplifyLoopVariables :: (BuilderOps rep, Aliased rep) => TopDownRuleDoLoop rep +simplifyLoopVariables :: (BuilderOps rep, Aliased rep) => TopDownRuleLoop rep simplifyLoopVariables vtable pat aux (merge, form@(ForLoop i it num_iters loop_vars), body) | simplifiable <- map checkIfSimplifiable loop_vars, not $ all isNothing simplifiable = Simplify $ do @@ -195,7 +193,7 @@ addStms $ mconcat body_prefix_stms bodyBind body let form' = ForLoop i it num_iters $ catMaybes maybe_loop_vars - auxing aux $ letBind pat $ DoLoop merge form' body' + auxing aux $ letBind pat $ Loop merge form' body' where seType (Var v) | v == i = Just $ Prim $ IntType it @@ -246,7 +244,7 @@ simplifyLoopVariables _ _ _ _ = Skip unroll :: - BuilderOps rep => + (BuilderOps rep) => Integer -> [(FParam rep, SubExpRes)] -> (VName, IntType, Integer) -> @@ -277,7 +275,7 @@ let merge' = zip (map fst merge) $ bodyResult iter_body' unroll n merge' (iv, it, i + 1) loop_vars body -simplifyKnownIterationLoop :: BuilderOps rep => TopDownRuleDoLoop rep +simplifyKnownIterationLoop :: (BuilderOps rep) => TopDownRuleLoop rep simplifyKnownIterationLoop _ pat aux (merge, ForLoop i it (Constant iters) loop_vars, body) | IntValue n <- iters, zeroIshInt n || oneIshInt n || "unroll" `inAttrs` stmAuxAttrs aux = Simplify $ do @@ -289,15 +287,15 @@ topDownRules :: (BuilderOps rep, Aliased rep) => [TopDownRule rep] topDownRules = - [ RuleDoLoop hoistLoopInvariantMergeVariables, - RuleDoLoop simplifyClosedFormLoop, - RuleDoLoop simplifyKnownIterationLoop, - RuleDoLoop simplifyLoopVariables + [ RuleLoop hoistLoopInvariantMergeVariables, + RuleLoop simplifyClosedFormLoop, + RuleLoop simplifyKnownIterationLoop, + RuleLoop simplifyLoopVariables ] -bottomUpRules :: BuilderOps rep => [BottomUpRule rep] +bottomUpRules :: (BuilderOps rep) => [BottomUpRule rep] bottomUpRules = - [ RuleDoLoop removeRedundantMergeVariables + [ RuleLoop removeRedundantMergeVariables ] -- | Standard loop simplification rules. 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 @@ -28,7 +28,7 @@ impossible (Constant v1) (Just v2) = v1 /= v2 impossible _ _ = False -ruleMatch :: BuilderOps rep => TopDownRuleMatch rep +ruleMatch :: (BuilderOps rep) => TopDownRuleMatch rep -- Remove impossible cases. ruleMatch _ pat _ (cond, cases, defbody, ifdec) | (impossible, cases') <- partition (caseNeverMatches cond) cases, @@ -135,7 +135,7 @@ -- | Move out results of a conditional expression whose computation is -- either invariant to the branches (only done for results used for -- existentials), or the same in both branches. -hoistBranchInvariant :: BuilderOps rep => TopDownRuleMatch rep +hoistBranchInvariant :: (BuilderOps rep) => TopDownRuleMatch rep hoistBranchInvariant _ pat _ (cond, cases, defbody, MatchDec ret ifsort) = let case_reses = map (bodyResult . caseBody) cases defbody_res = bodyResult defbody @@ -211,7 +211,7 @@ -- after a branch. Standard dead code removal can remove the branch -- if *none* of the return values are used, but this rule is more -- precise. -removeDeadBranchResult :: BuilderOps rep => BottomUpRuleMatch rep +removeDeadBranchResult :: (BuilderOps rep) => BottomUpRuleMatch rep removeDeadBranchResult (_, used) pat _ (cond, cases, defbody, MatchDec rettype ifsort) | -- Only if there is no existential binding... all (`notNameIn` foldMap freeIn (patElems pat)) (patNames pat), @@ -234,7 +234,7 @@ where onBody pick (Body _ stms res) = mkBodyM stms $ pick res -topDownRules :: BuilderOps rep => [TopDownRule rep] +topDownRules :: (BuilderOps rep) => [TopDownRule rep] topDownRules = [ RuleMatch ruleMatch, RuleMatch hoistBranchInvariant diff --git a/src/Futhark/Optimise/Sink.hs b/src/Futhark/Optimise/Sink.hs --- a/src/Futhark/Optimise/Sink.hs +++ b/src/Futhark/Optimise/Sink.hs @@ -76,7 +76,7 @@ -- | Given a statement, compute how often each of its free variables -- are used. Not accurate: what we care about are only 1, and greater -- than 1. -multiplicity :: Constraints rep => Stm rep -> M.Map VName Int +multiplicity :: (Constraints rep) => Stm rep -> M.Map VName Int multiplicity stm = case stmExp stm of Match cond cases defbody _ -> @@ -85,14 +85,14 @@ : free 1 defbody : map (free 1 . caseBody) cases Op {} -> free 2 stm - DoLoop {} -> free 2 stm + Loop {} -> free 2 stm _ -> free 1 stm where - free k x = M.fromList $ zip (namesToList $ freeIn x) $ repeat k + free k x = M.fromList $ map (,k) $ namesToList $ freeIn x comb = M.unionWith (+) optimiseBranch :: - Constraints rep => + (Constraints rep) => Sinker rep (Op rep) -> Sinker rep (Body rep) optimiseBranch onOp vtable sinking (Body dec stms res) = @@ -111,7 +111,7 @@ sunk = namesFromList $ foldMap (patNames . stmPat) sunk_stms optimiseLoop :: - Constraints rep => + (Constraints rep) => Sinker rep (Op rep) -> Sinker rep ([(FParam rep, SubExp)], LoopForm rep, Body rep) optimiseLoop onOp vtable sinking (merge, form, body0) @@ -144,7 +144,7 @@ in stm <| stms optimiseStms :: - Constraints rep => + (Constraints rep) => Sinker rep (Op rep) -> SymbolTable rep -> Sinking rep -> @@ -159,7 +159,7 @@ multiplicities = foldl' (M.unionWith (+)) - (M.fromList (zip (namesToList free_in_res) (repeat 1))) + (M.fromList (map (,1) (namesToList free_in_res))) (map multiplicity $ stmsToList all_stms) optimiseStms' _ _ [] = ([], mempty) @@ -183,13 +183,13 @@ in ( stm {stmExp = Match cond cases' defbody' ret} : stms', mconcat cases_sunk <> defbody_sunk <> sunk ) - | DoLoop merge lform body <- stmExp stm = + | Loop merge lform body <- stmExp stm = let comps = (merge, lform, body) (comps', loop_sunk) = optimiseLoop onOp vtable sinking comps (merge', lform', body') = comps' (stms', stms_sunk) = optimiseStms' vtable' sinking stms - in ( stm {stmExp = DoLoop merge' lform' body'} : stms', + in ( stm {stmExp = Loop merge' lform' body'} : stms', stms_sunk <> loop_sunk ) | Op op <- stmExp stm = @@ -220,7 +220,7 @@ } optimiseBody :: - Constraints rep => + (Constraints rep) => Sinker rep (Op rep) -> Sinker rep (Body rep) optimiseBody onOp vtable sinking (Body attr stms res) = @@ -228,7 +228,7 @@ in (Body attr stms' res, sunk) optimiseKernelBody :: - Constraints rep => + (Constraints rep) => Sinker rep (Op rep) -> Sinker rep (KernelBody rep) optimiseKernelBody onOp vtable sinking (KernelBody attr stms res) = @@ -236,7 +236,7 @@ in (KernelBody attr stms' res, sunk) optimiseSegOp :: - Constraints rep => + (Constraints rep) => Sinker rep (Op rep) -> Sinker rep (SegOp lvl rep) optimiseSegOp onOp vtable sinking op = diff --git a/src/Futhark/Optimise/TileLoops.hs b/src/Futhark/Optimise/TileLoops.hs --- a/src/Futhark/Optimise/TileLoops.hs +++ b/src/Futhark/Optimise/TileLoops.hs @@ -164,7 +164,7 @@ poststms' stms_res -- Tiling inside for-loop. - | DoLoop merge (ForLoop i it bound []) loopbody <- stmExp stm_to_tile, + | Loop merge (ForLoop i it bound []) loopbody <- stmExp stm_to_tile, not $ any ((`nameIn` freeIn merge) . paramName . fst) merge, Just (prestms', poststms') <- preludeToPostlude variance prestms stm_to_tile (stmsFromList poststms) = do @@ -191,7 +191,7 @@ Nothing -> next Just tiled -> Just - <$> tileDoLoop + <$> tileLoop initial_space variance prestms' @@ -350,7 +350,7 @@ tiledBody private' (prelude_privstms <> privstms) -tileDoLoop :: +tileLoop :: SegSpace -> VarianceTable -> Stms GPU -> @@ -366,7 +366,7 @@ Stms GPU -> Result -> TileM (Stms GPU, Tiling, TiledBody) -tileDoLoop initial_space variance prestms used_in_body (host_stms, tiling, tiledBody) res_ts pat aux merge i it bound poststms poststms_res = do +tileLoop initial_space variance prestms used_in_body (host_stms, tiling, tiledBody) res_ts pat aux merge i it bound poststms poststms_res = do let prestms_used = used_in_body <> freeIn poststms <> freeIn poststms_res ( invariant_prestms, precomputed_variant_prestms, @@ -432,7 +432,7 @@ resultBody . map Var <$> tiledBody private' privstms' accs' <- letTupExp "tiled_inside_loop" $ - DoLoop merge' (ForLoop i it bound []) loopbody' + Loop merge' (ForLoop i it bound []) loopbody' postludeGeneric tiling (privstms <> inloop_privstms) pat accs' poststms poststms_res res_ts @@ -454,7 +454,7 @@ addStms prestms pure $ varsRes prestms_live -liveSet :: FreeIn a => Stms GPU -> a -> Names +liveSet :: (FreeIn a) => Stms GPU -> a -> Names liveSet stms after = namesFromList (concatMap (patNames . stmPat) stms) `namesIntersection` freeIn after @@ -508,7 +508,7 @@ -- The atual tile size may be smaller for the last tile, so we have to -- be careful now. sliceUntiled :: - MonadBuilder m => + (MonadBuilder m) => VName -> SubExp -> SubExp -> @@ -713,7 +713,7 @@ ProcessTileArgs privstms red_comm red_lam map_lam tile accs (Var tile_id) resultBody . map Var <$> tilingProcessTile tiling tile_args - accs <- letTupExp "accs" $ DoLoop merge loopform loopbody + accs <- letTupExp "accs" $ Loop merge loopform loopbody -- We possibly have to traverse a residual tile. red_lam' <- renameLambda red_lam @@ -1049,7 +1049,7 @@ TileFull -> mapM readTileElem arrs_and_perms -findTileSize :: HasScope rep m => [InputTile] -> m SubExp +findTileSize :: (HasScope rep m) => [InputTile] -> m SubExp findTileSize tiles = case mapMaybe isTiled tiles of v : _ -> arraySize 0 <$> lookupType v diff --git a/src/Futhark/Optimise/TileLoops/Shared.hs b/src/Futhark/Optimise/TileLoops/Shared.hs --- a/src/Futhark/Optimise/TileLoops/Shared.hs +++ b/src/Futhark/Optimise/TileLoops/Shared.hs @@ -36,13 +36,13 @@ -- index an array with indices given in outer_indices; any inner -- dims of arr not indexed by outer_indices are sliced entirely -index :: MonadBuilder m => String -> VName -> [VName] -> m VName +index :: (MonadBuilder m) => String -> VName -> [VName] -> m VName index se_desc arr outer_indices = do arr_t <- lookupType arr let slice = fullSlice arr_t $ map (DimFix . Var) outer_indices letExp se_desc $ BasicOp $ Index arr slice -update :: MonadBuilder m => String -> VName -> [VName] -> SubExp -> m VName +update :: (MonadBuilder m) => String -> VName -> [VName] -> SubExp -> m VName update se_desc arr indices new_elem = letExp se_desc $ BasicOp $ Update Unsafe arr (Slice $ map (DimFix . Var) indices) new_elem @@ -67,7 +67,7 @@ map paramName loop_inits letTupExp "loop" $ - DoLoop (zip loop_inits $ map Var merge) loop_form loop_body + Loop (zip loop_inits $ map Var merge) loop_form loop_body forLoop :: SubExp -> diff --git a/src/Futhark/Optimise/Unstream.hs b/src/Futhark/Optimise/Unstream.hs --- a/src/Futhark/Optimise/Unstream.hs +++ b/src/Futhark/Optimise/Unstream.hs @@ -43,7 +43,7 @@ data Stage = SeqStreams | SeqAll unstream :: - ASTRep rep => + (ASTRep rep) => (Stage -> OnOp rep) -> (Prog rep -> PassM (Prog rep)) -> Pass rep rep @@ -64,7 +64,7 @@ Pat (LetDec rep) -> StmAux (ExpDec rep) -> Op rep -> UnstreamM rep [Stm rep] optimiseStms :: - ASTRep rep => + (ASTRep rep) => OnOp rep -> Stms rep -> UnstreamM rep (Stms rep) @@ -73,7 +73,7 @@ stmsFromList . concat <$> mapM (optimiseStm onOp) (stmsToList stms) optimiseBody :: - ASTRep rep => + (ASTRep rep) => OnOp rep -> Body rep -> UnstreamM rep (Body rep) @@ -81,7 +81,7 @@ Body aux <$> optimiseStms onOp stms <*> pure res optimiseKernelBody :: - ASTRep rep => + (ASTRep rep) => OnOp rep -> KernelBody rep -> UnstreamM rep (KernelBody rep) @@ -92,7 +92,7 @@ <*> pure res optimiseLambda :: - ASTRep rep => + (ASTRep rep) => OnOp rep -> Lambda rep -> UnstreamM rep (Lambda rep) @@ -101,7 +101,7 @@ pure lam {lambdaBody = body} optimiseStm :: - ASTRep rep => + (ASTRep rep) => OnOp rep -> Stm rep -> UnstreamM rep [Stm rep] @@ -117,7 +117,7 @@ } optimiseSegOp :: - ASTRep rep => + (ASTRep rep) => OnOp rep -> SegOp lvl rep -> UnstreamM rep (SegOp lvl rep) diff --git a/src/Futhark/Pass.hs b/src/Futhark/Pass.hs --- a/src/Futhark/Pass.hs +++ b/src/Futhark/Pass.hs @@ -36,7 +36,7 @@ -- | Execute a 'PassM' action, yielding logging information and either -- an error pretty or a result. runPassM :: - MonadFreshNames m => + (MonadFreshNames m) => PassM a -> m (a, Log) runPassM (PassM m) = modifyNameSource $ runState (runWriterT m) diff --git a/src/Futhark/Pass/ExpandAllocations.hs b/src/Futhark/Pass/ExpandAllocations.hs --- a/src/Futhark/Pass/ExpandAllocations.hs +++ b/src/Futhark/Pass/ExpandAllocations.hs @@ -219,7 +219,8 @@ let user = (lvl, [le64 $ segFlat space]) (kbody', kbody_allocs) = extractKernelBodyAllocations user bound_outside bound_in_kernel kbody - (ops', ops_allocs) = unzip $ map (extractLambdaAllocations user bound_outside mempty) ops + (ops', ops_allocs) = + unzip $ map (extractLambdaAllocations user bound_outside mempty) ops variantAlloc (_, Var v, _) = v `notNameIn` bound_outside variantAlloc _ = False (variant_allocs, invariant_allocs) = @@ -247,10 +248,11 @@ then pure (mempty, (lvl, ops, kbody)) else do (lvl_stms, lvl', grid) <- ensureGridKnown lvl - allocsForBody variant_allocs invariant_allocs grid space kbody kbody' $ \alloc_stms kbody'' -> do - ops'' <- forM ops' $ \op' -> - localScope (scopeOf op') $ offsetMemoryInLambda op' - pure (lvl_stms <> alloc_stms, (lvl', ops'', kbody'')) + allocsForBody variant_allocs invariant_allocs grid space kbody kbody' $ + \alloc_stms kbody'' -> do + ops'' <- forM ops' $ \op' -> + localScope (scopeOf op') $ offsetMemoryInLambda op' + pure (lvl_stms <> alloc_stms, (lvl', ops'', kbody'')) where bound_in_kernel = namesFromList (M.keys $ scopeOfSegSpace space) @@ -320,9 +322,11 @@ num_threads_stms <> invariant_alloc_stms <> variant_alloc_stms ) +type Exp64 = TPrimExp Int64 VName + -- | Identifying the spot where an allocation occurs in terms of its -- level and unique thread ID. -type User = (SegLevel, [TPrimExp Int64 VName]) +type User = (SegLevel, [Exp64]) -- | A description of allocations that have been extracted, and how -- much memory (and which space) is needed. @@ -356,9 +360,12 @@ Names -> Lambda GPUMem -> (Lambda GPUMem, Extraction) -extractLambdaAllocations user bound_outside bound_kernel lam = (lam {lambdaBody = body'}, allocs) +extractLambdaAllocations user bound_outside bound_kernel lam = + (lam {lambdaBody = body'}, allocs) where - (body', allocs) = extractBodyAllocations user bound_outside bound_kernel $ lambdaBody lam + (body', allocs) = + extractBodyAllocations user bound_outside bound_kernel $ + lambdaBody lam extractGenericBodyAllocations :: User -> @@ -373,11 +380,9 @@ extractGenericBodyAllocations user bound_outside bound_kernel get_stms set_stms body = let bound_kernel' = bound_kernel <> boundByStms (get_stms body) (stms, allocs) = - runWriter $ - fmap catMaybes $ - mapM (extractStmAllocations user bound_outside bound_kernel') $ - stmsToList $ - get_stms body + runWriter . fmap catMaybes $ + mapM (extractStmAllocations user bound_outside bound_kernel') $ + stmsToList (get_stms body) in (set_stms (stmsFromList stms) body, allocs) expandable, notScalar :: Space -> Bool @@ -436,7 +441,8 @@ } onKernelBody user' body = do - let (body', allocs) = extractKernelBodyAllocations user' bound_outside bound_kernel body + let (body', allocs) = + extractKernelBodyAllocations user' bound_outside bound_kernel body tell allocs pure body' @@ -445,7 +451,7 @@ pure lam {lambdaBody = body} genericExpandedInvariantAllocations :: - (User -> (Shape, [TPrimExp Int64 VName])) -> Extraction -> ExpandM (Stms GPUMem, RebaseMap) + (User -> (Shape, [Exp64])) -> Extraction -> ExpandM (Stms GPUMem, RebaseMap) genericExpandedInvariantAllocations getNumUsers invariant_allocs = do -- We expand the invariant allocations by adding an inner dimension -- equal to the number of kernel threads. @@ -462,29 +468,21 @@ letBind allocpat $ Op $ Alloc (Var total_size) space pure $ M.singleton mem $ newBase user - untouched d = DimSlice 0 d 1 - - newBaseThread user (old_shape, _) = + newBaseThread user _old_shape = let (users_shape, user_ids) = getNumUsers user - num_dims = length old_shape - perm = [num_dims .. num_dims + shapeRank users_shape - 1] ++ [0 .. num_dims - 1] - root_ixfun = IxFun.iota (old_shape ++ map pe64 (shapeDims users_shape)) - permuted_ixfun = IxFun.permute root_ixfun perm - offset_ixfun = - IxFun.slice permuted_ixfun $ - Slice $ - map DimFix user_ids ++ map untouched old_shape - in offset_ixfun + dims = map pe64 (shapeDims users_shape) + in ( flattenIndex dims user_ids, + product dims + ) newBase user@(SegThreadInGroup {}, _) = newBaseThread user newBase user@(SegThread {}, _) = newBaseThread user - newBase user@(SegGroup {}, _) = \(old_shape, _) -> + newBase user@(SegGroup {}, _) = \_old_shape -> let (users_shape, user_ids) = getNumUsers user - root_ixfun = IxFun.iota $ map pe64 (shapeDims users_shape) ++ old_shape - offset_ixfun = - IxFun.slice root_ixfun . Slice $ - map DimFix user_ids ++ map untouched old_shape - in offset_ixfun + dims = map pe64 (shapeDims users_shape) + in ( flattenIndex dims user_ids, + product dims + ) expandedInvariantAllocations :: SubExp -> @@ -524,10 +522,7 @@ let variant_allocs' :: [(VName, (SubExp, SubExp, Space))] variant_allocs' = concat $ - zipWith - memInfo - (map snd sizes_to_blocks) - (zip offsets size_sums) + zipWith memInfo (map snd sizes_to_blocks) (zip offsets size_sums) memInfo blocks (offset, total_size) = [(mem, (Var offset, Var total_size, space)) | (mem, space) <- blocks] @@ -547,20 +542,16 @@ num_threads' = pe64 num_threads gtid = le64 $ segFlat kspace - untouched d = DimSlice 0 d 1 - -- For the variant allocations, we add an inner dimension, -- which is then offset by a thread-specific amount. - newBase (old_shape, _pt) = - let root_ixfun = IxFun.iota $ old_shape ++ [num_threads'] - offset_ixfun = - IxFun.slice root_ixfun . Slice $ - map untouched old_shape ++ [DimFix gtid] - in offset_ixfun + newBase _old_shape = + (gtid, num_threads') --- | A map from memory block names to new index function bases. -type RebaseMap = M.Map VName (([TPrimExp Int64 VName], PrimType) -> IxFun) +type Expansion = (Exp64, Exp64) +-- | A map from memory block names to index function embeddings.. +type RebaseMap = M.Map VName ([Exp64] -> Expansion) + newtype OffsetM a = OffsetM ( ReaderT @@ -589,7 +580,7 @@ scope <- ask lift $ local f $ runReaderT m scope -lookupNewBase :: VName -> ([TPrimExp Int64 VName], PrimType) -> OffsetM (Maybe IxFun) +lookupNewBase :: VName -> [Exp64] -> OffsetM (Maybe Expansion) lookupNewBase name x = do offsets <- askRebaseMap pure $ ($ x) <$> M.lookup name offsets @@ -657,14 +648,18 @@ where onPE (PatElem name (MemArray pt shape u (ArrayIn mem _))) - (MemArray _ _ _ (Just (ReturnsNewBlock _ _ ixfun))) = - pure . PatElem name . MemArray pt shape u . ArrayIn mem $ - fmap (fmap unExt) ixfun + (MemArray _ _ _ info) + | Just ixfun <- getIxFun info = + pure . PatElem name . MemArray pt shape u . ArrayIn mem $ + fmap (fmap unExt) ixfun onPE pe _ = do new_dec <- offsetMemoryInMemBound (patElemName pe) $ patElemDec pe pure pe {patElemDec = new_dec} unExt (Ext i) = patElemName (pes !! i) unExt (Free v) = v + getIxFun (Just (ReturnsNewBlock _ _ ixfun)) = Just ixfun + getIxFun (Just (ReturnsInBlock _ ixfun)) = Just ixfun + getIxFun _ = Nothing offsetMemoryInParam :: Param (MemBound u) -> OffsetM (Param (MemBound u)) offsetMemoryInParam fparam = do @@ -673,42 +668,45 @@ offsetMemoryInMemBound :: VName -> MemBound u -> OffsetM (MemBound u) offsetMemoryInMemBound v summary@(MemArray pt shape u (ArrayIn mem ixfun)) = do - new_base <- lookupNewBase mem (IxFun.base ixfun, pt) - case new_base of + embedding <- lookupNewBase mem $ IxFun.shape ixfun + case embedding of Nothing -> pure summary - Just new_base' -> do + Just (o, p) -> do let problem = throwError . unlines $ [ "offsetMemoryInMemBound", prettyString v, - prettyString new_base', + prettyString (o, p), prettyString ixfun ] - ixfun' <- maybe problem pure $ IxFun.rebase new_base' ixfun + ixfun' <- maybe problem pure $ IxFun.expand o p ixfun pure $ MemArray pt shape u $ ArrayIn mem ixfun' offsetMemoryInMemBound _ summary = pure summary offsetMemoryInBodyReturns :: BodyReturns -> OffsetM BodyReturns offsetMemoryInBodyReturns br@(MemArray pt shape u (ReturnsInBlock mem ixfun)) | Just ixfun' <- isStaticIxFun ixfun = do - new_base <- lookupNewBase mem (IxFun.base ixfun', pt) - case new_base of + embedding <- lookupNewBase mem $ IxFun.shape ixfun' + case embedding of Nothing -> pure br - Just new_base' -> do + Just (o, p) -> do let problem = throwError . unlines $ [ "offsetMemoryInBodyReturns", - prettyString new_base', + prettyString (o, p), prettyString ixfun ] - ixfun'' <- maybe problem pure $ IxFun.rebase (fmap (fmap Free) new_base') ixfun + ixfun'' <- + maybe problem pure $ + IxFun.expand (Free <$> o) (fmap Free p) ixfun pure $ MemArray pt shape u $ ReturnsInBlock mem ixfun'' offsetMemoryInBodyReturns br = pure br offsetMemoryInLambda :: Lambda GPUMem -> OffsetM (Lambda GPUMem) -offsetMemoryInLambda lam = inScopeOf lam $ do - body <- offsetMemoryInBody $ lambdaBody lam - pure $ lam {lambdaBody = body} +offsetMemoryInLambda lam = do + body <- inScopeOf lam $ offsetMemoryInBody $ lambdaBody lam + params <- mapM offsetMemoryInParam $ lambdaParams lam + pure $ lam {lambdaBody = body, lambdaParams = params} -- A loop may have memory parameters, and those memory blocks may -- be expanded. We assume (but do not check - FIXME) that if the @@ -731,13 +729,13 @@ onParamArg rm _ = rm offsetMemoryInExp :: Exp GPUMem -> OffsetM (Exp GPUMem) -offsetMemoryInExp (DoLoop merge form body) = do +offsetMemoryInExp (Loop merge form body) = do offsetMemoryInLoopParams merge $ \merge' -> do body' <- localScope (scopeOfFParams (map fst merge') <> scopeOf form) (offsetMemoryInBody body) - pure $ DoLoop merge' form body' + pure $ Loop merge' form body' offsetMemoryInExp e = mapExpM recurse e where recurse = 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 @@ -130,7 +130,7 @@ askDefaultSpace = asks allocSpace runAllocM :: - MonadFreshNames m => + (MonadFreshNames m) => Space -> (Op fromrep -> AllocM fromrep torep (Op torep)) -> (Exp torep -> AllocM fromrep torep [ExpHint]) -> @@ -148,14 +148,14 @@ envExpHints = hints } -elemSize :: Num a => Type -> a +elemSize :: (Num a) => Type -> a elemSize = primByteSize . elemType arraySizeInBytesExp :: Type -> PrimExp VName arraySizeInBytesExp t = untyped $ foldl' (*) (elemSize t) $ map pe64 (arrayDims t) -arraySizeInBytesExpM :: MonadBuilder m => Type -> m (PrimExp VName) +arraySizeInBytesExpM :: (MonadBuilder m) => Type -> m (PrimExp VName) arraySizeInBytesExpM t = do let dim_prod_i64 = product $ map pe64 (arrayDims t) elm_size_i64 = elemSize t @@ -164,7 +164,7 @@ untyped $ dim_prod_i64 * elm_size_i64 -arraySizeInBytes :: MonadBuilder m => Type -> m SubExp +arraySizeInBytes :: (MonadBuilder m) => Type -> m SubExp arraySizeInBytes = letSubExp "bytes" <=< toExp <=< arraySizeInBytesExpM allocForArray' :: @@ -178,7 +178,7 @@ -- | Allocate memory for a value of the given type. allocForArray :: - Allocable fromrep torep inner => + (Allocable fromrep torep inner) => Type -> Space -> AllocM fromrep torep VName @@ -245,7 +245,7 @@ rts <- fromMaybe (error "patWithAllocations: ill-typed") <$> expReturns e Pat <$> allocsForPat def_space idents rts hints -mkMissingIdents :: MonadFreshNames m => [Ident] -> [ExpReturns] -> m [Ident] +mkMissingIdents :: (MonadFreshNames m) => [Ident] -> [ExpReturns] -> m [Ident] mkMissingIdents idents rts = reverse <$> zipWithM f (reverse rts) (map Just (reverse idents) ++ repeat Nothing) where @@ -301,7 +301,7 @@ inst (Free v) = v inst (Ext i) = getIdent idents i -instantiateIxFun :: Monad m => ExtIxFun -> m IxFun +instantiateIxFun :: (Monad m) => ExtIxFun -> m IxFun instantiateIxFun = traverse $ traverse inst where inst Ext {} = error "instantiateIxFun: not yet" @@ -377,8 +377,7 @@ mem_space <- lookupMemSpace mem default_space <- askDefaultSpace let space = fromMaybe default_space space_ok - if IxFun.permutation ixfun == [0 .. IxFun.rank ixfun - 1] - && length (IxFun.base ixfun) == IxFun.rank ixfun + if length (IxFun.base ixfun) == IxFun.rank ixfun && maybe True (== mem_space) space_ok then pure (mem, v) else allocLinearArray space (baseString v) v @@ -569,7 +568,6 @@ mem_space <- lookupMemSpace mem default_space <- askDefaultSpace if length (IxFun.base ixfun) == length (IxFun.shape ixfun) - && IxFun.permutation ixfun == perm && maybe True (== mem_space) space_ok then pure (mem, v) else allocPermArray (fromMaybe default_space space_ok) perm (baseString v) v @@ -630,7 +628,7 @@ allocInFun consts (FunDef entry attrs fname rettype params fbody) = runAllocM space handleOp hints . inScopeOf consts $ - allocInFParams (zip params $ repeat space) $ \params' -> do + allocInFParams (map (,space) params) $ \params' -> do (fbody', mem_rets) <- allocInFunBody (map (const $ Just space) rettype) fbody let num_extra_params = length params' - length params @@ -750,7 +748,7 @@ addStm =<< allocsForStm (map patElemIdent pes) =<< allocInExp e allocInLambda :: - Allocable fromrep torep inner => + (Allocable fromrep torep inner) => [LParam torep] -> Body fromrep -> AllocM fromrep torep (Lambda torep) @@ -758,14 +756,14 @@ mkLambda params . allocInStms (bodyStms body) $ pure $ bodyResult body data MemReq - = MemReq Space [Int] Rank + = MemReq Space Rank | NeedsNormalisation Space deriving (Eq, Show) combMemReqs :: MemReq -> MemReq -> MemReq combMemReqs x@NeedsNormalisation {} _ = x combMemReqs _ y@NeedsNormalisation {} = y -combMemReqs x@(MemReq x_space _ _) y@MemReq {} = +combMemReqs x@(MemReq x_space _) y@MemReq {} = if x == y then x else NeedsNormalisation x_space type MemReqType = MemInfo (Ext SubExp) NoUniqueness MemReq @@ -776,7 +774,7 @@ combMemReqTypes x _ = x contextRets :: MemReqType -> [MemInfo d u r] -contextRets (MemArray _ shape _ (MemReq space _ (Rank base_rank))) = +contextRets (MemArray _ shape _ (MemReq space (Rank base_rank))) = -- Memory + offset + base_rank + (stride,size)*rank. MemMem space : MemPrim int64 @@ -809,10 +807,7 @@ (Array pt shape u, MemArray _ _ _ (ArrayIn mem ixfun)) -> do space <- lookupMemSpace mem pure . MemArray pt shape u $ - MemReq - space - (IxFun.permutation ixfun) - (Rank $ length $ IxFun.base ixfun) + MemReq space (Rank $ length $ IxFun.base ixfun) (_, MemMem space) -> pure $ MemMem space (_, MemPrim pt) -> pure $ MemPrim pt (_, MemAcc acc ispace ts u) -> pure $ MemAcc acc ispace ts u @@ -834,15 +829,15 @@ ) arrayInfo rank (NeedsNormalisation space) = - (space, [0 .. rank - 1], rank) - arrayInfo _ (MemReq space perm (Rank base_rank)) = - (space, perm, base_rank) + (space, rank) + arrayInfo _ (MemReq space (Rank base_rank)) = + (space, base_rank) inspect ctx_offset (MemArray pt shape u req) = let shape' = fmap (adjustExt num_new_ctx) shape - (space, perm, base_rank) = arrayInfo (shapeRank shape) req + (space, base_rank) = arrayInfo (shapeRank shape) req in MemArray pt shape' u . ReturnsNewBlock space ctx_offset $ - convert <$> IxFun.mkExistential base_rank perm (ctx_offset + 1) + convert <$> IxFun.mkExistential base_rank (shapeRank shape) (ctx_offset + 1) inspect _ (MemAcc acc ispace ts u) = MemAcc acc ispace ts u inspect _ (MemPrim pt) = MemPrim pt inspect _ (MemMem space) = MemMem space @@ -891,7 +886,7 @@ -- Futhark.Optimise.EntryPointMem for a very specialised version of -- the idea, but which could perhaps be generalised. simplifyMatch :: - Mem rep inner => + (Mem rep inner) => [Case (Body rep)] -> Body rep -> [BranchTypeMem] -> @@ -932,7 +927,7 @@ (Allocable fromrep torep inner) => Exp fromrep -> AllocM fromrep torep (Exp torep) -allocInExp (DoLoop merge form (Body () bodystms bodyres)) = +allocInExp (Loop merge form (Body () bodystms bodyres)) = allocInMergeParams merge $ \merge' mk_loop_val -> do form' <- allocInLoopForm form localScope (scopeOf form') $ do @@ -940,7 +935,7 @@ buildBody_ . allocInStms bodystms $ do (valctx, valres') <- mk_loop_val $ map resSubExp bodyres pure $ subExpsRes valctx <> zipWith SubExpRes (map resCerts bodyres) valres' - pure $ DoLoop merge' form' body' + pure $ Loop merge' form' body' allocInExp (Apply fname args rettype loc) = do args' <- funcallArgs args space <- askDefaultSpace @@ -1062,11 +1057,11 @@ instance SizeSubst (NoOp rep) -instance SizeSubst (op rep) => SizeSubst (MemOp op rep) where +instance (SizeSubst (op rep)) => SizeSubst (MemOp op rep) where opIsConst (Inner op) = opIsConst op opIsConst _ = False -stmConsts :: SizeSubst (Op rep) => Stm rep -> S.Set VName +stmConsts :: (SizeSubst (Op rep)) => Stm rep -> S.Set VName stmConsts (Let pat _ (Op op)) | opIsConst op = S.fromList $ patNames pat stmConsts _ = mempty @@ -1113,7 +1108,7 @@ nohints = map (const NoHint) names simplifyMemOp :: - Engine.SimplifiableRep rep => + (Engine.SimplifiableRep rep) => ( inner (Engine.Wise rep) -> Engine.SimpleM rep (inner (Engine.Wise rep), Stms (Engine.Wise rep)) ) -> @@ -1144,7 +1139,7 @@ ) -> SimpleOps rep simplifiable innerUsage simplifyInnerOp = - SimpleOps mkExpDecS' mkBodyS' protectOp opUsage simplifyPat (simplifyMemOp simplifyInnerOp) + SimpleOps mkExpDecS' mkBodyS' protectOp opUsage (simplifyMemOp simplifyInnerOp) where mkExpDecS' _ pat e = pure $ Engine.mkWiseExpDec pat () e @@ -1167,26 +1162,6 @@ mempty opUsage (Inner inner) = innerUsage inner - - simplifyPat (Pat pes) e = do - rets <- fromMaybe (error "simplifyPat: ill-typed") <$> expReturns e - Pat <$> zipWithM update pes rets - where - names = map patElemName pes - update - (PatElem pe_v (MemArray pt shape u (ArrayIn mem _))) - (MemArray _ _ _ (Just (ReturnsInBlock _ ixfun))) - | Just ixfun' <- traverse (traverse inst) ixfun = - PatElem pe_v - <$> ( MemArray pt - <$> Engine.simplify shape - <*> pure u - <*> (ArrayIn <$> Engine.simplify mem <*> pure ixfun') - ) - where - inst (Ext i) = maybeNth i names - inst (Free v) = Just v - update pe _ = traverse Engine.simplify pe data ExpHint = NoHint diff --git a/src/Futhark/Pass/ExplicitAllocations/GPU.hs b/src/Futhark/Pass/ExplicitAllocations/GPU.hs --- a/src/Futhark/Pass/ExplicitAllocations/GPU.hs +++ b/src/Futhark/Pass/ExplicitAllocations/GPU.hs @@ -40,19 +40,25 @@ AllocM GPU GPUMem (SegOp SegLevel GPUMem) handleSegOp outer_lvl op = do num_threads <- - letSubExp "num_threads" - =<< case maybe_grid of - Just grid -> - pure . BasicOp $ - BinOp - (Mul Int64 OverflowUndef) - (unCount (gridNumGroups grid)) - (unCount (gridGroupSize grid)) - Nothing -> - foldBinOp - (Mul Int64 OverflowUndef) - (intConst Int64 1) - (segSpaceDims $ segSpace op) + case (outer_lvl, segLevel op) of + -- This implies we are in the intragroup parallelism situation. + -- Just allocate for a single group; memory expansion will + -- handle the rest later. + (Just (SegGroup _ (Just grid)), _) -> pure $ unCount $ gridGroupSize grid + _ -> + letSubExp "num_threads" + =<< case maybe_grid of + Just grid -> + pure . BasicOp $ + BinOp + (Mul Int64 OverflowUndef) + (unCount (gridNumGroups grid)) + (unCount (gridGroupSize grid)) + Nothing -> + foldBinOp + (Mul Int64 OverflowUndef) + (intConst Int64 1) + (segSpaceDims $ segSpace op) allocAtLevel (segLevel op) $ mapSegOpM (mapper num_threads) op where maybe_grid = diff --git a/src/Futhark/Pass/ExplicitAllocations/SegOp.hs b/src/Futhark/Pass/ExplicitAllocations/SegOp.hs --- a/src/Futhark/Pass/ExplicitAllocations/SegOp.hs +++ b/src/Futhark/Pass/ExplicitAllocations/SegOp.hs @@ -15,7 +15,7 @@ instance SizeSubst (SegOp lvl rep) allocInKernelBody :: - Allocable fromrep torep inner => + (Allocable fromrep torep inner) => KernelBody fromrep -> AllocM fromrep torep (KernelBody torep) allocInKernelBody (KernelBody () stms res) = @@ -23,7 +23,7 @@ <$> collectStms (allocInStms stms (pure res)) allocInLambda :: - Allocable fromrep torep inner => + (Allocable fromrep torep inner) => [LParam torep] -> Body fromrep -> AllocM fromrep torep (Lambda torep) @@ -33,7 +33,7 @@ bodyResult body allocInBinOpParams :: - Allocable fromrep torep inner => + (Allocable fromrep torep inner) => SubExp -> TPrimExp Int64 VName -> TPrimExp Int64 VName -> @@ -45,11 +45,10 @@ alloc x y = case paramType x of Array pt shape u -> do + let name = maybe "num_threads" baseString (subExpVar num_threads) twice_num_threads <- - letSubExp "twice_num_threads" $ - BasicOp $ - BinOp (Mul Int64 OverflowUndef) num_threads $ - intConst Int64 2 + letSubExp ("twice_" <> name) . BasicOp $ + BinOp (Mul Int64 OverflowUndef) num_threads (intConst Int64 2) let t = paramType x `arrayOfRow` twice_num_threads mem <- allocForArray t =<< askDefaultSpace -- XXX: this iota ixfun is a bit inefficient; leading to @@ -84,7 +83,7 @@ ) allocInBinOpLambda :: - Allocable fromrep torep inner => + (Allocable fromrep torep inner) => SubExp -> SegSpace -> Lambda fromrep -> 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 @@ -279,7 +279,7 @@ w `subExpBound` bound unbalancedStm _ Op {} = False - unbalancedStm _ DoLoop {} = False + unbalancedStm _ Loop {} = False unbalancedStm bound (WithAcc _ lam) = unbalancedBody bound (lambdaBody lam) unbalancedStm bound (Match ses cases defbody _) = @@ -363,9 +363,9 @@ where transformInput (shape, arrs, op) = (shape, arrs, fmap (first soacsLambdaToGPU) op) -transformStm path (Let pat aux (DoLoop merge form body)) = +transformStm path (Let pat aux (Loop merge form body)) = localScope (castScope (scopeOf form) <> scopeOfFParams params) $ - oneStm . Let pat aux . DoLoop merge form' <$> transformBody path body + oneStm . Let pat aux . Loop merge form' <$> transformBody path body where params = map fst merge form' = case form of @@ -432,7 +432,7 @@ if not (lambdaContainsParallelism map_lam) || "sequential_inner" - `inAttrs` stmAuxAttrs aux + `inAttrs` stmAuxAttrs aux then paralleliseOuter else do ((outer_suff, outer_suff_key), suff_stms) <- @@ -519,7 +519,7 @@ mapLike w lam' | Op (Scatter w _ lam' _) <- stmExp stm = mapLike w lam' - | DoLoop _ _ body <- stmExp stm = + | Loop _ _ body <- stmExp stm = bodyInterest body * 10 | Match _ cases defbody _ <- stmExp stm = foldl @@ -562,7 +562,7 @@ else bodyInterest (lambdaBody lam') | Op Scatter {} <- stmExp stm = 0 -- Basically a map. - | DoLoop _ ForLoop {} body <- stmExp stm = + | Loop _ ForLoop {} body <- stmExp stm = bodyInterest body * 10 | WithAcc _ withacc_lam <- stmExp stm = bodyInterest (lambdaBody withacc_lam) @@ -634,7 +634,7 @@ AttrComp "incremental_flattening" ["no_outer"] `inAttrs` attrs || AttrComp "incremental_flattening" ["only_inner"] - `inAttrs` attrs + `inAttrs` attrs mayExploitIntra :: Attrs -> Bool mayExploitIntra attrs = @@ -642,7 +642,7 @@ AttrComp "incremental_flattening" ["no_intra"] `inAttrs` attrs || AttrComp "incremental_flattening" ["only_inner"] - `inAttrs` attrs + `inAttrs` attrs -- The minimum amount of inner parallelism we require (by default) in -- intra-group versions. Less than this is usually pointless on a GPU diff --git a/src/Futhark/Pass/ExtractKernels/BlockedKernel.hs b/src/Futhark/Pass/ExtractKernels/BlockedKernel.hs --- a/src/Futhark/Pass/ExtractKernels/BlockedKernel.hs +++ b/src/Futhark/Pass/ExtractKernels/BlockedKernel.hs @@ -44,7 +44,7 @@ type MkSegLevel rep m = [SubExp] -> String -> ThreadRecommendation -> BuilderT rep m (SegOpLevel rep) -mkSegSpace :: MonadFreshNames m => [(VName, SubExp)] -> m SegSpace +mkSegSpace :: (MonadFreshNames m) => [(VName, SubExp)] -> m SegSpace mkSegSpace dims = SegSpace <$> newVName "phys_tid" <*> pure dims prepareRedOrScan :: @@ -127,7 +127,7 @@ SegMap lvl kspace (lambdaReturnType map_lam) kbody dummyDim :: - MonadBuilder m => + (MonadBuilder m) => Pat Type -> m (Pat Type, [(VName, SubExp)], m ()) dummyDim pat = do 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 @@ -57,7 +57,7 @@ import Futhark.Util import Futhark.Util.Log -scopeForSOACs :: SameScope rep SOACS => Scope rep -> Scope SOACS +scopeForSOACs :: (SameScope rep SOACS) => Scope rep -> Scope SOACS scopeForSOACs = castScope data MapLoop = MapLoop (Pat Type) (StmAux ()) SubExp (Lambda SOACS) [VName] @@ -104,7 +104,7 @@ instance Monoid (PostStms rep) where mempty = PostStms mempty -typeEnvFromDistAcc :: DistRep rep => DistAcc rep -> Scope rep +typeEnvFromDistAcc :: (DistRep rep) => DistAcc rep -> Scope rep typeEnvFromDistAcc = scopeOfPat . fst . outerTarget . distTargets addStmsToAcc :: Stms rep -> DistAcc rep -> DistAcc rep @@ -148,7 +148,7 @@ inner_scope <- askScope localScope (outer_scope `M.difference` inner_scope) m -instance MonadFreshNames m => MonadFreshNames (DistNestT rep m) where +instance (MonadFreshNames m) => MonadFreshNames (DistNestT rep m) where getNameSource = DistNestT $ lift getNameSource putNameSource = DistNestT . lift . putNameSource @@ -159,7 +159,7 @@ localScope types = local $ \env -> env {distScope = types <> distScope env} -instance Monad m => MonadLogger (DistNestT rep m) where +instance (Monad m) => MonadLogger (DistNestT rep m) where addLog msgs = tell mempty {accLog = msgs} runDistNestT :: @@ -194,10 +194,10 @@ certify cs . Let (Pat [pe]) (defAux ()) . BasicOp $ Replicate (Shape [loopNestingWidth outermost]) se -addPostStms :: Monad m => PostStms rep -> DistNestT rep m () +addPostStms :: (Monad m) => PostStms rep -> DistNestT rep m () addPostStms ks = tell $ mempty {accPostStms = ks} -postStm :: Monad m => Stms rep -> DistNestT rep m () +postStm :: (Monad m) => Stms rep -> DistNestT rep m () postStm stms = addPostStms $ PostStms stms withStm :: @@ -320,8 +320,8 @@ isMap BasicOp {} = False isMap Apply {} = False isMap Match {} = False - isMap (DoLoop _ ForLoop {} body) = bodyContainsParallelism body - isMap (DoLoop _ WhileLoop {} _) = False + isMap (Loop _ ForLoop {} body) = bodyContainsParallelism body + isMap (Loop _ WhileLoop {} _) = False isMap (WithAcc _ lam) = bodyContainsParallelism $ lambdaBody lam isMap Op {} = True @@ -349,12 +349,12 @@ -- situation that stm is in scope of itself. withStm stm $ maybeDistributeStm stm =<< onStms acc stms -onInnerMap :: Monad m => MapLoop -> DistAcc rep -> DistNestT rep m (DistAcc rep) +onInnerMap :: (Monad m) => MapLoop -> DistAcc rep -> DistNestT rep m (DistAcc rep) onInnerMap loop acc = do f <- asks distOnInnerMap f loop acc -onTopLevelStms :: Monad m => Stms SOACS -> DistNestT rep m () +onTopLevelStms :: (Monad m) => Stms SOACS -> DistNestT rep m () onTopLevelStms stms = do f <- asks distOnTopLevelStms postStm =<< f stms @@ -378,7 +378,7 @@ distributeIfPossible acc >>= \case Nothing -> addStmToAcc stm acc Just acc' -> distribute =<< onInnerMap (MapLoop pat (stmAux stm) w lam arrs) acc' -maybeDistributeStm stm@(Let pat aux (DoLoop merge form@ForLoop {} body)) acc +maybeDistributeStm stm@(Let pat aux (Loop merge form@ForLoop {} body)) acc | all (`notNameIn` freeIn (patTypes pat)) (patNames pat), bodyContainsParallelism body = distributeSingleStm acc stm >>= \case @@ -996,7 +996,7 @@ =<< segHist lvl orig_pat hist_w ispace inputs' ops' lam arrs determineReduceOp :: - MonadBuilder m => + (MonadBuilder m) => Lambda SOACS -> [SubExp] -> m (Lambda SOACS, [SubExp], Shape) @@ -1161,7 +1161,7 @@ -- Add extra pattern elements to every kernel nesting level. expandKernelNest :: - MonadFreshNames m => [PatElem Type] -> KernelNest -> m KernelNest + (MonadFreshNames m) => [PatElem Type] -> KernelNest -> m KernelNest expandKernelNest pes (outer_nest, inner_nests) = do let outer_size = loopNestingWidth outer_nest diff --git a/src/Futhark/Pass/ExtractKernels/Distribution.hs b/src/Futhark/Pass/ExtractKernels/Distribution.hs --- a/src/Futhark/Pass/ExtractKernels/Distribution.hs +++ b/src/Futhark/Pass/ExtractKernels/Distribution.hs @@ -108,10 +108,10 @@ x : xs -> Just (t, Targets x $ reverse xs) [] -> Nothing -targetScope :: DistRep rep => Target -> Scope rep +targetScope :: (DistRep rep) => Target -> Scope rep targetScope = scopeOfPat . fst -targetsScope :: DistRep rep => Targets -> Scope rep +targetsScope :: (DistRep rep) => Targets -> Scope rep targetsScope (Targets t ts) = mconcat $ map targetScope $ t : ts data LoopNesting = MapNesting @@ -225,7 +225,7 @@ kernelNestLoops :: KernelNest -> [LoopNesting] kernelNestLoops (loop, loops) = loop : loops -scopeOfKernelNest :: LParamInfo rep ~ Type => KernelNest -> Scope rep +scopeOfKernelNest :: (LParamInfo rep ~ Type) => KernelNest -> Scope rep scopeOfKernelNest = foldMap scopeOfLoopNesting . kernelNestLoops boundInKernelNest :: KernelNest -> Names @@ -248,7 +248,7 @@ constructKernel mk_lvl kernel_nest inner_body = runBuilderT' $ do (ispace, inps) <- flatKernel kernel_nest let aux = loopNestingAux first_nest - ispace_scope = M.fromList $ zip (map fst ispace) $ repeat $ IndexName Int64 + ispace_scope = M.fromList $ map ((,IndexName Int64) . fst) ispace pat = loopNestingPat first_nest rts = map (stripArray (length ispace)) $ patTypes pat @@ -273,7 +273,7 @@ -- -- (2) The kernel inputs - note that some of these may be unused. flatKernel :: - MonadFreshNames m => + (MonadFreshNames m) => KernelNest -> m ([(VName, SubExp)], [KernelInput]) flatKernel (MapNesting _ _ nesting_w params_and_arrs, []) = do @@ -319,7 +319,7 @@ distributionInnerPat = fst . innerTarget . distributionTarget distributionBodyFromStms :: - ASTRep rep => + (ASTRep rep) => Targets -> Stms rep -> (DistributionBody, Result) @@ -340,7 +340,7 @@ ) distributionBodyFromStm :: - ASTRep rep => + (ASTRep rep) => Targets -> Stm rep -> (DistributionBody, Result) diff --git a/src/Futhark/Pass/ExtractKernels/ISRWIM.hs b/src/Futhark/Pass/ExtractKernels/ISRWIM.hs --- a/src/Futhark/Pass/ExtractKernels/ISRWIM.hs +++ b/src/Futhark/Pass/ExtractKernels/ISRWIM.hs @@ -160,7 +160,7 @@ | otherwise = Nothing -transposedArrays :: MonadBuilder m => [VName] -> m [VName] +transposedArrays :: (MonadBuilder m) => [VName] -> m [VName] transposedArrays arrs = forM arrs $ \arr -> do t <- lookupType arr let perm = [1, 0] ++ [2 .. arrayRank t - 1] diff --git a/src/Futhark/Pass/ExtractKernels/Interchange.hs b/src/Futhark/Pass/ExtractKernels/Interchange.hs --- a/src/Futhark/Pass/ExtractKernels/Interchange.hs +++ b/src/Futhark/Pass/ExtractKernels/Interchange.hs @@ -41,7 +41,7 @@ seqLoopStm :: SeqLoop -> Stm SOACS seqLoopStm (SeqLoop _ pat merge form body) = - Let pat (defAux ()) $ DoLoop merge form body + Let pat (defAux ()) $ Loop merge form body interchangeLoop :: (MonadBuilder m, Rep m ~ SOACS) => diff --git a/src/Futhark/Pass/ExtractKernels/Intragroup.hs b/src/Futhark/Pass/ExtractKernels/Intragroup.hs --- a/src/Futhark/Pass/ExtractKernels/Intragroup.hs +++ b/src/Futhark/Pass/ExtractKernels/Intragroup.hs @@ -106,7 +106,7 @@ addStms w_stms read_input_stms <- runBuilder_ $ mapM readGroupKernelInput used_inps - space <- mkSegSpace ispace + space <- SegSpace <$> newVName "phys_group_id" <*> pure ispace pure (intra_avail_par, space, read_input_stms) let kbody' = kbody {kernelBodyStms = read_input_stms <> kernelBodyStms kbody} @@ -184,19 +184,29 @@ stms <- collectStms_ $ intraGroupStms $ bodyStms body pure $ mkBody stms $ bodyResult body +intraGroupLambda :: Lambda SOACS -> IntraGroupM (Lambda GPU) +intraGroupLambda lam = + mkLambda (lambdaParams lam) $ + bodyBind =<< intraGroupBody (lambdaBody lam) + +intraGroupWithAccInput :: WithAccInput SOACS -> IntraGroupM (WithAccInput GPU) +intraGroupWithAccInput (shape, arrs, Nothing) = + pure (shape, arrs, Nothing) +intraGroupWithAccInput (shape, arrs, Just (lam, nes)) = do + lam' <- intraGroupLambda lam + pure (shape, arrs, Just (lam', nes)) + intraGroupStm :: Stm SOACS -> IntraGroupM () intraGroupStm stm@(Let pat aux e) = do scope <- askScope let lvl = SegThread SegNoVirt Nothing case e of - DoLoop merge form loopbody -> - localScope (scopeOf form') $ - localScope (scopeOfFParams $ map fst merge) $ do - loopbody' <- intraGroupBody loopbody - certifying (stmAuxCerts aux) $ - letBind pat $ - DoLoop merge form' loopbody' + Loop merge form loopbody -> + localScope (scopeOf form' <> scopeOfFParams (map fst merge)) $ do + loopbody' <- intraGroupBody loopbody + certifying (stmAuxCerts aux) . letBind pat $ + Loop merge form' loopbody' where form' = case form of ForLoop i it bound inps -> ForLoop i it bound inps @@ -206,6 +216,10 @@ defbody' <- intraGroupBody defbody certifying (stmAuxCerts aux) . letBind pat $ Match cond cases' defbody' ifdec + WithAcc inputs lam -> do + inputs' <- mapM intraGroupWithAccInput inputs + lam' <- intraGroupLambda lam + certifying (stmAuxCerts aux) . letBind pat $ WithAcc inputs' lam' Op soac | "sequential_outer" `inAttrs` stmAuxAttrs aux -> intraGroupStms . fmap (certify (stmAuxCerts aux)) diff --git a/src/Futhark/Pass/ExtractKernels/StreamKernel.hs b/src/Futhark/Pass/ExtractKernels/StreamKernel.hs --- a/src/Futhark/Pass/ExtractKernels/StreamKernel.hs +++ b/src/Futhark/Pass/ExtractKernels/StreamKernel.hs @@ -59,7 +59,7 @@ -- | Like 'segThread', but cap the thread count to the input size. -- This is more efficient for small kernels, e.g. summing a small -- array. -segThreadCapped :: MonadFreshNames m => MkSegLevel GPU m +segThreadCapped :: (MonadFreshNames m) => MkSegLevel GPU m segThreadCapped ws desc r = do w <- letSubExp "nest_size" diff --git a/src/Futhark/Pass/ExtractMulticore.hs b/src/Futhark/Pass/ExtractMulticore.hs --- a/src/Futhark/Pass/ExtractMulticore.hs +++ b/src/Futhark/Pass/ExtractMulticore.hs @@ -94,7 +94,7 @@ op'' <- transformLambda op' pure (stms, MC.HistOp num_bins rf dests nes' shape op'') -mkSegSpace :: MonadFreshNames m => SubExp -> m (VName, SegSpace) +mkSegSpace :: (MonadFreshNames m) => SubExp -> m (VName, SegSpace) mkSegSpace w = do flat <- newVName "flat_tid" gtid <- newVName "gtid" @@ -110,12 +110,12 @@ pure $ oneStm $ Let pat aux $ BasicOp op transformStm (Let pat aux (Apply f args ret info)) = pure $ oneStm $ Let pat aux $ Apply f args ret info -transformStm (Let pat aux (DoLoop merge form body)) = do +transformStm (Let pat aux (Loop merge form body)) = do let form' = transformLoopForm form body' <- localScope (scopeOfFParams (map fst merge) <> scopeOf form') $ transformBody body - pure $ oneStm $ Let pat aux $ DoLoop merge form' body' + pure $ oneStm $ Let pat aux $ Loop merge form' body' transformStm (Let pat aux (Match ses cases defbody ret)) = oneStm . Let pat aux <$> (Match ses <$> mapM transformCase cases <*> transformBody defbody <*> pure ret) @@ -164,7 +164,7 @@ data NeedsRename = DoRename | DoNotRename -renameIfNeeded :: Rename a => NeedsRename -> a -> ExtractM a +renameIfNeeded :: (Rename a) => NeedsRename -> a -> ExtractM a renameIfNeeded DoRename = renameSomething renameIfNeeded DoNotRename = pure diff --git a/src/Futhark/Pass/FirstOrderTransform.hs b/src/Futhark/Pass/FirstOrderTransform.hs --- a/src/Futhark/Pass/FirstOrderTransform.hs +++ b/src/Futhark/Pass/FirstOrderTransform.hs @@ -26,7 +26,7 @@ import Futhark.Transform.FirstOrderTransform (FirstOrderRep, transformConsts, transformFunDef) -- | The first-order transformation pass. -firstOrderTransform :: FirstOrderRep rep => Pass SOACS rep +firstOrderTransform :: (FirstOrderRep rep) => Pass SOACS rep firstOrderTransform = Pass "first order transform" diff --git a/src/Futhark/Pass/KernelBabysitting.hs b/src/Futhark/Pass/KernelBabysitting.hs --- a/src/Futhark/Pass/KernelBabysitting.hs +++ b/src/Futhark/Pass/KernelBabysitting.hs @@ -126,7 +126,7 @@ traverseKernelBodyArrayIndexes :: forall f. - Monad f => + (Monad f) => Names -> Names -> Scope GPU -> @@ -195,7 +195,7 @@ type Replacements = M.Map (VName, Slice SubExp) VName ensureCoalescedAccess :: - MonadBuilder m => + (MonadBuilder m) => ExpMap -> [(VName, SubExp)] -> ArrayIndexTransform (StateT Replacements m) @@ -360,7 +360,7 @@ [num_is .. rank - 1] ++ [0 .. num_is - 1] rearrangeInput :: - MonadBuilder m => + (MonadBuilder m) => Maybe (Maybe [Int]) -> [Int] -> VName -> @@ -384,7 +384,7 @@ Manifest perm manifested rowMajorArray :: - MonadBuilder m => + (MonadBuilder m) => VName -> m VName rowMajorArray arr = do diff --git a/src/Futhark/Pass/LiftAllocations.hs b/src/Futhark/Pass/LiftAllocations.hs --- a/src/Futhark/Pass/LiftAllocations.hs +++ b/src/Futhark/Pass/LiftAllocations.hs @@ -74,9 +74,9 @@ cases' <- mapM (\(Case p b) -> Case p <$> liftAllocationsInBody b) cases body' <- liftAllocationsInBody body pure stm {stmExp = Match cond_ses cases' body' dec} -liftInsideStm stm@(Let _ _ (DoLoop params form body)) = do +liftInsideStm stm@(Let _ _ (Loop params form body)) = do body' <- liftAllocationsInBody body - pure stm {stmExp = DoLoop params form body'} + pure stm {stmExp = Loop params form body'} liftInsideStm stm = pure stm liftAllocationsInStms :: diff --git a/src/Futhark/Pass/LowerAllocations.hs b/src/Futhark/Pass/LowerAllocations.hs --- a/src/Futhark/Pass/LowerAllocations.hs +++ b/src/Futhark/Pass/LowerAllocations.hs @@ -82,9 +82,9 @@ let stm' = stm {stmExp = Match cond_ses cases' body' dec} (alloc', acc') = insertLoweredAllocs (freeIn stm) alloc acc lowerAllocationsInStms stms alloc' (acc' :|> stm') -lowerAllocationsInStms (stm@(Let _ _ (DoLoop params form body)) :<| stms) alloc acc = do +lowerAllocationsInStms (stm@(Let _ _ (Loop params form body)) :<| stms) alloc acc = do body' <- lowerAllocationsInBody body - let stm' = stm {stmExp = DoLoop params form body'} + let stm' = stm {stmExp = Loop params form body'} (alloc', acc') = insertLoweredAllocs (freeIn stm) alloc acc lowerAllocationsInStms stms alloc' (acc' :|> stm') lowerAllocationsInStms (stm :<| stms) alloc acc = do diff --git a/src/Futhark/Pipeline.hs b/src/Futhark/Pipeline.hs --- a/src/Futhark/Pipeline.hs +++ b/src/Futhark/Pipeline.hs @@ -153,7 +153,7 @@ -- | Construct a pipeline from a single compiler pass. onePass :: - Checkable torep => + (Checkable torep) => Pass fromrep torep -> Pipeline fromrep torep onePass pass = Pipeline perform @@ -193,13 +193,13 @@ -- | Create a pipeline from a list of passes. passes :: - Checkable rep => + (Checkable rep) => [Pass rep rep] -> Pipeline rep rep passes = foldl (>>>) id . map onePass validationError :: - PrettyRep rep => + (PrettyRep rep) => Pass fromrep torep -> Prog rep -> String -> diff --git a/src/Futhark/Pkg/Info.hs b/src/Futhark/Pkg/Info.hs --- a/src/Futhark/Pkg/Info.hs +++ b/src/Futhark/Pkg/Info.hs @@ -80,7 +80,7 @@ -- | Create memoisation around a 'GetManifest' action to ensure that -- multiple inspections of the same revisions will not result in -- potentially expensive IO operations. -memoiseGetManifest :: MonadIO m => GetManifest m -> m (GetManifest m) +memoiseGetManifest :: (MonadIO m) => GetManifest m -> m (GetManifest m) memoiseGetManifest (GetManifest m) = do ref <- liftIO $ newIORef Nothing pure $ @@ -271,7 +271,7 @@ -- | Given a package path, look up information about that package. lookupPackage :: - MonadPkgRegistry m => + (MonadPkgRegistry m) => CacheDir -> PkgPath -> m (PkgInfo m) @@ -286,7 +286,7 @@ pure pinfo lookupPackageCommit :: - MonadPkgRegistry m => + (MonadPkgRegistry m) => CacheDir -> PkgPath -> Maybe T.Text -> @@ -306,7 +306,7 @@ -- | Look up information about a specific version of a package. lookupPackageRev :: - MonadPkgRegistry m => + (MonadPkgRegistry m) => CacheDir -> PkgPath -> SemVer -> @@ -346,7 +346,7 @@ -- | Find the newest version of a package. lookupNewestRev :: - MonadPkgRegistry m => + (MonadPkgRegistry m) => CacheDir -> PkgPath -> m SemVer diff --git a/src/Futhark/Pkg/Solve.hs b/src/Futhark/Pkg/Solve.hs --- a/src/Futhark/Pkg/Solve.hs +++ b/src/Futhark/Pkg/Solve.hs @@ -75,7 +75,7 @@ -- | Run the solver, producing both a package registry containing -- a cache of the lookups performed, as well as a build list. solveDeps :: - MonadPkgRegistry m => + (MonadPkgRegistry m) => CacheDir -> PkgRevDeps -> m BuildList diff --git a/src/Futhark/Script.hs b/src/Futhark/Script.hs --- a/src/Futhark/Script.hs +++ b/src/Futhark/Script.hs @@ -63,7 +63,7 @@ type TypeMap = M.Map TypeName (Maybe [(Name, TypeName)]) -typeMap :: MonadIO m => Server -> m TypeMap +typeMap :: (MonadIO m) => Server -> m TypeMap typeMap server = do liftIO $ either (pure mempty) onTypes =<< cmdTypes server where @@ -88,7 +88,7 @@ -- | Run an action with a 'ScriptServer' produced by an existing -- 'Server', without shutting it down at the end. -withScriptServer' :: MonadIO m => Server -> (ScriptServer -> m a) -> m a +withScriptServer' :: (MonadIO m) => Server -> (ScriptServer -> m a) -> m a withScriptServer' server f = do counter <- liftIO $ newIORef 0 types <- typeMap server diff --git a/src/Futhark/Test.hs b/src/Futhark/Test.hs --- a/src/Futhark/Test.hs +++ b/src/Futhark/Test.hs @@ -236,7 +236,7 @@ -- approach here seems robust enough for now, but certainly it could -- be made even better. The race condition that remains should mostly -- result in duplicate work, not crashes or data corruption. -getGenFile :: MonadIO m => FutharkExe -> FilePath -> GenValue -> m FilePath +getGenFile :: (MonadIO m) => FutharkExe -> FilePath -> GenValue -> m FilePath getGenFile futhark dir gen = do liftIO $ createDirectoryIfMissing True $ dir "data" exists_and_proper_size <- @@ -257,7 +257,7 @@ where file = "data" genFileName gen -getGenBS :: MonadIO m => FutharkExe -> FilePath -> GenValue -> m BS.ByteString +getGenBS :: (MonadIO m) => FutharkExe -> FilePath -> GenValue -> m BS.ByteString getGenBS futhark dir gen = liftIO . BS.readFile . (dir ) =<< getGenFile futhark dir gen genValues :: FutharkExe -> [GenValue] -> IO SBS.ByteString @@ -300,11 +300,11 @@ testRunReferenceOutput prog entry tr = "data" takeBaseName prog - <> ":" - <> T.unpack entry - <> "-" - <> map clean (T.unpack (runDescription tr)) - <.> "out" + <> ":" + <> T.unpack entry + <> "-" + <> map clean (T.unpack (runDescription tr)) + <.> "out" where clean '/' = '_' -- Would this ever happen? clean ' ' = '_' @@ -457,7 +457,7 @@ -- | Determine the @--tuning@ options to pass to the program. The first -- argument is the extension of the tuning file, or 'Nothing' if none -- should be used. -determineTuning :: MonadIO m => Maybe FilePath -> FilePath -> m ([String], String) +determineTuning :: (MonadIO m) => Maybe FilePath -> FilePath -> m ([String], String) determineTuning Nothing _ = pure ([], mempty) determineTuning (Just ext) program = do exists <- liftIO $ doesFileExist (program <.> ext) diff --git a/src/Futhark/Test/Values.hs b/src/Futhark/Test/Values.hs --- a/src/Futhark/Test/Values.hs +++ b/src/Futhark/Test/Values.hs @@ -48,7 +48,7 @@ traverse f (ValueTuple vs) = ValueTuple <$> traverse (traverse f) vs traverse f (ValueRecord m) = ValueRecord <$> traverse (traverse f) m -instance Pretty v => Pretty (Compound v) where +instance (Pretty v) => Pretty (Compound v) where pretty (ValueAtom v) = pretty v pretty (ValueTuple vs) = parens $ commasep $ map pretty vs pretty (ValueRecord m) = braces $ commasep $ map field $ M.toList m diff --git a/src/Futhark/Transform/CopyPropagate.hs b/src/Futhark/Transform/CopyPropagate.hs --- a/src/Futhark/Transform/CopyPropagate.hs +++ b/src/Futhark/Transform/CopyPropagate.hs @@ -17,7 +17,7 @@ -- | Run copy propagation on an entire program. copyPropagateInProg :: - SimplifiableRep rep => + (SimplifiableRep rep) => SimpleOps rep -> Prog rep -> PassM (Prog rep) diff --git a/src/Futhark/Transform/FirstOrderTransform.hs b/src/Futhark/Transform/FirstOrderTransform.hs --- a/src/Futhark/Transform/FirstOrderTransform.hs +++ b/src/Futhark/Transform/FirstOrderTransform.hs @@ -103,7 +103,7 @@ -- Produce scratch "arrays" for the Map and Scan outputs of Screma. -- "Arrays" is in quotes because some of those may be accumulators. -resultArray :: Transformer m => [VName] -> [Type] -> m [VName] +resultArray :: (Transformer m) => [VName] -> [Type] -> m [VName] resultArray arrs ts = do arrs_ts <- mapM lookupType arrs let oneArray t@Acc {} @@ -117,7 +117,7 @@ -- is untouched, and may or may not contain further 'SOAC's depending -- on the given rep. transformSOAC :: - Transformer m => + (Transformer m) => Pat (LetDec (Rep m)) -> SOAC (Rep m) -> m () @@ -225,7 +225,7 @@ names <- (++ patNames pat) <$> replicateM (length scanacc_params) (newVName "discard") - letBindNames names $ DoLoop merge loopform loop_body + letBindNames names $ Loop merge loopform loop_body transformSOAC pat (Stream w arrs nes lam) = do -- Create a loop that repeatedly applies the lambda body to a -- chunksize of 1. Hopefully this will lead to this outer loop @@ -280,7 +280,7 @@ mkBodyM mempty $ subExpsRes $ res' ++ mapout_res' - letBind pat $ DoLoop merge loop_form loop_body + letBind pat $ Loop merge loop_form loop_body transformSOAC pat (Scatter len ivs lam as) = do iter <- newVName "write_iter" @@ -308,7 +308,7 @@ foldM saveInArray arr indexes' pure $ resultBody (map Var ress) - letBind pat $ DoLoop merge (ForLoop iter Int64 len []) loopBody + letBind pat $ Loop merge (ForLoop iter Int64 len []) loopBody transformSOAC pat (Hist len imgs ops bucket_fun) = do iter <- newVName "iter" @@ -364,7 +364,7 @@ pure $ resultBody $ map Var $ concat hists_out'' -- Wrap up the above into a for-loop. - letBind pat $ DoLoop merge (ForLoop iter Int64 len []) loopBody + letBind pat $ Loop merge (ForLoop iter Int64 len []) loopBody -- | Recursively first-order-transform a lambda. transformLambda :: @@ -385,7 +385,7 @@ transformBody body pure $ Lambda params body' rettype -letwith :: Transformer m => [VName] -> SubExp -> [SubExp] -> m [VName] +letwith :: (Transformer m) => [VName] -> SubExp -> [SubExp] -> m [VName] letwith ks i vs = do let update k v = do k_t <- lookupType k @@ -397,7 +397,7 @@ zipWithM update ks vs bindLambda :: - Transformer m => + (Transformer m) => AST.Lambda (Rep m) -> [AST.Exp (Rep m)] -> m Result @@ -409,7 +409,7 @@ bodyBind body loopMerge :: [Ident] -> [SubExp] -> [(Param DeclType, SubExp)] -loopMerge vars = loopMerge' $ zip vars $ repeat Unique +loopMerge vars = loopMerge' $ map (,Unique) vars loopMerge' :: [(Ident, Uniqueness)] -> [SubExp] -> [(Param DeclType, SubExp)] loopMerge' vars vals = 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 @@ -149,7 +149,7 @@ -- | Perform a renaming using the 'Substitute' instance. This only -- works if the argument does not itself perform any name binding, but -- it can save on boilerplate for simple types. -substituteRename :: Substitute a => a -> RenameM a +substituteRename :: (Substitute a) => a -> RenameM a substituteRename x = do substs <- renamerSubstitutions pure $ substituteNames substs x @@ -164,7 +164,7 @@ instance Rename VName where rename name = asks (fromMaybe name . M.lookup name . envNameMap) -instance Rename a => Rename [a] where +instance (Rename a) => Rename [a] where rename = mapM rename instance (Rename a, Rename b) => Rename (a, b) where @@ -177,7 +177,7 @@ c' <- rename c pure (a', b', c') -instance Rename a => Rename (Maybe a) where +instance (Rename a) => Rename (Maybe a) where rename = maybe (pure Nothing) (fmap Just . rename) instance Rename Bool where @@ -207,7 +207,7 @@ -- | Rename some statements, then execute an action with the name -- substitutions induced by the statements active. -renamingStms :: Renameable rep => Stms rep -> (Stms rep -> RenameM a) -> RenameM a +renamingStms :: (Renameable rep) => Stms rep -> (Stms rep -> RenameM a) -> RenameM a renamingStms stms m = descend mempty stms where descend stms' rem_stms = case stmsHead rem_stms of @@ -216,7 +216,7 @@ stm' <- rename stm descend (stms' <> oneStm stm') rem_stms' -instance Renameable rep => Rename (FunDef rep) where +instance (Renameable rep) => Rename (FunDef rep) where rename (FunDef entry attrs fname ret params body) = renameBound (map paramName params) $ do params' <- mapM rename params @@ -228,14 +228,14 @@ rename (Var v) = Var <$> rename v rename (Constant v) = pure $ Constant v -instance Rename dec => Rename (Param dec) where +instance (Rename dec) => Rename (Param dec) where rename (Param attrs name dec) = Param <$> rename attrs <*> rename name <*> rename dec -instance Rename dec => Rename (Pat dec) where +instance (Rename dec) => Rename (Pat dec) where rename (Pat xs) = Pat <$> rename xs -instance Rename dec => Rename (PatElem dec) where +instance (Rename dec) => Rename (PatElem dec) where rename (PatElem ident dec) = PatElem <$> rename ident <*> rename dec instance Rename Certs where @@ -244,26 +244,26 @@ instance Rename Attrs where rename = pure -instance Rename dec => Rename (StmAux dec) where +instance (Rename dec) => Rename (StmAux dec) where rename (StmAux cs attrs dec) = StmAux <$> rename cs <*> rename attrs <*> rename dec instance Rename SubExpRes where rename (SubExpRes cs se) = SubExpRes <$> rename cs <*> rename se -instance Renameable rep => Rename (Body rep) where +instance (Renameable rep) => Rename (Body rep) where rename (Body dec stms res) = do dec' <- rename dec renamingStms stms $ \stms' -> Body dec' stms' <$> rename res -instance Renameable rep => Rename (Stm rep) where +instance (Renameable rep) => Rename (Stm rep) where rename (Let pat dec e) = Let <$> rename pat <*> rename dec <*> rename e -instance Renameable rep => Rename (Exp rep) where +instance (Renameable rep) => Rename (Exp rep) where rename (WithAcc inputs lam) = WithAcc <$> rename inputs <*> rename lam - rename (DoLoop merge form loopbody) = do + rename (Loop merge form loopbody) = do let (params, args) = unzip merge args' <- mapM rename args case form of @@ -280,7 +280,7 @@ i' <- rename i loopbody' <- rename loopbody pure $ - DoLoop + Loop (zip params' args') (ForLoop i' it boundexp' $ zip arr_params' loop_arrs') loopbody' @@ -289,7 +289,7 @@ params' <- mapM rename params loopbody' <- rename loopbody cond' <- rename cond - pure $ DoLoop (zip params' args') (WhileLoop cond') loopbody' + pure $ Loop (zip params' args') (WhileLoop cond') loopbody' rename e = mapExpM mapper e where mapper = @@ -307,14 +307,14 @@ instance Rename PrimType where rename = pure -instance Rename shape => Rename (TypeBase shape u) where +instance (Rename shape) => Rename (TypeBase shape u) where rename (Array et size u) = Array <$> rename et <*> rename size <*> pure u rename (Prim t) = pure $ Prim t rename (Mem space) = pure $ Mem space rename (Acc acc ispace ts u) = Acc <$> rename acc <*> rename ispace <*> rename ts <*> pure u -instance Renameable rep => Rename (Lambda rep) where +instance (Renameable rep) => Rename (Lambda rep) where rename (Lambda params body ret) = renameBound (map paramName params) $ do params' <- mapM rename params @@ -328,7 +328,7 @@ instance Rename Rank where rename = pure -instance Rename d => Rename (ShapeBase d) where +instance (Rename d) => Rename (ShapeBase d) where rename (Shape l) = Shape <$> mapM rename l instance Rename ExtSize where @@ -341,7 +341,7 @@ instance Rename (NoOp rep) where rename NoOp = pure NoOp -instance Rename d => Rename (DimIndex d) where +instance (Rename d) => Rename (DimIndex d) where rename (DimFix i) = DimFix <$> rename i rename (DimSlice i n s) = DimSlice <$> rename i <*> rename n <*> rename s 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 @@ -31,10 +31,10 @@ -- names in @e@ are unique, i.e. there is no shadowing. substituteNames :: M.Map VName VName -> a -> a -instance Substitute a => Substitute [a] where +instance (Substitute a) => Substitute [a] where substituteNames substs = map $ substituteNames substs -instance Substitute (Stm rep) => Substitute (Stms rep) where +instance (Substitute (Stm rep)) => Substitute (Stms rep) where substituteNames substs = fmap $ substituteNames substs instance (Substitute a, Substitute b) => Substitute (a, b) where @@ -56,7 +56,7 @@ substituteNames substs u ) -instance Substitute a => Substitute (Maybe a) where +instance (Substitute a) => Substitute (Maybe a) where substituteNames substs = fmap $ substituteNames substs instance Substitute Bool where @@ -69,24 +69,24 @@ substituteNames substs (Var v) = Var $ substituteNames substs v substituteNames _ (Constant v) = Constant v -instance Substitutable rep => Substitute (Exp rep) where +instance (Substitutable rep) => Substitute (Exp rep) where substituteNames substs = mapExp $ replace substs -instance Substitute dec => Substitute (PatElem dec) where +instance (Substitute dec) => Substitute (PatElem dec) where substituteNames substs (PatElem ident dec) = PatElem (substituteNames substs ident) (substituteNames substs dec) instance Substitute Attrs where substituteNames _ attrs = attrs -instance Substitute dec => Substitute (StmAux dec) where +instance (Substitute dec) => Substitute (StmAux dec) where substituteNames substs (StmAux cs attrs dec) = StmAux (substituteNames substs cs) (substituteNames substs attrs) (substituteNames substs dec) -instance Substitute dec => Substitute (Param dec) where +instance (Substitute dec) => Substitute (Param dec) where substituteNames substs (Param attrs name dec) = Param (substituteNames substs attrs) @@ -97,7 +97,7 @@ substituteNames substs (SubExpRes cs se) = SubExpRes (substituteNames substs cs) (substituteNames substs se) -instance Substitute dec => Substitute (Pat dec) where +instance (Substitute dec) => Substitute (Pat dec) where substituteNames substs (Pat xs) = Pat (substituteNames substs xs) @@ -105,21 +105,21 @@ substituteNames substs (Certs cs) = Certs $ substituteNames substs cs -instance Substitutable rep => Substitute (Stm rep) where +instance (Substitutable rep) => Substitute (Stm rep) where substituteNames substs (Let pat annot e) = Let (substituteNames substs pat) (substituteNames substs annot) (substituteNames substs e) -instance Substitutable rep => Substitute (Body rep) where +instance (Substitutable rep) => Substitute (Body rep) where substituteNames substs (Body dec stms res) = Body (substituteNames substs dec) (substituteNames substs stms) (substituteNames substs res) -replace :: Substitutable rep => M.Map VName VName -> Mapper rep rep Identity +replace :: (Substitutable rep) => M.Map VName VName -> Mapper rep rep Identity replace substs = Mapper { mapOnVName = pure . substituteNames substs, @@ -141,11 +141,11 @@ instance Substitute (NoOp rep) where substituteNames _ = id -instance Substitute d => Substitute (ShapeBase d) where +instance (Substitute d) => Substitute (ShapeBase d) where substituteNames substs (Shape es) = Shape $ map (substituteNames substs) es -instance Substitute d => Substitute (Ext d) where +instance (Substitute d) => Substitute (Ext d) where substituteNames substs (Free x) = Free $ substituteNames substs x substituteNames _ (Ext x) = Ext x @@ -155,7 +155,7 @@ instance Substitute PrimType where substituteNames _ t = t -instance Substitute shape => Substitute (TypeBase shape u) where +instance (Substitute shape) => Substitute (TypeBase shape u) where substituteNames _ (Prim et) = Prim et substituteNames substs (Acc acc ispace ts u) = @@ -169,7 +169,7 @@ substituteNames _ (Mem space) = Mem space -instance Substitutable rep => Substitute (Lambda rep) where +instance (Substitutable rep) => Substitute (Lambda rep) where substituteNames substs (Lambda params body rettype) = Lambda (substituteNames substs params) @@ -183,26 +183,26 @@ identType = substituteNames substs $ identType v } -instance Substitute d => Substitute (DimIndex d) where +instance (Substitute d) => Substitute (DimIndex d) where substituteNames substs = fmap $ substituteNames substs -instance Substitute d => Substitute (Slice d) where +instance (Substitute d) => Substitute (Slice d) where substituteNames substs = fmap $ substituteNames substs -instance Substitute d => Substitute (FlatDimIndex d) where +instance (Substitute d) => Substitute (FlatDimIndex d) where substituteNames substs = fmap $ substituteNames substs -instance Substitute d => Substitute (FlatSlice d) where +instance (Substitute d) => Substitute (FlatSlice d) where substituteNames substs = fmap $ substituteNames substs -instance Substitute v => Substitute (PrimExp v) where +instance (Substitute v) => Substitute (PrimExp v) where substituteNames substs = fmap $ substituteNames substs -instance Substitute v => Substitute (TPrimExp t v) where +instance (Substitute v) => Substitute (TPrimExp t v) where substituteNames substs = TPrimExp . fmap (substituteNames substs) . untyped -instance Substitutable rep => Substitute (NameInfo rep) where +instance (Substitutable rep) => Substitute (NameInfo rep) where substituteNames subst (LetName dec) = LetName $ substituteNames subst dec substituteNames subst (FParamName dec) = diff --git a/src/Futhark/Util.hs b/src/Futhark/Util.hs --- a/src/Futhark/Util.hs +++ b/src/Futhark/Util.hs @@ -89,7 +89,7 @@ import Text.Read (readMaybe) -- | Like @nub@, but without the quadratic runtime. -nubOrd :: Ord a => [a] -> [a] +nubOrd :: (Ord a) => [a] -> [a] nubOrd = nubByOrd compare -- | Like @nubBy@, but without the quadratic runtime. @@ -171,7 +171,7 @@ Nothing -> helper (acc1, x : acc2) xs -- | Return the list element at the given index, if the index is valid. -maybeNth :: Integral int => int -> [a] -> Maybe a +maybeNth :: (Integral int) => int -> [a] -> Maybe a maybeNth i l | i >= 0, v : _ <- genericDrop i l = Just v | otherwise = Nothing @@ -194,7 +194,7 @@ -- | Return the list element at the given index, if the index is -- valid, along with the elements before and after. -focusNth :: Integral int => int -> [a] -> Maybe ([a], a, [a]) +focusNth :: (Integral int) => int -> [a] -> Maybe ([a], a, [a]) focusNth i xs | (bef, x : aft) <- genericSplitAt i xs = Just (bef, x, aft) | otherwise = Nothing @@ -215,7 +215,7 @@ T.decodeUtf8With T.lenientDecode . Base16.encode . MD5.hash . T.encodeUtf8 -- | Like 'show', but produces text. -showText :: Show a => a -> T.Text +showText :: (Show a) => a -> T.Text showText = T.pack . show {-# NOINLINE unixEnvironment #-} @@ -463,7 +463,7 @@ traverseFold f = fmap fold . traverse f -- | Perform fixpoint iteration. -fixPoint :: Eq a => (a -> a) -> a -> a +fixPoint :: (Eq a) => (a -> a) -> a -> a fixPoint f x = let x' = f x in if x' == x then x else fixPoint f x' diff --git a/src/Futhark/Util/IntegralExp.hs b/src/Futhark/Util/IntegralExp.hs --- a/src/Futhark/Util/IntegralExp.hs +++ b/src/Futhark/Util/IntegralExp.hs @@ -25,7 +25,7 @@ -- | A twist on the 'Integral' type class that is more friendly to -- symbolic representations. -class Num e => IntegralExp e where +class (Num e) => IntegralExp e where quot :: e -> e -> e rem :: e -> e -> e div :: e -> e -> e @@ -44,7 +44,7 @@ newtype Wrapped a = Wrapped {wrappedValue :: a} deriving (Eq, Ord, Show) -instance Enum a => Enum (Wrapped a) where +instance (Enum a) => Enum (Wrapped a) where toEnum a = Wrapped $ toEnum a fromEnum (Wrapped a) = fromEnum a @@ -61,7 +61,7 @@ Wrapped a liftOp2 op (Wrapped x) (Wrapped y) = Wrapped $ x `op` y -instance Num a => Num (Wrapped a) where +instance (Num a) => Num (Wrapped a) where (+) = liftOp2 (Prelude.+) (-) = liftOp2 (Prelude.-) (*) = liftOp2 (Prelude.*) @@ -70,7 +70,7 @@ fromInteger = Wrapped . Prelude.fromInteger negate = liftOp Prelude.negate -instance Integral a => IntegralExp (Wrapped a) where +instance (Integral a) => IntegralExp (Wrapped a) where quot = liftOp2 Prelude.quot rem = liftOp2 Prelude.rem div = liftOp2 Prelude.div diff --git a/src/Futhark/Util/Log.hs b/src/Futhark/Util/Log.hs --- a/src/Futhark/Util/Log.hs +++ b/src/Futhark/Util/Log.hs @@ -43,19 +43,19 @@ -- | Typeclass for monads that support logging. class (Applicative m, Monad m) => MonadLogger m where -- | Add one log entry. - logMsg :: ToLog a => a -> m () + logMsg :: (ToLog a) => a -> m () logMsg = addLog . toLog -- | Append an entire log. addLog :: Log -> m () -instance Monad m => MonadLogger (WriterT Log m) where +instance (Monad m) => MonadLogger (WriterT Log m) where addLog = tell -instance Monad m => MonadLogger (Control.Monad.RWS.Lazy.RWST r Log s m) where +instance (Monad m) => MonadLogger (Control.Monad.RWS.Lazy.RWST r Log s m) where addLog = tell -instance Monad m => MonadLogger (Control.Monad.RWS.Strict.RWST r Log s m) where +instance (Monad m) => MonadLogger (Control.Monad.RWS.Strict.RWST r Log s m) where addLog = tell instance MonadLogger IO where diff --git a/src/Futhark/Util/Options.hs b/src/Futhark/Util/Options.hs --- a/src/Futhark/Util/Options.hs +++ b/src/Futhark/Util/Options.hs @@ -71,7 +71,7 @@ exitWith $ ExitFailure 1 -- | Short-hand for 'liftIO . hPutStrLn stderr' -errput :: MonadIO m => String -> m () +errput :: (MonadIO m) => String -> m () errput = liftIO . hPutStrLn stderr -- | Common definitions for @-v@ and @-h@, given the list of all other diff --git a/src/Futhark/Util/Pretty.hs b/src/Futhark/Util/Pretty.hs --- a/src/Futhark/Util/Pretty.hs +++ b/src/Futhark/Util/Pretty.hs @@ -93,15 +93,15 @@ else Prettyprinter.Render.Text.renderStrict sds -- | Prettyprint a value to a 'String', appropriately wrapped. -prettyString :: Pretty a => a -> String +prettyString :: (Pretty a) => a -> String prettyString = T.unpack . prettyText -- | Prettyprint a value to a 'String' on a single line. -prettyStringOneLine :: Pretty a => a -> String +prettyStringOneLine :: (Pretty a) => a -> String prettyStringOneLine = T.unpack . prettyTextOneLine -- | Prettyprint a value to a 'Text', appropriately wrapped. -prettyText :: Pretty a => a -> Text +prettyText :: (Pretty a) => a -> Text prettyText = docText . pretty -- | Convert a 'Doc' to text. Thsi ignores any annotations (i.e. it @@ -113,7 +113,7 @@ layoutSmart defaultLayoutOptions {layoutPageWidth = Unbounded} -- | Prettyprint a value to a 'Text' on a single line. -prettyTextOneLine :: Pretty a => a -> Text +prettyTextOneLine :: (Pretty a) => a -> Text prettyTextOneLine = Prettyprinter.Render.Text.renderStrict . layoutSmart oneLineLayout . group . pretty where oneLineLayout = defaultLayoutOptions {layoutPageWidth = Unbounded} @@ -125,11 +125,11 @@ ppTupleLines' ets = braces $ commastack $ map align ets -- | Prettyprint a list enclosed in curly braces. -prettyTuple :: Pretty a => [a] -> Text +prettyTuple :: (Pretty a) => [a] -> Text prettyTuple = docText . ppTuple' . map pretty -- | Like 'prettyTuple', but put a linebreak after every element. -prettyTupleLines :: Pretty a => [a] -> Text +prettyTupleLines :: (Pretty a) => [a] -> Text prettyTupleLines = docText . ppTupleLines' . map pretty -- | The document @'apply' ds@ separates @ds@ with commas and encloses them with 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 @@ -118,7 +118,7 @@ -- -- This function assumes that both start and end position is in the -- same file (it is not clear what the alternative would even mean). -locStr :: Located a => a -> String +locStr :: (Located a) => a -> String locStr a = case locOf a of NoLoc -> "unknown location" @@ -150,7 +150,7 @@ _ -> locStr b -- | 'locStr', but for text. -locText :: Located a => a -> T.Text +locText :: (Located a) => a -> T.Text locText = T.pack . locStr -- | 'locStrRel', but for text. diff --git a/src/Language/Futhark/FreeVars.hs b/src/Language/Futhark/FreeVars.hs --- a/src/Language/Futhark/FreeVars.hs +++ b/src/Language/Futhark/FreeVars.hs @@ -84,7 +84,7 @@ OpSectionRight _ _ e _ _ _ -> freeInExp e ProjectSection {} -> mempty IndexSection idxs _ _ -> foldMap freeInDimIndex idxs - AppExp (DoLoop sparams pat e1 form e3 _) _ -> + AppExp (Loop sparams pat e1 form e3 _) _ -> let (e2fv, e2ident) = formVars form in freeInExp e1 <> ( (e2fv <> freeInExp e3) 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 @@ -305,15 +305,25 @@ TermPoly (Maybe T.BoundV) (StructType -> Eval -> EvalM Value) | TermModule Module +instance Show TermBinding where + show (TermValue bv v) = unwords ["TermValue", show bv, show v] + show (TermPoly bv _) = unwords ["TermPoly", show bv] + show (TermModule m) = unwords ["TermModule", show m] + data Module = Module Env | ModuleFun (Module -> EvalM Module) +instance Show Module where + show (Module env) = "(" <> unwords ["Module", show env] <> ")" + show (ModuleFun _) = "(ModuleFun _)" + -- | The actual type- and value environment. data Env = Env { envTerm :: M.Map VName TermBinding, envType :: M.Map VName T.TypeBinding } + deriving (Show) instance Monoid Env where mempty = Env mempty mempty @@ -530,7 +540,7 @@ writeArray slice x y = runIdentity $ updateArray (\_ y' -> pure y') slice x y updateArray :: - Monad m => + (Monad m) => (Value -> Value -> m Value) -> [Indexing] -> Value -> @@ -584,7 +594,7 @@ -- | Expand type based on information that was not available at -- type-checking time (the structure of abstract types). -expandType :: Env -> TypeBase Size u -> TypeBase Size u +expandType :: (Pretty u) => Env -> TypeBase Size u -> TypeBase Size u expandType _ (Scalar (Prim pt)) = Scalar $ Prim pt expandType env (Scalar (Record fs)) = Scalar $ Record $ fmap (expandType env) fs expandType env (Scalar (Arrow u p d t1 (RetType dims t2))) = @@ -649,12 +659,14 @@ case lookupVar qv env of Just (TermPoly _ v) -> v (expandType env t) =<< evalWithExts env Just (TermValue _ v) -> pure v - _ -> do + x -> do ss <- map (locText . srclocOf) <$> stacktrace error $ prettyString qv <> " is not bound to a value.\n" <> T.unpack (prettyStacktrace 0 ss) + <> "Bound to\n" + <> show x typeValueShape :: Env -> StructType -> EvalM ValueShape typeValueShape env t = do @@ -853,7 +865,7 @@ eval (valEnv (M.singleton (identName dest) (Just t, dest')) <> env) body where oob = bad loc env "Update out of bounds" -evalAppExp env (DoLoop sparams pat init_e form body _) = do +evalAppExp env (Loop sparams pat init_e form body _) = do init_v <- eval env init_e case form of For iv bound -> do @@ -1118,7 +1130,13 @@ Just (TermModule m) -> pure m _ -> error $ prettyString qv <> " is not bound to a module." -evalModExp :: Env -> ModExp -> EvalM Module +-- We also return a new Env here, because we want the definitions +-- inside any constructed modules to also be in scope at the top +-- level. This is because types may contain un-qualified references to +-- definitions in modules, and sometimes those definitions may not +-- actually *have* any qualified name! See tests/modules/sizes7.fut. +-- This occurs solely because of evalType. +evalModExp :: Env -> ModExp -> EvalM (Env, Module) evalModExp _ (ModImport _ (Info f) _) = do f' <- lookupImport f known <- asks snd @@ -1129,33 +1147,47 @@ [ "Unknown interpreter import: " ++ show f, "Known: " ++ show (M.keys known) ] - Just m -> pure $ Module m + Just m -> pure (mempty, Module m) evalModExp env (ModDecs ds _) = do Env terms types <- foldM evalDec env ds -- Remove everything that was present in the original Env. - pure $ - Module $ - Env + pure + ( Env (terms `M.difference` envTerm env) - (types `M.difference` envType env) + (types `M.difference` envType env), + Module $ + Env + (terms `M.difference` envTerm env) + (types `M.difference` envType env) + ) evalModExp env (ModVar qv _) = - evalModuleVar env qv + (mempty,) <$> evalModuleVar env qv evalModExp env (ModAscript me _ (Info substs) _) = - substituteInModule substs <$> evalModExp env me -evalModExp env (ModParens me _) = evalModExp env me + bimap substituteInEnv (substituteInModule substs) <$> evalModExp env me + where + substituteInEnv env' = + let Module env'' = substituteInModule substs (Module env') in env'' +evalModExp env (ModParens me _) = + evalModExp env me evalModExp env (ModLambda p ret e loc) = - pure $ - ModuleFun $ \am -> do - let env' = env {envTerm = M.insert (modParamName p) (TermModule am) $ envTerm env} - evalModExp env' $ case ret of - Nothing -> e - Just (se, rsubsts) -> ModAscript e se rsubsts loc + pure + ( mempty, + ModuleFun $ \am -> do + let env' = env {envTerm = M.insert (modParamName p) (TermModule am) $ envTerm env} + fmap snd . evalModExp env' $ case ret of + Nothing -> e + Just (se, rsubsts) -> ModAscript e se rsubsts loc + ) evalModExp env (ModApply f e (Info psubst) (Info rsubst) _) = do - f' <- evalModExp env f + (f_env, f') <- evalModExp env f + (e_env, e') <- evalModExp env e case f' of ModuleFun f'' -> do - e' <- evalModExp env e - substituteInModule rsubst <$> f'' (substituteInModule psubst e') + res_mod <- substituteInModule rsubst <$> f'' (substituteInModule psubst e') + let res_env = case res_mod of + Module x -> x + _ -> mempty + pure (f_env <> e_env <> res_env, res_mod) _ -> error "Expected ModuleFun." evalDec :: Env -> Dec -> EvalM Env @@ -1165,9 +1197,9 @@ pure $ env {envTerm = M.insert v binding $ envTerm env} <> sizes evalDec env (OpenDec me _) = do - me' <- evalModExp env me + (me_env, me') <- evalModExp env me case me' of - Module me'' -> pure $ me'' <> env + Module me'' -> pure $ me'' <> me_env <> env _ -> error "Expected Module" evalDec env (ImportDec name name' loc) = evalDec env $ LocalDec (OpenDec (ModImport name name' loc) loc) loc @@ -1177,8 +1209,8 @@ let abbr = T.TypeAbbr l ps . RetType dims $ expandType env t pure env {envType = M.insert v abbr $ envType env} evalDec env (ModDec (ModBind v ps ret body _ loc)) = do - mod <- evalModExp env $ wrapInLambda ps - pure $ modEnv (M.singleton v mod) <> env + (mod_env, mod) <- evalModExp env $ wrapInLambda ps + pure $ modEnv (M.singleton v mod) <> mod_env <> env where wrapInLambda [] = case ret of Just (se, substs) -> ModAscript body se substs loc @@ -1960,7 +1992,9 @@ | null param_ts = "Entry point " <> dquotes (prettyName entry) <> " is not a function." | otherwise = - "Entry point " <> dquotes (prettyName entry) <> " expects input of type(s)" + "Entry point " + <> dquotes (prettyName entry) + <> " expects input of type(s)" indent 2 (stack (map pretty param_ts)) -- | Execute the named function on the given arguments; may fail @@ -1994,12 +2028,18 @@ updateType _ t = Right t - -- FIXME: we don't check array sizes. checkInput :: ValueType -> StructType -> Either T.Text () checkInput (Scalar (Prim vt)) (Scalar (Prim pt)) | vt /= pt = badPrim vt pt checkInput (Array _ _ (Prim vt)) (Array _ _ (Prim pt)) | vt /= pt = badPrim vt pt + checkInput vArr@(Array _ (F.Shape vd) _) pArr@(Array _ (F.Shape pd) _) + | length vd /= length pd = badDim vArr pArr + | not . and $ zipWith sameShape vd pd = badDim vArr pArr + where + sameShape :: Int64 -> Size -> Bool + sameShape shape0 (IntLit shape1 _ _) = fromIntegral shape0 == shape1 + sameShape _ _ = True checkInput _ _ = Right () @@ -2010,3 +2050,11 @@ <+> align (pretty pt) "Got: " <+> align (pretty vt) + + badDim vd pd = + Left . docText $ + "Invalid argument dimensions." + "Expected:" + <+> align (pretty pd) + "Got: " + <+> align (pretty vd) diff --git a/src/Language/Futhark/Interpreter/Values.hs b/src/Language/Futhark/Interpreter/Values.hs --- a/src/Language/Futhark/Interpreter/Values.hs +++ b/src/Language/Futhark/Interpreter/Values.hs @@ -62,7 +62,7 @@ -- | The shape of an array. type ValueShape = Shape Int64 -instance Pretty d => Pretty (Shape d) where +instance (Pretty d) => Pretty (Shape d) where pretty ShapeLeaf = mempty pretty (ShapeDim d s) = brackets (pretty d) <> pretty s pretty (ShapeRecord m) = prettyRecord pretty m @@ -206,7 +206,7 @@ where shape = ShapeDim (genericLength vs) rowshape -arrayLength :: Integral int => Array Int (Value m) -> int +arrayLength :: (Integral int) => Array Int (Value m) -> int arrayLength = fromIntegral . (+ 1) . snd . bounds toTuple :: [Value m] -> Value m @@ -220,7 +220,7 @@ fromDataShape = foldr (ShapeDim . fromIntegral) ShapeLeaf . SVec.toList fromDataValueWith :: - SVec.Storable a => + (SVec.Storable a) => (a -> PrimValue) -> SVec.Vector Int -> SVec.Vector a -> diff --git a/src/Language/Futhark/Parser/Lexer/Tokens.hs b/src/Language/Futhark/Parser/Lexer/Tokens.hs --- a/src/Language/Futhark/Parser/Lexer/Tokens.hs +++ b/src/Language/Futhark/Parser/Lexer/Tokens.hs @@ -140,7 +140,7 @@ suffZero :: T.Text -> T.Text suffZero s = if T.last s == '.' then s <> "0" else s -tryRead :: Read a => String -> T.Text -> a +tryRead :: (Read a) => String -> T.Text -> a tryRead desc s = case reads s' of [(x, "")] -> x _ -> error $ "Invalid " ++ desc ++ " literal: `" ++ T.unpack s ++ "'." @@ -152,7 +152,7 @@ tokenC v _ = v {-# INLINE decToken #-} -decToken :: Integral a => (a -> Token) -> BS.ByteString -> Token +decToken :: (Integral a) => (a -> Token) -> BS.ByteString -> Token decToken f = f . BS.foldl' digit 0 where digit x c = @@ -161,7 +161,7 @@ else x {-# INLINE binToken #-} -binToken :: Integral a => (a -> Token) -> BS.ByteString -> Token +binToken :: (Integral a) => (a -> Token) -> BS.ByteString -> Token binToken f = f . BS.foldl' digit 0 where digit x c = @@ -170,7 +170,7 @@ else x {-# INLINE hexToken #-} -hexToken :: Integral a => (a -> Token) -> BS.ByteString -> Token +hexToken :: (Integral a) => (a -> Token) -> BS.ByteString -> Token hexToken f = f . BS.foldl' digit 0 where digit x c @@ -184,7 +184,7 @@ x {-# INLINE romToken #-} -romToken :: Integral a => (a -> Token) -> BS.ByteString -> Token +romToken :: (Integral a) => (a -> Token) -> BS.ByteString -> Token romToken f = tokenS $ f . fromRoman {-# INLINE tokenS #-} @@ -209,7 +209,7 @@ | otherwise = SYMBOL (leadingOperator q) [] q symbol qs q = SYMBOL (leadingOperator q) qs q -romanNumerals :: Integral a => [(T.Text, a)] +romanNumerals :: (Integral a) => [(T.Text, a)] romanNumerals = reverse [ ("I", 1), @@ -227,13 +227,13 @@ ("M", 1000) ] -fromRoman :: Integral a => T.Text -> a +fromRoman :: (Integral a) => T.Text -> a fromRoman s = case find ((`T.isPrefixOf` s) . fst) romanNumerals of Nothing -> 0 Just (d, n) -> n + fromRoman (T.drop (T.length d) s) -readHexRealLit :: RealFloat a => T.Text -> a +readHexRealLit :: (RealFloat a) => T.Text -> a readHexRealLit s = let num = T.drop 2 s in -- extract number into integer, fractional and (optional) exponent diff --git a/src/Language/Futhark/Parser/Monad.hs b/src/Language/Futhark/Parser/Monad.hs --- a/src/Language/Futhark/Parser/Monad.hs +++ b/src/Language/Futhark/Parser/Monad.hs @@ -84,7 +84,7 @@ parseErrorAt loc . Just $ "Only the keyword '" <> expected <> "' may appear here." -mustBeEmpty :: Located loc => loc -> ValueType -> ParserMonad () +mustBeEmpty :: (Located loc) => loc -> ValueType -> ParserMonad () mustBeEmpty _ (Array _ (Shape dims) _) | 0 `elem` dims = pure () mustBeEmpty loc t = @@ -203,7 +203,7 @@ "Expected one of the following: " <> T.unwords (map T.pack expected) ] -parseErrorAt :: Located loc => loc -> Maybe T.Text -> ParserMonad a +parseErrorAt :: (Located loc) => loc -> Maybe T.Text -> ParserMonad a parseErrorAt loc Nothing = throwError $ SyntaxError (locOf loc) "Syntax error." parseErrorAt loc (Just s) = throwError $ SyntaxError (locOf loc) s diff --git a/src/Language/Futhark/Parser/Parser.y b/src/Language/Futhark/Parser/Parser.y --- a/src/Language/Futhark/Parser/Parser.y +++ b/src/Language/Futhark/Parser/Parser.y @@ -769,9 +769,9 @@ LoopExp :: { UncheckedExp } : loop Pat LoopForm do Exp %prec ifprec - {% fmap (\t -> AppExp (DoLoop [] (fmap (toParam Observe) $2) t $3 $5 (srcspan $1 $>)) NoInfo) (patternExp $2) } + {% fmap (\t -> AppExp (Loop [] (fmap (toParam Observe) $2) t $3 $5 (srcspan $1 $>)) NoInfo) (patternExp $2) } | loop Pat '=' Exp LoopForm do Exp %prec ifprec - { AppExp (DoLoop [] (fmap (toParam Observe) $2) $4 $5 $7 (srcspan $1 $>)) NoInfo } + { AppExp (Loop [] (fmap (toParam Observe) $2) $4 $5 $7 (srcspan $1 $>)) NoInfo } MatchExp :: { UncheckedExp } : match Exp Cases diff --git a/src/Language/Futhark/Pretty.hs b/src/Language/Futhark/Pretty.hs --- a/src/Language/Futhark/Pretty.hs +++ b/src/Language/Futhark/Pretty.hs @@ -155,7 +155,7 @@ instance (Pretty (Shape dim), Pretty u) => Pretty (TypeBase dim u) where pretty = prettyType 0 -prettyTypeArg :: Pretty (Shape dim) => Int -> TypeArg dim -> Doc a +prettyTypeArg :: (Pretty (Shape dim)) => Int -> TypeArg dim -> Doc a prettyTypeArg _ (TypeArgDim d) = pretty $ Shape [d] prettyTypeArg p (TypeArgType t) = prettyType p t @@ -187,11 +187,11 @@ pretty (TypeArgExpSize d) = pretty d pretty (TypeArgExpType t) = pretty t -instance IsName vn => Pretty (QualName vn) where +instance (IsName vn) => Pretty (QualName vn) where pretty (QualName names name) = mconcat $ punctuate "." $ map prettyName names ++ [prettyName name] -instance IsName vn => Pretty (IdentBase f vn t) where +instance (IsName vn) => Pretty (IdentBase f vn t) where pretty = prettyName . identName hasArrayLit :: ExpBase ty vn -> Bool @@ -215,7 +215,7 @@ pretty (DimSlice i Nothing Nothing) = maybe mempty pretty i <> ":" -instance IsName vn => Pretty (SizeBinder vn) where +instance (IsName vn) => Pretty (SizeBinder vn) where pretty (SizeBinder v _) = brackets $ prettyName v letBody :: (Eq vn, IsName vn, Annot f) => ExpBase f vn -> Doc a @@ -226,7 +226,7 @@ prettyAppExp :: (Eq vn, IsName vn, Annot f) => Int -> AppExpBase f vn -> Doc a prettyAppExp p (BinOp (bop, _) _ (x, _) (y, _) _) = prettyBinOp p bop x y prettyAppExp _ (Match e cs _) = "match" <+> pretty e (stack . map pretty) (NE.toList cs) -prettyAppExp _ (DoLoop sizeparams pat initexp form loopbody _) = +prettyAppExp _ (Loop sizeparams pat initexp form loopbody _) = "loop" <+> align ( hsep (map (brackets . prettyName) sizeparams ++ [pretty pat]) @@ -257,7 +257,7 @@ prettyAppExp _ (LetFun fname (tparams, params, retdecl, rettype, e) body _) = "let" <+> hsep (prettyName fname : map pretty tparams ++ map pretty params) - <> retdecl' + <> retdecl' <+> equals indent 2 (pretty e) letBody body @@ -268,7 +268,8 @@ prettyAppExp _ (LetWith dest src idxs ve body _) | dest == src = "let" - <+> pretty dest <> list (map pretty idxs) + <+> pretty dest + <> list (map pretty idxs) <+> equals <+> align (pretty ve) letBody body @@ -313,7 +314,7 @@ "@" <> parens (align $ pretty t') _ -> mempty -prettyAttr :: Pretty a => a -> Doc ann +prettyAttr :: (Pretty a) => a -> Doc ann prettyAttr attr = "#[" <> pretty attr <> "]" operatorName :: Name -> Bool @@ -370,7 +371,9 @@ "assert" <+> prettyExp 10 e1 <+> prettyExp 10 e2 prettyExp p (Lambda params body rettype _ _) = parensIf (p /= -1) $ - "\\" <> hsep (map pretty params) <> ppAscription rettype + "\\" + <> hsep (map pretty params) + <> ppAscription rettype <+> "->" indent 2 (align (pretty body)) prettyExp _ (OpSection binop _ _) = @@ -396,17 +399,17 @@ not $ null ext = parens (prettyAppExp i e) "@" - <> parens (pretty t <> "," <+> brackets (commasep $ map prettyName ext)) + <> parens (pretty t <> "," <+> brackets (commasep $ map prettyName ext)) | otherwise = prettyAppExp i e instance (Eq vn, IsName vn, Annot f) => Pretty (ExpBase f vn) where pretty = prettyExp (-1) -instance IsName vn => Pretty (AttrAtom vn) where +instance (IsName vn) => Pretty (AttrAtom vn) where pretty (AtomName v) = pretty v pretty (AtomInt x) = pretty x -instance IsName vn => Pretty (AttrInfo vn) where +instance (IsName vn) => Pretty (AttrInfo vn) where pretty (AttrAtom attr _) = pretty attr pretty (AttrComp f attrs _) = pretty f <> parens (commasep $ map pretty attrs) @@ -447,7 +450,7 @@ pretty (PatConstr n _ ps _) = "#" <> pretty n <+> sep (map pretty ps) pretty (PatAttr attr p _) = "#[" <> pretty attr <> "]" pretty p -ppAscription :: Pretty t => Maybe t -> Doc a +ppAscription :: (Pretty t) => Maybe t -> Doc a ppAscription Nothing = mempty ppAscription (Just t) = colon <> align (pretty t) @@ -463,22 +466,34 @@ pretty (LocalDec dec _) = "local" <+> pretty dec pretty (ImportDec x _ _) = "import" <+> pretty x -instance (Eq vn, IsName vn, Annot f) => Pretty (ModExpBase f vn) where - pretty (ModVar v _) = pretty v - pretty (ModParens e _) = parens $ pretty e - pretty (ModImport v _ _) = "import" <+> pretty (show v) - pretty (ModDecs ds _) = nestedBlock "{" "}" (stack $ punctuate line $ map pretty ds) - pretty (ModApply f a _ _ _) = parens $ pretty f <+> parens (pretty a) - pretty (ModAscript me se _ _) = pretty me <> colon <+> pretty se - pretty (ModLambda param maybe_sig body _) = - "\\" <> pretty param <> maybe_sig' +prettyModExp :: (Eq vn, IsName vn, Annot f) => Int -> ModExpBase f vn -> Doc a +prettyModExp _ (ModVar v _) = + pretty v +prettyModExp _ (ModParens e _) = + align $ parens $ pretty e +prettyModExp _ (ModImport v _ _) = + "import" <+> pretty (show v) +prettyModExp _ (ModDecs ds _) = + nestedBlock "{" "}" $ stack $ punctuate line $ map pretty ds +prettyModExp p (ModApply f a _ _ _) = + parensIf (p >= 10) $ prettyModExp 0 f <+> prettyModExp 10 a +prettyModExp p (ModAscript me se _ _) = + parensIf (p /= -1) $ pretty me <> colon <+> pretty se +prettyModExp p (ModLambda param maybe_sig body _) = + parensIf (p /= -1) $ + "\\" + <> pretty param + <> maybe_sig' <+> "->" indent 2 (pretty body) - where - maybe_sig' = case maybe_sig of - Nothing -> mempty - Just (sig, _) -> colon <+> pretty sig + where + maybe_sig' = case maybe_sig of + Nothing -> mempty + Just (sig, _) -> colon <+> pretty sig +instance (Eq vn, IsName vn, Annot f) => Pretty (ModExpBase f vn) where + pretty = prettyModExp (-1) + instance Pretty Liftedness where pretty Unlifted = "" pretty SizeLifted = "~" @@ -555,7 +570,7 @@ Nothing -> mempty Just (s, _) -> " " <> colon <+> pretty s <> " " -ppBinOp :: IsName v => QualName v -> Doc a +ppBinOp :: (IsName v) => QualName v -> Doc a ppBinOp bop = case leading of Backtick -> "`" <> pretty bop <> "`" 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 @@ -237,7 +237,7 @@ pretty (Int64Value v) = pretty $ show v ++ "i64" -- | Create an t'IntValue' from a type and an 'Integer'. -intValue :: Integral int => IntType -> int -> IntValue +intValue :: (Integral int) => IntType -> int -> IntValue intValue Int8 = Int8Value . fromIntegral intValue Int16 = Int16Value . fromIntegral intValue Int32 = Int32Value . fromIntegral @@ -251,7 +251,7 @@ intValueType Int64Value {} = Int64 -- | Convert an t'IntValue' to any 'Integral' type. -valueIntegral :: Integral int => IntValue -> int +valueIntegral :: (Integral int) => IntValue -> int valueIntegral (Int8Value v) = fromIntegral v valueIntegral (Int16Value v) = fromIntegral v valueIntegral (Int32Value v) = fromIntegral v @@ -313,7 +313,7 @@ | otherwise = pretty $ show v ++ "f64" -- | Create a t'FloatValue' from a type and a 'Rational'. -floatValue :: Real num => FloatType -> num -> FloatValue +floatValue :: (Real num) => FloatType -> num -> FloatValue floatValue Float16 = Float16Value . fromRational . toRational floatValue Float32 = Float32Value . fromRational . toRational floatValue Float64 = Float64Value . fromRational . toRational @@ -1688,21 +1688,21 @@ -- -- Warning: note that this is 0 for 'Unit', but a 'Unit' takes up a -- byte in the binary data format. -primByteSize :: Num a => PrimType -> a +primByteSize :: (Num a) => PrimType -> a primByteSize (IntType t) = intByteSize t primByteSize (FloatType t) = floatByteSize t primByteSize Bool = 1 primByteSize Unit = 0 -- | The size of a value of a given integer type in eight-bit bytes. -intByteSize :: Num a => IntType -> a +intByteSize :: (Num a) => IntType -> a intByteSize Int8 = 1 intByteSize Int16 = 2 intByteSize Int32 = 4 intByteSize Int64 = 8 -- | The size of a value of a given floating-point type in eight-bit bytes. -floatByteSize :: Num a => FloatType -> a +floatByteSize :: (Num a) => FloatType -> a floatByteSize Float16 = 2 floatByteSize Float32 = 4 floatByteSize Float64 = 8 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 @@ -182,7 +182,7 @@ -- occurrence of the dimension. traverseDims :: forall f fdim tdim als. - Applicative f => + (Applicative f) => (S.Set VName -> DimPos -> fdim -> f tdim) -> TypeBase fdim als -> f (TypeBase tdim als) @@ -380,7 +380,7 @@ matchDims onDims = matchDims' mempty where matchDims' :: - forall u'. Monoid u' => [VName] -> TypeBase d1 u' -> TypeBase d2 u' -> m (TypeBase d1 u') + forall u'. (Monoid u') => [VName] -> TypeBase d1 u' -> TypeBase d2 u' -> m (TypeBase d1 u') matchDims' bound t1 t2 = case (t1, t2) of (Array u1 shape1 et1, Array u2 shape2 et2) -> @@ -1176,7 +1176,7 @@ -- | Is the position of this thing builtin as per 'isBuiltin'? Things -- without location are considered not built-in. -isBuiltinLoc :: Located a => a -> Bool +isBuiltinLoc :: (Located a) => a -> Bool isBuiltinLoc x = case locOf x of NoLoc -> False diff --git a/src/Language/Futhark/Query.hs b/src/Language/Futhark/Query.hs --- a/src/Language/Futhark/Query.hs +++ b/src/Language/Futhark/Query.hs @@ -94,7 +94,7 @@ <> mconcat (map patternDefs params) AppExp (LetWith v _ _ _ _ _) _ -> identDefs v - AppExp (DoLoop _ merge _ form _ _) _ -> + AppExp (Loop _ merge _ form _ _) _ -> patternDefs merge <> case form of For i _ -> identDefs i @@ -198,7 +198,7 @@ data RawAtPos = RawAtName (QualName VName) Loc -contains :: Located a => a -> Pos -> Bool +contains :: (Located a) => a -> Pos -> Bool contains a pos = case locOf a of Loc start end -> pos >= start && pos <= end @@ -268,7 +268,7 @@ atPosInExp (AppExp (LetWith a b _ _ _ _) _) pos | a `contains` pos = Just $ RawAtName (qualName $ identName a) (locOf a) | b `contains` pos = Just $ RawAtName (qualName $ identName b) (locOf b) -atPosInExp (AppExp (DoLoop _ merge _ _ _ _) _) pos +atPosInExp (AppExp (Loop _ merge _ _ _ _) _) pos | merge `contains` pos = atPosInPat merge pos atPosInExp (Ascript _ te _) pos | te `contains` pos = atPosInTypeExp te pos 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 @@ -415,7 +415,7 @@ deriving instance Show (SizeExp Info VName) -deriving instance Show vn => Show (SizeExp NoInfo vn) +deriving instance (Show vn) => Show (SizeExp NoInfo vn) deriving instance Eq (SizeExp NoInfo VName) @@ -443,7 +443,7 @@ deriving instance Show (TypeExp Info VName) -deriving instance Show vn => Show (TypeExp NoInfo vn) +deriving instance (Show vn) => Show (TypeExp NoInfo vn) deriving instance Eq (TypeExp NoInfo VName) @@ -472,7 +472,7 @@ deriving instance Show (TypeArgExp Info VName) -deriving instance Show vn => Show (TypeArgExp NoInfo vn) +deriving instance (Show vn) => Show (TypeArgExp NoInfo vn) deriving instance Eq (TypeArgExp NoInfo VName) @@ -509,14 +509,14 @@ identSrcLoc :: SrcLoc } -deriving instance Show (Info t) => Show (IdentBase Info VName t) +deriving instance (Show (Info t)) => Show (IdentBase Info VName t) deriving instance (Show (Info t), Show vn) => Show (IdentBase NoInfo vn t) -instance Eq vn => Eq (IdentBase ty vn t) where +instance (Eq vn) => Eq (IdentBase ty vn t) where x == y = identName x == identName y -instance Ord vn => Ord (IdentBase ty vn t) where +instance (Ord vn) => Ord (IdentBase ty vn t) where compare = comparing identName instance Located (IdentBase ty vn t) where @@ -574,7 +574,7 @@ | UpToExclusive a deriving (Eq, Ord, Show) -instance Located a => Located (Inclusiveness a) where +instance (Located a) => Located (Inclusiveness a) where locOf (DownToExclusive x) = locOf x locOf (ToInclusive x) = locOf x locOf (UpToExclusive x) = locOf x @@ -600,7 +600,7 @@ deriving instance Show (DimIndexBase Info VName) -deriving instance Show vn => Show (DimIndexBase NoInfo vn) +deriving instance (Show vn) => Show (DimIndexBase NoInfo vn) deriving instance Eq (DimIndexBase NoInfo VName) @@ -693,7 +693,7 @@ (ExpBase f vn) SrcLoc | If (ExpBase f vn) (ExpBase f vn) (ExpBase f vn) SrcLoc - | DoLoop + | Loop [VName] -- Size parameters. (PatBase f vn ParamType) -- Merge variable pattern. (ExpBase f vn) -- Initial values of merge variables. @@ -719,7 +719,7 @@ deriving instance Show (AppExpBase Info VName) -deriving instance Show vn => Show (AppExpBase NoInfo vn) +deriving instance (Show vn) => Show (AppExpBase NoInfo vn) deriving instance Eq (AppExpBase NoInfo VName) @@ -738,7 +738,7 @@ locOf (LetFun _ _ _ loc) = locOf loc locOf (LetWith _ _ _ _ _ loc) = locOf loc locOf (Index _ _ loc) = locOf loc - locOf (DoLoop _ _ _ _ _ loc) = locOf loc + locOf (Loop _ _ _ _ _ loc) = locOf loc locOf (Match _ _ loc) = locOf loc -- | An annotation inserted by the type checker on constructs that are @@ -830,7 +830,7 @@ deriving instance Show (ExpBase Info VName) -deriving instance Show vn => Show (ExpBase NoInfo vn) +deriving instance (Show vn) => Show (ExpBase NoInfo vn) deriving instance Eq (ExpBase NoInfo VName) @@ -877,7 +877,7 @@ deriving instance Show (FieldBase Info VName) -deriving instance Show vn => Show (FieldBase NoInfo vn) +deriving instance (Show vn) => Show (FieldBase NoInfo vn) deriving instance Eq (FieldBase NoInfo VName) @@ -896,7 +896,7 @@ deriving instance Show (CaseBase Info VName) -deriving instance Show vn => Show (CaseBase NoInfo vn) +deriving instance (Show vn) => Show (CaseBase NoInfo vn) deriving instance Eq (CaseBase NoInfo VName) @@ -917,7 +917,7 @@ deriving instance Show (LoopFormBase Info VName) -deriving instance Show vn => Show (LoopFormBase NoInfo vn) +deriving instance (Show vn) => Show (LoopFormBase NoInfo vn) deriving instance Eq (LoopFormBase NoInfo VName) @@ -947,17 +947,17 @@ | PatConstr Name (f t) [PatBase f vn t] SrcLoc | PatAttr (AttrInfo vn) (PatBase f vn t) SrcLoc -deriving instance Show (Info t) => Show (PatBase Info VName t) +deriving instance (Show (Info t)) => Show (PatBase Info VName t) deriving instance (Show (NoInfo t), Show vn) => Show (PatBase NoInfo vn t) -deriving instance Eq (NoInfo t) => Eq (PatBase NoInfo VName t) +deriving instance (Eq (NoInfo t)) => Eq (PatBase NoInfo VName t) -deriving instance Eq (Info t) => Eq (PatBase Info VName t) +deriving instance (Eq (Info t)) => Eq (PatBase Info VName t) -deriving instance Ord (NoInfo t) => Ord (PatBase NoInfo VName t) +deriving instance (Ord (NoInfo t)) => Ord (PatBase NoInfo VName t) -deriving instance Ord (Info t) => Ord (PatBase Info VName t) +deriving instance (Ord (Info t)) => Ord (PatBase Info VName t) instance Located (PatBase f vn t) where locOf (TuplePat _ loc) = locOf loc @@ -970,10 +970,10 @@ locOf (PatConstr _ _ _ loc) = locOf loc locOf (PatAttr _ _ loc) = locOf loc -instance Traversable f => Functor (PatBase f vn) where +instance (Traversable f) => Functor (PatBase f vn) where fmap = fmapDefault -instance Traversable f => Foldable (PatBase f vn) where +instance (Traversable f) => Foldable (PatBase f vn) where foldMap = foldMapDefault instance (Traversable f) => Traversable (PatBase f vn) where diff --git a/src/Language/Futhark/Traversals.hs b/src/Language/Futhark/Traversals.hs --- a/src/Language/Futhark/Traversals.hs +++ b/src/Language/Futhark/Traversals.hs @@ -35,14 +35,14 @@ -- given child. data ASTMapper m = ASTMapper { mapOnExp :: ExpBase Info VName -> m (ExpBase Info VName), - mapOnName :: VName -> m VName, + mapOnName :: QualName VName -> m (QualName VName), mapOnStructType :: StructType -> m StructType, mapOnParamType :: ParamType -> m ParamType, mapOnResRetType :: ResRetType -> m ResRetType } -- | An 'ASTMapper' that just leaves its input unchanged. -identityMapper :: Monad m => ASTMapper m +identityMapper :: (Monad m) => ASTMapper m identityMapper = ASTMapper { mapOnExp = pure, @@ -58,10 +58,7 @@ -- object. Importantly, the 'astMap' action is not invoked for -- the object itself, and the mapping does not descend recursively -- into subexpressions. The mapping is done left-to-right. - astMap :: Monad m => ASTMapper m -> x -> m x - -instance ASTMappable (QualName VName) where - astMap tv = traverse (mapOnName tv) + astMap :: (Monad m) => ASTMapper m -> x -> m x instance ASTMappable (AppExpBase Info VName) where astMap tv (Range start next end loc) = @@ -85,13 +82,11 @@ _ -> Apply f' args' loc astMap tv (LetPat sizes pat e body loc) = - LetPat <$> astMap tv sizes <*> astMap tv pat <*> mapOnExp tv e <*> mapOnExp tv body <*> pure loc - astMap tv (LetFun name (fparams, params, ret, t, e) body loc) = - LetFun - <$> mapOnName tv name - <*> ( (,,,,) - <$> mapM (astMap tv) fparams - <*> mapM (astMap tv) params + LetPat sizes <$> astMap tv pat <*> mapOnExp tv e <*> mapOnExp tv body <*> pure loc + astMap tv (LetFun name (tparams, params, ret, t, e) body loc) = + LetFun name + <$> ( (tparams,,,,) + <$> mapM (astMap tv) params <*> traverse (astMap tv) ret <*> traverse (mapOnResRetType tv) t <*> mapOnExp tv e @@ -108,15 +103,14 @@ <*> pure loc astMap tv (BinOp (fname, fname_loc) t (x, xext) (y, yext) loc) = BinOp - <$> ((,) <$> astMap tv fname <*> pure fname_loc) + <$> ((,) <$> mapOnName tv fname <*> pure fname_loc) <*> traverse (mapOnStructType tv) t <*> ((,) <$> mapOnExp tv x <*> pure xext) <*> ((,) <$> mapOnExp tv y <*> pure yext) <*> pure loc - astMap tv (DoLoop sparams mergepat mergeexp form loopbody loc) = - DoLoop - <$> mapM (mapOnName tv) sparams - <*> astMap tv mergepat + astMap tv (Loop sparams mergepat mergeexp form loopbody loc) = + Loop sparams + <$> astMap tv mergepat <*> mapOnExp tv mergeexp <*> astMap tv form <*> mapOnExp tv loopbody @@ -127,7 +121,7 @@ instance ASTMappable (ExpBase Info VName) where astMap tv (Var name t loc) = Var - <$> astMap tv name + <$> mapOnName tv name <*> traverse (mapOnStructType tv) t <*> pure loc astMap tv (Hole t loc) = @@ -144,7 +138,7 @@ Parens <$> mapOnExp tv e <*> pure loc astMap tv (QualParens (name, nameloc) e loc) = QualParens - <$> ((,) <$> astMap tv name <*> pure nameloc) + <$> ((,) <$> mapOnName tv name <*> pure nameloc) <*> mapOnExp tv e <*> pure loc astMap tv (TupLit els loc) = @@ -187,23 +181,23 @@ <*> pure loc astMap tv (OpSection name t loc) = OpSection - <$> astMap tv name + <$> mapOnName tv name <*> traverse (mapOnStructType tv) t <*> pure loc astMap tv (OpSectionLeft name t arg (Info (pa, t1a, argext), Info (pb, t1b)) (ret, retext) loc) = OpSectionLeft - <$> astMap tv name + <$> mapOnName tv name <*> traverse (mapOnStructType tv) t <*> mapOnExp tv arg <*> ( (,) <$> (Info <$> ((pa,,) <$> mapOnParamType tv t1a <*> pure argext)) <*> (Info <$> ((pb,) <$> mapOnParamType tv t1b)) ) - <*> ((,) <$> traverse (mapOnResRetType tv) ret <*> traverse (mapM (mapOnName tv)) retext) + <*> ((,) <$> traverse (mapOnResRetType tv) ret <*> pure retext) <*> pure loc astMap tv (OpSectionRight name t arg (Info (pa, t1a), Info (pb, t1b, argext)) t2 loc) = OpSectionRight - <$> astMap tv name + <$> mapOnName tv name <*> traverse (mapOnStructType tv) t <*> mapOnExp tv arg <*> ( (,) @@ -233,7 +227,7 @@ instance ASTMappable (TypeExp Info VName) where astMap tv (TEVar qn loc) = - TEVar <$> astMap tv qn <*> pure loc + TEVar <$> mapOnName tv qn <*> pure loc astMap tv (TEParens te loc) = TEParens <$> astMap tv te <*> pure loc astMap tv (TETuple ts loc) = @@ -261,9 +255,6 @@ astMap tv (SizeExp e loc) = SizeExp <$> mapOnExp tv e <*> pure loc astMap _ (SizeExpAny loc) = pure $ SizeExpAny loc -instance ASTMappable (TypeParamBase VName) where - astMap = traverse . mapOnName - instance ASTMappable (DimIndexBase Info VName) where astMap tv (DimFix j) = DimFix <$> mapOnExp tv j astMap tv (DimSlice i j stride) = @@ -284,7 +275,7 @@ f (t dim2 als2) traverseScalarType :: - Applicative f => + (Applicative f) => TypeTraverser f ScalarTypeBase dim1 als1 dims als2 traverseScalarType _ _ _ (Prim t) = pure $ Prim t traverseScalarType f g h (Record fs) = Record <$> traverse (traverseType f g h) fs @@ -300,14 +291,14 @@ traverseScalarType f g h (Sum cs) = Sum <$> (traverse . traverse) (traverseType f g h) cs -traverseType :: Applicative f => TypeTraverser f TypeBase dim1 als1 dims als2 +traverseType :: (Applicative f) => TypeTraverser f TypeBase dim1 als1 dims als2 traverseType f g h (Array als shape et) = Array <$> h als <*> traverse g shape <*> traverseScalarType f g pure et traverseType f g h (Scalar t) = Scalar <$> traverseScalarType f g h t traverseTypeArg :: - Applicative f => + (Applicative f) => (QualName VName -> f (QualName VName)) -> (dim1 -> f dim2) -> TypeArg dim1 -> @@ -318,26 +309,22 @@ TypeArgType <$> traverseType f g pure t instance ASTMappable StructType where - astMap tv = traverseType (astMap tv) (mapOnExp tv) pure + astMap tv = traverseType (mapOnName tv) (mapOnExp tv) pure instance ASTMappable ParamType where - astMap tv = traverseType (astMap tv) (mapOnExp tv) pure + astMap tv = traverseType (mapOnName tv) (mapOnExp tv) pure instance ASTMappable (TypeBase Size Uniqueness) where - astMap tv = traverseType (astMap tv) (mapOnExp tv) pure + astMap tv = traverseType (mapOnName tv) (mapOnExp tv) pure instance ASTMappable ResRetType where astMap tv (RetType ext t) = RetType ext <$> astMap tv t instance ASTMappable (IdentBase Info VName StructType) where astMap tv (Ident name (Info t) loc) = - Ident <$> mapOnName tv name <*> (Info <$> mapOnStructType tv t) <*> pure loc - -instance ASTMappable (SizeBinder VName) where - astMap tv (SizeBinder name loc) = - SizeBinder <$> mapOnName tv name <*> pure loc + Ident name <$> (Info <$> mapOnStructType tv t) <*> pure loc -traversePat :: Monad m => (t1 -> m t2) -> PatBase Info VName t1 -> m (PatBase Info VName t2) +traversePat :: (Monad m) => (t1 -> m t2) -> PatBase Info VName t1 -> m (PatBase Info VName t2) traversePat f (Id name (Info t) loc) = Id name <$> (Info <$> f t) <*> pure loc traversePat f (TuplePat pats loc) = @@ -368,7 +355,7 @@ RecordFieldExplicit name <$> mapOnExp tv e <*> pure loc astMap tv (RecordFieldImplicit name t loc) = RecordFieldImplicit - <$> mapOnName tv name + <$> (qualLeaf <$> mapOnName tv (QualName [] name)) <*> traverse (mapOnStructType tv) t <*> pure loc @@ -376,13 +363,13 @@ astMap tv (CasePat pat e loc) = CasePat <$> astMap tv pat <*> mapOnExp tv e <*> pure loc -instance ASTMappable a => ASTMappable (Info a) where +instance (ASTMappable a) => ASTMappable (Info a) where astMap tv = traverse $ astMap tv -instance ASTMappable a => ASTMappable [a] where +instance (ASTMappable a) => ASTMappable [a] where astMap tv = traverse $ astMap tv -instance ASTMappable a => ASTMappable (NE.NonEmpty a) where +instance (ASTMappable a) => ASTMappable (NE.NonEmpty a) where astMap tv = traverse $ astMap tv instance (ASTMappable a, ASTMappable b) => ASTMappable (a, b) where @@ -494,8 +481,8 @@ case appexp of Match e cases loc -> Match (bareExp e) (fmap bareCase cases) loc - DoLoop _ mergepat mergeexp form loopbody loc -> - DoLoop + Loop _ mergepat mergeexp form loopbody loc -> + Loop [] (barePat mergepat) (bareExp mergeexp) diff --git a/src/Language/Futhark/TypeChecker.hs b/src/Language/Futhark/TypeChecker.hs --- a/src/Language/Futhark/TypeChecker.hs +++ b/src/Language/Futhark/TypeChecker.hs @@ -148,7 +148,7 @@ pure (FileModule abs env (Prog doc decs') full_env) dupDefinitionError :: - MonadTypeChecker m => + (MonadTypeChecker m) => Namespace -> Name -> SrcLoc -> @@ -158,9 +158,11 @@ typeError loc1 mempty $ "Duplicate definition of" <+> pretty space - <+> prettyName name <> "." + <+> prettyName name + <> "." "Previously defined at" - <+> pretty (locStr loc2) <> "." + <+> pretty (locStr loc2) + <> "." checkForDuplicateDecs :: [DecBase NoInfo Name] -> TypeM () checkForDuplicateDecs = @@ -228,7 +230,8 @@ typeError loc mempty $ "All function parameters must have non-anonymous sizes." "Hint: add size parameters to" - <+> dquotes (prettyName name') <> "." + <+> dquotes (prettyName name') + <> "." pure (tparams', vtype', vtype_t) @@ -588,7 +591,8 @@ typeError loc mempty $ "Non-lifted type abbreviations may not use existential sizes in their definition." "Hint: use 'type~' or add size parameters to" - <+> dquotes (prettyName name) <> "." + <+> dquotes (prettyName name) + <> "." _ -> pure () bindSpaced [(Type, name)] $ do @@ -710,12 +714,12 @@ vb ) -nastyType :: Monoid als => TypeBase dim als -> Bool +nastyType :: (Monoid als) => TypeBase dim als -> Bool nastyType (Scalar Prim {}) = False nastyType t@Array {} = nastyType $ stripArray 1 t nastyType _ = True -nastyReturnType :: Monoid als => Maybe (TypeExp Info VName) -> TypeBase dim als -> Bool +nastyReturnType :: (Monoid als) => Maybe (TypeExp Info VName) -> TypeBase dim als -> Bool nastyReturnType Nothing (Scalar (Arrow _ _ _ t1 (RetType _ t2))) = nastyType t1 || nastyReturnType Nothing t2 nastyReturnType (Just (TEArrow _ te1 te2 _)) (Scalar (Arrow _ _ _ t1 (RetType _ t2))) = 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 @@ -156,7 +156,7 @@ where f = Nonconsumable . entryAliases -addError :: Located loc => loc -> Notes -> Doc () -> CheckM () +addError :: (Located loc) => loc -> Notes -> Doc () -> CheckM () addError loc notes e = modify $ \s -> s {stateErrors = DL.snoc (stateErrors s) (TypeError (locOf loc) notes e)} @@ -410,7 +410,7 @@ delve (Scalar (Record fs)) = foldl' (M.unionWith (+)) mempty $ map delve $ M.elems fs delve t = - M.fromList $ zip (map aliasVar $ S.toList (aliases t)) $ repeat (1 :: Int) + M.fromList $ map ((,1 :: Int) . aliasVar) $ S.toList $ aliases t consumingParams :: [Pat ParamType] -> Names consumingParams = @@ -454,7 +454,7 @@ | otherwise = t `setUniqueness` Nonunique -checkSubExps :: ASTMappable e => e -> CheckM e +checkSubExps :: (ASTMappable e) => e -> CheckM e checkSubExps = astMap identityMapper {mapOnExp = fmap fst . checkExp} noAliases :: Exp -> CheckM (Exp, TypeAliases) @@ -481,8 +481,8 @@ consumeAsNeeded loc pt t = when (diet pt == Consume) $ consumeAliases loc $ aliases t -checkArg :: ParamType -> Exp -> CheckM (Exp, TypeAliases) -checkArg p_t e = do +checkArg :: [(Exp, TypeAliases)] -> ParamType -> Exp -> CheckM (Exp, TypeAliases) +checkArg prev p_t e = do ((e', e_als), e_cons) <- contain $ checkExp e consumed e_cons let e_t = typeOf e' @@ -494,7 +494,21 @@ when (diet p_t == Consume) $ do noSelfAliases (locOf e) e_als consumeAsNeeded (locOf e) p_t e_als + case mapMaybe prevAlias $ S.toList $ boundAliases $ aliases e_als of + [] -> pure () + (v, prev_arg) : _ -> + addError (locOf e) mempty $ + "Argument is consumed, but aliases" + indent 2 (prettyName v) + "which is also aliased by other argument" + indent 2 (pretty prev_arg) + "at" + <+> pretty (locTextRel (locOf e) (locOf prev_arg)) + <> "." pure (e', e_als) + where + prevAlias v = + (v,) . fst <$> find (S.member v . boundAliases . aliases . snd) prev -- | @returnType appres ret_type arg_diet arg_type@ gives result of applying -- an argument the given types to a function with the given return @@ -643,7 +657,7 @@ param' <- convergeLoopParam loop_loc param (M.keysSet body_cons) body_als let param_t = patternType param' - ((arg', arg_als), arg_cons) <- contain $ checkArg param_t arg + ((arg', arg_als), arg_cons) <- contain $ checkArg [] param_t arg consumed arg_cons free_bound <- boundFreeInExp body @@ -652,7 +666,8 @@ v' <- describeVar v addError loop_loc mempty $ "Loop body uses" - <+> v' <> " (or an alias)," + <+> v' + <> " (or an alias)," "but this is consumed by the initial loop argument." v <- VName "internal_loop_result" <$> incCounter @@ -667,24 +682,23 @@ ) checkFuncall :: - Foldable f => + (Foldable f) => SrcLoc -> Maybe (QualName VName) -> TypeAliases -> f TypeAliases -> CheckM TypeAliases -checkFuncall loc fname f_als args_als = do +checkFuncall loc fname f_als arg_als = do v <- VName "internal_app_result" <$> incCounter modify $ \s -> s {stateNames = M.insert v (NameAppRes fname loc) $ stateNames s} - pure $ foldl applyArg (second (S.insert (AliasFree v)) f_als) args_als + pure $ foldl applyArg (second (S.insert (AliasFree v)) f_als) arg_als checkExp :: Exp -> CheckM (Exp, TypeAliases) -- First we have the complicated cases. -- checkExp (AppExp (Apply f args loc) appres) = do - -- Note Futhark uses right-to-left evaluation of applications. - (args', args_als) <- NE.unzip . NE.reverse <$> traverse checkArg' (NE.reverse args) + (args', args_als) <- NE.unzip <$> checkArgs args (f', f_als) <- checkExp f res_als <- checkFuncall loc (fname f) f_als args_als pure (AppExp (Apply f' args' loc) appres, res_als) @@ -692,15 +706,21 @@ fname (Var v _ _) = Just v fname (AppExp (Apply e _ _) _) = fname e fname _ = Nothing - checkArg' (Info (d, p), e) = do - (e', e_als) <- checkArg (second (const d) (typeOf e)) e + checkArg' prev (Info (d, p), e) = do + (e', e_als) <- checkArg prev (second (const d) (typeOf e)) e pure ((Info (d, p), e'), e_als) + checkArgs (x NE.:| args') = do + -- Note Futhark uses right-to-left evaluation of applications. + args'' <- maybe (pure []) (fmap NE.toList . checkArgs) $ NE.nonEmpty args' + (x', x_als) <- checkArg' (map (first snd) args'') x + pure $ (x', x_als) NE.:| args'' + -- -checkExp (AppExp (DoLoop sparams pat args form body loc) appres) = do +checkExp (AppExp (Loop sparams pat args form body loc) appres) = do ((pat', args', form', body'), als) <- checkLoop (locOf loc) (pat, args, form, body) pure - ( AppExp (DoLoop sparams pat' args' form' body' loc) appres, + ( AppExp (Loop sparams pat' args' form' body' loc) appres, als ) @@ -777,8 +797,8 @@ checkExp (AppExp (BinOp (op, oploc) opt (x, xp) (y, yp) loc) appres) = do op_als <- observeVar (locOf oploc) (qualLeaf op) (unInfo opt) let at1 : at2 : _ = fst $ unfoldFunType op_als - (x', x_als) <- checkArg at1 x - (y', y_als) <- checkArg at2 y + (x', x_als) <- checkArg [] at1 x + (y', y_als) <- checkArg [(x', x_als)] at2 y res_als <- checkFuncall loc (Just op) op_als [x_als, y_als] pure ( AppExp (BinOp (op, oploc) opt (x', xp) (y', yp) loc) appres, diff --git a/src/Language/Futhark/TypeChecker/Modules.hs b/src/Language/Futhark/TypeChecker/Modules.hs --- a/src/Language/Futhark/TypeChecker/Modules.hs +++ b/src/Language/Futhark/TypeChecker/Modules.hs @@ -280,7 +280,8 @@ "Module defines" indent 2 (ppTypeAbbr abs name mod_t) "but module type requires" - <+> what <> "." + <+> what + <> "." where what = case name_l of Unlifted -> "a non-lifted type" @@ -332,17 +333,17 @@ resolve' name _ = M.lookup (namespace, baseName name) $ envNameMap mod_env -missingType :: Pretty a => Loc -> a -> Either TypeError b +missingType :: (Pretty a) => Loc -> a -> Either TypeError b missingType loc name = Left . TypeError loc mempty $ "Module does not define a type named" <+> pretty name <> "." -missingVal :: Pretty a => Loc -> a -> Either TypeError b +missingVal :: (Pretty a) => Loc -> a -> Either TypeError b missingVal loc name = Left . TypeError loc mempty $ "Module does not define a value named" <+> pretty name <> "." -missingMod :: Pretty a => Loc -> a -> Either TypeError b +missingMod :: (Pretty a) => Loc -> a -> Either TypeError b missingMod loc name = Left . TypeError loc mempty $ "Module does not define a module named" <+> pretty name <> "." diff --git a/src/Language/Futhark/TypeChecker/Monad.hs b/src/Language/Futhark/TypeChecker/Monad.hs --- a/src/Language/Futhark/TypeChecker/Monad.hs +++ b/src/Language/Futhark/TypeChecker/Monad.hs @@ -52,6 +52,7 @@ import Control.Monad import Control.Monad.Except +import Control.Monad.Identity import Control.Monad.Reader import Control.Monad.State.Strict import Data.Either @@ -65,6 +66,7 @@ import Futhark.Util.Pretty hiding (space) import Language.Futhark import Language.Futhark.Semantic +import Language.Futhark.Traversals import Language.Futhark.Warnings import Paths_futhark qualified import Prelude hiding (mapM, mod) @@ -121,13 +123,13 @@ ] -- | An unexpected functor appeared! -unappliedFunctor :: MonadTypeChecker m => SrcLoc -> m a +unappliedFunctor :: (MonadTypeChecker m) => SrcLoc -> m a unappliedFunctor loc = typeError loc mempty "Cannot have parametric module here." -- | An unknown variable was referenced. unknownVariable :: - MonadTypeChecker m => + (MonadTypeChecker m) => Namespace -> QualName Name -> SrcLoc -> @@ -137,13 +139,13 @@ "Unknown" <+> pretty space <+> dquotes (pretty name) -- | An unknown type was referenced. -unknownType :: MonadTypeChecker m => SrcLoc -> QualName Name -> m a +unknownType :: (MonadTypeChecker m) => SrcLoc -> QualName Name -> m a unknownType loc name = typeError loc mempty $ "Unknown type" <+> pretty name <> "." -- | A name prefixed with an underscore was used. underscoreUse :: - MonadTypeChecker m => + (MonadTypeChecker m) => SrcLoc -> QualName Name -> m a @@ -273,8 +275,8 @@ -- | Monads that support type checking. The reason we have this -- internal interface is because we use distinct monads for checking -- expressions and declarations. -class Monad m => MonadTypeChecker m where - warn :: Located loc => loc -> Doc () -> m () +class (Monad m) => MonadTypeChecker m where + warn :: (Located loc) => loc -> Doc () -> m () warnings :: Warnings -> m () newName :: VName -> m VName @@ -292,16 +294,16 @@ checkExpForSize :: UncheckedExp -> m Exp - typeError :: Located loc => loc -> Notes -> Doc () -> m a + typeError :: (Located loc) => loc -> Notes -> Doc () -> m a -- | Elaborate the given name in the given namespace at the given -- location, producing the corresponding unique 'VName'. -checkName :: MonadTypeChecker m => Namespace -> Name -> SrcLoc -> m VName +checkName :: (MonadTypeChecker m) => Namespace -> Name -> SrcLoc -> m VName checkName space name loc = qualLeaf <$> checkQualName space (qualName name) loc -- | Map source-level names do fresh unique internal names, and -- evaluate a type checker context with the mapping active. -bindSpaced :: MonadTypeChecker m => [(Namespace, Name)] -> m a -> m a +bindSpaced :: (MonadTypeChecker m) => [(Namespace, Name)] -> m a -> m a bindSpaced names body = do names' <- mapM (newID . snd) names let mapping = M.fromList (zip names $ map qualName names') @@ -442,8 +444,9 @@ onTypeArg except (TypeArgType t) = TypeArgType $ onType except t - onDim except (Var qn typ loc) = Var (qual except qn) typ loc - onDim _ d = d + onDim except e = runIdentity $ onDimM except e + onDimM except (Var qn typ loc) = pure $ Var (qual except qn) typ loc + onDimM except e = astMap (identityMapper {mapOnExp = onDimM except}) e qual except (QualName orig_qs name) | name `elem` except || reachable orig_qs name outer_env = @@ -520,7 +523,7 @@ map (nameFromText . prettyText) [minBound .. (maxBound :: BinOp)] - fun_names = S.fromList $ map nameFromString ["shape"] + fun_names = S.fromList [nameFromString "shape"] available _ = False -- | Construct the name of a new type variable given a base @@ -534,7 +537,7 @@ subscript = flip lookup $ zip "0123456789" "₀₁₂₃₄₅₆₇₈₉" -- | Type-check an attribute. -checkAttr :: MonadTypeChecker m => AttrInfo Name -> m (AttrInfo VName) +checkAttr :: (MonadTypeChecker m) => AttrInfo Name -> m (AttrInfo VName) checkAttr (AttrComp f attrs loc) = AttrComp f <$> mapM checkAttr attrs <*> pure loc checkAttr (AttrAtom (AtomName v) loc) = diff --git a/src/Language/Futhark/TypeChecker/Terms.hs b/src/Language/Futhark/TypeChecker/Terms.hs --- a/src/Language/Futhark/TypeChecker/Terms.hs +++ b/src/Language/Futhark/TypeChecker/Terms.hs @@ -27,7 +27,7 @@ import Data.Map.Strict qualified as M import Data.Maybe import Data.Set qualified as S -import Futhark.Util (mapAccumLM, topologicalSort) +import Futhark.Util (mapAccumLM, nubOrd, topologicalSort) import Futhark.Util.Pretty hiding (space) import Language.Futhark import Language.Futhark.Primitive (intByteSize) @@ -35,7 +35,7 @@ import Language.Futhark.TypeChecker.Consumption qualified as Consumption import Language.Futhark.TypeChecker.Match import Language.Futhark.TypeChecker.Monad hiding (BoundV) -import Language.Futhark.TypeChecker.Terms.DoLoop +import Language.Futhark.TypeChecker.Terms.Loop import Language.Futhark.TypeChecker.Terms.Monad import Language.Futhark.TypeChecker.Terms.Pat import Language.Futhark.TypeChecker.Types @@ -46,7 +46,7 @@ hasBinding Lambda {} = True hasBinding (AppExp LetPat {} _) = True hasBinding (AppExp LetFun {} _) = True -hasBinding (AppExp DoLoop {} _) = True +hasBinding (AppExp Loop {} _) = True hasBinding (AppExp LetWith {} _) = True hasBinding (AppExp Match {} _) = True hasBinding e = isNothing $ astMap m e @@ -839,12 +839,12 @@ (t', retext) <- sliceShape Nothing slice' t let ft = Scalar $ Arrow mempty Unnamed Observe t $ RetType retext $ toRes Nonunique t' pure $ IndexSection slice' (Info ft) loc -checkExp (AppExp (DoLoop _ mergepat mergeexp form loopbody loc) _) = do +checkExp (AppExp (Loop _ mergepat mergeexp form loopbody loc) _) = do ((sparams, mergepat', mergeexp', form', loopbody'), appres) <- - checkDoLoop checkExp (mergepat, mergeexp, form, loopbody) loc + checkLoop checkExp (mergepat, mergeexp, form, loopbody) loc pure $ AppExp - (DoLoop sparams mergepat' mergeexp' form' loopbody' loc) + (Loop sparams mergepat' mergeexp' form' loopbody' loc) (Info appres) checkExp (Constr name es NoInfo loc) = do t <- newTypeVar loc "t" @@ -1060,13 +1060,16 @@ else "Cannot apply" <+> fname' - <+> "to argument #" <> pretty (prev_applied + 1) - <+> dquotes (shorten $ group $ pretty argexp) <> "," + <+> "to argument #" + <> pretty (prev_applied + 1) + <+> dquotes (shorten $ group $ pretty argexp) + <> "," "as" <+> fname' <+> "only takes" <+> pretty prev_applied - <+> arguments <> "." + <+> arguments + <> "." where arguments | prev_applied == 1 = "argument" @@ -1224,12 +1227,14 @@ "Causality check: size" <+> dquotes (prettyName d) <+> "needed for type of" - <+> what <> colon + <+> what + <> colon indent 2 (pretty t) "But" <+> dquotes (prettyName d) <+> "is computed at" - <+> pretty (locStrRel loc dloc) <> "." + <+> pretty (locStrRel loc dloc) + <> "." "" "Hint:" <+> align @@ -1381,7 +1386,8 @@ | otherwise = typeError usage mempty . withIndexLink "ambiguous-type" $ "Type is ambiguous (could be one of" - <+> commasep (map pretty ots) <> ")." + <+> commasep (map pretty ots) + <> ")." "Add a type annotation to disambiguate the type." fixOverloaded (v, NoConstraint _ usage) = do -- See #1552. @@ -1403,7 +1409,8 @@ fixOverloaded (_, HasConstrs _ cs usage) = typeError usage mempty . withIndexLink "ambiguous-type" $ "Type is ambiguous (must be a sum type with constructors:" - <+> pretty (Sum cs) <> ")." + <+> pretty (Sum cs) + <> ")." "Add a type annotation to disambiguate the type." fixOverloaded (v, Size Nothing (Usage Nothing loc)) = typeError loc mempty . withIndexLink "ambiguous-size" $ @@ -1480,6 +1487,18 @@ letGeneralise fname loc tparams' params'' =<< unscopeUnknown rettype + when + ( null params + && any isSizeParam tparams'' + && not (null (retDims rettype')) + ) + $ typeError loc mempty + $ textwrap "A size-polymorphic value binding may not have a type with an existential size." + "Type of this binding is:" + indent 2 (pretty rettype') + "with the following type parameters:" + indent 2 (sep $ map pretty $ filter isSizeParam tparams'') + pure (tparams'', params''', maybe_retdecl'', rettype', body') -- | Extract all the shape names that occur in positive position @@ -1515,13 +1534,13 @@ <+> dquotes (pretty p) "refers to size" <+> dquotes (prettyName d) - <> comma + <> comma textwrap "which will not be accessible to the caller" - <> comma + <> comma textwrap "possibly because it is nested in a tuple or record." textwrap "Consider ascribing an explicit type that does not reference " - <> dquotes (prettyName d) - <> "." + <> dquotes (prettyName d) + <> "." | otherwise = verifyParams forbidden' ps where forbidden' = @@ -1553,7 +1572,7 @@ deeper (Scalar (Record fs)) = Scalar $ Record $ M.map deeper fs deeper (Scalar (Sum cs)) = Scalar $ Sum $ M.map (map deeper) cs deeper (Scalar (Arrow als p d1 t1 (RetType t2_ext t2))) = - Scalar $ Arrow als p d1 t1 $ injectExt (ext_there <> t2_ext) t2 + Scalar $ Arrow als p d1 t1 $ injectExt (nubOrd (ext_there <> t2_ext)) t2 deeper (Scalar (TypeVar u tn targs)) = Scalar $ TypeVar u tn $ map deeperArg targs deeper t@Array {} = t @@ -1584,7 +1603,7 @@ _ -> Nothing pure ( tparams ++ more_tparams, - injectExt (retext ++ mapMaybe mkExt (S.toList $ fvVars $ freeInType ret)) ret + injectExt (nubOrd $ retext ++ mapMaybe mkExt (S.toList $ fvVars $ freeInType ret)) ret ) where -- Diet does not matter here. @@ -1613,7 +1632,7 @@ <+> dquotes (prettyName k) <+> "in parameter of" <+> dquotes (prettyName defname) - <> ", which is inferred as:" + <> ", which is inferred as:" indent 2 (pretty t) | k `S.member` produced_sizes = pure $ Just $ Right k @@ -1627,7 +1646,7 @@ [Pat ParamType] -> ResType -> TermTypeM ([TypeParam], [Pat ParamType], ResRetType) -letGeneralise defname defloc tparams params rettype = +letGeneralise defname defloc tparams params restype = onFailure (CheckingLetGeneralise defname) $ do now_substs <- getConstraints @@ -1651,19 +1670,19 @@ let candidate k (lvl, _) = (k `S.notMember` keep_type_vars) && lvl >= cur_lvl new_substs = M.filterWithKey candidate now_substs - (tparams', RetType ret_dims rettype') <- + (tparams', RetType ret_dims restype') <- closeOverTypes defname defloc tparams (map patternStructType params) - rettype + restype new_substs - rettype'' <- updateTypes rettype' + restype'' <- updateTypes restype' let used_sizes = - freeInType rettype'' <> foldMap (freeInType . patternType) params + freeInType restype'' <> foldMap (freeInType . patternType) params case filter ((`S.notMember` fvVars used_sizes) . typeParamName) $ filter isSizeParam tparams' of [] -> pure () @@ -1673,7 +1692,7 @@ -- let-generalisation. modifyConstraints $ M.filterWithKey $ \k _ -> k `notElem` map typeParamName tparams' - pure (tparams', params, RetType ret_dims rettype'') + pure (tparams', params, RetType ret_dims restype'') checkFunBody :: [Pat ParamType] -> diff --git a/src/Language/Futhark/TypeChecker/Terms/DoLoop.hs b/src/Language/Futhark/TypeChecker/Terms/DoLoop.hs deleted file mode 100644 --- a/src/Language/Futhark/TypeChecker/Terms/DoLoop.hs +++ /dev/null @@ -1,288 +0,0 @@ --- | Type inference of @loop@. This is complicated because of the --- uniqueness and size inference, so the implementation is separate --- from the main type checker. -module Language.Futhark.TypeChecker.Terms.DoLoop - ( UncheckedLoop, - CheckedLoop, - checkDoLoop, - ) -where - -import Control.Monad -import Control.Monad.Reader -import Control.Monad.State -import Data.Bifunctor -import Data.Bitraversable -import Data.List qualified as L -import Data.Map.Strict qualified as M -import Data.Maybe -import Data.Set qualified as S -import Futhark.Util (nubOrd) -import Futhark.Util.Pretty hiding (group, space) -import Language.Futhark -import Language.Futhark.TypeChecker.Monad hiding (BoundV) -import Language.Futhark.TypeChecker.Terms.Monad -import Language.Futhark.TypeChecker.Terms.Pat -import Language.Futhark.TypeChecker.Types -import Language.Futhark.TypeChecker.Unify -import Prelude hiding (mod) - --- | Retrieve an oracle that can be used to decide whether two are in --- the same equivalence class (i.e. have been unified). This is an --- exotic operation. -getAreSame :: MonadUnify m => m (VName -> VName -> Bool) -getAreSame = check <$> getConstraints - where - check constraints x y = - case (M.lookup x constraints, M.lookup y constraints) of - (Just (_, Size (Just (Var x' _ _)) _), _) -> - check constraints (qualLeaf x') y - (_, Just (_, Size (Just (Var y' _ _)) _)) -> - check constraints x (qualLeaf y') - _ -> - x == y - --- | Replace specified sizes with distinct fresh size variables. -someDimsFreshInType :: - SrcLoc -> - Name -> - [VName] -> - TypeBase Size als -> - TermTypeM (TypeBase Size als) -someDimsFreshInType loc desc fresh t = do - areSameSize <- getAreSame - let freshen v = any (areSameSize v) fresh - bitraverse (onDim freshen) pure t - where - onDim freshen (Var d _ _) - | freshen $ qualLeaf d = do - v <- newFlexibleDim (mkUsage' loc) desc - pure $ sizeFromName (qualName v) loc - onDim _ d = pure d - --- | Replace the specified sizes with fresh size variables of the --- specified ridigity. Returns the new fresh size variables. -freshDimsInType :: - Usage -> - Rigidity -> - Name -> - [VName] -> - TypeBase Size u -> - TermTypeM (TypeBase Size u, [VName]) -freshDimsInType usage r desc fresh t = do - areSameSize <- getAreSame - second (map snd) <$> runStateT (bitraverse (onDim areSameSize) pure t) mempty - where - onDim areSameSize (Var (QualName _ d) _ _) - | any (areSameSize d) fresh = do - prev_subst <- gets $ L.find (areSameSize d . fst) - case prev_subst of - Just (_, d') -> pure $ sizeFromName (qualName d') $ srclocOf usage - Nothing -> do - v <- lift $ newDimVar usage r desc - modify ((d, v) :) - pure $ sizeFromName (qualName v) $ srclocOf usage - onDim _ d = pure d - -data ArgSource = Initial | BodyResult - -wellTypedLoopArg :: ArgSource -> [VName] -> Pat ParamType -> Exp -> TermTypeM () -wellTypedLoopArg src sparams pat arg = do - (merge_t, _) <- - freshDimsInType (mkUsage arg desc) Nonrigid "loop" sparams $ - toStruct (patternType pat) - arg_t <- toStruct <$> expTypeFully arg - onFailure (checking merge_t arg_t) $ - unify (mkUsage arg desc) merge_t arg_t - where - (checking, desc) = - case src of - Initial -> (CheckingLoopInitial, "matching initial loop values to pattern") - BodyResult -> (CheckingLoopBody, "matching loop body to pattern") - --- | An un-checked loop. -type UncheckedLoop = - (UncheckedPat ParamType, UncheckedExp, LoopFormBase NoInfo Name, UncheckedExp) - --- | A loop that has been type-checked. -type CheckedLoop = - ([VName], Pat ParamType, Exp, LoopFormBase Info VName, Exp) - --- | Type-check a @loop@ expression, passing in a function for --- type-checking subexpressions. -checkDoLoop :: - (UncheckedExp -> TermTypeM Exp) -> - UncheckedLoop -> - SrcLoc -> - TermTypeM (CheckedLoop, AppRes) -checkDoLoop checkExp (mergepat, mergeexp, form, loopbody) loc = do - mergeexp' <- checkExp mergeexp - known_before <- M.keysSet <$> getConstraints - zeroOrderType - (mkUsage mergeexp "use as loop variable") - "type used as loop variable" - . toStruct - =<< expTypeFully mergeexp' - - -- The handling of dimension sizes is a bit intricate, but very - -- similar to checking a function, followed by checking a call to - -- it. The overall procedure is as follows: - -- - -- (1) All empty dimensions in the merge pattern are instantiated - -- with nonrigid size variables. All explicitly specified - -- dimensions are preserved. - -- - -- (2) The body of the loop is type-checked. The result type is - -- combined with the merge pattern type to determine which sizes are - -- variant, and these are turned into size parameters for the merge - -- pattern. - -- - -- (3) We now conceptually have a function parameter type and - -- return type. We check that it can be called with the body type - -- as argument. - -- - -- (4) Similarly to (3), we check that the "function" can be - -- called with the initial merge values as argument. The result - -- of this is the type of the loop as a whole. - - (merge_t, new_dims_map) <- - -- dim handling (1) - allDimsFreshInType (mkUsage loc "loop parameter type inference") Nonrigid "loop_d" - =<< expTypeFully mergeexp' - let new_dims_to_initial_dim = M.toList new_dims_map - new_dims = map fst new_dims_to_initial_dim - - -- dim handling (2) - let checkLoopReturnSize mergepat' loopbody' = do - loopbody_t <- expTypeFully loopbody' - pat_t <- - someDimsFreshInType loc "loop" new_dims - =<< normTypeFully (patternType mergepat') - - -- We are ignoring the dimensions here, because any mismatches - -- should be turned into fresh size variables. - onFailure (CheckingLoopBody (toStruct pat_t) (toStruct loopbody_t)) $ - unify - (mkUsage loopbody "matching loop body to loop pattern") - (toStruct pat_t) - (toStruct loopbody_t) - - -- Figure out which of the 'new_dims' dimensions are variant. - -- This works because we know that each dimension from - -- new_dims in the pattern is unique and distinct. - areSameSize <- getAreSame - let onDims _ x y - | x == y = pure x - onDims _ e d = do - forM_ (fvVars $ freeInExp e) $ \v -> do - case L.find (areSameSize v . fst) new_dims_to_initial_dim of - Just (_, e') -> - if e' == d - then modify $ first $ M.insert v $ ExpSubst e' - else - unless (v `S.member` known_before) $ - modify (second (v :)) - _ -> - pure () - pure e - loopbody_t' <- normTypeFully loopbody_t - merge_t' <- normTypeFully merge_t - - let (init_substs, sparams) = - execState (matchDims onDims merge_t' loopbody_t') mempty - - -- Make sure that any of new_dims that are invariant will be - -- replaced with the invariant size in the loop body. Failure - -- to do this can cause type annotations to still refer to - -- new_dims. - let dimToInit (v, ExpSubst e) = - constrain v $ Size (Just e) (mkUsage loc "size of loop parameter") - dimToInit _ = - pure () - mapM_ dimToInit $ M.toList init_substs - - mergepat'' <- applySubst (`M.lookup` init_substs) <$> updateTypes mergepat' - - -- Eliminate those new_dims that turned into sparams so it won't - -- look like we have ambiguous sizes lying around. - modifyConstraints $ M.filterWithKey $ \k _ -> k `notElem` sparams - - -- dim handling (3) - -- - -- The only trick here is that we have to turn any instances - -- of loop parameters in the type of loopbody' rigid, - -- because we are no longer in a position to change them, - -- really. - wellTypedLoopArg BodyResult sparams mergepat'' loopbody' - - pure (nubOrd sparams, mergepat'') - - (sparams, mergepat', form', loopbody') <- - case form of - For i uboundexp -> do - uboundexp' <- - require "being the bound in a 'for' loop" anySignedType - =<< checkExp uboundexp - bound_t <- expTypeFully uboundexp' - bindingIdent i bound_t $ \i' -> - bindingPat [] mergepat merge_t $ - \mergepat' -> incLevel $ do - loopbody' <- checkExp loopbody - (sparams, mergepat'') <- checkLoopReturnSize mergepat' loopbody' - pure - ( sparams, - mergepat'', - For i' uboundexp', - loopbody' - ) - ForIn xpat e -> do - (arr_t, _) <- newArrayType (mkUsage' (srclocOf e)) "e" 1 - e' <- unifies "being iterated in a 'for-in' loop" arr_t =<< checkExp e - t <- expTypeFully e' - case t of - _ - | Just t' <- peelArray 1 t -> - bindingPat [] xpat t' $ \xpat' -> - bindingPat [] mergepat merge_t $ - \mergepat' -> incLevel $ do - loopbody' <- checkExp loopbody - (sparams, mergepat'') <- checkLoopReturnSize mergepat' loopbody' - pure - ( sparams, - mergepat'', - ForIn (fmap toStruct xpat') e', - loopbody' - ) - | otherwise -> - typeError (srclocOf e) mempty $ - "Iteratee of a for-in loop must be an array, but expression has type" - <+> pretty t - While cond -> - bindingPat [] mergepat merge_t $ \mergepat' -> - incLevel $ do - cond' <- - checkExp cond - >>= unifies "being the condition of a 'while' loop" (Scalar $ Prim Bool) - loopbody' <- checkExp loopbody - (sparams, mergepat'') <- checkLoopReturnSize mergepat' loopbody' - pure - ( sparams, - mergepat'', - While cond', - loopbody' - ) - - -- dim handling (4) - wellTypedLoopArg Initial sparams mergepat' mergeexp' - - (loopt, retext) <- - freshDimsInType - (mkUsage loc "inference of loop result type") - (Rigid RigidLoop) - "loop" - sparams - (patternType mergepat') - pure - ( (sparams, mergepat', mergeexp', form', loopbody'), - AppRes (toStruct loopt) retext - ) diff --git a/src/Language/Futhark/TypeChecker/Terms/Loop.hs b/src/Language/Futhark/TypeChecker/Terms/Loop.hs new file mode 100644 --- /dev/null +++ b/src/Language/Futhark/TypeChecker/Terms/Loop.hs @@ -0,0 +1,288 @@ +-- | Type inference of @loop@. This is complicated because of the +-- uniqueness and size inference, so the implementation is separate +-- from the main type checker. +module Language.Futhark.TypeChecker.Terms.Loop + ( UncheckedLoop, + CheckedLoop, + checkLoop, + ) +where + +import Control.Monad +import Control.Monad.Reader +import Control.Monad.State +import Data.Bifunctor +import Data.Bitraversable +import Data.List qualified as L +import Data.Map.Strict qualified as M +import Data.Maybe +import Data.Set qualified as S +import Futhark.Util (nubOrd) +import Futhark.Util.Pretty hiding (group, space) +import Language.Futhark +import Language.Futhark.TypeChecker.Monad hiding (BoundV) +import Language.Futhark.TypeChecker.Terms.Monad +import Language.Futhark.TypeChecker.Terms.Pat +import Language.Futhark.TypeChecker.Types +import Language.Futhark.TypeChecker.Unify +import Prelude hiding (mod) + +-- | Retrieve an oracle that can be used to decide whether two are in +-- the same equivalence class (i.e. have been unified). This is an +-- exotic operation. +getAreSame :: (MonadUnify m) => m (VName -> VName -> Bool) +getAreSame = check <$> getConstraints + where + check constraints x y = + case (M.lookup x constraints, M.lookup y constraints) of + (Just (_, Size (Just (Var x' _ _)) _), _) -> + check constraints (qualLeaf x') y + (_, Just (_, Size (Just (Var y' _ _)) _)) -> + check constraints x (qualLeaf y') + _ -> + x == y + +-- | Replace specified sizes with distinct fresh size variables. +someDimsFreshInType :: + SrcLoc -> + Name -> + [VName] -> + TypeBase Size als -> + TermTypeM (TypeBase Size als) +someDimsFreshInType loc desc fresh t = do + areSameSize <- getAreSame + let freshen v = any (areSameSize v) fresh + bitraverse (onDim freshen) pure t + where + onDim freshen (Var d _ _) + | freshen $ qualLeaf d = do + v <- newFlexibleDim (mkUsage' loc) desc + pure $ sizeFromName (qualName v) loc + onDim _ d = pure d + +-- | Replace the specified sizes with fresh size variables of the +-- specified ridigity. Returns the new fresh size variables. +freshDimsInType :: + Usage -> + Rigidity -> + Name -> + [VName] -> + TypeBase Size u -> + TermTypeM (TypeBase Size u, [VName]) +freshDimsInType usage r desc fresh t = do + areSameSize <- getAreSame + second (map snd) <$> runStateT (bitraverse (onDim areSameSize) pure t) mempty + where + onDim areSameSize (Var (QualName _ d) _ _) + | any (areSameSize d) fresh = do + prev_subst <- gets $ L.find (areSameSize d . fst) + case prev_subst of + Just (_, d') -> pure $ sizeFromName (qualName d') $ srclocOf usage + Nothing -> do + v <- lift $ newDimVar usage r desc + modify ((d, v) :) + pure $ sizeFromName (qualName v) $ srclocOf usage + onDim _ d = pure d + +data ArgSource = Initial | BodyResult + +wellTypedLoopArg :: ArgSource -> [VName] -> Pat ParamType -> Exp -> TermTypeM () +wellTypedLoopArg src sparams pat arg = do + (merge_t, _) <- + freshDimsInType (mkUsage arg desc) Nonrigid "loop" sparams $ + toStruct (patternType pat) + arg_t <- toStruct <$> expTypeFully arg + onFailure (checking merge_t arg_t) $ + unify (mkUsage arg desc) merge_t arg_t + where + (checking, desc) = + case src of + Initial -> (CheckingLoopInitial, "matching initial loop values to pattern") + BodyResult -> (CheckingLoopBody, "matching loop body to pattern") + +-- | An un-checked loop. +type UncheckedLoop = + (UncheckedPat ParamType, UncheckedExp, LoopFormBase NoInfo Name, UncheckedExp) + +-- | A loop that has been type-checked. +type CheckedLoop = + ([VName], Pat ParamType, Exp, LoopFormBase Info VName, Exp) + +-- | Type-check a @loop@ expression, passing in a function for +-- type-checking subexpressions. +checkLoop :: + (UncheckedExp -> TermTypeM Exp) -> + UncheckedLoop -> + SrcLoc -> + TermTypeM (CheckedLoop, AppRes) +checkLoop checkExp (mergepat, mergeexp, form, loopbody) loc = do + mergeexp' <- checkExp mergeexp + known_before <- M.keysSet <$> getConstraints + zeroOrderType + (mkUsage mergeexp "use as loop variable") + "type used as loop variable" + . toStruct + =<< expTypeFully mergeexp' + + -- The handling of dimension sizes is a bit intricate, but very + -- similar to checking a function, followed by checking a call to + -- it. The overall procedure is as follows: + -- + -- (1) All empty dimensions in the merge pattern are instantiated + -- with nonrigid size variables. All explicitly specified + -- dimensions are preserved. + -- + -- (2) The body of the loop is type-checked. The result type is + -- combined with the merge pattern type to determine which sizes are + -- variant, and these are turned into size parameters for the merge + -- pattern. + -- + -- (3) We now conceptually have a function parameter type and + -- return type. We check that it can be called with the body type + -- as argument. + -- + -- (4) Similarly to (3), we check that the "function" can be + -- called with the initial merge values as argument. The result + -- of this is the type of the loop as a whole. + + (merge_t, new_dims_map) <- + -- dim handling (1) + allDimsFreshInType (mkUsage loc "loop parameter type inference") Nonrigid "loop_d" + =<< expTypeFully mergeexp' + let new_dims_to_initial_dim = M.toList new_dims_map + new_dims = map fst new_dims_to_initial_dim + + -- dim handling (2) + let checkLoopReturnSize mergepat' loopbody' = do + loopbody_t <- expTypeFully loopbody' + pat_t <- + someDimsFreshInType loc "loop" new_dims + =<< normTypeFully (patternType mergepat') + + -- We are ignoring the dimensions here, because any mismatches + -- should be turned into fresh size variables. + onFailure (CheckingLoopBody (toStruct pat_t) (toStruct loopbody_t)) $ + unify + (mkUsage loopbody "matching loop body to loop pattern") + (toStruct pat_t) + (toStruct loopbody_t) + + -- Figure out which of the 'new_dims' dimensions are variant. + -- This works because we know that each dimension from + -- new_dims in the pattern is unique and distinct. + areSameSize <- getAreSame + let onDims _ x y + | x == y = pure x + onDims _ e d = do + forM_ (fvVars $ freeInExp e) $ \v -> do + case L.find (areSameSize v . fst) new_dims_to_initial_dim of + Just (_, e') -> + if e' == d + then modify $ first $ M.insert v $ ExpSubst e' + else + unless (v `S.member` known_before) $ + modify (second (v :)) + _ -> + pure () + pure e + loopbody_t' <- normTypeFully loopbody_t + merge_t' <- normTypeFully merge_t + + let (init_substs, sparams) = + execState (matchDims onDims merge_t' loopbody_t') mempty + + -- Make sure that any of new_dims that are invariant will be + -- replaced with the invariant size in the loop body. Failure + -- to do this can cause type annotations to still refer to + -- new_dims. + let dimToInit (v, ExpSubst e) = + constrain v $ Size (Just e) (mkUsage loc "size of loop parameter") + dimToInit _ = + pure () + mapM_ dimToInit $ M.toList init_substs + + mergepat'' <- applySubst (`M.lookup` init_substs) <$> updateTypes mergepat' + + -- Eliminate those new_dims that turned into sparams so it won't + -- look like we have ambiguous sizes lying around. + modifyConstraints $ M.filterWithKey $ \k _ -> k `notElem` sparams + + -- dim handling (3) + -- + -- The only trick here is that we have to turn any instances + -- of loop parameters in the type of loopbody' rigid, + -- because we are no longer in a position to change them, + -- really. + wellTypedLoopArg BodyResult sparams mergepat'' loopbody' + + pure (nubOrd sparams, mergepat'') + + (sparams, mergepat', form', loopbody') <- + case form of + For i uboundexp -> do + uboundexp' <- + require "being the bound in a 'for' loop" anySignedType + =<< checkExp uboundexp + bound_t <- expTypeFully uboundexp' + bindingIdent i bound_t $ \i' -> + bindingPat [] mergepat merge_t $ + \mergepat' -> incLevel $ do + loopbody' <- checkExp loopbody + (sparams, mergepat'') <- checkLoopReturnSize mergepat' loopbody' + pure + ( sparams, + mergepat'', + For i' uboundexp', + loopbody' + ) + ForIn xpat e -> do + (arr_t, _) <- newArrayType (mkUsage' (srclocOf e)) "e" 1 + e' <- unifies "being iterated in a 'for-in' loop" arr_t =<< checkExp e + t <- expTypeFully e' + case t of + _ + | Just t' <- peelArray 1 t -> + bindingPat [] xpat t' $ \xpat' -> + bindingPat [] mergepat merge_t $ + \mergepat' -> incLevel $ do + loopbody' <- checkExp loopbody + (sparams, mergepat'') <- checkLoopReturnSize mergepat' loopbody' + pure + ( sparams, + mergepat'', + ForIn (fmap toStruct xpat') e', + loopbody' + ) + | otherwise -> + typeError (srclocOf e) mempty $ + "Iteratee of a for-in loop must be an array, but expression has type" + <+> pretty t + While cond -> + bindingPat [] mergepat merge_t $ \mergepat' -> + incLevel $ do + cond' <- + checkExp cond + >>= unifies "being the condition of a 'while' loop" (Scalar $ Prim Bool) + loopbody' <- checkExp loopbody + (sparams, mergepat'') <- checkLoopReturnSize mergepat' loopbody' + pure + ( sparams, + mergepat'', + While cond', + loopbody' + ) + + -- dim handling (4) + wellTypedLoopArg Initial sparams mergepat' mergeexp' + + (loopt, retext) <- + freshDimsInType + (mkUsage loc "inference of loop result type") + (Rigid RigidLoop) + "loop" + sparams + (patternType mergepat') + pure + ( (sparams, mergepat', mergeexp', form', loopbody'), + AppRes (toStruct loopt) retext + ) diff --git a/src/Language/Futhark/TypeChecker/Terms/Monad.hs b/src/Language/Futhark/TypeChecker/Terms/Monad.hs --- a/src/Language/Futhark/TypeChecker/Terms/Monad.hs +++ b/src/Language/Futhark/TypeChecker/Terms/Monad.hs @@ -157,7 +157,8 @@ <+> align (pretty actual) pretty (CheckingRecordUpdate fs expected actual) = "Type mismatch when updating record field" - <+> dquotes fs' <> "." + <+> dquotes fs' + <> "." "Existing:" <+> align (pretty expected) "New: " @@ -166,12 +167,14 @@ fs' = mconcat $ punctuate "." $ map pretty fs pretty (CheckingRequired [expected] actual) = "Expression must must have type" - <+> pretty expected <> "." + <+> pretty expected + <> "." "Actual type:" <+> align (pretty actual) pretty (CheckingRequired expected actual) = "Type of expression must must be one of " - <+> expected' <> "." + <+> expected' + <> "." "Actual type:" <+> align (pretty actual) where @@ -362,7 +365,7 @@ -- | Create a new type name and insert it (unconstrained) in the -- substitution map. instantiateTypeParam :: - Monoid as => + (Monoid as) => QualName VName -> SrcLoc -> TypeParam -> @@ -585,7 +588,7 @@ pure $ sizeFromName (qualName v) $ srclocOf usage -- | Replace all type variables with their concrete types. -updateTypes :: ASTMappable e => e -> TermTypeM e +updateTypes :: (ASTMappable e) => e -> TermTypeM e updateTypes = astMap tv where tv = diff --git a/src/Language/Futhark/TypeChecker/Terms/Pat.hs b/src/Language/Futhark/TypeChecker/Terms/Pat.hs --- a/src/Language/Futhark/TypeChecker/Terms/Pat.hs +++ b/src/Language/Futhark/TypeChecker/Terms/Pat.hs @@ -211,7 +211,9 @@ | Just (f, fp) <- find (("_" `isPrefixOf`) . nameToString . fst) p_fs = typeError fp mempty $ "Underscore-prefixed fields are not allowed." - "Did you mean" <> dquotes (pretty (drop 1 (nameToString f)) <> "=_") <> "?" + "Did you mean" + <> dquotes (pretty (drop 1 (nameToString f)) <> "=_") + <> "?" checkPat' sizes (RecordPat p_fs loc) (Ascribed (Scalar (Record t_fs))) | sort (map fst p_fs) == sort (M.keys t_fs) = RecordPat . M.toList <$> check <*> pure loc diff --git a/src/Language/Futhark/TypeChecker/Types.hs b/src/Language/Futhark/TypeChecker/Types.hs --- a/src/Language/Futhark/TypeChecker/Types.hs +++ b/src/Language/Futhark/TypeChecker/Types.hs @@ -61,7 +61,7 @@ mustBeExplicitInBinding :: StructType -> S.Set VName mustBeExplicitInBinding bind_t = let (ts, ret) = unfoldFunType bind_t - alsoRet = M.unionWith (&&) $ M.fromList $ zip (S.toList (fvVars (freeInType ret))) (repeat True) + alsoRet = M.unionWith (&&) $ M.fromList $ map (,True) (S.toList (fvVars (freeInType ret))) in S.fromList $ M.keys $ M.filter id $ alsoRet $ foldl' onType mempty $ map toStruct ts where onType uses t = uses <> mustBeExplicitAux t -- Left-biased union. @@ -74,7 +74,7 @@ -- | Ensure that the dimensions of the RetType are unique by -- generating new names for them. This is to avoid name capture. -renameRetType :: MonadTypeChecker m => ResRetType -> m ResRetType +renameRetType :: (MonadTypeChecker m) => ResRetType -> m ResRetType renameRetType (RetType dims st) | dims /= mempty = do dims' <- mapM newName dims @@ -86,7 +86,7 @@ pure $ RetType dims st evalTypeExp :: - MonadTypeChecker m => + (MonadTypeChecker m) => TypeExp NoInfo Name -> m (TypeExp Info VName, [VName], ResRetType, Liftedness) evalTypeExp (TEVar name loc) = do @@ -273,7 +273,7 @@ tloc = srclocOf ote rootAndArgs :: - MonadTypeChecker m => + (MonadTypeChecker m) => TypeExp NoInfo Name -> m (QualName Name, SrcLoc, [TypeArgExp NoInfo Name]) rootAndArgs (TEVar qn loc) = pure (qn, loc, []) @@ -323,7 +323,7 @@ -- * The elaborated type. -- * The liftedness of the type. checkTypeExp :: - MonadTypeChecker m => + (MonadTypeChecker m) => TypeExp NoInfo Name -> m (TypeExp Info VName, [VName], ResRetType, Liftedness) checkTypeExp te = do @@ -332,7 +332,7 @@ -- | Check for duplication of names inside a binding group. checkForDuplicateNames :: - MonadTypeChecker m => [UncheckedTypeParam] -> [UncheckedPat t] -> m () + (MonadTypeChecker m) => [UncheckedTypeParam] -> [UncheckedPat t] -> m () checkForDuplicateNames tps pats = (`evalStateT` mempty) $ do mapM_ checkTypeParam tps mapM_ checkPat pats @@ -369,7 +369,7 @@ -- since it is likely an error, but it's easy to assign a semantics to -- it (normal name shadowing). checkForDuplicateNamesInType :: - MonadTypeChecker m => + (MonadTypeChecker m) => TypeExp NoInfo Name -> m () checkForDuplicateNamesInType = check mempty @@ -413,7 +413,7 @@ -- invokes the continuation @m@ with the checked parameters, while -- extending the monadic name map with @ps@. checkTypeParams :: - MonadTypeChecker m => + (MonadTypeChecker m) => [TypeParamBase Name] -> ([TypeParamBase VName] -> m a) -> m a @@ -456,7 +456,7 @@ data Subst t = Subst [TypeParam] t | ExpSubst Exp deriving (Show) -instance Pretty t => Pretty (Subst t) where +instance (Pretty t) => Pretty (Subst t) where pretty (Subst [] t) = pretty t pretty (Subst tps t) = mconcat (map pretty tps) <> colon <+> pretty t pretty (ExpSubst e) = pretty e @@ -514,7 +514,7 @@ mapOnResRetType = pure . applySubst f } -instance Substitutable d => Substitutable (Shape d) where +instance (Substitutable d) => Substitutable (Shape d) where applySubst f = fmap $ applySubst f instance Substitutable (Pat StructType) where @@ -542,7 +542,7 @@ } applyType :: - Monoid als => + (Monoid als) => [TypeParam] -> TypeBase Size als -> [StructTypeArg] -> @@ -559,7 +559,7 @@ error $ "applyType mkSubst: cannot substitute " ++ prettyString a ++ " for " ++ prettyString p substTypesRet :: - Monoid as => + (Monoid as) => (VName -> Maybe (Subst (RetTypeBase Size as))) -> TypeBase Size as -> RetTypeBase Size as @@ -590,7 +590,7 @@ onType :: forall as. - Monoid as => + (Monoid as) => TypeBase Size as -> State [VName] (TypeBase Size as) @@ -637,7 +637,7 @@ -- | Perform substitutions, from type names to types, on a type. Works -- regardless of what shape and uniqueness information is attached to the type. substTypesAny :: - Monoid as => + (Monoid as) => (VName -> Maybe (Subst (RetTypeBase Size as))) -> TypeBase Size as -> TypeBase Size as diff --git a/src/Language/Futhark/TypeChecker/Unify.hs b/src/Language/Futhark/TypeChecker/Unify.hs --- a/src/Language/Futhark/TypeChecker/Unify.hs +++ b/src/Language/Futhark/TypeChecker/Unify.hs @@ -93,12 +93,12 @@ deriving (Show) -- | Construct a 'Usage' from a location and a description. -mkUsage :: Located a => a -> T.Text -> Usage +mkUsage :: (Located a) => a -> T.Text -> Usage mkUsage = flip (Usage . Just) . srclocOf -- | Construct a 'Usage' that has just a location, but no particular -- description. -mkUsage' :: Located a => a -> Usage +mkUsage' :: (Located a) => a -> Usage mkUsage' = Usage Nothing . srclocOf instance Pretty Usage where @@ -200,14 +200,17 @@ "passed to" <+> fname' <+> "at" - <+> pretty (locStrRel ctx loc) <> "." + <+> pretty (locStrRel ctx loc) + <> "." where fname' = maybe "function" (dquotes . pretty) fname prettySource ctx loc (RigidSlice d slice) = "is size produced by slice" indent 2 (shorten (pretty slice)) - d_desc <> "at" - <+> pretty (locStrRel ctx loc) <> "." + d_desc + <> "at" + <+> pretty (locStrRel ctx loc) + <> "." where d_desc = case d of Just d' -> "of dimension of size " <> dquotes (pretty d') <> " " @@ -219,7 +222,9 @@ prettySource ctx loc (RigidBound bound) = "generated from expression" indent 2 (shorten (pretty bound)) - "used in range at " <> pretty (locStrRel ctx loc) <> "." + "used in range at " + <> pretty (locStrRel ctx loc) + <> "." prettySource ctx loc (RigidOutOfScope boundloc v) = "is an unknown size arising from " <> dquotes (prettyName v) @@ -227,8 +232,8 @@ <> pretty (locStrRel ctx loc) <> "." "Originally bound at " - <> pretty (locStrRel ctx boundloc) - <> "." + <> pretty (locStrRel ctx boundloc) + <> "." prettySource ctx loc RigidCoerce = "is an unknown size arising from empty dimension in coercion at" <+> pretty (locStrRel ctx loc) <> "." @@ -239,9 +244,9 @@ <> pretty (locStrRel ctx loc) <> "." "One branch returns array of type: " - <> align (pretty t1) + <> align (pretty t1) "The other an array of type: " - <> align (pretty t2) + <> align (pretty t2) -- | Retrieve notes describing the purpose or origin of the given -- t'Size'. The location is used as the *current* location, for the @@ -264,7 +269,7 @@ . fvVars . freeInType -typeVarNotes :: MonadUnify m => VName -> m Notes +typeVarNotes :: (MonadUnify m) => VName -> m Notes typeVarNotes v = maybe mempty (note . snd) . M.lookup v <$> getConstraints where note (HasConstrs _ cs _) = @@ -287,7 +292,7 @@ -- | Monads that which to perform unification must implement this type -- class. -class Monad m => MonadUnify m where +class (Monad m) => MonadUnify m where getConstraints :: m Constraints putConstraints :: Constraints -> m () modifyConstraints :: (Constraints -> Constraints) -> m () @@ -295,9 +300,9 @@ x <- getConstraints putConstraints $ f x - newTypeVar :: Monoid als => SrcLoc -> Name -> m (TypeBase dim als) + newTypeVar :: (Monoid als) => SrcLoc -> Name -> m (TypeBase dim als) newDimVar :: Usage -> Rigidity -> Name -> m VName - newRigidDim :: Located a => a -> RigidSource -> Name -> m VName + newRigidDim :: (Located a) => a -> RigidSource -> Name -> m VName newRigidDim loc = newDimVar (mkUsage' loc) . Rigid newFlexibleDim :: Usage -> Name -> m VName newFlexibleDim usage = newDimVar usage Nonrigid @@ -305,7 +310,7 @@ curLevel :: m Level matchError :: - Located loc => + (Located loc) => loc -> Notes -> BreadCrumbs -> @@ -314,7 +319,7 @@ m a unifyError :: - Located loc => + (Located loc) => loc -> Notes -> BreadCrumbs -> @@ -328,7 +333,7 @@ pure $ applySubst (`lookupSubst` constraints) t -- | Replace any top-level type variable with its substitution. -normType :: MonadUnify m => StructType -> m StructType +normType :: (MonadUnify m) => StructType -> m StructType normType t@(Scalar (TypeVar _ (QualName [] v) [])) = do constraints <- getConstraints case snd <$> M.lookup v constraints of @@ -371,7 +376,7 @@ onDims bcs bound nonrigid t2 t1 unifyWith :: - MonadUnify m => + (MonadUnify m) => UnifySizes m -> Usage -> [VName] -> @@ -486,8 +491,8 @@ (Size Nothing $ Usage Nothing mempty) (UnknownSize mempty RigidUnify) lvl <- curLevel - modifyConstraints (M.fromList (zip b1_dims $ repeat (lvl, r1)) <>) - modifyConstraints (M.fromList (zip b2_dims $ repeat (lvl, r2)) <>) + modifyConstraints (M.fromList (map (,(lvl, r1)) b1_dims) <>) + modifyConstraints (M.fromList (map (,(lvl, r2)) b2_dims) <>) let bound' = bound <> mapMaybe pname [p1, p2] <> b1_dims <> b2_dims subunify @@ -542,7 +547,7 @@ anyBound :: [VName] -> ExpBase Info VName -> Bool anyBound bound e = any (`S.member` fvVars (freeInExp e)) bound -unifySizes :: MonadUnify m => Usage -> UnifySizes m +unifySizes :: (MonadUnify m) => Usage -> UnifySizes m unifySizes usage bcs bound nonrigid e1 e2 | Just es <- similarExps e1 e2 = mapM_ (uncurry $ unifySizes usage bcs bound nonrigid) es @@ -564,11 +569,11 @@ <+> "do not match." -- | Unifies two types. -unify :: MonadUnify m => Usage -> StructType -> StructType -> m () +unify :: (MonadUnify m) => Usage -> StructType -> StructType -> m () unify usage = unifyWith (unifySizes usage) usage mempty noBreadCrumbs occursCheck :: - MonadUnify m => + (MonadUnify m) => Usage -> BreadCrumbs -> VName -> @@ -583,7 +588,7 @@ <+> pretty tp <> "." scopeCheck :: - MonadUnify m => + (MonadUnify m) => Usage -> BreadCrumbs -> VName -> @@ -619,7 +624,7 @@ <+> "is rigidly bound in a deeper scope." linkVarToType :: - MonadUnify m => + (MonadUnify m) => UnifySizes m -> Usage -> [VName] -> @@ -693,7 +698,8 @@ <+> "must be one of" <+> commasep (map pretty ts) "due to" - <+> pretty old_usage <> "." + <+> pretty old_usage + <> "." Just (HasFields l required_fields old_usage) -> do when (l == Unlifted) $ arrayElemTypeWith usage (unliftedBcs old_usage) tp case tp of @@ -735,7 +741,8 @@ <+> "must be a record with fields" indent 2 (pretty (Record required_fields)) "due to" - <+> pretty old_usage <> "." + <+> pretty old_usage + <> "." -- See Note [Linking variables to sum types] Just (HasConstrs l required_cs old_usage) -> do when (l == Unlifted) $ arrayElemTypeWith usage (unliftedBcs old_usage) tp @@ -791,7 +798,7 @@ "Cannot unify a record type with a non-record type." linkVarToDim :: - MonadUnify m => + (MonadUnify m) => Usage -> BreadCrumbs -> VName -> @@ -833,7 +840,7 @@ checkVar _ _ = pure () -- | Assert that this type must be one of the given primitive types. -mustBeOneOf :: MonadUnify m => [PrimType] -> Usage -> StructType -> m () +mustBeOneOf :: (MonadUnify m) => [PrimType] -> Usage -> StructType -> m () mustBeOneOf [req_t] usage t = unify usage (Scalar (Prim req_t)) t mustBeOneOf ts usage t = do t' <- normType t @@ -852,7 +859,7 @@ <+> dquotes (pretty t) <+> "with any of " <> commasep (map pretty ts) <> "." -linkVarToTypes :: MonadUnify m => Usage -> VName -> [PrimType] -> m () +linkVarToTypes :: (MonadUnify m) => Usage -> VName -> [PrimType] -> m () linkVarToTypes usage vn ts = do vn_constraint <- M.lookup vn <$> getConstraints case vn_constraint of @@ -926,7 +933,7 @@ "Type" <+> prettyName vn <+> "does not support equality." zeroOrderTypeWith :: - MonadUnify m => + (MonadUnify m) => Usage -> BreadCrumbs -> StructType -> @@ -957,7 +964,7 @@ -- | Assert that this type must be zero-order. zeroOrderType :: - MonadUnify m => Usage -> T.Text -> StructType -> m () + (MonadUnify m) => Usage -> T.Text -> StructType -> m () zeroOrderType usage desc = zeroOrderTypeWith usage $ breadCrumb bc noBreadCrumbs where @@ -1003,7 +1010,7 @@ bc = Matching $ "When checking" <+> textwrap desc unifySharedFields :: - MonadUnify m => + (MonadUnify m) => UnifySizes m -> Usage -> [VName] -> @@ -1016,7 +1023,7 @@ unifyWith onDims usage bound (breadCrumb (MatchingFields [f]) bcs) t1 t2 unifySharedConstructors :: - MonadUnify m => + (MonadUnify m) => UnifySizes m -> Usage -> [VName] -> @@ -1039,7 +1046,7 @@ -- | In @mustHaveConstr usage c t fs@, the type @t@ must have a -- constructor named @c@ that takes arguments of types @ts@. mustHaveConstr :: - MonadUnify m => + (MonadUnify m) => Usage -> Name -> StructType -> @@ -1076,7 +1083,7 @@ unify usage t $ Scalar $ Sum $ M.singleton c fs mustHaveFieldWith :: - MonadUnify m => + (MonadUnify m) => UnifySizes m -> Usage -> [VName] -> @@ -1118,7 +1125,7 @@ -- | Assert that some type must have a field with this name and type. mustHaveField :: - MonadUnify m => + (MonadUnify m) => Usage -> Name -> StructType -> @@ -1126,7 +1133,7 @@ mustHaveField usage = mustHaveFieldWith (unifySizes usage) usage mempty noBreadCrumbs newDimOnMismatch :: - MonadUnify m => + (MonadUnify m) => SrcLoc -> StructType -> StructType -> @@ -1152,7 +1159,7 @@ -- | Like unification, but creates new size variables where mismatches -- occur. Returns the new dimensions thus created. unifyMostCommon :: - MonadUnify m => + (MonadUnify m) => Usage -> StructType -> StructType -> diff --git a/unittests/Futhark/IR/Mem/IxFun/Alg.hs b/unittests/Futhark/IR/Mem/IxFun/Alg.hs --- a/unittests/Futhark/IR/Mem/IxFun/Alg.hs +++ b/unittests/Futhark/IR/Mem/IxFun/Alg.hs @@ -9,7 +9,7 @@ coerce, slice, flatSlice, - rebase, + expand, shape, index, disjoint, @@ -47,10 +47,10 @@ | Reshape (IxFun num) (Shape num) | Coerce (IxFun num) (Shape num) | OffsetIndex (IxFun num) num - | Rebase (IxFun num) (IxFun num) + | Expand num num (IxFun num) deriving (Eq, Show) -instance Pretty num => Pretty (IxFun num) where +instance (Pretty num) => Pretty (IxFun num) where pretty (Direct dims) = "Direct" <> parens (commasep $ map pretty dims) pretty (Permute fun perm) = pretty fun <> pretty perm @@ -66,8 +66,8 @@ <> parens (pretty oldshape) pretty (OffsetIndex fun i) = pretty fun <> "->offset_index" <> parens (pretty i) - pretty (Rebase new_base fun) = - "rebase(" <> pretty new_base <> ", " <> pretty fun <> ")" + pretty (Expand o p fun) = + "expand(" <> pretty o <> "," <+> pretty p <> "," <+> pretty fun <> ")" iota :: Shape num -> IxFun num iota = Direct @@ -84,8 +84,8 @@ flatSlice :: IxFun num -> FlatSlice num -> IxFun num flatSlice = FlatIndex -rebase :: IxFun num -> IxFun num -> IxFun num -rebase = Rebase +expand :: num -> num -> IxFun num -> IxFun num +expand = Expand reshape :: IxFun num -> Shape num -> IxFun num reshape = Reshape @@ -94,7 +94,7 @@ coerce = Reshape shape :: - IntegralExp num => + (IntegralExp num) => IxFun num -> Shape num shape (Direct dims) = @@ -111,7 +111,7 @@ dims shape (OffsetIndex ixfun _) = shape ixfun -shape (Rebase _ ixfun) = +shape (Expand _ _ ixfun) = shape ixfun index :: @@ -147,27 +147,8 @@ 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 (Rebase new_base fun) is = - let fun' = case fun of - Direct old_shape -> - if old_shape == shape new_base - then new_base - else reshape new_base old_shape - Permute ixfun perm -> - permute (rebase new_base ixfun) perm - Index ixfun iis -> - slice (rebase new_base ixfun) iis - FlatIndex ixfun iis -> - flatSlice (rebase new_base ixfun) iis - Reshape ixfun new_shape -> - reshape (rebase new_base ixfun) new_shape - Coerce ixfun new_shape -> - coerce (rebase new_base ixfun) new_shape - OffsetIndex ixfun s -> - offsetIndex (rebase new_base ixfun) s - r@Rebase {} -> - r - in index fun' is +index (Expand o p ixfun) is = + o + p * index ixfun is allPoints :: (IntegralExp num, Enum num) => [num] -> [[num]] allPoints dims = diff --git a/unittests/Futhark/IR/Mem/IxFunTests.hs b/unittests/Futhark/IR/Mem/IxFunTests.hs --- a/unittests/Futhark/IR/Mem/IxFunTests.hs +++ b/unittests/Futhark/IR/Mem/IxFunTests.hs @@ -5,6 +5,7 @@ ) where +import Data.Bifunctor import Data.Function ((&)) import Data.List qualified as L import Data.Map qualified as M @@ -57,14 +58,22 @@ 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 + "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 $ @@ -81,8 +90,10 @@ compareOpsFailure (Just ixfunLMAD, ixfunAlg) = assertFailure . T.unpack . docText $ "Not supposed to be representable as LMAD." - "lmad ixfun: " <> pretty ixfunLMAD - "alg ixfun: " <> pretty ixfunAlg + "lmad ixfun: " + <> pretty ixfunLMAD + "alg ixfun: " + <> pretty ixfunAlg -- XXX: Clean this up. n :: Int @@ -111,12 +122,10 @@ test_reshape_slice_iota3, test_complex1, test_complex2, - test_rebase1, - test_rebase2, - test_rebase3, - test_rebase4_5, - test_rebase6, - test_rebase7, + test_expand1, + test_expand2, + test_expand3, + test_expand4, test_flatSlice_iota, test_slice_flatSlice_iota, test_flatSlice_flatSlice_iota, @@ -235,105 +244,44 @@ ixfun' = slice ixfun slice1 in ixfun' -test_rebase1 :: [TestTree] -test_rebase1 = - singleton . testCase "rebase 1" . compareOpsFailure $ - let slice_base = - Slice - [ DimFix (n `P.div` 2), - DimSlice 2 (n - 2) 1, - DimSlice 3 (n - 3) 1 - ] - ixfn_base = permute (slice (iota [n, n, n]) slice_base) [1, 0] - ixfn_orig = permute (iota [n - 3, n - 2]) [1, 0] - ixfn_rebase = rebase ixfn_base ixfn_orig - in ixfn_rebase - -test_rebase2 :: [TestTree] -test_rebase2 = - singleton . testCase "rebase 2" . compareOpsFailure $ - let slice_base = - Slice - [ DimFix (n `P.div` 2), - DimSlice (n - 1) (n - 2) (-1), - DimSlice (n - 1) (n - 3) (-1) - ] - slice_orig = - Slice - [ DimSlice (n - 4) (n - 3) (-1), - DimSlice (n - 3) (n - 2) (-1) - ] - ixfn_base = permute (slice (iota [n, n, n]) slice_base) [1, 0] - ixfn_orig = permute (slice (iota [n - 3, n - 2]) slice_orig) [1, 0] - ixfn_rebase = rebase ixfn_base ixfn_orig - in ixfn_rebase - -test_rebase3 :: [TestTree] -test_rebase3 = - singleton . testCase "rebase full orig but not monotonic" . compareOpsFailure $ - let n2 = (n - 2) `P.div` 3 - n3 = (n - 3) `P.div` 2 - slice_base = - Slice - [ DimFix (n `P.div` 2), - DimSlice (n - 1) n2 (-3), - DimSlice (n - 1) n3 (-2) - ] - slice_orig = - Slice - [ DimSlice (n3 - 1) n3 (-1), - DimSlice (n2 - 1) n2 (-1) - ] - ixfn_base = permute (slice (iota [n, n, n]) slice_base) [1, 0] - ixfn_orig = permute (slice (iota [n3, n2]) slice_orig) [1, 0] - ixfn_rebase = rebase ixfn_base ixfn_orig - in ixfn_rebase - -test_rebase4_5 :: [TestTree] -test_rebase4_5 = - let n2 = (n - 2) `P.div` 3 - n3 = (n - 3) `P.div` 2 - slice_base = - Slice - [ DimFix (n `P.div` 2), - DimSlice (n - 1) n2 (-3), - DimSlice 3 n3 2 - ] - slice_orig = - Slice - [ DimSlice (n3 - 1) n3 (-1), - DimSlice 0 n2 1 - ] - ixfn_base = permute (slice (iota [n, n, n]) slice_base) [1, 0] - ixfn_orig = permute (slice (iota [n3, n2]) slice_orig) [1, 0] - in [ testCase "rebase mixed monotonicities" . compareOpsFailure $ - rebase ixfn_base ixfn_orig - ] - -- Imitates a case from memory expansion. -test_rebase6 :: [TestTree] -test_rebase6 = - [ testCase "rebase . slice1 . iota" . compareOps $ - rebase - (slice (iota [n, n, n]) (Slice [DimSlice 0 n 1, DimSlice 0 n 1])) - ( slice - (iota [n, n]) - (Slice [DimSlice 1 (n - 1) 1, DimSlice 0 n 1]) - ) +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_rebase7 :: [TestTree] -test_rebase7 = - [ testCase "rebase . slice2 . iota" . compareOps $ - rebase - (slice (iota [n, n, n]) (Slice [DimSlice 0 n 1, DimSlice 0 n 1])) - ( slice - (iota [n, n]) - (Slice [DimSlice 0 (n - 1) 1, DimSlice 0 n 1]) - ) +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 $ @@ -365,7 +313,7 @@ test_flatSlice_transpose_slice_iota :: [TestTree] test_flatSlice_transpose_slice_iota = - singleton . testCase "flatSlice . transpose . slice . iota " . compareOpsFailure $ + 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] @@ -464,37 +412,37 @@ 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) 0, - IxFunLMAD.LMADDim 1 (block_size_12121 + 1) 1 + [ 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 0, - IxFunLMAD.LMADDim 1 (1 + 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 (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 0, - IxFunLMAD.LMADDim 1 block_size_12121 1 + [ 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) 0, - IxFunLMAD.LMADDim n_blab block_size_12121 1, - IxFunLMAD.LMADDim 1 block_size_12121 2 + [ 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) 0, - IxFunLMAD.LMADDim 1 (block_size_12121 + 1) 1 + [ 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 @@ -523,36 +471,40 @@ 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) 0, - IxFunLMAD.LMADDim n_blab block_size_12121 1 + [ 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) 0, - IxFunLMAD.LMADDim 1 (1 + block_size_12121) 1 + [ 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 0, - IxFunLMAD.LMADDim n_blab 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 0, - IxFunLMAD.LMADDim 1 (1 + 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 0, - IxFunLMAD.LMADDim 1 block_size_12121 1 + [ IxFunLMAD.LMADDim n_blab block_size_12121, + IxFunLMAD.LMADDim 1 block_size_12121 ] res1 = disjointTester asserts lessthans lm1 lm_w @@ -562,9 +514,11 @@ in res1 && res2 && res3 && res4 @? "Failed " <> show [res1, res2, res3, res4], testCase "lud long" $ let lessthans = - [ (step, num_blocks - 1 :: TPrimExp Int64 VName) + [ bimap + (head . namesToList . freeIn) + untyped + (step, num_blocks - 1 :: TPrimExp Int64 VName) ] - & map (\(v, p) -> (head $ namesToList $ freeIn v, untyped p)) step = TPrimExp $ LeafExp (foo "step" 1337) $ IntType Int64 @@ -573,29 +527,29 @@ lm1 = IxFunLMAD.LMAD (1024 * num_blocks * (1 + step) + 1024 * step) - [ IxFunLMAD.LMADDim (1024 * num_blocks) (num_blocks - step - 1) 0, - IxFunLMAD.LMADDim 32 32 1, - IxFunLMAD.LMADDim 1 32 2 + [ 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 0, - IxFunLMAD.LMADDim 1 32 1 + [ 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) 0, - IxFunLMAD.LMADDim 1024 (num_blocks - step - 1) 1, - IxFunLMAD.LMADDim 1024 1 2, - IxFunLMAD.LMADDim 32 1 3, - IxFunLMAD.LMADDim 128 8 4, - IxFunLMAD.LMADDim 4 8 5, - IxFunLMAD.LMADDim 32 4 6, - IxFunLMAD.LMADDim 1 4 7 + [ 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 = diff --git a/unittests/Futhark/IR/Mem/IxFunWrapper.hs b/unittests/Futhark/IR/Mem/IxFunWrapper.hs --- a/unittests/Futhark/IR/Mem/IxFunWrapper.hs +++ b/unittests/Futhark/IR/Mem/IxFunWrapper.hs @@ -8,7 +8,7 @@ coerce, slice, flatSlice, - rebase, + expand, ) where @@ -25,13 +25,13 @@ type IxFun num = (Maybe (I.IxFun num), IA.IxFun num) iota :: - IntegralExp num => + (IntegralExp num) => Shape num -> IxFun num iota x = (Just $ I.iota x, IA.iota x) permute :: - IntegralExp num => + (IntegralExp num) => IxFun num -> Permutation -> IxFun num @@ -63,11 +63,12 @@ IxFun num -> FlatSlice num -> IxFun num -flatSlice (l, a) x = (join (I.flatSlice <$> l <*> pure x), IA.flatSlice a x) +flatSlice (l, a) x = (I.flatSlice <$> l <*> pure x, IA.flatSlice a x) -rebase :: +expand :: (Eq num, IntegralExp num) => - IxFun num -> + num -> + num -> IxFun num -> IxFun num -rebase (l, a) (l1, a1) = (join (I.rebase <$> l <*> l1), IA.rebase a a1) +expand o p (lf, af) = (I.expand o p =<< lf, IA.expand o p af) diff --git a/unittests/Language/Futhark/SyntaxTests.hs b/unittests/Language/Futhark/SyntaxTests.hs --- a/unittests/Language/Futhark/SyntaxTests.hs +++ b/unittests/Language/Futhark/SyntaxTests.hs @@ -54,7 +54,7 @@ let (s', '_' : tag) = span (/= '_') s in VName (fromString s') (read tag) -instance IsString v => IsString (QualName v) where +instance (IsString v) => IsString (QualName v) where fromString = QualName [] . fromString instance IsString UncheckedTypeExp where